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

See changelog 20000421 23:00 gmt -3

Browse Source
This commit is contained in:
Luiz Rafael Culik
2000-04-22 02:50:34 +00:00
parent fdc28e5f1f
commit 31b060a030
14 changed files with 5578 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

177
harbour/contrib/libnf/kspeed.c Normal file
View File

@@ -0,0 +1,177 @@
/*
* $Id$
*/
/* File......: KSPEED.ASM
* Author....: James R. Zack
* CIS ID....: 75410,1567
*
* This is an original work by James R. Zack and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:06:54 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:54:40 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:03:28 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_SETRATE()
* $CATEGORY$
* Keyboard/Mouse
* $ONELINER$
* Set the keyboard delay and repeat rate on PC/AT & PS/2
* $SYNTAX$
* FT_SETRATE( [ <nDelayTime> ] [, <nRepeatRate> ] ) -> NIL
* $ARGUMENTS$
* <nDelayTime> is the keyboard delay time.
*
* <nRepeatRate> is the keyboard repeat rate.
*
* ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿
* ³ nDelayTime DELAY ³ ³ RepeatRate SPEED ³
* ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ´ ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ´
* ³ 0 250ms ³ ³ 0 30.0cps ³
* ³ 1 (default) 500ms ³ ³ 1 26.7cps ³
* ³ 2 750ms ³ ³ 2 24.0cps ³
* ³ 3 1000ms ³ ³ 3 21.8cps ³
* ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ ³ 4 20.0cps ³
* ³ 5 18.5cps ³
* ³ 6 17.1cps ³
* ³ 7 16.0cps ³
* ³ 8 15.0cps ³
* ³ 9 13.3cps ³
* ³ 10 12.0cps ³
* ³ 11 10.9cps ³
* ³ 12 (default) 10.0cps ³
* ³ 13 9.2cps ³
* ³ 14 8.6cps ³
* ³ 15 8.0cps ³
* ³ 16 7.5cps ³
* ³ 17 6.7cps ³
* ³ 18 6.0cps ³
* ³ 19 5.5cps ³
* ³ 20 5.0cps ³
* ³ 21 4.6cps ³
* ³ 22 4.3cps ³
* ³ 23 4.0cps ³
* ³ 24 3.7cps ³
* ³ 25 3.3cps ³
* ³ 26 3.0cps ³
* ³ 27 2.7cps ³
* ³ 28 2.5cps ³
* ³ 29 2.3cps ³
* ³ 30 2.1cps ³
* ³ 31 2.0cps ³
* ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ
* $RETURNS$
* NIL
* $DESCRIPTION$
* This routine is used to adjust the IBM PC/AT and PS/2 "typematic"
* repeat and delay feature. This is used to allow the users of your
* application to adjust these speeds to the most comfortable level.
*
* This source code is written for Microsoft Assembler v5.1.
* $EXAMPLES$
* FT_SETRATE(0,0) // Set keyboard to fastest possible settings
* FT_SETRATE() // Set keyboard to AT defaults (10.9cps,500ms delay)
* FT_SETRATE(11,1) // Set keyboard to PS/2 defaults (10cps,500ms delay)
* $END$
*/
/*This is the Original FT_SETRATE() code
PUBLIC FT_SETRATE * MAKE ROUTINE VISIBLE
EXTRN __PARNI:FAR * DECLARE EXTERNALS
EXTRN __RET:FAR
EXTRN __PARINFO:FAR
_NANFOR SEGMENT 'CODE'
ASSUME CS:_NANFOR * POINT CS TO MY CODE
FT_SETRATE PROC FAR
PUSH BP * SAVE BASE POINTER
MOV BP,SP * POINT TO TOP OF STACK
PUSH DS * SAVE REGISTERS
PUSH ES
PUSH SI
PUSH DI
MOV AX,0 * LOOK AT NUMBER OF PARAMS PASSED
PUSH AX * SET UP FOR __PARINFO
CALL __PARINFO * GET NUMBER OF PARAMS PASSED
ADD SP,2 * ADJUST STACK
CMP AX,2 * WERE BOTH PARMS PASSED?
JL DEFAULTS * NO, USE DEFAULTS
JMP GETPARMS * OTHERWISE, LETS GET SOME PARAMS.
DEFAULTS: MOV BX,010CH * SET UP DEFAULTS (for AT)
jmp goodparm * and make the int call.
getparms: mov ax,01h * First param is repeat rate
push ax * Set up for __PARNI
call __PARNI * Get first param
add sp,2 * Adjust stack
mov bl,al * Put repeat rate into BL
cmp bl,20h * Is BL > 20h? (max value)
jg defaults * Yes, then use defaults
mov ax,02h * Second parm is typeamatic delay
push ax * Set up for __PARNI
call __PARNI * Get second param
add sp,2 * Adjust stack
mov bh,al * Put delay into BH
cmp bh,04h * Is BH > 04h (max value)
jg defaults * Yes, then use defaults
goodparm: mov ax,0305h * BIOS Function 03 Subfunction 05
int 16h * Set Typematic Rate and Delay
exit: pop di * Retore registers
pop si
pop es
pop ds
pop bp
call __RET * Clean up for Clipper
ret * Pass control back to Clipper
FT_SETRATE ENDP
_NanFor ENDS
END
*/
/* This is the New one Rewriten in C*/
#include "extend.h"
#include "dos.h"
HB_FUNC( FT_SETRATE)
{
#if defined(HB_OS_DOS)
{
union REGS registers;
int tempo,nrepete;
switch(PCOUNT) {
case 0: tempo = 0 ;
nrepete = 0;
break;
case 1: tempo = hb_parni(1) ;
nrepete = 0;
break;
case 0: tempo = hb_parni(1);
nrepete = hb_parni(2);
break;
}
registers.h.ah = 0x03;
registers.h.al = 0x05;
registers.h.bh = tempo;
registers.h.bl = nrepete;
HB_DOS_INT86(0x16,&registers,&registers);
}
#endif
}

61
harbour/contrib/libnf/lastday.prg Normal file
View File

@@ -0,0 +1,61 @@
/*
* File......: LASTDAY.PRG
* Author....: Mike Schinkel
* CIS ID....: ?
*
* This is an original work by Mike Schinkel and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.1 15 Aug 1991 23:02:32 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.0 14 Jun 1991 04:24:04 GLENN
* Initial revision.
*
*
*/
/* Librarian's note: The toolkit's original ft_lday() function was
submitted by Jeff Bryant. Mike saw it and optimized it. Thanks
to you both for your great code!
*/
/* $DOC$
* $FUNCNAME$
* FT_LDAY()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Return last day of the month
* $SYNTAX$
* FT_LDAY( [ <dDateToChk> ] ) -> dLastDay
* $ARGUMENTS$
* <dDateToChk> is a date within a month for which you want to find
* the last date of that month. If not passed or is an incorrect
* type, defaults to current system date.
* $RETURNS$
* A Clipper date value representing the last date of the month.
* $DESCRIPTION$
* This function will return the last day of the month of the date
* passed, or the last day of the current month if no argument is
* supplied.
* $EXAMPLES$
* dDate := CTOD( "09/15/90" )
* ? FT_LDAY( dDate ) // 09/30/90
* ? FT_LDAY() // 03/31/91 (current month)
* $SEEALSO$
* FT_FDAY()
* $END$
*/
FUNCTION ft_lday( dDate )
LOCAL d:= dDate
IF dDate == NIL
d:= Date()
ENDIF
RETURN ( d+= 45 - Day( d ) ) - Day( d )

135
harbour/contrib/libnf/linked.prg Normal file
View File

@@ -0,0 +1,135 @@
/*
* File......: Linked.PRG
* Author....: Brian Loesgen
* CIS ID....: 74326,1174
*
* This is an original work by Brian Loesgen and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:05:52 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:08 GLENN
* Minor edit to file header
*
* Rev 1.0 13 Jun 1991 15:21:26 GLENN
* Initial revision.
*
*/
/* $DOC$
* $FUNCNAME$
* FT_LINKED()
* $CATEGORY$
* Environment
* $ONELINER$
* Determine if a function was linked in
* $SYNTAX$
* FT_LINKED( <cString> ) -> lResult
* $ARGUMENTS$
* <cString> is a character string containing one or more function
* calls
* $RETURNS$
* .T. if all functions within the string are currently linked into
* the application, .F. if one or more aren't. See below for a
* definition of "function."
* $DESCRIPTION$
*
* This function would be used in data driven application to determine
* whether or not a macro compiled function was linked in.
*
* Several functions can be passed, and nested, in <cString>.
*
* Caveat: Some function calls are converted by the preprocessor
* into other function calls. You cannot have these types of
* functions in a macro compiled string as they never exist at
* runtime. FT_LINKED will correctly tell you that they are invalid.
*
* For instance: there is no function called SORT() in any of the
* Nantucket LIBraries, but it is a valid CLIPPER command because the
* preprocessor will convert it to other function calls.
*
*
* $EXAMPLES$
*
* cString := "FT_GoodFunc(BadFunc(3,2))"
* IF FT_LINKED(cString)
* EVAL( &("{||"+cString+"}") )
* ELSE
* ALERT("Error: "+cString+" was not linked in. Called by FT_LINKED()")
* ENDIF
*
*
* $END$
*/
#ifdef FT_TEST
FUNCTION Main
LOCAL cString
LOCAL aString := { "TRIM('abc ')", ;
"NotARealFunc()", ;
"FT_DispMsg()", ;
'TRIM(cVar+"abc"+LEFT(cString)), FOUND()', ;
"IsItLinked()", ;
"lRetVal := FOUND()", ;
"!EOF() .AND. MONTH(DATE())=12 .AND. YeeHa()", ;
"!EOF() .AND. MONTH(DATE())=12", ;
"!EOF() .AND. MONTH(DATE(YeeHa()))=12", ;
"LEFT(SUBSTR(nNum,4,VAL(cChar+ASC(c))))", ;
"EOF(>> Note: Syntax IS NOT checked! <<)" ;
}
CLS
@1,0 SAY "String Tested Result"
@2,0 TO 2,MAXCOL()
AEVAL(aString, {|ele,num| QOUT(ele, SPACE(45-LEN(ele)), FT_Linked(ele)) } )
@MAXROW()-2,0
RETURN NIL
#endif
*------------------------------------------------
FUNCTION FT_Linked( cFuncs )
// A function is detected by the left parenthesis, "(", and it begins
// at the space, comma or start-of-string preceeding the "("
// Returns: .T. if all functions are available,
// .F. if not
LOCAL aFuncArray := {}, nSpace, nComma, nFEnd, lRetVal := .F.
IF AT("(",cFuncs) = 0
// No functions in string
ALERT("Warning: Expected function(s) in FT_Linked(), but none were found")
ELSE
DO WHILE (nFEnd := AT("(",cFuncs)) > 0
// Add the current function to the array of functions
AADD( aFuncArray,LEFT(cFuncs,nFEnd)+")" )
// Remove the current function from the string
cFuncs := SUBSTR(cFuncs, nFEnd+1)
nSpace := AT(" ",cFuncs) ; nComma := AT(",",cFuncs)
DO WHILE (nComma > 0 .and. nComma < nFEnd) .or. ;
(nSpace > 0 .and. nSpace < nFEnd)
// We have extra parameters or spaces prior to the start
// of the function. Strip them out.
if nComma > 0
cFuncs := SUBSTR(cFuncs, nComma+1)
elseif nSpace > 0
cFuncs := SUBSTR(cFuncs, nSpace+1)
endif
nSpace := AT(" ", cFuncs) ; nComma := AT(",", cFuncs)
ENDDO
ENDDO
// Scan through the array of functions, stop after the first occurence
// of a function which returns a TYPE() of "U" (hence is not linked in)
lRetVal := ASCAN(aFuncArray,{|element| TYPE(element)=="U"})=0
ENDIF
RETURN( lRetVal )

102
harbour/contrib/libnf/madd.prg Normal file
View File

