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

See changelog 20000421 23:00 gmt -3

Browse Source
This commit is contained in:
Luiz Rafael Culik
2000-04-22 02:10:10 +00:00
parent a80cc1cbc6
commit e26e112ea5
17 changed files with 2309 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

85
harbour/contrib/libnf/bitclr.prg Normal file
View File

@@ -0,0 +1,85 @@
/*
* File......: BITCLR.PRG
* Author....: Forest Belt, Computer Diagnostic Services, Inc.
* CIS ID....: ?
*
* This is an original work by Forest Belt and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:02:50 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:50:58 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:40 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_BITCLR()
* $CATEGORY$
* String
* $ONELINER$
* Clear (reset) selected bit in a byte
* $SYNTAX$
* FT_BITCLR( <cByte>, <nBitPos> ) -> cByte
* $ARGUMENTS$
* <cByte> is a character from CHR(0) to CHR(255).
*
* <nBitPos> is a number from 0 to 7 conforming to standard
* right-to-left bit numbering convention and representing the
* position of the bit within the byte.
* $RETURNS$
* Returns new byte, with designated bit cleared (reset).
* If parameters are faulty, returns NIL.
* $DESCRIPTION$
* In effect, ANDs argument byte with a byte that has all bits set except
* the target bit. If bit is already clear (0), it remains clear.
* Note: Calls FT_ISBIT() which is also in this Library.
*
* This function is presented to illustrate that bit-wise operations
* are possible with Clipper code. For greater speed, write .C or
* .ASM versions and use the Clipper Extend system.
* $EXAMPLES$
* This code would clear bit 4 in a byte represented by CHR(115):
*
* cNewByte := FT_BITCLR( CHR(115), 4 )
* ? ASC( cNewbyte ) // result: 99
* ? cNewByte // result: 'c'
*
* This code would clear bit 5 in the byte represented by letter 'A':
*
* FT_BITCLR( 'A', 5 ) // result: 'A', since
* // bit 5 already clear
*
* For a demonstration of Clipper bit manipulations, compile and
* link the program BITTEST.PRG in the Nanforum Toolkit source code.
* $SEEALSO$
* FT_BITSET() FT_ISBIT()
* $END$
*/
FUNCTION FT_BITCLR(cInbyte, nBitpos)
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
RETURN cByte

87
harbour/contrib/libnf/bitset.prg Normal file
View File

@@ -0,0 +1,87 @@
/*
* File......: BITSET.PRG
* Author....: Forest Belt, Computer Diagnostic Services, Inc.
* CIS ID....: ?
*
* This is an original work by Forest Belt and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:02:52 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:51:00 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:42 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_BITSET()
* $CATEGORY$
* String
* $ONELINER$
* Set selected bit in a byte
* $SYNTAX$
* FT_BITSET( <cByte>, <nBitPos> ) -> cByte
* $ARGUMENTS$
* <cByte> is a character from CHR(0) to CHR(255).
*
* <nBitPos> is a number from 0 to 7 conforming to standard right-to-left
* bit numbering convention and representing the position of the bit
* within the byte.
* $RETURNS$
* Returns new byte, with designated bit set. If parameters are faulty,
* returns NIL.
* $DESCRIPTION$
* In effect, ORs argument byte with a byte that has only the target bit
* set. If bit is already set, it remains set.
* Note: Calls FT_ISBIT() which is also in this Library.
*
* This function is presented to illustrate that bit-wise operations
* are possible with Clipper code. For greater speed, write .C or
* .ASM versions and use the Clipper Extend system.
* $EXAMPLES$
* This code would set bit 4 in a byte represented by CHR(107):
*
* cNewbyte := FT_BITSET( CHR(107), 4 )
* ? ASC( cNewbyte ) // result: 123
* ? cNewbyte // result: '{'
*
*
* This code would set bit 5 in the byte represented by the letter 'A'.
*
* ? FT_BITSET( 'A', 5 ) // result: 'a'
* // bit 5 set
*
* For a demonstration of Clipper bit manipulations, compile and
* link the program BITTEST.PRG in the Nanforum Toolkit source code.
* $SEEALSO$
* FT_BITCLR() FT_ISBIT()
* $END$
*/
FUNCTION FT_BITSET(cInByte, nBitpos)
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
RETURN cByte

79
harbour/contrib/libnf/blink.prg Normal file
View File

@@ -0,0 +1,79 @@
/*
* File......: BLINK.PRG
* Author....: Terry Hackett
* CIS ID....: 76662,2035
*
* This is an original work by Terry Hackett and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:02:56 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:51:06 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:46 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_BLINK()
* $CATEGORY$
* Menus/Prompts
* $ONELINER$
* Display a blinking message on the screen
* $SYNTAX$
* FT_BLINK( <cMsg>, [ <nRow> ], [ <nCol> ] ) -> NIL
* $ARGUMENTS$
* <cMsg> is the string to blink.
*
* <nRow> is an optional screen row for @...SAY, default current.
*
* <nCol> is an optional screen col for @...say, default current.
* $RETURNS$
* NIL
* $DESCRIPTION$
* A quick way to blink a msg on screen in the CURRENT colors.
* Restores colors on return.
* $EXAMPLES$
* FT_BLINK( "WAIT", 5, 10 ) // Blinks "WAIT" in current colors @ 5,10
*
* @5,10 SAY "WAIT - Printing Report"
* FT_BLINK( "..." ) // Blink "..." after wait message...
* $END$
*/
#ifdef FT_TEST
FUNCTION MAIN()
FT_BLINK( "WAIT", 5, 10 )
return ( nil )
#endif
FUNCTION FT_BLINK( cMsg, nRow, nCol )
* Declare color restore var.
LOCAL cSavColor
* Return if no msg.
IF (cMsg == NIL) ; RETURN NIL; ENDIF
* Set default row and col to current.
nRow := IF( nRow == NIL, ROW(), nRow )
nCol := IF( nCol == NIL, COL(), nCol )
cSavColor := SETCOLOR() // Save colors to restore on exit.
* IF blink colors not already set, add blink to current foreground color.
SETCOLOR( IF( ("*" $ LEFT(cSavColor,4)), cSavColor, "*" + cSavColor ) )
@ nRow, nCol SAY cMsg // Say the dreaded blinking msg.
SETCOLOR( cSavColor ) // It's a wrap, restore colors & exit.
RETURN NIL

