diff --git a/harbour/ChangeLog b/harbour/ChangeLog index f8a0ac25e4..16b1527467 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -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 diff --git a/harbour/contrib/hbnf/aading.prg b/harbour/contrib/hbnf/aading.prg index 2699c4f83c..a9bb620cea 100644 --- a/harbour/contrib/hbnf/aading.prg +++ b/harbour/contrib/hbnf/aading.prg @@ -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 diff --git a/harbour/contrib/hbnf/aavg.prg b/harbour/contrib/hbnf/aavg.prg index a57d037f5e..780d6a29b1 100644 --- a/harbour/contrib/hbnf/aavg.prg +++ b/harbour/contrib/hbnf/aavg.prg @@ -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 TO [, TO ] ; - => ; - := iif( == NIL,,) ; - [; := iif( == NIL,,)] +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 ) ) diff --git a/harbour/contrib/hbnf/acctadj.prg b/harbour/contrib/hbnf/acctadj.prg index 4f4e51997d..7bb9629966 100644 --- a/harbour/contrib/hbnf/acctadj.prg +++ b/harbour/contrib/hbnf/acctadj.prg @@ -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 diff --git a/harbour/contrib/hbnf/acctmnth.prg b/harbour/contrib/hbnf/acctmnth.prg index a4d4f0cf65..525303116c 100644 --- a/harbour/contrib/hbnf/acctmnth.prg +++ b/harbour/contrib/hbnf/acctmnth.prg @@ -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 diff --git a/harbour/contrib/hbnf/acctqtr.prg b/harbour/contrib/hbnf/acctqtr.prg index 30d5248a9a..c91b5e31ad 100644 --- a/harbour/contrib/hbnf/acctqtr.prg +++ b/harbour/contrib/hbnf/acctqtr.prg @@ -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 diff --git a/harbour/contrib/hbnf/acctweek.prg b/harbour/contrib/hbnf/acctweek.prg index ec90efe02a..06c307b5f6 100644 --- a/harbour/contrib/hbnf/acctweek.prg +++ b/harbour/contrib/hbnf/acctweek.prg @@ -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 diff --git a/harbour/contrib/hbnf/acctyear.prg b/harbour/contrib/hbnf/acctyear.prg index 072fee0885..6b6099d6d4 100644 --- a/harbour/contrib/hbnf/acctyear.prg +++ b/harbour/contrib/hbnf/acctyear.prg @@ -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 diff --git a/harbour/contrib/hbnf/adessort.prg b/harbour/contrib/hbnf/adessort.prg index da268d742d..b75e055257 100644 --- a/harbour/contrib/hbnf/adessort.prg +++ b/harbour/contrib/hbnf/adessort.prg @@ -24,27 +24,18 @@ * */ -#command DEFAULT TO [, TO ] ; - => ; - := iif( == NIL,,) ; - [; := iif( == NIL,,)] - -#command DEFAULT TO IF NOT ; - [, TO IF NOT ] ; - => ; - := iif(VALTYPE() == ,,) ; - [; := iif(VALTYPE() == ,,)] +#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 } ) diff --git a/harbour/contrib/hbnf/aemaxlen.prg b/harbour/contrib/hbnf/aemaxlen.prg index eca207356f..da38b0e4b9 100644 --- a/harbour/contrib/hbnf/aemaxlen.prg +++ b/harbour/contrib/hbnf/aemaxlen.prg @@ -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 diff --git a/harbour/contrib/hbnf/aeminlen.prg b/harbour/contrib/hbnf/aeminlen.prg index b1675e6644..9220c73600 100644 --- a/harbour/contrib/hbnf/aeminlen.prg +++ b/harbour/contrib/hbnf/aeminlen.prg @@ -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 diff --git a/harbour/contrib/hbnf/amedian.prg b/harbour/contrib/hbnf/amedian.prg index cdf7b56afd..7e16ef969d 100644 --- a/harbour/contrib/hbnf/amedian.prg +++ b/harbour/contrib/hbnf/amedian.prg @@ -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 TO [, TO ] ; - => ; - := iif( == NIL,,) ; - [; := iif( == NIL,,)] +#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 diff --git a/harbour/contrib/hbnf/anomatch.prg b/harbour/contrib/hbnf/anomatch.prg index 09b34a06ec..ea179c2e3d 100644 --- a/harbour/contrib/hbnf/anomatch.prg +++ b/harbour/contrib/hbnf/anomatch.prg @@ -24,27 +24,24 @@ * */ +#include "common.ch" + #define FORCE_BETWEEN(x,y,z) (y := MAX(MIN(y,z),x)) -#command DEFAULT TO [, TO ] ; - => ; - := iif( == NIL,,) ; - [; := iif( == NIL,,)] - -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 diff --git a/harbour/contrib/hbnf/any2any.prg b/harbour/contrib/hbnf/any2any.prg index 0d9c5e3d4a..9c12936980 100644 --- a/harbour/contrib/hbnf/any2any.prg +++ b/harbour/contrib/hbnf/any2any.prg @@ -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 TO [, TO ] ; - => ; - := iif( == NIL,,) ; - [; := iif( == NIL,,)] +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 diff --git a/harbour/contrib/hbnf/aredit.prg b/harbour/contrib/hbnf/aredit.prg index 2a398e7820..f2cc5194a6 100644 --- a/harbour/contrib/hbnf/aredit.prg +++ b/harbour/contrib/hbnf/aredit.prg @@ -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, = Delete Row, = Add Row" - @ 22,7 SAY " = Quit Array Edit, or 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, = Delete Row, = Add Row" + @ 22, 7 SAY " = Quit Array Edit, or 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] ) diff --git a/harbour/contrib/hbnf/asum.prg b/harbour/contrib/hbnf/asum.prg index 18e52770e3..8402925498 100644 --- a/harbour/contrib/hbnf/asum.prg +++ b/harbour/contrib/hbnf/asum.prg @@ -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 TO [, TO ] ; - => ; - := iif( == NIL,,) ; - [; := iif( == NIL,,)] - -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 diff --git a/harbour/contrib/hbnf/at2.prg b/harbour/contrib/hbnf/at2.prg index 503e81f16d..fecaa93e19 100644 --- a/harbour/contrib/hbnf/at2.prg +++ b/harbour/contrib/hbnf/at2.prg @@ -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 diff --git a/harbour/contrib/hbnf/bitclr.prg b/harbour/contrib/hbnf/bitclr.prg index 07f1fbbf3b..b471c6dca1 100644 --- a/harbour/contrib/hbnf/bitclr.prg +++ b/harbour/contrib/hbnf/bitclr.prg @@ -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 diff --git a/harbour/contrib/hbnf/bitset.prg b/harbour/contrib/hbnf/bitset.prg index fde21fd3e4..17280c7322 100644 --- a/harbour/contrib/hbnf/bitset.prg +++ b/harbour/contrib/hbnf/bitset.prg @@ -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 diff --git a/harbour/contrib/hbnf/blink.prg b/harbour/contrib/hbnf/blink.prg index 2e26a91299..578804cbfe 100644 --- a/harbour/contrib/hbnf/blink.prg +++ b/harbour/contrib/hbnf/blink.prg @@ -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 diff --git a/harbour/contrib/hbnf/byt2bit.prg b/harbour/contrib/hbnf/byt2bit.prg index 81391d8695..60d98db45d 100644 --- a/harbour/contrib/hbnf/byt2bit.prg +++ b/harbour/contrib/hbnf/byt2bit.prg @@ -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 diff --git a/harbour/contrib/hbnf/byt2hex.prg b/harbour/contrib/hbnf/byt2hex.prg index eb0d6f8184..4ecb07a04d 100644 --- a/harbour/contrib/hbnf/byt2hex.prg +++ b/harbour/contrib/hbnf/byt2hex.prg @@ -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 diff --git a/harbour/contrib/hbnf/byteand.prg b/harbour/contrib/hbnf/byteand.prg index 232be62308..23d6b57251 100644 --- a/harbour/contrib/hbnf/byteand.prg +++ b/harbour/contrib/hbnf/byteand.prg @@ -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 diff --git a/harbour/contrib/hbnf/byteneg.prg b/harbour/contrib/hbnf/byteneg.prg index c2c8fedd0b..27295a2a91 100644 --- a/harbour/contrib/hbnf/byteneg.prg +++ b/harbour/contrib/hbnf/byteneg.prg @@ -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 ) ) diff --git a/harbour/contrib/hbnf/bytenot.prg b/harbour/contrib/hbnf/bytenot.prg index 1fe9b699c2..c6c4f0f56a 100644 --- a/harbour/contrib/hbnf/bytenot.prg +++ b/harbour/contrib/hbnf/bytenot.prg @@ -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 diff --git a/harbour/contrib/hbnf/byteor.prg b/harbour/contrib/hbnf/byteor.prg index da3c11c54d..93fda89570 100644 --- a/harbour/contrib/hbnf/byteor.prg +++ b/harbour/contrib/hbnf/byteor.prg @@ -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 diff --git a/harbour/contrib/hbnf/bytexor.prg b/harbour/contrib/hbnf/bytexor.prg index fc85d02f7d..0b275e21ce 100644 --- a/harbour/contrib/hbnf/bytexor.prg +++ b/harbour/contrib/hbnf/bytexor.prg @@ -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 diff --git a/harbour/contrib/hbnf/calendar.prg b/harbour/contrib/hbnf/calendar.prg index e4034f7dcb..e044187cd0 100644 --- a/harbour/contrib/hbnf/calendar.prg +++ b/harbour/contrib/hbnf/calendar.prg @@ -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 ) ) diff --git a/harbour/contrib/hbnf/clrsel.prg b/harbour/contrib/hbnf/clrsel.prg index 1746a17996..8c699ebea3 100644 --- a/harbour/contrib/hbnf/clrsel.prg +++ b/harbour/contrib/hbnf/clrsel.prg @@ -51,10 +51,11 @@ * */ -*------------------------------------------------ +//------------------------------------------------ // Pre-processor stuff #include "box.ch" +#include "common.ch" #include "setcurs.ch" #include "inkey.ch" @@ -64,22 +65,18 @@ #define C_CHAR 4 #translate Single( , , , ) =>; - @ , , , BOX B_SINGLE + @ < t > , < l > , < b > , < r > BOX B_SINGLE #translate Double( , , , ) =>; - @ , , , BOX B_DOUBLE + @ < t > , < l > , < b > , < r > BOX B_DOUBLE #translate ClearS( , , , ) =>; - @ , CLEAR TO , + @ < t > , < l > CLEAR TO < b > , < r > #translate BkGrnd( , , , , ) =>; - DispBox( , , , , REPLICATE(,9) ) + DispBox( < t > , < l > , < b > , < r > , Replicate( < c > ,9 ) ) -#command DEFAULT

TO [, TO ] =>; -