@@ -0,0 +1,102 @@
/*
* File......: MADD.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:39:04 GLENN
* Jo French cleaned up.
*
* Rev 1.2 15 Aug 1991 23:03:58 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:14 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:01:38 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_MADD()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Add or subtract months to/from a date
* $SYNTAX$
* FT_MADD( [ <dGivenDate> ], [ <nAddMonths> ], [ <lMakeEOM> ] )
* -> dDate
* $ARGUMENTS$
* <dGivenDate> is any valid date in any date format. Defaults to
* current system date if not supplied.
*
* <nAddMonths> is the number of months to be added or subtracted.
* Defaults to 0 if not supplied.
*
* <lMakeEOM> is a logical variable indicating whether or not to
* force the returned date to the last date of the month. It only
* affects the returned date if <dGivenDate> is an end-of-month date.
* $RETURNS$
* A date.
* $DESCRIPTION$
* FT_MADD() adds or subtracts months to/from a given date.
*
* If MakeEOM is passed and dGivenDate is the last day of a month,
* it will return the EOM of calculated month. Otherwise it will
* return the same day as the day of the passed date.
* $EXAMPLES$
* dDate := CTOD( "09/15/90" )
* ? FT_MADD( dDate, 1 ) // 10/15/90
* ? FT_MADD( dDate, -2 ) // 07/15/90
*
* // force EOM
* dDate := CTOD( "04/30/91" )
* ? FT_MADD( dDate, 1 ) // 05/30/91
* ? FT_MADD( dDate, 1, .T. ) // 05/31/91 <- forced EOM
* ? FT_MADD( dDate, 2 ) // 06/30/91
* ? FT_MADD( dDate, 2, .T. ) // 06/30/91 <- June only has 30 days
* ? FT_MADD( dDate, 3 ) // 07/30/91
* ? FT_MADD( dDate, 3, .T. ) // 07/31/91 <- forced EOM
*
* $SEEALSO$
* FT_DAYOFYR() FT_DAYTOBOW()
* $END$
*/
FUNCTION FT_MADD( dGivenDate, nAddMonths, lMakeEOM)
LOCAL nAdjDay, dTemp, i
IF(VALTYPE(dGivenDate) != 'D', dGivenDate := DATE(), )
IF(VALTYPE(nAddMonths) != 'N', nAddMonths := 0, )
IF(VALTYPE(lMakeEOM) != 'L', lMakeEom := .F., )
nAdjDay := DAY( dGivenDate ) - 1
/* If givendate is end of month and lMakeEom, then force EOM.*/
lMakeEom := ( lMakeEom .AND. dGivenDate == dGivenDate - nAdjDay + 31 - ;
DAY( dGivenDate - nAdjDay + 31 ) )
dTemp := dGivenDate - nAdjDay // first of month
/* Work with 1st of months.*/
FOR i := 1 TO ABS(nAddMonths)
dTemp += IF( nAddMonths > 0, 31, -1 )
dTemp += 1 - DAY( dTemp )
NEXT
IF lMakeEom
dTemp += 31 - DAY( dTemp + 31 )
ELSE
dTemp := MIN( (dTemp + nAdjday), (dTemp += 31 - DAY( dTemp + 31 )))
ENDIF
RETURN dTemp

544
harbour/contrib/libnf/menu1.prg Normal file
View File