79
harbour/contrib/libnf/byt2bit.prg Normal file
View File

@@ -0,0 +1,79 @@
/*
* File......: BYT2BIT.PRG
* Author....: Forest Belt, Computer Diagnostic Services, Inc.
* CIS ID....: ?
*
* This is an original work by Forest Belt and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:02:58 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:51:08 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:48 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_BYT2BIT()
* $CATEGORY$
* Conversion
* $ONELINER$
* Convert byte to string of 1's and 0's
* $SYNTAX$
* FT_BYT2BIT( <cByte> ) -> cBitPattern
* $ARGUMENTS$
* <cByte> is the byte to convert.
* $RETURNS$
* 9-character string, consisting of 1's and 0's, representing bits 0
* through 7 of parameter byte, with space between bits 3 and 4. Returns
* NIL if parameters are faulty.
* $DESCRIPTION$
* Can be used to show results of bit manipulation, both before and after.
* Binary representation follows right-to-left convention of bit position
* numbering, 0 through 7. Space between high and low nibbles for clarity
* and easy comparison to hexadecimal notation.
*
* This function is presented to illustrate that bit-wise operations
* are possible with Clipper code. For greater speed, write .C or
* .ASM versions and use the Clipper Extend system.
* $EXAMPLES$
* These three code lines perform a bitwise AND on bytes with values of
* CHR(20) and CHR(36), and deliver the result as a string in binary (bit)
* format.
*
* ? FT_BYT2BIT(CHR(20)) // byte1: '0001 0100'
* ? FT_BYT2BIT(CHR(36)) // byte2: '0010 0100'
*
* ? FT_BYT2BIT(FT_BYTEAND(CHR(20), CHR(36)))
* // result: '0000 0100'
*
* For a demonstration of Clipper bit manipulations, compile and
* link the program BITTEST.PRG in the Nanforum Toolkit source code.
* $SEEALSO$
* FT_BYT2HEX()
* $END$
*/
FUNCTION FT_BYT2BIT(cByte)
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
RETURN xBitString

76
harbour/contrib/libnf/byt2hex.prg Normal file
View File

@@ -0,0 +1,76 @@
/*
* File......: BYT2HEX.PRG
* Author....: Forest Belt, Computer Diagnostic Services, Inc.
* CIS ID....: ?
*
* This is an original work by Forest Belt and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:03:00 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:51:10 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:48 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_BYT2HEX()
* $CATEGORY$
* Conversion
* $ONELINER$
* Convert byte to hexadecimal version of its binary value
* $SYNTAX$
* FT_BYT2HEX( cByte ) -> cHexValue
* $ARGUMENTS$
* <cByte> is the byte to convert.
* $RETURNS$
* Three-character string, consisting of two digits of hexadecimal
* notation and letter 'h' to signify hex. Returns NIL if parameters are
* faulty.
* $DESCRIPTION$
* Can be used to show results of bit manipulation, both before and after.
*
* This function is presented to illustrate that bit-wise operations
* are possible with Clipper code. For greater speed, write .C or
* .ASM versions and use the Clipper Extend system.
* $EXAMPLES$
* These three code lines perform a bitwise AND on bytes with values of
* CHR(20) and CHR(36), and deliver the result as a string in hexadecimal
* format, using 'h' to signify hexadecimal.
*
* ? FT_BYT2HEX(CHR(20)) // byte1: '14h'
* ? FT_BYT2HEX(CHR(36)) // byte2: '24h'
*
* ? FT_BYT2HEX(FT_BYTEAND(CHR(20), CHR(36)))
* // result: '04h'
*
* For a demonstration of Clipper bit manipulations, compile and
* link the program BITTEST.PRG in the Nanforum Toolkit source code.
* $SEEALSO$
* FT_BYT2BIT()
* $END$
*/
FUNCTION FT_BYT2HEX(cByte)
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
RETURN xHexString

80
harbour/contrib/libnf/byteand.prg Normal file
View File

@@ -0,0 +1,80 @@
/*
* File......: BYTEAND.PRG
* Author....: Forest Belt, Computer Diagnostic Services, Inc.
* CIS ID....: ?
*
* This is an original work by Forest Belt and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:03:02 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:51:12 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:50 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_BYTEAND()
* $CATEGORY$
* String
* $ONELINER$
* Perform bit-wise AND on two ASCII characters (bytes)
* $SYNTAX$
* FT_BYTEAND( <cByte1>, <cByte2> ) -> cByte
* $ARGUMENTS$
* <cByte1> and <cByte2> are characters from CHR(0) TO CHR(255).
* May be passed in CHR() form, as character literals, or as expressions
* evaluating to CHR() values.
* $RETURNS$
* Returns resulting byte, in CHR() form. If parameters are faulty,
* returns NIL.
* $DESCRIPTION$
* Can be used for any bit-wise masking operation. In effect, this is a
* bit-by-bit AND operation. Equivalent to AND assembler instruction.
*
* This function is presented to illustrate that bit-wise operations
* are possible with Clipper code. For greater speed, write .C or
* .ASM versions and use the Clipper Extend system.
* $EXAMPLES$
* This code would mask out the high nibble (four most significant bits)
* of the byte represented by chr(123) and leave the low nibble bits as in
* the parameter byte.
*
* cNewbyte := FT_BYTEAND( CHR(123), CHR(15) )
* ? asc(cNewByte) // result: 11
* ? cNewByte // result: non-printable character
*
* For a demonstration of Clipper bit manipulations, compile and
* link the program BITTEST.PRG in the Nanforum Toolkit source code.
* $SEEALSO$
* FT_BYTEOR() FT_BYTEXOR() FT_BYTENOT() FT_BYTENEG()
* $END$
*/
FUNCTION FT_BYTEAND(cByte1, cByte2)
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
RETURN cNewByte