:= iif(

== Nil, ,

); ; - [ := iif( == Nil, , ) ] - -*------------------------------------------------ +//------------------------------------------------ // Demo of FT_ClrSel() /* @@ -100,589 +97,613 @@ PROCEDURE Main( cVidMode ) - LOCAL nRowDos := ROW() - LOCAL nColDos := COL() - LOCAL lBlink := SETBLINK( .F. ) // make sure it starts out .F. - LOCAL aEnvDos := FT_SaveSets() - LOCAL cScrDos := SAVESCREEN( 00, 00, MAXROW(), MAXCOL() ) - LOCAL lColour := .F. - LOCAL aClrs := {} + LOCAL nRowDos := Row() + LOCAL nColDos := Col() + LOCAL lBlink := SetBlink( .F. ) // make sure it starts out .F. + LOCAL aEnvDos := FT_SaveSets() + LOCAL cScrDos := SaveScreen( 00, 00, MaxRow(), MaxCol() ) + LOCAL lColour := .F. + LOCAL aClrs := {} - DEFAULT cVidMode TO "" - NOSNOW( ( "NOSNOW" $ UPPER( cVidMode ) ) ) - IF "VGA" $ UPPER( cVidMode ) - SETMODE( 50, 80 ) - ENDIF - IF "EGA" $ UPPER( cVidMode ) - SETMODE( 43, 80 ) - ENDIF - lColour := iif( "MONO" $ UPPER( cVidMode ), .F., IsColor() ) + DEFAULT cVidMode TO "" + NoSnow( ( "NOSNOW" $ Upper( cVidMode ) ) ) + IF "VGA" $ Upper( cVidMode ) + SetMode( 50, 80 ) + ENDIF + IF "EGA" $ Upper( cVidMode ) + SetMode( 43, 80 ) + ENDIF + lColour := iif( "MONO" $ Upper( cVidMode ), .F. , IsColor() ) - SET SCOREBOARD Off - SETCURSOR( SC_NONE ) - lBlink := SETBLINK( .F. ) + SET SCOREBOARD OFF + SetCursor( SC_NONE ) + lBlink := SetBlink( .F. ) - *.... a typical application might have the following different settings - * normally these would be stored in a .dbf/.dbv - aClrs := {; - { "Desktop", "N/BG", "D", hb_UTF8ToStr( "▒" ) }, ; - { "Title", "N/W", "T" }, ; - { "Top Menu", "N/BG,N/W,W+/BG,W+/N,GR+/N", "M" }, ; - { "Sub Menu", "W+/N*,GR+/N*,GR+/N*,W+/R,G+/R","M" }, ; - { "Standard Gets", "W/B, W+/N,,, W/N", "G" }, ; - { "Nested Gets", "N/BG, W+/N,,, W/N", "G" }, ; - { "Help", "N/G, W+/N,,, W/N", "W" }, ; - { "Error Messages", "W+/R*,N/GR*,,,N/R*", "W" }, ; - { "Database Query", "N/BG, N/GR*,,,N+/BG", "B" }, ; - { "Pick List", "N/GR*,W+/B,,, BG/GR*", "A" } ; - } +//.... a typical application might have the following different settings +// normally these would be stored in a .dbf/.dbv + aClrs := { ; + { "Desktop", "N/BG", "D", hb_UTF8ToStr( "▒" ) }, ; + { "Title", "N/W", "T" }, ; + { "Top Menu", "N/BG,N/W,W+/BG,W+/N,GR+/N", "M" }, ; + { "Sub Menu", "W+/N*,GR+/N*,GR+/N*,W+/R,G+/R", "M" }, ; + { "Standard Gets", "W/B, W+/N,,, W/N", "G" }, ; + { "Nested Gets", "N/BG, W+/N,,, W/N", "G" }, ; + { "Help", "N/G, W+/N,,, W/N", "W" }, ; + { "Error Messages", "W+/R*,N/GR*,,,N/R*", "W" }, ; + { "Database Query", "N/BG, N/GR*,,,N+/BG", "B" }, ; + { "Pick List", "N/GR*,W+/B,,, BG/GR*", "A" } ; + } - aClrs := FT_ClrSel( aClrs, lColour ) + aClrs := FT_ClrSel( aClrs, lColour ) - *.... restore the DOS environment - FT_RestSets( aEnvDos ) - RESTSCREEN( 00, 00, MAXROW(), MAXCOL(), cScrDos ) - SETPOS( nRowDos, nColDos ) - SETBLINK( .F. ) // doesn't appear to be reset from FT_RestSets +//.... restore the DOS environment + FT_RestSets( aEnvDos ) + RestScreen( 00, 00, MaxRow(), MaxCol(), cScrDos ) + SetPos( nRowDos, nColDos ) + SetBlink( .F. ) // doesn't appear to be reset from FT_RestSets - RETURN + RETURN #endif -*------------------------------------------------ +//------------------------------------------------ + FUNCTION FT_ClrSel( aClrs, lColour, cChr ) + // Colour selection routine // Return -> the same array that was passed but with modified colours -LOCAL aClrOld := aClone( aClrs ) -LOCAL aOptions -LOCAL nB, nT, nL, nR -LOCAL nChoice := 1 -LOCAL nLen := 0 -LOCAL aPrompt := {} -LOCAL aClrPal -LOCAL aClrTab := { "N","B","G","BG","R","RB","GR","W" } -LOCAL aClrBW := { "N","B","W" } -LOCAL nRowSav := ROW() -LOCAL nColSav := COL() -LOCAL aEnvSav := FT_SaveSets() -LOCAL cScrSav := SAVESCREEN( 00, 00, MAXROW(), MAXCOL() ) + LOCAL aClrOld := AClone( aClrs ) + LOCAL aOptions + LOCAL nB, nT, nL, nR + LOCAL nChoice := 1 + LOCAL nLen := 0 + LOCAL aPrompt := {} + LOCAL aClrPal + LOCAL aClrTab := { "N", "B", "G", "BG", "R", "RB", "GR", "W" } + LOCAL aClrBW := { "N", "B", "W" } + LOCAL nRowSav := Row() + LOCAL nColSav := Col() + LOCAL aEnvSav := FT_SaveSets() + LOCAL cScrSav := SaveScreen( 00, 00, MaxRow(), MaxCol() ) -DEFAULT lColour TO IsColor() -DEFAULT cChr TO chr(254)+chr(254) -cChr := PadR( cChr, 2 ) + DEFAULT lColour TO IsColor() + DEFAULT cChr TO Chr( 254 ) + Chr( 254 ) + cChr := PadR( cChr, 2 ) -SETCURSOR( SC_NONE ) -SETCOLOR( iif( lColour, "GR+/N,,N/N", "W+/N,,N/N" ) ) -CLS + SetCursor( SC_NONE ) + SetColor( iif( lColour, "GR+/N,,N/N", "W+/N,,N/N" ) ) + CLS -*.... initialize the colour palette -aClrPal := _ftInitPal( iif( lColour, aClrTab, aClrBW ) ) +//.... initialize the colour palette + aClrPal := _ftInitPal( iif( lColour, aClrTab, aClrBW ) ) -*.... paint the colours on the screen -_ftShowPal( aClrPal, cChr ) +//.... paint the colours on the screen + _ftShowPal( aClrPal, cChr ) -*.... Determine length of longest name and make sure not greater than 20 -aEval( aClrs, { |aOpt| nLen := MAX( nLen, LEN( aOpt[C_NAME] ) ) } ) -nLen := MIN( MAX( nLen, 1 ), 20 ) + 2 +//.... Determine length of longest name and make sure not greater than 20 + AEval( aClrs, { |aOpt| nLen := Max( nLen, Len( aOpt[C_NAME] ) ) } ) + nLen := Min( Max( nLen, 1 ), 20 ) + 2 -*.... prepare an array for use with aChoice(); truncate names at 20 chrs. -aPrompt := ARRAY( LEN( aClrs ) ) -aEval( aClrs,; - { |aOpt,nE| aPrompt[nE] := " "+ SUBS(aOpt[C_NAME], 1, nLen-2) +" " }; - ) +//.... prepare an array for use with aChoice(); truncate names at 20 chrs. + aPrompt := Array( Len( aClrs ) ) + AEval( aClrs, ; + { |aOpt, nE| aPrompt[nE] := " " + SUBS( aOpt[C_NAME], 1, nLen - 2 ) + " " }; + ) -*.... determine co-ordinates for the achoice window -nT := MAX( INT( (18-LEN(aPrompt)) /2 )-1, 1 ) -nB := MIN( nT + LEN(aPrompt) + 1, 17 ) -nL := MAX( INT( (27-nLen) /2 )-2, 1 ) -nR := MIN( nL + nLen + 3, 26 ) +//.... determine co-ordinates for the achoice window + nT := Max( Int( (18 - Len(aPrompt ) ) /2 ) - 1, 1 ) + nB := Min( nT + Len( aPrompt ) + 1, 17 ) + nL := Max( Int( (27 - nLen ) /2 ) - 2, 1 ) + nR := Min( nL + nLen + 3, 26 ) -*.... set up the window for aChoice -SETCOLOR( iif( lColour, "N/W,W+/R", "N/W,W+/N" ) ) -ClearS( nT, nL, nB, nR ) +//.... set up the window for aChoice + SetColor( iif( lColour, "N/W,W+/R", "N/W,W+/N" ) ) + ClearS( nT, nL, nB, nR ) -*.... prompt for colour setting and modify -DO WHILE nChoice != 0 - Double( nT, nL+1, nB, nR-1 ) - nChoice := aChoice( nt+1, nL+2, nB-1, nR-2, aPrompt, , , nChoice ) - IF nChoice != 0 - _ftHiLite( ROW(), nL+2, aPrompt[ nChoice ], nLen ) - Single( nT, nL+1, nB, nR-1 ) - aClrs[ nChoice ] := _ftColours( aClrs[ nChoice ], aClrPal, lColour ) - ENDIF -ENDDO +//.... prompt for colour setting and modify + DO WHILE nChoice != 0 + Double( nT, nL + 1, nB, nR - 1 ) + nChoice := AChoice( nt + 1, nL + 2, nB - 1, nR - 2, aPrompt, , , nChoice ) + IF nChoice != 0 + _ftHiLite( Row(), nL + 2, aPrompt[ nChoice ], nLen ) + Single( nT, nL + 1, nB, nR - 1 ) + aClrs[ nChoice ] := _ftColours( aClrs[ nChoice ], aClrPal, lColour ) + ENDIF + ENDDO -aOptions := { "Save New Colours", "Restore Original" } -IF ! _ftIdentArr( aClrs, aClrOld ) - nChoice := ALERT( "Colors have been modified...", aOptions ) -ELSE - nChoice := 1 -ENDIF + aOptions := { "Save New Colours", "Restore Original" } + IF ! _ftIdentArr( aClrs, aClrOld ) + nChoice := Alert( "Colors have been modified...", aOptions ) + ELSE + nChoice := 1 + ENDIF -FT_RestSets( aEnvSav ) -RESTSCREEN( 00, 00, MAXROW(), MAXCOL(), cScrSav ) -SETPOS( nRowSav, nColSav ) + FT_RestSets( aEnvSav ) + RestScreen( 00, 00, MaxRow(), MaxCol(), cScrSav ) + SetPos( nRowSav, nColSav ) -RETURN iif( nChoice == 1, aClrs, aClrOld ) + RETURN iif( nChoice == 1, aClrs, aClrOld ) + +//------------------------------------------------ -*------------------------------------------------ STATIC FUNCTION _ftHiLite( nRow, nCol, cStr, nLen ) + // Highlight the current selected aChoice element // Return -> Nil -LOCAL cClr := SETCOLOR() -LOCAL aClr := _ftChr2Arr( cClr ) + LOCAL cClr := SetColor() + LOCAL aClr := _ftChr2Arr( cClr ) -SETCOLOR( aClr[ 2 ] ) // enhanced colour -@ nRow, nCol SAY PadR( cStr, nLen ) -SETCOLOR( cClr ) + SetColor( aClr[ 2 ] ) // enhanced colour + @ nRow, nCol SAY PadR( cStr, nLen ) + SetColor( cClr ) -RETURN Nil + RETURN Nil + +//------------------------------------------------ -*------------------------------------------------ STATIC FUNCTION _ftColours( aOpt, aClrPal, lColour ) + // Colour selection for specific type of colour setting // Return -> aOpt with modified colour strings -LOCAL nB, nT, nL, nR -LOCAL nX -LOCAL aClrs := {} -LOCAL cClr -LOCAL nChoice := 1 -LOCAL aPrompt -LOCAL nLen := 0 -LOCAL cColour := SETCOLOR() -LOCAL cScrSav := SAVESCREEN( 18, 00, MAXROW(), MAXCOL() ) + LOCAL nB, nT, nL, nR + LOCAL nX + LOCAL aClrs := {} + LOCAL cClr + LOCAL nChoice := 1 + LOCAL aPrompt + LOCAL nLen := 0 + LOCAL cColour := SetColor() + LOCAL cScrSav := SaveScreen( 18, 00, MaxRow(), MaxCol() ) -aSize( aOpt, 4 ) // check incoming parameters -DEFAULT aOpt[ C_CHAR ] TO "" -DEFAULT aOpt[ C_TYPE ] TO "W" -aOpt[ C_CLR ] := UPPER( aOpt[ C_CLR ] ) // need upper case -aOpt[ C_TYPE ] := UPPER( aOpt[ C_TYPE ] ) + ASize( aOpt, 4 ) // check incoming parameters + DEFAULT aOpt[ C_CHAR ] TO "" + DEFAULT aOpt[ C_TYPE ] TO "W" + aOpt[ C_CLR ] := Upper( aOpt[ C_CLR ] ) // need upper case + aOpt[ C_TYPE ] := Upper( aOpt[ C_TYPE ] ) -DEFAULT lColour TO IsColor() + DEFAULT lColour TO IsColor() -*.... display appropriate prompts based on type of colour setting -nChoice := 1 -DO CASE +//.... display appropriate prompts based on type of colour setting + nChoice := 1 + DO CASE CASE aOpt[ C_TYPE ] == "D" - aPrompt := { " Color ", " Character " } + aPrompt := { " Color ", " Character " } CASE aOpt[ C_TYPE ] == "M" - aPrompt := { " Prompt ", " Message ", " HotKey ",; - " LightBar ", " LightBar HotKey " } + aPrompt := { " Prompt ", " Message ", " HotKey ", ; + " LightBar ", " LightBar HotKey " } CASE aOpt[ C_TYPE ] == "A" .OR. aOpt[ C_TYPE ] == "B" - aPrompt := { " Standard ", " Selected ", " Border ", " Unavailable " } + aPrompt := { " Standard ", " Selected ", " Border ", " Unavailable " } OTHERWISE - aPrompt := { " Standard ", " Selected ", " Border ", " Unselected " } -ENDCASE + aPrompt := { " Standard ", " Selected ", " Border ", " Unselected " } + ENDCASE -IF !( aOpt[ C_TYPE ] == "T" ) // no prompt for titles - *.... we need to know top,left,bottom,right for the prompt window - aEval( aPrompt, { |cPrompt| nLen := MAX( nLen, LEN( cPrompt ) ) } ) - nLen := MAX( nLen, LEN( aOpt[ C_NAME ] ) + 2 ) - nT := iif( aOpt[ C_TYPE ] == "M", 18, 19 ) - nB := nT + LEN(aPrompt) + 1 - nL := MAX( INT( (27-nLen) /2 )-2, 1 ) - nR := MIN( nL + nLen + 3, 26 ) + IF !( aOpt[ C_TYPE ] == "T" ) // no prompt for titles + //.... we need to know top,left,bottom,right for the prompt window + AEval( aPrompt, { |cPrompt| nLen := Max( nLen, Len( cPrompt ) ) } ) + nLen := Max( nLen, Len( aOpt[ C_NAME ] ) + 2 ) + nT := iif( aOpt[ C_TYPE ] == "M", 18, 19 ) + nB := nT + Len( aPrompt ) + 1 + nL := Max( Int( (27 - nLen ) /2 ) - 2, 1 ) + nR := Min( nL + nLen + 3, 26 ) - *.... set up the window for prompt - SETCOLOR( "N/W" ) - ClearS( nT, nL, nB, nR ) -ENDIF + //.... set up the window for prompt + SetColor( "N/W" ) + ClearS( nT, nL, nB, nR ) + ENDIF -DO WHILE .T. + DO WHILE .T. - *.... show sample window - _ftShowIt( aOpt ) + //.... show sample window + _ftShowIt( aOpt ) - IF !( aOpt[ C_TYPE ] == "T" ) // no prompt for titles - SETCOLOR( iif( lColour, "N/W,W+/R,,,N/W", "N/W,W+/N,,,N/W" ) ) - Double( nT, nL+1, nB, nR-1 ) - @ nT, nL+2 SAY PadC( " "+ aOpt[C_NAME] +" ", nR -nL -3, hb_UTF8ToStr( "═" ) ) - FOR nX := 1 TO LEN( aPrompt ) - @ nX+nT, nL+2 PROMPT PadR( aPrompt[nX], nR -nL -3 ) - NEXT - MENU TO nChoice + IF !( aOpt[ C_TYPE ] == "T" ) // no prompt for titles + SetColor( iif( lColour, "N/W,W+/R,,,N/W", "N/W,W+/N,,,N/W" ) ) + Double( nT, nL + 1, nB, nR - 1 ) + @ nT, nL + 2 SAY PadC( " " + aOpt[C_NAME] + " ", nR - nL - 3, hb_UTF8ToStr( "═" ) ) + FOR nX := 1 TO Len( aPrompt ) + @ nX + nT, nL + 2 PROMPT PadR( aPrompt[nX], nR - nL - 3 ) + NEXT + MENU TO nChoice - DO CASE - CASE nChoice == 0 + DO CASE + CASE nChoice == 0 + EXIT + CASE nChoice == 2 .AND. aOpt[ C_TYPE ] == "D" + //.... desktop character + aOpt := _ftDeskChar( aOpt ) + LOOP + CASE nChoice == 4 .AND. !( aOpt[ C_TYPE ] == "M" ) + nChoice := 5 // 4th color param is unused + ENDCASE + ENDIF + + //.... get the specific colour combination + aClrs := _ftChr2Arr( aOpt[ C_CLR ] ) // place color string in an array + ASize( aClrs, 5 ) // make sure there are 5 settings + //.... empty elements are made Nil so they can be defaulted + AEval( aClrs, { |v, e| aClrs[e] := iif( Empty(v ), Nil, AllTrim(v ) ) } ) + DEFAULT aClrs[1] TO "W/N" + DEFAULT aClrs[2] TO "N/W" // place default colours into + DEFAULT aClrs[3] TO "N/N" // elements which are empty + DEFAULT aClrs[4] TO "N/N" + DEFAULT aClrs[5] TO "N/W" + cClr := aClrs[ nChoice ] // selected colour + + //.... allow change to specific part of colour string + IF !( aOpt[ C_TYPE ] == "T" ) + Single( nT, nL + 1, nB, nR - 1 ) + @ nT, nL + 2 SAY PadC( " " + aOpt[C_NAME] + " ", nR - nL - 3, hb_UTF8ToStr( "─" ) ) + ENDIF + cClr := _ftClrSel( aClrPal, cClr, nChoice, aOpt ) // selection routine + aClrs[ nChoice ] := cClr // put colour back in array + aOpt[ C_CLR ] := _ftArr2Chr( aClrs ) // convert array to colour string + + IF aOpt[ C_TYPE ] == "T" EXIT - CASE nChoice == 2 .AND. aOpt[ C_TYPE ] == "D" - *.... desktop character - aOpt := _ftDeskChar( aOpt ) - LOOP - CASE nChoice == 4 .AND. !( aOpt[ C_TYPE ] == "M" ) - nChoice := 5 // 4th color param is unused - ENDCASE - ENDIF + ENDIF - *.... get the specific colour combination - aClrs := _ftChr2Arr( aOpt[ C_CLR ] ) // place color string in an array - aSize( aClrs, 5 ) // make sure there are 5 settings - *.... empty elements are made Nil so they can be defaulted - aEval( aClrs, { |v,e| aClrs[e] := iif( EMPTY(v), Nil, ALLTRIM(v) ) } ) - DEFAULT aClrs[1] TO "W/N" - DEFAULT aClrs[2] TO "N/W" // place default colours into - DEFAULT aClrs[3] TO "N/N" // elements which are empty - DEFAULT aClrs[4] TO "N/N" - DEFAULT aClrs[5] TO "N/W" - cClr := aClrs[ nChoice ] // selected colour + ENDDO - *.... allow change to specific part of colour string - IF !( aOpt[ C_TYPE ] == "T" ) - Single( nT, nL+1, nB, nR-1 ) - @ nT, nL+2 SAY PadC( " "+ aOpt[C_NAME] +" ", nR -nL -3, hb_UTF8ToStr( "─" ) ) - ENDIF - cClr := _ftClrSel( aClrPal, cClr, nChoice, aOpt ) // selection routine - aClrs[ nChoice ] := cClr // put colour back in array - aOpt[ C_CLR ] := _ftArr2Chr( aClrs ) // convert array to colour string +//.... restore the lower 1/2 of screen, and colour + RestScreen( 18, 00, MaxRow(), MaxCol(), cScrSav ) + SetColor( cColour ) - IF aOpt[ C_TYPE ] == "T" - EXIT - ENDIF + RETURN aOpt -ENDDO +//------------------------------------------------ -*.... restore the lower 1/2 of screen, and colour -RESTSCREEN( 18, 00, MAXROW(), MAXCOL(), cScrSav ) -SETCOLOR( cColour ) - -RETURN aOpt - -*------------------------------------------------ STATIC FUNCTION _ftShowIt( aOpt ) + // Show an example of the colour setting // Return -> Nil -LOCAL aClr := _ftChr2Arr( aOpt[ C_CLR ] ) + LOCAL aClr := _ftChr2Arr( aOpt[ C_CLR ] ) -IF !( aOpt[ C_TYPE ] == "M" ) // no borders in menu colour selection - SETCOLOR( aOpt[ C_CLR ] ) // this will set the border on VGA -ENDIF + IF !( aOpt[ C_TYPE ] == "M" ) // no borders in menu colour selection + SetColor( aOpt[ C_CLR ] ) // this will set the border on VGA + ENDIF -DispBegin() -DO CASE + DispBegin() + DO CASE CASE aOpt[ C_TYPE ] == "D" // Desktop Background - SETCOLOR( aClr[1] ) - BkGrnd( 19, 43, 22, 64, aOpt[ C_CHAR ] ) + SetColor( aClr[1] ) + BkGrnd( 19, 43, 22, 64, aOpt[ C_CHAR ] ) CASE aOpt[ C_TYPE ] == "T" // Title - SETCOLOR( aClr[1] ) - @ 20,08 SAY PadC( "This is an example of how the text shall look", 63 ) + SetColor( aClr[1] ) + @ 20, 08 SAY PadC( "This is an example of how the text shall look", 63 ) CASE aOpt[ C_TYPE ] == "M" // Menus - SETCOLOR( "W/N" ) - BkGrnd( 19, 41, 23, 66, CHR(177) ) - SETCOLOR( aClr[1] ) - Single( 19, 43, 22, 60 ) - @ 18,41 SAY " Report Inquiry Quit " - @ 21,44 SAY " eXit " - SETCOLOR( aClr[4] ) - @ 18,43 SAY " Report " - @ 20,44 SAY " Product List " - SETCOLOR( aClr[3] ) - @ 18,52 SAY "I" - @ 18,61 SAY "Q" - @ 21,46 SAY "X" - SETCOLOR( aClr[5] ) - @ 18,44 SAY "R" - @ 20,45 SAY "P" - SETCOLOR( aClr[2] ) - @ 24,41 SAY PadC( "Inventory Report", 26 ) + SetColor( "W/N" ) + BkGrnd( 19, 41, 23, 66, Chr( 177 ) ) + SetColor( aClr[1] ) + Single( 19, 43, 22, 60 ) + @ 18, 41 SAY " Report Inquiry Quit " + @ 21, 44 SAY " eXit " + SetColor( aClr[4] ) + @ 18, 43 SAY " Report " + @ 20, 44 SAY " Product List " + SetColor( aClr[3] ) + @ 18, 52 SAY "I" + @ 18, 61 SAY "Q" + @ 21, 46 SAY "X" + SetColor( aClr[5] ) + @ 18, 44 SAY "R" + @ 20, 45 SAY "P" + SetColor( aClr[2] ) + @ 24, 41 SAY PadC( "Inventory Report", 26 ) CASE aOpt[ C_TYPE ] == "G" // Get windows - SETCOLOR( aClr[1] ) - ClearS( 19, 41, 24, 66 ) - Single( 19, 42, 24, 65 ) - @ 20,43 SAY " Invoice Entry " - @ 21,42 SAY hb_UTF8ToStr( "├──────────────────────┤" ) - @ 22,43 SAY " Amount " - @ 23,43 SAY " Date " - SETCOLOR( aClr[2] ) - @ 22,53 SAY " 199.95" - SETCOLOR( aClr[5] ) - @ 23,53 SAY "09/15/91" + SetColor( aClr[1] ) + ClearS( 19, 41, 24, 66 ) + Single( 19, 42, 24, 65 ) + @ 20, 43 SAY " Invoice Entry " + @ 21, 42 SAY hb_UTF8ToStr( "├──────────────────────┤" ) + @ 22, 43 SAY " Amount " + @ 23, 43 SAY " Date " + SetColor( aClr[2] ) + @ 22, 53 SAY " 199.95" + SetColor( aClr[5] ) + @ 23, 53 SAY "09/15/91" CASE aOpt[ C_TYPE ] == "W" // Alert windows - SETCOLOR( aClr[1] ) - ClearS( 18, 40, 24, 66 ) - Single( 18, 41, 24, 65 ) - @ 19,42 SAY " " - @ 20,42 SAY " Test Message " - @ 21,42 SAY " " - @ 22,41 SAY hb_UTF8ToStr( "├───────────────────────┤" ) - SETCOLOR( aClr[2] ) - @ 23,44 SAY " Accept " - SETCOLOR( aClr[5] ) - @ 23,55 SAY " Reject " + SetColor( aClr[1] ) + ClearS( 18, 40, 24, 66 ) + Single( 18, 41, 24, 65 ) + @ 19, 42 SAY " " + @ 20, 42 SAY " Test Message " + @ 21, 42 SAY " " + @ 22, 41 SAY hb_UTF8ToStr( "├───────────────────────┤" ) + SetColor( aClr[2] ) + @ 23, 44 SAY " Accept " + SetColor( aClr[5] ) + @ 23, 55 SAY " Reject " CASE aOpt[ C_TYPE ] == "B" // browse windows - SETCOLOR( aClr[1] ) - ClearS( 18, 37, 24, 70 ) - Single( 18, 38, 24, 69 ) - @ 19,39 SAY " Cust Name Amount " - @ 20,38 SAY hb_UTF8ToStr( "╞══════╤══════════════╤════════╡" ) - @ 21,39 SAY hb_UTF8ToStr( " 312 │ Rick Shaw │ 143.25 " ) - @ 23,39 SAY hb_UTF8ToStr( " │ │ " ) - @ 24,38 SAY hb_UTF8ToStr( "╘══════╧══════════════╧════════╛" ) - SETCOLOR( aClr[2] ) - @ 22,39 SAY hb_UTF8ToStr( " 1005 │ Harry Pitts │ 78.95 " ) - SETCOLOR( aClr[5] ) - @ 23,39 SAY " 3162 " - @ 23,46 SAY " Barb Wire " - @ 23,61 SAY " 345.06 " + SetColor( aClr[1] ) + ClearS( 18, 37, 24, 70 ) + Single( 18, 38, 24, 69 ) + @ 19, 39 SAY " Cust Name Amount " + @ 20, 38 SAY hb_UTF8ToStr( "╞══════╤══════════════╤════════╡" ) + @ 21, 39 SAY hb_UTF8ToStr( " 312 │ Rick Shaw │ 143.25 " ) + @ 23, 39 SAY hb_UTF8ToStr( " │ │ " ) + @ 24, 38 SAY hb_UTF8ToStr( "╘══════╧══════════════╧════════╛" ) + SetColor( aClr[2] ) + @ 22, 39 SAY hb_UTF8ToStr( " 1005 │ Harry Pitts │ 78.95 " ) + SetColor( aClr[5] ) + @ 23, 39 SAY " 3162 " + @ 23, 46 SAY " Barb Wire " + @ 23, 61 SAY " 345.06 " CASE aOpt[ C_TYPE ] == "A" // achoice type window - SETCOLOR( aClr[1] ) - ClearS( 18, 42, 24, 64 ) - Single( 18, 43, 24, 63 ) - @ 19,44 SAY " Daily Reports " - @ 21,44 SAY " Quarterly Reports " - @ 23,44 SAY " Exit ... " - SETCOLOR( aClr[2] ) - @ 20,44 SAY " Monthend Reports " - SETCOLOR( aClr[5] ) - @ 22,44 SAY " Yearend Reports " + SetColor( aClr[1] ) + ClearS( 18, 42, 24, 64 ) + Single( 18, 43, 24, 63 ) + @ 19, 44 SAY " Daily Reports " + @ 21, 44 SAY " Quarterly Reports " + @ 23, 44 SAY " Exit ... " + SetColor( aClr[2] ) + @ 20, 44 SAY " Monthend Reports " + SetColor( aClr[5] ) + @ 22, 44 SAY " Yearend Reports " -ENDCASE -DispEnd() + ENDCASE + DispEnd() -RETURN Nil + RETURN Nil + +//------------------------------------------------ -*------------------------------------------------ STATIC FUNCTION _ftClrSel( aClrPal, cClr, nElem, aOpt ) + // select the colour combination from aClrPal and place in cClr // cClr is the current colour being modified // Return -> selected colour combination -LOCAL nR -LOCAL nC := 1 -LOCAL lFound := .F. -LOCAL nKey -LOCAL nDim := LEN( aClrPal ) -LOCAL nTop := 0 -LOCAL nLeft := 28 -LOCAL nBottom := nTop + nDim + 1 -LOCAL nRight := nLeft + ( nDim * 3 ) + 2 + LOCAL nR + LOCAL nC := 1 + LOCAL lFound := .F. + LOCAL nKey + LOCAL nDim := Len( aClrPal ) + LOCAL nTop := 0 + LOCAL nLeft := 28 + LOCAL nBottom := nTop + nDim + 1 + LOCAL nRight := nLeft + ( nDim * 3 ) + 2 -SETCOLOR( "GR+/N" ) -Double( nTop, nLeft, nBottom, nRight ) + SetColor( "GR+/N" ) + Double( nTop, nLeft, nBottom, nRight ) -SETCOLOR ( "W+/N" ) + SetColor( "W+/N" ) -*.... find the starting row and column for the current colour -FOR nR := 1 TO nDim - FOR nC := 1 TO nDim - IF aClrPal[ nR, nC ] == ALLTRIM( cClr ) - lFound := .T. ; EXIT - ENDIF - NEXT - IF lFound ; EXIT ; ENDIF -NEXT +//.... find the starting row and column for the current colour + FOR nR := 1 TO nDim + FOR nC := 1 TO nDim + IF aClrPal[ nR, nC ] == AllTrim( cClr ) + lFound := .T. ; EXIT + ENDIF + NEXT + IF lFound ; EXIT ; ENDIF + NEXT -IF ! lFound - nR := 1 // black background - nC := iif( nDim == 5, 3, 8 ) // white foreground -ENDIF + IF ! lFound + nR := 1 // black background + nC := iif( nDim == 5, 3, 8 ) // white foreground + ENDIF -DO WHILE .T. + DO WHILE .T. - *.... make sure array boundary not exceeded - nR := iif( nR > nDim, 1, iif( nR == 0, nDim, nR ) ) - nC := iif( nC > nDim, 1, iif( nC == 0, nDim, nC ) ) + //.... make sure array boundary not exceeded + nR := iif( nR > nDim, 1, iif( nR == 0, nDim, nR ) ) + nC := iif( nC > nDim, 1, iif( nC == 0, nDim, nC ) ) - *.... place selected colour in the appropriate spot in clr string - aOpt[ C_CLR ] := _ftClrPut( aOpt[ C_CLR ], nElem, aClrPal[ nR, nC ] ) + //.... place selected colour in the appropriate spot in clr string + aOpt[ C_CLR ] := _ftClrPut( aOpt[ C_CLR ], nElem, aClrPal[ nR, nC ] ) - *.... show sample window - _ftShowIt( aOpt ) + //.... show sample window + _ftShowIt( aOpt ) - *.... highlight the colour palette element - SETCOLOR ( "W+/N" ) - @ nR, nC*3+26 SAY "" - @ nR, nC*3+29 SAY "" - nKey := INKEY(0) - @ nR, nC*3+26 SAY " " - @ nR, nC*3+29 SAY " " + //.... highlight the colour palette element + SetColor( "W+/N" ) + @ nR, nC * 3 + 26 SAY "" + @ nR, nC * 3 + 29 SAY "" + nKey := Inkey( 0 ) + @ nR, nC * 3 + 26 SAY " " + @ nR, nC * 3 + 29 SAY " " - *.... check key movement and modify co-ordinates - DO CASE - CASE nKey == K_ESC ; EXIT - CASE nKey == K_ENTER ; cClr := aClrPal[ nR, nC ] ; EXIT - CASE nKey == K_UP ; --nR - CASE nKey == K_DOWN ; ++nR - CASE nKey == K_LEFT ; --nC - CASE nKey == K_RIGHT ; ++nC - ENDCASE + //.... check key movement and modify co-ordinates + DO CASE + CASE nKey == K_ESC ; EXIT + CASE nKey == K_ENTER ; cClr := aClrPal[ nR, nC ] ; EXIT + CASE nKey == K_UP ; --nR + CASE nKey == K_DOWN ; ++nR + CASE nKey == K_LEFT ; --nC + CASE nKey == K_RIGHT ; ++nC + ENDCASE -ENDDO + ENDDO -SETCOLOR( "GR+/N" ) -Single( nTop, nLeft, nBottom, nRight ) + SetColor( "GR+/N" ) + Single( nTop, nLeft, nBottom, nRight ) -RETURN cClr + RETURN cClr + +//------------------------------------------------ -*------------------------------------------------ STATIC FUNCTION _ftClrPut( cClrStr, nElem, cClr ) + // Place a colour setting in the colour string // Return -> modified colour string -LOCAL aClr := _ftChr2Arr( cClrStr ) + LOCAL aClr := _ftChr2Arr( cClrStr ) -aClr[ nElem ] := cClr + aClr[ nElem ] := cClr -RETURN _ftArr2Chr( aClr ) + RETURN _ftArr2Chr( aClr ) + +//------------------------------------------------ -*------------------------------------------------ STATIC FUNCTION _ftDeskChar( aOpt ) + // Select the character to be used for the desktop background // Return -> same array with new character -LOCAL aChar := { CHR(32), CHR(176), CHR(177), CHR(178) } -LOCAL cChar := aOpt[ C_CHAR ] -LOCAL cClr := aOpt[ C_CLR ] -LOCAL nElem := aScan( aChar, cChar ) -LOCAL n, nKey + LOCAL aChar := { Chr( 32 ), Chr( 176 ), Chr( 177 ), Chr( 178 ) } + LOCAL cChar := aOpt[ C_CHAR ] + LOCAL cClr := aOpt[ C_CLR ] + LOCAL nElem := AScan( aChar, cChar ) + LOCAL n, nKey -IF nElem == 0 // this allows another character to be selected - aAdd( aChar, cChar ) // but there is the possibility that it will - nElem := 5 // not be available if they ever select another -ENDIF // char and store it. It's up to you to put it in + IF nElem == 0 // this allows another character to be selected + AAdd( aChar, cChar ) // but there is the possibility that it will + nElem := 5 // not be available if they ever select another + ENDIF // char and store it. It's up to you to put it in -*.... draw the choices on the screen -SETCOLOR ( cClr ) -FOR n := 1 TO LEN( aChar ) - @ n+18, 29 SAY REPL( aChar[n], 10 ) -NEXT +//.... draw the choices on the screen + SetColor( cClr ) + FOR n := 1 TO Len( aChar ) + @ n + 18, 29 SAY REPL( aChar[n], 10 ) + NEXT -n := nElem + 18 -DO WHILE .T. - *.... make sure boundary not exeeded - n := iif( n > Len(aChar)+18, 19, iif( n < 19, Len(aChar)+18, n ) ) + n := nElem + 18 + DO WHILE .T. + //.... make sure boundary not exeeded + n := iif( n > Len( aChar ) + 18, 19, iif( n < 19, Len(aChar ) + 18, n ) ) - *.... show sample window - aOpt[ C_CHAR ] := aChar[ n-18 ] // place in array - _ftShowIt( aOpt ) + //.... show sample window + aOpt[ C_CHAR ] := aChar[ n-18 ] // place in array + _ftShowIt( aOpt ) - SETCOLOR ( "W+/N" ) - @ n, 28 SAY "" - @ n, 39 SAY "" - nKey := INKEY(0) - @ n, 28 SAY " " - @ n, 39 SAY " " + SetColor( "W+/N" ) + @ n, 28 SAY "" + @ n, 39 SAY "" + nKey := Inkey( 0 ) + @ n, 28 SAY " " + @ n, 39 SAY " " - *.... check key movement and modify co-ordinates - DO CASE - CASE nKey == K_ESC ; aOpt[ C_CHAR ] := cChar ; EXIT - CASE nKey == K_ENTER ; EXIT - CASE nKey == K_UP ; --n - CASE nKey == K_DOWN ; ++n - ENDCASE + //.... check key movement and modify co-ordinates + DO CASE + CASE nKey == K_ESC ; aOpt[ C_CHAR ] := cChar ; EXIT + CASE nKey == K_ENTER ; EXIT + CASE nKey == K_UP ; --n + CASE nKey == K_DOWN ; ++n + ENDCASE -ENDDO + ENDDO -SETCOLOR ( "W+/N" ) -ClearS( 18, 28, 23, 39 ) + SetColor( "W+/N" ) + ClearS( 18, 28, 23, 39 ) -RETURN aOpt + RETURN aOpt + +//------------------------------------------------ -*------------------------------------------------ STATIC FUNCTION _ftChr2Arr( cString, cDelim ) + // Convert a chr string to an array // Return -> array -LOCAL n, aArray := {} + LOCAL n, aArray := {} -DEFAULT cDelim TO "," -DEFAULT cString TO "" // this should really be passed -cString += cDelim + DEFAULT cDelim TO "," + DEFAULT cString TO "" // this should really be passed + cString += cDelim -DO WHILE .T. - IF EMPTY( cString ) ; EXIT ; ENDIF - n := AT( cDelim, cString ) - AADD( aArray, iif( n == 1, "", LEFT( cString, n - 1 ) ) ) - cString := SUBS( cString, n + 1 ) -ENDDO + DO WHILE .T. + IF Empty( cString ) ; EXIT ; ENDIF + n := At( cDelim, cString ) + AAdd( aArray, iif( n == 1, "", Left( cString, n - 1 ) ) ) + cString := SUBS( cString, n + 1 ) + ENDDO -RETURN aArray + RETURN aArray + +//------------------------------------------------ -*------------------------------------------------ STATIC FUNCTION _ftArr2Chr( aArray, cDelim ) + // convert an array to a chr string // Return -> string -LOCAL cString := "" + LOCAL cString := "" -DEFAULT aArray TO {} -DEFAULT cDelim TO "," + DEFAULT aArray TO {} + DEFAULT cDelim TO "," -AEVAL( aArray, { |v,e| cString += iif( e == 1, v, cDelim + v ) } ) + AEval( aArray, { |v, e| cString += iif( e == 1, v, cDelim + v ) } ) -RETURN cString + RETURN cString + +//------------------------------------------------ -*------------------------------------------------ STATIC FUNCTION _ftShowPal( aClrPal, cChr ) + // Paint the palette on the screen // Return -> Nil -LOCAL nF,nB -LOCAL nTop := 0 -LOCAL nLeft := 28 -LOCAL nBottom := nTop + LEN( aClrPal ) + 1 -LOCAL nRight := nLeft + ( LEN( aClrPal )*3 ) + 2 + LOCAL nF, nB + LOCAL nTop := 0 + LOCAL nLeft := 28 + LOCAL nBottom := nTop + Len( aClrPal ) + 1 + LOCAL nRight := nLeft + ( Len( aClrPal ) * 3 ) + 2 -*.... Buffer the screen output -DispBegin() -Single( nTop, nLeft, nBottom, nRight ) -FOR nF := 1 TO LEN( aClrPal ) - FOR nB := 1 TO LEN( aClrPal[ nF ] ) - SETCOLOR( aClrPal[ nF, nB ] ) - @ nF, nB*3+27 SAY cChr - NEXT -NEXT -DispEnd() +//.... Buffer the screen output + DispBegin() + Single( nTop, nLeft, nBottom, nRight ) + FOR nF := 1 TO Len( aClrPal ) + FOR nB := 1 TO Len( aClrPal[ nF ] ) + SetColor( aClrPal[ nF, nB ] ) + @ nF, nB * 3 + 27 SAY cChr + NEXT + NEXT + DispEnd() -RETURN Nil + RETURN Nil + +//------------------------------------------------ -*------------------------------------------------ STATIC FUNCTION _ftInitPal( aClrTab ) + // Initialise the colour palette based on the passed colour table aClrTab // Load the palette with colours // Return -> Colour pallette array -LOCAL nF,nB -LOCAL nDim := LEN( aClrTab ) -LOCAL aClrPal := ARRAY( nDim*2, nDim*2 ) + LOCAL nF, nB + LOCAL nDim := Len( aClrTab ) + LOCAL aClrPal := Array( nDim * 2, nDim * 2 ) -FOR nF := 1 TO nDim*2 - FOR nB := 1 TO nDim*2 - aClrPal[ nF, nB ] :=; - iif( nF <= nDim, aClrTab[ nF ], aClrTab[ nF-nDim ] +"+" ) +"/"+; - iif( nB <= nDim, aClrTab[ nB ], aClrTab[ nB-nDim ] +"*" ) - NEXT -NEXT + FOR nF := 1 TO nDim * 2 + FOR nB := 1 TO nDim * 2 + aClrPal[ nF, nB ] := ; + iif( nF <= nDim, aClrTab[ nF ], aClrTab[ nF-nDim ] + "+" ) + "/" + ; + iif( nB <= nDim, aClrTab[ nB ], aClrTab[ nB-nDim ] + "*" ) + NEXT + NEXT -RETURN aClrPal + RETURN aClrPal + +//------------------------------------------------ -*------------------------------------------------ STATIC FUNCTION _ftIdentArr( aArr1, aArr2 ) + // Compares the contents of 2 arrays // Return -> logical -LOCAL lIdentical := LEN(aArr1) == LEN(aArr2) -LOCAL n := 1 + LOCAL lIdentical := Len( aArr1 ) == Len( aArr2 ) + LOCAL n := 1 -DO WHILE lIdentical .AND. n <= LEN(aArr1) - IF VALTYPE( aArr1[n] ) == VALTYPE( aArr2[n] ) - lIdentical := iif( VALTYPE( aArr1[n] ) == "A", ; - _ftIdentArr( aArr1[n], aArr2[n] ), ; - aArr1[n] == aArr2[n] ) - ELSE - lIdentical := .f. - ENDIF - n++ -ENDDO + DO WHILE lIdentical .AND. n <= Len( aArr1 ) + IF ValType( aArr1[n] ) == ValType( aArr2[n] ) + lIdentical := iif( ValType( aArr1[n] ) == "A", ; + _ftIdentArr( aArr1[n], aArr2[n] ), ; + aArr1[n] == aArr2[n] ) + ELSE + lIdentical := .F. + ENDIF + n++ + ENDDO -RETURN lIdentical + RETURN lIdentical diff --git a/harbour/contrib/hbnf/cntryset.prg b/harbour/contrib/hbnf/cntryset.prg index f5bb8f04ac..5d2bf3ba51 100644 --- a/harbour/contrib/hbnf/cntryset.prg +++ b/harbour/contrib/hbnf/cntryset.prg @@ -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 diff --git a/harbour/contrib/hbnf/d2e.prg b/harbour/contrib/hbnf/d2e.prg index b91780ca1c..62c93622ad 100644 --- a/harbour/contrib/hbnf/d2e.prg +++ b/harbour/contrib/hbnf/d2e.prg @@ -24,35 +24,43 @@ * */ +#include "common.ch" + #define log10( num ) log( num ) / log( 10 ) #define DEFAULT_PRECISION 6 -#command DEFAULT