@@ -0,0 +1,544 @@
/*
* File......: MENU1.PRG
* Author....: Paul Ferrara
* CIS ID....: 76702,556
*
* This is an original work by Paul Ferrara and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:04:42 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:12 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:01:40 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_MENU1()
* $CATEGORY$
* Menus/Prompts
* $ONELINER$
* Pulldown menu system
* $SYNTAX$
* FT_MENU1( <acBarNames>, <acOptions>, <acAction>,
* <acColors> [, <nTopRow> ], [ <lShadow> ] ) -> NIL
* $ARGUMENTS$
* <acBarNames> is a character array containing the names to appear
* on the menu bar.
*
* <acOptions> is a multi-dimensional array with one element for each
* selection to appear on the pulldown menus.
*
* <acColors> is an array containing the colors for the menu groups.
*
* <nTopRow> is a numeric value that determines the row for the menu
* bar. If omitted, it defaults to 0.
*
* <lShadow> is a logical variable. If true (.T.) or omitted, it
* uses FT_SHADOW() to add a transparent shadow to the each
* pulldown menu. If false (.F.), the menu is drawn without
* the shadow.
*
* All arguments except nTopRow and lShadow are required.
* $RETURNS$
* NIL
* $DESCRIPTION$
* FT_MENU1() is a function that displays a pulldown menu for each item
* on the menu bar and executes the corresponding function for the item
* selected. When a called function returns false, FT_MENU1 returns
* control to the calling program.
*
* Valid keystrokes and their corresponding actions:
*
* Home - Activates Pulldown for first item on the menu bar
* End - Activates Pulldown for last item on the menu bar
* Left Arrow - Activates next Pulldown to the left
* Right Arrow - Activates next Pulldown to the right
* Tab - Same as Right Arrow
* Shift-Tab - Same as Left Arrow
* Page Up - Top item on current Pulldown menu
* Page Down - Bottom item on current Pulldown menu
* Enter - Selects current item
* Alpha Character - Moves to closest match and selects
* Alt-<Key> - Moves to corresponding menu bar item
* Escape - Prompts for confirmation and either returns to
* the calling routine or resumes
* $EXAMPLES$
* // Declare arrays
* LOCAL aColors := {}
* LOCAL aBar := { " ENTER/EDIT ", " REPORTS ", " DISPLAY " }
*
* // Include the following two lines of code in your program, as is.
* // The first creates aOptions with the same length as aBar. The
* // second assigns a three-element array to each element of aOptions.
* LOCAL aOptions[ LEN( aBar ) ]
* AEVAL( aBar, { |x,i| aOptions[i] := { {},{},{} } } )
*
* // fill color array
* // Box Border, Menu Options, Menu Bar, Current Selection, Unselected
* aColors := IF( lColor, {"W+/G", "N/G", "N/G", "N/W", "N+/G"}, ;
* {"W+/N", "W+/N", "W/N", "N/W","W/N"} )
*
* // array for first pulldown menu
* FT_FILL( aOptions[1], 'A. Execute A Dummy Procedure' , {|| fubar()}, .t. )
* FT_FILL( aOptions[1], 'B. Enter Daily Charges' , {|| .t.}, .f. )
* FT_FILL( aOptions[1], 'C. Enter Payments On Accounts', {|| .t.}, .t. )
*
* // array for second pulldown menu
* FT_FILL( aOptions[2], 'A. Print Member List' , {|| .t.}, .t. )
* FT_FILL( aOptions[2], 'B. Print Active Auto Charges' , {|| .t.}, .t. )
*
* // array for third pulldown menu
* FT_FILL( aOptions[3], 'A. Transaction Totals Display', {|| .t.}, .t. )
* FT_FILL( aOptions[3], 'B. Display Invoice Totals' , {|| .t.}, .t. )
* FT_FILL( aOptions[3], 'C. Exit To DOS' , {|| .f.}, .t. )
*
* Call FT_FILL() once for each item on each pulldown menu, passing it
* three parameters:
*
* FT_FILL( <cMenuSelection>, <bCodeBlock>, <lSelectable>
*
* <cMenuSelection> is a character string which will be displayed on
* the pulldown menu.
*
* <bCodeBlock> should contain one of the following:
*
* A function name to execute, which in turn should return .T. or .F.
* FT_MENU1 WILL RETURN CONTROL TO THE CALLING PROGRAM IF .F. IS
* RETURNED OR CONTINUE IF .T. IS RETURNED.
*
* .F. WHICH WILL CAUSE FT_MENU1 TO RETURN CONTROL TO THE CALLING
* PROGRAM.
*
* .T. WHICH WILL DO NOTHING. THIS ALLOWS THE DEVELOPER TO DESIGN A
* SKELETON MENU STRUCTURE PRIOR TO COMPLETING ALL OF THE SUBROUTINES.
*
* // CALL FT_MENU1
* FT_MENU1( aBar, aOptions, aColors, 0 )
*
* NOTE: FT_MENU1() disables Alt-C and Alt-D in order to make them
* available for the menu bar. It enables Alt-D and resets
* Alt-C to its previous state prior to calling each function.
* $SEEALSO$
* FT_FILL()
* $END$
*/
/*
For the sample program:
Compile with "/n /dFT_TEST" SWITCHES AND LINK.
PASS "MONO" OR "MONO" AS A COMMAND LINE PARAMETER TO FORCE MONO MODE.
PASS "NOSNOW" OR "NOSNOW" AS A COMMAND LINE PARAMETER ON A CGA.
PASS "VGA" OR "VGA" AS A COMMAND LINE PARAMETER FOR 50-LINE MODE.
*/
#define LEFTARROW 19
#define RIGHTARROW 4
#define ENTER 13
#define CTRLEND 23
#define CTRLHOME 29
#define HOME 1
#define END 6
#define TAB 9
#define SHIFTTAB 271
#define PGUP 18
#define PGDN 3
#define ESCAPE 27
#define HITTOP 1
#define HITBOTTOM 2
#define KEYEXCEPT 3
#define NEXTITEM 3
#define RESUME 2
#define MAKESELECT 1
#define ABORT 0
#define DISABLE 0
#define ENABLE 1
#define SCNONE 0
#define SCNORMAL 1
STATIC ACHOICES := {}, AVALIDKEYS := {}
STATIC NHPOS, NVPOS, NMAXROW, NMAXCOL
// BEGINNING OF DEMO PROGRAM
#IFDEF FT_TEST
// DUMMY PROCEDURE NAME SO "CCMDLINE" WILL BE LOCAL
PROCEDURE CALLMENU( cCmdLine )
LOCAL sDosScrn, nDosRow, nDosCol, lColor
// my approach to color variables
// see colorchg.arc on NANFORUM
STATIC cNormH, cNormN, cNormE, ;
cWindH, cWindN, cWindE, ;
cErrH, cErrN, cErrE
// options on menu bar
LOCAL aColors := {}
LOCAL aBar := { " ENTER/EDIT ", " REPORTS ", " DISPLAY ", " MAINTENANCE ", " QUIT " }
LOCAL aOptions[ LEN( aBar ) ]
AEVAL( aBar, { |x,i| aOptions[i] := { {},{},{} } } )
cCmdLine := IF( cCmdLine == NIL, "", cCmdLine )
lColor := IF( "MONO" $ UPPER( cCmdLine ), .F., ISCOLOR() )
* Border, Box, Bar, Current, Unselected
aColors := IF( lColor, {"W+/G", "N/G", "N/G", "N/W", "N+/G"}, ;
{"W+/N", "W+/N", "W/N", "N/W", "W/N"} )
FT_FILL( aOptions[1], 'A. Execute A Dummy Procedure' , {|| fubar()}, .t. )
FT_FILL( aOptions[1], 'B. Enter Daily Charge/Credit Slips' , {|| .t.}, .t. )
FT_FILL( aOptions[1], 'C. Enter Payments On Accounts' , {|| .t.}, .f. )
FT_FILL( aOptions[1], 'D. Edit Daily Transactions' , {|| .t.}, .t. )
FT_FILL( aOptions[1], 'E. Enter/Update Member File' , {|| .t.}, .t. )
FT_FILL( aOptions[1], 'F. Update Code File' , {|| .t.}, .f. )
FT_FILL( aOptions[1], 'G. Add/Update Auto Charge File' , {|| .t.}, .t. )
FT_FILL( aOptions[1], 'H. Post All Transactions To A/R File', {|| .t.}, .t. )
FT_FILL( aOptions[1], 'I. Increment Next Posting Date' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'A. Print Member List' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'B. Print Active Auto Charges' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'C. Print Edit List' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'D. Print Pro-Usage Report' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'E. Print A/R Transaction Report' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'F. Aging Report Preparation' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'G. Add Interest Charges' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'H. Print Aging Report' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'I. Print Monthly Statements' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'J. Print Mailing Labels' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'K. Print Transaction Totals' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'L. Print Transaction Codes File' , {|| .t.}, .t. )
FT_FILL( aOptions[2], 'M. Print No-Activity List' , {|| .t.}, .t. )
FT_FILL( aOptions[3], 'A. Transaction Totals Display' , {|| .t.}, .t. )
FT_FILL( aOptions[3], 'B. Display Invoice Totals' , {|| .t.}, .t. )
FT_FILL( aOptions[3], 'C. Accounts Receivable Display' , {|| .t.}, .t. )
FT_FILL( aOptions[4], 'A. Backup Database Files' , {|| .t.}, .t. )
FT_FILL( aOptions[4], 'B. Reindex Database Files' , {|| .t.}, .t. )
FT_FILL( aOptions[4], 'C. Set System Parameters' , {|| .t.}, .t. )
FT_FILL( aOptions[4], 'D. This EXITs Too' , {|| .f. }, .t. )
FT_FILL( aOptions[5], 'A. Does Nothing' , {|| .t.}, .t. )
FT_FILL( aOptions[5], 'B. Exit To DOS' , {|| .f. }, .t. )
// main routine starts here
SET SCOREBOARD OFF
cNormH := IF( lColor, "W+/G", "W+/N" )
cNormN := IF( lColor, "N/G" , "W/N" )
cNormE := IF( lColor, "N/W" , "N/W" )
cWindH := IF( lColor, "W+/B", "W+/N" )
cWindN := IF( lColor, "W/B" , "W/N" )
cWindE := IF( lColor, "N/W" , "N/W" )
cErrH := IF( lColor, "W+/R", "W+/N" )
cErrN := IF( lColor, "W/R" , "W/N" )
cErrE := IF( lColor, "N/W" , "N/W" )
SAVE SCREEN TO sDosScrn
nDosRow=ROW()
nDosCol=COL()
SETCOLOR( "w/n" )
CLS
NOSNOW( ( "NOSNOW" $ UPPER( cCmdLine ) ) )
IF "VGA" $ UPPER( cCmdLine )
SETMODE(50,80)
ENDIF
nMaxRow := MAXROW()
SETBLINK(.f.)
SETCOLOR( cWindN + "*" )
CLEAR SCREEN
SETCOLOR( cNormN )
@ nMaxRow, 0
@ nMaxRow, 0 SAY " FT_MENU1 1.0 ³ "
@ NMAXROW,16 SAY "WRITTEN BY PAUL FERRARA [76702,556] FOR NANFORUM.LIB"
@ NMAXROW,69 SAY "³ "+DTOC( DATE() )
SETCOLOR( cErrH )
@ nMaxRow-11, 23, nMaxRow-3, 56 BOX "ÚÄ¿³ÙÄÀ³ "
@ nMaxRow- 9,23 SAY "ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ´"
SETCOLOR( cErrN )
@ nMaxRow-10,33 SAY "Navigation Keys"
@ nMaxRow- 8,25 SAY "LeftArrow RightArrow Alt-E"
@ nMaxRow- 7,25 SAY "Home End Alt-R"
@ nMaxRow- 6,25 SAY "Tab Shift-Tab Alt-D"
@ nMaxRow- 5,25 SAY "PgUp PgDn Alt-M"
@ nMaxRow- 4,25 SAY "Enter ESCape Alt-Q"
SETCOLOR( cNormN )
FT_MENU1( aBar, aOptions, aColors )
SETCOLOR( "W/N" )
SETCURSOR( SCNORMAL )
SETBLINK(.t.)
IF "VGA" $ UPPER( cCmdLine )
SETMODE(25,80)
ENDIF
RESTORE SCREEN FROM sDosScrn
SETPOS(nDosRow, nDosCol)
QUIT
FUNCTION fubar()
LOCAL OldColor:= SETCOLOR( "W/N" )
CLEAR SCREEN
Qout( "Press Any Key" )
INKEY(0)
SETCOLOR( OldColor )
RETURN .t.
#endif
// end of demo program
FUNCTION FT_MENU1( aBar, aOptions, aColors, nTopRow, lShadow )
LOCAL nTtlWid, nTtlUsed, i, j, nPad
LOCAL sMainScrn, lCancMode, lLooping := .t.
// column position for each item on the menu bar
LOCAL aBarCol[LEN(aBar)]
// inkey code for each item on menu bar
LOCAL aBarKeys[ LEN( aBar ) ]
// inkey codes for A - Z
LOCAL aKeyCodes := { 286, 304, 302, 288, 274, 289, 290, 291, 279, ;
292, 293, 294, 306, 305, 280, 281, 272, 275, ;
287, 276, 278, 303, 273, 301, 277, 300 }
// LEN() of widest array element for for each pulldown menu
LOCAL aBarWidth[LEN(aBar)]
// starting column for each box
LOCAL aBoxLoc[LEN(aBar)]
// last selection for each element
LOCAL aLastSel[LEN(aBar)]
// color memvars
LOCAL cBorder := aColors[1]
LOCAL cBox := aColors[2]
LOCAL cBar := aColors[3]
LOCAL cCurrent := aColors[4]
LOCAL cUnSelec := aColors[5]
nMaxRow := MAXROW()
nMaxCol := MAXCOL()
// row for menu bar
nTopRow := IF( nTopRow == NIL, 0, nTopRow )
AFILL(aLastSel,1)
aChoices := aOptions
// this is the routine that calculates the position of each item
// on the menu bar.
nTtlWid := 0
aBarCol[1] := 0
nTtlUsed := LEN( aBar[1] ) + 1
AEVAL( aBar, ;
{|x,i| aBarcol[i]:= nTtlUsed,nTtlUsed+= (LEN(aBar[i]) +1 )}, ;
2, LEN(aBar) -1 )
// calculates widest element for each pulldown menu
// see below for _ftWidest()
AFILL(aBarWidth,1)
AEVAL( aChoices, { |x,i| _ftWidest( @i, aChoices, @aBarWidth ) } )
// box location for each pulldown menu
// see below for _ftLocat()
AEVAL( aChoices, { |x,i| _ftLocat( i, aBarCol, aBarWidth, @aBoxLoc, nMaxCol ) } )
// valid keys for each pulldown menu
// see below for _ftValKeys()
AEVAL( aChoices,{|x,i| AADD( aValidkeys,"" ),;
_ftValKeys( i,aChoices,@aValidKeys ) } )
// display the menu bar
SETCOLOR( cBar )
@ nTopRow, 0
AEVAL( aBar, { |x,i| Devpos(nTopRow, aBarCol[i]), Devout(aBar[i]) })
// store inkey code for each item on menu bar to aBarKeys
AEVAL( aBarKeys, {|x,i| aBarKeys[i] := ;
aKeyCodes[ ASC( UPPER( LTRIM( aBar[i] ) ) ) - 64 ] } )
// disable Alt-C and Alt-D
lCancMode := SETCANCEL( .f. )
AltD( DISABLE )
// main menu loop
SAVE SCREEN TO sMainScrn
// which menu and which menu item
nHpos := 1; nVpos := 1
DO WHILE lLooping
RESTORE SCREEN FROM sMainScrn
SETCOLOR( cCurrent )
@ nTopRow, aBarCol[nHpos] SAY aBar[nHpos]
IF lShadow == NIL .OR. lShadow
FT_SHADOW( nTopRow+1, aBoxLoc[nHpos], LEN(aChoices[nHpos,1])+nTopRow+2, aBarWidth[nHpos]+3+aBoxLoc[nHpos] )
ENDIF
SETCOLOR( cBorder )
@ nTopRow+1, aBoxLoc[nHpos], LEN(aChoices[nHpos,1])+nTopRow+2, aBarWidth[nHpos]+3+aBoxLoc[nHpos] BOX "ÉÍ»º¼ÍȺ "
SETCOLOR( cBox +","+ cCurrent +",,,"+ cUnselec )
nVpos := ACHOICE( nTopRow+2, aBoxLoc[nHpos]+2, LEN(aChoices[nHpos,1])+nTopRow+2, aBarWidth[nHpos]+1+aBoxLoc[nHpos], aChoices[nHpos,1], aChoices[nHpos,3], "__ftAcUdf", aLastSel[nHpos])
DO CASE
CASE LASTKEY() == RIGHTARROW .OR. LASTKEY() == TAB
IF( nHpos == LEN( aChoices ), nHpos := 1, nHpos := nHpos + 1 )
CASE LASTKEY() == LEFTARROW .OR. LASTKEY() == SHIFTTAB
IF( nHpos == 1, nHpos := LEN( aChoices ), nHpos := nHpos - 1 )
CASE LASTKEY() == ESCAPE
lLooping := _ftBailOut( cBorder, cBox )
CASE LASTKEY() == HOME
nHpos := 1
CASE LASTKEY() == END
nHpos := LEN( aChoices )
CASE LASTKEY() == ENTER
aLastSel[nHpos] := nVpos
IF aChoices[nHpos,2,nVpos] != NIL
SETCANCEL( lCancMode )
ALTD( ENABLE )
lLooping := EVAL( aChoices[nHpos,2,nVpos] )
ALTD( DISABLE )
SETCANCEL( .f. )
ENDIF
CASE ASCAN( aBarKeys, LASTKEY() ) > 0
nHpos := ASCAN( aBarKeys, LASTKEY() )
ENDCASE
ENDDO
SETCANCEL( lCancMode )
AltD( ENABLE )
RESTORE SCREEN FROM sMainScrn
RETURN NIL
FUNCTION __ftAcUdf( nMode )
// ACHOICE() user function
LOCAL nRtnVal := RESUME
DO CASE
CASE nMode == HITTOP
KEYBOARD CHR( CTRLEND )
CASE nMode == HITBOTTOM
KEYBOARD CHR( CTRLHOME )
CASE nMode == KEYEXCEPT
IF UPPER( CHR( LASTKEY() ) ) $ aValidKeys[ nHpos ]
IF aChoices[ nHpos, 3, AT( UPPER(CHR(LASTKEY())), aValidKeys[ nHpos ] )]
KEYBOARD CHR( ENTER )
nRtnVal := NEXTITEM
ENDIF
ELSE
nRtnVal := MAKESELECT
ENDIF
ENDCASE
RETURN nRtnVal
STATIC FUNCTION _ftWidest( i, aChoices, aBarWidth )
AEVAL(aChoices[i,1],{|a,b| aBarWidth[i] := ;
MAX( aBarWidth[i],LEN(aChoices[i,1,b])) })
RETURN NIL
STATIC FUNCTION _ftLocat( i, aBarCol, aBarWidth, aBoxLoc, nMaxCol )
aBoxLoc[i] := IF( aBarCol[i] + aBarWidth[i] + 4 > nMaxCol + 1, ;
nMaxCol - 3 - aBarWidth[i], aBarCol[i] )
RETURN NIL
STATIC FUNCTION _ftBailOut( cBorder, cBox )
LOCAL cOldColor, sOldScreen, nKeyPress, nOldCursor, nCenter
nOldCursor := SETCURSOR( SCNONE )
sOldScreen := SAVESCREEN(nMaxRow/2-1, 24, nMaxRow/2+2, 55)
cOldColor := SETCOLOR( cBorder )
FT_SHADOW( nMaxRow/2-1, 24, nMaxRow/2+2, 55 )
@ nMaxRow/2-1, 24, nMaxRow/2+2, 55 BOX "ÉÍ»º¼ÍȺ "
SETCOLOR( cBox )
@ nMaxRow/2, 26 SAY "Press ESCape To Confirm Exit"
@ nMaxRow/2+1,27 SAY "Or Any Other Key To Resume"
nKeyPress := INKEY(0)
SETCOLOR( cOldColor )
RESTSCREEN(nMaxRow/2-1, 24, nMaxRow/2+2, 55,sOldScreen )
SETCURSOR( nOldCursor )
RETURN !(nKeyPress == ESCAPE)
STATIC FUNCTION _ftValKeys( nNum,aChoices,aValidkeys )
AEVAL( aChoices[nNum,1], {|x| aValidKeys[nNum] += LEFT( x, 1)} )
RETURN NIL
/* $DOC$
* $FUNCNAME$
* FT_FILL()
* $CATEGORY$
* Menus/Prompts
* $ONELINER$
* Declare menu options for FT_MENU1()
* $SYNTAX$
* FT_FILL( <aSubArrayName>, <cMenuSelection>, <bFunction>,
* <lSelectable> ) -> NIL
* $ARGUMENTS$
* <aSubArrayName> is a sub-array of <acOptions> in FT_MENU1()
* denoting the group in which to include the selection --
* e.g., acOptions[1]
*
* <cMenuSelection> is the character string that will appear on
* the menu.
*
* <bFunction> is the code block to be executed when that menu
* option is selected. i.e. {|| MyFunction() } would execute
* the function called MyFunction(). {|| .f.} would exit the
* FT_MENU1 and return to the calling routine. {|| .T.} would
* do nothing.
*
* <lSelectable> is a logical variable that determines whether
* the corresponding menu option is selectable or not.
* $RETURNS$
* NIL
* $DESCRIPTION$
* FT_FILL() is a function used to set up the menu options prior
* to calling FT_MENU1().
* $EXAMPLES$
* FT_FILL( aOptions[1], 'A. Execute A Dummy Procedure' , {|| fubar()}, .t. )
*
* The above would be added to the sub-menu associated with the first menu
* bar item, would execute the function FUBAR() when that option was
* selected, and would be selectable.
*
*
* FT_FILL( aOptions[3], 'B. Enter Daily Charges' , {|| .t.}, .f. )
*
* The above would be added to the sub-menu associated with the third menu
* bar item, and would be unselectable.
*
*
* FT_FILL( aOptions[2], 'C. Enter Payments On Accounts', {|| .t.}, .t. )
*
* The above would be added to the sub-menu associated with the second menu
* bar item, and would be selectable, but would do nothing when selected.
*
*
* FT_FILL( aOptions[4], 'C. Exit' , {|| .f.}, .t. )
*
* The above would be added to the sub-menu associated with the fourth menu
* bar item, and would be selectable, and would exit FT_MENU1() when chosen.
* $SEEALSO$
* FT_MENU1()
* $END$
*/
FUNCTION FT_FILL( aArray, cMenuOption, bBlock, lAvailable )
AADD( aArray[1], cMenuOption )
AADD( aArray[2], bBlock )
AADD( aArray[3], lAvailable )
RETURN NIL

589
harbour/contrib/libnf/menuto.prg Normal file
View File