64
harbour/contrib/libnf/byteneg.prg Normal file
View File

@@ -0,0 +1,64 @@
/*
* File......: BYTENEG.PRG
* Author....: Forest Belt, Computer Diagnostic Services, Inc.
* CIS ID....: ?
*
* This is an original work by Forest Belt and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:03:04 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:51:14 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:52 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_BYTENEG()
* $CATEGORY$
* String
* $ONELINER$
* Perform bit-wise negation on an ASCII character
* $SYNTAX$
* FT_BYTENEG( <cByte> ) -> cNewByte
* $ARGUMENTS$
* <cByte> is a character from CHR(0) to CHR(255).
* May be passed in CHR() form, as character literal, or
* as expression evaluating to CHR() value.
* $RETURNS$
* Returns resulting byte, in CHR() form. If parameters are faulty,
* returns NIL.
* $DESCRIPTION$
* Can be used for bit-wise byte manipulation. In effect, this is a
* bit-by-bit NEG (two's complement) operation. Equivalent to NEG
* assembler instruction.
*
* This function is presented to illustrate that bit-wise operations
* are possible with Clipper code. For greater speed, write .C or
* .ASM versions and use the Clipper Extend system.
* $EXAMPLES$
* This code performs a bit-wise NEG on byte represented by CHR(32):
*
* cNewByte := FT_BYTENOT(CHR(32))
* ? asc(cNewByte) // result: 224
*
* For a demonstration of Clipper bit manipulations, compile and
* link the program BITTEST.PRG in the Nanforum Toolkit source code.
* $SEEALSO$
* FT_BYTEOR() FT_BYTEXOR() FT_BYTENOT() FT_BYTEAND()
* $END$
*/
FUNCTION FT_BYTENEG(cByte)
RETURN iif(valtype(cByte) != "C", NIL, chr((256 - asc(cByte)) % 256))

79
harbour/contrib/libnf/bytenot.prg Normal file
View File

@@ -0,0 +1,79 @@
/*
* File......: BYTENOT.PRG
* Author....: Forest Belt, Computer Diagnostic Services, Inc.
* CIS ID....: ?
*
* This is an original work by Forest Belt and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:05:00 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 10 May 1991 23:54:40 GLENN
* Documentation correction. The "oneliner" said two characters were NOTted,
* but this function just takes one byte.
*
* Rev 1.0 01 Apr 1991 01:00:54 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_BYTENOT()
* $CATEGORY$
* String
* $ONELINER$
* Perform bit-wise NOT on an ASCII character (byte)
* $SYNTAX$
* FT_BYTENOT( <cByte> ) -> cNewByte
* $ARGUMENTS$
* <cByte> is a character from CHR(0) to CHR(255).
* May be passed in CHR() form, as character literal, or
* as expression evaluating to CHR() value.
* $RETURNS$
* Returns resulting byte, in CHR() form. If parameters are faulty,
* returns NIL.
* $DESCRIPTION$
* Can be used for bitwise byte manipulation. In effect, this is a
* bit-by-bit NOT (one's complement) operation. Equivalent to the
* NOT assembler instruction.
*
* This function is presented to illustrate that bit-wise operations
* are possible with Clipper code. For greater speed, write .C or
* .ASM versions and use the Clipper Extend system.
* $EXAMPLES$
* This code performs a bitwise NOT on byte represented by CHR(32):
*
* cNewByte := FT_BYTENOT( CHR(32) )
* ? ASC( cNewByte ) // result: 223
*
* For a demonstration of Clipper bit manipulations, compile and
* link the program BITTEST.PRG in the Nanforum Toolkit source code.
* $SEEALSO$
* FT_BYTEOR() FT_BYTEXOR() FT_BYTENEG() FT_BYTEAND()
* $END$
*/
FUNCTION FT_BYTENOT(cByte)
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
RETURN cNewByte

78
harbour/contrib/libnf/byteor.prg Normal file
View File

@@ -0,0 +1,78 @@
/*
* File......: BYTEOR.PRG
* Author....: Forest Belt, Computer Diagnostic Services, Inc.
* CIS ID....: ?
*
* This is an original work by Forest Belt and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:03:06 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:51:16 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:56 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_BYTEOR()
* $CATEGORY$
* String
* $ONELINER$
* Perform bit-wise OR on two ASCII characters (bytes)
* $SYNTAX$
* FT_BYTEOR( <cByte1>, <cByte2> ) -> cNewByte
* $ARGUMENTS$
* <cByte1> and <cByte2> are characters from CHR(0) TO CHR(255).
* May be passed in CHR() form, as character literals, or as
* expressions evaluating to CHR() values.
* $RETURNS$
* Returns resulting byte, in CHR() form. If parameters are faulty,
* returns NIL.
* $DESCRIPTION$
* Can be used for bit-wise byte manipulation. In effect, this is a
* bit-by-bit OR operation. Equivalent to OR assembler instruction.
*
* This function is presented to illustrate that bit-wise operations
* are possible with Clipper code. For greater speed, write .C or
* .ASM versions and use the Clipper Extend system.
* $EXAMPLES$
* This code performs a bit-wise OR on two bytes represented
* by CHR(20) and CHR(10):
*
* cNewByte := FT_BYTEOR( CHR(20), CHR(10) )
* ? ASC( cNewByte ) // result: 30
* ? cNewByte // result: non-printable character
*
* For a demonstration of Clipper bit manipulations, compile and
* link the program BITTEST.PRG in the Nanforum Toolkit source code.
* $SEEALSO$
* FT_BYTEXOR() FT_BYTENOT() FT_BYTENEG() FT_BYTEAND()
* $END$
*/
FUNCTION FT_BYTEOR(cByte1, cByte2)
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
RETURN cNewByte

