diff --git a/harbour/contrib/libnf/d2e.prg b/harbour/contrib/libnf/d2e.prg new file mode 100644 index 0000000000..ae695f863e --- /dev/null +++ b/harbour/contrib/libnf/d2e.prg @@ -0,0 +1,89 @@ +/* + * File......: D2E.PRG + * Author....: Gary Baren + * CIS ID....: 75470,1027 + * + * This is an original work by Gary Baren and is hereby placed in the + * public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.2 15 Aug 1991 23:05:02 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:51:24 GLENN + * Minor edit to file header + * + * Rev 1.0 09 Jun 1991 00:27:06 GLENN + * Initial revision. + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_D2E() + * $CATEGORY$ + * Conversion + * $ONELINER$ + * Convert decimal to scientific notation + * $SYNTAX$ + * FT_D2E( , ) -> + * $ARGUMENTS$ + * Decimal number to convert + * + * Number of decimal places in result. + * Defaults to 6 decimal places. + * $RETURNS$ + * A string representing a number in + * scientific notation + * $DESCRIPTION$ + * Given a decimal number and the desired precision, + * a string representing the equivalent in scientific + * notation is returned. + * $EXAMPLES$ + * ? FT_D2E( 12.345, 2 ) + * -> 1.23E1 + * + * ? FT_D2E( -12.345, 3 ) + * -> -1.235E1 + * + * ? FT_D2E( 0.00000543, 2 ) + * -> 5.43E-6 + * $SEEALSO$ + * FT_E2D() + * $END$ + */ + +#define log10( num ) log( num ) / log( 10 ) +#define DEFAULT_PRECISION 6 +#command DEFAULT

TO =>