@@ -0,0 +1,589 @@
/*
* File......: MENUTO.PRG
* Author....: Ted Means
* CIS ID....: 73067,3332
*
* This is an original work by Ted Means and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.5 16 Oct 1992 00:20:28 GLENN
* Cleaned up documentation header.
*
* Rev 1.4 16 Oct 1992 00:08:44 GLENN
* Just making sure we had Ted's latest revision.
*
* Rev 1.3 13 Oct 1992 20:45:46 GLENN
* Complete rewrite by Ted Means, dumping assembler version for a
* Clipper version.
*
* Rev 1.2 15 Aug 1991 23:03:54 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:16 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:01:42 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_Prompt()
* $CATEGORY$
* Menus/Prompts
* $ONELINER$
* Define a menu item for use with FT_MenuTo()
* $SYNTAX$
* #include "FTMENUTO.CH"
*
* @ <nRow>, <nCol> PROMPT <cPrompt> ;
* [COLOR <cColor>] ;
* [MESSAGE <cMessage>] ;
* [MSGROW <nMsgRow>] ;
* [MSGCOL <nMsgCol>] ;
* [MSGCOLOR <cMsgColor>] ;
* [TRIGGER <nTrigger>] ;
* [TRIGGERCOLOR <cTriggerColor>] ;
* [HOME <nHome>] ;
* [END <nEnd>] ;
* [UP <nUp>] ;
* [DOWN <nDown>] ;
* [LEFT <nLeft>] ;
* [RIGHT <nRight>] ;
* [EXECUTE <bExec>] ;
*
* $ARGUMENTS$
* <nRow> is the row at which the prompt is to appear.
*
* <nCol> is the column at which the prompt will appear.
*
* <cPrompt> is the menu item string.
*
* <cColor> is optional and is the color attribute of the prompt. Note
* that two colors are required; one for the standard setting and one
* for the enhanced setting (i.e. the light bar color). See the example
* below if this isn't clear. If <cColor> is not specified then the
* current SetColor() value is used by default.
*
* <cMessage> is optional and is the message associated with the
* prompt. If not specified, then no message will be displayed.
*
* <nMsgRow> is optional and is the row at which the message, if any,
* will appear. If not specified, the default is the current setting
* of the SET MESSAGE TO command.
*
* <nMsgCol> is optional and is the column at which the message, if
* any, will appear. If not specified, the default is either zero or
* centered, depending on the current setting of the CENTER option of
* the SET MESSAGE TO command.
*
* <cMsgColor> is optional and is the color attribute of the message.
* If not specified, the default is the same as the prompt color.
*
* <nTrigger> is optional and is the position within the prompt string
* where the trigger character is located. If not specified, the
* default is one.
*
* <cTriggerColor> is optional and is the color attribute of the trigger
* character. Note that two colors are required; one for the standard
* setting and one for the enhanced setting (i.e. the light bar color).
* See the example below if this isn't clear. If <cTriggerColor> is not
* specified then the default is the same color as the rest of the
* prompt.
*
* <nHome> is optional and specifies which prompt becomes active
* when the home key is pressed. If not specified, the default is
* the first prompt.
*
* <nEnd> is optional and specifies which prompt becomes active
* when the end key is pressed. If not specified, the default is
* the last prompt.
*
* <nUp> is optional and specifies which prompt becomes active
* when the up arrow key is pressed. If not specified, the
* default is the previous prompt. The current setting of SET
* WRAP TO is obeyed.
*
* <nDown> is optional and specifies which prompt becomes
* active when the down arrow key is pressed. If not
* specified, the default is the next prompt. The current
* setting of SET WRAP TO is obeyed.
*
* <nRight> is optional and specifies which prompt becomes
* active when the right arrow key is pressed. If not
* specified, the default is the next prompt. The current
* setting of SET WRAP TO is obeyed.
*
* <nLeft> is optional and specifies which prompt becomes
* active when the left arrow is pressed. If not specified,
* the default is the previous prompt. The current setting of
* SET WRAP TO is obeyed.
*
* <bExec> is optional and is a code block to evaluate whenever
* the menu item to which it belongs is selected.
* $DESCRIPTION$
* Clipper's @...PROMPT and MENU TO commands are fine as far as
* they go. But many times you need more flexibility. As
* you'll no doubt notice if you read the argument list, this
* function is almost completely flexible. You can adjust
* locations and colors for every part of the prompt and its
* associated message. In addition, since you can control the
* effect of the arrow keys, you can allow both horizontal and
* vertical movement, or even disable certain arrow keys if you
* so desire. Support for nested menus is also available, since
* the prompts are stored in stack-based static arrays.
*
* Note that this command can also be called using function-style
* syntax. See the entry for FT_PROMPT() for further details.
*
* This enhanced version of @...PROMPT requires the inclusion of
* the header file FTMENUTO.CH in any source file that uses it.
* It is may be used in place of the standard Clipper @...PROMPT
* command. However, in the interests of functionality it is NOT
* 100% compatible. No whining! If compatibility is such a big
* deal then use the standard Clipper commands.
*
* $EXAMPLES$
* #include "FTMENUTO.CH"
*
* // Simple prompt
* @ 1, 1 PROMPT "Menu choice #1"
*
* // Prompt with color
* @ 3, 1 PROMPT "Menu choice #2" COLOR "W+/R,W+/B"
*
* // Prompt with a message
* @ 5, 1 PROMPT "Menu choice #3" MESSAGE "Go to lunch"
*
* // Prompt with pinpoint message control
* @ 7, 1 PROMPT "Menu choice #4" MESSAGE "Drop Dead" ;
* MSGROW 22 MSGCOL 4 MSGCOLOR "GR+/N"
*
* // Prompt with a trigger character ("#" character)
* @11, 1 PROMPT "Menu choice #6" TRIGGER 13
*
* // Prompt with trigger character color control
* @13, 1 PROMPT "Menu Choice #7" TRIGGER 13 TRIGGERCOLOR "R+/BG,G+/N"
*
* // Prompt with right and left arrow keys disabled
* @15, 1 PROMPT "Menu Choice #8" RIGHT 8 LEFT 8
* $INCLUDE$
* FTMENUTO.CH
* $SEEALSO$
*
* $END$
*/
#include "SETCURS.CH"
#include "INKEY.CH"
#xcommand if <true> then <action> => ;
if <true> ; <action> ; end
#xtranslate display( <row>, <col>, <stuff>, <color> ) => ;
setpos( <row>, <col> ) ; dispout( <stuff>, <color> )
#xtranslate EnhColor( <colorspec> ) => ;
substr( <colorspec>, at( ",", <colorspec> ) + 1 )
#xtranslate isOkay( <exp> ) => ;
( <exp> \> 0 .and. <exp> \<= nCount )
#xtranslate isBetween( <val>, <lower>, <upper> ) => ;
( <val> \>= <lower> .and. <val> \<= <upper> )
#define nTriggerInkey asc( upper( substr( cPrompt, nTrigger, 1 ) ) )
#define cTrigger substr( cPrompt, nTrigger, 1 )
#define nCurrent nMenu,nActive
#define nLast nMenu,nPrev
// These arrays hold information about each menu item
static aRow := {{}}
static aCol := {{}}
static aPrompt := {{}}
static aColor := {{}}
static aMsgRow := {{}}
static aMsgCol := {{}}
static aMessage := {{}}
static aMsgColor := {{}}
static aTrigger := {{}}
static aTriggerInkey := {{}}
static aTriggerColor := {{}}
static aHome := {{}}
static aEnd := {{}}
static aUp := {{}}
static aDown := {{}}
static aLeft := {{}}
static aRight := {{}}
static aExecute := {{}}
static nLevel := 1
function FT_Prompt( nRow, nCol, cPrompt, cColor, ;
nMsgRow, nMsgCol, cMessage, cMsgColor, ;
nTrigger, cTriggerColor, nHome, nEnd, ;
nUp, nDown, nLeft, nRight, bExecute )
// If the prompt color setting is not specified, use default
if cColor == NIL then cColor := setcolor()
// If no message is supplied, set message values to NIL
if cMessage == NIL
nMsgRow := nMsgCol := cMsgColor := NIL
else
// If message row not supplied, use the default
if nMsgRow == NIL then nMsgRow := set( _SET_MESSAGE )
// If message column not supplied, use the default
if nMsgCol == NIL
if set( _SET_MCENTER )
nMsgCol := int( ( maxcol() + 1 - len( cPrompt ) ) / 2 )
else
nMsgCol := 0
endif
endif
// If message color not specified, use the default
if cMsgColor == NIL then cMsgColor := cColor
endif
// If trigger values not specifed, set the defaults
if nTrigger == NIL then nTrigger := 1
if cTriggerColor == NIL then cTriggerColor := cColor
// Now add elements to the static arrays -- nLevel indicates the recursion
// level, which allows for nested menus.
aadd( aRow[ nLevel ], nRow )
aadd( aCol[ nLevel ], nCol )
aadd( aPrompt[ nLevel ], cPrompt )
aadd( aColor[ nLevel ], cColor )
aadd( aMsgRow[ nLevel ], nMsgRow )
aadd( aMsgCol[ nLevel ], nMsgCol )
aadd( aMessage[ nLevel ], cMessage )
aadd( aMsgColor[ nLevel ], cMsgColor )
aadd( aTrigger[ nLevel ], nTrigger )
aadd( aTriggerInkey[ nLevel ], nTriggerInkey )
aadd( aTriggerColor[ nLevel ], cTriggerColor )
aadd( aHome[ nLevel ], nHome )
aadd( aEnd[ nLevel ], nEnd )
aadd( aUp[ nLevel ], nUp )
aadd( aDown[ nLevel ], nDown )
aadd( aLeft[ nLevel ], nLeft )
aadd( aRight[ nLevel ], nRight )
aadd( aExecute[ nLevel ], bExecute )
// Now display the prompt for the sake of compatibility
dispbegin()
display( nRow, nCol, cPrompt, cColor )
display( nRow, nCol - 1 + nTrigger, cTrigger, cTriggerColor )
dispend()
return NIL
/* $DOC$
* $FUNCNAME$
* FT_MenuTo()
* $CATEGORY$
* Menus/Prompts
* $ONELINER$
* Execute light bar menu using prompts created with @...PROMPT
* $SYNTAX$
* #include "FTMENUTO.CH"
*
* MENU TO <var> [COLD]
* $ARGUMENTS$
* <var> is the name of the variable to which the result of the menu
* selection should be assigned.
*
* [COLD] is optional and if specified indicates that trigger characters
* should be treated as "cold," i.e. rather than causing the menu item
* to be selected it only causes the light bar to move to that selection.
* $DESCRIPTION$
* This enhanced version of MENU TO requires the inclusion of the header
* file FTMENUTO.CH in any source file that uses it. It may be used in
* place of the standard Clipper MENU TO command. However, in the
* interests of functionality it is NOT 100% compatible (in particular,
* you should make sure that the target memvar exists before executing
* the menu -- the Clipper version will create a PRIVATE memvar for you
* if it does not already exist, but this version does not). No whining!
* If compatibility is such a big deal then use the standard Clipper
* command.
*
* Note that this command can also be called using function-style
* syntax. See the entry for FT_MENUTO() for further details.
* $EXAMPLES$
* #include "FTMENUTO.CH"
*
* // Simple command
*
* MENU TO memvar
*
* $INCLUDE$
* FTMENUTO.CH
* $SEEALSO$
* FT_Prompt()
* $END$
*/
function FT_MenuTo( bGetSet, cReadVar, lCold )
local nMenu := nLevel++
local nActive := 1
local nCount := len( aRow[ nMenu ] )
local lChoice := .F.
local nCursor := set( _SET_CURSOR,SC_NONE )
local nKey,bKey,nScan,lWrap,cScreen,nPrev
// Validate the incoming parameters and assign some reasonable defaults
// to prevent a crash later.
cReadVar := iif( cReadVar == NIL, "", upper( cReadVar ) )
if bGetSet == NIL then bGetSet := {|| 1}
// Eval the incoming getset block to initialize nActive, which indicates
// the menu prompt which is to be active when the menu is first displayed.
// If nActive is outside the appropriate limits, a value of 1 is assigned.
nActive := eval( bGetSet )
if ( nActive < 1 .or. nActive > nCount ) then nActive := 1
// Increment the recursion level in case a hotkey procedure
// calls FT_Prompt(). This will cause a new set of prompts
// to be created without disturbing the current set.
aadd( aRow, {} )
aadd( aCol, {} )
aadd( aPrompt, {} )
aadd( aColor, {} )
aadd( aMsgRow, {} )
aadd( aMsgCol, {} )
aadd( aMessage, {} )
aadd( aMsgColor, {} )
aadd( aTrigger, {} )
aadd( aTriggerInkey, {} )
aadd( aTriggerColor, {} )
aadd( aUp, {} )
aadd( aDown, {} )
aadd( aLeft, {} )
aadd( aRight, {} )
aadd( aExecute, {} )
// Loop until Enter or Esc is pressed
while .not. lChoice
// Evaluate the getset block to update the target memory variable
// in case it needs to be examined by a hotkey procedure.
eval( bGetSet,nActive )
// Get the current setting of SET WRAP so that the desired menu behavior
// can be implemented.
lWrap := set( _SET_WRAP )
// If a message is to be displayed, save the current screen contents
// and then display the message, otherwise set the screen buffer to NIL.
dispbegin()
if aMessage[ nCurrent ] != NIL
cScreen := savescreen( aMsgRow[ nCurrent ], aMsgCol[ nCurrent ], ;
aMsgRow[ nCurrent ], aMsgCol[ nCurrent ] + ;
len( aMessage[ nCurrent ] ) - 1 )
display( aMsgRow[ nCurrent ], aMsgCol[ nCurrent ], ;
aMessage[ nCurrent ], aMsgColor[ nCurrent ] )
else
cScreen := NIL
endif
// Display the prompt using the designated colors for the prompt and
// the trigger character.
display( aRow[ nCurrent ], aCol[ nCurrent ], ;
aPrompt[ nCurrent ], EnhColor( aColor[ nCurrent ] ) )
display( aRow[ nCurrent ], ;
aCol[ nCurrent ] - 1 + aTrigger[ nCurrent ], ;
substr( aPrompt[ nCurrent ], aTrigger[ nCurrent ], 1 ), ;
EnhColor( aTriggerColor[ nCurrent ] ) )
dispend()
// Wait for a keystroke
nKey := inkey( 0 )
// If the key was an alphabetic char, convert to uppercase
if isBetween( nKey,97,122 ) then nKey -= 32
// Set nPrev to the currently active menu item
nPrev := nActive
do case
// Check for a hotkey, and evaluate the associated block if present.
case ( bKey := setkey( nKey ) ) != NIL
eval( bKey, ProcName( 1 ), ProcLine( 1 ), cReadVar )
// If Enter was pressed, either exit the menu or evaluate the
// associated code block.
case nKey == K_ENTER
if aExecute[ nCurrent ] != NIL
eval( aExecute[ nCurrent ] )
else
lChoice := .T.
endif
// If ESC was pressed, set the selected item to zero and exit.
case nKey == K_ESC
lChoice := .T.
nActive := 0
// If Home was pressed, go to the designated menu item.
case nKey == K_HOME
nActive := iif( aHome[ nCurrent ] == NIL, 1, aHome[ nCurrent ] )
// If End was pressed, go to the designated menu item.
case nKey == K_END
nActive := iif( aEnd[ nCurrent ] == NIL, nCount, aEnd[ nCurrent ] )
// If Up Arrow was pressed, go to the designated menu item.
case nKey == K_UP
if aUp[ nCurrent ] == NIL
if --nActive < 1 then nActive := iif( lWrap, nCount, 1 )
else
if isOkay( aUp[ nCurrent ] ) then nActive := aUp[ nCurrent ]
endif
// If Down Arrow was pressed, go to the designated menu item.
case nKey == K_DOWN
if aDown[ nCurrent ] == NIL
if ++nActive > nCount then nActive := iif( lWrap, 1, nCount )
else
if isOkay( aDown[ nCurrent ] ) then nActive := aDown[ nCurrent ]
endif
// If Left Arrow was pressed, go to the designated menu item.
case nKey == K_LEFT
if aLeft[ nCurrent ] == NIL
if --nActive < 1 then nActive := iif( lWrap, nCount, 1 )
else
if isOkay( aLeft[ nCurrent ] ) then nActive := aLeft[ nCurrent ]
endif
// If Right Arrow was pressed, go to the designated menu item.
case nKey == K_RIGHT
if aRight[ nCurrent ] == NIL
if ++nActive > nCount then nActive := iif( lWrap, 1, nCount )
else
if isOkay( aRight[ nCurrent ] ) then nActive := aRight[ nCurrent ]
endif
// If a trigger letter was pressed, handle it based on the COLD
// parameter.
case ( nScan := ascan( aTriggerInkey[ nMenu ], nKey ) ) > 0
nActive := nScan
if .not. lCold then FT_PutKey( K_ENTER )
endcase
// Erase the highlight bar in preparation for the next iteration
if .not. lChoice
dispbegin()
display( aRow[ nLast ], aCol[ nLast ], ;
aPrompt[ nLast ], aColor[ nLast ] )
display( aRow[ nLast ], aCol[ nLast ] - 1 + aTrigger[ nLast ], ;
substr( aPrompt[ nLast ], aTrigger[ nLast ], 1 ), ;
aTriggerColor[ nLast ] )
if cScreen != NIL then restscreen( aMsgRow[ nLast ], ;
aMsgCol[ nLast ], ;
aMsgRow[ nLast ], ;
aMsgCol[ nLast ] ;
+ len( aMessage[ nLast ] ) - 1, ;
cScreen )
dispend()
endif
end
// Now that we're exiting, decrement the recursion level and erase all
// the prompt information for the current invocation.
nLevel--
asize( aRow, nLevel )
asize( aCol, nLevel )
asize( aPrompt, nLevel )
asize( aColor, nLevel )
asize( aMsgRow, nLevel )
asize( aMsgCol, nLevel )
asize( aMessage, nLevel )
asize( aMsgColor, nLevel )
asize( aTrigger, nLevel )
asize( aTriggerInkey, nLevel )
asize( aTriggerColor, nLevel )
asize( aUp, nLevel )
asize( aDown, nLevel )
asize( aLeft, nLevel )
asize( aRight, nLevel )
asize( aExecute, nLevel )
aRow[ nLevel ] := {}
aCol[ nLevel ] := {}
aPrompt[ nLevel ] := {}
aColor[ nLevel ] := {}
aMsgRow[ nLevel ] := {}
aMsgCol[ nLevel ] := {}
aMessage[ nLevel ] := {}
aMsgColor[ nLevel ] := {}
aTrigger[ nLevel ] := {}
aTriggerInkey[ nLevel ] := {}
aTriggerColor[ nLevel ] := {}
aUp[ nLevel ] := {}
aDown[ nLevel ] := {}
aLeft[ nLevel ] := {}
aRight[ nLevel ] := {}
aExecute[ nLevel ] := {}
set( _SET_CURSOR, nCursor )
eval( bGetSet, nActive )
return nActive