82
harbour/contrib/libnf/bytexor.prg Normal file
View File

@@ -0,0 +1,82 @@
/*
* File......: BYTEXOR.PRG
* Author....: Forest Belt, Computer Diagnostic Services, Inc.
* CIS ID....: ?
*
* This is an original work by Forest Belt and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.3 16 Aug 1991 19:35:48 GLENN
* Don Caton corrected some spelling errors in doc
*
* Rev 1.2 15 Aug 1991 23:03:10 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:51:18 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:58 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_BYTEXOR()
* $CATEGORY$
* String
* $ONELINER$
* Perform bit-wise XOR on two ASCII characters (bytes)
* $SYNTAX$
* FT_BYTEXOR( <cByte1>, <cByte2> ) -> cNewByte
* $ARGUMENTS$
* <cByte1> and <cByte2> are characters from CHR(0) to CHR(255).
* May be passed in CHR() form, as character literals, or
* as expressions evaluating to CHR() values.
* $RETURNS$
* Returns resulting byte, in CHR() form. If parameters are faulty,
* returns NIL.
* $DESCRIPTION$
* Can be used for bit-wise byte manipulation. In effect, this is a
* bit-by-bit XOR operation. Equivalent to XOR assembler instruction.
*
* This function is presented to illustrate that bit-wise operations
* are possible with Clipper code. For greater speed, write .C or
* .ASM versions and use the Clipper Extend system.
* $EXAMPLES$
* This code performs a bit-wise XOR on two bytes represented
* by CHR(32) and CHR(55):
*
* cNewByte := FT_BYTEXOR( CHR(32), CHR(55) )
* ? ASC( cNewByte ) // result: 23
* ? cNewByte // result: non-printable character
*
* For a demonstration of Clipper bit manipulations, compile and
* link the program BITTEST.PRG in the Nanforum Toolkit source code.
* $SEEALSO$
* FT_BYTEOR() FT_BYTENOT() FT_BYTENEG() FT_BYTEAND()
* $END$
*/
FUNCTION FT_BYTEXOR(cByte1, cByte2)
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
RETURN cNewByte

229
harbour/contrib/libnf/calendar.prg Normal file
View File

@@ -0,0 +1,229 @@
/*
* File......: CALENDAR.PRG
* Author....: Isa Asudeh
* CIS ID....: 76477,647
*
* This is an original work by Isa Asudeh and is placed in the
* public domain.
*
* Modification history
* --------------------
*
* Rev 1.1 15 Aug 1991 23:05:24 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.0 31 May 1991 21:07:26 GLENN
* Initial revision.
*
*/
/* $DOC$
* $FUNCNAME$
* FT_CALENDAR()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Display date/time calendar, find a date, return calendar data.
* $SYNTAX$
* FT_CALENDAR ( [ <nRow> ], [ <nCol> ], [ <cColor> ], [ <lShadow> ] ,
* [ <lShowHelp> ] ) -> aRetVal
* $ARGUMENTS$
*
* <nRow> is an optional screen row for calendar display,
* default row 1.
*
* <nCol> is an optional screen col for calendar display,
* default col 63.
*
* <cColor> is an optional color string for displayed messages,
* default is bright white text over green background.
*
* <lShadow> is an optional logical variable. If true (.T.),
* it uses FT_SHADOW() to add a transparent shadow
* to the display, default (.F.).
*
* <lShowHelp> is an optional logical variable. If true, uses
* FT_XBOX to display a four line help message
* if the F1 key is pressed, default (.F.).
*
* $RETURNS$
* aRetVal is an 8 element array containing date, month, day, year,
* month (in character format), day of the week, julian day
* and current time.
*
* $DESCRIPTION$
* FT_CALENDAR() simply displays today's date, time and julian
* day in a two line display with an optional box shadow. Cursor keys may
* be used to page through the calendar by day, week, month or year
* increments. Returns an 8 element array of calendar data:
*
* Element Value
* [1] Date in current date format.
* [2] Numeric month number.
* [3] Numeric day number.
* [4] Numeric year number.
* [5] Month in character format.
* [6] Day of the week in character format.
* [7] Numeric Julian day.
* [8] Current time in time format.
*
* WARNING: FT_CALENDAR uses FT_SHADOW and FT_XBOX
* from the Nanforum Toolkit!
*
* $EXAMPLES$
*
* LOCAL aRetVal[8]
* CLS
* aRetVal := FT_CALENDAR (10,40,'W+/RB',.T.,.T.)
* ?aRetVal[1] // Result: 04/20/91
* ?aRetVal[2] // Result: 4
* ?aRetVal[3] // Result: 20
* ?aRetVal[4] // Result: 1991
* ?aRetVal[5] // Result: April
* ?aRetVal[6] // Result: Saturday
* ?aRetVal[7] // Result: 110
* ?aRetVal[8] // Result: 12:45:20
*
* $SEEALSO$
* FT_DAYOFYR()
*
* $END$
*/
#ifdef FT_TEST
FUNCTION 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]
return ( nil )
#endif
#include "INKEY.CH"
FUNCTION FT_CALENDAR (nRow, nCol, cColor, lShadow, lShowHelp)
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 <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 (0) // 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 lShowHelp
nHelpRow := IIF (nRow > 10 , nRow - 10 , nRow + 6 )
ENDIF
DO WHILE nKey <> K_ESC
DO CASE
CASE nKey == K_HOME
nJump = nJump - 1
CASE nKey == K_END
nJump = nJump + 1
CASE nKey == K_UP
nJump = nJump - 30
CASE nKey == K_DOWN
nJump = nJump + 30
CASE nKey == K_PGUP
nJump = nJump - 365
CASE nKey == K_PGDN
nJump = nJump + 365
CASE nKey == K_RIGHT
nJump = nJump - 7
CASE nKey == K_LEFT
nJump = nJump + 7
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
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] )
@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
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
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) )
STATIC FUNCTION VALS (cString, nOffset, nChar)
RETURN ( VAL(SUBSTR(cString,nOffset,nChar)) )
* end of calendar.prg

