diff --git a/harbour/contrib/libnf/bitclr.prg b/harbour/contrib/libnf/bitclr.prg new file mode 100644 index 0000000000..4ea1392896 --- /dev/null +++ b/harbour/contrib/libnf/bitclr.prg @@ -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 + * $ARGUMENTS$ + * is a character from CHR(0) to CHR(255). + * + * 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 + diff --git a/harbour/contrib/libnf/bitset.prg b/harbour/contrib/libnf/bitset.prg new file mode 100644 index 0000000000..44353da078 --- /dev/null +++ b/harbour/contrib/libnf/bitset.prg @@ -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 + * $ARGUMENTS$ + * is a character from CHR(0) to CHR(255). + * + * 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 + diff --git a/harbour/contrib/libnf/blink.prg b/harbour/contrib/libnf/blink.prg new file mode 100644 index 0000000000..9bc160bb00 --- /dev/null +++ b/harbour/contrib/libnf/blink.prg @@ -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( , [ ], [ ] ) -> NIL + * $ARGUMENTS$ + * is the string to blink. + * + * is an optional screen row for @...SAY, default current. + * + * 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 + diff --git a/harbour/contrib/libnf/byt2bit.prg b/harbour/contrib/libnf/byt2bit.prg new file mode 100644 index 0000000000..316e46e535 --- /dev/null +++ b/harbour/contrib/libnf/byt2bit.prg @@ -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( ) -> cBitPattern + * $ARGUMENTS$ + * 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 diff --git a/harbour/contrib/libnf/byt2hex.prg b/harbour/contrib/libnf/byt2hex.prg new file mode 100644 index 0000000000..55e98bef95 --- /dev/null +++ b/harbour/contrib/libnf/byt2hex.prg @@ -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$ + * 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 diff --git a/harbour/contrib/libnf/byteand.prg b/harbour/contrib/libnf/byteand.prg new file mode 100644 index 0000000000..9cbcc4a83c --- /dev/null +++ b/harbour/contrib/libnf/byteand.prg @@ -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( , ) -> cByte + * $ARGUMENTS$ + * and 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 + diff --git a/harbour/contrib/libnf/byteneg.prg b/harbour/contrib/libnf/byteneg.prg new file mode 100644 index 0000000000..3c5cb1e19f --- /dev/null +++ b/harbour/contrib/libnf/byteneg.prg @@ -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( ) -> cNewByte + * $ARGUMENTS$ + * 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)) + diff --git a/harbour/contrib/libnf/bytenot.prg b/harbour/contrib/libnf/bytenot.prg new file mode 100644 index 0000000000..ea8c36b2b8 --- /dev/null +++ b/harbour/contrib/libnf/bytenot.prg @@ -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( ) -> cNewByte + * $ARGUMENTS$ + * 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 + diff --git a/harbour/contrib/libnf/byteor.prg b/harbour/contrib/libnf/byteor.prg new file mode 100644 index 0000000000..bbbd742f5e --- /dev/null +++ b/harbour/contrib/libnf/byteor.prg @@ -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( , ) -> cNewByte + * $ARGUMENTS$ + * and 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 + diff --git a/harbour/contrib/libnf/bytexor.prg b/harbour/contrib/libnf/bytexor.prg new file mode 100644 index 0000000000..77e1e0322a --- /dev/null +++ b/harbour/contrib/libnf/bytexor.prg @@ -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( , ) -> cNewByte + * $ARGUMENTS$ + * and 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 diff --git a/harbour/contrib/libnf/calendar.prg b/harbour/contrib/libnf/calendar.prg new file mode 100644 index 0000000000..fb8ed3a2a8 --- /dev/null +++ b/harbour/contrib/libnf/calendar.prg @@ -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 ( [ ], [ ], [ ], [ ] , + * [ ] ) -> aRetVal + * $ARGUMENTS$ + * + * is an optional screen row for calendar display, + * default row 1. + * + * is an optional screen col for calendar display, + * default col 63. + * + * is an optional color string for displayed messages, + * default is bright white text over green background. + * + * is an optional logical variable. If true (.T.), + * it uses FT_SHADOW() to add a transparent shadow + * to the display, default (.F.). + * + * 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 diff --git a/harbour/contrib/libnf/caplock.c b/harbour/contrib/libnf/caplock.c new file mode 100644 index 0000000000..9413963ddf --- /dev/null +++ b/harbour/contrib/libnf/caplock.c @@ -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([ ]) -> lCurrentSetting + * $ARGUMENTS$ + * 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 . + * $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 + +#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 +} diff --git a/harbour/contrib/libnf/chdir.c b/harbour/contrib/libnf/chdir.c new file mode 100644 index 0000000000..e6cf0028b8 --- /dev/null +++ b/harbour/contrib/libnf/chdir.c @@ -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( ) -> nResult +* $ARGUMENTS$ +* 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,®s,®s,&sregs); + Status=regs.HB_XREGS.ax; + hb_retl(Status); + } +#endif + } diff --git a/harbour/contrib/libnf/clrsel.prg b/harbour/contrib/libnf/clrsel.prg new file mode 100644 index 0000000000..a00cfacd77 --- /dev/null +++ b/harbour/contrib/libnf/clrsel.prg @@ -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 + * $ARGUMENTS$ + * + * 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) "±±±±±±±±±±±±±±" + * + * + * .T. use colour palette + * .F. use monochrome palette + * + * Default is the ISCOLOR() setting + * + * 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( , , , ) =>; + @ , , , BOX B_SINGLE + +#translate Double( , , , ) =>; + @ , , , BOX B_DOUBLE + +#translate ClearS( , , , ) =>; + @ , CLEAR TO , + +#translate BkGrnd( , , , , ) =>; + DispBox( , , , , REPLICATE(,9) ) + +#command DEFAULT

TO [, TO ] =>; +

:= IIF(

== Nil, ,

); ; + [ := IIF( == Nil, , ) ] + +*------------------------------------------------ +// 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 ... " + 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 diff --git a/harbour/contrib/libnf/cntryset.prg b/harbour/contrib/libnf/cntryset.prg new file mode 100644 index 0000000000..d655a86dae --- /dev/null +++ b/harbour/contrib/libnf/cntryset.prg @@ -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( [ ] ) -> + * $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 diff --git a/harbour/contrib/libnf/color2n.c b/harbour/contrib/libnf/color2n.c new file mode 100644 index 0000000000..11ba96a9f9 --- /dev/null +++ b/harbour/contrib/libnf/color2n.c @@ -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( ) -> nValue + * $ARGUMENTS$ + * 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; +} diff --git a/harbour/contrib/libnf/ctrl.c b/harbour/contrib/libnf/ctrl.c new file mode 100644 index 0000000000..2b486aafdb --- /dev/null +++ b/harbour/contrib/libnf/ctrl.c @@ -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 + +HB_FUNC( FT_CTRL ) +{ +#if defined(HB_OS_DOS) + { + + hb_retl( ( int ) ( ( *( char * ) 0x00400017 ) & 0x4 ) ); + return; + } +#endif +}