389
harbour/contrib/libnf/metaph.prg Normal file
View File

@@ -0,0 +1,389 @@
/*
* File......: METAPH.PRG
* Author....: Dave Adams
* CIS ID....: ?
*
* This is an original work by Dave Adams and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:04:00 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:20 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:01:44 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_METAPH()
* $CATEGORY$
* String
* $ONELINER$
* Convert a character string to MetaPhone format
* $SYNTAX$
* FT_METAPH( <cName> [, <nSize> ] ) -> cMetaPhone
* $ARGUMENTS$
* <cName> is the character string to convert
* <nSize> is the length of the character string to be returned.
* If not specified the default length is 4 bytes.
* $RETURNS$
* A phonetically spelled character string
* $DESCRIPTION$
* This function is a character function use to index and search for
* sound-alike or phonetic matches. It is an alternative to
* the SOUNDEX() function, and addresses some basic pronunciation
* rules, by looking at surrounding letters to determine how parts of
* the string are pronounced. FT_METAPH() will group sound-alikes
* together, and forgive shortcomings in spelling ability.
* $EXAMPLES$
* USE Persons
* INDEX ON FT_METAPH( LastName ) TO LastName
* SEEK FT_METAPH( "Philmore" )
* ? FOUND(), LastName // Result: .T. Philmore
* SEEK FT_METAPH( "Fillmore" )
* ? FOUND(), LastName // Result: .T. Philmore
* $END$
*/
/*
* File Contents
*
* FT_METAPH() Calculates the metaphone of a name
* _ftMakeAlpha() Removes non-alpha characters from a string
* _ftConvVowel() Converts all vowels to the letter 'v'
*
*
* Commentary
*
* The concepts for this algoritm were adapted from an article in the
* Computer Language Magazine (Dec.90, Vol.7, No.12) written by
* Lawrence B.F. Phillips.
*
* The STRTRAN function was selected to calculate the MetaPhone, to
* allow the algoritm to be fine-tuned in an easy manner, as there are
* always exceptions to any phonetic pronunciation in not only English,
* but many other languages as well.
*
* What is a metaphone?
* Basically it takes a character string, removes the vowels, and equates
* letters (or groups of letters) to other consonent sounds. The vowels
* are not removed until near the end, as they play an important part
* in determining how some consonents sound in different surroundings.
*
* The consonant sounds are: B, F, H, J, K, L, M, N, P, R, S, T, W, X, Y, 0
* Vowels are only included if they are at the beginning.
* Here are the transformations. The order of evaluation is important
* as characters may meet more than one transformation conditions.
* ( note: v = vowel )
*
* B --> B unless at end of a word after 'm' as in dumb.
* C --> X (sh) CIA, TCH, CH, ISCH, CC
* S SCI, SCE, SCY, CI, CE, CY
* K otherwise ( including CK )
* D --> J DGE, DGY, DGI
* T otherwise
* F --> F
* G --> K GHv, vGHT
* W vGH
* J DGE, DGY, DGI, GI, GE, GY
* N GN
* K otherwise
* H --> H vHv
* otherwise silent
* J --> J
* K --> K
* L --> L
* M --> M
* N --> N
* P --> F PH
* P otherwise
* Q --> K
* R --> R
* S --> X (sh) SH, SIO, SIA, ISCH
* S otherwise
* T --> X (sh) TIA, TIO, TCH
* 0 (th) TH
* T otherwise
* V --> F
* W --> W
* X --> KS
* Y --> vY
* Y otherwise
* Z --> S
*
*/
*------------------------------------------------
// Demo of FT_METAPH()
// #define FT_TEST .T.
#IFDEF FT_TEST
FUNCTION MAIN()
LOCAL cJunk := SPACE( 8000 )
LOCAL aNames := {}
LOCAL cName, nElem
SET( _SET_SCOREBOARD, .F. )
SET( _SET_COLOR, "W/B" )
CLS
// Demo will create an array of names and display in 3 columns
// _ftRow() and _ftCol() will calculate the screen co-ordinates
// by evaluating the element number
AADD( aNames, "Adams" )
AADD( aNames, "Addams" )
AADD( aNames, "Atoms" )
AADD( aNames, "Adamson" )
AADD( aNames, "Cajun" )
AADD( aNames, "Cagen" )
AADD( aNames, "Cochy" )
AADD( aNames, "Cocci" )
AADD( aNames, "Smith" )
AADD( aNames, "Smythe" )
AADD( aNames, "Naylor" )
AADD( aNames, "Nailer" )
AADD( aNames, "Holberry" )
AADD( aNames, "Wholebary" )
AADD( aNames, "Jackson" )
AADD( aNames, "Jekksen" )
AADD( aNames, "The Source" )
AADD( aNames, "The Sores" )
AADD( aNames, "Jones" )
AADD( aNames, "Johns" )
AADD( aNames, "Lennon" )
AADD( aNames, "Lenin" )
AADD( aNames, "Fischer" )
AADD( aNames, "Fisher" )
AADD( aNames, "O'Donnell" )
AADD( aNames, "O Donald" )
AADD( aNames, "Pugh" )
AADD( aNames, "Pew" )
AADD( aNames, "Heimendinger" )
AADD( aNames, "Hymendinker" )
AADD( aNames, "Knight" )
AADD( aNames, "Nite" )
AADD( aNames, "Lamb" )
AADD( aNames, "Lamb Chops" )
AADD( aNames, "Stephens" )
AADD( aNames, "Stevens" )
AADD( aNames, "Neilson" )
AADD( aNames, "Nelson" )
AADD( aNames, "Tchaikovski" )
AADD( aNames, "Chikofski" )
AADD( aNames, "Caton" )
AADD( aNames, "Wright" )
AADD( aNames, "Write" )
AADD( aNames, "Right" )
AADD( aNames, "Manual" )
AADD( aNames, "Now" )
AADD( aNames, "Wheatabix" )
AADD( aNames, "Science" )
AADD( aNames, "Cinzano" )
AADD( aNames, "Lucy" )
AADD( aNames, "Reece" )
AADD( aNames, "Righetti" )
AADD( aNames, "Oppermann" )
AADD( aNames, "Bookkeeper" )
AADD( aNames, "McGill" )
AADD( aNames, "Magic" )
AADD( aNames, "McLean" )
AADD( aNames, "McLane" )
AADD( aNames, "Maclean" )
AADD( aNames, "Exxon" )
// display names and metaphones in 3 columns on screen
AEVAL( aNames, ;
{ | cName, nElem | ;
SETPOS( _ftRow( nElem ), _ftCol( nElem ) ), ;
QQOUT( PadR( cName, 18, "." ) + FT_METAPH( cName ) ) ;
} )
SETPOS( 21, 00 )
QUIT
*------------------------------------------------
STATIC FUNCTION _ftRow( nElem ) // Determine which row to print on
RETURN IIF( nElem > 40, nElem - 40, IIF( nElem > 20, nElem - 20, nElem ) )
*------------------------------------------------
STATIC FUNCTION _ftCol( nElem ) // Determine which column to start print
RETURN IIF( nElem > 40, 55, IIF( nElem > 20, 28, 1 ) )
*------------------------------------------------
#endif
// End of Test program
*------------------------------------------------
FUNCTION FT_METAPH ( cName, nSize )
// Calculates the metaphone of a character string
LOCAL cMeta
cName := IIF( cName == NIL, "", cName ) // catch-all
nSize := IIF( nSize == NIL, 4, nSize ) // default size: 4-bytes
// Remove non-alpha characters and make upper case.
// The string is padded with 1 space at the beginning & end.
// Spaces, if present inside the string, are not removed until all
// the prefix/suffix checking has been completed.
cMeta := " " + _ftMakeAlpha( UPPER( ALLTRIM( cName ) ) ) + " "
// prefixes which need special consideration
IF " KN" $ cMeta ; cMeta := STRTRAN( cMeta, " KN" , " N" ) ; ENDIF
IF " GN" $ cMeta ; cMeta := STRTRAN( cMeta, " GN" , " N" ) ; ENDIF
IF " PN" $ cMeta ; cMeta := STRTRAN( cMeta, " PN" , " N" ) ; ENDIF
IF " AE" $ cMeta ; cMeta := STRTRAN( cMeta, " AE" , " E" ) ; ENDIF
IF " X" $ cMeta ; cMeta := STRTRAN( cMeta, " X" , " S" ) ; ENDIF
IF " WR" $ cMeta ; cMeta := STRTRAN( cMeta, " WR" , " R" ) ; ENDIF
IF " WHO" $ cMeta ; cMeta := STRTRAN( cMeta, " WHO", " H" ) ; ENDIF
IF " WH" $ cMeta ; cMeta := STRTRAN( cMeta, " WH" , " W" ) ; ENDIF
IF " MCG" $ cMeta ; cMeta := STRTRAN( cMeta, " MCG", " MK" ) ; ENDIF
IF " MC" $ cMeta ; cMeta := STRTRAN( cMeta, " MC" , " MK" ) ; ENDIF
IF " MACG" $ cMeta ; cMeta := STRTRAN( cMeta, " MACG"," MK" ) ; ENDIF
IF " MAC" $ cMeta ; cMeta := STRTRAN( cMeta, " MAC", " MK" ) ; ENDIF
IF " GI" $ cMeta ; cMeta := STRTRAN( cMeta, " GI", " K" ) ; ENDIF
// Suffixes which need special consideration
IF "MB " $ cMeta ; cMeta := STRTRAN( cMeta, "MB " , "M " ) ; ENDIF
IF "NG " $ cMeta ; cMeta := STRTRAN( cMeta, "NG " , "N " ) ; ENDIF
// Remove inner spaces (1st and last byte are spaces)
IF " " $ SUBSTR( cMeta, 2, LEN( cMeta ) - 2 )
cMeta := " " + STRTRAN( cMeta, " " , "" ) + " "
ENDIF
// Double consonants sound much the same as singles
IF "BB" $ cMeta ; cMeta := STRTRAN( cMeta, "BB" , "B" ) ; ENDIF
IF "CC" $ cMeta ; cMeta := STRTRAN( cMeta, "CC" , "CH" ) ; ENDIF
IF "DD" $ cMeta ; cMeta := STRTRAN( cMeta, "DD" , "T" ) ; ENDIF
IF "FF" $ cMeta ; cMeta := STRTRAN( cMeta, "FF" , "F" ) ; ENDIF
IF "GG" $ cMeta ; cMeta := STRTRAN( cMeta, "GG" , "K" ) ; ENDIF
IF "KK" $ cMeta ; cMeta := STRTRAN( cMeta, "KK" , "K" ) ; ENDIF
IF "LL" $ cMeta ; cMeta := STRTRAN( cMeta, "LL" , "L" ) ; ENDIF
IF "MM" $ cMeta ; cMeta := STRTRAN( cMeta, "MM" , "M" ) ; ENDIF
IF "NN" $ cMeta ; cMeta := STRTRAN( cMeta, "NN" , "N" ) ; ENDIF
IF "PP" $ cMeta ; cMeta := STRTRAN( cMeta, "PP" , "P" ) ; ENDIF
IF "RR" $ cMeta ; cMeta := STRTRAN( cMeta, "RR" , "R" ) ; ENDIF
IF "SS" $ cMeta ; cMeta := STRTRAN( cMeta, "SS" , "S" ) ; ENDIF
IF "TT" $ cMeta ; cMeta := STRTRAN( cMeta, "TT" , "T" ) ; ENDIF
IF "XX" $ cMeta ; cMeta := STRTRAN( cMeta, "XX" , "KS" ) ; ENDIF
IF "ZZ" $ cMeta ; cMeta := STRTRAN( cMeta, "ZZ" , "S" ) ; ENDIF
// J sounds
IF "DGE" $ cMeta ; cMeta := STRTRAN( cMeta, "DGE" , "J" ) ; ENDIF
IF "DGY" $ cMeta ; cMeta := STRTRAN( cMeta, "DGY" , "J" ) ; ENDIF
IF "DGI" $ cMeta ; cMeta := STRTRAN( cMeta, "DGI" , "J" ) ; ENDIF
IF "GI" $ cMeta ; cMeta := STRTRAN( cMeta, "GI" , "J" ) ; ENDIF
IF "GE" $ cMeta ; cMeta := STRTRAN( cMeta, "GE" , "J" ) ; ENDIF
IF "GY" $ cMeta ; cMeta := STRTRAN( cMeta, "GY" , "J" ) ; ENDIF
// X sounds (KS)
IF "X" $ cMeta ; cMeta := STRTRAN( cMeta, "X" , "KS" ) ; ENDIF
// special consideration for SCH
IF "ISCH" $ cMeta; cMeta := STRTRAN( cMeta, "ISCH", "IX" ) ; ENDIF
IF "SCH" $ cMeta ; cMeta := STRTRAN( cMeta, "SCH" , "SK" ) ; ENDIF
// sh sounds (X)
IF "CIA" $ cMeta ; cMeta := STRTRAN( cMeta, "CIA" , "X" ) ; ENDIF
IF "SIO" $ cMeta ; cMeta := STRTRAN( cMeta, "SIO" , "X" ) ; ENDIF
IF "C" $ cMeta ; cMeta := STRTRAN( cMeta, "SIA" , "X" ) ; ENDIF
IF "SH" $ cMeta ; cMeta := STRTRAN( cMeta, "SH" , "X" ) ; ENDIF
IF "TIA" $ cMeta ; cMeta := STRTRAN( cMeta, "TIA" , "X" ) ; ENDIF
IF "TIO" $ cMeta ; cMeta := STRTRAN( cMeta, "TIO" , "X" ) ; ENDIF
IF "TCH" $ cMeta ; cMeta := STRTRAN( cMeta, "TCH" , "X" ) ; ENDIF
IF "CH" $ cMeta ; cMeta := STRTRAN( cMeta, "CH" , "X" ) ; ENDIF
// hissing sounds (S)
IF "SCI" $ cMeta ; cMeta := STRTRAN( cMeta, "SCI" , "S" ) ; ENDIF
IF "SCE" $ cMeta ; cMeta := STRTRAN( cMeta, "SCE" , "S" ) ; ENDIF
IF "SCY" $ cMeta ; cMeta := STRTRAN( cMeta, "SCY" , "S" ) ; ENDIF
IF "CI" $ cMeta ; cMeta := STRTRAN( cMeta, "CI" , "S" ) ; ENDIF
IF "CE" $ cMeta ; cMeta := STRTRAN( cMeta, "CE" , "S" ) ; ENDIF
IF "CY" $ cMeta ; cMeta := STRTRAN( cMeta, "CY" , "S" ) ; ENDIF
IF "Z" $ cMeta ; cMeta := STRTRAN( cMeta, "Z" , "S" ) ; ENDIF
// th sound (0)
IF "TH" $ cMeta ; cMeta := STRTRAN( cMeta, "TH" , "0" ) ; ENDIF
// Convert all vowels to 'v' from 3rd byte on
cMeta := LEFT( cMeta, 2 ) + _ftConvVowel( SUBSTR( cMeta, 3 ) )
// Make Y's silent if not followed by vowel
IF "Y" $ cMeta
cMeta := STRTRAN( cMeta, "Yv" , "#" ) // Y followed by vowel
cMeta := STRTRAN( cMeta, "Y" , "" ) // not followed by vowel
cMeta := STRTRAN( cMeta, "#" , "Yv" ) // restore Y and vowel
ENDIF
// More G sounds, looking at surrounding vowels
IF "GHv" $ cMeta ; cMeta := STRTRAN( cMeta, "GHv" , "G" ) ; ENDIF
IF "vGHT" $ cMeta; cMeta := STRTRAN( cMeta, "vGHT", "T" ) ; ENDIF
IF "vGH" $ cMeta ; cMeta := STRTRAN( cMeta, "vGH" , "W" ) ; ENDIF
IF "GN" $ cMeta ; cMeta := STRTRAN( cMeta, "GN" , "N" ) ; ENDIF
IF "G" $ cMeta ; cMeta := STRTRAN( cMeta, "G" , "K" ) ; ENDIF
// H sounds, looking at surrounding vowels
IF "vHv" $ cMeta ; cMeta := STRTRAN( cMeta, "vHv" , "H" ) ; ENDIF
IF "vH" $ cMeta ; cMeta := STRTRAN( cMeta, "vH" , "" ) ; ENDIF
// F sounds
IF "PH" $ cMeta ; cMeta := STRTRAN( cMeta, "PH" , "F" ) ; ENDIF
IF "V" $ cMeta ; cMeta := STRTRAN( cMeta, "V" , "F" ) ; ENDIF
// D sounds a bit like T
IF "D" $ cMeta ; cMeta := STRTRAN( cMeta, "D" , "T" ) ; ENDIF
// K sounds
IF "CK" $ cMeta ; cMeta := STRTRAN( cMeta, "CK" , "K" ) ; ENDIF
IF "Q" $ cMeta ; cMeta := STRTRAN( cMeta, "Q" , "K" ) ; ENDIF
IF "C" $ cMeta ; cMeta := STRTRAN( cMeta, "C" , "K" ) ; ENDIF
// Remove vowels
cMeta := STRTRAN( cMeta, "v", "" )
RETURN PadR( ALLTRIM( cMeta ), nSize )
*------------------------------------------------
STATIC FUNCTION _ftMakeAlpha ( cStr )
// Strips non-alpha characters from a string, leaving spaces
LOCAL x, cAlpha := ""
FOR x := 1 to LEN( cStr )
IF SUBSTR( cStr, x, 1 ) == " " .OR. ISALPHA( SUBSTR( cStr, x, 1 ) )
cAlpha := cAlpha + SUBSTR( cStr, x, 1 )
ENDIF
NEXT
RETURN cAlpha
*------------------------------------------------
STATIC FUNCTION _ftConvVowel ( cStr )
// Converts all vowels to letter 'v'
LOCAL x, cConverted := ""
FOR x := 1 to LEN( cStr )
IF SUBSTR( cStr, x, 1 ) $ "AEIOU"
cConverted := cConverted + "v"
ELSE
cConverted := cConverted + SUBSTR( cStr, x, 1 )
ENDIF
NEXT
RETURN cConverted
*------------------------------------------------
// eof metaph.prg