84
harbour/contrib/libnf/caplock.c Normal file
View File

@@ -0,0 +1,84 @@
/*
* $Id$
*/
/*
* File......: CAPLOCK.C
* Author....: Ted Means
* CIS ID....: 73067,3332
*
* This is an original work by Ted Means and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.5 01 May 1995 03:05:00 TED
* Modified typecasting to tame compiler warning.
*
* Rev 1.4 15 Jul 1993 00:12:22 GLENN
* Changed status_byte to make the function work in protected mode.
*
* Rev 1.3 15 Aug 1991 23:08:30 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.2 14 Jun 1991 19:53:38 GLENN
* Minor edit to file header
*
* Rev 1.1 27 May 1991 14:41:56 GLENN
* Added a parameter to turn CapLock on or off.
*
*
*
*/
/* $DOC$
* $FUNCNAME$
* FT_CAPLOCK()
* $CATEGORY$
* Keyboard/Mouse
* $ONELINER$
* Determine and optionally change the status of CapLock key
* $SYNTAX$
* FT_CAPLOCK([ <lNewSetting> ]) -> lCurrentSetting
* $ARGUMENTS$
* <lNewSetting> is optional and if supplied is the new setting
* for the CapLock key. Specify .T. to turn CapLock on, or .F. to
* turn it off.
* $RETURNS$
* .T. if CapLock is set, .F. if it isn't set. The value returned
* represents the setting in effect prior to any changes that might
* by made by <lNewSetting>.
* $DESCRIPTION$
* This function is useful if you need to know or set the status of the
* CapLock key for some reason.
* $EXAMPLES$
* IF FT_CAPLOCK()
* Qout( "CapLock is active" )
* ENDIF
* $SEEALSO$
* FT_ALT() FT_CTRL() FT_NUMLOCK() FT_PRTSCR() FT_SHIFT()
* $END$
*/
#include <hbapi.h>
#define status_byte ( *( unsigned char * ) ( 0x00400017 ) )
HB_FUNC(FT_CAPLOCK)
{
#if defined(HB_OS_DOS)
{
hb_retl( ( int ) ( status_byte & 0x40 ) );
if ( hb_pcount() )
if ( ISLOG(1) )
status_byte = ( status_byte | ( unsigned char ) 0x40 );
else
status_byte = ( status_byte & ( unsigned char ) 0xBF );
return;
}
#endif
}

101
harbour/contrib/libnf/chdir.c Normal file
View File

@@ -0,0 +1,101 @@
/*
* $Id$
*/
/* File......: CHDIR.ASM
* Author....: Ted Means
* CIS ID....: 73067,3332
*
* This is an original work by Ted Means and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:07:20 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:54:20 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:03:10 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_CHDIR()
* $CATEGORY$
* DOS/BIOS
* $ONELINER$
* Change the current directory
* $SYNTAX$
* FT_CHDIR( <cDirName> ) -> nResult
* $ARGUMENTS$
* <cDirName> is the name of the desired directory.
* $RETURNS$
* 0 if successful
* 3 if path not found
* 99 if invalid parameters passed
* $DESCRIPTION$
* Use this function if you prefer to change the active directory
* instead of relying on the SET PATH command.
*
* The source code is written to adhere to Turbo Assembler's IDEAL mode.
* To use another assembler, you will need to rearrange the PROC and
* SEGMENT directives, and also the ENDP and ENDS directives (a very
* minor task).
* $EXAMPLES$
* FT_CHDIR( "C:\CLIPPER" )
* FT_CHDIR( "\" )
* FT_CHDIR( "..\SOURCE" )
* $END$
*/
/*This is the Original FT_CHDIR() code
IDEAL
MODEL HUGE
Public _HB_FUN_FT_CHDIR
Extrn _hb_ftdir:Far
Segment _NanFor Word Public "CODE"
Assume CS:_NanFor
Proc _HB_FUN_FT_CHDIR Far
Mov AH,3Bh * DOS service -- change directory
Push AX * Save on stack
Call _hb_ftdir * Call generic directory routine
Add SP,2 * Realign stack
RetF
Endp _HB_FUN_FT_CHDIR
Ends _NanFor
End
*/
/* This is the New one Rewriten in C*/
#include "extend.h"
#include "dos.h"
HB_FUNC( FT_CHDIR)
{
#if defined(HB_OS_DOS)
{
int Status;
char *path=hb_parc(1);
union REGS regs;
struct SREGS sregs;
segread(&sregs);
regs.h.ah=0x3B;
sregs.ds=FP_SEG(path);
regs.HB_XREGS.dx=FP_OFF(path);
int86x(0x21,&regs,&regs,&sregs);
Status=regs.HB_XREGS.ax;
hb_retl(Status);
}
#endif
}

786
harbour/contrib/libnf/clrsel.prg Normal file
View File

