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

See changelog 20000421 23:00

Browse Source
This commit is contained in:
Luiz Rafael Culik
2000-04-22 02:24:42 +00:00
parent e26e112ea5
commit ae5b4f3c1e
15 changed files with 1959 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

89
harbour/contrib/libnf/d2e.prg Normal file
View File

@@ -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( <nDec>, <nPrecision> ) -> <cNumE>
* $ARGUMENTS$
* <nDec> Decimal number to convert
*
* <nPrecision> Number of decimal places in result.
* Defaults to 6 decimal places.
* $RETURNS$
* <cNumE> 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 <p> TO <val> => <p> := iif( <p> == NIL, <val>, <p> )
#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 ) ) )

330
harbour/contrib/libnf/datecnfg.prg Normal file
View File

@@ -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( [ <cFYStart> ], [ <nDow> ] ) -> aDateInfo
* $ARGUMENTS$
* <cFYStart> 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.
*
* <nDow> 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 )

116
harbour/contrib/libnf/dayofyr.prg Normal file
View File

@@ -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( [ <dGivenDate> ], [ <nDayNum> ], [ <lIsAcct> ] )
* -> aDateInfo
* $ARGUMENTS$
* <dGivenDate> is any valid date in any valid format. Defaults
* to current system date if not supplied.
*
* <nDayNum> is a number from 1 to 371, signifying a day of a year.
* Defaults to current day if not supplied.
*
* <lIsAcct> 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 <nDayNum> 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 <nDayNum> 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

75
harbour/contrib/libnf/daytobow.prg Normal file
View File

@@ -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( [ <dGivenDate> ] ) -> nDays
* $ARGUMENTS$
* <dGivenDate> 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

67
harbour/contrib/libnf/dectobin.prg Normal file
View File

@@ -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( <nNum> ) -> cBinaryNumber
* $ARGUMENTS$
* <nNum> is the numeric expression to be converted.
* $RETURNS$
* A character string representing <nNum> 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

100
harbour/contrib/libnf/descend.c Normal file
View File

@@ -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( <exp> ) -> <value>
* $ARGUMENTS$
* <exp> is any expression of character, numeric, date, or logical type.
* $RETURNS$
* The inverse of <exp>
* $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 <hbapi.H>
#include <hbapiitm.h>
//#include <FM.API>
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
}

227
harbour/contrib/libnf/dfile.prg Normal file
View File

@@ -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( <cInFile>, <nTop>, <nLeft>, <nBottom>, <nRight>, ;
* <nStart>, <nCNormal>, <nCHighlight>, <cExitKeys>, ;
* <lBrowse>, <nColSkip>, <nRMargin>, <nBuffSize> ) -> nResult
* $ARGUMENTS$
* <cInFile> - text file to display (full path and filename)
* <nTop> - upper row of window
* <nLeft> - left col of window
* <nBottom> - lower row of window
* <nRight> - right col of window
* <nStart> - line to place highlight at startup
* <nCNormal> - normal text color (numeric attribute)
* <nCHighlight> - text highlight color (numeric attribute)
* <cExitKeys> - terminating key list (each byte of string is a
* key code)
* <lBrowse> - act-like-a-browse-routine flag
* <nColSkip> - col increment for left/right arrows
* <nRMargin> - right margin - anything to right is truncated
* <nBuffSize> - 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)

100
harbour/contrib/libnf/diskfunc.prg Normal file
View File

@@ -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( [ <cDrive> ] ) -> nMaxCapacity
* $ARGUMENTS$
* <cDrive> 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( [ <cDrive> ] ) -> nSpaceAvail
* $ARGUMENTS$
* <cDrive> 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)

333
harbour/contrib/libnf/dispmsg.prg Normal file
View File

@@ -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( <aMessageArray>, [ <cKey2Check> ],
* [ <nTopBoxRow> ], [ <nLeftBoxColumn> ],
* [ <cnBoxType> ], [ <lShadow> ] ) -> lKeyMatch
* $ARGUMENTS$
* <aMessageArray> 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.
*
* <Key2Check> 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.
*
* <nTopBoxRow> is the upper row for the message box. If omitted, the
* box is centered vertically.
*
* <nLeftBoxColumn> is the leftmost column for the box. If omitted, the
* box is centered horizontally.
*
* <cnBoxType> is a string of characters or a variable for the box
* border. See the DISPBOX() function. If omitted, a double box is
* drawn.
*
* <lShadow> 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 <Key2Check> is not specified, FT_DISPMSG() will return false
* (.F.).
*
* If <Key2Check> 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 <Key2Check> 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

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

@@ -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() -> <cVersion>
* $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 )

68
harbour/contrib/libnf/e2d.prg Normal file
View File

@@ -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( <cNumE> ) -> <nDec>
* $ARGUMENTS$
* <cNumE> Scientific notation string to convert
* $RETURNS$
* <nDec> 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 )

127
harbour/contrib/libnf/easter.prg Normal file
View File

@@ -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( <xYear> ) -> 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
* <<nGold>> is Golden number of the year in the 19 year Metonic cycle
nGold = nYear % 19 + 1
* <<nCent>> is Century
nCent = INT (nYear / 100) + 1
* Corrections:
* <<nCorx>> is the no. of years in which leap-year was dropped in order
* to keep step with the sun
nCorx = INT ((3 * nCent) / 4 - 12)
* <<nCorz>> is a special correction to synchronize Easter with the moon's
* orbit.
nCorz = INT ((8 * nCent + 5) / 25 - 5)
* <<nSunday>> Find Sunday
nSunday = INT ((5 * nYear) / 4 - nCorx - 10)
* Set Epact <<nEpact>> (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 <<nMoon>>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))

52
harbour/contrib/libnf/elapmil.prg Normal file
View File

@@ -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( <cTIME1>, <cTIME2> ) -> nMINUTES
* $ARGUMENTS$
* <cTIME1, cTIME2> character strings of military form "hhmm",
* where 0<=hh<24.
* $RETURNS$
* <nMINUTES>
* $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))))

127
harbour/contrib/libnf/elapsed.prg Normal file
View File

@@ -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([ <dStart> ], [ <dEnd> ], ;
* <cTimeStart>, <cTimeEnd>) -> aTimedata
* $ARGUMENTS$
* <dStart> is any valid date in any date format. Defaults to DATE().
*
* <dEnd> is any valid date in any date format. Defaults to DATE().
*
* <cTimeStart> is a valid Time string of the format 'hh:mm:ss' where
* hh is hours in 24-hour format.
*
* <cTimeEnd> 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

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

@@ -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( <cTime1>, <cTime2> ) -> cDiff
* $ARGUMENTS$
* <cTime1, cTime2> character strings representing times in
* hh:mm:ss format.
* $RETURNS$
* <cDiff> 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)