280
harbour/contrib/libnf/miltime.prg Normal file
View File

@@ -0,0 +1,280 @@
/*
* File......: MILTIME.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:04:02 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:22 GLENN
* Minor edit to file header
*
* Rev 1.0 14 Jun 1991 03:43:52 GLENN
* Initial revision.
*
*/
#ifdef FT_TEST
function main()
cls
? "am-pm"
? ft_civ2mil(" 5:40 pm")
? ft_civ2mil("05:40 pm")
? ft_civ2mil(" 5:40 PM")
? ft_civ2mil(" 5:40 am")
? ft_civ2mil("05:40 am")
? ft_civ2mil(" 5:40 AM")
?
inkey(0)
cls
? "noon-midnight"
? ft_civ2mil("12:00 m")
? ft_civ2mil("12:00 M")
? ft_civ2mil("12:00 m")
? ft_civ2mil("12:00 n")
? ft_civ2mil("12:00 N")
? ft_civ2mil("12:00 n")
?
inkey(0)
cls
? "errors in noon-midnight"
? ft_civ2mil("12:01 n")
? ft_civ2mil("22:00 n")
? ft_civ2mil("12:01 m")
? ft_civ2mil("22:00 n")
?
? "sys to mil"
? time()
? ft_sys2mil()
return nil
#endif
/* $DOC$
* $FUNCNAME$
* FT_MIL2MIN()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Convert time in military format to number of minute of day.
* $SYNTAX$
* FT_MIL2MIN( <cMILTIME> ) -> nMINUTE
* $ARGUMENTS$
* <cMILTIME> character string of form hhmm, where 0<=hh<24.
* $RETURNS$
* <nMINOFDAY> numeric value representing minute of day.
* $DESCRIPTION$
* Converts time in military format to number of minute of the day.
* $EXAMPLES$
* FT_MIL2MIN( "1729" ) -> 1049
* $SEEALSO$
* FT_MIN2MIL() FT_CIV2MIL() FT_MIL2CIV() FT_SYS2MIL()
* $END$
*/
function FT_MIL2MIN(cMILTIME)
return int(val(left(cMILTIME,2))*60 + val(right(cMILTIME,2)))
/* $DOC$
* $FUNCNAME$
* FT_MIN2MIL()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Convert minute of day to military format time.
* $SYNTAX$
* FT_MIN2MIL( <nMINUTE> ) -> cMILTIME
* $ARGUMENTS$
* <nMINUTE> numeric integer representing minute of day.
* $RETURNS$
* <cMILTIME> character string of form hhmm, where 0<=hh<24.
* $DESCRIPTION$
* Converts minute of the day to military format time.
* $EXAMPLES$
* FT_MIN2MIL( 279 ) -> 0439
* $SEEALSO$
* FT_MIL2MIN() FT_MIL2CIV() FT_CIV2MIL() FT_SYS2MIL()
* $END$
*/
function FT_MIN2MIL(nMIN)
nMIN := nMIN%1440
return right("00" + ltrim(str(INT(nMIN/60))),2) + ;
right("00" + ltrim(str(INT(nMIN%60))),2)
/* $DOC$
* $FUNCNAME$
* FT_MIL2CIV()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Convert time in military format to civilian format.
* $SYNTAX$
* FT_MIL2CIV( <cCIVTIME> ) -> dMILTIME
* $ARGUMENTS$
* <cMILTIME> character string of form hhmm, where 0<=hh<24.
* $RETURNS$
* <cCIVTIME> character string of form hh:mm (am,pm,n or m),
* where 0<hh<12.
* $DESCRIPTION$
* Converts time from military to civilian format
* $EXAMPLES$
* FT_MIL2CIV( "1640" ) -> 4:40 pm
*
* FT_MIL2CIV( "0440" ) -> 4:40 am
*
* FT_MIL2CIV( "1200" ) -> 12:00 n
*
* FT_MIL2CIV( "0000" ) and FT_MIL2CIV( "2400" ) -> 12:00 m
*
* Caution: leading blanks are irrelevant.
* $SEEALSO$
* FT_CIV2MIL() FT_SYS2MIL() FT_MIL2MIN() FT_MIN2MIL()
* $END$
*/
function FT_MIL2CIV(cMILTIME)
local cHRS,cMINS,nHRS,cCIVTIME
nHRS := val(LEFT(cMILTIME,2))
cMINS := right(cMILTIME,2)
do case
case (nHRS == 24 .OR. nHRS == 0) .AND. (cMINS == "00") // Midnight
cCIVTIME = "12:00 m"
case (nHRS == 12) // Noon to 12:59pm
if cMINS == "00"
cCIVTIME = "12:00 n"
else
cCIVTIME = "12:" + cMINS + " pm"
endif
case (nHRS < 12) && AM
if nHRS == 0
cHRS = "12"
else
cHRS = right(" " + ltrim(str(int(nHRS))),2)
endif
cCIVTIME = cHRS + ":" + cMINS + " am"
otherwise && PM
cCIVTIME = right(" " + ltrim(str(int(nHRS - 12))), 2) + ;
":" + cMINS + " pm"
endcase
return cCIVTIME
/* $DOC$
* $FUNCNAME$
* FT_CIV2MIL()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Convert usual civilian format time to military time.
* $SYNTAX$
* FT_CIV2MIL( <cCIVTIME> ) -> cMILTIME
* $ARGUMENTS$
* <cCIVTIME> character string of form hh:mm (am,pm,n or m),
* where 0<hh<12.
* $RETURNS$
* <cMILTIME> character string of form hhmm, where 0<=hh<24.
* $DESCRIPTION$
* Converts time from 12-hour civilian format to military.
* $EXAMPLES$
* FT_CIV2MIL( " 5:40 pm" ) -> 1740
*
* FT_CIV2MIL( " 5:40 am" ) -> 0540
*
* FT_CIV2MIL( "12:00 n" ) -> 1200
*
* FT_CIV2MIL( "12:00 m" ) -> 0000
*
* Caution: leading blanks are irrelevant; p,a,n,m must be preceded by
* one and only one space.
* $SEEALSO$
* FT_MIL2CIV() FT_SYS2MIL() FT_MIL2MIN() FT_MIN2MIL()
* $END$
*/
function FT_CIV2MIL(cTIME)
local cKEY, cMILTIME
*** Insure leading 0's
cTIME = REPLICATE("0", 3 - at(":", ltrim(cTIME))) + ltrim(cTIME)
*** Adjust for popular use of '12' for first hour after noon and midnight
if left(ltrim(cTIME),2) == "12"
cTIME = stuff(cTIME, 1, 2, "00")
endif
*** am, pm, noon or midnight
cKEY = substr(ltrim(cTIME), 7, 1)
do case
case upper(cKEY) == "N" && noon
if left(cTIME,2) + substr(cTIME,4,2) == "0000"
cMILTIME = "1200"
else
cMILTIME = " "
endif
case upper(cKEY) == "M" && midnight
if left(cTIME,2) + substr(cTIME,4,2) == "0000"
cMILTIME = "0000"
else
cMILTIME = " "
endif
case upper(cKEY) == "A" && am
cMILTIME = right("00" + ltrim(str(val(left(cTIME,2)))),2) + ;
substr(cTIME,4,2)
case upper(cKEY) == "P" && pm
cMILTIME = right("00" + ltrim(str(val(left(cTIME,2))+12)),2) + ;
substr(cTIME,4,2)
otherwise
cMILTIME = " " && error
endcase
return cMILTIME
/* $DOC$
* $FUNCNAME$
* FT_SYS2MIL()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Convert system time to military time format.
* $SYNTAX$
* FT_SYS2MIL() -> cMILTIME
* $ARGUMENTS$
* none
* $RETURNS$
* <cMILTIME> character string of form hhmm, where 0<=hh<24.
* $DESCRIPTION$
* Return current system time as character string in military format.
* $EXAMPLES$
* FT_SYS2MIL() -> 1623
* $SEEALSO$
* FT_MIL2CIV() FT_CIV2MIL()
* $END$
*/
function FT_SYS2MIL()
return left(stuff(time(),3,1,""),4)