@@ -0,0 +1,786 @@
/*
* File......: ClrSel.PRG
* Author....: Dave Adams
* CIS ID....: 72037,2654
*
* This is an original work by Dave Adams and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 17 Aug 1991 15:05:22 GLENN
* Don Caton made corrected some spelling errors in the doc
*
* Rev 1.1 15 Aug 1991 23:03:50 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.0 13 Jun 1991 15:21:46 GLENN
* Initial revision.
*
*/
/* $DOC$
* $FUNCNAME$
* FT_ClrSel()
* $CATEGORY$
* Menus/Prompts
* $ONELINER$
* User Selectable Colour Routine
* $SYNTAX$
* FT_ClrSel( <aClrData>, [ <lClrMode> ], [ <cTestChr> ] -> aClrData
* $ARGUMENTS$
*
* <aClrData> is an array of subarrays, with each subarray containing
* information about the colour settings.
*
* The subarray has the following structure:
*
* [1] cName is the name of this colour setting i.e. "Pick List"
* Maximum length is 20 bytes
*
* [2] cClrStr is the current colour string
* Default is "W/N,N/W,N/N,N/N,N/W"
*
* If Setting type is "M" (Menu) the colours are...
* 1. Prompt Colour
* 2. Message Colour
* 3. HotKey Colour
* 4. LightBar Colour
* 5. LightBar HotKey Colour
*
* Note: While there are many ways to code the individual
* colour combinations, they should be in the same
* format that gets returned from SETCOLOR(), so
* the defaults can be found in the colour palette.
*
* foreground [+] / background [*]
* i.e. "GR+/BG*, N/W*, N+/N, , W/N"
*
* [3] cType is the type of colour setting
* Default is "W" (Window)
*
* T = Title Only 1 colour element
* D = Desktop Background colour and character
* M = Menu For FT_Menuto() style menus
* W = Window Windows with radio buttons
* G = Get For use with @ SAY...
* B = Browse For tBrowse() and *dbEdit()
* A = aChoice Pick-lists etc...
*
* W/G/B/A are functionally the same but will provide
* a more appropriate test display.
*
* [4] cFillChar is the character (for desktop background only)
* Default is CHR(177) "±±±±±±±±±±±±±±"
*
*
* <lClrMode> .T. use colour palette
* .F. use monochrome palette
*
* Default is the ISCOLOR() setting
*
* <cTestChr> 2 Byte character string for colour test display
*
* Default is the CHR(254)+CHR(254) "þþ"
*
* $RETURNS$
* An array identical to the one passed, with new selected colours
* $DESCRIPTION$
* This function allows users to select their own colour combinations
* for all the different types of screen I/O in a typical application.
* This facilitates an easy implementation of Ted Means' replacement
* of the @..PROMPT/MENU TO found in the NanForum Toolkit. If you are
* not using FT_MENUTO(), you can specify "A" for setting type and have
* a normal colour string returned.
* $EXAMPLES$
* LOCAL aClrs := {}
* LOCAL lColour := ISCOLOR()
* LOCAL cChr := CHR(254) + CHR(254)
*
* SET SCOREBOARD Off
* SETBLINK( .F. ) // Allow bright backgrounds
*
* *.... a typical application might have the following different settings
* * normally these would be stored in a .dbf/.dbv
* aClrs := {;
* { "Desktop", "N/BG", "D", "±" }, ;
* { "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, cChr )
* $END$
*/
/*
* File Contents
*
* FT_ClrSel( aClrs, lColour, cChr ) user selectable colour routine
* _ftHiLite( nRow, nCol, cStr, nLen ) re-hilite an achoice prompt
* _ftColours( aOpt, aClrPal, lColour ) control colour selection
* _ftShowIt( aOpt ) show a sample of the colours
* _ftClrSel( aClrPal, cClr, nElem, aOpt) pick a colour
* _ftClrPut( cClrStr, nElem, cClr ) place a clr element into str
* _ftDeskChar( aOpt ) select desktop char
* _ftChr2Arr( cString, cDelim ) parse string into array
* _ftArr2Chr( aArray, cDelim ) create string from array
* _ftShowPal( aClrPal, cChr ) paint palette on screen
* _ftInitPal( aClrTab ) create the palette
* _ftIdentArr( aArray1, aArray2 ) compare array contents
*
*/
/*
* Commentary
*
* Thanks to Brian Loesgen for offering ideas and helping to tweak
* the code.
*
*
*/
*------------------------------------------------
// Pre-processor stuff
#include "box.ch"
#include "setcurs.ch"
#include "inkey.ch"
#define C_NAME 1
#define C_CLR 2
#define C_TYPE 3
#define C_CHAR 4
#translate Single( <t>, <l>, <b>, <r> ) =>;
@ <t>, <l>, <b>, <r> BOX B_SINGLE
#translate Double( <t>, <l>, <b>, <r> ) =>;
@ <t>, <l>, <b>, <r> BOX B_DOUBLE
#translate ClearS( <t>, <l>, <b>, <r> ) =>;
@ <t>, <l> CLEAR TO <b>, <r>
#translate BkGrnd( <t>, <l>, <b>, <r>, <c> ) =>;
DispBox( <t>, <l>, <b>, <r>, REPLICATE(<c>,9) )
#command DEFAULT <p> TO <val> [, <pn> TO <valn> ] =>;
<p> := IIF( <p> == Nil, <val>, <p> ); ;
[ <pn> := IIF( <pn> == Nil, <valn>, <pn> ) ]
*------------------------------------------------
// Demo of FT_ClrSel()
/*
* To run the sample program:
*
* Compile : Clipper ClrSel /n /m /w /dFT_TEST
* Link : Rtlink FILE ClrSel LIB NanFor [/PLL:Fullbase]
* .OR. [/PLL:Base50]
*
* ClrSel MONO To force monochrome mode
* ClrSel NOSNOW To prevent CGA snowstorms
* ClrSel EGA 43 line mode
* ClrSel VGA 50 line mode
*
*/
#IFDEF FT_TEST
FUNCTION 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 := {}
DEFAULT cVidMode TO ""
NOSNOW( ( "NOSNOW" $ UPPER( cVidMode ) ) )
IF "VGA" $ UPPER( cVidMode )
SETMODE( 50, 80 )
ENDIF
IF "EGA" $ UPPER( cVidMode )
SETMODE( 43, 80 )
ENDIF
lColour := IF( "MONO" $ UPPER( cVidMode ), .F., ISCOLOR() )
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", "±" }, ;
{ "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 )
*.... 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 Nil
#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 nF, 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 )
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 ) )
*.... 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
*.... 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 )
*.... 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
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 )
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 )
SETCOLOR( aClr[ 2 ] ) // enhanced colour
@ nRow, nCol SAY PadR( cStr, nLen )
SETCOLOR( cClr )
RETURN Nil
*------------------------------------------------
STATIC FUNCTION _ftColours( aOpt, aClrPal, lColour )
// Colour selection for specific type of colour setting
// Return -> aOpt with modified colour strings
LOCAL nF, nB, nT, nL, nR
LOCAL nX := 0
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 ] )
DEFAULT lColour TO ISCOLOR()
*.... display appropriate prompts based on type of colour setting
nChoice := 1
DO CASE
CASE aOpt[ C_TYPE ] == "D"
aPrompt := { " Color ", " Character " }
CASE aOpt[ C_TYPE ] == "M"
aPrompt := { " Prompt ", " Message ", " HotKey ",;
" LightBar ", " LightBar HotKey " }
CASE aOpt[ C_TYPE ] == "A" .OR. aOpt[ C_TYPE ] == "B"
aPrompt := { " Standard ", " Selected ", " Border ", " Unavailable " }
OTHERWISE
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 )
*.... set up the window for prompt
SETCOLOR( "N/W" )
ClearS( nT, nL, nB, nR )
ENDIF
DO WHILE .T.
*.... 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, "Í" )
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
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, "Ä" )
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
ENDIF
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 ] )
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
CASE aOpt[ C_TYPE ] == "D" // Desktop Background
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 )
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 )
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 "ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ´"
@ 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 "ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ´"
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 "ÆÍÍÍÍÍÍÑÍÍÍÍÍÍÍÍÍÍÍÍÍÍÑÍÍÍÍÍÍÍ͵"
@ 21,39 SAY " 312 ³ Rick Shaw ³ 143.25 "
@ 23,39 SAY " ³ ³ "
@ 24,38 SAY "ÔÍÍÍÍÍÍÏÍÍÍÍÍÍÍÍÍÍÍÍÍÍÏÍÍÍÍÍÍÍ;"
SETCOLOR( aClr[2] )
@ 22,39 SAY " 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 ... <Esc> "
SETCOLOR( aClr[2] )
@ 20,44 SAY " Monthend Reports "
SETCOLOR( aClr[5] )
@ 22,44 SAY " Yearend Reports "
ENDCASE
DispEnd()
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 := 1
LOCAL nC := 1
LOCAL lFound := .F.
LOCAL nKey := 0
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 ( "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
IF ! lFound
nR := 1 // black background
nC := IIF( nDim == 5, 3, 8 ) // white foreground
ENDIF
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 ) )
*.... 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 )
*.... 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
ENDDO
SETCOLOR( "GR+/N" )
Single( nTop, nLeft, nBottom, nRight )
RETURN cClr
*------------------------------------------------
STATIC FUNCTION _ftClrPut( cClrStr, nElem, cClr )
// Place a colour setting in the colour string
// Return -> modified colour string
LOCAL aClr := _ftChr2Arr( cClrStr )
aClr[ nElem ] := cClr
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
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
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 )
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
ENDDO
SETCOLOR ( "W+/N" )
ClearS( 18, 28, 23, 39 )
RETURN aOpt
*------------------------------------------------
STATIC FUNCTION _ftChr2Arr( cString, cDelim )
// Convert a chr string to an array
// Return -> array
LOCAL n, aArray := {}
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
RETURN aArray
*------------------------------------------------
STATIC FUNCTION _ftArr2Chr( aArray, cDelim )
// convert an array to a chr string
// Return -> string
LOCAL cString := ""
DEFAULT aArray TO {}
DEFAULT cDelim TO ","
AEVAL( aArray, { |v,e| cString += IIF( e == 1, v, cDelim + v ) } )
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
*.... 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
*------------------------------------------------
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 )
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
*------------------------------------------------
STATIC FUNCTION _ftIdentArr( aArr1, aArr2 )
// Compares the contents of 2 arrays
// Return -> logical
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
RETURN lIdentical

