diff --git a/harbour/contrib/libnf/aading.prg b/harbour/contrib/libnf/aading.prg new file mode 100644 index 0000000000..2ad5b9d7c9 --- /dev/null +++ b/harbour/contrib/libnf/aading.prg @@ -0,0 +1,160 @@ +/* + * File......: Aadding.prg + * Author....: Ralph Oliver, TRANSCOM SYSTEMS + * CIS ID....: 74030,703 + * + * This is an original work by Ralph Oliver and is placed in the + * public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.1 15 Aug 1991 23:05:40 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.0 07 Jun 1991 23:03:08 GLENN + * Initial revision. + * + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_AADDITION() + * $CATEGORY$ + * Array + * $ONELINER$ + * Add elements unique of source array to target array + * $SYNTAX$ + * FT_AADDITION( , [, [, ] ] ) ; + * -> aNewArray + * $ARGUMENTS$ + * is the primary array. + * + * is the secondary array. + * + * is a logical value denoting whether leading or + * trailing spaces should be included in the + * comparison. If .T., then ignores spaces in + * comparison, defaults to .T., .F. includes spaces. + * + * is a logical value denoting case sensitivity. + * If .T., then comparison is sensitive to case, + * defaults to .T., .F. ignores case. + * $RETURNS$ + * An array of the union of aList1 and aList2. + * $DESCRIPTION$ + * This function will add the elements unique of aList2 with aList1. + * It returns a new array including all the elements of aList1 + * plus the unique elements of aList2. + * $EXAMPLES$ + * aList1 := {"apple", "orange", "pear"} + * aList2 := {"apple ", "banana", "PEAR"} + * + * FT_AADDITION( aList1, aList2 ) + * // ignores spaces, sensitive to case + * // returns {"apple","orange","pear","banana","PEAR"} + * + * FT_AADDITION( aList1, aList2, , .F. ) + * // ignores spaces, not sensitive to case + * // returns {"apple","orange","pear","banana"} + * + * FT_AADDITION( aList1, aList2, .F., .F. ) + * // sensitive to spaces, not sensitive to case + * // returns {"apple","orange","pear","apple ","banana"} + * $END$ + */ + +#ifdef FT_TEST + +FUNCTION MAIN() + LOCAL aList1,aList2,var0,nstart,nstop,nelapsed,nCtr + CLS + ? "TEST TO DEMONSTRATE EXAMPLES OF FT_AADDITION" + ? + aList1 := {"apple", "orange", "pear"} + aList2 := {"apple ", "banana", "PEAR"} + ? "aList1 : " + AEVAL( aList1, { |x| QQOUT(x + ",") } ) + ? + ? "aList2 : " + AEVAL( aList2, { |x| QQOUT(x + ",") } ) + ? + + nstart := SECONDS() + FOR nCtr := 1 to 100 + var0 := FT_AADDITION( aList1, aList2 ) + NEXT + nstop := SECONDS() + nelapsed := nstop - nstart + ? "time for 100 merges:", nelapsed + + ? PADR("FT_AADDITION( aList1, aList2 ) ->",44) + AEVAL( var0, { |x| QQOUT(x + ",") } ) + ? + var0 := FT_AADDITION( aList1, aList2, , .F. ) + ? PADR("FT_AADDITION( aList1, aList2, , .F. ) ->",44) + AEVAL( var0, { |x| QQOUT(x + ",") } ) + ? + var0 := FT_AADDITION( aList1, aList2, .F., .F. ) + ? PADR("FT_AADDITION( aList1, aList2, .F., .F. ) ->",44) + AEVAL( var0, { |x| QQOUT(x + ",") } ) + ? + RETURN NIL + +#endif + + +FUNCTION FT_AADDITION( aList1, aList2, lTrimmer, lCaseSens ) + + LOCAL nElement, nPos, bScanCode + LOCAL aNewArray := ACLONE( aList1 ) + + // Set default parameters as necessary. + IF lCaseSens == NIL + lCaseSens := .T. + ENDIF + + IF lTrimmer == NIL + lTrimmer := .T. + ENDIF + + // Assign code blocks according to case sensitivity and trim. + IF lCaseSens + + IF lTrimmer // Ignore spaces. + bScanCode := { |x| ; + ALLTRIM( x ) == ; + ALLTRIM( aList2[ nElement ]) } + ELSE + bScanCode := { |x| ( aList2[ nElement ]) } + ENDIF + + ELSE // Ignore case. + + IF lTrimmer // Ignore spaces. + bScanCode := { |x| ; + UPPER( ALLTRIM( x )) == ; + UPPER( ALLTRIM( aList2[ nElement ] )) } + ELSE + bScanCode := { |x| ; + UPPER( x ) == ; + UPPER( aList2[ nElement ] ) } + ENDIF + ENDIF + + + // Add the unique elements of aList2 to aList1. + FOR nElement := 1 TO LEN( aList2 ) + + nPos := ASCAN( aList1, bScanCode ) + + // If unique, then add element to new array. + IF nPos = 0 + AADD( aNewArray, aList2[ nElement ] ) + ENDIF + + NEXT + + RETURN ( aNewArray ) diff --git a/harbour/contrib/libnf/aavg.prg b/harbour/contrib/libnf/aavg.prg new file mode 100644 index 0000000000..4a177cd446 --- /dev/null +++ b/harbour/contrib/libnf/aavg.prg @@ -0,0 +1,82 @@ +/* + * File......: AAvg.Prg + * Author....: David Husnian + * CIS ID....: ? + * + * This is an original work by David Husnian and is placed in the + * public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.2 15 Aug 1991 23:04:54 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:50:38 GLENN + * Minor edit to file header + * + * Rev 1.0 01 Apr 1991 01:00:20 GLENN + * Nanforum Toolkit + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_AAVG() + * $CATEGORY$ + * Array + * $ONELINER$ + * Average numeric values in an array + * $SYNTAX$ + * FT_AAVG( [, [, ] ] ) -> nAverage + * $ARGUMENTS$ + * is the array containing the elements to be averaged. + * + * is the first array item to include, + * defaults to first element. + * + * is the last array element to include, + * defaults to all elements. + * $RETURNS$ + * The average of the specified array elements. + * $DESCRIPTION$ + * This function is used to get a numeric average of selected or all + * elements of an array. + * + * This routine requires FT_ASUM(). + * $EXAMPLES$ + * FT_AAVG(aSubTotals) // Get Average of Entire Array + * + * FT_AAVG(aSubTotals, 5) // Get Average of 5th Element On + * + * FT_AAVG(aSubTotals, , 10) // Get Average of 1st 10 Elements + * + * FT_AAVG(aSubTotals, 5, 10) // Get Average of Elements 5-10 + * $END$ + */ + +#define FORCE_BETWEEN(x,y,z) (y := MAX(MIN(y,z),x)) +#define IS_NOT_ARRAY(x) (VALTYPE(x) != "A") + +#command DEFAULT TO [, TO ] ; + => ; + := IF( == NIL,,) ; + [; := IF( == NIL,,)] + + + +FUNCTION FT_AAVG(aArray, nStartIndex, nEndIndex) + + DEFAULT nStartIndex TO 1, ; + nEndIndex TO LEN(aArray) + + // Make Sure Bounds are in Range + + FORCE_BETWEEN(1, nEndIndex, LEN(aArray)) + FORCE_BETWEEN(1, nStartIndex, nEndIndex) + + RETURN (IF(IS_NOT_ARRAY(aArray) .OR. LEN(aArray) == 0, ; + 0, ; + FT_ASUM(aArray, nStartIndex, nEndIndex) / ; + (nEndIndex - nStartIndex + 1))) diff --git a/harbour/contrib/libnf/acctadj.prg b/harbour/contrib/libnf/acctadj.prg new file mode 100644 index 0000000000..6f97b5f3a7 --- /dev/null +++ b/harbour/contrib/libnf/acctadj.prg @@ -0,0 +1,106 @@ +/* + * File......: ACCTADJ.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.4 28 Sep 1992 00:22:38 GLENN + * Jo French clean up. + * + * Rev 1.3 15 Aug 1991 23:04:58 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.2 14 Jun 1991 19:50:40 GLENN + * Minor edit to file header + * + * Rev 1.1 11 May 1991 00:34:00 GLENN + * Documentation rewrite. Enter DOC header was rewritten and resubmitted + * by the author. No code changes. + * + * Rev 1.0 01 Apr 1991 01:00:22 GLENN + * Nanforum Toolkit + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_ACCTADJ() + * $CATEGORY$ + * Date/Time + * $ONELINER$ + * Adjust beginning or ending fiscal pd. dates to acctg. dates + * $SYNTAX$ + * FT_ACCTADJ( [ ], [ ] ) -> dDate + * $ARGUMENTS$ + * is any valid date in any valid format. + * Defaults to DATE() if not supplied. + * + * is a logical variable. .F. = adjust for beginning of + * period mode, .T. = adjust for end of period mode. Defaults to + * beginning of period mode. + * $RETURNS$ + * An adjusted date dependent upon mode and work week start day. + * $DESCRIPTION$ + * Called by other FT_ACCT.. functions. The algorithm is: + * + * Beginning of period mode: + * + * If dGivenDate is in last 3 days of work week + * Return next week's start date + * Else + * Return this week's start date + * Endif + * + * End of period mode: + * + * If dGivenDate is in last 4 days of work week + * Return this week's end date + * Else + * Return prior week's end date + * Endif + * $EXAMPLES$ + * Beginning of period mode (lIsEnd == .F.) + * + * dDate := Ctod( "01/31/91" ) // In last 3 days of work week + * ? FT_ACCTADJ( dDate ) // 02/03/91 (next week's start) + * + * dDate := Ctod( "03/31/91" ) // Not in last 3 days of work week + * ? FT_ACCTADJ( dDate ) // 03/31/91 (this week's start) + * + * End of period mode (lIsEnd == .T.) + * + * dDate := Ctod( "01/31/91" ) // In last 4 days of work week + * ? FT_ACCTADJ( dDate, .T. ) // 02/02/91 (this week's end) + * + * dDate := Ctod( "03/31/91" ) // Not in last 4 days of work week + * ? FT_ACCTADJ( dDate, .T. ) // 03/30/91 (prior week's end) + * $SEEALSO$ + * FT_DATECNFG() FT_DAYTOBOW() + * $END$ +*/ + +FUNCTION FT_ACCTADJ(dGivenDate, lIsEnd) + + LOCAL nTemp + + IF( VALTYPE(dGivenDate) != 'D', dGivenDate := DATE(), ) + lIsEnd := ( VALTYPE(lIsEnd) == 'L' ) + nTemp := FT_DAYTOBOW(dGivenDate) + + IF nTemp > ( 2 + IF(!lIsEnd, 1, 0) ) + dGivenDate += ( 7 - nTemp ) // Next Week Start (This Week End + 1) + ELSE + dGivenDate -= nTemp // This Week Start (Prior Week End + 1) + ENDIF + + IF( lIsEnd, dGivenDate -= 1, ) + +RETURN dGivenDate + + diff --git a/harbour/contrib/libnf/acctmnth.prg b/harbour/contrib/libnf/acctmnth.prg new file mode 100644 index 0000000000..b44d3c9765 --- /dev/null +++ b/harbour/contrib/libnf/acctmnth.prg @@ -0,0 +1,135 @@ +/* + * File......: ACCTMNTH.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:24:54 GLENN + * Jo French clean up. + * + * Rev 1.2 15 Aug 1991 23:02:30 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:50:42 GLENN + * Minor edit to file header + * + * Rev 1.0 01 Apr 1991 01:00:24 GLENN + * Nanforum Toolkit + * + */ + +/* $DOC$ + * $FUNCNAME$ + * FT_ACCTMONTH() + * $CATEGORY$ + * Date/Time + * $ONELINER$ + * Return accounting month data + * $SYNTAX$ + * FT_ACCTMONTH( [ ], [ ] ) -> aDateInfo + * $ARGUMENTS$ + * is any valid date in any date format. Defaults + * to current system date if not supplied. + * + * is a number from 1 to 12 signifying a month. + * Defaults to current month if not supplied. + * $RETURNS$ + * A three element array containing the following data: + * + * aDateInfo[1] - The year and month as a character string "YYYYMM" + * aDateInfo[2] - The beginning date of the accounting month + * aDateInfo[3] - The ending date of the accounting month + * $DESCRIPTION$ + * FT_ACCTMONTH() creates an array containing data about the + * accounting month containing the given date. + * + * 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. + * $EXAMPLES$ + * // get info about accounting month containing 9/15/90 + * aDateInfo := FT_ACCTMONTH( Ctod("09/15/90") ) + * ? aDateInfo[1] // 199009 (9th month) + * ? aDateInfo[2] // 09/02/90 beginning of month 9 + * ? aDateInfo[3] // 09/29/90 end of month 9 + * + * // get info about accounting month 5 in year containing 9/15/90 + * aDateInfo := FT_ACCTMONTH( Ctod("09/15/90"), 5 ) + * ? aDateInfo[1] // 199005 + * ? aDateInfo[2] // 04/29/89 beginning of month 5 + * ? aDateInfo[3] // 06/02/90 end of month 5 + * $SEEALSO$ + * FT_DATECNFG() FT_ACCTWEEK() FT_ACCTQTR() FT_ACCTYEAR() + * $END$ +*/ + +FUNCTION FT_ACCTMONTH(dGivenDate,nMonthNum) + LOCAL nYTemp, nMTemp, lIsMonth, aRetVal + + IF ! ( VALTYPE(dGivenDate) $ 'ND' ) + dGivenDate := DATE() + ELSEIF VALTYPE(dGivenDate) == 'N' + nMonthNum := dGivenDate + dGivenDate := DATE() + ENDIF + + aRetVal := FT_MONTH(dGivenDate) + nYTemp := VAL(SUBSTR(aRetVal[1],1,4)) + nMTemp := VAL(SUBSTR(aRetVal[1],5,2)) + aRetVal[2] := FT_ACCTADJ(aRetVal[2]) + aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. ) + + IF dGivenDate < aRetVal[2] + dGivenDate := FT_MADD(dGivenDate, -1) + aRetVal := FT_MONTH(dGivenDate) + nMTemp -= 1 + IF nMTemp == 0 + nYTemp -= 1 + nMTemp := 12 + ENDIF + aRetVal[2] := FT_ACCTADJ(aRetVal[2]) + aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. ) + + ELSEIF dGivenDate > aRetVal[3] + + dGivenDate := FT_MADD(dGivenDate, 1) + aRetVal := FT_MONTH(dGivenDate) + nMTemp += 1 + IF nMTemp == 13 + nYTemp += 1 + nMTemp := 1 + ENDIF + aRetVal[2] := FT_ACCTADJ(aRetVal[2]) + aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. ) + + ENDIF + + lIsMonth := ( VALTYPE(nMonthNum) == 'N' ) + IF lIsMonth + IF( nMonthNum < 1 .OR. nMonthNum > 12 , nMonthNum := 12, ) + aRetVal := FT_MONTH(dGivenDate, nMonthNum) + nYTemp := VAL(SUBSTR(aRetVal[1],1,4)) + nMTemp := VAL(SUBSTR(aRetVal[1],5,2)) + aRetVal[2] := FT_ACCTADJ(aRetVal[2]) + aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. ) + ENDIF + + aRetVal[1] := STR(nYTemp,4) + PADL(LTRIM(STR(nMTemp,2)), 2, '0') + +RETURN aRetVal + + diff --git a/harbour/contrib/libnf/acctqtr.prg b/harbour/contrib/libnf/acctqtr.prg new file mode 100644 index 0000000000..636f852f57 --- /dev/null +++ b/harbour/contrib/libnf/acctqtr.prg @@ -0,0 +1,134 @@ +/* + * File......: ACCTQTR.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:26:30 GLENN + * Jo French clean up. + * + * Rev 1.2 15 Aug 1991 23:02:36 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:50:44 GLENN + * Minor edit to file header + * + * Rev 1.0 01 Apr 1991 01:00:26 GLENN + * Nanforum Toolkit + * + */ + +/* $DOC$ + * $FUNCNAME$ + * FT_ACCTQTR() + * $CATEGORY$ + * Date/Time + * $ONELINER$ + * Return accounting quarter data + * $SYNTAX$ + * FT_ACCTQTR( [ ], [ ] ) -> aDateinfo + * $ARGUMENTS$ + * is any valid date in any date format. Defaults + * to current system date if not supplied. + * + * is a number from 1 to 4 signifying a quarter. + * Defaults to current quarter if not supplied. + * $RETURNS$ + * A three element array containing the following data: + * + * aDateInfo[1] - The year and qtr. as a character string "YYYYQQ" + * aDateInfo[2] - The beginning date of the accounting quarter + * aDateInfo[3] - The ending date of the accounting quarter + * $DESCRIPTION$ + * FT_ACCTQTR() creates an array containing data about the + * accounting quarter containing the given date. + * + * 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. + * $EXAMPLES$ + * // get info about accounting month containing 9/15/90 + * aDateInfo := FT_ACCTQTR( CTOD("09/15/90") ) + * ? aDateInfo[1] // 199003 (3rd quarter) + * ? aDateInfo[2] // 07/01/90 beginning of quarter 3 + * ? aDateInfo[3] // 09/29/90 end of quarter 3 + * + * // get info about accounting qtr. 2 in year containing 9/15/90 + * aDateInfo := FT_ACCTQTR( CTOD("09/15/90"), 2 ) + * ? aDateInfo[1] // 199002 + * ? aDateInfo[2] // 04/01/89 beginning of quarter 2 + * ? aDateInfo[3] // 06/30/90 end of quarter 2 + * $SEEALSO$ + * FT_DATECNFG() FT_ACCTWEEK() FT_ACCTMONTH() FT_ACCTYEAR() + * $END$ +*/ + +FUNCTION FT_ACCTQTR(dGivenDate,nQtrNum) + LOCAL nYTemp, nQTemp, lIsQtr, aRetVal + + IF ! ( VALTYPE(dGivenDate) $ 'ND' ) + dGivenDate := DATE() + ELSEIF VALTYPE(dGivenDate) == 'N' + nQtrNum := dGivenDate + dGivenDate := DATE() + ENDIF + aRetVal := FT_QTR(dGivenDate) + nYTemp := VAL(SUBSTR(aRetVal[1],1,4)) + nQTemp := VAL(SUBSTR(aRetVal[1],5,2)) + aRetVal[2] := FT_ACCTADJ(aRetVal[2]) + aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. ) + + IF dGivenDate < aRetVal[2] + dGivenDate := FT_MADD(dGivenDate, -1) + aRetVal := FT_QTR(dGivenDate) + nQTemp -= 1 + IF nQTemp == 0 + nYTemp -= 1 + nQTemp := 4 + ENDIF + aRetVal[2] := FT_ACCTADJ(aRetVal[2]) + aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. ) + + ELSEIF dGivenDate > aRetVal[3] + + dGivenDate := FT_MADD(dGivenDate,1) + aRetVal := FT_QTR(dGivenDate) + nQTemp += 1 + IF nQTemp == 5 + nYTemp += 1 + nQTemp := 1 + ENDIF + aRetVal[2] := FT_ACCTADJ(aRetVal[2]) + aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. ) + + ENDIF + + lIsQtr := ( VALTYPE(nQtrNum) == 'N' ) + IF lIsQtr + IF( nQtrNum < 1 .OR. nQtrNum > 4 , nQtrNum := 4, ) + aRetVal := FT_QTR(dGivenDate, nQtrNum) + nYTemp := VAL(SUBSTR(aRetVal[1],1,4)) + nQTemp := VAL(SUBSTR(aRetVal[1],5,2)) + aRetVal[2] := FT_ACCTADJ(aRetVal[2]) + aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. ) + ENDIF + + aRetVal[1] := STR(nYTemp,4) + PADL(LTRIM(STR(nQTemp,2)), 2, '0') + +RETURN aRetVal + + diff --git a/harbour/contrib/libnf/acctweek.prg b/harbour/contrib/libnf/acctweek.prg new file mode 100644 index 0000000000..427a0f2851 --- /dev/null +++ b/harbour/contrib/libnf/acctweek.prg @@ -0,0 +1,107 @@ +/* + * File......: ACCTWEEK.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:27:50 GLENN + * Jo French clean up. + * + * Rev 1.2 15 Aug 1991 23:02:38 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:50:46 GLENN + * Minor edit to file header + * + * Rev 1.0 01 Apr 1991 01:00:28 GLENN + * Nanforum Toolkit + * + */ + +/* $DOC$ + * $FUNCNAME$ + * FT_ACCTWEEK() + * $CATEGORY$ + * Date/Time + * $ONELINER$ + * Return accounting week data + * $SYNTAX$ + * FT_ACCTWEEK( [ ], [ ] ) -> aDateInfo + * $ARGUMENTS$ + * is any valid date in any date format. Defaults + * to current system date if not supplied. + * + * is a number from 1 to 52 signifying a week. + * Defaults to current week if not supplied. + * $RETURNS$ + * A three element array containing the following data: + * + * aDateInfo[1] - The year and week as a character string "YYYYWW" + * aDateInfo[2] - The beginning date of the accounting week + * aDateInfo[3] - The ending date of the accounting week + * $DESCRIPTION$ + * FT_ACCTWEEK() returns an array containing data about the + * accounting week containing the given date. + * + * 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. + * $EXAMPLES$ + * // get info about accounting week containing 9/15/90 + * aDateInfo := FT_ACCTWEEK( CTOD("09/15/90") ) + * ? aDateInfo[1] // 199037 (37th week) + * ? aDateInfo[2] // 09/09/90 beginning of week 37 + * ? aDateInfo[3] // 09/15/90 end of week 37 + * + * // get info about accounting week 25 in year containing 9/15/90 + * aDateInfo := FT_ACCTWEEK( CTOD("09/15/90"), 25 ) + * ? aDateInfo[1] // 199025 + * ? aDateInfo[2] // 06/17/89 beginning of week 25 + * ? aDateInfo[3] // 06/23/90 end of week 25 + * $SEEALSO$ + * FT_DATECNFG() FT_ACCTMONTH() FT_ACCTQTR() FT_ACCTYEAR() + * $END$ +*/ + +FUNCTION FT_ACCTWEEK(dGivenDate,nWeekNum) + + LOCAL nTemp, lIsWeek, aRetVal + + IF ! VALTYPE(dGivenDate) $ 'ND' + dGivenDate := DATE() + ELSEIF VALTYPE(dGivenDate) == 'N' + nWeekNum := dGivenDate + dGivenDate := DATE() + ENDIF + + aRetVal := FT_ACCTYEAR(dGivenDate) + + lIsWeek := ( VALTYPE(nWeekNum) == 'N' ) + IF lIsWeek + nTemp := INT( (aRetVal[3] - aRetVal[2]) / 7 ) + 1 + IF( nWeekNum < 1 .OR. nWeekNum > nTemp, nWeekNum := nTemp, ) + dGivenDate := aRetVal[2] + (nWeekNum - 1) * 7 + ENDIF + + aRetVal[1] += PADL(LTRIM(STR(INT( (dGivenDate - ; + aRetVal[2]) / 7 ) + 1, 2)), 2, '0') + dGivenDate += ( 6 - FT_DAYTOBOW(dGivenDate) ) // end of week + aRetVal[2] := dGivenDate - 6 + aRetVal[3] := dGivenDate + +RETURN aRetVal + diff --git a/harbour/contrib/libnf/acctyear.prg b/harbour/contrib/libnf/acctyear.prg new file mode 100644 index 0000000000..90af4ccb7e --- /dev/null +++ b/harbour/contrib/libnf/acctyear.prg @@ -0,0 +1,98 @@ +/* + * File......: ACCTYEAR.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:29:14 GLENN + * Jo French clean up. + * + * Rev 1.2 15 Aug 1991 23:02:40 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:50:48 GLENN + * Minor edit to file header + * + * Rev 1.0 01 Apr 1991 01:00:28 GLENN + * Nanforum Toolkit + * + */ + +/* $DOC$ + * $FUNCNAME$ + * FT_ACCTYEAR() + * $CATEGORY$ + * Date/Time + * $ONELINER$ + * Return accounting year data + * $SYNTAX$ + * FT_ACCTYEAR( [ ] ) -> aDateInfo + * $ARGUMENTS$ + * is any valid date in any date format. Defaults + * to current system date if not supplied. + * $RETURNS$ + * A three element array containing the following data: + * + * aDateInfo[1] - The year as a character string "YYYY" + * aDateInfo[2] - The beginning date of the accounting year + * aDateInfo[3] - The ending date of the accounting year + * $DESCRIPTION$ + * FT_ACCTYEAR() creates an array containing data about the + * accounting year containing the given date. + * + * 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. + * $EXAMPLES$ + * // get info about accounting year containing 9/15/90 + * aDateInfo := FT_ACCTYEAR( CTOD("09/15/90") ) + * ? aDateInfo[1] // 1990 + * ? aDateInfo[2] // 12/31/89 beginning of year + * ? aDateInfo[3] // 12/29/90 end of year + * $SEEALSO$ + * FT_DATECNFG() FT_ACCTWEEK() FT_ACCTMONTH() FT_ACCTQTR() + * $END$ +*/ + +FUNCTION FT_ACCTYEAR(dGivenDate) + + LOCAL nYTemp, aRetVal + + IF( VALTYPE(dGivenDate) != 'D', dGivenDate := DATE(), ) + + aRetVal := FT_YEAR(dGivenDate) + nYTemp := VAL(aRetVal[1]) + aRetVal[2] := FT_ACCTADJ(aRetVal[2]) + aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. ) + + IF dGivenDate < aRetVal[2] + aRetVal := FT_YEAR(FT_MADD(dGivenDate, -1)) + nYTemp -- + aRetVal[2] := FT_ACCTADJ(aRetVal[2]) + aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. ) + ELSEIF dGivenDate > aRetVal[3] + aRetVal := FT_YEAR(FT_MADD(dGivenDate, 1)) + nYTemp ++ + aRetVal[2] := FT_ACCTADJ(aRetVal[2]) + aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. ) + ENDIF + + aRetVal[1] := STR(nYTemp,4) + +RETURN aRetVal + + diff --git a/harbour/contrib/libnf/adessort.prg b/harbour/contrib/libnf/adessort.prg new file mode 100644 index 0000000000..b0ae8a8259 --- /dev/null +++ b/harbour/contrib/libnf/adessort.prg @@ -0,0 +1,81 @@ +/* + * File......: ADesSort.Prg + * Author....: David Husnian + * CIS ID....: ? + * + * This is an original work by David Husnian and is placed in the + * public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.2 15 Aug 1991 23:02:42 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:50:50 GLENN + * Minor edit to file header + * + * Rev 1.0 01 Apr 1991 01:00:30 GLENN + * Nanforum Toolkit + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_ADESSORT() + * $CATEGORY$ + * Array + * $ONELINER$ + * Sort an array in descending order + * $SYNTAX$ + * FT_ADESSORT( [, [, ] ] ) -> aSorted + * $ARGUMENTS$ + * is the array to be sorted + * + * is the first array item to include in the sort, + * defaults to first element + * + * is the last array element to include in the sort, + * defaults to all elements + * $RETURNS$ + * The array, sorted in descending order. + * $DESCRIPTION$ + * This function is used to sort an array in descending order, i.e., Z-A + * $EXAMPLES$ + * FT_ADESSORT(aNames) // Sort the Entire Array + * + * FT_ADESSORT(aNames, 5) // Sort from the 5th Element On + * + * FT_ADESSORT(aNames, , 10) // Sort the 1st 10 Elements + * + * FT_ADESSORT(aNames, 5, 10) // Sort Elements 5-10 + * $END$ + */ + + +#command DEFAULT TO [, TO ] ; + => ; + := IF( == NIL,,) ; + [; := IF( == NIL,,)] + +#command DEFAULT TO IF NOT ; + [, TO IF NOT ] ; + => ; + := IF(VALTYPE() == ,,) ; + [; := IF(VALTYPE() == ,,)] + + +#define FORCE_BETWEEN(x,y,z) (y := MAX(MIN(y,z),x)) + +FUNCTION FT_ADESSORT(aArray, nStartIndex, nEndIndex) + + DEFAULT nStartIndex TO 1, ; + nEndIndex TO LEN(aArray) + + // Make Sure Bounds are in Range + FORCE_BETWEEN(1, nEndIndex, LEN(aArray)) + FORCE_BETWEEN(1, nStartIndex, nEndIndex) + + RETURN (ASORT(aArray, nStartIndex, nEndIndex, ; + { | xElement1, xElement2 | xElement1 > xElement2 } )) diff --git a/harbour/contrib/libnf/aemaxlen.prg b/harbour/contrib/libnf/aemaxlen.prg new file mode 100644 index 0000000000..901d759482 --- /dev/null +++ b/harbour/contrib/libnf/aemaxlen.prg @@ -0,0 +1,133 @@ +/* + * File......: AEmaxlen.prg + * Author....: Ralph Oliver, TRANSCOM SYSTEMS + * CIS ID....: 74030,703 + * + * This is an original work by Ralph Oliver and is placed in the + * public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.1 15 Aug 1991 23:05:38 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.0 07 Jun 1991 23:03:12 GLENN + * Initial revision. + * + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_AEMAXLEN() + * $CATEGORY$ + * Array + * $ONELINER$ + * Find longest element within an array + * $SYNTAX$ + * FT_AEMAXLEN( [, [, [, ] ] ] ) ; + * -> nMaxlen + * $ARGUMENTS$ + * is the array containing the elements to be measured. + * + * is the array dimension to be measured, + * defaults to first dimension. + * + * is the starting array element to include, + * defaults to first array element. + * + * is the number of array elements to process from + * from , defaults to remaining elements + * in array. + * $RETURNS$ + * The length of the longest size element of an array. + * $DESCRIPTION$ + * This function will measure each element of an array + * dimension and return the longest element. + * $EXAMPLES$ + * FT_AEMAXLEN(aArray) // Measure the 1st dimension of an Array + * + * FT_AEMAXLEN(aArray,2) // Measure the 2nd dimension of an Array + * + * FT_AEMAXLEN(aArray,2,,9) // Measure Elements 1-9 of the + * 2nd dimension or subarray + * + * FT_AEMAXLEN(aArray,3,5,9) // Measure Elements 5-9 of the + * 3rd dimension or subarray + * + * FT_AEMAXLEN(aArray,3,5) // Measure Elements 5 to last in the + * 3rd dimension or subarray + * $SEEALSO$ + * FT_AEMINLEN() + * $END$ + */ + +#ifdef FT_TEST + +FUNCTION MAIN() + LOCAL var0, myarray1 := DIRECTORY() + CLS + ? "TEST TO DEMONSTRATE EXAMPLES OF FT_AEMAXLEN" + ? + ? "myarray1 = DIRECTORY()" + ? + var0 := FT_AEMAXLEN( myarray1 ) + ? PADR('FT_AEMAXLEN( myarray1 ) ->',30) + ?? var0 + ? + var0 := FT_AEMAXLEN( myarray1,2 ) + ? PADR('FT_AEMAXLEN( myarray1,2 ) ->',30) + ?? var0 + ? + var0 := FT_AEMAXLEN( myarray1,3 ) + ? PADR('FT_AEMAXLEN( myarray1,3 ) ->',30) + ?? var0 + ? + var0 := FT_AEMAXLEN( aTail( myarray1 ) ) + ? PADR('FT_AEMAXLEN( aTail( myarray1 ) ) ->',30) + ?? var0 + ? + RETURN NIL + +#endif + + +FUNCTION FT_AEmaxlen( aArray, nDimension, nStart, nCount ) + + LOCAL i, nLast, cType, nMaxlen := 0 + + // Set default parameters as necessary. + IF nDimension == NIL + nDimension := 1 + ENDIF + + IF nStart == NIL + nStart := 1 + ENDIF + + IF nCount == NIL + nCount := LEN( aArray ) - nStart + 1 + ENDIF + + nLast := MIN( nStart +nCount -1, LEN( aArray )) + + FOR i := nStart TO nLast + cType := VALTYPE( aArray[i] ) + DO CASE + CASE ( cType == "C" ) + nMaxlen := MAX( nMaxlen, LEN( aArray[i] )) + + CASE ( cType == "A" ) + nMaxlen := MAX( nMaxlen, ; + LEN( LTRIM( TRANSFORM( aArray[i] [nDimension], "@X")))) + + OTHERWISE + nMaxlen := MAX( nMaxlen, ; + LEN( LTRIM( TRANSFORM( aArray[i], "@X" )))) + ENDCASE + NEXT + + RETURN ( nMaxlen ) + diff --git a/harbour/contrib/libnf/aeminlen.prg b/harbour/contrib/libnf/aeminlen.prg new file mode 100644 index 0000000000..5584ef52a6 --- /dev/null +++ b/harbour/contrib/libnf/aeminlen.prg @@ -0,0 +1,134 @@ +/* + * File......: AEminlen.prg + * Author....: Ralph Oliver, TRANSCOM SYSTEMS + * CIS ID....: 74030,703 + * + * This is an original work by Ralph Oliver and is placed in the + * public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.1 15 Aug 1991 23:02:28 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.0 07 Jun 1991 23:03:16 GLENN + * Initial revision. + * + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_AEMINLEN() + * $CATEGORY$ + * Array + * $ONELINER$ + * Find shortest element within an array + * $SYNTAX$ + * FT_AEMINLEN( [, [, [, ] ] ] ) + * -> nMinlen + * $ARGUMENTS$ + * is the array containing the elements to be measured. + * + * is the array dimension to be measured, + * defaults to first dimension. + * + * is the starting array element to include, + * defaults to first array element. + * + * is the number of array elements to process from + * from , defaults to remaining elements + * in array. + * $RETURNS$ + * The length of the shortest size element of an array. + * $DESCRIPTION$ + * This function will measure each element of an array + * dimension and return the shortest element. + * $EXAMPLES$ + * FT_AEMINLEN(aArray) // Measure the 1st dimension of an Array + * + * FT_AEMINLEN(aArray,2) // Measure the 2nd dimension of an Array + * + * FT_AEMINLEN(aArray,2,,9) // Measure Elements 1-9 of 2nd dimension + * + * FT_AEMINLEN(aArray,3,5,9) // Measure Elements 5-9 of 3rd dimension + * + * FT_AEMINLEN(aArray,3,5) // Measure Elements 5 to end of 3rd dimension + * $SEEALSO$ + * FT_AEMAXLEN() + * $END$ + */ + +#ifdef FT_TEST + +FUNCTION MAIN() + LOCAL var0, myarray1 := DIRECTORY() + CLS + ? "TEST TO DEMONSTRATE EXAMPLES OF FT_AEMINLEN" + ? + ? "myarray1 = DIRECTORY()" + ? + aEval( myarray1, {|v| qout( padr(v[1],12), v[2], v[3], v[4], v[5] ) } ) + var0 := FT_AEMINLEN( myarray1 ) + ? PADR('FT_AEMINLEN( myarray1 ) ->',30) + ?? var0 + ? + var0 := FT_AEMINLEN( myarray1,2 ) + ? PADR('FT_AEMINLEN( myarray1,2 ) ->',30) + ?? var0 + ? + ? + var0 := FT_AEMINLEN( myarray1[2] ) + ? PADR('FT_AEMINLEN( myarray1[2] ) ->',30) + ?? var0 + ? + ? + var0 := FT_AEMINLEN( myarray1,3 ) + ? PADR('FT_AEMINLEN( myarray1,3 ) ->',30) + ?? var0 + ? + RETURN NIL + +#endif + + +FUNCTION FT_AEminlen( aArray, nDimension, nStart, nCount ) + + LOCAL i, nLast, cType, nMinlen := 65519 + + // Set default parameters as necessary. + IF nDimension == NIL + nDimension := 1 + ENDIF + + IF nStart == NIL + nStart := 1 + ENDIF + + IF nCount == NIL + nCount := LEN( aArray ) - nStart + 1 + ENDIF + + nLast := MIN( nStart +nCount -1, LEN( aArray )) + + FOR i := nStart TO nLast + cType := VALTYPE( aArray[i] ) + DO CASE + CASE ( cType == "C" ) + nMinlen := MIN( nMinlen, LEN( aArray[i] )) + + CASE ( cType == "A" ) + nMinlen := MIN( nMinlen, ; + LEN( LTRIM( TRANSFORM( aArray[i] [nDimension], "@X" )))) + + OTHERWISE + nMinlen := MIN( nMinlen, ; + LEN( LTRIM( TRANSFORM( aArray[i], "@X" )))) + + ENDCASE + NEXT + + RETURN ( nMinlen ) + diff --git a/harbour/contrib/libnf/alt.c b/harbour/contrib/libnf/alt.c new file mode 100644 index 0000000000..5513c595c0 --- /dev/null +++ b/harbour/contrib/libnf/alt.c @@ -0,0 +1,76 @@ +/* + * $Id$ + */ + +/* + * File......: ALT.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.5 16 Apr 2000 17:30:00 Luiz Rafael Culik + * Ported to Harbour + * + * Rev 1.4 15 Jul 1993 23:48:00 GLENN + * Dropped _MK_FP for preferred 0x00400017 + * + * Rev 1.3 13 Jul 1993 22:28:58 GLENN + * Added call to _MK_FP in order to be compatible in protected mode. + * + * Rev 1.2 15 Aug 1991 23:08:34 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:53:36 GLENN + * Minor edit to file header + * + * Rev 1.0 01 Apr 1991 01:02:42 GLENN + * Nanforum Toolkit + * + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_ALT() + * $CATEGORY$ + * Keyboard/Mouse + * $ONELINER$ + * Determine status of the Alt key + * $SYNTAX$ + * FT_ALT() -> lValue + * $ARGUMENTS$ + * None + * $RETURNS$ + * .T. if Alt key is pressed, .F. if otherwise. + * $DESCRIPTION$ + * This function is useful for times you need to know whether or not the + * Alt key is pressed, such as during a MemoEdit(). + * $EXAMPLES$ + * IF FT_ALT() + * @24, 0 say "Alt" + * ELSE + * @24, 0 say " " + * ENDIF + * $SEEALSO$ + * FT_CAPLOCK() FT_CTRL() FT_NUMLOCK() FT_PRTSCR() FT_SHIFT() + * $END$ + */ + +#include + +HB_FUNC(FT_ALT) +{ +#if defined(HB_OS_DOS) + { + hb_retl( ( int ) ( ( *( char * ) 0x00400017 ) & 0x8 ) ); + + return; + } +#endif +} diff --git a/harbour/contrib/libnf/amedian.prg b/harbour/contrib/libnf/amedian.prg new file mode 100644 index 0000000000..a306dced5a --- /dev/null +++ b/harbour/contrib/libnf/amedian.prg @@ -0,0 +1,132 @@ +/* + * File......: AMedian.Prg + * Author....: Ralph Oliver, TRANSCOM SYSTEMS + * CIS ID....: 74030,703 + * + * This is an original work by Ralph Oliver and is placed in the + * public domain. + * + * This program uses the preprocessor #defines and #command in + * Aavg.prg by David Husnian. + * + * Modification history: + * --------------------- + * + * Rev 1.1 15 Aug 1991 23:05:22 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.0 07 Jun 1991 23:03:20 GLENN + * Initial revision. + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_AMEDIAN() + * $CATEGORY$ + * Array + * $ONELINER$ + * Find middle value in array, or average of two middle values + * $SYNTAX$ + * FT_AMEDIAN( [, [, ] ] ) + * -> nMedian + * $ARGUMENTS$ + * is the array containing the elements to be averaged. + * + * is the first array element to include, + * defaults to first element. + * + * is the last array element to include, + * defaults to last element. + * $RETURNS$ + * The median average of the array elements + * $DESCRIPTION$ + * This function sorts the elements of a numeric array and + * then returns the value in the middle element of the sorted + * array. If there is no exact middle value, then it returns + * the average of the two middle values. Half of the elements + * are > median and half are < median. A median average may + * more reflect a more useful average when there are extreme + * values in the set. + * $EXAMPLES$ + * FT_AMEDIAN( aArray ) // Return Median for entire array + * + * FT_AMEDIAN( aArray, 2) // Return Median for elements from 2 to end + * + * FT_AMEDIAN( aArray, ,9) // Return Median for 1st 9 elements + * + * FT_AMEDIAN( aArray,8,40 ) // Return Median for elements 8 to 40 + * $END$ + */ + +#ifdef FT_TEST + +#include "directry.ch" + +FUNCTION MAIN() + LOCAL var0, myarray0 := DIRECTORY(), myarray1 := {} + CLS + ? "TEST TO DEMONSTRATE EXAMPLES OF FT_AMEDIAN" + ? + AEVAL( myarray0, { |x| AADD( myarray1, x[ F_SIZE ]) } ) + var0 := FT_AMEDIAN( myarray1 ) + ? PADR('FT_AMEDIAN( myarray1 ) ->',35) + ?? var0 + ? + var0 := FT_AMEDIAN( myarray1, 2 ) + ? PADR('FT_AMEDIAN( myarray1, 2 ) ->',35) + ?? var0 + ? + var0 := FT_AMEDIAN( myarray1, , 9 ) + ? PADR('FT_AMEDIAN( myarray1, , 9 ) ->',35) + ?? var0 + ? + var0 := FT_AMEDIAN( myarray1, 8, 40 ) + ? PADR('FT_AMEDIAN( myarray1, 8, 40 ) ->',35) + ?? var0 + ? + RETURN NIL + +#endif + + +#define FORCE_BETWEEN(x,y,z) (y := MAX(MIN(y,z),x)) + +#command DEFAULT TO [, TO ] ; + => ; + := IF( == NIL,,) ; + [; := IF( == NIL,,)] + + +FUNCTION FT_AMEDIAN( aArray, nStart, nEnd ) + + LOCAL nTemplen, aTemparray, nMiddle1, nMiddle2, nMedian + + DEFAULT nStart TO 1, ; + nEnd TO LEN( aArray ) + + // Make Sure Bounds are in Range + FORCE_BETWEEN(1, nEnd, LEN( aArray )) + FORCE_BETWEEN(1, nStart, nEnd) + + // Length of aTemparray + nTemplen := ( nEnd - nStart ) + 1 + + // Initialize aTemparray + aTemparray := ACOPY( aArray, ARRAY( nTemplen ), nStart, nTemplen ) + + // Sort aTemparray + aTemparray := ASORT( aTemparray ) + + // Determine middle value(s) + IF ( nTemplen % 2 ) == 0 + nMiddle1 := aTemparray[ (nTemplen / 2) ] + nMiddle2 := aTemparray[ INT(nTemplen / 2) +1 ] + nMedian := INT( ( nMIddle1 + nMiddle2 ) / 2 ) + ELSE + nMedian := aTemparray[ INT( nTemplen / 2 ) + 1 ] + ENDIF + + RETURN ( nMedian ) + diff --git a/harbour/contrib/libnf/anomatch.prg b/harbour/contrib/libnf/anomatch.prg new file mode 100644 index 0000000000..a1fe64a42a --- /dev/null +++ b/harbour/contrib/libnf/anomatch.prg @@ -0,0 +1,90 @@ +/* + * File......: ANoMatch.Prg + * Author....: David Husnian + * CIS ID....: ? + * + * This is an original work by David Husnian and is placed in the + * public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.2 15 Aug 1991 23:02:44 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:50:52 GLENN + * Minor edit to file header + * + * Rev 1.0 01 Apr 1991 01:00:32 GLENN + * Nanforum Toolkit + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_ANOMATCHES() + * $CATEGORY$ + * Array + * $ONELINER$ + * Find the number of array elements meeting a condition + * $SYNTAX$ + * FT_ANOMATCHES( , ; + * [, [, ] ] ) -> nNoOfMatches + * $ARGUMENTS$ + * is the array to be searched + * + * is a code block containing the expression for + * the array elements to be tested with. Each element is passed + * as a parameter to the block. If the block returns .T., the + * number of matches will be incremented by one. + * + * is the first array item to include in the search, + * defaults to first element. + * + * is the last array element to include in the search, + * defaults to all elements. + * $RETURNS$ + * The number of elements that cause the code block to return .T. + * $DESCRIPTION$ + * This function returns the number of array elements that, when passed + * to the supplied code block, cause that code block to return a .T. value. + * $EXAMPLES$ + * // Search the Entire Array + * FT_ANOMATCHES(aTries, { | x | x <= 100 } ) + * + * // Search from the 5th Element On + * FT_ANOMATCHES(aCodes, { | x | UPPER(x) == cCurrentCode }, 5) + * + * // Search the 1st 10 Elements + * FT_ANOMATCHES(aDates, { | x | IS_BETWEEN(DATE()-7,x,DATE() + 7) }, 10) + * + * // Search Elements 5-10 + * FT_ANOMATCHES(aNames, { | x | x <= cLastGoodName }, 5, 10) + * $END$ + */ + +#define FORCE_BETWEEN(x,y,z) (y := MAX(MIN(y,z),x)) + +#command DEFAULT TO [, TO ] ; + => ; + := IF( == NIL,,) ; + [; := IF( == NIL,,)] + +FUNCTION FT_ANOMATCHES(aArray, bCompareBlock, nStartIndex, nEndIndex) + + LOCAL nNoOfMatches := 0 // Number of Matches Found + + DEFAULT nStartIndex TO 1, ; + nEndIndex TO LEN(aArray) + + // Make Sure Bounds are in Range + FORCE_BETWEEN(1, nEndIndex, LEN(aArray)) + FORCE_BETWEEN(1, nStartIndex, nEndIndex) + + AEVAL(aArray, ; + { | xElement | ; + IIF(EVAL(bCompareBlock, xElement), nNoOfMatches++, NIL) }, ; + nStartIndex, nEndIndex - nStartIndex + 1) + + RETURN (nNoOfMatches) // FT_ANoMatches diff --git a/harbour/contrib/libnf/any2any.prg b/harbour/contrib/libnf/any2any.prg new file mode 100644 index 0000000000..c496ab895e --- /dev/null +++ b/harbour/contrib/libnf/any2any.prg @@ -0,0 +1,168 @@ +/* + * File......: Any2Any.Prg + * Author....: David Husnian + * CIS ID....: ? + * + * This is an original work by David Husnian and is placed in the + * public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.2 15 Aug 1991 23:02:46 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:50:54 GLENN + * Minor edit to file header + * + * Rev 1.0 01 Apr 1991 01:00:34 GLENN + * Nanforum Toolkit + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_XTOY() + * $CATEGORY$ + * Conversion + * $ONELINER$ + * Convert from any data type to any other data type + * $SYNTAX$ + * FT_XTOY( , ; + * [, ] ) -> xResult + * $ARGUMENTS$ + * is the value to convert. + * + * is the type of value to convert to + * ("C","D","L","N","A" or "B"). + * + * is a logical to signal if 'Y' or 'N' is to be returned + * if Converting a logical, otherwise '.T.' or '.F.' will be returned + * for logicals. + * $RETURNS$ + * The original value converted to the new type. + * $DESCRIPTION$ + * This function converts a value of character, date, numeric, logical, + * array or code block type to any of the other type. While it is + * guaranteed to return a value of the correct type, that value may not + * be meaningful (i.e., converting from a code block returns an EMPTY() + * value of the desired type). + * $EXAMPLES$ + * nNumericValue := FT_XTOY(cInputValue, "N") + * IF (FT_XTOY(nInputValue, "L")) + * $END$ + */ + + +#define BLOCKIFY(x) { || x } +#define IS_CHAR(x) (VALTYPE(x) == "C") +#define IS_DATE(x) (VALTYPE(x) == "D") +#define IS_LOGICAL(x) (VALTYPE(x) == "L") +#define IS_NUMERIC(x) (VALTYPE(x) == "N") +#define CASE_AT(x,y,z) z[AT(x,y)+1] +#define TRIM_NUMBER(x) LTRIM(STR(x)) +#define NULL "" +#define IS_NOT_CHAR(x) (VALTYPE(x) != "C") +#define IS_NOT_DATE(x) (VALTYPE(x) != "D") +#define EARLIEST_DATE CTOD("01/01/0100") +#define BLANK_DATE CTOD(NULL) +#define IS_NOT_ARRAY(x) (VALTYPE(x) != "A") +#define IS_NOT_LOGICAL(x) (VALTYPE(x) != "L") +#define IS_NOT_NUMERIC(x) (VALTYPE(x) != "N") +#define IS_NOT_CODE_BLOCK(x) (VALTYPE(x) != "B") +#define TRUE (.t.) +#define FALSE (.f.) + +#Define XTOC(x) CASE_AT(VALTYPE(x), "CNDLM", ; + { NULL, ; + x, ; + IF(IS_NUMERIC(x),; + TRIM_NUMBER(x), ; + NULL), ; + IF(IS_DATE(x),DTOC(x),NULL),; + IF(IS_LOGICAL(x),; + IF(x,".T.",".F."), ; + NULL), ; + x }) + +#command DEFAULT TO [, TO ] ; + => ; + := IF( == NIL,,) ; + [; := IF( == NIL,,)] + + +FUNCTION FT_XTOY(xValueToConvert, cTypeToConvertTo, lWantYesNo) + + DEFAULT lWantYesNo TO FALSE + + DO CASE + + CASE cTypeToConvertTo == "C" .AND.; // They Want a Character String + IS_NOT_CHAR(xValueToConvert) + + xValueToConvert := XTOC(xValueToConvert) + + CASE cTypeToConvertTo == "D" .AND.; // They Want a Date + IS_NOT_DATE(xValueToConvert) + + + xValueToConvert := IF(IS_CHAR(xValueToConvert), ; + ; // Convert from a Character + CTOD(xValueToConvert), ; + IF(IS_NUMERIC(xValueToConvert), ; + ; // Convert from a Number + xValueToConvert + EARLIEST_DATE, ; + IF(IS_LOGICAL(xValueToConvert), ; + ; // Convert from a Logical + IF(xValueToConvert, DATE(), BLANK_DATE), ; + ; // Unsupported Type + BLANK_DATE))) + + CASE cTypeToConvertTo == "N" .AND.; // They Want a Number + IS_NOT_NUMERIC(xValueToConvert) + + + xValueToConvert := IF(IS_CHAR(xValueToConvert), ; + ; // Convert from a Character + VAL(xValueToConvert), ; + IF(IS_DATE(xValueToConvert), ; + ; // Convert from a Date + xValueToConvert - EARLIEST_DATE, ; + IF(IS_LOGICAL(xValueToConvert), ; + ; // Convert from a Logical + IF(xValueToConvert, 1, 0), ; + ; // Unsupported Type + 0))) + + CASE cTypeToConvertTo == "L" .AND.; // They Want a Logical + IS_NOT_LOGICAL(xValueToConvert) + + + xValueToConvert := IF(IS_CHAR(xValueToConvert), ; + ; // Convert from a Character + UPPER(xValueToConvert) == IF(lWantYesNo,"Y",".T."), ; + IF(IS_DATE(xValueToConvert), ; + ; // Convert from a Date + ! EMPTY(xValueToConvert), ; + IF(IS_NUMERIC(xValueToConvert), ; + ; // Convert from a Number + xValueToConvert != 0, ; + ; // Unsupported Type + FALSE))) + + CASE cTypeToConvertTo == "A" .AND.; // They Want an Array + IS_NOT_ARRAY(xValueToConvert) + + + xValueToConvert := { xValueToConvert } + + CASE cTypeToConvertTo == "B" .AND.; // They Want a Code Block + IS_NOT_CODE_BLOCK(xValueToConvert) + + + xValueToConvert := BLOCKIFY(xValueToConvert) + + ENDCASE + + RETURN (xValueToConvert) // XToY diff --git a/harbour/contrib/libnf/aredit.prg b/harbour/contrib/libnf/aredit.prg new file mode 100644 index 0000000000..fea8fd9f53 --- /dev/null +++ b/harbour/contrib/libnf/aredit.prg @@ -0,0 +1,303 @@ +/* + * File......: ArEdit.prg + * Author....: James J. Orlowski, M.D. + * CIS ID....: 72707,601 + * + * + * Modification history: + * --------------------- + * + * Rev 1.2 15 Aug 1991 23:05:56 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 12 Jun 1991 00:42:38 GLENN + * A referee suggested changing the documentation such that the return value + * is shown as "xElement" rather than "cElement" because the function + * can return different types. + * + * Rev 1.0 07 Jun 1991 23:03:24 GLENN + * Initial revision. + * + * + */ + + + +/* + + Some notes: + + The tbmethods section is a short cut from Spence's book instead + of using the longer DO CASE method. + + Jim Gale showed me the basic array browser and Robert DiFalco + showed me the improved skipblock in public messages on Nanforum. + + I added the functionality of the "Edit Get" code block + (ie bGetFunc), TestGet() demo, and the add/delete rows. + +*/ + + +/* $DOC$ + * $FUNCNAME$ + * FT_AREDIT() + * $CATEGORY$ + * Array + * $ONELINER$ + * 2 dimensional array editing function using TBrowse + * $SYNTAX$ + * FT_AREDIT( , , , , , ; + * , , [, ] ) -> xElement + * $ARGUMENTS$ + * , , , are coordinates for TBrowse + * + * is name of 2 dimensional to array edit + * + * is pointer for element in array + * + * is array of column headings + * + * is array of blocks describing each array element + * + * [ ] is get editing function for handling individual elements + * $RETURNS$ + * Value of element positioned on when exit FT_AREDIT() + * The type of this value depends on what is displayed. + * $DESCRIPTION$ + * This function allows you to position yourself in an array, + * add and delete rows with the and keys, + * and pass a UDF with information to edit the individual gets. + * $EXAMPLES$ + * FT_AREDIT(3, 5, 18, 75, ar, @nElem, aHeadings, aBlocks) + * + * This example will allow you to browse a 2 dimensional array + * But you can't edit it since there is no GetBlock UDF + * It allows the user to hit ENTER to select an element or ESC to + * return 0 + * + * * This second example shows how to edit a 2 dimensional array + * * as might be done to edit an invoice + * + * LOCAL i, ar[3, 26], aBlocks[3], aHeadings[3] + * LOCAL nElem := 1, bGetFunc + * + * * Set up two dimensional array "ar" + * + * FOR i = 1 TO 26 + * ar[1, i] := i // 1 -> 26 Numeric + * ar[2, i] := CHR(i+64) // "A" -> "Z" Character + * ar[3, i] := CHR(91-i) // "Z" -> "A" Character + * NEXT i + * + * * SET UP aHeadings Array for column headings + * + * aHeadings := { "Numbers", "Letters", "Reverse" } + * + * * Need to set up individual array blocks for each TBrowse column + * + * aBlocks[1] := {|| STR(ar[1, nElem], 2) } // prevent default 10 spaces + * aBlocks[2] := {|| ar[2, nElem] } + * aBlocks[3] := {|| ar[3, nElem] } + * + * * set up TestGet() as the passed Get Function so FT_ArEdit knows how + * * to edit the individual gets. + * + * bGetFunc := { | b, ar, nDim, nElem | TestGet(b, ar, nDim, nElem) } + * SetColor( "N/W, W/N, , , W/N" ) + * CLEAR SCREEN + * FT_AREDIT(3, 5, 18, 75, ar, @nElem, aHeadings, aBlocks, bGetFunc) + * + * $END$ + */ + +#include "inkey.ch" + +* Default heading, column, footer separators +#define DEF_HSEP "мям" +#define DEF_CSEP " Ё " +#define DEF_FSEP "мом" + +* Default info for tb_methods section +#define KEY_ELEM 1 +#define BLK_ELEM 2 + +#ifdef FT_TEST + PROCEDURE Test + * Thanks to Jim Gale for helping me understand the basics + LOCAL i, ar[3, 26], aBlocks[3], aHeadings[3], nElem := 1, bGetFunc, cRet + * set up 2 dimensional array ar[] + FOR i = 1 TO 26 + ar[1, i] := i // 1 -> 26 Numeric + ar[2, i] := CHR(i+64) // "A" -> "Z" Character + ar[3, i] := CHR(91-i) // "Z" -> "A" Character + NEXT i + * Set Up aHeadings[] for column headings + aHeadings := { "Numbers", "Letters", "Reverse" } + * Set Up Blocks Describing Individual Elements in Array ar[] + aBlocks[1] := {|| STR(ar[1, nElem], 2)} // to prevent default 10 spaces + aBlocks[2] := {|| ar[2, nElem]} + aBlocks[3] := {|| ar[3, nElem]} + * Set up TestGet() as bGetFunc + bGetFunc := {|b, ar, nDim, nElem|TestGet(b, ar, nDim, nElem)} + + SET SCOREBOARD OFF + SetColor( "W/N") + CLEAR SCREEN + @ 21,4 SAY "Use Cursor Keys To Move Between Fields, = Delete Row, = Add Row" + @ 22,7 SAY " = Quit Array Edit, or Edits Element" + SetColor( "N/W, W/N, , , W/N" ) + cRet := FT_ArEdit(3, 5, 18, 75, ar, @nElem, aHeadings, aBlocks, bGetFunc) + SetColor( "W/N") + CLEAR SCREEN + ? cRet + ? "Lastkey() = ESC:", LASTKEY() == K_ESC + RETURN + + FUNCTION TestGet( b, ar, nDim, nElem) + LOCAL GetList := {} + LOCAL nRow := ROW() + LOCAL nCol := COL() + LOCAL cSaveScrn := SAVESCREEN(21, 0, 22, MaxCol()) + LOCAL cOldColor := SetColor( "W/N") + @ 21, 0 CLEAR TO 22, MaxCol() + @ 21,29 SAY "Editing Array Element" + SetColor(cOldColor) + DO CASE + CASE nDim == 1 + @ nRow, nCol GET ar[1, nElem] PICTURE "99" + READ + b:refreshAll() + CASE nDim == 2 + @ nRow, nCol GET ar[2, nElem] PICTURE "!" + READ + b:refreshAll() + CASE nDim == 3 + @ nRow, nCol GET ar[3, nElem] PICTURE "!" + READ + b:refreshAll() + ENDCASE + RESTSCREEN(21, 0, 22, MaxCol(), cSaveScrn) + @ nRow, nCol SAY "" + RETURN(.t.) +#endif + +FUNCTION FT_ArEdit( nTop, nLeft, nBot, nRight, ; + ar, nElem, aHeadings, aBlocks, bGetFunc) + * ANYTYPE[] ar - Array to browse + * NUMERIC nElem - Element In Array + * CHARACTER[] aHeadings - Array of Headings for each column + * BLOCK[] aBlocks - Array containing code block for each column. + * CODE BLOCK bGetFunc - Code Block For Special Get Processing + * NOTE: When evaluated a code block is passed the array element to + * be edited + + LOCAL exit_requested := .F., nKey, meth_no, ; + cSaveWin, i, b, column + LOCAL nDim, nWorkRow, cType, cVal + LOCAL tb_methods := ; + { ; + {K_DOWN, {|b| b:down()}}, ; + {K_UP, {|b| b:up()}}, ; + {K_PGDN, {|b| b:pagedown()}}, ; + {K_PGUP, {|b| b:pageup()}}, ; + {K_CTRL_PGUP, {|b| b:gotop()}}, ; + {K_CTRL_PGDN, {|b| b:gobottom()}}, ; + {K_RIGHT, {|b| b:right()}}, ; + {K_LEFT, {|b| b:left()}}, ; + {K_HOME, {|b| b:home()}}, ; + {K_END, {|b| b:end()}}, ; + {K_CTRL_LEFT, {|b| b:panleft()}}, ; + {K_CTRL_RIGHT, {|b| b:panright()}}, ; + {K_CTRL_HOME, {|b| b:panhome()}}, ; + {K_CTRL_END, {|b| b:panend()}} ; + } + + cSaveWin := SaveScreen(nTop, nLeft, nBot, nRight) + @ nTop, nLeft TO nBot, nRight + + b := TBrowseNew(nTop + 1, nLeft + 1, nBot - 1, nRight - 1) + b:headsep := DEF_HSEP + b:colsep := DEF_CSEP + b:footsep := DEF_FSEP + + b:gotopblock := {|| nElem := 1} + b:gobottomblock := {|| nElem := LEN(ar[1])} + + * skipblock originally coded by Robert DiFalco + b:SkipBlock := {|nSkip, nStart| nStart := nElem,; + nElem := MAX( 1, MIN( LEN(ar[1]), nElem + nSkip ) ),; + nElem - nStart } + + FOR i = 1 TO LEN(aBlocks) + column := TBColumnNew(aHeadings[i], aBlocks[i] ) + b:addcolumn(column) + NEXT + + exit_requested = .F. + DO WHILE !exit_requested + + DO WHILE NEXTKEY() == 0 .AND. !b:stabilize() + ENDDO + + nKey := INKEY(0) + + meth_no := ASCAN(tb_methods, {|elem| nKey = elem[KEY_ELEM]}) + IF meth_no != 0 + EVAL(tb_methods[meth_no, BLK_ELEM], b) + ELSE + DO CASE + CASE nKey == K_F7 + FOR nDim = 1 TO LEN(ar) + ADEL(ar[nDim], nElem) + ASIZE(ar[nDim], LEN(ar[nDim]) - 1) + NEXT + b:refreshAll() + + CASE nKey == K_F8 + FOR nDim = 1 TO LEN(ar) + * check valtype of current element before AINS() + cType := VALTYPE(ar[nDim, nElem]) + cVal := ar[nDim, nElem] + ASIZE(ar[nDim], LEN(ar[nDim]) + 1) + AINS(ar[nDim], nElem) + IF cType == "C" + ar[nDim, nElem] := SPACE(LEN(cVal)) + ELSEIF cType == "N" + ar[nDim, nElem] := 0 + ELSEIF cType == "L" + ar[nDim, nElem] := .f. + ELSEIF cType == "D" + ar[nDim, nElem] := CTOD(" / / ") + ENDIF + NEXT + b:refreshAll() + + CASE nKey == K_ESC + exit_requested := .T. + + * Other exception handling ... + CASE VALTYPE(bGetFunc) == "B" + IF nKey <> K_ENTER + * want last key to be part of GET edit so KEYBOARD it + KEYBOARD CHR(LASTKEY()) + ENDIF + EVAL(bGetFunc, b, ar, b:colPos, nElem ) + * after get move to next field + KEYBOARD IF(b:colPos < b:colCount, ; + CHR(K_RIGHT), CHR(K_HOME) + CHR(K_DOWN) ) + + * Placing K_ENTER here below Edit Block (i.e. bGetFunc) + * defaults K_ENTER to Edit when bGetFunc Is Present + * BUT if no bGetFunc, then K_ENTER selects element to return + CASE nKey == K_ENTER + exit_requested := .T. + + ENDCASE + ENDIF // meth_no != 0 + ENDDO // WHILE !exit_requested + RestScreen(nTop, nLeft, nBot, nRight, cSaveWin) + * if no bGetFunc then ESC returns 0, otherwise return value of last element +RETURN IF( VALTYPE(bGetFunc) == NIL .AND. nKey == K_ESC, ; + 0, ar[b:colPos, nElem] ) +* EOFcn FT_ArEdit() diff --git a/harbour/contrib/libnf/asum.prg b/harbour/contrib/libnf/asum.prg new file mode 100644 index 0000000000..9bcf52d2cc --- /dev/null +++ b/harbour/contrib/libnf/asum.prg @@ -0,0 +1,86 @@ +/* + * File......: ASum.Prg + * Author....: David Husnian + * CIS ID....: ? + * + * This is an original work by David Husnian and is placed in the + * public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.2 15 Aug 1991 23:02:48 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 14 Jun 1991 19:50:56 GLENN + * Minor edit to file header + * + * Rev 1.0 01 Apr 1991 01:00:36 GLENN + * Nanforum Toolkit + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_ASUM() + * $CATEGORY$ + * Array + * $ONELINER$ + * Sum the elements of an array + * $SYNTAX$ + * FT_ASUM( [, [, ] ] ) -> nSum + * $ARGUMENTS$ + * is the array containing the elements to be summed. + * + * is the first array item to include, + * defaults to first element. + * + * is the last array element to include, + * defaults to all elements. + * $RETURNS$ + * The sum of the elements of the array or the lengths of the elements. + * $DESCRIPTION$ + * This function is to sum the elements of a numeric array or to sum the + * lengths of a character array. + * $EXAMPLES$ + * + * FT_ASUM(aSubTotals) // Sum the Entire Array + * + * FT_ASUM(aSubTotals, 5) // Sum from the 5th Element On + * + * FT_ASUM(aSubTotals, , 10) // Sum the 1st 10 Elements + * + * FT_ASUM(aSubTotals, 5, 10) // Sum Elements 5-10 + * $END$ + */ + +#define CASE_AT(x,y,z) z[AT(x,y)+1] +#define FORCE_BETWEEN(x,y,z) (y := MAX(MIN(y,z),x)) +#define IS_CHAR(x) (VALTYPE(x) == "C") + +#command DEFAULT TO [, TO ] ; + => ; + := IF( == NIL,,) ; + [; := IF( == NIL,,)] + + +FUNCTION FT_ASUM(aArray, nStartIndex, nEndIndex) + + LOCAL nSumTotal := 0 // Array Sum + + DEFAULT nStartIndex TO 1, ; + nEndIndex TO LEN(aArray) + // Make Sure Bounds are in Range + FORCE_BETWEEN(1, nEndIndex, LEN(aArray)) + FORCE_BETWEEN(1, nStartIndex, nEndIndex) + + AEVAL(aArray, ; + { | xElement | ; + nSumTotal += ; + CASE_AT(VALTYPE(xElement), "NC", ; + { 0, xElement, ; + IF(IS_CHAR(xElement),LEN(xElement),0) }) }, ; + nStartIndex, nEndIndex - nStartIndex + 1) + + RETURN (nSumTotal) // FT_ASum diff --git a/harbour/contrib/libnf/at2.prg b/harbour/contrib/libnf/at2.prg new file mode 100644 index 0000000000..05b9bb3d4d --- /dev/null +++ b/harbour/contrib/libnf/at2.prg @@ -0,0 +1,136 @@ +/* + * File......: AT2.prg + * Author....: Ralph Oliver, TRANSCOM SYSTEMS + * CIS ID....: 74030,703 + * + * This is an original work by Ralph Oliver and is placed in the + * public domain. + * + * Modification history: + * --------------------- + * + * Rev 1.2 15 Aug 1991 23:05:58 GLENN + * Forest Belt proofread/edited/cleaned up doc + * + * Rev 1.1 12 Jun 1991 00:46:28 GLENN + * Posted a referee suggestion: Around line 118, break out if no + * occurrences (note the IF/ENDIF before the NEXT and RETURN at the + * bottom of the function). + * + * Rev 1.0 07 Jun 1991 23:03:28 GLENN + * Initial revision. + * + * + */ + + +/* $DOC$ + * $FUNCNAME$ + * FT_AT2() + * $CATEGORY$ + * String + * $ONELINER$ + * Find position of the nth occurrence of a substring + * $SYNTAX$ + * FT_AT2( , [, [, ] ] ) -> nPos + * $ARGUMENTS$ + * is the character substring to search for. + * + * is the character string to search. + * + * is the occurrence of cSearch to look for, + * defaults to 1. + * + * is a logical value denoting case sensitivity. + * If .F., then search is NOT sensitive to case, + * defaults to .T. + * $RETURNS$ + * The position of the nth occurrence of a substring + * $DESCRIPTION$ + * This function will find the nth occurrence of a substring + * within a string. + * $EXAMPLES$ + * cSearch := "t" + * cTarget := "This is the day that the Lord has made." + * + * FT_AT2( cSearch, cTarget ) // Returns ( 9 ) + * + * FT_AT2( cSearch, cTarget, 2 ) // Returns ( 17 ) + * + * FT_AT2( cSearch, cTarget, 2, .F. ) // Returns ( 9 ) + * $SEEALSO$ + * FT_FINDITH() + * $END$ + */ + +#ifdef FT_TEST + +FUNCTION MAIN() + LOCAL cSearch,cTarget,var0 + CLS + ? "TEST TO DEMONSTRATE EXAMPLES OF FT_AT2" + ? + cSearch := 't' + ? "Find occurrences of 't' in: " + cTarget := "This is the day that the Lord has made." + ?? cTarget + ? + var0 := ft_at2( cSearch, cTarget ) + ? PADR("FT_AT2( cSearch, cTarget ) -> ",40) + ?? var0 + ? + var0 := ft_at2( cSearch, cTarget, 2 ) + ? PADR("FT_AT2( cSearch, cTarget, 2 ) -> ",40) + ??var0 + ? + var0 := ft_at2( cSearch, cTarget, 2, .F. ) + ? PADR("FT_AT2( cSearch, cTarget, 2, .F. ) -> ",40) + ??var0 + ? + RETURN NIL + +#endif + + +FUNCTION FT_AT2( cSearch, cTarget, nOccurs, lCaseSens ) + + LOCAL nCount, nPos, nPos2 := 0 + LOCAL cSubstr := cTarget + + // Set default parameters as necessary. + IF lCaseSens == NIL + lCaseSens := .T. + ENDIF + + IF nOccurs == NIL + nOccurs := 1 + ENDIF + + FOR nCount := 1 TO nOccurs + + // Store position of next occurrence of cSearch. + IF lCaseSens + nPos := AT( cSearch, cSubstr ) + + ELSE + nPos := AT( UPPER( cSearch ), UPPER( cSubstr ) ) + + ENDIF + + // Store position of cSearch relative to original string. + nPos2 += nPos + + // Resize cSubstr + cSubstr := SUBSTR( cSubstr, AT( cSearch, cSubstr ) +1 ) + + // Breakout if there are no occurences here + + IF nPos == 0 + EXIT + ENDIF + + + NEXT + + RETURN ( nPos2 ) +