58
harbour/contrib/libnf/min2dhm.prg Normal file
View File

@@ -0,0 +1,58 @@
/*
* File......: MIN2DHM.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.3 17 Aug 1991 15:33:50 GLENN
* Don Caton fixed some spelling errors in the doc
*
* Rev 1.2 15 Aug 1991 23:04:46 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:26 GLENN
* Minor edit to file header
*
* Rev 1.0 07 Jun 1991 23:39:50 GLENN
* Initial revision.
*
*/
/* $DOC$
* $FUNCNAME$
* FT_MIN2DHM()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Convert numeric minutes to days, hours and minutes.
* $SYNTAX$
* FT_MIN2DHM( <nMinutes> ) -> aDHM_
* $ARGUMENTS$
* <nMinutes> the number of minutes.
* $RETURNS$
* <aDHM_>
* where:
* aDHM_[1] = cDAYS, aDHM_[2] = cHours, aDHM_[3] = cMinutes
* $DESCRIPTION$
* Converts numeric minutes into a character array containing
* days, hours & minutes.
* $EXAMPLES$
* aDHM_ = MIN2DHM(16789) -> aDHM_[1] = 11, aDHM_[2] = 15, aDHM_[3] = 49
* $END$
*/
function FT_MIN2DHM(nMINS)
local aDHM_[3]
aDHM_[1] = ltrim((str(int(nMINS/1440))))
aDHM_[2] = ltrim(str(int((nMINS%1440)/60)))
aDHM_[3] = ltrim(str(int((nMINS%1440)%60)))
return aDHM_

105
harbour/contrib/libnf/mkdir.c Normal file
View File

@@ -0,0 +1,105 @@
/*
* $Id$
*/
/*; File......: MKDIR.ASM
; Author....: Ted Means
; CIS ID....: 73067,3332
;
; This is an original work by Ted Means and is placed in the
; public domain.
;
; Modification history:
; ---------------------
;
; Rev 1.2 15 Aug 1991 23:06:58 GLENN
; Forest Belt proofread/edited/cleaned up doc
;
; Rev 1.1 14 Jun 1991 19:54:44 GLENN
; Minor edit to file header
;
; Rev 1.0 01 Apr 1991 01:03:32 GLENN
; Nanforum Toolkit
;
;
*/
/* $DOC$
* $FUNCNAME$
* FT_MKDIR()
* $CATEGORY$
* DOS/BIOS
* $ONELINER$
* Create a subdirectory
* $SYNTAX$
* FT_MKDIR( <cDirName> ) -> nResult
* $ARGUMENTS$
* <cDirName> is the name of the directory to create.
* $RETURNS$
* 0 if successful
* 3 if Path Not Found
* 5 if Access Denied or directory already exists
* 99 if invalid parameters passed
* $DESCRIPTION$
* Use this function to create the subdirectories needed by your
* application. It might be especially useful in an installation
* program.
*
* The source code is written to adhere to Turbo Assembler's IDEAL mode.
* To use another assembler, you will need to rearrange the PROC and
* SEGMENT directives, and also the ENDP and ENDS directives (a very
* minor task).
* $EXAMPLES$
* FT_MKDIR( "C:\CLIPPER" )
* FT_MKDIR( "\EXAMPLE" )
* FT_MKDIR( "..\SOURCE" )
* $END$
*/
/*This is the Original FT_CHDIR() code
IDEAL
MODEL HUGE
Public _HB_FUN_FT_MKDIR
Extrn _hb_ftdir:Far
Segment _NanFor Word Public "CODE"
Assume CS:_NanFor
Proc _HB_FUN_FT_MKDIR Far
Mov AH,39h * DOS service--create directory
Push AX * Save on stack
Call _hb_ftdir * Call generic directory routine
Add SP,2 * Realign stack
Ret
Endp _HB_FUN_FT_MKDIR
Ends _NanFor
End
*/
/* This is the New one Rewriten in C*/
#include "hbapi.h"
#include "dos.h"
HB_FUNC(FT_MKDIR)
{
#if defined(HB_OS_DOS)
{
int Status;
char *path=hb_parc(1);
union REGS regs;
struct SREGS sregs;
segread(&sregs);
regs.h.ah=0x39;
sregs.ds=FP_SEG(path);
regs.HB_XREGS.dx=FP_OFF(path);
int86x(0x21,&regs,&regs,&sregs);
Status=regs.HB_XREGS.ax;
hb_retni(Status);
}
#endif
}

110
harbour/contrib/libnf/month.prg Normal file
View File

@@ -0,0 +1,110 @@
/*
* File......: MONTH.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:40:00 GLENN
* Jo French cleaned up.
*
* Rev 1.2 15 Aug 1991 23:05:42 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:28 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:01:46 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_MONTH()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Return Calendar or Fiscal Month Data
* $SYNTAX$
* FT_MONTH( [ <dGivenDate> ], [nMonthNum] ) -> aDateInfo
* $ARGUMENTS$
* <dGivenDate> is any valid date in any date format. Defaults
* to current system date if not supplied.
*
* <nMonthNum> 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 month
* aDateInfo[3] - The ending date of the month
* $DESCRIPTION$
* FT_MONTH() returns an array containing data about the month
* containing the given date.
*
* Normally the return data will be based on a year beginning
* on January 1st with weeks beginning on Sunday.
*
* The beginning of year date and/or beginning of week day can be
* changed by using FT_DATECNFG(), which will affect all subsequent
* calls to FT_MONTH() until another call to FT_DATECNFG().
*
* The beginning of year date and beginning of week day may be reset
* to January 1 and Sunday by calling FT_DATECNFG() with no
* parameters.
* $EXAMPLES$
* // get info about month containing 9/15/90
* aDateInfo := FT_MONTH( CTOD("09/15/90") )
* ? aDateInfo[1] // 199009 (9th month)
* ? aDateInfo[2] // 09/01/90 beginning of month 9
* ? aDateInfo[3] // 09/30/90 end of week month 9
*
* // get info about month 5 in year containing 9/15/90
* aDateInfo := FT_MONTH( CTOD("09/15/90"), 5 )
* ? aDateInfo[1] // 199005
* ? aDateInfo[2] // 05/01/90 beginning of month 5
* ? aDateInfo[3] // 05/31/90 end of month 5
*
* // get info about month 5 in current year (1991)
* aDateInfo := FT_MONTH( , 5 )
* ? aDateInfo[1] // 199105
* ? aDateInfo[2] // 05/01/91 beginning of month 5
* ? aDateInfo[3] // 05/31/91 end of month 5
* $SEEALSO$
* FT_DATECNFG() FT_WEEK() FT_QTR() FT_YEAR()
* $END$
*/
FUNCTION FT_MONTH( dGivenDate, nMonthNum )
LOCAL lIsMonth, nTemp, aRetVal
IF !( VALTYPE(dGivenDate) $ 'ND')
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'N'
nMonthNum := dGivenDate
dGivenDate := DATE()
ENDIF
aRetVal := FT_YEAR(dGivenDate)
lIsMonth := ( VALTYPE(nMonthNum) == 'N' )
IF lISMonth
IF( nMonthNum < 1 .OR. nMonthNum > 12, nMonthNum := 12, )
dGivenDate := FT_MADD(aRetVal[2], nMonthNum - 1)
ENDIF
nTemp := MONTH( dGivenDate ) - MONTH( aRetVal[2] )
nTemp += IF(nTemp >= 0, 1, 13)
aRetVal[1] += PADL(LTRIM(STR(nTemp, 2)), 2, '0')
aRetVal[2] := FT_MADD( aRetVal[2], nTemp - 1 )
aRetVal[3] := FT_MADD( aRetVal[2], 1 ) - 1
RETURN aRetVal