66
harbour/contrib/libnf/cntryset.prg Normal file
View File

@@ -0,0 +1,66 @@
/*
* File......: CntrySet.Prg
* Author....: David Husnian
* CIS ID....: ?
*
* This is an original work by David Husnian and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:03:12 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:51:20 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:58 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_SETCENTURY()
* $CATEGORY$
* Environment
* $ONELINER$
* Check/Set the CENTURY Setting
* $SYNTAX$
* FT_SETCENTURY( [ <lNewSetState> ] ) -> <lOldState>
* $ARGUMENTS$
* lNewSetState - Boolean to Set CENTURY
* .F. - Toggle CENTURY off
* .T. - Toggle CENTURY on
* If not specified, leave CENTURY as is
* $RETURNS$
* The state of the CENTURY setting upon entry to the routine
* $DESCRIPTION$
* This function returns the state (ON/OFF, TRUE/FALSE) of the CENTURY
* and optionally sets it ON or OFF.
* $EXAMPLES$
* lOldState := FT_SETCENTURY() // Get current CENTURY Setting
*
* lOldState := FT_SETCENTURY(.T.) // Get the current CENTURY Setting
* // and turn it on (set it to TRUE)
*
* lOldState := FT_SETCENTURY(.F.) // Get the current CENTURY Setting
* // and turn it off (set it to FALSE)
* $END$
*/
#define IS_LOGICAL(x) (VALTYPE(x) == "L")
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)
IF (IS_LOGICAL(lNewSetState)) // Did They Want it Set??
SET CENTURY (lNewSetState) // Yes, Set it
ENDIF // IS_LOGICAL(lNewSetState)
RETURN (lOldSetState) // FT_SetCentury

181
harbour/contrib/libnf/color2n.c Normal file
View File