TO =>

:= iif(

== NIL, ,

) #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 ) ) diff --git a/harbour/contrib/hbnf/datecnfg.prg b/harbour/contrib/hbnf/datecnfg.prg index cfcdba1c07..712467adc1 100644 --- a/harbour/contrib/hbnf/datecnfg.prg +++ b/harbour/contrib/hbnf/datecnfg.prg @@ -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 ) diff --git a/harbour/contrib/hbnf/dayofyr.prg b/harbour/contrib/hbnf/dayofyr.prg index 0a8ece8ec8..9fcc0be348 100644 --- a/harbour/contrib/hbnf/dayofyr.prg +++ b/harbour/contrib/hbnf/dayofyr.prg @@ -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 diff --git a/harbour/contrib/hbnf/daytobow.prg b/harbour/contrib/hbnf/daytobow.prg index 488bcfc25f..d1311ee61c 100644 --- a/harbour/contrib/hbnf/daytobow.prg +++ b/harbour/contrib/hbnf/daytobow.prg @@ -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 diff --git a/harbour/contrib/hbnf/dectobin.prg b/harbour/contrib/hbnf/dectobin.prg index 351ebc7054..b21f853179 100644 --- a/harbour/contrib/hbnf/dectobin.prg +++ b/harbour/contrib/hbnf/dectobin.prg @@ -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 ] diff --git a/harbour/contrib/hbnf/dfile.prg b/harbour/contrib/hbnf/dfile.prg index 519becaf82..0fb9ee5a9a 100644 --- a/harbour/contrib/hbnf/dfile.prg +++ b/harbour/contrib/hbnf/dfile.prg @@ -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 diff --git a/harbour/contrib/hbnf/diskfunc.prg b/harbour/contrib/hbnf/diskfunc.prg index f0ffed0220..a963a391a3 100644 --- a/harbour/contrib/hbnf/diskfunc.prg +++ b/harbour/contrib/hbnf/diskfunc.prg @@ -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 ) diff --git a/harbour/contrib/hbnf/dispmsg.prg b/harbour/contrib/hbnf/dispmsg.prg index bce4dc80d5..21e63e78f0 100644 --- a/harbour/contrib/hbnf/dispmsg.prg +++ b/harbour/contrib/hbnf/dispmsg.prg @@ -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 diff --git a/harbour/contrib/hbnf/dosver.prg b/harbour/contrib/hbnf/dosver.prg index 63f83ee06c..f78a31b67f 100644 --- a/harbour/contrib/hbnf/dosver.prg +++ b/harbour/contrib/hbnf/dosver.prg @@ -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 diff --git a/harbour/contrib/hbnf/e2d.prg b/harbour/contrib/hbnf/e2d.prg index 075b22c6a6..0bfc9a9125 100644 --- a/harbour/contrib/hbnf/e2d.prg +++ b/harbour/contrib/hbnf/e2d.prg @@ -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 diff --git a/harbour/contrib/hbnf/easter.prg b/harbour/contrib/hbnf/easter.prg index 3913f1a7e7..43ef5351e4 100644 --- a/harbour/contrib/hbnf/easter.prg +++ b/harbour/contrib/hbnf/easter.prg @@ -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 - * <> is Golden number of the year in the 19 year Metonic cycle - nGold := nYear % 19 + 1 + IF ValType( nYear ) == "N" + IF nYear > 1582 - * <> is Century - nCent := INT (nYear / 100) + 1 + // <> is Golden number of the year in the 19 year Metonic cycle + nGold := nYear % 19 + 1 - * Corrections: - * <> 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) + // <> is Century + nCent := Int( nYear / 100 ) + 1 - * <> is a special correction to synchronize Easter with the moon's - * orbit. - nCorz := INT ((8 * nCent + 5) / 25 - 5) + // Corrections: + // <> 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 ) - * <> Find Sunday - nSunday := INT ((5 * nYear) / 4 - nCorx - 10) + // <> is a special correction to synchronize Easter with the moon's + // orbit. + nCorz := Int( ( 8 * nCent + 5 ) / 25 - 5 ) - * Set Epact <> (specifies occurance of a full moon) - nEpact := INT ((11 * nGold + 20 + nCorz - nCorx) % 30) + // <> Find Sunday + nSunday := Int( ( 5 * nYear ) / 4 - nCorx - 10 ) - IF nEpact < 0 - nEpact += 30 - ENDIF + // Set Epact <> (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 <>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 <>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" ) ) diff --git a/harbour/contrib/hbnf/elapmil.prg b/harbour/contrib/hbnf/elapmil.prg index 3c66267cdc..1ef13a2e02 100644 --- a/harbour/contrib/hbnf/elapmil.prg +++ b/harbour/contrib/hbnf/elapmil.prg @@ -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 ) ) ) ) diff --git a/harbour/contrib/hbnf/elapsed.prg b/harbour/contrib/hbnf/elapsed.prg index 434653bc17..03bfb6956d 100644 --- a/harbour/contrib/hbnf/elapsed.prg +++ b/harbour/contrib/hbnf/elapsed.prg @@ -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 diff --git a/harbour/contrib/hbnf/eltime.prg b/harbour/contrib/hbnf/eltime.prg index 923c9e5c01..e85ba59bcc 100644 --- a/harbour/contrib/hbnf/eltime.prg +++ b/harbour/contrib/hbnf/eltime.prg @@ -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 ) diff --git a/harbour/contrib/hbnf/findith.prg b/harbour/contrib/hbnf/findith.prg index 7b0652f61e..225a91cbc8 100644 --- a/harbour/contrib/hbnf/findith.prg +++ b/harbour/contrib/hbnf/findith.prg @@ -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 ) ) ) ) diff --git a/harbour/contrib/hbnf/firstday.prg b/harbour/contrib/hbnf/firstday.prg index 39863f592d..45d3211919 100644 --- a/harbour/contrib/hbnf/firstday.prg +++ b/harbour/contrib/hbnf/firstday.prg @@ -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 ) diff --git a/harbour/contrib/hbnf/floptst.prg b/harbour/contrib/hbnf/floptst.prg index 8ed023b417..178550ac2e 100644 --- a/harbour/contrib/hbnf/floptst.prg +++ b/harbour/contrib/hbnf/floptst.prg @@ -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 diff --git a/harbour/contrib/hbnf/ftround.prg b/harbour/contrib/hbnf/ftround.prg index 52336a8c80..a6974fda51 100644 --- a/harbour/contrib/hbnf/ftround.prg +++ b/harbour/contrib/hbnf/ftround.prg @@ -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 TO [, TO ] ; - => ; - := iif( == NIL,,) ; - [; := iif( == NIL,,)] +FUNCTION FT_ROUND( nNumber, nRoundToAmount, cRoundType, cRoundDirection, ; + nAcceptableError ) -#command DEFAULT TO IF NOT ; - [, TO IF NOT ] ; - => ; - := iif(VALTYPE() == ,,) ; - [; := iif(VALTYPE() == ,,)] + 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 diff --git a/harbour/contrib/hbnf/gcd.prg b/harbour/contrib/hbnf/gcd.prg index 718a5bc77c..a0a95b2489 100644 --- a/harbour/contrib/hbnf/gcd.prg +++ b/harbour/contrib/hbnf/gcd.prg @@ -24,43 +24,43 @@ * */ -#command REPEAT ; - => ; - DO WHILE .T. - -#command UNTIL ; - => ; - IF ; 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 diff --git a/harbour/contrib/hbnf/hex2dec.prg b/harbour/contrib/hbnf/hex2dec.prg index fec1fad4fc..c0359a0271 100644 --- a/harbour/contrib/hbnf/hex2dec.prg +++ b/harbour/contrib/hbnf/hex2dec.prg @@ -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 diff --git a/harbour/contrib/hbnf/invclr.prg b/harbour/contrib/hbnf/invclr.prg index 05cbf16515..c2619e1e32 100644 --- a/harbour/contrib/hbnf/invclr.prg +++ b/harbour/contrib/hbnf/invclr.prg @@ -24,30 +24,27 @@ * */ -#command DEFAULT TO [, TO ] ; - => ; - := iif( == NIL,,) ; - [; := iif( == NIL,,)] +#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, "+" ), "*" ) diff --git a/harbour/contrib/hbnf/isbit.prg b/harbour/contrib/hbnf/isbit.prg index 6766c533b1..9ff3fe0bcc 100644 --- a/harbour/contrib/hbnf/isbit.prg +++ b/harbour/contrib/hbnf/isbit.prg @@ -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 diff --git a/harbour/contrib/hbnf/isbiton.prg b/harbour/contrib/hbnf/isbiton.prg index fbb1fd1399..ff26fd6696 100644 --- a/harbour/contrib/hbnf/isbiton.prg +++ b/harbour/contrib/hbnf/isbiton.prg @@ -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 ) diff --git a/harbour/contrib/hbnf/isshare.prg b/harbour/contrib/hbnf/isshare.prg index e6688b10d7..37de5fd7a4 100644 --- a/harbour/contrib/hbnf/isshare.prg +++ b/harbour/contrib/hbnf/isshare.prg @@ -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() diff --git a/harbour/contrib/hbnf/lastday.prg b/harbour/contrib/hbnf/lastday.prg index c46b84c57f..8d6b488ed2 100644 --- a/harbour/contrib/hbnf/lastday.prg +++ b/harbour/contrib/hbnf/lastday.prg @@ -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 ) diff --git a/harbour/contrib/hbnf/linked.prg b/harbour/contrib/hbnf/linked.prg index 4dbb54a655..c81cc36adb 100644 --- a/harbour/contrib/hbnf/linked.prg +++ b/harbour/contrib/hbnf/linked.prg @@ -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 diff --git a/harbour/contrib/hbnf/madd.prg b/harbour/contrib/hbnf/madd.prg index 633db49320..adc8e91569 100644 --- a/harbour/contrib/hbnf/madd.prg +++ b/harbour/contrib/hbnf/madd.prg @@ -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 diff --git a/harbour/contrib/hbnf/menu1.prg b/harbour/contrib/hbnf/menu1.prg index 6aece5fb51..a0727b497f 100644 --- a/harbour/contrib/hbnf/menu1.prg +++ b/harbour/contrib/hbnf/menu1.prg @@ -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 diff --git a/harbour/contrib/hbnf/menutonf.prg b/harbour/contrib/hbnf/menutonf.prg index b26372b42b..343979e842 100644 --- a/harbour/contrib/hbnf/menutonf.prg +++ b/harbour/contrib/hbnf/menutonf.prg @@ -37,20 +37,17 @@ #include "setcurs.ch" #include "inkey.ch" -#xcommand if then => ; - if ; ; end - #xtranslate display( , , , ) => ; - setpos( , ) ; dispout( , ) + SetPos( < row > , < col > ) ; DispOut( < stuff > , < color > ) #xtranslate EnhColor( ) => ; - substr( , at( ",", ) + 1 ) + SubStr( < colorspec > , At( ",", < colorspec > ) + 1 ) #xtranslate isOkay( ) => ; - ( \> 0 .and. \<= nCount ) + ( < exp > \ > 0 .AND. < exp > \ <= nCount ) #xtranslate isBetween( , , ) => ; - ( \>= .and. \<= ) + ( < 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 diff --git a/harbour/contrib/hbnf/metaph.prg b/harbour/contrib/hbnf/metaph.prg index 77f84b2545..3f6411dab7 100644 --- a/harbour/contrib/hbnf/metaph.prg +++ b/harbour/contrib/hbnf/metaph.prg @@ -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 diff --git a/harbour/contrib/hbnf/miltime.prg b/harbour/contrib/hbnf/miltime.prg index 7224d8332d..1f7e454b55 100644 --- a/harbour/contrib/hbnf/miltime.prg +++ b/harbour/contrib/hbnf/miltime.prg @@ -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 ) diff --git a/harbour/contrib/hbnf/min2dhm.prg b/harbour/contrib/hbnf/min2dhm.prg index efd0c1a243..60353c66a6 100644 --- a/harbour/contrib/hbnf/min2dhm.prg +++ b/harbour/contrib/hbnf/min2dhm.prg @@ -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_ diff --git a/harbour/contrib/hbnf/month.prg b/harbour/contrib/hbnf/month.prg index 95be7bfef2..236066b2f5 100644 --- a/harbour/contrib/hbnf/month.prg +++ b/harbour/contrib/hbnf/month.prg @@ -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 diff --git a/harbour/contrib/hbnf/mouse1.prg b/harbour/contrib/hbnf/mouse1.prg index ec3fc030e1..821e325b9e 100644 --- a/harbour/contrib/hbnf/mouse1.prg +++ b/harbour/contrib/hbnf/mouse1.prg @@ -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 diff --git a/harbour/contrib/hbnf/mouse2.prg b/harbour/contrib/hbnf/mouse2.prg index 1b60baf658..75557fc727 100644 --- a/harbour/contrib/hbnf/mouse2.prg +++ b/harbour/contrib/hbnf/mouse2.prg @@ -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 diff --git a/harbour/contrib/hbnf/netpv.prg b/harbour/contrib/hbnf/netpv.prg index 16379d98dd..78c09c0e32 100644 --- a/harbour/contrib/hbnf/netpv.prg +++ b/harbour/contrib/hbnf/netpv.prg @@ -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 diff --git a/harbour/contrib/hbnf/nooccur.prg b/harbour/contrib/hbnf/nooccur.prg index 0ad7cd3091..969b9d2c43 100644 --- a/harbour/contrib/hbnf/nooccur.prg +++ b/harbour/contrib/hbnf/nooccur.prg @@ -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 ) ) ) diff --git a/harbour/contrib/hbnf/ntow.prg b/harbour/contrib/hbnf/ntow.prg index 075bbb9253..2fc5cdd08a 100644 --- a/harbour/contrib/hbnf/ntow.prg +++ b/harbour/contrib/hbnf/ntow.prg @@ -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 diff --git a/harbour/contrib/hbnf/nwlstat.prg b/harbour/contrib/hbnf/nwlstat.prg index 269f98caef..d5208319f9 100644 --- a/harbour/contrib/hbnf/nwlstat.prg +++ b/harbour/contrib/hbnf/nwlstat.prg @@ -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 diff --git a/harbour/contrib/hbnf/nwsem.prg b/harbour/contrib/hbnf/nwsem.prg index a8d931d0c1..4a6b23eaa7 100644 --- a/harbour/contrib/hbnf/nwsem.prg +++ b/harbour/contrib/hbnf/nwsem.prg @@ -37,13 +37,11 @@ // Semaphore Package for Novell NetWare // -------------------------------------------------------------- +#include "common.ch" #include "ftint86.ch" #define INT21 33 -#xcommand DEFAULT TO [, TO ]; - => iif(()==NIL,:=,NIL) [; iif(()==NIL,:=,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 diff --git a/harbour/contrib/hbnf/nwuid.prg b/harbour/contrib/hbnf/nwuid.prg index d3f7262cc4..8dd70c03fe 100644 --- a/harbour/contrib/hbnf/nwuid.prg +++ b/harbour/contrib/hbnf/nwuid.prg @@ -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 ) ) ) diff --git a/harbour/contrib/hbnf/ontick.prg b/harbour/contrib/hbnf/ontick.prg index 0cabff9d52..f7fd23e51a 100644 --- a/harbour/contrib/hbnf/ontick.prg +++ b/harbour/contrib/hbnf/ontick.prg @@ -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 diff --git a/harbour/contrib/hbnf/page.prg b/harbour/contrib/hbnf/page.prg index 0e8c13f4bd..4186aae3db 100644 --- a/harbour/contrib/hbnf/page.prg +++ b/harbour/contrib/hbnf/page.prg @@ -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() diff --git a/harbour/contrib/hbnf/pchr.prg b/harbour/contrib/hbnf/pchr.prg index b29740fb8f..947dafd890 100644 --- a/harbour/contrib/hbnf/pchr.prg +++ b/harbour/contrib/hbnf/pchr.prg @@ -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 diff --git a/harbour/contrib/hbnf/pegs.prg b/harbour/contrib/hbnf/pegs.prg index db756e90b9..53dc639f3f 100644 --- a/harbour/contrib/hbnf/pegs.prg +++ b/harbour/contrib/hbnf/pegs.prg @@ -33,10 +33,10 @@ #include "setcurs.ch" #translate SINGLEBOX(, , , ) => ; - @ , , , BOX hb_UTF8ToStr( "┌─┐│┘─└│ " ) + @ < top > , < left > , < bottom > , < right > BOX hb_UTF8ToStr( "┌─┐│┘─└│ " ) #translate DOUBLEBOX(, , , ) => ; - @ , , , 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() +//--------------------------------------------------------------------* diff --git a/harbour/contrib/hbnf/pending.prg b/harbour/contrib/hbnf/pending.prg index e9158afe20..0f3aa3eb6a 100644 --- a/harbour/contrib/hbnf/pending.prg +++ b/harbour/contrib/hbnf/pending.prg @@ -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 diff --git a/harbour/contrib/hbnf/pickday.prg b/harbour/contrib/hbnf/pickday.prg index 24d6d4e2b2..e7778bf14f 100644 --- a/harbour/contrib/hbnf/pickday.prg +++ b/harbour/contrib/hbnf/pickday.prg @@ -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] diff --git a/harbour/contrib/hbnf/popadder.prg b/harbour/contrib/hbnf/popadder.prg index 3a7c267229..a949a7bead 100644 --- a/harbour/contrib/hbnf/popadder.prg +++ b/harbour/contrib/hbnf/popadder.prg @@ -31,6 +31,7 @@ * */ +#include "common.ch" #include "inkey.ch" #include "setcurs.ch" #include "achoice.ch" @@ -67,28 +68,24 @@ #define CRLF CHR(13)+CHR(10) #define nTotTran LEN(aTrans) -#command DEFAULT

TO [, TO ] => ; -

