fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

2012-09-26 03:40 UTC+0200 Viktor Szakats (harbour syenar.net)

Browse Source 
* contrib/hbnf/aading.prg
  * contrib/hbnf/aavg.prg
  * contrib/hbnf/acctadj.prg
  * contrib/hbnf/acctmnth.prg
  * contrib/hbnf/acctqtr.prg
  * contrib/hbnf/acctweek.prg
  * contrib/hbnf/acctyear.prg
  * contrib/hbnf/adessort.prg
  * contrib/hbnf/aemaxlen.prg
  * contrib/hbnf/aeminlen.prg
  * contrib/hbnf/amedian.prg
  * contrib/hbnf/anomatch.prg
  * contrib/hbnf/any2any.prg
  * contrib/hbnf/aredit.prg
  * contrib/hbnf/asum.prg
  * contrib/hbnf/at2.prg
  * contrib/hbnf/bitclr.prg
  * contrib/hbnf/bitset.prg
  * contrib/hbnf/blink.prg
  * contrib/hbnf/byt2bit.prg
  * contrib/hbnf/byt2hex.prg
  * contrib/hbnf/byteand.prg
  * contrib/hbnf/byteneg.prg
  * contrib/hbnf/bytenot.prg
  * contrib/hbnf/byteor.prg
  * contrib/hbnf/bytexor.prg
  * contrib/hbnf/calendar.prg
  * contrib/hbnf/clrsel.prg
  * contrib/hbnf/cntryset.prg
  * contrib/hbnf/d2e.prg
  * contrib/hbnf/datecnfg.prg
  * contrib/hbnf/dayofyr.prg
  * contrib/hbnf/daytobow.prg
  * contrib/hbnf/dectobin.prg
  * contrib/hbnf/dfile.prg
  * contrib/hbnf/diskfunc.prg
  * contrib/hbnf/dispmsg.prg
  * contrib/hbnf/dosver.prg
  * contrib/hbnf/e2d.prg
  * contrib/hbnf/easter.prg
  * contrib/hbnf/elapmil.prg
  * contrib/hbnf/elapsed.prg
  * contrib/hbnf/eltime.prg
  * contrib/hbnf/findith.prg
  * contrib/hbnf/firstday.prg
  * contrib/hbnf/floptst.prg
  * contrib/hbnf/ftround.prg
  * contrib/hbnf/gcd.prg
  * contrib/hbnf/hex2dec.prg
  * contrib/hbnf/invclr.prg
  * contrib/hbnf/isbit.prg
  * contrib/hbnf/isbiton.prg
  * contrib/hbnf/isshare.prg
  * contrib/hbnf/lastday.prg
  * contrib/hbnf/linked.prg
  * contrib/hbnf/madd.prg
  * contrib/hbnf/menu1.prg
  * contrib/hbnf/menutonf.prg
  * contrib/hbnf/metaph.prg
  * contrib/hbnf/miltime.prg
  * contrib/hbnf/min2dhm.prg
  * contrib/hbnf/month.prg
  * contrib/hbnf/mouse1.prg
  * contrib/hbnf/mouse2.prg
  * contrib/hbnf/netpv.prg
  * contrib/hbnf/nooccur.prg
  * contrib/hbnf/ntow.prg
  * contrib/hbnf/nwlstat.prg
  * contrib/hbnf/nwsem.prg
  * contrib/hbnf/nwuid.prg
  * contrib/hbnf/ontick.prg
  * contrib/hbnf/page.prg
  * contrib/hbnf/pchr.prg
  * contrib/hbnf/pegs.prg
  * contrib/hbnf/pending.prg
  * contrib/hbnf/pickday.prg
  * contrib/hbnf/popadder.prg
  * contrib/hbnf/prtesc.prg
  * contrib/hbnf/pvid.prg
  * contrib/hbnf/qtr.prg
  * contrib/hbnf/rand1.prg
  * contrib/hbnf/restsets.prg
  * contrib/hbnf/savearr.prg
  * contrib/hbnf/savesets.prg
  * contrib/hbnf/scancode.prg
  * contrib/hbnf/scregion.prg
  * contrib/hbnf/setdate.prg
  * contrib/hbnf/settime.prg
  * contrib/hbnf/sinkey.prg
  * contrib/hbnf/sleep.prg
  * contrib/hbnf/sqzn.prg
  * contrib/hbnf/sysmem.prg
  * contrib/hbnf/tbwhile.prg
  * contrib/hbnf/tempfile.prg
  * contrib/hbnf/vertmenu.prg
  * contrib/hbnf/vidcur.prg
  * contrib/hbnf/vidmode.prg
  * contrib/hbnf/wda.prg
  * contrib/hbnf/week.prg
  * contrib/hbnf/workdays.prg
  * contrib/hbnf/woy.prg
  * contrib/hbnf/xbox.prg
  * contrib/hbnf/year.prg
    * formatted using hbformat and manually
    * code cleanups and standardizations
This commit is contained in:
Viktor Szakats
2012-09-26 01:46:40 +00:00
parent 952115af23
commit fa00a178e4
104 changed files with 6366 additions and 5845 deletions
Download Patch File Download Diff File Expand all files Collapse all files

107
harbour/ChangeLog
View File

@@ -16,6 +16,113 @@
The license applies to all entries newer than 2009-04-28.
*/
2012-09-26 03:40 UTC+0200 Viktor Szakats (harbour syenar.net)
* contrib/hbnf/aading.prg
* contrib/hbnf/aavg.prg
* contrib/hbnf/acctadj.prg
* contrib/hbnf/acctmnth.prg
* contrib/hbnf/acctqtr.prg
* contrib/hbnf/acctweek.prg
* contrib/hbnf/acctyear.prg
* contrib/hbnf/adessort.prg
* contrib/hbnf/aemaxlen.prg
* contrib/hbnf/aeminlen.prg
* contrib/hbnf/amedian.prg
* contrib/hbnf/anomatch.prg
* contrib/hbnf/any2any.prg
* contrib/hbnf/aredit.prg
* contrib/hbnf/asum.prg
* contrib/hbnf/at2.prg
* contrib/hbnf/bitclr.prg
* contrib/hbnf/bitset.prg
* contrib/hbnf/blink.prg
* contrib/hbnf/byt2bit.prg
* contrib/hbnf/byt2hex.prg
* contrib/hbnf/byteand.prg
* contrib/hbnf/byteneg.prg
* contrib/hbnf/bytenot.prg
* contrib/hbnf/byteor.prg
* contrib/hbnf/bytexor.prg
* contrib/hbnf/calendar.prg
* contrib/hbnf/clrsel.prg
* contrib/hbnf/cntryset.prg
* contrib/hbnf/d2e.prg
* contrib/hbnf/datecnfg.prg
* contrib/hbnf/dayofyr.prg
* contrib/hbnf/daytobow.prg
* contrib/hbnf/dectobin.prg
* contrib/hbnf/dfile.prg
* contrib/hbnf/diskfunc.prg
* contrib/hbnf/dispmsg.prg
* contrib/hbnf/dosver.prg
* contrib/hbnf/e2d.prg
* contrib/hbnf/easter.prg
* contrib/hbnf/elapmil.prg
* contrib/hbnf/elapsed.prg
* contrib/hbnf/eltime.prg
* contrib/hbnf/findith.prg
* contrib/hbnf/firstday.prg
* contrib/hbnf/floptst.prg
* contrib/hbnf/ftround.prg
* contrib/hbnf/gcd.prg
* contrib/hbnf/hex2dec.prg
* contrib/hbnf/invclr.prg
* contrib/hbnf/isbit.prg
* contrib/hbnf/isbiton.prg
* contrib/hbnf/isshare.prg
* contrib/hbnf/lastday.prg
* contrib/hbnf/linked.prg
* contrib/hbnf/madd.prg
* contrib/hbnf/menu1.prg
* contrib/hbnf/menutonf.prg
* contrib/hbnf/metaph.prg
* contrib/hbnf/miltime.prg
* contrib/hbnf/min2dhm.prg
* contrib/hbnf/month.prg
* contrib/hbnf/mouse1.prg
* contrib/hbnf/mouse2.prg
* contrib/hbnf/netpv.prg
* contrib/hbnf/nooccur.prg
* contrib/hbnf/ntow.prg
* contrib/hbnf/nwlstat.prg
* contrib/hbnf/nwsem.prg
* contrib/hbnf/nwuid.prg
* contrib/hbnf/ontick.prg
* contrib/hbnf/page.prg
* contrib/hbnf/pchr.prg
* contrib/hbnf/pegs.prg
* contrib/hbnf/pending.prg
* contrib/hbnf/pickday.prg
* contrib/hbnf/popadder.prg
* contrib/hbnf/prtesc.prg
* contrib/hbnf/pvid.prg
* contrib/hbnf/qtr.prg
* contrib/hbnf/rand1.prg
* contrib/hbnf/restsets.prg
* contrib/hbnf/savearr.prg
* contrib/hbnf/savesets.prg
* contrib/hbnf/scancode.prg
* contrib/hbnf/scregion.prg
* contrib/hbnf/setdate.prg
* contrib/hbnf/settime.prg
* contrib/hbnf/sinkey.prg
* contrib/hbnf/sleep.prg
* contrib/hbnf/sqzn.prg
* contrib/hbnf/sysmem.prg
* contrib/hbnf/tbwhile.prg
* contrib/hbnf/tempfile.prg
* contrib/hbnf/vertmenu.prg
* contrib/hbnf/vidcur.prg
* contrib/hbnf/vidmode.prg
* contrib/hbnf/wda.prg
* contrib/hbnf/week.prg
* contrib/hbnf/workdays.prg
* contrib/hbnf/woy.prg
* contrib/hbnf/xbox.prg
* contrib/hbnf/year.prg
* formatted using hbformat and manually
* code cleanups and standardizations
2012-09-26 02:44 UTC+0200 Przemyslaw Czerpak (druzus/at/poczta.onet.pl)
* harbour/include/hbexprb.c
* harbour/include/hbapicdp.h

67
harbour/contrib/hbnf/aading.prg
View File

@@ -25,38 +25,41 @@
#ifdef FT_TEST
PROCEDURE Main()
LOCAL aList1,aList2,var0,nstart,nstop,nelapsed,nCtr
LOCAL aList1, aList2, var0, nstart, nstop, nelapsed, nCtr
CLS
? "TEST TO DEMONSTRATE EXAMPLES OF FT_AADDITION"
?
aList1 := {"apple", "orange", "pear"}
aList2 := {"apple ", "banana", "PEAR"}
aList1 := { "apple", "orange", "pear" }
aList2 := { "apple ", "banana", "PEAR" }
? "aList1 : "
AEVAL( aList1, { |x| QQOUT(x + ",") } )
AEval( aList1, {| x | QQOut( x + "," ) } )
?
? "aList2 : "
AEVAL( aList2, { |x| QQOUT(x + ",") } )
AEval( aList2, {| x | QQOut( x + "," ) } )
?
nstart := SECONDS()
FOR nCtr := 1 to 100
nstart := Seconds()
FOR nCtr := 1 TO 100
var0 := FT_AADDITION( aList1, aList2 )
NEXT
nstop := SECONDS()
nstop := Seconds()
nelapsed := nstop - nstart
? "time for 100 merges:", nelapsed
? PADR("FT_AADDITION( aList1, aList2 ) ->",44)
AEVAL( var0, { |x| QQOUT(x + ",") } )
? PadR( "FT_AADDITION( aList1, aList2 ) ->", 44 )
AEval( var0, {| x | QQOut( x + "," ) } )
?
var0 := FT_AADDITION( aList1, aList2, , .F. )
? PADR("FT_AADDITION( aList1, aList2, , .F. ) ->",44)
AEVAL( var0, { |x| QQOUT(x + ",") } )
? PadR( "FT_AADDITION( aList1, aList2, , .F. ) ->", 44 )
AEval( var0, {| x | QQOut( x + "," ) } )
?
var0 := FT_AADDITION( aList1, aList2, .F., .F. )
? PADR("FT_AADDITION( aList1, aList2, .F., .F. ) ->",44)
AEVAL( var0, { |x| QQOUT(x + ",") } )
var0 := FT_AADDITION( aList1, aList2, .F. , .F. )
? PadR( "FT_AADDITION( aList1, aList2, .F., .F. ) ->", 44 )
AEval( var0, {| x | QQOut( x + "," ) } )
?
RETURN
#endif
@@ -64,9 +67,9 @@ PROCEDURE Main()
FUNCTION FT_AADDITION( aList1, aList2, lTrimmer, lCaseSens )
LOCAL nElement, nPos, bScanCode
LOCAL aNewArray := ACLONE( aList1 )
LOCAL aNewArray := AClone( aList1 )
// Set default parameters as necessary.
// Set default parameters as necessary.
IF lCaseSens == NIL
lCaseSens := .T.
ENDIF
@@ -75,38 +78,38 @@ FUNCTION FT_AADDITION( aList1, aList2, lTrimmer, lCaseSens )
lTrimmer := .T.
ENDIF
// Assign code blocks according to case sensitivity and trim.
// Assign code blocks according to case sensitivity and trim.
IF lCaseSens
IF lTrimmer // Ignore spaces.
bScanCode := { |x| ;
ALLTRIM( x ) == ;
ALLTRIM( aList2[ nElement ]) }
bScanCode := {| x | ;
AllTrim( x ) == ;
AllTrim( aList2[ nElement ] ) }
ELSE
bScanCode := { |x| x == ( aList2[ nElement ]) }
bScanCode := {| x | x == ( aList2[ nElement ] ) }
ENDIF
ELSE // Ignore case.
IF lTrimmer // Ignore spaces.
bScanCode := { |x| ;
UPPER( ALLTRIM( x )) == ;
UPPER( ALLTRIM( aList2[ nElement ] )) }
bScanCode := {| x | ;
Upper( AllTrim( x ) ) == ;
Upper( AllTrim( aList2[ nElement ] ) ) }
ELSE
bScanCode := { |x| ;
UPPER( x ) == ;
UPPER( aList2[ nElement ] ) }
bScanCode := {| x | ;
Upper( x ) == ;
Upper( aList2[ nElement ] ) }
ENDIF
ENDIF
// Add the unique elements of aList2 to aList1.
FOR nElement := 1 TO LEN( aList2 )
// Add the unique elements of aList2 to aList1.
FOR nElement := 1 TO Len( aList2 )
nPos := ASCAN( aList1, bScanCode )
nPos := AScan( aList1, bScanCode )
// If unique, then add element to new array.
IF nPos == 0
AADD( aNewArray, aList2[ nElement ] )
AAdd( aNewArray, aList2[ nElement ] )
ENDIF
NEXT

28
harbour/contrib/hbnf/aavg.prg
View File

@@ -24,25 +24,21 @@
*
*/
#include "common.ch"
#define FORCE_BETWEEN(x,y,z) (y := MAX(MIN(y,z),x))
#define IS_NOT_ARRAY(x) (VALTYPE(x) != "A")
#command DEFAULT <Param1> TO <Def1> [, <ParamN> TO <DefN> ] ;
=> ;
<Param1> := iif(<Param1> == NIL,<Def1>,<Param1>) ;
[; <ParamN> := iif(<ParamN> == NIL,<DefN>,<ParamN>)]
FUNCTION FT_AAVG( aArray, nStartIndex, nEndIndex )
FUNCTION FT_AAVG(aArray, nStartIndex, nEndIndex)
DEFAULT nStartIndex TO 1
DEFAULT nEndIndex TO Len( aArray )
DEFAULT nStartIndex TO 1, ;
nEndIndex TO LEN(aArray)
// Make Sure Bounds are in Range
// Make Sure Bounds are in Range
FORCE_BETWEEN( 1, nEndIndex, Len( aArray ) )
FORCE_BETWEEN( 1, nStartIndex, nEndIndex )
FORCE_BETWEEN(1, nEndIndex, LEN(aArray))
FORCE_BETWEEN(1, nStartIndex, nEndIndex)
RETURN iif(IS_NOT_ARRAY(aArray) .OR. LEN(aArray) == 0, ;
0, ;
FT_ASUM(aArray, nStartIndex, nEndIndex) / ;
(nEndIndex - nStartIndex + 1))
RETURN iif( ! HB_ISARRAY( aArray ) .OR. Empty( aArray ), ;
0, ;
FT_ASUM( aArray, nStartIndex, nEndIndex ) / ;
( nEndIndex - nStartIndex + 1 ) )

32
harbour/contrib/hbnf/acctadj.prg
View File

@@ -31,25 +31,25 @@
*
*/
FUNCTION FT_ACCTADJ(dGivenDate, lIsEnd)
FUNCTION FT_ACCTADJ( dGivenDate, lIsEnd )
LOCAL nTemp
LOCAL nTemp
IF !( VALTYPE(dGivenDate) == "D" )
dGivenDate := DATE()
ENDIF
IF !( ValType( dGivenDate ) == "D" )
dGivenDate := Date()
ENDIF
lIsEnd := VALTYPE(lIsEnd) == "L"
nTemp := FT_DAYTOBOW(dGivenDate)
lIsEnd := ValType( lIsEnd ) == "L"
nTemp := FT_DAYTOBOW( dGivenDate )
IF nTemp > ( 2 + iif(!lIsEnd, 1, 0) )
dGivenDate += ( 7 - nTemp ) // Next Week Start (This Week End + 1)
ELSE
dGivenDate -= nTemp // This Week Start (Prior Week End + 1)
ENDIF
IF nTemp > ( 2 + iif( ! lIsEnd, 1, 0 ) )
dGivenDate += ( 7 - nTemp ) // Next Week Start (This Week End + 1)
ELSE
dGivenDate -= nTemp // This Week Start (Prior Week End + 1)
ENDIF
IF lIsEnd
dGivenDate--
ENDIF
IF lIsEnd
dGivenDate--
ENDIF
RETURN dGivenDate
RETURN dGivenDate

95
harbour/contrib/hbnf/acctmnth.prg
View File

@@ -27,59 +27,60 @@
*
*/
FUNCTION FT_ACCTMONTH(dGivenDate,nMonthNum)
LOCAL nYTemp, nMTemp, lIsMonth, aRetVal
FUNCTION FT_ACCTMONTH( dGivenDate, nMonthNum )
IF ! ( VALTYPE(dGivenDate) $ 'ND' )
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'N'
nMonthNum := dGivenDate
dGivenDate := DATE()
ENDIF
LOCAL nYTemp, nMTemp, lIsMonth, aRetVal
aRetVal := FT_MONTH(dGivenDate)
nYTemp := VAL(SUBSTR(aRetVal[1],1,4))
nMTemp := VAL(SUBSTR(aRetVal[1],5,2))
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
IF ! ( ValType( dGivenDate ) $ 'ND' )
dGivenDate := Date()
ELSEIF ValType( dGivenDate ) == 'N'
nMonthNum := dGivenDate
dGivenDate := Date()
ENDIF
IF dGivenDate < aRetVal[2]
dGivenDate := FT_MADD(dGivenDate, -1)
aRetVal := FT_MONTH(dGivenDate)
nMTemp -= 1
IF nMTemp == 0
nYTemp -= 1
nMTemp := 12
ENDIF
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
aRetVal := FT_MONTH( dGivenDate )
nYTemp := Val( SubStr( aRetVal[1],1,4 ) )
nMTemp := Val( SubStr( aRetVal[1],5,2 ) )
aRetVal[2] := FT_ACCTADJ( aRetVal[2] )
aRetVal[3] := FT_ACCTADJ( aRetVal[3], .T. )
ELSEIF dGivenDate > aRetVal[3]
IF dGivenDate < aRetVal[2]
dGivenDate := FT_MADD( dGivenDate, - 1 )
aRetVal := FT_MONTH( dGivenDate )
nMTemp -= 1
IF nMTemp == 0
nYTemp -= 1
nMTemp := 12
ENDIF
aRetVal[2] := FT_ACCTADJ( aRetVal[2] )
aRetVal[3] := FT_ACCTADJ( aRetVal[3], .T. )
dGivenDate := FT_MADD(dGivenDate, 1)
aRetVal := FT_MONTH(dGivenDate)
nMTemp += 1
IF nMTemp == 13
nYTemp += 1
nMTemp := 1
ENDIF
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
ELSEIF dGivenDate > aRetVal[3]
ENDIF
dGivenDate := FT_MADD( dGivenDate, 1 )
aRetVal := FT_MONTH( dGivenDate )
nMTemp += 1
IF nMTemp == 13
nYTemp += 1
nMTemp := 1
ENDIF
aRetVal[2] := FT_ACCTADJ( aRetVal[2] )
aRetVal[3] := FT_ACCTADJ( aRetVal[3], .T. )
lIsMonth := ( VALTYPE(nMonthNum) == 'N' )
IF lIsMonth
IF nMonthNum < 1 .OR. nMonthNum > 12
nMonthNum := 12
ENDIF
aRetVal := FT_MONTH(dGivenDate, nMonthNum)
nYTemp := VAL(SUBSTR(aRetVal[1],1,4))
nMTemp := VAL(SUBSTR(aRetVal[1],5,2))
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
ENDIF
ENDIF
aRetVal[1] := STR(nYTemp,4) + PADL(LTRIM(STR(nMTemp,2)), 2, '0')
lIsMonth := ( ValType( nMonthNum ) == 'N' )
IF lIsMonth
IF nMonthNum < 1 .OR. nMonthNum > 12
nMonthNum := 12
ENDIF
aRetVal := FT_MONTH( dGivenDate, nMonthNum )
nYTemp := Val( SubStr( aRetVal[1],1,4 ) )
nMTemp := Val( SubStr( aRetVal[1],5,2 ) )
aRetVal[2] := FT_ACCTADJ( aRetVal[2] )
aRetVal[3] := FT_ACCTADJ( aRetVal[3], .T. )
ENDIF
RETURN aRetVal
aRetVal[1] := Str( nYTemp, 4 ) + PadL( LTrim( Str( nMTemp, 2 ) ), 2, '0' )
RETURN aRetVal

95
harbour/contrib/hbnf/acctqtr.prg
View File

@@ -27,58 +27,59 @@
*
*/
FUNCTION FT_ACCTQTR(dGivenDate,nQtrNum)
LOCAL nYTemp, nQTemp, lIsQtr, aRetVal
FUNCTION FT_ACCTQTR( dGivenDate, nQtrNum )
IF ! ( VALTYPE(dGivenDate) $ 'ND' )
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'N'
nQtrNum := dGivenDate
dGivenDate := DATE()
ENDIF
aRetVal := FT_QTR(dGivenDate)
nYTemp := VAL(SUBSTR(aRetVal[1],1,4))
nQTemp := VAL(SUBSTR(aRetVal[1],5,2))
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
LOCAL nYTemp, nQTemp, lIsQtr, aRetVal
IF dGivenDate < aRetVal[2]
dGivenDate := FT_MADD(dGivenDate, -1)
aRetVal := FT_QTR(dGivenDate)
nQTemp -= 1
IF nQTemp == 0
nYTemp -= 1
nQTemp := 4
ENDIF
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
IF ! ( ValType( dGivenDate ) $ 'ND' )
dGivenDate := Date()
ELSEIF ValType( dGivenDate ) == 'N'
nQtrNum := dGivenDate
dGivenDate := Date()
ENDIF
aRetVal := FT_QTR( dGivenDate )
nYTemp := Val( SubStr( aRetVal[1],1,4 ) )
nQTemp := Val( SubStr( aRetVal[1],5,2 ) )
aRetVal[2] := FT_ACCTADJ( aRetVal[2] )
aRetVal[3] := FT_ACCTADJ( aRetVal[3], .T. )
ELSEIF dGivenDate > aRetVal[3]
IF dGivenDate < aRetVal[2]
dGivenDate := FT_MADD( dGivenDate, - 1 )
aRetVal := FT_QTR( dGivenDate )
nQTemp -= 1
IF nQTemp == 0
nYTemp -= 1
nQTemp := 4
ENDIF
aRetVal[2] := FT_ACCTADJ( aRetVal[2] )
aRetVal[3] := FT_ACCTADJ( aRetVal[3], .T. )
dGivenDate := FT_MADD(dGivenDate,1)
aRetVal := FT_QTR(dGivenDate)
nQTemp += 1
IF nQTemp == 5
nYTemp += 1
nQTemp := 1
ENDIF
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
ELSEIF dGivenDate > aRetVal[3]
ENDIF
dGivenDate := FT_MADD( dGivenDate, 1 )
aRetVal := FT_QTR( dGivenDate )
nQTemp += 1
IF nQTemp == 5
nYTemp += 1
nQTemp := 1
ENDIF
aRetVal[2] := FT_ACCTADJ( aRetVal[2] )
aRetVal[3] := FT_ACCTADJ( aRetVal[3], .T. )
lIsQtr := ( VALTYPE(nQtrNum) == 'N' )
IF lIsQtr
IF nQtrNum < 1 .OR. nQtrNum > 4
nQtrNum := 4
ENDIF
aRetVal := FT_QTR(dGivenDate, nQtrNum)
nYTemp := VAL(SUBSTR(aRetVal[1],1,4))
nQTemp := VAL(SUBSTR(aRetVal[1],5,2))
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
ENDIF
ENDIF
aRetVal[1] := STR(nYTemp,4) + PADL(LTRIM(STR(nQTemp,2)), 2, '0')
lIsQtr := ( ValType( nQtrNum ) == 'N' )
IF lIsQtr
IF nQtrNum < 1 .OR. nQtrNum > 4
nQtrNum := 4
ENDIF
aRetVal := FT_QTR( dGivenDate, nQtrNum )
nYTemp := Val( SubStr( aRetVal[1],1,4 ) )
nQTemp := Val( SubStr( aRetVal[1],5,2 ) )
aRetVal[2] := FT_ACCTADJ( aRetVal[2] )
aRetVal[3] := FT_ACCTADJ( aRetVal[3], .T. )
ENDIF
RETURN aRetVal
aRetVal[1] := Str( nYTemp, 4 ) + PadL( LTrim( Str( nQTemp, 2 ) ), 2, '0' )
RETURN aRetVal

46
harbour/contrib/hbnf/acctweek.prg
View File

@@ -27,32 +27,32 @@
*
*/
FUNCTION FT_ACCTWEEK(dGivenDate,nWeekNum)
FUNCTION FT_ACCTWEEK( dGivenDate, nWeekNum )
LOCAL nTemp, lIsWeek, aRetVal
LOCAL nTemp, lIsWeek, aRetVal
IF ! VALTYPE(dGivenDate) $ 'ND'
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'N'
nWeekNum := dGivenDate
dGivenDate := DATE()
ENDIF
IF ! ValType( dGivenDate ) $ 'ND'
dGivenDate := Date()
ELSEIF ValType( dGivenDate ) == 'N'
nWeekNum := dGivenDate
dGivenDate := Date()
ENDIF
aRetVal := FT_ACCTYEAR(dGivenDate)
aRetVal := FT_ACCTYEAR( dGivenDate )
lIsWeek := ( VALTYPE(nWeekNum) == 'N' )
IF lIsWeek
nTemp := INT( (aRetVal[3] - aRetVal[2]) / 7 ) + 1
IF nWeekNum < 1 .OR. nWeekNum > nTemp
nWeekNum := nTemp
ENDIF
dGivenDate := aRetVal[2] + (nWeekNum - 1) * 7
ENDIF
lIsWeek := ( ValType( nWeekNum ) == 'N' )
IF lIsWeek
nTemp := Int( ( aRetVal[ 3 ] - aRetVal[ 2 ] ) / 7 ) + 1
IF nWeekNum < 1 .OR. nWeekNum > nTemp
nWeekNum := nTemp
ENDIF
dGivenDate := aRetVal[ 2 ] + ( nWeekNum - 1 ) * 7
ENDIF
aRetVal[1] += PADL(LTRIM(STR(INT( (dGivenDate - ;
aRetVal[2]) / 7 ) + 1, 2)), 2, '0')
dGivenDate += ( 6 - FT_DAYTOBOW(dGivenDate) ) // end of week
aRetVal[2] := dGivenDate - 6
aRetVal[3] := dGivenDate
aRetVal[ 1 ] += PadL( LTrim( Str( Int( ( dGivenDate - ;
aRetVal[ 2 ] ) / 7 ) + 1, 2 ) ), 2, '0' )
dGivenDate += ( 6 - FT_DAYTOBOW( dGivenDate ) ) // end of week
aRetVal[ 2 ] := dGivenDate - 6
aRetVal[ 3 ] := dGivenDate
RETURN aRetVal
RETURN aRetVal

44
harbour/contrib/hbnf/acctyear.prg
View File

@@ -27,31 +27,31 @@
*
*/
FUNCTION FT_ACCTYEAR(dGivenDate)
FUNCTION FT_ACCTYEAR( dGivenDate )
LOCAL nYTemp, aRetVal
LOCAL nYTemp, aRetVal
IF !( VALTYPE(dGivenDate) == "D" )
dGivenDate := DATE()
ENDIF
IF !( ValType( dGivenDate ) == "D" )
dGivenDate := Date()
ENDIF
aRetVal := FT_YEAR(dGivenDate)
nYTemp := VAL(aRetVal[1])
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
aRetVal := FT_YEAR( dGivenDate )
nYTemp := Val( aRetVal[ 1 ] )
aRetVal[ 2 ] := FT_ACCTADJ( aRetVal[ 2 ] )
aRetVal[ 3 ] := FT_ACCTADJ( aRetVal[ 3 ], .T. )
IF dGivenDate < aRetVal[2]
aRetVal := FT_YEAR(FT_MADD(dGivenDate, -1))
nYTemp --
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
ELSEIF dGivenDate > aRetVal[3]
aRetVal := FT_YEAR(FT_MADD(dGivenDate, 1))
nYTemp ++
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
ENDIF
IF dGivenDate < aRetVal[ 2 ]
aRetVal := FT_YEAR( FT_MADD( dGivenDate, - 1 ) )
nYTemp--
aRetVal[ 2 ] := FT_ACCTADJ( aRetVal[ 2 ] )
aRetVal[ 3 ] := FT_ACCTADJ( aRetVal[ 3 ], .T. )
ELSEIF dGivenDate > aRetVal[ 3 ]
aRetVal := FT_YEAR( FT_MADD( dGivenDate, 1 ) )
nYTemp++
aRetVal[ 2 ] := FT_ACCTADJ( aRetVal[ 2 ] )
aRetVal[ 3 ] := FT_ACCTADJ( aRetVal[ 3 ], .T. )
ENDIF
aRetVal[1] := STR(nYTemp,4)
aRetVal[ 1 ] := Str( nYTemp, 4 )
RETURN aRetVal
RETURN aRetVal

27
harbour/contrib/hbnf/adessort.prg
View File

@@ -24,27 +24,18 @@
*
*/
#command DEFAULT <Param1> TO <Def1> [, <ParamN> TO <DefN> ] ;
=> ;
<Param1> := iif(<Param1> == NIL,<Def1>,<Param1>) ;
[; <ParamN> := iif(<ParamN> == NIL,<DefN>,<ParamN>)]
#command DEFAULT <Param1> TO <Def1> IF NOT <Type1> ;
[, <ParamN> TO <DefN> IF NOT <TypeN> ] ;
=> ;
<Param1> := iif(VALTYPE(<Param1>) == <Type1>,<Param1>,<Def1>) ;
[; <ParamN> := iif(VALTYPE(<ParamN>) == <TypeN>,<ParamN>,<DefN>)]
#include "common.ch"
#define FORCE_BETWEEN(x,y,z) (y := MAX(MIN(y,z),x))
FUNCTION FT_ADESSORT(aArray, nStartIndex, nEndIndex)
FUNCTION FT_ADESSORT( aArray, nStartIndex, nEndIndex )
DEFAULT nStartIndex TO 1, ;
nEndIndex TO LEN(aArray)
DEFAULT nStartIndex TO 1
DEFAULT nEndIndex TO Len( aArray )
// Make Sure Bounds are in Range
FORCE_BETWEEN(1, nEndIndex, LEN(aArray))
FORCE_BETWEEN(1, nStartIndex, nEndIndex)
// Make Sure Bounds are in Range
FORCE_BETWEEN( 1, nEndIndex, Len( aArray ) )
FORCE_BETWEEN( 1, nStartIndex, nEndIndex )
RETURN (ASORT(aArray, nStartIndex, nEndIndex, ;
{ | xElement1, xElement2 | xElement1 > xElement2 } ))
RETURN ASort( aArray, nStartIndex, nEndIndex, ;
{| xElement1, xElement2 | xElement1 > xElement2 } )

43
harbour/contrib/hbnf/aemaxlen.prg
View File

@@ -25,28 +25,31 @@
#ifdef FT_TEST
PROCEDURE Main()
LOCAL var0, myarray1 := DIRECTORY()
LOCAL var0, myarray1 := Directory()
CLS
? "TEST TO DEMONSTRATE EXAMPLES OF FT_AEMAXLEN"
?
? "myarray1 := DIRECTORY()"
?
var0 := FT_AEMAXLEN( myarray1 )
? PADR('FT_AEMAXLEN( myarray1 ) ->',30)
? PadR( 'FT_AEMAXLEN( myarray1 ) ->', 30 )
?? var0
?
var0 := FT_AEMAXLEN( myarray1,2 )
? PADR('FT_AEMAXLEN( myarray1,2 ) ->',30)
var0 := FT_AEMAXLEN( myarray1, 2 )
? PadR( 'FT_AEMAXLEN( myarray1,2 ) ->', 30 )
?? var0
?
var0 := FT_AEMAXLEN( myarray1,3 )
? PADR('FT_AEMAXLEN( myarray1,3 ) ->',30)
var0 := FT_AEMAXLEN( myarray1, 3 )
? PadR( 'FT_AEMAXLEN( myarray1,3 ) ->', 30 )
?? var0
?
var0 := FT_AEMAXLEN( aTail( myarray1 ) )
? PADR('FT_AEMAXLEN( aTail( myarray1 ) ) ->',30)
var0 := FT_AEMAXLEN( ATail( myarray1 ) )
? PadR( 'FT_AEMAXLEN( aTail( myarray1 ) ) ->', 30 )
?? var0
?
RETURN
#endif
@@ -55,7 +58,7 @@ FUNCTION FT_AEmaxlen( aArray, nDimension, nStart, nCount )
LOCAL i, nLast, cType, nMaxlen := 0
// Set default parameters as necessary.
// Set default parameters as necessary.
IF nDimension == NIL
nDimension := 1
ENDIF
@@ -65,24 +68,24 @@ FUNCTION FT_AEmaxlen( aArray, nDimension, nStart, nCount )
ENDIF
IF nCount == NIL
nCount := LEN( aArray ) - nStart + 1
nCount := Len( aArray ) - nStart + 1
ENDIF
nLast := MIN( nStart +nCount -1, LEN( aArray ))
nLast := Min( nStart + nCount - 1, Len( aArray ) )
FOR i := nStart TO nLast
cType := VALTYPE( aArray[i] )
cType := ValType( aArray[ i ] )
DO CASE
CASE ( cType == "C" )
nMaxlen := MAX( nMaxlen, LEN( aArray[i] ))
CASE cType == "C"
nMaxlen := Max( nMaxlen, Len( aArray[ i ] ) )
CASE ( cType == "A" )
nMaxlen := MAX( nMaxlen, ;
LEN( LTRIM( TRANSFORM( aArray[i] [nDimension], "@X"))))
CASE cType == "A"
nMaxlen := Max( nMaxlen, ;
Len( LTrim( Transform( aArray[ i ][ nDimension ], "@X" ) ) ) )
OTHERWISE
nMaxlen := MAX( nMaxlen, ;
LEN( LTRIM( TRANSFORM( aArray[i], "@X" ))))
OTHERWISE
nMaxlen := Max( nMaxlen, ;
Len( LTrim( Transform( aArray[ i ], "@X" ) ) ) )
ENDCASE
NEXT

43
harbour/contrib/hbnf/aeminlen.prg
View File

@@ -25,31 +25,34 @@
#ifdef FT_TEST
PROCEDURE Main()
LOCAL var0, myarray1 := DIRECTORY()
LOCAL var0, myarray1 := Directory()
CLS
? "TEST TO DEMONSTRATE EXAMPLES OF FT_AEMINLEN"
?
? "myarray1 := DIRECTORY()"
?
aEval( myarray1, {|v| qout( padr(v[1],12), v[2], v[3], v[4], v[5] ) } )
AEval( myarray1, {|v| QOut( PadR(v[1],12 ), v[2], v[3], v[4], v[5] ) } )
var0 := FT_AEMINLEN( myarray1 )
? PADR('FT_AEMINLEN( myarray1 ) ->',30)
? PadR( 'FT_AEMINLEN( myarray1 ) ->', 30 )
?? var0
?
var0 := FT_AEMINLEN( myarray1,2 )
? PADR('FT_AEMINLEN( myarray1,2 ) ->',30)
var0 := FT_AEMINLEN( myarray1, 2 )
? PadR( 'FT_AEMINLEN( myarray1,2 ) ->', 30 )
?? var0
?
?
var0 := FT_AEMINLEN( myarray1[2] )
? PADR('FT_AEMINLEN( myarray1[2] ) ->',30)
? PadR( 'FT_AEMINLEN( myarray1[2] ) ->', 30 )
?? var0
?
?
var0 := FT_AEMINLEN( myarray1,3 )
? PADR('FT_AEMINLEN( myarray1,3 ) ->',30)
var0 := FT_AEMINLEN( myarray1, 3 )
? PadR( 'FT_AEMINLEN( myarray1,3 ) ->', 30 )
?? var0
?
RETURN
#endif
@@ -58,7 +61,7 @@ FUNCTION FT_AEminlen( aArray, nDimension, nStart, nCount )
LOCAL i, nLast, cType, nMinlen := 65519
// Set default parameters as necessary.
// Set default parameters as necessary.
IF nDimension == NIL
nDimension := 1
ENDIF
@@ -68,24 +71,24 @@ FUNCTION FT_AEminlen( aArray, nDimension, nStart, nCount )
ENDIF
IF nCount == NIL
nCount := LEN( aArray ) - nStart + 1
nCount := Len( aArray ) - nStart + 1
ENDIF
nLast := MIN( nStart +nCount -1, LEN( aArray ))
nLast := Min( nStart + nCount - 1, Len( aArray ) )
FOR i := nStart TO nLast
cType := VALTYPE( aArray[i] )
cType := ValType( aArray[ i ] )
DO CASE
CASE ( cType == "C" )
nMinlen := MIN( nMinlen, LEN( aArray[i] ))
CASE cType == "C"
nMinlen := Min( nMinlen, Len( aArray[ i ] ) )
CASE ( cType == "A" )
nMinlen := MIN( nMinlen, ;
LEN( LTRIM( TRANSFORM( aArray[i] [nDimension], "@X" ))))
CASE cType == "A"
nMinlen := Min( nMinlen, ;
Len( LTrim( Transform( aArray[ i ][ nDimension ], "@X" ) ) ) )
OTHERWISE
nMinlen := MIN( nMinlen, ;
LEN( LTRIM( TRANSFORM( aArray[i], "@X" ))))
OTHERWISE
nMinlen := Min( nMinlen, ;
Len( LTrim( Transform( aArray[ i ], "@X" ) ) ) )
ENDCASE
NEXT

52
harbour/contrib/hbnf/amedian.prg
View File

@@ -29,65 +29,65 @@
#include "directry.ch"
PROCEDURE Main()
LOCAL var0, myarray0 := DIRECTORY(), myarray1 := {}
LOCAL var0, myarray0 := Directory(), myarray1 := {}
CLS
? "TEST TO DEMONSTRATE EXAMPLES OF FT_AMEDIAN"
?
AEVAL( myarray0, { |x| AADD( myarray1, x[ F_SIZE ]) } )
AEval( myarray0, {| x | AAdd( myarray1, x[ F_SIZE ] ) } )
var0 := FT_AMEDIAN( myarray1 )
? PADR('FT_AMEDIAN( myarray1 ) ->',35)
? PadR( 'FT_AMEDIAN( myarray1 ) ->', 35 )
?? var0
?
var0 := FT_AMEDIAN( myarray1, 2 )
? PADR('FT_AMEDIAN( myarray1, 2 ) ->',35)
? PadR( 'FT_AMEDIAN( myarray1, 2 ) ->', 35 )
?? var0
?
var0 := FT_AMEDIAN( myarray1, , 9 )
? PADR('FT_AMEDIAN( myarray1, , 9 ) ->',35)
? PadR( 'FT_AMEDIAN( myarray1, , 9 ) ->', 35 )
?? var0
?
var0 := FT_AMEDIAN( myarray1, 8, 40 )
? PADR('FT_AMEDIAN( myarray1, 8, 40 ) ->',35)
? PadR( 'FT_AMEDIAN( myarray1, 8, 40 ) ->', 35 )
?? var0
?
RETURN
#endif
#define FORCE_BETWEEN(x,y,z) (y := MAX(MIN(y,z),x))
#include "common.ch"
#command DEFAULT <Param1> TO <Def1> [, <ParamN> TO <DefN> ] ;
=> ;
<Param1> := iif(<Param1> == NIL,<Def1>,<Param1>) ;
[; <ParamN> := iif(<ParamN> == NIL,<DefN>,<ParamN>)]
#define FORCE_BETWEEN(x,y,z) (y := MAX(MIN(y,z),x))
FUNCTION FT_AMEDIAN( aArray, nStart, nEnd )
LOCAL nTemplen, aTemparray, nMiddle1, nMiddle2, nMedian
DEFAULT nStart TO 1, ;
nEnd TO LEN( aArray )
DEFAULT nStart TO 1
DEFAULT nEnd TO Len( aArray )
// Make Sure Bounds are in Range
FORCE_BETWEEN(1, nEnd, LEN( aArray ))
FORCE_BETWEEN(1, nStart, nEnd)
// Make Sure Bounds are in Range
FORCE_BETWEEN( 1, nEnd, Len( aArray ) )
FORCE_BETWEEN( 1, nStart, nEnd )
// Length of aTemparray
// Length of aTemparray
nTemplen := ( nEnd - nStart ) + 1
// Initialize aTemparray
aTemparray := ACOPY( aArray, ARRAY( nTemplen ), nStart, nTemplen )
// Initialize aTemparray
aTemparray := ACopy( aArray, Array( nTemplen ), nStart, nTemplen )
// Sort aTemparray
aTemparray := ASORT( aTemparray )
// Sort aTemparray
aTemparray := ASort( aTemparray )
// Determine middle value(s)
// Determine middle value(s)
IF ( nTemplen % 2 ) == 0
nMiddle1 := aTemparray[ (nTemplen / 2) ]
nMiddle2 := aTemparray[ INT(nTemplen / 2) +1 ]
nMedian := INT( ( nMIddle1 + nMiddle2 ) / 2 )
nMiddle1 := aTemparray[ ( nTemplen / 2 ) ]
nMiddle2 := aTemparray[ Int( nTemplen / 2 ) + 1 ]
nMedian := Int( ( nMIddle1 + nMiddle2 ) / 2 )
ELSE
nMedian := aTemparray[ INT( nTemplen / 2 ) + 1 ]
nMedian := aTemparray[ Int( nTemplen / 2 ) + 1 ]
ENDIF
RETURN nMedian

27
harbour/contrib/hbnf/anomatch.prg
View File

@@ -24,27 +24,24 @@
*
*/
#include "common.ch"
#define FORCE_BETWEEN(x,y,z) (y := MAX(MIN(y,z),x))
#command DEFAULT <Param1> TO <Def1> [, <ParamN> TO <DefN> ] ;
=> ;
<Param1> := iif(<Param1> == NIL,<Def1>,<Param1>) ;
[; <ParamN> := iif(<ParamN> == NIL,<DefN>,<ParamN>)]
FUNCTION FT_ANOMATCHES(aArray, bCompareBlock, nStartIndex, nEndIndex)
FUNCTION FT_ANOMATCHES( aArray, bCompareBlock, nStartIndex, nEndIndex )
LOCAL nNoOfMatches := 0 // Number of Matches Found
DEFAULT nStartIndex TO 1, ;
nEndIndex TO LEN(aArray)
DEFAULT nStartIndex TO 1
DEFAULT nEndIndex TO Len( aArray )
// Make Sure Bounds are in Range
FORCE_BETWEEN(1, nEndIndex, LEN(aArray))
FORCE_BETWEEN(1, nStartIndex, nEndIndex)
// Make Sure Bounds are in Range
FORCE_BETWEEN( 1, nEndIndex, Len( aArray ) )
FORCE_BETWEEN( 1, nStartIndex, nEndIndex )
AEVAL(aArray, ;
{ | xElement | ;
iif(EVAL(bCompareBlock, xElement), nNoOfMatches++, NIL) }, ;
nStartIndex, nEndIndex - nStartIndex + 1)
AEval( aArray, ;
{| xElement | ;
iif( Eval( bCompareBlock, xElement ), nNoOfMatches++, NIL ) }, ;
nStartIndex, nEndIndex - nStartIndex + 1 )
RETURN nNoOfMatches // FT_ANoMatches

140
harbour/contrib/hbnf/any2any.prg
View File

@@ -24,107 +24,91 @@
*
*/
#include "common.ch"
#define BLOCKIFY(x) { || x }
#define IS_CHAR(x) (VALTYPE(x) == "C")
#define IS_DATE(x) (VALTYPE(x) == "D")
#define IS_LOGICAL(x) (VALTYPE(x) == "L")
#define IS_NUMERIC(x) (VALTYPE(x) == "N")
#define CASE_AT(x,y,z) z[AT(x,y)+1]
#define TRIM_NUMBER(x) hb_ntos(x)
#define NULL ""
#define IS_NOT_CHAR(x) (VALTYPE(x) != "C")
#define IS_NOT_DATE(x) (VALTYPE(x) != "D")
#define EARLIEST_DATE STOD("01000101")
#define BLANK_DATE STOD()
#define IS_NOT_ARRAY(x) (VALTYPE(x) != "A")
#define IS_NOT_LOGICAL(x) (VALTYPE(x) != "L")
#define IS_NOT_NUMERIC(x) (VALTYPE(x) != "N")
#define IS_NOT_CODE_BLOCK(x) (VALTYPE(x) != "B")
#define TRUE (.t.)
#define FALSE (.f.)
#define XTOC(x) CASE_AT(VALTYPE(x), "CNDLM", ;
{ NULL, ;
x, ;
iif(IS_NUMERIC(x),;
TRIM_NUMBER(x), ;
NULL), ;
iif(IS_DATE(x),DTOC(x),NULL),;
iif(IS_LOGICAL(x),;
iif(x,".T.",".F."), ;
NULL), ;
x })
{ NULL, ;
x, ;
iif( HB_ISNUMERIC( x ), ;
hb_ntos( x ), ;
NULL ), ;
iif( HB_ISDATE( x ), DToC( x ), NULL ), ;
iif( HB_ISLOGICAL( x ), ;
iif( x, ".T.", ".F." ), ;
NULL ), ;
x } )
#command DEFAULT <Param1> TO <Def1> [, <ParamN> TO <DefN> ] ;
=> ;
<Param1> := iif(<Param1> == NIL,<Def1>,<Param1>) ;
[; <ParamN> := iif(<ParamN> == NIL,<DefN>,<ParamN>)]
FUNCTION FT_XTOY( xValueToConvert, cTypeToConvertTo, lWantYesNo )
FUNCTION FT_XTOY(xValueToConvert, cTypeToConvertTo, lWantYesNo)
DEFAULT lWantYesNo TO FALSE
DEFAULT lWantYesNo TO .F.
DO CASE
CASE cTypeToConvertTo == "C" .AND.; // They Want a Character String
IS_NOT_CHAR(xValueToConvert)
CASE cTypeToConvertTo == "C" .AND. ; // They Want a Character String
! HB_ISSTRING( xValueToConvert )
xValueToConvert := XTOC(xValueToConvert)
xValueToConvert := XTOC( xValueToConvert )
CASE cTypeToConvertTo == "D" .AND.; // They Want a Date
IS_NOT_DATE(xValueToConvert)
CASE cTypeToConvertTo == "D" .AND. ; // They Want a Date
! HB_ISDATE( xValueToConvert )
xValueToConvert := iif(IS_CHAR(xValueToConvert), ;
; // Convert from a Character
CTOD(xValueToConvert), ;
iif(IS_NUMERIC(xValueToConvert), ;
; // Convert from a Number
xValueToConvert + EARLIEST_DATE, ;
iif(IS_LOGICAL(xValueToConvert), ;
; // Convert from a Logical
iif(xValueToConvert, DATE(), BLANK_DATE), ;
; // Unsupported Type
BLANK_DATE)))
xValueToConvert := iif( HB_ISSTRING( xValueToConvert ), ;
; // Convert from a Character
CToD( xValueToConvert ), ;
iif( HB_ISNUMERIC( xValueToConvert ), ;
; // Convert from a Number
xValueToConvert + EARLIEST_DATE, ;
iif( HB_ISLOGICAL( xValueToConvert ), ;
; // Convert from a Logical
iif( xValueToConvert, Date(), BLANK_DATE ), ;
; // Unsupported Type
BLANK_DATE ) ) )
CASE cTypeToConvertTo == "N" .AND.; // They Want a Number
IS_NOT_NUMERIC(xValueToConvert)
CASE cTypeToConvertTo == "N" .AND. ; // They Want a Number
! HB_ISNUMERIC( xValueToConvert )
xValueToConvert := iif(IS_CHAR(xValueToConvert), ;
; // Convert from a Character
VAL(xValueToConvert), ;
iif(IS_DATE(xValueToConvert), ;
; // Convert from a Date
xValueToConvert - EARLIEST_DATE, ;
iif(IS_LOGICAL(xValueToConvert), ;
; // Convert from a Logical
iif(xValueToConvert, 1, 0), ;
; // Unsupported Type
0)))
xValueToConvert := iif( HB_ISSTRING( xValueToConvert ), ;
; // Convert from a Character
Val( xValueToConvert ), ;
iif( HB_ISDATE( xValueToConvert ), ;
; // Convert from a Date
xValueToConvert - EARLIEST_DATE, ;
iif( HB_ISLOGICAL( xValueToConvert ), ;
; // Convert from a Logical
iif( xValueToConvert, 1, 0 ), ;
; // Unsupported Type
0 ) ) )
CASE cTypeToConvertTo == "L" .AND.; // They Want a Logical
IS_NOT_LOGICAL(xValueToConvert)
CASE cTypeToConvertTo == "L" .AND. ; // They Want a Logical
! HB_ISLOGICAL( xValueToConvert )
xValueToConvert := iif(IS_CHAR(xValueToConvert), ;
; // Convert from a Character
UPPER(xValueToConvert) == iif(lWantYesNo,"Y",".T."), ;
iif(IS_DATE(xValueToConvert), ;
; // Convert from a Date
! EMPTY(xValueToConvert), ;
iif(IS_NUMERIC(xValueToConvert), ;
; // Convert from a Number
xValueToConvert != 0, ;
; // Unsupported Type
FALSE)))
xValueToConvert := iif( HB_ISSTRING( xValueToConvert ), ;
; // Convert from a Character
Upper( xValueToConvert ) == iif( lWantYesNo, "Y", ".T." ), ;
iif( HB_ISDATE( xValueToConvert ), ;
; // Convert from a Date
! Empty( xValueToConvert ), ;
iif( HB_ISNUMERIC( xValueToConvert ), ;
; // Convert from a Number
xValueToConvert != 0, ;
; // Unsupported Type
.F. ) ) )
CASE cTypeToConvertTo == "A" .AND.; // They Want an Array
IS_NOT_ARRAY(xValueToConvert)
CASE cTypeToConvertTo == "A" .AND. ; // They Want an Array
! HB_ISARRAY( xValueToConvert )
xValueToConvert := { xValueToConvert }
xValueToConvert := { xValueToConvert }
CASE cTypeToConvertTo == "B" .AND.; // They Want a Code Block
IS_NOT_CODE_BLOCK(xValueToConvert)
CASE cTypeToConvertTo == "B" .AND. ; // They Want a Code Block
! HB_ISBLOCK( xValueToConvert )
xValueToConvert := BLOCKIFY(xValueToConvert)
xValueToConvert := BLOCKIFY( xValueToConvert )
ENDCASE

296
harbour/contrib/hbnf/aredit.prg
View File

@@ -42,191 +42,199 @@
#include "inkey.ch"
* Default heading, column, footer separators
// Default heading, column, footer separators
#define DEF_HSEP hb_UTF8ToStr( "═╤═" )
#define DEF_CSEP hb_UTF8ToStr( " │ " )
#define DEF_FSEP hb_UTF8ToStr( "═╧═" )
* Default info for tb_methods section
// Default info for tb_methods section
#define KEY_ELEM 1
#define BLK_ELEM 2
#ifdef FT_TEST
PROCEDURE Test
* Thanks to Jim Gale for helping me understand the basics
LOCAL i, ar[3, 26], aBlocks[3], aHeadings[3], nElem := 1, bGetFunc, cRet
* set up 2 dimensional array ar[]
FOR i := 1 TO 26
ar[1, i] := i // 1 -> 26 Numeric
ar[2, i] := CHR(i+64) // "A" -> "Z" Character
ar[3, i] := CHR(91-i) // "Z" -> "A" Character
NEXT i
* Set Up aHeadings[] for column headings
aHeadings := { "Numbers", "Letters", "Reverse" }
* Set Up Blocks Describing Individual Elements in Array ar[]
aBlocks[1] := {|| STR(ar[1, nElem], 2)} // to prevent default 10 spaces
aBlocks[2] := {|| ar[2, nElem]}
aBlocks[3] := {|| ar[3, nElem]}
* Set up TestGet() as bGetFunc
bGetFunc := {|b, ar, nDim, nElem|TestGet(b, ar, nDim, nElem)}
SET SCOREBOARD OFF
SetColor( "W/N")
CLS
@ 21,4 SAY "Use Cursor Keys To Move Between Fields, <F7> = Delete Row, <F8> = Add Row"
@ 22,7 SAY "<ESC> = Quit Array Edit, <Enter> or <Any Other Key> Edits Element"
SetColor( "N/W, W/N, , , W/N" )
cRet := FT_ArEdit(3, 5, 18, 75, ar, @nElem, aHeadings, aBlocks, bGetFunc)
SetColor( "W/N")
CLS
? cRet
? "Lastkey() = ESC:", LASTKEY() == K_ESC
PROCEDURE Test
// Thanks to Jim Gale for helping me understand the basics
LOCAL i, ar[3, 26], aBlocks[3], aHeadings[3], nElem := 1, bGetFunc, cRet
// set up 2 dimensional array ar[]
FOR i := 1 TO 26
ar[1, i] := i // 1 -> 26 Numeric
ar[2, i] := Chr( i + 64 ) // "A" -> "Z" Character
ar[3, i] := Chr( 91 - i ) // "Z" -> "A" Character
NEXT i
// Set Up aHeadings[] for column headings
aHeadings := { "Numbers", "Letters", "Reverse" }
// Set Up Blocks Describing Individual Elements in Array ar[]
aBlocks[1] := {|| Str( ar[1, nElem], 2 ) } // to prevent default 10 spaces
aBlocks[2] := {|| ar[2, nElem] }
aBlocks[3] := {|| ar[3, nElem] }
// Set up TestGet() as bGetFunc
bGetFunc := {| b, ar, nDim, nElem | TestGet( b, ar, nDim, nElem ) }
SET SCOREBOARD OFF
SetColor( "W/N" )
CLS
@ 21, 4 SAY "Use Cursor Keys To Move Between Fields, <F7> = Delete Row, <F8> = Add Row"
@ 22, 7 SAY "<ESC> = Quit Array Edit, <Enter> or <Any Other Key> Edits Element"
SetColor( "N/W, W/N, , , W/N" )
cRet := FT_ArEdit( 3, 5, 18, 75, ar, @nElem, aHeadings, aBlocks, bGetFunc )
SetColor( "W/N" )
CLS
? cRet
? "Lastkey() = ESC:", LastKey() == K_ESC
RETURN
FUNCTION TestGet( b, ar, nDim, nElem)
LOCAL GetList := {}
LOCAL nRow := ROW()
LOCAL nCol := COL()
LOCAL cSaveScrn := SAVESCREEN(21, 0, 22, MaxCol())
LOCAL cOldColor := SetColor( "W/N")
@ 21, 0 CLEAR TO 22, MaxCol()
@ 21,29 SAY "Editing Array Element"
SetColor(cOldColor)
DO CASE
CASE nDim == 1
@ nRow, nCol GET ar[1, nElem] PICTURE "99"
READ
b:refreshAll()
CASE nDim == 2
@ nRow, nCol GET ar[2, nElem] PICTURE "!"
READ
b:refreshAll()
CASE nDim == 3
@ nRow, nCol GET ar[3, nElem] PICTURE "!"
READ
b:refreshAll()
ENDCASE
RESTSCREEN(21, 0, 22, MaxCol(), cSaveScrn)
@ nRow, nCol SAY ""
RETURN .t.
FUNCTION TestGet( b, ar, nDim, nElem )
LOCAL GetList := {}
LOCAL nRow := Row()
LOCAL nCol := Col()
LOCAL cSaveScrn := SaveScreen( 21, 0, 22, MaxCol() )
LOCAL cOldColor := SetColor( "W/N" )
@ 21, 0 CLEAR TO 22, MaxCol()
@ 21, 29 SAY "Editing Array Element"
SetColor( cOldColor )
DO CASE
CASE nDim == 1
@ nRow, nCol GET ar[1, nElem] PICTURE "99"
READ
b:refreshAll()
CASE nDim == 2
@ nRow, nCol GET ar[2, nElem] PICTURE "!"
READ
b:refreshAll()
CASE nDim == 3
@ nRow, nCol GET ar[3, nElem] PICTURE "!"
READ
b:refreshAll()
ENDCASE
RestScreen( 21, 0, 22, MaxCol(), cSaveScrn )
@ nRow, nCol SAY ""
RETURN .T.
#endif
FUNCTION FT_ArEdit( nTop, nLeft, nBot, nRight, ;
ar, nElem, aHeadings, aBlocks, bGetFunc)
* ANYTYPE[] ar - Array to browse
* NUMERIC nElem - Element In Array
* CHARACTER[] aHeadings - Array of Headings for each column
* BLOCK[] aBlocks - Array containing code block for each column.
* CODE BLOCK bGetFunc - Code Block For Special Get Processing
* NOTE: When evaluated a code block is passed the array element to
* be edited
ar, nElem, aHeadings, aBlocks, bGetFunc )
LOCAL exit_requested, nKey, meth_no, ;
cSaveWin, i, b, column
// ANYTYPE[] ar - Array to browse
// NUMERIC nElem - Element In Array
// CHARACTER[] aHeadings - Array of Headings for each column
// BLOCK[] aBlocks - Array containing code block for each column.
// CODE BLOCK bGetFunc - Code Block For Special Get Processing
// NOTE: When evaluated a code block is passed the array element to
// be edited
LOCAL exit_requested, nKey, meth_no
LOCAL cSaveWin, i, b, column
LOCAL nDim, cType, cVal
LOCAL tb_methods := ;
{ ;
{K_DOWN, {|b| b:down()}}, ;
{K_UP, {|b| b:up()}}, ;
{K_PGDN, {|b| b:pagedown()}}, ;
{K_PGUP, {|b| b:pageup()}}, ;
{K_CTRL_PGUP, {|b| b:gotop()}}, ;
{K_CTRL_PGDN, {|b| b:gobottom()}}, ;
{K_RIGHT, {|b| b:right()}}, ;
{K_LEFT, {|b| b:left()}}, ;
{K_HOME, {|b| b:home()}}, ;
{K_END, {|b| b:end()}}, ;
{K_CTRL_LEFT, {|b| b:panleft()}}, ;
{K_CTRL_RIGHT, {|b| b:panright()}}, ;
{K_CTRL_HOME, {|b| b:panhome()}}, ;
{K_CTRL_END, {|b| b:panend()}} ;
}
{ ;
{ K_DOWN, {| b | b:down() } }, ;
{ K_UP, {| b | b:up() } }, ;
{ K_PGDN, {| b | b:pagedown() } }, ;
{ K_PGUP, {| b | b:pageup() } }, ;
{ K_CTRL_PGUP, {| b | b:gotop() } }, ;
{ K_CTRL_PGDN, {| b | b:gobottom() } }, ;
{ K_RIGHT, {| b | b:Right() } }, ;
{ K_LEFT, {| b | b:Left() } }, ;
{ K_HOME, {| b | b:home() } }, ;
{ K_END, {| b | b:end() } }, ;
{ K_CTRL_LEFT, {| b | b:panleft() } }, ;
{ K_CTRL_RIGHT, {| b | b:panright() } }, ;
{ K_CTRL_HOME, {| b | b:panhome() } }, ;
{ K_CTRL_END, {| b | b:panend() } } ;
}
cSaveWin := SaveScreen(nTop, nLeft, nBot, nRight)
cSaveWin := SaveScreen( nTop, nLeft, nBot, nRight )
@ nTop, nLeft TO nBot, nRight
b := TBrowseNew(nTop + 1, nLeft + 1, nBot - 1, nRight - 1)
b := TBRowseNew( nTop + 1, nLeft + 1, nBot - 1, nRight - 1 )
b:headsep := DEF_HSEP
b:colsep := DEF_CSEP
b:footsep := DEF_FSEP
b:gotopblock := {|| nElem := 1}
b:gobottomblock := {|| nElem := LEN(ar[1])}
b:gotopblock := {|| nElem := 1 }
b:gobottomblock := {|| nElem := Len( ar[1] ) }
* skipblock originally coded by Robert DiFalco
b:SkipBlock := {|nSkip, nStart| nStart := nElem,;
nElem := MAX( 1, MIN( LEN(ar[1]), nElem + nSkip ) ),;
// skipblock originally coded by Robert DiFalco
b:SkipBlock := {| nSkip, nStart | nStart := nElem, ;
nElem := Max( 1, Min( Len(ar[1] ), nElem + nSkip ) ), ;
nElem - nStart }
FOR i := 1 TO LEN(aBlocks)
column := TBColumnNew(aHeadings[i], aBlocks[i] )
b:addcolumn(column)
FOR i := 1 TO Len( aBlocks )
column := TBColumnNew( aHeadings[i], aBlocks[i] )
b:addcolumn( column )
NEXT
exit_requested := .F.
DO WHILE !exit_requested
DO WHILE NEXTKEY() == 0 .AND. !b:stabilize()
DO WHILE NextKey() == 0 .AND. !b:stabilize()
ENDDO
nKey := INKEY(0)
nKey := Inkey( 0 )
meth_no := ASCAN(tb_methods, {|elem| nKey == elem[KEY_ELEM]})
meth_no := AScan( tb_methods, {| elem | nKey == elem[KEY_ELEM] } )
IF meth_no != 0
EVAL(tb_methods[meth_no, BLK_ELEM], b)
Eval( tb_methods[meth_no, BLK_ELEM], b )
ELSE
DO CASE
CASE nKey == K_F7
FOR nDim := 1 TO LEN(ar)
ADEL(ar[nDim], nElem)
ASIZE(ar[nDim], LEN(ar[nDim]) - 1)
NEXT
b:refreshAll()
DO CASE
CASE nKey == K_F7
FOR nDim := 1 TO Len( ar )
ADel( ar[nDim], nElem )
ASize( ar[nDim], Len( ar[nDim] ) - 1 )
NEXT
b:refreshAll()
CASE nKey == K_F8
FOR nDim := 1 TO LEN(ar)
* check valtype of current element before AINS()
cType := VALTYPE(ar[nDim, nElem])
cVal := ar[nDim, nElem]
ASIZE(ar[nDim], LEN(ar[nDim]) + 1)
AINS(ar[nDim], nElem)
IF cType == "C"
ar[nDim, nElem] := SPACE(LEN(cVal))
ELSEIF cType == "N"
ar[nDim, nElem] := 0
ELSEIF cType == "L"
ar[nDim, nElem] := .f.
ELSEIF cType == "D"
ar[nDim, nElem] := CTOD(" / / ")
ENDIF
NEXT
b:refreshAll()
CASE nKey == K_F8
FOR nDim := 1 TO Len( ar )
// check valtype of current element before AINS()
cType := ValType( ar[nDim, nElem] )
cVal := ar[nDim, nElem]
ASize( ar[nDim], Len( ar[nDim] ) + 1 )
AIns( ar[nDim], nElem )
IF cType == "C"
ar[nDim, nElem] := Space( Len( cVal ) )
ELSEIF cType == "N"
ar[nDim, nElem] := 0
ELSEIF cType == "L"
ar[nDim, nElem] := .F.
ELSEIF cType == "D"
ar[nDim, nElem] := CToD( " / / " )
ENDIF
NEXT
b:refreshAll()
CASE nKey == K_ESC
exit_requested := .T.
CASE nKey == K_ESC
exit_requested := .T.
* Other exception handling ...
CASE VALTYPE(bGetFunc) == "B"
IF nKey != K_ENTER
* want last key to be part of GET edit so KEYBOARD it
KEYBOARD CHR(LASTKEY())
ENDIF
EVAL(bGetFunc, b, ar, b:colPos, nElem )
* after get move to next field
KEYBOARD iif(b:colPos < b:colCount, ;
CHR(K_RIGHT), CHR(K_HOME) + CHR(K_DOWN) )
// Other exception handling ...
CASE ValType( bGetFunc ) == "B"
IF nKey != K_ENTER
// want last key to be part of GET edit so KEYBOARD it
KEYBOARD Chr( LastKey() )
ENDIF
Eval( bGetFunc, b, ar, b:colPos, nElem )
// after get move to next field
KEYBOARD iif( b:colPos < b:colCount, ;
Chr( K_RIGHT ), Chr( K_HOME ) + Chr( K_DOWN ) )
* Placing K_ENTER here below Edit Block (i.e. bGetFunc)
* defaults K_ENTER to Edit when bGetFunc Is Present
* BUT if no bGetFunc, then K_ENTER selects element to return
CASE nKey == K_ENTER
exit_requested := .T.
// Placing K_ENTER here below Edit Block (i.e. bGetFunc)
// defaults K_ENTER to Edit when bGetFunc Is Present
// BUT if no bGetFunc, then K_ENTER selects element to return
CASE nKey == K_ENTER
exit_requested := .T.
ENDCASE
ENDCASE
ENDIF // meth_no != 0
ENDDO // WHILE !exit_requested
RestScreen(nTop, nLeft, nBot, nRight, cSaveWin)
* if no bGetFunc then ESC returns 0, otherwise return value of last element
RETURN iif( VALTYPE(bGetFunc) == NIL .AND. nKey == K_ESC, ;
0, ar[b:colPos, nElem] )
* EOFcn FT_ArEdit()
RestScreen( nTop, nLeft, nBot, nRight, cSaveWin )
// if no bGetFunc then ESC returns 0, otherwise return value of last element
RETURN iif( ValType( bGetFunc ) == NIL .AND. nKey == K_ESC, ;
0, ar[b:colPos, nElem] )

37
harbour/contrib/hbnf/asum.prg
View File

@@ -24,31 +24,28 @@
*
*/
#include "common.ch"
#define CASE_AT(x,y,z) z[AT(x,y)+1]
#define FORCE_BETWEEN(x,y,z) (y := MAX(MIN(y,z),x))
#define IS_CHAR(x) (VALTYPE(x) == "C")
#command DEFAULT <Param1> TO <Def1> [, <ParamN> TO <DefN> ] ;
=> ;
<Param1> := iif(<Param1> == NIL,<Def1>,<Param1>) ;
[; <ParamN> := iif(<ParamN> == NIL,<DefN>,<ParamN>)]
FUNCTION FT_ASUM(aArray, nStartIndex, nEndIndex)
FUNCTION FT_ASUM( aArray, nStartIndex, nEndIndex )
LOCAL nSumTotal := 0 // Array Sum
DEFAULT nStartIndex TO 1, ;
nEndIndex TO LEN(aArray)
// Make Sure Bounds are in Range
FORCE_BETWEEN(1, nEndIndex, LEN(aArray))
FORCE_BETWEEN(1, nStartIndex, nEndIndex)
DEFAULT nStartIndex TO 1
DEFAULT nEndIndex TO Len( aArray )
AEVAL(aArray, ;
{ | xElement | ;
nSumTotal += ;
CASE_AT(VALTYPE(xElement), "NC", ;
{ 0, xElement, ;
iif(IS_CHAR(xElement),LEN(xElement),0) }) }, ;
nStartIndex, nEndIndex - nStartIndex + 1)
// Make Sure Bounds are in Range
FORCE_BETWEEN( 1, nEndIndex, Len( aArray ) )
FORCE_BETWEEN( 1, nStartIndex, nEndIndex )
RETURN nSumTotal // FT_ASum
AEval( aArray, ;
{| xElement | ;
nSumTotal += ;
CASE_AT( ValType( xElement ), "NC", ;
{ 0, xElement, ;
iif( HB_ISSTRING( xElement ), Len( xElement ), 0 ) } ) }, ;
nStartIndex, nEndIndex - nStartIndex + 1 )
RETURN nSumTotal

34
harbour/contrib/hbnf/at2.prg
View File

@@ -30,7 +30,9 @@
#ifdef FT_TEST
PROCEDURE Main()
LOCAL cSearch,cTarget,var0
LOCAL cSearch, cTarget, var0
CLS
? "TEST TO DEMONSTRATE EXAMPLES OF FT_AT2"
?
@@ -40,17 +42,18 @@ PROCEDURE Main()
?? cTarget
?
var0 := ft_at2( cSearch, cTarget )
? PADR("FT_AT2( cSearch, cTarget ) -> ",40)
? PadR( "FT_AT2( cSearch, cTarget ) -> ", 40 )
?? var0
?
var0 := ft_at2( cSearch, cTarget, 2 )
? PADR("FT_AT2( cSearch, cTarget, 2 ) -> ",40)
? PadR( "FT_AT2( cSearch, cTarget, 2 ) -> ", 40 )
??var0
?
var0 := ft_at2( cSearch, cTarget, 2, .F. )
? PADR("FT_AT2( cSearch, cTarget, 2, .F. ) -> ",40)
? PadR( "FT_AT2( cSearch, cTarget, 2, .F. ) -> ", 40 )
??var0
?
RETURN
#endif
@@ -60,7 +63,7 @@ FUNCTION FT_AT2( cSearch, cTarget, nOccurs, lCaseSens )
LOCAL nCount, nPos, nPos2 := 0
LOCAL cSubstr := cTarget
// Set default parameters as necessary.
// Set default parameters as necessary.
IF lCaseSens == NIL
lCaseSens := .T.
ENDIF
@@ -73,10 +76,10 @@ FUNCTION FT_AT2( cSearch, cTarget, nOccurs, lCaseSens )
// Store position of next occurrence of cSearch.
IF lCaseSens
nPos := AT( cSearch, cSubstr )
nPos := At( cSearch, cSubstr )
ELSE
nPos := AT( UPPER( cSearch ), UPPER( cSubstr ) )
nPos := At( Upper( cSearch ), Upper( cSubstr ) )
ENDIF
@@ -84,12 +87,12 @@ FUNCTION FT_AT2( cSearch, cTarget, nOccurs, lCaseSens )
nPos2 += nPos
// Resize cSubstr
cSubstr := SUBSTR( cSubstr, AT( cSearch, cSubstr ) +1 )
cSubstr := SubStr( cSubstr, At( cSearch, cSubstr ) + 1 )
// Breakout if there are no occurences here
IF nPos == 0
EXIT
EXIT
ENDIF
NEXT
@@ -97,9 +100,11 @@ FUNCTION FT_AT2( cSearch, cTarget, nOccurs, lCaseSens )
RETURN nPos2
FUNCTION FT_RAT2( cSearch, cTarget, nOccurs, lCaseSens )
LOCAL nCount, nPos, nPos2 := 0
LOCAL cSubstr := cTarget
// Set default parameters as necessary.
// Set default parameters as necessary.
IF lCaseSens == NIL
lCaseSens := .T.
ENDIF
@@ -109,17 +114,18 @@ FUNCTION FT_RAT2( cSearch, cTarget, nOccurs, lCaseSens )
FOR nCount := 1 TO nOccurs
// Store position of next occurrence of cSearch.
IF lCaseSens
nPos := RAT( cSearch, cSubstr )
nPos := RAt( cSearch, cSubstr )
ELSE
nPos := RAT( UPPER( cSearch ), UPPER( cSubstr ) )
nPos := RAt( Upper( cSearch ), Upper( cSubstr ) )
ENDIF
// Store position of cSearch relative to original string.
nPos2 := nPos
// Resize cSubstr
cSubstr := SUBSTR( cSubstr, 1, RAT( cSearch, cSubstr ) - 1 )
cSubstr := SubStr( cSubstr, 1, RAt( cSearch, cSubstr ) - 1 )
// Breakout if there are no occurences here
IF nPos == 0
EXIT
EXIT
ENDIF
NEXT
RETURN nPos2

26
harbour/contrib/hbnf/bitclr.prg
View File

@@ -24,19 +24,19 @@
*
*/
FUNCTION FT_BITCLR(cInbyte, nBitpos)
FUNCTION FT_BITCLR( cInbyte, nBitpos )
LOCAL cByte
LOCAL cByte
IF valtype(cInbyte) != "C" .or. valtype(nBitpos) != "N" // parameter check
cByte := NIL
ELSE
IF (nBitPos > 7) .or. (nBitPos < 0) .or. (nBitPos != int(nBitPos))
cByte := NIL
ELSE
cByte := iif( .not. FT_ISBIT(cInByte, nBitpos), cInByte, ;
chr(asc(cInByte) - (2 ^ nBitpos)))
ENDIF
ENDIF
IF ValType( cInbyte ) != "C" .OR. ValType( nBitpos ) != "N" // parameter check
cByte := NIL
ELSE
IF nBitPos > 7 .OR. nBitPos < 0 .OR. nBitPos != Int( nBitPos )
cByte := NIL
ELSE
cByte := iif( ! FT_ISBIT( cInByte, nBitpos ), cInByte, ;
Chr( Asc( cInByte ) - ( 2 ^ nBitpos ) ) )
ENDIF
ENDIF
RETURN cByte
RETURN cByte

26
harbour/contrib/hbnf/bitset.prg
View File

@@ -24,19 +24,19 @@
*
*/
FUNCTION FT_BITSET(cInByte, nBitpos)
FUNCTION FT_BITSET( cInByte, nBitpos )
LOCAL cByte
LOCAL cByte
IF valtype(cInbyte) != "C" .or. valtype(nBitpos) != "N" // parameter check
cByte := NIL
ELSE
IF (nBitPos > 7) .or. (nBitPos < 0) .or. (nBitPos != int(nBitPos))
cByte := NIL
ELSE
cByte := iif( FT_ISBIT(cInByte, nBitpos), cInByte, ;
chr(asc(cInByte) + (2 ^ nBitpos)))
ENDIF
ENDIF
IF ValType( cInbyte ) != "C" .OR. ValType( nBitpos ) != "N" // parameter check
cByte := NIL
ELSE
IF nBitPos > 7 .OR. nBitPos < 0 .OR. nBitPos != Int( nBitPos )
cByte := NIL
ELSE
cByte := iif( FT_ISBIT( cInByte, nBitpos ), cInByte, ;
Chr( Asc( cInByte ) + ( 2 ^ nBitpos ) ) )
ENDIF
ENDIF
RETURN cByte
RETURN cByte

38
harbour/contrib/hbnf/blink.prg
View File

@@ -25,29 +25,35 @@
*/
#ifdef FT_TEST
PROCEDURE Main()
FT_BLINK( "WAIT", 5, 10 )
RETURN
PROCEDURE Main()
FT_BLINK( "WAIT", 5, 10 )
RETURN
#endif
FUNCTION FT_BLINK( cMsg, nRow, nCol )
* Declare color restore var.
LOCAL cSavColor
// Declare color restore var.
LOCAL cSavColor
* Return if no msg.
IF (cMsg == NIL) ; RETURN NIL; ENDIF
// Return if no msg.
IF cMsg == NIL
RETURN NIL
ENDIF
* Set default row and col to current.
nRow := iif( nRow == NIL, ROW(), nRow )
nCol := iif( nCol == NIL, COL(), nCol )
// Set default row and col to current.
nRow := iif( nRow == NIL, Row(), nRow )
nCol := iif( nCol == NIL, Col(), nCol )
cSavColor := SETCOLOR() // Save colors to restore on exit.
cSavColor := SetColor() // Save colors to restore on exit.
* IF blink colors not already set, add blink to current foreground color.
SETCOLOR( iif( ("*" $ LEFT(cSavColor,4)), cSavColor, "*" + cSavColor ) )
// IF blink colors not already set, add blink to current foreground color.
SetColor( iif( ( "*" $ Left( cSavColor, 4 ) ), cSavColor, "*" + cSavColor ) )
@ nRow, nCol SAY cMsg // Say the dreaded blinking msg.
SETCOLOR( cSavColor ) // It's a wrap, restore colors & exit.
@ nRow, nCol SAY cMsg // Say the dreaded blinking msg.
SetColor( cSavColor ) // It's a wrap, restore colors & exit.
RETURN NIL
RETURN NIL

22
harbour/contrib/hbnf/byt2bit.prg
View File

@@ -24,17 +24,17 @@
*
*/
FUNCTION FT_BYT2BIT(cByte)
FUNCTION FT_BYT2BIT( cByte )
local nCounter, xBitstring
LOCAL nCounter, xBitstring
IF valtype(cByte) != "C"
xBitString := NIL
ELSE
xBitString := ""
FOR nCounter := 7 TO 0 step -1
xBitString += iif(FT_ISBIT(cByte, nCounter), "1", "0")
NEXT
ENDIF
IF ValType( cByte ) != "C"
xBitString := NIL
ELSE
xBitString := ""
FOR nCounter := 7 TO 0 step - 1
xBitString += iif( FT_ISBIT( cByte, nCounter ), "1", "0" )
NEXT
ENDIF
RETURN xBitString
RETURN xBitString

22
harbour/contrib/hbnf/byt2hex.prg
View File

@@ -24,17 +24,17 @@
*
*/
FUNCTION FT_BYT2HEX(cByte)
FUNCTION FT_BYT2HEX( cByte )
local cHexTable := "0123456789ABCDEF"
local xHexString
LOCAL cHexTable := "0123456789ABCDEF"
LOCAL xHexString
if valtype(cByte) != "C"
xHexString := NIL
else
xHexString := substr(cHexTable, int(asc(cByte) / 16) + 1, 1) ;
+ substr(cHexTable, int(asc(cByte) % 16) + 1, 1) ;
+ "h"
endif
IF ValType( cByte ) != "C"
xHexString := NIL
ELSE
xHexString := SubStr( cHexTable, Int( Asc( cByte ) / 16 ) + 1, 1 ) ;
+ SubStr( cHexTable, Int( Asc( cByte ) % 16 ) + 1, 1 ) ;
+ "h"
ENDIF
RETURN xHexString
RETURN xHexString

26
harbour/contrib/hbnf/byteand.prg
View File

@@ -24,19 +24,19 @@
*
*/
FUNCTION FT_BYTEAND(cByte1, cByte2)
FUNCTION FT_BYTEAND( cByte1, cByte2 )
LOCAL nCounter, cNewByte
LOCAL nCounter, cNewByte
IF valtype(cByte1) != "C" .or. valtype(cByte2) != "C" // parameter check
cNewByte := NIL
ELSE
cNewByte := chr(0)
for nCounter := 0 to 7 // test each bit position
if FT_ISBIT(cByte1, nCounter) .and. FT_ISBIT(cByte2, nCounter)
cNewByte := FT_BITSET(cNewByte, nCounter)
endif
next
ENDIF
IF ValType( cByte1 ) != "C" .OR. ValType( cByte2 ) != "C" // parameter check
cNewByte := NIL
ELSE
cNewByte := Chr( 0 )
FOR nCounter := 0 TO 7 // test each bit position
IF FT_ISBIT( cByte1, nCounter ) .AND. FT_ISBIT( cByte2, nCounter )
cNewByte := FT_BITSET( cNewByte, nCounter )
ENDIF
NEXT
ENDIF
RETURN cNewByte
RETURN cNewByte

4
harbour/contrib/hbnf/byteneg.prg
View File

@@ -24,5 +24,5 @@
*
*/
FUNCTION FT_BYTENEG(cByte)
RETURN iif(valtype(cByte) != "C", NIL, chr((256 - asc(cByte)) % 256))
FUNCTION FT_BYTENEG( cByte )
RETURN iif( ValType( cByte ) != "C", NIL, Chr( ( 256 - Asc( cByte ) ) % 256 ) )

26
harbour/contrib/hbnf/bytenot.prg
View File

@@ -25,19 +25,19 @@
*
*/
FUNCTION FT_BYTENOT(cByte)
FUNCTION FT_BYTENOT( cByte )
LOCAL nCounter, cNewByte
LOCAL nCounter, cNewByte
IF valtype(cByte) != "C"
cNewByte := NIL
ELSE
cNewByte := chr(0)
FOR nCounter := 0 to 7 // test each bit position
IF .not. FT_ISBIT(cByte, nCounter)
cNewByte := FT_BITSET(cNewByte, nCounter)
ENDIF
NEXT
ENDIF
IF ValType( cByte ) != "C"
cNewByte := NIL
ELSE
cNewByte := Chr( 0 )
FOR nCounter := 0 TO 7 // test each bit position
IF ! FT_ISBIT( cByte, nCounter )
cNewByte := FT_BITSET( cNewByte, nCounter )
ENDIF
NEXT
ENDIF
RETURN cNewByte
RETURN cNewByte

26
harbour/contrib/hbnf/byteor.prg
View File

@@ -24,19 +24,19 @@
*
*/
FUNCTION FT_BYTEOR(cByte1, cByte2)
FUNCTION FT_BYTEOR( cByte1, cByte2 )
LOCAL nCounter, cNewByte
LOCAL nCounter, cNewByte
IF valtype(cByte1) != "C" .or. valtype(cByte2) != "C" // parameter check
cNewByte := NIL
ELSE
cNewByte := chr(0)
for nCounter := 0 to 7 // test each bit position
if FT_ISBIT(cByte1, nCounter) .or. FT_ISBIT(cByte2, nCounter)
cNewByte := FT_BITSET(cNewByte, nCounter)
endif
next
ENDIF
IF ValType( cByte1 ) != "C" .OR. ValType( cByte2 ) != "C" // parameter check
cNewByte := NIL
ELSE
cNewByte := Chr( 0 )
FOR nCounter := 0 TO 7 // test each bit position
IF FT_ISBIT( cByte1, nCounter ) .OR. FT_ISBIT( cByte2, nCounter )
cNewByte := FT_BITSET( cNewByte, nCounter )
ENDIF
NEXT
ENDIF
RETURN cNewByte
RETURN cNewByte

30
harbour/contrib/hbnf/bytexor.prg
View File

@@ -27,21 +27,21 @@
*
*/
FUNCTION FT_BYTEXOR(cByte1, cByte2)
FUNCTION FT_BYTEXOR( cByte1, cByte2 )
LOCAL nCounter, cNewByte
LOCAL nCounter, cNewByte
IF valtype(cByte1) != "C" .or. valtype(cByte2) != "C" // parameter check
cNewByte := NIL
ELSE
cNewByte := chr(0)
FOR nCounter := 0 to 7 // test each bit position
IF FT_ISBIT(cByte1, nCounter) .or. FT_ISBIT(cByte2, nCounter)
IF .not. (FT_ISBIT(cByte1, nCounter) .and. FT_ISBIT(cByte2, nCounter))
cNewByte := FT_BITSET(cNewByte, nCounter)
ENDIF
ENDIF
NEXT
ENDIF
IF ValType( cByte1 ) != "C" .OR. ValType( cByte2 ) != "C" // parameter check
cNewByte := NIL
ELSE
cNewByte := Chr( 0 )
FOR nCounter := 0 TO 7 // test each bit position
IF FT_ISBIT( cByte1, nCounter ) .OR. FT_ISBIT( cByte2, nCounter )
IF ! ( FT_ISBIT( cByte1, nCounter ) .AND. FT_ISBIT( cByte2, nCounter ) )
cNewByte := FT_BITSET( cNewByte, nCounter )
ENDIF
ENDIF
NEXT
ENDIF
RETURN cNewByte
RETURN cNewByte

210
harbour/contrib/hbnf/calendar.prg
View File

@@ -24,136 +24,142 @@
#include "setcurs.ch"
#ifdef FT_TEST
PROCEDURE Main()
local aRet[8], i
setcolor ('w+/b')
PROCEDURE Main()
LOCAL aRet[ 8 ], i
SetColor( 'w+/b' )
cls
if ft_numlock()
ft_numlock( .f. )
endif
keyboard chr (28)
aRet := ft_calendar (10,40,'w+/rb',.t.,.t.) //display calendar, return all.
@ 1,0 say 'Date :'+dtoc(aRet[1])
@ 2,0 say 'Month Number:'+str(aRet[2],2,0)
@ 3,0 say 'Day Number :'+str(aRet[3],2,0)
@ 4,0 say 'Year Number :'+str(aRet[4],4,0)
@ 5,0 say 'Month :'+aRet[5]
@ 6,0 say 'Day :'+aRet[6]
@ 7,0 say 'Julian Day :'+str(aRet[7],3,0)
@ 8,0 say 'Current Time:'+aRet[8]
IF ft_numlock()
ft_numlock( .F. )
ENDIF
KEYBOARD Chr( 28 )
aRet := ft_calendar( 10, 40, 'w+/rb', .T. , .T. ) //display calendar, return all.
@ 1, 0 SAY 'Date :' + DToC( aRet[ 1 ] )
@ 2, 0 SAY 'Month Number:' + Str( aRet[ 2 ], 2, 0 )
@ 3, 0 SAY 'Day Number :' + Str( aRet[ 3 ], 2, 0 )
@ 4, 0 SAY 'Year Number :' + Str( aRet[ 4 ], 4, 0 )
@ 5, 0 SAY 'Month :' + aRet[ 5 ]
@ 6, 0 SAY 'Day :' + aRet[ 6 ]
@ 7, 0 SAY 'Julian Day :' + Str( aRet[ 7 ], 3, 0 )
@ 8, 0 SAY 'Current Time:' + aRet[ 8 ]
RETURN
#endif
#include "inkey.ch"
FUNCTION FT_CALENDAR (nRow, nCol, cColor, lShadow, lShowHelp)
FUNCTION FT_CALENDAR( nRow, nCol, cColor, lShadow, lShowHelp )
LOCAL nJump :=0, nKey :=0, cSavColor, cSaveScreen, cSaveCursor
LOCAL aRetVal[8]
LOCAL nHelpRow, cSaveHelp, lHelpIsDisplayed :=.F.
LOCAL nJump := 0, nKey := 0, cSavColor, cSaveScreen, cSaveCursor
LOCAL aRetVal[8]
LOCAL nHelpRow, cSaveHelp, lHelpIsDisplayed := .F.
nRow := iif( nRow != NIL, nRow, 1 ) //check display row
nCol := iif( nCol != NIL, nCol, 63) //check display col
cColor := iif( cColor != NIL, cColor, 'W+/G' ) //check display color
lShadow := iif( lShadow == NIL , .F., lShadow ) //check shadow switch
lShowHelp := iif( lShowHelp == NIL , .F., lShowHelp )//check help switch
nRow := iif( nRow != NIL, nRow, 1 ) //check display row
nCol := iif( nCol != NIL, nCol, 63 ) //check display col
cColor := iif( cColor != NIL, cColor, 'W+/G' ) //check display color
lShadow := iif( lShadow == NIL , .F. , lShadow ) //check shadow switch
lShowHelp := iif( lShowHelp == NIL , .F. , lShowHelp )//check help switch
nRow := iif( nRow <1 .OR. nRow >21, 1, nRow ) //check row bounds
nCol := iif( nCol <1 .OR. nCol >63, 63, nCol ) //check col bounds
nRow := iif( nRow < 1 .OR. nRow > 21, 1, nRow ) //check row bounds
nCol := iif( nCol < 1 .OR. nCol > 63, 63, nCol ) //check col bounds
cSavColor := SETCOLOR(cColor) //save current and set display color
cSaveScreen := SAVESCREEN( nRow-1, nCol-1, nRow+3, nCol+17 ) //save screen
cSaveCursor := SETCURSOR( SC_NONE ) // save current and turn off cursor
cSavColor := SetColor( cColor ) //save current and set display color
cSaveScreen := SaveScreen( nRow - 1, nCol - 1, nRow + 3, nCol + 17 ) //save screen
cSaveCursor := SetCursor( SC_NONE ) // save current and turn off cursor
IF lShadow
@nRow-1,nCol-1 to nRow+2, nCol+15
FT_SHADOW( nRow-1, nCol-1, nRow+2, nCol+15 )
ENDIF
IF lShadow
@nRow - 1, nCol - 1 TO nRow + 2, nCol + 15
FT_SHADOW( nRow - 1, nCol - 1, nRow + 2, nCol + 15 )
ENDIF
IF lShowHelp
nHelpRow := iif(nRow > 10 , nRow - 10 , nRow + 6 )
ENDIF
IF lShowHelp
nHelpRow := iif( nRow > 10 , nRow - 10 , nRow + 6 )
ENDIF
DO WHILE nKey != K_ESC
DO WHILE nKey != K_ESC
DO CASE
CASE nKey == K_HOME
nJump := nJump - 1
DO CASE
CASE nKey == K_HOME
nJump := nJump - 1
CASE nKey == K_END
nJump := nJump + 1
CASE nKey == K_END
nJump := nJump + 1
CASE nKey == K_UP
nJump := nJump - 30
CASE nKey == K_UP
nJump := nJump - 30
CASE nKey == K_DOWN
nJump := nJump + 30
CASE nKey == K_DOWN
nJump := nJump + 30
CASE nKey == K_PGUP
nJump := nJump - 365
CASE nKey == K_PGUP
nJump := nJump - 365
CASE nKey == K_PGDN
nJump := nJump + 365
CASE nKey == K_PGDN
nJump := nJump + 365
CASE nKey == K_RIGHT
nJump := nJump - 7
CASE nKey == K_RIGHT
nJump := nJump - 7
CASE nKey == K_LEFT
nJump := nJump + 7
CASE nKey == K_LEFT
nJump := nJump + 7
CASE nKey == K_INS
nJump := 0
CASE nKey == K_INS
nJump := 0
CASE nKey == K_F1
IF lShowHelp .AND. .NOT. lHelpIsDisplayed
lHelpIsDisplayed := .T.
cSaveHelp := SAVESCREEN ( nHelpRow-1, 1, nHelpRow+7, 80)
FT_XBOX('L',,,cColor,cColor,nHelpRow,1,;
"Home, Up_Arrow or PgUp keys page by day, month or year to a past date.",;
"End, Dn_Arrow or PgDn keys page by day, month or year to a future date.",;
"Left_Arrow or Right_Arrow keys page by week to a past or future date.",;
"Hit Ins to reset to today's date, F1 to get this help, ESC to quit.")
ENDIF
CASE nKey == K_F1
IF lShowHelp .AND. ! lHelpIsDisplayed
lHelpIsDisplayed := .T.
cSaveHelp := SaveScreen ( nHelpRow - 1, 1, nHelpRow + 7, 80 )
FT_XBOX( 'L', , , cColor, cColor, nHelpRow, 1, ;
"Home, Up_Arrow or PgUp keys page by day, month or year to a past date.", ;
"End, Dn_Arrow or PgDn keys page by day, month or year to a future date.", ;
"Left_Arrow or Right_Arrow keys page by week to a past or future date.", ;
"Hit Ins to reset to today's date, F1 to get this help, ESC to quit." )
ENDIF
OTHERWISE
ENDCASE
OTHERWISE
ENDCASE
aRetVal[1] := DATE() + nJump
aRetVal[2] := MONTH( DATE() + nJump )
aRetVal[3] := DAY( DATE() + nJump )
aRetVal[4] := YEAR( DATE() + nJump )
aRetVal[5] := CMONTH( DATE() + nJump )
aRetVal[6] := CDOW( DATE() + nJump )
aRetVal[7] := JDOY( aRetVal[4], aRetVal[2], aRetVal[3] )
aRetVal[ 1 ] := Date() + nJump
aRetVal[ 2 ] := Month( Date() + nJump )
aRetVal[ 3 ] := Day( Date() + nJump )
aRetVal[ 4 ] := Year( Date() + nJump )
aRetVal[ 5 ] := CMonth( Date() + nJump )
aRetVal[ 6 ] := CDOW( Date() + nJump )
aRetVal[ 7 ] := JDOY( aRetVal[ 4 ], aRetVal[ 2 ], aRetVal[ 3 ] )
@nRow, nCol SAY SUBSTR(aRetval[6],1,3)+' '+;
STR(aRetVal[3],2,0)+' '+;
SUBSTR(aRetVal[5],1,3)+' '+;
STR(aRetVal[4],4,0)
@nRow+1,nCol SAY STR(aRetVal[7],3,0)
@ nRow, nCol SAY SubStr( aRetval[ 6 ], 1, 3 ) + ' ' + ;
Str( aRetVal[ 3 ], 2, 0 ) + ' ' + ;
SubStr( aRetVal[ 5 ], 1, 3 ) + ' ' + ;
Str( aRetVal[ 4 ], 4, 0 )
@ nRow + 1, nCol SAY Str( aRetVal[ 7 ], 3, 0 )
nKey := 0
DO WHILE nKey == 0
@nRow+1,nCol+3 SAY ' '+TIME()
nKey := INKEY(1)
ENDDO
aRetVal[8] := TIME()
ENDDO
nKey := 0
DO WHILE nKey == 0
@ nRow + 1, nCol + 3 SAY ' ' + Time()
nKey := Inkey( 1 )
ENDDO
aRetVal[ 8 ] := Time()
ENDDO
SETCOLOR ( cSavColor ) //restore colors.
SETCURSOR ( cSaveCursor ) //restore cursor.
RESTSCREEN ( nRow-1, nCol-1, nRow+3, nCol+17, cSaveScreen ) //restore screen.
IF lHelpIsDisplayed
RESTSCREEN (nHelpRow-1, 1, nHelpRow+7, 80, cSaveHelp)
ENDIF
RETURN aRetVal
SetColor( cSavColor ) //restore colors.
SetCursor( cSaveCursor ) //restore cursor.
RestScreen( nRow - 1, nCol - 1, nRow + 3, nCol + 17, cSaveScreen ) //restore screen.
IF lHelpIsDisplayed
RestScreen( nHelpRow - 1, 1, nHelpRow + 7, 80, cSaveHelp )
ENDIF
STATIC FUNCTION JDOY (nYear, nMonth, nDay)
LOCAL cString :='000031059090120151181212243273304334'
RETURN VALS(cString,(nMonth-1)*3+1,3) + nDay +;
iif( nYear%4==0.AND.nMonth>2, 1, 0)
RETURN aRetVal
STATIC FUNCTION VALS (cString, nOffset, nChar)
RETURN VAL(SUBSTR(cString,nOffset,nChar))
STATIC FUNCTION JDOY( nYear, nMonth, nDay )
* end of calendar.prg
LOCAL cString := '000031059090120151181212243273304334'
RETURN VALS( cString, ( nMonth - 1 ) * 3 + 1, 3 ) + nDay + ;
iif( nYear % 4 == 0 .AND. nMonth > 2, 1, 0 )
STATIC FUNCTION VALS( cString, nOffset, nChar )
RETURN Val( SubStr( cString, nOffset, nChar ) )

901
harbour/contrib/hbnf/clrsel.prg
View File

File diff suppressed because it is too large Load Diff

21
harbour/contrib/hbnf/cntryset.prg
View File

@@ -24,15 +24,16 @@
*
*/
#define IS_LOGICAL(x) (VALTYPE(x) == "L")
FUNCTION FT_SETCENTURY( lNewSetState )
FUNCTION FT_SETCENTURY(lNewSetState)
// Note that if CENTURY is ON then
// DTOC() Will Return a String of Length
// 10, Otherwise it Will be of Length 8
LOCAL lOldSetState := (LEN(DTOC(DATE())) == 10)
// Note that if CENTURY is ON then
// DTOC() Will Return a String of Length
// 10, Otherwise it Will be of Length 8
IF (IS_LOGICAL(lNewSetState)) // Did They Want it Set??
SET CENTURY (lNewSetState) // Yes, Set it
ENDIF // IS_LOGICAL(lNewSetState)
RETURN lOldSetState // FT_SetCentury
LOCAL lOldSetState := ( Len( DToC( Date() ) ) == 10 )
IF HB_ISLOGICAL( lNewSetState ) // Did They Want it Set??
SET CENTURY ( lNewSetState ) // Yes, Set it
ENDIF
RETURN lOldSetState

52
harbour/contrib/hbnf/d2e.prg
View File

@@ -24,35 +24,43 @@
*
*/
#include "common.ch"
#define log10( num ) log( num ) / log( 10 )
#define DEFAULT_PRECISION 6
#command DEFAULT <p> TO <val> => <p> := iif( <p> == NIL, <val>, <p> )
#ifdef FT_TEST
PROCEDURE Main( cNum, cPrec )
DEFAULT cPrec TO str( DEFAULT_PRECISION )
qout( ft_d2e( val(cNum), val(cPrec) ) )
RETURN
PROCEDURE Main( cNum, cPrec )
DEFAULT cPrec TO Str( DEFAULT_PRECISION )
QOut( ft_d2e( Val(cNum ), Val(cPrec ) ) )
RETURN
#endif
function ft_d2e( nDec, nPrecision )
local nExp, sScn
DEFAULT nPrecision TO DEFAULT_PRECISION
FUNCTION ft_d2e( nDec, nPrecision )
if nDec == 0
nExp := 0
elseif abs( nDec ) < 1
nExp := int( log10( nDec ) ) - 1
else
nExp := int( log10( abs(nDec)+0.00001 ) ) /* 0.00001 == kludge */
endif /* for imprecise logs */
LOCAL nExp, sScn
nDec /= 10 ^ nExp
DEFAULT nPrecision TO DEFAULT_PRECISION
if round( abs(nDec), nPrecision ) >= 10
nDec /= 10
nExp++
endif another kludge for stuff like '999999999'
IF nDec == 0
nExp := 0
ELSEIF Abs( nDec ) < 1
nExp := Int( log10( nDec ) ) - 1
ELSE
nExp := Int( log10( Abs(nDec ) + 0.00001 ) ) /* 0.00001 == kludge */
ENDIF /* for imprecise logs */
sScn := ltrim( str( nDec, nPrecision + 3, nPrecision ) )
return sScn + 'E' + alltrim( str( nExp, 5, 0 ) )
nDec /= 10 ^ nExp
IF Round( Abs( nDec ), nPrecision ) >= 10
nDec /= 10
nExp++
ENDIF // another kludge FOR stuff LIKE '999999999'
sScn := LTrim( Str( nDec, nPrecision + 3, nPrecision ) )
RETURN sScn + 'E' + AllTrim( Str( nExp, 5, 0 ) )

365
harbour/contrib/hbnf/datecnfg.prg
View File

@@ -28,230 +28,233 @@
*/
#ifdef FT_TEST
********************************************************************
*
* NOTES: 1) The date functions are 'international'; i.e., the
* system date format is maintained, although ANSI is
* temporarily used within certain functions.
*
* 2) The date functions fall into two categories:
*
* a) Calendar or fiscal periods.
* A calendar or fiscal year is identified by the year()
* of the last date in the year.
*
* b) Accounting Periods. An accounting period has the
* following characteristics:
* If the first week of the period contains 4 or
* more 'work' days, it is included in the period;
* otherwise, the first week was included in the
* prior period.
*
* If the last week of the period contains 4 or more
* 'work' days it is included in the period; otherwise,
* the last week is included in the next period.
* This results in 13 week 'quarters' and 4 or 5 week
* 'months'. Every 5 or 6 years, a 'quarter' will contain
* 14 weeks and the year will contain 53 weeks.
*
* 3) The date functions require the presence of two variables:
*
* a) cFY_Start is a character string used to define the
* first day of a calendar or fiscal year. It's format
* is ANSI; e.g., "1980.01.01" defines a calendar year,
* "1980.10.01" defines a fiscal year, starting October 1.
*
* The year may be any valid year. It's value has no
* effect on the date functions. The day is assumed to be
* less than 29. See function: FT_DATECNFG().
*
* B) nDow_Start is a number from 1 to 7 which defines the
* starting day, DOW(), of a work week; e.g., 1 == Sunday.
*
* See function: FT_DATECNFG()
*
* COMPILE ALL PROGRAMS WITH /N /W /A
*
********************************************************************
FUNCTION DEMO()
LOCAL nNum, dDate, aTestData := {}, aTemp, cFY_Start, nDOW_Start
//*******************************************************************
//
// NOTES: 1) The date functions are 'international'; i.e., the
// system date format is maintained, although ANSI is
// temporarily used within certain functions.
//
// 2) The date functions fall into two categories:
//
// a) Calendar or fiscal periods.
// A calendar or fiscal year is identified by the year()
// of the last date in the year.
//
// b) Accounting Periods. An accounting period has the
// following characteristics:
// If the first week of the period contains 4 or
// more 'work' days, it is included in the period;
// otherwise, the first week was included in the
// prior period.
//
// If the last week of the period contains 4 or more
// 'work' days it is included in the period; otherwise,
// the last week is included in the next period.
// This results in 13 week 'quarters' and 4 or 5 week
// 'months'. Every 5 or 6 years, a 'quarter' will contain
// 14 weeks and the year will contain 53 weeks.
//
// 3) The date functions require the presence of two variables:
//
// a) cFY_Start is a character string used to define the
// first day of a calendar or fiscal year. It's format
// is ANSI; e.g., "1980.01.01" defines a calendar year,
// "1980.10.01" defines a fiscal year, starting October 1.
//
// The year may be any valid year. It's value has no
// effect on the date functions. The day is assumed to be
// less than 29. See function: FT_DATECNFG().
//
// B) nDow_Start is a number from 1 to 7 which defines the
// starting day, DOW(), of a work week; e.g., 1 == Sunday.
//
// See function: FT_DATECNFG()
//
// COMPILE ALL PROGRAMS WITH /N /W /A
//
//*******************************************************************
* SET DATE ANSI // User's normal date format
aTemp := FT_DATECNFG() // Get/Set cFY_Start & nDOW_Start.
* aTemp := FT_DATECNFG("1980.01.03", 1) // Date string in user's format.
cFY_Start := aTemp[1] // See FT_DATECNFG() in ft_date0.prg
NDOW_START := ATEMP[2] // FOR PARAMETERS.
DDATE := DATE()
* dDate := STOD("19880229") // Test date, in user's normal date format
FUNCTION DEMO()
cls
? "Given Date: "
?? dDate
?? " cFY_Start: "+ cFY_Start
?? " nDOW_Start:" + STR(nDOW_Start,2)
? "---- Fiscal Year Data -----------"
LOCAL nNum, dDate, aTestData := {}, aTemp, cFY_Start, nDOW_Start
aTestData := FT_YEAR(dDate)
? "FYYear ", aTestData[1]+" ", aTestData[2], aTestData[3]
// SET DATE ANSI // User's normal date format
aTemp := FT_DATECNFG() // Get/Set cFY_Start & nDOW_Start.
// aTemp := FT_DATECNFG("1980.01.03", 1) // Date string in user's format.
cFY_Start := aTemp[ 1 ] // See FT_DATECNFG() in ft_date0.prg
NDOW_START := ATEMP[ 2 ] // FOR PARAMETERS.
DDATE := Date()
// dDate := STOD("19880229") // Test date, in user's normal date format
aTestData := FT_QTR(dDate)
? "FYQtr ", aTestData[1], aTestData[2], aTestData[3]
cls
? "Given Date: "
?? dDate
?? " cFY_Start: " + cFY_Start
?? " nDOW_Start:" + Str( nDOW_Start, 2 )
? "---- Fiscal Year Data -----------"
nNum := VAL(SUBSTR(aTestData[1],5,2))
aTestData := FT_QTR(dDate,nNum)
? "FYQtr "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3]
aTestData := FT_YEAR( dDate )
? "FYYear ", aTestData[ 1 ] + " ", aTestData[ 2 ], aTestData[ 3 ]
aTestData := FT_MONTH(dDate)
? "FYMonth ", aTestData[1], aTestData[2], aTestData[3]
aTestData := FT_QTR( dDate )
? "FYQtr ", aTestData[ 1 ], aTestData[ 2 ], aTestData[ 3 ]
nNum := VAL(SUBSTR(aTestData[1],5,2))
aTestData := FT_MONTH(dDate,nNum)
? "FYMonth "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3]
nNum := Val( SubStr( aTestData[ 1 ],5,2 ) )
aTestData := FT_QTR( dDate, nNum )
? "FYQtr " + Str( nNum, 2 ), aTestData[ 1 ], aTestData[ 2 ], aTestData[ 3 ]
aTestData := FT_WEEK(dDate)
? "FYWeek ", aTestData[1], aTestData[2], aTestData[3]
aTestData := FT_MONTH( dDate )
? "FYMonth ", aTestData[ 1 ], aTestData[ 2 ], aTestData[ 3 ]
nNum := VAL(SUBSTR(aTestData[1],5,2))
aTestData := FT_WEEK(dDate,nNum)
? "FYWeek "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3]
nNum := Val( SubStr( aTestData[ 1 ],5,2 ) )
aTestData := FT_MONTH( dDate, nNum )
? "FYMonth " + Str( nNum, 2 ), aTestData[ 1 ], aTestData[ 2 ], aTestData[ 3 ]
aTestData := FT_DAYOFYR(dDate)
? "FYDay ", aTestData[1], aTestData[2], aTestData[3]
aTestData := FT_WEEK( dDate )
? "FYWeek ", aTestData[ 1 ], aTestData[ 2 ], aTestData[ 3 ]
nNum := VAL(SUBSTR(aTestData[1],5,3))
aTestData := FT_DAYOFYR(dDate,nNum)
? "FYDAY "+STR(nNum,3), aTestData[1], aTestData[2], aTestData[3]
nNum := Val( SubStr( aTestData[ 1 ],5,2 ) )
aTestData := FT_WEEK( dDate, nNum )
? "FYWeek " + Str( nNum, 2 ), aTestData[ 1 ], aTestData[ 2 ], aTestData[ 3 ]
?
? "---- Accounting Year Data -------"
aTestData := FT_DAYOFYR( dDate )
? "FYDay ", aTestData[ 1 ], aTestData[ 2 ], aTestData[ 3 ]
aTestData := FT_ACCTYEAR(dDate)
? "ACCTYear ", aTestData[1]+" ", aTestData[2], aTestData[3],;
STR( (aTestData[3] - aTestData[2] + 1) /7, 3 ) + " Weeks"
nNum := Val( SubStr( aTestData[ 1 ],5,3 ) )
aTestData := FT_DAYOFYR( dDate, nNum )
? "FYDAY " + Str( nNum, 3 ), aTestData[ 1 ], aTestData[ 2 ], aTestData[ 3 ]
aTestData := FT_ACCTQTR(dDate)
? "ACCTQtr ", aTestData[1], aTestData[2], aTestData[3],;
STR( (aTestData[3] - aTestData[2] + 1) /7, 3 ) + " Weeks"
?
? "---- Accounting Year Data -------"
nNum := VAL(SUBSTR(aTestData[1],5,2))
aTestData := FT_ACCTQTR(dDate,nNum)
? "ACCTQtr "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3]
aTestData := FT_ACCTYEAR( dDate )
? "ACCTYear ", aTestData[ 1 ] + " ", aTestData[ 2 ], aTestData[ 3 ], ;
Str( ( aTestData[ 3 ] - aTestData[ 2 ] + 1 ) /7, 3 ) + " Weeks"
aTestData := FT_ACCTMONTH(dDate)
? "ACCTMonth ", aTestData[1], aTestData[2], aTestData[3],;
STR( (aTestData[3] - aTestData[2] + 1) /7, 3 ) + " Weeks"
aTestData := FT_ACCTQTR( dDate )
? "ACCTQtr ", aTestData[ 1 ], aTestData[ 2 ], aTestData[ 3 ], ;
Str( ( aTestData[ 3 ] - aTestData[ 2 ] + 1 ) /7, 3 ) + " Weeks"
nNum := VAL(SUBSTR(aTestData[1],5,2))
aTestData := FT_ACCTMONTH(dDate,nNum)
? "ACCTMonth"+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3]
nNum := Val( SubStr( aTestData[ 1 ],5,2 ) )
aTestData := FT_ACCTQTR( dDate, nNum )
? "ACCTQtr " + Str( nNum, 2 ), aTestData[ 1 ], aTestData[ 2 ], aTestData[ 3 ]
aTestData := FT_ACCTWEEK(dDate)
? "ACCTWeek ", aTestData[1], aTestData[2], aTestData[3]
aTestData := FT_ACCTMONTH( dDate )
? "ACCTMonth ", aTestData[ 1 ], aTestData[ 2 ], aTestData[ 3 ], ;
Str( ( aTestData[ 3 ] - aTestData[ 2 ] + 1 ) /7, 3 ) + " Weeks"
nNum := VAL(SUBSTR(aTestData[1],5,2))
aTestData := FT_ACCTWEEK(dDate,nNum)
? "ACCTWeek "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3]
nNum := Val( SubStr( aTestData[ 1 ],5,2 ) )
aTestData := FT_ACCTMONTH( dDate, nNum )
? "ACCTMonth" + Str( nNum, 2 ), aTestData[ 1 ], aTestData[ 2 ], aTestData[ 3 ]
aTestData := FT_DAYOFYR(dDate,,.T.)
? "ACCTDay ", aTestData[1], aTestData[2], aTestData[3]
aTestData := FT_ACCTWEEK( dDate )
? "ACCTWeek ", aTestData[ 1 ], aTestData[ 2 ], aTestData[ 3 ]
nNum := VAL(SUBSTR(aTestData[1],5,3))
aTestData := FT_DAYOFYR(dDate,nNum,.T.)
? "ACCTDay "+STR(nNum,3), aTestData[1], aTestData[2], aTestData[3]
nNum := Val( SubStr( aTestData[ 1 ],5,2 ) )
aTestData := FT_ACCTWEEK( dDate, nNum )
? "ACCTWeek " + Str( nNum, 2 ), aTestData[ 1 ], aTestData[ 2 ], aTestData[ 3 ]
WAIT
aTestData := FT_DAYOFYR( dDate, , .T. )
? "ACCTDay ", aTestData[ 1 ], aTestData[ 2 ], aTestData[ 3 ]
FT_CAL(dDate)
FT_CAL(dDate,1)
nNum := Val( SubStr( aTestData[ 1 ],5,3 ) )
aTestData := FT_DAYOFYR( dDate, nNum, .T. )
? "ACCTDay " + Str( nNum, 3 ), aTestData[ 1 ], aTestData[ 2 ], aTestData[ 3 ]
RETURN NIL
WAIT
* DEMO Monthly Calendar function.
* nType : 0 -> FT_MONTH, 1 -> FT_ACCTMONTH
*
FT_CAL( dDate )
FT_CAL( dDate, 1 )
FUNCTION FT_CAL(dGivenDate,nType)
LOCAL nTemp, dTemp, aTemp, cFY_Start, dStart, dEnd
RETURN NIL
aTemp := FT_DATECNFG()
cFY_Start := aTemp[1]
// DEMO Monthly Calendar function.
// nType : 0 -> FT_MONTH, 1 -> FT_ACCTMONTH
//
IF dGivenDate == NIL .OR. !VALTYPE(dGivenDate) $ 'ND'
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'N'
nType := dGivenDate
dGivenDate := DATE()
ENDIF
FUNCTION FT_CAL( dGivenDate, nType )
nType := iif(nType == NIL .OR. VALTYPE(nType) != 'N', 0, nType)
LOCAL nTemp, dTemp, aTemp, cFY_Start, dStart, dEnd
IF nType == 0
IF SUBSTR(cFY_Start,6,5) == "01.01"
? " Calendar Month Calendar containing " + DTOC(dGivenDate)
ELSE
? " Fiscal Month Calendar containing " + DTOC(dGivenDate)
ENDIF
aTemp := FT_DATECNFG()
cFY_Start := aTemp[ 1 ]
aTemp := FT_MONTH(dGivenDate)
dStart := aTemp[2]
dEnd := aTemp[3]
aTemp[2] -= FT_DAYTOBOW(aTemp[2])
aTemp[3] += 6 - FT_DAYTOBOW(aTemp[3])
ELSE
? " Accounting Month Calendar containing " + DTOC(dGivenDate)
aTemp := FT_ACCTMONTH(dGivenDate)
ENDIF
IF dGivenDate == NIL .OR. !ValType( dGivenDate ) $ 'ND'
dGivenDate := Date()
ELSEIF ValType( dGivenDate ) == 'N'
nType := dGivenDate
dGivenDate := Date()
ENDIF
?
dTemp := aTemp[2]
nType := iif( nType == NIL .OR. ValType( nType ) != 'N', 0, nType )
FOR nTemp := 0 to 6
?? PADC( CDOW(dTemp + nTemp),10)
NEXT
IF nType == 0
IF SubStr( cFY_Start, 6, 5 ) == "01.01"
? " Calendar Month Calendar containing " + DToC( dGivenDate )
ELSE
? " Fiscal Month Calendar containing " + DToC( dGivenDate )
ENDIF
?
WHILE dTemp <= aTemp[3]
FOR nTemp := 1 TO 7
?? " "
IF nType == 0 .AND. (dTemp < dStart .or. dTemp > dEnd)
?? SPACE(8)
ELSE
?? dTemp
ENDIF
?? " "
dTemp ++
NEXT
?
END
aTemp := FT_MONTH( dGivenDate )
dStart := aTemp[ 2 ]
dEnd := aTemp[ 3 ]
aTemp[ 2 ] -= FT_DAYTOBOW( aTemp[ 2 ] )
aTemp[ 3 ] += 6 - FT_DAYTOBOW( aTemp[ 3 ] )
ELSE
? " Accounting Month Calendar containing " + DToC( dGivenDate )
aTemp := FT_ACCTMONTH( dGivenDate )
ENDIF
RETURN NIL
?
dTemp := aTemp[ 2 ]
FOR nTemp := 0 TO 6
?? PadC( CDOW( dTemp + nTemp ), 10 )
NEXT
?
WHILE dTemp <= aTemp[ 3 ]
FOR nTemp := 1 TO 7
?? " "
IF nType == 0 .AND. ( dTemp < dStart .OR. dTemp > dEnd )
?? Space( 8 )
ELSE
?? dTemp
ENDIF
?? " "
dTemp++
NEXT
?
END
RETURN NIL
#endif
FUNCTION FT_DATECNFG( cFYStart ,nDow )
FUNCTION FT_DATECNFG( cFYStart , nDow )
THREAD STATIC aDatePar := { "1980.01.01", 1 }
THREAD STATIC aDatePar := { "1980.01.01", 1 }
LOCAL dCheck, cDateFormat := SET(_SET_DATEFORMAT)
LOCAL dCheck, cDateFormat := Set( _SET_DATEFORMAT )
IF VALTYPE( cFYStart ) == 'C'
dCheck := CTOD( cFYStart )
IF DTOC( dCheck ) != " "
IF ValType( cFYStart ) == 'C'
dCheck := CToD( cFYStart )
IF DToC( dCheck ) != " " // TOFIX
/* No one starts a Fiscal Year on 2/29 */
IF MONTH(dCheck) == 2 .and. DAY(dcheck) == 29
dCheck --
ENDIF
/* No one starts a Fiscal Year on 2/29 */
IF Month( dCheck ) == 2 .AND. Day( dcheck ) == 29
dCheck --
ENDIF
SET(_SET_DATEFORMAT, "yyyy.mm.dd")
aDatePar[1] := DTOC(dCheck)
SET(_SET_DATEFORMAT, cDateFormat)
ENDIF
ENDIF
SET( _SET_DATEFORMAT, "yyyy.mm.dd" )
aDatePar[ 1 ] := DToC( dCheck )
SET( _SET_DATEFORMAT, cDateFormat )
ENDIF
ENDIF
IF VALTYPE( nDow ) == 'N' .AND. nDow > 0 .AND. nDow < 8
aDatePar[2] := nDow
ENDIF
IF ValType( nDow ) == 'N' .AND. nDow > 0 .AND. nDow < 8
aDatePar[ 2 ] := nDow
ENDIF
RETURN ACLONE( aDatePar )
RETURN AClone( aDatePar )

57
harbour/contrib/hbnf/dayofyr.prg
View File

@@ -27,36 +27,37 @@
*
*/
FUNCTION FT_DAYOFYR( dGivenDate, nDayNum, lIsAcct)
LOCAL lIsDay, nTemp, aRetVal
FUNCTION FT_DAYOFYR( dGivenDate, nDayNum, lIsAcct )
IF !(VALTYPE(dGivenDate) $ 'NDL')
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'N'
nDayNum := dGivenDate
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'L'
lIsAcct := dGivenDate
dGivenDate := DATE()
ENDIF
LOCAL lIsDay, nTemp, aRetVal
lIsDay := VALTYPE(nDayNum) == 'N'
lIsAcct := VALTYPE(lIsAcct) == 'L'
IF !( ValType( dGivenDate ) $ 'NDL' )
dGivenDate := Date()
ELSEIF ValType( dGivenDate ) == 'N'
nDayNum := dGivenDate
dGivenDate := Date()
ELSEIF ValType( dGivenDate ) == 'L'
lIsAcct := dGivenDate
dGivenDate := Date()
ENDIF
IF lIsAcct
aRetVal := FT_ACCTYEAR(dGivenDate)
ELSE
aRetVal := FT_YEAR(dGivenDate)
ENDIF
lIsDay := ValType( nDayNum ) == 'N'
lIsAcct := ValType( lIsAcct ) == 'L'
IF lIsDay
nTemp := aRetVal[3] - aRetVal[2] + 1
IF nDayNum < 1 .OR. nDayNum > nTemp
nDayNum := nTemp
ENDIF
aRetVal[1] := aRetVal[2] + nDayNum - 1
ELSE
aRetVal[1] += PADL(LTRIM(STR( dGivenDate - aRetVal[2] + 1, 3)), 3, '0')
ENDIF
IF lIsAcct
aRetVal := FT_ACCTYEAR( dGivenDate )
ELSE
aRetVal := FT_YEAR( dGivenDate )
ENDIF
RETURN aRetVal
IF lIsDay
nTemp := aRetVal[ 3 ] - aRetVal[ 2 ] + 1
IF nDayNum < 1 .OR. nDayNum > nTemp
nDayNum := nTemp
ENDIF
aRetVal[ 1 ] := aRetVal[ 2 ] + nDayNum - 1
ELSE
aRetVal[ 1 ] += PadL( LTrim( Str( dGivenDate - aRetVal[ 2 ] + 1, 3 ) ), 3, '0' )
ENDIF
RETURN aRetVal

20
harbour/contrib/hbnf/daytobow.prg
View File

@@ -29,17 +29,17 @@
FUNCTION FT_DAYTOBOW( dGivenDate )
LOCAL nRetVal, nDOW_Start
LOCAL nRetVal, nDOW_Start
nDOW_Start := FT_DATECNFG()[2]
nDOW_Start := FT_DATECNFG()[ 2 ]
IF VALTYPE(dGivenDate) != 'D'
dGivenDate := DATE()
ENDIF
IF ValType( dGivenDate ) != 'D'
dGivenDate := Date()
ENDIF
nRetVal := DOW( dGivenDate ) - nDOW_Start
IF nRetVal < 0
nRetVal += 7
ENDIF
nRetVal := DOW( dGivenDate ) - nDOW_Start
IF nRetVal < 0
nRetVal += 7
ENDIF
RETURN nRetVal
RETURN nRetVal

36
harbour/contrib/hbnf/dectobin.prg
View File

@@ -27,23 +27,27 @@
#ifdef FT_TEST
PROCEDURE Main()
LOCAL X
FOR X := 1 TO 255
QOUT( FT_DEC2BIN( x ))
next
return
LOCAL X
FOR X := 1 TO 255
QOut( FT_DEC2BIN( x ) )
NEXT
RETURN
#endif
function FT_DEC2BIN(x)
local i, buffer := { '0', '0', '0', '0', '0', '0', '0', '0' }
for i := 8 to 1 step -1
if x >= 2 ^ (i - 1)
x -= 2 ^ (i - 1)
buffer[9 - i] := '1'
endif
next
return ( buffer[1] + buffer[2] + buffer[3] + buffer[4] + ;
buffer[5] + buffer[6] + buffer[7] + buffer[8] )
FUNCTION FT_DEC2BIN( x )
* end of file: dectobin.prg
LOCAL i, buffer := { "0", "0", "0", "0", "0", "0", "0", "0" }
FOR i := 8 TO 1 step - 1
IF x >= 2 ^ ( i - 1 )
x -= 2 ^ ( i - 1 )
buffer[ 9 - i ] := "1"
ENDIF
NEXT
RETURN buffer[ 1 ] + buffer[ 2 ] + buffer[ 3 ] + buffer[ 4 ] + ;
buffer[ 5 ] + buffer[ 6 ] + buffer[ 7 ] + buffer[ 8 ]

132
harbour/contrib/hbnf/dfile.prg
View File

@@ -27,35 +27,35 @@
*
*/
THREAD static nHandle := 0
THREAD STATIC t_nHandle := 0
#ifdef FT_TEST
PROCEDURE Main()
PROCEDURE Main()
@ 0,0 CLEAR
@ 0, 0 CLEAR
cInFile := "ft_dfile.prg"
CKEY := ""
NNCOLOR := 7
NHCOLOR := 15
NCOLSKIP := 5
NRMARGIN := 132
CEXITKEYS := "AABBC "
LBROWSE := .F.
NSTART := 1
NBUFFSIZE := 4096
cInFile := "ft_dfile.prg"
CKEY := ""
NNCOLOR := 7
NHCOLOR := 15
NCOLSKIP := 5
NRMARGIN := 132
CEXITKEYS := "AABBC "
LBROWSE := .F.
NSTART := 1
NBUFFSIZE := 4096
@ 0,0 SAY "ENTER FILENAME: " GET CINFILE
@ 1,0 SAY " FOREGROUND: " GET NNCOLOR PICTURE "999"
@ 2,0 SAY " HIGHLIGHT: " GET NHCOLOR PICTURE "999"
@ 3,0 SAY " EXIT KEYS: " GET CEXITKEYS
@ 4,0 SAY " BUFFER SIZE: " GET NBUFFSIZE PICTURE "9999"
@ 1,40 SAY "COLUMN INCREMENT: " GET NCOLSKIP PICTURE "999"
@ 2,40 SAY " MAX LINE SIZE: " GET NRMARGIN PICTURE "999"
@ 3,40 SAY " BROWSE MODE? " GET LBROWSE PICTURE "Y"
@ 0, 0 SAY "ENTER FILENAME: " GET CINFILE
@ 1, 0 SAY " FOREGROUND: " GET NNCOLOR PICTURE "999"
@ 2, 0 SAY " HIGHLIGHT: " GET NHCOLOR PICTURE "999"
@ 3, 0 SAY " EXIT KEYS: " GET CEXITKEYS
@ 4, 0 SAY " BUFFER SIZE: " GET NBUFFSIZE PICTURE "9999"
@ 1, 40 SAY "COLUMN INCREMENT: " GET NCOLSKIP PICTURE "999"
@ 2, 40 SAY " MAX LINE SIZE: " GET NRMARGIN PICTURE "999"
@ 3, 40 SAY " BROWSE MODE? " GET LBROWSE PICTURE "Y"
READ
READ
/*
* REMEMBER A WINDOW WILL BE ONE SIZE LESS AND GREATER THAN THE PASSED COORD.'S
@@ -65,71 +65,71 @@ THREAD static nHandle := 0
*
*/
@ 4,9 TO 11,71
@ 4, 9 TO 11, 71
FT_DFSETUP(cInFile, 5, 10, 10, 70, nStart,;
nNColor, nHColor, cExitKeys + CHR(143),;
lBrowse, nColSkip, nRMargin, nBuffSize)
FT_DFSETUP( cInFile, 5, 10, 10, 70, nStart, ;
nNColor, nHColor, cExitKeys + Chr( 143 ), ;
lBrowse, nColSkip, nRMargin, nBuffSize )
cKey := FT_DISPFILE()
cKey := FT_DISPFILE()
FT_DFCLOSE()
FT_DFCLOSE()
@ 20,0 SAY "Key pressed was: " + '[' + cKey + ']'
@ 20, 0 SAY "Key pressed was: " + '[' + cKey + ']'
return
RETURN
#endif
function FT_DFSETUP(cInFile, nTop, nLeft, nBottom, nRight,;
nStart, nCNormal, nCHighlight, cExitKeys,;
lBrowse, nColSkip, nRMargin, nBuffSize )
FUNCTION FT_DFSETUP( cInFile, nTop, nLeft, nBottom, nRight, ;
nStart, nCNormal, nCHighlight, cExitKeys, ;
lBrowse, nColSkip, nRMargin, nBuffSize )
local rval
LOCAL rval
if File(cInFile)
nTop := iif(ValType(nTop) == "N", nTop, 0)
nLeft := iif(ValType(nLeft) == "N", nLeft, 0)
nBottom := iif(ValType(nBottom) == "N", nBottom, MaxRow())
nRight := iif(ValType(nRight) == "N", nRight, MaxCol())
IF File( cInFile )
nTop := iif( ValType( nTop ) == "N", nTop, 0 )
nLeft := iif( ValType( nLeft ) == "N", nLeft, 0 )
nBottom := iif( ValType( nBottom ) == "N", nBottom, MaxRow() )
nRight := iif( ValType( nRight ) == "N", nRight, MaxCol() )
nCNormal := iif(ValType(nCNormal) == "N", nCNormal, 7)
nCHighlight := iif(ValType(nCHighlight) == "N", nCHighlight, 15)
nCNormal := iif( ValType( nCNormal ) == "N", nCNormal, 7 )
nCHighlight := iif( ValType( nCHighlight ) == "N", nCHighlight, 15 )
nStart := iif(ValType(nStart) == "N", nStart, 1)
nColSkip := iif(ValType(nColSkip) == "N", nColSkip, 1)
lBrowse := iif(ValType(lBrowse) == "L", lBrowse, .F.)
nStart := iif( ValType( nStart ) == "N", nStart, 1 )
nColSkip := iif( ValType( nColSkip ) == "N", nColSkip, 1 )
lBrowse := iif( ValType( lBrowse ) == "L", lBrowse, .F. )
nRMargin := iif(ValType(nRMargin) == "N", nRMargin, 255)
nBuffSize := iif(ValType(nBuffSize) == "N", nBuffSize, 4096)
nRMargin := iif( ValType( nRMargin ) == "N", nRMargin, 255 )
nBuffSize := iif( ValType( nBuffSize ) == "N", nBuffSize, 4096 )
cExitKeys := iif(ValType(cExitKeys) == "C", cExitKeys, "")
cExitKeys := iif( ValType( cExitKeys ) == "C", cExitKeys, "" )
cExitKeys := iif(Len(cExitKeys) > 25, SubStr(cExitKeys, 1, 25), cExitKeys)
cExitKeys := iif( Len( cExitKeys ) > 25, SubStr( cExitKeys, 1, 25 ), cExitKeys )
nHandle := FOpen(cInFile)
t_nHandle := FOpen( cInFile )
rval := FError()
rval := FError()
if ( rval == 0 )
rval := _FT_DFINIT(nHandle, nTop, nLeft, nBottom, nRight,;
nStart, nCNormal, nCHighlight, cExitKeys,;
lBrowse, nColSkip, nRMargin, nBuffSize)
endif
else
rval := 2 // simulate a file-not-found DOS file error
endif
IF rval == 0
rval := _FT_DFINIT( t_nHandle, nTop, nLeft, nBottom, nRight, ;
nStart, nCNormal, nCHighlight, cExitKeys, ;
lBrowse, nColSkip, nRMargin, nBuffSize )
ENDIF
ELSE
rval := 2 // simulate a file-not-found DOS file error
ENDIF
return (rval)
RETURN rval
function FT_DFCLOSE()
FUNCTION FT_DFCLOSE()
if ( nHandle > 0 )
_FT_DFCLOS()
IF t_nHandle > 0
_FT_DFCLOS()
FClose(nHandle)
FClose( t_nHandle )
nHandle := 0
endif
t_nHandle := 0
ENDIF
return (NIL)
RETURN NIL

22
harbour/contrib/hbnf/diskfunc.prg
View File

@@ -26,27 +26,23 @@
*
*/
#include "ftint86.ch"
#include "fileio.ch"
#define DRVTABLE "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
#ifdef FT_TEST
PROCEDURE Main( cDrv )
QOut("Disk size: " + str( FT_DSKSIZE() ) )
QOut("Free bytes: " + str( FT_DSKFREE() ) )
PROCEDURE Main( cDrv )
QOut( "Disk size: " + Str( FT_DSKSIZE() ) )
QOut( "Free bytes: " + Str( FT_DSKFREE() ) )
RETURN
RETURN
#endif
FUNCTION FT_DSKSIZE( cDrive )
local nDrive
nDrive := iif( cDrive == NIL, 0, at( upper(cDrive), DRVTABLE ) )
Return DISKSPACE(nDrive,3)
RETURN DiskSpace( iif( cDrive == NIL, 0, At( Upper( cDrive ), DRVTABLE ) ), HB_DISK_TOTAL )
FUNCTION FT_DSKFREE( cDrive )
local nDrive
nDrive := iif( cDrive == NIL, 0, at( upper(cDrive), DRVTABLE ) )
RETURN DISKSPACE(nDrive,1)
RETURN DiskSpace( iif( cDrive == NIL, 0, At( Upper( cDrive ), DRVTABLE ) ), HB_DISK_FREE )

196
harbour/contrib/hbnf/dispmsg.prg
View File

@@ -34,25 +34,26 @@
#ifdef FT_TEST
// color variables
STATIC cNormH, cNormN, cNormE, ;
cWindH, cWindN, cWindE, ;
cErrH, cErrN, cErrE
STATIC cNormH, cNormN, cNormE
STATIC cWindH, cWindN, cWindE
STATIC cErrH, cErrN, cErrE
PROCEDURE Main( cCmdLine )
LOCAL cDosScrn, ;
nDosRow, ;
nDosCol, ;
lColor, ;
nMaxRow, ;
nType
// main routine starts here
LOCAL cDosScrn
LOCAL nDosRow
LOCAL nDosCol
LOCAL lColor
LOCAL nMaxRow
LOCAL nType
// main routine starts here
SET SCOREBOARD OFF
lColor := .T.
cNormH := iif( lColor, "W+/BG","W+/N" )
cNormN := iif( lColor, "N/BG" ,"W/N" )
cNormH := iif( lColor, "W+/BG", "W+/N" )
cNormN := iif( lColor, "N/BG" , "W/N" )
cNormE := iif( lColor, "N/W" , "N/W" )
cWindH := iif( lColor, "W+/B", "W+/N" )
cWindN := iif( lColor, "W/B" , "W/N" )
@@ -61,35 +62,35 @@ PROCEDURE Main( cCmdLine )
cErrN := iif( lColor, "W/R" , "W/N" )
cErrE := iif( lColor, "N/W" , "N/W" )
cDosScrn := SAVESCREEN()
nDosRow := ROW()
nDosCol := COL()
SETCOLOR( "W/N" )
cDosScrn := SaveScreen()
nDosRow := Row()
nDosCol := Col()
SetColor( "W/N" )
CLS
nMaxRow := MAXROW()
SETBLINK(.F.)
SETCOLOR( cWindN + "*" )
nMaxRow := MaxRow()
SetBlink( .F. )
SetColor( cWindN + "*" )
CLS
SETCOLOR( cNormN )
SetColor( cNormN )
FT_DispMsg( { { "[Esc] To Abort Changes [PgDn] To Continue" }, { cNormN, , cNormH } }, , nMaxRow - 5 )
FT_DispMsg( { { "[E]dit [P]rint [D]elete", ;
"[Esc]ape [Alt-Q]" }, ;
{ cErrN, cErrN, cErrH } },, 2 )
"[Esc]ape [Alt-Q]" }, ;
{ cErrN, cErrN, cErrH } }, , 2 )
nType := FT_DispMsg( { { "Create Or Edit [I]nvoice", ;
"Create Or Edit [O]rder", ;
"Create Or Edit [B]ack Order", ;
"Create Or Edit [Q]uote", ;
"[Esc] To Exit" }, ;
{ cWindN,,,,, cWindH } }, "BIOQ" + CHR(27) )
nType := FT_DispMsg( { { "Create Or Edit [I]nvoice", ;
"Create Or Edit [O]rder", ;
"Create Or Edit [B]ack Order", ;
"Create Or Edit [Q]uote", ;
"[Esc] To Exit" }, ;
{ cWindN, , , , , cWindH } }, "BIOQ" + Chr( 27 ) )
SETCOLOR( "W/N" )
SETCURSOR( SC_NORMAL )
SETBLINK( .T.)
RESTSCREEN(,,,, cDosScrn )
SETPOS(nDosRow, nDosCol)
SetColor( "W/N" )
SetCursor( SC_NORMAL )
SetBlink( .T. )
RestScreen( , , , , cDosScrn )
SetPos( nDosRow, nDosCol )
QUIT
#endif
@@ -97,50 +98,50 @@ PROCEDURE Main( cCmdLine )
FUNCTION FT_DispMsg( aInfo, cKey, nBoxTop, nBoxLeft, cnBoxString, lShadow )
LOCAL xRtnVal := .F., ;
nWidest := 0, ;
nBoxRight, ;
nBoxBottom, ;
cOldScreen, ;
cOldCursor, ;
cOldColor, ;
i, ;
j, ;
nOption, ;
x, ;
y, ;
aPos := {}, ;
nLeft, ;
aLeft
LOCAL xRtnVal := .F.
LOCAL nWidest := 0
LOCAL nBoxRight
LOCAL nBoxBottom
LOCAL cOldScreen
LOCAL cOldCursor
LOCAL cOldColor
LOCAL i
LOCAL j
LOCAL nOption
LOCAL x
LOCAL y
LOCAL aPos := {}
LOCAL nLeft
LOCAL aLeft
FOR i := 1 TO LEN( aInfo[1] )
AADD( aPos, {} )
FOR i := 1 TO Len( aInfo[ 1 ] )
AAdd( aPos, {} )
NEXT
FOR i := 1 TO LEN( aInfo[1] )
FOR i := 1 TO Len( aInfo[1] )
DO WHILE AT( "[", aInfo[1,i] ) > 0
x := AT( "[", aInfo[1,i] )
y := AT( "]", aInfo[1,i] ) - 2
AADD( aPos[i], { x, y } )
aInfo[1,i] := STRTRAN( aInfo[1,i], "[", "", 1, 1 )
aInfo[1,i] := STRTRAN( aInfo[1,i], "]", "", 1, 1 )
DO WHILE At( "[", aInfo[ 1, i ] ) > 0
x := At( "[", aInfo[ 1, i ] )
y := At( "]", aInfo[ 1, i ] ) - 2
AAdd( aPos[ i ], { x, y } )
aInfo[ 1, i ] := StrTran( aInfo[ 1, i ], "[", "", 1, 1 )
aInfo[ 1, i ] := StrTran( aInfo[ 1, i ], "]", "", 1, 1 )
ENDDO
NEXT
AEVAL( aInfo[1], {|x| nWidest := MAX( nWidest, LEN( x ) ) } )
AEval( aInfo[1], {|x| nWidest := Max( nWidest, Len( x ) ) } )
/* calculate location of data */
IF nBoxLeft == NIL
nLeft := ROUND( ( MAXCOL() - nWidest ) / 2, 0 )
nLeft := Round( ( MaxCol() - nWidest ) / 2, 0 )
ELSE
nLeft := nBoxLeft + 2
ENDIF
/*
IF nBoxTop == NIL
nTop := ( MAXROW() - LEN( aInfo[1] ) - 2 ) / 2 + 2
nTop := ( MAXROW() - LEN( aInfo[ 1 ] ) - 2 ) / 2 + 2
ENDIF
*/
@@ -151,12 +152,12 @@ FUNCTION FT_DispMsg( aInfo, cKey, nBoxTop, nBoxLeft, cnBoxString, lShadow )
nBoxRight := nBoxLeft + nWidest + 3
IF nBoxTop == NIL
nBoxTop := (MAXROW() - LEN( aInfo[1] ) - 2) / 2 + 1
nBoxTop := ( MaxRow() - Len( aInfo[ 1 ] ) - 2 ) / 2 + 1
ENDIF
nBoxBottom := nBoxTop + LEN( aInfo[1] ) + 1
nBoxBottom := nBoxTop + Len( aInfo[ 1 ] ) + 1
// following is to keep from breaking old code and to be
// consistent with DISPBOX()
// following is to keep from breaking old code and to be
// consistent with DISPBOX()
IF cnBoxString == NIL .OR. cnBoxString == 2
cnBoxString := hb_UTF8ToStr( "╔═╗║╝═╚║ " )
@@ -164,71 +165,72 @@ FUNCTION FT_DispMsg( aInfo, cKey, nBoxTop, nBoxLeft, cnBoxString, lShadow )
cnBoxString := hb_UTF8ToStr( "┌─┐│┘─└│ " )
ENDIF
lShadow := iif( lShadow == NIL, .T., lShadow )
lShadow := iif( lShadow == NIL, .T. , lShadow )
cOldScreen := SAVESCREEN( nBoxTop, nBoxLeft, nBoxBottom+1, nBoxRight+2 )
cOldScreen := SaveScreen( nBoxTop, nBoxLeft, nBoxBottom + 1, nBoxRight + 2 )
cOldCursor := SETCURSOR( SC_NONE )
cOldCursor := SetCursor( SC_NONE )
// draw box
cOldColor := SETCOLOR( aInfo[ 2, LEN( aInfo[2] ) ] )
// draw box
cOldColor := SetColor( aInfo[ 2, LEN( aInfo[ 2 ] ) ] )
DISPBOX( nBoxTop, nBoxLeft, nBoxBottom, nBoxRight, cnBoxString, ;
aInfo[ 2, LEN( aInfo[2] ) ] )
DispBox( nBoxTop, nBoxLeft, nBoxBottom, nBoxRight, cnBoxString, ;
aInfo[ 2, LEN( aInfo[ 2 ] ) ] )
IF lShadow
FT_Shadow( nBoxTop, nBoxLeft, nBoxBottom, nBoxRight )
ENDIF
/* fill array with left positions for each row */
aLeft := ARRAY( LEN( aInfo[1] ) )
FOR i := 1 TO LEN( aInfo[1] )
IF LEN( aInfo[1,i] ) == nWidest
aLeft[i] := nLeft
aLeft := Array( Len( aInfo[ 1 ] ) )
FOR i := 1 TO Len( aInfo[ 1 ] )
IF Len( aInfo[ 1, i ] ) == nWidest
aLeft[ i ] := nLeft
ELSE
aLeft[i] := nLeft + ROUND( ( nWidest - LEN( aInfo[1,i] ) ) / 2, 0 )
aLeft[ i ] := nLeft + Round( ( nWidest - Len( aInfo[ 1, i ] ) ) / 2, 0 )
ENDIF
NEXT
/* fill array of colors */
FOR i := 2 TO LEN( aInfo[2] )
IF aInfo[2,i] == NIL
aInfo[2,i] := aInfo[2,i-1]
FOR i := 2 TO Len( aInfo[ 2 ] )
IF aInfo[ 2, i ] == NIL
aInfo[ 2, i ] := aInfo[ 2, i - 1 ]
ENDIF
NEXT
/* display messages */
FOR i := 1 TO LEN( aInfo[1] )
@ nBoxTop+i, aLeft[i] SAY aInfo[1,i] COLOR aInfo[2,i]
FOR i := 1 TO Len( aInfo[ 1 ] )
@ nBoxTop + i, aLeft[ i ] SAY aInfo[ 1, i ] COLOR aInfo[ 2, i ]
NEXT
/* highlight characters */
FOR i := 1 TO LEN( aPos )
FOR j := 1 TO LEN( aPos[i] )
FOR i := 1 TO Len( aPos )
FOR j := 1 TO Len( aPos[ i ] )
FT_SetAttr( nBoxTop + i, ;
aPos[i,j,1] + aLeft[i] - 1, ;
nBoxTop + i, ;
aPos[i,j,2] + aLeft[i] - 1, ;
FT_Color2N( aInfo[ 2, LEN( aInfo[2] ) ] ) )
FT_SetAttr( nBoxTop + i, ;
aPos[ i, j, 1 ] + aLeft[ i ] - 1, ;
nBoxTop + i, ;
aPos[ i, j, 2 ] + aLeft[ i ] - 1, ;
FT_Color2N( aInfo[ 2, LEN( aInfo[ 2 ] ) ] ) )
NEXT
NEXT
IF cKey != NIL
IF LEN( cKey ) == 1
nOption := FT_SInkey(0)
IF UPPER( CHR( nOption) ) == cKey
xRtnVal := .t.
IF Len( cKey ) == 1
nOption := FT_SInkey( 0 )
IF Upper( Chr( nOption ) ) == cKey
xRtnVal := .T.
ENDIF
ELSE
nOption := 0
DO WHILE AT( UPPER( CHR( nOption ) ), UPPER( cKey ) ) == 0
nOption := FT_SInkey(0)
DO WHILE At( Upper( Chr( nOption ) ), Upper( cKey ) ) == 0
nOption := FT_SInkey( 0 )
ENDDO
xRtnVal := nOption
ENDIF
RESTSCREEN( nBoxTop, nBoxLeft, nBoxBottom+1, nBoxRight+2, cOldScreen )
RestScreen( nBoxTop, nBoxLeft, nBoxBottom + 1, nBoxRight + 2, cOldScreen )
ENDIF
SETCOLOR( cOldColor )
SETCURSOR( cOldCursor )
SetColor( cOldColor )
SetCursor( cOldCursor )
RETURN xRtnVal

30
harbour/contrib/hbnf/dosver.prg
View File

@@ -31,20 +31,26 @@
#define DOSVER 48
#ifdef FT_TEST
PROCEDURE Main()
QOut( "Dos version: " + FT_DOSVER() )
RETURN
PROCEDURE Main()
QOut( "Dos version: " + FT_DOSVER() )
RETURN
#endif
FUNCTION FT_DOSVER()
/* local aRegs[ INT86_MAX_REGS ] */
local cResult
/* aRegs[ AX ] := MAKEHI( DOSVER )
if FT_INT86( DOS, aRegs )
cResult := alltrim( str( LOWBYTE( aRegs[ AX ] ) ) ) + "." + ;
alltrim( str( HIGHBYTE( aRegs[ AX ] ) ) )
endif
/* LOCAL aRegs[ INT86_MAX_REGS ] */
LOCAL cResult
/* aRegs[ AX ] := MAKEHI( DOSVER )
IF FT_INT86( DOS, aRegs )
cResult := AllTrim( Str( LOWBYTE( aRegs[ AX ] ) ) ) + "." + ;
AllTrim( Str( HIGHBYTE( aRegs[ AX ] ) ) )
ENDIF
*/
cResult:= _get_dosver()
RETURN ( cResult )
cResult := _get_dosver()
RETURN cResult

30
harbour/contrib/hbnf/e2d.prg
View File

@@ -25,18 +25,24 @@
*/
#ifdef FT_TEST
PROCEDURE Main( sNumE )
qout( FT_E2D( sNumE ) )
RETURN
PROCEDURE Main( sNumE )
QOut( FT_E2D( sNumE ) )
RETURN
#endif
function ft_e2d( sNumE )
local nMant, nExp
FUNCTION ft_e2d( sNumE )
nMant := val( left( sNumE, at( 'E', sNumE ) - 1 ) )
nExp := val(substr( sNumE, ;
at( 'E', sNumE ) + 1, ;
len( sNumE ) - at( 'E', sNumE ) ;
) ;
)
return nMant * 10 ^ nExp
LOCAL nMant, nExp
nMant := Val( Left( sNumE, At( 'E', sNumE ) - 1 ) )
nExp := Val( SubStr( sNumE, ;
At( 'E', sNumE ) + 1, ;
Len( sNumE ) - At( 'E', sNumE ) ;
) ;
)
RETURN nMant * 10 ^ nExp

105
harbour/contrib/hbnf/easter.prg
View File

@@ -26,71 +26,72 @@
*
*/
FUNCTION FT_EASTER (nYear)
local nGold, nCent, nCorx, nCorz, nSunday, nEpact, nMoon,;
nMonth := 0, nDay := 0
FUNCTION FT_EASTER( nYear )
IF VALTYPE (nYear) == "C"
nYear := VAL(nYear)
ENDIF
LOCAL nGold, nCent, nCorx, nCorz, nSunday, nEpact, nMoon
LOCAL nMonth := 0, nDay := 0
IF VALTYPE (nYear) == "D"
nYear := YEAR(nYear)
ENDIF
IF ValType( nYear ) == "C"
nYear := Val( nYear )
ENDIF
IF VALTYPE (nYear) == "N"
IF nYear > 1582
IF ValType( nYear ) == "D"
nYear := Year( nYear )
ENDIF
* <<nGold>> is Golden number of the year in the 19 year Metonic cycle
nGold := nYear % 19 + 1
IF ValType( nYear ) == "N"
IF nYear > 1582
* <<nCent>> is Century
nCent := INT (nYear / 100) + 1
// <<nGold>> is Golden number of the year in the 19 year Metonic cycle
nGold := nYear % 19 + 1
* Corrections:
* <<nCorx>> is the no. of years in which leap-year was dropped in order
* to keep step with the sun
nCorx := INT ((3 * nCent) / 4 - 12)
// <<nCent>> is Century
nCent := Int( nYear / 100 ) + 1
* <<nCorz>> is a special correction to synchronize Easter with the moon's
* orbit.
nCorz := INT ((8 * nCent + 5) / 25 - 5)
// Corrections:
// <<nCorx>> is the no. of years in which leap-year was dropped in order
// to keep step with the sun
nCorx := Int( ( 3 * nCent ) / 4 - 12 )
* <<nSunday>> Find Sunday
nSunday := INT ((5 * nYear) / 4 - nCorx - 10)
// <<nCorz>> is a special correction to synchronize Easter with the moon's
// orbit.
nCorz := Int( ( 8 * nCent + 5 ) / 25 - 5 )
* Set Epact <<nEpact>> (specifies occurance of a full moon)
nEpact := INT ((11 * nGold + 20 + nCorz - nCorx) % 30)
// <<nSunday>> Find Sunday
nSunday := Int( ( 5 * nYear ) / 4 - nCorx - 10 )
IF nEpact < 0
nEpact += 30
ENDIF
// Set Epact <<nEpact>> (specifies occurance of a full moon)
nEpact := Int( ( 11 * nGold + 20 + nCorz - nCorx ) % 30 )
IF ((nEpact == 25) .AND. (nGold > 11)) .OR. (nEpact == 24)
++nEpact
ENDIF
IF nEpact < 0
nEpact += 30
ENDIF
* Find full moon - the <<nMoon>>th of MARCH is a "calendar" full moon
nMoon := 44 - nEpact
IF ( nEpact == 25 .AND. nGold > 11 ) .OR. nEpact == 24
++nEpact
ENDIF
IF nMoon < 21
nMoon += 30
ENDIF
// Find full moon - the <<nMoon>>th of MARCH is a "calendar" full moon
nMoon := 44 - nEpact
* Advance to Sunday
nMoon := INT (nMoon + 7 - ((nSunday + nMoon) % 7))
IF nMoon < 21
nMoon += 30
ENDIF
* Get Month and Day
IF nMoon > 31
nMonth := 4
nDay := nMoon - 31
ELSE
nMonth := 3
nDay := nMoon
ENDIF
ENDIF
ELSE
nYear := 0
ENDIF
// Advance to Sunday
nMoon := Int ( nMoon + 7 - ( ( nSunday + nMoon ) % 7 ) )
RETURN StoD( Str( nYear,4) + PadL( nMonth, 2, "0" ) + PadL( Int( nDay ), 2, "0" ) )
// Get Month and Day
IF nMoon > 31
nMonth := 4
nDay := nMoon - 31
ELSE
nMonth := 3
nDay := nMoon
ENDIF
ENDIF
ELSE
nYear := 0
ENDIF
RETURN SToD( Str( nYear,4 ) + PadL( nMonth, 2, "0" ) + PadL( Int( nDay ), 2, "0" ) )

7
harbour/contrib/hbnf/elapmil.prg
View File

@@ -24,6 +24,7 @@
*
*/
function FT_ELAPMIN(cTIME1,cTIME2)
return ((VAL(LEFT(cTIME2,2))*60) + (VAL(RIGHT(cTIME2,2)))) - ;
((VAL(LEFT(cTIME1,2))*60) + (VAL(RIGHT(cTIME1,2))))
FUNCTION FT_ELAPMIN( cTIME1, cTIME2 )
RETURN ( ( Val( Left( cTIME2, 2 ) ) * 60 ) + ( Val( Right( cTIME2, 2 ) ) ) ) - ;
( ( Val( Left( cTIME1, 2 ) ) * 60 ) + ( Val( Right( cTIME1, 2 ) ) ) )

96
harbour/contrib/hbnf/elapsed.prg
View File

@@ -29,60 +29,64 @@
#ifdef FT_TEST
FUNCTION DEMO()
LOCAL dStart, dEnd, cTimeStart, cTimeEnd, n, aDataTest := {}
dStart := CTOD('11/28/90')
dEnd := CTOD('11/30/90')
cTimeStart := "08:00:00"
cTimeEnd := "12:10:30"
FUNCTION DEMO()
aDataTest := FT_ELAPSED(dStart,dEnd,cTimeStart,cTimeEnd)
FOR n := 1 to 4
? aDataTest[n,1], STR(aDataTest[n,2], 12, 4)
?? " "
?? iif(n == 1, 'Days', iif( n== 2, 'Hours', iif( n == 3, 'Mins.', 'Secs.')))
NEXT
RETURN NIL
LOCAL dStart, dEnd, cTimeStart, cTimeEnd, n, aDataTest := {}
dStart := SToD( '19901128' )
dEnd := SToD( '19901130' )
cTimeStart := "08:00:00"
cTimeEnd := "12:10:30"
aDataTest := FT_ELAPSED( dStart, dEnd, cTimeStart, cTimeEnd )
FOR n := 1 TO 4
? aDataTest[n,1], Str( aDataTest[n,2], 12, 4 )
?? " "
?? iif( n == 1, 'Days', iif( n == 2, 'Hours', iif( n == 3, 'Mins.', 'Secs.' ) ) )
NEXT
RETURN NIL
#endif
FUNCTION FT_ELAPSED(dStart, dEnd, cTimeStart, cTimeEnd)
LOCAL nTotalSec, nCtr, nConstant, nTemp, aRetVal[4,2]
FUNCTION FT_ELAPSED( dStart, dEnd, cTimeStart, cTimeEnd )
IF ! ( VALTYPE(dStart) $ 'DC' )
dStart := DATE()
ELSEIF VALTYPE(dStart) == 'C'
cTimeStart := dStart
dStart := DATE()
ENDIF
LOCAL nTotalSec, nCtr, nConstant, nTemp, aRetVal[4,2]
IF ! ( VALTYPE(dEnd) $ 'DC' )
dEnd := DATE()
ELSEIF VALTYPE(dEnd) == 'C'
cTimeEnd := dEnd
dEnd := DATE()
ENDIF
IF ! ( ValType( dStart ) $ 'DC' )
dStart := Date()
ELSEIF ValType( dStart ) == 'C'
cTimeStart := dStart
dStart := Date()
ENDIF
IF VALTYPE(cTimeStart) != 'C' ; cTimeStart := '00:00:00' ; ENDIF
IF VALTYPE(cTimeEnd) != 'C' ; cTimeEnd := '00:00:00' ; ENDIF
IF ! ( ValType( dEnd ) $ 'DC' )
dEnd := Date()
ELSEIF ValType( dEnd ) == 'C'
cTimeEnd := dEnd
dEnd := Date()
ENDIF
nTotalSec := (dEnd - dStart) * 86400 + ;
VAL(cTimeEnd) * 3600 + ;
VAL(SUBSTR(cTimeEnd,AT(':', cTimeEnd)+1,2)) * 60 + ;
iif(RAT(':', cTimeEnd) == AT(':', cTimeEnd), 0, ;
VAL(SUBSTR(cTimeEnd,RAT(':', cTimeEnd)+1))) - ;
VAL(cTimeStart) * 3600 - ;
VAL(SUBSTR(cTimeStart,AT(':', cTimeStart)+1,2)) * 60 - ;
iif(RAT(':', cTimeStart) == AT(':', cTimeStart), 0, ;
VAL(SUBSTR(cTimeStart,RAT(':', cTimeStart)+1)))
IF ValType( cTimeStart ) != 'C' ; cTimeStart := '00:00:00' ; ENDIF
IF ValType( cTimeEnd ) != 'C' ; cTimeEnd := '00:00:00' ; ENDIF
nTemp := nTotalSec
nTotalSec := ( dEnd - dStart ) * 86400 + ;
Val( cTimeEnd ) * 3600 + ;
Val( SubStr( cTimeEnd,At(':', cTimeEnd ) + 1,2 ) ) * 60 + ;
iif( RAt( ':', cTimeEnd ) == At( ':', cTimeEnd ), 0, ;
Val( SubStr( cTimeEnd,RAt(':', cTimeEnd ) + 1 ) ) ) - ;
Val( cTimeStart ) * 3600 - ;
Val( SubStr( cTimeStart,At(':', cTimeStart ) + 1,2 ) ) * 60 - ;
iif( RAt( ':', cTimeStart ) == At( ':', cTimeStart ), 0, ;
Val( SubStr( cTimeStart,RAt(':', cTimeStart ) + 1 ) ) )
FOR nCtr := 1 to 4
nConstant := iif(nCtr == 1, 86400, iif(nCtr == 2, 3600, iif( nCtr == 3, 60, 1)))
aRetVal[nCtr,1] := INT(nTemp/nConstant)
aRetval[nCtr,2] := nTotalSec / nConstant
nTemp -= aRetVal[nCtr,1] * nConstant
NEXT
nTemp := nTotalSec
RETURN aRetVal
FOR nCtr := 1 TO 4
nConstant := iif( nCtr == 1, 86400, iif( nCtr == 2, 3600, iif( nCtr == 3, 60, 1 ) ) )
aRetVal[ nCtr, 1 ] := Int( nTemp / nConstant )
aRetval[ nCtr, 2 ] := nTotalSec / nConstant
nTemp -= aRetVal[ nCtr, 1 ] * nConstant
NEXT
RETURN aRetVal

31
harbour/contrib/hbnf/eltime.prg
View File

@@ -24,20 +24,21 @@
*
*/
function FT_ELTIME(cTIME1,cTIME2)
local nDELSECS, nHRS, nMINS, nSECS, nSECS1, nSECS2
FUNCTION FT_ELTIME( cTIME1, cTIME2 )
nSECS1 := (val(substr(cTIME1,1,2)) * 3600) +;
(val(substr(cTIME1,4,2)) * 60) + (val(substr(cTIME1,7)))
nSECS2 := (val(substr(cTIME2,1,2)) * 3600) +;
(val(substr(cTIME2,4,2)) * 60) + (val(substr(cTIME2,7)))
nDELSECS := abs(nSECS2 - nSECS1)
nHRS := int(nDELSECS / 3600)
nMINS := int((nDELSECS - nHRS * 3600) / 60)
nSECS := nDELSECS - (nHRS * 3600) - (nMINS * 60)
LOCAL nDELSECS, nHRS, nMINS, nSECS, nSECS1, nSECS2
return right("00" + ltrim(str(nHRS)),2) + ;
":" + ;
right("00" + ltrim(str(nMINS)),2) + ;
":" + ;
right("00" + ltrim(str(nSECS)),2)
nSECS1 := ( Val( SubStr( cTIME1, 1, 2 ) ) * 3600 ) + ;
( Val( SubStr( cTIME1, 4, 2 ) ) * 60 ) + ( Val( SubStr( cTIME1, 7 ) ) )
nSECS2 := ( Val( SubStr( cTIME2, 1, 2 ) ) * 3600 ) + ;
( Val( SubStr( cTIME2, 4, 2 ) ) * 60 ) + ( Val( SubStr( cTIME2, 7 ) ) )
nDELSECS := Abs( nSECS2 - nSECS1 )
nHRS := Int( nDELSECS / 3600 )
nMINS := Int( ( nDELSECS - nHRS * 3600 ) / 60 )
nSECS := nDELSECS - ( nHRS * 3600 ) - ( nMINS * 60 )
RETURN Right( "00" + LTrim( Str( nHRS ) ), 2 ) + ;
":" + ;
Right( "00" + LTrim( Str( nMINS ) ), 2 ) + ;
":" + ;
Right( "00" + LTrim( Str( nSECS ) ), 2 )

62
harbour/contrib/hbnf/findith.prg
View File

@@ -24,47 +24,51 @@
*
*/
#define IS_NOT_LOGICAL(x) (VALTYPE(x) != "L")
#define MAKE_UPPER(cString) (cString := UPPER(cString))
#define NULL ""
#ifdef FT_TEST
PROCEDURE Main( cCk, cStr, nOcc, xCase )
LOCAL nFind
if pcount() != 4
QOut( "usage: findith cCk cStr nOcc xCase")
quit
endif
xCase := iif( xCase == "Y", .t., .f. )
nOcc := val(nOcc)
QOut( iif( xCase, "Ignoring ", "Observing ") + "case:" )
PROCEDURE Main( cCk, cStr, nOcc, xCase )
LOCAL nFind
IF PCount() != 4
QOut( "usage: findith cCk cStr nOcc xCase" )
QUIT
ENDIF
xCase := iif( xCase == "Y", .T. , .F. )
nOcc := Val( nOcc )
QOut( iif( xCase, "Ignoring ", "Observing " ) + "case:" )
QOut( cStr )
nFind := FT_FINDITH( cCk, cStr, nOcc, xCase )
QOut( iif( nFind > 0, Space( nFind - 1 ) + "^" , "Not found" ) )
RETURN
QOut( cStr )
nFind := FT_FINDITH( cCk, cStr, nOcc, xCase )
QOut( iif( nFind > 0, space( nFind - 1) + "^" , "Not found" ) )
RETURN
#endif
FUNCTION FT_FINDITH(cCheckFor,cCheckIn,nWhichOccurrence,lIgnoreCase)
FUNCTION FT_FINDITH( cCheckFor, cCheckIn, nWhichOccurrence, lIgnoreCase )
LOCAL nIthOccurrence
// Is Case Sensitivity Important??
IF IS_NOT_LOGICAL(lIgnoreCase) .OR. ;
lIgnoreCase
// Is Case Sensitivity Important??
IF ! HB_ISLOGICAL( lIgnoreCase ) .OR. ;
lIgnoreCase
MAKE_UPPER(cCheckFor) // No, Force Everything to Uppercase
MAKE_UPPER(cCheckIn)
MAKE_UPPER( cCheckFor ) // No, Force Everything to Uppercase
MAKE_UPPER( cCheckIn )
ENDIF // IS_NOT_LOGICAL(lIgnoreCase) or
// lIgnoreCase
// lIgnoreCase
RETURN iif(nWhichOccurrence == 1, ;
AT(cCheckFor, cCheckIn), ;
iif((nIthOccurrence := AT(cCheckFor, ;
STRTRAN(cCheckIn, cCheckFor, ;
NULL, 1, ;
nWhichOccurrence-1))) == 0, ;
0, ;
nIthOccurrence + ((nWhichOccurrence - 1) * LEN(cCheckFor))))
RETURN iif( nWhichOccurrence == 1, ;
At( cCheckFor, cCheckIn ), ;
iif( ( nIthOccurrence := At(cCheckFor, ;
StrTran( cCheckIn, cCheckFor, ;
NULL, 1, ;
nWhichOccurrence - 1 ) ) ) == 0, ;
0, ;
nIthOccurrence + ( ( nWhichOccurrence - 1 ) * Len( cCheckFor ) ) ) )

6
harbour/contrib/hbnf/firstday.prg
View File

@@ -24,10 +24,10 @@
*
*/
FUNCTION FT_FDAY(dDateToChk)
FUNCTION FT_FDAY( dDateToChk )
IF Valtype(dDatetoChk) # "D"
IF ValType( dDatetoChk ) != "D"
dDatetoChk := Date()
ENDIF
RETURN dDateToChk - (DAY(dDateToChk)-1)
RETURN dDateToChk - ( Day( dDateToChk ) - 1 )

256
harbour/contrib/hbnf/floptst.prg
View File

@@ -36,7 +36,7 @@
* File header changed to conform to Toolkit standard.
*/
*/
///
#include "ftint86.ch"
@@ -51,6 +51,7 @@
#define CR_LF hb_eol()
PROCEDURE Main( cArg1 )
LOCAL nErrCode
IF ValType( cArg1 ) == "C"
@@ -65,170 +66,173 @@ PROCEDURE Main( cArg1 )
#endif
FUNCTION FT_FLOPTST( ; // error code defined by ERR_*
nDriveNum_i ; // letter of floppy drive.
)
LOCAL cBuffer
LOCAL nErrorCode
LOCAL nRetCode
nDriveNum_i ; // letter of floppy drive.
)
LOCAL cBuffer
LOCAL nErrorCode
LOCAL nRetCode
nRetCode := ERR_WRONG_PARAMETERS
IF ValType( nDriveNum_i ) == "N"
nRetCode := ERR_WRONG_PARAMETERS
IF ValType( nDriveNum_i ) == "N"
IF _GetDisketteNum( nDriveNum_i )
_ResetDisketteSystem()
_ReadBootSector( nDriveNum_i, @cBuffer, @nErrorCode )
IF _GetDisketteNum( nDriveNum_i )
_ResetDisketteSystem()
_ReadBootSector( nDriveNum_i, @cBuffer, @nErrorCode )
IF nErrorCode == 0
_WriteBootSector( nDriveNum_i, cBuffer, @nErrorCode )
DO CASE
CASE nErrorCode == 0
nRetCode := ERR_NO_ERROR
CASE nErrorCode == 3
nRetCode := ERR_WRITE_PROTECTED
OTHERWISE
nRetCode := ERR_UNKNOWN
ENDCASE
ELSE
DO CASE
CASE nErrorCode == 128 // 80h
nRetCode := ERR_DRIVE_NOT_READY
CASE nErrorCode == 2
nRetCode := ERR_UNFORMATTED
OTHERWISE
nRetCode := ERR_UNKNOWN
END CASE
ENDIF
ENDIF
IF nErrorCode == 0
_WriteBootSector( nDriveNum_i, cBuffer, @nErrorCode )
DO CASE
CASE nErrorCode == 0
nRetCode := ERR_NO_ERROR
CASE nErrorCode == 3
nRetCode := ERR_WRITE_PROTECTED
OTHERWISE
nRetCode := ERR_UNKNOWN
ENDCASE
ELSE
DO CASE
CASE nErrorCode == 128 // 80h
nRetCode := ERR_DRIVE_NOT_READY
CASE nErrorCode == 2
nRetCode := ERR_UNFORMATTED
OTHERWISE
nRetCode := ERR_UNKNOWN
END CASE
ENDIF
ENDIF
ENDIF
RETURN nRetCode
RETURN nRetCode
#define BITS_6AND7 192 // value of byte when bits 6&7 are high
STATIC FUNCTION _GetDisketteNum( ; // returns false if no floppy drive installed or nDrive_i is invalid
nDrive_i ; // drive number to query status
)
LOCAL aRegs[INT86_MAX_REGS]
LOCAL lRetCode
LOCAL nByte
LOCAL nDriveCount
nDrive_i ; // drive number to query status
)
LOCAL aRegs[ INT86_MAX_REGS ]
LOCAL lRetCode
LOCAL nByte
LOCAL nDriveCount
// ASSERT 0 <= nDrive_i
// ASSERT 0 <= nDrive_i
lRetCode := .F.
IF FT_INT86( 1*16+1, aRegs ) // INT for equipment determination
nByte := lowbyte( aRegs[AX] )
// bit 0 indicates floppy drive installed
IF Int( nByte / 2 ) * 2 != nByte // is it odd i.e. is bit 0 set??
// bits 6 & 7 indicate number of floppies installed upto 4.
nDriveCount := Asc( FT_BYTEAND( Chr(nByte), chr(BITS_6AND7) ) )
IF nDriveCount >= nDrive_i
lRetCode := .T.
ENDIF
ENDIF
lRetCode := .F.
IF FT_INT86( 1 * 16 + 1, aRegs ) // INT for equipment determination
nByte := lowbyte( aRegs[ AX ] )
// bit 0 indicates floppy drive installed
IF Int( nByte / 2 ) * 2 != nByte // is it odd i.e. is bit 0 set??
// bits 6 & 7 indicate number of floppies installed upto 4.
nDriveCount := Asc( FT_BYTEAND( Chr( nByte ), Chr( BITS_6AND7 ) ) )
IF nDriveCount >= nDrive_i
lRetCode := .T.
ENDIF
ENDIF
ENDIF
RETURN lRetCode
RETURN lRetCode
STATIC PROCEDURE _ResetDisketteSystem()
LOCAL aRegs[INT86_MAX_REGS]
aRegs[AX] := 0
LOCAL aRegs[ INT86_MAX_REGS ]
FT_INT86( 1*16+3, aRegs )
aRegs[ AX ] := 0
RETURN
FT_INT86( 1 * 16 + 3, aRegs )
RETURN
#define BUFFER_SIZEOF_SECTOR 512+1
STATIC FUNCTION _ReadBootSector( ;
nDriveNum, ;
cBuffer_o, ;
nErrCode_o ;
)
// call BIOS INT 13 for sector read
LOCAL aRegs[INT86_MAX_REGS]
LOCAL cBuffer := Space( BUFFER_SIZEOF_SECTOR )
LOCAL lSuccess
LOCAL nErrorCode
LOCAL lCarryFlag
nDriveNum, ;
cBuffer_o, ;
nErrCode_o ;
)
aRegs[DX] := nDriveNum // DH = 0 Head 0, DL = drive number
aRegs[CX] := 1 // CH = 0 track 0, CL=1 sector 1
aRegs[BX] := REG_ES // buffer in ES:BX
aRegs[ES] := cBuffer
aRegs[AX] := makehi(2)+1 // AH = 02 read , AL=1 read one sector
// call BIOS INT 13 for sector read
LOCAL aRegs[ INT86_MAX_REGS ]
LOCAL cBuffer := Space( BUFFER_SIZEOF_SECTOR )
LOCAL lSuccess
LOCAL nErrorCode
LOCAL lCarryFlag
lSuccess := _CallInt13hRetry( aRegs, @lCarryFlag, @nErrorCode )
aRegs[ DX ] := nDriveNum // DH = 0 Head 0, DL = drive number
aRegs[ CX ] := 1 // CH = 0 track 0, CL=1 sector 1
aRegs[ BX ] := REG_ES // buffer in ES:BX
aRegs[ ES ] := cBuffer
aRegs[ AX ] := makehi( 2 ) + 1 // AH = 02 read , AL=1 read one sector
cBuffer_o := aRegs[ES]
lSuccess := _CallInt13hRetry( aRegs, @lCarryFlag, @nErrorCode )
cBuffer_o := aRegs[ ES ]
nErrCode_o := nErrorCode
RETURN lSuccess
RETURN lSuccess
STATIC FUNCTION _WriteBootSector( ;
nDriveNum, ;
cBuffer_i, ;
nErrCode_o ;
)
// call BIOS INT 13 for sector write
LOCAL aRegs[INT86_MAX_REGS]
LOCAL lSuccess
LOCAL nErrorCode
LOCAL lCarryFlag
nDriveNum, ;
cBuffer_i, ;
nErrCode_o ;
)
aRegs[DX] := nDriveNum // DH = 0 Head 0 , DL = drive number
aRegs[CX] := 1 // CH = 0 track 0, CL=1 sector 1
aRegs[BX] := REG_ES // buffer in ES:BX
aRegs[ES] := cBuffer_i
aRegs[AX] := makehi(3)+1 // AH = 03 write , AL=1 read one sector
// call BIOS INT 13 for sector write
LOCAL aRegs[INT86_MAX_REGS]
LOCAL lSuccess
LOCAL nErrorCode
LOCAL lCarryFlag
lSuccess := _CallInt13hRetry( aRegs, @lCarryFlag, @nErrorCode )
aRegs[ DX ] := nDriveNum // DH = 0 Head 0 , DL = drive number
aRegs[ CX ] := 1 // CH = 0 track 0, CL=1 sector 1
aRegs[ BX ] := REG_ES // buffer in ES:BX
aRegs[ ES ] := cBuffer_i
aRegs[ AX ] := makehi( 3 ) + 1 // AH = 03 write , AL=1 read one sector
lSuccess := _CallInt13hRetry( aRegs, @lCarryFlag, @nErrorCode )
nErrCode_o := nErrorCode
RETURN lSuccess
RETURN lSuccess
STATIC FUNCTION _CallInt13hRetry( ; // logical: did the interrupt succeed?
aRegs_io, ; // registers values for INT 13h
lCarrySet_o, ; // status of carry flag if return code is true.
nDriveStatus_o ; // status of drive ( error code )
)
LOCAL lCarrySet
LOCAL aRegisters
LOCAL lSuccess
LOCAL nInterrupt_c := 1*16+3 // INT 13h
LOCAL i
aRegs_io, ; // registers values for INT 13h
lCarrySet_o, ; // status of carry flag if return code is true.
nDriveStatus_o ; // status of drive ( error code )
)
LOCAL lCarrySet
LOCAL aRegisters
LOCAL lSuccess
LOCAL nInterrupt_c := 1 * 16 + 3 // INT 13h
LOCAL i
lCarrySet := .F.
aRegisters := AClone( aRegs_io )
lSuccess := FT_INT86( nInterrupt_c, aRegisters )
IF lSuccess
lCarrySet := carrySet( aRegisters[FLAGS] )
lCarrySet := .F.
aRegisters := AClone( aRegs_io )
lSuccess := FT_INT86( nInterrupt_c, aRegisters )
IF lSuccess
lCarrySet := carrySet( aRegisters[ FLAGS ] )
IF lCarrySet
_ResetDisketteSystem()
aRegisters := AClone( aRegs_io )
FT_INT86( nInterrupt_c, aRegisters )
lCarrySet := carrySet( aRegisters[ FLAGS ] )
IF lCarrySet
_ResetDisketteSystem()
aRegisters := AClone( aRegs_io )
FT_INT86( nInterrupt_c, aRegisters )
lCarrySet := carrySet( aRegisters[ FLAGS ] )
IF lCarrySet
_ResetDisketteSystem()
aRegisters := AClone( aRegs_io )
FT_INT86( nInterrupt_c, aRegisters )
lCarrySet := carrySet( aRegisters[FLAGS] )
IF lCarrySet
_ResetDisketteSystem()
aRegisters := AClone( aRegs_io )
FT_INT86( nInterrupt_c, aRegisters )
lCarrySet := carrySet( aRegisters[FLAGS] )
IF lCarrySet
_ResetDisketteSystem()
ENDIF
ENDIF
_ResetDisketteSystem()
ENDIF
ENDIF
ENDIF
ENDIF
FOR i := 1 TO INT86_MAX_REGS
// pass altered register back up
aRegs_io[i] := aRegisters[i]
NEXT // i
lCarrySet_o := lCarrySet
nDriveStatus_o := highByte( aRegisters[AX] )
FOR i := 1 TO INT86_MAX_REGS
// pass altered register back up
aRegs_io[ i ] := aRegisters[ i ]
NEXT
lCarrySet_o := lCarrySet
nDriveStatus_o := highByte( aRegisters[ AX ] )
RETURN lSuccess
RETURN lSuccess

108
harbour/contrib/hbnf/ftround.prg
View File

@@ -24,7 +24,7 @@
*
*/
#define IS_NEGATIVE(x) ((x) < 0)
#include "common.ch"
#define NEAREST_DECIMAL "D"
#define NEAREST_FRACTION "F"
@@ -33,90 +33,80 @@
#define ROUND_NORMAL "N"
#define ROUND_UP "U"
#command DEFAULT <Param1> TO <Def1> [, <ParamN> TO <DefN> ] ;
=> ;
<Param1> := iif(<Param1> == NIL,<Def1>,<Param1>) ;
[; <ParamN> := iif(<ParamN> == NIL,<DefN>,<ParamN>)]
FUNCTION FT_ROUND( nNumber, nRoundToAmount, cRoundType, cRoundDirection, ;
nAcceptableError )
#command DEFAULT <Param1> TO <Def1> IF NOT <Type1> ;
[, <ParamN> TO <DefN> IF NOT <TypeN> ] ;
=> ;
<Param1> := iif(VALTYPE(<Param1>) == <Type1>,<Param1>,<Def1>) ;
[; <ParamN> := iif(VALTYPE(<ParamN>) == <TypeN>,<ParamN>,<DefN>)]
LOCAL nResult := Abs( nNumber ) // The Result of the Rounding
FUNCTION FT_ROUND(nNumber, nRoundToAmount, cRoundType, cRoundDirection, ;
nAcceptableError)
DEFAULT nRoundToAmount TO 2
DEFAULT cRoundType TO NEAREST_DECIMAL
DEFAULT cRoundDirection TO ROUND_NORMAL
DEFAULT nAcceptableError TO 1 / ( nRoundToAmount ** 2 )
LOCAL nResult := ABS(nNumber) // The Result of the Rounding
// Are We Rounding to the Nearest Whole
// Number or to Zero Decimal Places??
IF ( Left( cRoundType, 1 ) != NEAREST_WHOLE_NUMBER .AND. ;
( nRoundToAmount := Int( nRoundToAmount ) ) != 0 )
DEFAULT nRoundToAmount TO 2, ;
cRoundType TO NEAREST_DECIMAL, ;
cRoundDirection TO ROUND_NORMAL, ;
nAcceptableError TO 1 / (nRoundToAmount ** 2)
// No, Are We Rounding to the Nearest
// Decimal Place??
IF ( Left( cRoundType, 1 ) == NEAREST_DECIMAL )
// Are We Rounding to the Nearest Whole
// Number or to Zero Decimal Places??
IF (LEFT(cRoundType,1) != NEAREST_WHOLE_NUMBER .AND. ;
(nRoundToAmount := INT(nRoundToAmount)) != 0)
// No, Are We Rounding to the Nearest
// Decimal Place??
IF (LEFT(cRoundType,1) == NEAREST_DECIMAL)
// Yes, Convert to Nearest Fraction
// Yes, Convert to Nearest Fraction
nRoundToAmount := 10 ** nRoundToAmount
ENDIF // LEFT(cRoundType,1) == NEAREST_DECIMAL
ENDIF // LEFT( cRoundType, 1 ) == NEAREST_DECIMAL
// Are We Already Within the Acceptable
// Error Factor??
IF (ABS(INT(nResult * nRoundToAmount) - (nResult * nRoundToAmount)) > ;
nAcceptableError)
// No, Are We Rounding Down??
nResult -= iif(LEFT(cRoundDirection,1) == ROUND_DOWN, ;
; // Yes, Make Downward Adjustment
1 / nRoundToAmount / 2, ;
; // Are We Rounding Up??
iif(LEFT(cRoundDirection,1) == ROUND_UP , ;
; // Yes, Make Upward Adjustment
-1 / (nRoundToAmount) / 2, ;
; // No, Rounding Normal, No Adjustment
0))
//Do the Actual Rounding
nResult := INT((nRoundToAmount * nResult) + .5 + nAcceptableError) / ;
nRoundToAmount
// Are We Already Within the Acceptable
// Error Factor??
IF ( Abs( Int(nResult * nRoundToAmount ) - ( nResult * nRoundToAmount ) ) > ;
nAcceptableError )
// No, Are We Rounding Down??
nResult -= iif( Left( cRoundDirection, 1 ) == ROUND_DOWN, ;
; // Yes, Make Downward Adjustment
1 / nRoundToAmount / 2, ;
; // Are We Rounding Up??
iif( Left( cRoundDirection, 1 ) == ROUND_UP , ;
; // Yes, Make Upward Adjustment
- 1 / ( nRoundToAmount ) / 2, ;
; // No, Rounding Normal, No Adjustment
0 ) )
//Do the Actual Rounding
nResult := Int( ( nRoundToAmount * nResult ) + .5 + nAcceptableError ) / ;
nRoundToAmount
ENDIF // ABS(INT(nResult * nRoundToAmount) -
// (mResult * nRoundAmount)) >
// nAcceptableError
// (mResult * nRoundAmount)) >
// nAcceptableError
ELSE // Yes, Round to Nearest Whole Number
// or to Zero Places
// or to Zero Places
nRoundToAmount := MAX(nRoundToAmount, 1)
nRoundToAmount := Max( nRoundToAmount, 1 )
DO CASE // Do "Whole" Rounding
CASE LEFT(cRoundDirection,1) == ROUND_UP
CASE Left( cRoundDirection, 1 ) == ROUND_UP
nResult := (INT(nResult / nRoundToAmount) * nRoundToAmount) + ;
nRoundToAmount
nResult := ( Int( nResult / nRoundToAmount ) * nRoundToAmount ) + ;
nRoundToAmount
CASE LEFT(cRoundDirection,1) == ROUND_DOWN
CASE Left( cRoundDirection, 1 ) == ROUND_DOWN
nResult := INT(nResult / nRoundToAmount) * nRoundToAmount
nResult := Int( nResult / nRoundToAmount ) * nRoundToAmount
OTHERWISE // Round Normally
OTHERWISE // Round Normally
nResult := INT((nResult + nRoundToAmount / 2) / nRoundToAmount) * ;
nRoundToAmount
nResult := Int( ( nResult + nRoundToAmount / 2 ) / nRoundToAmount ) * ;
nRoundToAmount
ENDCASE
ENDIF // LEFT(cRoundType,1)!=NEAREST_WHOLE or
// nRoundToAmount == 0
IF IS_NEGATIVE(nNumber) // Was the Number Negative??
IF nNumber < 0 // Was the Number Negative??
nResult := -nResult // Yes, Make the Result Negative Also
ENDIF // IS_NEGATIVE(nNumber)
ENDIF
RETURN nResult // FT_Round

42
harbour/contrib/hbnf/gcd.prg
View File

@@ -24,43 +24,43 @@
*
*/
#command REPEAT ;
=> ;
DO WHILE .T.
#command UNTIL <Condition> ;
=> ;
IF <Condition> ; EXIT ; END ; END
#ifdef FT_TEST
PROCEDURE Main( cNum1, cNum2 )
OUTSTD( STR(FT_GCD( val(cNum1), val(cNum2) )) + hb_eol() )
RETURN
PROCEDURE Main( cNum1, cNum2 )
OutStd( Str( FT_GCD( Val(cNum1 ), Val(cNum2 ) ) ) + hb_eol() )
RETURN
#endif
FUNCTION FT_GCD(nNumber1, nNumber2)
FUNCTION FT_GCD( nNumber1, nNumber2 )
LOCAL nHold1, ; // Temporarily Hold the Maximum Number
nHold2, ; // Temporarily Hold the Minimum Number
nResult // GCD
LOCAL nHold1 // Temporarily Hold the Maximum Number
LOCAL nHold2 // Temporarily Hold the Minimum Number
LOCAL nResult // GCD
// Either Number Zero??
IF (nNumber1 == 0 .OR. nNumber2 == 0)
// Either Number Zero??
IF nNumber1 == 0 .OR. nNumber2 == 0
nResult := 0 // Yes, Can't Have a GCD
ELSE // No, Calculate the GCD
nHold1 := MAX(ABS(nNumber1), ABS(nNumber2))
nHold2 := MIN(ABS(nNumber1), ABS(nNumber2))
nHold1 := Max( Abs( nNumber1 ), Abs( nNumber2 ) )
nHold2 := Min( Abs( nNumber1 ), Abs( nNumber2 ) )
REPEAT
DO WHILE .T.
nResult := nHold1 % nHold2 // Get the Remainder
nHold1 := nHold2 // Which Makes a New Maximum Number
nHold2 := nResult // and it's the Minimum Number
UNTIL nResult <= 0
IF nResult <= 0
EXIT
ENDIF
ENDDO
nResult := nHold1 // Maximum Number Should Be the Answer
ENDIF // nNumber1 == 0 or nNumber2 == 0
RETURN nResult // FT_GCD

21
harbour/contrib/hbnf/hex2dec.prg
View File

@@ -30,17 +30,22 @@
#define HEXTABLE "0123456789ABCDEF"
#ifdef FT_TEST
PROCEDURE Main( cHexNum )
QOut( FT_HEX2DEC( cHexNum ) )
RETURN
PROCEDURE Main( cHexNum )
QOut( FT_HEX2DEC( cHexNum ) )
RETURN
#endif
FUNCTION FT_HEX2DEC( cHexNum )
local n, nDec := 0, nHexPower := 1
for n := len( cHexNum ) to 1 step -1
nDec += ( at( subs( upper(cHexNum), n, 1 ), HEXTABLE ) - 1 ) * nHexPower
LOCAL n, nDec := 0, nHexPower := 1
FOR n := Len( cHexNum ) TO 1 step - 1
nDec += ( At( subs( Upper(cHexNum ), n, 1 ), HEXTABLE ) - 1 ) * nHexPower
nHexPower *= 16
next
NEXT
RETURN nDec
RETURN nDec

37
harbour/contrib/hbnf/invclr.prg
View File

@@ -24,30 +24,27 @@
*
*/
#command DEFAULT <Param1> TO <Def1> [, <ParamN> TO <DefN> ] ;
=> ;
<Param1> := iif(<Param1> == NIL,<Def1>,<Param1>) ;
[; <ParamN> := iif(<ParamN> == NIL,<DefN>,<ParamN>)]
#include "common.ch"
#define NULL ""
#define NULL ""
FUNCTION FT_INVCLR(cDsrdColor)
FUNCTION FT_INVCLR( cDsrdColor )
LOCAL cBackground, ; // The Background Color, New Foreground
cForeground, ; // The Foreground Color, New Background
cModifiers // Any Color Modifiers (+*)
LOCAL cBackground // The Background Color, New Foreground
LOCAL cForeground // The Foreground Color, New Background
LOCAL cModifiers // Any Color Modifiers (+*)
DEFAULT cDsrdColor TO SETCOLOR()
// Remove Anything Past 1st Color
cDsrdColor := LEFT(cDsrdColor, AT(",", cDsrdColor+",")-1)
DEFAULT cDsrdColor TO SetColor()
// Remove Anything Past 1st Color
cDsrdColor := Left( cDsrdColor, At( ",", cDsrdColor + "," ) - 1 )
// Get Any Modifiers
cModifiers := iif("*" $ cDsrdColor, "*", NULL) + ;
iif("+" $ cDsrdColor, "+", NULL)
// Get Any Modifiers
cModifiers := iif( "*" $ cDsrdColor, "*", NULL ) + ;
iif( "+" $ cDsrdColor, "+", NULL )
// Separate the Fore/Background Colors
cForeground := ALLTRIM(LEFT(cDsrdColor, AT("/", cDsrdColor) - 1))
cBackground := ALLTRIM(SUBSTR(cDsrdColor, AT("/", cDsrdColor) + 1))
// Separate the Fore/Background Colors
cForeground := AllTrim( Left( cDsrdColor, At( "/", cDsrdColor ) - 1 ) )
cBackground := AllTrim( SubStr( cDsrdColor, At( "/", cDsrdColor ) + 1 ) )
RETURN STRTRAN(STRTRAN(cBackground, "+"), "*") + cModifiers + "/" + ;
STRTRAN(STRTRAN(cForeground, "+"), "*")
RETURN StrTran( StrTran( cBackground, "+" ), "*" ) + cModifiers + "/" + ;
StrTran( StrTran( cForeground, "+" ), "*" )

24
harbour/contrib/hbnf/isbit.prg
View File

@@ -24,18 +24,18 @@
*
*/
FUNCTION FT_ISBIT(cInbyte,nBitPos)
FUNCTION FT_ISBIT( cInbyte, nBitPos )
LOCAL lBitStat
LOCAL lBitStat
IF valtype(cInbyte) != "C" .or. valtype(nBitPos) != "N" // parameter check
lBitStat := NIL
ELSE
if (nBitPos > 7) .or. (nBitPos < 0) .or. (nBitPos != int(nBitPos))
lBitStat := NIL
else
lBitStat := int(((asc(cInByte) * (2 ^ (7 - nBitPos))) % 256) / 128) == 1
endif
ENDIF
IF ValType( cInbyte ) != "C" .OR. ValType( nBitPos ) != "N" // parameter check
lBitStat := NIL
ELSE
IF nBitPos > 7 .OR. nBitPos < 0 .OR. nBitPos != Int( nBitPos )
lBitStat := NIL
ELSE
lBitStat := Int( ( ( Asc( cInByte ) * ( 2 ^ ( 7 - nBitPos ) ) ) % 256 ) / 128 ) == 1
ENDIF
ENDIF
RETURN lBitStat
RETURN lBitStat

12
harbour/contrib/hbnf/isbiton.prg
View File

@@ -27,11 +27,11 @@
*
*/
function FT_ISBITON( nWord, nBit )
FUNCTION FT_ISBITON( nWord, nBit )
nWord := iif(nWord < 0, nWord + 65536, nWord)
nWord := int(nWord * (2 ^ (15 - nBit)))
nWord := int(nWord % 65536)
nWord := int(nWord / 32768)
nWord := iif( nWord < 0, nWord + 65536, nWord )
nWord := Int( nWord * ( 2 ^ ( 15 - nBit ) ) )
nWord := Int( nWord % 65536 )
nWord := Int( nWord / 32768 )
return (nWord == 1)
RETURN ( nWord == 1 )

42
harbour/contrib/hbnf/isshare.prg
View File

@@ -31,32 +31,36 @@
#include "ftint86.ch"
#ifdef FT_TEST
PROCEDURE Main()
local nLoaded := ft_isshare()
do case
case nLoaded == 0
Qout("Share not loaded, but ok to load")
case nLoaded == 1
Qout("Share not loaded, but NOT ok to load!")
case nLoaded == 255
Qout("Share is loaded!")
endcase
PROCEDURE Main()
Qout("Retcode: " + str( nLoaded ) )
LOCAL nLoaded := ft_isshare()
DO CASE
CASE nLoaded == 0
QOut( "Share not loaded, but ok to load" )
CASE nLoaded == 1
QOut( "Share not loaded, but NOT ok to load!" )
CASE nLoaded == 255
QOut( "Share is loaded!" )
ENDCASE
QOut( "Retcode: " + Str( nLoaded ) )
RETURN
return
#endif
FUNCTION ft_isshare()
/*
local aRegs[ INT86_MAX_REGS ] // Declare the register array
LOCAL aRegs[ INT86_MAX_REGS ] // Declare the register array
aRegs[ AX ] := makehi(16) // share service
aRegs[ CX ] := 0 // Specify file attribute
aRegs[ AX ] := makehi( 16 ) // share service
aRegs[ CX ] := 0 // Specify file attribute
FT_Int86( 47, aRegs) // multiplex interrupt
FT_Int86( 47, aRegs) // multiplex interrupt
RETURN lowbyte( aRegs[AX] )
*/
RETURN _ft_isshare()
RETURN lowbyte( aRegs[ AX ] )
*/
RETURN _ft_isshare()

9
harbour/contrib/hbnf/lastday.prg
View File

@@ -29,8 +29,11 @@
*/
FUNCTION ft_lday( dDate )
LOCAL d:= dDate
LOCAL d := dDate
IF dDate == NIL
d:= Date()
d := Date()
ENDIF
RETURN ( d+= 45 - Day( d ) ) - Day( d )
RETURN ( d += 45 - Day( d ) ) - Day( d )

101
harbour/contrib/hbnf/linked.prg
View File

@@ -26,30 +26,33 @@
#ifdef FT_TEST
PROCEDURE Main()
LOCAL cString
LOCAL aString := { "TRIM('abc ')", ;
"NotARealFunc()", ;
"FT_DispMsg()", ;
'TRIM(cVar+"abc"+LEFT(cString)), FOUND()', ;
"IsItLinked()", ;
"lRetVal := FOUND()", ;
"!EOF() .AND. MONTH(DATE())=12 .AND. YeeHa()", ;
"!EOF() .AND. MONTH(DATE())=12", ;
"!EOF() .AND. MONTH(DATE(YeeHa()))=12", ;
"LEFT(SUBSTR(nNum,4,VAL(cChar+ASC(c))))", ;
"EOF(>> Note: Syntax IS NOT checked! <<)" ;
}
CLS
@ 1,0 SAY "String Tested Result"
@ 2,0 TO 2,MAXCOL()
AEVAL(aString, {|ele,num| QOUT(ele, SPACE(45-LEN(ele)), FT_Linked(ele)) } )
@ MAXROW()-2,0
RETURN
PROCEDURE Main()
LOCAL cString
LOCAL aString := { "TRIM('abc ')", ;
"NotARealFunc()", ;
"FT_DispMsg()", ;
'TRIM(cVar+"abc"+LEFT(cString)), FOUND()', ;
"IsItLinked()", ;
"lRetVal := FOUND()", ;
"!EOF() .AND. MONTH(DATE())=12 .AND. YeeHa()", ;
"!EOF() .AND. MONTH(DATE())=12", ;
"!EOF() .AND. MONTH(DATE(YeeHa()))=12", ;
"LEFT(SUBSTR(nNum,4,VAL(cChar+ASC(c))))", ;
"EOF(>> Note: Syntax IS NOT checked! <<)" ;
}
CLS
@ 1, 0 SAY "String Tested Result"
@ 2, 0 TO 2, MaxCol()
AEval( aString, {|ele, num| QOut( ele, Space(45 - Len(ele ) ), FT_Linked(ele ) ) } )
@ MaxRow() - 2, 0
RETURN
#endif
*------------------------------------------------
//------------------------------------------------
FUNCTION FT_Linked( cFuncs )
@@ -59,32 +62,34 @@ FUNCTION FT_Linked( cFuncs )
// Returns: .T. if all functions are available,
// .F. if not
LOCAL aFuncArray := {}, nSpace, nComma, nFEnd, lRetVal := .F.
LOCAL aFuncArray := {}, nSpace, nComma, nFEnd, lRetVal := .F.
IF AT("(",cFuncs) == 0
// No functions in string
ALERT("Warning: Expected function(s) in FT_Linked(), but none were found")
ELSE
DO WHILE (nFEnd := AT("(",cFuncs)) > 0
// Add the current function to the array of functions
AADD( aFuncArray,LEFT(cFuncs,nFEnd)+")" )
// Remove the current function from the string
cFuncs := SUBSTR(cFuncs, nFEnd+1)
nSpace := AT(" ",cFuncs) ; nComma := AT(",",cFuncs)
DO WHILE (nComma > 0 .and. nComma < nFEnd) .or. ;
(nSpace > 0 .and. nSpace < nFEnd)
// We have extra parameters or spaces prior to the start
// of the function. Strip them out.
if nComma > 0
cFuncs := SUBSTR(cFuncs, nComma+1)
elseif nSpace > 0
cFuncs := SUBSTR(cFuncs, nSpace+1)
endif
nSpace := AT(" ", cFuncs) ; nComma := AT(",", cFuncs)
IF At( "(", cFuncs ) == 0
// No functions in string
Alert( "Warning: Expected function(s) in FT_Linked(), but none were found" )
ELSE
DO WHILE ( nFEnd := At( "(",cFuncs ) ) > 0
// Add the current function to the array of functions
AAdd( aFuncArray, Left( cFuncs,nFEnd ) + ")" )
// Remove the current function from the string
cFuncs := SubStr( cFuncs, nFEnd + 1 )
nSpace := At( " ", cFuncs ) ; nComma := At( ",", cFuncs )
DO WHILE ( nComma > 0 .AND. nComma < nFEnd ) .OR. ;
( nSpace > 0 .AND. nSpace < nFEnd )
// We have extra parameters or spaces prior to the start
// of the function. Strip them out.
IF nComma > 0
cFuncs := SubStr( cFuncs, nComma + 1 )
ELSEIF nSpace > 0
cFuncs := SubStr( cFuncs, nSpace + 1 )
ENDIF
nSpace := At( " ", cFuncs )
nComma := At( ",", cFuncs )
ENDDO
ENDDO
ENDDO
// Scan through the array of functions, stop after the first occurence
// of a function which returns a TYPE() of "U" (hence is not linked in)
lRetVal := ASCAN(aFuncArray,{|element| TYPE(element)=="U"})=0
ENDIF
RETURN( lRetVal )
// Scan through the array of functions, stop after the first occurence
// of a function which returns a TYPE() of "U" (hence is not linked in)
lRetVal := AScan( aFuncArray, {|element| Type( element ) == "U" } ) = 0
ENDIF
RETURN lRetVal

43
harbour/contrib/hbnf/madd.prg
View File

@@ -27,32 +27,33 @@
*
*/
FUNCTION FT_MADD( dGivenDate, nAddMonths, lMakeEOM)
LOCAL nAdjDay, dTemp, i
FUNCTION FT_MADD( dGivenDate, nAddMonths, lMakeEOM )
IF VALTYPE(dGivenDate) != 'D' ; dGivenDate := DATE() ; ENDIF
IF VALTYPE(nAddMonths) != 'N' ; nAddMonths := 0 ; ENDIF
IF VALTYPE(lMakeEOM) != 'L' ; lMakeEom := .F. ; ENDIF
LOCAL nAdjDay, dTemp, i
nAdjDay := DAY( dGivenDate ) - 1
IF ValType( dGivenDate ) != 'D' ; dGivenDate := Date() ; ENDIF
IF ValType( nAddMonths ) != 'N' ; nAddMonths := 0 ; ENDIF
IF ValType( lMakeEOM ) != 'L' ; lMakeEom := .F. ; ENDIF
/* If givendate is end of month and lMakeEom, then force EOM.*/
nAdjDay := Day( dGivenDate ) - 1
lMakeEom := ( lMakeEom .AND. dGivenDate == dGivenDate - nAdjDay + 31 - ;
DAY( dGivenDate - nAdjDay + 31 ) )
/* If givendate is end of month and lMakeEom, then force EOM.*/
dTemp := dGivenDate - nAdjDay // first of month
lMakeEom := ( lMakeEom .AND. dGivenDate == dGivenDate - nAdjDay + 31 - ;
Day( dGivenDate - nAdjDay + 31 ) )
/* Work with 1st of months.*/
FOR i := 1 TO ABS(nAddMonths)
dTemp += iif( nAddMonths > 0, 31, -1 )
dTemp += 1 - DAY( dTemp )
NEXT
dTemp := dGivenDate - nAdjDay // first of month
IF lMakeEom
dTemp += 31 - DAY( dTemp + 31 )
ELSE
dTemp := MIN( (dTemp + nAdjday), (dTemp += 31 - DAY( dTemp + 31 )))
ENDIF
/* Work with 1st of months.*/
FOR i := 1 TO Abs( nAddMonths )
dTemp += iif( nAddMonths > 0, 31, - 1 )
dTemp += 1 - Day( dTemp )
NEXT
RETURN dTemp
IF lMakeEom
dTemp += 31 - Day( dTemp + 31 )
ELSE
dTemp := Min( ( dTemp + nAdjday ), ( dTemp += 31 - Day( dTemp + 31 ) ) )
ENDIF
RETURN dTemp

374
harbour/contrib/hbnf/menu1.prg
View File

@@ -60,72 +60,74 @@
#define SCNONE 0
#define SCNORMAL 1
THREAD STATIC ACHOICES := {}, AVALIDKEYS := {}
THREAD STATIC NHPOS, NVPOS, NMAXROW, NMAXCOL
THREAD STATIC ACHOICES := {}, AVALIDKEYS := {}
THREAD STATIC NHPOS, NVPOS, NMAXROW, NMAXCOL
// BEGINNING OF DEMO PROGRAM
#ifdef FT_TEST
// DUMMY PROCEDURE NAME SO "CCMDLINE" WILL BE LOCAL
PROCEDURE CALLMENU( cCmdLine )
// DUMMY PROCEDURE NAME SO "CCMDLINE" WILL BE LOCAL
PROCEDURE CALLMENU( cCmdLine )
LOCAL sDosScrn, nDosRow, nDosCol, lColor
// my approach to color variables
// see colorchg.arc on NANFORUM
// my approach to color variables
// see colorchg.arc on NANFORUM
STATIC cNormH, cNormN, cNormE, ;
cWindH, cWindN, cWindE, ;
cErrH, cErrN, cErrE
cWindH, cWindN, cWindE, ;
cErrH, cErrN, cErrE
// options on menu bar
// options on menu bar
LOCAL aColors := {}
LOCAL aBar := { " ENTER/EDIT ", " REPORTS ", " DISPLAY ", " MAINTENANCE ", " QUIT " }
LOCAL aOptions[ LEN( aBar ) ]
AEVAL( aBar, { |x,i| aOptions[i] := { {},{},{} } } )
AEval( aBar, { |x, i| aOptions[i] := { {},{},{} } } )
cCmdLine := iif( cCmdLine == NIL, "", cCmdLine )
lColor := iif( "MONO" $ UPPER( cCmdLine ), .F., IsColor() )
lColor := iif( "MONO" $ Upper( cCmdLine ), .F. , IsColor() )
* Border, Box, Bar, Current, Unselected
aColors := iif( lColor, {"W+/G", "N/G", "N/G", "N/W", "N+/G"}, ;
{"W+/N", "W+/N", "W/N", "N/W", "W/N"} )
// Border, Box, Bar, Current, Unselected
aColors := iif( lColor, { "W+/G", "N/G", "N/G", "N/W", "N+/G" }, ;
{ "W+/N", "W+/N", "W/N", "N/W", "W/N" } )
FT_FILL( aOptions[1], 'A. Execute A Dummy Procedure' , {|| fubar()}, .t. )
FT_FILL( aOptions[1], 'B. Enter Daily Charge/Credit Slips' , {|| .t.}, .t. )
FT_FILL( aOptions[1], 'C. Enter Payments On Accounts' , {|| .t.}, .f. )
FT_FILL( aOptions[1], 'D. Edit Daily Transactions' , {|| .t.}, .t. )
FT_FILL( aOptions[1], 'E. Enter/Update Member File' , {|| .t.}, .t. )
FT_FILL( aOptions[1], 'F. Update Code File' , {|| .t.}, .f. )
FT_FILL( aOptions[1], 'G. Add/Update Auto Charge File' , {|| .t.}, .t. )
FT_FILL( aOptions[1], 'H. Post All Transactions To A/R File', {|| .t.}, .t. )
FT_FILL( aOptions[1], 'I. Increment Next Posting Date' , {|| .t.}, .t. )
FT_FILL( aOptions[1], 'A. Execute A Dummy Procedure' , {|| fubar() }, .T. )
FT_FILL( aOptions[1], 'B. Enter Daily Charge/Credit Slips' , {|| .T. }, .T. )
FT_FILL( aOptions[1], 'C. Enter Payments On Accounts' , {|| .T. }, .F. )
FT_FILL( aOptions[1], 'D. Edit Daily Transactions' , {|| .T. }, .T. )
FT_FILL( aOptions[1], 'E. Enter/Update Member File' , {|| .T. }, .T. )
FT_FILL( aOptions[1], 'F. Update Code File' , {|| .T. }, .F. )
FT_FILL( aOptions[1], 'G. Add/Update Auto Charge File' , {|| .T. }, .T. )
FT_FILL( aOptions[1], 'H. Post All Transactions To A/R File', {|| .T. }, .T. )
FT_FILL( aOptions[1], 'I. Increment Next Posting Date' , {|| .T. }, .T. )
FT_FILL( aOptions[2], 'A. Print Member List' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'B. Print Active Auto Charges' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'C. Print Edit List' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'D. Print Pro-Usage Report' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'E. Print A/R Transaction Report' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'F. Aging Report Preparation' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'G. Add Interest Charges' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'H. Print Aging Report' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'I. Print Monthly Statements' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'J. Print Mailing Labels' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'K. Print Transaction Totals' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'L. Print Transaction Codes File' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'M. Print No-Activity List' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'A. Print Member List' , {|| .T. }, .T. )
FT_FILL( aOptions[2], 'B. Print Active Auto Charges' , {|| .T. }, .T. )
FT_FILL( aOptions[2], 'C. Print Edit List' , {|| .T. }, .T. )
FT_FILL( aOptions[2], 'D. Print Pro-Usage Report' , {|| .T. }, .T. )
FT_FILL( aOptions[2], 'E. Print A/R Transaction Report' , {|| .T. }, .T. )
FT_FILL( aOptions[2], 'F. Aging Report Preparation' , {|| .T. }, .T. )
FT_FILL( aOptions[2], 'G. Add Interest Charges' , {|| .T. }, .T. )
FT_FILL( aOptions[2], 'H. Print Aging Report' , {|| .T. }, .T. )
FT_FILL( aOptions[2], 'I. Print Monthly Statements' , {|| .T. }, .T. )
FT_FILL( aOptions[2], 'J. Print Mailing Labels' , {|| .T. }, .T. )
FT_FILL( aOptions[2], 'K. Print Transaction Totals' , {|| .T. }, .T. )
FT_FILL( aOptions[2], 'L. Print Transaction Codes File' , {|| .T. }, .T. )
FT_FILL( aOptions[2], 'M. Print No-Activity List' , {|| .T. }, .T. )
FT_FILL( aOptions[3], 'A. Transaction Totals Display' , {|| .t.}, .t. )
FT_FILL( aOptions[3], 'B. Display Invoice Totals' , {|| .t.}, .t. )
FT_FILL( aOptions[3], 'C. Accounts Receivable Display' , {|| .t.}, .t. )
FT_FILL( aOptions[3], 'A. Transaction Totals Display' , {|| .T. }, .T. )
FT_FILL( aOptions[3], 'B. Display Invoice Totals' , {|| .T. }, .T. )
FT_FILL( aOptions[3], 'C. Accounts Receivable Display' , {|| .T. }, .T. )
FT_FILL( aOptions[4], 'A. Backup Database Files' , {|| .t.}, .t. )
FT_FILL( aOptions[4], 'B. Reindex Database Files' , {|| .t.}, .t. )
FT_FILL( aOptions[4], 'C. Set System Parameters' , {|| .t.}, .t. )
FT_FILL( aOptions[4], 'D. This EXITs Too' , {|| .f. }, .t. )
FT_FILL( aOptions[4], 'A. Backup Database Files' , {|| .T. }, .T. )
FT_FILL( aOptions[4], 'B. Reindex Database Files' , {|| .T. }, .T. )
FT_FILL( aOptions[4], 'C. Set System Parameters' , {|| .T. }, .T. )
FT_FILL( aOptions[4], 'D. This EXITs Too' , {|| .F. }, .T. )
FT_FILL( aOptions[5], 'A. Does Nothing' , {|| .t.}, .t. )
FT_FILL( aOptions[5], 'B. Exit To DOS' , {|| .f. }, .t. )
FT_FILL( aOptions[5], 'A. Does Nothing' , {|| .T. }, .T. )
FT_FILL( aOptions[5], 'B. Exit To DOS' , {|| .F. }, .T. )
// main routine starts here
// main routine starts here
SET SCOREBOARD OFF
cNormH := iif( lColor, "W+/G", "W+/N" )
@@ -139,230 +141,250 @@ THREAD STATIC NHPOS, NVPOS, NMAXROW, NMAXCOL
cErrE := iif( lColor, "N/W" , "N/W" )
SAVE SCREEN TO sDosScrn
nDosRow := ROW()
nDosCol := COL()
SETCOLOR( "w/n" )
nDosRow := Row()
nDosCol := Col()
SetColor( "w/n" )
CLS
NOSNOW( ( "NOSNOW" $ UPPER( cCmdLine ) ) )
IF "VGA" $ UPPER( cCmdLine )
SETMODE(50,80)
NoSnow( ( "NOSNOW" $ Upper( cCmdLine ) ) )
IF "VGA" $ Upper( cCmdLine )
SetMode( 50, 80 )
ENDIF
nMaxRow := MAXROW()
SETBLINK(.f.)
SETCOLOR( cWindN + "*" )
nMaxRow := MaxRow()
SetBlink( .F. )
SetColor( cWindN + "*" )
CLS
SETCOLOR( cNormN )
SetColor( cNormN )
@ nMaxRow, 0
@ nMaxRow, 0 SAY hb_UTF8ToStr( " FT_MENU1 1.0 │ " )
@ NMAXROW,16 SAY "WRITTEN BY PAUL FERRARA [76702,556] FOR NANFORUM.LIB"
@ NMAXROW,69 SAY hb_UTF8ToStr( "│ " )+DTOC( DATE() )
@ NMAXROW, 16 SAY "WRITTEN BY PAUL FERRARA [76702,556] FOR NANFORUM.LIB"
@ NMAXROW, 69 SAY hb_UTF8ToStr( "│ " ) + DToC( Date() )
SETCOLOR( cErrH )
@ nMaxRow-11, 23, nMaxRow-3, 56 BOX hb_UTF8ToStr( "┌─┐│┘─└│ " )
@ nMaxRow- 9,23 SAY hb_UTF8ToStr( "├────────────────────────────────┤" )
SETCOLOR( cErrN )
@ nMaxRow-10,33 SAY "Navigation Keys"
@ nMaxRow- 8,25 SAY "LeftArrow RightArrow Alt-E"
@ nMaxRow- 7,25 SAY "Home End Alt-R"
@ nMaxRow- 6,25 SAY "Tab Shift-Tab Alt-D"
@ nMaxRow- 5,25 SAY "PgUp PgDn Alt-M"
@ nMaxRow- 4,25 SAY "Enter ESCape Alt-Q"
SETCOLOR( cNormN )
SetColor( cErrH )
@ nMaxRow - 11, 23, nMaxRow - 3, 56 BOX hb_UTF8ToStr( "┌─┐│┘─└│ " )
@ nMaxRow - 9, 23 SAY hb_UTF8ToStr( "├────────────────────────────────┤" )
SetColor( cErrN )
@ nMaxRow - 10, 33 SAY "Navigation Keys"
@ nMaxRow - 8, 25 SAY "LeftArrow RightArrow Alt-E"
@ nMaxRow - 7, 25 SAY "Home End Alt-R"
@ nMaxRow - 6, 25 SAY "Tab Shift-Tab Alt-D"
@ nMaxRow - 5, 25 SAY "PgUp PgDn Alt-M"
@ nMaxRow - 4, 25 SAY "Enter ESCape Alt-Q"
SetColor( cNormN )
FT_MENU1( aBar, aOptions, aColors )
SETCOLOR( "W/N" )
SETCURSOR( SCNORMAL )
SETBLINK(.t.)
IF "VGA" $ UPPER( cCmdLine )
SETMODE(25,80)
SetColor( "W/N" )
SetCursor( SCNORMAL )
SetBlink( .T. )
IF "VGA" $ Upper( cCmdLine )
SetMode( 25, 80 )
ENDIF
RESTORE SCREEN FROM sDosScrn
SETPOS(nDosRow, nDosCol)
SetPos( nDosRow, nDosCol )
QUIT
FUNCTION fubar()
LOCAL OldColor:= SETCOLOR( "W/N" )
FUNCTION fubar()
LOCAL OldColor := SetColor( "W/N" )
CLS
Qout( "Press Any Key" )
INKEY(0)
SETCOLOR( OldColor )
RETURN .t.
QOut( "Press Any Key" )
Inkey( 0 )
SetColor( OldColor )
RETURN .T.
#endif
// end of demo program
FUNCTION FT_MENU1( aBar, aOptions, aColors, nTopRow, lShadow )
LOCAL nTtlUsed
LOCAL sMainScrn, lCancMode, lLooping := .t.
// column position for each item on the menu bar
LOCAL nTtlUsed
LOCAL sMainScrn, lCancMode, lLooping := .T.
// column position for each item on the menu bar
LOCAL aBarCol[LEN(aBar)]
// inkey code for each item on menu bar
// inkey code for each item on menu bar
LOCAL aBarKeys[ LEN( aBar ) ]
// inkey codes for A - Z
// inkey codes for A - Z
LOCAL aKeyCodes := { 286, 304, 302, 288, 274, 289, 290, 291, 279, ;
292, 293, 294, 306, 305, 280, 281, 272, 275, ;
287, 276, 278, 303, 273, 301, 277, 300 }
292, 293, 294, 306, 305, 280, 281, 272, 275, ;
287, 276, 278, 303, 273, 301, 277, 300 }
// LEN() of widest array element for for each pulldown menu
// LEN() of widest array element for for each pulldown menu
LOCAL aBarWidth[LEN(aBar)]
// starting column for each box
// starting column for each box
LOCAL aBoxLoc[LEN(aBar)]
// last selection for each element
// last selection for each element
LOCAL aLastSel[LEN(aBar)]
// color memvars
// color memvars
LOCAL cBorder := aColors[1]
LOCAL cBox := aColors[2]
LOCAL cBar := aColors[3]
LOCAL cCurrent := aColors[4]
LOCAL cUnSelec := aColors[5]
nMaxRow := MAXROW()
nMaxCol := MAXCOL()
nMaxRow := MaxRow()
nMaxCol := MaxCol()
// row for menu bar
// row for menu bar
nTopRow := iif( nTopRow == NIL, 0, nTopRow )
AFILL(aLastSel,1)
AFill( aLastSel, 1 )
aChoices := aOptions
// this is the routine that calculates the position of each item
// on the menu bar.
// this is the routine that calculates the position of each item
// on the menu bar.
aBarCol[1] := 0
nTtlUsed := LEN( aBar[1] ) + 1
AEVAL( aBar, ;
{|x,i| HB_SYMBOL_UNUSED( x ), aBarcol[i]:= nTtlUsed,nTtlUsed+= (LEN(aBar[i]) +1 )}, ;
2, LEN(aBar) -1 )
nTtlUsed := Len( aBar[1] ) + 1
AEval( aBar, ;
{|x, i| HB_SYMBOL_UNUSED( x ), aBarcol[i] := nTtlUsed, nTtlUsed += ( Len( aBar[i] ) + 1 ) }, ;
2, Len( aBar ) - 1 )
// calculates widest element for each pulldown menu
// see below for _ftWidest()
AFILL(aBarWidth,1)
AEVAL( aChoices, { |x,i| HB_SYMBOL_UNUSED( x ), _ftWidest( @i, aChoices, @aBarWidth ) } )
// calculates widest element for each pulldown menu
// see below for _ftWidest()
AFill( aBarWidth, 1 )
AEval( aChoices, { |x, i| HB_SYMBOL_UNUSED( x ), _ftWidest( @i, aChoices, @aBarWidth ) } )
// box location for each pulldown menu
// see below for _ftLocat()
AEVAL( aChoices, { |x,i| HB_SYMBOL_UNUSED( x ), _ftLocat( i, aBarCol, aBarWidth, @aBoxLoc, nMaxCol ) } )
// box location for each pulldown menu
// see below for _ftLocat()
AEval( aChoices, { |x, i| HB_SYMBOL_UNUSED( x ), _ftLocat( i, aBarCol, aBarWidth, @aBoxLoc, nMaxCol ) } )
// valid keys for each pulldown menu
// see below for _ftValKeys()
AEVAL( aChoices,{|x,i| HB_SYMBOL_UNUSED( x ), AADD( aValidkeys,"" ),;
_ftValKeys( i,aChoices,@aValidKeys ) } )
// valid keys for each pulldown menu
// see below for _ftValKeys()
AEval( aChoices, {|x, i| HB_SYMBOL_UNUSED( x ), AAdd( aValidkeys,"" ), ;
_ftValKeys( i, aChoices, @aValidKeys ) } )
// display the menu bar
SETCOLOR( cBar )
// display the menu bar
SetColor( cBar )
@ nTopRow, 0
AEVAL( aBar, { |x,i| HB_SYMBOL_UNUSED( x ), Devpos(nTopRow, aBarCol[i]), Devout(aBar[i]) })
AEval( aBar, { |x, i| HB_SYMBOL_UNUSED( x ), DevPos( nTopRow, aBarCol[i] ), DevOut( aBar[i] ) } )
// store inkey code for each item on menu bar to aBarKeys
AEVAL( aBarKeys, {|x,i| HB_SYMBOL_UNUSED( x ), aBarKeys[i] := ;
aKeyCodes[ ASC( UPPER( LTRIM( aBar[i] ) ) ) - 64 ] } )
// store inkey code for each item on menu bar to aBarKeys
AEval( aBarKeys, {|x, i| HB_SYMBOL_UNUSED( x ), aBarKeys[i] := ;
aKeyCodes[ ASC( UPPER( LTRIM( aBar[i] ) ) ) - 64 ] } )
// disable Alt-C and Alt-D
lCancMode := SETCANCEL( .f. )
// disable Alt-C and Alt-D
lCancMode := SetCancel( .F. )
AltD( DISABLE )
// main menu loop
// main menu loop
SAVE SCREEN TO sMainScrn
// which menu and which menu item
// which menu and which menu item
nHpos := 1; nVpos := 1
DO WHILE lLooping
RESTORE SCREEN FROM sMainScrn
SETCOLOR( cCurrent )
SetColor( cCurrent )
@ nTopRow, aBarCol[nHpos] SAY aBar[nHpos]
IF lShadow == NIL .OR. lShadow
FT_SHADOW( nTopRow+1, aBoxLoc[nHpos], LEN(aChoices[nHpos,1])+nTopRow+2, aBarWidth[nHpos]+3+aBoxLoc[nHpos] )
FT_SHADOW( nTopRow + 1, aBoxLoc[nHpos], Len( aChoices[nHpos,1] ) + nTopRow + 2, aBarWidth[nHpos] + 3 + aBoxLoc[nHpos] )
ENDIF
SETCOLOR( cBorder )
@ nTopRow+1, aBoxLoc[nHpos], LEN(aChoices[nHpos,1])+nTopRow+2, aBarWidth[nHpos]+3+aBoxLoc[nHpos] BOX "╔═╗║╝═╚║ "
SETCOLOR( cBox +","+ cCurrent +",,,"+ cUnselec )
nVpos := ACHOICE( nTopRow+2, aBoxLoc[nHpos]+2, LEN(aChoices[nHpos,1])+nTopRow+2, aBarWidth[nHpos]+1+aBoxLoc[nHpos], aChoices[nHpos,1], aChoices[nHpos,3], "__ftAcUdf", aLastSel[nHpos])
SetColor( cBorder )
@ nTopRow + 1, aBoxLoc[nHpos], Len( aChoices[nHpos,1] ) + nTopRow + 2, aBarWidth[nHpos] + 3 + aBoxLoc[nHpos] BOX "╔═╗║╝═╚║ "
SetColor( cBox + "," + cCurrent + ",,," + cUnselec )
nVpos := AChoice( nTopRow + 2, aBoxLoc[nHpos] + 2, Len( aChoices[nHpos,1] ) + nTopRow + 2, aBarWidth[nHpos] + 1 + aBoxLoc[nHpos], aChoices[nHpos,1], aChoices[nHpos,3], "__ftAcUdf", aLastSel[nHpos] )
DO CASE
CASE LASTKEY() == RIGHTARROW .OR. LASTKEY() == TAB
nHpos := iif( nHpos == LEN( aChoices ), 1, nHpos + 1 )
CASE LASTKEY() == LEFTARROW .OR. LASTKEY() == SHIFTTAB
nHpos := iif( nHpos == 1, LEN( aChoices ), nHpos - 1 )
CASE LASTKEY() == ESCAPE
CASE LastKey() == RIGHTARROW .OR. LastKey() == TAB
nHpos := iif( nHpos == Len( aChoices ), 1, nHpos + 1 )
CASE LastKey() == LEFTARROW .OR. LastKey() == SHIFTTAB
nHpos := iif( nHpos == 1, Len( aChoices ), nHpos - 1 )
CASE LastKey() == ESCAPE
lLooping := _ftBailOut( cBorder, cBox )
CASE LASTKEY() == HOME
CASE LastKey() == HOME
nHpos := 1
CASE LASTKEY() == END
nHpos := LEN( aChoices )
CASE LASTKEY() == ENTER
CASE LastKey() == END
nHpos := Len( aChoices )
CASE LastKey() == ENTER
aLastSel[nHpos] := nVpos
IF aChoices[nHpos,2,nVpos] != NIL
SETCANCEL( lCancMode )
ALTD( ENABLE )
lLooping := EVAL( aChoices[nHpos,2,nVpos] )
ALTD( DISABLE )
SETCANCEL( .f. )
IF aChoices[ nHpos, 2, nVpos ] != NIL
SetCancel( lCancMode )
AltD( ENABLE )
lLooping := Eval( aChoices[ nHpos, 2, nVpos ] )
AltD( DISABLE )
SetCancel( .F. )
ENDIF
CASE ASCAN( aBarKeys, LASTKEY() ) > 0
nHpos := ASCAN( aBarKeys, LASTKEY() )
CASE AScan( aBarKeys, LastKey() ) > 0
nHpos := AScan( aBarKeys, LastKey() )
ENDCASE
ENDDO
SETCANCEL( lCancMode )
SetCancel( lCancMode )
AltD( ENABLE )
RESTORE SCREEN FROM sMainScrn
RETURN NIL
FUNCTION __ftAcUdf( nMode )
// ACHOICE() user function
// ACHOICE() user function
LOCAL nRtnVal := RESUME
DO CASE
CASE nMode == HITTOP
KEYBOARD CHR( CTRLEND )
KEYBOARD Chr( CTRLEND )
CASE nMode == HITBOTTOM
KEYBOARD CHR( CTRLHOME )
KEYBOARD Chr( CTRLHOME )
CASE nMode == KEYEXCEPT
IF UPPER( CHR( LASTKEY() ) ) $ aValidKeys[ nHpos ]
IF aChoices[ nHpos, 3, AT( UPPER(CHR(LASTKEY())), aValidKeys[ nHpos ] )]
KEYBOARD CHR( ENTER )
IF Upper( Chr( LastKey() ) ) $ aValidKeys[ nHpos ]
IF aChoices[ nHpos, 3, AT( UPPER( CHR( LASTKEY() ) ), aValidKeys[ nHpos ] )]
KEYBOARD Chr( ENTER )
nRtnVal := NEXTITEM
ENDIF
ELSE
nRtnVal := MAKESELECT
ENDIF
ENDCASE
RETURN nRtnVal
STATIC FUNCTION _ftWidest( i, aChoices, aBarWidth )
AEVAL(aChoices[i,1],{|a,b| HB_SYMBOL_UNUSED( a ), aBarWidth[i] := ;
MAX( aBarWidth[i],LEN(aChoices[i,1,b])) })
AEval( aChoices[ i, 1 ], {| a, b | HB_SYMBOL_UNUSED( a ), aBarWidth[ i ] := ;
Max( aBarWidth[ i ], Len( aChoices[ i, 1, b ] ) ) } )
RETURN NIL
STATIC FUNCTION _ftLocat( i, aBarCol, aBarWidth, aBoxLoc, nMaxCol )
aBoxLoc[i] := iif( aBarCol[i] + aBarWidth[i] + 4 > nMaxCol + 1, ;
nMaxCol - 3 - aBarWidth[i], aBarCol[i] )
aBoxLoc[ i ] := iif( aBarCol[ i ] + aBarWidth[ i ] + 4 > nMaxCol + 1, ;
nMaxCol - 3 - aBarWidth[ i ], aBarCol[ i ] )
RETURN NIL
STATIC FUNCTION _ftBailOut( cBorder, cBox )
LOCAL cOldColor, sOldScreen, nKeyPress, nOldCursor
nOldCursor := SETCURSOR( SCNONE )
sOldScreen := SAVESCREEN(nMaxRow/2-1, 24, nMaxRow/2+2, 55)
cOldColor := SETCOLOR( cBorder )
FT_SHADOW( nMaxRow/2-1, 24, nMaxRow/2+2, 55 )
@ nMaxRow/2-1, 24, nMaxRow/2+2, 55 BOX hb_UTF8ToStr( "╔═╗║╝═╚║ " )
SETCOLOR( cBox )
@ nMaxRow/2, 26 SAY "Press ESCape To Confirm Exit"
@ nMaxRow/2+1,27 SAY "Or Any Other Key To Resume"
nKeyPress := INKEY(0)
SETCOLOR( cOldColor )
RESTSCREEN(nMaxRow/2-1, 24, nMaxRow/2+2, 55,sOldScreen )
SETCURSOR( nOldCursor )
RETURN !(nKeyPress == ESCAPE)
STATIC FUNCTION _ftValKeys( nNum,aChoices,aValidkeys )
AEVAL( aChoices[nNum,1], {|x| aValidKeys[nNum] += LEFT( x, 1)} )
LOCAL cOldColor, sOldScreen, nKeyPress, nOldCursor
nOldCursor := SetCursor( SCNONE )
sOldScreen := SaveScreen( nMaxRow / 2 - 1, 24, nMaxRow / 2 + 2, 55 )
cOldColor := SetColor( cBorder )
FT_SHADOW( nMaxRow / 2 - 1, 24, nMaxRow / 2 + 2, 55 )
@ nMaxRow / 2 - 1, 24, nMaxRow/2 + 2, 55 BOX hb_UTF8ToStr( "╔═╗║╝═╚║ " )
SetColor( cBox )
@ nMaxRow / 2, 26 SAY "Press ESCape To Confirm Exit"
@ nMaxRow / 2 + 1, 27 SAY "Or Any Other Key To Resume"
nKeyPress := Inkey( 0 )
SetColor( cOldColor )
RestScreen( nMaxRow / 2 - 1, 24, nMaxRow / 2 + 2, 55, sOldScreen )
SetCursor( nOldCursor )
RETURN !( nKeyPress == ESCAPE )
STATIC FUNCTION _ftValKeys( nNum, aChoices, aValidkeys )
AEval( aChoices[ nNum, 1 ], {| x | aValidKeys[ nNum ] += Left( x, 1 ) } )
RETURN NIL
FUNCTION FT_FILL( aArray, cMenuOption, bBlock, lAvailable )
AADD( aArray[1], cMenuOption )
AADD( aArray[2], bBlock )
AADD( aArray[3], lAvailable )
AAdd( aArray[ 1 ], cMenuOption )
AAdd( aArray[ 2 ], bBlock )
AAdd( aArray[ 3 ], lAvailable )
RETURN NIL

507
harbour/contrib/hbnf/menutonf.prg
View File

@@ -37,20 +37,17 @@
#include "setcurs.ch"
#include "inkey.ch"
#xcommand if <true> then <action> => ;
if <true> ; <action> ; end
#xtranslate display( <row>, <col>, <stuff>, <color> ) => ;
setpos( <row>, <col> ) ; dispout( <stuff>, <color> )
SetPos( < row > , < col > ) ; DispOut( < stuff > , < color > )
#xtranslate EnhColor( <colorspec> ) => ;
substr( <colorspec>, at( ",", <colorspec> ) + 1 )
SubStr( < colorspec > , At( ",", < colorspec > ) + 1 )
#xtranslate isOkay( <exp> ) => ;
( <exp> \> 0 .and. <exp> \<= nCount )
( < exp > \ > 0 .AND. < exp > \ <= nCount )
#xtranslate isBetween( <val>, <lower>, <upper> ) => ;
( <val> \>= <lower> .and. <val> \<= <upper> )
( < val > \ >= < lower > .AND. < val > \ <= < upper > )
#define nTriggerInkey asc( upper( substr( cPrompt, nTrigger, 1 ) ) )
#define cTrigger substr( cPrompt, nTrigger, 1 )
@@ -59,342 +56,378 @@
// These arrays hold information about each menu item
THREAD static aRow := {{}}
THREAD static aCol := {{}}
THREAD static aPrompt := {{}}
THREAD static aColor := {{}}
THREAD static aMsgRow := {{}}
THREAD static aMsgCol := {{}}
THREAD static aMessage := {{}}
THREAD static aMsgColor := {{}}
THREAD static aTrigger := {{}}
THREAD static aTriggerInkey := {{}}
THREAD static aTriggerColor := {{}}
THREAD static aHome := {{}}
THREAD static aEnd := {{}}
THREAD static aUp := {{}}
THREAD static aDown := {{}}
THREAD static aLeft := {{}}
THREAD static aRight := {{}}
THREAD static aExecute := {{}}
THREAD static nLevel := 1
THREAD STATIC aRow := { {} }
THREAD STATIC aCol := { {} }
THREAD STATIC aPrompt := { {} }
THREAD STATIC aColor := { {} }
THREAD STATIC aMsgRow := { {} }
THREAD STATIC aMsgCol := { {} }
THREAD STATIC aMessage := { {} }
THREAD STATIC aMsgColor := { {} }
THREAD STATIC aTrigger := { {} }
THREAD STATIC aTriggerInkey := { {} }
THREAD STATIC aTriggerColor := { {} }
THREAD STATIC aHome := { {} }
THREAD STATIC aEnd := { {} }
THREAD STATIC aUp := { {} }
THREAD STATIC aDown := { {} }
THREAD STATIC aLeft := { {} }
THREAD STATIC aRight := { {} }
THREAD STATIC aExecute := { {} }
THREAD STATIC nLevel := 1
function FT_Prompt( nRow, nCol, cPrompt, cColor, ;
nMsgRow, nMsgCol, cMessage, cMsgColor, ;
nTrigger, cTriggerColor, nHome, nEnd, ;
nUp, nDown, nLeft, nRight, bExecute )
FUNCTION FT_Prompt( nRow, nCol, cPrompt, cColor, ;
nMsgRow, nMsgCol, cMessage, cMsgColor, ;
nTrigger, cTriggerColor, nHome, nEnd, ;
nUp, nDown, nLeft, nRight, bExecute )
// If the prompt color setting is not specified, use default
if cColor == NIL then cColor := setcolor()
IF cColor == NIL
cColor := SetColor()
ENDIF
// If no message is supplied, set message values to NIL
if cMessage == NIL
IF cMessage == NIL
nMsgRow := nMsgCol := cMsgColor := NIL
nMsgRow := nMsgCol := cMsgColor := NIL
else
ELSE
// If message row not supplied, use the default
// If message row not supplied, use the default
if nMsgRow == NIL then nMsgRow := set( _SET_MESSAGE )
IF nMsgRow == NIL
nMsgRow := Set( _SET_MESSAGE )
ENDIF
// If message column not supplied, use the default
// If message column not supplied, use the default
if nMsgCol == NIL
if set( _SET_MCENTER )
nMsgCol := int( ( maxcol() + 1 - len( cPrompt ) ) / 2 )
else
nMsgCol := 0
endif
endif
IF nMsgCol == NIL
IF SET( _SET_MCENTER )
nMsgCol := Int( ( MaxCol() + 1 - Len( cPrompt ) ) / 2 )
ELSE
nMsgCol := 0
ENDIF
ENDIF
// If message color not specified, use the default
// If message color not specified, use the default
if cMsgColor == NIL then cMsgColor := cColor
endif
IF cMsgColor == NIL
cMsgColor := cColor
ENDIF
ENDIF
// If trigger values not specifed, set the defaults
if nTrigger == NIL then nTrigger := 1
if cTriggerColor == NIL then cTriggerColor := cColor
IF nTrigger == NIL
nTrigger := 1
ENDIF
IF cTriggerColor == NIL
cTriggerColor := cColor
ENDIF
// Now add elements to the static arrays -- nLevel indicates the recursion
// level, which allows for nested menus.
aadd( aRow[ nLevel ], nRow )
aadd( aCol[ nLevel ], nCol )
aadd( aPrompt[ nLevel ], cPrompt )
aadd( aColor[ nLevel ], cColor )
aadd( aMsgRow[ nLevel ], nMsgRow )
aadd( aMsgCol[ nLevel ], nMsgCol )
aadd( aMessage[ nLevel ], cMessage )
aadd( aMsgColor[ nLevel ], cMsgColor )
aadd( aTrigger[ nLevel ], nTrigger )
aadd( aTriggerInkey[ nLevel ], nTriggerInkey )
aadd( aTriggerColor[ nLevel ], cTriggerColor )
aadd( aHome[ nLevel ], nHome )
aadd( aEnd[ nLevel ], nEnd )
aadd( aUp[ nLevel ], nUp )
aadd( aDown[ nLevel ], nDown )
aadd( aLeft[ nLevel ], nLeft )
aadd( aRight[ nLevel ], nRight )
aadd( aExecute[ nLevel ], bExecute )
AAdd( aRow[ nLevel ], nRow )
AAdd( aCol[ nLevel ], nCol )
AAdd( aPrompt[ nLevel ], cPrompt )
AAdd( aColor[ nLevel ], cColor )
AAdd( aMsgRow[ nLevel ], nMsgRow )
AAdd( aMsgCol[ nLevel ], nMsgCol )
AAdd( aMessage[ nLevel ], cMessage )
AAdd( aMsgColor[ nLevel ], cMsgColor )
AAdd( aTrigger[ nLevel ], nTrigger )
AAdd( aTriggerInkey[ nLevel ], nTriggerInkey )
AAdd( aTriggerColor[ nLevel ], cTriggerColor )
AAdd( aHome[ nLevel ], nHome )
AAdd( aEnd[ nLevel ], nEnd )
AAdd( aUp[ nLevel ], nUp )
AAdd( aDown[ nLevel ], nDown )
AAdd( aLeft[ nLevel ], nLeft )
AAdd( aRight[ nLevel ], nRight )
AAdd( aExecute[ nLevel ], bExecute )
// Now display the prompt for the sake of compatibility
dispbegin()
display( nRow, nCol, cPrompt, cColor )
display( nRow, nCol - 1 + nTrigger, cTrigger, cTriggerColor )
dispend()
DispBegin()
DISPLAY( nRow, nCol, cPrompt, cColor )
DISPLAY( nRow, nCol - 1 + nTrigger, cTrigger, cTriggerColor )
DispEnd()
return NIL
RETURN NIL
function FT_MenuTo( bGetSet, cReadVar, lCold )
FUNCTION FT_MenuTo( bGetSet, cReadVar, lCold )
local nMenu := nLevel++
local nActive
local nCount := len( aRow[ nMenu ] )
local lChoice := .F.
local nCursor := set( _SET_CURSOR,SC_NONE )
local nKey,bKey,nScan,lWrap,cScreen,nPrev
LOCAL nMenu := nLevel++
LOCAL nActive
LOCAL nCount := Len( aRow[ nMenu ] )
LOCAL lChoice := .F.
LOCAL nCursor := Set( _SET_CURSOR, SC_NONE )
LOCAL nKey, bKey, nScan, lWrap, cScreen, nPrev
IF ! HB_ISLOGICAL( lCold )
lCold := .F.
ENDIF
IF ! HB_ISLOGICAL( lCold )
lCold := .F.
ENDIF
// Validate the incoming parameters and assign some reasonable defaults
// to prevent a crash later.
cReadVar := iif( cReadVar == NIL, "", upper( cReadVar ) )
cReadVar := iif( cReadVar == NIL, "", Upper( cReadVar ) )
if bGetSet == NIL then bGetSet := {|| 1}
IF bGetSet == NIL
bGetSet := {|| 1 }
ENDIF
// Eval the incoming getset block to initialize nActive, which indicates
// the menu prompt which is to be active when the menu is first displayed.
// If nActive is outside the appropriate limits, a value of 1 is assigned.
nActive := eval( bGetSet )
nActive := Eval( bGetSet )
if ( nActive < 1 .or. nActive > nCount ) then nActive := 1
IF ( nActive < 1 .OR. nActive > nCount )
nActive := 1
ENDIF
// Increment the recursion level in case a hotkey procedure
// calls FT_Prompt(). This will cause a new set of prompts
// to be created without disturbing the current set.
aadd( aRow, {} )
aadd( aCol, {} )
aadd( aPrompt, {} )
aadd( aColor, {} )
aadd( aMsgRow, {} )
aadd( aMsgCol, {} )
aadd( aMessage, {} )
aadd( aMsgColor, {} )
aadd( aTrigger, {} )
aadd( aTriggerInkey, {} )
aadd( aTriggerColor, {} )
aadd( aUp, {} )
aadd( aDown, {} )
aadd( aLeft, {} )
aadd( aRight, {} )
aadd( aExecute, {} )
AAdd( aRow, {} )
AAdd( aCol, {} )
AAdd( aPrompt, {} )
AAdd( aColor, {} )
AAdd( aMsgRow, {} )
AAdd( aMsgCol, {} )
AAdd( aMessage, {} )
AAdd( aMsgColor, {} )
AAdd( aTrigger, {} )
AAdd( aTriggerInkey, {} )
AAdd( aTriggerColor, {} )
AAdd( aUp, {} )
AAdd( aDown, {} )
AAdd( aLeft, {} )
AAdd( aRight, {} )
AAdd( aExecute, {} )
// Loop until Enter or Esc is pressed
while .not. lChoice
WHILE ! lChoice
// Evaluate the getset block to update the target memory variable
// in case it needs to be examined by a hotkey procedure.
// Evaluate the getset block to update the target memory variable
// in case it needs to be examined by a hotkey procedure.
eval( bGetSet,nActive )
Eval( bGetSet, nActive )
// Get the current setting of SET WRAP so that the desired menu behavior
// can be implemented.
// Get the current setting of SET WRAP so that the desired menu behavior
// can be implemented.
lWrap := set( _SET_WRAP )
lWrap := Set( _SET_WRAP )
// If a message is to be displayed, save the current screen contents
// and then display the message, otherwise set the screen buffer to NIL.
// If a message is to be displayed, save the current screen contents
// and then display the message, otherwise set the screen buffer to NIL.
dispbegin()
DispBegin()
if aMessage[ nCurrent ] != NIL
cScreen := savescreen( aMsgRow[ nCurrent ], aMsgCol[ nCurrent ], ;
aMsgRow[ nCurrent ], aMsgCol[ nCurrent ] + ;
len( aMessage[ nCurrent ] ) - 1 )
IF aMessage[ nCurrent ] != NIL
cScreen := SaveScreen( aMsgRow[ nCurrent ], aMsgCol[ nCurrent ], ;
aMsgRow[ nCurrent ], aMsgCol[ nCurrent ] + ;
Len( aMessage[ nCurrent ] ) - 1 )
display( aMsgRow[ nCurrent ], aMsgCol[ nCurrent ], ;
aMessage[ nCurrent ], aMsgColor[ nCurrent ] )
DISPLAY( aMsgRow[ nCurrent ], aMsgCol[ nCurrent ], ;
aMessage[ nCurrent ], aMsgColor[ nCurrent ] )
else
cScreen := NIL
endif
ELSE
cScreen := NIL
ENDIF
// Display the prompt using the designated colors for the prompt and
// the trigger character.
// Display the prompt using the designated colors for the prompt and
// the trigger character.
display( aRow[ nCurrent ], aCol[ nCurrent ], ;
DISPLAY( aRow[ nCurrent ], aCol[ nCurrent ], ;
aPrompt[ nCurrent ], EnhColor( aColor[ nCurrent ] ) )
display( aRow[ nCurrent ], ;
aCol[ nCurrent ] - 1 + aTrigger[ nCurrent ], ;
substr( aPrompt[ nCurrent ], aTrigger[ nCurrent ], 1 ), ;
EnhColor( aTriggerColor[ nCurrent ] ) )
DISPLAY( aRow[ nCurrent ], ;
aCol[ nCurrent ] - 1 + aTrigger[ nCurrent ], ;
SubStr( aPrompt[ nCurrent ], aTrigger[ nCurrent ], 1 ), ;
EnhColor( aTriggerColor[ nCurrent ] ) )
dispend()
DispEnd()
// Wait for a keystroke
// Wait for a keystroke
nKey := inkey( 0 )
nKey := Inkey( 0 )
// If the key was an alphabetic char, convert to uppercase
// If the key was an alphabetic char, convert to uppercase
if isBetween( nKey,97,122 ) then nKey -= 32
IF isBetween( nKey, 97, 122 )
nKey -= 32
ENDIF
// Set nPrev to the currently active menu item
// Set nPrev to the currently active menu item
nPrev := nActive
nPrev := nActive
do case
DO CASE
// Check for a hotkey, and evaluate the associated block if present.
// Check for a hotkey, and evaluate the associated block if present.
case ( bKey := setkey( nKey ) ) != NIL
eval( bKey, ProcName( 1 ), ProcLine( 1 ), cReadVar )
CASE ( bKey := SetKey( nKey ) ) != NIL
Eval( bKey, ProcName( 1 ), ProcLine( 1 ), cReadVar )
// If Enter was pressed, either exit the menu or evaluate the
// associated code block.
// If Enter was pressed, either exit the menu or evaluate the
// associated code block.
case nKey == K_ENTER
if aExecute[ nCurrent ] != NIL
eval( aExecute[ nCurrent ] )
else
CASE nKey == K_ENTER
IF aExecute[ nCurrent ] != NIL
Eval( aExecute[ nCurrent ] )
ELSE
lChoice := .T.
endif
ENDIF
// If ESC was pressed, set the selected item to zero and exit.
// If ESC was pressed, set the selected item to zero and exit.
case nKey == K_ESC
CASE nKey == K_ESC
lChoice := .T.
nActive := 0
// If Home was pressed, go to the designated menu item.
// If Home was pressed, go to the designated menu item.
case nKey == K_HOME
CASE nKey == K_HOME
nActive := iif( aHome[ nCurrent ] == NIL, 1, aHome[ nCurrent ] )
// If End was pressed, go to the designated menu item.
// If End was pressed, go to the designated menu item.
case nKey == K_END
CASE nKey == K_END
nActive := iif( aEnd[ nCurrent ] == NIL, nCount, aEnd[ nCurrent ] )
// If Up Arrow was pressed, go to the designated menu item.
// If Up Arrow was pressed, go to the designated menu item.
case nKey == K_UP
if aUp[ nCurrent ] == NIL
if --nActive < 1 then nActive := iif( lWrap, nCount, 1 )
else
if isOkay( aUp[ nCurrent ] ) then nActive := aUp[ nCurrent ]
endif
CASE nKey == K_UP
IF aUp[ nCurrent ] == NIL
if --nActive < 1
nActive := iif( lWrap, nCount, 1 )
ENDIF
ELSE
IF isOkay( aUp[ nCurrent ] )
nActive := aUp[ nCurrent ]
ENDIF
ENDIF
// If Down Arrow was pressed, go to the designated menu item.
// If Down Arrow was pressed, go to the designated menu item.
case nKey == K_DOWN
if aDown[ nCurrent ] == NIL
if ++nActive > nCount then nActive := iif( lWrap, 1, nCount )
else
if isOkay( aDown[ nCurrent ] ) then nActive := aDown[ nCurrent ]
endif
CASE nKey == K_DOWN
IF aDown[ nCurrent ] == NIL
if ++nActive > nCount
nActive := iif( lWrap, 1, nCount )
ENDIF
ELSE
IF isOkay( aDown[ nCurrent ] )
nActive := aDown[ nCurrent ]
ENDIF
ENDIF
// If Left Arrow was pressed, go to the designated menu item.
// If Left Arrow was pressed, go to the designated menu item.
case nKey == K_LEFT
if aLeft[ nCurrent ] == NIL
if --nActive < 1 then nActive := iif( lWrap, nCount, 1 )
else
if isOkay( aLeft[ nCurrent ] ) then nActive := aLeft[ nCurrent ]
endif
CASE nKey == K_LEFT
IF aLeft[ nCurrent ] == NIL
if --nActive < 1
nActive := iif( lWrap, nCount, 1 )
ENDIF
ELSE
IF isOkay( aLeft[ nCurrent ] )
nActive := aLeft[ nCurrent ]
ENDIF
ENDIF
// If Right Arrow was pressed, go to the designated menu item.
// If Right Arrow was pressed, go to the designated menu item.
case nKey == K_RIGHT
if aRight[ nCurrent ] == NIL
if ++nActive > nCount then nActive := iif( lWrap, 1, nCount )
else
if isOkay( aRight[ nCurrent ] ) then nActive := aRight[ nCurrent ]
endif
CASE nKey == K_RIGHT
IF aRight[ nCurrent ] == NIL
if ++nActive > nCount
nActive := iif( lWrap, 1, nCount )
ENDIF
ELSE
IF isOkay( aRight[ nCurrent ] )
nActive := aRight[ nCurrent ]
ENDIF
ENDIF
// If a trigger letter was pressed, handle it based on the COLD
// parameter.
// If a trigger letter was pressed, handle it based on the COLD
// parameter.
case ( nScan := ascan( aTriggerInkey[ nMenu ], nKey ) ) > 0
CASE ( nScan := AScan( aTriggerInkey[ nMenu ], nKey ) ) > 0
nActive := nScan
if .not. lCold then FT_PutKey( K_ENTER )
endcase
IF ! lCold
FT_PutKey( K_ENTER )
ENDIF
ENDCASE
// Erase the highlight bar in preparation for the next iteration
// Erase the highlight bar in preparation for the next iteration
if .not. lChoice
dispbegin()
display( aRow[ nLast ], aCol[ nLast ], ;
IF ! lChoice
DispBegin()
DISPLAY( aRow[ nLast ], aCol[ nLast ], ;
aPrompt[ nLast ], aColor[ nLast ] )
display( aRow[ nLast ], aCol[ nLast ] - 1 + aTrigger[ nLast ], ;
substr( aPrompt[ nLast ], aTrigger[ nLast ], 1 ), ;
aTriggerColor[ nLast ] )
DISPLAY( aRow[ nLast ], aCol[ nLast ] - 1 + aTrigger[ nLast ], ;
SubStr( aPrompt[ nLast ], aTrigger[ nLast ], 1 ), ;
aTriggerColor[ nLast ] )
if cScreen != NIL then restscreen( aMsgRow[ nLast ], ;
aMsgCol[ nLast ], ;
aMsgRow[ nLast ], ;
aMsgCol[ nLast ] ;
+ len( aMessage[ nLast ] ) - 1, ;
cScreen )
dispend()
endif
end
IF cScreen != NIL
RestScreen( aMsgRow[ nLast ], ;
aMsgCol[ nLast ], ;
aMsgRow[ nLast ], ;
aMsgCol[ nLast ] ;
+ Len( aMessage[ nLast ] ) - 1, ;
cScreen )
ENDIF
DispEnd()
ENDIF
ENDDO
// Now that we're exiting, decrement the recursion level and erase all
// the prompt information for the current invocation.
nLevel--
nLevel--
asize( aRow, nLevel )
asize( aCol, nLevel )
asize( aPrompt, nLevel )
asize( aColor, nLevel )
asize( aMsgRow, nLevel )
asize( aMsgCol, nLevel )
asize( aMessage, nLevel )
asize( aMsgColor, nLevel )
asize( aTrigger, nLevel )
asize( aTriggerInkey, nLevel )
asize( aTriggerColor, nLevel )
asize( aUp, nLevel )
asize( aDown, nLevel )
asize( aLeft, nLevel )
asize( aRight, nLevel )
asize( aExecute, nLevel )
ASize( aRow, nLevel )
ASize( aCol, nLevel )
ASize( aPrompt, nLevel )
ASize( aColor, nLevel )
ASize( aMsgRow, nLevel )
ASize( aMsgCol, nLevel )
ASize( aMessage, nLevel )
ASize( aMsgColor, nLevel )
ASize( aTrigger, nLevel )
ASize( aTriggerInkey, nLevel )
ASize( aTriggerColor, nLevel )
ASize( aUp, nLevel )
ASize( aDown, nLevel )
ASize( aLeft, nLevel )
ASize( aRight, nLevel )
ASize( aExecute, nLevel )
aRow[ nLevel ] := {}
aCol[ nLevel ] := {}
aPrompt[ nLevel ] := {}
aColor[ nLevel ] := {}
aMsgRow[ nLevel ] := {}
aMsgCol[ nLevel ] := {}
aMessage[ nLevel ] := {}
aMsgColor[ nLevel ] := {}
aTrigger[ nLevel ] := {}
aTriggerInkey[ nLevel ] := {}
aTriggerColor[ nLevel ] := {}
aUp[ nLevel ] := {}
aDown[ nLevel ] := {}
aLeft[ nLevel ] := {}
aRight[ nLevel ] := {}
aExecute[ nLevel ] := {}
aRow[ nLevel ] := {}
aCol[ nLevel ] := {}
aPrompt[ nLevel ] := {}
aColor[ nLevel ] := {}
aMsgRow[ nLevel ] := {}
aMsgCol[ nLevel ] := {}
aMessage[ nLevel ] := {}
aMsgColor[ nLevel ] := {}
aTrigger[ nLevel ] := {}
aTriggerInkey[ nLevel ] := {}
aTriggerColor[ nLevel ] := {}
aUp[ nLevel ] := {}
aDown[ nLevel ] := {}
aLeft[ nLevel ] := {}
aRight[ nLevel ] := {}
aExecute[ nLevel ] := {}
set( _SET_CURSOR, nCursor )
SET( _SET_CURSOR, nCursor )
eval( bGetSet, nActive )
Eval( bGetSet, nActive )
return nActive
RETURN nActive

397
harbour/contrib/hbnf/metaph.prg
View File

@@ -92,267 +92,278 @@
*
*/
*------------------------------------------------
//------------------------------------------------
// Demo of FT_METAPH()
// #define FT_TEST .T.
#ifdef FT_TEST
PROCEDURE Main()
LOCAL cJunk := SPACE( 8000 )
LOCAL aNames := {}
LOCAL cName, nElem
SET( _SET_SCOREBOARD, .F. )
SET( _SET_COLOR, "W/B" )
CLS
LOCAL cJunk := Space( 8000 )
LOCAL aNames := {}
LOCAL cName, nElem
// Demo will create an array of names and display in 3 columns
// _ftRow() and _ftCol() will calculate the screen co-ordinates
// by evaluating the element number
SET( _SET_SCOREBOARD, .F. )
SET( _SET_COLOR, "W/B" )
CLS
AADD( aNames, "Adams" )
AADD( aNames, "Addams" )
AADD( aNames, "Atoms" )
AADD( aNames, "Adamson" )
AADD( aNames, "Cajun" )
AADD( aNames, "Cagen" )
AADD( aNames, "Cochy" )
AADD( aNames, "Cocci" )
AADD( aNames, "Smith" )
AADD( aNames, "Smythe" )
AADD( aNames, "Naylor" )
AADD( aNames, "Nailer" )
AADD( aNames, "Holberry" )
AADD( aNames, "Wholebary" )
AADD( aNames, "Jackson" )
AADD( aNames, "Jekksen" )
AADD( aNames, "The Source" )
AADD( aNames, "The Sores" )
AADD( aNames, "Jones" )
AADD( aNames, "Johns" )
AADD( aNames, "Lennon" )
AADD( aNames, "Lenin" )
AADD( aNames, "Fischer" )
AADD( aNames, "Fisher" )
AADD( aNames, "O'Donnell" )
AADD( aNames, "O Donald" )
AADD( aNames, "Pugh" )
AADD( aNames, "Pew" )
AADD( aNames, "Heimendinger" )
AADD( aNames, "Hymendinker" )
AADD( aNames, "Knight" )
AADD( aNames, "Nite" )
AADD( aNames, "Lamb" )
AADD( aNames, "Lamb Chops" )
AADD( aNames, "Stephens" )
AADD( aNames, "Stevens" )
AADD( aNames, "Neilson" )
AADD( aNames, "Nelson" )
AADD( aNames, "Tchaikovski" )
AADD( aNames, "Chikofski" )
AADD( aNames, "Caton" )
AADD( aNames, "Wright" )
AADD( aNames, "Write" )
AADD( aNames, "Right" )
AADD( aNames, "Manual" )
AADD( aNames, "Now" )
AADD( aNames, "Wheatabix" )
AADD( aNames, "Science" )
AADD( aNames, "Cinzano" )
AADD( aNames, "Lucy" )
AADD( aNames, "Reece" )
AADD( aNames, "Righetti" )
AADD( aNames, "Oppermann" )
AADD( aNames, "Bookkeeper" )
AADD( aNames, "McGill" )
AADD( aNames, "Magic" )
AADD( aNames, "McLean" )
AADD( aNames, "McLane" )
AADD( aNames, "Maclean" )
AADD( aNames, "Exxon" )
// Demo will create an array of names and display in 3 columns
// _ftRow() and _ftCol() will calculate the screen co-ordinates
// by evaluating the element number
// display names and metaphones in 3 columns on screen
AEVAL( aNames, ;
{ | cName, nElem | ;
SETPOS( _ftRow( nElem ), _ftCol( nElem ) ), ;
QQOUT( PadR( cName, 18, "." ) + FT_METAPH( cName ) ) ;
} )
AAdd( aNames, "Adams" )
AAdd( aNames, "Addams" )
AAdd( aNames, "Atoms" )
AAdd( aNames, "Adamson" )
AAdd( aNames, "Cajun" )
AAdd( aNames, "Cagen" )
AAdd( aNames, "Cochy" )
AAdd( aNames, "Cocci" )
AAdd( aNames, "Smith" )
AAdd( aNames, "Smythe" )
AAdd( aNames, "Naylor" )
AAdd( aNames, "Nailer" )
AAdd( aNames, "Holberry" )
AAdd( aNames, "Wholebary" )
AAdd( aNames, "Jackson" )
AAdd( aNames, "Jekksen" )
AAdd( aNames, "The Source" )
AAdd( aNames, "The Sores" )
AAdd( aNames, "Jones" )
AAdd( aNames, "Johns" )
AAdd( aNames, "Lennon" )
AAdd( aNames, "Lenin" )
AAdd( aNames, "Fischer" )
AAdd( aNames, "Fisher" )
AAdd( aNames, "O'Donnell" )
AAdd( aNames, "O Donald" )
AAdd( aNames, "Pugh" )
AAdd( aNames, "Pew" )
AAdd( aNames, "Heimendinger" )
AAdd( aNames, "Hymendinker" )
AAdd( aNames, "Knight" )
AAdd( aNames, "Nite" )
AAdd( aNames, "Lamb" )
AAdd( aNames, "Lamb Chops" )
AAdd( aNames, "Stephens" )
AAdd( aNames, "Stevens" )
AAdd( aNames, "Neilson" )
AAdd( aNames, "Nelson" )
AAdd( aNames, "Tchaikovski" )
AAdd( aNames, "Chikofski" )
AAdd( aNames, "Caton" )
AAdd( aNames, "Wright" )
AAdd( aNames, "Write" )
AAdd( aNames, "Right" )
AAdd( aNames, "Manual" )
AAdd( aNames, "Now" )
AAdd( aNames, "Wheatabix" )
AAdd( aNames, "Science" )
AAdd( aNames, "Cinzano" )
AAdd( aNames, "Lucy" )
AAdd( aNames, "Reece" )
AAdd( aNames, "Righetti" )
AAdd( aNames, "Oppermann" )
AAdd( aNames, "Bookkeeper" )
AAdd( aNames, "McGill" )
AAdd( aNames, "Magic" )
AAdd( aNames, "McLean" )
AAdd( aNames, "McLane" )
AAdd( aNames, "Maclean" )
AAdd( aNames, "Exxon" )
SETPOS( 21, 00 )
QUIT
// display names and metaphones in 3 columns on screen
AEval( aNames, ;
{| cName, nElem | ;
SetPos( _ftRow( nElem ), _ftCol( nElem ) ), ;
QQOut( PadR( cName, 18, "." ) + FT_METAPH( cName ) ) ;
} )
*------------------------------------------------
STATIC FUNCTION _ftRow( nElem ) // Determine which row to print on
RETURN iif( nElem > 40, nElem - 40, iif( nElem > 20, nElem - 20, nElem ) )
*------------------------------------------------
STATIC FUNCTION _ftCol( nElem ) // Determine which column to start print
RETURN iif( nElem > 40, 55, iif( nElem > 20, 28, 1 ) )
*------------------------------------------------
SetPos( 21, 00 )
QUIT
//------------------------------------------------
STATIC FUNCTION _ftRow( nElem ) // Determine which row to print on
RETURN iif( nElem > 40, nElem - 40, iif( nElem > 20, nElem - 20, nElem ) )
//------------------------------------------------
STATIC FUNCTION _ftCol( nElem ) // Determine which column to start print
RETURN iif( nElem > 40, 55, iif( nElem > 20, 28, 1 ) )
//------------------------------------------------
#endif
// End of Test program
*------------------------------------------------
FUNCTION FT_METAPH ( cName, nSize )
//------------------------------------------------
FUNCTION FT_METAPH( cName, nSize )
// Calculates the metaphone of a character string
LOCAL cMeta
LOCAL cMeta
cName := iif( cName == NIL, "", cName ) // catch-all
nSize := iif( nSize == NIL, 4, nSize ) // default size: 4-bytes
cName := iif( cName == NIL, "", cName ) // catch-all
nSize := iif( nSize == NIL, 4, nSize ) // default size: 4-bytes
// Remove non-alpha characters and make upper case.
// The string is padded with 1 space at the beginning & end.
// Spaces, if present inside the string, are not removed until all
// the prefix/suffix checking has been completed.
cMeta := " " + _ftMakeAlpha( UPPER( ALLTRIM( cName ) ) ) + " "
cMeta := " " + _ftMakeAlpha( Upper( AllTrim( cName ) ) ) + " "
// prefixes which need special consideration
IF " KN" $ cMeta ; cMeta := STRTRAN( cMeta, " KN" , " N" ) ; ENDIF
IF " GN" $ cMeta ; cMeta := STRTRAN( cMeta, " GN" , " N" ) ; ENDIF
IF " PN" $ cMeta ; cMeta := STRTRAN( cMeta, " PN" , " N" ) ; ENDIF
IF " AE" $ cMeta ; cMeta := STRTRAN( cMeta, " AE" , " E" ) ; ENDIF
IF " X" $ cMeta ; cMeta := STRTRAN( cMeta, " X" , " S" ) ; ENDIF
IF " WR" $ cMeta ; cMeta := STRTRAN( cMeta, " WR" , " R" ) ; ENDIF
IF " WHO" $ cMeta ; cMeta := STRTRAN( cMeta, " WHO", " H" ) ; ENDIF
IF " WH" $ cMeta ; cMeta := STRTRAN( cMeta, " WH" , " W" ) ; ENDIF
IF " MCG" $ cMeta ; cMeta := STRTRAN( cMeta, " MCG", " MK" ) ; ENDIF
IF " MC" $ cMeta ; cMeta := STRTRAN( cMeta, " MC" , " MK" ) ; ENDIF
IF " MACG" $ cMeta ; cMeta := STRTRAN( cMeta, " MACG"," MK" ) ; ENDIF
IF " MAC" $ cMeta ; cMeta := STRTRAN( cMeta, " MAC", " MK" ) ; ENDIF
IF " GI" $ cMeta ; cMeta := STRTRAN( cMeta, " GI", " K" ) ; ENDIF
IF " KN" $ cMeta ; cMeta := StrTran( cMeta, " KN" , " N" ) ; ENDIF
IF " GN" $ cMeta ; cMeta := StrTran( cMeta, " GN" , " N" ) ; ENDIF
IF " PN" $ cMeta ; cMeta := StrTran( cMeta, " PN" , " N" ) ; ENDIF
IF " AE" $ cMeta ; cMeta := StrTran( cMeta, " AE" , " E" ) ; ENDIF
IF " X" $ cMeta ; cMeta := StrTran( cMeta, " X" , " S" ) ; ENDIF
IF " WR" $ cMeta ; cMeta := StrTran( cMeta, " WR" , " R" ) ; ENDIF
IF " WHO" $ cMeta ; cMeta := StrTran( cMeta, " WHO", " H" ) ; ENDIF
IF " WH" $ cMeta ; cMeta := StrTran( cMeta, " WH" , " W" ) ; ENDIF
IF " MCG" $ cMeta ; cMeta := StrTran( cMeta, " MCG", " MK" ) ; ENDIF
IF " MC" $ cMeta ; cMeta := StrTran( cMeta, " MC" , " MK" ) ; ENDIF
IF " MACG" $ cMeta ; cMeta := StrTran( cMeta, " MACG", " MK" ) ; ENDIF
IF " MAC" $ cMeta ; cMeta := StrTran( cMeta, " MAC", " MK" ) ; ENDIF
IF " GI" $ cMeta ; cMeta := StrTran( cMeta, " GI", " K" ) ; ENDIF
// Suffixes which need special consideration
IF "MB " $ cMeta ; cMeta := STRTRAN( cMeta, "MB " , "M " ) ; ENDIF
IF "NG " $ cMeta ; cMeta := STRTRAN( cMeta, "NG " , "N " ) ; ENDIF
IF "MB " $ cMeta ; cMeta := StrTran( cMeta, "MB " , "M " ) ; ENDIF
IF "NG " $ cMeta ; cMeta := StrTran( cMeta, "NG " , "N " ) ; ENDIF
// Remove inner spaces (1st and last byte are spaces)
IF " " $ SUBSTR( cMeta, 2, LEN( cMeta ) - 2 )
cMeta := " " + STRTRAN( cMeta, " " , "" ) + " "
ENDIF
IF " " $ SubStr( cMeta, 2, Len( cMeta ) - 2 )
cMeta := " " + StrTran( cMeta, " " , "" ) + " "
ENDIF
// Double consonants sound much the same as singles
IF "BB" $ cMeta ; cMeta := STRTRAN( cMeta, "BB" , "B" ) ; ENDIF
IF "CC" $ cMeta ; cMeta := STRTRAN( cMeta, "CC" , "CH" ) ; ENDIF
IF "DD" $ cMeta ; cMeta := STRTRAN( cMeta, "DD" , "T" ) ; ENDIF
IF "FF" $ cMeta ; cMeta := STRTRAN( cMeta, "FF" , "F" ) ; ENDIF
IF "GG" $ cMeta ; cMeta := STRTRAN( cMeta, "GG" , "K" ) ; ENDIF
IF "KK" $ cMeta ; cMeta := STRTRAN( cMeta, "KK" , "K" ) ; ENDIF
IF "LL" $ cMeta ; cMeta := STRTRAN( cMeta, "LL" , "L" ) ; ENDIF
IF "MM" $ cMeta ; cMeta := STRTRAN( cMeta, "MM" , "M" ) ; ENDIF
IF "NN" $ cMeta ; cMeta := STRTRAN( cMeta, "NN" , "N" ) ; ENDIF
IF "PP" $ cMeta ; cMeta := STRTRAN( cMeta, "PP" , "P" ) ; ENDIF
IF "RR" $ cMeta ; cMeta := STRTRAN( cMeta, "RR" , "R" ) ; ENDIF
IF "SS" $ cMeta ; cMeta := STRTRAN( cMeta, "SS" , "S" ) ; ENDIF
IF "TT" $ cMeta ; cMeta := STRTRAN( cMeta, "TT" , "T" ) ; ENDIF
IF "XX" $ cMeta ; cMeta := STRTRAN( cMeta, "XX" , "KS" ) ; ENDIF
IF "ZZ" $ cMeta ; cMeta := STRTRAN( cMeta, "ZZ" , "S" ) ; ENDIF
IF "BB" $ cMeta ; cMeta := StrTran( cMeta, "BB" , "B" ) ; ENDIF
IF "CC" $ cMeta ; cMeta := StrTran( cMeta, "CC" , "CH" ) ; ENDIF
IF "DD" $ cMeta ; cMeta := StrTran( cMeta, "DD" , "T" ) ; ENDIF
IF "FF" $ cMeta ; cMeta := StrTran( cMeta, "FF" , "F" ) ; ENDIF
IF "GG" $ cMeta ; cMeta := StrTran( cMeta, "GG" , "K" ) ; ENDIF
IF "KK" $ cMeta ; cMeta := StrTran( cMeta, "KK" , "K" ) ; ENDIF
IF "LL" $ cMeta ; cMeta := StrTran( cMeta, "LL" , "L" ) ; ENDIF
IF "MM" $ cMeta ; cMeta := StrTran( cMeta, "MM" , "M" ) ; ENDIF
IF "NN" $ cMeta ; cMeta := StrTran( cMeta, "NN" , "N" ) ; ENDIF
IF "PP" $ cMeta ; cMeta := StrTran( cMeta, "PP" , "P" ) ; ENDIF
IF "RR" $ cMeta ; cMeta := StrTran( cMeta, "RR" , "R" ) ; ENDIF
IF "SS" $ cMeta ; cMeta := StrTran( cMeta, "SS" , "S" ) ; ENDIF
IF "TT" $ cMeta ; cMeta := StrTran( cMeta, "TT" , "T" ) ; ENDIF
IF "XX" $ cMeta ; cMeta := StrTran( cMeta, "XX" , "KS" ) ; ENDIF
IF "ZZ" $ cMeta ; cMeta := StrTran( cMeta, "ZZ" , "S" ) ; ENDIF
// J sounds
IF "DGE" $ cMeta ; cMeta := STRTRAN( cMeta, "DGE" , "J" ) ; ENDIF
IF "DGY" $ cMeta ; cMeta := STRTRAN( cMeta, "DGY" , "J" ) ; ENDIF
IF "DGI" $ cMeta ; cMeta := STRTRAN( cMeta, "DGI" , "J" ) ; ENDIF
IF "GI" $ cMeta ; cMeta := STRTRAN( cMeta, "GI" , "J" ) ; ENDIF
IF "GE" $ cMeta ; cMeta := STRTRAN( cMeta, "GE" , "J" ) ; ENDIF
IF "GY" $ cMeta ; cMeta := STRTRAN( cMeta, "GY" , "J" ) ; ENDIF
IF "DGE" $ cMeta ; cMeta := StrTran( cMeta, "DGE" , "J" ) ; ENDIF
IF "DGY" $ cMeta ; cMeta := StrTran( cMeta, "DGY" , "J" ) ; ENDIF
IF "DGI" $ cMeta ; cMeta := StrTran( cMeta, "DGI" , "J" ) ; ENDIF
IF "GI" $ cMeta ; cMeta := StrTran( cMeta, "GI" , "J" ) ; ENDIF
IF "GE" $ cMeta ; cMeta := StrTran( cMeta, "GE" , "J" ) ; ENDIF
IF "GY" $ cMeta ; cMeta := StrTran( cMeta, "GY" , "J" ) ; ENDIF
// X sounds (KS)
IF "X" $ cMeta ; cMeta := STRTRAN( cMeta, "X" , "KS" ) ; ENDIF
IF "X" $ cMeta ; cMeta := StrTran( cMeta, "X" , "KS" ) ; ENDIF
// special consideration for SCH
IF "ISCH" $ cMeta; cMeta := STRTRAN( cMeta, "ISCH", "IX" ) ; ENDIF
IF "SCH" $ cMeta ; cMeta := STRTRAN( cMeta, "SCH" , "SK" ) ; ENDIF
IF "ISCH" $ cMeta; cMeta := StrTran( cMeta, "ISCH", "IX" ) ; ENDIF
IF "SCH" $ cMeta ; cMeta := StrTran( cMeta, "SCH" , "SK" ) ; ENDIF
// sh sounds (X)
IF "CIA" $ cMeta ; cMeta := STRTRAN( cMeta, "CIA" , "X" ) ; ENDIF
IF "SIO" $ cMeta ; cMeta := STRTRAN( cMeta, "SIO" , "X" ) ; ENDIF
IF "C" $ cMeta ; cMeta := STRTRAN( cMeta, "SIA" , "X" ) ; ENDIF
IF "SH" $ cMeta ; cMeta := STRTRAN( cMeta, "SH" , "X" ) ; ENDIF
IF "TIA" $ cMeta ; cMeta := STRTRAN( cMeta, "TIA" , "X" ) ; ENDIF
IF "TIO" $ cMeta ; cMeta := STRTRAN( cMeta, "TIO" , "X" ) ; ENDIF
IF "TCH" $ cMeta ; cMeta := STRTRAN( cMeta, "TCH" , "X" ) ; ENDIF
IF "CH" $ cMeta ; cMeta := STRTRAN( cMeta, "CH" , "X" ) ; ENDIF
IF "CIA" $ cMeta ; cMeta := StrTran( cMeta, "CIA" , "X" ) ; ENDIF
IF "SIO" $ cMeta ; cMeta := StrTran( cMeta, "SIO" , "X" ) ; ENDIF
IF "C" $ cMeta ; cMeta := StrTran( cMeta, "SIA" , "X" ) ; ENDIF
IF "SH" $ cMeta ; cMeta := StrTran( cMeta, "SH" , "X" ) ; ENDIF
IF "TIA" $ cMeta ; cMeta := StrTran( cMeta, "TIA" , "X" ) ; ENDIF
IF "TIO" $ cMeta ; cMeta := StrTran( cMeta, "TIO" , "X" ) ; ENDIF
IF "TCH" $ cMeta ; cMeta := StrTran( cMeta, "TCH" , "X" ) ; ENDIF
IF "CH" $ cMeta ; cMeta := StrTran( cMeta, "CH" , "X" ) ; ENDIF
// hissing sounds (S)
IF "SCI" $ cMeta ; cMeta := STRTRAN( cMeta, "SCI" , "S" ) ; ENDIF
IF "SCE" $ cMeta ; cMeta := STRTRAN( cMeta, "SCE" , "S" ) ; ENDIF
IF "SCY" $ cMeta ; cMeta := STRTRAN( cMeta, "SCY" , "S" ) ; ENDIF
IF "CI" $ cMeta ; cMeta := STRTRAN( cMeta, "CI" , "S" ) ; ENDIF
IF "CE" $ cMeta ; cMeta := STRTRAN( cMeta, "CE" , "S" ) ; ENDIF
IF "CY" $ cMeta ; cMeta := STRTRAN( cMeta, "CY" , "S" ) ; ENDIF
IF "Z" $ cMeta ; cMeta := STRTRAN( cMeta, "Z" , "S" ) ; ENDIF
IF "SCI" $ cMeta ; cMeta := StrTran( cMeta, "SCI" , "S" ) ; ENDIF
IF "SCE" $ cMeta ; cMeta := StrTran( cMeta, "SCE" , "S" ) ; ENDIF
IF "SCY" $ cMeta ; cMeta := StrTran( cMeta, "SCY" , "S" ) ; ENDIF
IF "CI" $ cMeta ; cMeta := StrTran( cMeta, "CI" , "S" ) ; ENDIF
IF "CE" $ cMeta ; cMeta := StrTran( cMeta, "CE" , "S" ) ; ENDIF
IF "CY" $ cMeta ; cMeta := StrTran( cMeta, "CY" , "S" ) ; ENDIF
IF "Z" $ cMeta ; cMeta := StrTran( cMeta, "Z" , "S" ) ; ENDIF
// th sound (0)
IF "TH" $ cMeta ; cMeta := STRTRAN( cMeta, "TH" , "0" ) ; ENDIF
IF "TH" $ cMeta ; cMeta := StrTran( cMeta, "TH" , "0" ) ; ENDIF
// Convert all vowels to 'v' from 3rd byte on
cMeta := LEFT( cMeta, 2 ) + _ftConvVowel( SUBSTR( cMeta, 3 ) )
cMeta := Left( cMeta, 2 ) + _ftConvVowel( SubStr( cMeta, 3 ) )
// Make Y's silent if not followed by vowel
IF "Y" $ cMeta
cMeta := STRTRAN( cMeta, "Yv" , "#" ) // Y followed by vowel
cMeta := STRTRAN( cMeta, "Y" , "" ) // not followed by vowel
cMeta := STRTRAN( cMeta, "#" , "Yv" ) // restore Y and vowel
ENDIF
IF "Y" $ cMeta
cMeta := StrTran( cMeta, "Yv" , "#" ) // Y followed by vowel
cMeta := StrTran( cMeta, "Y" , "" ) // not followed by vowel
cMeta := StrTran( cMeta, "#" , "Yv" ) // restore Y and vowel
ENDIF
// More G sounds, looking at surrounding vowels
IF "GHv" $ cMeta ; cMeta := STRTRAN( cMeta, "GHv" , "G" ) ; ENDIF
IF "vGHT" $ cMeta; cMeta := STRTRAN( cMeta, "vGHT", "T" ) ; ENDIF
IF "vGH" $ cMeta ; cMeta := STRTRAN( cMeta, "vGH" , "W" ) ; ENDIF
IF "GN" $ cMeta ; cMeta := STRTRAN( cMeta, "GN" , "N" ) ; ENDIF
IF "G" $ cMeta ; cMeta := STRTRAN( cMeta, "G" , "K" ) ; ENDIF
IF "GHv" $ cMeta ; cMeta := StrTran( cMeta, "GHv" , "G" ) ; ENDIF
IF "vGHT" $ cMeta; cMeta := StrTran( cMeta, "vGHT", "T" ) ; ENDIF
IF "vGH" $ cMeta ; cMeta := StrTran( cMeta, "vGH" , "W" ) ; ENDIF
IF "GN" $ cMeta ; cMeta := StrTran( cMeta, "GN" , "N" ) ; ENDIF
IF "G" $ cMeta ; cMeta := StrTran( cMeta, "G" , "K" ) ; ENDIF
// H sounds, looking at surrounding vowels
IF "vHv" $ cMeta ; cMeta := STRTRAN( cMeta, "vHv" , "H" ) ; ENDIF
IF "vH" $ cMeta ; cMeta := STRTRAN( cMeta, "vH" , "" ) ; ENDIF
IF "vHv" $ cMeta ; cMeta := StrTran( cMeta, "vHv" , "H" ) ; ENDIF
IF "vH" $ cMeta ; cMeta := StrTran( cMeta, "vH" , "" ) ; ENDIF
// F sounds
IF "PH" $ cMeta ; cMeta := STRTRAN( cMeta, "PH" , "F" ) ; ENDIF
IF "V" $ cMeta ; cMeta := STRTRAN( cMeta, "V" , "F" ) ; ENDIF
IF "PH" $ cMeta ; cMeta := StrTran( cMeta, "PH" , "F" ) ; ENDIF
IF "V" $ cMeta ; cMeta := StrTran( cMeta, "V" , "F" ) ; ENDIF
// D sounds a bit like T
IF "D" $ cMeta ; cMeta := STRTRAN( cMeta, "D" , "T" ) ; ENDIF
IF "D" $ cMeta ; cMeta := StrTran( cMeta, "D" , "T" ) ; ENDIF
// K sounds
IF "CK" $ cMeta ; cMeta := STRTRAN( cMeta, "CK" , "K" ) ; ENDIF
IF "Q" $ cMeta ; cMeta := STRTRAN( cMeta, "Q" , "K" ) ; ENDIF
IF "C" $ cMeta ; cMeta := STRTRAN( cMeta, "C" , "K" ) ; ENDIF
IF "CK" $ cMeta ; cMeta := StrTran( cMeta, "CK" , "K" ) ; ENDIF
IF "Q" $ cMeta ; cMeta := StrTran( cMeta, "Q" , "K" ) ; ENDIF
IF "C" $ cMeta ; cMeta := StrTran( cMeta, "C" , "K" ) ; ENDIF
// Remove vowels
cMeta := STRTRAN( cMeta, "v", "" )
cMeta := StrTran( cMeta, "v", "" )
RETURN PadR( ALLTRIM( cMeta ), nSize )
RETURN PadR( AllTrim( cMeta ), nSize )
//------------------------------------------------
STATIC FUNCTION _ftMakeAlpha( cStr )
*------------------------------------------------
STATIC FUNCTION _ftMakeAlpha ( cStr )
// Strips non-alpha characters from a string, leaving spaces
LOCAL x, cAlpha := ""
LOCAL x, cAlpha := ""
FOR x := 1 to LEN( cStr )
IF SUBSTR( cStr, x, 1 ) == " " .OR. IsAlpha( SUBSTR( cStr, x, 1 ) )
cAlpha := cAlpha + SUBSTR( cStr, x, 1 )
ENDIF
NEXT
FOR x := 1 TO Len( cStr )
IF SubStr( cStr, x, 1 ) == " " .OR. IsAlpha( SubStr( cStr, x, 1 ) )
cAlpha := cAlpha + SubStr( cStr, x, 1 )
ENDIF
NEXT
RETURN cAlpha
RETURN cAlpha
//------------------------------------------------
STATIC FUNCTION _ftConvVowel( cStr )
*------------------------------------------------
STATIC FUNCTION _ftConvVowel ( cStr )
// Converts all vowels to letter 'v'
LOCAL x, cConverted := ""
LOCAL x, cConverted := ""
FOR x := 1 to LEN( cStr )
IF SUBSTR( cStr, x, 1 ) $ "AEIOU"
cConverted := cConverted + "v"
ELSE
cConverted := cConverted + SUBSTR( cStr, x, 1 )
ENDIF
NEXT
FOR x := 1 TO Len( cStr )
IF SubStr( cStr, x, 1 ) $ "AEIOU"
cConverted := cConverted + "v"
ELSE
cConverted := cConverted + SubStr( cStr, x, 1 )
ENDIF
NEXT
RETURN cConverted
*------------------------------------------------
// eof metaph.prg
RETURN cConverted

193
harbour/contrib/hbnf/miltime.prg
View File

@@ -26,118 +26,125 @@
#ifdef FT_TEST
PROCEDURE Main()
PROCEDURE Main()
cls
? "am-pm"
? ft_civ2mil(" 5:40 pm")
? ft_civ2mil("05:40 pm")
? ft_civ2mil(" 5:40 PM")
? ft_civ2mil(" 5:40 am")
? ft_civ2mil("05:40 am")
? ft_civ2mil(" 5:40 AM")
?
inkey(0)
cls
? "noon-midnight"
? ft_civ2mil("12:00 m")
? ft_civ2mil("12:00 M")
? ft_civ2mil("12:00 m")
? ft_civ2mil("12:00 n")
? ft_civ2mil("12:00 N")
? ft_civ2mil("12:00 n")
?
inkey(0)
cls
? "errors in noon-midnight"
? ft_civ2mil("12:01 n")
? ft_civ2mil("22:00 n")
? ft_civ2mil("12:01 m")
? ft_civ2mil("22:00 n")
?
? "sys to mil"
? time()
? ft_sys2mil()
return
cls
? "am-pm"
? ft_civ2mil( " 5:40 pm" )
? ft_civ2mil( "05:40 pm" )
? ft_civ2mil( " 5:40 PM" )
? ft_civ2mil( " 5:40 am" )
? ft_civ2mil( "05:40 am" )
? ft_civ2mil( " 5:40 AM" )
?
Inkey( 0 )
cls
? "noon-midnight"
? ft_civ2mil( "12:00 m" )
? ft_civ2mil( "12:00 M" )
? ft_civ2mil( "12:00 m" )
? ft_civ2mil( "12:00 n" )
? ft_civ2mil( "12:00 N" )
? ft_civ2mil( "12:00 n" )
?
Inkey( 0 )
cls
? "errors in noon-midnight"
? ft_civ2mil( "12:01 n" )
? ft_civ2mil( "22:00 n" )
? ft_civ2mil( "12:01 m" )
? ft_civ2mil( "22:00 n" )
?
? "sys to mil"
? Time()
? ft_sys2mil()
RETURN
#endif
function FT_MIL2MIN(cMILTIME)
return int(val(left(cMILTIME,2))*60 + val(right(cMILTIME,2)))
FUNCTION FT_MIL2MIN( cMILTIME )
function FT_MIN2MIL(nMIN)
nMIN := nMIN%1440
return right("00" + ltrim(str(INT(nMIN/60))),2) + ;
right("00" + ltrim(str(INT(nMIN%60))),2)
RETURN Int( Val( Left( cMILTIME, 2 ) ) * 60 + Val( Right( cMILTIME, 2 ) ) )
function FT_MIL2CIV(cMILTIME)
local cHRS,cMINS,nHRS,cCIVTIME
FUNCTION FT_MIN2MIL( nMIN )
nHRS := val(LEFT(cMILTIME,2))
cMINS := right(cMILTIME,2)
nMIN := nMIN % 1440
do case
case (nHRS == 24 .OR. nHRS == 0) .AND. (cMINS == "00") // Midnight
cCIVTIME := "12:00 m"
case (nHRS == 12) // Noon to 12:59pm
if cMINS == "00"
cCIVTIME := "12:00 n"
else
cCIVTIME := "12:" + cMINS + " pm"
endif
case (nHRS < 12) // AM
if nHRS == 0
cHRS := "12"
else
cHRS := right(" " + ltrim(str(int(nHRS))),2)
endif
cCIVTIME := cHRS + ":" + cMINS + " am"
RETURN Right( "00" + LTrim( Str( Int( nMIN / 60 ) ) ), 2 ) + ;
Right( "00" + LTrim( Str( Int( nMIN % 60 ) ) ), 2 )
otherwise // PM
cCIVTIME := right(" " + ltrim(str(int(nHRS - 12))), 2) + ;
":" + cMINS + " pm"
endcase
FUNCTION FT_MIL2CIV( cMILTIME )
return cCIVTIME
LOCAL cHRS, cMINS, nHRS, cCIVTIME
function FT_CIV2MIL(cTIME)
local cKEY, cMILTIME
nHRS := Val( Left( cMILTIME,2 ) )
cMINS := Right( cMILTIME, 2 )
*** Insure leading 0's
cTIME := REPLICATE("0", 3 - at(":", ltrim(cTIME))) + ltrim(cTIME)
DO CASE
CASE ( nHRS == 24 .OR. nHRS == 0 ) .AND. ( cMINS == "00" ) // Midnight
cCIVTIME := "12:00 m"
CASE ( nHRS == 12 ) // Noon to 12:59pm
IF cMINS == "00"
cCIVTIME := "12:00 n"
ELSE
cCIVTIME := "12:" + cMINS + " pm"
ENDIF
CASE ( nHRS < 12 ) // AM
IF nHRS == 0
cHRS := "12"
ELSE
cHRS := Right( " " + LTrim( Str( Int( nHRS ) ) ), 2 )
ENDIF
cCIVTIME := cHRS + ":" + cMINS + " am"
*** Adjust for popular use of '12' for first hour after noon and midnight
if left(ltrim(cTIME),2) == "12"
cTIME := stuff(cTIME, 1, 2, "00")
endif
OTHERWISE // PM
cCIVTIME := Right( " " + LTrim( Str( Int( nHRS - 12 ) ) ), 2 ) + ;
":" + cMINS + " pm"
ENDCASE
*** am, pm, noon or midnight
cKEY := substr(ltrim(cTIME), 7, 1)
RETURN cCIVTIME
do case
case upper(cKEY) == "N" // noon
if left(cTIME,2) + substr(cTIME,4,2) == "0000"
FUNCTION FT_CIV2MIL( cTIME )
LOCAL cKEY, cMILTIME
//** Insure leading 0's
cTIME := Replicate( "0", 3 - At( ":", LTrim( cTIME ) ) ) + LTrim( cTIME )
//** Adjust for popular use of '12' for first hour after noon and midnight
IF Left( LTrim( cTIME ), 2 ) == "12"
cTIME := Stuff( cTIME, 1, 2, "00" )
ENDIF
//** am, pm, noon or midnight
cKEY := SubStr( LTrim( cTIME ), 7, 1 )
DO CASE
CASE Upper( cKEY ) == "N" // noon
IF Left( cTIME, 2 ) + SubStr( cTIME, 4, 2 ) == "0000"
cMILTIME := "1200"
else
ELSE
cMILTIME := " "
endif
case upper(cKEY) == "M" // midnight
if left(cTIME,2) + substr(cTIME,4,2) == "0000"
ENDIF
CASE Upper( cKEY ) == "M" // midnight
IF Left( cTIME, 2 ) + SubStr( cTIME, 4, 2 ) == "0000"
cMILTIME := "0000"
else
ELSE
cMILTIME := " "
endif
case upper(cKEY) == "A" // am
cMILTIME := right("00" + ltrim(str(val(left(cTIME,2)))),2) + ;
substr(cTIME,4,2)
case upper(cKEY) == "P" // pm
cMILTIME := right("00" + ltrim(str(val(left(cTIME,2))+12)),2) + ;
substr(cTIME,4,2)
otherwise
ENDIF
CASE Upper( cKEY ) == "A" // am
cMILTIME := Right( "00" + LTrim( Str( Val( Left( cTIME, 2 ) ) ) ), 2 ) + ;
SubStr( cTIME, 4, 2 )
CASE Upper( cKEY ) == "P" // pm
cMILTIME := Right( "00" + LTrim( Str( Val( Left( cTIME, 2 ) ) + 12 ) ), 2 ) + ;
SubStr( cTIME, 4, 2 )
OTHERWISE
cMILTIME := " " // error
endcase
ENDCASE
return cMILTIME
RETURN cMILTIME
function FT_SYS2MIL()
return left(stuff(time(),3,1,""),4)
FUNCTION FT_SYS2MIL()
RETURN Left( Stuff( Time(), 3, 1, "" ), 4 )

13
harbour/contrib/hbnf/min2dhm.prg
View File

@@ -27,11 +27,12 @@
*
*/
function FT_MIN2DHM(nMINS)
local aDHM_[3]
FUNCTION FT_MIN2DHM( nMINS )
aDHM_[1] := ltrim((str(int(nMINS/1440))))
aDHM_[2] := ltrim(str(int((nMINS%1440)/60)))
aDHM_[3] := ltrim(str(int((nMINS%1440)%60)))
LOCAL aDHM_[ 3 ]
return aDHM_
aDHM_[ 1 ] := LTrim( ( Str( Int( nMINS / 1440 ) ) ) )
aDHM_[ 2 ] := LTrim( Str( Int( ( nMINS % 1440 ) / 60 ) ) )
aDHM_[ 3 ] := LTrim( Str( Int( ( nMINS % 1440 ) % 60 ) ) )
RETURN aDHM_

43
harbour/contrib/hbnf/month.prg
View File

@@ -28,30 +28,31 @@
*/
FUNCTION FT_MONTH( dGivenDate, nMonthNum )
LOCAL lIsMonth, nTemp, aRetVal
IF !( VALTYPE(dGivenDate) $ 'ND')
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'N'
nMonthNum := dGivenDate
dGivenDate := DATE()
ENDIF
LOCAL lIsMonth, nTemp, aRetVal
aRetVal := FT_YEAR(dGivenDate)
IF !( ValType( dGivenDate ) $ 'ND' )
dGivenDate := Date()
ELSEIF ValType( dGivenDate ) == 'N'
nMonthNum := dGivenDate
dGivenDate := Date()
ENDIF
lIsMonth := ( VALTYPE(nMonthNum) == 'N' )
IF lISMonth
IF nMonthNum < 1 .OR. nMonthNum > 12
nMonthNum := 12
ENDIF
dGivenDate := FT_MADD(aRetVal[2], nMonthNum - 1)
ENDIF
aRetVal := FT_YEAR( dGivenDate )
nTemp := MONTH( dGivenDate ) - MONTH( aRetVal[2] )
nTemp += iif(nTemp >= 0, 1, 13)
lIsMonth := ( ValType( nMonthNum ) == 'N' )
IF lISMonth
IF nMonthNum < 1 .OR. nMonthNum > 12
nMonthNum := 12
ENDIF
dGivenDate := FT_MADD( aRetVal[ 2 ], nMonthNum - 1 )
ENDIF
aRetVal[1] += PADL(LTRIM(STR(nTemp, 2)), 2, '0')
aRetVal[2] := FT_MADD( aRetVal[2], nTemp - 1 )
aRetVal[3] := FT_MADD( aRetVal[2], 1 ) - 1
nTemp := Month( dGivenDate ) - Month( aRetVal[ 2 ] )
nTemp += iif( nTemp >= 0, 1, 13 )
RETURN aRetVal
aRetVal[ 1 ] += PadL( LTrim( Str( nTemp, 2 ) ), 2, '0' )
aRetVal[ 2 ] := FT_MADD( aRetVal[ 2 ], nTemp - 1 )
aRetVal[ 3 ] := FT_MADD( aRetVal[ 2 ], 1 ) - 1
RETURN aRetVal

687
harbour/contrib/hbnf/mouse1.prg
View File

@@ -2,595 +2,630 @@
* $Id$
*/
THREAD static s_lCrsState:=.F.
THREAD static s_lMinit:=.F.
THREAD STATIC t_lCrsState := .F.
THREAD STATIC t_lMinit := .F.
#ifdef FT_TEST
PROCEDURE Main(nRow,nCol)
PROCEDURE Main( nRow, nCol )
* Pass valid row and column values for different video modes to change modes
// Pass valid row and column values for different video modes to change modes
local nX, nY, cSavClr
local cSavScr := savescreen( 0, 0, maxrow(), maxcol() )
local nXm, nYm
local nSaveRow:=MAXROW()+1, nSaveCol:=MAXCOL()+1
local nMinor, nType, nIRQ
local aType:={"Bus","Serial","InPort","PS/2","HP"}
local nHoriz, nVert, nDouble
local nTime
LOCAL nX, nY, cSavClr
LOCAL cSavScr := SaveScreen( 0, 0, MaxRow(), MaxCol() )
LOCAL nXm, nYm
LOCAL nSaveRow := MaxRow() + 1, nSaveCol := MaxCol() + 1
LOCAL nMinor, nType, nIRQ
LOCAL aType := { "Bus", "Serial", "InPort", "PS/2", "HP" }
LOCAL nHoriz, nVert, nDouble
LOCAL nTime
IF nRow == NIL
nRow := MAXROW()+1
ELSE
nRow := VAL(nRow)
ENDIF
IF nRow == NIL
nRow := MaxRow() + 1
ELSE
nRow := Val( nRow )
ENDIF
IF nCol == NIL
nCol := MAXCOL()+1
ELSE
nCol := VAL(nCol)
ENDIF
IF nCol == NIL
nCol := MaxCol() + 1
ELSE
nCol := Val( nCol )
ENDIF
if !FT_MINIT()
@ maxrow(), 0 say "Mouse driver is not installed!"
IF !FT_MINIT()
@ MaxRow(), 0 SAY "Mouse driver is not installed!"
return ""
endif
RETURN ""
ENDIF
* ..... Set up the screen
cSavClr := setcolor( "w/n" )
@ 0,0,maxrow(),maxcol() box hb_UTF8ToStr( "░░░░░░░░░" )
// ..... Set up the screen
cSavClr := SetColor( "w/n" )
@ 0, 0, MaxRow(), MaxCol() BOX hb_UTF8ToStr( "░░░░░░░░░" )
setcolor( "GR+/RB" )
SetColor( "GR+/RB" )
// scroll( 7,2,19,63,0 )
@ 7,2 to 20,63
@ 7, 2 TO 20, 63
@ 17, 10 to 19, 40 double
@ 17, 10 TO 19, 40 double
setcolor( "N/W" )
@ 18, 11 say " Double Click here to Quit "
SetColor( "N/W" )
@ 18, 11 SAY " Double Click here to Quit "
setcolor( "GR+/RB" )
SetColor( "GR+/RB" )
* ..... Start the demo
// ..... Start the demo
@MAXROW(),0 SAY "Driver version: "+;
ALLTRIM(STR(FT_MVERSION(@nMinor,@nType,@nIRQ),2,0))+"."+;
ALLTRIM(STR(nMinor,2,0))
@ ROW(),COL() SAY " "+aType[nType]+" mouse using IRQ "+STR(nIRQ,1,0)
@MaxRow(), 0 SAY "Driver version: " + ;
AllTrim( Str( FT_MVERSION(@nMinor,@nType,@nIRQ ),2,0 ) ) + "." + ;
AllTrim( Str( nMinor,2,0 ) )
@ Row(), Col() SAY " " + aType[nType] + " mouse using IRQ " + Str( nIRQ, 1, 0 )
FT_MGETSENS(@nHoriz,@nVert,@nDouble) // Get the current sensitivities
FT_MSETSENS(70,70,60) // Bump up the sensitivity of the mouse
FT_MGETSENS( @nHoriz, @nVert, @nDouble ) // Get the current sensitivities
FT_MSETSENS( 70, 70, 60 ) // Bump up the sensitivity of the mouse
FT_MSHOWCRS()
FT_MSETCOORD(10,20) // just an arbitrary place for demo
FT_MSHOWCRS()
FT_MSETCOORD( 10, 20 ) // just an arbitrary place for demo
* put the unchanging stuff
// put the unchanging stuff
devpos( 9, 10 )
devout( "FT_MMICKEYS :" )
DevPos( 9, 10 )
DevOut( "FT_MMICKEYS :" )
devpos( 10, 10 )
devout( "FT_MGETPOS :" )
DevPos( 10, 10 )
DevOut( "FT_MGETPOS :" )
devpos( 11, 10 )
devout( "FT_MGETX :" )
DevPos( 11, 10 )
DevOut( "FT_MGETX :" )
devpos( 12, 10 )
devout( "FT_MGETY :")
DevPos( 12, 10 )
DevOut( "FT_MGETY :" )
devpos( 13, 10 )
devout( "FT_MGETCOORD:" )
DevPos( 13, 10 )
DevOut( "FT_MGETCOORD:" )
devpos( 14, 10 )
devout( "FT_MBUTPRS :" )
DevPos( 14, 10 )
DevOut( "FT_MBUTPRS :" )
devpos( 16, 10 )
devout( "FT_MBUTREL :" )
DevPos( 16, 10 )
DevOut( "FT_MBUTREL :" )
nX := nY := 1
do while .t.
nX := nY := 1
DO WHILE .T.
* If we are not moving then wait for movement.
* This whole demo is a bit artificial in its requirements when compared
* to a "normal" CLIPPER program so some of these examples are a bit out of
* the ordinary.
// If we are not moving then wait for movement.
// This whole demo is a bit artificial in its requirements when compared
// to a "normal" CLIPPER program so some of these examples are a bit out of
// the ordinary.
DO WHILE nX == 0 .AND. nY == 0
FT_MMICKEYS( @nX, @nY )
ENDDO
* tell the mouse driver where updates will be taking place so it can hide
* the cursor when necessary.
DO WHILE nX == 0 .AND. nY == 0
FT_MMICKEYS( @nX, @nY )
ENDDO
// tell the mouse driver where updates will be taking place so it can hide
// the cursor when necessary.
FT_MCONOFF( 9, 23, 16, 53 )
nTime := -1
FT_MCONOFF( 9, 23, 16, 53 )
nTime := - 1
devpos( 9, 23 )
devout( nX )
devout( nY )
DevPos( 9, 23 )
DevOut( nX )
DevOut( nY )
devpos( 10, 23 )
DEVOUT( FT_MGETPOS( @nX, @nY ) )
devout( nX )
devout( nY )
DevPos( 10, 23 )
DevOut( FT_MGETPOS( @nX, @nY ) )
DevOut( nX )
DevOut( nY )
devpos( 11, 23 )
DEVOUT( FT_MGETX() )
DevPos( 11, 23 )
DevOut( FT_MGETX() )
devpos( 12, 23 )
DEVOUT( FT_MGETY() )
DevPos( 12, 23 )
DevOut( FT_MGETY() )
devpos( 13, 23 )
devout( FT_MGETCOORD( @nX, @nY ) )
devout ( nX )
devout ( nY )
DevPos( 13, 23 )
DevOut( FT_MGETCOORD( @nX, @nY ) )
DevOut( nX )
DevOut( nY )
nX:=nY:=0
devpos( 14, 23 )
DEVOUT( FT_MBUTPRS(1) )
DEVOUT( FT_MBUTPRS(0,, nX, nY) )
devpos( 15, 23 )
nX := nY := 0
DevPos( 14, 23 )
DevOut( FT_MBUTPRS( 1 ) )
DevOut( FT_MBUTPRS( 0,, nX, nY ) )
DevPos( 15, 23 )
* show only the last Press since it flashes by so quickly
// show only the last Press since it flashes by so quickly
IF nX!=0.OR.nY!=0
devout( nX )
devout( nY )
endif
IF nX != 0 .OR. nY != 0
DevOut( nX )
DevOut( nY )
ENDIF
nX:=nY:=0
devpos( 16, 23 )
devout( FT_MBUTREL(0,, @nX, @nY) )
nX := nY := 0
DevPos( 16, 23 )
DevOut( FT_MBUTREL( 0,, @nX, @nY ) )
* show only the last release since it flashes by so quickly
// show only the last release since it flashes by so quickly
if nX!=0.OR.nY!=0
devout( nX )
devout( nY )
endif
IF nX != 0 .OR. nY != 0
DevOut( nX )
DevOut( nY )
ENDIF
* Restore the cursor if it has been hidden
// Restore the cursor if it has been hidden
FT_MSHOWCRS()
FT_MSHOWCRS()
if FT_MINREGION( 18, 11, 18, 39 )
IF FT_MINREGION( 18, 11, 18, 39 )
* Change the type of cursor when in the box. Just slightly different than the
* normal. The character is shown in high intensity.
// Change the type of cursor when in the box. Just slightly different than the
// normal. The character is shown in high intensity.
FT_MDEFCRS(0,32767,32512)
if FT_MDBLCLK(2,0,0.8)
exit
endif
endif
FT_MDEFCRS( 0, 32767, 32512 )
IF FT_MDBLCLK( 2, 0, 0.8 )
EXIT
ENDIF
ENDIF
if FT_MINREGION( 18, 11, 18, 39 )
IF FT_MINREGION( 18, 11, 18, 39 )
* Change the type of cursor when in the box. Just slightly different than the
* normal. The character is shown in high intensity.
// Change the type of cursor when in the box. Just slightly different than the
// normal. The character is shown in high intensity.
FT_MDEFCRS(0,32767,32512)
else
FT_MDEFCRS( 0, 32767, 32512 )
ELSE
* Put the cursor back to normal mode
// Put the cursor back to normal mode
FT_MDEFCRS(0,30719,30464)
endif
FT_MDEFCRS( 0, 30719, 30464 )
ENDIF
FT_MMICKEYS( @nX, @nY )
enddo
FT_MMICKEYS( @nX, @nY )
ENDDO
FT_MHIDECRS()
FT_MHIDECRS()
SETMODE(nSaveRow,nSaveCol)
setcolor( cSavClr )
restscreen( 0, 0, maxrow(), maxcol(), cSavScr )
devpos( maxrow(), 0 )
SetMode( nSaveRow, nSaveCol )
SetColor( cSavClr )
RestScreen( 0, 0, MaxRow(), MaxCol(), cSavScr )
DevPos( MaxRow(), 0 )
// Reset sensitivity
FT_MSETSENS(nHoriz, nVert, nDouble)
FT_MSETSENS( nHoriz, nVert, nDouble )
RETURN
RETURN
#endif
FUNCTION FT_MMICKEYS( nX, nY ) // read mouse motion counters
/*
aReg[AX] := 11 // set mouse function call 11
aReg[ AX ] := 11 // set mouse function call 11
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
Local areturn
areturn:=_mget_mics()
LOCAL areturn
areturn := _mget_mics()
nX := areturn[1] // store horizontal motion units
nY := areturn[2] // store vertical motion units
RETURN NIL // no function output
RETURN NIL // no function output
FUNCTION FT_MDBLCLK( nClick, nButton, nInterval, nRow, nCol, nStart )
LOCAL nVert, nHorz // local row and col coordinates
LOCAL lDouble // double click actually occurred
LOCAL lDone // loop flag
LOCAL nPrs // number of presses which occurred
LOCAL nVert, nHorz // local row and col coordinates
LOCAL lDouble // double click actually occurred
LOCAL lDone // loop flag
LOCAL nPrs // number of presses which occurred
* Initialize any empty arguments
// Initialize any empty arguments
if nClick==NIL
nClick:=1
endif
IF nClick == NIL
nClick := 1
ENDIF
if nButton==NIL
nButton:=0
endif
IF nButton == NIL
nButton := 0
ENDIF
if nRow==NIL
nRow:=FT_MGETX()
endif
IF nRow == NIL
nRow := FT_MGETX()
ENDIF
if nCol==NIL
nCol:=FT_MGETY()
endif
IF nCol == NIL
nCol := FT_MGETY()
ENDIF
if nInterval==NIL
nInterval:=0.5
endif
IF nInterval == NIL
nInterval := 0.5
ENDIF
if nStart==NIL
nStart:=seconds()
endif
IF nStart == NIL
nStart := Seconds()
ENDIF
nVert:=nRow
nHorz:=nCol
lDouble:=lDone:=nClick==0
nVert := nRow
nHorz := nCol
lDouble := lDone := nClick == 0
// Wait for first press if requested
// Wait for first press if requested
do while !lDone
DO WHILE !lDone
FT_MBUTPRS( nButton, @nPrs, @nVert, @nHorz )
nVert:=INT(nVert/8)
nHorz:=INT(nHorz/8)
FT_MBUTPRS( nButton, @nPrs, @nVert, @nHorz )
nVert := Int( nVert/8 )
nHorz := Int( nHorz/8 )
lDouble:=(nPrs>0)
ldone:= seconds() - nStart >= nInterval .or. lDouble
lDouble := ( nPrs > 0 )
ldone := Seconds() - nStart >= nInterval .OR. lDouble
enddo
ENDDO
// if we have not moved then keep the preliminary double click setting
// if we have not moved then keep the preliminary double click setting
lDouble:=lDouble.and.(nVert==nRow.and.nHorz==nCol)
lDouble := lDouble .AND. ( nVert == nRow .AND. nHorz == nCol )
// change start time if we waited for first click. nInterval is the
// maximum time between clicks not the total time for two clicks if
// requested.
// change start time if we waited for first click. nInterval is the
// maximum time between clicks not the total time for two clicks if
// requested.
if nClick>0
nStart:=seconds()
endif
IF nClick > 0
nStart := Seconds()
ENDIF
// If we have fulfilled all of the requirements then wait for second click
// If we have fulfilled all of the requirements then wait for second click
if lDouble
IF lDouble
lDouble:=lDone:=.F.
lDouble := lDone := .F.
do while !lDone
DO WHILE !lDone
FT_MBUTPRS( nButton, @nPrs, @nVert, @nHorz )
nVert:=INT(nVert/8)
nHorz:=INT(nHorz/8)
FT_MBUTPRS( nButton, @nPrs, @nVert, @nHorz )
nVert := Int( nVert/8 )
nHorz := Int( nHorz/8 )
lDouble:=(nPrs>0)
lDone:= seconds() - nStart >= nInterval .or. lDouble
lDouble := ( nPrs > 0 )
lDone := Seconds() - nStart >= nInterval .OR. lDouble
enddo
ENDDO
// make sure we haven't moved
// make sure we haven't moved
lDouble:=lDouble.and.(nVert==nRow.and.nHorz==nCol)
lDouble := lDouble .AND. ( nVert == nRow .AND. nHorz == nCol )
endif
ENDIF
RETURN lDouble
RETURN lDouble
FUNCTION FT_MCONOFF( nTop, nLeft, nBottom, nRight )
* Fill the registers
// Fill the registers
/*
aReg[AX]:=16
aReg[DX]:=nTop*8
aReg[CX]:=nLeft*8
aReg[ AX ]:=16
aReg[ DX ]:=nTop*8
aReg[ CX ]:=nLeft*8
aReg[DI]:=nBottom*8
aReg[SI]:=nRight*8
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
_mse_conoff(nTop*8,nLeft*8,nBottom*8,nRight*8)
RETURN NIL
_mse_conoff( nTop * 8, nLeft * 8, nBottom * 8, nRight * 8 )
RETURN NIL
FUNCTION FT_MINREGION( nTR, nLC, nBR, nRC )
RETURN ( FT_MGETX() >= nTR .and. FT_MGETX() <= nBR .and. ;
FT_MGETY() >= nLC .and. FT_MGETY() <= nRC )
FUNCTION FT_MSETSENS(nHoriz, nVert, nDouble)
LOCAL nCurHoriz, nCurVert, nCurDouble
RETURN FT_MGETX() >= nTR .AND. FT_MGETX() <= nBR .AND. ;
FT_MGETY() >= nLC .AND. FT_MGETY() <= nRC
FUNCTION FT_MSETSENS( nHoriz, nVert, nDouble )
LOCAL nCurHoriz, nCurVert, nCurDouble
// Get current values
FT_MGETSENS(@nCurHoriz, @nCurVert, @nCurDouble)
FT_MGETSENS( @nCurHoriz, @nCurVert, @nCurDouble )
// Set defaults if necessary
IF !( VALTYPE( nHoriz ) == "N" )
nHoriz := nCurHoriz
ENDIF
IF !( ValType( nHoriz ) == "N" )
nHoriz := nCurHoriz
ENDIF
IF !( VALTYPE( nVert ) == "N" )
nVert := nCurVert
ENDIF
IF !( ValType( nVert ) == "N" )
nVert := nCurVert
ENDIF
IF !( VALTYPE( nDouble ) == "N" )
nDouble := nCurDouble
ENDIF
IF !( ValType( nDouble ) == "N" )
nDouble := nCurDouble
ENDIF
* Fill the registers
_mset_sensitive(nHoriz,nVert,nDouble)
// Fill the registers
_mset_sensitive( nHoriz, nVert, nDouble )
RETURN nil
RETURN nil
FUNCTION FT_MGETSENS(nHoriz, nVert, nDouble)
FUNCTION FT_MGETSENS( nHoriz, nVert, nDouble )
/*
* Fill the register
aReg[AX]:=27
aReg[ AX ] := 27
* Execute interupt
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
// Set the return values
nHoriz := _mget_horispeed()
nVert := _mget_verspeed()
nDouble:= _mget_doublespeed()
nHoriz := _mget_horispeed()
nVert := _mget_verspeed()
nDouble := _mget_doublespeed()
RETURN NIL
RETURN NIL
FUNCTION FT_MVERSION( nMinor, nType, nIRQ )
LOCAL aReturn
FUNCTION FT_MVERSION(nMinor, nType, nIRQ)
Local aReturn
// Set up register
/*
aReg[AX] := 36
aReg[ AX ] := 36
// Call interupt
FT_INT86( 51, aReg)
*/
// decode out of half registers
areturn:=_mget_mversion()
areturn := _mget_mversion()
nMinor := areturn[1]
nType := areturn[2]
nIRQ := areturn[3]
nMinor := areturn[ 1 ]
nType := areturn[ 2 ]
nIRQ := areturn[ 3 ]
// Return
RETURN areturn[4]
RETURN areturn[ 4 ]
FUNCTION FT_MSETPAGE(nPage)
FUNCTION FT_MSETPAGE( nPage )
// Set up register
/*
aReg[AX] := 29
aReg[BX] := nPage
aReg[ AX ] := 29
aReg[ BX ] := nPage
// Call interupt
FT_INT86( 51, aReg)
*/
_mset_page(nPage)
RETURN NIL
_mset_page( nPage )
RETURN NIL
FUNCTION FT_MGETPAGE()
// Set up register
/*
aReg[AX] := 30
aReg[ AX ] := 30
// Call interupt
FT_INT86( 51, aReg)
*/
RETURN _mget_page()
RETURN _mget_page()
FUNCTION FT_MINIT()
* If not previously initialized then try
// If not previously initialized then try
IF !s_lMinit
s_lMinit := ( FT_MRESET() != 0 )
IF !t_lMinit
t_lMinit := ( FT_MRESET() != 0 )
ELSE
* Reset maximum x and y limits
// Reset maximum x and y limits
FT_MYLIMIT(0,8*24)
FT_MXLIMIT(0,8*80)
FT_MYLIMIT( 0, 8 * 24 )
FT_MXLIMIT( 0, 8 * 80 )
ENDIF
RETURN s_lMinit
RETURN t_lMinit
FUNCTION FT_MRESET()
LOCAL lStatus
LOCAL lStatus
/*
aReg[AX] := 0 // set mouse function call 0
aReg[ AX ] := 0 // set mouse function call 0
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
s_lCrsState:=.F. // Cursor is off after reset
lStatus:=_m_reset()
* Reset maximum x and y limits
FT_MYLIMIT(0,8*MAXROW())
FT_MXLIMIT(0,8*MAXCOL())
t_lCrsState := .F. // Cursor is off after reset
lStatus := _m_reset()
// Reset maximum x and y limits
RETURN lStatus // return status code
FT_MYLIMIT( 0, 8 * MaxRow() )
FT_MXLIMIT( 0, 8 * MaxCol() )
RETURN lStatus // return status code
FUNCTION FT_MCURSOR( lState )
local lSavState := s_lCrsState
if VALTYPE(lState)=="L"
if ( s_lCrsState := lState )
LOCAL lSavState := t_lCrsState
IF ValType( lState ) == "L"
IF ( t_lCrsState := lState )
FT_MSHOWCRS()
else
ELSE
FT_MHIDECRS()
endif
ENDIF
ENDIF
RETURN lSavState
RETURN lSavState
FUNCTION FT_MSHOWCRS()
/*
aReg[AX] := 1 // set mouse function call 1
aReg[ AX ] := 1 // set mouse function call 1
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
_mse_showcurs()
s_lCrsState := .t.
RETURN NIL // no output from function
_mse_showcurs()
t_lCrsState := .T.
RETURN NIL // no output from function
FUNCTION FT_MHIDECRS() // decrement internal cursor flag and hide cursor
/*
aReg[AX] := 2 // set mouse function call 2
aReg[ AX ] := 2 // set mouse function call 2
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
_mse_mhidecrs()
s_lCrsState := .f.
RETURN NIL // no output from function
t_lCrsState := .F.
RETURN NIL // no output from function
FUNCTION FT_MGETPOS( nX, nY )
Local amse
LOCAL amse
nX := iif( nX == NIL, 0, nX )
nY := iif( nY == NIL, 0, nY )
/*
aReg[AX] := 3 // set mouse function call 3
aReg[ AX ] := 3 // set mouse function call 3
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
amse:=_mse_getpos()
amse := _mse_getpos()
nX := amse[1] // store new x-coordinate
nY := amse[2] // store new y-coordinate
RETURN amse[3] // return button status
RETURN amse[3] // return button status
FUNCTION FT_MGETX()
* Duplicated code from FT_MGETPOS() for speed reasons
// Duplicated code from FT_MGETPOS() for speed reasons
/*
aReg[AX] := 3 // set mouse function call 3
aReg[ AX ] := 3 // set mouse function call 3
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
RETURN( _m_getx()/8 ) // return x-coordinate
RETURN _m_getx() / 8 // return x-coordinate
FUNCTION FT_MGETY()
* Duplicated code from FT_MGETPOS() for speed reasons
// Duplicated code from FT_MGETPOS() for speed reasons
/*
aReg[AX] := 3 // set mouse function call 3
aReg[ AX ] := 3 // set mouse function call 3
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
RETURN( _m_gety()/8) // return y-coordinate
RETURN _m_gety() / 8 // return y-coordinate
FUNCTION FT_MSETPOS( nX, nY ) // set mouse cursor location
/*
aReg[AX] := 4 // set mouse function call 4
aReg[CX] := nY // assign new x-coordinate
aReg[DX] := nX // assign new y-coordinate
aReg[ AX ] := 4 // set mouse function call 4
aReg[ CX ] := nY // assign new x-coordinate
aReg[ DX ] := nX // assign new y-coordinate
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
_m_msetpos(nY,nX)
RETURN NIL // no function output
_m_msetpos( nY, nX )
RETURN NIL // no function output
FUNCTION FT_MSETCOORD( nX, nY ) // set mouse cursor location
/*
aReg[AX] := 4 // set mouse function call 4
aReg[CX] := nY*8 // assign new x-coordinate
aReg[DX] := nX*8 // assign new y-coordinate
aReg[ AX ] := 4 // set mouse function call 4
aReg[ CX ] := nY*8 // assign new x-coordinate
aReg[ DX ] := nX*8 // assign new y-coordinate
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
_m_MSETCOORD(nY*8,nX*8)
RETURN NIL // no function output
_m_MSETCOORD( nY * 8, nX * 8 )
RETURN NIL // no function output
FUNCTION FT_MXLIMIT( nXMin, nXMax ) // set vertical minimum and maximum coordinates
/*
aReg[AX] := 7 // set mouse function call 7
aReg[CX] := nXMin // load vertical minimum parameter
aReg[DX] := nXMax // load vertical maximum parameter
aReg[ AX ] := 7 // set mouse function call 7
aReg[ CX ] := nXMin // load vertical minimum parameter
aReg[ DX ] := nXMax // load vertical maximum parameter
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
_m_mxlimit(nXMin,nXMAX)
RETURN NIL
_m_mxlimit( nXMin, nXMAX )
RETURN NIL
FUNCTION FT_MYLIMIT( nYMin, nYMax ) // set horizontal minimum and maximum coordinates
/*
aReg[AX] := 8 // set mouse function call 8
aReg[CX] := nYMin // load horz minimum parameter
aReg[DX] := nYMax // load horz maximum parameter
aReg[ AX ] := 8 // set mouse function call 8
aReg[ CX ] := nYMin // load horz minimum parameter
aReg[ DX ] := nYMax // load horz maximum parameter
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
_m_mYlimit(nYMin,nYMAX)
RETURN NIL // no function output
_m_mYlimit( nYMin, nYMAX )
RETURN NIL // no function output
FUNCTION FT_MBUTPRS( nButton, nButPrs, nX, nY ) // get button press information
local aReg:={}
LOCAL aReg := {}
/*
aReg[AX] := 5 // set mouse function call 5
aReg[BX] := nButton // pass parameter for left or right button
aReg[ AX ] := 5 // set mouse function call 5
aReg[ BX ] := nButton // pass parameter for left or right button
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
nButPrs := aReg[1] // store updated press count
nX := aReg[2] // x-coordinate at last press
nY := aReg[3] // y-coordinate at last press
_m_MBUTPRS(nButton)
RETURN aReg[4] // return button status
nButPrs := aReg[ 1 ] // store updated press count
nX := aReg[ 2 ] // x-coordinate at last press
nY := aReg[ 3 ] // y-coordinate at last press
_m_MBUTPRS( nButton )
RETURN aReg[4 ] // return button status
FUNCTION FT_MBUTREL( nButton, nButRel, nX, nY ) // get button release information
local areg
Local iButton
areg:=_m_MBUTREL(nButton)
nButRel := aReg[1] // store updated release count
nX := aReg[2] // x-coordinate at last release
nY := aReg[3] // y-coordinate at last release
iButton:= aReg[4] // return button status
RETURN iButton
LOCAL areg
LOCAL iButton
areg := _m_MBUTREL( nButton )
nButRel := aReg[ 1 ] // store updated release count
nX := aReg[ 2 ] // x-coordinate at last release
nY := aReg[ 3 ] // y-coordinate at last release
iButton := aReg[ 4 ] // return button status
RETURN iButton
FUNCTION FT_MDEFCRS( nCurType, nScrMask, nCurMask ) // define text cursor type and masks
/*
aReg[AX] := 10 // set mouse function call 10
aReg[BX] := nCurType // load cursor type parameter
aReg[CX] := nScrMask // load screen mask value
aReg[DX] := nCurMask // load cursor mask value
aReg[ AX ] := 10 // set mouse function call 10
aReg[ BX ] := nCurType // load cursor type parameter
aReg[ CX ] := nScrMask // load screen mask value
aReg[ DX ] := nCurMask // load cursor mask value
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
_m_mdefcrs(nCurType, nScrMask, nCurMask )
RETURN NIL // no function output
_m_mdefcrs( nCurType, nScrMask, nCurMask )
RETURN NIL // no function output
FUNCTION FT_MGETCOORD( nX, nY )
* Duplicated code from FT_MGETPOS() for speed reasons
local aReg
local iButton
// Duplicated code from FT_MGETPOS() for speed reasons
LOCAL aReg
LOCAL iButton
nX := iif( nX == NIL, 0, nX )
nY := iif( nY == NIL, 0, nY )
/*
aReg[AX] := 3 // set mouse function call 3
FT_INT86( 51, aReg ) // execute mouse interrupt
aReg[ AX ] := 3 // set mouse function call 3
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
areg:=_m_mgetcoord()
nX := INT(aReg[1]/8) // store new x-coordinate
nY := INT(aReg[2]/8) // store new y-coordinate
iButton:= aReg[3] // return button status
areg := _m_mgetcoord()
nX := Int( aReg[ 1 ] / 8 ) // store new x-coordinate
nY := Int( aReg[ 2 ] / 8 ) // store new y-coordinate
iButton := aReg[ 3 ] // return button status
RETURN iButton
RETURN iButton

454
harbour/contrib/hbnf/mouse2.prg
View File

@@ -66,373 +66,375 @@
#include "ftint86.ch"
THREAD static aReg[10]
THREAD static lCrsState:=.F.
THREAD static lMinit:=.F.
THREAD STATIC t_aReg[ 10 ]
THREAD STATIC t_lCrsState := .F.
THREAD STATIC t_lMinit := .F.
#ifdef FT_TEST
PROCEDURE Main(nRow,nCol)
PROCEDURE Main( nRow, nCol )
* Pass valid row and column values for different video modes to change modes
// Pass valid row and column values for different video modes to change modes
local nX, nY, cSavClr
local cSavScr := savescreen( 0, 0, maxrow(), maxcol() )
local nXm, nYm
local nSaveRow:=MAXROW()+1, nSaveCol:=MAXCOL()+1
local nMinor, nType, nIRQ
local aType:={"Bus","Serial","InPort","PS/2","HP"}
local nHoriz, nVert, nDouble
local nTime
LOCAL nX, nY, cSavClr
LOCAL cSavScr := SaveScreen( 0, 0, MaxRow(), MaxCol() )
LOCAL nXm, nYm
LOCAL nSaveRow := MaxRow() + 1, nSaveCol := MaxCol() + 1
LOCAL nMinor, nType, nIRQ
LOCAL aType := { "Bus", "Serial", "InPort", "PS/2", "HP" }
LOCAL nHoriz, nVert, nDouble
LOCAL nTime
IF nRow==NIL
nRow:=MAXROW()+1
ELSE
nRow:=VAL(nRow)
ENDIF
IF nRow == NIL
nRow := MaxRow() + 1
ELSE
nRow := Val( nRow )
ENDIF
IF nCol==NIL
nCol:=MAXCOL()+1
ELSE
nCol:=VAL(nCol)
ENDIF
IF nCol == NIL
nCol := MaxCol() + 1
ELSE
nCol := Val( nCol )
ENDIF
IF .NOT.SETMODE(nRow,nCol)
@maxrow(),0 SAY "Mode Change unsuccessful:"+STR(nRow,2,0)+" by";
+STR(nCol,3,0)
RETURN NIL
ENDIF
IF ! SetMode( nRow, nCol )
@MaxRow(), 0 SAY "Mode Change unsuccessful:" + Str( nRow, 2, 0 ) + " by";
+ Str( nCol, 3, 0 )
RETURN NIL
ENDIF
if empty( FT_MINIT() )
@ maxrow(), 0 say "Mouse driver is not installed!"
SETMODE(nSaveRow,nSaveCol)
return ""
endif
IF Empty( FT_MINIT() )
@ MaxRow(), 0 SAY "Mouse driver is not installed!"
SetMode( nSaveRow, nSaveCol )
RETURN ""
ENDIF
* ..... Set up the screen
cSavClr := setcolor( "w/n" )
@ 0,0,maxrow(),maxcol() box hb_UTF8ToStr( "░░░░░░░░░" )
// ..... Set up the screen
cSavClr := SetColor( "w/n" )
@ 0, 0, MaxRow(), MaxCol() BOX hb_UTF8ToStr( "░░░░░░░░░" )
setcolor( "GR+/RB" )
scroll( 7,2,19,63,0 )
@ 7,2 to 20,63
SetColor( "GR+/RB" )
Scroll( 7, 2, 19, 63, 0 )
@ 7, 2 TO 20, 63
@ 17, 10 to 19, 40 double
@ 17, 10 TO 19, 40 double
setcolor( "N/W" )
@ 18, 11 say " Double Click here to Quit "
SetColor( "N/W" )
@ 18, 11 SAY " Double Click here to Quit "
setcolor( "GR+/RB" )
SetColor( "GR+/RB" )
* ..... Start the demo
// ..... Start the demo
@MAXROW(),0 SAY "Driver version: "+;
ALLTRIM(STR(FT_MVERSION(@nMinor,@nType,@nIRQ),2,0))+"."+;
ALLTRIM(STR(nMinor,2,0))
@ ROW(),COL() SAY " "+aType[nType]+" mouse using IRQ "+STR(nIRQ,1,0)
@MaxRow(), 0 SAY "Driver version: " + ;
AllTrim( Str( FT_MVERSION(@nMinor,@nType,@nIRQ ),2,0 ) ) + "." + ;
AllTrim( Str( nMinor,2,0 ) )
@ Row(), Col() SAY " " + aType[nType] + " mouse using IRQ " + Str( nIRQ, 1, 0 )
FT_MGETSENS(@nHoriz,@nVert,@nDouble) // Get the current sensitivities
FT_MSETSENS(70,70,60) // Bump up the sensitivity of the mouse
FT_MGETSENS( @nHoriz, @nVert, @nDouble ) // Get the current sensitivities
FT_MSETSENS( 70, 70, 60 ) // Bump up the sensitivity of the mouse
FT_MSHOWCRS()
FT_MSETCOORD(10,20) // just an arbitrary place for demo
FT_MSHOWCRS()
FT_MSETCOORD( 10, 20 ) // just an arbitrary place for demo
* put the unchanging stuff
// put the unchanging stuff
devpos( 9, 10 )
devout( "FT_MMICKEYS :" )
DevPos( 9, 10 )
DevOut( "FT_MMICKEYS :" )
devpos( 10, 10 )
devout( "FT_MGETPOS :" )
DevPos( 10, 10 )
DevOut( "FT_MGETPOS :" )
devpos( 11, 10 )
devout( "FT_MGETX :" )
DevPos( 11, 10 )
DevOut( "FT_MGETX :" )
devpos( 12, 10 )
devout( "FT_MGETY :")
DevPos( 12, 10 )
DevOut( "FT_MGETY :" )
devpos( 13, 10 )
devout( "FT_MGETCOORD:" )
DevPos( 13, 10 )
DevOut( "FT_MGETCOORD:" )
devpos( 14, 10 )
devout( "FT_MBUTPRS :" )
DevPos( 14, 10 )
DevOut( "FT_MBUTPRS :" )
devpos( 16, 10 )
devout( "FT_MBUTREL :" )
DevPos( 16, 10 )
DevOut( "FT_MBUTREL :" )
nX := nY := 1
do while .t.
nX := nY := 1
DO WHILE .T.
* If we are not moving then wait for movement.
* This whole demo is a bit artificial in its requirements when compared
* to a "normal" CLIPPER program so some of these examples are a bit out of
* the ordinary.
// If we are not moving then wait for movement.
// This whole demo is a bit artificial in its requirements when compared
// to a "normal" CLIPPER program so some of these examples are a bit out of
// the ordinary.
DO WHILE nX==0.AND.nY==0
FT_MMICKEYS( @nX, @nY )
ENDDO
* tell the mouse driver where updates will be taking place so it can hide
* the cursor when necessary.
DO WHILE nX == 0 .AND. nY == 0
FT_MMICKEYS( @nX, @nY )
ENDDO
// tell the mouse driver where updates will be taking place so it can hide
// the cursor when necessary.
FT_MCONOFF( 9, 23, 16, 53 )
nTime:=-1
FT_MCONOFF( 9, 23, 16, 53 )
nTime := - 1
devpos( 9, 23 )
devout( nX )
devout( nY )
DevPos( 9, 23 )
DevOut( nX )
DevOut( nY )
devpos( 10, 23 )
DEVOUT( FT_MGETPOS( @nX, @nY ) )
devout( nX )
devout( nY )
DevPos( 10, 23 )
DevOut( FT_MGETPOS( @nX, @nY ) )
DevOut( nX )
DevOut( nY )
devpos( 11, 23 )
DEVOUT( FT_MGETX() )
DevPos( 11, 23 )
DevOut( FT_MGETX() )
devpos( 12, 23 )
DEVOUT( FT_MGETY() )
DevPos( 12, 23 )
DevOut( FT_MGETY() )
devpos( 13, 23 )
devout( FT_MGETCOORD( @nX, @nY ) )
devout ( nX )
devout ( nY )
DevPos( 13, 23 )
DevOut( FT_MGETCOORD( @nX, @nY ) )
DevOut( nX )
DevOut( nY )
nX:=nY:=0
devpos( 14, 23 )
DEVOUT( FT_MBUTPRS(1) )
DEVOUT( FT_MBUTPRS(0,, nX, nY) )
devpos( 15, 23 )
nX := nY := 0
DevPos( 14, 23 )
DevOut( FT_MBUTPRS( 1 ) )
DevOut( FT_MBUTPRS( 0,, nX, nY ) )
DevPos( 15, 23 )
* show only the last Press since it flashes by so quickly
// show only the last Press since it flashes by so quickly
IF nX!=0.OR.nY!=0
devout( nX )
devout( nY )
endif
IF nX != 0 .OR. nY != 0
DevOut( nX )
DevOut( nY )
ENDIF
nX:=nY:=0
devpos( 16, 23 )
devout( FT_MBUTREL(0,, @nX, @nY) )
nX := nY := 0
DevPos( 16, 23 )
DevOut( FT_MBUTREL( 0,, @nX, @nY ) )
* show only the last release since it flashes by so quickly
// show only the last release since it flashes by so quickly
if nX!=0.OR.nY!=0
devout( nX )
devout( nY )
endif
IF nX != 0 .OR. nY != 0
DevOut( nX )
DevOut( nY )
ENDIF
* Restore the cursor if it has been hidden
// Restore the cursor if it has been hidden
FT_MSHOWCRS()
FT_MSHOWCRS()
if FT_MINREGION( 18, 11, 18, 39 )
IF FT_MINREGION( 18, 11, 18, 39 )
* Change the type of cursor when in the box. Just slightly different than the
* normal. The character is shown in high intensity.
// Change the type of cursor when in the box. Just slightly different than the
// normal. The character is shown in high intensity.
FT_MDEFCRS(0,32767,32512)
if FT_MDBLCLK(2,0,0.8)
exit
endif
endif
FT_MDEFCRS( 0, 32767, 32512 )
IF FT_MDBLCLK( 2, 0, 0.8 )
EXIT
ENDIF
ENDIF
if FT_MINREGION( 18, 11, 18, 39 )
IF FT_MINREGION( 18, 11, 18, 39 )
* Change the type of cursor when in the box. Just slightly different than the
* normal. The character is shown in high intensity.
// Change the type of cursor when in the box. Just slightly different than the
// normal. The character is shown in high intensity.
FT_MDEFCRS(0,32767,32512)
else
FT_MDEFCRS( 0, 32767, 32512 )
ELSE
* Put the cursor back to normal mode
// Put the cursor back to normal mode
FT_MDEFCRS(0,30719,30464)
endif
FT_MDEFCRS( 0, 30719, 30464 )
ENDIF
FT_MMICKEYS( @nX, @nY )
enddo
FT_MMICKEYS( @nX, @nY )
ENDDO
FT_MHIDECRS()
FT_MHIDECRS()
SETMODE(nSaveRow,nSaveCol)
setcolor( cSavClr )
restscreen( 0, 0, maxrow(), maxcol(), cSavScr )
devpos( maxrow(), 0 )
SetMode( nSaveRow, nSaveCol )
SetColor( cSavClr )
RestScreen( 0, 0, MaxRow(), MaxCol(), cSavScr )
DevPos( MaxRow(), 0 )
// Reset sensitivity
FT_MSETSENS(nHoriz, nVert, nDouble)
FT_MSETSENS( nHoriz, nVert, nDouble )
RETURN
RETURN
#endif
FUNCTION FT_MINIT()
* If not previously initialized then try
// If not previously initialized then try
IF !lMinit
lMinit := (FT_MRESET()!=0)
IF !t_lMinit
t_lMinit := ( FT_MRESET() != 0 )
ELSE
* Reset maximum x and y limits
// Reset maximum x and y limits
FT_MYLIMIT(0,8*MAXROW())
FT_MXLIMIT(0,8*MAXCOL())
FT_MYLIMIT( 0, 8 * MaxRow() )
FT_MXLIMIT( 0, 8 * MaxCol() )
ENDIF
RETURN lMinit
RETURN t_lMinit
FUNCTION FT_MRESET()
aReg[AX] := 0 // set mouse function call 0
FT_INT86( 51, aReg ) // execute mouse interrupt
lCrsState := .F. // Cursor is off after reset
t_aReg[ AX ] := 0 // set mouse function call 0
FT_INT86( 51, t_aReg ) // execute mouse interrupt
t_lCrsState := .F. // Cursor is off after reset
* Reset maximum x and y limits
// Reset maximum x and y limits
FT_MYLIMIT(0,8*MAXROW())
FT_MXLIMIT(0,8*MAXCOL())
FT_MYLIMIT( 0, 8 * MaxRow() )
FT_MXLIMIT( 0, 8 * MaxCol() )
RETURN aReg[AX] // return status code
RETURN t_aReg[ AX ] // return status code
FUNCTION FT_MCURSOR( lState )
local lSavState := lCrsState
if VALTYPE(lState)="L"
if ( lCrsState := lState )
LOCAL lSavState := t_lCrsState
IF ValType( lState ) = "L"
IF ( t_lCrsState := lState )
FT_MSHOWCRS()
else
ELSE
FT_MHIDECRS()
endif
ENDIF
ENDIF
RETURN lSavState
RETURN lSavState
FUNCTION FT_MSHOWCRS()
aReg[AX] := 1 // set mouse function call 1
FT_INT86( 51, aReg ) // execute mouse interrupt
lCrsState := .t.
t_aReg[ AX ] := 1 // set mouse function call 1
FT_INT86( 51, t_aReg ) // execute mouse interrupt
t_lCrsState := .T.
RETURN NIL // no output from function
RETURN NIL // no output from function
FUNCTION FT_MHIDECRS() // decrement internal cursor flag and hide cursor
aReg[AX] := 2 // set mouse function call 2
FT_INT86( 51, aReg ) // execute mouse interrupt
lCrsState := .f.
RETURN NIL // no output from function
t_aReg[ AX ] := 2 // set mouse function call 2
FT_INT86( 51, t_aReg ) // execute mouse interrupt
t_lCrsState := .F.
RETURN NIL // no output from function
FUNCTION FT_MGETPOS( nX, nY )
nX := iif( nX == NIL, 0, nX )
nY := iif( nY == NIL, 0, nY )
aReg[AX] := 3 // set mouse function call 3
FT_INT86( 51, aReg ) // execute mouse interrupt
nX := aReg[DX] // store new x-coordinate
nY := aReg[CX] // store new y-coordinate
t_aReg[ AX ] := 3 // set mouse function call 3
FT_INT86( 51, t_aReg ) // execute mouse interrupt
nX := t_aReg[ DX ] // store new x-coordinate
nY := t_aReg[ CX ] // store new y-coordinate
RETURN aReg[BX] // return button status
RETURN t_aReg[ BX ] // return button status
FUNCTION FT_MGETCOORD( nX, nY )
* Duplicated code from FT_MGETPOS() for speed reasons
// Duplicated code from FT_MGETPOS() for speed reasons
nX := iif( nX == NIL, 0, nX )
nY := iif( nY == NIL, 0, nY )
aReg[AX] := 3 // set mouse function call 3
FT_INT86( 51, aReg ) // execute mouse interrupt
nX := INT(aReg[DX]/8) // store new x-coordinate
nY := INT(aReg[CX]/8) // store new y-coordinate
t_aReg[ AX ] := 3 // set mouse function call 3
FT_INT86( 51, t_aReg ) // execute mouse interrupt
nX := Int( t_aReg[ DX ] / 8 ) // store new x-coordinate
nY := Int( t_aReg[ CX ] / 8 ) // store new y-coordinate
RETURN aReg[BX] // return button status
RETURN t_aReg[ BX ] // return button status
FUNCTION FT_MGETX()
* Duplicated code from FT_MGETPOS() for speed reasons
// Duplicated code from FT_MGETPOS() for speed reasons
aReg[AX] := 3 // set mouse function call 3
FT_INT86( 51, aReg ) // execute mouse interrupt
t_aReg[ AX ] := 3 // set mouse function call 3
FT_INT86( 51, t_aReg ) // execute mouse interrupt
RETURN( INT(aReg[DX]/8) ) // return x-coordinate
RETURN Int( t_aReg[ DX ] / 8 ) // return x-coordinate
FUNCTION FT_MGETY()
* Duplicated code from FT_MGETPOS() for speed reasons
// Duplicated code from FT_MGETPOS() for speed reasons
aReg[AX] := 3 // set mouse function call 3
FT_INT86( 51, aReg ) // execute mouse interrupt
t_aReg[ AX ] := 3 // set mouse function call 3
FT_INT86( 51, t_aReg ) // execute mouse interrupt
RETURN( INT(aReg[CX]/8)) // return y-coordinate
RETURN Int( t_aReg[ CX ] / 8 ) // return y-coordinate
FUNCTION FT_MSETPOS( nX, nY ) // set mouse cursor location
aReg[AX] := 4 // set mouse function call 4
aReg[CX] := nY // assign new x-coordinate
aReg[DX] := nX // assign new y-coordinate
FT_INT86( 51, aReg ) // execute mouse interrupt
t_aReg[ AX ] := 4 // set mouse function call 4
t_aReg[ CX ] := nY // assign new x-coordinate
t_aReg[ DX ] := nX // assign new y-coordinate
FT_INT86( 51, t_aReg ) // execute mouse interrupt
RETURN NIL // no function output
RETURN NIL // no function output
FUNCTION FT_MSETCOORD( nX, nY ) // set mouse cursor location
aReg[AX] := 4 // set mouse function call 4
aReg[CX] := nY*8 // assign new x-coordinate
aReg[DX] := nX*8 // assign new y-coordinate
FT_INT86( 51, aReg ) // execute mouse interrupt
t_aReg[ AX ] := 4 // set mouse function call 4
t_aReg[ CX ] := nY * 8 // assign new x-coordinate
t_aReg[ DX ] := nX * 8 // assign new y-coordinate
FT_INT86( 51, t_aReg ) // execute mouse interrupt
RETURN NIL // no function output
RETURN NIL // no function output
FUNCTION FT_MXLIMIT( nXMin, nXMax ) // set vertical minimum and maximum coordinates
aReg[AX] := 7 // set mouse function call 7
aReg[CX] := nXMin // load vertical minimum parameter
aReg[DX] := nXMax // load vertical maximum parameter
FT_INT86( 51, aReg ) // execute mouse interrupt
t_aReg[ AX ] := 7 // set mouse function call 7
t_aReg[ CX ] := nXMin // load vertical minimum parameter
t_aReg[ DX ] := nXMax // load vertical maximum parameter
FT_INT86( 51, t_aReg ) // execute mouse interrupt
RETURN NIL
RETURN NIL
FUNCTION FT_MYLIMIT( nYMin, nYMax ) // set horizontal minimum and maximum coordinates
aReg[AX] := 8 // set mouse function call 8
aReg[CX] := nYMin // load horz minimum parameter
aReg[DX] := nYMax // load horz maximum parameter
FT_INT86( 51, aReg ) // execute mouse interrupt
t_aReg[ AX ] := 8 // set mouse function call 8
t_aReg[ CX ] := nYMin // load horz minimum parameter
t_aReg[ DX ] := nYMax // load horz maximum parameter
FT_INT86( 51, t_aReg ) // execute mouse interrupt
RETURN NIL // no function output
RETURN NIL // no function output
FUNCTION FT_MBUTPRS( nButton, nButPrs, nX, nY ) // get button press information
aReg[AX] := 5 // set mouse function call 5
aReg[BX] := nButton // pass parameter for left or right button
FT_INT86( 51, aReg ) // execute mouse interrupt
nButPrs := aReg[BX] // store updated press count
nX := aReg[DX] // x-coordinate at last press
nY := aReg[CX] // y-coordinate at last press
t_aReg[ AX ] := 5 // set mouse function call 5
t_aReg[ BX ] := nButton // pass parameter for left or right button
FT_INT86( 51, t_aReg ) // execute mouse interrupt
nButPrs := t_aReg[ BX ] // store updated press count
nX := t_aReg[ DX ] // x-coordinate at last press
nY := t_aReg[ CX ] // y-coordinate at last press
RETURN aReg[AX] // return button status
RETURN t_aReg[ AX ] // return button status
FUNCTION FT_MBUTREL( nButton, nButRel, nX, nY ) // get button release information
aReg[AX] := 6 // set mouse function call 6
aReg[BX] := nButton // pass parameter for left or right button
FT_INT86( 51, aReg ) // execute mouse interrupt
nButRel := aReg[BX] // store updated release count
nX := aReg[DX] // x-coordinate at last release
nY := aReg[CX] // y-coordinate at last release
t_aReg[ AX ] := 6 // set mouse function call 6
t_aReg[ BX ] := nButton // pass parameter for left or right button
FT_INT86( 51, t_aReg ) // execute mouse interrupt
nButRel := t_aReg[ BX ] // store updated release count
nX := t_aReg[ DX ] // x-coordinate at last release
nY := t_aReg[ CX ] // y-coordinate at last release
RETURN aReg[AX] // return button status
RETURN t_aReg[ AX ] // return button status
/*
FUNCTION FT_MDEFCRS( nCurType, nScrMask, nCurMask ) // define text cursor type and masks
aReg[AX] := 10 // set mouse function call 10
aReg[BX] := nCurType // load cursor type parameter
aReg[CX] := nScrMask // load screen mask value
aReg[DX] := nCurMask // load cursor mask value
FT_INT86( 51, aReg ) // execute mouse interrupt
t_aReg[ AX ] := 10 // set mouse function call 10
t_aReg[ BX ] := nCurType // load cursor type parameter
t_aReg[ CX ] := nScrMask // load screen mask value
t_aReg[ DX ] := nCurMask // load cursor mask value
FT_INT86( 51, t_aReg ) // execute mouse interrupt
RETURN NIL // no function output

26
harbour/contrib/hbnf/netpv.prg
View File

@@ -25,21 +25,25 @@
*/
#ifdef FT_TEST
PROCEDURE Main()
? FT_NETPV( 10000, 10, { 10000,15000,16000,17000 } )
RETURN
PROCEDURE Main()
? FT_NETPV( 10000, 10, { 10000, 15000, 16000, 17000 } )
RETURN
#endif
FUNCTION FT_NETPV(nInitialInvestment, nInterestRate, aCashFlow, nNoOfCashFlows)
FUNCTION FT_NETPV( nInitialInvestment, nInterestRate, aCashFlow, nNoOfCashFlows )
LOCAL nNetPresentValue := 0
nNoOfCashFlows := iif( nNoOfCashFlows == nil, len( aCashFlow ), nNoOfCashFlows )
nNoOfCashFlows := iif( nNoOfCashFlows == nil, Len( aCashFlow ), nNoOfCashFlows )
AEVAL(aCashFlow, ;
{ | nElement, nElementNo | ;
nNetPresentValue += nElement / ;
((1 + (nInterestRate / 100)) ** nElementNo) }, ;
1, nNoOfCashFlows)
AEval( aCashFlow, ;
{| nElement, nElementNo | ;
nNetPresentValue += nElement / ;
( ( 1 + (nInterestRate / 100 ) ) ** nElementNo ) }, ;
1, nNoOfCashFlows )
RETURN (nNetPresentValue -= nInitialInvestment)
RETURN nNetPresentValue -= nInitialInvestment

23
harbour/contrib/hbnf/nooccur.prg
View File

@@ -24,21 +24,20 @@
*
*/
#define IS_NOT_LOGICAL(x) (VALTYPE(x) != "L")
#define MAKE_UPPER(x) (x := UPPER(x))
#define MAKE_UPPER(x) ( x := UPPER( x ) )
FUNCTION FT_NOOCCUR(cCheckFor, cCheckIn, lIgnoreCase)
FUNCTION FT_NOOCCUR( cCheckFor, cCheckIn, lIgnoreCase )
// Is Case Important??
IF (IS_NOT_LOGICAL(lIgnoreCase) .OR. lIgnoreCase)
// Is Case Important??
IF ! HB_ISLOGICAL( lIgnoreCase ) .OR. lIgnoreCase
MAKE_UPPER(cCheckFor) // No, Force Everything to Uppercase
MAKE_UPPER(cCheckIn)
MAKE_UPPER( cCheckFor ) // No, Force Everything to Uppercase
MAKE_UPPER( cCheckIn )
ENDIF // IS_NOT_LOGICAL(lIgnoreCase) or ;
// lIgnoreCase
// lIgnoreCase
RETURN iif(LEN(cCheckFor) == 0 .OR. LEN(cCheckIn) == 0, ;
0, ;
INT((LEN(cCheckIn) - LEN(STRTRAN(cCheckIn, cCheckFor))) / ;
LEN(cCheckFor)))
RETURN iif( Len( cCheckFor ) == 0 .OR. Len( cCheckIn ) == 0, ;
0, ;
Int( ( Len( cCheckIn ) - Len( StrTran( cCheckIn, cCheckFor ) ) ) / ;
Len( cCheckFor ) ) )

102
harbour/contrib/hbnf/ntow.prg
View File

@@ -21,63 +21,73 @@
*
*/
static sc_ones := { "", " One", " Two", " Three", " Four", " Five", ;
" Six", " Seven", " Eight", " Nine" ;
}
STATIC sc_ones := { "", " One", " Two", " Three", " Four", " Five", ;
" Six", " Seven", " Eight", " Nine" ;
}
static sc_teens := { " Ten", " Eleven", " Twelve", ;
" Thirteen", " Fourteen", " Fifteen", ;
" Sixteen", " Seventeen", " Eighteen", ;
" Nineteen" ;
}
STATIC sc_teens := { " Ten", " Eleven", " Twelve", ;
" Thirteen", " Fourteen", " Fifteen", ;
" Sixteen", " Seventeen", " Eighteen", ;
" Nineteen" ;
}
static sc_tens := { "", "", " Twenty", " Thirty", " Forty", " Fifty", ;
" Sixty", " Seventy", " Eighty", " Ninety" }
STATIC sc_tens := { "", "", " Twenty", " Thirty", " Forty", " Fifty", ;
" Sixty", " Seventy", " Eighty", " Ninety" }
static sc_qualifiers := { "", " Thousand", " Million", " Billion", " Trillion" }
STATIC sc_qualifiers := { "", " Thousand", " Million", " Billion", " Trillion" }
#ifdef FT_TEST
PROCEDURE Main( cNum )
qout( ft_ntow( val( cNum ) ) )
RETURN
PROCEDURE Main( cNum )
QOut( ft_ntow( Val( cNum ) ) )
RETURN
#endif
function ft_ntow(nAmount)
local nTemp, sResult := " ", nQualNo
local nDiv := 10 ^ ( int( sol10(nAmount) / 3 ) * 3 )
FUNCTION ft_ntow( nAmount )
nTemp := int(nAmount % nDiv)
nAmount := int(nAmount / nDiv)
nQualNo := int( sol10( nDiv ) / 3 ) + 1
sResult += grp_to_words(nAmount, sc_qualifiers[ nQualNo ] )
LOCAL nTemp, sResult := " ", nQualNo
LOCAL nDiv := 10 ^ ( Int( sol10(nAmount ) / 3 ) * 3 )
if nTemp > (nDiv /= 1000) .and. (nDiv > 1)
sResult += ft_ntow( nTemp, nDiv )
else
sResult += grp_to_words(nTemp, "")
endif
return ltrim(sResult)
nTemp := Int( nAmount % nDiv )
nAmount := Int( nAmount / nDiv )
nQualNo := Int( sol10( nDiv ) / 3 ) + 1
sResult += grp_to_words( nAmount, sc_qualifiers[ nQualNo ] )
static function grp_to_words(nGrp, sQual)
local sResult := "", nTemp
IF nTemp > ( nDiv /= 1000 ) .AND. ( nDiv > 1 )
sResult += ft_ntow( nTemp, nDiv )
ELSE
sResult += grp_to_words( nTemp, "" )
ENDIF
nTemp := int(nGrp % 100)
nGrp := int(nGrp / 100)
sResult += sc_ones[ nGrp + 1 ] + iif( nGrp > 0, " Hundred", "")
RETURN LTrim( sResult )
do case
case nTemp > 19
sResult += sc_tens[ int( nTemp / 10 ) + 1 ]
sResult += sc_ones[ int( nTemp % 10 ) + 1 ]
case nTemp < 20 .and. nTemp > 9
sResult += sc_teens[ int( nTemp % 10 ) + 1 ]
case nTemp < 10 .and. nTemp > 0
sResult += sc_ones[ int( nTemp) + 1 ]
endcase
return sResult + sQual
STATIC FUNCTION grp_to_words( nGrp, sQual )
static function sol10( nNumber )
local sTemp
LOCAL sResult := "", nTemp
sTemp := ltrim( str( int(nNumber), 0) )
return len(sTemp) - 1
nTemp := Int( nGrp % 100 )
nGrp := Int( nGrp / 100 )
sResult += sc_ones[ nGrp + 1 ] + iif( nGrp > 0, " Hundred", "" )
DO CASE
CASE nTemp > 19
sResult += sc_tens[ int( nTemp / 10 ) + 1 ]
sResult += sc_ones[ int( nTemp % 10 ) + 1 ]
CASE nTemp < 20 .AND. nTemp > 9
sResult += sc_teens[ int( nTemp % 10 ) + 1 ]
CASE nTemp < 10 .AND. nTemp > 0
sResult += sc_ones[ int( nTemp) + 1 ]
ENDCASE
RETURN sResult + sQual
STATIC FUNCTION sol10( nNumber )
LOCAL sTemp
sTemp := LTrim( Str( Int( nNumber ), 0 ) )
RETURN Len( sTemp ) - 1

33
harbour/contrib/hbnf/nwlstat.prg
View File

@@ -31,21 +31,26 @@
#define STATNUM 220
#ifdef FT_TEST
PROCEDURE Main()
QOut( "Logical station: " + str( FT_NWLSTAT() ) )
RETURN
PROCEDURE Main()
QOut( "Logical station: " + Str( FT_NWLSTAT() ) )
RETURN
#endif
FUNCTION FT_NWLSTAT()
/* LOCAL aRegs[ INT86_MAX_REGS ] */
LOCAL nStation
/*
aRegs[ AX ] := MAKEHI( STATNUM )
FT_INT86( DOS, aRegs )
*/
nStation := _ft_nwkstat() /* LOWBYTE( aRegs[ AX ] ) */
if nStation < 0
nStation += 256
endif
RETURN nStation
/* LOCAL aRegs[ INT86_MAX_REGS ] */
LOCAL nStation
/*
aRegs[ AX ] := MAKEHI( STATNUM )
FT_INT86( DOS, aRegs )
*/
nStation := _ft_nwkstat() /* LOWBYTE( aRegs[ AX ] ) */
IF nStation < 0
nStation += 256
ENDIF
RETURN nStation

210
harbour/contrib/hbnf/nwsem.prg
View File

@@ -37,13 +37,11 @@
// Semaphore Package for Novell NetWare
// --------------------------------------------------------------
#include "common.ch"
#include "ftint86.ch"
#define INT21 33
#xcommand DEFAULT <v1> TO <x1> [, <vN> TO <xN> ];
=> iif((<v1>)==NIL,<v1>:=<x1>,NIL) [; iif((<vN>)==NIL,<vN>:=<xN>,NIL)]
#define WAIT_SEMAPHORE 2
#define SIGNAL_SEMAPHORE 3
#define CLOSE_SEMAPHORE 4
@@ -53,149 +51,157 @@
#ifdef FT_TEST
#define INITIAL_SEMAPHORE_VALUE 2
#define WAIT_SECONDS 1
#define INITIAL_SEMAPHORE_VALUE 2
#define WAIT_SECONDS 1
PROCEDURE Main()
local nInitVal, nRc, nHandle, nValue, nOpenCnt
PROCEDURE Main()
cls
LOCAL nInitVal, nRc, nHandle, nValue, nOpenCnt
nInitVal := INITIAL_SEMAPHORE_VALUE
FT_NWSEMOPEN( "TEST", nInitVal, @nHandle, @nOpenCnt )
CLS
qout( "Waiting ten seconds..." )
nRc := ft_nwSemWait( nHandle, 180 )
qout( "Final nRc value = " + STR( nRc ) )
inkey(0)
if nRc == 254
qout("Couldn't get the semaphore. Try again.")
quit
end
nInitVal := INITIAL_SEMAPHORE_VALUE
FT_NWSEMOPEN( "TEST", nInitVal, @nHandle, @nOpenCnt )
cls
QOut( "Waiting ten seconds..." )
nRc := ft_nwSemWait( nHandle, 180 )
QOut( "Final nRc value = " + Str( nRc ) )
Inkey( 0 )
IF nRc == 254
QOut( "Couldn't get the semaphore. Try again." )
QUIT
ENDIF
@ 24, 0 say "Any key to exit"
@ 0, 0 say "Handle: " + str( nHandle )
CLS
ft_nwSemEx( nHandle, @nValue, @nOpenCnt )
while .t.
@ 23, 0 say "Semaphore test -> Open at [" + ;
alltrim(str(nOpenCnt)) + ;
"] stations, value is [" + ;
alltrim(str(nValue)) + "]"
@ 24, 0 SAY "Any key to exit"
@ 0, 0 SAY "Handle: " + Str( nHandle )
if inkey( WAIT_SECONDS ) != 0
exit
endif
ft_nwSemEx( nHandle, @nValue, @nOpenCnt )
WHILE .T.
@ 23, 0 SAY "Semaphore test -> Open at [" + ;
AllTrim( Str( nOpenCnt ) ) + ;
"] stations, value is [" + ;
AllTrim( Str( nValue ) ) + "]"
tone( nHandle,.5 )
ft_nwSemEx( nHandle, @nValue, @nOpenCnt )
enddo
IF Inkey( WAIT_SECONDS ) != 0
EXIT
ENDIF
qout( "Signal returns: " + str( ft_nwsemSig( nHandle ) ) )
qout( "Close returns: " + str( ft_nwsemClose( nHandle ) ) )
Tone( nHandle, .5 )
ft_nwSemEx( nHandle, @nValue, @nOpenCnt )
ENDDO
return
QOut( "Signal returns: " + Str( ft_nwsemSig( nHandle ) ) )
QOut( "Close returns: " + Str( ft_nwsemClose( nHandle ) ) )
RETURN
#endif
function ft_nwSemOpen( cName, nInitVal, nHandle, nOpenCnt )
local aRegs[ INT86_MAX_REGS ], cRequest, nRet
FUNCTION ft_nwSemOpen( cName, nInitVal, nHandle, nOpenCnt )
default cName to "", ;
nInitVal to 0, ;
nHandle to 0, ;
nOpenCnt to 0
LOCAL aRegs[ INT86_MAX_REGS ], cRequest, nRet
cName := iif( len( cName ) > 127, substr( cName, 1, 127 ), cName )
cRequest := chr( len( cName ) ) + cName
DEFAULT cName TO ""
DEFAULT nInitVal TO 0
DEFAULT nHandle TO 0
DEFAULT nOpenCnt TO 0
aRegs[ AX ] := makehi( 197 ) // C5h
aRegs[ DS ] := cRequest
aRegs[ DX ] := REG_DS
aRegs[ CX ] := nInitVal
cName := iif( Len( cName ) > 127, SubStr( cName, 1, 127 ), cName )
cRequest := Chr( Len( cName ) ) + cName
ft_int86( INT21, aRegs )
aRegs[ AX ] := makehi( 197 ) // C5h
aRegs[ DS ] := cRequest
aRegs[ DX ] := REG_DS
aRegs[ CX ] := nInitVal
nHandle := bin2l( i2bin( aRegs[CX] ) + i2bin( aRegs[DX] ) )
nOpenCnt := lowbyte( aRegs[ BX ] )
ft_int86( INT21, aRegs )
nRet := lowbyte( aRegs[AX] )
nHandle := Bin2L( I2Bin( aRegs[CX] ) + I2Bin( aRegs[DX] ) )
nOpenCnt := lowbyte( aRegs[ BX ] )
return iif( nRet < 0, nRet + 256, nRet )
nRet := lowbyte( aRegs[AX] )
function ft_nwSemEx( nHandle, nValue, nOpenCnt )
local aRegs[ INT86_MAX_REGS ], nRet
RETURN iif( nRet < 0, nRet + 256, nRet )
default nHandle to 0, ;
nValue to 0, ;
nOpenCnt to 0
FUNCTION ft_nwSemEx( nHandle, nValue, nOpenCnt )
aRegs[ AX ] := makehi( 197 ) + 1 // C5h, 01h
aRegs[ CX ] := bin2i( substr( l2bin( nHandle ), 1, 2 ) )
aRegs[ DX ] := bin2i( substr( l2bin( nHandle ), 3, 2 ) )
LOCAL aRegs[ INT86_MAX_REGS ], nRet
ft_int86( INT21, aRegs )
DEFAULT nHandle TO 0
DEFAULT nValue TO 0
DEFAULT nOpenCnt TO 0
#ifdef FT_TEST
aRegs[ AX ] := makehi( 197 ) + 1 // C5h, 01h
aRegs[ CX ] := Bin2I( SubStr( L2Bin( nHandle ), 1, 2 ) )
aRegs[ DX ] := Bin2I( SubStr( L2Bin( nHandle ), 3, 2 ) )
@ 5, 1 say highbyte( aregs[CX] )
@ 6, 1 say lowbyte( aregs[CX ] )
ft_int86( INT21, aRegs )
#endif
#ifdef FT_TEST
nValue := aRegs[ CX ]
nOpenCnt := lowbyte( aRegs[ DX ] )
nRet := lowbyte( aRegs[ AX ] )
@ 5, 1 SAY highbyte( aregs[CX] )
@ 6, 1 SAY lowbyte( aregs[CX ] )
return iif( nRet < 0, nRet + 256, nRet )
#endif
function ft_nwSemWait( nHandle, nTimeout )
return _ftnwsem( WAIT_SEMAPHORE, nHandle, nTimeout )
nValue := aRegs[ CX ]
nOpenCnt := lowbyte( aRegs[ DX ] )
nRet := lowbyte( aRegs[ AX ] )
function ft_nwSemSig( nHandle )
return _ftnwsem( SIGNAL_SEMAPHORE, nHandle )
RETURN iif( nRet < 0, nRet + 256, nRet )
function ft_nwSemClose( nHandle )
return _ftnwsem( CLOSE_SEMAPHORE, nHandle )
FUNCTION ft_nwSemWait( nHandle, nTimeout )
RETURN _ftnwsem( WAIT_SEMAPHORE, nHandle, nTimeout )
FUNCTION ft_nwSemSig( nHandle )
RETURN _ftnwsem( SIGNAL_SEMAPHORE, nHandle )
FUNCTION ft_nwSemClose( nHandle )
RETURN _ftnwsem( CLOSE_SEMAPHORE, nHandle )
// ---------------------------------------------------------
// _ftnwsem() - internal for the semaphore package
// ---------------------------------------------------------
static function _ftnwsem( nOp, nHandle, nTimeout )
local aRegs[ INT86_MAX_REGS ],;
nRet
STATIC FUNCTION _ftnwsem( nOp, nHandle, nTimeout )
default nOp to SIGNAL_SEMAPHORE, ;
nHandle to 0, ;
nTimeout to 0
LOCAL aRegs[ INT86_MAX_REGS ], nRet
aRegs[ AX ] := makehi( 197 ) + nOp
aRegs[ CX ] := bin2i( substr( l2bin( nHandle ), 1, 2 ) )
aRegs[ DX ] := bin2i( substr( l2bin( nHandle ), 3, 2 ) )
aRegs[ BP ] := nTimeout
DEFAULT nOp TO SIGNAL_SEMAPHORE
DEFAULT nHandle TO 0
DEFAULT nTimeout TO 0
ft_int86( INT21, aRegs )
nRet := lowbyte( aRegs[AX] )
nRet := iif( nRet < 0, nRet + 256, nRet )
aRegs[ AX ] := makehi( 197 ) + nOp
aRegs[ CX ] := Bin2I( SubStr( L2Bin( nHandle ), 1, 2 ) )
aRegs[ DX ] := Bin2I( SubStr( L2Bin( nHandle ), 3, 2 ) )
aRegs[ BP ] := nTimeout
return nRet
ft_int86( INT21, aRegs )
nRet := lowbyte( aRegs[ AX ] )
nRet := iif( nRet < 0, nRet + 256, nRet )
function ft_nwSemLock( cSemaphore, nHandle )
local nRc
local nOpenCnt := 0
RETURN nRet
nRc := FT_NWSEMOPEN( cSemaphore, 0, @nHandle, @nOpenCnt )
FUNCTION ft_nwSemLock( cSemaphore, nHandle )
if nRc == 0
if nOpenCnt != 1
ft_nwSemClose( nHandle )
endif
endif
LOCAL nRc
LOCAL nOpenCnt := 0
return ( nOpenCnt == 1 )
nRc := FT_NWSEMOPEN( cSemaphore, 0, @nHandle, @nOpenCnt )
function ft_nwSemUnLock( nHandle )
return ( ft_nwSemClose( nHandle ) == 0 )
IF nRc == 0
IF nOpenCnt != 1
ft_nwSemClose( nHandle )
ENDIF
ENDIF
RETURN nOpenCnt == 1
FUNCTION ft_nwSemUnLock( nHandle )
RETURN ft_nwSemClose( nHandle ) == 0

64
harbour/contrib/hbnf/nwuid.prg
View File

@@ -38,45 +38,51 @@
#define NW_LOG 227
#ifdef FT_TEST
PROCEDURE Main()
local x, cUid
QOut( "I am: [" + FT_NWUID() + "]" )
QOut( "---------------------" )
for x:= 1 to 100
cUid := FT_NWUID( x )
if .not. empty( cUid )
QOut( str( x, 3 ) + space(3) + cUid )
endif
next
PROCEDURE Main()
LOCAL x, cUid
QOut( "I am: [" + FT_NWUID() + "]" )
QOut( "---------------------" )
FOR x := 1 TO 100
cUid := FT_NWUID( x )
IF ! Empty( cUid )
QOut( Str( x, 3 ) + Space( 3 ) + cUid )
ENDIF
NEXT
RETURN
RETURN
#endif
FUNCTION FT_NWUID( nConn )
LOCAL aRegs[ INT86_MAX_REGS ], ;
cReqPkt, ;
cRepPkt
nConn := iif( nConn == nil, FT_NWLSTAT(), nConn )
LOCAL aRegs[ INT86_MAX_REGS ]
LOCAL cReqPkt
LOCAL cRepPkt
// Set up request packet
nConn := iif( nConn == nil, FT_NWLSTAT(), nConn )
cReqPkt := chr( 22 ) // Function 22: Get Connection Information
cReqPkt += chr( nConn )
cReqPkt := i2bin( len( cReqPkt ) ) + cReqPkt
// Set up request packet
// Set up reply packet
cReqPkt := Chr( 22 ) // Function 22: Get Connection Information
cReqPkt += Chr( nConn )
cReqPkt := I2Bin( Len( cReqPkt ) ) + cReqPkt
cRepPkt := space(63)
// Set up reply packet
// Assign registers
cRepPkt := Space( 63 )
aRegs[ AX ] := MAKEHI( NW_LOG )
aRegs[ DS ] := cReqPkt
aRegs[ SI ] := REG_DS
aRegs[ ES ] := cRepPkt
aRegs[ DI ] := REG_ES
// Assign registers
FT_INT86( DOS, aRegs )
RETURN alltrim( strtran( substr( aRegs[ ES ], 9, 48 ), chr(0) ) )
aRegs[ AX ] := MAKEHI( NW_LOG )
aRegs[ DS ] := cReqPkt
aRegs[ SI ] := REG_DS
aRegs[ ES ] := cRepPkt
aRegs[ DI ] := REG_ES
FT_INT86( DOS, aRegs )
RETURN AllTrim( StrTran( SubStr( aRegs[ ES ], 9, 48 ), Chr( 0 ) ) )

4
harbour/contrib/hbnf/ontick.prg
View File

@@ -73,13 +73,13 @@ PROCEDURE FT_ONTICK( bOnTick, nTickInterval )
ENDIF
t_nLastCheck := hb_milliSeconds()
IF Empty( t_hIdle )
t_hIdle := hb_IdleAdd( {|| __FT_ONTICK() } )
t_hIdle := hb_idleAdd( {|| __FT_ONTICK() } )
ENDIF
ELSE
t_bOnTick := NIL
t_nTickInterval := 0
IF ! Empty( t_hIdle )
hb_IdleDel( t_hIdle )
hb_idleDel( t_hIdle )
t_hIdle := NIL
ENDIF
ENDIF

22
harbour/contrib/hbnf/page.prg
View File

@@ -33,21 +33,23 @@
FUNCTION FT_SETVPG( nPage )
/*
LOCAL aRegs[ INT86_MAX_REGS ]
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] := MAKEHI( 5 ) + nPage
FT_INT86( VIDEO, aRegs )
aRegs[ AX ] := MAKEHI( 5 ) + nPage
FT_INT86( VIDEO, aRegs )
*/
_ft_setvpg(nPage)
RETURN NIL
_ft_setvpg( nPage )
RETURN NIL
FUNCTION FT_GETVPG()
/*
LOCAL aRegs[ INT86_MAX_REGS ]
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] := MAKEHI( 15 )
FT_INT86( VIDEO, aRegs )
aRegs[ AX ] := MAKEHI( 15 )
FT_INT86( VIDEO, aRegs )
RETURN ( HIGHBYTE( aRegs[ BX ] ) ) */
Return _ft_getvpg()
RETURN HIGHBYTE( aRegs[ BX ] ) */
RETURN _ft_getvpg()

189
harbour/contrib/hbnf/pchr.prg
View File

@@ -29,116 +29,117 @@
but only if _SET_EXACT was set to .F., Harbour accepts them
that way regardless of _SET_EXACT setting. [vszakats] */
Function FT_PCHR(c_nums)
Local c_ret:='', c_st:=0,c_part,c_st2,c_hex:="0123456789ABCDEF"
Local c_upper,c_t1,c_t2
FUNCTION FT_PCHR( c_nums )
If Substr(c_nums,1,1)==','.or.Trim(c_nums)==''
Return ""
Endif
LOCAL c_ret := '', c_st := 0, c_part, c_st2, c_hex := "0123456789ABCDEF"
LOCAL c_upper, c_t1, c_t2
c_nums := Trim(c_nums) + ",~,"
c_part := Substr(c_nums,c_st+1,At(",",Substr(c_nums,c_st+2)))
IF SubStr( c_nums, 1, 1 ) == ',' .OR. Trim( c_nums ) == ''
RETURN ""
ENDIF
Do While .not.(c_part=="~".or.c_part=="")
c_nums := Trim( c_nums ) + ",~,"
c_part := SubStr( c_nums, c_st + 1, At( ",",SubStr(c_nums,c_st + 2 ) ) )
If Substr(c_part,1,1)==Chr(34)
DO WHILE ! ( c_part == "~" .OR. c_part == "" )
c_st2:=At(Chr(34),Substr(c_part,2))+1
c_ret:=c_ret+Substr(c_part,2,c_st2-2)
IF SubStr( c_part, 1, 1 ) == Chr( 34 )
Elseif Substr(c_part,1,1)=="&"
c_st2 := At( Chr( 34 ), SubStr( c_part,2 ) ) + 1
c_ret := c_ret + SubStr( c_part, 2, c_st2 - 2 )
c_upper:=Upper(c_part)
c_t1:=At(Substr(c_upper,2,1),c_hex)-1
If c_t1>-1
c_t2:=At(Substr(c_upper,3,1),c_hex)-1
If c_t2>-1
c_t1:=c_t1*16+c_t2
Endif
c_ret:=c_ret+Chr(c_t1)
Endif
ELSEIF SubStr( c_part, 1, 1 ) == "&"
ElseIf (Val(c_part)>0.and.Val(c_part)<256).or.c_part=="0"
c_upper := Upper( c_part )
c_t1 := At( SubStr( c_upper,2,1 ), c_hex ) - 1
IF c_t1 >- 1
c_t2 := At( SubStr( c_upper,3,1 ), c_hex ) - 1
IF c_t2 >- 1
c_t1 := c_t1 * 16 + c_t2
ENDIF
c_ret := c_ret + Chr( c_t1 )
ENDIF
c_ret:=c_ret+Chr(Val(c_part))
ELSEIF ( Val( c_part ) > 0 .AND. Val( c_part ) < 256 ) .OR. c_part == "0"
Else
c_ret := c_ret + Chr( Val( c_part ) )
If Substr(c_part,1,1)=="/"
ELSE
c_upper:=Upper(c_part)
IF SubStr( c_part, 1, 1 ) == "/"
#define LEFTEQUAL( l, r ) ( Left( l, Len( r ) ) == r )
c_upper := Upper( c_part )
Do Case
Case LEFTEQUAL( c_upper, '/GRAPHIC' )
c_ret += Chr(27)+Chr(116)+Chr(1)
Case LEFTEQUAL( c_upper, '/ITALIC' )
c_ret += Chr(27)+Chr(116)+Chr(0)
Case LEFTEQUAL( c_upper, '/PICTURE' )
c_ret += Chr(27)+Chr(116)+Chr(1)+;
Chr(27)+Chr(120)+Chr(1)+Chr(27)+Chr(107)+Chr(1)+;
Chr(27)+Chr(77)+Chr(27)+'U'
Case LEFTEQUAL( c_upper, '/COND' ) .or. LEFTEQUAL( c_upper, '/SI' )
c_ret += Chr(15)
Case LEFTEQUAL( c_upper, '/ROMAN' )
c_ret += Chr(27)+Chr(107)+Chr(0)
Case LEFTEQUAL( c_upper, '/SANS' )
c_ret += Chr(27)+Chr(107)+Chr(1)
Case LEFTEQUAL( c_upper, '/NLQ' )
c_ret += Chr(27)+Chr(120)+Chr(1)
Case LEFTEQUAL( c_upper, '/DRAFT' )
c_ret += Chr(27)+Chr(120)+Chr(0)
Case LEFTEQUAL( c_upper, '/ELITE' )
c_ret += Chr(27)+Chr(77)
Case LEFTEQUAL( c_upper, '/PICA' )
c_ret += Chr(27)+Chr(80)
Case LEFTEQUAL( c_upper, '/EMPHOFF' )
c_ret += Chr(27)+Chr(70)
Case LEFTEQUAL( c_upper, '/EMPH' )
c_ret += Chr(27)+Chr(69)
Case LEFTEQUAL( c_upper, '/1/6' )
c_ret += Chr(27)+Chr(50)
Case LEFTEQUAL( c_upper, '/1/8' )
c_ret += Chr(27)+Chr(48)
Case LEFTEQUAL( c_upper, '/SKIPOFF' )
c_ret += Chr(27)+Chr(79)
Case LEFTEQUAL( c_upper, '/SKIP' )
c_ret += Chr(27)+Chr(78)
Case LEFTEQUAL( c_upper, '/FF' ).or.LEFTEQUAL( c_upper, '/EJECT' )
c_ret += Chr(12)
Case LEFTEQUAL( c_upper, '/INIT' ).or.LEFTEQUAL( c_upper, '/RESET' )
c_ret += Chr(27)+Chr(64)
Case LEFTEQUAL( c_upper, '/SPANISH' )
c_ret += Chr(27)+Chr(82)+Chr(12)
Case LEFTEQUAL( c_upper, '/USA' )
c_ret += Chr(27)+Chr(82)+Chr(0)
Case LEFTEQUAL( c_upper, '/ONE' )
c_ret += Chr(27)+'U'+Chr(1)
Case LEFTEQUAL( c_upper, '/TWO' )
c_ret += Chr(27)+'U'+Chr(0)
Case LEFTEQUAL( c_upper, '/FAST' )
c_ret += Chr(27)+'s'+Chr(0)
Case LEFTEQUAL( c_upper, '/SLOW' )
c_ret += Chr(27)+'s'+Chr(1)
Case LEFTEQUAL( c_upper, '/OFF' )
c_ret += Chr(19)
Case LEFTEQUAL( c_upper, '/ON' )
c_ret += Chr(17)
Case LEFTEQUAL( c_upper, '/BEEP' ) .or. LEFTEQUAL( c_upper, '/BELL' )
c_ret += Chr(7)
Case LEFTEQUAL( c_upper, '/CAN' )
c_ret += Chr(24)
Endcase
#define LEFTEQUAL( l, r ) ( Left( l, Len( r ) ) == r )
Endif
DO CASE
CASE LEFTEQUAL( c_upper, '/GRAPHIC' )
c_ret += Chr( 27 ) + Chr( 116 ) + Chr( 1 )
CASE LEFTEQUAL( c_upper, '/ITALIC' )
c_ret += Chr( 27 ) + Chr( 116 ) + Chr( 0 )
CASE LEFTEQUAL( c_upper, '/PICTURE' )
c_ret += Chr( 27 ) + Chr( 116 ) + Chr( 1 ) + ;
Chr( 27 ) + Chr( 120 ) + Chr( 1 ) + Chr( 27 ) + Chr( 107 ) + Chr( 1 ) + ;
Chr( 27 ) + Chr( 77 ) + Chr( 27 ) + 'U'
CASE LEFTEQUAL( c_upper, '/COND' ) .OR. LEFTEQUAL( c_upper, '/SI' )
c_ret += Chr( 15 )
CASE LEFTEQUAL( c_upper, '/ROMAN' )
c_ret += Chr( 27 ) + Chr( 107 ) + Chr( 0 )
CASE LEFTEQUAL( c_upper, '/SANS' )
c_ret += Chr( 27 ) + Chr( 107 ) + Chr( 1 )
CASE LEFTEQUAL( c_upper, '/NLQ' )
c_ret += Chr( 27 ) + Chr( 120 ) + Chr( 1 )
CASE LEFTEQUAL( c_upper, '/DRAFT' )
c_ret += Chr( 27 ) + Chr( 120 ) + Chr( 0 )
CASE LEFTEQUAL( c_upper, '/ELITE' )
c_ret += Chr( 27 ) + Chr( 77 )
CASE LEFTEQUAL( c_upper, '/PICA' )
c_ret += Chr( 27 ) + Chr( 80 )
CASE LEFTEQUAL( c_upper, '/EMPHOFF' )
c_ret += Chr( 27 ) + Chr( 70 )
CASE LEFTEQUAL( c_upper, '/EMPH' )
c_ret += Chr( 27 ) + Chr( 69 )
CASE LEFTEQUAL( c_upper, '/1/6' )
c_ret += Chr( 27 ) + Chr( 50 )
CASE LEFTEQUAL( c_upper, '/1/8' )
c_ret += Chr( 27 ) + Chr( 48 )
CASE LEFTEQUAL( c_upper, '/SKIPOFF' )
c_ret += Chr( 27 ) + Chr( 79 )
CASE LEFTEQUAL( c_upper, '/SKIP' )
c_ret += Chr( 27 ) + Chr( 78 )
CASE LEFTEQUAL( c_upper, '/FF' ) .OR. LEFTEQUAL( c_upper, '/EJECT' )
c_ret += Chr( 12 )
CASE LEFTEQUAL( c_upper, '/INIT' ) .OR. LEFTEQUAL( c_upper, '/RESET' )
c_ret += Chr( 27 ) + Chr( 64 )
CASE LEFTEQUAL( c_upper, '/SPANISH' )
c_ret += Chr( 27 ) + Chr( 82 ) + Chr( 12 )
CASE LEFTEQUAL( c_upper, '/USA' )
c_ret += Chr( 27 ) + Chr( 82 ) + Chr( 0 )
CASE LEFTEQUAL( c_upper, '/ONE' )
c_ret += Chr( 27 ) + 'U' + Chr( 1 )
CASE LEFTEQUAL( c_upper, '/TWO' )
c_ret += Chr( 27 ) + 'U' + Chr( 0 )
CASE LEFTEQUAL( c_upper, '/FAST' )
c_ret += Chr( 27 ) + 's' + Chr( 0 )
CASE LEFTEQUAL( c_upper, '/SLOW' )
c_ret += Chr( 27 ) + 's' + Chr( 1 )
CASE LEFTEQUAL( c_upper, '/OFF' )
c_ret += Chr( 19 )
CASE LEFTEQUAL( c_upper, '/ON' )
c_ret += Chr( 17 )
CASE LEFTEQUAL( c_upper, '/BEEP' ) .OR. LEFTEQUAL( c_upper, '/BELL' )
c_ret += Chr( 7 )
CASE LEFTEQUAL( c_upper, '/CAN' )
c_ret += Chr( 24 )
ENDCASE
Endif
ENDIF
c_st := At(",",Substr(c_nums,c_st+1))+c_st
c_part := Substr(c_nums,c_st+1,At(",",Substr(c_nums,c_st+2)))
ENDIF
Enddo
c_st := At( ",", SubStr( c_nums,c_st + 1 ) ) + c_st
c_part := SubStr( c_nums, c_st + 1, At( ",", SubStr( c_nums, c_st + 2 ) ) )
Return c_ret
ENDDO
RETURN c_ret

320
harbour/contrib/hbnf/pegs.prg
View File

@@ -33,10 +33,10 @@
#include "setcurs.ch"
#translate SINGLEBOX(<top>, <left>, <bottom>, <right>) => ;
@ <top>, <left>, <bottom>, <right> BOX hb_UTF8ToStr( "┌─┐│┘─└│ " )
@ < top > , < left > , < bottom > , < right > BOX hb_UTF8ToStr( "┌─┐│┘─└│ " )
#translate DOUBLEBOX(<top>, <left>, <bottom>, <right>) => ;
@ <top>, <left>, <bottom>, <right> BOX hb_UTF8ToStr( '╔═╗║╝═╚║ ' )
memvar getlist
@ < top > , < left > , < bottom > , < right > BOX hb_UTF8ToStr( '╔═╗║╝═╚║ ' )
MEMVAR getlist
/*
here's the board array -- structure of which is:
@@ -45,170 +45,180 @@ memvar getlist
board_[xx, 3] - subarray containing all target locations
board_[xx, 4] - is the location occupied or not? .T. -> Yes, .F. -> No
*/
THREAD static board_ := { { {0, 29, 2, 34}, {2, 4}, {3, 9}, .T. } , ;
{ {0, 37, 2, 42}, {5}, {10}, .T.} , ;
{ {0, 45, 2, 50}, {2, 6}, {1, 11}, .T. } , ;
{ {3, 29, 5, 34}, {5, 9}, {6, 16}, .T. } , ;
{ {3, 37, 5, 42}, {10}, {17}, .T. } , ;
{ {3, 45, 5, 50}, {5, 11}, {4, 18}, .T. } , ;
{ {6, 13, 8, 18}, {8, 14}, {9, 21}, .T. } , ;
{ {6, 21, 8, 26}, {9, 15}, {10, 22}, .T. } , ;
{ {6, 29, 8, 34}, {4, 8, 10, 16}, {1, 7, 11, 23}, .T. } , ;
{ {6, 37, 8, 42}, {5, 9, 11, 17}, {2, 8, 12, 24}, .T. } , ;
{ {6, 45, 8, 50}, {6, 10, 12, 18}, {3, 9, 13, 25}, .T. } , ;
{ {6, 53, 8, 58}, {11, 19}, {10, 26}, .T. } , ;
{ {6, 61, 8, 66}, {12, 20}, {11, 27}, .T. } , ;
{ {9, 13, 11, 18}, {15}, {16}, .T. } , ;
{ {9, 21, 11, 26}, {16}, {17}, .T. } , ;
{ {9, 29, 11, 34}, {9, 15, 17, 23}, {4, 14, 18, 28}, .T. } , ;
{ {9, 37, 11, 42}, {10, 16, 18, 24}, {5, 15, 19, 29}, .F. } , ;
{ {9, 45, 11, 50}, {11, 17, 19, 25}, {6, 16, 20, 30}, .T. } , ;
{ {9, 53, 11, 58}, {18}, {17}, .T. } , ;
{ {9, 61, 11, 66}, {19}, {18}, .T. } , ;
{ {12, 13, 14, 18}, {14, 22}, {7, 23}, .T. } , ;
{ {12, 21, 14, 26}, {15, 23}, {8, 24}, .T. } , ;
{ {12, 29, 14, 34}, {16, 22, 24, 28}, {9, 21, 25, 31}, .T. } , ;
{ {12, 37, 14, 42}, {17, 23, 25, 29}, {10, 22, 26, 32}, .T. } , ;
{ {12, 45, 14, 50}, {18, 24, 26, 30}, {11, 23, 27, 33}, .T. } , ;
{ {12, 53, 14, 58}, {19, 25}, {12, 24}, .T. } , ;
{ {12, 61, 14, 66}, {20, 26}, {13, 25}, .T. } , ;
{ {15, 29, 17, 34}, {23, 29}, {16, 30}, .T. } , ;
{ {15, 37, 17, 42}, {24}, {17}, .T. } , ;
{ {15, 45, 17, 50}, {25, 29}, {18, 28}, .T. } , ;
{ {18, 29, 20, 34}, {28, 32}, {23, 33}, .T. } , ;
{ {18, 37, 20, 42}, {29}, {24}, .T. } , ;
{ {18, 45, 20, 50}, {30, 32}, {25, 31}, .T. } }
function FT_PEGS
LOCAL XX, MOVE, MPOS, POSSIBLE_, BUFFER, TOPROW, OLDSCORE, MOVE2, ;
SCANBLOCK, OLDCOLOR := SETCOLOR('w/n'), ;
oldscrn := savescreen(0, 0, maxrow(), maxcol())
THREAD STATIC board_ := { { {0, 29, 2, 34}, {2, 4}, {3, 9}, .T. } , ;
{ { 0, 37, 2, 42 }, { 5 }, { 10 }, .T. } , ;
{ { 0, 45, 2, 50 }, { 2, 6 }, { 1, 11 }, .T. } , ;
{ { 3, 29, 5, 34 }, { 5, 9 }, { 6, 16 }, .T. } , ;
{ { 3, 37, 5, 42 }, { 10 }, { 17 }, .T. } , ;
{ { 3, 45, 5, 50 }, { 5, 11 }, { 4, 18 }, .T. } , ;
{ { 6, 13, 8, 18 }, { 8, 14 }, { 9, 21 }, .T. } , ;
{ { 6, 21, 8, 26 }, { 9, 15 }, { 10, 22 }, .T. } , ;
{ { 6, 29, 8, 34 }, { 4, 8, 10, 16 }, { 1, 7, 11, 23 }, .T. } , ;
{ { 6, 37, 8, 42 }, { 5, 9, 11, 17 }, { 2, 8, 12, 24 }, .T. } , ;
{ { 6, 45, 8, 50 }, { 6, 10, 12, 18 }, { 3, 9, 13, 25 }, .T. } , ;
{ { 6, 53, 8, 58 }, { 11, 19 }, { 10, 26 }, .T. } , ;
{ { 6, 61, 8, 66 }, { 12, 20 }, { 11, 27 }, .T. } , ;
{ { 9, 13, 11, 18 }, { 15 }, { 16 }, .T. } , ;
{ { 9, 21, 11, 26 }, { 16 }, { 17 }, .T. } , ;
{ { 9, 29, 11, 34 }, { 9, 15, 17, 23 }, { 4, 14, 18, 28 }, .T. } , ;
{ { 9, 37, 11, 42 }, { 10, 16, 18, 24 }, { 5, 15, 19, 29 }, .F. } , ;
{ { 9, 45, 11, 50 }, { 11, 17, 19, 25 }, { 6, 16, 20, 30 }, .T. } , ;
{ { 9, 53, 11, 58 }, { 18 }, { 17 }, .T. } , ;
{ { 9, 61, 11, 66 }, { 19 }, { 18 }, .T. } , ;
{ { 12, 13, 14, 18 }, { 14, 22 }, { 7, 23 }, .T. } , ;
{ { 12, 21, 14, 26 }, { 15, 23 }, { 8, 24 }, .T. } , ;
{ { 12, 29, 14, 34 }, { 16, 22, 24, 28 }, { 9, 21, 25, 31 }, .T. } , ;
{ { 12, 37, 14, 42 }, { 17, 23, 25, 29 }, { 10, 22, 26, 32 }, .T. } , ;
{ { 12, 45, 14, 50 }, { 18, 24, 26, 30 }, { 11, 23, 27, 33 }, .T. } , ;
{ { 12, 53, 14, 58 }, { 19, 25 }, { 12, 24 }, .T. } , ;
{ { 12, 61, 14, 66 }, { 20, 26 }, { 13, 25 }, .T. } , ;
{ { 15, 29, 17, 34 }, { 23, 29 }, { 16, 30 }, .T. } , ;
{ { 15, 37, 17, 42 }, { 24 }, { 17 }, .T. } , ;
{ { 15, 45, 17, 50 }, { 25, 29 }, { 18, 28 }, .T. } , ;
{ { 18, 29, 20, 34 }, { 28, 32 }, { 23, 33 }, .T. } , ;
{ { 18, 37, 20, 42 }, { 29 }, { 24 }, .T. } , ;
{ { 18, 45, 20, 50 }, { 30, 32 }, { 25, 31 }, .T. } }
FUNCTION FT_PEGS()
LOCAL XX, MOVE, MPOS, POSSIBLE_, BUFFER, TOPROW, OLDSCORE, MOVE2
LOCAL SCANBLOCK, OLDCOLOR := SetColor( 'w/n' )
LOCAL oldscrn := SaveScreen( 0, 0, MaxRow(), MaxCol() )
/*
the following code block is used in conjunction with ASCAN()
to validate entry when there is more than one possible move
*/
scanblock := { | a | a[2] == move2 }
cls
setcolor('w/r')
SINGLEBOX(22, 31, 24, 48)
@ 23, 33 say "Your move:"
aeval(board_, { | a, x | HB_SYMBOL_UNUSED( a ), drawbox( x ) } )
do while lastkey() != K_ESC .and. moremoves()
move := 1
setcolor('w/n')
@ 23, 44 get move picture '##' range 1, 33
read
if move > 0
do case
case ! board_[move][4]
err_msg("No piece there!")
otherwise
possible_ := {}
for xx := 1 to len(board_[move][2])
if board_[board_[move][2,xx] ][4] .and. ;
! board_[board_[move][3,xx] ][4]
aadd(possible_, { board_[move][2,xx], board_[move][3,xx] })
endif
next
// only one available move -- do it
do case
case len(possible_) == 1
// clear out original position and the position you jumped over
board_[move][4] := board_[possible_[1, 1] ][4] := .F.
board_[possible_[1, 2] ][4] := .T.
drawbox(move, board_[move])
drawbox(possible_[1,1])
drawbox(possible_[1,2])
case len(possible_) == 0
err_msg('Illegal move!')
otherwise
move2 := possible_[1, 2]
toprow := 21 - len(possible_)
setcolor('+w/b')
buffer := savescreen(toprow, 55, 22, 74)
DOUBLEBOX(toprow, 55, 22, 74)
@ toprow, 58 say 'Possible Moves'
devpos(toprow, 65)
aeval(possible_, { | a | devpos(row()+1, 65), ;
devoutpict(a[2], '##') } )
oldscore := set(_SET_SCOREBOARD, .f.)
@23, 44 get move2 picture '##' ;
valid ascan(possible_, scanblock) > 0
read
restscreen(toprow, 55, 22, 74, buffer)
set(_SET_SCOREBOARD, oldscore)
mpos := ascan(possible_, { | a | move2 == a[2] })
// clear out original position and the position you jumped over
board_[move][4] := board_[possible_[mpos, 1] ][4] := .F.
board_[move2][4] := .T.
drawbox(move)
drawbox(possible_[mpos,1])
drawbox(move2)
endcase
endcase
scanblock := { | a | a[2] == move2 }
cls
SetColor( 'w/r' )
SINGLEBOX( 22, 31, 24, 48 )
@ 23, 33 SAY "Your move:"
AEval( board_, { | a, x | HB_SYMBOL_UNUSED( a ), drawbox( x ) } )
DO WHILE LastKey() != K_ESC .AND. moremoves()
move := 1
endif
enddo
setcolor(oldcolor)
restscreen(0, 0, maxrow(), maxcol(), oldscrn)
return NIL
SetColor( 'w/n' )
@ 23, 44 GET move PICTURE '##' RANGE 1, 33
READ
IF move > 0
DO CASE
CASE ! board_[move][4]
err_msg( "No piece there!" )
OTHERWISE
possible_ := {}
FOR xx := 1 TO Len( board_[move][2] )
IF board_[board_[move][2,xx] ][4] .AND. ;
! board_[board_[move][3,xx] ][4]
AAdd( possible_, { board_[move][2,xx], board_[move][3,xx] } )
ENDIF
NEXT
// only one available move -- do it
DO CASE
CASE Len( possible_ ) == 1
// clear out original position and the position you jumped over
board_[move][4] := board_[possible_[1, 1] ][4] := .F.
board_[possible_[1, 2] ][4] := .T.
drawbox( move, board_[move] )
drawbox( possible_[1,1] )
drawbox( possible_[1,2] )
CASE Len( possible_ ) == 0
err_msg( 'Illegal move!' )
OTHERWISE
move2 := possible_[1, 2]
toprow := 21 - Len( possible_ )
SetColor( '+w/b' )
buffer := SaveScreen( toprow, 55, 22, 74 )
DOUBLEBOX( toprow, 55, 22, 74 )
@ toprow, 58 SAY 'Possible Moves'
DevPos( toprow, 65 )
AEval( possible_, { | a | DevPos( Row() + 1, 65 ), ;
DevOutPict( a[2], '##' ) } )
oldscore := Set( _SET_SCOREBOARD, .F. )
@23, 44 GET move2 PICTURE '##' ;
VALID AScan( possible_, scanblock ) > 0
READ
RestScreen( toprow, 55, 22, 74, buffer )
SET( _SET_SCOREBOARD, oldscore )
mpos := AScan( possible_, { | a | move2 == a[2] } )
// clear out original position and the position you jumped over
board_[move][4] := board_[possible_[mpos, 1] ][4] := .F.
board_[move2][4] := .T.
drawbox( move )
drawbox( possible_[mpos,1] )
drawbox( move2 )
* end function FT_PEGS()
*--------------------------------------------------------------------*
ENDCASE
ENDCASE
move := 1
ENDIF
ENDDO
SetColor( oldcolor )
RestScreen( 0, 0, MaxRow(), MaxCol(), oldscrn )
static function DrawBox(nelement)
setcolor(iif(board_[nelement][4], '+w/rb', 'w/n'))
@ board_[nelement][1,1], board_[nelement][1,2], board_[nelement][1,3], ;
board_[nelement][1,4] box hb_UTF8ToStr( "┌─┐│┘─└│ " )
DevPos(board_[nelement][1,1] + 1, board_[nelement][1,2] + 2)
DevOut(ltrim(str(nelement)))
return NIL
RETURN NIL
* end static function DrawBox()
*--------------------------------------------------------------------*
// end function FT_PEGS()
//--------------------------------------------------------------------*
static function err_msg(msg)
local buffer := savescreen(23, 33, 23, 47)
setcursor(SC_NONE)
setcolor('+w/r')
@ 23, 33 say msg
inkey(2)
setcursor(SC_NORMAL)
restscreen(23, 33, 23, 47, buffer)
return nil
STATIC FUNCTION DrawBox( nelement )
* end static function Err_Msg()
*--------------------------------------------------------------------*
SetColor( iif( board_[ nelement ][ 4 ], '+w/rb', 'w/n' ) )
@ board_[ nelement ][ 1, 1 ], board_[ nelement ][1,2], board_[ nelement ][ 1, 3 ], ;
board_[ nelement ][ 1, 4 ] BOX hb_UTF8ToStr( "┌─┐│┘─└│ " )
DevPos( board_[ nelement ][ 1, 1 ] + 1, board_[ nelement ][ 1, 2 ] + 2 )
DevOut( hb_ntos( nelement ) )
static function moremoves()
local xx, yy, canmove := .f., piecesleft := 0, buffer
for xx := 1 to 33
for yy := 1 to len(board_[xx][2])
if board_[xx][4] .and. ; // if current location is filled
board_[board_[xx][2,yy] ][4] .and. ; // adjacent must be filled
! board_[board_[xx][3,yy] ][4] // target must be empty
canmove := .t.
exit
endif
next
// increment number of pieces left
if board_[xx][4]
piecesleft++
endif
next
if ! canmove
setcolor('+w/b')
buffer := savescreen(18, 55, 21, 74)
DOUBLEBOX(18, 55, 21, 74)
@ 19, 58 say "No more moves!"
@ 20, 58 say ltrim(str(piecesleft)) + " pieces left"
inkey(0)
restscreen(18, 55, 21, 74, buffer)
endif
return canmove
RETURN NIL
* end static function MoreMoves()
*--------------------------------------------------------------------*
// end static function DrawBox()
//--------------------------------------------------------------------*
* eof pegs.prg
STATIC FUNCTION err_msg( msg )
LOCAL buffer := SaveScreen( 23, 33, 23, 47 )
SetCursor( SC_NONE )
SetColor( '+w/r' )
@ 23, 33 SAY msg
Inkey( 2 )
SetCursor( SC_NORMAL )
RestScreen( 23, 33, 23, 47, buffer )
RETURN nil
// end static function Err_Msg()
//--------------------------------------------------------------------*
STATIC FUNCTION moremoves()
LOCAL xx, yy, canmove := .F. , piecesleft := 0, buffer
FOR xx := 1 TO 33
FOR yy := 1 TO Len( board_[ xx ][ 2 ] )
IF board_[ xx ][ 4 ] .AND. ; // if current location is filled
board_[ board_[ xx ][ 2, yy ] ][ 4 ] .AND. ; // adjacent must be filled
! board_[ board_[ xx ][ 3, yy ] ][ 4 ] // target must be empty
canmove := .T.
EXIT
ENDIF
NEXT
// increment number of pieces left
IF board_[ xx ][ 4 ]
piecesleft++
ENDIF
NEXT
IF ! canmove
SetColor( '+w/b' )
buffer := SaveScreen( 18, 55, 21, 74 )
DOUBLEBOX( 18, 55, 21, 74 )
@ 19, 58 SAY "No more moves!"
@ 20, 58 SAY hb_ntos( piecesleft ) + " pieces left"
Inkey( 0 )
RestScreen( 18, 55, 21, 74, buffer )
ENDIF
RETURN canmove
// end static function MoreMoves()
//--------------------------------------------------------------------*

89
harbour/contrib/hbnf/pending.prg
View File

@@ -22,59 +22,64 @@
*/
#ifdef FT_TEST
PROCEDURE Main()
@ 0,0 CLEAR
FT_PENDING("Message one",20,0,3,"W+/G") // Displays "Message one."
// sets row to 20, col to 0.
// wait to 3 and color to
// bright white over green.
FT_PENDING("Message two") // Displays "Message two", after 5 sec.
FT_PENDING("Message three") // Displays "Message three", after 5 sec.
RETURN
PROCEDURE Main()
@ 0, 0 CLEAR
FT_PENDING( "Message one", 20, 0, 3, "W+/G" ) // Displays "Message one."
// sets row to 20, col to 0.
// wait to 3 and color to
// bright white over green.
FT_PENDING( "Message two" ) // Displays "Message two", after 5 sec.
FT_PENDING( "Message three" ) // Displays "Message three", after 5 sec.
RETURN
#endif
FUNCTION FT_PENDING (cMsg, nRow, nCol, nWait, cColor)
THREAD STATIC nLast_Time := 0, nRow1 := 24, nCol1 := 0
THREAD STATIC nWait1 := 5, cColor1 := 'W+/R,X'
LOCAL nThis_Time, nTiny := 0.1, cSavColor
FUNCTION FT_PENDING( cMsg, nRow, nCol, nWait, cColor )
*
* cMsg Message to display
* nRow Row of displayed message
* nCol Col of displayed message
* nWait Wait in seconds between messages
* cColor Color of displayed message
*
THREAD STATIC nLast_Time := 0, nRow1 := 24, nCol1 := 0
THREAD STATIC nWait1 := 5, cColor1 := 'W+/R,X'
LOCAL nThis_Time, nTiny := 0.1, cSavColor
IF (cMsg == NIL ) //if no message, no work
RETURN NIL
ENDIF
//
// cMsg Message to display
// nRow Row of displayed message
// nCol Col of displayed message
// nWait Wait in seconds between messages
// cColor Color of displayed message
//
nRow1 := iif( nRow != NIL, nRow, nRow1 ) //reset display row
nCol1 := iif( nCol != NIL, nCol, nCol1 ) //reset display col
IF cMsg == NIL //if no message, no work
RETURN NIL
ENDIF
nWait1 := iif( nWait != NIL, nWait, nWait1) //reset display wait
cColor1 := iif( cColor != NIL, cColor, cColor1) //reset display color
nRow1 := iif( nRow != NIL, nRow, nRow1 ) //reset display row
nCol1 := iif( nCol != NIL, nCol, nCol1 ) //reset display col
nThis_Time := SECONDS() //time of current message
nWait1 := iif( nWait != NIL, nWait, nWait1 ) //reset display wait
cColor1 := iif( cColor != NIL, cColor, cColor1 ) //reset display color
IF nLast_Time == 0
nLast_Time := nThis_Time - nWait1 //for first time round.
ENDIF
nThis_Time := Seconds() //time of current message
IF (nThis_Time - nLast_Time) < nTiny //if messages are coming too fast,
nLast_Time := nThis_Time + nWait1 //set time counter and then
INKEY (nWait1) //wait a few seconds.
ELSE
nLast_Time := nThis_Time //set time counter for next message.
ENDIF
IF nLast_Time == 0
nLast_Time := nThis_Time - nWait1 //for first time round.
ENDIF
@nRow1,0 clear to nRow1,80 //clear the display line
IF ( nThis_Time - nLast_Time ) < nTiny //if messages are coming too fast,
nLast_Time := nThis_Time + nWait1 //set time counter and then
Inkey ( nWait1 ) //wait a few seconds.
ELSE
nLast_Time := nThis_Time //set time counter for next message.
ENDIF
cSavColor := SETCOLOR(cColor1) //save current and set display color
@ nRow1, 0 CLEAR TO nRow1, 80 //clear the display line
@nRow1,nCol1 SAY cMsg //display message
cSavColor := SetColor( cColor1 ) //save current and set display color
SETCOLOR( cSavColor ) //restore colors.
@ nRow1, nCol1 SAY cMsg //display message
RETURN NIL
SetColor( cSavColor ) //restore colors.
RETURN NIL

33
harbour/contrib/hbnf/pickday.prg
View File

@@ -30,21 +30,26 @@
#ifdef FT_TEST
PROCEDURE Main()
QOUT("You selected " + FT_PICKDAY())
QOut( "You selected " + FT_PICKDAY() )
RETURN
#endif
function FT_PICKDAY()
LOCAL DAYS := { "SUNDAY", "MONDAY", "TUESDAY", "WEDNESDAY", "THURSDAY", ;
"FRIDAY", "SATURDAY" }, SEL := 0
LOCAL OLDSCRN := SAVESCREEN(8, 35, 16, 45), oldcolor := setcolor('+w/r')
@ 8, 35, 16, 45 box B_SINGLE + " "
/* do not allow user to Esc out, which would cause array access error */
do while sel == 0
sel := achoice(9, 36, 15, 44, days)
enddo
/* restore previous screen contents and color */
restscreen(8, 35, 16, 45, oldscrn)
setcolor(oldcolor)
return days[sel]
FUNCTION FT_PICKDAY()
LOCAL DAYS := { "SUNDAY", "MONDAY", "TUESDAY", "WEDNESDAY", "THURSDAY", ;
"FRIDAY", "SATURDAY" }, SEL := 0
LOCAL OLDSCRN := SaveScreen( 8, 35, 16, 45 ), oldcolor := SetColor( '+w/r' )
@ 8, 35, 16, 45 BOX B_SINGLE + " "
/* do not allow user to Esc out, which would cause array access error */
DO WHILE sel == 0
sel := AChoice( 9, 36, 15, 44, days )
ENDDO
/* restore previous screen contents and color */
RestScreen( 8, 35, 16, 45, oldscrn )
SetColor( oldcolor )
RETURN days[sel]

1844
harbour/contrib/hbnf/popadder.prg
View File

File diff suppressed because it is too large Load Diff

56
harbour/contrib/hbnf/prtesc.prg
View File

@@ -25,51 +25,55 @@
*/
#ifdef FT_TEST
PROCEDURE Main( cParm1 )
*-------------------------------------------------------
* Sample routine to test function from command line
*-------------------------------------------------------
IF PCount() > 0
PROCEDURE Main( cParm1 )
//-------------------------------------------------------
// Sample routine to test function from command line
//-------------------------------------------------------
IF PCount() > 0
? FT_ESCCODE( cParm1 )
ELSE
ELSE
? "Usage: PRT_ESC 'escape code sequence' "
? " outputs converted code to standard output"
?
ENDIF
RETURN
ENDIF
RETURN
#endif
FUNCTION FT_ESCCODE( cInput )
LOCAL cOutput := "" ,;
cCurrent ,;
nPointer := 1 ,;
nLen := Len( cInput )
LOCAL cOutput := ""
LOCAL cCurrent
LOCAL nPointer := 1
LOCAL nLen := Len( cInput )
DO WHILE nPointer <= nLen
DO WHILE nPointer <= nLen
cCurrent := Substr( cInput, nPointer, 1 )
cCurrent := SubStr( cInput, nPointer, 1 )
DO CASE
DO CASE
CASE cCurrent == "\" .AND. ;
IsDigit(Substr(cInput, nPointer+1, 1) ) .AND. ;
IsDigit(Substr(cInput, nPointer+2, 1) ) .AND. ;
IsDigit(Substr(cInput, nPointer+3, 1) )
cOutput += Chr(Val(Substr(cInput, nPointer+1,3)))
CASE cCurrent == "\" .AND. ;
IsDigit( SubStr( cInput, nPointer + 1, 1 ) ) .AND. ;
IsDigit( SubStr( cInput, nPointer + 2, 1 ) ) .AND. ;
IsDigit( SubStr( cInput, nPointer + 3, 1 ) )
cOutput += Chr( Val( SubStr(cInput, nPointer + 1, 3 ) ) )
nPointer += 4
CASE cCurrent == "\" .AND. ;
Substr(cInput, nPointer+1, 1) == "\"
CASE cCurrent == "\" .AND. ;
SubStr( cInput, nPointer + 1, 1 ) == "\"
cOutput += "\"
nPointer += 2
OTHERWISE
OTHERWISE
cOutput += cCurrent
nPointer++
ENDCASE
ENDDO
ENDCASE
ENDDO
RETURN cOutput
RETURN cOutput

56
harbour/contrib/hbnf/pvid.prg
View File

@@ -33,39 +33,39 @@
#define PV_MAXCOL 9
#define PV_SCORE 10
THREAD static aVideo := {}
THREAD STATIC t_aVideo := {}
function FT_PushVid()
FUNCTION FT_PushVid()
AAdd( aVideo, { row(), ;
col(), ;
setcolor(), ;
savescreen( 0, 0, maxrow(), maxcol() ), ;
set( _SET_CURSOR ), ;
setblink(), ;
nosnow(), ;
maxrow() + 1, ;
maxcol() + 1, ;
set( _SET_SCOREBOARD ) } )
AAdd( t_aVideo, { Row(), ;
Col(), ;
SetColor(), ;
SaveScreen( 0, 0, MaxRow(), MaxCol() ), ;
Set( _SET_CURSOR ), ;
SetBlink(), ;
NoSnow(), ;
MaxRow() + 1, ;
MaxCol() + 1, ;
Set( _SET_SCOREBOARD ) } )
return len( aVideo )
RETURN Len( t_aVideo )
function FT_PopVid()
FUNCTION FT_PopVid()
local nNewSize := len( aVideo ) - 1
local aBottom := ATail( aVideo )
LOCAL nNewSize := Len( t_aVideo ) - 1
LOCAL aBottom := ATail( t_aVideo )
if nNewSize >= 0
setmode( aBottom[ PV_MAXROW ], aBottom[ PV_MAXCOL ] )
set( _SET_CURSOR, aBottom[ PV_CURSOR ] )
nosnow( aBottom[ PV_NOSNOW ] )
setblink( aBottom[ PV_BLINK ] )
restscreen( 0, 0, maxrow(), maxcol(), aBottom[ PV_IMAGE ] )
setcolor( aBottom[ PV_COLOR ] )
setpos( aBottom[ PV_ROW ], aBottom[ PV_COL ] )
set( _SET_SCOREBOARD, aBottom[ PV_SCORE ] )
IF nNewSize >= 0
SetMode( aBottom[ PV_MAXROW ], aBottom[ PV_MAXCOL ] )
SET( _SET_CURSOR, aBottom[ PV_CURSOR ] )
NoSnow( aBottom[ PV_NOSNOW ] )
SetBlink( aBottom[ PV_BLINK ] )
RestScreen( 0, 0, MaxRow(), MaxCol(), aBottom[ PV_IMAGE ] )
SetColor( aBottom[ PV_COLOR ] )
SetPos( aBottom[ PV_ROW ], aBottom[ PV_COL ] )
Set( _SET_SCOREBOARD, aBottom[ PV_SCORE ] )
aSize( aVideo, nNewSize )
endif
ASize( t_aVideo, nNewSize )
ENDIF
return len( aVideo )
RETURN Len( t_aVideo )

47
harbour/contrib/hbnf/qtr.prg
View File

@@ -27,32 +27,33 @@
*
*/
FUNCTION FT_QTR(dGivenDate,nQtrNum)
LOCAL lIsQtr, nTemp, aRetVal
FUNCTION FT_QTR( dGivenDate, nQtrNum )
IF !(VALTYPE(dGivenDate) $ 'ND')
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'N'
nQtrNum := dGivenDate
dGivenDate := DATE()
ENDIF
LOCAL lIsQtr, nTemp, aRetVal
aRetval := FT_YEAR(dGivenDate)
IF !( ValType( dGivenDate ) $ 'ND' )
dGivenDate := Date()
ELSEIF ValType( dGivenDate ) == 'N'
nQtrNum := dGivenDate
dGivenDate := Date()
ENDIF
lIsQtr := ( VALTYPE(nQtrNum) == 'N' )
IF lIsQtr
IF nQtrNum < 1 .OR. nQtrNum > 4
nQtrNum := 4
ENDIF
dGivenDate := FT_MADD(aRetVal[2], 3*(nQtrNum - 1) )
ENDIF
aRetval := FT_YEAR( dGivenDate )
nTemp := MONTH( dGivenDate ) - MONTH( aRetVal[2] )
nTemp += iif( nTemp >= 0, 1, 13 )
nTemp := INT( (nTemp - 1) / 3 )
lIsQtr := ( ValType( nQtrNum ) == 'N' )
IF lIsQtr
IF nQtrNum < 1 .OR. nQtrNum > 4
nQtrNum := 4
ENDIF
dGivenDate := FT_MADD( aRetVal[ 2 ], 3 * ( nQtrNum - 1 ) )
ENDIF
aRetVal[1] += PADL(LTRIM(STR( nTemp + 1, 2)), 2, '0')
aRetVal[2] := FT_MADD( aRetVal[2], nTemp * 3 )
aRetVal[3] := FT_MADD( aRetVal[2], 3 ) - 1
nTemp := Month( dGivenDate ) - Month( aRetVal[ 2 ] )
nTemp += iif( nTemp >= 0, 1, 13 )
nTemp := Int( ( nTemp - 1 ) / 3 )
RETURN aRetVal
aRetVal[ 1 ] += PadL( LTrim( Str( nTemp + 1, 2 ) ), 2, '0' )
aRetVal[ 2 ] := FT_MADD( aRetVal[ 2 ], nTemp * 3 )
aRetVal[ 3 ] := FT_MADD( aRetVal[ 2 ], 3 ) - 1
RETURN aRetVal

33
harbour/contrib/hbnf/rand1.prg
View File

@@ -26,25 +26,28 @@
#ifdef FT_TEST
// Write 100 random numbers from 1 to 100 to stdout.
// Run it multiple times and redirect output to a file
// to check it
// Write 100 random numbers from 1 to 100 to stdout.
// Run it multiple times and redirect output to a file
// to check it
PROCEDURE Main()
local x
PROCEDURE Main()
for x := 1 to 100
outstd( int( ft_rand1(100) ) )
outstd( hb_eol() )
next
return
LOCAL x
FOR x := 1 TO 100
OutStd( Int( ft_rand1(100 ) ) )
OutStd( hb_eol() )
NEXT
RETURN
#endif
function ft_rand1(nMax)
THREAD static nSeed
local m := 100000000, b := 31415621
FUNCTION ft_rand1( nMax )
nSeed := iif( nSeed == NIL, seconds(), nSeed ) // init_seed()
THREAD STATIC t_nSeed
LOCAL m := 100000000, b := 31415621
return nMax * ( ( nSeed := mod( nSeed*b+1, m ) ) / m )
t_nSeed := iif( t_nSeed == NIL, Seconds(), t_nSeed ) // init_seed()
RETURN nMax * ( ( t_nSeed := Mod( t_nSeed * b + 1, m ) ) / m )

22
harbour/contrib/hbnf/restsets.prg
View File

@@ -26,18 +26,18 @@
#include "set.ch"
#Define FT_EXTRA_SETS 2
#DEFINE FT_SET_CENTURY _SET_COUNT + 1
#DEFINE FT_SET_BLINK _SET_COUNT + 2
#define FT_EXTRA_SETS 2
#define FT_SET_CENTURY _SET_COUNT + 1
#define FT_SET_BLINK _SET_COUNT + 2
FUNCTION FT_RESTSETS(aOldSets)
FUNCTION FT_RESTSETS( aOldSets )
AEVAL(aOldSets, ;
{ | xElement, nElementNo | ;
SET(nElementNo, xElement) }, ;
1, _SET_COUNT )
AEval( aOldSets, ;
{| xElement, nElementNo | ;
Set( nElementNo, xElement ) }, ;
1, _SET_COUNT )
FT_SETCENTURY(aOldSets[FT_SET_CENTURY])
SETBLINK(aOldSets[FT_SET_BLINK])
FT_SETCENTURY( aOldSets[ FT_SET_CENTURY ] )
SetBlink( aOldSets[ FT_SET_BLINK ] )
RETURN (NIL) // FT_RestSets
RETURN NIL // FT_RestSets

265
harbour/contrib/hbnf/savearr.prg
View File

@@ -35,140 +35,159 @@ MEMVAR lRet
#ifdef FT_TEST // test program to demonstrate functions
LOCAL aArray := { {'Invoice 1', CTOD('04/15/91'), 1234.32, .T.},;
{'Invoice 2', DATE(), 234.98, .F.},;
{'Invoice 3', DATE() + 1, 0, .T.} }, aSave
LOCAL nErrorCode := 0
FT_SAVEARR(aArray,'invoice.dat',@nErrorCode)
IF nErrorCode == 0
CLS
DispArray(aArray)
aSave := FT_RESTARR('invoice.dat',@nErrorCode)
IF nErrorCode == 0
DispArray(aSave)
ELSE
? 'Error restoring array'
ENDIF
ELSE
? 'Error writing array'
ENDIF
RETURN
LOCAL aArray := {;
{ 'Invoice 1', SToD( "19910415" ), 1234.32, .T. }, ;
{ 'Invoice 2', Date(), 234.98, .F. }, ;
{ 'Invoice 3', Date() + 1, 0, .T. } }, aSave
LOCAL nErrorCode := 0
FT_SAVEARR( aArray, 'invoice.dat', @nErrorCode )
IF nErrorCode == 0
CLS
DispArray( aArray )
aSave := FT_RESTARR( 'invoice.dat', @nErrorCode )
IF nErrorCode == 0
DispArray( aSave )
ELSE
? 'Error restoring array'
ENDIF
ELSE
? 'Error writing array'
ENDIF
RETURN
FUNCTION DispArray( aTest )
FUNCTION DispArray(aTest)
LOCAL nk
FOR nk := 1 TO LEN(aTest)
? aTest[nk, 1]
?? ' '
?? DTOC(aTest[nk, 2])
?? ' '
?? STR(aTest[nk, 3])
?? ' '
?? iif(aTest[nk, 4], 'true', 'false')
FOR nk := 1 TO Len( aTest )
? aTest[ nk, 1 ]
?? ' '
?? DToC( aTest[ nk, 2 ] )
?? ' '
?? Str( aTest[ nk, 3 ] )
?? ' '
?? iif( aTest[ nk, 4 ], 'true', 'false' )
NEXT
RETURN Nil
RETURN Nil
#endif
FUNCTION FT_SAVEARR(aArray, cFileName, nErrorCode)
LOCAL nHandle, lRet
nHandle := FCREATE(cFileName)
nErrorCode := FError()
IF nErrorCode == 0
lRet := _ftsavesub(aArray, nHandle, @nErrorCode)
FCLOSE(nHandle)
IF (lRet) .AND. (FERROR() # 0)
nErrorCode := FERROR()
lRet := .F.
ENDIF
ELSE
lRet := .F.
ENDIF
RETURN lRet
FUNCTION FT_SAVEARR( aArray, cFileName, nErrorCode )
STATIC FUNCTION _ftsavesub(xMemVar, nHandle, nErrorCode)
LOCAL cValType, nLen, cString
PRIVATE lRet // accessed in code block
lRet := .T.
cValType := ValType(xMemVar)
FWrite(nHandle, cValType, 1)
IF FError() == 0
DO CASE
CASE cValType == "A"
nLen := Len(xMemVar)
FWrite(nHandle, L2Bin(nLen), 4)
IF FError() == 0
AEVAL(xMemVar, {|xMemVar1| lRet := _ftsavesub(xMemVar1, nHandle) } )
ELSE
LOCAL nHandle, lRet
nHandle := FCreate( cFileName )
nErrorCode := FError()
IF nErrorCode == 0
lRet := _ftsavesub( aArray, nHandle, @nErrorCode )
FClose( nHandle )
IF ( lRet ) .AND. ( FError() != 0 )
nErrorCode := FError()
lRet := .F.
ENDIF
CASE cValType == "B"
lRet := .F.
CASE cValType == "C"
nLen := Len(xMemVar)
FWrite(nHandle, L2Bin(nLen), 4)
FWrite(nHandle, xMemVar)
CASE cValType == "D"
nLen := 8
FWrite(nHandle, L2Bin(nLen), 4)
FWrite(nHandle, DTOC(xMemVar))
CASE cValType == "L"
nLen := 1
FWrite(nHandle, L2Bin(nLen), 4)
FWrite(nHandle, iif(xMemVar, "T", "F") )
CASE cValType == "N"
cString := STR(xMemVar)
nLen := LEN(cString)
FWrite(nHandle, L2Bin(nLen), 4)
FWrite(nHandle, cString)
ENDCASE
ELSE
lRet := .F.
ENDIF
nErrorCode := FError()
RETURN lRet
ENDIF
ELSE
lRet := .F.
ENDIF
FUNCTION FT_RESTARR(cFileName, nErrorCode)
LOCAL nHandle, aArray
nHandle := FOPEN(cFileName)
nErrorCode := FError()
IF nErrorCode == 0
aArray := _ftrestsub(nHandle, @nErrorCode)
FCLOSE(nHandle)
ELSE
aArray := {}
ENDIF
RETURN aArray
RETURN lRet
STATIC FUNCTION _ftrestsub(nHandle, nErrorCode)
LOCAL cValType, nLen, cLenStr, xMemVar, cMemVar, nk
cValType := ' '
FREAD(nHandle, @cValType, 1)
cLenStr := SPACE(4)
FREAD(nHandle, @cLenStr, 4)
nLen := Bin2L(cLenStr)
nErrorCode := FError()
IF nErrorCode == 0
DO CASE
STATIC FUNCTION _ftsavesub( xMemVar, nHandle, nErrorCode )
LOCAL cValType, nLen, cString
PRIVATE lRet // accessed in code block
lRet := .T.
cValType := ValType( xMemVar )
FWrite( nHandle, cValType, 1 )
IF FError() == 0
DO CASE
CASE cValType == "A"
xMemVar := {}
FOR nk := 1 TO nLen
AADD(xMemVar, _ftrestsub(nHandle)) // Recursive call
NEXT
nLen := Len( xMemVar )
FWrite( nHandle, L2Bin( nLen ), 4 )
IF FError() == 0
AEval( xMemVar, {|xMemVar1| lRet := _ftsavesub( xMemVar1, nHandle ) } )
ELSE
lRet := .F.
ENDIF
CASE cValType == "B"
lRet := .F.
CASE cValType == "C"
xMemVar := SPACE(nLen)
FREAD(nHandle, @xMemVar, nLen)
nLen := Len( xMemVar )
FWrite( nHandle, L2Bin( nLen ), 4 )
FWrite( nHandle, xMemVar )
CASE cValType == "D"
cMemVar := SPACE(8)
FREAD(nHandle, @cMemVar,8)
xMemVar := CTOD(cMemVar)
nLen := 8
FWrite( nHandle, L2Bin( nLen ), 4 )
FWrite( nHandle, DToC( xMemVar ) )
CASE cValType == "L"
cMemVar := ' '
FREAD(nHandle, @cMemVar, 1)
xMemVar := (cMemVar == "T")
nLen := 1
FWrite( nHandle, L2Bin( nLen ), 4 )
FWrite( nHandle, iif( xMemVar, "T", "F" ) )
CASE cValType == "N"
cMemVar := SPACE(nLen)
FREAD(nHandle, @cMemVar, nLen)
xMemVar := VAL(cMemVar)
ENDCASE
nErrorCode := FERROR()
ENDIF
RETURN xMemVar
cString := Str( xMemVar )
nLen := Len( cString )
FWrite( nHandle, L2Bin( nLen ), 4 )
FWrite( nHandle, cString )
ENDCASE
ELSE
lRet := .F.
ENDIF
nErrorCode := FError()
RETURN lRet
FUNCTION FT_RESTARR( cFileName, nErrorCode )
LOCAL nHandle, aArray
nHandle := FOpen( cFileName )
nErrorCode := FError()
IF nErrorCode == 0
aArray := _ftrestsub( nHandle, @nErrorCode )
FClose( nHandle )
ELSE
aArray := {}
ENDIF
RETURN aArray
STATIC FUNCTION _ftrestsub( nHandle, nErrorCode )
LOCAL cValType, nLen, cLenStr, xMemVar, cMemVar, nk
cValType := ' '
FRead( nHandle, @cValType, 1 )
cLenStr := Space( 4 )
FRead( nHandle, @cLenStr, 4 )
nLen := Bin2L( cLenStr )
nErrorCode := FError()
IF nErrorCode == 0
DO CASE
CASE cValType == "A"
xMemVar := {}
FOR nk := 1 TO nLen
AAdd( xMemVar, _ftrestsub( nHandle ) ) // Recursive call
NEXT
CASE cValType == "C"
xMemVar := Space( nLen )
FRead( nHandle, @xMemVar, nLen )
CASE cValType == "D"
cMemVar := Space( 8 )
FRead( nHandle, @cMemVar, 8 )
xMemVar := CToD( cMemVar )
CASE cValType == "L"
cMemVar := ' '
FRead( nHandle, @cMemVar, 1 )
xMemVar := ( cMemVar == "T" )
CASE cValType == "N"
cMemVar := Space( nLen )
FRead( nHandle, @cMemVar, nLen )
xMemVar := Val( cMemVar )
ENDCASE
nErrorCode := FError()
ENDIF
RETURN xMemVar

25
harbour/contrib/hbnf/savesets.prg
View File

@@ -34,21 +34,26 @@
#define FT_SET_BLINK _SET_COUNT + 2
#ifdef FT_TEST
PROCEDURE Main()
LOCAL ASETS := FT_SAVESETS()
INKEY(0)
RETURN
PROCEDURE Main()
LOCAL ASETS := FT_SAVESETS()
Inkey( 0 )
RETURN
#endif
FUNCTION FT_SAVESETS()
LOCAL aOldSets := ARRAY(_SET_COUNT + FT_EXTRA_SETS)
LOCAL aOldSets := Array( _SET_COUNT + FT_EXTRA_SETS )
AEVAL(aOldSets, ;
{ | xElement, nElementNo | HB_SYMBOL_UNUSED( xElement ), ;
aOldSets[nElementNo] := SET(nElementNo) } )
AEval( aOldSets, ;
{| xElement, nElementNo | HB_SYMBOL_UNUSED( xElement ), ;
aOldSets[ nElementNo ] := Set( nElementNo ) } )
aOldSets[FT_SET_CENTURY] := FT_SETCENTURY()
aOldSets[FT_SET_BLINK] := SETBLINK()
aOldSets[ FT_SET_CENTURY ] := FT_SETCENTURY()
aOldSets[ FT_SET_BLINK ] := SetBlink()
RETURN aOldSets // FT_SaveSets

39
harbour/contrib/hbnf/scancode.prg
View File

@@ -33,27 +33,32 @@
#ifdef FT_TEST
#define SCANCODE_ESCAPE (chr(27) + chr(1))
#define SCANCODE_ESCAPE ( chr( 27 ) + chr( 1 ) )
PROCEDURE Main()
LOCAL getlist, cKey
CLEAR
QOut("Press any key, ESCape to exit:")
PROCEDURE Main()
while .t.
cKey := FT_SCANCODE()
QOUT( "chr(" + str(asc(substr(cKey,1,1)),3) + ")+chr(" + str(asc(substr(cKey,2,1)),3) + ")" )
if cKey == SCANCODE_ESCAPE
exit
endif
enddo
RETURN
LOCAL getlist, cKey
CLEAR
QOut( "Press any key, ESCape to exit:" )
DO WHILE .T.
cKey := FT_SCANCODE()
QOut( "chr(" + Str( Asc( SubStr( cKey, 1, 1 ) ), 3 ) + ")+chr(" + Str( Asc( SubStr( cKey, 2, 1 ) ), 3 ) + ")" )
IF cKey == SCANCODE_ESCAPE
EXIT
ENDIF
ENDDO
RETURN
#endif
FUNCTION FT_SCANCODE()
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] := MAKEHI( 0 )
FT_INT86( KEYB, aRegs )
RETURN chr(LOWBYTE( aRegs[AX] )) + chr(HIGHBYTE( aRegs[AX] ))
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] := MAKEHI( 0 )
FT_INT86( KEYB, aRegs )
RETURN Chr( LOWBYTE( aRegs[ AX ] ) ) + Chr( HIGHBYTE( aRegs[ AX ] ) )

38
harbour/contrib/hbnf/scregion.prg
View File

@@ -24,22 +24,22 @@
*
*/
THREAD STATIC aRgnStack := {}
THREAD STATIC t_aRgnStack := {}
FUNCTION FT_SAVRGN(nTop, nLeft, nBottom, nRight)
FUNCTION FT_SAVRGN( nTop, nLeft, nBottom, nRight )
RETURN CHR(nTop) + CHR(nLeft) + CHR(nBottom) + CHR(nRight) + ;
SAVESCREEN(nTop, nLeft, nBottom, nRight)
RETURN Chr( nTop ) + Chr( nLeft ) + Chr( nBottom ) + Chr( nRight ) + ;
SaveScreen( nTop, nLeft, nBottom, nRight )
FUNCTION FT_RSTRGN(cScreen, nTop, nLeft)
FUNCTION FT_RSTRGN( cScreen, nTop, nLeft )
IF PCOUNT() == 3
RESTSCREEN(nTop, nLeft, (nTop - ASC(cScreen)) + ASC(SUBSTR(cScreen, 3)), ;
(nLeft - ASC(SUBSTR(cScreen, 2))) + ASC(SUBSTR(cScreen, 4)), ;
SUBSTR(cScreen, 5))
IF PCount() == 3
RestScreen( nTop, nLeft, ( nTop - Asc(cScreen ) ) + Asc( SubStr(cScreen, 3 ) ), ;
( nLeft - Asc( SubStr(cScreen, 2 ) ) ) + Asc( SubStr( cScreen, 4 ) ), ;
SubStr( cScreen, 5 ) )
ELSE
RESTSCREEN(ASC(cScreen), ASC(SUBSTR(cScreen, 2)), ASC(SUBSTR(cScreen, 3)), ;
ASC(SUBSTR(cScreen, 4)), SUBSTR(cScreen, 5))
RestScreen( Asc( cScreen ), Asc( SubStr(cScreen, 2 ) ), Asc( SubStr(cScreen, 3 ) ), ;
Asc( SubStr( cScreen, 4 ) ), SubStr( cScreen, 5 ) )
ENDIF
RETURN NIL
@@ -48,25 +48,25 @@ FUNCTION FT_RSTRGN(cScreen, nTop, nLeft)
extra character and _SET_EXACT was set to .F.
Harbour version accepts "pop all" only. [vszakats] */
FUNCTION FT_RGNSTACK(cAction, nTop, nLeft, nBottom, nRight)
FUNCTION FT_RGNSTACK( cAction, nTop, nLeft, nBottom, nRight )
THREAD STATIC nStackPtr := 0
THREAD STATIC t_nStackPtr := 0
LOCAL nPopTop
IF cAction == "push"
ASIZE(aRgnStack, ++nStackPtr)[nStackPtr] := ;
FT_SAVRGN(nTop, nLeft, nBottom, nRight)
ASize( t_aRgnStack, ++t_nStackPtr )[ t_nStackPtr ] := ;
FT_SAVRGN( nTop, nLeft, nBottom, nRight )
ELSEIF cAction == "pop" .OR. cAction == "pop all"
nPopTop := iif("all" $ cAction, 0, nStackPtr-1)
nPopTop := iif( "all" $ cAction, 0, t_nStackPtr - 1 )
DO WHILE nStackPtr > nPopTop
FT_RSTRGN(aRgnStack[nStackPtr--])
DO WHILE t_nStackPtr > nPopTop
FT_RSTRGN( t_aRgnStack[ t_nStackPtr-- ] )
ENDDO
ASIZE(aRgnStack, nStackPtr)
ASize( t_aRgnStack, t_nStackPtr )
ENDIF

29
harbour/contrib/hbnf/setdate.prg
View File

@@ -34,23 +34,26 @@
#define SETDATE 43
#ifdef FT_TEST
PROCEDURE Main( cDate )
cDate := iif( cDate == nil, dtoc( date() ), cDate )
QOut( "Setting date to: " + cDate + "... " )
FT_SETDATE( ctod( cDate ) )
QOut( "Today is now: " + dtoc( date() ) )
PROCEDURE Main( cDate )
cDate := iif( cDate == nil, DToC( Date() ), cDate )
QOut( "Setting date to: " + cDate + "... " )
FT_SETDATE( CToD( cDate ) )
QOut( "Today is now: " + DToC( Date() ) )
RETURN
RETURN
#endif
function FT_SETDATE( dDate )
local aRegs[ INT86_MAX_REGS ]
FUNCTION FT_SETDATE( dDate )
dDate := iif( valtype(dDate) != "D", date(), dDate )
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] := SETDATE * ( 2 ^ 8 )
aregs[ CX ] := year( dDate )
aregs[ DX ] := ( month( dDate ) * ( 2 ^ 8 ) ) + day( dDate )
dDate := iif( ValType( dDate ) != "D", Date(), dDate )
return( FT_INT86( DOS, aRegs ) )
aRegs[ AX ] := SETDATE * ( 2 ^ 8 )
aregs[ CX ] := Year( dDate )
aregs[ DX ] := ( Month( dDate ) * ( 2 ^ 8 ) ) + Day( dDate )
RETURN FT_INT86( DOS, aRegs )

33
harbour/contrib/hbnf/settime.prg
View File

@@ -38,23 +38,28 @@
#define MINS( ts ) ( val( substr( ts, 4, 2 ) ) )
#ifdef FT_TEST
PROCEDURE Main( cTime )
cTime := iif( cTime == nil, time(), cTime )
QOut( "Setting time to: " + cTime + "... " )
FT_SETTIME( cTime )
QOut( "Time is now: " + time() )
RETURN
PROCEDURE Main( cTime )
cTime := iif( cTime == nil, Time(), cTime )
QOut( "Setting time to: " + cTime + "... " )
FT_SETTIME( cTime )
QOut( "Time is now: " + Time() )
RETURN
#endif
function FT_SETTIME( cTime )
local aRegs[ INT86_MAX_REGS ]
FUNCTION FT_SETTIME( cTime )
cTime := iif( cTime == nil, time(), cTime )
LOCAL aRegs[ INT86_MAX_REGS ]
// -------- High Byte ------ ----- Low Byte -------
cTime := iif( cTime == nil, Time(), cTime )
aRegs[ AX ] := SETTIME * ( 2 ^ 8 )
aRegs[ CX ] := HRS( cTime ) * ( 2 ^ 8 ) + MINS( cTime )
aRegs[ DX ] := SECS( cTime ) * ( 2 ^ 8 )
// -------- High Byte ------ ----- Low Byte -------
return( FT_INT86( DOS, aRegs ) )
aRegs[ AX ] := SETTIME * ( 2 ^ 8 )
aRegs[ CX ] := HRS( cTime ) * ( 2 ^ 8 ) + MINS( cTime )
aRegs[ DX ] := Secs( cTime ) * ( 2 ^ 8 )
RETURN FT_INT86( DOS, aRegs )

37
harbour/contrib/hbnf/sinkey.prg
View File

@@ -24,36 +24,37 @@
*
*/
FUNCTION FT_SINKEY(waittime)
LOCAL key, cblock
FUNCTION FT_SINKEY( waittime )
DO CASE
LOCAL key, cblock
/* if no WAITTIME passed, go straight through */
CASE pcount() == 0
key := inkey()
DO CASE
/* if no WAITTIME passed, go straight through */
CASE PCount() == 0
key := Inkey()
/* dig this... if you pass inkey(NIL), it is identical to INKEY(0)!
therefore, I allow you to pass FT_SINKEY(NIL) -- hence this mild bit
of convolution */
CASE waittime == NIL .AND. Pcount() == 1
key := inkey(0)
CASE waittime == NIL .AND. PCount() == 1
key := Inkey( 0 )
OTHERWISE
key := inkey(waittime)
OTHERWISE
key := Inkey( waittime )
ENDCASE
ENDCASE
cblock := Setkey(key)
cblock := SetKey( key )
IF cblock != NIL
IF cblock != NIL
// run the code block associated with this key and pass it the
// name of the previous procedure and the previous line number
// run the code block associated with this key and pass it the
// name of the previous procedure and the previous line number
Eval(cblock, Procname(1), Procline(1), NIL)
Eval( cblock, ProcName( 1 ), ProcLine( 1 ), NIL )
ENDIF
ENDIF
RETURN key
RETURN KEY

48
harbour/contrib/hbnf/sleep.prg
View File

@@ -23,42 +23,42 @@
#ifdef FT_TEST
* Test routine
* Invoke by running SLEEP 1.0 to sleep 1.0 seconds
*
// Test routine
// Invoke by running SLEEP 1.0 to sleep 1.0 seconds
//
PROCEDURE Main(nSleep)
PROCEDURE Main( nSleep )
? "Time is now: " + time()
FT_SLEEP(VAL(nSleep))
? "Time is now: " + time()
? "Time is now: " + Time()
FT_SLEEP( Val( nSleep ) )
? "Time is now: " + Time()
RETURN
RETURN
#endif
FUNCTION FT_SLEEP( nSeconds, nInitial )
IF nInitial == NIL .OR. VALTYPE( nInitial ) != "N"
nInitial := SECONDS()
ENDIF
IF nInitial == NIL .OR. ValType( nInitial ) != "N"
nInitial := Seconds()
ENDIF
// correct for running at midnight
// correct for running at midnight
IF nInitial + nSeconds > 86399
nInitial -= 86399
* Wait until midnight
DO WHILE SECONDS() > 100 // no problem with a _very_ slow machine
ENDDO
ENDIF
IF nInitial + nSeconds > 86399
nInitial -= 86399
// Wait until midnight
DO WHILE Seconds() > 100 // no problem with a _very_ slow machine
ENDDO
ENDIF
// calculate final time
// calculate final time
nSeconds += ninitial
nSeconds += ninitial
// Loop until we are done
// Loop until we are done
DO WHILE ( SECONDS() < nSeconds )
ENDDO
DO WHILE Seconds() < nSeconds
ENDDO
RETURN NIL
RETURN NIL

65
harbour/contrib/hbnf/sqzn.prg
View File

@@ -21,41 +21,44 @@
*
*/
function ft_sqzn(nValue,nSize,nDecimals)
local tmpstr,cCompressed,k
FUNCTION ft_sqzn( nValue, nSize, nDecimals )
nSize := iif(nSize ==NIL,10,nSize )
nDecimals := iif(nDecimals==NIL, 0,nDecimals )
nValue := nValue * (10**nDecimals)
nSize := iif(nSize/2!=int(nSize/2),nSize+1,nSize)
tmpstr := str( abs(nValue),nSize )
tmpstr := strtran(tmpstr," ","0")
cCompressed := chr( val(substr(tmpstr,1,2))+iif(nValue<0,128,0) )
LOCAL tmpstr, cCompressed, k
for k := 3 to len(tmpstr) step 2
cCompressed += chr(val(substr(tmpstr,k,2)))
next
return cCompressed
nSize := iif( nSize == NIL, 10, nSize )
nDecimals := iif( nDecimals == NIL, 0, nDecimals )
nValue := nValue * ( 10 ** nDecimals )
nSize := iif( nSize / 2 != Int( nSize / 2 ), nSize + 1, nSize )
tmpstr := Str( Abs( nValue ), nSize )
tmpstr := StrTran( tmpstr, " ", "0" )
cCompressed := Chr( Val( SubStr( tmpstr, 1, 2 ) ) + iif( nValue < 0, 128, 0 ) )
function ft_unsqzn(cCompressed,nSize,nDecimals)
local tmp:="",k,cValue,multi:=1
FOR k := 3 TO Len( tmpstr ) STEP 2
cCompressed += Chr( Val( SubStr(tmpstr, k, 2 ) ) )
NEXT
nSize := iif(nSize ==NIL,10,nSize )
nDecimals := iif(nDecimals==NIL, 0,nDecimals)
cCompressed := iif(multi ==-1,substr(cCompressed,2),cCompressed)
nSize := iif(nSize/2!=int(nSize/2),nSize+1,nSize)
if asc(cCompressed) > 127
tmp := str(asc(cCompressed)-128,2)
multi := -1
else
tmp := str(asc(cCompressed),2)
endif
RETURN cCompressed
for k := 2 to len(cCompressed)
tmp += str(asc(substr(cCompressed,k,1)),2)
next
FUNCTION ft_unsqzn( cCompressed, nSize, nDecimals )
tmp := strtran(tmp," ","0")
cValue := substr(tmp,1,nSize-nDecimals)+"."+substr(tmp,nSize-nDecimals+1)
LOCAL tmp := "", k, cValue, multi := 1
return val(cValue) * multi
nSize := iif( nSize == NIL, 10, nSize )
nDecimals := iif( nDecimals == NIL, 0, nDecimals )
cCompressed := iif( multi == - 1, SubStr( cCompressed, 2 ), cCompressed )
nSize := iif( nSize / 2 != Int( nSize / 2 ), nSize + 1, nSize )
IF Asc( cCompressed ) > 127
tmp := Str( Asc( cCompressed ) - 128, 2 )
multi := - 1
ELSE
tmp := Str( Asc( cCompressed ), 2 )
ENDIF
FOR k := 2 TO Len( cCompressed )
tmp += Str( Asc( SubStr( cCompressed, k, 1 ) ), 2 )
NEXT
tmp := StrTran( tmp, " ", "0" )
cValue := SubStr( tmp, 1, nSize - nDecimals ) + "." + SubStr( tmp, nSize - nDecimals + 1 )
RETURN Val( cValue ) * multi

19
harbour/contrib/hbnf/sysmem.prg
View File

@@ -35,15 +35,20 @@
#define MEMSIZE 18
#ifdef FT_TEST
PROCEDURE Main()
QOut( "Conventional memory: " + str( FT_SYSMEM() ) + "K installed" )
RETURN
PROCEDURE Main()
QOut( "Conventional memory: " + Str( FT_SYSMEM() ) + "K installed" )
RETURN
#endif
FUNCTION FT_SYSMEM()
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] := 0
FT_INT86( MEMSIZE, aRegs )
LOCAL aRegs[ INT86_MAX_REGS ]
RETURN ( aRegs[ AX ] )
aRegs[ AX ] := 0
FT_INT86( MEMSIZE, aRegs )
RETURN aRegs[ AX ]

392
harbour/contrib/hbnf/tbwhile.prg
View File

@@ -55,144 +55,146 @@
* 2. Passing and evaluating the block for the TbSkipWhil().
*/
#command DEFAULT <param> TO <val> [, <paramn> TO <valn> ];
=> ;
<param> := iif(<param> == NIL, <val>, <param> ) ;
[; <paramn> := iif(<paramn> == NIL, <valn>, <paramn> ) ]
#include "common.ch"
#include "inkey.ch"
#include "set.ch"
#include "setcurs.ch"
#ifdef FT_TEST
/*
* THIS DEMO SHOWS tbnames.dbf CONSISTING OF LAST, FIRST, ADDR, CITY,
* STATE, ZIP WITH ACTIVE INDEX ON LAST + FIRST. IT SHOWS LAST NAME,
* FIRST NAME, CITY ONLY FOR THOSE LAST NAMES THAT BEGIN WITH LETTER
* THAT YOU INPUT FOR THE CKEY GET.
*
* tbnames.dbf/.ntx ARE AUTOMATICALLY CREATED BY THIS TEST PROGRAM
*/
/*
* THIS DEMO SHOWS tbnames.dbf CONSISTING OF LAST, FIRST, ADDR, CITY,
* STATE, ZIP WITH ACTIVE INDEX ON LAST + FIRST. IT SHOWS LAST NAME,
* FIRST NAME, CITY ONLY FOR THOSE LAST NAMES THAT BEGIN WITH LETTER
* THAT YOU INPUT FOR THE CKEY GET.
*
* tbnames.dbf/.ntx ARE AUTOMATICALLY CREATED BY THIS TEST PROGRAM
*/
#include "setcurs.ch"
PROCEDURE TBWHILE()
FUNCTION TBWHILE()
LOCAL aFields := {}, cKey := "O", cOldColor
LOCAL nFreeze := 1, lSaveScrn := .t., nRecSel
LOCAL cColorList := "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R"
LOCAL cColorShad := "N/N"
FIELD last, first
MEMVAR GetList
LOCAL aFields := {}, cKey := "O", cOldColor
LOCAL nFreeze := 1, lSaveScrn := .T. , nRecSel
LOCAL cColorList := "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R"
LOCAL cColorShad := "N/N"
FIELD last, first
MEMVAR GetList
IF ! hb_FileExists( "tbnames.dbf" )
MAKE_DBF()
ENDIF
IF ! hb_FileExists( "tbnames.dbf" )
MAKE_DBF()
ENDIF
USE TBNames
USE TBNames
IF ! hb_FileExists( "tbnames.ntx" )
INDEX ON last + first TO TBNAMES
ENDIF
IF ! hb_FileExists( "tbnames.ntx" )
INDEX ON last + first TO TBNAMES
ENDIF
SET INDEX TO TBNAMES
SET INDEX TO TBNAMES
* Pass Heading as character and Field as Block including Alias
* To eliminate the need to use FIELDWBLOCK() function in FT_BRWSWHL()
// Pass Heading as character and Field as Block including Alias
// To eliminate the need to use FIELDWBLOCK() function in FT_BRWSWHL()
AADD(aFields, {"Last Name" , {||TBNames->Last} } )
AADD(aFields, {"First Name", {||TBNames->First} } )
AADD(aFields, {"City" , {||TBNames->City} } )
AAdd( aFields, { "Last Name" , {|| TBNames->Last } } )
AAdd( aFields, { "First Name", {|| TBNames->First } } )
AAdd( aFields, { "City" , {|| TBNames->City } } )
cOldColor := SetColor("N/BG")
CLS
@ 5,10 SAY "Enter First Letter Of Last Name:" GET cKey PICTURE "!"
READ
cOldColor := SetColor( "N/BG" )
CLS
@ 5, 10 SAY "Enter First Letter Of Last Name:" GET cKey PICTURE "!"
READ
* TBNames->Last = cKey is the Conditional Block passed to this function
* you can make it as complicated as you want, but you would then
* have to modify TBWhileSet() to find first and last records
* matching your key.
nRecSel := FT_BRWSWHL( aFields, {||TBNames->Last = cKey}, cKey, nFreeze,;
lSaveScrn, cColorList, cColorShad, 3, 6, MaxRow() - 2, MaxCol() - 6)
* Note you can use Compound Condition
* such as cLast =: "Pierce " and cFirst =: "Hawkeye "
* by changing above block to:
* {||TBNames->Last = cLast .AND. TBNames->First = cFirst}
* and setting cKey := cLast + cFirst
// TBNames->Last = cKey is the Conditional Block passed to this function
// you can make it as complicated as you want, but you would then
// have to modify TBWhileSet() to find first and last records
// matching your key.
nRecSel := FT_BRWSWHL( aFields, {||TBNames->Last = cKey }, cKey, nFreeze, ;
lSaveScrn, cColorList, cColorShad, 3, 6, MaxRow() - 2, MaxCol() - 6 )
// Note you can use Compound Condition
// such as cLast =: "Pierce " and cFirst =: "Hawkeye "
// by changing above block to:
// {||TBNames->Last = cLast .AND. TBNames->First = cFirst}
// and setting cKey := cLast + cFirst
?
IF nRecSel == 0
? "Sorry, NO Records Were Selected"
ELSE
? "You Selected " + TBNames->Last +" "+ ;
TBNames->First +" "+ TBNames->City
ENDIF
?
?
IF nRecSel == 0
? "Sorry, NO Records Were Selected"
ELSE
? "You Selected " + TBNames->Last + " " + ;
TBNames->First + " " + TBNames->City
ENDIF
?
WAIT
SetColor(cOldColor)
CLS
RETURN nil
WAIT
SetColor( cOldColor )
CLS
STATIC FUNCTION make_dbf
LOCAL x, aData := { ;
{ "SHAEFER","KATHRYN","415 WEST CITRUS ROAD #150","LOS ANGELES","CA","90030" },;
{ "OLSON","JAMES","225 NORTH RANCH ROAD","LOS ANGELES","CA","90023" },;
{ "KAYBEE","JOHN","123 SANDS ROAD","CAMARILLO","CA","93010" },;
{ "HERMAN","JIM","123 TOON PAGE ROAD","VENTURA","CA","93001" },;
{ "BURNS","FRANK","123 VIRGINA STREET","OXNARD","CA","93030" },;
{ "PIERCE","HAWKEYE","123 OLD TOWN ROAD","PORT MUGU","CA","93043" },;
{ "MORGAN","JESSICA","123 FRONTAGE ROAD","CAMARILLO","CA","93010" },;
{ "POTTER","ROBERT","123 FIR STREET","OXNARD","CA","93030" },;
{ "WORTH","MARY","123-1/2 JOHNSON DRIVE","OXNARD","CA","93033" },;
{ "JOHNSON","SUSAN","123 QUEENS STREET","OXNARD","CA","93030" },;
{ "SAMSON","SAM","215 MAIN STREET","OXNARD","CA","93030" },;
{ "NEWNAME","JAMES","215 MAIN STREET","LOS ANGELES","CA","90000" },;
{ "OLEANDAR","JILL","425 FLORAL PARK DRIVE","FLORAL PARK","NY","10093" },;
{ "SUGARMAN","CANDY","1541 SWEETHEART ROAD","HERSHEY","PA","10132" } }
RETURN
DbCreate( "TBNAMES", { { "LAST ", "C", 18, 0, } ,;
{ "FIRST", "C", 9, 0, } ,;
{ "ADDR ", "C", 28, 0, } ,;
{ "CITY ", "C", 21, 0, } ,;
{ "STATE", "C", 2, 0, } ,;
{ "ZIP ", "C", 9, 0, } } )
USE tbnames
FOR x := 1 TO Len( aData )
APPEND BLANK
Aeval( aData[x], {|e,n| FieldPut( n, e ) } )
NEXT
USE
RETURN NIL
STATIC FUNCTION make_dbf()
LOCAL x, aData := { ;
{ "SHAEFER", "KATHRYN", "415 WEST CITRUS ROAD #150", "LOS ANGELES", "CA", "90030" }, ;
{ "OLSON", "JAMES", "225 NORTH RANCH ROAD", "LOS ANGELES", "CA", "90023" }, ;
{ "KAYBEE", "JOHN", "123 SANDS ROAD", "CAMARILLO", "CA", "93010" }, ;
{ "HERMAN", "JIM", "123 TOON PAGE ROAD", "VENTURA", "CA", "93001" }, ;
{ "BURNS", "FRANK", "123 VIRGINA STREET", "OXNARD", "CA", "93030" }, ;
{ "PIERCE", "HAWKEYE", "123 OLD TOWN ROAD", "PORT MUGU", "CA", "93043" }, ;
{ "MORGAN", "JESSICA", "123 FRONTAGE ROAD", "CAMARILLO", "CA", "93010" }, ;
{ "POTTER", "ROBERT", "123 FIR STREET", "OXNARD", "CA", "93030" }, ;
{ "WORTH", "MARY", "123-1/2 JOHNSON DRIVE", "OXNARD", "CA", "93033" }, ;
{ "JOHNSON", "SUSAN", "123 QUEENS STREET", "OXNARD", "CA", "93030" }, ;
{ "SAMSON", "SAM", "215 MAIN STREET", "OXNARD", "CA", "93030" }, ;
{ "NEWNAME", "JAMES", "215 MAIN STREET", "LOS ANGELES", "CA", "90000" }, ;
{ "OLEANDAR", "JILL", "425 FLORAL PARK DRIVE", "FLORAL PARK", "NY", "10093" }, ;
{ "SUGARMAN", "CANDY", "1541 SWEETHEART ROAD", "HERSHEY", "PA", "10132" } }
dbCreate( "TBNAMES", {;
{ "LAST ", "C", 18, 0, } , ;
{ "FIRST", "C", 9, 0, } , ;
{ "ADDR ", "C", 28, 0, } , ;
{ "CITY ", "C", 21, 0, } , ;
{ "STATE", "C", 2, 0, } , ;
{ "ZIP ", "C", 9, 0, } } )
USE tbnames
FOR x := 1 TO Len( aData )
APPEND BLANK
AEval( aData[ x ], {| e, n | FieldPut( n, e ) } )
NEXT
USE
RETURN NIL
#endif
/* ------------------------------------------------------------------- */
FUNCTION FT_BRWSWHL(aFields, bWhileCond, cKey, nFreeze, lSaveScrn, ;
cColorList, cColorShad, nTop, nLeft, nBottom, nRight )
FUNCTION FT_BRWSWHL( aFields, bWhileCond, cKey, nFreeze, lSaveScrn, ;
cColorList, cColorShad, nTop, nLeft, nBottom, nRight )
LOCAL b, column, i
LOCAL cHead, bField, lKeepScrn, cScrnSave
LOCAL cColorSave, cColorBack, nCursSave
LOCAL lMore, nKey, nPassRec
DEFAULT nFreeze TO 0, ;
lSaveScrn TO .t., ;
cColorList TO "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R", ;
cColorShad TO "N/N", ;
nTop TO 2, ;
nLeft TO 2, ;
nBottom TO MaxRow() - 2, ;
nRight TO MaxCol() - 2
lKeepScrn := PCOUNT() > 6
DEFAULT nFreeze TO 0
DEFAULT lSaveScrn TO .T.
DEFAULT cColorList TO "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R"
DEFAULT cColorShad TO "N/N"
DEFAULT nTop TO 2
DEFAULT nLeft TO 2
DEFAULT nBottom TO MaxRow() - 2
DEFAULT nRight TO MaxCol() - 2
lKeepScrn := PCount() > 6
SEEK cKey
IF .NOT. FOUND() .OR. LASTREC() == 0
IF ! Found() .OR. LastRec() == 0
RETURN 0
ENDIF
/* make new browse object */
b := TBrowseDB(nTop, nLeft, nBottom, nRight)
b := TBRowseDb( nTop, nLeft, nBottom, nRight )
/* default heading and column separators */
b:headSep := hb_UTF8ToStr( "═╤═" )
@@ -200,38 +202,38 @@ FUNCTION FT_BRWSWHL(aFields, bWhileCond, cKey, nFreeze, lSaveScrn, ;
b:footSep := hb_UTF8ToStr( "═╧═" )
/* add custom 'TbSkipWhil' (to handle passed condition) */
b:skipBlock := {|x| TbSkipWhil(x, bWhileCond)}
b:skipBlock := {| x | TbSkipWhil( x, bWhileCond ) }
/* Set up substitute goto top and goto bottom */
/* with While's top and bottom records */
b:goTopBlock := {|| TbWhileTop(cKey)}
b:goBottomBlock := {|| TbWhileBot(cKey)}
b:goTopBlock := {|| TbWhileTop( cKey ) }
b:goBottomBlock := {|| TbWhileBot( cKey ) }
/* colors */
b:colorSpec := cColorList
/* add a column for each field in the current workarea */
FOR i := 1 TO LEN(aFields)
cHead := aFields[i, 1]
bField := aFields[i, 2]
FOR i := 1 TO Len( aFields )
cHead := aFields[ i, 1 ]
bField := aFields[ i, 2 ]
/* make the new column */
column := TBColumnNew( cHead, bField )
/* these are color setups from tbdemo.prg from Nantucket */
* IF ( cType == "N" )
* column:defColor := {5, 6}
* column:colorBlock := {|x| iif( x < 0, {7, 8}, {5, 6} )}
*ELSE
* column:defColor := {3, 4}
*ENDIF
// IF cType == "N"
// column:defColor := { 5, 6 }
// column:colorBlock := {| x | iif( x < 0, { 7, 8 }, { 5, 6 } ) }
// ELSE
// column:defColor := { 3, 4 }
// ENDIF
/* To simplify I just used 3rd and 4th colors from passed cColorList */
/* This way 1st is SAY, 2nd is GET, 3rd and 4th are used here,
/* 5th is Unselected Get, extras can be used as in tbdemo.prg */
column:defColor := {3, 4}
column:defColor := { 3, 4 }
b:addColumn(column)
b:addColumn( column )
NEXT
/* freeze columns */
@@ -241,170 +243,176 @@ FUNCTION FT_BRWSWHL(aFields, bWhileCond, cKey, nFreeze, lSaveScrn, ;
/* save old screen and colors */
IF lSaveScrn
cScrnSave := SAVESCREEN(0, 0, MaxRow(), MaxCol())
cScrnSave := SaveScreen( 0, 0, MaxRow(), MaxCol() )
ENDIF
cColorSave := SetColor()
/* Background Color Is Based On First Color In Passed cColorList */
cColorBack := iif(',' $ cColorList, ;
SUBSTR(cColorList, 1, AT(',', cColorList) - 1), cColorList )
cColorBack := iif( ',' $ cColorList, ;
SubStr( cColorList, 1, At( ',', cColorList ) - 1 ), cColorList )
IF .NOT. lKeepScrn
SetColor(cColorBack)
IF ! lKeepScrn
SetColor( cColorBack )
CLS
ENDIF
/* make a window shadow */
SetColor(cColorShad)
@ nTop+1, nLeft+1 CLEAR TO nBottom+1, nRight+1
SetColor(cColorBack)
SetColor( cColorShad )
@ nTop + 1, nLeft + 1 CLEAR TO nBottom + 1, nRight + 1
SetColor( cColorBack )
@ nTop, nLeft CLEAR TO nBottom, nRight
SetColor(cColorSave)
SetColor( cColorSave )
nCursSave := SetCursor(SC_NONE)
nCursSave := SetCursor( SC_NONE )
lMore := .t.
WHILE (lMore)
lMore := .T.
DO WHILE lMore
/* stabilize the display */
nKey := 0
DISPBEGIN()
DO WHILE nKey == 0 .AND. .NOT. b:stable
b:stabilize()
nKey := InKey()
DispBegin()
DO WHILE nKey == 0 .AND. ! b:stable
b:stabilize()
nKey := Inkey()
ENDDO
DISPEND()
DispEnd()
IF ( b:stable )
IF b:stable
/* display is stable */
IF ( b:hitTop .OR. b:hitBottom )
Tone(125, 0)
IF b:hitTop .OR. b:hitBottom
Tone( 125, 0 )
ENDIF
// Make sure that the current record is showing
// up-to-date data in case we are on a network.
DISPBEGIN()
DispBegin()
b:refreshCurrent()
DO WHILE .NOT. b:stabilize()
DO WHILE ! b:stabilize()
ENDDO
DISPEND()
DispEnd()
/* everything's done; just wait for a key */
nKey := INKEY(0)
/* everything's done. just wait for a key */
nKey := Inkey( 0 )
ENDIF
/* process key */
DO CASE
CASE ( nKey == K_DOWN )
CASE nKey == K_DOWN
b:down()
CASE ( nKey == K_UP )
CASE nKey == K_UP
b:up()
CASE ( nKey == K_PGDN )
CASE nKey == K_PGDN
b:pageDown()
CASE ( nKey == K_PGUP )
CASE nKey == K_PGUP
b:pageUp()
CASE ( nKey == K_CTRL_PGUP )
CASE nKey == K_CTRL_PGUP
b:goTop()
CASE ( nKey == K_CTRL_PGDN )
CASE nKey == K_CTRL_PGDN
b:goBottom()
CASE ( nKey == K_RIGHT )
b:right()
CASE nKey == K_RIGHT
b:Right()
CASE ( nKey == K_LEFT )
b:left()
CASE nKey == K_LEFT
b:Left()
CASE ( nKey == K_HOME )
CASE nKey == K_HOME
b:home()
CASE ( nKey == K_END )
CASE nKey == K_END
b:end()
CASE ( nKey == K_CTRL_LEFT )
CASE nKey == K_CTRL_LEFT
b:panLeft()
CASE ( nKey == K_CTRL_RIGHT )
CASE nKey == K_CTRL_RIGHT
b:panRight()
CASE ( nKey == K_CTRL_HOME )
CASE nKey == K_CTRL_HOME
b:panHome()
CASE ( nKey == K_CTRL_END )
CASE nKey == K_CTRL_END
b:panEnd()
CASE ( nKey == K_ESC )
CASE nKey == K_ESC
nPassRec := 0
lMore := .f.
lMore := .F.
CASE ( nKey == K_RETURN )
nPassRec := RECNO()
lMore := .f.
CASE nKey == K_RETURN
nPassRec := RecNo()
lMore := .F.
ENDCASE
ENDDO // for WHILE (lmore)
ENDDO
/* restore old screen */
IF lSaveScrn
RESTSCREEN(0, 0, MaxRow(), MaxCol(), cScrnSave)
RestScreen( 0, 0, MaxRow(), MaxCol(), cScrnSave )
ENDIF
SetCursor(nCursSave)
SetColor(cColorSave)
SetCursor( nCursSave )
SetColor( cColorSave )
RETURN (nPassRec)
RETURN nPassRec
/* -------------------------------------------------------------------- */
STATIC FUNCTION TbSkipWhil(n, bWhileCond)
STATIC FUNCTION TbSkipWhil( n, bWhileCond )
LOCAL i := 0
IF n == 0 .OR. LASTREC() == 0
IF n == 0 .OR. LastRec() == 0
SKIP 0 // significant on a network
ELSEIF ( n > 0 .AND. RECNO() != LASTREC() + 1)
WHILE ( i < n )
ELSEIF n > 0 .AND. RecNo() != LastRec() + 1
WHILE i < n
SKIP 1
IF ( EOF() .OR. .NOT. Eval(bWhileCond) )
IF EOF() .OR. ! Eval( bWhileCond )
SKIP -1
EXIT
ENDIF
i++
ENDDO
ELSEIF ( n < 0 )
WHILE ( i > n )
ELSEIF n < 0
DO WHILE i > n
SKIP -1
IF ( BOF() )
IF BOF()
EXIT
ELSEIF .NOT. Eval( (bWhileCond) )
ELSEIF ! Eval( bWhileCond )
SKIP
EXIT
ENDIF
i--
ENDDO
ENDIF
RETURN (i)
* EOFcn TbSkipWhil()
RETURN i
/* -------------------------------------------------------------------- */
STATIC FUNCTION TbWhileTop(cKey)
STATIC FUNCTION TbWhileTop( cKey )
SEEK cKey
RETURN NIL
RETURN NIL
/* -------------------------------------------------------------------- */
STATIC FUNCTION TbWhileBot(cKey)
* SeekLast: Finds Last Record For Matching Key
* Developed By Jon Cole
* With softseek set on, seek the first record after condition.
* This is accomplished by incrementing the right most character of the
* string cKey by one ascii character. After SEEKing the new string,
* back up one record to get to the last record which matches cKey.
#include "set.ch"
LOCAL cSoftSave := SET(_SET_SOFTSEEK, .t.)
SEEK LEFT(cKey, LEN(cKey) -1) + CHR( ASC( RIGHT(cKey,1) ) +1)
SET(_SET_SOFTSEEK, cSoftSave)
STATIC FUNCTION TbWhileBot( cKey )
// SeekLast: Finds Last Record For Matching Key
// Developed By Jon Cole
// With softseek set on, seek the first record after condition.
// This is accomplished by incrementing the right most character of the
// string cKey by one ascii character. After SEEKing the new string,
// back up one record to get to the last record which matches cKey.
LOCAL cSoftSave := Set( _SET_SOFTSEEK, .T. )
SEEK Left( cKey, Len( cKey ) - 1 ) + Chr( Asc( Right( cKey, 1 ) ) + 1 )
Set( _SET_SOFTSEEK, cSoftSave )
SKIP -1
RETURN NIL
RETURN NIL

110
harbour/contrib/hbnf/tempfile.prg
View File

@@ -41,91 +41,97 @@
*
*/
#include "fileio.ch"
#ifdef HB_OS_DOS
#define FT_TEMPFILE_ORIGINAL
#define FT_TEMPFILE_ORIGINAL
#endif
#ifdef HB_OS_DOS_32
#undef FT_TEMPFILE_ORIGINAL
#undef FT_TEMPFILE_ORIGINAL
#endif
#ifdef FT_TEMPFILE_ORIGINAL
#include "ftint86.ch"
#include "ftint86.ch"
#define DOS 33
#define TEMPNAME 90
#define DOS 33
#define TEMPNAME 90
FUNCTION FT_TEMPFIL( cPath, lHide, nHandle )
LOCAL cRet,aRegs[3]
FUNCTION FT_TEMPFIL( cPath, lHide, nHandle )
cPath := iif( valType(cPath) != "C", ;
replicate( chr(0),13) , ;
cPath += replicate( chr(0), 13 ) ;
)
LOCAL cRet, aRegs[3]
lHide := iif( valType(lHide) != "L", .f., lHide )
cPath := iif( ValType( cPath ) != "C", ;
Replicate( Chr( 0 ), 13 ) , ;
cPath += Replicate( Chr( 0 ), 13 ) ;
)
lHide := iif( ValType( lHide ) != "L", .F. , lHide )
/*
aRegs[AX] := MAKEHI( TEMPNAME )
aRegs[CX] := iif( lHide, 2, 0 )
aRegs[DS] := cPath
aRegs[DX] := REG_DS
aRegs[ AX ] := MAKEHI( TEMPNAME )
aRegs[ CX ] := iif( lHide, 2, 0 )
aRegs[ DS ] := cPath
aRegs[ DX ] := REG_DS
FT_INT86( DOS, aRegs )
*/
aRegs:=_ft_tempfil(cPath,lHide)
aRegs := _ft_tempfil( cPath, lHide )
/* If carry flag is clear, then call succeeded and a file handle is
* sitting in AX that needs to be closed.
*/
if !ft_isBitOn( aRegs[3], FLAG_CARRY )
if pcount() >= 3
nHandle := aRegs[1]
else
fclose( aRegs[1] )
endif
cRet := alltrim( strtran( aRegs[2], chr(0) ) )
else
cRet := ""
endif
IF ! ft_isBitOn( aRegs[ 3 ], FLAG_CARRY )
IF PCount() >= 3
nHandle := aRegs[ 1 ]
ELSE
FClose( aRegs[ 1 ] )
ENDIF
cRet := AllTrim( StrTran( aRegs[ 2 ], Chr( 0 ) ) )
ELSE
cRet := ""
ENDIF
RETURN cRet
RETURN cRet
#else
#include "fileio.ch"
FUNCTION FT_TEMPFIL( cPath, lHide, nHandle )
FUNCTION FT_TEMPFIL( cPath, lHide, nHandle )
LOCAL cFile
LOCAL cFile
hb_default( @cPath, ".\" )
hb_default( @lHide, .F. )
hb_default( @cPath, ".\" )
hb_default( @lHide, .F. )
cPath := AllTrim( cPath )
cPath := alltrim( cPath )
nHandle := hb_FTempCreate( cPath, NIL, iif( lHide, FC_HIDDEN, FC_NORMAL ), @cFile )
nHandle := HB_FTempCreate( cPath, nil, iif( lHide, FC_HIDDEN, FC_NORMAL ), @cFile )
IF PCount() <= 2
FClose( nHandle )
ENDIF
if pcount() <= 2
fclose( nHandle )
endif
RETURN cFile
RETURN cFile
#endif /* FT_TEMPFILE_ORIGINAL */
#ifdef FT_TEST
PROCEDURE Main( cPath, cHide )
LOCAL cFile, nHandle
cFile := FT_TEMPFIL( cPath, (cHide == "Y") )
if !empty( cFile )
QOut( cFile )
nHandle := fopen( cFile, 1 )
fwrite( nHandle, "This is a test!" )
fclose( nHandle )
else
Qout( "An error occurred" )
endif
RETURN
PROCEDURE Main( cPath, cHide )
LOCAL cFile, nHandle
cFile := FT_TEMPFIL( cPath, ( cHide == "Y" ) )
IF ! Empty( cFile )
QOut( cFile )
nHandle := FOpen( cFile, FO_WRITE )
FWrite( nHandle, "This is a test!" )
FClose( nHandle )
ELSE
QOut( "An error occurred" )
ENDIF
RETURN
#endif

177
harbour/contrib/hbnf/vertmenu.prg
View File

@@ -27,44 +27,47 @@
#ifdef FT_TEST
PROCEDURE Main()
LOCAL MAINMENU := ;
{ { "DATA ENTRY", "ENTER DATA", { || FT_MENU2(datamenu) } }, ;
{ "Reports", "Hard copy", { || FT_MENU2(repmenu) } }, ;
{ "Maintenance","Reindex files, etc.",{ || FT_MENU2(maintmenu) } }, ;
LOCAL MAINMENU := ;
{ { "DATA ENTRY", "ENTER DATA", { || FT_MENU2( datamenu) } }, ;
{ "Reports", "Hard copy", { || FT_MENU2( repmenu ) } }, ;
{ "Maintenance", "Reindex files, etc.", { || FT_MENU2( maintmenu ) } }, ;
{ "Quit", "See ya later" } }
local datamenu := { { "Customers", , { || cust() } } , ;
{ "Invoices", , { || inv() } } , ;
{ "Vendors", , { || vendors() } }, ;
{ "Exit", "Return to Main Menu" } }
LOCAL datamenu := { { "Customers", , { || cust() } } , ;
{ "Invoices", , { || inv() } } , ;
{ "Vendors", , { || vendors() } }, ;
{ "Exit", "Return to Main Menu" } }
local repmenu := { { "Customer List", , { || custrep() } } , ;
{ "Past Due", , { || pastdue() } } , ;
{ "Weekly Sales", , { || weeksales() } }, ;
{ "Monthly P&L", , { || monthpl() } } , ;
{ "Vendor List", , { || vendorrep() } }, ;
{ "Exit", "Return to Main Menu" } }
LOCAL repmenu := { { "Customer List", , { || custrep() } } , ;
{ "Past Due", , { || pastdue() } } , ;
{ "Weekly Sales", , { || weeksales() } }, ;
{ "Monthly P&L", , { || monthpl() } } , ;
{ "Vendor List", , { || vendorrep() } }, ;
{ "Exit", "Return to Main Menu" } }
local maintmenu := { { "Reindex", "Rebuild index files", { || re_ntx() } } , ;
{ "Backup", "Backup data files" , { || backup() } } , ;
{ "Compress", "Compress data files", { || compress()} }, ;
{ "Exit", "Return to Main Menu" } }
LOCAL maintmenu := { { "Reindex", "Rebuild index files", { || re_ntx() } } , ;
{ "Backup", "Backup data files" , { || backup() } } , ;
{ "Compress", "Compress data files", { || compress() } }, ;
{ "Exit", "Return to Main Menu" } }
FT_MENU2(mainmenu)
return
FT_MENU2( mainmenu )
RETURN
/* stub functions to avoid missing symbols */
static function cust
static function inv
static function vendors
static function custrep
static function pastdue
static function weeksales
static function monthpl
static function vendorrep
static function re_ntx
static function backup
static function compress
STATIC FUNCTION cust()
STATIC FUNCTION inv()
STATIC FUNCTION vendors()
STATIC FUNCTION custrep()
STATIC FUNCTION pastdue()
STATIC FUNCTION weeksales()
STATIC FUNCTION monthpl()
STATIC FUNCTION vendorrep()
STATIC FUNCTION re_ntx()
STATIC FUNCTION backup()
STATIC FUNCTION compress()
#endif
@@ -74,64 +77,64 @@ static function compress
FUNCTION ft_menu2( aMenuInfo, cColors )
LOCAL nChoice := 1 ,;
nOptions := Len( aMenuInfo ) ,;
nMaxwidth := 0 ,;
nLeft ,;
x ,;
cOldscreen ,;
nTop ,;
lOldwrap := Set( _SET_WRAP, .T. ) ,;
lOldcenter := Set( _SET_MCENTER, .T. ),;
lOldmessrow := Set( _SET_MESSAGE ) ,;
cOldcolor := Set( _SET_COLOR )
LOCAL nChoice := 1
LOCAL nOptions := Len( aMenuInfo )
LOCAL nMaxwidth := 0
LOCAL nLeft
LOCAL x
LOCAL cOldscreen
LOCAL nTop
LOCAL lOldwrap := Set( _SET_WRAP, .T. )
LOCAL lOldcenter := Set( _SET_MCENTER, .T. )
LOCAL lOldmessrow := Set( _SET_MESSAGE )
LOCAL cOldcolor := Set( _SET_COLOR )
IF cColors # NIL
Set( _SET_COLOR, cColors )
ENDIF
/* if no message row has been established, use bottom row */
IF lOldmessrow == 0
Set( _SET_MESSAGE, Maxrow() )
ENDIF
/* determine longest menu option */
Aeval( aMenuInfo, { | ele | nMaxwidth := max( nMaxwidth, len( ele[1] ) ) } )
/* establish top and left box coordinates */
nLeft := ( ( Maxcol() + 1 ) - nMaxwidth ) / 2
nTop := ( ( Maxrow() + 1 ) - ( nOptions + 2 ) ) / 2
DO WHILE nChoice != 0 .AND. nChoice != nOptions
cOldscreen := Savescreen( nTop, nLeft - 1, nTop + nOptions + 1, nLeft + nMaxwidth )
@ nTop, nLeft - 1, nTop + nOptions + 1, nLeft + nMaxwidth BOX B_SINGLE + ' '
Devpos( nTop, nLeft )
FOR x := 1 to Len( aMenuInfo )
IF Len( aMenuInfo[x] ) > 1 .AND. aMenuInfo[x,2] != NIL
@ Row() + 1, nLeft PROMPT Padr( aMenuInfo[x, 1], nMaxwidth ) ;
MESSAGE aMenuInfo[x,2]
ELSE
@ Row() + 1, nLeft PROMPT Padr( aMenuInfo[x,1], nMaxwidth )
ENDIF
NEXT
MENU TO nChoice
Restscreen( nTop, nLeft - 1, nTop + nOptions + 1, nLeft + nMaxwidth, cOldscreen )
/* execute action block attached to this option if there is one */
IF nChoice > 0 .AND. Len( aMenuInfo[ nChoice ] ) == 3
Eval( aMenuInfo[nChoice,3] )
IF cColors != NIL
Set( _SET_COLOR, cColors )
ENDIF
ENDDO
/* if no message row has been established, use bottom row */
IF lOldmessrow == 0
Set( _SET_MESSAGE, MaxRow() )
ENDIF
/* restore previous message and wrap settings */
Set( _SET_MESSAGE, lOldmessrow )
Set( _SET_MCENTER, lOldcenter )
Set( _SET_WRAP, lOldwrap )
Set( _SET_COLOR, cOldcolor )
/* determine longest menu option */
AEval( aMenuInfo, { | ele | nMaxwidth := Max( nMaxwidth, Len( ele[1] ) ) } )
RETURN NIL
/* establish top and left box coordinates */
nLeft := ( ( MaxCol() + 1 ) - nMaxwidth ) / 2
nTop := ( ( MaxRow() + 1 ) - ( nOptions + 2 ) ) / 2
DO WHILE nChoice != 0 .AND. nChoice != nOptions
cOldscreen := SaveScreen( nTop, nLeft - 1, nTop + nOptions + 1, nLeft + nMaxwidth )
@ nTop, nLeft - 1, nTop + nOptions + 1, nLeft + nMaxwidth BOX B_SINGLE + ' '
DevPos( nTop, nLeft )
FOR x := 1 TO Len( aMenuInfo )
IF Len( aMenuInfo[ x ] ) > 1 .AND. aMenuInfo[ x, 2 ] != NIL
@ Row() + 1, nLeft PROMPT PadR( aMenuInfo[ x, 1 ], nMaxwidth ) ;
MESSAGE aMenuInfo[ x, 2 ]
ELSE
@ Row() + 1, nLeft PROMPT PadR( aMenuInfo[ x, 1 ], nMaxwidth )
ENDIF
NEXT
MENU TO nChoice
RestScreen( nTop, nLeft - 1, nTop + nOptions + 1, nLeft + nMaxwidth, cOldscreen )
/* execute action block attached to this option if there is one */
IF nChoice > 0 .AND. Len( aMenuInfo[ nChoice ] ) == 3
Eval( aMenuInfo[ nChoice, 3 ] )
ENDIF
ENDDO
/* restore previous message and wrap settings */
Set( _SET_MESSAGE, lOldmessrow )
Set( _SET_MCENTER, lOldcenter )
Set( _SET_WRAP, lOldwrap )
Set( _SET_COLOR, cOldcolor )
RETURN NIL

32
harbour/contrib/hbnf/vidcur.prg
View File

@@ -33,26 +33,28 @@
#define VIDEO 16
FUNCTION FT_SETVCUR( nPage, nRow, nCol )
LOCAL aRegs[ INT86_MAX_REGS ]
nPage := iif( nPage == nil, FT_GETVPG() , nPage )
nRow := iif( nRow == nil, 0 , nRow )
nCol := iif( nCol == nil, 0 , nCol )
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] := MAKEHI( 2 )
aRegs[ BX ] := MAKEHI( nPage )
aRegs[ DX ] := MAKEHI( nRow ) + nCol
nPage := iif( nPage == NIL, FT_GETVPG() , nPage )
nRow := iif( nRow == NIL, 0 , nRow )
nCol := iif( nCol == NIL, 0 , nCol )
FT_INT86( VIDEO, aRegs )
aRegs[ AX ] := MAKEHI( 2 )
aRegs[ BX ] := MAKEHI( nPage )
aRegs[ DX ] := MAKEHI( nRow ) + nCol
RETURN NIL
FT_INT86( VIDEO, aRegs )
RETURN NIL
FUNCTION FT_GETVCUR( nPage )
LOCAL aRegs[ INT86_MAX_REGS ]
nPage := iif( nPage == nil, FT_GETVPG(), nPage )
aRegs[ AX ] := MAKEHI( 3 )
aRegs[ BX ] := MAKEHI( nPage )
FT_INT86( VIDEO, aRegs )
LOCAL aRegs[ INT86_MAX_REGS ]
RETURN ( { HIGHBYTE( aRegs[CX] ), LOWBYTE( aRegs[CX] ), HIGHBYTE( aRegs[DX] ), LOWBYTE( aRegs[DX] ) } )
nPage := iif( nPage == NIL, FT_GETVPG(), nPage )
aRegs[ AX ] := MAKEHI( 3 )
aRegs[ BX ] := MAKEHI( nPage )
FT_INT86( VIDEO, aRegs )
RETURN { HIGHBYTE( aRegs[ CX ] ), LOWBYTE( aRegs[ CX ] ), HIGHBYTE( aRegs[ DX ] ), LOWBYTE( aRegs[ DX ] ) }

33
harbour/contrib/hbnf/vidmode.prg
View File

@@ -34,31 +34,36 @@
#define GETMODE 15
#ifdef FT_TEST
PROCEDURE Main( cMode )
FT_SETMODE( val( cMode ) )
QOut( "Video mode is: " + str( FT_GETMODE() ) )
RETURN
PROCEDURE Main( cMode )
FT_SETMODE( Val( cMode ) )
QOut( "Video mode is: " + Str( FT_GETMODE() ) )
RETURN
#endif
FUNCTION FT_SETMODE( nMode )
/*
LOCAL aRegs[ INT86_MAX_REGS ]
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] := nMode
FT_INT86( VIDEO, aRegs )
aRegs[ AX ] := nMode
FT_INT86( VIDEO, aRegs )
*/
_ft_setmode(nMode)
RETURN NIL
_ft_setmode( nMode )
RETURN NIL
FUNCTION FT_GETMODE()
/*
LOCAL aRegs[INT86_MAX_REGS]
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] := MAKEHI( GETMODE )
FT_INT86( VIDEO, aRegs )
aRegs[ AX ] := MAKEHI( GETMODE )
FT_INT86( VIDEO, aRegs )
RETURN LOWBYTE( aRegs[ AX ] )
RETURN LOWBYTE( aRegs[ AX ] )
*/
RETURN _ft_getmode()
RETURN _ft_getmode()

27
harbour/contrib/hbnf/wda.prg
View File

@@ -22,16 +22,23 @@
*/
#ifdef FT_TEST
PROCEDURE Main( cDate, cDays )
local nDays := ft_addWkDy( ctod(cDate), val(cDays) )
qout( "Num days to add: " + str( nDays ) )
qout( "New date: " + dtoc( ctod( cDate ) + nDays ) )
return
PROCEDURE Main( cDate, cDays )
LOCAL nDays := ft_addWkDy( CToD( cDate ), Val( cDays ) )
QOut( "Num days to add: " + Str( nDays ) )
QOut( "New date: " + DToC( CToD( cDate ) + nDays ) )
RETURN
#endif
FUNCTION ft_addWkDy( dStart, nDys )
LOCAL nDc := dow( dStart )
RETURN iif( nDc == 7, ;
(nDys-1) % 5 + 7 * int( (nDys-1) / 5 ) + 2, ;
(nDys+nDc-2) % 5 + 7 * int( (nDys+nDc-2) / 5 ) + 2 - nDc ;
) ;
LOCAL nDc := DOW( dStart )
RETURN iif( nDc == 7, ;
( nDys - 1 ) % 5 + 7 * Int( ( nDys - 1 ) / 5 ) + 2, ;
( nDys + nDc - 2 ) % 5 + 7 * Int( ( nDys + nDc - 2 ) / 5 ) + 2 - nDc ;
)

49
harbour/contrib/hbnf/week.prg
View File

@@ -28,33 +28,34 @@
*/
FUNCTION FT_WEEK( dGivenDate, nWeekNum )
LOCAL lIsWeek, nTemp, aRetVal, dTemp
IF ! (VALTYPE(dGivenDate) $ 'ND')
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'N'
nWeekNum := dGivenDate
dGivenDate := DATE()
ENDIF
LOCAL lIsWeek, nTemp, aRetVal, dTemp
aRetVal := FT_YEAR(dGivenDate)
dTemp := aRetVal[2]
aRetVal[2] -= FT_DAYTOBOW( aRetVal[2] )
IF ! ( ValType( dGivenDate ) $ 'ND' )
dGivenDate := Date()
ELSEIF ValType( dGivenDate ) == 'N'
nWeekNum := dGivenDate
dGivenDate := Date()
ENDIF
lIsWeek := ( VALTYPE(nWeekNum) == 'N' )
IF lIsWeek
nTemp := INT( (aRetVal[3] - aRetVal[2]) / 7 ) + 1
IF nWeekNum < 1 .OR. nWeekNum > nTemp
nWeekNum := nTemp
ENDIF
dGivenDate := aRetVal[2] + (nWeekNum - 1) * 7
ENDIF
aRetVal := FT_YEAR( dGivenDate )
dTemp := aRetVal[ 2 ]
aRetVal[ 2 ] -= FT_DAYTOBOW( aRetVal[ 2 ] )
dGivenDate += ( 6 - FT_DAYTOBOW(dGivenDate) ) // end of week
lIsWeek := ( ValType( nWeekNum ) == 'N' )
IF lIsWeek
nTemp := Int( ( aRetVal[ 3 ] - aRetVal[ 2 ] ) / 7 ) + 1
IF nWeekNum < 1 .OR. nWeekNum > nTemp
nWeekNum := nTemp
ENDIF
dGivenDate := aRetVal[ 2 ] + ( nWeekNum - 1 ) * 7
ENDIF
aRetVal[1] += PADL(LTRIM(STR(INT( (dGivenDate - ;
aRetVal[2]) / 7 ) + 1, 2)), 2, '0')
aRetVal[2] := MAX( dGivenDate - 6, dTemp )
aRetVal[3] := MIN( dGivenDate, aRetVal[3] )
dGivenDate += ( 6 - FT_DAYTOBOW( dGivenDate ) ) // end of week
RETURN aRetVal
aRetVal[ 1 ] += PadL( LTrim( Str( Int( ( dGivenDate - ;
aRetVal[ 2 ] ) / 7 ) + 1, 2 ) ), 2, '0' )
aRetVal[ 2 ] := Max( dGivenDate - 6, dTemp )
aRetVal[ 3 ] := Min( dGivenDate, aRetVal[ 3 ] )
RETURN aRetVal

Some files were not shown because too many files have changed in this diff Show More