@@ -0,0 +1,181 @@
/*
* $Id$
*/
/*
* File......: COLOR2N.C
* Author....: David Richardson
* CIS ID....: 72271,53
*
* This function is an original work by David Richardson and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.0 01 Jan 1995 03:01:00 TED
* Initial release
*
*/
/* $DOC$
* $FUNCNAME$
* FT_COLOR2N()
* $CATEGORY$
* String
* $ONELINER$
* Returns the numeric complement of a Clipper color string
* $SYNTAX$
* FT_COLOR2N( <cColor> ) -> nValue
* $ARGUMENTS$
* <cColor> is a Clipper color string
* $RETURNS$
* The numeric complement of a color string or 0 if passed color
* is invalid.
* $DESCRIPTION$
* This function is useful when calling other functions that expect
* a numeric color parameter. It is often more convenient to pass
* a converted color string than having to calculate or look up the
* corresponding number.
* $EXAMPLES$
* nColor := FT_COLOR2N( "gr+/b" ) // returns 30
*
* FT_SETATTR( 0, 0, 10, 10, nColor )
* $SEEALSO$
* FT_N2COLOR()
* $END$
*/
#include "hbapi.h"
static int _ftColor2I( char * cColor );
static int _ftGetColorNum( char * cColor );
static char * _ftStripIt( char * cColor );
HB_FUNC(FT_COLOR2N)
{
#if defined(HB_OS_DOS) || defined(HB_OS_WIN_32)
{
int iRet = 0;
// make sure parameter is a char type and that it is 8 chars or less
if ( ISCHAR( 1 ) && hb_parclen( 1 ) < 8 )
iRet = _ftColor2I( hb_parc( 1 ) );
hb_retni( iRet );
return;
}
#endif
}
// ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
// Function : _ftColor2I
// Purpose : Converts an Xbase color string to an int
// Parameters: cColor - a pointer to the color string
// Returns : int complement of color string, or 0 if string is invalid
// ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
static int _ftColor2I( char * cColor )
{
char * cFore = " ", * cBack = " ";
unsigned int iBlink = 0, iIntense = 0, iBack = 0, i = 0;
// copy the Clipper string to buffer, check for attributes, and
// make lower case
while ( ( cFore[ i ] = cColor[ i ] ) != NULL )
{
// check for a blink attrib
if ( cFore[ i ] == '*' && iBlink == 0 ) iBlink = 128;
// check for an intensity attrib
if ( cFore[ i ] == '+' && iIntense == 0 ) iIntense = 8;
// make sure all chars are lower case
if ( 91 > cFore[ i ] && cFore[ i ] > 64 ) cFore[ i ] += 32;
i++;
}
// check for the background color
while ( cColor[ iBack++ ] != '/' && cColor[ iBack ] != NULL );
if ( cColor[--iBack ] == '/' )
{
cBack = cFore + iBack + 1;
cFore[ iBack ] = NULL;
}
// calculate and return the value
return ( iIntense + iBlink + _ftGetColorNum( _ftStripIt( cFore ) ) +
( 16 * _ftGetColorNum( _ftStripIt( cBack ) ) ) );
}
// ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
// Function : _ftGetColorNum
// Purpose : Returns the corresponding number for an Xbase color
// Parameters: cColor - a pointer to the color string
// Returns : int complement of a single color
// ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
static int _ftGetColorNum( char * cColor )
{
unsigned * iColor = ( unsigned * ) cColor;
if ( cColor[ 1 ] == 0 ) switch ( cColor[ 0 ] )
{
case 'n' : *iColor = 0; break;
case 'b' : *iColor = 1; break;
case 'g' : *iColor = 2; break;
case 'r' : *iColor = 4; break;
case 'w' : *iColor = 7; break;
}
else
{
if ( ( cColor[ 0 ] == 'b' ) && cColor[ 1 ] == 'g' ) *iColor = 3;
if ( ( cColor[ 0 ] == 'r' ) && cColor[ 1 ] == 'b' ) *iColor = 5;
if ( ( cColor[ 0 ] == 'g' ) && cColor[ 1 ] == 'r' ) *iColor = 6;
}
return *iColor;
}
// ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
// Function : _ftStripIt
// Purpose : Removes the intensity/blink chars from the passed string
// Parameters: cColor - a pointer to the color string
// Returns : a pointer to the modified color string
// ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
static char * _ftStripIt( char * cColor )
{
unsigned i = 0;
// move past any leading markers
while ( *cColor == '+' || *cColor == '*' ) cColor++;
// truncate any trailing markers
while ( cColor[ i ] && cColor[ i ] != '+' && cColor[ i ] != '*' ) i++;
// null terminate the string
cColor[ i ] = 0;
return cColor;
}

73
harbour/contrib/libnf/ctrl.c Normal file
View File

@@ -0,0 +1,73 @@
/*
* $Id$
*/
/*
* File......: CTRL.C
* Author....: Ted Means
* CIS ID....: 73067,3332
*
* This function is an original work by Ted Means and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.4 15 Jul 1993 23:51:28 GLENN
* Dropped _MK_FP for preferred 0x00400017
*
* Rev 1.3 13 Jul 1993 22:20:22 GLENN
* Modified to use _MK_FP for compatibility in protected mode.
*
* Rev 1.2 15 Aug 1991 23:08:10 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:53:40 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:02:44 GLENN
* Nanforum Toolkit
*
*
*/
/* $DOC$
* $FUNCNAME$
* FT_CTRL()
* $CATEGORY$
* Keyboard/Mouse
* $ONELINER$
* Determine status of the Ctrl key
* $SYNTAX$
* FT_CTRL() -> lValue
* $ARGUMENTS$
* None
* $RETURNS$
* .T. if Ctrl key is pressed, .F. if otherwise.
* $DESCRIPTION$
* This function is useful for times you need to know whether or not
* the Ctrl key is pressed, such as during a MemoEdit().
* $EXAMPLES$
* IF FT_CTRL()
* @24, 0 say "Ctrl"
* ELSE
* @24, 0 say " "
* ENDIF
* $SEEALSO$
* FT_CAPLOCK() FT_NUMLOCK() FT_PRTSCR() FT_SHIFT() FT_ALT()
* $END$
*/
#include <hbapi.h>
HB_FUNC( FT_CTRL )
{
#if defined(HB_OS_DOS)
{
hb_retl( ( int ) ( ( *( char * ) 0x00400017 ) & 0x4 ) );
return;
}
#endif
}