:= iif(

== NIL, ,

) + +#ifdef FT_TEST + function main( cNum, cPrec ) + DEFAULT cPrec TO str( DEFAULT_PRECISION ) + return qout( ft_d2e( val(cNum), val(cPrec) ) ) +#endif + +function ft_d2e( nDec, nPrecision ) + local nExp, sScn + DEFAULT nPrecision TO DEFAULT_PRECISION + + if nDec == 0 + nExp := 0 + elseif abs( nDec ) < 1 + nExp := int( log10( nDec ) ) - 1 + else + nExp := int( log10( abs(nDec)+0.00001 ) ) && 0.00001 == kludge + endif && for imprecise logs + + nDec /= 10 ^ nExp + + if round( abs(nDec), nPrecision ) >= 10 + nDec /= 10 + nExp++ + endif another kludge for stuff like '999999999' + + sScn := ltrim( str( nDec, nPrecision + 3, nPrecision ) ) + return( sScn + 'E' + alltrim( str( nExp, 5, 0 ) ) ) diff --git a/harbour/contrib/libnf/datecnfg.prg b/harbour/contrib/libnf/datecnfg.prg new file mode 100644 index 0000000000..7351e911f3 --- /dev/null +++ b/harbour/contrib/libnf/datecnfg.prg @@ -0,0 +1,330 @@ +/* + * File......: DATECNFG.PRG + * Author....: Jo W. French dba Practical Computing + * CIS ID....: 74730,1751 + * + * The functions contained herein are the original work of Jo W. French + * and are placed in the public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.3 28 Sep 1992 00:34:08 GLENN + * Jo French clean up. + * + * Rev 1.2 15 Aug 1991 23:05:10 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:51:26 GLENN + * Minor edit to file header + * + * Rev 1.0 01 Apr 1991 01:01:00 GLENN + * Nanforum Toolkit + * + */ + + +#ifdef FT_TEST + ******************************************************************** + * + * NOTES: 1) The date functions are 'international'; i.e., the + * system date format is maintained, although ANSI is + * temporarily used within certain functions. + * + * 2) The date functions fall into two categories: + * + * a) Calendar or fiscal periods. + * A calendar or fiscal year is identified by the year() + * of the last date in the year. + * + * b) Accounting Periods. An accounting period has the + * following characteristics: + * If the first week of the period contains 4 or + * more 'work' days, it is included in the period; + * otherwise, the first week was included in the + * prior period. + * + * If the last week of the period contains 4 or more + * 'work' days it is included in the period; otherwise, + * the last week is included in the next period. + * This results in 13 week 'quarters' and 4 or 5 week + * 'months'. Every 5 or 6 years, a 'quarter' will contain + * 14 weeks and the year will contain 53 weeks. + * + * 3) The date functions require the presence of two variables: + * + * a) cFY_Start is a character string used to define the + * first day of a calendar or fiscal year. It's format + * is ANSI; e.g., "1980.01.01" defines a calendar year, + * "1980.10.01" defines a fiscal year, starting October 1. + * + * The year may be any valid year. It's value has no + * effect on the date functions. The day is assumed to be + * less than 29. See function: FT_DATECNFG(). + * + * B) nDow_Start is a number from 1 to 7 which defines the + * starting day, DOW(), of a work week; e.g., 1 == Sunday. + * + * See function: FT_DATECNFG() + * + * COMPILE ALL PROGRAMS WITH /N /W /A + * + ******************************************************************** + + FUNCTION DEMO() + LOCAL nNum, dDate, aTestData := {}, aTemp, cFY_Start, nDOW_Start + +* SET DATE American // User's normal date format + aTemp := FT_DATECNFG() // Get/Set cFY_Start & nDOW_Start. +* aTemp := FT_DATECNFG("03/01/80", 1) // Date string in user's format. + cFY_Start := aTemp[1] // See FT_DATECNFG() in FT_DATE0.PRG + NDOW_START := ATEMP[2] // FOR PARAMETERS. + DDATE := DATE() +* dDate := CTOD("02/29/88") // Test date, in user's normal date format + + cls + ? "Given Date: " + ?? dDate + ?? " cFY_Start: "+ cFY_Start + ?? " nDOW_Start:" + STR(nDOW_Start,2) + ? "---- Fiscal Year Data -----------" + + aTestData := FT_YEAR(dDate) + ? "FYYear ", aTestData[1]+" ", aTestData[2], aTestData[3] + + aTestData := FT_QTR(dDate) + ? "FYQtr ", aTestData[1], aTestData[2], aTestData[3] + + nNum := VAL(SUBSTR(aTestData[1],5,2)) + aTestData := FT_QTR(dDate,nNum) + ? "FYQtr "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3] + + aTestData := FT_MONTH(dDate) + ? "FYMonth ", aTestData[1], aTestData[2], aTestData[3] + + nNum := VAL(SUBSTR(aTestData[1],5,2)) + aTestData := FT_MONTH(dDate,nNum) + ? "FYMonth "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3] + + aTestData := FT_WEEK(dDate) + ? "FYWeek ", aTestData[1], aTestData[2], aTestData[3] + + nNum := VAL(SUBSTR(aTestData[1],5,2)) + aTestData := FT_WEEK(dDate,nNum) + ? "FYWeek "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3] + + aTestData := FT_DAYOFYR(dDate) + ? "FYDay ", aTestData[1], aTestData[2], aTestData[3] + + nNum := VAL(SUBSTR(aTestData[1],5,3)) + aTestData := FT_DAYOFYR(dDate,nNum) + ? "FYDAY "+STR(nNum,3), aTestData[1], aTestData[2], aTestData[3] + + ? + ? "---- Accounting Year Data -------" + + aTestData := FT_ACCTYEAR(dDate) + ? "ACCTYear ", aTestData[1]+" ", aTestData[2], aTestData[3],; + STR( (aTestData[3] - aTestData[2] + 1) /7, 3 ) + " Weeks" + + aTestData := FT_ACCTQTR(dDate) + ? "ACCTQtr ", aTestData[1], aTestData[2], aTestData[3],; + STR( (aTestData[3] - aTestData[2] + 1) /7, 3 ) + " Weeks" + + nNum := VAL(SUBSTR(aTestData[1],5,2)) + aTestData := FT_ACCTQTR(dDate,nNum) + ? "ACCTQtr "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3] + + aTestData := FT_ACCTMONTH(dDate) + ? "ACCTMonth ", aTestData[1], aTestData[2], aTestData[3],; + STR( (aTestData[3] - aTestData[2] + 1) /7, 3 ) + " Weeks" + + nNum := VAL(SUBSTR(aTestData[1],5,2)) + aTestData := FT_ACCTMONTH(dDate,nNum) + ? "ACCTMonth"+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3] + + aTestData := FT_ACCTWEEK(dDate) + ? "ACCTWeek ", aTestData[1], aTestData[2], aTestData[3] + + nNum := VAL(SUBSTR(aTestData[1],5,2)) + aTestData := FT_ACCTWEEK(dDate,nNum) + ? "ACCTWeek "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3] + + aTestData := FT_DAYOFYR(dDate,,.T.) + ? "ACCTDay ", aTestData[1], aTestData[2], aTestData[3] + + nNum := VAL(SUBSTR(aTestData[1],5,3)) + aTestData := FT_DAYOFYR(dDate,nNum,.T.) + ? "ACCTDay "+STR(nNum,3), aTestData[1], aTestData[2], aTestData[3] + + WAIT + + FT_CAL(dDate) + FT_CAL(dDate,1) + + RETURN NIL + + + * DEMO Monthly Calendar function. + * nType : 0 = FT_MONTH, 1 = FT_ACCTMONTH + * + + FUNCTION FT_CAL(dGivenDate,nType) + LOCAL nTemp, dTemp, aTemp, cFY_Start, dStart, dEnd + + aTemp := FT_DATECNFG() + cFY_Start := aTemp[1] + + IF dGivenDate == NIL .OR. !VALTYPE(dGivenDate) $ 'ND' + dGivenDate := DATE() + ELSEIF VALTYPE(dGivenDate) == 'N' + nType := dGivenDate + dGivenDate := DATE() + ENDIF + + nType := IF(nType == NIL .OR. VALTYPE(nType) != 'N', 0, nType) + + IF nType == 0 + IF SUBSTR(cFY_Start,6,5) == "01.01" + ? " Calendar Month Calendar containing " + DTOC(dGivenDate) + ELSE + ? " Fiscal Month Calendar containing " + DTOC(dGivenDate) + ENDIF + + aTemp := FT_MONTH(dGivenDate) + dStart := aTemp[2] + dEnd := aTemp[3] + aTemp[2] -= FT_DAYTOBOW(aTemp[2]) + aTemp[3] += 6 - FT_DAYTOBOW(aTemp[3]) + ELSE + ? " Accounting Month Calendar containing " + DTOC(dGivenDate) + aTemp := FT_ACCTMONTH(dGivenDate) + ENDIF + + ? + dTemp := aTemp[2] + + FOR nTemp := 0 to 6 + ?? PADC( CDOW(dTemp + nTemp),10) + NEXT + + ? + WHILE dTemp <= aTemp[3] + FOR nTemp = 1 TO 7 + ?? " " + IF nType == 0 .AND. (dTemp < dStart .or. dTemp > dEnd) + ?? SPACE(8) + ELSE + ?? dTemp + ENDIF + ?? " " + dTemp ++ + NEXT + ? + END + + RETURN NIL + +#endif + +/* $DOC$ + * $FUNCNAME$ + * FT_DATECNFG() + * $CATEGORY$ + * Date/Time + * $ONELINER$ + * Set beginning of year/week for FT_ date functions + * $SYNTAX$ + * FT_DATECNFG( [ ], [ ] ) -> aDateInfo + * $ARGUMENTS$ + * is a character date string in the user's system date + * format, i.e., the same as the user would enter for CTOD(). If + * this argument is NIL, the current value is unchanged. + * + * Note: The year portion of the date string must be present and + * be a valid year; however, it has no real meaning. + * + * is a number from 1 to 7 (1 = Sunday) indicating the + * desired start of a work week. If this argument is NIL, + * the current value is unchanged. + * + * $RETURNS$ + * A 2-element array containing the following information: + * + * aDateInfo[1] - an ANSI date string indicating the beginning + * date of the year. Only the month and day are + * meaningful. + * + * aDateInfo[2] - the number of the first day of the week + * (1 = Sunday) + * + * $DESCRIPTION$ + * FT_DATECNFG() is called internally by many of the date functions + * in the library to determine the beginning of year date and + * beginning of week day. + * + * The default beginning of the year is January 1st and the default + * beginning of the week is Sunday (day 1). Either or both of these + * settings may be changed by calling FT_DATECNFG() with the proper + * arguments. They will retain their values for the duration of the + * program or until they are changed again by a subsequent call to + * FT_DATECNFG(). + * + * It is not necessary to call FT_DATECNFG() unless you need to + * change the defaults. + * + * FT_DATECNFG() affects the following library functions: + * + * FT_WEEK() FT_ACCTWEEK() FT_DAYTOBOW() + * FT_MONTH() FT_ACCTMONTH() FT_DAYOFYR() + * FT_QTR() FT_ACCTQTR() FT_ACCTADJ() + * FT_YEAR() FT_ACCTYEAR() + * $EXAMPLES$ + * // Configure library date functions to begin year on + * // July 1st. + * + * FT_DATECNFG("07/01/80") // year is insignificant + * + * // Examples of return values: + * + * // System date format: American aArray[1] aArray[2] + * + * aArray := FT_DATECNFG() // '1980.01.01' 1 (Sun.) + * aArray := FT_DATECNFG('07/01/80') // '1980.07.01' 1 (Sun.) + * aArray := FT_DATECNFG('07/01/80', 2) // '1980.07.01' 2 (Mon.) + * aArray := FT_DATECNFG( , 2 ) // '1980.01.01' 2 (Mon.) + * + * // System date format: British + * + * aArray := FT_DATECNFG('01/07/80', 2) // '1980.07.01' 2 (Mon.) + * $SEEALSO$ + * FT_ACCTADJ() + * $END$ +*/ + +FUNCTION FT_DATECNFG( cFYStart ,nDow ) + + STATIC aDatePar := { "1980.01.01", 1 } + + LOCAL dCheck, cDateFormat := SET(_SET_DATEFORMAT) + + IF VALTYPE( cFYStart ) == 'C' + dCheck := CTOD( cFYStart ) + IF DTOC( dCheck ) != " " + + /* No one starts a Fiscal Year on 2/29 */ + IF MONTH(dCheck) == 2 .and. DAY(dcheck) == 29 + dCheck -- + ENDIF + + SET(_SET_DATEFORMAT, "yyyy.mm.dd") + aDatePar[1] := DTOC(dCheck) + SET(_SET_DATEFORMAT, cDateFormat) + ENDIF + ENDIF + + IF VALTYPE( nDow ) == 'N' .AND. nDow > 0 .AND. nDow < 8 + aDatePar[2] := nDow + ENDIF + +RETURN ACLONE( aDatePar ) diff --git a/harbour/contrib/libnf/dayofyr.prg b/harbour/contrib/libnf/dayofyr.prg new file mode 100644 index 0000000000..c873449b85 --- /dev/null +++ b/harbour/contrib/libnf/dayofyr.prg @@ -0,0 +1,116 @@ +/* + * File......: DAYOFYR.PRG + * Author....: Jo W. French dba Practical Computing + * CIS_ID....: 74731,1751 + * + * The functions contained herein are the original work of Jo W. French + * and are placed in the public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.3 28 Sep 1992 00:35:20 GLENN + * Jo French clean up. + * + * Rev 1.2 15 Aug 1991 23:03:08 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 10 May 1991 23:59:38 GLENN + * Minor adjustment to header. + * + * Rev 1.0 01 Apr 1991 01:01:02 GLENN + * Nanforum Toolkit + * + */ + +/* $DOC$ + * $FUNCNAME$ + * FT_DAYOFYR() + * $CATEGORY$ + * Date/Time + * $ONELINER$ + * Return calendar, fiscal or accounting day data + * $SYNTAX$ + * FT_DAYOFYR( [ ], [ ], [ ] ) + * -> aDateInfo + * $ARGUMENTS$ + * is any valid date in any valid format. Defaults + * to current system date if not supplied. + * + * is a number from 1 to 371, signifying a day of a year. + * Defaults to current day if not supplied. + * + * is a logical which specifies the type of year to base + * the return value on: .F. = calendar or fiscal year, + * .T. = accounting year. + * $RETURNS$ + * A three element array containing the following data: + * + * If is specified: + * + * aDateInfo[1] - The date of the specified day number + * aDateInfo[2] - The beginning date of the year + * aDateInfo[3] - The ending date of the year + * + * If is not specified: + * + * aDateInfo[1] - The year and day as a character string "YYYYDDD" + * aDateInfo[2] - The beginning date of the year + * aDateInfo[3] - The ending date of the year + * $DESCRIPTION$ + * FT_DAYOFYR() returns an array containing data about a day in the + * calendar or fiscal year containing the given date. + * + * The beginning of year date defaults to January 1st but may be + * changed with FT_DATECNFG(). + * $EXAMPLES$ + * aDateInfo := FT_DAYOFYR( CTOD("03/31/91") ) + * ? aDateInfo[1] // 1991090 (90th day of year 1991) + * ? aDateInfo[2] // 01/01/91 + * ? aDateInfo[3] // 12/31/91 + * + * aDateInfo := FT_DAYOFYR( , 90 ) // assume current date is 3/31/91 + * ? aDateInfo[1] // 03/31/91 (90th day of year) + * ? aDateInfo[2] // 01/01/91 + * ? aDateInfo[3] // 12/31/91 + * + * aDateInfo := FT_DAYOFYR( , 90, .T. ) + * ? aDateInfo[1] // 03/29/91 (90th day of accounting year) + * ? aDateInfo[2] // 12/30/90 (1st day of accounting year) + * ? aDateInfo[3] // 12/28/91 (last day of accounting year) + * $SEEALSO$ + * FT_DATECNFG() + * $END$ +*/ + +FUNCTION FT_DAYOFYR( dGivenDate, nDayNum, lIsAcct) + LOCAL lIsDay, nTemp, aRetVal + + IF !(VALTYPE(dGivenDate) $ 'NDL') + dGivenDate := DATE() + ELSEIF VALTYPE(dGivenDate) == 'N' + nDayNum := dGivenDate + dGivenDate := DATE() + ELSEIF VALTYPE(dGivenDate) == 'L' + lIsAcct := dGivenDate + dGivenDate := DATE() + ENDIF + + lIsDay := VALTYPE(nDayNum) == 'N' + lIsAcct := VALTYPE(lIsAcct) == 'L' + + IF lIsAcct + aRetVal := FT_ACCTYEAR(dGivenDate) + ELSE + aRetVal := FT_YEAR(dGivenDate) + ENDIF + + IF lIsDay + nTemp := aRetVal[3] - aRetVal[2] + 1 + IF(nDayNum < 1 .OR. nDayNum > nTemp , nDayNum := nTemp, ) + aRetVal[1] := aRetVal[2] + nDayNum - 1 + ELSE + aRetVal[1] += PADL(LTRIM(STR( dGivenDate - aRetVal[2] + 1, 3)), 3, '0') + ENDIF + +RETURN aRetVal diff --git a/harbour/contrib/libnf/daytobow.prg b/harbour/contrib/libnf/daytobow.prg new file mode 100644 index 0000000000..4ca2cc1cfa --- /dev/null +++ b/harbour/contrib/libnf/daytobow.prg @@ -0,0 +1,75 @@ +/* + * File......: DAYTOBOW.PRG + * Author....: Jo W. French dba Practical Computing + * CIS_ID....: 74731,1751 + * + * The functions contained herein are the original work of Jo W. French + * and are placed in the public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.3 28 Sep 1992 00:36:46 GLENN + * Jo French clean up. + * + * Rev 1.2 15 Aug 1991 23:03:16 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:51:28 GLENN + * Minor edit to file header + * + * Rev 1.0 01 Apr 1991 01:01:04 GLENN + * Nanforum Toolkit + * + */ + +/* $DOC$ + * $FUNCNAME$ + * FT_DAYTOBOW() + * $CATEGORY$ + * Date/Time + * $ONELINER$ + * Calculate no. of days between date and beginning of week + * $SYNTAX$ + * FT_DAYTOBOW( [ ] ) -> nDays + * $ARGUMENTS$ + * is any valid date in any valid date format. + * Defaults to current date if not supplied. + * $RETURNS$ + * A positive number of days to beginning of week, range 0 to 6. + * $DESCRIPTION$ + * FT_DAYTOBOW() returns the number of days to the beginning of the + * week. Normally this will be one less than the value that + * would be returned by the Clipper function DOW(), unless the + * day for the beginning of the week has been changed with + * FT_DATECNFG(). + * $EXAMPLES$ + * dDate := CTOD( "09/15/90" ) + * + * ? DOW( dDate ) // 7 + * ? CDOW( dDate ) // Saturday + * ? FT_DAYTOBOW( dDate ) // 6 + * + * // change beginning of week to Friday (yeah!) + * FT_DATECNFG( , 6 ) + * ? DOW( dDate ) // 7 + * ? CDOW( dDate ) // Saturday + * ? FT_DAYTOBOW( dDate ) // 1 + * $SEEALSO$ + * FT_DATECNFG() FT_ACCTWEEK() FT_WEEK() + * $END$ +*/ + +FUNCTION FT_DAYTOBOW( dGivenDate ) + + LOCAL nRetVal, nDOW_Start + + nDOW_Start := FT_DATECNFG()[2] + + IF(VALTYPE(dGivenDate) != 'D', dGivenDate := DATE(), ) + + nRetVal := DOW( dGivenDate ) - nDOW_Start + IF( nRetVal < 0, nRetVal += 7, ) + +RETURN nRetVal + diff --git a/harbour/contrib/libnf/dectobin.prg b/harbour/contrib/libnf/dectobin.prg new file mode 100644 index 0000000000..d0005751c9 --- /dev/null +++ b/harbour/contrib/libnf/dectobin.prg @@ -0,0 +1,67 @@ +/* + * File......: DECTOBIN.PRG + * Author....: Greg Lief + * CIS ID....: 72460,1760 + * + * This function is an original work by Mr. Grump and is placed in the + * public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.2 15 Aug 1991 23:03:22 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:51:30 GLENN + * Minor edit to file header + * + * Rev 1.0 01 Apr 1991 01:01:06 GLENN + * Nanforum Toolkit + * + */ + +/* $DOC$ + * $FUNCNAME$ + * FT_DEC2BIN() + * $CATEGORY$ + * Conversion + * $ONELINER$ + * Convert decimal to binary + * $SYNTAX$ + * FT_DEC2BIN( ) -> cBinaryNumber + * $ARGUMENTS$ + * is the numeric expression to be converted. + * $RETURNS$ + * A character string representing in binary format. + * $DESCRIPTION$ + * This function can be used in conjunction with any bit-wise + * operations. + * $EXAMPLES$ + * QOut( FT_DEC2BIN(255) ) // "11111111" + * QOut( FT_DEC2BIN(2) ) // "00000010" + * $END$ + */ + +#ifdef FT_TEST + +FUNCTION MAIN +LOCAL X +FOR X = 1 TO 255 + QOUT( FT_DEC2BIN( x )) +next +return nil + +#endif + +function FT_DEC2BIN(x) +local i, buffer := { '0', '0', '0', '0', '0', '0', '0', '0' } +for i = 8 to 1 step -1 + if x >= 2 ^ (i - 1) + x -= 2 ^ (i - 1) + buffer[9 - i] = '1' + endif +next +return ( buffer[1] + buffer[2] + buffer[3] + buffer[4] + ; + buffer[5] + buffer[6] + buffer[7] + buffer[8] ) + +* end of file: dectobin.prg diff --git a/harbour/contrib/libnf/descend.c b/harbour/contrib/libnf/descend.c new file mode 100644 index 0000000000..6f3a29a270 --- /dev/null +++ b/harbour/contrib/libnf/descend.c @@ -0,0 +1,100 @@ +/* + * $Id$ + */ + +/* + * File......: DESCEND.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.1 01 May 1995 03:05:00 TED + * Added typecast to tame compiler warning + * + * Rev 1.0 01 Feb 1995 03:02:00 TED + * Initial release + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_Descend() + * $CATEGORY$ + * Conversion + * $ONELINER$ + * Create a descending index key value + * $SYNTAX$ + * FT_Descend( ) -> + * $ARGUMENTS$ + * is any expression of character, numeric, date, or logical type. + * $RETURNS$ + * The inverse of + * $DESCRIPTION$ + * This function is a replacement for CA-Clipper's Descend() function, + * which is known to produce memory corruption occassionally. + * $EXAMPLES$ + * ? FT_Descend( 1 ) // Returns -1 + * $SEEALSO$ + * FT_XTOY() + * $END$ + */ + +#include +#include +//#include + +HB_FUNC( FT_DESCEND) +{ +#if defined(HB_OS_DOS) || defined(HB_OS_WIN_32) + { + + auto PHB_ITEM iP = hb_itemParam( 1 ); + auto USHORT uiType = hb_itemType( iP ); + + auto PHB_ITEM iR; + auto USHORT uiLen, n; + auto char * pDescend; + + if ( ( uiType & HB_IT_NUMERIC ) && ( uiType & HB_IT_DOUBLE ) ) + iR = hb_itemPutND( 0, 0 - hb_itemGetND( iP ) ); + + else if ( uiType & HB_IT_NUMERIC ) + iR = hb_itemPutNL( 0, 0 - hb_itemGetNL( iP ) ); + + else if ( uiType & HB_IT_DATE ) + iR = hb_itemPutNL( 0, 0x4FD4C0L - hb_itemGetNL( iP ) ); + + else if ( uiType & HB_IT_LOGICAL ) + iR = hb_itemPutL( 0, ( hb_itemGetL( iP ) > 0 ) ? 0 : 1 ); + + else if ( uiType & HB_IT_STRING ) + { + uiLen = hb_itemSize( iP ); + + pDescend = hb_xgrab( uiLen ); + + hb_itemCopyC( iP, pDescend, uiLen ); + + for ( n = 0; n < uiLen; n++ ) + pDescend[ n ] = ( char ) 0 - pDescend[ n ]; + + iR = hb_itemPutCL( 0, pDescend, uiLen ); + + hb_xfree( pDescend ); + } + + hb_itemReturn( iR ); + + hb_itemRelease( iP ); + hb_itemRelease( iR ); + + return; + } +#endif +} diff --git a/harbour/contrib/libnf/dfile.prg b/harbour/contrib/libnf/dfile.prg new file mode 100644 index 0000000000..54dda71acc --- /dev/null +++ b/harbour/contrib/libnf/dfile.prg @@ -0,0 +1,227 @@ +/* + * File......: DFILE.PRG + * Author....: Mike Taylor + * CIS ID....: ? + * + * This is an original work by Mike Taylor and is placed in the + * public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.3 17 Aug 1991 15:24:14 GLENN + * Don Caton corrected some spelling errors in the doc + * + * Rev 1.2 15 Aug 1991 23:03:24 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:51:32 GLENN + * Minor edit to file header + * + * Rev 1.0 01 Apr 1991 01:01:08 GLENN + * Nanforum Toolkit + * + */ + + + +static nHandle := 0 + +#ifdef FT_TEST + + FUNCTION MAIN() + + @ 0,0 CLEAR + + cInFile := "FT_DFILE.PRG" + CKEY := "" + NNCOLOR := 7 + NHCOLOR := 15 + NCOLSKIP := 5 + NRMARGIN := 132 + CEXITKEYS := "AABBC " + LBROWSE := .F. + NSTART := 1 + NBUFFSIZE := 4096 + + @ 0,0 SAY "ENTER FILENAME: " GET CINFILE + @ 1,0 SAY " FOREGROUND: " GET NNCOLOR PICTURE "999" + @ 2,0 SAY " HIGHLIGHT: " GET NHCOLOR PICTURE "999" + @ 3,0 SAY " EXIT KEYS: " GET CEXITKEYS + @ 4,0 SAY " BUFFER SIZE: " GET NBUFFSIZE PICTURE "9999" + @ 1,40 SAY "COLUMN INCREMENT: " GET NCOLSKIP PICTURE "999" + @ 2,40 SAY " MAX LINE SIZE: " GET NRMARGIN PICTURE "999" + @ 3,40 SAY " BROWSE MODE? " GET LBROWSE PICTURE "Y" + + READ + + /* + * REMEMBER A WINDOW WILL BE ONE SIZE LESS AND GREATER THAN THE PASSED COORD.'S + * + * THE 9TH PARAMETER CONTAINS THE KEYS THAT THE ROUTINE WILL TERMINATE ON + * AND THE CHR(143) represents the F3 key. + * + */ + + @ 4,9 TO 11,71 + + FT_DFSETUP(cInFile, 5, 10, 10, 70, nStart,; + nNColor, nHColor, cExitKeys + CHR(143),; + lBrowse, nColSkip, nRMargin, nBuffSize) + + cKey := FT_DISPFILE() + + FT_DFCLOSE() + + @ 20,0 SAY "Key pressed was: " + '[' + cKey + ']' + + return (NIL) + +#endif + + + + +/* $DOC$ + * $FUNCNAME$ + * FT_DFSETUP() + * $CATEGORY$ + * File I/O + * $ONELINER$ + * Set up parameters for FT_DISPFILE() + * $SYNTAX$ + * FT_DFSETUP( , , , , , ; + * , , , , ; + * , , , ) -> nResult + * $ARGUMENTS$ + * - text file to display (full path and filename) + * - upper row of window + * - left col of window + * - lower row of window + * - right col of window + * - line to place highlight at startup + * - normal text color (numeric attribute) + * - text highlight color (numeric attribute) + * - terminating key list (each byte of string is a + * key code) + * - act-like-a-browse-routine flag + * - col increment for left/right arrows + * - right margin - anything to right is truncated + * - size of the paging buffer + * $RETURNS$ + * 0 if successful, FError() code if not + * $DESCRIPTION$ + * Note: make sure you allocate a buffer large enough to hold enough + * data for the number of lines that you have in the window. Use the + * following formula as a guideline: + * + * buffer size = (# of line) + 1 * RMargin + * + * This is the smallest you should make the buffer. For normal use, + * 4096 bytes is recommended + * $EXAMPLES$ + * @ 4,9 TO 11,71 + * + * FT_DFSETUP("test.txt", 5, 10, 10, 70, 1, 7, 15,; + * "AaBb" + Chr(143), .T., 5, 132, 4096) + * + * cKey = FT_DISPFILE() + * + * FT_DFCLOSE() + * + * @ 20,0 SAY "Key that terminated FT_DISPFILE() was: " + '[' + cKey + ']' + * $SEEALSO$ + * FT_DISPFILE() FT_DFCLOSE() + * $END$ + */ + + + +function FT_DFSETUP(cInFile, nTop, nLeft, nBottom, nRight,; + nStart, nCNormal, nCHighlight, cExitKeys,; + lBrowse, nColSkip, nRMargin, nBuffSize ) + + local rval := 0 + + if File(cInFile) + nTop := if(ValType(nTop) == "N", nTop, 0) + nLeft := if(ValType(nLeft) == "N", nLeft, 0) + nBottom := if(ValType(nBottom) == "N", nBottom, MaxRow()) + nRight := if(ValType(nRight) == "N", nRight, MaxCol()) + + nCNormal := if(ValType(nCNormal) == "N", nCNormal, 7) + nCHighlight := if(ValType(nCHighlight) == "N", nCHighlight, 15) + + nStart := if(ValType(nStart) == "N", nStart, 1) + nColSkip := if(ValType(nColSkip) == "N", nColSkip, 1) + lBrowse := if(ValType(lBrowse) == "L", lBrowse, .F.) + + nRMargin := if(ValType(nRMargin) == "N", nRMargin, 255) + nBuffSize := if(ValType(nBuffSize) == "N", nBuffSize, 4096) + + cExitKeys := if(ValType(cExitKeys) == "C", cExitKeys, "") + + cExitKeys := if(Len(cExitKeys) > 25, SubStr(cExitKeys, 1, 25), cExitKeys) + + nHandle := FOpen(cInFile) + + rval := FError() + + if ( rval == 0 ) + rval := _FT_DFINIT(nHandle, nTop, nLeft, nBottom, nRight,; + nStart, nCNormal, nCHighlight, cExitKeys,; + lBrowse, nColSkip, nRMargin, nBuffSize) + endif + else + rval := 2 // simulate a file-not-found DOS file error + endif + +return (rval) + + + +/* $DOC$ + * $FUNCNAME$ + * FT_DFCLOSE() + * $CATEGORY$ + * File I/O + * $ONELINER$ + * Close file displayed by FT_DISPFILE() + * $SYNTAX$ + * FT_DFCLOSE() -> NIL + * $ARGUMENTS$ + * None + * $RETURNS$ + * NIL + * $DESCRIPTION$ + * Closes the file opened by FT_DFSETUP() + * $EXAMPLES$ + * @ 4,9 TO 11,71 + * + * FT_DFSETUP("test.txt", 5, 10, 10, 70, 1, 7, 15,; + * "AaBb" + Chr(143), .T., 5, 132, 4096) + * + * cKey = FT_DISPFILE() + * + * FT_DFCLOSE() + * + * @ 20,0 SAY "Key that terminated FT_DISPFILE() was: " + '[' + cKey + ']' + * $SEEALSO$ + * FT_DFSETUP() FT_DISPFILE() + * $END$ + */ + + + + +function FT_DFCLOSE() + + if ( nHandle > 0 ) + _FT_DFCLOS() + + FClose(nHandle) + + nHandle := 0 + endif + + return (NIL) diff --git a/harbour/contrib/libnf/diskfunc.prg b/harbour/contrib/libnf/diskfunc.prg new file mode 100644 index 0000000000..7956f0a412 --- /dev/null +++ b/harbour/contrib/libnf/diskfunc.prg @@ -0,0 +1,100 @@ +/* + * File......: DISKFUNC.PRG + * Author....: Robert A. DiFalco + * CIS ID....: ? + * + * This is an original work by Robert A. DiFalco and is placed in + * the public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.2 15 Aug 1991 23:02:20 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 17:49:28 GLENN + * Documentation format change (minor). + * Added work around suggested by a number of Nanforum users; sometimes + * _ftDiskFunc() would return negative numbers on large drives. + * + * Rev 1.0 01 Apr 1991 01:01:12 GLENN + * Nanforum Toolkit + * + */ + +#include "FTINT86.CH" + +#define DRVTABLE "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + +#ifdef FT_TEST + FUNCTION MAIN( cDrv ) + + QOut("Disk size: " + str( FT_DSKSIZE() ) ) + QOut("Free bytes: " + str( FT_DSKFREE() ) ) + + return ( nil ) +#endif + +/* $DOC$ + * $FUNCNAME$ + * FT_DSKSIZE() + * $CATEGORY$ + * DOS/BIOS + * $ONELINER$ + * Return the maximum capacity of a fixed disk + * $SYNTAX$ + * FT_DSKSIZE( [ ] ) -> nMaxCapacity + * $ARGUMENTS$ + * is the fixed disk to query. If no drive is sent, the + * operation will be performed on the default drive. Send without + * the ":". + * $RETURNS$ + * An integer representing the maximum disk capacity in bytes. + * $DESCRIPTION$ + * Function utilizing FT_INT86() to return Maximum Disk Size. + * Uses FT_INT86() through the internal function _ftDiskInfo(). + * $EXAMPLES$ + * ? FT_DSKSIZE() // Maximum capacity for default drive + * ? FT_DSKSIZE( "D" ) // Maximum capacity for Drive D: + * $END$ + */ + +FUNCTION FT_DSKSIZE( cDrive ) + local nDrive + nDrive := if( cDrive == NIL, 0, at( upper(cDrive), DRVTABLE ) ) + +Return DISKSPACE(nDrive,3) + + +/* $DOC$ + * $FUNCNAME$ + * FT_DSKFREE() + * $CATEGORY$ + * DOS/BIOS + * $ONELINER$ + * Return the amount of available disk space + * $SYNTAX$ + * FT_DSKFREE( [ ] ) -> nSpaceAvail + * $ARGUMENTS$ + * is the fixed disk to query. If no parameter is passed + * the operation will be performed on the default drive. Do not + * include the ":". + * $RETURNS$ + * Integer representing the available disk space in bytes. + * $DESCRIPTION$ + * Function to return the available space on the passed + * drive letter or the default drive if no drive is passed. + * + * Uses FT_INT86() through the internal function _ftDiskInfo(). + * $EXAMPLES$ + * ? FT_DSKFREE() // Returns free space on default drive. + * $END$ + */ + + +FUNCTION FT_DSKFREE( cDrive ) + local nDrive + nDrive := if( cDrive == NIL, 0, at( upper(cDrive), DRVTABLE ) ) + + +RETURN DISKSPACE(nDrive,1) diff --git a/harbour/contrib/libnf/dispmsg.prg b/harbour/contrib/libnf/dispmsg.prg new file mode 100644 index 0000000000..ca47397311 --- /dev/null +++ b/harbour/contrib/libnf/dispmsg.prg @@ -0,0 +1,333 @@ +/* + * File......: DISPMSG.PRG + * Author....: Paul Ferrara, ColumbuSoft + * CIS ID....: 76702,556 + * + * This function is an original work by Paul Ferrara and is placed in the + * public domain. + * + * Modification history: + * --------------------- + * + * Rev 2.0 12 Aug 1994 23:05:14 PAUL + * Added ablilty to highlight individual characters and cleaned up code + * + * Rev 1.2 15 Aug 1991 23:05:14 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:51:36 GLENN + * Minor edit to file header + * + * Rev 1.0 01 Apr 1991 01:01:12 GLENN + * Nanforum Toolkit + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_DISPMSG() + * $CATEGORY$ + * Menus/Prompts + * $ONELINER$ + * Display a message and optionally waits for a keypress + * $SYNTAX$ + * FT_DISPMSG( , [ ], + * [ ], [ ], + * [ ], [ ] ) -> lKeyMatch + * $ARGUMENTS$ + * is a multidimensional array of messages to be + * displayed and the color attributes for each message. + * + * The first dimension of the array contains one or more elements, + * each representing one line in the message box, up to the maximum + * number of rows on the screen. + * + * Within each line of the message individual characters or groups + * of characters may be delimited with braces ([]). The braces will + * be stripped out and the character(s) inside those braces will be + * highlighted. + * + * The second dimension of the array contains a color attribute for + * the corresponding element in dimension one, plus one additional + * element for the color of the box border. Dimension two will + * always contain one more element than dimension one. If an + * attribute is omitted, the last color selected will be used. + * + * is a character string of one or more keys to check + * for. If omitted, the message is displayed and control is returned + * to the calling procedure. If one character is specified, + * FT_DISPMSG() waits for one keypress, restores the screen and + * returns. If multiple characters are specified, FT_DISPMSG() + * remains in a loop until one of the specified keys has been + * pressed, then restores the screen and returns. + * + * is the upper row for the message box. If omitted, the + * box is centered vertically. + * + * is the leftmost column for the box. If omitted, the + * box is centered horizontally. + * + * is a string of characters or a variable for the box + * border. See the DISPBOX() function. If omitted, a double box is + * drawn. + * + * is a logical variable. If true (.T.) or omitted, it + * uses FT_SHADOW() to add a transparent shadow to the box. If + * false (.F.), the box is drawn without the shadow. + * $RETURNS$ + * If is not specified, FT_DISPMSG() will return false + * (.F.). + * + * If is a one-character string, FT_DISPMSG() will return + * true (.T.) if the user presses that key, or false (.F.) if any + * other key is pressed. + * + * If consists of multiple characters, it will lock the + * user in a loop until one of those keys are pressed and return the + * INKEY() value of the keypress. + * $DESCRIPTION$ + * FT_DISPMSG() is a multi-purpose pop-up for user messages. + * Multiple lines may be displayed, each with a different attribute. + * The box will be automatically centered on the screen, or the row + * and/or column can be specified by the programmer. It also centers + * each line of the message within the box. + * $EXAMPLES$ + * The following example displays a simple two-line message + * and returns immediately to the calling routine. + * + * FT_DISPMSG( { { "Printing Report" , ; + * "Press [ESC] To Interrupt" } , ; + * { "W+/B*", "W/B", "GR+/B" } } ) + * + * The next example displays a message and waits for a key press. + * + * FT_DISPMSG( { { "Press [D] To Confirm Deletion" , ; + * "Or Any Other Key To Abort" } , ; + * { "W+/B", "W+/B", "GR+/B" } } , ; + * "D" ) + * + * The next example displays a one-line message centered on row 5 + * and returns to the calling procedure. + * + * FT_DISPMSG( { { "Please Do Not Interrupt" } , ; + * { "W+/B", "GR+/B" } } , ; + * , 5, ) + * $END$ + */ + + +#include "INKEY.CH" + +// beginning of demo program +#ifdef FT_TEST + +// color variables +STATIC cNormH, cNormN, cNormE, ; + cWindH, cWindN, cWindE, ; + cErrH, cErrN, cErrE + +PROCEDURE Main( cCmdLine ) + LOCAL cDosScrn, ; + nDosRow, ; + nDosCol, ; + lColor, ; + nMaxRow, ; + nType + + + // main routine starts here + SET SCOREBOARD OFF + + lColor := .T. + + cNormH := IIF( lColor, "W+/BG","W+/N" ) + cNormN := IIF( lColor, "N/BG" ,"W/N" ) + cNormE := IIF( lColor, "N/W" , "N/W" ) + cWindH := IIF( lColor, "W+/B", "W+/N" ) + cWindN := IIF( lColor, "W/B" , "W/N" ) + cWindE := IIF( lColor, "N/W" , "N/W" ) + cErrH := IIF( lColor, "W+/R", "W+/N" ) + cErrN := IIF( lColor, "W/R" , "W/N" ) + cErrE := IIF( lColor, "N/W" , "N/W" ) + + cDosScrn := SAVESCREEN() + nDosRow=ROW() + nDosCol=COL() + SETCOLOR( "W/N" ) + CLS + nMaxRow := MAXROW() + SETBLINK(.F.) + SETCOLOR( cWindN + "*" ) + CLS + SETCOLOR( cNormN ) + + FT_DispMsg( { { "[Esc] To Abort Changes [PgDn] To Continue" }, { cNormN, , cNormH } }, , nMaxRow - 5 ) + + FT_DispMsg( { { "[E]dit [P]rint [D]elete", ; + "[Esc]ape [Alt-Q]" }, ; + { cErrN, cErrN, cErrH } },, 2 ) + + nType := FT_DispMsg( { { "Create Or Edit [I]nvoice", ; + "Create Or Edit [O]rder", ; + "Create Or Edit [B]ack Order", ; + "Create Or Edit [Q]uote", ; + "[Esc] To Exit" }, ; + { cWindN,,,,, cWindH } }, "BIOQ" + CHR(27) ) + + SETCOLOR( "W/N" ) + SETCURSOR( 1 ) + SETBLINK( .T.) + RESTSCREEN(,,,, cDosScrn ) + SETPOS(nDosRow, nDosCol) + QUIT + +#endif +// end of demo program + + + + +FUNCTION FT_DispMsg( aInfo, cKey, nBoxTop, nBoxLeft, cnBoxString, lShadow ) + + LOCAL xRtnVal := .F., ; + nWidest := 0, ; + nBoxRight, ; + nBoxBottom, ; + cOldScreen, ; + cOldCursor, ; + cOldColor, ; + i, ; + j, ; + nOption, ; + x, ; + y, ; + aPos := {}, ; + nLeft, ; + nTop, ; + aLeft, ; + cLeftMarker, ; + cRightMarker + + FOR i := 1 TO LEN( aInfo[1] ) + AADD( aPos, {} ) + NEXT + + FOR i := 1 TO LEN( aInfo[1] ) + + DO WHILE AT( "[", aInfo[1,i] ) > 0 + x := AT( "[", aInfo[1,i] ) + y := AT( "]", aInfo[1,i] ) - 2 + AADD( aPos[i], { x, y } ) + aInfo[1,i] := STRTRAN( aInfo[1,i], "[", "", 1, 1 ) + aInfo[1,i] := STRTRAN( aInfo[1,i], "]", "", 1, 1 ) + ENDDO + + NEXT + + AEVAL( aInfo[1], {|x| nWidest := MAX( nWidest, LEN( x ) ) } ) + + /* calculate location of data */ + IF nBoxLeft == NIL + nLeft := ROUND( ( MAXCOL() - nWidest ) / 2, 0 ) + ELSE + nLeft := nBoxLeft + 2 + ENDIF + + IF nBoxTop == NIL + nTop := ( MAXROW() - LEN( aInfo[1] ) - 2 ) / 2 + 2 + ENDIF + + + /* calculate location of box */ + IF nBoxLeft == NIL + nBoxLeft := nLeft - 2 + ENDIF + nBoxRight := nBoxLeft + nWidest + 3 + + IF nBoxTop == NIL + nBoxTop := (MAXROW() - LEN( aInfo[1] ) - 2) / 2 + 1 + ENDIF + nBoxBottom := nBoxTop + LEN( aInfo[1] ) + 1 + + // following is to keep from breaking old code and to be + // consistent with DISPBOX() + + IF cnBoxString == NIL .OR. cnBoxString == 2 + cnBoxString := "ÉÍ»º¼ÍȺ " + ELSEIF cnBoxString == 1 + cnBoxString := "ÚÄ¿³ÙÄÀ³ " + ENDIF + + lShadow := IIF( lShadow == NIL, .T., lShadow ) + + cOldScreen := SAVESCREEN( nBoxTop, nBoxLeft, nBoxBottom+1, nBoxRight+2 ) + + cOldCursor := SETCURSOR( 0 ) + + // draw box + cOldColor := SETCOLOR( aInfo[ 2, LEN( aInfo[2] ) ] ) + + DISPBOX( nBoxTop, nBoxLeft, nBoxBottom, nBoxRight, cnBoxString, ; + aInfo[ 2, LEN( aInfo[2] ) ] ) + IF lShadow + FT_Shadow( nBoxTop, nBoxLeft, nBoxBottom, nBoxRight ) + ENDIF + + + /* fill array with left positions for each row */ + aLeft := ARRAY( LEN( aInfo[1] ) ) + FOR i := 1 TO LEN( aInfo[1] ) + IF LEN( aInfo[1,i] ) = nWidest + aLeft[i] := nLeft + ELSE + aLeft[i] := nLeft + ROUND( ( nWidest - LEN( aInfo[1,i] ) ) / 2, 0 ) + ENDIF + NEXT + + /* fill array of colors */ + FOR i := 2 TO LEN( aInfo[2] ) + IF aInfo[2,i] == NIL + aInfo[2,i] := aInfo[2,i-1] + ENDIF + NEXT + + + /* display messages */ + FOR i := 1 TO LEN( aInfo[1] ) + @ nBoxTop+i, aLeft[i] SAY aInfo[1,i] COLOR aInfo[2,i] + NEXT + + + /* highlight characters */ + FOR i := 1 TO LEN( aPos ) + FOR j := 1 TO LEN( aPos[i] ) + + FT_SetAttr( nBoxTop + i, ; + aPos[i,j,1] + aLeft[i] - 1, ; + nBoxTop + i, ; + aPos[i,j,2] + aLeft[i] - 1, ; + FT_Color2N( aInfo[ 2, LEN( aInfo[2] ) ] ) ) + NEXT + NEXT + + + IF cKey != NIL + IF LEN( cKey ) == 1 + nOption := FT_SInkey(0) + IF UPPER( CHR( nOption) ) == cKey + xRtnVal := .t. + ENDIF + ELSE + nOption := 0 + DO WHILE AT( UPPER( CHR( nOption ) ), UPPER( cKey ) ) == 0 + nOption := FT_SInkey(0) + ENDDO + xRtnVal := nOption + ENDIF + RESTSCREEN( nBoxTop, nBoxLeft, nBoxBottom+1, nBoxRight+2, cOldScreen ) + ENDIF + + SETCOLOR( cOldColor ) + SETCURSOR( cOldCursor ) + RETURN xRtnVal diff --git a/harbour/contrib/libnf/dosver.prg b/harbour/contrib/libnf/dosver.prg new file mode 100644 index 0000000000..06056c0b24 --- /dev/null +++ b/harbour/contrib/libnf/dosver.prg @@ -0,0 +1,82 @@ +/* + * File......: DOSVER.PRG + * Author....: Glenn Scott + * CIS ID....: ? + * + * This is an original work by Glenn Scott and is placed in the + * public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.2 15 Aug 1991 23:02:24 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 12 Jun 1991 02:38:24 GLENN + * Documentation mod and removal of reference to constant INT86_SUCCESS. + * Checked for ft_int86() compatibility. + * + * Rev 1.0 01 Apr 1991 01:01:14 GLENN + * Nanforum Toolkit + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_DOSVER + * $CATEGORY$ + * DOS/BIOS + * $ONELINER$ + * Return the current DOS major and minor version as a string + * $SYNTAX$ + * FT_DOSVER() -> + * $ARGUMENTS$ + * None + * $RETURNS$ + * A character string with the major version number first, a + * period ("."), then the minor version number (e.g., "3.30") + * $DESCRIPTION$ + * + * FT_DOSVER() invokes DOS interrupt 21h, service 30 in order to + * return the current DOS version. It does this by setting up + * an array corresponding to machine registers and then calling + * the toolkit function FT_INT86(). + * + * It returns a character string corresponding to the DOS + * version, as follows: The major version, a period ("."), then + * the minor version. + * + * + * $EXAMPLES$ + * + * FUNCTION main() + * RETURN QOut( "Dos version: " + FT_DOSVER() ) + * + * $END$ + */ + +#include "FTINT86.CH" + +#define DOS 33 +#define DOSVER 48 + + +#ifdef FT_TEST + FUNCTION MAIN() + QOut( "Dos version: " + FT_DOSVER() ) + return ( nil ) +#endif + +FUNCTION FT_DOSVER() +/* local aRegs[ INT86_MAX_REGS ] */ + local cResult := "" + +/* aRegs[ AX ] = MAKEHI( DOSVER ) + if FT_INT86( DOS, aRegs ) + cResult := alltrim( str( LOWBYTE( aRegs[ AX ] ) ) ) + "." + ; + alltrim( str( HIGHBYTE( aRegs[ AX ] ) ) ) + endif +*/ +cResult:= _get_dosver() +RETURN ( cResult ) diff --git a/harbour/contrib/libnf/e2d.prg b/harbour/contrib/libnf/e2d.prg new file mode 100644 index 0000000000..996b9df422 --- /dev/null +++ b/harbour/contrib/libnf/e2d.prg @@ -0,0 +1,68 @@ +/* + * File......: E2D.PRG + * Author....: Gary Baren + * CIS ID....: 75470,1027 + * + * This is an original work by Gary Baren and is hereby placed in the + * public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.2 15 Aug 1991 23:03:28 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:51:40 GLENN + * Minor edit to file header + * + * Rev 1.0 07 Jun 1991 23:03:32 GLENN + * Initial revision. + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_E2D() + * $CATEGORY$ + * Conversion + * $ONELINER$ + * Convert scientific notation string to a decimal + * $SYNTAX$ + * FT_E2D( ) -> + * $ARGUMENTS$ + * Scientific notation string to convert + * $RETURNS$ + * Decimal number + * $DESCRIPTION$ + * Given a string in the format x.yEz, the decimal + * equivalent is returned. + * $EXAMPLES$ + * ? FT_E2D( "1.23E1" ) + * -> 12.3 + * + * ? FT_E2D( "-1.235E1" ) + * -> -12.35 + * + * ? ft_d2e( "5.43E-6" ) + * -> 0.0000543 + * $SEEALSO$ + * FT_D2E() + * $END$ + */ + +#ifdef FT_TEST + function main( sNumE ) + return qout( FT_E2D( sNumE ) ) +#endif + +function ft_e2d( sNumE ) + local nMant, nExp + + nMant := val( left( sNumE, at( 'E', sNumE ) - 1 ) ) + nExp := val(substr( sNumE, ; + at( 'E', sNumE ) + 1, ; + len( sNumE ) - at( 'E', sNumE ) ; + ) ; + ) + return( nMant * 10 ^ nExp ) diff --git a/harbour/contrib/libnf/easter.prg b/harbour/contrib/libnf/easter.prg new file mode 100644 index 0000000000..1c6db8c8e6 --- /dev/null +++ b/harbour/contrib/libnf/easter.prg @@ -0,0 +1,127 @@ +/* + * File......: EASTER.PRG + * Author....: Paul Tucker + * CIS ID....: ? + * + * While I can say that I wrote the program, the algorithm is from Donald + * Knuth's The Art of Computer Programming, Section 1.3.2. So, the source + * code is an original work by Paul Tucker and is placed in the public + * domain + * + * Modification history: + * --------------------- + * + * Rev 1.2 15 Aug 1991 23:05:28 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:51:42 GLENN + * Minor edit to file header + * + * Rev 1.0 01 Apr 1991 01:01:16 GLENN + * Nanforum Toolkit + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_EASTER() + * $CATEGORY$ + * Date/Time + * $ONELINER$ + * Return the date of Easter + * $SYNTAX$ + * FT_EASTER( ) -> dEdate + * $ARGUMENTS$ + * xYear can be a character, date or numeric describing the year + * for which you wish to receive the date of Easter. + * $RETURNS$ + * The actual date that Easter occurs. + * $DESCRIPTION$ + * Returns the date of Easter for any year after 1582 up to Clipper's + * limit which the manual states is 9999, but the Guide agrees with + * the actual imposed limit of 2999. + * + * This function can be useful in calender type programs that indicate + * when holidays occur. + * $EXAMPLES$ + * dEdate := FT_EASTER( 1990 ) && returns 04/15/1990 + * $END$ + */ + + +FUNCTION FT_EASTER (nYear) + local nGold, nCent, nCorx, nCorz, nSunday, nEpact, nMoon,; + nMonth := 0, nDay := 0, lCent := __SetCentury( .t. ) + + // -------------------------------- + // NOTE: __SetCentury() is internal + // -------------------------------- + + IF VALTYPE (nYear) == "C" + nYear = VAL(nYear) + ENDIF + + IF VALTYPE (nYear) == "D" + nYear = YEAR(nYear) + ENDIF + + IF VALTYPE (nYear) == "N" + IF nYear > 1582 + + * <> is Golden number of the year in the 19 year Metonic cycle + nGold = nYear % 19 + 1 + + * <> is Century + nCent = INT (nYear / 100) + 1 + + * Corrections: + * <> is the no. of years in which leap-year was dropped in order + * to keep step with the sun + nCorx = INT ((3 * nCent) / 4 - 12) + + * <> is a special correction to synchronize Easter with the moon's + * orbit. + nCorz = INT ((8 * nCent + 5) / 25 - 5) + + * <> Find Sunday + nSunday = INT ((5 * nYear) / 4 - nCorx - 10) + + * Set Epact <> (specifies occurance of a full moon) + nEpact = INT ((11 * nGold + 20 + nCorz - nCorx) % 30) + + IF nEpact < 0 + nEpact += 30 + ENDIF + + IF ((nEpact = 25) .AND. (nGold > 11)) .OR. (nEpact = 24) + ++nEpact + ENDIF + + * Find full moon - the <>th of MARCH is a "calendar" full moon + nMoon = 44 - nEpact + + IF nMoon < 21 + nMoon += 30 + ENDIF + + * Advance to Sunday + nMoon = INT (nMoon + 7 - ((nSunday + nMoon) % 7)) + + * Get Month and Day + IF nMoon > 31 + nMonth = 4 + nDay = nMoon - 31 + ELSE + nMonth = 3 + nDay = nMoon + ENDIF + ENDIF + ELSE + nYear = 0 + ENDIF + + set century (lCent) + +RETURN CTOD (RIGHT ("00"+LTRIM (STR (nMonth)),2) + "/" +; + RIGHT ("00"+LTRIM (STR (INT (nDay))) ,2) + "/" +STR (nYear,4)) diff --git a/harbour/contrib/libnf/elapmil.prg b/harbour/contrib/libnf/elapmil.prg new file mode 100644 index 0000000000..cf54c48a7e --- /dev/null +++ b/harbour/contrib/libnf/elapmil.prg @@ -0,0 +1,52 @@ +/* + * File......: ELAPMIL.PRG + * Author....: Alexander B. Spencer + * CIS ID....: 76276,1012 + * + * This is an original work by Alexander B. Spencer and is placed in the + * public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.2 15 Aug 1991 23:03:32 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:51:44 GLENN + * Minor edit to file header + * + * Rev 1.0 07 Jun 1991 23:39:42 GLENN + * Initial revision. + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_ELAPMIN() + * $CATEGORY$ + * Date/Time + * $ONELINER$ + * Return difference, in minutes, between two mil format times. + * $SYNTAX$ + * FT_ELAPMIN( , ) -> nMINUTES + * $ARGUMENTS$ + * character strings of military form "hhmm", + * where 0<=hh<24. + * $RETURNS$ + * + * $DESCRIPTION$ + * Finds the arithmetic difference between time two times + * (time 2 - time 1). + * If time 2 is smaller than time 1, a NEGATIVE value is returned. + * $EXAMPLES$ + * FT_ELAPMIN( "1718", "2040" ) -> 322 + * FT_ELAPMIN( "2040", "1718" ) -> -322 + * $SEEALSO$ + * FT_ELTIME() FT_MIL2MIN() FT_MIN2MIL() + * $END$ + */ + +function FT_ELAPMIN(cTIME1,cTIME2) + return ((VAL(LEFT(cTIME2,2))*60) + (VAL(RIGHT(cTIME2,2)))) - ; + ((VAL(LEFT(cTIME1,2))*60) + (VAL(RIGHT(cTIME1,2)))) diff --git a/harbour/contrib/libnf/elapsed.prg b/harbour/contrib/libnf/elapsed.prg new file mode 100644 index 0000000000..044210ba69 --- /dev/null +++ b/harbour/contrib/libnf/elapsed.prg @@ -0,0 +1,127 @@ +/* + * File......: ELAPSED.PRG + * Author....: Jo W. French dba Practical Computing + * CIS ID....: ? + * + * The functions contained herein are the original work of Jo W. French + * and are placed in the public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.3 28 Sep 1992 00:37:56 GLENN + * Jo French cleaned up. + * + * Rev 1.2 15 Aug 1991 23:05:44 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:51:46 GLENN + * Minor edit to file header + * + * Rev 1.0 01 Apr 1991 01:01:18 GLENN + * Nanforum Toolkit + * + */ + + +#ifdef FT_TEST + + FUNCTION DEMO() + LOCAL dStart, dEnd, cTimeStart, cTimeEnd, n, aDataTest := {} + dStart := CTOD('11/28/90') + dEnd := CTOD('11/30/90') + cTimeStart := "08:00:00" + cTimeEnd := "12:10:30" + + aDataTest := FT_ELAPSED(dStart,dEnd,cTimeStart,cTimeEnd) + FOR n = 1 to 4 + ? aDataTest[n,1], STR(aDataTest[n,2], 12, 4) + ?? " " + ?? IF(n == 1, 'Days', IF( n== 2, 'Hours', IF( n == 3, 'Mins.', 'Secs.'))) + NEXT + RETURN NIL + +#endif + +/* $DOC$ + * $FUNCNAME$ + * FT_ELAPSED() + * $CATEGORY$ + * Date/Time + * $ONELINER$ + * Return elapsed time between two days and/or times + * $SYNTAX$ + * FT_ELAPSED([ ], [ ], ; + * , ) -> aTimedata + * $ARGUMENTS$ + * is any valid date in any date format. Defaults to DATE(). + * + * is any valid date in any date format. Defaults to DATE(). + * + * is a valid Time string of the format 'hh:mm:ss' where + * hh is hours in 24-hour format. + * + * is a valid Time string of the format 'hh:mm:ss' where + * hh is hours in 24-hour format. + * $RETURNS$ + * A two-dimensional array containing elapsed time data. + * $DESCRIPTION$ + * FT_ELAPSED() calculates the elapsed time between two Date/Time events. + * + * It returns an array which contains the following data: + * + * aRetVal[1,1] Integer Days aRetVal[1,2] Total Days (nn.nnnn) + * aRetVal[2,1] Integer Hours aRetVal[2,2] Total Hours (nn.nnnn) + * aRetVal[3,1] Integer Minutes aRetVal[3,2] Total Minutes (nn.nnnn) + * aRetVal[4,1] Integer Seconds aRetVal[4,2] Total Seconds (nn) + * $EXAMPLES$ + * FT_ELAPSED(CTOD('11/28/90'), CTOD('11/30/90'), '08:00:00', '12:10:30') + * will return: + * + * aRetVal[1,1] -> 2 (Days) aRetVal[1,2] -> 2.1740 Days + * aRetVal[2,1] -> 4 (Hours) aRetVal[2,2] -> 52.1750 Hours + * aRetVal[3,1] -> 10 (Minutes) aRetVal[3,2] -> 3130.5000 Minutes + * aRetVal[4,1] -> 30 (Seconds) aRetVal[4,2] -> 187830 Seconds + * $END$ + */ + +FUNCTION FT_ELAPSED(dStart, dEnd, cTimeStart, cTimeEnd) + LOCAL nTotalSec, nCtr, nConstant, nTemp, aRetVal[4,2] + + IF ! ( VALTYPE(dStart) $ 'DC' ) + dStart := DATE() + ELSEIF VALTYPE(dStart) == 'C' + cTimeStart := dStart + dStart := DATE() + ENDIF + + IF ! ( VALTYPE(dEnd) $ 'DC' ) + dEnd := DATE() + ELSEIF VALTYPE(dEnd) == 'C' + cTimeEnd := dEnd + dEnd := DATE() + ENDIF + + IF( VALTYPE(cTimeStart) != 'C', cTimeStart := '00:00:00', ) + IF( VALTYPE(cTimeEnd) != 'C', cTimeEnd := '00:00:00', ) + + nTotalSec := (dEnd - dStart) * 86400 + ; + VAL(cTimeEnd) * 3600 + ; + VAL(SUBSTR(cTimeEnd,AT(':', cTimeEnd)+1,2)) * 60 + ; + IF(RAT(':', cTimeEnd) == AT(':', cTimeEnd), 0, ; + VAL(SUBSTR(cTimeEnd,RAT(':', cTimeEnd)+1))) - ; + VAL(cTimeStart) * 3600 - ; + VAL(SUBSTR(cTimeStart,AT(':', cTimeStart)+1,2)) * 60 - ; + IF(RAT(':', cTimeStart) == AT(':', cTimeStart), 0, ; + VAL(SUBSTR(cTimeStart,RAT(':', cTimeStart)+1))) + + nTemp := nTotalSec + + FOR nCtr = 1 to 4 + nConstant := IF(nCtr == 1, 86400, IF(nCtr == 2, 3600, IF( nCtr == 3, 60, 1))) + aRetVal[nCtr,1] := INT(nTemp/nConstant) + aRetval[nCtr,2] := nTotalSec / nConstant + nTemp -= aRetVal[nCtr,1] * nConstant + NEXT + +RETURN aRetVal diff --git a/harbour/contrib/libnf/eltime.prg b/harbour/contrib/libnf/eltime.prg new file mode 100644 index 0000000000..e370ec775b --- /dev/null +++ b/harbour/contrib/libnf/eltime.prg @@ -0,0 +1,66 @@ +/* + * File......: ELTIME.PRG + * Author....: Alexander B. Spencer + * CIS ID....: 76276,1012 + * + * This is an original work by Alexander B. Spencer and is placed in the + * public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.2 15 Aug 1991 23:06:14 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 20:58:56 GLENN + * Two locals, nSECS1 and nSECS2, were not declared; this was fixed. + * + * Rev 1.0 07 Jun 1991 23:39:46 GLENN + * Initial revision. + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_ELTIME() + * $CATEGORY$ + * Date/Time + * $ONELINER$ + * Compute difference between times in hours, minutes, seconds. + * $SYNTAX$ + * FT_ELTIME( , ) -> cDiff + * $ARGUMENTS$ + * character strings representing times in + * hh:mm:ss format. + * $RETURNS$ + * character string representing time difference in + * hh:mm:ss format. + * $DESCRIPTION$ + * Return the absolute difference between two times in hh:mm:ss format + * in character hours, minutes and seconds (hh:mm:ss). + * $EXAMPLES$ + * FT_ELTIME( "22:40:12", "23:55:17" ) -> 01:15:05 + * FT_ELTIME( "23:55:17", "22:40:12" ) -> 01:15:05 + * $SEEALSO$ + * FT_ELAPMIN() FT_MIL2MIN() FT_MIN2MIL() + * $END$ + */ + +function FT_ELTIME(cTIME1,cTIME2) + local nTIME1, nTIME2, nDELSECS, nHRS, nMINS, nSECS, nSECS1, nSECS2 + + nSECS1 := (val(substr(cTIME1,1,2)) * 3600) +; + (val(substr(cTIME1,4,2)) * 60) + (val(substr(cTIME1,7))) + nSECS2 := (val(substr(cTIME2,1,2)) * 3600) +; + (val(substr(cTIME2,4,2)) * 60) + (val(substr(cTIME2,7))) + nDELSECS := abs(nSECS2 - nSECS1) + nHRS := int(nDELSECS / 3600) + nMINS := int((nDELSECS - nHRS * 3600) / 60) + nSECS := nDELSECS - (nHRS * 3600) - (nMINS * 60) + + return right("00" + ltrim(str(nHRS)),2) + ; + ":" + ; + right("00" + ltrim(str(nMINS)),2) + ; + ":" + ; + right("00" + ltrim(str(nSECS)),2)