555
harbour/contrib/libnf/mouse.c Normal file
View File

@@ -0,0 +1,555 @@
/*
* $Id$
*/
/*
Harbour Project source code
mouse.c Support functions for Nanfor Library
Copyright 2000 Luiz Rafael Culik <Culik@sl.conex.net>
www - http://www.harbour-project.org
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version, with one exception:
The exception is that if you link the Harbour Runtime Library (HRL)
and/or the Harbour Virtual Machine (HVM) with other files to produce
an executable, this does not by itself cause the resulting executable
to be covered by the GNU General Public License. Your use of that
executable is in no way restricted on account of linking the HRL
and/or HVM code into it.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA (or visit
their web site at http://www.gnu.org/).
*/
#include "extend.h"
#include "dos.h"
#include "hbapiitm.h"
#include "hbapigt.h"
HB_FUNC(_MGET_PAGE)
{
int iPage;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=0x1E;
HB_DOS_INT86(0x33,&regs,&regs);
}
#else
{
iPage=0;
}
#endif
{
hb_retni(iPage);
}
}
HB_FUNC(_MSET_PAGE)
{
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=0x1D;
regs.HB_XREGS.bx=hb_parni(1);
HB_DOS_INT86(0x33,&regs,&regs);
}
#endif
}
HB_FUNC(_MGET_MVERSION)
{
int iMinor;
int iType;
int iIRQ;
int iMajor;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax = 0x24;
HB_DOS_INT86( 0x33, &regs, &regs );
iMinor = regs.h.bl;
iType = regs.h.ch;
iIRQ = regs.h.cl;
iMajor = regs.h.bh;
}
#else
{
iMinor = 0;
iType = 0;
iIRQ = 0;
iMajor = 0;
}
#endif
{
PHB_ITEM pArray = hb_itemArrayNew( 4 );
PHB_ITEM pMinor = hb_itemPutNI( NULL, iMinor );
PHB_ITEM pType = hb_itemPutNI( NULL, iType );
PHB_ITEM pIRQ = hb_itemPutNI( NULL, iIRQ );
PHB_ITEM pMajor = hb_itemPutNI( NULL, iMajor );
hb_itemArrayPut( pArray, 1, pMinor );
hb_itemArrayPut( pArray, 2, pType );
hb_itemArrayPut( pArray, 3, pIRQ );
hb_itemArrayPut( pArray, 4, pMajor );
hb_itemReturn( pArray );
hb_itemRelease( pMajor );
hb_itemRelease( pIRQ );
hb_itemRelease( pType );
hb_itemRelease( pMinor );
hb_itemRelease( pArray );
}
}
HB_FUNC(_MGET_HORISPEED)
{
int iSpeed;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=0x1B;
HB_DOS_INT86(0x33,&regs,&regs);
iSpeed=regs.HB_XREGS.bx;
}
#else
{
iSpeed=0;
}
#endif
{
hb_retni(iSpeed);
}
}
HB_FUNC(_MGET_VERSPEED)
{
int iSpeed;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=0x1B;
HB_DOS_INT86(0x33,&regs,&regs);
iSpeed=regs.HB_XREGS.cx;
}
#else
{
iSpeed=0;
}
#endif
{
hb_retni(iSpeed);
}
}
HB_FUNC(_MGET_DOUBLESPEED)
{
int iSpeed;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=0x1B;
HB_DOS_INT86(0x33,&regs,&regs);
iSpeed=regs.HB_XREGS.dx;
}
#else
{
iSpeed=0;
}
#endif
{
hb_retni(iSpeed);
}
}
HB_FUNC(_MSET_SENSITIVE) //nHoriz,nVert,nDouble)
{
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=0x1A;
regs.HB_XREGS.bx=hb_parni(1);
regs.HB_XREGS.cx=hb_parni(2);
regs.HB_XREGS.dx=hb_parni(3);
HB_DOS_INT86(0x33,&regs,&regs);
}
#endif
}
HB_FUNC(_MSE_CONOFF) //nTop*8,nLeft*8,nBotton*8,nRight*8)
{
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=0x1A;
regs.HB_XREGS.cx=hb_parni(2);
regs.HB_XREGS.dx=hb_parni(1);
regs.HB_XREGS.si=hb_parni(4);
regs.HB_XREGS.di=hb_parni(3);
HB_DOS_INT86(0x33,&regs,&regs);
}
#endif
}
HB_FUNC(_MGET_MICS)
{
int iHori;
int iVert;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=0x0B;
HB_DOS_INT86(0x33,&regs,&regs);
iHori=regs.HB_XREGS.cx;
iVert=regs.HB_XREGS.dx;
}
#else
{
iHori=0;
iVert=0;
}
#endif
{
PHB_ITEM pArray = hb_itemArrayNew(2);
PHB_ITEM pHori = hb_itemPutNI(NULL,iHori);
PHB_ITEM pVert = hb_itemPutNI(NULL,iVert);
hb_itemArrayPut( pArray, 1, pHori );
hb_itemArrayPut( pArray, 2, pVert );
hb_itemReturn(pArray);
hb_itemRelease(pArray);
hb_itemRelease(pHori);
hb_itemRelease(pVert);
}
}
HB_FUNC(_M_RESET)
{
int iMouse;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=0;
HB_DOS_INT86(0x33,&regs,&regs);
iMouse=regs.HB_XREGS.ax;
}
#else
{
iMouse=0;
}
#endif
{
hb_retl(iMouse);
}
}
HB_FUNC( _MSE_SHOWCURS)
{
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=1;
HB_DOS_INT86(0x33,&regs,&regs);
}
#endif
}
HB_FUNC( _MSE_MHIDECRS)
{
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=2;
HB_DOS_INT86(0x33,&regs,&regs);
}
#endif
}
HB_FUNC( _MSE_GETPOS)
{
int iHori;
int iVert;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=3;
HB_DOS_INT86(0x33,&regs,&regs);
iHori=regs.HB_XREGS.cx;
iVert=regs.HB_XREGS.dx;
}
#else
{
iHori=0;
iVert=0;
}
#endif
{
PHB_ITEM pArray = hb_itemArrayNew(2);
PHB_ITEM pHori = hb_itemPutNI(NULL,iHori);
PHB_ITEM pVert = hb_itemPutNI(NULL,iVert);
hb_itemArrayPut( pArray, 1, pHori );
hb_itemArrayPut( pArray, 2, pVert );
hb_itemReturn(pArray);
hb_itemRelease(pArray);
hb_itemRelease(pHori);
hb_itemRelease(pVert);
}
}
HB_FUNC( _M_GETX)
{
int iRow;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=3;
HB_DOS_INT86(0x33,&regs,&regs);
iRow=regs.HB_XREGS.dx;
}
#else
{
iRow=0;
}
#endif
{
hb_retni(iRow);
}
}
HB_FUNC( _M_GETY)
{
int iCol ;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=3;
HB_DOS_INT86(0x33,&regs,&regs);
iCol=regs.HB_XREGS.cx;
}
#else
{
iCol=0;
}
#endif
{
hb_retni(iCol);
}
}
HB_FUNC( _M_MSETPOS)
{
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=4;
regs.HB_XREGS.cx=hb_parni(1);
regs.HB_XREGS.dx=hb_parni(2);
HB_DOS_INT86(0x33,&regs,&regs);
}
#endif
}
HB_FUNC( _M_MSETCOORD)
{
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=4;
regs.HB_XREGS.cx=hb_parni(1);
regs.HB_XREGS.dx=hb_parni(2);
HB_DOS_INT86(0x33,&regs,&regs);
}
#endif
}
HB_FUNC( _M_MXLIMIT)
{
int iMaxRow;
int iMinRow;
#if defined(HB_OS_DOS)
{
union REGS regs;
iMaxRow=hb_parni(2);
iMinRow=hb_parni(1);
regs.HB_XREGS.ax=7;
regs.HB_XREGS.cx=iMinRow;
regs.HB_XREGS.dx=iMaxRow;
HB_DOS_INT86(0x33,&regs,&regs);
}
#endif
}
HB_FUNC( _M_MYLIMIT)
{
int iMaxCol;
int iMinCol;
#if defined(HB_OS_DOS)
{
union REGS regs;
iMaxCol=hb_parni(2);
iMinCol=hb_parni(1);
regs.HB_XREGS.ax=8;
regs.HB_XREGS.cx=iMinCol;
regs.HB_XREGS.dx=iMaxCol;
HB_DOS_INT86(0x33,&regs,&regs);
}
#endif
}
HB_FUNC( _M_MBUTPRS)
{
int inX;
int inY;
int inButton ;
BOOL lStatus;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=6;
regs.HB_XREGS.bx=hb_parni(1);
HB_DOS_INT86(0x33,&regs,&regs);
inY=regs.HB_XREGS.cx;
inX=regs.HB_XREGS.dx;
inButton=regs.HB_XREGS.bx;
lStatus=regs.HB_XREGS.ax;
}
#else
{
inY=0;
inX=0;
inButton=0;
lStatus=0;
}
#endif
{
PHB_ITEM pArray = hb_itemArrayNew(4);
PHB_ITEM pY = hb_itemPutNI(NULL,inY);
PHB_ITEM pX = hb_itemPutNI(NULL,inX);
PHB_ITEM pButton = hb_itemPutNI(NULL,inButton);
PHB_ITEM pStatus = hb_itemPutNI(NULL,lStatus);
hb_itemArrayPut( pArray, 1, pButton ); /* NOTE: I've changed 1 to 3 */
hb_itemArrayPut( pArray, 2, pX );
hb_itemArrayPut( pArray, 3, pY );
hb_itemArrayPut( pArray, 4, pStatus ); /* NOTE: I've changed 1 to 3 */
hb_itemReturn(pArray);
hb_itemRelease(pArray);
hb_itemRelease(pX);
hb_itemRelease(pY);
hb_itemRelease(pStatus);
hb_itemRelease(pButton);
}
}
HB_FUNC( _M_MDEFCRS)
{
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=0x0A;
regs.HB_XREGS.bx=hb_parni(1);
regs.HB_XREGS.cx=hb_parni(2);
regs.HB_XREGS.dx=hb_parni(3);
HB_DOS_INT86(0x33,&regs,&regs);
}
#endif
}
HB_FUNC( _M_MGETCOORD)
{
int inX;
int inY;
int inButton;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=3;
HB_DOS_INT86(0x33,&regs,&regs);
inButton=regs.HB_XREGS.bx;
inY=regs.HB_XREGS.cx;
inX=regs.HB_XREGS.dx;
}
#else
{
inX=0;
inY=0;
inButton=0;
}
#endif
{
PHB_ITEM pArray = hb_itemArrayNew(3);
PHB_ITEM pnY = hb_itemPutNI(NULL,inY);
PHB_ITEM pnX = hb_itemPutNI(NULL,inX);
PHB_ITEM pnButton= hb_itemPutNI(NULL,inButton);
hb_itemArrayPut( pArray, 1, pnX );
hb_itemArrayPut( pArray, 2, pnY );
hb_itemArrayPut( pArray, 3, pnButton );
hb_itemReturn(pArray);
hb_itemRelease(pArray);
hb_itemRelease(pnY);
hb_itemRelease(pnX);
hb_itemRelease(pnButton);
}
}

1470
harbour/contrib/libnf/mouse1.prg Normal file
View File

File diff suppressed because it is too large Load Diff

1003
harbour/contrib/libnf/mouse2.prg Normal file
View File

File diff suppressed because it is too large Load Diff