:= iif(

== NIL, ,

) ; - [; := iif( == NIL, , )] - #command DISPMESSAGE ,,,, => ; - _ftPushKeys(); KEYBOARD CHR(K_CTRL_PGDN)+CHR(K_CTRL_W) ;; - MEMOEDIT(,,,,, .F., NIL, ()-()+1) ;; - _ftPopKeys() + _ftPushKeys(); KEYBOARD Chr( K_CTRL_PGDN ) + Chr( K_CTRL_W ) ;; + MemoEdit( < mess > , < t > , < l > , < b > , < r > , .F. , NIL, ( < r > ) - ( < l > ) + 1 ) ;; + _ftPopKeys() #define ASHRINK(ar) ASIZE(ar,LEN(ar)-1) -/* This INKEY UDC was posted by Don Caton on NanForum... Thanks Don */ + /* This INKEY UDC was posted by Don Caton on NanForum... Thanks Don */ #command FT_INKEY [ ] TO ; - => ; - WHILE (.T.) ;; - := Inkey([ ]) ;; - IF Setkey() # NIL ;; - Eval( Setkey(), ProcName(), ProcLine(), # ) ;; - ELSE ;; - EXIT ;; - END ;; - END + => ; + WHILE .T. ;; + < var > := Inkey( [ ] ) ;; + IF SetKey( < var > ) != NIL ;; + Eval( SetKey( < var > ), ProcName(), ProcLine(), #< var > ) ;; + ELSE ;; + EXIT ;; + END ;; + END // Instead of using STATIC variables for these I'm using a LOCAL array // and passing aAdder[] all over the place.... Don't let this confuse @@ -119,50 +116,51 @@ #define cTapeScr aAdder[23] // I still use a few of STATICS, but most are set to NIL when quiting... -THREAD STATIC lAdderOpen := .F., ; - aKeys, aWindow, nWinColor, aWinColor, aStdColor +THREAD STATIC lAdderOpen := .F. +THREAD STATIC aKeys, aWindow, nWinColor, aWinColor, aStdColor #ifdef FT_TEST - FUNCTION TEST +FUNCTION TEST - LOCAL nSickHrs := 0, ; - nPersHrs := 0, ; - nVacaHrs := 0, ; - GetList := {} + LOCAL nSickHrs := 0 + LOCAL nPersHrs := 0 + LOCAL nVacaHrs := 0 + LOCAL GetList := {} - SET SCOREBOARD OFF - _ftSetScrColor(STD_SCREEN,STD_VARIABLE) - CLS + SET SCOREBOARD OFF + _ftSetScrColor( STD_SCREEN, STD_VARIABLE ) + CLS - SET KEY K_ALT_A TO FT_Adder // Make call FT_Adder + SET KEY K_ALT_A TO FT_Adder // Make call FT_Adder - * SIMPLE Sample of program data entry! +// SIMPLE Sample of program data entry! - @ 12,5 SAY "Please enter the total Sick, Personal, and Vacation hours." - @ 15,22 SAY "Sick hrs." - @ 15,40 SAY "Pers. hrs." - @ 15,60 SAY "Vaca. hrs." - @ 23,20 SAY "Press to Pop - Up the Adder." - @ 24,20 SAY "Press to Quit the adder Demo." - DO WHILE .T. // Get the sick, personal, & vaca - @ 16,24 GET nSickHrs PICTURE "9999.999" // Normally I have a VALID() - @ 16,43 GET nPersHrs PICTURE "9999.999" // to make sure the value is - @ 16,63 GET nVacaHrs PICTURE "9999.999" // within the allowable range. + @ 12, 5 SAY "Please enter the total Sick, Personal, and Vacation hours." + @ 15, 22 SAY "Sick hrs." + @ 15, 40 SAY "Pers. hrs." + @ 15, 60 SAY "Vaca. hrs." + @ 23, 20 SAY "Press to Pop - Up the Adder." + @ 24, 20 SAY "Press to Quit the adder Demo." + DO WHILE .T. // Get the sick, personal, & vaca + @ 16, 24 GET nSickHrs PICTURE "9999.999" // Normally I have a VALID() + @ 16, 43 GET nPersHrs PICTURE "9999.999" // to make sure the value is + @ 16, 63 GET nVacaHrs PICTURE "9999.999" // within the allowable range. SET CURSOR ON // But, like I said it is a CLEAR TYPEAHEAD // SIMPLE example . READ SET CURSOR OFF - IF LASTKEY() == K_ESC // - ABORT - CLEAR TYPEAHEAD - EXIT + IF LastKey() == K_ESC // - ABORT + CLEAR TYPEAHEAD + EXIT ENDIF - ENDDO - SET CURSOR ON + ENDDO + SET CURSOR ON - SET KEY K_ALT_A // Reset + SET KEY K_ALT_A // Reset + + RETURN NIL - RETURN NIL #endif /*+- Function ---------------------------------------------------------------+ @@ -181,174 +179,175 @@ THREAD STATIC lAdderOpen := .F., ; | : at the top of your application | +--------------------------------------------------------------------------+ */ + FUNCTION FT_Adder() - LOCAL nOldDecim, cMoveTotSubTot, cTotal, lDone, nKey, ; - oGet := GetActive(), ; - nOldCurs := SETCURSOR(SC_NONE), ; - nOldRow := ROW(), ; - nOldCol := COL(), ; - bOldF10 := SETKEY(K_F10, NIL), ; - nOldLastKey := LASTKEY(), ; - lShowRight := .T., ; - aAdder := ARRAY(23) + LOCAL nOldDecim, cMoveTotSubTot, cTotal, lDone, nKey + LOCAL oGet := GetActive() + LOCAL nOldCurs := SetCursor( SC_NONE ) + LOCAL nOldRow := Row() + LOCAL nOldCol := Col() + LOCAL bOldF10 := SetKey( K_F10, NIL ) + LOCAL nOldLastKey := LastKey() + LOCAL lShowRight := .T. + LOCAL aAdder := Array( 23 ) - // Must prevent recursive calls - IF lAdderOpen - RETURN NIL - ELSE - lAdderOpen := .T. - ENDIF +// Must prevent recursive calls + IF lAdderOpen + RETURN NIL + ELSE + lAdderOpen := .T. + ENDIF - aTrans := {" 0.00 C "} - nOldDecim := SET(_SET_DECIMALS,9) - cTotPict := "999999999999999.99" - cTapeScr := "" - nTotal := nNumTotal := nSavTotal := nDecDigit := 0 - lDone := .F. // Loop flag - nKey := 0 - nMaxDeci := 2 // Initial # of decimals - nSavSubTot := 0 - lNewNum := .F. - nAddMode := 1 // Start in ADD mode - lMultDiv := .F. // Start in ADD mode - lClAdder := .F. // Clear adder flag - lDecSet := .F. // Decimal ? - keyboard routine - lSubRtn := lTotalOk := lTape := lAddError := lDivError := .F. + aTrans := { " 0.00 C " } + nOldDecim := Set( _SET_DECIMALS, 9 ) + cTotPict := "999999999999999.99" + cTapeScr := "" + nTotal := nNumTotal := nSavTotal := nDecDigit := 0 + lDone := .F. // Loop flag + nKey := 0 + nMaxDeci := 2 // Initial # of decimals + nSavSubTot := 0 + lNewNum := .F. + nAddMode := 1 // Start in ADD mode + lMultDiv := .F. // Start in ADD mode + lClAdder := .F. // Clear adder flag + lDecSet := .F. // Decimal ? - keyboard routine + lSubRtn := lTotalOk := lTape := lAddError := lDivError := .F. - nTopOS := INT((MAXROW()-24)/2) // Using the TopOffSet & LeftOffSet - nLeftOS := INT((MAXCOL()-79)/2) // the Adder will always be centered - nAddSpace := iif(lShowRight,40,0)+nLeftOS - nTapeSpace := iif(lShowRight,0,40)+nLeftOS + nTopOS := Int( ( MaxRow() - 24 ) / 2 ) // Using the TopOffSet & LeftOffSet + nLeftOS := Int( ( MaxCol() - 79 ) / 2 ) // the Adder will always be centered + nAddSpace := iif( lShowRight, 40, 0 ) + nLeftOS + nTapeSpace := iif( lShowRight, 0, 40 ) + nLeftOS - // Set Up the STATIC variables - aKeys := {} - aWindow := {} - nWinColor := 0 +// Set Up the STATIC variables + aKeys := {} + aWindow := {} + nWinColor := 0 - _ftAddScreen(aAdder) + _ftAddScreen( aAdder ) - // Set the decimals to 2 & display a cleared adder - _ftChangeDec(aAdder, 2) - @ 4+nTopOS, 7+nAddSpace SAY nTotal PICTURE cTotPict +// Set the decimals to 2 & display a cleared adder + _ftChangeDec( aAdder, 2 ) + @ 4 + nTopOS, 7 + nAddSpace SAY nTotal PICTURE cTotPict - DO WHILE ! lDone // Input key & test loop - FT_INKEY 0 TO nKey - DO CASE - CASE UPPER(CHR(nKey)) $"1234567890." - _ftProcessNumb(aAdder, nKey) + DO WHILE ! lDone // Input key & test loop + FT_INKEY 0 TO nKey + DO CASE + CASE Upper( Chr( nKey ) ) $ "1234567890." + _ftProcessNumb( aAdder, nKey ) CASE nKey == K_PLUS // <+> sign - _ftAddSub(aAdder, nKey) + _ftAddSub( aAdder, nKey ) CASE nKey == K_MINUS // <-> sign - _ftAddSub(aAdder, nKey) + _ftAddSub( aAdder, nKey ) CASE nKey == K_MULTIPLY // <*> sign - _ftMultDiv(aAdder, nKey) + _ftMultDiv( aAdder, nKey ) CASE nKey == K_DIVIDE // sign - _ftMultDiv(aAdder, nKey) + _ftMultDiv( aAdder, nKey ) CASE nKey == K_RETURN // Total or Subtotal - _ftAddTotal(aAdder) + _ftAddTotal( aAdder ) CASE nKey == K_ESC // Quit - SET(_SET_DECIMALS,nOldDecim) - SETCURSOR(nOldCurs) - IF lTape - RESTSCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,35+nTapeSpace,cTapeScr) - ENDIF - _ftPopWin() - SETPOS(nOldRow,nOldCol) - _ftSetLastKey(nOldLastKey) - SETKEY(K_F10, bOldF10) - lAdderOpen := .F. // Reset the recursive flag - lDone := .T. + SET( _SET_DECIMALS, nOldDecim ) + SetCursor( nOldCurs ) + IF lTape + RestScreen( 4 + nTopOS, 6 + nTapeSpace, 22 + nTopOS, 35 + nTapeSpace, cTapeScr ) + ENDIF + _ftPopWin() + SetPos( nOldRow, nOldCol ) + _ftSetLastKey( nOldLastKey ) + SetKey( K_F10, bOldF10 ) + lAdderOpen := .F. // Reset the recursive flag + lDone := .T. CASE nKey == 68 .OR. nKey == 100 // Change number of decimal places - _ftChangeDec(aAdder) + _ftChangeDec( aAdder ) CASE nKey == 84 .OR. nKey == 116 // Display Tape - _ftDisplayTape(aAdder, nKey) + _ftDisplayTape( aAdder, nKey ) CASE nKey == 77 .OR. nKey == 109 // Move Adder - IF lTape - RESTSCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,35+nTapeSpace,cTapeScr) - ENDIF - IF LEFT(SAVESCREEN(6+nTopOS,26+nAddSpace,6+nTopOS,27+nAddSpace),1) ; - != " " - IF LEFT(SAVESCREEN(6+nTopOS,19+nAddSpace,6+nTopOS,20+nAddSpace),1) ; - == "S" - cMoveTotSubTot := "S" - ELSE - cMoveTotSubTot := "T" - ENDIF - ELSE - cMoveTotSubTot := " " - ENDIF - cTotal := _ftCharOdd(SAVESCREEN( 4 + nTopOS, 8 + nAddSpace, 4 + ; - nTopOS,25+nAddSpace)) - _ftPopWin() // Remove Adder - lShowRight := !lShowRight - nAddSpace := iif(lShowRight,40,0)+nLeftOS - nTapeSpace := iif(lShowRight,0,40)+nLeftOS - _ftAddScreen(aAdder) - _ftDispTotal(aAdder) - IF lTape - lTape := .F. - _ftDisplayTape(aAdder, nKey) - ENDIF - @ 4+nTopOS, 8+nAddSpace SAY cTotal - IF !EMPTY(cMoveTotSubTot) - _ftSetWinColor(W_CURR,W_SCREEN) - @ 6+nTopOS,18+nAddSpace SAY iif(cMoveTotSubTot=="T", " ", ; - "") - _ftSetWinColor(W_CURR,W_PROMPT) - ENDIF - CASE (nKey == 83 .OR. nKey == 115) .AND. lTape // Scroll tape display - IF nTotTran>16 // We need to scroll - SETCOLOR("GR+/W") - @ 21+nTopOS,8+nTapeSpace SAY " "+CHR(24)+CHR(25)+"-SCROLL -QUIT " - SETCOLOR("N/W,W+/N") - ACHOICE(5+nTopOS,7+nTapeSpace,20+nTopOS,32+nTapeSpace,aTrans,.T., ; - "_ftAdderTapeUDF",nTotTran,20) - SETCOLOR("R+/W") - @ 21+nTopOS,8+nTapeSpace TO 21+nTopOS,30+nTapeSpace - _ftSetWinColor(W_CURR,W_PROMPT) - CLEAR TYPEAHEAD - ELSE - _ftError("there are " + iif(nTotTran > 0, "only " + ; - LTRIM(STR(nTotTran, 3, 0)), "no") + ; - " transactions entered so far." + ; - " No need to scroll!") - ENDIF - CASE nKey == 7 // Delete - Clear adder - _ftClearAdder(aAdder) - CASE nKey == K_F1 // Help - _ftAddHelp() - CASE nKey == K_F10 // Quit - Return total - IF lTotalOk // Did they finish the calculation - IF oGet != NIL .AND. oGet:TYPE == "N" - SET(_SET_DECIMALS,nOldDecim) - SETCURSOR(nOldCurs) - IF lTape - RESTSCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,35+nTapeSpace,cTapeScr) + IF lTape + RestScreen( 4 + nTopOS, 6 + nTapeSpace, 22 + nTopOS, 35 + nTapeSpace, cTapeScr ) + ENDIF + IF Left( SaveScreen( 6 + nTopOS,26 + nAddSpace,6 + nTopOS,27 + nAddSpace ), 1 ) ; + != " " + IF Left( SaveScreen( 6 + nTopOS,19 + nAddSpace,6 + nTopOS,20 + nAddSpace ), 1 ) ; + == "S" + cMoveTotSubTot := "S" + ELSE + cMoveTotSubTot := "T" ENDIF - _ftPopWin() - SETPOS(nOldRow,nOldCol) - _ftSetLastKey(nOldLastKey) - SETKEY(K_F10, bOldF10) - oGet:VARPUT(nSavTotal) - lAdderOpen := .F. // Reset the recursive flag - lDone := .T. - ELSE - _ftError("but I can not return the total from the "+ ; - "adder to this variable. You must quit the adder using"+ ; - " the key and then enter the total manually.") - ENDIF - ELSE - _ftError("the calculation is not finished yet! You must have"+ ; - " a TOTAL before you can return it to the program.") - ENDIF - ENDCASE - ENDDO (WHILE .T. Data entry from keyboard) + ELSE + cMoveTotSubTot := " " + ENDIF + cTotal := _ftCharOdd( SaveScreen( 4 + nTopOS, 8 + nAddSpace, 4 + ; + nTopOS, 25 + nAddSpace ) ) + _ftPopWin() // Remove Adder + lShowRight := !lShowRight + nAddSpace := iif( lShowRight, 40, 0 ) + nLeftOS + nTapeSpace := iif( lShowRight, 0, 40 ) + nLeftOS + _ftAddScreen( aAdder ) + _ftDispTotal( aAdder ) + IF lTape + lTape := .F. + _ftDisplayTape( aAdder, nKey ) + ENDIF + @ 4 + nTopOS, 8 + nAddSpace SAY cTotal + IF !Empty( cMoveTotSubTot ) + _ftSetWinColor( W_CURR, W_SCREEN ) + @ 6 + nTopOS, 18 + nAddSpace SAY iif( cMoveTotSubTot == "T", " ", ; + "" ) + _ftSetWinColor( W_CURR, W_PROMPT ) + ENDIF + CASE ( nKey == 83 .OR. nKey == 115 ) .AND. lTape // Scroll tape display + IF nTotTran > 16 // We need to scroll + SetColor( "GR+/W" ) + @ 21 + nTopOS, 8 + nTapeSpace SAY " " + Chr( 24 ) + Chr( 25 ) + "-SCROLL -QUIT " + SetColor( "N/W,W+/N" ) + AChoice( 5 + nTopOS, 7 + nTapeSpace, 20 + nTopOS, 32 + nTapeSpace, aTrans, .T. , ; + "_ftAdderTapeUDF", nTotTran, 20 ) + SetColor( "R+/W" ) + @ 21 + nTopOS, 8 + nTapeSpace TO 21 + nTopOS, 30 + nTapeSpace + _ftSetWinColor( W_CURR, W_PROMPT ) + CLEAR TYPEAHEAD + ELSE + _ftError( "there are " + iif( nTotTran > 0, "only " + ; + LTrim( Str( nTotTran, 3, 0 ) ), "no" ) + ; + " transactions entered so far." + ; + " No need to scroll!" ) + ENDIF + CASE nKey == 7 // Delete - Clear adder + _ftClearAdder( aAdder ) + CASE nKey == K_F1 // Help + _ftAddHelp() + CASE nKey == K_F10 // Quit - Return total + IF lTotalOk // Did they finish the calculation + IF oGet != NIL .AND. oGet:TYPE == "N" + SET( _SET_DECIMALS, nOldDecim ) + SetCursor( nOldCurs ) + IF lTape + RestScreen( 4 + nTopOS, 6 + nTapeSpace, 22 + nTopOS, 35 + nTapeSpace, cTapeScr ) + ENDIF + _ftPopWin() + SetPos( nOldRow, nOldCol ) + _ftSetLastKey( nOldLastKey ) + SetKey( K_F10, bOldF10 ) + oGet:VARPUT( nSavTotal ) + lAdderOpen := .F. // Reset the recursive flag + lDone := .T. + ELSE + _ftError( "but I can not return the total from the " + ; + "adder to this variable. You must quit the adder using" + ; + " the key and then enter the total manually." ) + ENDIF + ELSE + _ftError( "the calculation is not finished yet! You must have" + ; + " a TOTAL before you can return it to the program." ) + ENDIF + ENDCASE + ENDDO ( WHILE .T. DATA entry FROM keyboard ) // Reset the STATICS to NIL -aKeys := aWindow := aWinColor := aStdColor := NIL + aKeys := aWindow := aWinColor := aStdColor := NIL -RETURN NIL + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftAddScreen() Docs: Keith A. Wire | @@ -362,51 +361,55 @@ RETURN NIL | Return Value: NIL | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftAddScreen(aAdder) - LOCAL nCol - _ftPushWin(2+nTopOS,2+nAddSpace,22+nTopOS,30+nAddSpace," Adder ", ; - " for Help",,B_DOUBLE) - nCol := 5+nAddSpace - @ 7+nTopOS, nCol SAY hb_UTF8ToStr( ' ┌───┐ ┌───┐ ┌───┐' ) - @ 8+nTopOS, nCol SAY hb_UTF8ToStr( ' │ │ │ │ │ │' ) - @ 9+nTopOS, nCol SAY hb_UTF8ToStr( ' └───┘ └───┘ └───┘' ) - @ 10+nTopOS, nCol SAY hb_UTF8ToStr( '┌───┐ ┌───┐ ┌───┐ ┌───┐' ) - @ 11+nTopOS, nCol SAY hb_UTF8ToStr( '│ │ │ │ │ │ │ │' ) - @ 12+nTopOS, nCol SAY hb_UTF8ToStr( '└───┘ └───┘ └───┘ │ │' ) - @ 13+nTopOS, nCol SAY hb_UTF8ToStr( '┌───┐ ┌───┐ ┌───┐ │ │' ) - @ 14+nTopOS, nCol SAY hb_UTF8ToStr( '│ │ │ │ │ │ │ │' ) - @ 15+nTopOS, nCol SAY hb_UTF8ToStr( '└───┘ └───┘ └───┘ └───┘' ) - @ 16+nTopOS, nCol SAY hb_UTF8ToStr( '┌───┐ ┌───┐ ┌───┐ ┌───┐' ) - @ 17+nTopOS, nCol SAY hb_UTF8ToStr( '│ │ │ │ │ │ │ │' ) - @ 18+nTopOS, nCol SAY hb_UTF8ToStr( '└───┘ └───┘ └───┘ │ │' ) - @ 19+nTopOS, nCol SAY hb_UTF8ToStr( '┌─────────┐ ┌───┐ │ │' ) - @ 20+nTopOS, nCol SAY hb_UTF8ToStr( '│ │ │ │ │ │' ) - @ 21+nTopOS, nCol SAY hb_UTF8ToStr( '└─────────┘ └───┘ └───┘' ) - _ftSetWinColor(W_CURR,W_TITLE) - nCol := 7+nAddSpace - @ 11+nTopOS, nCol SAY "7" - @ 14+nTopOS, nCol SAY "4" - @ 17+nTopOS, nCol SAY "1" - nCol := 13+nAddSpace - @ 8+nTopOS,nCol SAY "/" - @ 11+nTopOS,nCol SAY "8" - @ 14+nTopOS,nCol SAY "5" - @ 17+nTopOS,nCol SAY "2" - nCol := 19+nAddSpace - @ 8+nTopOS,nCol SAY "X" - @ 11+nTopOS,nCol SAY "9" - @ 14+nTopOS,nCol SAY "6" - @ 17+nTopOS,nCol SAY "3" - @ 20+nTopOS,nCol SAY "." - @ 20+nTopOS,10+nAddSpace SAY "0" - nCol := 25+nAddSpace - @ 8+nTopOS,nCol SAY "-" - @ 13+nTopOS,nCol SAY "+" - @ 18+nTopOS,nCol SAY "=" - @ 19+nTopOS,nCol SAY "" - _ftSetWinColor(W_CURR,W_PROMPT) - @ 3+nTopOS, 6+nAddSpace, 5+nTopOS, 27+nAddSpace BOX B_DOUBLE -RETURN NIL + +STATIC FUNCTION _ftAddScreen( aAdder ) + + LOCAL nCol + + _ftPushWin( 2 + nTopOS, 2 + nAddSpace, 22 + nTopOS, 30 + nAddSpace, " Adder ", ; + " for Help", , B_DOUBLE ) + nCol := 5 + nAddSpace + @ 7 + nTopOS, nCol SAY hb_UTF8ToStr( ' ┌───┐ ┌───┐ ┌───┐' ) + @ 8 + nTopOS, nCol SAY hb_UTF8ToStr( ' │ │ │ │ │ │' ) + @ 9 + nTopOS, nCol SAY hb_UTF8ToStr( ' └───┘ └───┘ └───┘' ) + @ 10 + nTopOS, nCol SAY hb_UTF8ToStr( '┌───┐ ┌───┐ ┌───┐ ┌───┐' ) + @ 11 + nTopOS, nCol SAY hb_UTF8ToStr( '│ │ │ │ │ │ │ │' ) + @ 12 + nTopOS, nCol SAY hb_UTF8ToStr( '└───┘ └───┘ └───┘ │ │' ) + @ 13 + nTopOS, nCol SAY hb_UTF8ToStr( '┌───┐ ┌───┐ ┌───┐ │ │' ) + @ 14 + nTopOS, nCol SAY hb_UTF8ToStr( '│ │ │ │ │ │ │ │' ) + @ 15 + nTopOS, nCol SAY hb_UTF8ToStr( '└───┘ └───┘ └───┘ └───┘' ) + @ 16 + nTopOS, nCol SAY hb_UTF8ToStr( '┌───┐ ┌───┐ ┌───┐ ┌───┐' ) + @ 17 + nTopOS, nCol SAY hb_UTF8ToStr( '│ │ │ │ │ │ │ │' ) + @ 18 + nTopOS, nCol SAY hb_UTF8ToStr( '└───┘ └───┘ └───┘ │ │' ) + @ 19 + nTopOS, nCol SAY hb_UTF8ToStr( '┌─────────┐ ┌───┐ │ │' ) + @ 20 + nTopOS, nCol SAY hb_UTF8ToStr( '│ │ │ │ │ │' ) + @ 21 + nTopOS, nCol SAY hb_UTF8ToStr( '└─────────┘ └───┘ └───┘' ) + _ftSetWinColor( W_CURR, W_TITLE ) + nCol := 7 + nAddSpace + @ 11 + nTopOS, nCol SAY "7" + @ 14 + nTopOS, nCol SAY "4" + @ 17 + nTopOS, nCol SAY "1" + nCol := 13 + nAddSpace + @ 8 + nTopOS, nCol SAY "/" + @ 11 + nTopOS, nCol SAY "8" + @ 14 + nTopOS, nCol SAY "5" + @ 17 + nTopOS, nCol SAY "2" + nCol := 19 + nAddSpace + @ 8 + nTopOS, nCol SAY "X" + @ 11 + nTopOS, nCol SAY "9" + @ 14 + nTopOS, nCol SAY "6" + @ 17 + nTopOS, nCol SAY "3" + @ 20 + nTopOS, nCol SAY "." + @ 20 + nTopOS, 10 + nAddSpace SAY "0" + nCol := 25 + nAddSpace + @ 8 + nTopOS, nCol SAY "-" + @ 13 + nTopOS, nCol SAY "+" + @ 18 + nTopOS, nCol SAY "=" + @ 19 + nTopOS, nCol SAY "" + _ftSetWinColor( W_CURR, W_PROMPT ) + @ 3 + nTopOS, 6 + nAddSpace, 5 + nTopOS, 27 + nAddSpace BOX B_DOUBLE + + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftChangeDec() Docs: Keith A. Wire | @@ -421,32 +424,33 @@ RETURN NIL | Return Value: NIL | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftChangeDec(aAdder, nNumDec) - LOCAL cDefTotPict := "9999999999999999999" +STATIC FUNCTION _ftChangeDec( aAdder, nNumDec ) - IF nNumDec == NIL - nNumDec := 0 + LOCAL cDefTotPict := "9999999999999999999" - nNumDec := _ftQuest("How many decimals do you want to display?", ; - nNumDec, "9", {|oGet| _ftValDeci(oGet)}) + IF nNumDec == NIL + nNumDec := 0 - cTotPict := _ftPosRepl(cDefTotPict, ".", 19 - ABS(nNumDec)) + nNumDec := _ftQuest( "How many decimals do you want to display?", ; + nNumDec, "9", {|oGet| _ftValDeci( oGet ) } ) - cTotPict := RIGHT(_ftStuffComma(cTotPict), 19 ) - cTotPict := iif(nNumDec==2 .OR. nNumDec==6, " "+RIGHT(cTotPict,18),cTotPict) + cTotPict := _ftPosRepl( cDefTotPict, ".", 19 - Abs( nNumDec ) ) - nMaxDeci := nNumDec + cTotPict := Right( _ftStuffComma( cTotPict ), 19 ) + cTotPict := iif( nNumDec == 2 .OR. nNumDec == 6, " " + Right( cTotPict,18 ), cTotPict ) - IF lSubRtn - _ftDispTotal(aAdder) - ELSE - _ftDispSubTot(aAdder) - ENDIF + nMaxDeci := nNumDec - ENDIF + IF lSubRtn + _ftDispTotal( aAdder ) + ELSE + _ftDispSubTot( aAdder ) + ENDIF -RETURN NIL + ENDIF + + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftDispTotal() Docs: Keith A. Wire | @@ -460,26 +464,27 @@ RETURN NIL | Return Value: NIL | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftDispTotal(aAdder) - LOCAL cTotStr +STATIC FUNCTION _ftDispTotal( aAdder ) - IF nTotal>VAL(_ftCharRem(",",cTotPict)) - cTotStr := _ftStuffComma(LTRIM(STR(nTotal))) - @ 4+nTopOS, 8+nAddSpace SAY "**** ERROR **** " - _ftError("that number is to big to display! I believe the answer was " + ; - cTotStr+".") - lAddError := .T. - _ftUpdateTrans(aAdder, .T., NIL) - _ftClearAdder(aAdder) - nTotal := 0 - nNumTotal := 0 - lAddError := .F. - ELSE - @ 4+nTopOS, 7+nAddSpace SAY nTotal PICTURE cTotPict - ENDIF + LOCAL cTotStr -RETURN NIL + IF nTotal > Val( _ftCharRem( ",",cTotPict ) ) + cTotStr := _ftStuffComma( LTrim( Str(nTotal ) ) ) + @ 4 + nTopOS, 8 + nAddSpace SAY "**** ERROR **** " + _ftError( "that number is to big to display! I believe the answer was " + ; + cTotStr + "." ) + lAddError := .T. + _ftUpdateTrans( aAdder, .T. , NIL ) + _ftClearAdder( aAdder ) + nTotal := 0 + nNumTotal := 0 + lAddError := .F. + ELSE + @ 4 + nTopOS, 7 + nAddSpace SAY nTotal PICTURE cTotPict + ENDIF + + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftDispSubTot() Docs: Keith A. Wire | @@ -493,25 +498,27 @@ RETURN NIL | Return Value: NIL | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftDispSubTot(aAdder) - LOCAL cStotStr +STATIC FUNCTION _ftDispSubTot( aAdder ) - IF nNumTotal>VAL(_ftCharRem(",",cTotPict)) - cStotStr := _ftStuffComma(LTRIM(STR(nNumTotal))) - @ 4+nTopOS, 8+nAddSpace SAY "**** ERROR **** " - _ftError("that number is to big to display! I believe the answer was " + ; - cStotStr+".") - lAddError := .T. - _ftUpdateTrans(aAdder, .T.,nNumTotal) - _ftClearAdder(aAdder) - nTotal := 0 - nNumTotal := 0 - lAddError := .F. - ELSE - @ 4+nTopOS, 7+nAddSpace SAY nNumTotal PICTURE cTotPict - ENDIF -RETURN NIL + LOCAL cStotStr + + IF nNumTotal > Val( _ftCharRem( ",",cTotPict ) ) + cStotStr := _ftStuffComma( LTrim( Str(nNumTotal ) ) ) + @ 4 + nTopOS, 8 + nAddSpace SAY "**** ERROR **** " + _ftError( "that number is to big to display! I believe the answer was " + ; + cStotStr + "." ) + lAddError := .T. + _ftUpdateTrans( aAdder, .T. , nNumTotal ) + _ftClearAdder( aAdder ) + nTotal := 0 + nNumTotal := 0 + lAddError := .F. + ELSE + @ 4 + nTopOS, 7 + nAddSpace SAY nNumTotal PICTURE cTotPict + ENDIF + + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftProcessNumb() Docs: Keith A. Wire | @@ -526,35 +533,38 @@ RETURN NIL | Return Value: NIL | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftProcessNumb(aAdder, nKey) - LOCAL nNum - _ftEraseTotSubTot(aAdder) - lTotalOk := .F. - lClAdder := .F. // Reset the Clear flag - lAddError := .F. // Reset adder error flag - IF nKey == Asc( "." ) // Period (.) decimal point - IF lDecSet // Has decimal already been set - TONE(800, 1) - ELSE - lDecSet := .T. - ENDIF - ELSE // It must be a number input - lNewNum := .T. - nNum := nKey-48 - IF lDecSet // Decimal set - IF nDecDigit" - _ftSetWinColor(W_CURR,W_PROMPT) - _ftUpdateTrans(aAdder, .T., NIL) - _ftDispTotal(aAdder) - lSubRtn := .F. // pressed the total key reset everyting - nSavTotal := nTotal - nTotal := 0 - lTotalOk := .T. - ENDIF - ELSE // This was the first time they pressed - IF !lMultDiv .AND. LASTKEY() == K_RETURN // total key - lSubRtn := .T. - ENDIF - IF _ftRoundIt(nTotal,nMaxDeci)!=0 .OR. _ftRoundIt(nNumTotal,nMaxDeci)!=0 - IF !lMultDiv - _ftSetWinColor(W_CURR,W_SCREEN) - @ 6+nTopOS, 18+nAddSpace SAY "" - _ftSetWinColor(W_CURR,W_PROMPT) - ENDIF - IF _ftRoundIt(nNumTotal,nMaxDeci)!=0 - lSubRtn := .F. - _ftUpdateTrans(aAdder, .F.,nNumTotal) - ENDIF - IF !lMultDiv - lSubRtn := .T. // total key - ENDIF - IF nAddMode == 1 // Add - nTotal := nTotal+nNumTotal - ELSEIF nAddMode == 2 // Subtract - nTotal := nTotal-nNumTotal - ELSEIF nAddMode == 3 // Multiply - nTotal := nTotal*nNumTotal - ELSEIF nAddMode == 4 // Divide - nTotal := _ftDivide(aAdder, nTotal,nNumTotal) - IF lDivError - _ftError("you can't divide by ZERO!") - lDivError := .F. - ENDIF - ENDIF - ENDIF - _ftDispTotal(aAdder) - IF lMultDiv // This was a multiply or divide - _ftSetWinColor(W_CURR,W_SCREEN) - @ 6+nTopOS, 18+nAddSpace SAY " " - _ftSetWinColor(W_CURR,W_PROMPT) - lSubRtn := .F. // pressed total so key reset everything - IF !lTotalOk // If you haven't printed total DO-IT - lTotalOk := .T. - _ftUpdateTrans(aAdder, .F., NIL) - ENDIF - nNumTotal := 0 - nSavTotal := nTotal - nTotal := 0 - ELSE - IF !lTotalOk // If you haven't printed total DO-IT - _ftUpdateTrans(aAdder, .F., NIL) - nNumTotal := 0 - ENDIF - ENDIF - ENDIF -RETURN NIL +STATIC FUNCTION _ftAddTotal( aAdder ) + + _ftEraseTotSubTot( aAdder ) + lDecSet := .F. + nDecDigit := 0 + lClAdder := .F. // Reset the Clear flag + IF lSubRtn // If this was the second time they + IF !lMultDiv + _ftSetWinColor( W_CURR, W_SCREEN ) + @ 6 + nTopOS, 18 + nAddSpace SAY " " + _ftSetWinColor( W_CURR, W_PROMPT ) + _ftUpdateTrans( aAdder, .T. , NIL ) + _ftDispTotal( aAdder ) + lSubRtn := .F. // pressed the total key reset everyting + nSavTotal := nTotal + nTotal := 0 + lTotalOk := .T. + ENDIF + ELSE // This was the first time they pressed + IF !lMultDiv .AND. LastKey() == K_RETURN // total key + lSubRtn := .T. + ENDIF + IF _ftRoundIt( nTotal, nMaxDeci ) != 0 .OR. _ftRoundIt( nNumTotal, nMaxDeci ) != 0 + IF !lMultDiv + _ftSetWinColor( W_CURR, W_SCREEN ) + @ 6 + nTopOS, 18 + nAddSpace SAY "" + _ftSetWinColor( W_CURR, W_PROMPT ) + ENDIF + IF _ftRoundIt( nNumTotal, nMaxDeci ) != 0 + lSubRtn := .F. + _ftUpdateTrans( aAdder, .F. , nNumTotal ) + ENDIF + IF !lMultDiv + lSubRtn := .T. // total key + ENDIF + IF nAddMode == 1 // Add + nTotal := nTotal + nNumTotal + ELSEIF nAddMode == 2 // Subtract + nTotal := nTotal - nNumTotal + ELSEIF nAddMode == 3 // Multiply + nTotal := nTotal * nNumTotal + ELSEIF nAddMode == 4 // Divide + nTotal := _ftDivide( aAdder, nTotal, nNumTotal ) + IF lDivError + _ftError( "you can't divide by ZERO!" ) + lDivError := .F. + ENDIF + ENDIF + ENDIF + _ftDispTotal( aAdder ) + IF lMultDiv // This was a multiply or divide + _ftSetWinColor( W_CURR, W_SCREEN ) + @ 6 + nTopOS, 18 + nAddSpace SAY " " + _ftSetWinColor( W_CURR, W_PROMPT ) + lSubRtn := .F. // pressed total so key reset everything + IF !lTotalOk // If you haven't printed total DO-IT + lTotalOk := .T. + _ftUpdateTrans( aAdder, .F. , NIL ) + ENDIF + nNumTotal := 0 + nSavTotal := nTotal + nTotal := 0 + ELSE + IF !lTotalOk // If you haven't printed total DO-IT + _ftUpdateTrans( aAdder, .F. , NIL ) + nNumTotal := 0 + ENDIF + ENDIF + ENDIF + + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftAddSub() Docs: Keith A. Wire | @@ -652,45 +664,46 @@ RETURN NIL | Return Value: NIL | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftAddSub(aAdder, nKey) - lMultDiv := .F. - _ftEraseTotSubTot(aAdder) - lTotalOk := .F. - lDecSet := .F. - nDecDigit := 0 - lSubRtn := .F. - // They pressed the + or - key to process the previous total - IF _ftRoundIt(nNumTotal,nMaxDeci)==0 .AND. _ftRoundIt(nTotal,nMaxDeci)==0 - nNumTotal := nSavTotal - lNewNum := .T. - ENDIF - IF nKey == K_PLUS // Add - nAddMode := 1 - IF !lNewNum // They pressed + again to add the same - nNumTotal := nSavSubTot // number without re-entering - ENDIF - _ftUpdateTrans(aAdder, .F.,nNumTotal) - nTotal := nTotal+nNumTotal - lNewNum := .F. - nSavSubTot := nNumTotal // Save this number in case they just press + or - - nNumTotal := 0 - ELSEIF nKey == K_MINUS // Subtract - nAddMode := 2 - IF !lNewNum // They pressed + again to add the same - nNumTotal := nSavSubTot // number without re-entering +STATIC FUNCTION _ftAddSub( aAdder, nKey ) + + lMultDiv := .F. + _ftEraseTotSubTot( aAdder ) + lTotalOk := .F. + lDecSet := .F. + nDecDigit := 0 + lSubRtn := .F. +// They pressed the + or - key to process the previous total + IF _ftRoundIt( nNumTotal, nMaxDeci ) == 0 .AND. _ftRoundIt( nTotal, nMaxDeci ) == 0 + nNumTotal := nSavTotal lNewNum := .T. - ENDIF - _ftUpdateTrans(aAdder, .F.,nNumTotal) - nTotal := nTotal-nNumTotal - lNewNum := .F. - nSavSubTot := nNumTotal // Save this number in case they just press + or - - nNumTotal := 0 - ENDIF + ENDIF + IF nKey == K_PLUS // Add + nAddMode := 1 + IF !lNewNum // They pressed + again to add the same + nNumTotal := nSavSubTot // number without re-entering + ENDIF + _ftUpdateTrans( aAdder, .F. , nNumTotal ) + nTotal := nTotal + nNumTotal + lNewNum := .F. + nSavSubTot := nNumTotal // Save this number in case they just press + or - + nNumTotal := 0 + ELSEIF nKey == K_MINUS // Subtract + nAddMode := 2 + IF !lNewNum // They pressed + again to add the same + nNumTotal := nSavSubTot // number without re-entering + lNewNum := .T. + ENDIF + _ftUpdateTrans( aAdder, .F. , nNumTotal ) + nTotal := nTotal - nNumTotal + lNewNum := .F. + nSavSubTot := nNumTotal // Save this number in case they just press + or - + nNumTotal := 0 + ENDIF - _ftDispTotal(aAdder) + _ftDispTotal( aAdder ) -RETURN NIL + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftMultDiv() Docs: Keith A. Wire | @@ -705,50 +718,51 @@ RETURN NIL | Return Value: NIL | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftMultDiv(aAdder, nKey) - lMultDiv := .T. - _ftEraseTotSubTot(aAdder) - lTotalOk := .F. - lDecSet := .F. - nDecDigit := 0 - lSubRtn := .F. - // They pressed the + or - key to process the previous total - IF _ftRoundIt(nNumTotal,nMaxDeci)==0 .AND. _ftRoundIt(nTotal,nMaxDeci)==0 - nNumTotal := nSavTotal - ENDIF - // Get the first number of the product or division - IF _ftRoundIt(nTotal,nMaxDeci)==0 - IF nKey == K_MULTIPLY // Setup mode - nAddMode := 3 - _ftUpdateTrans(aAdder, .F.,nNumTotal) - ELSEIF nKey == K_DIVIDE - nAddMode := 4 - _ftUpdateTrans(aAdder, .F.,nNumTotal) - ENDIF - nTotal := nNumTotal - nNumTotal := 0 - ELSE - IF nKey == K_MULTIPLY // Multiply - nAddMode := 3 - _ftUpdateTrans(aAdder, .F.,nNumTotal) - nTotal := nTotal*nNumTotal - nNumTotal := 0 - ELSEIF nKey == K_MULTIPLY // Divide - nAddMode := 4 - _ftUpdateTrans(aAdder, .F.,nNumTotal) - nTotal:=_ftDivide(aAdder, nTotal,nNumTotal) - IF lDivError - _ftError("you can't divide by ZERO!") - lDivError := .F. +STATIC FUNCTION _ftMultDiv( aAdder, nKey ) + + lMultDiv := .T. + _ftEraseTotSubTot( aAdder ) + lTotalOk := .F. + lDecSet := .F. + nDecDigit := 0 + lSubRtn := .F. +// They pressed the + or - key to process the previous total + IF _ftRoundIt( nNumTotal, nMaxDeci ) == 0 .AND. _ftRoundIt( nTotal, nMaxDeci ) == 0 + nNumTotal := nSavTotal + ENDIF +// Get the first number of the product or division + IF _ftRoundIt( nTotal, nMaxDeci ) == 0 + IF nKey == K_MULTIPLY // Setup mode + nAddMode := 3 + _ftUpdateTrans( aAdder, .F. , nNumTotal ) + ELSEIF nKey == K_DIVIDE + nAddMode := 4 + _ftUpdateTrans( aAdder, .F. , nNumTotal ) ENDIF + nTotal := nNumTotal nNumTotal := 0 - ENDIF - ENDIF + ELSE + IF nKey == K_MULTIPLY // Multiply + nAddMode := 3 + _ftUpdateTrans( aAdder, .F. , nNumTotal ) + nTotal := nTotal * nNumTotal + nNumTotal := 0 + ELSEIF nKey == K_MULTIPLY // Divide + nAddMode := 4 + _ftUpdateTrans( aAdder, .F. , nNumTotal ) + nTotal := _ftDivide( aAdder, nTotal, nNumTotal ) + IF lDivError + _ftError( "you can't divide by ZERO!" ) + lDivError := .F. + ENDIF + nNumTotal := 0 + ENDIF + ENDIF - _ftDispTotal(aAdder) + _ftDispTotal( aAdder ) -RETURN NIL + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftAddHelp Docs: Keith A. Wire | @@ -762,30 +776,31 @@ RETURN NIL | Return Value: NIL | +--------------------------------------------------------------------------+ */ + STATIC FUNCTION _ftAddHelp - LOCAL cMess := "This Adder works like a desk top calculator. You may add,"+; - " subtract, multiply, or divide. " + CRLF + CRLF +; - "When adding or subtracting, the first entry is entered " +; - "into the accumulator and each sucessive entry is " +; - "subtotaled. When you press the SubTotal is also " +; - "shown on the tape. The second time you press the "+; - "adder is Totaled. When multiplying or dividing the " +; - " is a Total the first time pressed." + CRLF + CRLF +; - "Hot Keys:" +CRLF+; - " ecimals - change # of decimals" +CRLF+; - " ove - the Adder from right to left" +CRLF+; - " ape - turn Tape Display On or Off" +CRLF+; - " croll - the tape display" + CRLF +CRLF+; - " ---┬-- 1st Clear entry" +CRLF+; - " +-- 2nd Clear ADDER" +CRLF+; - " - Quit" +CRLF+; - " - return a to the active get" + LOCAL cMess := "This Adder works like a desk top calculator. You may add," + ; + " subtract, multiply, or divide. " + CRLF + CRLF + ; + "When adding or subtracting, the first entry is entered " + ; + "into the accumulator and each sucessive entry is " + ; + "subtotaled. When you press the SubTotal is also " + ; + "shown on the tape. The second time you press the " + ; + "adder is Totaled. When multiplying or dividing the " + ; + " is a Total the first time pressed." + CRLF + CRLF + ; + "Hot Keys:" + CRLF + ; + " ecimals - change # of decimals" + CRLF + ; + " ove - the Adder from right to left" + CRLF + ; + " ape - turn Tape Display On or Off" + CRLF + ; + " croll - the tape display" + CRLF + CRLF + ; + " ---┬-- 1st Clear entry" + CRLF + ; + " +-- 2nd Clear ADDER" + CRLF + ; + " - Quit" + CRLF + ; + " - return a to the active get" - _ftPushMessage(cMess, .T., "ADDER HELP", "press any key to continue...", ; - "QUIET") + _ftPushMessage( cMess, .T. , "ADDER HELP", "press any key to continue...", ; + "QUIET" ) -RETURN NIL + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftClearAdder() Docs: Keith A. Wire | @@ -799,23 +814,25 @@ RETURN NIL | Return Value: NIL | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftClearAdder(aAdder) - _ftEraseTotSubTot(aAdder) - lDecSet := .F. - nDecDigit := 0 - IF lClAdder // If it has alredy been pressed once - nTotal := 0 // then we are clearing the total - nSavTotal := 0 - _ftUpdateTrans(aAdder, .F., NIL) - lClAdder := .F. - _ftDispTotal(aAdder) - ELSE - nNumTotal := 0 // Just clearing the last entry - lClAdder := .T. - _ftDispSubTot(aAdder) - ENDIF -RETURN NIL +STATIC FUNCTION _ftClearAdder( aAdder ) + + _ftEraseTotSubTot( aAdder ) + lDecSet := .F. + nDecDigit := 0 + IF lClAdder // If it has alredy been pressed once + nTotal := 0 // then we are clearing the total + nSavTotal := 0 + _ftUpdateTrans( aAdder, .F. , NIL ) + lClAdder := .F. + _ftDispTotal( aAdder ) + ELSE + nNumTotal := 0 // Just clearing the last entry + lClAdder := .T. + _ftDispSubTot( aAdder ) + ENDIF + + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftUpdateTrans() Docs: Keith A. Wire | @@ -831,38 +848,39 @@ RETURN NIL | Return Value: NIL | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftUpdateTrans(aAdder, lTypeTotal, nAmount) - LOCAL lUseTotal := (nAmount == NIL) +STATIC FUNCTION _ftUpdateTrans( aAdder, lTypeTotal, nAmount ) - nAmount := iif(nAmount==NIL,0,nAmount) - IF lClAdder // Clear the adder (they pressed twice - AADD(aTrans,STR(0,22,nMaxDeci)+" C") - IF lTape // If there is a tape Show Clear - _ftDisplayTape(aAdder) - ENDIF - RETU NIL - ENDIF + LOCAL lUseTotal := ( nAmount == NIL ) - IF lTypeTotal // If lTypeTotal=.T. Update from total - AADD(aTrans,STR(iif(lUseTotal,nTotal,nAmount),22,nMaxDeci) ) - aTrans[nTotTran] := _ftStuffComma(aTrans[nTotTran], .T.) + " *"+ ; - iif(lAddError,"ER","") + nAmount := iif( nAmount == NIL, 0, nAmount ) + IF lClAdder // Clear the adder (they pressed twice + AAdd( aTrans, Str( 0,22,nMaxDeci ) + " C" ) + IF lTape // If there is a tape Show Clear + _ftDisplayTape( aAdder ) + ENDIF + RETU NIL + ENDIF - ELSE // If lTypeTotal=.F. Update from nNumTotal - AADD(aTrans,STR(iif(lUseTotal,nTotal,nAmount),22,nMaxDeci)) + IF lTypeTotal // If lTypeTotal=.T. Update from total + AAdd( aTrans, Str( iif(lUseTotal,nTotal,nAmount ),22,nMaxDeci ) ) + aTrans[nTotTran] := _ftStuffComma( aTrans[nTotTran], .T. ) + " *" + ; + iif( lAddError, "ER", "" ) - aTrans[nTotTran] := _ftStuffComma(aTrans[nTotTran], .T.) + ; - iif(lSubRtn," S",iif(nAddMode==1," +",iif(nAddMode==2," -",IF ; - (lTotalOk," =",iif(nAddMode==3," X"," /"))))) + iif(lAddError,"ER","") + ELSE // If lTypeTotal=.F. Update from nNumTotal + AAdd( aTrans, Str( iif(lUseTotal,nTotal,nAmount ),22,nMaxDeci ) ) - ENDIF + aTrans[nTotTran] := _ftStuffComma( aTrans[nTotTran], .T. ) + ; + iif( lSubRtn, " S", iif( nAddMode == 1," +",iif(nAddMode == 2," -",IF ; + ( lTotalOk, " =", iif( nAddMode == 3," X"," /" ) ) ) ) ) + iif( lAddError, "ER", "" ) - IF lTape - _ftDisplayTape(aAdder) - ENDIF + ENDIF -RETURN NIL + IF lTape + _ftDisplayTape( aAdder ) + ENDIF + + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftEraseTotSubTot() Docs: Keith A. Wire | @@ -876,11 +894,14 @@ RETURN NIL | Return Value: NIL | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftEraseTotSubTot(aAdder) - _ftSetWinColor(W_CURR,W_SCREEN) - @ 6+nTopOS, 18+nAddSpace SAY " " - _ftSetWinColor(W_CURR,W_PROMPT) -RETURN NIL + +STATIC FUNCTION _ftEraseTotSubTot( aAdder ) + + _ftSetWinColor( W_CURR, W_SCREEN ) + @ 6 + nTopOS, 18 + nAddSpace SAY " " + _ftSetWinColor( W_CURR, W_PROMPT ) + + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftRoundIt() Docs: Keith A. Wire | @@ -896,10 +917,13 @@ RETURN NIL | : 12 @) / 10 @^ nPlaces | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftRoundIt(nNumber, nPlaces) - nPlaces := iif( nPlaces == NIL, 0, nPlaces ) -RETURN iif(nNumber < 0.0, -1.0, 1.0) * ; - INT( ABS(nNumber) * 10 ^ nPlaces + 0.50 + 10 ^ -12 ) / 10 ^ nPlaces + +STATIC FUNCTION _ftRoundIt( nNumber, nPlaces ) + + nPlaces := iif( nPlaces == NIL, 0, nPlaces ) + + RETURN iif( nNumber < 0.0, - 1.0, 1.0 ) * ; + Int( Abs( nNumber ) * 10 ^ nPlaces + 0.50 + 10 ^ - 12 ) / 10 ^ nPlaces /*+- Function ---------------------------------------------------------------+ | Name: _ftDivide() Docs: Keith A. Wire | @@ -915,14 +939,17 @@ RETURN iif(nNumber < 0.0, -1.0, 1.0) * ; | Return Value: @(nNumerator/nDenominator@) | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftDivide(aAdder, nNumerator,nDenominator) - IF nDenominator==0.0 - lDivError := .T. - RETU 0 - ELSE - lDivError := .F. - ENDIF -RETURN(nNumerator/nDenominator) + +STATIC FUNCTION _ftDivide( aAdder, nNumerator, nDenominator ) + + IF nDenominator == 0.0 + lDivError := .T. + RETU 0 + ELSE + lDivError := .F. + ENDIF + + RETURN nNumerator / nDenominator /*+- Function ---------------------------------------------------------------+ | Name: _ftValDeci() Docs: Keith A. Wire | @@ -936,16 +963,17 @@ RETURN(nNumerator/nDenominator) | Return Value: lRtnValue | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftValDeci(oGet) - LOCAL lRtnValue := .T. +STATIC FUNCTION _ftValDeci( oGet ) - IF oGet:VarGet() > 8 - _ftError("no more than 8 decimal places please!") - lRtnValue := .F. - ENDIF + LOCAL lRtnValue := .T. -RETURN lRtnValue + IF oGet:VarGet() > 8 + _ftError( "no more than 8 decimal places please!" ) + lRtnValue := .F. + ENDIF + + RETURN lRtnValue /*+- Function ---------------------------------------------------------------+ | Name: _ftDisplayTape() Docs: Keith A. Wire | @@ -960,40 +988,44 @@ RETURN lRtnValue | Return Value: NIL | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftDisplayTape(aAdder, nKey) - LOCAL nDispTape, nTopTape := 1 - IF (nKey == 84 .OR. nKey == 116) .AND. lTape // Stop displaying tape - lTape := .F. - RESTSCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,35+nTapeSpace,cTapeScr) - RETU NIL - ENDIF - IF lTape // Are we in the display mode - SETCOLOR("N/W") - SCROLL(5+nTopOS,7+nTapeSpace,20+nTopOS,32+nTapeSpace,1) - IF nTotTran>0 // Any transactions been entered yet? - @ 20+nTopOS,7+nTapeSpace SAY aTrans[nTotTran] - ENDIF - _ftSetWinColor(W_CURR,W_PROMPT) - ELSE // Start displaying tape - lTape := .T. - SETCOLOR("N/W") - cTapeScr := SAVESCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,35+nTapeSpace) - _ftShadow(22+nTopOS,8+nTapeSpace,22+nTopOS,35+nTapeSpace) - _ftShadow(5+nTopOS,33+nTapeSpace,21+nTopOS,35+nTapeSpace) - SETCOLOR("R+/W") - @ 4+nTopOS,6+nTapeSpace,21+nTopOS,33+nTapeSpace BOX B_SINGLE - SETCOLOR("GR+/W") - @ 4+nTopOS,17+nTapeSpace SAY " TAPE " - SETCOLOR("N/W") - IF nTotTran>15 - nTopTape := nTotTran-15 - ENDIF - FOR nDispTape := nTotTran TO nTopTape STEP -1 - @ 20+nDispTape-nTotTran+nTopOS,7+nTapeSpace SAY aTrans[nDispTape] - NEXT - ENDIF - _ftSetWinColor(W_CURR,W_PROMPT) -RETURN NIL + +STATIC FUNCTION _ftDisplayTape( aAdder, nKey ) + + LOCAL nDispTape, nTopTape := 1 + + IF ( nKey == 84 .OR. nKey == 116 ) .AND. lTape // Stop displaying tape + lTape := .F. + RestScreen( 4 + nTopOS, 6 + nTapeSpace, 22 + nTopOS, 35 + nTapeSpace, cTapeScr ) + RETU NIL + ENDIF + IF lTape // Are we in the display mode + SetColor( "N/W" ) + Scroll( 5 + nTopOS, 7 + nTapeSpace, 20 + nTopOS, 32 + nTapeSpace, 1 ) + IF nTotTran > 0 // Any transactions been entered yet? + @ 20 + nTopOS, 7 + nTapeSpace SAY aTrans[nTotTran] + ENDIF + _ftSetWinColor( W_CURR, W_PROMPT ) + ELSE // Start displaying tape + lTape := .T. + SetColor( "N/W" ) + cTapeScr := SaveScreen( 4 + nTopOS, 6 + nTapeSpace, 22 + nTopOS, 35 + nTapeSpace ) + _ftShadow( 22 + nTopOS, 8 + nTapeSpace, 22 + nTopOS, 35 + nTapeSpace ) + _ftShadow( 5 + nTopOS, 33 + nTapeSpace, 21 + nTopOS, 35 + nTapeSpace ) + SetColor( "R+/W" ) + @ 4 + nTopOS, 6 + nTapeSpace, 21 + nTopOS, 33 + nTapeSpace BOX B_SINGLE + SetColor( "GR+/W" ) + @ 4 + nTopOS, 17 + nTapeSpace SAY " TAPE " + SetColor( "N/W" ) + IF nTotTran > 15 + nTopTape := nTotTran - 15 + ENDIF + FOR nDispTape := nTotTran TO nTopTape STEP - 1 + @ 20 + nDispTape - nTotTran + nTopOS, 7 + nTapeSpace SAY aTrans[nDispTape] + NEXT + ENDIF + _ftSetWinColor( W_CURR, W_PROMPT ) + + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftSetLastKey() Docs: Keith A. Wire | @@ -1009,12 +1041,15 @@ RETURN NIL | : original value of LASTKEY() when quitting. | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftSetLastKey(nLastKey) - _ftPushKeys() - KEYBOARD CHR(nLastKey) - INKEY() - _ftPopKeys() -RETURN NIL + +STATIC FUNCTION _ftSetLastKey( nLastKey ) + + _ftPushKeys() + KEYBOARD Chr( nLastKey ) + Inkey() + _ftPopKeys() + + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftPushKeys Docs: Keith A. Wire | @@ -1029,11 +1064,14 @@ RETURN NIL | Notes: Save any keys in the buffer... for FAST typists . | +--------------------------------------------------------------------------+ */ + STATIC FUNCTION _ftPushKeys - DO WHILE NEXTKEY() != 0 - AADD(aKeys,INKEY()) - ENDDO -RETURN NIL + + DO WHILE NextKey() != 0 + AAdd( aKeys, Inkey() ) + ENDDO + + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftPopKeys Docs: Keith A. Wire | @@ -1048,14 +1086,18 @@ RETURN NIL | Return Value: NIL | +--------------------------------------------------------------------------+ */ + STATIC FUNCTION _ftPopKeys - LOCAL cKeys := "" - IF LEN(aKeys) != 0 - AEVAL(aKeys, {|elem| cKeys += CHR(elem)}) - ENDIF - KEYBOARD cKeys - aKeys := {} -RETURN NIL + + LOCAL cKeys := "" + + IF Len( aKeys ) != 0 + AEval( aKeys, {|elem| cKeys += Chr( elem ) } ) + ENDIF + KEYBOARD cKeys + aKeys := {} + + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftPushMessage() Docs: Keith A. Wire | @@ -1075,48 +1117,51 @@ RETURN NIL | See Also: _ftPopMessage | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftPushMessage(cMessage,lWait,cTitle,cBotTitle,xQuiet, nTop) - LOCAL nMessLen, nNumRows, nWide, nLeft, nBottom, nRight, nKey, cOldDevic, ; - lOldPrint, ; - cOldColor := SETCOLOR(), ; - nOldLastkey := LASTKEY(), ; - nOldRow := ROW(), ; - nOldCol := COL(), ; - nOldCurs := SETCURSOR(SC_NONE), ; - nWinColor := iif(nWinColor == NIL, W_CURR, nWinColor) - cOldDevic := SET(_SET_DEVICE, "SCREEN") - lOldPrint := SET(_SET_PRINTER, .F.) - nMessLen := LEN(cMessage) - nWide := iif(nMessLen>72,72,iif(nMessLen<12,12,nMessLen)) - nNumRows := MLCOUNT(cMessage,nWide) +STATIC FUNCTION _ftPushMessage( cMessage, lWait, cTitle, cBotTitle, xQuiet, nTop ) - // If they didn't say what the top row is, Center it on the screen - DEFAULT nTop TO INT((MAXROW()-nNumRows)/2) + LOCAL nMessLen, nNumRows, nWide, nLeft, nBottom, nRight, nKey, cOldDevic + LOCAL lOldPrint + LOCAL cOldColor := SetColor() + LOCAL nOldLastkey := LastKey() + LOCAL nOldRow := Row() + LOCAL nOldCol := Col() + LOCAL nOldCurs := SetCursor( SC_NONE ) + LOCAL nWinColor := iif( nWinColor == NIL, W_CURR, nWinColor ) - nBottom := nTop+nNumRows+2 - nLeft := INT((MAXCOL()-nWide)/2)-3 - nRight := nLeft+nWide+4 - lWait := iif(lWait == NIL, .F., lWait) + cOldDevic := Set( _SET_DEVICE, "SCREEN" ) + lOldPrint := Set( _SET_PRINTER, .F. ) + nMessLen := Len( cMessage ) + nWide := iif( nMessLen > 72, 72, iif( nMessLen < 12,12,nMessLen ) ) + nNumRows := MLCount( cMessage, nWide ) - _ftPushWin(nTop,nLeft,nBottom,nRight,cTitle,cBotTitle,nWinColor) - DISPMESSAGE cMessage,nTop+1,nLeft+2,nBottom-1,nRight-2 +// If they didn't say what the top row is, Center it on the screen + DEFAULT nTop TO Int( ( MaxRow() - nNumRows ) / 2 ) - IF xQuiet == NIL - TONE(800, 1) - ENDIF - IF lWait - FT_INKEY 0 TO nKey - _ftPopMessage() - ENDIF + nBottom := nTop + nNumRows + 2 + nLeft := Int( ( MaxCol() - nWide ) / 2 ) - 3 + nRight := nLeft + nWide + 4 + lWait := iif( lWait == NIL, .F. , lWait ) - SETCURSOR(nOldCurs) - SETCOLOR(cOldColor) - SETPOS(nOldRow,nOldCol) - SET(_SET_DEVICE, cOldDevic) - SET(_SET_PRINTER, lOldPrint) - _ftSetLastKey(nOldLastKey) -RETURN NIL + _ftPushWin( nTop, nLeft, nBottom, nRight, cTitle, cBotTitle, nWinColor ) + DISPMESSAGE cMessage, nTop + 1, nLeft + 2, nBottom - 1, nRight - 2 + + IF xQuiet == NIL + Tone( 800, 1 ) + ENDIF + IF lWait + FT_INKEY 0 TO nKey + _ftPopMessage() + ENDIF + + SetCursor( nOldCurs ) + SetColor( cOldColor ) + SetPos( nOldRow, nOldCol ) + SET( _SET_DEVICE, cOldDevic ) + SET( _SET_PRINTER, lOldPrint ) + _ftSetLastKey( nOldLastKey ) + + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftPopMessage Docs: Keith A. Wire | @@ -1131,9 +1176,12 @@ RETURN NIL | See Also: _ftPushMessage() | +--------------------------------------------------------------------------+ */ + STATIC FUNCTION _ftPopMessage - _ftPopWin() -RETURN NIL + + _ftPopWin() + + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftQuest() Docs: Keith A. Wire | @@ -1154,89 +1202,91 @@ RETURN NIL | Notes: This function will work for all Data Types | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftQuest(cMessage,xVarVal,cPict,bValid,lNoESC,nWinColor,nTop) - LOCAL nOldRow, nOldCol, cOldColor, nMessLen, nWide, nNumRows, nBottom, nLeft - LOCAL nRight, oNewGet, nNumMessRow, nLenLastRow, lGetOnNextLine, nOldCurs - LOCAL cVarType := VALTYPE(xVarVal) - LOCAL nVarLen := iif(cVarType=="C",LEN(xVarVal),iif(cVarType=="D",8, ; - iif(cVarType=="L",1,iif(cVarType=="N",iif(cPict==NIL,9, ; - LEN(cPict)),0)))) - LOCAL nOldLastKey := LASTKEY() - LOCAL cOldDevice := SET(_SET_DEVICE, "SCREEN"), ; - lOldPrint := SET(_SET_PRINTER, .F.) +STATIC FUNCTION _ftQuest( cMessage, xVarVal, cPict, bValid, lNoESC, nWinColor, nTop ) - nOldRow := ROW() - nOldCol := COL() - nOldCurs := SETCURSOR(SC_NONE) - cOldColor := SETCOLOR() - lNoESC := iif(lNoESC==NIL,.F.,lNoESC) + LOCAL nOldRow, nOldCol, cOldColor, nMessLen, nWide, nNumRows, nBottom, nLeft + LOCAL nRight, oNewGet, nNumMessRow, nLenLastRow, lGetOnNextLine, nOldCurs + LOCAL cVarType := ValType( xVarVal ) + LOCAL nVarLen := iif( cVarType == "C", Len( xVarVal ), iif( cVarType == "D",8, ; + iif( cVarType == "L", 1, iif( cVarType == "N",iif(cPict == NIL,9, ; + Len( cPict ) ), 0 ) ) ) ) + LOCAL nOldLastKey := LastKey() + LOCAL cOldDevice := Set( _SET_DEVICE, "SCREEN" ) + LOCAL lOldPrint := Set( _SET_PRINTER, .F. ) - nMessLen := LEN(cMessage)+nVarLen+1 - nWide := iif(nMessLen>66,66,iif(nMessLen<12,12,nMessLen)) + nOldRow := Row() + nOldCol := Col() + nOldCurs := SetCursor( SC_NONE ) + cOldColor := SetColor() + lNoESC := iif( lNoESC == NIL, .F. , lNoESC ) - nNumMessRow := MLCOUNT(cMessage,nWide) - nLenLastRow := LEN(TRIM(MEMOLINE(cMessage,nWide,nNumMessRow))) - lGetOnNextLine := (nLenLastRow + nVarLen) > nWide - nNumRows := nNumMessRow + iif(lGetOnNextLine,1,0) + nMessLen := Len( cMessage ) + nVarLen + 1 + nWide := iif( nMessLen > 66, 66, iif( nMessLen < 12,12,nMessLen ) ) - // Center it in the screen - nTop := iif(nTop==NIL,INT((MAXROW() - nNumRows)/2),nTop) - nBottom := nTop+nNumRows+1 - nLeft := INT((MAXCOL()-nWide)/2)-4 - nRight := nLeft+nWide+4 + nNumMessRow := MLCount( cMessage, nWide ) + nLenLastRow := Len( Trim( MemoLine(cMessage,nWide,nNumMessRow ) ) ) + lGetOnNextLine := ( nLenLastRow + nVarLen ) > nWide + nNumRows := nNumMessRow + iif( lGetOnNextLine, 1, 0 ) - _ftPushWin(nTop,nLeft,nBottom,nRight,"QUESTION ?",iif(VALTYPE(xVarVal)=="C" ; - .AND. nVarLen>nWide,CHR(27)+" scroll "+ CHR(26),NIL),nWinColor) - DISPMESSAGE cMessage,nTop+1,nLeft+2,nBottom-1,nRight-2 +// Center it in the screen + nTop := iif( nTop == NIL, Int( ( MaxRow() - nNumRows ) / 2 ), nTop ) + nBottom := nTop + nNumRows + 1 + nLeft := Int( ( MaxCol() - nWide ) / 2 ) - 4 + nRight := nLeft + nWide + 4 - oNewGet := GetNew( iif(lGetOnNextLine,Row()+1,Row()), ; - iif(lGetOnNextLine,nLeft+2,Col()+1), ; - {|x| iif(PCOUNT() > 0, xVarVal := x, xVarVal)}, ; - "xVarVal" ) + _ftPushWin( nTop, nLeft, nBottom, nRight, "QUESTION ?", iif( ValType(xVarVal ) == "C" ; + .AND. nVarLen > nWide, Chr( 27 ) + " scroll " + Chr( 26 ), NIL ), nWinColor ) + DISPMESSAGE cMessage, nTop + 1, nLeft + 2, nBottom - 1, nRight - 2 - // If the input line is character & wider than window SCROLL - IF lGetOnNextLine .AND. VALTYPE(xVarVal)=="C" .AND. nVarLen>nWide - oNewGet:Picture := "@S"+LTRIM(STR(nWide,4,0))+iif(cPict==NIL,""," "+cPict) - ENDIF + oNewGet := GetNew( iif( lGetOnNextLine,Row() + 1,Row() ), ; + iif( lGetOnNextLine, nLeft + 2, Col() + 1 ), ; + {| x | iif( PCount() > 0, xVarVal := x, xVarVal ) }, ; + "xVarVal" ) - IF cPict != NIL // Use the picture they passed - oNewGet:Picture := cPict - ELSE // Else setup default pictures - IF VALTYPE(xVarVal)=="D" - oNewGet:Picture := "99/99/99" - ELSEIF VALTYPE(xVarVal)=="L" - oNewGet:Picture := "Y" - ELSEIF VALTYPE(xVarVal)=="N" - oNewGet:Picture := "999999.99" // Guess that they are inputting dollars - ENDIF - ENDIF +// If the input line is character & wider than window SCROLL + IF lGetOnNextLine .AND. ValType( xVarVal ) == "C" .AND. nVarLen > nWide + oNewGet:Picture := "@S" + LTrim( Str( nWide,4,0 ) ) + iif( cPict == NIL, "", " " + cPict ) + ENDIF - oNewGet:PostBlock := iif(bValid==NIL,NIL,bValid) + IF cPict != NIL // Use the picture they passed + oNewGet:Picture := cPict + ELSE // Else setup default pictures + IF ValType( xVarVal ) == "D" + oNewGet:Picture := "99/99/99" + ELSEIF ValType( xVarVal ) == "L" + oNewGet:Picture := "Y" + ELSEIF ValType( xVarVal ) == "N" + oNewGet:Picture := "999999.99" // Guess that they are inputting dollars + ENDIF + ENDIF - oNewGet:Display() + oNewGet:PostBlock := iif( bValid == NIL, NIL, bValid ) - SETCURSOR(SC_NORMAL) - DO WHILE .T. // Loop so we can check for - // without reissuing the gets - ReadModal({oNewGet}) - IF LASTKEY() == K_ESC .AND. lNoESC // They pressed - _ftError("you cannot Abort! Please enter an answer.") - ELSE - EXIT - ENDIF + oNewGet:Display() - ENDDO + SetCursor( SC_NORMAL ) + DO WHILE .T. // Loop so we can check for + // without reissuing the gets + ReadModal( { oNewGet } ) + IF LastKey() == K_ESC .AND. lNoESC // They pressed + _ftError( "you cannot Abort! Please enter an answer." ) + ELSE + EXIT + ENDIF - _ftPopWin() + ENDDO - SETCURSOR(nOldCurs) - SETCOLOR(cOldColor) - SETPOS(nOldRow,nOldCol) - SET(_SET_DEVICE, cOldDevice) - SET(_SET_PRINTER, lOldPrint) - _ftSetLastKey(nOldLastKey) -RETURN xVarVal + _ftPopWin() + + SetCursor( nOldCurs ) + SetColor( cOldColor ) + SetPos( nOldRow, nOldCol ) + SET( _SET_DEVICE, cOldDevice ) + SET( _SET_PRINTER, lOldPrint ) + _ftSetLastKey( nOldLastKey ) + + RETURN xVarVal /*+- Function ---------------------------------------------------------------+ | Name: _ftAdderTapeUDF() Docs: Keith A. Wire | @@ -1252,33 +1302,37 @@ RETURN xVarVal | Return Value: nRtnVal | +--------------------------------------------------------------------------+ */ -FUNCTION _ftAdderTapeUDF(mode,cur_elem,rel_pos) - LOCAL nKey,nRtnVal - THREAD STATIC ac_exit_ok := .F. - HB_SYMBOL_UNUSED( cur_elem ) - HB_SYMBOL_UNUSED( rel_pos ) +FUNCTION _ftAdderTapeUDF( mode, cur_elem, rel_pos ) - DO CASE - CASE mode == AC_EXCEPT - nKey := LASTKEY() + LOCAL nKey, nRtnVal + + THREAD STATIC ac_exit_ok := .F. + + HB_SYMBOL_UNUSED( cur_elem ) + HB_SYMBOL_UNUSED( rel_pos ) + + DO CASE + CASE mode == AC_EXCEPT + nKey := LastKey() DO CASE - CASE nKey == 30 - nRtnVal := AC_CONT - CASE nKey == K_ESC - KEYBOARD CHR(K_CTRL_PGDN)+CHR(K_RETURN) // Go to last item - ac_exit_ok := .T. - nRtnVal := AC_CONT - CASE ac_exit_ok - nRtnVal := AC_ABORT - ac_exit_ok := .F. - OTHERWISE - nRtnVal := AC_CONT + CASE nKey == 30 + nRtnVal := AC_CONT + CASE nKey == K_ESC + KEYBOARD Chr( K_CTRL_PGDN ) + Chr( K_RETURN ) // Go to last item + ac_exit_ok := .T. + nRtnVal := AC_CONT + CASE ac_exit_ok + nRtnVal := AC_ABORT + ac_exit_ok := .F. + OTHERWISE + nRtnVal := AC_CONT ENDCASE - OTHERWISE + OTHERWISE nRtnVal := AC_CONT - ENDCASE -RETURN nRtnVal + ENDCASE + + RETURN nRtnVal /*+- Function ---------------------------------------------------------------+ | Name: _ftError() Docs: Keith A. Wire | @@ -1293,50 +1347,52 @@ RETURN nRtnVal | Return Value: NIL | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftError(cMessage, xDontReset) - LOCAL nOldRow,nOldCol,nOldCurs,nTop,nLeft,nBot,nRight,cOldColor, ; - nOldLastKey,cErrorScr,nMessLen,nWide,nNumRows,nKey, ; - cOldDevic,lOldPrint, ; - lResetLKey := iif(xDontReset==NIL, .T., .F.) - nOldLastKey := LASTKEY() - nOldRow := ROW() - nOldCol := COL() - nOldCurs := SETCURSOR(SC_NONE) - cOldColor:= _ftSetSCRColor(STD_ERROR) - cOldDevic := SET(_SET_DEVICE, "SCREEN") - lOldPrint := SET(_SET_PRINTER, .F.) - cMessage := "I'm sorry but, " + cMessage - nMessLen := LEN(cMessage) - nWide := iif(nMessLen>66,66,iif(nMessLen<12,12,nMessLen)) - nNumRows := MLCOUNT(cMessage,nWide) - nTop := INT((MAXROW() - nNumRows)/2) // Center it in the screen - nBot := nTop+3+nNumRows - nLeft := INT((MAXCOL()-nWide)/2)-2 - nRight := nLeft+nWide+4 +STATIC FUNCTION _ftError( cMessage, xDontReset ) - cErrorScr:=SAVESCREEN(nTop,nLeft,nBot+1,nRight+2) - _ftShadow(nBot+1,nLeft+2,nBot+1,nRight+2,8) - _ftShadow(nTop+1,nRight+1,nBot ,nRight+2,8) - @ nTop,nLeft,nBot,nRight BOX B_SINGLE - @ nTop,nLeft+INT(nWide/2)-1 SAY " ERROR " - @ nBot-1,nLeft+INT(nWide-28)/2+3 SAY "Press any key to continue..." - DISPMESSAGE cMessage,nTop+1,nLeft+3,nBot-2,nRight-3 - TONE(70,5) - FT_INKEY 0 TO nKey - RESTSCREEN(nTop,nLeft,nBot+1,nRight+2,cErrorScr) - SETCURSOR(nOldCurs) - SETCOLOR(cOldColor) - SETPOS(nOldRow,nOldCol) + LOCAL nOldRow, nOldCol, nOldCurs, nTop, nLeft, nBot, nRight, cOldColor + LOCAL nOldLastKey, cErrorScr, nMessLen, nWide, nNumRows, nKey + LOCAL cOldDevic, lOldPrint + LOCAL lResetLKey := iif( xDontReset == NIL, .T. , .F. ) - IF lResetLKey - _ftSetLastKey(nOldLastKey) - ENDIF + nOldLastKey := LastKey() + nOldRow := Row() + nOldCol := Col() + nOldCurs := SetCursor( SC_NONE ) + cOldColor := _ftSetSCRColor( STD_ERROR ) + cOldDevic := Set( _SET_DEVICE, "SCREEN" ) + lOldPrint := Set( _SET_PRINTER, .F. ) + cMessage := "I'm sorry but, " + cMessage + nMessLen := Len( cMessage ) + nWide := iif( nMessLen > 66, 66, iif( nMessLen < 12,12,nMessLen ) ) + nNumRows := MLCount( cMessage, nWide ) + nTop := Int( ( MaxRow() - nNumRows ) / 2 ) // Center it in the screen + nBot := nTop + 3 + nNumRows + nLeft := Int( ( MaxCol() - nWide ) / 2 ) - 2 + nRight := nLeft + nWide + 4 - SET(_SET_DEVICE, cOldDevic) - SET(_SET_PRINTER, lOldPrint) + cErrorScr := SaveScreen( nTop, nLeft, nBot + 1, nRight + 2 ) + _ftShadow( nBot + 1, nLeft + 2, nBot + 1, nRight + 2, 8 ) + _ftShadow( nTop + 1, nRight + 1, nBot , nRight + 2, 8 ) + @ nTop, nLeft, nBot, nRight BOX B_SINGLE + @ nTop, nLeft + Int( nWide / 2 ) - 1 SAY " ERROR " + @ nBot - 1, nLeft + Int( nWide - 28 ) / 2 + 3 SAY "Press any key to continue..." + DISPMESSAGE cMessage, nTop + 1, nLeft + 3, nBot - 2, nRight - 3 + Tone( 70, 5 ) + FT_INKEY 0 TO nKey + RestScreen( nTop, nLeft, nBot + 1, nRight + 2, cErrorScr ) + SetCursor( nOldCurs ) + SetColor( cOldColor ) + SetPos( nOldRow, nOldCol ) -RETURN NIL + IF lResetLKey + _ftSetLastKey( nOldLastKey ) + ENDIF + + SET( _SET_DEVICE, cOldDevic ) + SET( _SET_PRINTER, lOldPrint ) + + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftStuffComma() Docs: Keith A. Wire | @@ -1351,39 +1407,40 @@ RETURN NIL | Return Value: cStrToStuff | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftStuffComma(cStrToStuff,lTrimStuffedStr) - LOCAL nDecPosit, x +STATIC FUNCTION _ftStuffComma( cStrToStuff, lTrimStuffedStr ) - lTrimStuffedStr := iif(lTrimStuffedStr==NIL,.F.,lTrimStuffedStr) - IF !("." $ cStrToStuff) - cStrToStuff := _ftPosIns(cStrToStuff,".",iif("C"$cStrToStuff .OR. ; - "E"$cStrToStuff .OR. "+"$cStrToStuff .OR. "-"$cStrToStuff ; - .OR. "X"$cStrToStuff .OR. "*"$cStrToStuff .OR. ; - ""$cStrToStuff .OR. "/"$cStrToStuff .OR. "="$cStrToStuff,; - LEN(cStrToStuff)-1,LEN(cStrToStuff)+1)) + LOCAL nDecPosit, x - IF ASC(cStrToStuff) == K_SPACE .OR. ASC(cStrToStuff) == K_ZERO - cStrToStuff := SUBSTR(cStrToStuff, 2) - ENDIF + lTrimStuffedStr := iif( lTrimStuffedStr == NIL, .F. , lTrimStuffedStr ) + IF !( "." $ cStrToStuff ) + cStrToStuff := _ftPosIns( cStrToStuff, ".", iif( "C" $ cStrToStuff .OR. ; + "E" $ cStrToStuff .OR. "+" $ cStrToStuff .OR. "-" $ cStrToStuff ; + .OR. "X" $ cStrToStuff .OR. "*" $ cStrToStuff .OR. ; + "" $ cStrToStuff .OR. "/" $ cStrToStuff .OR. "=" $ cStrToStuff, ; + Len( cStrToStuff ) - 1, Len( cStrToStuff ) + 1 ) ) - ENDIF - nDecPosit := AT(".",cStrToStuff) + IF Asc( cStrToStuff ) == K_SPACE .OR. Asc( cStrToStuff ) == K_ZERO + cStrToStuff := SubStr( cStrToStuff, 2 ) + ENDIF - IF LEN(LEFT(LTRIM(_ftCharRem("-",cStrToStuff)), ; - AT(".",LTRIM(_ftCharRem("-",cStrToStuff)))-1))>3 - IF lTrimStuffedStr // Do we trim the number each time we insert a comma - FOR x := nDecPosit-3 TO 2+_ftCountLeft(cStrToStuff," ") STEP -4 - cStrToStuff := SUBSTR(_ftPosIns(cStrToStuff,",",x),2) - NEXT - ELSE - FOR x := nDecPosit-3 TO 2+_ftCountLeft(cStrToStuff," ") STEP -3 - cStrToStuff := _ftPosIns(cStrToStuff,",",x) - NEXT - ENDIF - ENDIF + ENDIF + nDecPosit := At( ".", cStrToStuff ) -RETURN cStrToStuff + IF Len( Left( LTrim(_ftCharRem("-",cStrToStuff ) ), ; + At( ".", LTrim( _ftCharRem("-",cStrToStuff ) ) ) - 1 ) ) > 3 + IF lTrimStuffedStr // Do we trim the number each time we insert a comma + FOR x := nDecPosit - 3 TO 2 + _ftCountLeft( cStrToStuff, " " ) STEP - 4 + cStrToStuff := SubStr( _ftPosIns( cStrToStuff,",",x ), 2 ) + NEXT + ELSE + FOR x := nDecPosit - 3 TO 2 + _ftCountLeft( cStrToStuff, " " ) STEP - 3 + cStrToStuff := _ftPosIns( cStrToStuff, ",", x ) + NEXT + ENDIF + ENDIF + + RETURN cStrToStuff /*+- Function ---------------------------------------------------------------+ | Name: _ftSetSCRColor() Docs: Keith A. Wire | @@ -1404,20 +1461,21 @@ RETURN cStrToStuff | See Also: _ftSetWinColor() | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftSetSCRColor(nStd,nEnh,nBord,nBack,nUnsel) - IF EMPTY(aWinColor) - _ftInitColors() - ENDIF +STATIC FUNCTION _ftSetSCRColor( nStd, nEnh, nBord, nBack, nUnsel ) - nStd := iif(nStd == NIL, 8, nStd) - nEnh := iif(nEnh == NIL, 8, nEnh) - nBord := iif(nBord == NIL, 8, nBord) - nBack := iif(nBack == NIL, 8, nBack) - nUnsel:= iif(nUnsel == NIL, nEnh, nUnsel) + IF Empty( aWinColor ) + _ftInitColors() + ENDIF -RETURN SETCOLOR(aStdColor[nStd]+","+aStdColor[nEnh]+","+aStdColor[nBord]+","+; - aStdColor[nBack]+","+aStdColor[nUnsel]) + nStd := iif( nStd == NIL, 8, nStd ) + nEnh := iif( nEnh == NIL, 8, nEnh ) + nBord := iif( nBord == NIL, 8, nBord ) + nBack := iif( nBack == NIL, 8, nBack ) + nUnsel := iif( nUnsel == NIL, nEnh, nUnsel ) + + RETURN SetColor( aStdColor[nStd] + "," + aStdColor[nEnh] + "," + aStdColor[nBord] + "," + ; + aStdColor[nBack] + "," + aStdColor[nUnsel] ) /*+- Function ---------------------------------------------------------------+ | Name: _ftPushWin() Docs: Keith A. Wire | @@ -1452,31 +1510,32 @@ RETURN SETCOLOR(aStdColor[nStd]+","+aStdColor[nEnh]+","+aStdColor[nBord]+","+; | : nWinColor DEFAULT == _ftNextWinColor() | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftPushWin(t,l,b,r,cTitle,cBotTitle,nWinColor) - LOCAL lAutoWindow := nWinColor==NIL +STATIC FUNCTION _ftPushWin( t, l, b, r, cTitle, cBotTitle, nWinColor ) - nWinColor := iif(nWinColor==NIL,_ftNextWinColor(),nWinColor) - AADD(aWindow,{t,l,b,r,nWinColor,SAVESCREEN(t,l,b+1,r+2),lAutoWindow}) - _ftShadow(b+1,l+2,b+1,r+2) - _ftShadow(t+1,r+1,b,r+2) - _ftSetWinColor(nWinColor,W_BORDER) - @ t,l,b,r BOX B_SINGLE + LOCAL lAutoWindow := nWinColor == NIL - IF cTitle!=NIL - _ftSetWinColor(nWinColor,W_TITLE) - _ftWinTitle(cTitle) - ENDIF + nWinColor := iif( nWinColor == NIL, _ftNextWinColor(), nWinColor ) + AAdd( aWindow, { t, l, b, r, nWinColor, SaveScreen( t,l,b + 1,r + 2 ), lAutoWindow } ) + _ftShadow( b + 1, l + 2, b + 1, r + 2 ) + _ftShadow( t + 1, r + 1, b, r + 2 ) + _ftSetWinColor( nWinColor, W_BORDER ) + @ t, l, b, r BOX B_SINGLE - IF cBotTitle!=NIL - _ftSetWinColor(nWinColor,W_TITLE) - _ftWinTitle(cBotTitle,"bot") - ENDIF + IF cTitle != NIL + _ftSetWinColor( nWinColor, W_TITLE ) + _ftWinTitle( cTitle ) + ENDIF - _ftSetWinColor(nWinColor,W_SCREEN,W_VARIAB) - @ t+1,l+1 CLEAR TO b-1,r-1 + IF cBotTitle != NIL + _ftSetWinColor( nWinColor, W_TITLE ) + _ftWinTitle( cBotTitle, "bot" ) + ENDIF -RETURN NIL + _ftSetWinColor( nWinColor, W_SCREEN, W_VARIAB ) + @ t + 1, l + 1 CLEAR TO b - 1, r - 1 + + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftPopWin Docs: Keith A. Wire | @@ -1495,27 +1554,28 @@ RETURN NIL | : the color to the color setting when window was pushed. | +--------------------------------------------------------------------------+ */ + STATIC FUNCTION _ftPopWin - LOCAL nNumWindow:=LEN(aWindow) + LOCAL nNumWindow := Len( aWindow ) - RESTSCREEN(aWindow[nNumWindow,1],aWindow[nNumWindow,2], ; - aWindow[nNumWindow,3]+1,aWindow[nNumWindow,4]+2, ; - aWindow[nNumWindow,6]) + RestScreen( aWindow[nNumWindow,1], aWindow[nNumWindow,2], ; + aWindow[nNumWindow,3] + 1, aWindow[nNumWindow,4] + 2, ; + aWindow[nNumWindow,6] ) - IF aWindow[nNumWindow,7] - _ftLastWinColor() - ENDIF + IF aWindow[nNumWindow,7] + _ftLastWinColor() + ENDIF - ASHRINK(aWindow) + ASHRINK( aWindow ) - IF !EMPTY(aWindow) - _ftSetWinColor(W_CURR,W_SCREEN,W_VARIAB) - ELSE - _ftSetSCRColor(STD_SCREEN,STD_VARIABLE) - ENDIF + IF !Empty( aWindow ) + _ftSetWinColor( W_CURR, W_SCREEN, W_VARIAB ) + ELSE + _ftSetSCRColor( STD_SCREEN, STD_VARIABLE ) + ENDIF -RETURN NIL + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftSetWinColor() Docs: Keith A. Wire | @@ -1539,17 +1599,18 @@ RETURN NIL | : window number nWinColor. | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftSetWinColor(nWin,nStd,nEnh,nBord,nBack,nUnsel) - nWin := iif(nWin == NIL, nWinColor, nWin) - nStd := iif(nStd == NIL, 7, nStd) - nEnh := iif(nEnh == NIL, 7, nEnh) - nBord := iif(nBord == NIL, 7, nBord) - nBack := iif(nBack == NIL, 7, nBack) - nUnsel:= iif(nUnsel == NIL, nEnh, nUnsel) +STATIC FUNCTION _ftSetWinColor( nWin, nStd, nEnh, nBord, nBack, nUnsel ) -RETURN SETCOLOR(aWinColor[nStd,nWin]+","+aWinColor[nEnh,nWin]+","+ ; - aWinColor[nBord,nWin]+","+aWinColor[nBack,nWin]+","+aWinColor[nUnsel,nWin]) + nWin := iif( nWin == NIL, nWinColor, nWin ) + nStd := iif( nStd == NIL, 7, nStd ) + nEnh := iif( nEnh == NIL, 7, nEnh ) + nBord := iif( nBord == NIL, 7, nBord ) + nBack := iif( nBack == NIL, 7, nBack ) + nUnsel := iif( nUnsel == NIL, nEnh, nUnsel ) + + RETURN SetColor( aWinColor[nStd,nWin] + "," + aWinColor[nEnh,nWin] + "," + ; + aWinColor[nBord,nWin] + "," + aWinColor[nBack,nWin] + "," + aWinColor[nUnsel,nWin] ) /*+- Function ---------------------------------------------------------------+ | Name: _ftShadow() Docs: Keith A. Wire | @@ -1567,14 +1628,15 @@ RETURN SETCOLOR(aWinColor[nStd,nWin]+","+aWinColor[nEnh,nWin]+","+ ; | See Also: _ftPushWin() | +--------------------------------------------------------------------------+ */ + STATIC FUNCTION _ftShadow( nTop, nLeft, nBottom, nRight ) - LOCAL theShadow := SAVESCREEN(nTop, nLeft, nBottom, nRight) + LOCAL theShadow := SaveScreen( nTop, nLeft, nBottom, nRight ) - RESTSCREEN( nTop, nLeft, nBottom, nRight, ; - TRANSFORM( theShadow,REPLICATE("X", LEN(theShadow)/2 ) ) ) + RestScreen( nTop, nLeft, nBottom, nRight, ; + Transform( theShadow, Replicate( "X", Len( theShadow ) / 2 ) ) ) -RETURN NIL + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftLastWinColor Docs: Keith A. Wire | @@ -1590,8 +1652,10 @@ RETURN NIL | Notes: If we are already on window #1 restart count by using # 4. | +--------------------------------------------------------------------------+ */ + STATIC FUNCTION _ftLastWinColor -RETURN nWinColor := iif(nWinColor==1,4,nWinColor-1) + + RETURN nWinColor := iif( nWinColor == 1, 4, nWinColor - 1 ) /*+- Function ---------------------------------------------------------------+ | Name: _ftNextWinColor Docs: Keith A. Wire | @@ -1607,12 +1671,14 @@ RETURN nWinColor := iif(nWinColor==1,4,nWinColor-1) | Notes: If we are already on window #4 restart count by using # 1. | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftNextWinColor - IF EMPTY(aWinColor) - _ftInitColors() - ENDIF -RETURN nWinColor := (iif(nWinColor<4,nWinColor+1,1)) +STATIC FUNCTION _ftNextWinColor + + IF Empty( aWinColor ) + _ftInitColors() + ENDIF + + RETURN nWinColor := ( iif( nWinColor < 4,nWinColor + 1,1 ) ) /*+- Function ---------------------------------------------------------------+ | Name: _ftWinTitle() Docs: Keith A. Wire | @@ -1628,15 +1694,16 @@ RETURN nWinColor := (iif(nWinColor<4,nWinColor+1,1)) | Return Value: NIL | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftWinTitle(cTheTitle,cTopOrBot) - LOCAL nCurWin :=LEN(aWindow), ; - nLenTitle:=LEN(cTheTitle) +STATIC FUNCTION _ftWinTitle( cTheTitle, cTopOrBot ) - @ aWindow[nCurWin,iif(cTopOrBot==NIL,1,3)],(aWindow[nCurWin,4]- ; - aWindow[nCurWin,2]-nLenTitle)/2+aWindow[nCurWin,2] SAY " "+cTheTitle+" " + LOCAL nCurWin := Len( aWindow ) + LOCAL nLenTitle := Len( cTheTitle ) -RETURN NIL + @ aWindow[ nCurWin, iif( cTopOrBot == NIL, 1 , 3 ) ], ( aWindow[ nCurWin, 4 ] - ; + aWindow[ nCurWin, 2 ] - nLenTitle ) / 2 + aWindow[ nCurWin, 2 ] SAY " " + cTheTitle + " " + + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftInitColors Docs: Keith A. Wire | @@ -1650,26 +1717,28 @@ RETURN NIL | Return Value: NIL | +--------------------------------------------------------------------------+ */ + STATIC FUNCTION _ftInitColors - aWinColor := { {"GR+/BG","GR+/G", "B+/RB", "G+/R"} , ; - {"R+/N", "W+/RB","W+/BG","GR+/B"} , ; - {"GR+/N", "GR+/N","GR+/N", "GR+/N"} , ; - { "B/BG","BG+/G", "W+/RB","BG+/R"} , ; - { "W+/BG", "W+/G","GR+/RB", "W+/R"} , ; - {"GR+/B", "GR+/R", "R+/B", "W+/BG"}, ; - { "N/N", "N/N", "N/N", "N/N"} } + aWinColor := { { "GR+/BG","GR+/G", "B+/RB", "G+/R" } , ; + { "R+/N", "W+/RB", "W+/BG", "GR+/B" } , ; + { "GR+/N", "GR+/N", "GR+/N", "GR+/N" } , ; + { "B/BG", "BG+/G", "W+/RB", "BG+/R" } , ; + { "W+/BG", "W+/G", "GR+/RB", "W+/R" } , ; + { "GR+/B", "GR+/R", "R+/B", "W+/BG" }, ; + { "N/N", "N/N", "N/N", "N/N" } } - aStdColor := { "BG+*/RB" , ; - "GR+/R" , ; - "GR+/N" , ; - "W/B" , ; - "GR+/N" , ; - "GR+/GR" , ; - { "W+/B", "W/B","G+/B","R+/B", ; - "GR+/B","BG+/B","B+/B","G+/B"}, ; - "N/N" } -RETURN NIL + aStdColor := { "BG+*/RB" , ; + "GR+/R" , ; + "GR+/N" , ; + "W/B" , ; + "GR+/N" , ; + "GR+/GR" , ; + { "W+/B", "W/B", "G+/B", "R+/B", ; + "GR+/B", "BG+/B", "B+/B", "G+/B" }, ; + "N/N" } + + RETURN NIL /*+- Function ---------------------------------------------------------------+ | Name: _ftCharOdd() Docs: Keith A. Wire | @@ -1685,9 +1754,12 @@ RETURN NIL | : from a screen save. | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftCharOdd(cString) - cString := TRANSFORM(cString,REPLICATE("X", LEN(cString)/2 ) ) -RETURN STRTRAN(cString,"") + +STATIC FUNCTION _ftCharOdd( cString ) + + cString := Transform( cString, Replicate( "X", Len( cString ) / 2 ) ) + + RETURN StrTran( cString, "" ) /*+- Function ---------------------------------------------------------------+ | Name: _ftPosRepl() Docs: Keith A. Wire | @@ -1703,8 +1775,10 @@ RETURN STRTRAN(cString,"") | Return Value: STRTRAN(cString,"9",cChar,nPosit,1)+"" | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftPosRepl(cString,cChar,nPosit) -RETURN STRTRAN(cString,"9",cChar,nPosit,1)+"" + +STATIC FUNCTION _ftPosRepl( cString, cChar, nPosit ) + + RETURN StrTran( cString, "9", cChar, nPosit, 1 ) + "" /*+- Function ---------------------------------------------------------------+ | Name: _ftCharRem() Docs: Keith A. Wire | @@ -1719,8 +1793,10 @@ RETURN STRTRAN(cString,"9",cChar,nPosit,1)+"" | Return Value: STRTRAN(cString,cChar) | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftCharRem(cChar,cString) -RETURN STRTRAN(cString,cChar) + +STATIC FUNCTION _ftCharRem( cChar, cString ) + + RETURN StrTran( cString, cChar ) /*+- Function ---------------------------------------------------------------+ | Name: _ftCountLeft() Docs: Keith A. Wire | @@ -1734,8 +1810,10 @@ RETURN STRTRAN(cString,cChar) | Return Value: LEN(cString)-LEN(LTRIM(cString)) | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftCountLeft(cString) -RETURN LEN(cString)-LEN(LTRIM(cString)) + +STATIC FUNCTION _ftCountLeft( cString ) + + RETURN Len( cString ) - Len( LTrim( cString ) ) /*+- Function ---------------------------------------------------------------+ | Name: _ftPosIns() Docs: Keith A. Wire | @@ -1751,5 +1829,7 @@ RETURN LEN(cString)-LEN(LTRIM(cString)) | Return Value: LEFT(cString,nPosit-1)+cChar+SUBSTR(cString,nPosit) | +--------------------------------------------------------------------------+ */ -STATIC FUNCTION _ftPosIns(cString,cChar,nPosit) -RETURN LEFT(cString,nPosit-1)+cChar+SUBSTR(cString,nPosit) + +STATIC FUNCTION _ftPosIns( cString, cChar, nPosit ) + + RETURN Left( cString, nPosit - 1 ) + cChar + SubStr( cString, nPosit ) diff --git a/harbour/contrib/hbnf/prtesc.prg b/harbour/contrib/hbnf/prtesc.prg index df980b0c89..a7864f99c1 100644 --- a/harbour/contrib/hbnf/prtesc.prg +++ b/harbour/contrib/hbnf/prtesc.prg @@ -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 diff --git a/harbour/contrib/hbnf/pvid.prg b/harbour/contrib/hbnf/pvid.prg index 2861a93ac6..97fb30aed7 100644 --- a/harbour/contrib/hbnf/pvid.prg +++ b/harbour/contrib/hbnf/pvid.prg @@ -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 ) diff --git a/harbour/contrib/hbnf/qtr.prg b/harbour/contrib/hbnf/qtr.prg index 77c64b0b0e..de6988e581 100644 --- a/harbour/contrib/hbnf/qtr.prg +++ b/harbour/contrib/hbnf/qtr.prg @@ -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 diff --git a/harbour/contrib/hbnf/rand1.prg b/harbour/contrib/hbnf/rand1.prg index 3fc73710b1..de566c45d5 100644 --- a/harbour/contrib/hbnf/rand1.prg +++ b/harbour/contrib/hbnf/rand1.prg @@ -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 ) diff --git a/harbour/contrib/hbnf/restsets.prg b/harbour/contrib/hbnf/restsets.prg index 0b0a977fa6..a68e9f5b98 100644 --- a/harbour/contrib/hbnf/restsets.prg +++ b/harbour/contrib/hbnf/restsets.prg @@ -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 diff --git a/harbour/contrib/hbnf/savearr.prg b/harbour/contrib/hbnf/savearr.prg index b31573a5be..5c17cf7fed 100644 --- a/harbour/contrib/hbnf/savearr.prg +++ b/harbour/contrib/hbnf/savearr.prg @@ -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 diff --git a/harbour/contrib/hbnf/savesets.prg b/harbour/contrib/hbnf/savesets.prg index 2f2d56a1bc..81d38a2610 100644 --- a/harbour/contrib/hbnf/savesets.prg +++ b/harbour/contrib/hbnf/savesets.prg @@ -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 diff --git a/harbour/contrib/hbnf/scancode.prg b/harbour/contrib/hbnf/scancode.prg index 65b4279efa..b2d8769607 100644 --- a/harbour/contrib/hbnf/scancode.prg +++ b/harbour/contrib/hbnf/scancode.prg @@ -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 ] ) ) diff --git a/harbour/contrib/hbnf/scregion.prg b/harbour/contrib/hbnf/scregion.prg index af203e61ff..a627f70669 100644 --- a/harbour/contrib/hbnf/scregion.prg +++ b/harbour/contrib/hbnf/scregion.prg @@ -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 diff --git a/harbour/contrib/hbnf/setdate.prg b/harbour/contrib/hbnf/setdate.prg index ce2d091f64..d34545e06b 100644 --- a/harbour/contrib/hbnf/setdate.prg +++ b/harbour/contrib/hbnf/setdate.prg @@ -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 ) diff --git a/harbour/contrib/hbnf/settime.prg b/harbour/contrib/hbnf/settime.prg index 7fa8ce7fc4..facd6aaf82 100644 --- a/harbour/contrib/hbnf/settime.prg +++ b/harbour/contrib/hbnf/settime.prg @@ -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 ) diff --git a/harbour/contrib/hbnf/sinkey.prg b/harbour/contrib/hbnf/sinkey.prg index 31f9db0227..377320cbbd 100644 --- a/harbour/contrib/hbnf/sinkey.prg +++ b/harbour/contrib/hbnf/sinkey.prg @@ -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 diff --git a/harbour/contrib/hbnf/sleep.prg b/harbour/contrib/hbnf/sleep.prg index fdb7e0ce48..e8b229b243 100644 --- a/harbour/contrib/hbnf/sleep.prg +++ b/harbour/contrib/hbnf/sleep.prg @@ -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 diff --git a/harbour/contrib/hbnf/sqzn.prg b/harbour/contrib/hbnf/sqzn.prg index 0569eb41c2..8b9a2516cf 100644 --- a/harbour/contrib/hbnf/sqzn.prg +++ b/harbour/contrib/hbnf/sqzn.prg @@ -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 diff --git a/harbour/contrib/hbnf/sysmem.prg b/harbour/contrib/hbnf/sysmem.prg index 325ef4f91e..a95b07c502 100644 --- a/harbour/contrib/hbnf/sysmem.prg +++ b/harbour/contrib/hbnf/sysmem.prg @@ -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 ] diff --git a/harbour/contrib/hbnf/tbwhile.prg b/harbour/contrib/hbnf/tbwhile.prg index 0c62762734..4eeeb2d8ca 100644 --- a/harbour/contrib/hbnf/tbwhile.prg +++ b/harbour/contrib/hbnf/tbwhile.prg @@ -55,144 +55,146 @@ * 2. Passing and evaluating the block for the TbSkipWhil(). */ -#command DEFAULT TO [, TO ]; -=> ; - := iif( == NIL, , ) ; - [; := iif( == NIL, , ) ] +#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 diff --git a/harbour/contrib/hbnf/tempfile.prg b/harbour/contrib/hbnf/tempfile.prg index afa1a5d9b6..6a77443a85 100644 --- a/harbour/contrib/hbnf/tempfile.prg +++ b/harbour/contrib/hbnf/tempfile.prg @@ -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 diff --git a/harbour/contrib/hbnf/vertmenu.prg b/harbour/contrib/hbnf/vertmenu.prg index abe9887cff..2b07e79609 100644 --- a/harbour/contrib/hbnf/vertmenu.prg +++ b/harbour/contrib/hbnf/vertmenu.prg @@ -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 diff --git a/harbour/contrib/hbnf/vidcur.prg b/harbour/contrib/hbnf/vidcur.prg index 3bd301f1d6..acd042257a 100644 --- a/harbour/contrib/hbnf/vidcur.prg +++ b/harbour/contrib/hbnf/vidcur.prg @@ -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 ] ) } diff --git a/harbour/contrib/hbnf/vidmode.prg b/harbour/contrib/hbnf/vidmode.prg index 27d2016784..f56e53bd4c 100644 --- a/harbour/contrib/hbnf/vidmode.prg +++ b/harbour/contrib/hbnf/vidmode.prg @@ -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() diff --git a/harbour/contrib/hbnf/wda.prg b/harbour/contrib/hbnf/wda.prg index 12ef380152..fd4767d022 100644 --- a/harbour/contrib/hbnf/wda.prg +++ b/harbour/contrib/hbnf/wda.prg @@ -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 ; + ) diff --git a/harbour/contrib/hbnf/week.prg b/harbour/contrib/hbnf/week.prg index 9a83e1be7a..be12157468 100644 --- a/harbour/contrib/hbnf/week.prg +++ b/harbour/contrib/hbnf/week.prg @@ -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 diff --git a/harbour/contrib/hbnf/workdays.prg b/harbour/contrib/hbnf/workdays.prg index 0faed6007c..44b9c934e4 100644 --- a/harbour/contrib/hbnf/workdays.prg +++ b/harbour/contrib/hbnf/workdays.prg @@ -28,29 +28,34 @@ */ #ifdef FT_TEST - PROCEDURE Main( cStart, cStop ) - qout( ft_workdays( ctod( cStart ), ctod( cStop ) ) ) - RETURN + +PROCEDURE Main( cStart, cStop ) + + QOut( ft_workdays( CToD( cStart ), CToD( cStop ) ) ) + + RETURN + #endif FUNCTION FT_WorkDays( dStart, dStop ) + LOCAL nWorkDays := 0, nDays, nAdjust - IF dStart # NIL .AND. dStop # NIL - IF dStart # dStop + IF dStart != NIL .AND. dStop != NIL + IF dStart != dStop IF dStart > dStop // Swap the values - nAdjust := dStop + nAdjust := dStop dStop := dStart - dStart := nAdjust + dStart := nAdjust ENDIF - IF ( nDays := Dow( dStart ) ) == 1 // Sunday (change to next Monday) + IF ( nDays := DOW( dStart ) ) == 1 // Sunday (change to next Monday) dStart++ ELSEIF nDays == 7 // Saturday (change to next Monday) dStart += 2 ENDIF - IF ( nDays := Dow( dStop ) ) == 1 // Sunday (change to prev Friday) + IF ( nDays := DOW( dStop ) ) == 1 // Sunday (change to prev Friday) dStop -= 2 ELSEIF nDays == 7 // Saturday (change to prev Friday) dStop-- @@ -58,13 +63,13 @@ FUNCTION FT_WorkDays( dStart, dStop ) nAdjust := ( nDays := dStop - dStart + 1 ) % 7 - IF Dow( dStop ) + 1 < Dow( dStart ) // Weekend adjustment + IF DOW( dStop ) + 1 < DOW( dStart ) // Weekend adjustment nAdjust -= 2 ENDIF nWorkDays := Int( nDays / 7 ) * 5 + nAdjust - ELSEIF ( Dow( dStart ) # 1 .AND. Dow( dStart ) # 7 ) + ELSEIF ( DOW( dStart ) != 1 .AND. DOW( dStart ) != 7 ) nWorkDays := 1 @@ -72,4 +77,4 @@ FUNCTION FT_WorkDays( dStart, dStop ) ENDIF -RETURN ( iif(nWorkDays>0,nWorkDays,0) ) + RETURN iif( nWorkDays > 0, nWorkDays, 0 ) diff --git a/harbour/contrib/hbnf/woy.prg b/harbour/contrib/hbnf/woy.prg index 752d0d99d4..05394bbb61 100644 --- a/harbour/contrib/hbnf/woy.prg +++ b/harbour/contrib/hbnf/woy.prg @@ -27,109 +27,110 @@ #ifdef FT_TEST - // ADD PARAMETER "CENTURY" ON COMMAND LINES TO TEST 4-DIGIT YEARS +// ADD PARAMETER "CENTURY" ON COMMAND LINES TO TEST 4-DIGIT YEARS - PROCEDURE Main( cCent ) - LOCAL lCentOn := .F., cDate - MEMVAR getlist +PROCEDURE Main( cCent ) - IF VALTYPE( cCent) == "C" .AND. "CENT" $ UPPER( cCent) - SET CENTURY ON - lCentOn := .T. - ENDIF + LOCAL lCentOn := .F. , cDate + MEMVAR getlist - DO WHILE .T. - CLEAR - @ 2,10 SAY "Date to Test" + IF ValType( cCent ) == "C" .AND. "CENT" $ Upper( cCent ) + SET CENTURY ON + lCentOn := .T. + ENDIF - IF lCentOn - cDate := SPACE(10) - @ 2,24 GET cDate PICTURE "##/##/####" - ELSE - cDate := SPACE(8) - @ 2,24 GET cDate PICTURE "##/##/##" - ENDIF - READ + DO WHILE .T. + CLEAR + @ 2, 10 SAY "Date to Test" - IF EMPTY(cDate) - EXIT - ENDIF + IF lCentOn + cDate := Space( 10 ) + @ 2, 24 GET cDate PICTURE "##/##/####" + ELSE + cDate := Space( 8 ) + @ 2, 24 GET cDate PICTURE "##/##/##" + ENDIF + READ - IF Left( DTOC( CTOD( cDate) ), 1 ) == " " - QQOUT( CHR( 7) ) - @ 4,24 SAY "INVALID DATE" - INKEY(2) - LOOP - ENDIF + IF Empty( cDate ) + EXIT + ENDIF - @ 4,10 SAY "Is Day Number " + STR( FT_DOY( CTOD( cDate)) ,3) + IF Left( DToC( CToD( cDate ) ), 1 ) == " " + QQOut( Chr( 7 ) ) + @ 4, 24 SAY "INVALID DATE" + Inkey( 2 ) + LOOP + ENDIF - @ 6,10 SAY "Is in Week Number " + STR( FT_WOY( CTOD( cDate)) ,2) - @ 7,0 - WAIT - ENDDO + @ 4, 10 SAY "Is Day Number " + Str( FT_DOY( CToD( cDate ) ), 3 ) - CLEAR - RETURN + @ 6, 10 SAY "Is in Week Number " + Str( FT_WOY( CToD( cDate ) ), 2 ) + @ 7, 0 + WAIT + ENDDO + + CLEAR + + RETURN #endif -FUNCTION FT_WOY(dInDate) +FUNCTION FT_WOY( dInDate ) - LOCAL nFirstDays, nDayOffset, nWkNumber, cCentury + LOCAL nFirstDays, nDayOffset, nWkNumber, cCentury - IF VALTYPE( dInDate) != "D" - nWkNumber := NIL + IF !( ValType( dInDate ) == "D" ) + nWkNumber := NIL + ELSE - ELSE + // resolve century issue + IF Len( DToC( dInDate ) ) > 8 // CENTURY is on + cCentury := SubStr( DToC( dInDate ), 7, 4 ) + ELSE + cCentury := SubStr( DToC( dInDate ), 7, 2 ) + ENDIF - // resolve century issue - IF LEN( DTOC( dInDate) ) > 8 // CENTURY is on - cCentury := SUBSTR( DTOC( dInDate) ,7 ,4) - ELSE - cCentury := SUBSTR( DTOC( dInDate) ,7 ,2) - END + // find number of days in first week of year - // find number of days in first week of year + nFirstDays := 8 - ( DOW( CToD( "01/01/" + cCentury ) ) ) - nFirstDays := 8 - (DOW (CTOD ("01/01/" + cCentury) ) ) + nWkNumber := 1 - nWkNumber := 1 + // find how many days after first week till dInDate - // find how many days after first week till dInDate + nDayOffset := ( dInDate - ; + CToD( "01/01/" + cCentury ) ) - nFirstDays + 1 - nDayOffset := (dInDate - ; - CTOD ("01/01/" + cCentury) ) - nFirstDays + 1 + // count weeks in offset period - // count weeks in offset period + DO WHILE nDayOffset > 0 + ++nWkNumber + nDayOffset -= 7 + ENDDO - DO WHILE nDayOffset > 0 - ++nWkNumber - nDayOffset -= 7 - END + ENDIF - END + RETURN nWkNumber -RETURN (nWkNumber) +FUNCTION FT_DOY( dInDate ) -FUNCTION FT_DOY(dInDate) + LOCAL nDayNum, cCentury - LOCAL nDayNum, cCentury + IF !( ValType( dInDate ) == "D" ) + nDayNum := NIL + ELSE - IF VALTYPE(dInDate) != "D" - nDayNum := NIL - ELSE + // resolve century issue + IF Len( DToC( dInDate ) ) > 8 // CENTURY is on + cCentury := SubStr( DToC( dInDate ), 7, 4 ) + ELSE + cCentury := SubStr( DToC( dInDate ), 7, 2 ) + ENDIF - // resolve century issue - IF LEN( DTOC( dInDate) ) > 8 // CENTURY is on - cCentury := SUBSTR( DTOC( dInDate) ,7 ,4) - ELSE - cCentury := SUBSTR( DTOC( dInDate) ,7 ,2) - END + // calculate + nDayNum := ( dInDate - CToD( "01/01/" + cCentury ) ) + 1 - // calculate - nDayNum := (dInDate - CTOD ("01/01/" + cCentury)) + 1 + ENDIF - END - -RETURN (nDayNum) + RETURN nDayNum diff --git a/harbour/contrib/hbnf/xbox.prg b/harbour/contrib/hbnf/xbox.prg index c824bd87be..9e49ed646c 100644 --- a/harbour/contrib/hbnf/xbox.prg +++ b/harbour/contrib/hbnf/xbox.prg @@ -28,24 +28,28 @@ */ #ifdef FT_TEST - PROCEDURE Main() - local i - setcolor('W/B') - * clear screen - for i := 1 to 24 - @ i, 0 say replicate('@', 80) - next - FT_XBOX(,,,,,,,'This is a test','of the XBOX() function') - FT_XBOX('L','W','D','GR+/R','W/B',1,10,'It is so nice',; - 'to not have to do the messy chore',; - 'of calculating the box size!') - FT_XBOX(,'W','D','GR+/R','W/B',16,10,'It is so nice',; - 'to not have to do the messy chore',; - 'of calculating the box size!',; - 'Even though this line is way too long, and is in fact more than 80 characters long, if you care to check!') +PROCEDURE Main() + + LOCAL i + + SetColor( 'W/B' ) +// clear screen + FOR i := 1 TO 24 + @ i, 0 SAY Replicate( '@', 80 ) + NEXT + + FT_XBOX( , , , , , , , 'This is a test', 'of the XBOX() function' ) + FT_XBOX( 'L', 'W', 'D', 'GR+/R', 'W/B', 1, 10, 'It is so nice', ; + 'to not have to do the messy chore', ; + 'of calculating the box size!' ) + FT_XBOX( , 'W', 'D', 'GR+/R', 'W/B', 16, 10, 'It is so nice', ; + 'to not have to do the messy chore', ; + 'of calculating the box size!', ; + 'Even though this line is way too long, and is in fact more than 80 characters long, if you care to check!' ) RETURN + #endif /* NOTE: In original NF, flag parameters were also accepted when @@ -53,105 +57,107 @@ but only if _SET_EXACT was set to .F., Harbour accepts them that way regardless of _SET_EXACT setting. [vszakats] */ -FUNCTION FT_XBOX(cJustType,; // "L" -> left, otherwise centered - cRetWait, ; // "W" -> wait for keypress before continuing - cBorType, ; // "D" -> double, anything else single border - cBorColor,; // color string for border - cBoxColor,; // color string for text - nStartRow,; // upper row of box. 99=center vertically - nStartCol,; // left edge of box. 99=center horizontally - cLine1, cLine2, cLine3, cLine4, cLine5, cLine6, cLine7, cLine8) +FUNCTION FT_XBOX( cJustType, ; // "L" -> left, otherwise centered + cRetWait, ; // "W" -> wait for keypress before continuing + cBorType, ; // "D" -> double, anything else single border + cBorColor, ; // color string for border + cBoxColor, ; // color string for text + nStartRow, ; // upper row of box. 99=center vertically + nStartCol, ; // left edge of box. 99=center horizontally + cLine1, cLine2, cLine3, cLine4, cLine5, cLine6, cLine7, cLine8 ) - LOCAL nLLen := 0, ; - ;// cOldColor, ; - nLCol, ; - nRCol, ; - nTRow, ; - nBRow, ; - nLoop, ; - nSayRow, ; - nSayCol, ; - nNumRows, ; - aLines_[8] + LOCAL nLLen := 0 +// LOCAL cOldColor + LOCAL nLCol + LOCAL nRCol + LOCAL nTRow + LOCAL nBRow + LOCAL nLoop + LOCAL nSayRow + LOCAL nSayCol + LOCAL nNumRows + LOCAL aLines_[ 8 ] - IF cJustType == NIL - cJustType := "" - ENDIF - IF cRetWait == NIL - cRetWait := "" - ENDIF - IF cBorType == NIL - cBorType := "" - ENDIF + IF cJustType == NIL + cJustType := "" + ENDIF + IF cRetWait == NIL + cRetWait := "" + ENDIF + IF cBorType == NIL + cBorType := "" + ENDIF - // validate parameters - cJustType := iif(ValType(cJustType)=='C',Upper(cJustType),'') - cRetWait := iif(ValType(cRetWait )=='C',Upper(cRetWait), '') - cBorType := iif(ValType(cBorType )=='C',Upper(cBorType), '') - cBorColor := iif(ValType(cBoxColor)=='C',cBorColor, 'N/W') - cBoxColor := iif(ValType(cBoxColor)=='C',cBoxColor, 'W/N') - nStartRow := iif(ValType(nStartRow)=='N',nStartRow,99) - nStartCol := iif(ValType(nStartCol)=='N',nStartCol,99) +// validate parameters + cJustType := iif( ValType( cJustType ) == 'C', Upper( cJustType ), '' ) + cRetWait := iif( ValType( cRetWait ) == 'C', Upper( cRetWait ), '' ) + cBorType := iif( ValType( cBorType ) == 'C', Upper( cBorType ), '' ) + cBorColor := iif( ValType( cBoxColor ) == 'C', cBorColor, 'N/W' ) + cBoxColor := iif( ValType( cBoxColor ) == 'C', cBoxColor, 'W/N' ) + nStartRow := iif( ValType( nStartRow ) == 'N', nStartRow, 99 ) + nStartCol := iif( ValType( nStartCol ) == 'N', nStartCol, 99 ) - nNumRows := Min(PCount()-7,8) + nNumRows := Min( PCount() - 7, 8 ) - //establish array of strings to be displayed - aLines_[1] := iif(ValType(cLine1) == 'C',AllTrim(SubStr(cLine1,1,74)),'') - aLines_[2] := iif(ValType(cLine2) == 'C',AllTrim(SubStr(cLine2,1,74)),'') - aLines_[3] := iif(ValType(cLine3) == 'C',AllTrim(SubStr(cLine3,1,74)),'') - aLines_[4] := iif(ValType(cLine4) == 'C',AllTrim(SubStr(cLine4,1,74)),'') - aLines_[5] := iif(ValType(cLine5) == 'C',AllTrim(SubStr(cLine5,1,74)),'') - aLines_[6] := iif(ValType(cLine6) == 'C',AllTrim(SubStr(cLine6,1,74)),'') - aLines_[7] := iif(ValType(cLine7) == 'C',AllTrim(SubStr(cLine7,1,74)),'') - aLines_[8] := iif(ValType(cLine8) == 'C',AllTrim(SubStr(cLine8,1,74)),'') - ASize(aLines_,Min(nNumRows,8)) +//establish array of strings to be displayed + aLines_[1] := iif( ValType( cLine1 ) == 'C', AllTrim( SubStr(cLine1, 1, 74 ) ), '' ) + aLines_[2] := iif( ValType( cLine2 ) == 'C', AllTrim( SubStr(cLine2, 1, 74 ) ), '' ) + aLines_[3] := iif( ValType( cLine3 ) == 'C', AllTrim( SubStr(cLine3, 1, 74 ) ), '' ) + aLines_[4] := iif( ValType( cLine4 ) == 'C', AllTrim( SubStr(cLine4, 1, 74 ) ), '' ) + aLines_[5] := iif( ValType( cLine5 ) == 'C', AllTrim( SubStr(cLine5, 1, 74 ) ), '' ) + aLines_[6] := iif( ValType( cLine6 ) == 'C', AllTrim( SubStr(cLine6, 1, 74 ) ), '' ) + aLines_[7] := iif( ValType( cLine7 ) == 'C', AllTrim( SubStr(cLine7, 1, 74 ) ), '' ) + aLines_[8] := iif( ValType( cLine8 ) == 'C', AllTrim( SubStr(cLine8, 1, 74 ) ), '' ) + ASize( aLines_, Min( nNumRows, 8 ) ) - // determine longest line - nLoop := 1 - AEVAL(aLines_,{|| nLLen:=Max(nLLen,Len(aLines_[nLoop])),nLoop++}) +// determine longest line + nLoop := 1 + AEval( aLines_, {|| nLLen := Max( nLLen, Len( aLines_[ nLoop ] ) ), nLoop++ } ) - // calculate corners - nLCol := iif(nStartCol==99,Int((76-nLLen)/2),Min(nStartCol,74-nLLen)) - nRCol := nLCol+nLLen+3 - nTRow := iif(nStartRow==99,INT((24-nNumRows)/2),Min(nStartRow,22-nNumRows)) - nBRow := nTRow+nNumRows+1 +// calculate corners + nLCol := iif( nStartCol == 99, Int( ( 76 - nLLen ) / 2 ), Min( nStartCol, 74 - nLLen ) ) + nRCol := nLCol + nLLen + 3 + nTRow := iif( nStartRow == 99, Int( ( 24 - nNumRows ) / 2 ), Min( nStartRow, 22 - nNumRows ) ) + nBRow := nTRow + nNumRows + 1 - // form box and border +// form box and border - // save screen color and set new color - //cOldColor := SetColor(cBoxColor) - @ nTRow,nLCol Clear to nBRow,nRCol +// save screen color and set new color +// cOldColor := SetColor( cBoxColor ) + @ nTRow, nLCol CLEAR TO nBRow, nRCol - // draw border - SetColor(cBorColor) - IF Left( cBorType, 1 ) == "D" - @ nTRow,nLCol TO nBRow,nRCol double - ELSE - @ nTRow,nLCol TO nBRow,nRCol - ENDIF +// draw border + SetColor( cBorColor ) + IF Left( cBorType, 1 ) == "D" + @ nTRow, nLCol TO nBRow, nRCol double + ELSE + @ nTRow, nLCol TO nBRow, nRCol + ENDIF - // write shadow - FT_SHADOW(nTRow,nLCol,nBRow,nRCol) +// write shadow + FT_SHADOW( nTRow, nLCol, nBRow, nRCol ) - // print text in box - SetColor(cBoxColor) - nLoop :=1 - AEVAL(aLines_,{|cSayStr|; - nSayRow := nTRow+nLoop,; - nSayCol := iif( Left( cJustType, 1 ) == 'L',; - nLCol+2,; - nLCol+2+(nLLen-Int(Len(aLines_[nLoop])))/2),; - nLoop++,; - _FTSAY(nSayRow,nSayCol,cSayStr); - }) +// print text in box + SetColor( cBoxColor ) + nLoop := 1 + AEval( aLines_, {| cSayStr |; + nSayRow := nTRow + nLoop, ; + nSayCol := iif( Left( cJustType, 1 ) == 'L', ; + nLCol + 2, ; + nLCol + 2 + ( nLLen - Int( Len( aLines_[ nLoop ] ) ) ) / 2 ), ; + nLoop++, ; + _FTSAY( nSayRow, nSayCol, cSayStr ); + } ) - // wait for keypress if desired - IF Left( cRetWait, 1 ) == 'W' - Inkey(0) - ENDIF +// wait for keypress if desired + IF Left( cRetWait, 1 ) == 'W' + Inkey( 0 ) + ENDIF - RETURN NIL + RETURN NIL -STATIC FUNCTION _FTSAY(nSayRow,nSayCol,cSayStr) - @ nSayRow,nSayCol SAY cSayStr - RETURN NIL +STATIC FUNCTION _FTSAY( nSayRow, nSayCol, cSayStr ) + + @ nSayRow, nSayCol SAY cSayStr + + RETURN NIL diff --git a/harbour/contrib/hbnf/year.prg b/harbour/contrib/hbnf/year.prg index 78462f518e..c3d7d71725 100644 --- a/harbour/contrib/hbnf/year.prg +++ b/harbour/contrib/hbnf/year.prg @@ -27,22 +27,23 @@ * */ -FUNCTION FT_YEAR(dGivenDate) +FUNCTION FT_YEAR( dGivenDate ) - LOCAL aRetVal[3], cFY_Start, cDateFormat + LOCAL aRetVal[ 3 ], cFY_Start, cDateFormat - cFY_Start := FT_DATECNFG()[1] - cDateFormat := SET(_SET_DATEFORMAT, "yyyy.mm.dd") - IF !( VALTYPE(dGivenDate) == 'D' ) - dGivenDate := DATE() - ENDIF + cFY_Start := FT_DATECNFG()[ 1 ] + cDateFormat := Set( _SET_DATEFORMAT, "yyyy.mm.dd" ) - aRetVal[2] := CTOD(STR( YEAR(dGivenDate) - iif(MONTH(dGivenDate) < ; - MONTH(CTOD(cFY_Start)), 1, 0), 4) + ; - SUBSTR(cFY_Start, 5, 6) ) - aRetval[3] := FT_MADD(aRetVal[2], 12) - 1 - aRetVal[1] := STR(YEAR(aRetVal[3]),4) // End of Year + IF ! HB_ISDATE( dGivenDate ) + dGivenDate := Date() + ENDIF - SET(_SET_DATEFORMAT, cDateFormat) + aRetVal[ 2 ] := CToD( Str( Year( dGivenDate ) - iif( Month( dGivenDate ) < ; + Month( CToD( cFY_Start ) ), 1, 0 ), 4 ) + ; + SubStr( cFY_Start, 5, 6 ) ) + aRetval[ 3 ] := FT_MADD( aRetVal[ 2 ], 12 ) - 1 + aRetVal[ 1 ] := Str( Year( aRetVal[ 3 ] ), 4 ) // End of Year -RETURN aRetVal + Set( _SET_DATEFORMAT, cDateFormat ) + + RETURN aRetVal