|
c:\harbour\contrib\hbnf
| alt.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_ALT(void)
HB_FUNC( FT_ALT )
{
HB_GT_INFO gtInfo;
gtInfo.pNewVal = gtInfo.pResult = NULL;
hb_gtInfo( GTI_KBDSHIFTS, >Info );
hb_retl( ( hb_itemGetNI( gtInfo.pResult ) & GTI_KBD_ALT ) != 0 );
if( gtInfo.pResult )
hb_itemRelease( gtInfo.pResult );
}
| alt.c | 68 |
| caplock.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_CAPLOCK(void)
HB_FUNC( FT_CAPLOCK )
{
int iState = 0, iNewState;
HB_GT_INFO gtInfo;
gtInfo.pNewVal = gtInfo.pResult = NULL;
hb_gtInfo( GTI_KBDSHIFTS, >Info );
if( gtInfo.pResult )
{
iState = hb_itemGetNI( gtInfo.pResult );
gtInfo.pNewVal = gtInfo.pResult;
gtInfo.pResult = NULL;
}
if( ISLOG( 1 ) )
{
iNewState = hb_parl( 1 ) ? ( iState | GTI_KBD_CAPSLOCK ) :
( iState & ~GTI_KBD_CAPSLOCK );
gtInfo.pNewVal = hb_itemPutNI( gtInfo.pNewVal, iNewState );
hb_gtInfo( GTI_KBDSHIFTS, >Info );
}
if( gtInfo.pNewVal )
hb_itemRelease( gtInfo.pNewVal );
if( gtInfo.pResult )
hb_itemRelease( gtInfo.pResult );
hb_retl( ( iState & GTI_KBD_CAPSLOCK ) != 0 );
}
| caplock.c | 68 |
| chdir.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_CHDIR(void)
HB_FUNC( FT_CHDIR)
{
hb_retl( ISCHAR( 1 ) && hb_fsChDir( ( BYTE * ) hb_parc(1) ) );
}
| chdir.c | 84 |
| color2n.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_COLOR2N(void)
HB_FUNC( FT_COLOR2N )
{
int iRet = 0;
if( ISCHAR( 1 ) )
{
iRet = hb_gtColorToN( hb_parc( 1 ) );
if( iRet == -1 )
iRet = 0;
}
hb_retni( iRet );
}
| color2n.c | 57 |
| ctrl.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_CTRL(void)
HB_FUNC( FT_CTRL )
{
HB_GT_INFO gtInfo;
gtInfo.pNewVal = gtInfo.pResult = NULL;
hb_gtInfo( GTI_KBDSHIFTS, >Info );
hb_retl( ( hb_itemGetNI( gtInfo.pResult ) & GTI_KBD_CTRL ) != 0 );
if( gtInfo.pResult )
hb_itemRelease( gtInfo.pResult );
}
| ctrl.c | 65 |
| descendn.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_DESCEND(void)
HB_FUNC( FT_DESCEND )
{
#if defined(HB_OS_DOS) || defined(HB_OS_WIN_32)
{
auto PHB_ITEM iP = hb_itemParam( 1 );
auto USHORT uiType = hb_itemType( iP );
auto PHB_ITEM iR = NULL;
auto USHORT uiLen, n;
auto char * pDescend;
if ( ( uiType & HB_IT_NUMERIC ) && ( uiType & HB_IT_DOUBLE ) )
iR = hb_itemPutND( 0, 0 - hb_itemGetND( iP ) );
else if ( uiType & HB_IT_NUMERIC )
iR = hb_itemPutNL( 0, 0 - hb_itemGetNL( iP ) );
else if ( uiType & HB_IT_DATE )
iR = hb_itemPutNL( 0, 0x4FD4C0L - hb_itemGetNL( iP ) );
else if ( uiType & HB_IT_LOGICAL )
iR = hb_itemPutL( 0, ( hb_itemGetL( iP ) > 0 ) ? 0 : 1 );
else if ( uiType & HB_IT_STRING )
{
uiLen = (USHORT) hb_itemSize( iP );
pDescend = ( char *) hb_xgrab( uiLen );
hb_itemCopyC( iP, pDescend, uiLen );
for ( n = 0; n < uiLen; n++ )
pDescend[ n ] = ( char ) 0 - pDescend[ n ];
iR = hb_itemPutCL( 0, pDescend, uiLen );
hb_xfree( pDescend );
}
hb_itemReturn( iR );
hb_itemRelease( iP );
hb_itemRelease( iR );
}
#endif
}
| descendn.c | 51 |
| dispc.c |
| Type | Function | Source | Line |
|---|
| STATIC VOID | chattr(int x, int y, int len, int attr)
static void chattr(int x, int y, int len, int attr)
{
int i;
char *vmem;
vmem = vseg + (y * (width + 1) * 2) + (x * 2) + 1;
/* calc the screen memory coord */
for (i = 0; i <= len; i++, vmem += 2) /* write the new attribute value */
*vmem = (char) attr;
}
| dispc.c | 132 |
| STATIC LONG | getblock(long offset)
static long getblock(long offset)
{
/*
set the file pointer to the proper offset
and if an error occured then check to see
if a positive offset was requested, if so
then set the pointer to the offset from
the end of the file, otherwise set it from
the beginning of the file.
*/
hb_fsSeek( infile, offset, FS_SET );
/* read in the file and set the buffer bottom variable equal */
/* to the number of bytes actually read in. */
buffbot = hb_fsReadLarge( infile, ( BYTE * ) buffer, buffsize );
/* if a full buffer's worth was not read in, make it full. */
if (( buffbot != buffsize ) && ( fsize > buffsize ))
{
if ( offset > 0 )
hb_fsSeek( infile, (long) -buffsize, FS_END );
else
hb_fsSeek( infile, (long) buffsize, FS_SET );
buffbot = hb_fsReadLarge( infile, ( BYTE * ) buffer, buffsize );
}
/* return the actual file position */
return( hb_fsSeek( infile, 0L, FS_RELATIVE ) - buffbot);
}
| dispc.c | 158 |
| STATIC VOID | buff_align()
static void buff_align()
{
int i;
bufftop = 0;
buffbot = buffsize;
if ( buffoffset != 0L ) /* if the buffoffset is otherthan 0 */
{
i = bufftop; /* start at the top of the file and scan */
/* forward until a CR is reached. */
while (( buffer[i] != CR ) && ( i < buffbot ))
i++;
bufftop = i + 2;
}
/* if the buffer offset is not a complete */
/* buffer's length away from the file end */
if ( buffoffset + ((long) buffbot) != fsize )
{
/*
if the file position of the last byte
of the buffer would end up past the
end of the file, then the buffer does
contain a complete buffer full and the
buffer end pointer needs to be set to
the last character of the file.
*/
if ( buffoffset + ((long) buffbot) > fsize )
buffbot = (int) (fsize - buffoffset);
i = buffbot; /* point the end of the buffer to a valid */
/* complete text line. */
while (( buffer[i] != CR ) && ( i > bufftop ))
i--;
buffbot = i + 2;
}
}
| dispc.c | 204 |
| STATIC VOID | win_align()
static void win_align()
{
int i;
winbot = wintop; /* find out if there is enough text for */
i = 0; /* full window. */
while (( winbot < buffbot ) && ( i < height ))
{
if ( buffer[winbot] == CR )
i++;
winbot++;
}
if ( i < height ) /* if there is not a full window, */
{
/* then retrofit winbot to the end of a line */
while ( buffer[winbot] != LF && winbot > bufftop)
winbot--;
wintop = winbot;
i = 0; /* and setup wintop */
while (( wintop > bufftop ) && ( i <= height ))
{
if ( buffer[wintop] == LF )
i++;
wintop--;
}
if ( wintop != bufftop )
wintop += 2;
}
}
| dispc.c | 261 |
| STATIC VOID | disp_update(int offset)
static void disp_update(int offset)
{
int line, col, pos, i;
char *vmem;
refresh = NO;
line = 0;
while ( line < height )
{
/*
calculate the initial position, this save execution
time because each column is considered as a offset
from the line start
*/
pos = (line * (width + 1) * 2);
/* copy string to temp buffer */
for (i = 0; buffer[offset] != CR && offset <= winbot; offset++)
{
if ( i <= maxlin )
{
if (buffer[offset] == '\t') /* check for a tab */
{
lbuff[i++] = ' '; /* pad with spaces */
while (i % TABSET && i <= maxlin) /* until tab stop */
lbuff[i++] = ' '; /* is reached or EOL */
}
else lbuff[i++] = buffer[offset];
}
}
for (; i <= maxlin; i++) /* fill out with spaces */
lbuff[i] = ' ';
/* place the proper characters onto the screen */
for (i = wincol, col = 0; col <= width; col++)
{
vmem = vseg + pos + (col * 2);
*vmem = lbuff[i++];
}
line += 1;
offset += 2;
}
hb_gtRest( sline, scol, eline, ecol, vseg );
}
| dispc.c | 309 |
| STATIC VOID | winup()
static void winup()
{
int k;
long i, j;
refresh = YES;
k = wintop - 3;
while (( buffer[k] != CR ) && ( k > bufftop ))
k--;
if ( k >= bufftop )
{
if (buffer[k] == CR) k += 2;
wintop = k;
k = winbot - 3;
while ( buffer[k] != CR )
k--;
winbot = k + 2;
}
else
if ( ((long) bufftop) + buffoffset > 0 && fsize > buffsize )
{
i = buffoffset + wintop;
j = buffoffset - ((long) (buffsize / 2));
if ( j < 0 )
j = 0;
buffoffset = getblock(j);
wintop = ((int) (i - buffoffset));
buff_align();
win_align();
}
}
| dispc.c | 374 |
| STATIC VOID | windown()
static void windown()
{
int k;
long i, j;
refresh = YES;
k = winbot;
while (( buffer[k] != CR ) && ( k <= buffbot ))
k++;
k += 2;
if ( k <= buffbot )
{
winbot = k;
k = wintop;
while ( buffer[k] != CR )
k++;
wintop = k + 2;
}
else
if ( (((long) buffbot) + buffoffset) < fsize && fsize > buffsize)
{
i = buffoffset + wintop;
j = i;
if ( j > fsize )
j = fsize - ((long) buffsize);
buffoffset = getblock(j);
if ( i < buffoffset )
wintop = 0;
else
wintop = ((int) (i - buffoffset));
buff_align();
win_align();
}
}
| dispc.c | 425 |
| STATIC VOID | linedown()
static void linedown()
{
if ( winrow < eline ) /* if cursor not at last line */
winrow += 1;
else /* otherwise adjust the window top variable */
windown();
}
| dispc.c | 473 |
| STATIC VOID | lineup()
static void lineup()
{
if ( winrow > sline )
winrow -= 1;
else
winup();
}
| dispc.c | 487 |
| STATIC VOID | filetop()
static void filetop()
{
if ( buffoffset != 0 )
{
buffoffset = getblock(0L);
buff_align();
}
refresh = YES;
wintop = (int) buffoffset;
winrow = sline;
wincol = 0;
win_align();
}
| dispc.c | 501 |
| STATIC VOID | filebot()
static void filebot()
{
if ( (((long) buffbot) + buffoffset) < fsize && fsize > buffsize )
{
buffoffset = getblock(fsize + 1);
buff_align();
}
refresh = YES;
wintop = buffbot - 3;
winrow = eline;
wincol = 0;
win_align();
}
| dispc.c | 524 |
| HB_FUNC | _FT_DFINIT(void)
HB_FUNC( _FT_DFINIT )
{
int rval, i, j;
ULONG ulSize;
rval = 0;
sline = hb_parni(2); /* top row of window */
scol = hb_parni(3); /* left col */
eline = hb_parni(4); /* bottom row */
ecol = hb_parni(5); /* right col */
width = ecol - scol; /* calc width of window */
height = eline - sline + 1; /* calc height of window */
hb_gtRectSize( sline, scol, eline, ecol, &ulSize );
vseg = (char * ) hb_xalloc( ulSize );
if (vseg != NULL)
hb_gtSave( sline, scol, eline, ecol, vseg );
maxlin = hb_parni(12);
buffsize = hb_parni(13); /* yes - load value */
buffer = (char *) hb_xalloc(buffsize); /* allocate memory */
lbuff = (char *) hb_xalloc(maxlin + 1); /* for buffers */
isallocated = !(buffer == NULL || lbuff == NULL || vseg == NULL);
/* memory allocated? */
if (!isallocated)
{
rval = 8; /* return error code 8 (memory) */
if (buffer != NULL) hb_xfree(buffer);
if (lbuff != NULL) hb_xfree(lbuff);
if (vseg != NULL) hb_xfree(vseg);
}
else /* get parameters */
{
infile = hb_parni(1); /* file handle */
j = hb_parni(6); /* starting line value */
norm = hb_parni(7); /* normal color attribute */
hlight = hb_parni(8); /* highlight color attribute */
if (hb_parinfo(9) & HB_IT_ARRAY) /* if array */
{
keytype = K_LIST;
kcount = hb_parinfa( 9, 0 );
if (kcount > 24)
kcount = 24;
for (i = 1; i <= kcount; i++)
keylist[i - 1] = hb_parni( 9, i ); /* get exit key list */
}
else
{
keytype = K_STRING;
kcount = hb_parclen( 9 );
if (kcount > 24)
kcount = 24;
strcpyn(kstr, hb_parcx(9), kcount); /* get exit key string */
}
brows = hb_parl(10); /* get browse flag */
colinc = hb_parni(11); /* column skip value */
bufftop = 0; /* init buffer top pointer */
buffbot = buffsize; /* init buffer bottom pointer */
buffoffset = 0; /* curr line offset into buffer */
winrow = sline; /* init window row */
wincol = 0; /* init window col */
wintop = 0; /* init window top pointer */
winbot = 0; /* init window bottom pointer */
/* get file size */
fsize = hb_fsSeek( infile, 0L, FS_END ) - 1;
/* get the first block */
hb_fsSeek( infile, 0L, FS_SET );
/* if block less than buffsize */
if ( fsize < ((long) buffbot) )
buffbot = (int) fsize; /* then set buffer bottom */
/* set the current lines buffer offset pointer */
buffoffset = getblock((long) bufftop);
/* align buffer and window pointer to valid values */
buff_align();
win_align();
/* point line pointer to line passed by caller */
for (i = 1; i < j; i++)
linedown();
hb_gtRest( sline, scol, eline, ecol, vseg );
}
hb_retni(rval);
}
| dispc.c | 542 |
| HB_FUNC | _FT_DFCLOS(void)
HB_FUNC ( _FT_DFCLOS )
{
if (isallocated)
{
if (buffer != NULL) hb_xfree(buffer); /* free up allocated buffer memory */
if (lbuff != NULL) hb_xfree(lbuff);
if (vseg != NULL) hb_xfree(vseg);
}
}
| dispc.c | 653 |
| HB_FUNC | FT_DISPFILE(void)
HB_FUNC( FT_DISPFILE )
{
int i, done;
char rval[2];
int ch;
/* make sure buffers were allocated and file was opened */
if (isallocated && infile > 0)
{
done = NO;
refresh = YES;
/* draw inside of window with normal color attribute */
for (i = 0; i < height; i++)
chattr(0, i, width, norm);
hb_gtRest( sline, scol, eline, ecol, vseg );
/* main processing loop -- terminated by user key press */
do
{
if ( refresh == YES ) /* redraw window contents? */
disp_update(wintop);
hb_gtRest( sline, scol, eline, ecol, vseg );
/* if not browse, highlight the current line */
if ( brows == NO )
chattr(0, winrow - sline, width, hlight);
hb_gtRest( sline, scol, eline, ecol, vseg );
hb_gtSetPos( winrow, scol );
ch = keyin(); /* get user key press */
/* if not browse, then un-highlight current line */
if ( brows == NO )
chattr(0, winrow - sline, width, norm);
hb_gtRest( sline, scol, eline, ecol, vseg );
/* figure out what the user wants to do */
switch (ch)
{
case K_DOWN : if ( brows == YES ) /* if browse flag */
winrow = eline; /* is set, force */
/* active line to */
linedown(); /* be last line */
break;
case K_UP : if ( brows == YES ) /* if browse flag */
winrow = sline; /* is set, force */
/* active line to */
lineup(); /* be first line */
break;
case K_LEFT : wincol -= colinc; /* move cursor */
refresh = YES; /* to the left */
if ( wincol < 0 )
wincol = 0;
break;
case K_RIGHT : wincol += colinc; /* move cursor */
refresh = YES; /* to the right */
if ( wincol > (maxlin - width) )
wincol = maxlin - width;
break;
case K_HOME : wincol = 0; /* move cursor */
refresh = YES; /* to first col */
break;
/* move cursor to last col */
case K_END : wincol = maxlin - width;
refresh = YES;
break;
case K_CTRL_LEFT : wincol -= 16; /* move cursor */
refresh = YES; /* 16 col to left */
if ( wincol < 0 )
wincol = 0;
break;
case K_CTRL_RIGHT : wincol += 16; /* move cursor */
refresh = YES; /* 16 col to right */
if ( wincol > (maxlin - width) )
wincol = maxlin - width;
break;
case K_PGUP : for (i = 0; i < height; i++) /* move window */
winup(); /* up one page */
break;
case K_PGDN : for (i = 0; i < height; i++) /* move window */
windown(); /* down 1 page */
break;
case K_CTRL_PGUP : filetop(); /* move cursor to */
break; /* to top of file */
case K_CTRL_PGDN : filebot(); /* move cursor to */
break; /* to bot of file */
case K_ENTER : done = YES; /* carriage return */
break; /* terminates */
case K_ESC : done = YES; /* escape key */
break; /* terminates */
/* scan key list and see if key pressed is there */
default : if (keytype == K_STRING)
{
for (i = 0; i <= kcount; i++)
if ((ch > 0) && (ch < 256))
if ( (int) kstr[i] == ch )
done = YES;
break; /* if so terminate */
}
else
{
for (i = 0; i < kcount; i++)
if ( keylist[i] == ch )
done = YES;
break;
}
}
} while ( done == NO );
}
else
ch = 0;
/* store the key pressed as a character to be returned */
/* return key value to caller */
if (keytype == K_STRING)
{
rval[0] = (char) ch;
rval[1] = '\0';
hb_retc( rval );
}
else
hb_retni( ch );
}
| dispc.c | 724 |
| STATIC INT | keyin()
static int keyin()
{
return hb_inkey( TRUE, 0.0, INKEY_ALL );
}
| dispc.c | 904 |
| STATIC VOID | strcpyn( char *dest, const char *source, int len )
static void strcpyn( char *dest, const char *source, int len )
{
int i;
for (i = 0; i < len; i++)
dest[i] = source[i];
dest[len+1] = 0x00;
}
| dispc.c | 910 |
| ftattr.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_SAVEATT(void)
HB_FUNC( FT_SAVEATT )
{
USHORT uiTop = hb_parni( 1 ); /* Defaults to zero on bad type */
USHORT uiLeft = hb_parni( 2 ); /* Defaults to zero on bad type */
USHORT uiMaxRow = hb_gtMaxRow();
USHORT uiMaxCol = hb_gtMaxCol();
USHORT uiBottom = ISNUM( 3 ) ? hb_parni( 3 ) : uiMaxRow;
USHORT uiRight = ISNUM( 4 ) ? hb_parni( 4 ) : uiMaxRow;
ULONG ulSize;
char * pBuffer;
char * pAttrib;
if( uiBottom > uiMaxRow )
uiBottom = uiMaxRow;
if( uiRight > uiMaxCol )
uiRight = uiMaxCol;
if( uiTop <= uiBottom && uiLeft <= uiRight )
{
ulSize = ( uiBottom - uiTop + 1 ) * ( uiRight - uiLeft + 1 );
pBuffer = pAttrib = ( char * ) hb_xgrab( ulSize + 1 );
while( uiTop <= uiBottom )
{
USHORT uiCol = uiLeft;
while( uiCol <= uiRight )
{
BYTE bColor, bAttr;
USHORT usChar;
hb_gtGetChar( uiTop, uiCol, &bColor, &bAttr, &usChar );
*pBuffer++ = ( char ) bColor;
++uiCol;
}
++uiTop;
}
hb_retclen_buffer( pAttrib, ulSize );
}
else
hb_retc( NULL );
}
/*
* File......: RESTATT.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 03 Oct 1992 14:33:46 GLENN
* Ted Means made modifications so these functions will work with
* dispBegin() and dispEnd().
*
* Rev 1.1 15 Aug 1991 23:08:02 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.0 12 Jun 1991 01:30:14 GLENN
* Initial revision.
*
* $DOC$
* $FUNCNAME$
* FT_RESTATT()
* $CATEGORY$
* Video
* $ONELINER$
* Restore the attribute bytes of a specified screen region.
* $SYNTAX$
* FT_RESTATT( , , , , ) -> NIL
* $ARGUMENTS$
* , , , and define the screen region.
* is a character string containing the attribute bytes
* for the screen region. This will most often be a string
* previously returned by FT_SAVEATT(), but any character
* string may be used (provided it is of the proper size).
* $RETURNS$
* NIL
* $DESCRIPTION$
* This function is similar to Clipper's RestScreen(), except that it only
* restores the attribute bytes. This is useful if you want to change the
* screen color without affecting the text.
*
* *** INTERNALS ALERT ***
*
* This function calls the Clipper internals __gtSave and __gtRest to
* manipulate the the screen image. If you're too gutless to use
* internals, then this function isn't for you.
* $EXAMPLES$
* // Restore attributes of row 4
* FT_RESTATT( 4, 0, 4, maxcol(), cBuffer)
*
* // Restore attributes to middle of screen
* FT_RESTATT(10,20,14,59,cBuffer)
* $SEEALSO$
* FT_SAVEATT()
* $END$
*
*/
/* This is the Original FT_RESTATT() code
IDEAL
Public FT_RestAtt
Extrn __ParNI:Far
Extrn __ParC:Far
Extrn __XGrab:Far
Extrn __XFree:Far
Extrn __gtSave:Far
Extrn __gtRest:Far
nTop EQU Word Ptr BP - 2
nLeft EQU Word Ptr BP - 4
nBottom EQU Word Ptr BP - 6
nRight EQU Word Ptr BP - 8
nAttr EQU Byte Ptr BP - 10
nBufLen EQU Word Ptr BP - 12
cBuffer EQU DWord Ptr BP - 16
nBufOfs EQU Word Ptr BP - 16
nBufSeg EQU Word Ptr BP - 14
Segment _NanFor Word Public "CODE"
Assume CS:_NanFor
Proc FT_RestAtt Far
Push BP ; Save BP
Mov BP,SP ; Set up stack reference
Sub SP,16 ; Allocate locals
Mov CX,4 ; Set param count
@@Coord: Push CX ; Put on stack
Call __ParNI ; Retrieve param
Pop CX ; Get count back
Push AX ; Put value on stack
Loop @@Coord ; Get next value
Pop [nTop] ; Store top coordinate
Pop [nLeft] ; Store left coordinate
Pop [nBottom] ; Store bottom coordinate
Pop [nRight] ; Store right coordinate
Mov AX,[nBottom] ; Load bottom coordinate
Sub AX,[nTop] ; Subtract top
Inc AX ; Calc length
Mov CX,[nRight] ; Load right coordinate
Sub CX,[nLeft] ; Subtract left
Inc CX ; Calc width
Mul CX ; Multiply length by width
SHL AX,1 ; Calc buffer size
Mov [nBufLen],AX ; Store buffer size
@@Alloc: Push AX ; Put size on stack
Call __xGrab ; Allocate memory
Add SP,2 ; Realign stack
Mov [nBufSeg],DX ; Store segment
Mov [nBufOfs],AX ; Store offset
Push DX ; Load parameters for __gtSave
Push AX ; onto stack
Push [nRight]
Push [nBottom]
Push [nLeft]
Push [nTop]
Call __gtSave ; Grab screen image
Push DS ; Save required registers
Push SI
Push DI
Mov AX,5 ; Specify 5th param
Push AX ; Put on stack
Call __ParC ; Get pointer to attr string
Add SP,2 ; Realign stack
Mov DS,DX ; Load pointer to string
Mov SI,AX ; into DS:SI
Mov ES,[nBufSeg] ; Load pointer to buffer
Mov DI,[nBufOfs] ; into ES:DI
Mov CX,[nBufLen] ; Load buffer length
SHR CX,1 ; Divide by two
@@Attr: Inc DI ; Point DI to attribute
Lodsb ; Grab an attribute byte
Stosb ; Store attribute
Loop @@Attr ; Do next
Pop DI ; Restore registers
Pop SI
Pop DS
Call __gtRest ; Restore screen image
Done: Push [nBufSeg] ; Put segment on stack
Push [nBufOfs] ; Put offset on stack
Call __xFree ; Free memory
Mov SP,BP ; Realign stack
Pop BP ; Restore BP
Ret
Endp FT_RestAtt
Ends _NanFor
End
*/
| ftattr.c | 174 |
| HB_FUNC | FT_RESTATT(void)
HB_FUNC( FT_RESTATT )
{
ULONG ulLen = hb_parclen( 5 );
if( ulLen )
{
USHORT uiTop = hb_parni( 1 ); /* Defaults to zero on bad type */
USHORT uiLeft = hb_parni( 2 ); /* Defaults to zero on bad type */
USHORT uiMaxRow = hb_gtMaxRow();
USHORT uiMaxCol = hb_gtMaxCol();
USHORT uiBottom = ISNUM( 3 ) ? hb_parni( 3 ) : hb_gtMaxRow();
USHORT uiRight = ISNUM( 4 ) ? hb_parni( 4 ) : hb_gtMaxCol();
char * pAttrib = hb_parc( 5 );
if( uiBottom > uiMaxRow )
uiBottom = uiMaxRow;
if( uiRight > uiMaxCol )
uiRight = uiMaxCol;
if( uiTop <= uiBottom && uiLeft <= uiRight )
{
while( ulLen && uiTop <= uiBottom)
{
USHORT uiCol = uiLeft;
while( ulLen && uiCol <= uiRight )
{
BYTE bColor, bAttr;
USHORT usChar;
hb_gtGetChar( uiTop, uiCol, &bColor, &bAttr, &usChar );
bColor = *pAttrib++;
hb_gtPutChar( uiTop, uiCol, bColor, bAttr, usChar );
++uiCol;
--ulLen;
}
++uiTop;
}
}
}
}
| ftattr.c | 384 |
| ftidle.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_Idle(void)
HB_FUNC(FT_Idle)
{
hb_idleState();
}
| ftidle.c | 65 |
| ftisprn.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_ISPRINT(void)
HB_FUNC( FT_ISPRINT )
{
HB_FUNC_EXEC( HB_ISPRINT )
}
| ftisprn.c | 148 |
| ftshadow.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_SHADOW(void)
HB_FUNC( FT_SHADOW )
{
HB_FUNC_EXEC( HB_SHADOW );
}
| ftshadow.c | 59 |
| HB_FUNC | FT_SETATTR(void)
HB_FUNC( FT_SETATTR )
{
hb_gtSetAttribute( hb_parni( 1 ), hb_parni( 2 ),
hb_parni( 3 ), hb_parni( 4 ), hb_parni( 5 ) );
}
| ftshadow.c | 64 |
| fttext.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FTSETINT(void)
HB_FUNC( FTSETINT )
{
doInt ^= 0xFF;
}
| fttext.c | 215 |
| HB_FUNC | FT_FOFFSET(void)
HB_FUNC( FT_FOFFSET )
{
_retnl( offset[area] );
}
/* standard macros */
#define __max(a,b) (((a) > (b)) ? (a) : (b))
#define __min(a,b) (((a) < (b)) ? (a) : (b))
#define FT_CHR_CR 13
#define FT_CHR_LF 10
#define FT_CHR_EOF 26
| fttext.c | 220 |
| HB_FUNC | FT_FUSE(void)
HB_FUNC( FT_FUSE )
{
int attr = ISNUM( 2 ) ? _parni(2) : FO_READWRITE|FO_DENYNONE;
error[area] = 0;
if ( ISCHAR(1) )
{
handles[area] = _fsOpen( ( BYTEP ) _parc(1), attr ) ;
if( handles[area] <= 0 )
error[area] = _fsError();
offset[area] = 0 ;
recno[area] = 1;
lastbyte[area] = _fsSeek( handles[area], 0L, FS_END );
_retni( handles[area] );
}
else
{
if ( handles[area] != 0 )
{
_fsClose( handles[area] );
_retni(0);
recno[area] = 0L;
offset[area] = 0L;
handles[area] = 0;
last_rec[area] = 0L;
last_off[area] = 0L;
lastbyte[area] = 0L;
isEof[area] = 0;
}
}
}
| fttext.c | 300 |
| HB_FUNC | FT_FSELECT(void)
HB_FUNC( FT_FSELECT )
{
int oldarea = area + 1;
int newArea;
if ( ISNUM(1) )
{
newArea = _parni(1);
if( newArea <= TEXT_WORKAREAS )
{
if ( newArea == 0 )
{
for ( ; newArea < TEXT_WORKAREAS - 1; newArea++ )
{
if ( handles[ newArea] == 0 )
{
area = newArea;
break;
}
}
}
else
area = newArea - 1;
}
}
_retni( oldarea );
}
| fttext.c | 393 |
| HB_FUNC | FT_FGOTOP(void)
HB_FUNC( FT_FGOTOP )
{
error[area] = 0;
offset[area] = 0L;
recno[area] = 1L;
isBof[area] = FALSE;
isEof[area] = FALSE;
}
| fttext.c | 468 |
| HB_FUNC | FT_FERROR(void)
HB_FUNC( FT_FERROR )
{
_retni( error[area] );
}
| fttext.c | 520 |
| HB_FUNC | FT_FRECNO(void)
HB_FUNC( FT_FRECNO )
{
_retnl( recno[area] );
}
| fttext.c | 575 |
| HB_FUNC | FT_FGOBOT(void)
HB_FUNC( FT_FGOBOT )
{
error[area] = 0;
if( !last_rec[area] )
{
/* if the last record has not already been found */
_ft_skip( 0 );
}
recno[ area] = last_rec[area];
offset[area] = last_off[area];
isBof[area] = FALSE;
isEof[area] = FALSE;
}
| fttext.c | 624 |
| HB_FUNC | FT_FSKIP(void)
HB_FUNC( FT_FSKIP )
{
if ( ISNUM(1) )
{
if( _parnl(1) )
_retnl( _ft_skip( _parnl(1) ) );
else
_retnl( 0L );
}
else
_retnl( _ft_skip(1L) );
}
| fttext.c | 697 |
| STATIC LONG | _ft_skip( long iRecs )
static long _ft_skip( long iRecs )
{
int iByteCount;
int iBytesRead, iBytesRemaining;
BYTEP cPtr;
long iSkipped = 0;
BYTEP cBuff = ( BYTEP ) hb_xgrab( BUFFSIZE );
long fpOffset = offset[area];
isBof[area] = FALSE;
isEof[area] = FALSE;
error[area] = 0;
/* iRecs is zero if they want to find the EOF, start a top of file */
if( iRecs == 0 )
{
fpOffset = 0L;
recno[area] = 1;
}
if ( iRecs >= 0 )
{
do {
cPtr = cBuff;
/* position file pointer to beginning of current record */
_fsSeek( handles[area], fpOffset, FS_SET );
/* read a chunk */
iBytesRead = _fsRead( handles[area], cBuff, BUFFSIZE );
if( !iBytesRead )
{
/* buffer is empty thus EOF, set vars and quit */
isEof[area] = TRUE;
last_rec[area] = recno[ area];
last_off[area] = offset[area];
error[area] = _fsError();
break;
}
iBytesRemaining = iBytesRead;
/* parse the buffer while there's still stuff in it */
do {
/* get count of chars in this line */
iByteCount = _findeol( cPtr, iBytesRemaining );
if( ( iByteCount > 0 ) && ( iByteCount != iBytesRemaining ) )
{
/* found a CRLF, iByteCount points to first char of next
record */
iBytesRemaining -= iByteCount;
fpOffset += iByteCount;
cPtr += iByteCount;
offset[area] = fpOffset;
recno[area]++;
iSkipped++;
if( iRecs && ( iSkipped == iRecs ) )
iBytesRemaining = iBytesRead = 0;
}
else
{
/* no more CRLFs in this buffer, or CRLF is last
chars in the buffer */
/* check for EOF */
if( iBytesRead != BUFFSIZE )
{
/* buffer was not full, thus EOF, set vars and quit */
iBytesRemaining = 0;
last_rec[area] = recno[area];
last_off[area] = offset[area];
if( iRecs )
isEof[area] = TRUE;
}
else
{
/* buffer was full, so probably not EOF, but maybe
CRLF straddled end of buffer, so back up pointer a bit
before doing the next read */
fpOffset = _fsSeek( handles[area], 0, FS_RELATIVE ) - 1;
iBytesRemaining = 0;
}
}
} while ( ( iBytesRemaining > 0 ) );
} while( ( iBytesRead == BUFFSIZE ) );
}
else
{
/* skip backwards */
iRecs = -iRecs;
if( recno[area] > iRecs )
{
do
{
/* calc offset to read area of file ahead of current pointer */
fpOffset = __max( offset[area] - BUFFSIZE, 0L );
/* move file pointer */
_fsSeek( handles[area], fpOffset, FS_SET );
/* read a chunk */
iBytesRead =
_fsRead( handles[area], cBuff, BUFFSIZE );
if( !iBytesRead )
{
/* buffer is empty thus file is zero len, set vars and quit */
isBof[area] = TRUE;
isEof[area] = TRUE;
recno[area] = 0;
offset[area] = 0;
last_rec[area] = 0;
error[area] = _fsError();
break;
}
/* set pointer within buffer */
iBytesRemaining = (int) ( offset[area] - fpOffset );
cPtr = cBuff + iBytesRemaining;
/* parse the buffer while there's still stuff in it */
do {
/* get count of chars in this line */
iByteCount = _findbol( cPtr, iBytesRemaining );
if( iByteCount > 0 )
{
/* found a CRLF, iByteCount points to first char of next
record */
iBytesRemaining -= iByteCount;
offset[area] -= iByteCount;
cPtr -= iByteCount;
fpOffset = offset[area];
recno[area]--;
iSkipped++;
if( iSkipped == iRecs )
iBytesRemaining = iBytesRead = 0;
}
else
{
/* no more CRLFs in this buffer so we're either at
BOF or record crosses buffer boundary */
/* check for BOF */
if( iBytesRead != BUFFSIZE )
{
/* buffer was not full, thus BOF, set vars and quit */
iBytesRemaining = 0;
offset[area] = 0;
recno[area] = 1;
isBof[area] = TRUE;
}
else
{
/* buffer was full, so not BOF */
iBytesRemaining = 0;
}
}
} while ( ( iBytesRemaining > 0 ) );
} while( ( fpOffset > 0 ) && ( iBytesRead == BUFFSIZE ) );
}
else
{
offset[area] = 0;
recno[area] = 1;
isBof[area] = TRUE;
}
}
hb_xfree( ( void * ) cBuff );
return ( iSkipped );
}
| fttext.c | 711 |
| HB_FUNC | FT_FREADLN(void)
HB_FUNC( FT_FREADLN )
{
USHORT iByteCount;
USHORT iBytesRead;
BYTEP cPtr = ( BYTEP ) hb_xgrab( BUFFSIZE );
_fsSeek( handles[area], offset[area], FS_SET );
iBytesRead = (int) _fsRead( handles[area], cPtr, BUFFSIZE );
error[area] = 0;
if( !iBytesRead )
{
error[area] = _fsError();
}
iByteCount = _findeol( cPtr, iBytesRead );
if( iByteCount )
_retclen( ( char * ) cPtr, iByteCount-2 );
else
_retclen( ( char * ) cPtr, iBytesRead );
hb_xfree( ( void * ) cPtr );
}
| fttext.c | 955 |
| HB_FUNC | FT_FDELETE(void)
HB_FUNC( FT_FDELETE )
{
int iBytesRead ;
long srcPtr ;
long destPtr ;
long cur_rec = recno[area];
long cur_off = offset[area];
BYTEP Buff = ( BYTEP ) _xgrab( BUFFSIZE );
/* save address to current record ( first record to be deleted ) */
destPtr = offset[area] ;
/* skip over deleted records, point to first 'to be retained' record */
_ft_skip( ( ISNUM( 1 ) ? _parni( 1 ) : 1 ) ) ;
srcPtr = _fsSeek( handles[area], offset[area], FS_SET );
/* buffer read retained data, write atop old data */
do
{
_fsSeek( handles[area], srcPtr, FS_SET );
iBytesRead = _fsRead( handles[area], Buff , BUFFSIZE ); /* now read in a big glob */
srcPtr += iBytesRead;
_fsSeek( handles[area], destPtr, FS_SET );
destPtr += _fsWrite( handles[area], Buff, iBytesRead );
} while( iBytesRead > 0 );
/* move DOS EOF marker */
_fsSeek( handles[area], srcPtr, FS_SET );
_fsWrite( handles[area], Buff, 0 );
error[area] = _fsError();
/* restore pointers */
recno[area] = cur_rec;
offset[area]= cur_off;
/* re_calc EOF */
lastbyte[area] = _fsSeek( handles[area], 0L, FS_END );
_ft_skip( 0 );
/* restore pointers again */
recno[area] = cur_rec;
offset[area]= cur_off;
/* if we've deleted to EOF, leave EOF flag set, otherwise clear it */
if( recno[area] != last_rec[area] )
isEof[area] = FALSE;
hb_xfree( ( void * ) Buff );
_retl( (error[area]) ? 0 : 1 );
}
| fttext.c | 1025 |
| HB_FUNC | FT_FINSERT(void)
HB_FUNC( FT_FINSERT )
{
int no_lines = ( ISNUM( 1 ) ? _parni( 1 ) : 1 );
int no_bytes = no_lines * 2 ;
int err = 1;
if( _ins_buff( no_bytes ) )
err = 0;
else
{
while( no_lines-- )
if( !_writeeol( handles[area] ) )
{
error[area] = _fsError();
err = 0;
break;
}
}
_retl( err );
}
| fttext.c | 1128 |
| HB_FUNC | FT_FAPPEND(void)
HB_FUNC( FT_FAPPEND )
{
int no_lines = ( ISNUM( 1 ) ? _parni( 1 ) : 1 );
int iRead;
int iByteCount;
char * buff = ( char * ) hb_xgrab( BUFFSIZE );
error[area] = 0;
/* go to end of file */
HB_FUNC_EXEC( FT_FGOBOT );
/* find end of record */
_fsSeek( handles[area], offset[area], FS_SET );
iRead = _fsRead( handles[area], buff, BUFFSIZE ); /* now read in a big glob */
/* determine if CRLF pair exists, if not, add one */
/* get count of chars in this line */
iByteCount = _findeol( ( BYTEP ) buff, iRead );
if( iByteCount == 0 )
_fsSeek( handles[area], 0, FS_END );
else
{
offset[area] = _fsSeek( handles[area], offset[area] + iByteCount, FS_SET );
recno[area]++;
no_lines--;
}
while( no_lines-- )
{
if( !_writeeol( handles[area] ) )
{
error[area] = _fsError();
break;
}
recno[area]++;
offset[area] = _fsSeek( handles[area], 0, FS_RELATIVE );
/* no_lines--; !Harbour FIX! */
}
if( !error[area] )
{
/* move DOS eof marker */
_fsWrite( handles[area], (void *) buff, 0 );
error[area] = _fsError();
}
/* force recalc of last record/offset */
last_rec[area] = 0;
hb_xfree( ( void * ) buff );
_retl( (error[area]) ? 0 : 1 );
}
| fttext.c | 1210 |
| HB_FUNC | FT_FWRITEL(void)
HB_FUNC( FT_FWRITEL )
{
char * theData = _parc( 1 );
int iDataLen = _parclen( 1 );
int lInsert = ( ISLOG( 2 ) ? _parl( 2 ) : 0 );
int err;
int iLineLen = 0;
int iRead, iEOL;
char * buffer ;
/* position file pointer to insertion point */
_fsSeek( handles[area], offset[area], FS_SET );
if( lInsert )
{
/* insert mode, insert the length of new string + crlf */
err = _ins_buff( iDataLen + 2 );
if( !err )
{
_fsSeek( handles[area], offset[area], FS_SET );
err = _writeLine( theData, iDataLen );
}
}
else
{
/* overwrite mode, determine how many bytes over/under */
buffer = ( char * ) hb_xgrab( BUFFSIZE );
/* find length of current line, loop if longer than buffer */
do
{
iRead = _fsRead( handles[area], buffer, BUFFSIZE );
iEOL = _findeol( ( BYTEP ) buffer, iRead );
if( iEOL == 0 )
{
iLineLen += iRead;
}
else
{
iLineLen += iEOL;
break;
}
} while( iRead == BUFFSIZE );
hb_xfree( ( void * ) buffer );
if( (iDataLen+2) <= iLineLen )
{
/* delete excess bytes from current record */
_del_buff( iLineLen - iDataLen - 2 );
/* write the new record's contents */
_fsWrite( handles[area], theData, iDataLen );
}
else
{
/* insert extra bytes into current record */
_ins_buff( iDataLen - iLineLen + 2 );
/* write the new record's contents */
_fsWrite( handles[area], theData, iDataLen );
}
error[area] = _fsError();
err = (error[area]) ? 0 : 1;
}
_retl( err );
}
| fttext.c | 1332 |
| HB_FUNC | FT_FLASTRE(void)
HB_FUNC( FT_FLASTRE )
{
long cur_rec;
long cur_offset;
cur_rec = recno[area];
cur_offset = offset[area];
HB_FUNC_EXEC( FT_FGOBOT );
_retnl( last_rec[area] );
recno[area] = cur_rec;
offset[area] = cur_offset;
}
| fttext.c | 1442 |
| HB_FUNC | FT_FEOF(void)
HB_FUNC( FT_FEOF )
{
_retl( isEof[area] );
}
| fttext.c | 1499 |
| HB_FUNC | FT_FBOF(void)
HB_FUNC( FT_FBOF )
{
_retl( isBof[area] );
}
| fttext.c | 1549 |
| HB_FUNC | FT_FGOTO(void)
HB_FUNC( FT_FGOTO )
{
long target = _parnl(1);
/* if a recno was passed, do a relative skip */
if( target )
{
/* skip relative */
target -= recno[area];
if( target )
_ft_skip( target );
}
else
{
/* goto 0 passed, go top then skip back */
target = recno[area];
offset[area] = 0L;
recno[area] = 1L;
isBof[area] = FALSE;
isEof[area] = FALSE;
if( --target )
_ft_skip( target );
}
error[area] = _fsError();
}
/*----------------------------------------------------------------------
_findeol() - In-line assembler routine to parse a buffer
for a CRLF pair
Returns count to first character _after_ next
CRLF pair (beginning of next line). Current line
will contain the trailing CRLF. 1Ah and trailing
LFs will be ignored (included in count).
If no CRLF found return is zero. (could mean EOF or
line is longer than buffer end)
| fttext.c | 1609 |
| STATIC INT | _findeol( BYTEP buf, int buf_len )
------------------------------------------------------------------------*/
static int _findeol( BYTEP buf, int buf_len )
{
int tmp;
for( tmp = 0; tmp < buf_len; tmp++ )
{
if( buf[ tmp ] == FT_CHR_CR && buf[ tmp + 1 ] == FT_CHR_LF )
return tmp + 2;
else if( buf[ tmp ] == FT_CHR_LF )
return tmp + 1;
}
return 0;
/*
ASM
{
push di ; save flags and registers
push es
pushf
cld ; move forward
les di, buf ; point to buffer
mov bx, di ; save buffer start for offset calc later
mov cx, buf_len ; scan entire buffer
mov al, 13
_feol1:repne scasb ; look for a CR
jcxz _feolerr ; no find, return entire buffer
cmp es:[di], 10 ; got a CRLF pair?
jne _feol1 ; no, try again
inc di ; yes, point to first character after CR and return
mov ax, di ; subtract current pointer pos from start to
sub ax, bx ; learn offset within buffer
jmp _feoldone
_feolerr:
mov ax, 0
_feoldone:
popf
pop es
pop di
}
*/
} /* end _findeol() */
/*----------------------------------------------------------------------
_findbol() - In-line assembler routine to parse a buffer
for a CRLF pair
buf pointer points at beginning of search (end
of the buffer), all searches are conducted
backwards, returns No. of characters betw.
initial position and first character _after_
the preceding CRLF pair (beginning of line).
| fttext.c | 1651 |
| STATIC INT | _findbol( BYTEP buf, int buf_len )
------------------------------------------------------------------------*/
static int _findbol( BYTEP buf, int buf_len )
{
int tmp = buf_len - 1;
if( tmp != 0 )
{
BYTEP p = buf - 1;
BYTE b = *p;
if( b == FT_CHR_EOF )
{
p--;
tmp--;
if( tmp == 0 )
return buf_len;
}
if( b == FT_CHR_LF )
{
p--;
tmp--;
if( tmp == 0 )
return buf_len;
if( *p == FT_CHR_CR )
{
p--;
tmp--;
if( tmp == 0 )
return buf_len;
}
}
for( ; tmp > 0; tmp--, p-- )
{
if( *p == FT_CHR_LF && *( p - 1 ) == FT_CHR_CR )
return buf_len - ( tmp + 2 ) + 1;
else if( *p == FT_CHR_LF )
return buf_len - ( tmp + 1 ) + 1;
}
}
return buf_len;
} /* end _findbol() */
| fttext.c | 1710 |
| STATIC INT | _ins_buff( int iLen )
/* inserts xxx bytes into the current file, beginning at the current record */
/* the contents of the inserted bytes are indeterminate, i.e. you'll have to
write to them before they mean anything */
static int _ins_buff( int iLen )
{
char * ReadBuff = ( char * ) hb_xgrab( BUFFSIZE );
char * WriteBuff = ( char * ) hb_xgrab( BUFFSIZE );
char * SaveBuff;
long fpRead, fpWrite;
int WriteLen, ReadLen;
int SaveLen;
int iLenRemaining = iLen;
/* set target move distance, this allows iLen to be greater than
BUFFSIZE */
iLen = __min( iLenRemaining, BUFFSIZE );
iLenRemaining -= iLen;
/* initialize file pointers */
fpRead = offset[area];
fpWrite= offset[area] + iLen;
/* do initial load of both buffers */
_fsSeek( handles[area], fpRead, FS_SET );
WriteLen = _fsRead( handles[area], WriteBuff, BUFFSIZE );
fpRead += WriteLen;
ReadLen = _fsRead( handles[area], ReadBuff, BUFFSIZE );
fpRead += ReadLen;
error[area] = 0;
while( !error[area] && iLen > 0 )
{
while( WriteLen > 0 )
{
/* position to beginning of write area */
if( _fsSeek( handles[area], fpWrite, FS_SET ) != (unsigned long) fpWrite )
{
error[area] = _fsError();
break;
}
SaveLen = _fsWrite( handles[area], WriteBuff, WriteLen );
if( !SaveLen )
{
error[area] = _fsError();
break;
}
/* move write pointer */
fpWrite += SaveLen;
if( SaveLen != WriteLen )
{
/* error, fetch errcode and quit */
error[area] = _fsError();
break;
}
/* WriteLen = SaveLen; */
/* swap buffers */
SaveBuff = WriteBuff;
WriteBuff = ReadBuff ;
ReadBuff = SaveBuff ;
WriteLen = ReadLen ;
/* return to read area and read another buffer */
_fsSeek( handles[area], fpRead, FS_SET );
ReadLen = _fsRead( handles[area], ReadBuff, BUFFSIZE );
fpRead += ReadLen;
}
iLen = __min( iLenRemaining, BUFFSIZE );
iLenRemaining -= iLen;
}
/* store length in bytes, set EOF marker for DOS */
lastbyte[area] = _fsSeek( handles[area], fpWrite, FS_SET );
_fsWrite( handles[area], WriteBuff, 0 );
/* clear last_rec so next gobot will recount the records */
last_rec[area] = 0L;
_fsSeek( handles[area], offset[area], FS_SET );
hb_xfree( ( void * ) ReadBuff );
hb_xfree( ( void * ) WriteBuff );
return error[area];
}
| fttext.c | 1803 |
| STATIC INT | _del_buff( int iLen )
/* deletes xxx bytes from the current file, beginning at the current record */
static int _del_buff( int iLen )
{
char * WriteBuff = ( char * ) hb_xgrab( BUFFSIZE );
long fpRead, fpWrite;
int WriteLen;
int SaveLen;
/* initialize file pointers */
fpWrite = offset[area];
fpRead = offset[area] + iLen;
/* do initial load of buffer */
_fsSeek( handles[area], fpRead, FS_SET );
WriteLen = _fsRead( handles[area], WriteBuff, BUFFSIZE );
fpRead += WriteLen;
error[area] = 0;
while( WriteLen > 0 )
{
/* position to beginning of write area */
_fsSeek( handles[area], fpWrite, FS_SET );
SaveLen = _fsWrite( handles[area], WriteBuff, WriteLen );
/* move write pointer */
fpWrite += SaveLen;
if( SaveLen != WriteLen )
{
/* error, fetch errcode and quit */
error[area] = _fsError();
break;
}
/* return to read area and read another buffer */
_fsSeek( handles[area], fpRead, FS_SET );
WriteLen = _fsRead( handles[area], WriteBuff, BUFFSIZE );
fpRead += WriteLen;
}
/* store length in bytes, set EOF marker for DOS */
lastbyte[area] = _fsSeek( handles[area], fpWrite, FS_SET );
_fsWrite( handles[area], WriteBuff, 0 );
/* clear last_rec so next gobot will recount the records */
last_rec[area] = 0L;
_fsSeek( handles[area], offset[area], FS_SET );
hb_xfree( ( void * ) WriteBuff );
return error[area];
}
| fttext.c | 1900 |
| STATIC INT | _writeLine( char * theData, int iDataLen )
/* writes a line of data to the file, including the terminating CRLF */
static int _writeLine( char * theData, int iDataLen )
{
int err = 0;
if( !( _fsWrite( handles[area], theData, iDataLen ) == iDataLen ) )
{
err = 1;
error[area] = _fsError();
}
else
if( !_writeeol( handles[area] ) )
{
err = 1;
error[area] = _fsError();
}
return err;
}
| fttext.c | 1959 |
| STATIC BOOL | _writeeol( FHANDLE fhnd )
static BOOL _writeeol( FHANDLE fhnd )
{
char * crlf = hb_conNewLine();
int len = strlen( crlf );
return ( _fsWrite( fhnd, crlf, len ) == len );
}
| fttext.c | 1979 |
| getenvrn.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_GETE(void)
HB_FUNC( FT_GETE )
{
/* INTERNALS WARNING: All references to 'environ', strlen(), ;
strcpy(), and strcat() are undocumented Clipper 5.0 internals.
*/
#if defined(HB_OS_DOS) || defined(OS_UNIX_COMPATIBLE)
{
char *buffer = NULL;
int x;
int buffsize = 0;
int rettype = NORETURN;
if( ISCHAR( 1 ) )
rettype = CHARTYPE;
if( ISARRAY( 1 ) )
rettype = ARRAYTYPE;
/* scan strings first and add up total size */
if( rettype == CHARTYPE )
{
for( x = 0; environ[x]; x++ )
{
/* add length of this string plus 2 for the crlf */
buffsize += ( strlen( environ[x] ) + 2 );
}
/* add 1 more byte for final nul character */
buffsize++;
/* now allocate that much memory and make sure 1st byte is a nul */
buffer = ( char * ) hb_xalloc( buffsize + 1 );
buffer[0] = '\0';
}
for( x = 0; environ[x]; x++ )
{
if( !environ[x] )
/* null string, we're done */
break;
if( rettype == CHARTYPE )
{
/* tack string onto end of buffer */
strcat( buffer, environ[x] );
/* add crlf at end of each string */
strcat( buffer, CRLF );
}
else if( rettype == ARRAYTYPE )
/* store string to next array element */
hb_storc( environ[x], 1, x + 1 );
}
if( rettype == CHARTYPE )
{
/* return buffer to app and free memory */
hb_storc( buffer, 1 );
hb_xfree( buffer );
}
/* return number of strings found */
hb_retni( x );
}
#elif defined(HB_OS_WIN_32)
{
char *buffer = NULL;
LPVOID lpEnviron = GetEnvironmentStringsA();
char *sCurEnv;
int x;
int buffsize = 0;
int rettype = NORETURN;
if( ISCHAR( 1 ) )
rettype = CHARTYPE;
if( ISARRAY( 1 ) )
rettype = ARRAYTYPE;
if( rettype == CHARTYPE )
/* scan strings first and add up total size */
{
for( sCurEnv = ( LPSTR ) lpEnviron; *sCurEnv; sCurEnv++ )
{
{
if( !*sCurEnv )
/* null string, we're done */
break;
/* add length of this string plus 2 for the crlf */
buffsize += ( strlen( ( char * ) sCurEnv ) + 2 );
}
/* add 1 more byte for final nul character */
buffsize++;
/* now allocate that much memory and make sure 1st byte is a nul */
buffer = ( char * ) hb_xalloc( buffsize );
strcpy( buffer, "\0" );
while( *sCurEnv )
sCurEnv++;
}
}
x = 0;
for( sCurEnv = ( LPSTR ) lpEnviron; *sCurEnv; sCurEnv++ )
{
if( !*sCurEnv )
/* null string, we're done */
break;
if( rettype == CHARTYPE )
{
/* tack string onto end of buffer */
strcat( buffer, ( char * ) sCurEnv );
/* add crlf at end of each string */
strcat( buffer, CRLF );
}
if( rettype == ARRAYTYPE )
/* store string to next array element */
hb_storc( ( char * ) sCurEnv, 1, x + 1 );
x++;
while( *sCurEnv )
sCurEnv++;
}
if( rettype == CHARTYPE )
{
/* return buffer to app and free memory */
hb_storc( buffer, 1 );
hb_xfree( buffer );
}
/* return number of strings found */
hb_retni( x );
FreeEnvironmentStrings( ( LPTSTR ) lpEnviron );
}
#endif
}
| getenvrn.c | 120 |
| getver.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | _GET_DOSVER(void)
HB_FUNC( _GET_DOSVER )
{
#if defined(HB_OS_DOS)
{
char * pszPlatform;
union REGS regs;
pszPlatform = ( char * ) hb_xgrab( 256 );
regs.h.ah = 0x30;
HB_DOS_INT86( 0x21, ®s, ®s );
snprintf( pszPlatform, 256, "%d.%02d", regs.h.al, regs.h.ah );
hb_retc_buffer( pszPlatform );
}
#endif
}
| getver.c | 62 |
| HB_FUNC | _FT_ISSHARE(void)
HB_FUNC( _FT_ISSHARE )
{
int iShare;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax = 0x1000;
regs.HB_XREGS.cx = 0;
HB_DOS_INT86( 0x2F, ®s, ®s );
iShare = regs.h.al;
}
#else
{
iShare = 0;
}
#endif
hb_retni( iShare );
}
| getver.c | 80 |
| HB_FUNC | _FT_NWKSTAT(void)
HB_FUNC( _FT_NWKSTAT )
{
int iConnect;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax = 0xDC;
HB_DOS_INT86( 0x2F, ®s, ®s );
iConnect = regs.h.al;
}
#else
{
iConnect = 0;
}
#endif
hb_retni( iConnect );
}
| getver.c | 100 |
| HB_FUNC | _FT_SETMODE(void)
HB_FUNC( _FT_SETMODE )
{
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.h.ah = 0;
regs.h.al = hb_parni( 1 );
HB_DOS_INT86( 0x10, ®s, ®s );
}
#endif
}
| getver.c | 118 |
| HB_FUNC | _FT_GETMODE(void)
HB_FUNC( _FT_GETMODE )
{
int iMode;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.h.ah = 0x0F;
HB_DOS_INT86( 0x10, ®s, ®s );
iMode = regs.h.al;
}
#else
{
iMode = 0;
}
#endif
hb_retni( iMode );
}
| getver.c | 130 |
| HB_FUNC | _FT_TEMPFIL(void)
HB_FUNC( _FT_TEMPFIL )
{
int nax;
int iflags;
char * cPath;
#if defined(HB_OS_DOS) && !defined(HB_OS_DOS_32)
{
int iMode = hb_parni( 2 );
union REGS regs;
struct SREGS sregs;
segread( &sregs );
cPath = hb_parcx( 1 );
regs.h.ah = 0x5A;
regs.HB_XREGS.cx = iMode;
sregs.ds = FP_SEG( cPath );
regs.HB_XREGS.dx = FP_OFF( cPath );
HB_DOS_INT86X( 0x21, ®s, ®s, &sregs );
nax = regs.HB_XREGS.ax;
iflags = regs.HB_XREGS.flags;
}
#else
{
nax = 0;
iflags = 0;
cPath = hb_parcx( 1 );
}
#endif
{
PHB_ITEM pArray = hb_itemArrayNew( 3 );
PHB_ITEM pAx = hb_itemPutNI( NULL, nax );
PHB_ITEM pDs = hb_itemPutC( NULL, cPath );
PHB_ITEM pFlags = hb_itemPutNI( NULL, iflags );
hb_itemArrayPut( pArray, 1, pAx );
hb_itemArrayPut( pArray, 2, pDs );
hb_itemArrayPut( pArray, 3, pFlags);
hb_itemReturn( pArray );
hb_itemRelease( pAx);
hb_itemRelease( pDs );
hb_itemRelease( pFlags );
hb_itemRelease( pArray );
}
}
| getver.c | 148 |
| getvid.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | _FT_GETVPG(void)
HB_FUNC( _FT_GETVPG )
{
int iPage;
#if defined(HB_OS_DOS)
{
union REGS registers;
registers.h.ah = 0x0F;
HB_DOS_INT86( 0x10, ®isters, ®isters );
iPage = registers.h.bh;
}
#else
{
iPage = 0;
}
#endif
hb_retni( iPage );
}
| getvid.c | 59 |
| HB_FUNC | _V_SETVPG(void)
HB_FUNC( _V_SETVPG )
{
#if defined(HB_OS_DOS)
{
int iPage;
union REGS registers;
iPage = hb_parni( 1 );
registers.h.ah = 0x05;
registers.h.al = iPage;
HB_DOS_INT86( 0x10, ®isters, ®isters );
}
#endif
}
| getvid.c | 79 |
| iamidle.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_IAMIDLE(void)
HB_FUNC( FT_IAMIDLE )
{
hb_releaseCPU();
}
| iamidle.c | 108 |
| kspeed.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_SETRATE(void)
HB_FUNC( FT_SETRATE )
{
#if defined(HB_OS_DOS)
{
union REGS registers;
int tempo = 0, nrepete = 0;
switch( hb_pcount() )
{
case 0:
tempo = 0;
nrepete = 0;
break;
case 1:
tempo = hb_parni( 1 );
nrepete = 0;
break;
case 2:
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, ®isters, ®isters );
}
#endif
}
| kspeed.c | 151 |
| mkdir.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_MKDIR(void)
HB_FUNC(FT_MKDIR)
{
hb_retl( ISCHAR( 1 ) && hb_fsMkDir( ( BYTE * ) hb_parc(1) ) );
}
| mkdir.c | 86 |
| mouse.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | _MGET_PAGE(void)
HB_FUNC( _MGET_PAGE )
{
int iPage;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax = 0x1E;
HB_DOS_INT86( 0x33, ®s, ®s );
iPage = regs.HB_XREGS.bx;
}
#else
{
iPage = 0;
}
#endif
hb_retni( iPage );
}
| mouse.c | 61 |
| HB_FUNC | _MSET_PAGE(void)
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, ®s, ®s );
}
#endif
}
| mouse.c | 79 |
| HB_FUNC | _MGET_MVERSION(void)
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, ®s, ®s );
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 );
}
}
| mouse.c | 91 |
| HB_FUNC | _MGET_HORISPEED(void)
HB_FUNC( _MGET_HORISPEED )
{
int iSpeed;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax = 0x1B;
HB_DOS_INT86( 0x33, ®s, ®s );
iSpeed = regs.HB_XREGS.bx;
}
#else
{
iSpeed = 0;
}
#endif
hb_retni( iSpeed );
}
| mouse.c | 143 |
| HB_FUNC | _MGET_VERSPEED(void)
HB_FUNC( _MGET_VERSPEED )
{
int iSpeed;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax = 0x1B;
HB_DOS_INT86( 0x33, ®s, ®s );
iSpeed = regs.HB_XREGS.cx;
}
#else
{
iSpeed = 0;
}
#endif
hb_retni( iSpeed );
}
| mouse.c | 162 |
| HB_FUNC | _MGET_DOUBLESPEED(void)
HB_FUNC( _MGET_DOUBLESPEED )
{
int iSpeed;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax = 0x1B;
HB_DOS_INT86( 0x33, ®s, ®s );
iSpeed = regs.HB_XREGS.dx;
}
#else
{
iSpeed = 0;
}
#endif
hb_retni( iSpeed );
}
| mouse.c | 180 |
| HB_FUNC | _MSET_SENSITIVE(void)
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, ®s, ®s );
}
#endif
}
| mouse.c | 198 |
| HB_FUNC | _MSE_CONOFF(void)
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, ®s, ®s );
}
#endif
}
| mouse.c | 212 |
| HB_FUNC | _MGET_MICS(void)
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, ®s, ®s );
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 );
}
}
| mouse.c | 227 |
| HB_FUNC | _M_RESET(void)
HB_FUNC( _M_RESET )
{
int iMouse;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax = 0;
HB_DOS_INT86( 0x33, ®s, ®s );
iMouse = regs.HB_XREGS.ax;
}
#else
{
iMouse = 0;
}
#endif
{
hb_retl( iMouse );
}
}
| mouse.c | 262 |
| HB_FUNC | _MSE_SHOWCURS(void)
HB_FUNC( _MSE_SHOWCURS )
{
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax = 1;
HB_DOS_INT86( 0x33, ®s, ®s );
}
#endif
}
| mouse.c | 282 |
| HB_FUNC | _MSE_MHIDECRS(void)
HB_FUNC( _MSE_MHIDECRS )
{
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax = 2;
HB_DOS_INT86( 0x33, ®s, ®s );
}
#endif
}
| mouse.c | 293 |
| HB_FUNC | _MSE_GETPOS(void)
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, ®s, ®s );
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 );
}
}
| mouse.c | 304 |
| HB_FUNC | _M_GETX(void)
HB_FUNC( _M_GETX )
{
int iRow;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax = 3;
HB_DOS_INT86( 0x33, ®s, ®s );
iRow = regs.HB_XREGS.dx;
}
#else
{
iRow = 0;
}
#endif
hb_retni( iRow );
}
| mouse.c | 338 |
| HB_FUNC | _M_GETY(void)
HB_FUNC( _M_GETY )
{
int iCol;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax = 3;
HB_DOS_INT86( 0x33, ®s, ®s );
iCol = regs.HB_XREGS.cx;
}
#else
{
iCol = 0;
}
#endif
hb_retni( iCol );
}
| mouse.c | 356 |
| HB_FUNC | _M_MSETPOS(void)
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, ®s, ®s );
}
#endif
}
| mouse.c | 374 |
| HB_FUNC | _M_MSETCOORD(void)
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, ®s, ®s );
}
#endif
}
| mouse.c | 387 |
| HB_FUNC | _M_MXLIMIT(void)
HB_FUNC( _M_MXLIMIT )
{
#if defined(HB_OS_DOS)
{
union REGS regs;
int iMaxRow = hb_parni( 2 );
int iMinRow = hb_parni( 1 );
regs.HB_XREGS.ax = 7;
regs.HB_XREGS.cx = iMinRow;
regs.HB_XREGS.dx = iMaxRow;
HB_DOS_INT86( 0x33, ®s, ®s );
}
#endif
}
| mouse.c | 400 |
| HB_FUNC | _M_MYLIMIT(void)
HB_FUNC( _M_MYLIMIT )
{
#if defined(HB_OS_DOS)
{
union REGS regs;
int iMaxCol = hb_parni( 2 );
int iMinCol = hb_parni( 1 );
regs.HB_XREGS.ax = 8;
regs.HB_XREGS.cx = iMinCol;
regs.HB_XREGS.dx = iMaxCol;
HB_DOS_INT86( 0x33, ®s, ®s );
}
#endif
}
| mouse.c | 418 |
| HB_FUNC | _M_MBUTPRS(void)
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, ®s, ®s );
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 );
}
}
| mouse.c | 434 |
| HB_FUNC | _M_MBUTREL(void)
HB_FUNC( _M_MBUTREL )
{
#if defined(HB_OS_DOS)
union REGS regs;
regs.HB_XREGS.ax = 0x0A;
regs.HB_XREGS.bx = hb_parni( 1 );
HB_DOS_INT86( 0x33, ®s, ®s );
hb_reta( 4 );
hb_storni( regs.HB_XREGS.bx, -1, 1 );
hb_storni( regs.HB_XREGS.cx, -1, 2 );
hb_storni( regs.HB_XREGS.dx, -1, 3 );
hb_storni( regs.HB_XREGS.ax, -1, 4 );
#else
hb_reta( 4 );
hb_storni( 0, -1, 1 );
hb_storni( 0, -1, 2 );
hb_storni( 0, -1, 3 );
hb_storni( 0, -1, 4 );
#endif
}
| mouse.c | 482 |
| HB_FUNC | _M_MDEFCRS(void)
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, ®s, ®s );
}
#endif
}
| mouse.c | 505 |
| HB_FUNC | _M_MGETCOORD(void)
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, ®s, ®s );
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 );
}
}
| mouse.c | 520 |
| n2color.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_N2COLOR(void)
HB_FUNC( FT_N2COLOR )
{
int iColor = ISNUM( 1 ) ? hb_parni( 1 ) : -1;
if( iColor >= 0x00 && iColor <= 0xff )
{
char szColorString[ 10 ];
hb_gtColorsToString( &iColor, 1, szColorString, 10 );
hb_retc( szColorString );
}
else
hb_retc( NULL );
}
| n2color.c | 57 |
| numlock.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_NUMLOCK(void)
HB_FUNC( FT_NUMLOCK )
{
int iState = 0, iNewState;
HB_GT_INFO gtInfo;
gtInfo.pNewVal = gtInfo.pResult = NULL;
hb_gtInfo( GTI_KBDSHIFTS, >Info );
if( gtInfo.pResult )
{
iState = hb_itemGetNI( gtInfo.pResult );
gtInfo.pNewVal = gtInfo.pResult;
gtInfo.pResult = NULL;
}
if( ISLOG( 1 ) )
{
iNewState = hb_parl( 1 ) ? ( iState | GTI_KBD_NUMLOCK ) :
( iState & ~GTI_KBD_NUMLOCK );
gtInfo.pNewVal = hb_itemPutNI( gtInfo.pNewVal, iNewState );
hb_gtInfo( GTI_KBDSHIFTS, >Info );
}
if( gtInfo.pNewVal )
hb_itemRelease( gtInfo.pNewVal );
if( gtInfo.pResult )
hb_itemRelease( gtInfo.pResult );
hb_retl( ( iState & GTI_KBD_NUMLOCK ) != 0 );
}
| numlock.c | 79 |
| ontick.c |
| Type | Function | Source | Line |
|---|
| STATIC VOID CDECL | TickTock( void )
static void cdecl TickTock( void )
{
auto unsigned int ProtMode = cpmiIsProtected();
auto LONGPTR Timer;
auto EVALINFO eval;
if ( inProgress ) return;
inProgress = 1;
if ( ProtMode )
{
Timer.Pointer.Segment = cpmiProtectedPtr( ( long * ) ( 0x0000046C ), sizeof( long ) );
Timer.Pointer.Offset = 0;
if ( Timer.Pointer.Segment == 0 ) goto Exit;
}
else
Timer.Address = ( long * ) ( 0x0000046C );
if ( *Timer.Address >= ( Ticks + Interval ) ||
( *Timer.Address < Ticks ) )
{
Ticks = *Timer.Address;
_evalNew( &eval, codeBlock );
_itemRelease( _evalLaunch( &eval ) );
}
if ( ProtMode ) cpmiFreeSelector( Timer.Pointer.Segment );
Exit: inProgress = 0;
return;
}
| ontick.c | 90 |
| CLIPPER | FT_OnTick( void )
CLIPPER FT_OnTick( void )
{
if ( _itemType( codeBlock ) == BLOCK ) _itemRelease( codeBlock );
codeBlock = _itemParam( 1 );
if ( _itemType( codeBlock ) == BLOCK )
{
Interval = _parnl( 2 );
_evLow( 5, TickTock, TRUE );
}
else
_evLow( 5, TickTock, FALSE );
return;
}
| ontick.c | 128 |
| origin.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_ORIGIN(void)
HB_FUNC( FT_ORIGIN )
{
hb_retc( hb_cmdargARGV()[ 0 ] );
}
| origin.c | 65 |
| peek.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_PEEK(void)
HB_FUNC(FT_PEEK)
{
auto unsigned int ProtMode = cpmiIsProtected();
auto unsigned char * bytePtr;
if ( ( PCOUNT >= 2 ) && ( ISNUM( 1 ) ) && ( ISNUM( 2 ) ) )
{
FP_SEG( bytePtr ) = _parni( 1 );
FP_OFF( bytePtr ) = _parni( 2 );
if ( ProtMode )
{
FP_SEG( bytePtr ) = hb_cpmiProtectedPtr( bytePtr, 1 );
FP_OFF( bytePtr ) = 0;
if ( FP_SEG( bytePtr ) == 0 ) goto Bogus;
}
_retni( ( int ) *bytePtr );
if ( ProtMode ) hb_cpmiFreeSelector( FP_SEG( bytePtr ) );
}
else
Bogus: _retni( -1 );
return;
}
| peek.c | 68 |
| poke.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_POKE(void)
HB_FUNC( FT_POKE )
{
auto unsigned int ProtMode = hb_cpmiIsProtected();
auto unsigned char * bytePtr;
if ( ( PCOUNT >= 3 ) && ( ISNUM( 1 ) ) && ( ISNUM( 2 ) ) && ( ISNUM( 3 ) ) )
{
FP_SEG( bytePtr ) = _parni( 1 );
FP_OFF( bytePtr ) = _parni( 2 );
if ( ProtMode )
{
FP_SEG( bytePtr ) = hb_cpmiProtectedPtr( bytePtr, 1 );
FP_OFF( bytePtr ) = 0;
if ( FP_SEG( bytePtr ) == 0 ) goto Bogus;
}
*bytePtr = ( unsigned char ) _parni( 3 );
if ( ProtMode ) hb_cpmiFreeSelector( FP_SEG( bytePtr ) );
_retl( TRUE );
}
else
Bogus: _retl( FALSE );
return;
}
| poke.c | 71 |
| proper.c |
| Type | Function | Source | Line |
|---|
| STATIC CHAR | _ftToLower( char c )
static char _ftToLower( char c )
{
return(c >= 'A' && c <= 'Z' ? c - 'A' + 'a' : c);
}
| proper.c | 75 |
| STATIC CHAR | _ftToUpper( char c )
static char _ftToUpper( char c )
{
return(c >= 'a' && c <= 'z' ? c - 'a' + 'A' : c);
}
| proper.c | 80 |
| STATIC INT | _ftIsUpper( char c )
static int _ftIsUpper( char c )
{
return(c >= 'A' && c <= 'Z');
}
| proper.c | 85 |
| STATIC INT | _ftIsLower( char c )
static int _ftIsLower( char c )
{
return(c >= 'a' && c <= 'z');
}
| proper.c | 90 |
| STATIC INT | _ftIsAlpha( char c )
static int _ftIsAlpha( char c )
{
return( _ftIsUpper(c) || _ftIsLower(c));
}
| proper.c | 95 |
| HB_FUNC | FT_PROPER(void)
HB_FUNC( FT_PROPER )
{
int iLen = hb_parclen(1);
char *cStr, *cDst = NULL;
int i, fCap = TRUE; /*, iPos = 0; */
hb_storc( NULL, 1 );
cStr = hb_parc(1);
for( i = 0; i < iLen; i++ ) {
if( _ftIsAlpha( cStr[i] ) != 0 ) {
if( !cDst ) {
cDst = (char *) hb_xgrab(iLen + 1);
memcpy(cDst, cStr, iLen + 1);
cStr = cDst;
}
if( fCap != 0 )
cStr[i] = _ftToUpper( cStr[i] );
else
cStr[i] = _ftToLower( cStr[i] );
}
fCap = ( cStr[i] == ' ' || cStr[i] == '-' || cStr[i] == 0x27 );
}
/* Find "Mc" */
if( cDst ) {
for( i = 0; i < iLen - 2; i++ )
if( cStr[i] == 'M' && cStr[i+1] == 'c' ) {
cStr[i+2] = _ftToUpper( cStr[i+2] );
}
}
/* // If "Mc" was found, Cap next letter if Alpha
if( iPos > 1 )
if( iPos < iLen )
if( _ftIsUpper( cStr[iPos] ) == FALSE )
cStr[iPos] = _ftToUpper( cStr[iPos] );
*/
if( cDst )
hb_retclen_buffer( cDst, iLen );
else
hb_retclen( cStr, iLen );
}
| proper.c | 100 |
| prtscr.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_PRTSCR(void)
HB_FUNC( FT_PRTSCR )
{
#if defined(HB_OS_DOS)
if ( hb_pcount() && ISLOG( 1 ) )
{
if ( hb_parl( 1 ) )
pbyte = 0;
else
pbyte = 1;
}
if ( pbyte == 1)
hb_retl( FALSE );
else
hb_retl( TRUE );
#else
hb_retl( FALSE );
#endif
}
| prtscr.c | 64 |
| putkey.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_PUTKEY(void)
HB_FUNC( FT_PUTKEY )
{
BOOL lSuccess = FALSE;
if( ISNUM( 1 ) )
{
int iKey = hb_parni(1);
if( iKey >= -39 && iKey <= 385 )
{
hb_inkeyPut( iKey );
lSuccess = TRUE;
}
}
hb_retl( lSuccess );
}
| putkey.c | 245 |
| rmdir.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_RMDIR(void)
HB_FUNC(FT_RMDIR)
{
hb_retl( ISCHAR( 1 ) && hb_fsRmDir( ( BYTE * ) hb_parc(1) ) );
}
| rmdir.c | 85 |
| setkeys.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_SETKEYS(void)
HB_FUNC( FT_SETKEYS )
{
HB_FUNC_EXEC( HB_SETKEYSAVE )
}
| setkeys.c | 109 |
| setlastk.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_LASTKEY(void)
HB_FUNC( FT_LASTKEY )
{
HB_FUNC_EXEC( HB_SETLASTKEY )
}
| setlastk.c | 109 |
| shift.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_SHIFT(void)
HB_FUNC( FT_SHIFT )
{
HB_GT_INFO gtInfo;
gtInfo.pNewVal = gtInfo.pResult = NULL;
hb_gtInfo( GTI_KBDSHIFTS, >Info );
hb_retl( ( hb_itemGetNI( gtInfo.pResult ) & GTI_KBD_SHIFT ) != 0 );
if( gtInfo.pResult )
hb_itemRelease( gtInfo.pResult );
}
| shift.c | 65 |
| stod.c |
| Type | Function | Source | Line |
|---|
| HB_FUNC | FT_STOD(void)
HB_FUNC(FT_STOD)
{
hb_retds( hb_parclen( 1 ) >= 8 ? hb_parc( 1 ) : NULL );
}
| stod.c | 54 |
| aading.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN()
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
| aading.prg | 75 |
| FUNCTION | FT_AADDITION( aList1, aList2, lTrimmer, lCaseSens )
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| 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 )
| aading.prg | 113 |
| aavg.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_AAVG(aArray, nStartIndex, nEndIndex)
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)))
| aavg.prg | 73 |
| acctadj.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_ACCTADJ(dGivenDate, lIsEnd)
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
| acctadj.prg | 92 |
| acctmnth.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_ACCTMONTH(dGivenDate,nMonthNum)
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
| acctmnth.prg | 84 |
| acctqtr.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_ACCTQTR(dGivenDate,nQtrNum)
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
| acctqtr.prg | 84 |
| acctweek.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_ACCTWEEK(dGivenDate,nWeekNum)
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
| acctweek.prg | 84 |
| acctyear.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_ACCTYEAR(dGivenDate)
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
| acctyear.prg | 75 |
| adessort.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_ADESSORT(aArray, nStartIndex, nEndIndex)
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 } ))
| adessort.prg | 75 |
| aemaxlen.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN()
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
| aemaxlen.prg | 73 |
| FUNCTION | FT_AEmaxlen( aArray, nDimension, nStart, nCount )
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 )
| aemaxlen.prg | 101 |
| aeminlen.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN()
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
| aeminlen.prg | 70 |
| FUNCTION | FT_AEminlen( aArray, nDimension, nStart, nCount )
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 )
| aeminlen.prg | 101 |
| amedian.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN()
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,,)]
| amedian.prg | 71 |
| FUNCTION | FT_AMEDIAN( aArray, nStart, nEnd )
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 )
| amedian.prg | 106 |
| anomatch.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_ANOMATCHES(aArray, bCompareBlock, nStartIndex, nEndIndex)
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
| anomatch.prg | 78 |
| any2any.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_XTOY(xValueToConvert, cTypeToConvertTo, lWantYesNo)
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
| any2any.prg | 99 |
| aredit.prg |
| Type | Function | Source | Line |
|---|
| PROCEDURE | 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
| aredit.prg | 130 |
| FUNCTION | TestGet( b, ar, nDim, nElem)
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.)
| aredit.prg | 161 |
| FUNCTION | FT_ArEdit( nTop, nLeft, nBot, nRight, ar, nElem, aHeadings, aBlocks, bGetFunc)
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, 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()
| aredit.prg | 189 |
| asum.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_ASUM(aArray, nStartIndex, nEndIndex)
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
| asum.prg | 72 |
| at2.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN()
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
| at2.prg | 72 |
| FUNCTION | FT_AT2( cSearch, cTarget, nOccurs, lCaseSens )
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 )
| at2.prg | 99 |
| FUNCTION | FT_RAT2( cSearch, cTarget, nOccurs, lCaseSens )
FUNCTION FT_RAT2( 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 := RAT( cSearch, cSubstr )
ELSE
nPos := RAT( UPPER( cSearch ), UPPER( cSubstr ) )
ENDIF
// Store position of cSearch relative to original string.
nPos2 := nPos
// Resize cSubstr
cSubstr := SUBSTR( cSubstr, 1, RAT( cSearch, cSubstr ) - 1 )
// Breakout if there are no occurences here
IF nPos == 0
EXIT
ENDIF
NEXT
RETURN ( nPos2 )
| at2.prg | 180 |
| bitclr.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_BITCLR(cInbyte, nBitpos)
FUNCTION FT_BITCLR(cInbyte, nBitpos)
LOCAL cByte
IF valtype(cInbyte) != "C" .or. valtype(nBitpos) != "N" // parameter check
cByte := NIL
ELSE
IF (nBitPos > 7) .or. (nBitPos < 0) .or. (nBitPos != int(nBitPos))
cByte := NIL
ELSE
cByte := iif( .not. FT_ISBIT(cInByte, nBitpos), cInByte, ;
chr(asc(cInByte) - (2 ^ nBitpos)))
ENDIF
ENDIF
RETURN cByte
| bitclr.prg | 73 |
| bitset.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_BITSET(cInByte, nBitpos)
FUNCTION FT_BITSET(cInByte, nBitpos)
LOCAL cByte
IF valtype(cInbyte) != "C" .or. valtype(nBitpos) != "N" // parameter check
cByte := NIL
ELSE
IF (nBitPos > 7) .or. (nBitPos < 0) .or. (nBitPos != int(nBitPos))
cByte := NIL
ELSE
cByte := iif( FT_ISBIT(cInByte, nBitpos), cInByte, ;
chr(asc(cInByte) + (2 ^ nBitpos)))
ENDIF
ENDIF
RETURN cByte
| bitset.prg | 75 |
| blink.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN()
FUNCTION MAIN()
FT_BLINK( "WAIT", 5, 10 )
return ( nil )
| blink.prg | 57 |
| FUNCTION | FT_BLINK( cMsg, nRow, nCol )
FUNCTION FT_BLINK( cMsg, nRow, nCol )
* Declare color restore var.
LOCAL cSavColor
* Return if no msg.
IF (cMsg == NIL) ; RETURN NIL; ENDIF
* Set default row and col to current.
nRow := IF( nRow == NIL, ROW(), nRow )
nCol := IF( nCol == NIL, COL(), nCol )
cSavColor := SETCOLOR() // Save colors to restore on exit.
* IF blink colors not already set, add blink to current foreground color.
SETCOLOR( IF( ("*" $ LEFT(cSavColor,4)), cSavColor, "*" + cSavColor ) )
@ nRow, nCol SAY cMsg // Say the dreaded blinking msg.
SETCOLOR( cSavColor ) // It's a wrap, restore colors & exit.
RETURN NIL
| blink.prg | 62 |
| byt2bit.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_BYT2BIT(cByte)
FUNCTION FT_BYT2BIT(cByte)
local nCounter, xBitstring
IF valtype(cByte) != "C"
xBitString := NIL
ELSE
xBitString := ""
FOR nCounter := 7 TO 0 step -1
xBitString += iif(FT_ISBIT(cByte, nCounter), "1", "0")
NEXT
ENDIF
RETURN xBitString
| byt2bit.prg | 70 |
| byt2hex.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_BYT2HEX(cByte)
FUNCTION FT_BYT2HEX(cByte)
local cHexTable := "0123456789ABCDEF"
local xHexString
if valtype(cByte) != "C"
xHexString := NIL
else
xHexString := substr(cHexTable, int(asc(cByte) / 16) + 1, 1) ;
+ substr(cHexTable, int(asc(cByte) % 16) + 1, 1) ;
+ "h"
endif
RETURN xHexString
| byt2hex.prg | 67 |
| byteand.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_BYTEAND(cByte1, cByte2)
FUNCTION FT_BYTEAND(cByte1, cByte2)
LOCAL nCounter, cNewByte
IF valtype(cByte1) != "C" .or. valtype(cByte2) != "C" // parameter check
cNewByte := NIL
ELSE
cNewByte := chr(0)
for nCounter := 0 to 7 // test each bit position
if FT_ISBIT(cByte1, nCounter) .and. FT_ISBIT(cByte2, nCounter)
cNewByte := FT_BITSET(cNewByte, nCounter)
endif
next
ENDIF
RETURN cNewByte
| byteand.prg | 68 |
| byteneg.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_BYTENEG(cByte)
FUNCTION FT_BYTENEG(cByte)
RETURN iif(valtype(cByte) != "C", NIL, chr((256 - asc(cByte)) % 256))
| byteneg.prg | 66 |
| bytenot.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_BYTENOT(cByte)
FUNCTION FT_BYTENOT(cByte)
LOCAL nCounter, cNewByte
IF valtype(cByte) != "C"
cNewByte := NIL
ELSE
cNewByte := chr(0)
FOR nCounter := 0 to 7 // test each bit position
IF .not. FT_ISBIT(cByte, nCounter)
cNewByte := FT_BITSET(cNewByte, nCounter)
ENDIF
NEXT
ENDIF
RETURN cNewByte
| bytenot.prg | 67 |
| byteor.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_BYTEOR(cByte1, cByte2)
FUNCTION FT_BYTEOR(cByte1, cByte2)
LOCAL nCounter, cNewByte
IF valtype(cByte1) != "C" .or. valtype(cByte2) != "C" // parameter check
cNewByte := NIL
ELSE
cNewByte := chr(0)
for nCounter := 0 to 7 // test each bit position
if FT_ISBIT(cByte1, nCounter) .or. FT_ISBIT(cByte2, nCounter)
cNewByte := FT_BITSET(cNewByte, nCounter)
endif
next
ENDIF
RETURN cNewByte
| byteor.prg | 66 |
| bytexor.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_BYTEXOR(cByte1, cByte2)
FUNCTION FT_BYTEXOR(cByte1, cByte2)
LOCAL nCounter, cNewByte
IF valtype(cByte1) != "C" .or. valtype(cByte2) != "C" // parameter check
cNewByte := NIL
ELSE
cNewByte := chr(0)
FOR nCounter := 0 to 7 // test each bit position
IF FT_ISBIT(cByte1, nCounter) .or. FT_ISBIT(cByte2, nCounter)
IF .not. (FT_ISBIT(cByte1, nCounter) .and. FT_ISBIT(cByte2, nCounter))
cNewByte := FT_BITSET(cNewByte, nCounter)
ENDIF
ENDIF
NEXT
ENDIF
RETURN cNewByte
| bytexor.prg | 69 |
| calendar.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN()
FUNCTION MAIN()
local aRet[8], i
setcolor ('w+/b')
cls
if ft_numlock()
ft_numlock( .f. )
endif
keyboard chr (28)
aRet := ft_calendar (10,40,'w+/rb',.t.,.t.) //display calendar, return all.
@1,0 say 'Date :'+dtoc(aRet[1])
@2,0 say 'Month Number:'+str(aRet[2],2,0)
@3,0 say 'Day Number :'+str(aRet[3],2,0)
@4,0 say 'Year Number :'+str(aRet[4],4,0)
@5,0 say 'Month :'+aRet[5]
@6,0 say 'Day :'+aRet[6]
@7,0 say 'Julian Day :'+str(aRet[7],3,0)
@8,0 say 'Current Time:'+aRet[8]
return ( nil )
| calendar.prg | 100 |
| FUNCTION | FT_CALENDAR (nRow, nCol, cColor, lShadow, lShowHelp)
FUNCTION FT_CALENDAR (nRow, nCol, cColor, lShadow, lShowHelp)
LOCAL nJump :=0, nKey :=0, cSavColor, cSaveScreen, cSaveCursor
LOCAL aRetVal[8]
LOCAL nHelpRow, cSaveHelp, lHelpIsDisplayed :=.F.
nRow := IIF ( nRow != NIL, nRow, 1 ) //check display row
nCol := IIF ( nCol != NIL, nCol, 63) //check display col
cColor := IIF ( cColor != NIL, cColor, 'W+/G' ) //check display color
lShadow := IIF ( lShadow == NIL , .F., lShadow ) //check shadow switch
lShowHelp := IIF ( lShowHelp == NIL , .F., lShowHelp )//check help switch
nRow := IIF ( nRow <1 .OR. nRow >21, 1, nRow ) //check row bounds
nCol := IIF ( nCol <1 .OR. nCol >63, 63, nCol ) //check col bounds
cSavColor := SETCOLOR(cColor) //save current and set display color
cSaveScreen := SAVESCREEN ( nRow-1, nCol-1, nRow+3, nCol+17 ) //save screen
cSaveCursor := SETCURSOR (0) // save current and turn off cursor
IF lShadow
@nRow-1,nCol-1 to nRow+2, nCol+15
FT_SHADOW( nRow-1, nCol-1, nRow+2, nCol+15 )
ENDIF
IF lShowHelp
nHelpRow := IIF (nRow > 10 , nRow - 10 , nRow + 6 )
ENDIF
DO WHILE nKey != K_ESC
DO CASE
CASE nKey == K_HOME
nJump = nJump - 1
CASE nKey == K_END
nJump = nJump + 1
CASE nKey == K_UP
nJump = nJump - 30
CASE nKey == K_DOWN
nJump = nJump + 30
CASE nKey == K_PGUP
nJump = nJump - 365
CASE nKey == K_PGDN
nJump = nJump + 365
CASE nKey == K_RIGHT
nJump = nJump - 7
CASE nKey == K_LEFT
nJump = nJump + 7
CASE nKey == K_INS
nJump = 0
CASE nKey == K_F1
IF lShowHelp .AND. .NOT. lHelpIsDisplayed
lHelpIsDisplayed := .T.
cSaveHelp := SAVESCREEN ( nHelpRow-1, 1, nHelpRow+7, 80)
FT_XBOX('L',,,cColor,cColor,nHelpRow,1,;
"Home, Up_Arrow or PgUp keys page by day, month or year to a past date.",;
"End, Dn_Arrow or PgDn keys page by day, month or year to a future date.",;
"Left_Arrow or Right_Arrow keys page by week to a past or future date.",;
"Hit Ins to reset to today's date, F1 to get this help, ESC to quit.")
ENDIF
OTHERWISE
ENDCASE
aRetVal[1] := DATE() + nJump
aRetVal[2] := MONTH( DATE() + nJump )
aRetVal[3] := DAY( DATE() + nJump )
aRetVal[4] := YEAR( DATE() + nJump )
aRetVal[5] := CMONTH( DATE() + nJump )
aRetVal[6] := CDOW( DATE() + nJump )
aRetVal[7] := JDOY( aRetVal[4], aRetVal[2], aRetVal[3] )
@nRow, nCol SAY SUBSTR(aRetval[6],1,3)+' '+;
STR(aRetVal[3],2,0)+' '+;
SUBSTR(aRetVal[5],1,3)+' '+;
STR(aRetVal[4],4,0)
@nRow+1,nCol SAY STR(aRetVal[7],3,0)
nKey := 0
DO WHILE nKey == 0
@nRow+1,nCol+3 SAY ' '+TIME()
nKey := INKEY(1)
ENDDO
aRetVal[8] := TIME()
ENDDO
SETCOLOR ( cSavColor ) //restore colors.
SETCURSOR ( cSaveCursor ) //restore cursor.
RESTSCREEN ( nRow-1, nCol-1, nRow+3, nCol+17, cSaveScreen ) //restore screen.
IF lHelpIsDisplayed
RESTSCREEN (nHelpRow-1, 1, nHelpRow+7, 80, cSaveHelp)
ENDIF
RETURN aRetVal
| calendar.prg | 123 |
| STATIC FUNCTION | JDOY (nYear, nMonth, nDay)
STATIC FUNCTION JDOY (nYear, nMonth, nDay)
LOCAL cString :='000031059090120151181212243273304334'
RETURN ( VALS(cString,(nMonth-1)*3+1,3) + nDay +;
IIF( nYear%4==0.AND.nMonth>2, 1, 0) )
| calendar.prg | 225 |
| STATIC FUNCTION | VALS (cString, nOffset, nChar)
STATIC FUNCTION VALS (cString, nOffset, nChar)
RETURN ( VAL(SUBSTR(cString,nOffset,nChar)) )
* end of calendar.prg
| calendar.prg | 230 |
| clrsel.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | Main( cVidMode )
FUNCTION Main( cVidMode )
LOCAL nRowDos := ROW()
LOCAL nColDos := COL()
LOCAL lBlink := SETBLINK( .F. ) // make sure it starts out .F.
LOCAL aEnvDos := FT_SaveSets()
LOCAL cScrDos := SAVESCREEN( 00, 00, MAXROW(), MAXCOL() )
LOCAL lColour := .F.
LOCAL aClrs := {}
DEFAULT cVidMode TO ""
NOSNOW( ( "NOSNOW" $ UPPER( cVidMode ) ) )
IF "VGA" $ UPPER( cVidMode )
SETMODE( 50, 80 )
ENDIF
IF "EGA" $ UPPER( cVidMode )
SETMODE( 43, 80 )
ENDIF
lColour := IF( "MONO" $ UPPER( cVidMode ), .F., ISCOLOR() )
SET SCOREBOARD Off
SETCURSOR( SC_NONE )
lBlink := SETBLINK( .F. )
*.... a typical application might have the following different settings
* normally these would be stored in a .dbf/.dbv
aClrs := {;
{ "Desktop", "N/BG", "D", "±" }, ;
{ "Title", "N/W", "T" }, ;
{ "Top Menu", "N/BG,N/W,W+/BG,W+/N,GR+/N", "M" }, ;
{ "Sub Menu", "W+/N*,GR+/N*,GR+/N*,W+/R,G+/R","M" }, ;
{ "Standard Gets", "W/B, W+/N,,, W/N", "G" }, ;
{ "Nested Gets", "N/BG, W+/N,,, W/N", "G" }, ;
{ "Help", "N/G, W+/N,,, W/N", "W" }, ;
{ "Error Messages", "W+/R*,N/GR*,,,N/R*", "W" }, ;
{ "Database Query", "N/BG, N/GR*,,,N+/BG", "B" }, ;
{ "Pick List", "N/GR*,W+/B,,, BG/GR*", "A" } ;
}
aClrs := FT_ClrSel( aClrs, lColour )
*.... restore the DOS environment
FT_RestSets( aEnvDos )
RESTSCREEN( 00, 00, MAXROW(), MAXCOL(), cScrDos )
SETPOS( nRowDos, nColDos )
SETBLINK( .F. ) // doesn't appear to be reset from FT_RestSets
RETURN Nil
#ENDIF
*------------------------------------------------
| clrsel.prg | 203 |
| FUNCTION | FT_ClrSel( aClrs, lColour, cChr )
FUNCTION FT_ClrSel( aClrs, lColour, cChr )
// Colour selection routine
// Return -> the same array that was passed but with modified colours
LOCAL aClrOld := aClone( aClrs )
LOCAL aOptions
LOCAL nB, nT, nL, nR
LOCAL nChoice := 1
LOCAL nLen := 0
LOCAL aPrompt := {}
LOCAL aClrPal := {}
LOCAL aClrTab := { "N","B","G","BG","R","RB","GR","W" }
LOCAL aClrBW := { "N","B","W" }
LOCAL nRowSav := ROW()
LOCAL nColSav := COL()
LOCAL aEnvSav := FT_SaveSets()
LOCAL cScrSav := SAVESCREEN( 00, 00, MAXROW(), MAXCOL() )
DEFAULT lColour TO ISCOLOR()
DEFAULT cChr TO chr(254)+chr(254)
cChr := PadR( cChr, 2 )
SETCURSOR( SC_NONE )
SETCOLOR( IIF( lColour, "GR+/N,,N/N", "W+/N,,N/N" ) )
CLS
*.... initialize the colour palette
aClrPal := _ftInitPal( IIF( lColour, aClrTab, aClrBW ) )
*.... paint the colours on the screen
_ftShowPal( aClrPal, cChr )
*.... Determine length of longest name and make sure not greater than 20
aEval( aClrs, { |aOpt| nLen := MAX( nLen, LEN( aOpt[C_NAME] ) ) } )
nLen := MIN( MAX( nLen, 1 ), 20 ) + 2
*.... prepare an array for use with aChoice(); truncate names at 20 chrs.
aPrompt := ARRAY( LEN( aClrs ) )
aEval( aClrs,;
{ |aOpt,nE| aPrompt[nE] := " "+ SUBS(aOpt[C_NAME], 1, nLen-2) +" " };
)
*.... determine co-ordinates for the achoice window
nT := MAX( INT( (18-LEN(aPrompt)) /2 )-1, 1 )
nB := MIN( nT + LEN(aPrompt) + 1, 17 )
nL := MAX( INT( (27-nLen) /2 )-2, 1 )
nR := MIN( nL + nLen + 3, 26 )
*.... set up the window for aChoice
SETCOLOR( IIF( lColour, "N/W,W+/R", "N/W,W+/N" ) )
ClearS( nT, nL, nB, nR )
*.... prompt for colour setting and modify
DO WHILE nChoice != 0
Double( nT, nL+1, nB, nR-1 )
nChoice := aChoice( nt+1, nL+2, nB-1, nR-2, aPrompt, , , nChoice )
IF nChoice != 0
_ftHiLite( ROW(), nL+2, aPrompt[ nChoice ], nLen )
Single( nT, nL+1, nB, nR-1 )
aClrs[ nChoice ] := _ftColours( aClrs[ nChoice ], aClrPal, lColour )
ENDIF
ENDDO
aOptions := { "Save New Colours", "Restore Original" }
IF ! _ftIdentArr( aClrs, aClrOld )
nChoice := ALERT( "Colors have been modified...", aOptions )
ELSE
nChoice := 1
ENDIF
FT_RestSets( aEnvSav )
RESTSCREEN( 00, 00, MAXROW(), MAXCOL(), cScrSav )
SETPOS( nRowSav, nColSav )
RETURN IIF( nChoice == 1, aClrs, aClrOld )
*------------------------------------------------
| clrsel.prg | 255 |
| STATIC FUNCTION | _ftHiLite( nRow, nCol, cStr, nLen )
STATIC FUNCTION _ftHiLite( nRow, nCol, cStr, nLen )
// Highlight the current selected aChoice element
// Return -> Nil
LOCAL cClr := SETCOLOR()
LOCAL aClr := _ftChr2Arr( cClr )
SETCOLOR( aClr[ 2 ] ) // enhanced colour
@ nRow, nCol SAY PadR( cStr, nLen )
SETCOLOR( cClr )
RETURN Nil
*------------------------------------------------
| clrsel.prg | 332 |
| STATIC FUNCTION | _ftColours( aOpt, aClrPal, lColour )
STATIC FUNCTION _ftColours( aOpt, aClrPal, lColour )
// Colour selection for specific type of colour setting
// Return -> aOpt with modified colour strings
LOCAL nB, nT, nL, nR
LOCAL nX := 0
LOCAL aClrs := {}
LOCAL cClr := ""
LOCAL nChoice := 1
LOCAL aPrompt := {}
LOCAL nLen := 0
LOCAL cColour := SETCOLOR()
LOCAL cScrSav := SAVESCREEN( 18, 00, MAXROW(), MAXCOL() )
aSize( aOpt, 4 ) // check incoming parameters
DEFAULT aOpt[ C_CHAR ] TO ""
DEFAULT aOpt[ C_TYPE ] TO "W"
aOpt[ C_CLR ] := UPPER( aOpt[ C_CLR ] ) // need upper case
aOpt[ C_TYPE ] := UPPER( aOpt[ C_TYPE ] )
DEFAULT lColour TO ISCOLOR()
*.... display appropriate prompts based on type of colour setting
nChoice := 1
DO CASE
CASE aOpt[ C_TYPE ] == "D"
aPrompt := { " Color ", " Character " }
CASE aOpt[ C_TYPE ] == "M"
aPrompt := { " Prompt ", " Message ", " HotKey ",;
" LightBar ", " LightBar HotKey " }
CASE aOpt[ C_TYPE ] == "A" .OR. aOpt[ C_TYPE ] == "B"
aPrompt := { " Standard ", " Selected ", " Border ", " Unavailable " }
OTHERWISE
aPrompt := { " Standard ", " Selected ", " Border ", " Unselected " }
ENDCASE
IF !( aOpt[ C_TYPE ] == "T" ) // no prompt for titles
*.... we need to know top,left,bottom,right for the prompt window
aEval( aPrompt, { |cPrompt| nLen := MAX( nLen, LEN( cPrompt ) ) } )
nLen := MAX( nLen, LEN( aOpt[ C_NAME ] ) + 2 )
nT := IIF( aOpt[ C_TYPE ] == "M", 18, 19 )
nB := nT + LEN(aPrompt) + 1
nL := MAX( INT( (27-nLen) /2 )-2, 1 )
nR := MIN( nL + nLen + 3, 26 )
*.... set up the window for prompt
SETCOLOR( "N/W" )
ClearS( nT, nL, nB, nR )
ENDIF
DO WHILE .T.
*.... show sample window
_ftShowIt( aOpt )
IF !( aOpt[ C_TYPE ] == "T" ) // no prompt for titles
SETCOLOR( IIF( lColour, "N/W,W+/R,,,N/W", "N/W,W+/N,,,N/W" ) )
Double( nT, nL+1, nB, nR-1 )
@ nT, nL+2 SAY PadC( " "+ aOpt[C_NAME] +" ", nR -nL -3, "Í" )
FOR nX := 1 TO LEN( aPrompt )
@ nX+nT, nL+2 PROMPT PadR( aPrompt[nX], nR -nL -3 )
NEXT
MENU TO nChoice
DO CASE
CASE nChoice == 0
EXIT
CASE nChoice == 2 .AND. aOpt[ C_TYPE ] == "D"
*.... desktop character
aOpt := _ftDeskChar( aOpt )
LOOP
CASE nChoice == 4 .AND. !( aOpt[ C_TYPE ] == "M" )
nChoice := 5 // 4th color param is unused
ENDCASE
ENDIF
*.... get the specific colour combination
aClrs := _ftChr2Arr( aOpt[ C_CLR ] ) // place color string in an array
aSize( aClrs, 5 ) // make sure there are 5 settings
*.... empty elements are made Nil so they can be defaulted
aEval( aClrs, { |v,e| aClrs[e] := IIF( EMPTY(v), Nil, ALLTRIM(v) ) } )
DEFAULT aClrs[1] TO "W/N"
DEFAULT aClrs[2] TO "N/W" // place default colours into
DEFAULT aClrs[3] TO "N/N" // elements which are empty
DEFAULT aClrs[4] TO "N/N"
DEFAULT aClrs[5] TO "N/W"
cClr := aClrs[ nChoice ] // selected colour
*.... allow change to specific part of colour string
IF !( aOpt[ C_TYPE ] == "T" )
Single( nT, nL+1, nB, nR-1 )
@ nT, nL+2 SAY PadC( " "+ aOpt[C_NAME] +" ", nR -nL -3, "Ä" )
ENDIF
cClr := _ftClrSel( aClrPal, cClr, nChoice, aOpt ) // selection routine
aClrs[ nChoice ] := cClr // put colour back in array
aOpt[ C_CLR ] := _ftArr2Chr( aClrs ) // convert array to colour string
IF aOpt[ C_TYPE ] == "T"
EXIT
ENDIF
ENDDO
*.... restore the lower 1/2 of screen, and colour
RESTSCREEN( 18, 00, MAXROW(), MAXCOL(), cScrSav )
SETCOLOR( cColour )
RETURN aOpt
*------------------------------------------------
| clrsel.prg | 346 |
| STATIC FUNCTION | _ftShowIt( aOpt )
STATIC FUNCTION _ftShowIt( aOpt )
// Show an example of the colour setting
// Return -> Nil
LOCAL aClr := _ftChr2Arr( aOpt[ C_CLR ] )
IF !( aOpt[ C_TYPE ] == "M" ) // no borders in menu colour selection
SETCOLOR( aOpt[ C_CLR ] ) // this will set the border on VGA
ENDIF
DispBegin()
DO CASE
CASE aOpt[ C_TYPE ] == "D" // Desktop Background
SETCOLOR( aClr[1] )
BkGrnd( 19, 43, 22, 64, aOpt[ C_CHAR ] )
CASE aOpt[ C_TYPE ] == "T" // Title
SETCOLOR( aClr[1] )
@ 20,08 SAY PadC( "This is an example of how the text shall look", 63 )
CASE aOpt[ C_TYPE ] == "M" // Menus
SETCOLOR( "W/N" )
BkGrnd( 19, 41, 23, 66, CHR(177) )
SETCOLOR( aClr[1] )
Single( 19, 43, 22, 60 )
@ 18,41 SAY " Report Inquiry Quit "
@ 21,44 SAY " eXit "
SETCOLOR( aClr[4] )
@ 18,43 SAY " Report "
@ 20,44 SAY " Product List "
SETCOLOR( aClr[3] )
@ 18,52 SAY "I"
@ 18,61 SAY "Q"
@ 21,46 SAY "X"
SETCOLOR( aClr[5] )
@ 18,44 SAY "R"
@ 20,45 SAY "P"
SETCOLOR( aClr[2] )
@ 24,41 SAY PadC( "Inventory Report", 26 )
CASE aOpt[ C_TYPE ] == "G" // Get windows
SETCOLOR( aClr[1] )
ClearS( 19, 41, 24, 66 )
Single( 19, 42, 24, 65 )
@ 20,43 SAY " Invoice Entry "
@ 21,42 SAY "ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ´"
@ 22,43 SAY " Amount "
@ 23,43 SAY " Date "
SETCOLOR( aClr[2] )
@ 22,53 SAY " 199.95"
SETCOLOR( aClr[5] )
@ 23,53 SAY "09/15/91"
CASE aOpt[ C_TYPE ] == "W" // Alert windows
SETCOLOR( aClr[1] )
ClearS( 18, 40, 24, 66 )
Single( 18, 41, 24, 65 )
@ 19,42 SAY " "
@ 20,42 SAY " Test Message "
@ 21,42 SAY " "
@ 22,41 SAY "ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ´"
SETCOLOR( aClr[2] )
@ 23,44 SAY " Accept "
SETCOLOR( aClr[5] )
@ 23,55 SAY " Reject "
CASE aOpt[ C_TYPE ] == "B" // browse windows
SETCOLOR( aClr[1] )
ClearS( 18, 37, 24, 70 )
Single( 18, 38, 24, 69 )
@ 19,39 SAY " Cust Name Amount "
@ 20,38 SAY "ÆÍÍÍÍÍÍÑÍÍÍÍÍÍÍÍÍÍÍÍÍÍÑÍÍÍÍÍÍÍ͵"
@ 21,39 SAY " 312 ³ Rick Shaw ³ 143.25 "
@ 23,39 SAY " ³ ³ "
@ 24,38 SAY "ÔÍÍÍÍÍÍÏÍÍÍÍÍÍÍÍÍÍÍÍÍÍÏÍÍÍÍÍÍÍ;"
SETCOLOR( aClr[2] )
@ 22,39 SAY " 1005 ³ Harry Pitts ³ 78.95 "
SETCOLOR( aClr[5] )
@ 23,39 SAY " 3162 "
@ 23,46 SAY " Barb Wire "
@ 23,61 SAY " 345.06 "
CASE aOpt[ C_TYPE ] == "A" // achoice type window
SETCOLOR( aClr[1] )
ClearS( 18, 42, 24, 64 )
Single( 18, 43, 24, 63 )
@ 19,44 SAY " Daily Reports "
@ 21,44 SAY " Quarterly Reports "
@ 23,44 SAY " Exit ... "
SETCOLOR( aClr[2] )
@ 20,44 SAY " Monthend Reports "
SETCOLOR( aClr[5] )
@ 22,44 SAY " Yearend Reports "
ENDCASE
DispEnd()
RETURN Nil
*------------------------------------------------
| clrsel.prg | 456 |
| STATIC FUNCTION | _ftClrSel( aClrPal, cClr, nElem, aOpt )
STATIC FUNCTION _ftClrSel( aClrPal, cClr, nElem, aOpt )
// select the colour combination from aClrPal and place in cClr
// cClr is the current colour being modified
// Return -> selected colour combination
LOCAL nR := 1
LOCAL nC := 1
LOCAL lFound := .F.
LOCAL nKey := 0
LOCAL nDim := LEN( aClrPal )
LOCAL nTop := 0
LOCAL nLeft := 28
LOCAL nBottom := nTop + nDim + 1
LOCAL nRight := nLeft + ( nDim * 3 ) + 2
SETCOLOR( "GR+/N" )
Double( nTop, nLeft, nBottom, nRight )
SETCOLOR ( "W+/N" )
*.... find the starting row and column for the current colour
FOR nR := 1 TO nDim
FOR nC := 1 TO nDim
IF aClrPal[ nR, nC ] == ALLTRIM( cClr )
lFound := .T. ; EXIT
ENDIF
NEXT
IF lFound ; EXIT ; ENDIF
NEXT
IF ! lFound
nR := 1 // black background
nC := IIF( nDim == 5, 3, 8 ) // white foreground
ENDIF
DO WHILE .T.
*.... make sure array boundary not exceeded
nR := IIF( nR > nDim, 1, IIF( nR == 0, nDim, nR ) )
nC := IIF( nC > nDim, 1, IIF( nC == 0, nDim, nC ) )
*.... place selected colour in the appropriate spot in clr string
aOpt[ C_CLR ] := _ftClrPut( aOpt[ C_CLR ], nElem, aClrPal[ nR, nC ] )
*.... show sample window
_ftShowIt( aOpt )
*.... highlight the colour palette element
SETCOLOR ( "W+/N" )
@ nR, nC*3+26 SAY ""
@ nR, nC*3+29 SAY ""
nKey := INKEY(0)
@ nR, nC*3+26 SAY " "
@ nR, nC*3+29 SAY " "
*.... check key movement and modify co-ordinates
DO CASE
CASE nKey == K_ESC ; EXIT
CASE nKey == K_ENTER ; cClr := aClrPal[ nR, nC ] ; EXIT
CASE nKey == K_UP ; --nR
CASE nKey == K_DOWN ; ++nR
CASE nKey == K_LEFT ; --nC
CASE nKey == K_RIGHT ; ++nC
ENDCASE
ENDDO
SETCOLOR( "GR+/N" )
Single( nTop, nLeft, nBottom, nRight )
RETURN cClr
*------------------------------------------------
| clrsel.prg | 557 |
| STATIC FUNCTION | _ftClrPut( cClrStr, nElem, cClr )
STATIC FUNCTION _ftClrPut( cClrStr, nElem, cClr )
// Place a colour setting in the colour string
// Return -> modified colour string
LOCAL aClr := _ftChr2Arr( cClrStr )
aClr[ nElem ] := cClr
RETURN _ftArr2Chr( aClr )
*------------------------------------------------
| clrsel.prg | 630 |
| STATIC FUNCTION | _ftDeskChar( aOpt )
STATIC FUNCTION _ftDeskChar( aOpt )
// Select the character to be used for the desktop background
// Return -> same array with new character
LOCAL aChar := { CHR(32), CHR(176), CHR(177), CHR(178) }
LOCAL cChar := aOpt[ C_CHAR ]
LOCAL cClr := aOpt[ C_CLR ]
LOCAL nElem := aScan( aChar, cChar )
LOCAL n, nKey
IF nElem == 0 // this allows another character to be selected
aAdd( aChar, cChar ) // but there is the possibility that it will
nElem := 5 // not be available if they ever select another
ENDIF // char and store it. It's up to you to put it in
*.... draw the choices on the screen
SETCOLOR ( cClr )
FOR n := 1 TO LEN( aChar )
@ n+18, 29 SAY REPL( aChar[n], 10 )
NEXT
n := nElem + 18
DO WHILE .T.
*.... make sure boundary not exeeded
n := IIF( n > Len(aChar)+18, 19, IIF( n < 19, Len(aChar)+18, n ) )
*.... show sample window
aOpt[ C_CHAR ] := aChar[ n-18 ] // place in array
_ftShowIt( aOpt )
SETCOLOR ( "W+/N" )
@ n, 28 SAY ""
@ n, 39 SAY ""
nKey := INKEY(0)
@ n, 28 SAY " "
@ n, 39 SAY " "
*.... check key movement and modify co-ordinates
DO CASE
CASE nKey == K_ESC ; aOpt[ C_CHAR ] := cChar ; EXIT
CASE nKey == K_ENTER ; EXIT
CASE nKey == K_UP ; --n
CASE nKey == K_DOWN ; ++n
ENDCASE
ENDDO
SETCOLOR ( "W+/N" )
ClearS( 18, 28, 23, 39 )
RETURN aOpt
*------------------------------------------------
| clrsel.prg | 641 |
| STATIC FUNCTION | _ftChr2Arr( cString, cDelim )
STATIC FUNCTION _ftChr2Arr( cString, cDelim )
// Convert a chr string to an array
// Return -> array
LOCAL n, aArray := {}
DEFAULT cDelim TO ","
DEFAULT cString TO "" // this should really be passed
cString += cDelim
DO WHILE .T.
IF EMPTY( cString ) ; EXIT ; ENDIF
n := AT( cDelim, cString )
AADD( aArray, IIF( n == 1, "", LEFT( cString, n - 1 ) ) )
cString := SUBS( cString, n + 1 )
ENDDO
RETURN aArray
*------------------------------------------------
| clrsel.prg | 694 |
| STATIC FUNCTION | _ftArr2Chr( aArray, cDelim )
STATIC FUNCTION _ftArr2Chr( aArray, cDelim )
// convert an array to a chr string
// Return -> string
LOCAL cString := ""
DEFAULT aArray TO {}
DEFAULT cDelim TO ","
AEVAL( aArray, { |v,e| cString += IIF( e == 1, v, cDelim + v ) } )
RETURN cString
*------------------------------------------------
| clrsel.prg | 714 |
| STATIC FUNCTION | _ftShowPal( aClrPal, cChr )
STATIC FUNCTION _ftShowPal( aClrPal, cChr )
// Paint the palette on the screen
// Return -> Nil
LOCAL nF,nB
LOCAL nTop := 0
LOCAL nLeft := 28
LOCAL nBottom := nTop + LEN( aClrPal ) + 1
LOCAL nRight := nLeft + ( LEN( aClrPal )*3 ) + 2
*.... Buffer the screen output
DispBegin()
Single( nTop, nLeft, nBottom, nRight )
FOR nF := 1 TO LEN( aClrPal )
FOR nB := 1 TO LEN( aClrPal[ nF ] )
SETCOLOR( aClrPal[ nF, nB ] )
@ nF, nB*3+27 SAY cChr
NEXT
NEXT
DispEnd()
RETURN Nil
*------------------------------------------------
| clrsel.prg | 728 |
| STATIC FUNCTION | _ftInitPal( aClrTab )
STATIC FUNCTION _ftInitPal( aClrTab )
// Initialise the colour palette based on the passed colour table aClrTab
// Load the palette with colours
// Return -> Colour pallette array
LOCAL nF,nB
LOCAL nDim := LEN( aClrTab )
LOCAL aClrPal := ARRAY( nDim*2, nDim*2 )
FOR nF := 1 TO nDim*2
FOR nB := 1 TO nDim*2
aClrPal[ nF, nB ] :=;
IIF( nF <= nDim, aClrTab[ nF ], aClrTab[ nF-nDim ] +"+" ) +"/"+;
IIF( nB <= nDim, aClrTab[ nB ], aClrTab[ nB-nDim ] +"*" )
NEXT
NEXT
RETURN aClrPal
*------------------------------------------------
| clrsel.prg | 752 |
| STATIC FUNCTION | _ftIdentArr( aArr1, aArr2 )
STATIC FUNCTION _ftIdentArr( aArr1, aArr2 )
// Compares the contents of 2 arrays
// Return -> logical
LOCAL lIdentical := LEN(aArr1) == LEN(aArr2)
LOCAL n := 1
DO WHILE lIdentical .AND. n <= LEN(aArr1)
IF VALTYPE( aArr1[n] ) == VALTYPE( aArr2[n] )
lIdentical := IIF( VALTYPE( aArr1[n] ) == "A", ;
_ftIdentArr( aArr1[n], aArr2[n] ), ;
aArr1[n] == aArr2[n] )
ELSE
lIdentical := .f.
ENDIF
n++
ENDDO
RETURN lIdentical
| clrsel.prg | 772 |
| cntryset.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_SETCENTURY(lNewSetState)
FUNCTION FT_SETCENTURY(lNewSetState)
// Note that if CENTURY is ON then
// DTOC() Will Return a String of Length
// 10, Otherwise it Will be of Length 8
LOCAL lOldSetState := (LEN(DTOC(DATE())) == 10)
IF (IS_LOGICAL(lNewSetState)) // Did They Want it Set??
SET CENTURY (lNewSetState) // Yes, Set it
ENDIF // IS_LOGICAL(lNewSetState)
RETURN (lOldSetState) // FT_SetCentury
| cntryset.prg | 61 |
| d2e.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | main( cNum, cPrec )
function main( cNum, cPrec )
DEFAULT cPrec TO str( DEFAULT_PRECISION )
return qout( ft_d2e( val(cNum), val(cPrec) ) )
| d2e.prg | 68 |
| FUNCTION | ft_d2e( nDec, nPrecision )
function ft_d2e( nDec, nPrecision )
local nExp, sScn
DEFAULT nPrecision TO DEFAULT_PRECISION
if nDec == 0
nExp := 0
elseif abs( nDec ) < 1
nExp := int( log10( nDec ) ) - 1
else
nExp := int( log10( abs(nDec)+0.00001 ) ) && 0.00001 == kludge
endif && for imprecise logs
nDec /= 10 ^ nExp
if round( abs(nDec), nPrecision ) >= 10
nDec /= 10
nExp++
endif another kludge for stuff like '999999999'
sScn := ltrim( str( nDec, nPrecision + 3, nPrecision ) )
return( sScn + 'E' + alltrim( str( nExp, 5, 0 ) ) )
| d2e.prg | 73 |
| datecnfg.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | DEMO()
FUNCTION DEMO()
LOCAL nNum, dDate, aTestData := {}, aTemp, cFY_Start, nDOW_Start
* SET DATE American // User's normal date format
aTemp := FT_DATECNFG() // Get/Set cFY_Start & nDOW_Start.
* aTemp := FT_DATECNFG("03/01/80", 1) // Date string in user's format.
cFY_Start := aTemp[1] // See FT_DATECNFG() in FT_DATE0.PRG
NDOW_START := ATEMP[2] // FOR PARAMETERS.
DDATE := DATE()
* dDate := CTOD("02/29/88") // Test date, in user's normal date format
cls
? "Given Date: "
?? dDate
?? " cFY_Start: "+ cFY_Start
?? " nDOW_Start:" + STR(nDOW_Start,2)
? "---- Fiscal Year Data -----------"
aTestData := FT_YEAR(dDate)
? "FYYear ", aTestData[1]+" ", aTestData[2], aTestData[3]
aTestData := FT_QTR(dDate)
? "FYQtr ", aTestData[1], aTestData[2], aTestData[3]
nNum := VAL(SUBSTR(aTestData[1],5,2))
aTestData := FT_QTR(dDate,nNum)
? "FYQtr "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3]
aTestData := FT_MONTH(dDate)
? "FYMonth ", aTestData[1], aTestData[2], aTestData[3]
nNum := VAL(SUBSTR(aTestData[1],5,2))
aTestData := FT_MONTH(dDate,nNum)
? "FYMonth "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3]
aTestData := FT_WEEK(dDate)
? "FYWeek ", aTestData[1], aTestData[2], aTestData[3]
nNum := VAL(SUBSTR(aTestData[1],5,2))
aTestData := FT_WEEK(dDate,nNum)
? "FYWeek "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3]
aTestData := FT_DAYOFYR(dDate)
? "FYDay ", aTestData[1], aTestData[2], aTestData[3]
nNum := VAL(SUBSTR(aTestData[1],5,3))
aTestData := FT_DAYOFYR(dDate,nNum)
? "FYDAY "+STR(nNum,3), aTestData[1], aTestData[2], aTestData[3]
?
? "---- Accounting Year Data -------"
aTestData := FT_ACCTYEAR(dDate)
? "ACCTYear ", aTestData[1]+" ", aTestData[2], aTestData[3],;
STR( (aTestData[3] - aTestData[2] + 1) /7, 3 ) + " Weeks"
aTestData := FT_ACCTQTR(dDate)
? "ACCTQtr ", aTestData[1], aTestData[2], aTestData[3],;
STR( (aTestData[3] - aTestData[2] + 1) /7, 3 ) + " Weeks"
nNum := VAL(SUBSTR(aTestData[1],5,2))
aTestData := FT_ACCTQTR(dDate,nNum)
? "ACCTQtr "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3]
aTestData := FT_ACCTMONTH(dDate)
? "ACCTMonth ", aTestData[1], aTestData[2], aTestData[3],;
STR( (aTestData[3] - aTestData[2] + 1) /7, 3 ) + " Weeks"
nNum := VAL(SUBSTR(aTestData[1],5,2))
aTestData := FT_ACCTMONTH(dDate,nNum)
? "ACCTMonth"+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3]
aTestData := FT_ACCTWEEK(dDate)
? "ACCTWeek ", aTestData[1], aTestData[2], aTestData[3]
nNum := VAL(SUBSTR(aTestData[1],5,2))
aTestData := FT_ACCTWEEK(dDate,nNum)
? "ACCTWeek "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3]
aTestData := FT_DAYOFYR(dDate,,.T.)
? "ACCTDay ", aTestData[1], aTestData[2], aTestData[3]
nNum := VAL(SUBSTR(aTestData[1],5,3))
aTestData := FT_DAYOFYR(dDate,nNum,.T.)
? "ACCTDay "+STR(nNum,3), aTestData[1], aTestData[2], aTestData[3]
WAIT
FT_CAL(dDate)
FT_CAL(dDate,1)
RETURN NIL
* DEMO Monthly Calendar function.
* nType : 0 = FT_MONTH, 1 = FT_ACCTMONTH
*
| datecnfg.prg | 78 |
| FUNCTION | FT_CAL(dGivenDate,nType)
FUNCTION FT_CAL(dGivenDate,nType)
LOCAL nTemp, dTemp, aTemp, cFY_Start, dStart, dEnd
aTemp := FT_DATECNFG()
cFY_Start := aTemp[1]
IF dGivenDate == NIL .OR. !VALTYPE(dGivenDate) $ 'ND'
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'N'
nType := dGivenDate
dGivenDate := DATE()
ENDIF
nType := IF(nType == NIL .OR. VALTYPE(nType) != 'N', 0, nType)
IF nType == 0
IF SUBSTR(cFY_Start,6,5) == "01.01"
? " Calendar Month Calendar containing " + DTOC(dGivenDate)
ELSE
? " Fiscal Month Calendar containing " + DTOC(dGivenDate)
ENDIF
aTemp := FT_MONTH(dGivenDate)
dStart := aTemp[2]
dEnd := aTemp[3]
aTemp[2] -= FT_DAYTOBOW(aTemp[2])
aTemp[3] += 6 - FT_DAYTOBOW(aTemp[3])
ELSE
? " Accounting Month Calendar containing " + DTOC(dGivenDate)
aTemp := FT_ACCTMONTH(dGivenDate)
ENDIF
?
dTemp := aTemp[2]
FOR nTemp := 0 to 6
?? PADC( CDOW(dTemp + nTemp),10)
NEXT
?
WHILE dTemp <= aTemp[3]
FOR nTemp = 1 TO 7
?? " "
IF nType == 0 .AND. (dTemp < dStart .or. dTemp > dEnd)
?? SPACE(8)
ELSE
?? dTemp
ENDIF
?? " "
dTemp ++
NEXT
?
END
RETURN NIL
#endif
| datecnfg.prg | 176 |
| FUNCTION | FT_DATECNFG( cFYStart ,nDow )
FUNCTION FT_DATECNFG( cFYStart ,nDow )
STATIC aDatePar := { "1980.01.01", 1 }
LOCAL dCheck, cDateFormat := SET(_SET_DATEFORMAT)
IF VALTYPE( cFYStart ) == 'C'
dCheck := CTOD( cFYStart )
IF DTOC( dCheck ) != " "
/* No one starts a Fiscal Year on 2/29 */
IF MONTH(dCheck) == 2 .and. DAY(dcheck) == 29
dCheck --
ENDIF
SET(_SET_DATEFORMAT, "yyyy.mm.dd")
aDatePar[1] := DTOC(dCheck)
SET(_SET_DATEFORMAT, cDateFormat)
ENDIF
ENDIF
IF VALTYPE( nDow ) == 'N' .AND. nDow > 0 .AND. nDow < 8
aDatePar[2] := nDow
ENDIF
RETURN ACLONE( aDatePar )
| datecnfg.prg | 309 |
| dayofyr.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_DAYOFYR( dGivenDate, nDayNum, lIsAcct)
FUNCTION FT_DAYOFYR( dGivenDate, nDayNum, lIsAcct)
LOCAL lIsDay, nTemp, aRetVal
IF !(VALTYPE(dGivenDate) $ 'NDL')
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'N'
nDayNum := dGivenDate
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'L'
lIsAcct := dGivenDate
dGivenDate := DATE()
ENDIF
lIsDay := VALTYPE(nDayNum) == 'N'
lIsAcct := VALTYPE(lIsAcct) == 'L'
IF lIsAcct
aRetVal := FT_ACCTYEAR(dGivenDate)
ELSE
aRetVal := FT_YEAR(dGivenDate)
ENDIF
IF lIsDay
nTemp := aRetVal[3] - aRetVal[2] + 1
IF(nDayNum < 1 .OR. nDayNum > nTemp , nDayNum := nTemp, )
aRetVal[1] := aRetVal[2] + nDayNum - 1
ELSE
aRetVal[1] += PADL(LTRIM(STR( dGivenDate - aRetVal[2] + 1, 3)), 3, '0')
ENDIF
RETURN aRetVal
| dayofyr.prg | 90 |
| daytobow.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_DAYTOBOW( dGivenDate )
FUNCTION FT_DAYTOBOW( dGivenDate )
LOCAL nRetVal, nDOW_Start
nDOW_Start := FT_DATECNFG()[2]
IF(VALTYPE(dGivenDate) != 'D', dGivenDate := DATE(), )
nRetVal := DOW( dGivenDate ) - nDOW_Start
IF( nRetVal < 0, nRetVal += 7, )
RETURN nRetVal
| daytobow.prg | 67 |
| dectobin.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN
FUNCTION MAIN
LOCAL X
FOR X = 1 TO 255
QOUT( FT_DEC2BIN( x ))
next
return nil
| dectobin.prg | 51 |
| FUNCTION | FT_DEC2BIN(x)
function FT_DEC2BIN(x)
local i, buffer := { '0', '0', '0', '0', '0', '0', '0', '0' }
for i = 8 to 1 step -1
if x >= 2 ^ (i - 1)
x -= 2 ^ (i - 1)
buffer[9 - i] = '1'
endif
next
return ( buffer[1] + buffer[2] + buffer[3] + buffer[4] + ;
buffer[5] + buffer[6] + buffer[7] + buffer[8] )
* end of file: dectobin.prg
| dectobin.prg | 60 |
| dfile.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN()
FUNCTION MAIN()
@ 0,0 CLEAR
cInFile := "FT_DFILE.PRG"
CKEY := ""
NNCOLOR := 7
NHCOLOR := 15
NCOLSKIP := 5
NRMARGIN := 132
CEXITKEYS := "AABBC "
LBROWSE := .F.
NSTART := 1
NBUFFSIZE := 4096
@ 0,0 SAY "ENTER FILENAME: " GET CINFILE
@ 1,0 SAY " FOREGROUND: " GET NNCOLOR PICTURE "999"
@ 2,0 SAY " HIGHLIGHT: " GET NHCOLOR PICTURE "999"
@ 3,0 SAY " EXIT KEYS: " GET CEXITKEYS
@ 4,0 SAY " BUFFER SIZE: " GET NBUFFSIZE PICTURE "9999"
@ 1,40 SAY "COLUMN INCREMENT: " GET NCOLSKIP PICTURE "999"
@ 2,40 SAY " MAX LINE SIZE: " GET NRMARGIN PICTURE "999"
@ 3,40 SAY " BROWSE MODE? " GET LBROWSE PICTURE "Y"
READ
/*
* REMEMBER A WINDOW WILL BE ONE SIZE LESS AND GREATER THAN THE PASSED COORD.'S
*
* THE 9TH PARAMETER CONTAINS THE KEYS THAT THE ROUTINE WILL TERMINATE ON
* AND THE CHR(143) represents the F3 key.
*
*/
@ 4,9 TO 11,71
FT_DFSETUP(cInFile, 5, 10, 10, 70, nStart,;
nNColor, nHColor, cExitKeys + CHR(143),;
lBrowse, nColSkip, nRMargin, nBuffSize)
cKey := FT_DISPFILE()
FT_DFCLOSE()
@ 20,0 SAY "Key pressed was: " + '[' + cKey + ']'
return (NIL)
#endif
| dfile.prg | 36 |
| FUNCTION | FT_DFSETUP(cInFile, nTop, nLeft, nBottom, nRight, nStart, nCNormal, nCHighlight, cExitKeys, lBrowse, nColSkip, nRMargin, nBuffSize )
function FT_DFSETUP(cInFile, nTop, nLeft, nBottom, nRight,;
nStart, nCNormal, nCHighlight, cExitKeys,;
lBrowse, nColSkip, nRMargin, nBuffSize )
local rval := 0
if File(cInFile)
nTop := if(ValType(nTop) == "N", nTop, 0)
nLeft := if(ValType(nLeft) == "N", nLeft, 0)
nBottom := if(ValType(nBottom) == "N", nBottom, MaxRow())
nRight := if(ValType(nRight) == "N", nRight, MaxCol())
nCNormal := if(ValType(nCNormal) == "N", nCNormal, 7)
nCHighlight := if(ValType(nCHighlight) == "N", nCHighlight, 15)
nStart := if(ValType(nStart) == "N", nStart, 1)
nColSkip := if(ValType(nColSkip) == "N", nColSkip, 1)
lBrowse := if(ValType(lBrowse) == "L", lBrowse, .F.)
nRMargin := if(ValType(nRMargin) == "N", nRMargin, 255)
nBuffSize := if(ValType(nBuffSize) == "N", nBuffSize, 4096)
cExitKeys := if(ValType(cExitKeys) == "C", cExitKeys, "")
cExitKeys := if(Len(cExitKeys) > 25, SubStr(cExitKeys, 1, 25), cExitKeys)
nHandle := FOpen(cInFile)
rval := FError()
if ( rval == 0 )
rval := _FT_DFINIT(nHandle, nTop, nLeft, nBottom, nRight,;
nStart, nCNormal, nCHighlight, cExitKeys,;
lBrowse, nColSkip, nRMargin, nBuffSize)
endif
else
rval := 2 // simulate a file-not-found DOS file error
endif
return (rval)
| dfile.prg | 144 |
| FUNCTION | FT_DFCLOSE()
function FT_DFCLOSE()
if ( nHandle > 0 )
_FT_DFCLOS()
FClose(nHandle)
nHandle := 0
endif
return (NIL)
| dfile.prg | 221 |
| diskfunc.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN( cDrv )
FUNCTION MAIN( cDrv )
QOut("Disk size: " + str( FT_DSKSIZE() ) )
QOut("Free bytes: " + str( FT_DSKFREE() ) )
return ( nil )
#endif
| diskfunc.prg | 34 |
| FUNCTION | FT_DSKSIZE( cDrive )
FUNCTION FT_DSKSIZE( cDrive )
local nDrive
nDrive := if( cDrive == NIL, 0, at( upper(cDrive), DRVTABLE ) )
Return DISKSPACE(nDrive,3)
| diskfunc.prg | 66 |
| FUNCTION | FT_DSKFREE( cDrive )
FUNCTION FT_DSKFREE( cDrive )
local nDrive
nDrive := if( cDrive == NIL, 0, at( upper(cDrive), DRVTABLE ) )
RETURN DISKSPACE(nDrive,1)
| diskfunc.prg | 99 |
| dispmsg.prg |
| Type | Function | Source | Line |
|---|
| PROCEDURE | Main( cCmdLine )
PROCEDURE Main( cCmdLine )
LOCAL cDosScrn, ;
nDosRow, ;
nDosCol, ;
lColor, ;
nMaxRow, ;
nType
// main routine starts here
SET SCOREBOARD OFF
lColor := .T.
cNormH := IIF( lColor, "W+/BG","W+/N" )
cNormN := IIF( lColor, "N/BG" ,"W/N" )
cNormE := IIF( lColor, "N/W" , "N/W" )
cWindH := IIF( lColor, "W+/B", "W+/N" )
cWindN := IIF( lColor, "W/B" , "W/N" )
cWindE := IIF( lColor, "N/W" , "N/W" )
cErrH := IIF( lColor, "W+/R", "W+/N" )
cErrN := IIF( lColor, "W/R" , "W/N" )
cErrE := IIF( lColor, "N/W" , "N/W" )
cDosScrn := SAVESCREEN()
nDosRow=ROW()
nDosCol=COL()
SETCOLOR( "W/N" )
CLS
nMaxRow := MAXROW()
SETBLINK(.F.)
SETCOLOR( cWindN + "*" )
CLS
SETCOLOR( cNormN )
FT_DispMsg( { { "[Esc] To Abort Changes [PgDn] To Continue" }, { cNormN, , cNormH } }, , nMaxRow - 5 )
FT_DispMsg( { { "[E]dit [P]rint [D]elete", ;
"[Esc]ape [Alt-Q]" }, ;
{ cErrN, cErrN, cErrH } },, 2 )
nType := FT_DispMsg( { { "Create Or Edit [I]nvoice", ;
"Create Or Edit [O]rder", ;
"Create Or Edit [B]ack Order", ;
"Create Or Edit [Q]uote", ;
"[Esc] To Exit" }, ;
{ cWindN,,,,, cWindH } }, "BIOQ" + CHR(27) )
SETCOLOR( "W/N" )
SETCURSOR( 1 )
SETBLINK( .T.)
RESTSCREEN(,,,, cDosScrn )
SETPOS(nDosRow, nDosCol)
QUIT
| dispmsg.prg | 134 |
| FUNCTION | FT_DispMsg( aInfo, cKey, nBoxTop, nBoxLeft, cnBoxString, lShadow )
FUNCTION FT_DispMsg( aInfo, cKey, nBoxTop, nBoxLeft, cnBoxString, lShadow )
LOCAL xRtnVal := .F., ;
nWidest := 0, ;
nBoxRight, ;
nBoxBottom, ;
cOldScreen, ;
cOldCursor, ;
cOldColor, ;
i, ;
j, ;
nOption, ;
x, ;
y, ;
aPos := {}, ;
nLeft, ;
nTop, ;
aLeft
FOR i := 1 TO LEN( aInfo[1] )
AADD( aPos, {} )
NEXT
FOR i := 1 TO LEN( aInfo[1] )
DO WHILE AT( "[", aInfo[1,i] ) > 0
x := AT( "[", aInfo[1,i] )
y := AT( "]", aInfo[1,i] ) - 2
AADD( aPos[i], { x, y } )
aInfo[1,i] := STRTRAN( aInfo[1,i], "[", "", 1, 1 )
aInfo[1,i] := STRTRAN( aInfo[1,i], "]", "", 1, 1 )
ENDDO
NEXT
AEVAL( aInfo[1], {|x| nWidest := MAX( nWidest, LEN( x ) ) } )
/* calculate location of data */
IF nBoxLeft == NIL
nLeft := ROUND( ( MAXCOL() - nWidest ) / 2, 0 )
ELSE
nLeft := nBoxLeft + 2
ENDIF
IF nBoxTop == NIL
nTop := ( MAXROW() - LEN( aInfo[1] ) - 2 ) / 2 + 2
ENDIF
/* calculate location of box */
IF nBoxLeft == NIL
nBoxLeft := nLeft - 2
ENDIF
nBoxRight := nBoxLeft + nWidest + 3
IF nBoxTop == NIL
nBoxTop := (MAXROW() - LEN( aInfo[1] ) - 2) / 2 + 1
ENDIF
nBoxBottom := nBoxTop + LEN( aInfo[1] ) + 1
// following is to keep from breaking old code and to be
// consistent with DISPBOX()
IF cnBoxString == NIL .OR. cnBoxString == 2
cnBoxString := "ÉÍ»º¼ÍȺ "
ELSEIF cnBoxString == 1
cnBoxString := "ÚÄ¿³ÙÄÀ³ "
ENDIF
lShadow := IIF( lShadow == NIL, .T., lShadow )
cOldScreen := SAVESCREEN( nBoxTop, nBoxLeft, nBoxBottom+1, nBoxRight+2 )
cOldCursor := SETCURSOR( 0 )
// draw box
cOldColor := SETCOLOR( aInfo[ 2, LEN( aInfo[2] ) ] )
DISPBOX( nBoxTop, nBoxLeft, nBoxBottom, nBoxRight, cnBoxString, ;
aInfo[ 2, LEN( aInfo[2] ) ] )
IF lShadow
FT_Shadow( nBoxTop, nBoxLeft, nBoxBottom, nBoxRight )
ENDIF
/* fill array with left positions for each row */
aLeft := ARRAY( LEN( aInfo[1] ) )
FOR i := 1 TO LEN( aInfo[1] )
IF LEN( aInfo[1,i] ) = nWidest
aLeft[i] := nLeft
ELSE
aLeft[i] := nLeft + ROUND( ( nWidest - LEN( aInfo[1,i] ) ) / 2, 0 )
ENDIF
NEXT
/* fill array of colors */
FOR i := 2 TO LEN( aInfo[2] )
IF aInfo[2,i] == NIL
aInfo[2,i] := aInfo[2,i-1]
ENDIF
NEXT
/* display messages */
FOR i := 1 TO LEN( aInfo[1] )
@ nBoxTop+i, aLeft[i] SAY aInfo[1,i] COLOR aInfo[2,i]
NEXT
/* highlight characters */
FOR i := 1 TO LEN( aPos )
FOR j := 1 TO LEN( aPos[i] )
FT_SetAttr( nBoxTop + i, ;
aPos[i,j,1] + aLeft[i] - 1, ;
nBoxTop + i, ;
aPos[i,j,2] + aLeft[i] - 1, ;
FT_Color2N( aInfo[ 2, LEN( aInfo[2] ) ] ) )
NEXT
NEXT
IF cKey != NIL
IF LEN( cKey ) == 1
nOption := FT_SInkey(0)
IF UPPER( CHR( nOption) ) == cKey
xRtnVal := .t.
ENDIF
ELSE
nOption := 0
DO WHILE AT( UPPER( CHR( nOption ) ), UPPER( cKey ) ) == 0
nOption := FT_SInkey(0)
ENDDO
xRtnVal := nOption
ENDIF
RESTSCREEN( nBoxTop, nBoxLeft, nBoxBottom+1, nBoxRight+2, cOldScreen )
ENDIF
SETCOLOR( cOldColor )
SETCURSOR( cOldCursor )
RETURN xRtnVal
| dispmsg.prg | 195 |
| dosver.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN()
FUNCTION MAIN()
QOut( "Dos version: " + FT_DOSVER() )
return ( nil )
| dosver.prg | 70 |
| FUNCTION | FT_DOSVER()
FUNCTION FT_DOSVER()
/* local aRegs[ INT86_MAX_REGS ] */
local cResult := ""
/* aRegs[ AX ] = MAKEHI( DOSVER )
if FT_INT86( DOS, aRegs )
cResult := alltrim( str( LOWBYTE( aRegs[ AX ] ) ) ) + "." + ;
alltrim( str( HIGHBYTE( aRegs[ AX ] ) ) )
endif
*/
cResult:= _get_dosver()
RETURN ( cResult )
| dosver.prg | 75 |
| e2d.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | main( sNumE )
function main( sNumE )
return qout( FT_E2D( sNumE ) )
| e2d.prg | 59 |
| FUNCTION | ft_e2d( sNumE )
function ft_e2d( sNumE )
local nMant, nExp
nMant := val( left( sNumE, at( 'E', sNumE ) - 1 ) )
nExp := val(substr( sNumE, ;
at( 'E', sNumE ) + 1, ;
len( sNumE ) - at( 'E', sNumE ) ;
) ;
)
return( nMant * 10 ^ nExp )
| e2d.prg | 63 |
| easter.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_EASTER (nYear)
FUNCTION FT_EASTER (nYear)
local nGold, nCent, nCorx, nCorz, nSunday, nEpact, nMoon,;
nMonth := 0, nDay := 0
IF VALTYPE (nYear) == "C"
nYear = VAL(nYear)
ENDIF
IF VALTYPE (nYear) == "D"
nYear = YEAR(nYear)
ENDIF
IF VALTYPE (nYear) == "N"
IF nYear > 1582
* <> is Golden number of the year in the 19 year Metonic cycle
nGold = nYear % 19 + 1
* <> is Century
nCent = INT (nYear / 100) + 1
* Corrections:
* <> is the no. of years in which leap-year was dropped in order
* to keep step with the sun
nCorx = INT ((3 * nCent) / 4 - 12)
* <> is a special correction to synchronize Easter with the moon's
* orbit.
nCorz = INT ((8 * nCent + 5) / 25 - 5)
* <> Find Sunday
nSunday = INT ((5 * nYear) / 4 - nCorx - 10)
* Set Epact <> (specifies occurance of a full moon)
nEpact = INT ((11 * nGold + 20 + nCorz - nCorx) % 30)
IF nEpact < 0
nEpact += 30
ENDIF
IF ((nEpact = 25) .AND. (nGold > 11)) .OR. (nEpact = 24)
++nEpact
ENDIF
* Find full moon - the <>th of MARCH is a "calendar" full moon
nMoon = 44 - nEpact
IF nMoon < 21
nMoon += 30
ENDIF
* Advance to Sunday
nMoon = INT (nMoon + 7 - ((nSunday + nMoon) % 7))
* Get Month and Day
IF nMoon > 31
nMonth = 4
nDay = nMoon - 31
ELSE
nMonth = 3
nDay = nMoon
ENDIF
ENDIF
ELSE
nYear = 0
ENDIF
RETURN StoD( Str( nYear,4) + PadL( nMonth, 2, "0" ) + PadL( Int( nDay ), 2, "0" ) )
| easter.prg | 57 |
| elapmil.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_ELAPMIN(cTIME1,cTIME2)
function FT_ELAPMIN(cTIME1,cTIME2)
return ((VAL(LEFT(cTIME2,2))*60) + (VAL(RIGHT(cTIME2,2)))) - ;
((VAL(LEFT(cTIME1,2))*60) + (VAL(RIGHT(cTIME1,2))))
| elapmil.prg | 54 |
| elapsed.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | DEMO()
FUNCTION DEMO()
LOCAL dStart, dEnd, cTimeStart, cTimeEnd, n, aDataTest := {}
dStart := CTOD('11/28/90')
dEnd := CTOD('11/30/90')
cTimeStart := "08:00:00"
cTimeEnd := "12:10:30"
aDataTest := FT_ELAPSED(dStart,dEnd,cTimeStart,cTimeEnd)
FOR n = 1 to 4
? aDataTest[n,1], STR(aDataTest[n,2], 12, 4)
?? " "
?? IF(n == 1, 'Days', IF( n== 2, 'Hours', IF( n == 3, 'Mins.', 'Secs.')))
NEXT
RETURN NIL
#endif
| elapsed.prg | 33 |
| FUNCTION | FT_ELAPSED(dStart, dEnd, cTimeStart, cTimeEnd)
FUNCTION FT_ELAPSED(dStart, dEnd, cTimeStart, cTimeEnd)
LOCAL nTotalSec, nCtr, nConstant, nTemp, aRetVal[4,2]
IF ! ( VALTYPE(dStart) $ 'DC' )
dStart := DATE()
ELSEIF VALTYPE(dStart) == 'C'
cTimeStart := dStart
dStart := DATE()
ENDIF
IF ! ( VALTYPE(dEnd) $ 'DC' )
dEnd := DATE()
ELSEIF VALTYPE(dEnd) == 'C'
cTimeEnd := dEnd
dEnd := DATE()
ENDIF
IF( VALTYPE(cTimeStart) != 'C', cTimeStart := '00:00:00', )
IF( VALTYPE(cTimeEnd) != 'C', cTimeEnd := '00:00:00', )
nTotalSec := (dEnd - dStart) * 86400 + ;
VAL(cTimeEnd) * 3600 + ;
VAL(SUBSTR(cTimeEnd,AT(':', cTimeEnd)+1,2)) * 60 + ;
IF(RAT(':', cTimeEnd) == AT(':', cTimeEnd), 0, ;
VAL(SUBSTR(cTimeEnd,RAT(':', cTimeEnd)+1))) - ;
VAL(cTimeStart) * 3600 - ;
VAL(SUBSTR(cTimeStart,AT(':', cTimeStart)+1,2)) * 60 - ;
IF(RAT(':', cTimeStart) == AT(':', cTimeStart), 0, ;
VAL(SUBSTR(cTimeStart,RAT(':', cTimeStart)+1)))
nTemp := nTotalSec
FOR nCtr = 1 to 4
nConstant := IF(nCtr == 1, 86400, IF(nCtr == 2, 3600, IF( nCtr == 3, 60, 1)))
aRetVal[nCtr,1] := INT(nTemp/nConstant)
aRetval[nCtr,2] := nTotalSec / nConstant
nTemp -= aRetVal[nCtr,1] * nConstant
NEXT
RETURN aRetVal
| elapsed.prg | 92 |
| eltime.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_ELTIME(cTIME1,cTIME2)
function FT_ELTIME(cTIME1,cTIME2)
local nDELSECS, nHRS, nMINS, nSECS, nSECS1, nSECS2
nSECS1 := (val(substr(cTIME1,1,2)) * 3600) +;
(val(substr(cTIME1,4,2)) * 60) + (val(substr(cTIME1,7)))
nSECS2 := (val(substr(cTIME2,1,2)) * 3600) +;
(val(substr(cTIME2,4,2)) * 60) + (val(substr(cTIME2,7)))
nDELSECS := abs(nSECS2 - nSECS1)
nHRS := int(nDELSECS / 3600)
nMINS := int((nDELSECS - nHRS * 3600) / 60)
nSECS := nDELSECS - (nHRS * 3600) - (nMINS * 60)
return right("00" + ltrim(str(nHRS)),2) + ;
":" + ;
right("00" + ltrim(str(nMINS)),2) + ;
":" + ;
right("00" + ltrim(str(nSECS)),2)
| eltime.prg | 54 |
| findith.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN( cCk, cStr, nOcc, xCase )
FUNCTION MAIN( cCk, cStr, nOcc, xCase )
LOCAL nFind
if pcount() != 4
QOut( "usage: findith cCk cStr nOcc xCase")
quit
endif
xCase := iif( xCase == "Y", .t., .f. )
nOcc := val(nOcc)
QOut( iif( xCase, "Ignoring ", "Observing ") + "case:" )
QOut( cStr )
nFind := FT_FINDITH( cCk, cStr, nOcc, xCase )
QOut( iif( nFind > 0, space( nFind - 1) + "^" , "Not found" ) )
RETURN nil
| findith.prg | 69 |
| FUNCTION | FT_FINDITH(cCheckFor,cCheckIn,nWhichOccurrence,lIgnoreCase)
FUNCTION FT_FINDITH(cCheckFor,cCheckIn,nWhichOccurrence,lIgnoreCase)
LOCAL nIthOccurrence
// Is Case Sensitivity Important??
IF IS_NOT_LOGICAL(lIgnoreCase) .OR. ;
lIgnoreCase
MAKE_UPPER(cCheckFor) // No, Force Everything to Uppercase
MAKE_UPPER(cCheckIn)
ENDIF // IS_NOT_LOGICAL(lIgnoreCase) or
// lIgnoreCase
RETURN (IF(nWhichOccurrence == 1, ;
AT(cCheckFor, cCheckIn), ;
IF((nIthOccurrence := AT(cCheckFor, ;
STRTRAN(cCheckIn, cCheckFor, ;
NULL, 1, ;
nWhichOccurrence-1))) == 0, ;
0, ;
nIthOccurrence + ((nWhichOccurrence - 1) * LEN(cCheckFor)))))
| findith.prg | 86 |
| firstday.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_FDAY(dDateToChk)
FUNCTION FT_FDAY(dDateToChk)
IF Valtype(dDatetoChk) # "D"
dDatetoChk := Date()
ENDIF
RETURN dDateToChk - (DAY(dDateToChk)-1)
| firstday.prg | 56 |
| floptst.prg |
| Type | Function | Source | Line |
|---|
| PROCEDURE | MAIN( cArg1 )
PROCEDURE MAIN( ;
cArg1 ;
)
LOCAL nErrCode
IF ValType( cArg1 ) == "C"
nErrCode := FT_FLOPTST( Asc( Upper(cArg1) ) - Asc( "A" ) )
OutStd( "Return Code is "+LTrim(Str(nErrCode)) +CR_LF )
ELSE
OutStd( "Usage: floptst cDrive"+CR_LF+" where cDrive is 'A' or 'B' etc..."+CR_LF )
ENDIF
RETURN
| floptst.prg | 106 |
| FUNCTION | FT_FLOPTST( nDriveNum_i )
FUNCTION FT_FLOPTST( ; // error code defined by ERR_*
nDriveNum_i ; // letter of floppy drive.
)
LOCAL cBuffer
LOCAL nErrorCode
LOCAL nRetCode
nRetCode := ERR_WRONG_PARAMETERS
IF ValType( nDriveNum_i ) == "N"
IF _GetDisketteNum( nDriveNum_i )
_ResetDisketteSystem()
_ReadBootSector( nDriveNum_i, @cBuffer, @nErrorCode )
IF nErrorCode == 0
_WriteBootSector( nDriveNum_i, cBuffer, @nErrorCode )
DO CASE
CASE nErrorCode == 0
nRetCode := ERR_NO_ERROR
CASE nErrorCode == 3
nRetCode := ERR_WRITE_PROTECTED
OTHERWISE
nRetCode := ERR_UNKNOWN
ENDCASE
ELSE
DO CASE
CASE nErrorCode == 128 // 80h
nRetCode := ERR_DRIVE_NOT_READY
CASE nErrorCode == 2
nRetCode := ERR_UNFORMATTED
OTHERWISE
nRetCode := ERR_UNKNOWN
END CASE
ENDIF
ENDIF
ENDIF
RETURN nRetCode
| floptst.prg | 123 |
| STATIC FUNCTION | _GetDisketteNum( nDrive_i )
STATIC FUNCTION _GetDisketteNum( ; // returns false if no floppy drive installed or nDrive_i is invalid
nDrive_i ; // drive number to query status
)
LOCAL aRegs[INT86_MAX_REGS]
LOCAL lRetCode
LOCAL nByte
LOCAL nDriveCount
// ASSERT 0 <= nDrive_i
lRetCode := FALSE
IF FT_INT86( 1*16+1, aRegs ) // INT for equipment determination
nByte := lowbyte( aRegs[AX] )
// bit 0 indicates floppy drive installed
IF Int( nByte / 2 ) * 2 != nByte // is it odd i.e. is bit 0 set??
// bits 6 & 7 indicate number of floppies installed upto 4.
nDriveCount := Asc( FT_BYTEAND( Chr(nByte), chr(BITS_6AND7) ) )
IF nDriveCount >= nDrive_i
lRetCode := TRUE
ENDIF
ENDIF
ENDIF
RETURN lRetCode
| floptst.prg | 164 |
| STATIC PROCEDURE | _ResetDisketteSystem()
STATIC PROCEDURE _ResetDisketteSystem()
LOCAL aRegs[INT86_MAX_REGS]
aRegs[AX] := 0
FT_INT86( 1*16+3, aRegs )
RETURN
| floptst.prg | 190 |
| STATIC FUNCTION | _ReadBootSector( nDriveNum, cBuffer_o, nErrCode_o )
STATIC FUNCTION _ReadBootSector( ;
nDriveNum, ;
cBuffer_o, ;
nErrCode_o ;
)
// call BIOS INT 13 for sector read
LOCAL aRegs[INT86_MAX_REGS]
LOCAL cBuffer := Space( BUFFER_SIZEOF_SECTOR )
LOCAL lSuccess
LOCAL nErrorCode
LOCAL lCarryFlag
aRegs[DX] := nDriveNum // DH = 0 Head 0, DL = drive number
aRegs[CX] := 1 // CH = 0 track 0, CL=1 sector 1
aRegs[BX] := REG_ES // buffer in ES:BX
aRegs[ES] := cBuffer
aRegs[AX] := makehi(2)+1 // AH = 02 read , AL=1 read one sector
lSuccess := _CallInt13hRetry( aRegs, @lCarryFlag, @nErrorCode )
cBuffer_o := aRegs[ES]
nErrCode_o := nErrorCode
RETURN lSuccess
| floptst.prg | 201 |
| STATIC FUNCTION | _WriteBootSector( nDriveNum, cBuffer_i, nErrCode_o )
STATIC FUNCTION _WriteBootSector( ;
nDriveNum, ;
cBuffer_i, ;
nErrCode_o ;
)
// call BIOS INT 13 for sector write
LOCAL aRegs[INT86_MAX_REGS]
LOCAL lSuccess
LOCAL nErrorCode
LOCAL lCarryFlag
aRegs[DX] := nDriveNum // DH = 0 Head 0 , DL = drive number
aRegs[CX] := 1 // CH = 0 track 0, CL=1 sector 1
aRegs[BX] := REG_ES // buffer in ES:BX
aRegs[ES] := cBuffer_i
aRegs[AX] := makehi(3)+1 // AH = 03 write , AL=1 read one sector
lSuccess := _CallInt13hRetry( aRegs, @lCarryFlag, @nErrorCode )
nErrCode_o := nErrorCode
RETURN lSuccess
| floptst.prg | 227 |
| STATIC FUNCTION | _CallInt13hRetry( aRegs_io, lCarrySet_o, nDriveStatus_o )
STATIC FUNCTION _CallInt13hRetry( ; // logical: did the interrupt succeed?
aRegs_io, ; // registers values for INT 13h
lCarrySet_o, ; // status of carry flag if return code is true.
nDriveStatus_o ; // status of drive ( error code )
)
LOCAL lCarrySet
LOCAL aRegisters
LOCAL lSuccess
LOCAL nInterrupt_c := 1*16+3 // INT 13h
LOCAL i
lCarrySet := FALSE
aRegisters := AClone( aRegs_io )
lSuccess := FT_INT86( nInterrupt_c, aRegisters )
IF lSuccess
lCarrySet := carrySet( aRegisters[FLAGS] )
IF lCarrySet
_ResetDisketteSystem()
aRegisters := AClone( aRegs_io )
FT_INT86( nInterrupt_c, aRegisters )
lCarrySet := carrySet( aRegisters[FLAGS] )
IF lCarrySet
_ResetDisketteSystem()
aRegisters := AClone( aRegs_io )
FT_INT86( nInterrupt_c, aRegisters )
lCarrySet := carrySet( aRegisters[FLAGS] )
IF lCarrySet
_ResetDisketteSystem()
ENDIF
ENDIF
ENDIF
ENDIF
FOR i := 1 TO INT86_MAX_REGS
// pass altered register back up
aRegs_io[i] := aRegisters[i]
NEXT // i
lCarrySet_o := lCarrySet
nDriveStatus_o := highByte( aRegisters[AX] )
RETURN lSuccess
| floptst.prg | 251 |
| ftround.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_ROUND(nNumber, nRoundToAmount, cRoundType, cRoundDirection, nAcceptableError)
FUNCTION FT_ROUND(nNumber, nRoundToAmount, cRoundType, cRoundDirection, ;
nAcceptableError)
LOCAL nResult := ABS(nNumber) // The Result of the Rounding
DEFAULT nRoundToAmount TO 2, ;
cRoundType TO NEAREST_DECIMAL, ;
cRoundDirection TO ROUND_NORMAL, ;
nAcceptableError TO 1 / (nRoundToAmount ** 2)
// Are We Rounding to the Nearest Whole
// Number or to Zero Decimal Places??
IF (LEFT(cRoundType,1) != NEAREST_WHOLE_NUMBER .AND. ;
(nRoundToAmount := INT(nRoundToAmount)) != 0)
// No, Are We Rounding to the Nearest
// Decimal Place??
IF (LEFT(cRoundType,1) == NEAREST_DECIMAL)
// Yes, Convert to Nearest Fraction
nRoundToAmount := 10 ** nRoundToAmount
ENDIF // LEFT(cRoundType,1) == NEAREST_DECIMAL
// Are We Already Within the Acceptable
// Error Factor??
IF (ABS(INT(nResult * nRoundToAmount) - (nResult * nRoundToAmount)) > ;
nAcceptableError)
// No, Are We Rounding Down??
nResult -= IIF(LEFT(cRoundDirection,1) == ROUND_DOWN, ;
; // Yes, Make Downward Adjustment
1 / nRoundToAmount / 2, ;
; // Are We Rounding Up??
IIF(LEFT(cRoundDirection,1) == ROUND_UP , ;
; // Yes, Make Upward Adjustment
-1 / (nRoundToAmount) / 2, ;
; // No, Rounding Normal, No Adjustment
0))
//Do the Actual Rounding
nResult := INT((nRoundToAmount * nResult) + .5 + nAcceptableError) / ;
nRoundToAmount
ENDIF // ABS(INT(nResult * nRoundToAmount) -
// (mResult * nRoundAmount)) >
// nAcceptableError
ELSE // Yes, Round to Nearest Whole Number
// or to Zero Places
nRoundToAmount := MAX(nRoundToAmount, 1)
DO CASE // Do "Whole" Rounding
CASE LEFT(cRoundDirection,1) == ROUND_UP
nResult := (INT(nResult / nRoundToAmount) * nRoundToAmount) + ;
nRoundToAmount
CASE LEFT(cRoundDirection,1) = ROUND_DOWN
nResult := INT(nResult / nRoundToAmount) * nRoundToAmount
OTHERWISE // Round Normally
nResult := INT((nResult + nRoundToAmount / 2) / nRoundToAmount) * ;
nRoundToAmount
ENDCASE
ENDIF // LEFT(cRoundType,1)!=NEAREST_WHOLE or
// nRoundToAmount == 0
IF IS_NEGATIVE(nNumber) // Was the Number Negative??
nResult := -nResult // Yes, Make the Result Negative Also
ENDIF // IS_NEGATIVE(nNumber)
RETURN (nResult) // FT_Round
| ftround.prg | 114 |
| gcd.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN( cNum1, cNum2 )
FUNCTION MAIN( cNum1, cNum2 )
RETURN OUTSTD( STR(FT_GCD( val(cNum1), val(cNum2) )) + CHR(13) + CHR(10) )
| gcd.prg | 65 |
| FUNCTION | FT_GCD(nNumber1, nNumber2)
FUNCTION FT_GCD(nNumber1, nNumber2)
LOCAL nHold1, ; // Temporarily Hold the Maximum Number
nHold2, ; // Temporarily Hold the Minimum Number
nResult // GCD
// Either Number Zero??
IF (nNumber1 == 0 .OR. nNumber2 == 0)
nResult := 0 // Yes, Can't Have a GCD
ELSE // No, Calculate the GCD
nHold1 := MAX(ABS(nNumber1), ABS(nNumber2))
nHold2 := MIN(ABS(nNumber1), ABS(nNumber2))
REPEAT
nResult := nHold1 % nHold2 // Get the Remainder
nHold1 := nHold2 // Which Makes a New Maximum Number
nHold2 := nResult // and it's the Minimum Number
UNTIL nResult <= 0
nResult := nHold1 // Maximum Number Should Be the Answer
ENDIF // nNumber1 == 0 or nNumber2 == 0
RETURN (nResult) // FT_GCD
| gcd.prg | 69 |
| hex2dec.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN( cHexNum )
FUNCTION MAIN( cHexNum )
QOut( FT_HEX2DEC( cHexNum ) )
return ( nil )
| hex2dec.prg | 59 |
| FUNCTION | FT_HEX2DEC( cHexNum )
FUNCTION FT_HEX2DEC( cHexNum )
local n, nDec := 0, nHexPower := 1
for n := len( cHexNum ) to 1 step -1
nDec += ( at( subs( upper(cHexNum), n, 1 ), HEXTABLE ) - 1 ) * nHexPower
nHexPower *= 16
next
RETURN nDec
| hex2dec.prg | 64 |
| invclr.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_INVCLR(cDsrdColor)
FUNCTION FT_INVCLR(cDsrdColor)
LOCAL cBackground, ; // The Background Color, New Foreground
cForeground, ; // The Foreground Color, New Background
cModifiers // Any Color Modifiers (+*)
DEFAULT cDsrdColor TO SETCOLOR()
// Remove Anything Past 1st Color
cDsrdColor := LEFT(cDsrdColor, AT(",", cDsrdColor+",")-1)
// Get Any Modifiers
cModifiers := IF("*" $ cDsrdColor, "*", NULL) + ;
IF("+" $ cDsrdColor, "+", NULL)
// Separate the Fore/Background Colors
cForeground := ALLTRIM(LEFT(cDsrdColor, AT("/", cDsrdColor) - 1))
cBackground := ALLTRIM(SUBSTR(cDsrdColor, AT("/", cDsrdColor) + 1))
RETURN (STRTRAN(STRTRAN(cBackground, "+"), "*") + cModifiers + "/" + ;
STRTRAN(STRTRAN(cForeground, "+"), "*"))
| invclr.prg | 58 |
| isbit.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_ISBIT(cInbyte,nBitPos)
FUNCTION FT_ISBIT(cInbyte,nBitPos)
LOCAL lBitStat
IF valtype(cInbyte) != "C" .or. valtype(nBitPos) != "N" // parameter check
lBitStat := NIL
ELSE
if (nBitPos > 7) .or. (nBitPos < 0) .or. (nBitPos != int(nBitPos))
lBitStat := NIL
else
lBitStat := int(((asc(cInByte) * (2 ^ (7 - nBitPos))) % 256) / 128) == 1
endif
ENDIF
RETURN lBitStat
| isbit.prg | 73 |
| isbiton.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_ISBITON( nWord, nBit )
function FT_ISBITON( nWord, nBit )
nWord := iif(nWord < 0, nWord + 65536, nWord)
nWord := int(nWord * (2 ^ (15 - nBit)))
nWord := int(nWord % 65536)
nWord := int(nWord / 32768)
return (nWord == 1)
| isbiton.prg | 63 |
| isshare.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | main()
function main()
local nLoaded := ft_isshare()
do case
case nLoaded == 0
Qout("Share not loaded, but ok to load")
case nLoaded == 1
Qout("Share not loaded, but NOT ok to load!")
case nLoaded == 255
Qout("Share is loaded!")
endcase
Qout("Retcode: " + str( nLoaded ) )
return nil
| isshare.prg | 64 |
| FUNCTION | ft_isshare()
FUNCTION ft_isshare()
/*
local aRegs[ INT86_MAX_REGS ] // Declare the register array
aRegs[ AX ] := makehi(16) // share service
aRegs[ CX ] := 0 // Specify file attribute
FT_Int86( 47, aRegs) // multiplex interrupt
RETURN lowbyte( aRegs[AX] )
*/
RETURN _ft_isshare()
| isshare.prg | 81 |
| lastday.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | ft_lday( dDate )
FUNCTION ft_lday( dDate )
LOCAL d:= dDate
IF dDate == NIL
d:= Date()
ENDIF
RETURN ( d+= 45 - Day( d ) ) - Day( d )
| lastday.prg | 60 |
| linked.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | Main
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
*------------------------------------------------
| linked.prg | 77 |
| FUNCTION | FT_Linked( cFuncs )
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 )
| linked.prg | 103 |
| madd.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_MADD( dGivenDate, nAddMonths, lMakeEOM)
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
| madd.prg | 77 |
| menu1.prg |
| Type | Function | Source | Line |
|---|
| PROCEDURE | CALLMENU( cCmdLine )
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
| menu1.prg | 188 |
| FUNCTION | fubar()
FUNCTION fubar()
LOCAL OldColor:= SETCOLOR( "W/N" )
CLEAR SCREEN
Qout( "Press Any Key" )
INKEY(0)
SETCOLOR( OldColor )
RETURN .t.
| menu1.prg | 303 |
| FUNCTION | FT_MENU1( aBar, aOptions, aColors, nTopRow, lShadow )
FUNCTION FT_MENU1( aBar, aOptions, aColors, nTopRow, lShadow )
LOCAL nTtlWid, nTtlUsed
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| HB_SYMBOL_UNUSED( x ), 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| HB_SYMBOL_UNUSED( x ), _ftWidest( @i, aChoices, @aBarWidth ) } )
// box location for each pulldown menu
// see below for _ftLocat()
AEVAL( aChoices, { |x,i| HB_SYMBOL_UNUSED( x ), _ftLocat( i, aBarCol, aBarWidth, @aBoxLoc, nMaxCol ) } )
// valid keys for each pulldown menu
// see below for _ftValKeys()
AEVAL( aChoices,{|x,i| HB_SYMBOL_UNUSED( x ), AADD( aValidkeys,"" ),;
_ftValKeys( i,aChoices,@aValidKeys ) } )
// display the menu bar
SETCOLOR( cBar )
@ nTopRow, 0
AEVAL( aBar, { |x,i| HB_SYMBOL_UNUSED( x ), Devpos(nTopRow, aBarCol[i]), Devout(aBar[i]) })
// store inkey code for each item on menu bar to aBarKeys
AEVAL( aBarKeys, {|x,i| HB_SYMBOL_UNUSED( x ), 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
| menu1.prg | 314 |
| FUNCTION | __ftAcUdf( nMode )
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
| menu1.prg | 434 |
| STATIC FUNCTION | _ftWidest( i, aChoices, aBarWidth )
STATIC FUNCTION _ftWidest( i, aChoices, aBarWidth )
AEVAL(aChoices[i,1],{|a,b| HB_SYMBOL_UNUSED( a ), aBarWidth[i] := ;
MAX( aBarWidth[i],LEN(aChoices[i,1,b])) })
RETURN NIL
| menu1.prg | 454 |
| STATIC FUNCTION | _ftLocat( i, aBarCol, aBarWidth, aBoxLoc, nMaxCol )
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
| menu1.prg | 459 |
| STATIC FUNCTION | _ftBailOut( cBorder, cBox )
STATIC FUNCTION _ftBailOut( cBorder, cBox )
LOCAL cOldColor, sOldScreen, nKeyPress, nOldCursor
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)
| menu1.prg | 464 |
| STATIC FUNCTION | _ftValKeys( nNum,aChoices,aValidkeys )
STATIC FUNCTION _ftValKeys( nNum,aChoices,aValidkeys )
AEVAL( aChoices[nNum,1], {|x| aValidKeys[nNum] += LEFT( x, 1)} )
RETURN NIL
| menu1.prg | 480 |
| FUNCTION | FT_FILL( aArray, cMenuOption, bBlock, lAvailable )
FUNCTION FT_FILL( aArray, cMenuOption, bBlock, lAvailable )
AADD( aArray[1], cMenuOption )
AADD( aArray[2], bBlock )
AADD( aArray[3], lAvailable )
RETURN NIL
| menu1.prg | 544 |
| menutonf.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_Prompt( nRow, nCol, cPrompt, cColor, nMsgRow, nMsgCol, cMessage, cMsgColor, nTrigger, cTriggerColor, nHome, nEnd, nUp, nDown, nLeft, nRight, bExecute )
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
| menutonf.prg | 230 |
| FUNCTION | FT_MenuTo( bGetSet, cReadVar, lCold )
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
| menutonf.prg | 349 |
| metaph.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN()
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
*------------------------------------------------
| metaph.prg | 135 |
| STATIC FUNCTION | _ftRow( nElem )
STATIC FUNCTION _ftRow( nElem ) // Determine which row to print on
RETURN IIF( nElem > 40, nElem - 40, IIF( nElem > 20, nElem - 20, nElem ) )
*------------------------------------------------
| metaph.prg | 220 |
| STATIC FUNCTION | _ftCol( 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
*------------------------------------------------
| metaph.prg | 223 |
| FUNCTION | FT_METAPH ( cName, nSize )
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 )
*------------------------------------------------
| metaph.prg | 231 |
| STATIC FUNCTION | _ftMakeAlpha ( cStr )
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
*------------------------------------------------
| metaph.prg | 362 |
| STATIC FUNCTION | _ftConvVowel ( cStr )
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
*------------------------------------------------
| metaph.prg | 376 |
| miltime.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | main()
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
| miltime.prg | 33 |
| FUNCTION | FT_MIL2MIN(cMILTIME)
function FT_MIL2MIN(cMILTIME)
return int(val(left(cMILTIME,2))*60 + val(right(cMILTIME,2)))
| miltime.prg | 93 |
| FUNCTION | FT_MIN2MIL(nMIN)
function FT_MIN2MIL(nMIN)
nMIN := nMIN%1440
return right("00" + ltrim(str(INT(nMIN/60))),2) + ;
right("00" + ltrim(str(INT(nMIN%60))),2)
| miltime.prg | 119 |
| FUNCTION | FT_MIL2CIV(cMILTIME)
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
| miltime.prg | 157 |
| FUNCTION | FT_CIV2MIL(cTIME)
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
| miltime.prg | 221 |
| FUNCTION | FT_SYS2MIL()
function FT_SYS2MIL()
return left(stuff(time(),3,1,""),4)
| miltime.prg | 283 |
| min2dhm.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_MIN2DHM(nMINS)
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_
| min2dhm.prg | 55 |
| month.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_MONTH( dGivenDate, nMonthNum )
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
| month.prg | 88 |
| mouse1.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN(nRow,nCol)
FUNCTION MAIN(nRow,nCol)
* Pass valid row and column values for different video modes to change modes
local nX, nY, cSavClr
local cSavScr := savescreen( 0, 0, maxrow(), maxcol() )
local nXm, nYm
local nSaveRow:=MAXROW()+1, nSaveCol:=MAXCOL()+1
local nMinor, nType, nIRQ
local aType:={"Bus","Serial","InPort","PS/2","HP"}
local nHoriz, nVert, nDouble
local nTime
IF nRow=NIL
nRow=MAXROW()+1
ELSE
nRow=VAL(nRow)
ENDIF
IF nCol=NIL
nCol=MAXCOL()+1
ELSE
nCol=VAL(nCol)
ENDIF
if !FT_MINIT()
@ maxrow(), 0 say "Mouse driver is not installed!"
return ""
endif
* ..... Set up the screen
cSavClr := setcolor( "w/n" )
@ 0,0,maxrow(),maxcol() box "°°°°°°°°°"
setcolor( "GR+/RB" )
// scroll( 7,2,19,63,0 )
@ 7,2 to 20,63
@ 17, 10 to 19, 40 double
setcolor( "N/W" )
@ 18, 11 say " Double Click here to Quit "
setcolor( "GR+/RB" )
* ..... Start the demo
@MAXROW(),0 SAY "Driver version: "+;
ALLTRIM(STR(FT_MVERSION(@nMinor,@nType,@nIRQ),2,0))+"."+;
ALLTRIM(STR(nMinor,2,0))
@ ROW(),COL() SAY " "+aType[nType]+" mouse using IRQ "+STR(nIRQ,1,0)
FT_MGETSENS(@nHoriz,@nVert,@nDouble) // Get the current sensitivities
FT_MSETSENS(70,70,60) // Bump up the sensitivity of the mouse
FT_MSHOWCRS()
FT_MSETCOORD(10,20) // just an arbitrary place for demo
* put the unchanging stuff
devpos( 9, 10 )
devout( "FT_MMICKEYS :" )
devpos( 10, 10 )
devout( "FT_MGETPOS :" )
devpos( 11, 10 )
devout( "FT_MGETX :" )
devpos( 12, 10 )
devout( "FT_MGETY :")
devpos( 13, 10 )
devout( "FT_MGETCOORD:" )
devpos( 14, 10 )
devout( "FT_MBUTPRS :" )
devpos( 16, 10 )
devout( "FT_MBUTREL :" )
nX := nY := 1
do while .t.
* If we are not moving then wait for movement.
* This whole demo is a bit artificial in its requirements when compared
* to a "normal" CLIPPER program so some of these examples are a bit out of
* the ordinary.
DO WHILE nX=0.AND.nY=0
FT_MMICKEYS( @nX, @nY )
ENDDO
* tell the mouse driver where updates will be taking place so it can hide
* the cursor when necessary.
FT_MCONOFF( 9, 23, 16, 53 )
nTime=-1
devpos( 9, 23 )
devout( nX )
devout( nY )
devpos( 10, 23 )
DEVOUT( FT_MGETPOS( @nX, @nY ) )
devout( nX )
devout( nY )
devpos( 11, 23 )
DEVOUT( FT_MGETX() )
devpos( 12, 23 )
DEVOUT( FT_MGETY() )
devpos( 13, 23 )
devout( FT_MGETCOORD( @nX, @nY ) )
devout ( nX )
devout ( nY )
nX:=nY:=0
devpos( 14, 23 )
DEVOUT( FT_MBUTPRS(1) )
DEVOUT( FT_MBUTPRS(0,, nX, nY) )
devpos( 15, 23 )
* show only the last Press since it flashes by so quickly
IF nX!=0.OR.nY!=0
devout( nX )
devout( nY )
endif
nX:=nY:=0
devpos( 16, 23 )
devout( FT_MBUTREL(0,, @nX, @nY) )
* show only the last release since it flashes by so quickly
if nX!=0.OR.nY!=0
devout( nX )
devout( nY )
endif
* Restore the cursor if it has been hidden
FT_MSHOWCRS()
if FT_MINREGION( 18, 11, 18, 39 )
* Change the type of cursor when in the box. Just slightly different than the
* normal. The character is shown in high intensity.
FT_MDEFCRS(0,32767,32512)
if FT_MDBLCLK(2,0,0.8)
exit
endif
endif
if FT_MINREGION( 18, 11, 18, 39 )
* Change the type of cursor when in the box. Just slightly different than the
* normal. The character is shown in high intensity.
FT_MDEFCRS(0,32767,32512)
else
* Put the cursor back to normal mode
FT_MDEFCRS(0,30719,30464)
endif
FT_MMICKEYS( @nX, @nY )
enddo
FT_MHIDECRS()
SETMODE(nSaveRow,nSaveCol)
setcolor( cSavClr )
restscreen( 0, 0, maxrow(), maxcol(), cSavScr )
devpos( maxrow(), 0 )
// Reset sensitivity
FT_MSETSENS(nHoriz, nVert, nDouble)
RETURN nil
#endif
| mouse1.prg | 10 |
| FUNCTION | FT_MMICKEYS( nX, nY )
FUNCTION FT_MMICKEYS( nX, nY ) // read mouse motion counters
/*
aReg[AX] = 11 // set mouse function call 11
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
Local areturn:={}
areturn:=_mget_mics()
nX := areturn[1] // store horizontal motion units
nY := areturn[2] // store vertical motion units
RETURN NIL // no function output
| mouse1.prg | 227 |
| FUNCTION | FT_MDBLCLK( nClick, nButton, nInterval, nRow, nCol, nStart )
FUNCTION FT_MDBLCLK( nClick, nButton, nInterval, nRow, nCol, nStart )
LOCAL nVert, nHorz // local row and col coordinates
LOCAL lDouble:=.F. // double click actually occurred
LOCAL lDone // loop flag
LOCAL nPrs // number of presses which occurred
* Initialize any empty arguments
if nClick=NIL
nClick=1
endif
if nButton=NIL
nButton=0
endif
if nRow=NIL
nRow=FT_MGETX()
endif
if nCol=NIL
nCol=FT_MGETY()
endif
if nInterval=NIL
nInterval=0.5
endif
if nStart=NIL
nStart=seconds()
endif
nVert=nRow
nHorz=nCol
lDouble:=lDone:=nClick==0
// Wait for first press if requested
do while !lDone
FT_MBUTPRS( nButton, @nPrs, @nVert, @nHorz )
nVert=INT(nVert/8)
nHorz=INT(nHorz/8)
lDouble=(nPrs>0)
ldone= seconds() - nStart >= nInterval .or. lDouble
enddo
// if we have not moved then keep the preliminary double click setting
lDouble=lDouble.and.(nVert=nRow.and.nHorz=nCol)
// change start time if we waited for first click. nInterval is the
// maximum time between clicks not the total time for two clicks if
// requested.
if nClick>0
nStart=seconds()
endif
// If we have fulfilled all of the requirements then wait for second click
if lDouble
lDouble:=lDone:=.F.
do while !lDone
FT_MBUTPRS( nButton, @nPrs, @nVert, @nHorz )
nVert=INT(nVert/8)
nHorz=INT(nHorz/8)
lDouble=(nPrs>0)
lDone= seconds() - nStart >= nInterval .or. lDouble
enddo
// make sure we haven't moved
lDouble=lDouble.and.(nVert=nRow.and.nHorz=nCol)
endif
RETURN lDouble
| mouse1.prg | 300 |
| FUNCTION | FT_MCONOFF( nTop, nLeft, nBottom, nRight )
FUNCTION FT_MCONOFF( nTop, nLeft, nBottom, nRight )
* Fill the registers
/*
aReg[AX]:=16
aReg[DX]:=nTop*8
aReg[CX]:=nLeft*8
aReg[DI]:=nBottom*8
aReg[SI]:=nRight*8
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
_mse_conoff(nTop*8,nLeft*8,nBottom*8,nRight*8)
RETURN NIL
| mouse1.prg | 417 |
| FUNCTION | FT_MINREGION( nTR, nLC, nBR, nRC )
FUNCTION FT_MINREGION( nTR, nLC, nBR, nRC )
RETURN ( FT_MGETX() >= nTR .and. FT_MGETX() <= nBR .and. ;
FT_MGETY() >= nLC .and. FT_MGETY() <= nRC )
| mouse1.prg | 458 |
| FUNCTION | FT_MSETSENS(nHoriz, nVert, nDouble)
FUNCTION FT_MSETSENS(nHoriz, nVert, nDouble)
LOCAL nCurHoriz, nCurVert, nCurDouble
// Get current values
FT_MGETSENS(@nCurHoriz, @nCurVert, @nCurDouble)
// Set defaults if necessary
IF VALTYPE(nHoriz)!="N"
nHoriz=nCurHoriz
ENDIF
IF VALTYPE(nVert)!="N"
nVert=nCurVert
ENDIF
IF VALTYPE(nDouble)!="N"
nDouble=nCurDouble
ENDIF
* Fill the registers
_mset_sensitive(nHoriz,nVert,nDouble)
RETURN nil
| mouse1.prg | 526 |
| FUNCTION | FT_MGETSENS(nHoriz, nVert, nDouble)
FUNCTION FT_MGETSENS(nHoriz, nVert, nDouble)
/*
* Fill the register
aReg[AX]=27
* Execute interupt
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
// Set the return values
nHoriz = _mget_horispeed()
nVert = _mget_verspeed()
nDouble= _mget_doublespeed()
RETURN NIL
| mouse1.prg | 585 |
| FUNCTION | FT_MVERSION(nMinor, nType, nIRQ)
FUNCTION FT_MVERSION(nMinor, nType, nIRQ)
Local aReturn:={}
// Set up register
/*
aReg[AX] = 36
// Call interupt
FT_INT86( 51, aReg)
*/
// decode out of half registers
areturn:=_mget_mversion()
nMinor=areturn[1]
nType=areturn[2]
nIRQ=areturn[3]
// Return
RETURN areturn[4]
| mouse1.prg | 649 |
| FUNCTION | FT_MSETPAGE(nPage)
FUNCTION FT_MSETPAGE(nPage)
// Set up register
/*
aReg[AX] = 29
aReg[BX]=nPage
// Call interupt
FT_INT86( 51, aReg)
*/
_mset_page(nPage)
RETURN NIL
| mouse1.prg | 696 |
| FUNCTION | FT_MGETPAGE()
FUNCTION FT_MGETPAGE()
// Set up register
/*
aReg[AX] = 30
// Call interupt
FT_INT86( 51, aReg)
*/
RETURN _mget_page()
| mouse1.prg | 736 |
| FUNCTION | FT_MINIT()
FUNCTION FT_MINIT()
* If not previously initialized then try
IF !s_lMinit
s_lMinit := ( FT_MRESET() != 0 )
ELSE
* Reset maximum x and y limits
FT_MYLIMIT(0,8*24)
FT_MXLIMIT(0,8*80)
ENDIF
RETURN s_lMinit
| mouse1.prg | 751 |
| FUNCTION | FT_MRESET()
FUNCTION FT_MRESET()
LOCAL lStatus
/*
aReg[AX] := 0 // set mouse function call 0
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
s_lCrsState=.F. // Cursor is off after reset
lStatus:=_m_reset()
* Reset maximum x and y limits
FT_MYLIMIT(0,8*MAXROW())
FT_MXLIMIT(0,8*MAXCOL())
RETURN lStatus // return status code
| mouse1.prg | 800 |
| FUNCTION | FT_MCURSOR( lState )
FUNCTION FT_MCURSOR( lState )
local lSavState := s_lCrsState
if VALTYPE(lState)="L"
if ( s_lCrsState := lState )
FT_MSHOWCRS()
else
FT_MHIDECRS()
endif
ENDIF
RETURN lSavState
| mouse1.prg | 842 |
| FUNCTION | FT_MSHOWCRS()
FUNCTION FT_MSHOWCRS()
/*
aReg[AX] := 1 // set mouse function call 1
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
_mse_showcurs()
s_lCrsState := .t.
RETURN NIL // no output from function
| mouse1.prg | 890 |
| FUNCTION | FT_MHIDECRS()
FUNCTION FT_MHIDECRS() // decrement internal cursor flag and hide cursor
/*
aReg[AX] := 2 // set mouse function call 2
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
_mse_mhidecrs()
s_lCrsState := .f.
RETURN NIL // no output from function
| mouse1.prg | 939 |
| FUNCTION | FT_MGETPOS( nX, nY )
FUNCTION FT_MGETPOS( nX, nY )
Local amse:={}
nX := if( nX == NIL, 0, nX )
nY := if( nY == NIL, 0, nY )
/*
aReg[AX] := 3 // set mouse function call 3
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
amse:=_mse_getpos()
nX := amse[1] // store new x-coordinate
nY := amse[2] // store new y-coordinate
RETURN amse[3] // return button status
| mouse1.prg | 996 |
| FUNCTION | FT_MGETX()
FUNCTION FT_MGETX()
* Duplicated code from FT_MGETPOS() for speed reasons
/*
aReg[AX] := 3 // set mouse function call 3
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
RETURN( _m_getx()/8 ) // return x-coordinate
| mouse1.prg | 1038 |
| FUNCTION | FT_MGETY()
FUNCTION FT_MGETY()
* Duplicated code from FT_MGETPOS() for speed reasons
/*
aReg[AX] := 3 // set mouse function call 3
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
RETURN( _m_gety()/8) // return y-coordinate
| mouse1.prg | 1072 |
| FUNCTION | FT_MSETPOS( nX, nY )
FUNCTION FT_MSETPOS( nX, nY ) // set mouse cursor location
/*
aReg[AX] := 4 // set mouse function call 4
aReg[CX] := nY // assign new x-coordinate
aReg[DX] := nX // assign new y-coordinate
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
_m_msetpos(nY,nX)
RETURN NIL // no function output
| mouse1.prg | 1109 |
| FUNCTION | FT_MSETCOORD( nX, nY )
FUNCTION FT_MSETCOORD( nX, nY ) // set mouse cursor location
/*
aReg[AX] := 4 // set mouse function call 4
aReg[CX] := nY*8 // assign new x-coordinate
aReg[DX] := nX*8 // assign new y-coordinate
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
_m_MSETCOORD(nY*8,nX*8)
RETURN NIL // no function output
| mouse1.prg | 1147 |
| FUNCTION | FT_MXLIMIT( nXMin, nXMax )
FUNCTION FT_MXLIMIT( nXMin, nXMax ) // set vertical minimum and maximum coordinates
/*
aReg[AX] = 7 // set mouse function call 7
aReg[CX] = nXMin // load vertical minimum parameter
aReg[DX] = nXMax // load vertical maximum parameter
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
_m_mxlimit(nXMin,nXMAX)
RETURN NIL
| mouse1.prg | 1182 |
| FUNCTION | FT_MYLIMIT( nYMin, nYMax )
FUNCTION FT_MYLIMIT( nYMin, nYMax ) // set horizontal minimum and maximum coordinates
/*
aReg[AX] = 8 // set mouse function call 8
aReg[CX] = nYMin // load horz minimum parameter
aReg[DX] = nYMax // load horz maximum parameter
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
_m_mYlimit(nYMin,nYMAX)
RETURN NIL // no function output
| mouse1.prg | 1217 |
| FUNCTION | FT_MBUTPRS( nButton, nButPrs, nX, nY )
FUNCTION FT_MBUTPRS( nButton, nButPrs, nX, nY ) // get button press information
local aReg:={}
/*
aReg[AX] := 5 // set mouse function call 5
aReg[BX] := nButton // pass parameter for left or right button
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
nButPrs := aReg[1] // store updated press count
nX := aReg[2] // x-coordinate at last press
nY := aReg[3] // y-coordinate at last press
_m_MBUTPRS(nButton)
RETURN aReg[4] // return button status
| mouse1.prg | 1274 |
| FUNCTION | FT_MBUTREL( nButton, nButRel, nX, nY )
FUNCTION FT_MBUTREL( nButton, nButRel, nX, nY ) // get button release information
local areg:={}
Local iButton
areg:=_m_MBUTREL(nButton)
nButRel := aReg[1] // store updated release count
nX := aReg[2] // x-coordinate at last release
nY := aReg[3] // y-coordinate at last release
iButton:= aReg[4] // return button status
RETURN iButton
| mouse1.prg | 1331 |
| FUNCTION | FT_MDEFCRS( nCurType, nScrMask, nCurMask )
FUNCTION FT_MDEFCRS( nCurType, nScrMask, nCurMask ) // define text cursor type and masks
/*
aReg[AX] = 10 // set mouse function call 10
aReg[BX] = nCurType // load cursor type parameter
aReg[CX] = nScrMask // load screen mask value
aReg[DX] = nCurMask // load cursor mask value
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
_m_mdefcrs(nCurType, nScrMask, nCurMask )
RETURN NIL // no function output
| mouse1.prg | 1402 |
| FUNCTION | FT_MGETCOORD( nX, nY )
FUNCTION FT_MGETCOORD( nX, nY )
* Duplicated code from FT_MGETPOS() for speed reasons
local aReg:={}
local iButton
nX := if( nX == NIL, 0, nX )
nY := if( nY == NIL, 0, nY )
/*
aReg[AX] := 3 // set mouse function call 3
FT_INT86( 51, aReg ) // execute mouse interrupt
*/
areg:=_m_mgetcoord()
nX := INT(aReg[1]/8) // store new x-coordinate
nY := INT(aReg[2]/8) // store new y-coordinate
iButton:= aReg[3] // return button status
RETURN iButton
| mouse1.prg | 1455 |
| mouse2.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN(nRow,nCol)
FUNCTION MAIN(nRow,nCol)
* Pass valid row and column values for different video modes to change modes
local nX, nY, cSavClr
local cSavScr := savescreen( 0, 0, maxrow(), maxcol() )
local nXm, nYm
local nSaveRow:=MAXROW()+1, nSaveCol:=MAXCOL()+1
local nMinor, nType, nIRQ
local aType:={"Bus","Serial","InPort","PS/2","HP"}
local nHoriz, nVert, nDouble
local nTime
IF nRow=NIL
nRow=MAXROW()+1
ELSE
nRow=VAL(nRow)
ENDIF
IF nCol=NIL
nCol=MAXCOL()+1
ELSE
nCol=VAL(nCol)
ENDIF
IF .NOT.SETMODE(nRow,nCol)
@maxrow(),0 SAY "Mode Change unsuccessful:"+STR(nRow,2,0)+" by";
+STR(nCol,3,0)
RETURN NIL
ENDIF
if empty( FT_MINIT() )
@ maxrow(), 0 say "Mouse driver is not installed!"
SETMODE(nSaveRow,nSaveCol)
return ""
endif
* ..... Set up the screen
cSavClr := setcolor( "w/n" )
@ 0,0,maxrow(),maxcol() box "°°°°°°°°°"
setcolor( "GR+/RB" )
scroll( 7,2,19,63,0 )
@ 7,2 to 20,63
@ 17, 10 to 19, 40 double
setcolor( "N/W" )
@ 18, 11 say " Double Click here to Quit "
setcolor( "GR+/RB" )
* ..... Start the demo
@MAXROW(),0 SAY "Driver version: "+;
ALLTRIM(STR(FT_MVERSION(@nMinor,@nType,@nIRQ),2,0))+"."+;
ALLTRIM(STR(nMinor,2,0))
@ ROW(),COL() SAY " "+aType[nType]+" mouse using IRQ "+STR(nIRQ,1,0)
FT_MGETSENS(@nHoriz,@nVert,@nDouble) // Get the current sensitivities
FT_MSETSENS(70,70,60) // Bump up the sensitivity of the mouse
FT_MSHOWCRS()
FT_MSETCOORD(10,20) // just an arbitrary place for demo
* put the unchanging stuff
devpos( 9, 10 )
devout( "FT_MMICKEYS :" )
devpos( 10, 10 )
devout( "FT_MGETPOS :" )
devpos( 11, 10 )
devout( "FT_MGETX :" )
devpos( 12, 10 )
devout( "FT_MGETY :")
devpos( 13, 10 )
devout( "FT_MGETCOORD:" )
devpos( 14, 10 )
devout( "FT_MBUTPRS :" )
devpos( 16, 10 )
devout( "FT_MBUTREL :" )
nX := nY := 1
do while .t.
* If we are not moving then wait for movement.
* This whole demo is a bit artificial in its requirements when compared
* to a "normal" CLIPPER program so some of these examples are a bit out of
* the ordinary.
DO WHILE nX=0.AND.nY=0
FT_MMICKEYS( @nX, @nY )
ENDDO
* tell the mouse driver where updates will be taking place so it can hide
* the cursor when necessary.
FT_MCONOFF( 9, 23, 16, 53 )
nTime=-1
devpos( 9, 23 )
devout( nX )
devout( nY )
devpos( 10, 23 )
DEVOUT( FT_MGETPOS( @nX, @nY ) )
devout( nX )
devout( nY )
devpos( 11, 23 )
DEVOUT( FT_MGETX() )
devpos( 12, 23 )
DEVOUT( FT_MGETY() )
devpos( 13, 23 )
devout( FT_MGETCOORD( @nX, @nY ) )
devout ( nX )
devout ( nY )
nX:=nY:=0
devpos( 14, 23 )
DEVOUT( FT_MBUTPRS(1) )
DEVOUT( FT_MBUTPRS(0,, nX, nY) )
devpos( 15, 23 )
* show only the last Press since it flashes by so quickly
IF nX!=0.OR.nY!=0
devout( nX )
devout( nY )
endif
nX:=nY:=0
devpos( 16, 23 )
devout( FT_MBUTREL(0,, @nX, @nY) )
* show only the last release since it flashes by so quickly
if nX!=0.OR.nY!=0
devout( nX )
devout( nY )
endif
* Restore the cursor if it has been hidden
FT_MSHOWCRS()
if FT_MINREGION( 18, 11, 18, 39 )
* Change the type of cursor when in the box. Just slightly different than the
* normal. The character is shown in high intensity.
FT_MDEFCRS(0,32767,32512)
if FT_MDBLCLK(2,0,0.8)
exit
endif
endif
if FT_MINREGION( 18, 11, 18, 39 )
* Change the type of cursor when in the box. Just slightly different than the
* normal. The character is shown in high intensity.
FT_MDEFCRS(0,32767,32512)
else
* Put the cursor back to normal mode
FT_MDEFCRS(0,30719,30464)
endif
FT_MMICKEYS( @nX, @nY )
enddo
FT_MHIDECRS()
SETMODE(nSaveRow,nSaveCol)
setcolor( cSavClr )
restscreen( 0, 0, maxrow(), maxcol(), cSavScr )
devpos( maxrow(), 0 )
// Reset sensitivity
FT_MSETSENS(nHoriz, nVert, nDouble)
RETURN nil
#endif
| mouse2.prg | 77 |
| FUNCTION | FT_MINIT()
FUNCTION FT_MINIT()
* If not previously initialized then try
IF !lMinit
lMinit=(FT_MRESET()!=0)
ELSE
* Reset maximum x and y limits
FT_MYLIMIT(0,8*MAXROW())
FT_MXLIMIT(0,8*MAXCOL())
ENDIF
RETURN lMinit
| mouse2.prg | 304 |
| FUNCTION | FT_MRESET()
FUNCTION FT_MRESET()
aReg[AX] := 0 // set mouse function call 0
FT_INT86( 51, aReg ) // execute mouse interrupt
lCrsState=.F. // Cursor is off after reset
* Reset maximum x and y limits
FT_MYLIMIT(0,8*MAXROW())
FT_MXLIMIT(0,8*MAXCOL())
RETURN aReg[AX] // return status code
| mouse2.prg | 353 |
| FUNCTION | FT_MCURSOR( lState )
FUNCTION FT_MCURSOR( lState )
local lSavState := lCrsState
if VALTYPE(lState)="L"
if ( lCrsState := lState )
FT_MSHOWCRS()
else
FT_MHIDECRS()
endif
ENDIF
RETURN lSavState
| mouse2.prg | 393 |
| FUNCTION | FT_MSHOWCRS()
FUNCTION FT_MSHOWCRS()
aReg[AX] := 1 // set mouse function call 1
FT_INT86( 51, aReg ) // execute mouse interrupt
lCrsState := .t.
RETURN NIL // no output from function
| mouse2.prg | 441 |
| FUNCTION | FT_MHIDECRS()
FUNCTION FT_MHIDECRS() // decrement internal cursor flag and hide cursor
aReg[AX] := 2 // set mouse function call 2
FT_INT86( 51, aReg ) // execute mouse interrupt
lCrsState := .f.
RETURN NIL // no output from function
| mouse2.prg | 488 |
| FUNCTION | FT_MGETPOS( nX, nY )
FUNCTION FT_MGETPOS( nX, nY )
nX := if( nX == NIL, 0, nX )
nY := if( nY == NIL, 0, nY )
aReg[AX] := 3 // set mouse function call 3
FT_INT86( 51, aReg ) // execute mouse interrupt
nX := aReg[DX] // store new x-coordinate
nY := aReg[CX] // store new y-coordinate
RETURN aReg[BX] // return button status
| mouse2.prg | 544 |
| FUNCTION | FT_MGETCOORD( nX, nY )
FUNCTION FT_MGETCOORD( nX, nY )
* Duplicated code from FT_MGETPOS() for speed reasons
nX := if( nX == NIL, 0, nX )
nY := if( nY == NIL, 0, nY )
aReg[AX] := 3 // set mouse function call 3
FT_INT86( 51, aReg ) // execute mouse interrupt
nX := INT(aReg[DX]/8) // store new x-coordinate
nY := INT(aReg[CX]/8) // store new y-coordinate
RETURN aReg[BX] // return button status
| mouse2.prg | 597 |
| FUNCTION | FT_MGETX()
FUNCTION FT_MGETX()
* Duplicated code from FT_MGETPOS() for speed reasons
aReg[AX] := 3 // set mouse function call 3
FT_INT86( 51, aReg ) // execute mouse interrupt
RETURN( INT(aReg[DX]/8) ) // return x-coordinate
| mouse2.prg | 637 |
| FUNCTION | FT_MGETY()
FUNCTION FT_MGETY()
* Duplicated code from FT_MGETPOS() for speed reasons
aReg[AX] := 3 // set mouse function call 3
FT_INT86( 51, aReg ) // execute mouse interrupt
RETURN( INT(aReg[CX]/8)) // return y-coordinate
| mouse2.prg | 671 |
| FUNCTION | FT_MSETPOS( nX, nY )
FUNCTION FT_MSETPOS( nX, nY ) // set mouse cursor location
aReg[AX] := 4 // set mouse function call 4
aReg[CX] := nY // assign new x-coordinate
aReg[DX] := nX // assign new y-coordinate
FT_INT86( 51, aReg ) // execute mouse interrupt
RETURN NIL // no function output
| mouse2.prg | 708 |
| FUNCTION | FT_MSETCOORD( nX, nY )
FUNCTION FT_MSETCOORD( nX, nY ) // set mouse cursor location
aReg[AX] := 4 // set mouse function call 4
aReg[CX] := nY*8 // assign new x-coordinate
aReg[DX] := nX*8 // assign new y-coordinate
FT_INT86( 51, aReg ) // execute mouse interrupt
RETURN NIL // no function output
| mouse2.prg | 745 |
| FUNCTION | FT_MXLIMIT( nXMin, nXMax )
FUNCTION FT_MXLIMIT( nXMin, nXMax ) // set vertical minimum and maximum coordinates
aReg[AX] = 7 // set mouse function call 7
aReg[CX] = nXMin // load vertical minimum parameter
aReg[DX] = nXMax // load vertical maximum parameter
FT_INT86( 51, aReg ) // execute mouse interrupt
RETURN NIL
| mouse2.prg | 779 |
| FUNCTION | FT_MYLIMIT( nYMin, nYMax )
FUNCTION FT_MYLIMIT( nYMin, nYMax ) // set horizontal minimum and maximum coordinates
aReg[AX] = 8 // set mouse function call 8
aReg[CX] = nYMin // load horz minimum parameter
aReg[DX] = nYMax // load horz maximum parameter
FT_INT86( 51, aReg ) // execute mouse interrupt
RETURN NIL // no function output
| mouse2.prg | 813 |
| FUNCTION | FT_MBUTPRS( nButton, nButPrs, nX, nY )
FUNCTION FT_MBUTPRS( nButton, nButPrs, nX, nY ) // get button press information
aReg[AX] := 5 // set mouse function call 5
aReg[BX] := nButton // pass parameter for left or right button
FT_INT86( 51, aReg ) // execute mouse interrupt
nButPrs := aReg[BX] // store updated press count
nX := aReg[DX] // x-coordinate at last press
nY := aReg[CX] // y-coordinate at last press
RETURN aReg[AX] // return button status
| mouse2.prg | 870 |
| FUNCTION | FT_MBUTREL( nButton, nButRel, nX, nY )
FUNCTION FT_MBUTREL( nButton, nButRel, nX, nY ) // get button release information
aReg[AX] := 6 // set mouse function call 6
aReg[BX] := nButton // pass parameter for left or right button
FT_INT86( 51, aReg ) // execute mouse interrupt
nButRel := aReg[BX] // store updated release count
nX := aReg[DX] // x-coordinate at last release
nY := aReg[CX] // y-coordinate at last release
RETURN aReg[AX] // return button status
/*
* $DOC$
* $FUNCNAME$
* FT_MDEFCRS()
* $CATEGORY$
* Keyboard/Mouse
* $ONELINER$
* Define the mouse cursor
* $SYNTAX$
* FT_MDEFCRS( , , ) -> NIL
* $ARGUMENTS$
* is the cursor type. A value of 0 indicates the software cursor
* (the default) and a value of 1 indicates the hardware cursor.
*
* is the screen mask for the software cursor or the first scan
* line of the hardware cursor. See the description for more
* information.
*
* is the cursor mask for the software cursor of the last scan
* line of the hardware cursor. See the description for more
* information.
* $RETURNS$
* NIL
* $DESCRIPTION$
* In text mode the mouse cursor can either be a software generated or
* the actual hardware cursor. This routine allows one choose between them.
* The software cursor is the default and its effect on the character it
* covers is determined by the screen mask and the cursor mask. Both of
* these masks are 16 bit values (which in Clipper are passed as standard
* numerical values). The 16 bit masks are arranged in a manner identical
* to the way information is stored for each character cell on the screen.
* The low order 8 bits represent the actual character displayed while the
* high order bits represent the display atributes such as blinking,
* intensity and forground and background colors. The mask is represented in
* the diagram below:
*
* Bit: ³15 ³14 12³11 ³10 8³7 0³
* Function:³blink ³background³intensity³foreground³character³
*
* Blinking and high intensity are on when the bit is 1. The background and
* foreground indicate which colors are used for each. The software mouse
* cursor uses these two values by taking the mask from the screen cell it
* is on and performing a logical AND on each bit with the screen mask
* value. The result is then logically XOR'ed with the cursor mask value.
* Thus to keep the character the same but invert the foreground and
* background colors the following values would be used:
*
* Bit: ³15 ³14 12³11 ³10 8³7 0³
* Function:³blink ³background³intensity³foreground³character³
* screen: ³ 0 ³ 111 ³ 0 ³ 111 ³11111111 ³ =30719
* cursor: ³ 0 ³ 111 ³ 0 ³ 111 ³00000000 ³ =30464
*
* The hardware cursor is the text cursor provided by the video board. One
* specifies the range of scan lines which are on using and
* . The range of values is dependant upon the type of monitor.
* The first scan line is 0.
* $END$
*/
| mouse2.prg | 926 |
| netpv.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN()
FUNCTION MAIN()
? FT_NETPV( 10000, 10, { 10000,15000,16000,17000 } )
RETURN ( nil )
| netpv.prg | 72 |
| FUNCTION | FT_NETPV(nInitialInvestment, nInterestRate, aCashFlow, nNoOfCashFlows)
FUNCTION FT_NETPV(nInitialInvestment, nInterestRate, aCashFlow, nNoOfCashFlows)
LOCAL nNetPresentValue := 0
nNoOfCashFlows := iif( nNoOfCashFlows == nil, len( aCashFlow ), nNoOfCashFlows )
AEVAL(aCashFlow, ;
{ | nElement, nElementNo | ;
nNetPresentValue += nElement / ;
((1 + (nInterestRate / 100)) ** nElementNo) }, ;
1, nNoOfCashFlows)
RETURN (nNetPresentValue -= nInitialInvestment)
| netpv.prg | 78 |
| nooccur.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_NOOCCUR(cCheckFor, cCheckIn, lIgnoreCase)
FUNCTION FT_NOOCCUR(cCheckFor, cCheckIn, lIgnoreCase)
// Is Case Important??
IF (IS_NOT_LOGICAL(lIgnoreCase) .OR. lIgnoreCase)
MAKE_UPPER(cCheckFor) // No, Force Everything to Uppercase
MAKE_UPPER(cCheckIn)
ENDIF // IS_NOT_LOGICAL(lIgnoreCase) or ;
// lIgnoreCase
RETURN (IF(LEN(cCheckFor) == 0 .OR. LEN(cCheckIn) == 0, ;
0, ;
INT((LEN(cCheckIn) - LEN(STRTRAN(cCheckIn, cCheckFor))) / ;
LEN(cCheckFor))))
| nooccur.prg | 66 |
| ntow.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | main( cNum )
function main( cNum )
return qout( ft_ntow( val( cNum ) ) )
| ntow.prg | 92 |
| FUNCTION | ft_ntow(nAmount)
function ft_ntow(nAmount)
local nTemp, sResult := " ", nQualNo
local nDiv := 10 ^ ( int( sol10(nAmount) / 3 ) * 3 )
nTemp := int(nAmount % nDiv)
nAmount := int(nAmount / nDiv)
nQualNo := int( sol10( nDiv ) / 3 ) + 1
sResult += grp_to_words(nAmount, qualifiers[ nQualNo ] )
if nTemp > (nDiv /= 1000) .and. (nDiv > 1)
sResult += ft_ntow( nTemp, nDiv )
else
sResult += grp_to_words(nTemp, "")
endif
return( ltrim(sResult) )
| ntow.prg | 98 |
| STATIC FUNCTION | grp_to_words(nGrp, sQual)
static function grp_to_words(nGrp, sQual)
local sResult := "", nTemp
nTemp := int(nGrp % 100)
nGrp := int(nGrp / 100)
sResult += ones[ nGrp + 1 ] + iif( nGrp > 0, " Hundred", "")
do case
case nTemp > 19
sResult += tens[ int( nTemp / 10 ) + 1 ]
sResult += ones[ int( nTemp % 10 ) + 1 ]
case nTemp < 20 .and. nTemp > 9
sResult += teens[ int( nTemp % 10 ) + 1 ]
case nTemp < 10 .and. nTemp > 0
sResult += ones[ int( nTemp) + 1 ]
endcase
return(sResult + sQual)
| ntow.prg | 115 |
| STATIC FUNCTION | sol10( nNumber )
static function sol10( nNumber )
local sTemp
sTemp := ltrim( str( int(nNumber), 0) )
return( len(sTemp) - 1 )
| ntow.prg | 134 |
| nwlstat.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN()
FUNCTION MAIN()
QOut( "Logical station: " + str( FT_NWLSTAT() ) )
return ( nil )
| nwlstat.prg | 66 |
| FUNCTION | FT_NWLSTAT()
FUNCTION FT_NWLSTAT()
/* LOCAL aRegs[ INT86_MAX_REGS ] */
LOCAL nStation
/*
aRegs[ AX ] = MAKEHI( STATNUM )
FT_INT86( DOS, aRegs )
*/
nStation := _ft_nwkstat() /* LOWBYTE( aRegs[ AX ] ) */
if nStation < 0
nStation += 256
endif
RETURN nStation
| nwlstat.prg | 71 |
| nwsem.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | main()
function main()
local nInitVal, nRc, nHandle, nValue, nOpenCnt
cls
nInitVal := INITIAL_SEMAPHORE_VALUE
FT_NWSEMOPEN( "TEST", nInitVal, @nHandle, @nOpenCnt )
qout( "Waiting ten seconds..." )
nRc := ft_nwSemWait( nHandle, 180 )
qout( "Final nRc value = " + STR( nRc ) )
inkey(0)
if nRc == 254
qout("Couldn't get the semaphore. Try again.")
quit
end
cls
@ 24, 0 say "Any key to exit"
@ 0, 0 say "Handle: " + str( nHandle )
ft_nwSemEx( nHandle, @nValue, @nOpenCnt )
while .t.
@ 23, 0 say "Semaphore test -> Open at [" + ;
alltrim(str(nOpenCnt)) + ;
"] stations, value is [" + ;
alltrim(str(nValue)) + "]"
if inkey( WAIT_SECONDS ) != 0
exit
endif
tone( nHandle,.5 )
ft_nwSemEx( nHandle, @nValue, @nOpenCnt )
end
qout( "Signal returns: " + str( ft_nwsemSig( nHandle ) ) )
qout( "Close returns: " + str( ft_nwsemClose( nHandle ) ) )
return nil
#endif
| nwsem.prg | 61 |
| FUNCTION | ft_nwSemOpen( cName, nInitVal, nHandle, nOpenCnt )
function ft_nwSemOpen( cName, nInitVal, nHandle, nOpenCnt )
local aRegs[ INT86_MAX_REGS ], cRequest, nRet
default cName to "", ;
nInitVal to 0, ;
nHandle to 0, ;
nOpenCnt to 0
cName := iif( len( cName ) > 127, substr( cName, 1, 127 ), cName )
cRequest := chr( len( cName ) ) + cName
aRegs[ AX ] := makehi( 197 ) // C5h
aRegs[ DS ] := cRequest
aRegs[ DX ] := REG_DS
aRegs[ CX ] := nInitVal
ft_int86( INT21, aRegs )
nHandle := bin2l( i2bin( aRegs[CX] ) + i2bin( aRegs[DX] ) )
nOpenCnt := lowbyte( aRegs[ BX ] )
nRet := lowbyte( aRegs[AX] )
return iif( nRet < 0, nRet + 256, nRet )
| nwsem.prg | 198 |
| FUNCTION | ft_nwSemEx( nHandle, nValue, nOpenCnt )
function ft_nwSemEx( nHandle, nValue, nOpenCnt )
local aRegs[ INT86_MAX_REGS ], nRet
default nHandle to 0, ;
nValue to 0, ;
nOpenCnt to 0
aRegs[ AX ] := makehi( 197 ) + 1 // C5h, 01h
aRegs[ CX ] := bin2i( substr( l2bin( nHandle ), 1, 2 ) )
aRegs[ DX ] := bin2i( substr( l2bin( nHandle ), 3, 2 ) )
ft_int86( INT21, aRegs )
#ifdef FT_TEST
@ 5, 1 say highbyte( aregs[CX] )
@ 6, 1 say lowbyte( aregs[CX ] )
#endif
nValue := aRegs[ CX ]
nOpenCnt := lowbyte( aRegs[ DX ] )
nRet := lowbyte( aRegs[ AX ] )
return iif( nRet < 0, nRet + 256, nRet )
| nwsem.prg | 281 |
| FUNCTION | ft_nwSemWait( nHandle, nTimeout )
function ft_nwSemWait( nHandle, nTimeout )
return _ftnwsem( WAIT_SEMAPHORE, nHandle, nTimeout )
| nwsem.prg | 348 |
| FUNCTION | ft_nwSemSig( nHandle )
function ft_nwSemSig( nHandle )
return _ftnwsem( SIGNAL_SEMAPHORE, nHandle )
| nwsem.prg | 385 |
| FUNCTION | ft_nwSemClose( nHandle )
function ft_nwSemClose( nHandle )
return _ftnwsem( CLOSE_SEMAPHORE, nHandle )
| nwsem.prg | 417 |
| STATIC FUNCTION | _ftnwsem( nOp, nHandle, nTimeout )
static function _ftnwsem( nOp, nHandle, nTimeout )
local aRegs[ INT86_MAX_REGS ],;
nRet
default nOp to SIGNAL_SEMAPHORE, ;
nHandle to 0, ;
nTimeout to 0
aRegs[ AX ] := makehi( 197 ) + nOp
aRegs[ CX ] := bin2i( substr( l2bin( nHandle ), 1, 2 ) )
aRegs[ DX ] := bin2i( substr( l2bin( nHandle ), 3, 2 ) )
aRegs[ BP ] := nTimeout
ft_int86( INT21, aRegs )
nRet := lowbyte( aRegs[AX] )
nRet := iif( nRet < 0, nRet + 256, nRet )
return nRet
| nwsem.prg | 425 |
| FUNCTION | ft_nwSemLock( cSemaphore, nHandle )
function ft_nwSemLock( cSemaphore, nHandle )
local nRc
local nOpenCnt := 0
nRc := FT_NWSEMOPEN( cSemaphore, 0, @nHandle, @nOpenCnt )
if nRc == 0
if nOpenCnt != 1
ft_nwSemClose( nHandle )
endif
endif
return ( nOpenCnt == 1 )
| nwsem.prg | 513 |
| FUNCTION | ft_nwSemUnLock( nHandle )
function ft_nwSemUnLock( nHandle )
return ( ft_nwSemClose( nHandle ) == 0 )
| nwsem.prg | 570 |
| nwuid.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN()
FUNCTION MAIN()
local x, cUid
QOut( "I am: [" + FT_NWUID() + "]" )
QOut( "---------------------" )
for x:= 1 to 100
cUid := FT_NWUID( x )
if .not. empty( cUid )
QOut( str( x, 3 ) + space(3) + cUid )
endif
next
return ( nil )
| nwuid.prg | 86 |
| FUNCTION | FT_NWUID( nConn )
FUNCTION FT_NWUID( nConn )
LOCAL aRegs[ INT86_MAX_REGS ], ;
cReqPkt, ;
cRepPkt
nConn := IIF( nConn == nil, FT_NWLSTAT(), nConn )
// Set up request packet
cReqPkt := chr( 22 ) // Function 22: Get Connection Information
cReqPkt += chr( nConn )
cReqPkt := i2bin( len( cReqPkt ) ) + cReqPkt
// Set up reply packet
cRepPkt := space(63)
// Assign registers
aRegs[ AX ] := MAKEHI( NW_LOG )
aRegs[ DS ] := cReqPkt
aRegs[ SI ] := REG_DS
aRegs[ ES ] := cRepPkt
aRegs[ DI ] := REG_ES
FT_INT86( DOS, aRegs )
RETURN alltrim( strtran( substr( aRegs[ ES ], 9, 48 ), chr(0) ) )
| nwuid.prg | 101 |
| page.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_SETVPG( nPage )
FUNCTION FT_SETVPG( nPage )
/*
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] = MAKEHI( 5 ) + nPage
FT_INT86( VIDEO, aRegs )
*/
_ft_setvpg(nPage)
RETURN( NIL )
| page.prg | 63 |
| FUNCTION | FT_GETVPG()
FUNCTION FT_GETVPG()
/*
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] := MAKEHI( 15 )
FT_INT86( VIDEO, aRegs )
RETURN ( HIGHBYTE( aRegs[ BX ] ) ) */
Return _ft_getvpg()
| page.prg | 105 |
| pchr.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_PCHR(c_nums)
Function FT_PCHR(c_nums)
Local c_ret:='', c_st:=0,c_part,c_st2,c_hex:="0123456789ABCDEF"
Local c_upper,c_t1,c_t2
If Substr(c_nums,1,1)=','.or.Trim(c_nums)==''
Return ""
Endif
c_nums := Trim(c_nums) + ",~,"
c_part := Substr(c_nums,c_st+1,At(",",Substr(c_nums,c_st+2)))
Do While .not.(c_part=="~".or.c_part=="")
If Substr(c_part,1,1)=Chr(34)
c_st2:=At(Chr(34),Substr(c_part,2))+1
c_ret:=c_ret+Substr(c_part,2,c_st2-2)
Elseif Substr(c_part,1,1)="&"
c_upper=Upper(c_part)
c_t1=At(Substr(c_upper,2,1),c_hex)-1
If c_t1>-1
c_t2=At(Substr(c_upper,3,1),c_hex)-1
If c_t2>-1
c_t1=c_t1*16+c_t2
Endif
c_ret=c_ret+Chr(c_t1)
Endif
ElseIf (Val(c_part)>0.and.Val(c_part)<256).or.c_part="0"
c_ret=c_ret+Chr(Val(c_part))
Else
If Substr(c_part,1,1)="/"
c_upper=Upper(c_part)
Do Case
Case c_upper = '/GRAPHIC'
c_ret = c_ret + Chr(27)+Chr(116)+Chr(1)
Case c_upper = '/ITALIC'
c_ret = c_ret + Chr(27)+Chr(116)+Chr(0)
Case c_upper = '/PICTURE'
c_ret = c_ret + Chr(27)+Chr(116)+Chr(1)+;
Chr(27)+Chr(120)+Chr(1)+Chr(27)+Chr(107)+Chr(1)+;
Chr(27)+Chr(77)+Chr(27)+'U'
Case c_upper = '/COND' .or. c_upper = '/SI'
c_ret = c_ret + Chr(15)
Case c_upper = '/ROMAN'
c_ret = c_ret + Chr(27)+Chr(107)+Chr(0)
Case c_upper = '/SANS'
c_ret = c_ret + Chr(27)+Chr(107)+Chr(1)
Case c_upper = '/NLQ'
c_ret = c_ret + Chr(27)+Chr(120)+Chr(1)
Case c_upper = '/DRAFT'
c_ret = c_ret + Chr(27)+Chr(120)+Chr(0)
Case c_upper = '/ELITE'
c_ret = c_ret + Chr(27)+Chr(77)
Case c_upper = '/PICA'
c_ret = c_ret + Chr(27)+Chr(80)
Case c_upper = '/EMPHOFF'
c_ret = c_ret + Chr(27)+Chr(70)
Case c_upper = '/EMPH'
c_ret = c_ret + Chr(27)+Chr(69)
Case c_upper = '/1/6'
c_ret = c_ret + Chr(27)+Chr(50)
Case c_upper = '/1/8'
c_ret = c_ret + Chr(27)+Chr(48)
Case c_upper = '/SKIPOFF'
c_ret = c_ret + Chr(27)+Chr(79)
Case c_upper = '/SKIP'
c_ret = c_ret + Chr(27)+Chr(78)
Case c_upper = '/FF'.or.c_upper='/EJECT'
c_ret = c_ret + Chr(12)
Case c_upper = '/INIT'.or.c_upper = '/RESET'
c_ret = c_ret + Chr(27)+Chr(64)
Case c_upper = '/SPANISH'
c_ret = c_ret + Chr(27)+Chr(82)+Chr(12)
Case c_upper = '/USA'
c_ret = c_ret + Chr(27)+Chr(82)+Chr(0)
Case c_upper = '/ONE'
c_ret = c_ret + Chr(27)+'U'+Chr(1)
Case c_upper = '/TWO'
c_ret = c_ret + Chr(27)+'U'+Chr(0)
Case c_upper = '/FAST'
c_ret = c_ret + Chr(27)+'s'+Chr(0)
Case c_upper = '/SLOW'
c_ret = c_ret + Chr(27)+'s'+Chr(1)
Case c_upper = '/OFF'
c_ret = c_ret + Chr(19)
Case c_upper = '/ON'
c_ret = c_ret + Chr(17)
Case c_upper = '/BEEP' .or. c_upper='/BELL'
c_ret = c_ret + Chr(7)
Case c_upper = '/CAN'
c_ret = c_ret + Chr(24)
Endcase
Endif
Endif
c_st = At(",",Substr(c_nums,c_st+1))+c_st
c_part = Substr(c_nums,c_st+1,At(",",Substr(c_nums,c_st+2)))
Enddo
Return c_ret
| pchr.prg | 118 |
| pegs.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_PEGS
function FT_PEGS
LOCAL XX, MOVE, MPOS, POSSIBLE_, BUFFER, TOPROW, OLDSCORE, MOVE2, ;
SCANBLOCK, OLDCOLOR := SETCOLOR('w/n'), ;
oldscrn := savescreen(0, 0, maxrow(), maxcol())
/*
the following code block is used in conjunction with ASCAN()
to validate entry when there is more than one possible move
*/
scanblock := { | a | a[2] == move2 }
cls
xx := 1
setcolor('w/r')
SINGLEBOX(22, 31, 24, 48)
@ 23, 33 say "Your move:"
aeval(board_, { | a, x | HB_SYMBOL_UNUSED( a ), drawbox( x ) } )
do while lastkey() != K_ESC .and. moremoves()
move := 1
setcolor('w/n')
@ 23, 44 get move picture '##' range 1, 33
read
if move > 0
do case
case ! board_[move][4]
err_msg("No piece there!")
otherwise
possible_ := {}
for xx := 1 to len(board_[move][2])
if board_[board_[move][2,xx] ][4] .and. ;
! board_[board_[move][3,xx] ][4]
aadd(possible_, { board_[move][2,xx], board_[move][3,xx] })
endif
next
// only one available move -- do it
do case
case len(possible_) = 1
// clear out original position and the position you jumped over
board_[move][4] := board_[possible_[1, 1] ][4] := .F.
board_[possible_[1, 2] ][4] := .T.
drawbox(move, board_[move])
drawbox(possible_[1,1])
drawbox(possible_[1,2])
case len(possible_) = 0
err_msg('Illegal move!')
otherwise
move2 := possible_[1, 2]
toprow := 21 - len(possible_)
setcolor('+w/b')
buffer := savescreen(toprow, 55, 22, 74)
DOUBLEBOX(toprow, 55, 22, 74)
@ toprow, 58 say 'Possible Moves'
devpos(toprow, 65)
aeval(possible_, { | a | devpos(row()+1, 65), ;
devoutpict(a[2], '##') } )
oldscore := set(_SET_SCOREBOARD, .f.)
@23, 44 get move2 picture '##' ;
valid ascan(possible_, scanblock) > 0
read
restscreen(toprow, 55, 22, 74, buffer)
set(_SET_SCOREBOARD, oldscore)
mpos := ascan(possible_, { | a | move2 == a[2] })
// clear out original position and the position you jumped over
board_[move][4] := board_[possible_[mpos, 1] ][4] := .F.
board_[move2][4] := .T.
drawbox(move)
drawbox(possible_[mpos,1])
drawbox(move2)
endcase
endcase
move := 1
endif
enddo
setcolor(oldcolor)
restscreen(0, 0, maxrow(), maxcol(), oldscrn)
return NIL
* end function FT_PEGS()
*--------------------------------------------------------------------*
| pegs.prg | 104 |
| STATIC FUNCTION | DrawBox(nelement)
static function DrawBox(nelement)
setcolor(if(board_[nelement][4], '+w/rb', 'w/n'))
@ board_[nelement][1,1], board_[nelement][1,2], board_[nelement][1,3], ;
board_[nelement][1,4] box "ÚÄ¿³ÙÄÀ³ "
DevPos(board_[nelement][1,1] + 1, board_[nelement][1,2] + 2)
DevOut(ltrim(str(nelement)))
return NIL
* end static function DrawBox()
*--------------------------------------------------------------------*
| pegs.prg | 184 |
| STATIC FUNCTION | err_msg(msg)
static function err_msg(msg)
local buffer := savescreen(23, 33, 23, 47)
setcursor(0)
setcolor('+w/r')
@ 23, 33 say msg
inkey(2)
setcursor(1)
restscreen(23, 33, 23, 47, buffer)
return nil
* end static function Err_Msg()
*--------------------------------------------------------------------*
| pegs.prg | 196 |
| STATIC FUNCTION | moremoves()
static function moremoves()
local xx, yy, canmove := .f., piecesleft := 0, buffer
for xx := 1 to 33
for yy := 1 to len(board_[xx][2])
if board_[xx][4] .and. ; // if current location is filled
board_[board_[xx][2,yy] ][4] .and. ; // adjacent must be filled
! board_[board_[xx][3,yy] ][4] // target must be empty
canmove := .t.
exit
endif
next
// increment number of pieces left
if board_[xx][4]
piecesleft++
endif
next
if ! canmove
setcolor('+w/b')
buffer := savescreen(18, 55, 21, 74)
DOUBLEBOX(18, 55, 21, 74)
@ 19, 58 say "No more moves!"
@ 20, 58 say ltrim(str(piecesleft)) + " pieces left"
inkey(0)
restscreen(18, 55, 21, 74, buffer)
endif
return canmove
* end static function MoreMoves()
*--------------------------------------------------------------------*
* eof pegs.prg
| pegs.prg | 210 |
| pending.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN()
FUNCTION MAIN()
@0,0 CLEAR
FT_PENDING("Message one",20,0,3,"W+/G") // Displays "Message one."
// sets row to 20, col to 0.
// wait to 3 and color to
// bright white over green.
FT_PENDING("Message two") // Displays "Message two", after 5 sec.
FT_PENDING("Message three") // Displays "Message three", after 5 sec.
return ( nil )
| pending.prg | 76 |
| FUNCTION | FT_PENDING (cMsg, nRow, nCol, nWait, cColor)
FUNCTION FT_PENDING (cMsg, nRow, nCol, nWait, cColor)
STATIC nLast_Time := 0, nRow1 := 24, nCol1 := 0
STATIC nWait1 := 5, cColor1 := 'W+/R,X'
LOCAL nThis_Time, nTiny := 0.1, cSavColor
*
* cMsg Message to display
* nRow Row of displayed message
* nCol Col of displayed message
* nWait Wait in seconds between messages
* cColor Color of displayed message
*
IF (cMsg == NIL ) //if no message, no work
RETURN NIL
ENDIF
nRow1 := IIF( nRow != NIL, nRow, nRow1 ) //reset display row
nCol1 := IIF( nCol != NIL, nCol, nCol1 ) //reset display col
nWait1 := IIF( nWait != NIL, nWait, nWait1) //reset display wait
cColor1 := IIF( cColor != NIL, cColor, cColor1) //reset display color
nThis_Time := SECONDS() //time of current message
IF nLast_Time == 0
nLast_Time := nThis_Time - nWait1 //for first time round.
ENDIF
IF (nThis_Time - nLast_Time) < nTiny //if messages are coming too fast,
nLast_Time := nThis_Time + nWait1 //set time counter and then
INKEY (nWait1) //wait a few seconds.
ELSE
nLast_Time := nThis_Time //set time counter for next message.
ENDIF
@nRow1,0 clear to nRow1,80 //clear the display line
cSavColor := SETCOLOR(cColor1) //save current and set display color
@nRow1,nCol1 SAY cMsg //display message
SETCOLOR( cSavColor ) //restore colors.
RETURN NIL
| pending.prg | 87 |
| pickday.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN
FUNCTION MAIN
QOUT("You selected " + FT_PICKDAY())
return nil
| pickday.prg | 52 |
| FUNCTION | FT_PICKDAY
function FT_PICKDAY
LOCAL DAYS := { "SUNDAY", "MONDAY", "TUESDAY", "WEDNESDAY", "THURSDAY", ;
"FRIDAY", "SATURDAY" }, SEL := 0
LOCAL OLDSCRN := SAVESCREEN(8, 35, 16, 45), oldcolor := setcolor('+w/r')
@ 8, 35, 16, 45 box B_SINGLE + " "
/* do not allow user to Esc out, which would cause array access error */
do while sel = 0
sel = achoice(9, 36, 15, 44, days)
enddo
/* restore previous screen contents and color */
restscreen(8, 35, 16, 45, oldscrn)
setcolor(oldcolor)
return days[sel]
| pickday.prg | 59 |
| popadder.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | TEST
FUNCTION TEST
LOCAL nSickHrs := 0, ;
nPersHrs := 0, ;
nVacaHrs := 0, ;
GetList := {}
SET SCOREBOARD OFF
_ftSetScrColor(STD_SCREEN,STD_VARIABLE)
CLEAR SCREEN
SET KEY K_ALT_A TO FT_Adder // Make call FT_Adder
* SIMPLE Sample of program data entry!
@ 12,5 SAY 'Please enter the total Sick, Personal, and Vacation hours.'
@ 15,22 SAY 'Sick hrs.'
@ 15,40 SAY 'Pers. hrs.'
@ 15,60 SAY 'Vaca. hrs.'
@ 23,20 SAY 'Press to Pop - Up the Adder.'
@ 24,20 SAY 'Press to Quit the adder Demo.'
DO WHILE .T. // Get the sick, personal, & vaca
@ 16,24 GET nSickHrs PICTURE '9999.999' // Normally I have a VALID()
@ 16,43 GET nPersHrs PICTURE '9999.999' // to make sure the value is
@ 16,63 GET nVacaHrs PICTURE '9999.999' // within the allowable range.
SET CURSOR ON // But, like I said it is a
CLEAR TYPEAHEAD // SIMPLE example .
READ
SET CURSOR OFF
IF LASTKEY() == K_ESC // - ABORT
CLEAR TYPEAHEAD
EXIT
ENDIF
ENDDO
SET CURSOR ON
SET KEY K_ALT_A // Reset
RETURN NIL
#endif
| popadder.prg | 210 |
| FUNCTION | FT_Adder()
FUNCTION FT_Adder()
LOCAL nOldDecim, cMoveTotSubTot, cTotal, lDone, nKey, ;
oGet := GetActive(), ;
nOldCurs := SETCURSOR(SC_NONE), ;
nOldRow := ROW(), ;
nOldCol := COL(), ;
bOldF10 := SETKEY(K_F10, NIL), ;
nOldLastKey := LASTKEY(), ;
lShowRight := .T., ;
aAdder := ARRAY(23)
// Must prevent recursive calls
IF lAdderOpen
RETURN NIL
ELSE
lAdderOpen := .T.
ENDIF
aTrans := {' 0.00 C '}
nOldDecim := SET(_SET_DECIMALS,9)
cTotPict := '999999999999999.99'
cTapeScr := ''
nTotal := nNumTotal := nSavTotal := nDecDigit := 0
lDone := .F. // Loop flag
nKey := 0
nMaxDeci := 2 // Initial # of decimals
nSavSubTot := 0
lNewNum := .F.
nAddMode := 1 // Start in ADD mode
lMultDiv := .F. // Start in ADD mode
lClAdder := .F. // Clear adder flag
lDecSet := .F. // Decimal ? - keyboard routine
lSubRtn := lTotalOk := lTape := lAddError := lDivError := .F.
nTopOS := INT((MAXROW()-24)/2) // Using the TopOffSet & LeftOffSet
nLeftOS := INT((MAXCOL()-79)/2) // the Adder will always be centered
nAddSpace := IF(lShowRight,40,0)+nLeftOS
nTapeSpace := IF(lShowRight,0,40)+nLeftOS
// Set Up the STATIC variables
aKeys := {}
aWindow := {}
nWinColor := 0
_ftAddScreen(aAdder)
// Set the decimals to 2 & display a cleared adder
_ftChangeDec(aAdder, 2)
@ 4+nTopOS, 7+nAddSpace SAY nTotal PICTURE cTotPict
DO WHILE ! lDone // Input key & test loop
FT_INKEY 0 TO nKey
DO CASE
CASE UPPER(CHR(nKey)) $'1234567890.'
_ftProcessNumb(aAdder, nKey)
CASE nKey == K_PLUS // <+> sign
_ftAddSub(aAdder, nKey)
CASE nKey == K_MINUS // <-> sign
_ftAddSub(aAdder, nKey)
CASE nKey == K_MULTIPLY // <*> sign
_ftMultDiv(aAdder, nKey)
CASE nKey == K_DIVIDE // sign
_ftMultDiv(aAdder, nKey)
CASE nKey == K_RETURN // Total or Subtotal
_ftAddTotal(aAdder)
CASE nKey == K_ESC // Quit
SET(_SET_DECIMALS,nOldDecim)
SETCURSOR(nOldCurs)
IF lTape
RESTSCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,35+nTapeSpace,cTapeScr)
ENDIF
_ftPopWin()
SETPOS(nOldRow,nOldCol)
_ftSetLastKey(nOldLastKey)
SETKEY(K_F10, bOldF10)
lAdderOpen := .F. // Reset the recursive flag
lDone := .T.
CASE nKey == 68 .OR. nKey == 100 // Change number of decimal places
_ftChangeDec(aAdder)
CASE nKey == 84 .OR. nKey == 116 // Display Tape
_ftDisplayTape(aAdder, nKey)
CASE nKey == 77 .OR. nKey == 109 // Move Adder
IF lTape
RESTSCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,35+nTapeSpace,cTapeScr)
ENDIF
IF LEFT(SAVESCREEN(6+nTopOS,26+nAddSpace,6+nTopOS,27+nAddSpace),1) ;
!= ' '
IF LEFT(SAVESCREEN(6+nTopOS,19+nAddSpace,6+nTopOS,20+nAddSpace),1) ;
== 'S'
cMoveTotSubTot := 'S'
ELSE
cMoveTotSubTot := 'T'
ENDIF
ELSE
cMoveTotSubTot := ' '
ENDIF
cTotal := _ftCharOdd(SAVESCREEN( 4 + nTopOS, 8 + nAddSpace, 4 + ;
nTopOS,25+nAddSpace))
_ftPopWin() // Remove Adder
lShowRight := !lShowRight
nAddSpace := IF(lShowRight,40,0)+nLeftOS
nTapeSpace := IF(lShowRight,0,40)+nLeftOS
_ftAddScreen(aAdder)
_ftDispTotal(aAdder)
IF lTape
lTape := .F.
_ftDisplayTape(aAdder, nKey)
ENDIF
@ 4+nTopOS, 8+nAddSpace SAY cTotal
IF !EMPTY(cMoveTotSubTot)
_ftSetWinColor(W_CURR,W_SCREEN)
@ 6+nTopOS,18+nAddSpace SAY IF(cMoveTotSubTot=='T', ' ', ;
'')
_ftSetWinColor(W_CURR,W_PROMPT)
ENDIF
CASE (nKey == 83 .OR. nKey == 115) .AND. lTape // Scroll tape display
IF nTotTran>16 // We need to scroll
SETCOLOR('GR+/W')
@ 21+nTopOS,8+nTapeSpace SAY ' '+CHR(24)+CHR(25)+'-SCROLL -QUIT '
SETCOLOR('N/W,W+/N')
ACHOICE(5+nTopOS,7+nTapeSpace,20+nTopOS,32+nTapeSpace,aTrans,.T., ;
'_ftAdderTapeUDF',nTotTran,20)
SETCOLOR('R+/W')
@ 21+nTopOS,8+nTapeSpace TO 21+nTopOS,30+nTapeSpace
_ftSetWinColor(W_CURR,W_PROMPT)
CLEAR TYPEAHEAD
ELSE
_ftError('there are ' + IF(nTotTran > 0, 'only ' + ;
LTRIM(STR(nTotTran, 3, 0)), 'no') + ;
' transactions entered so far.' + ;
' No need to scroll!')
ENDIF
CASE nKey == 7 // Delete - Clear adder
_ftClearAdder(aAdder)
CASE nKey == K_F1 // Help
_ftAddHelp()
CASE nKey == K_F10 // Quit - Return total
IF lTotalOk // Did they finish the calculation
IF oGet != NIL .AND. oGet:TYPE == 'N'
SET(_SET_DECIMALS,nOldDecim)
SETCURSOR(nOldCurs)
IF lTape
RESTSCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,35+nTapeSpace,cTapeScr)
ENDIF
_ftPopWin()
SETPOS(nOldRow,nOldCol)
_ftSetLastKey(nOldLastKey)
SETKEY(K_F10, bOldF10)
oGet:VARPUT(nSavTotal)
lAdderOpen := .F. // Reset the recursive flag
lDone := .T.
ELSE
_ftError('but I can not return the total from the '+ ;
'adder to this variable. You must quit the adder using'+ ;
' the key and then enter the total manually.')
ENDIF
ELSE
_ftError('the calculation is not finished yet! You must have'+ ;
' a TOTAL before you can return it to the program.')
ENDIF
ENDCASE
ENDDO (WHILE .T. Data entry from keyboard)
// Reset the STATICS to NIL
aKeys := aWindow := aWinColor := aStdColor := NIL
RETURN NIL
| popadder.prg | 269 |
| STATIC FUNCTION | _ftAddScreen(aAdder)
STATIC FUNCTION _ftAddScreen(aAdder)
LOCAL nCol
_ftPushWin(2+nTopOS,2+nAddSpace,22+nTopOS,30+nAddSpace,' Adder ', ;
' for Help',,B_DOUBLE)
nCol := 5+nAddSpace
@ 7+nTopOS, nCol SAY ' ÚÄÄÄ¿ ÚÄÄÄ¿ ÚÄÄÄ¿'
@ 8+nTopOS, nCol SAY ' ³ ³ ³ ³ ³ ³'
@ 9+nTopOS, nCol SAY ' ÀÄÄÄÙ ÀÄÄÄÙ ÀÄÄÄÙ'
@ 10+nTopOS, nCol SAY 'ÚÄÄÄ¿ ÚÄÄÄ¿ ÚÄÄÄ¿ ÚÄÄÄ¿'
@ 11+nTopOS, nCol SAY '³ ³ ³ ³ ³ ³ ³ ³'
@ 12+nTopOS, nCol SAY 'ÀÄÄÄÙ ÀÄÄÄÙ ÀÄÄÄÙ ³ ³'
@ 13+nTopOS, nCol SAY 'ÚÄÄÄ¿ ÚÄÄÄ¿ ÚÄÄÄ¿ ³ ³'
@ 14+nTopOS, nCol SAY '³ ³ ³ ³ ³ ³ ³ ³'
@ 15+nTopOS, nCol SAY 'ÀÄÄÄÙ ÀÄÄÄÙ ÀÄÄÄÙ ÀÄÄÄÙ'
@ 16+nTopOS, nCol SAY 'ÚÄÄÄ¿ ÚÄÄÄ¿ ÚÄÄÄ¿ ÚÄÄÄ¿'
@ 17+nTopOS, nCol SAY '³ ³ ³ ³ ³ ³ ³ ³'
@ 18+nTopOS, nCol SAY 'ÀÄÄÄÙ ÀÄÄÄÙ ÀÄÄÄÙ ³ ³'
@ 19+nTopOS, nCol SAY 'ÚÄÄÄÄÄÄÄÄÄ¿ ÚÄÄÄ¿ ³ ³'
@ 20+nTopOS, nCol SAY '³ ³ ³ ³ ³ ³'
@ 21+nTopOS, nCol SAY 'ÀÄÄÄÄÄÄÄÄÄÙ ÀÄÄÄÙ ÀÄÄÄÙ'
_ftSetWinColor(W_CURR,W_TITLE)
nCol := 7+nAddSpace
@ 11+nTopOS, nCol SAY '7'
@ 14+nTopOS, nCol SAY '4'
@ 17+nTopOS, nCol SAY '1'
nCol := 13+nAddSpace
@ 8+nTopOS,nCol SAY '/'
@ 11+nTopOS,nCol SAY '8'
@ 14+nTopOS,nCol SAY '5'
@ 17+nTopOS,nCol SAY '2'
nCol := 19+nAddSpace
@ 8+nTopOS,nCol SAY 'X'
@ 11+nTopOS,nCol SAY '9'
@ 14+nTopOS,nCol SAY '6'
@ 17+nTopOS,nCol SAY '3'
@ 20+nTopOS,nCol SAY '.'
@ 20+nTopOS,10+nAddSpace SAY '0'
nCol := 25+nAddSpace
@ 8+nTopOS,nCol SAY '-'
@ 13+nTopOS,nCol SAY '+'
@ 18+nTopOS,nCol SAY '='
@ 19+nTopOS,nCol SAY ''
_ftSetWinColor(W_CURR,W_PROMPT)
@ 3+nTopOS, 6+nAddSpace, 5+nTopOS, 27+nAddSpace BOX B_DOUBLE
RETURN NIL
| popadder.prg | 452 |
| STATIC FUNCTION | _ftChangeDec(aAdder, nNumDec)
STATIC FUNCTION _ftChangeDec(aAdder, nNumDec)
LOCAL cDefTotPict := '9999999999999999999'
IF nNumDec == NIL
nNumDec := 0
nNumDec := _ftQuest('How many decimals do you want to display?', ;
nNumDec, '9', {|oGet| _ftValDeci(oGet)})
cTotPict := _ftPosRepl(cDefTotPict, '.', 19 - ABS(nNumDec))
cTotPict := RIGHT(_ftStuffComma(cTotPict), 19 )
cTotPict := IIF(nNumDec==2 .OR. nNumDec==6, ' '+RIGHT(cTotPict,18),cTotPict)
nMaxDeci := nNumDec
IF lSubRtn
_ftDispTotal(aAdder)
ELSE
_ftDispSubTot(aAdder)
ENDIF
ENDIF
RETURN NIL
| popadder.prg | 513 |
| STATIC FUNCTION | _ftDispTotal(aAdder)
STATIC FUNCTION _ftDispTotal(aAdder)
LOCAL cTotStr
IF nTotal>VAL(_ftCharRem(',',cTotPict))
cTotStr := _ftStuffComma(LTRIM(STR(nTotal)))
@ 4+nTopOS, 8+nAddSpace SAY '**** ERROR **** '
_ftError('that number is to big to display! I believe the answer was ' + ;
cTotStr+'.')
lAddError := .T.
_ftUpdateTrans(aAdder, .T., NIL)
_ftClearAdder(aAdder)
nTotal := 0
nNumTotal := 0
lAddError := .F.
ELSE
@ 4+nTopOS, 7+nAddSpace SAY nTotal PICTURE cTotPict
ENDIF
RETURN NIL
| popadder.prg | 554 |
| STATIC FUNCTION | _ftDispSubTot(aAdder)
STATIC FUNCTION _ftDispSubTot(aAdder)
LOCAL cStotStr
IF nNumTotal>VAL(_ftCharRem(',',cTotPict))
cStotStr := _ftStuffComma(LTRIM(STR(nNumTotal)))
@ 4+nTopOS, 8+nAddSpace SAY '**** ERROR **** '
_ftError('that number is to big to display! I believe the answer was ' + ;
cStotStr+'.')
lAddError := .T.
_ftUpdateTrans(aAdder, .T.,nNumTotal)
_ftClearAdder(aAdder)
nTotal := 0
nNumTotal := 0
lAddError := .F.
ELSE
@ 4+nTopOS, 7+nAddSpace SAY nNumTotal PICTURE cTotPict
ENDIF
RETURN NIL
| popadder.prg | 590 |
| STATIC FUNCTION | _ftProcessNumb(aAdder, nKey)
STATIC FUNCTION _ftProcessNumb(aAdder, nKey)
LOCAL nNum
_ftEraseTotSubTot(aAdder)
lTotalOk := .F.
lClAdder := .F. // Reset the Clear flag
lAddError := .F. // Reset adder error flag
IF nKey=46 // Period (.) decimal point
IF lDecSet // Has decimal already been set
TONE(800, 1)
ELSE
lDecSet := .T.
ENDIF
ELSE // It must be a number input
lNewNum := .T.
nNum := nKey-48
IF lDecSet // Decimal set
IF nDecDigit| popadder.prg | 625 | |
| STATIC FUNCTION | _ftAddTotal(aAdder)
STATIC FUNCTION _ftAddTotal(aAdder)
_ftEraseTotSubTot(aAdder)
lDecSet := .F.
nDecDigit := 0
lClAdder := .F. // Reset the Clear flag
IF lSubRtn // If this was the second time they
IF !lMultDiv
_ftSetWinColor(W_CURR,W_SCREEN)
@ 6+nTopOS, 18+nAddSpace SAY ' '
_ftSetWinColor(W_CURR,W_PROMPT)
_ftUpdateTrans(aAdder, .T., NIL)
_ftDispTotal(aAdder)
lSubRtn := .F. // pressed the total key reset everyting
nSavTotal := nTotal
nTotal := 0
lTotalOk := .T.
ENDIF
ELSE // This was the first time they pressed
IF !lMultDiv .AND. LASTKEY() == K_RETURN // total key
lSubRtn := .T.
ENDIF
IF _ftRoundIt(nTotal,nMaxDeci)!=0 .OR. _ftRoundIt(nNumTotal,nMaxDeci)!=0
IF !lMultDiv
_ftSetWinColor(W_CURR,W_SCREEN)
@ 6+nTopOS, 18+nAddSpace SAY ''
_ftSetWinColor(W_CURR,W_PROMPT)
ENDIF
IF _ftRoundIt(nNumTotal,nMaxDeci)!=0
lSubRtn := .F.
_ftUpdateTrans(aAdder, .F.,nNumTotal)
ENDIF
IF !lMultDiv
lSubRtn := .T. // total key
ENDIF
IF nAddMode == 1 // Add
nTotal := nTotal+nNumTotal
ELSEIF nAddMode == 2 // Subtract
nTotal := nTotal-nNumTotal
ELSEIF nAddMode == 3 // Multiply
nTotal := nTotal*nNumTotal
ELSEIF nAddMode == 4 // Divide
nTotal := _ftDivide(aAdder, nTotal,nNumTotal)
IF lDivError
_ftError("you can't divide by ZERO!")
lDivError := .F.
ENDIF
ENDIF
ENDIF
_ftDispTotal(aAdder)
IF lMultDiv // This was a multiply or divide
_ftSetWinColor(W_CURR,W_SCREEN)
@ 6+nTopOS, 18+nAddSpace SAY ' '
_ftSetWinColor(W_CURR,W_PROMPT)
lSubRtn := .F. // pressed total so key reset everything
IF !lTotalOk // If you haven't printed total DO-IT
lTotalOk := .T.
_ftUpdateTrans(aAdder, .F., NIL)
ENDIF
nNumTotal := 0
nSavTotal := nTotal
nTotal := 0
ELSE
IF !lTotalOk // If you haven't printed total DO-IT
_ftUpdateTrans(aAdder, .F., NIL)
nNumTotal := 0
ENDIF
ENDIF
ENDIF
RETURN NIL
| popadder.prg | 671 |
| STATIC FUNCTION | _ftAddSub(aAdder, nKey)
STATIC FUNCTION _ftAddSub(aAdder, nKey)
lMultDiv := .F.
_ftEraseTotSubTot(aAdder)
lTotalOk := .F.
lDecSet := .F.
nDecDigit := 0
lSubRtn := .F.
// They pressed the + or - key to process the previous total
IF _ftRoundIt(nNumTotal,nMaxDeci)==0 .AND. _ftRoundIt(nTotal,nMaxDeci)==0
nNumTotal := nSavTotal
lNewNum := .T.
ENDIF
IF nKey == K_PLUS // Add
nAddMode := 1
IF !lNewNum // They pressed + again to add the same
nNumTotal := nSavSubTot // number without re-entering
ENDIF
_ftUpdateTrans(aAdder, .F.,nNumTotal)
nTotal := nTotal+nNumTotal
lNewNum := .F.
nSavSubTot := nNumTotal // Save this number in case they just press + or -
nNumTotal := 0
ELSEIF nKey == K_MINUS // Subtract
nAddMode := 2
IF !lNewNum // They pressed + again to add the same
nNumTotal := nSavSubTot // number without re-entering
lNewNum := .T.
ENDIF
_ftUpdateTrans(aAdder, .F.,nNumTotal)
nTotal := nTotal-nNumTotal
lNewNum := .F.
nSavSubTot := nNumTotal // Save this number in case they just press + or -
nNumTotal := 0
ENDIF
_ftDispTotal(aAdder)
RETURN NIL
| popadder.prg | 758 |
| STATIC FUNCTION | _ftMultDiv(aAdder, nKey)
STATIC FUNCTION _ftMultDiv(aAdder, nKey)
lMultDiv := .T.
_ftEraseTotSubTot(aAdder)
lTotalOk := .F.
lDecSet := .F.
nDecDigit := 0
lSubRtn := .F.
// They pressed the + or - key to process the previous total
IF _ftRoundIt(nNumTotal,nMaxDeci)==0 .AND. _ftRoundIt(nTotal,nMaxDeci)==0
nNumTotal := nSavTotal
ENDIF
// Get the first number of the product or division
IF _ftRoundIt(nTotal,nMaxDeci)==0
IF nKey == K_MULTIPLY // Setup mode
nAddMode := 3
_ftUpdateTrans(aAdder, .F.,nNumTotal)
ELSEIF nKey == K_DIVIDE
nAddMode := 4
_ftUpdateTrans(aAdder, .F.,nNumTotal)
ENDIF
nTotal := nNumTotal
nNumTotal := 0
ELSE
IF nKey == K_MULTIPLY // Multiply
nAddMode := 3
_ftUpdateTrans(aAdder, .F.,nNumTotal)
nTotal := nTotal*nNumTotal
nNumTotal := 0
ELSEIF nKey == K_MULTIPLY // Divide
nAddMode := 4
_ftUpdateTrans(aAdder, .F.,nNumTotal)
nTotal:=_ftDivide(aAdder, nTotal,nNumTotal)
IF lDivError
_ftError("you can't divide by ZERO!")
lDivError := .F.
ENDIF
nNumTotal := 0
ENDIF
ENDIF
_ftDispTotal(aAdder)
RETURN NIL
| popadder.prg | 815 |
| STATIC FUNCTION | _ftAddHelp
STATIC FUNCTION _ftAddHelp
LOCAL cMess := 'This Adder works like a desk top calculator. You may add,'+;
' subtract, multiply, or divide. ' + CRLF + CRLF +;
'When adding or subtracting, the first entry is entered ' +;
'into the accumulator and each sucessive entry is ' +;
'subtotaled. When you press the SubTotal is also ' +;
'shown on the tape. The second time you press the '+;
'adder is Totaled. When multiplying or dividing the ' +;
' is a Total the first time pressed.' + CRLF + CRLF +;
'Hot Keys:' +CRLF+;
' ecimals Ä change # of decimals' +CRLF+;
' ove Ä the Adder from right to left' +CRLF+;
' ape Ä turn Tape Display On or Off' +CRLF+;
' croll Ä the tape display' + CRLF +CRLF+;
' ÄÄÄÂÄÄ 1st Clear entry' +CRLF+;
' ÀÄÄ 2nd Clear ADDER' +CRLF+;
' Ä Quit' +CRLF+;
' Ä return a to the active get'
_ftPushMessage(cMess, .T., 'ADDER HELP', 'press any key to continue...', ;
'QUIET')
RETURN NIL
| popadder.prg | 875 |
| STATIC FUNCTION | _ftClearAdder(aAdder)
STATIC FUNCTION _ftClearAdder(aAdder)
_ftEraseTotSubTot(aAdder)
lDecSet := .F.
nDecDigit := 0
IF lClAdder // If it has alredy been pressed once
nTotal := 0 // then we are clearing the total
nSavTotal := 0
_ftUpdateTrans(aAdder, .F., NIL)
lClAdder := .F.
_ftDispTotal(aAdder)
ELSE
nNumTotal := 0 // Just clearing the last entry
lClAdder := .T.
_ftDispSubTot(aAdder)
ENDIF
RETURN NIL
| popadder.prg | 916 |
| STATIC FUNCTION | _ftUpdateTrans(aAdder, lTypeTotal, nAmount)
STATIC FUNCTION _ftUpdateTrans(aAdder, lTypeTotal, nAmount)
LOCAL lUseTotal := (nAmount == NIL)
nAmount := IF(nAmount==NIL,0,nAmount)
IF lClAdder // Clear the adder (they pressed twice
AADD(aTrans,STR(0,22,nMaxDeci)+' C')
IF lTape // If there is a tape Show Clear
_ftDisplayTape(aAdder)
ENDIF
RETU NIL
ENDIF
IF lTypeTotal // If lTypeTotal=.T. Update from total
AADD(aTrans,STR(IF(lUseTotal,nTotal,nAmount),22,nMaxDeci) )
aTrans[nTotTran] := _ftStuffComma(aTrans[nTotTran], .T.) + ' *'+ ;
IF(lAddError,'ER','')
ELSE // If lTypeTotal=.F. Update from nNumTotal
AADD(aTrans,STR(IF(lUseTotal,nTotal,nAmount),22,nMaxDeci))
aTrans[nTotTran] := _ftStuffComma(aTrans[nTotTran], .T.) + ;
IF(lSubRtn,' S',IF(nAddMode==1,' +',IF(nAddMode==2,' -',IF ;
(lTotalOk,' =',IF(nAddMode==3,' X',' /'))))) + IF(lAddError,'ER','')
ENDIF
IF lTape
_ftDisplayTape(aAdder)
ENDIF
RETURN NIL
| popadder.prg | 951 |
| STATIC FUNCTION | _ftEraseTotSubTot(aAdder)
STATIC FUNCTION _ftEraseTotSubTot(aAdder)
_ftSetWinColor(W_CURR,W_SCREEN)
@ 6+nTopOS, 18+nAddSpace SAY ' '
_ftSetWinColor(W_CURR,W_PROMPT)
RETURN NIL
| popadder.prg | 999 |
| STATIC FUNCTION | _ftRoundIt(nNumber, nPlaces)
STATIC FUNCTION _ftRoundIt(nNumber, nPlaces)
nPlaces := IF( nPlaces == NIL, 0, nPlaces )
RETURN IF(nNumber < 0.0, -1.0, 1.0) * ;
INT( ABS(nNumber) * 10 ^ nPlaces + 0.50 + 10 ^ -12 ) / 10 ^ nPlaces
| popadder.prg | 1021 |
| STATIC FUNCTION | _ftDivide(aAdder, nNumerator,nDenominator)
STATIC FUNCTION _ftDivide(aAdder, nNumerator,nDenominator)
IF nDenominator==0.0
lDivError := .T.
RETU 0
ELSE
lDivError := .F.
ENDIF
RETURN(nNumerator/nDenominator)
| popadder.prg | 1043 |
| STATIC FUNCTION | _ftValDeci(oGet)
STATIC FUNCTION _ftValDeci(oGet)
LOCAL lRtnValue := .T.
IF oGet:VarGet() > 8
_ftError('no more than 8 decimal places please!')
lRtnValue := .F.
ENDIF
RETURN lRtnValue
| popadder.prg | 1066 |
| STATIC FUNCTION | _ftDisplayTape(aAdder, nKey)
STATIC FUNCTION _ftDisplayTape(aAdder, nKey)
LOCAL nDispTape, nTopTape := 1
IF (nKey == 84 .OR. nKey == 116) .AND. lTape // Stop displaying tape
lTape := .F.
RESTSCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,35+nTapeSpace,cTapeScr)
RETU NIL
ENDIF
IF lTape // Are we in the display mode
SETCOLOR('N/W')
SCROLL(5+nTopOS,7+nTapeSpace,20+nTopOS,32+nTapeSpace,1)
IF nTotTran>0 // Any transactions been entered yet?
@ 20+nTopOS,7+nTapeSpace SAY aTrans[nTotTran]
ENDIF
_ftSetWinColor(W_CURR,W_PROMPT)
ELSE // Start displaying tape
lTape := .T.
SETCOLOR('N/W')
cTapeScr := SAVESCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,35+nTapeSpace)
_ftShadow(22+nTopOS,8+nTapeSpace,22+nTopOS,35+nTapeSpace)
_ftShadow(5+nTopOS,33+nTapeSpace,21+nTopOS,35+nTapeSpace)
SETCOLOR('R+/W')
@ 4+nTopOS,6+nTapeSpace,21+nTopOS,33+nTapeSpace BOX B_SINGLE
SETCOLOR('GR+/W')
@ 4+nTopOS,17+nTapeSpace SAY ' TAPE '
SETCOLOR('N/W')
IF nTotTran>15
nTopTape := nTotTran-15
ENDIF
FOR nDispTape=nTotTran TO nTopTape STEP -1
@ 20+nDispTape-nTotTran+nTopOS,7+nTapeSpace SAY aTrans[nDispTape]
NEXT
ENDIF
_ftSetWinColor(W_CURR,W_PROMPT)
RETURN NIL
| popadder.prg | 1092 |
| STATIC FUNCTION | _ftSetLastKey(nLastKey)
STATIC FUNCTION _ftSetLastKey(nLastKey)
_ftPushKeys()
KEYBOARD CHR(nLastKey)
INKEY()
_ftPopKeys()
RETURN NIL
| popadder.prg | 1144 |
| STATIC FUNCTION | _ftPushKeys
STATIC FUNCTION _ftPushKeys
DO WHILE NEXTKEY() != 0
AADD(aKeys,INKEY())
ENDDO
RETURN NIL
| popadder.prg | 1168 |
| STATIC FUNCTION | _ftPopKeys
STATIC FUNCTION _ftPopKeys
LOCAL cKeys := ''
IF LEN(aKeys) != 0
AEVAL(aKeys, {|elem| cKeys += CHR(elem)})
ENDIF
KEYBOARD cKeys
aKeys := {}
RETURN NIL
| popadder.prg | 1191 |
| STATIC FUNCTION | _ftPushMessage(cMessage,lWait,cTitle,cBotTitle,xQuiet, nTop)
STATIC FUNCTION _ftPushMessage(cMessage,lWait,cTitle,cBotTitle,xQuiet, nTop)
LOCAL nMessLen, nNumRows, nWide, nLeft, nBottom, nRight, nKey, cOldDevic, ;
lOldPrint, ;
cOldColor := SETCOLOR(), ;
nOldLastkey := LASTKEY(), ;
nOldRow := ROW(), ;
nOldCol := COL(), ;
nOldCurs := SETCURSOR(SC_NONE), ;
nWinColor := IF(nWinColor == NIL, W_CURR, nWinColor)
cOldDevic := SET(_SET_DEVICE, 'SCREEN')
lOldPrint := SET(_SET_PRINTER, .F.)
nMessLen := LEN(cMessage)
nWide := IF(nMessLen>72,72,IF(nMessLen<12,12,nMessLen))
nNumRows := MLCOUNT(cMessage,nWide)
// If they didn't say what the top row is, Center it on the screen
DEFAULT nTop TO INT((MAXROW()-nNumRows)/2)
nBottom := nTop+nNumRows+2
nLeft := INT((MAXCOL()-nWide)/2)-3
nRight := nLeft+nWide+4
lWait := IF(lWait == NIL, .F., lWait)
_ftPushWin(nTop,nLeft,nBottom,nRight,cTitle,cBotTitle,nWinColor)
DISPMESSAGE cMessage,nTop+1,nLeft+2,nBottom-1,nRight-2
IF xQuiet == NIL
TONE(800, 1)
ENDIF
IF lWait
FT_INKEY 0 TO nKey
_ftPopMessage()
ENDIF
SETCURSOR(nOldCurs)
SETCOLOR(cOldColor)
SETPOS(nOldRow,nOldCol)
SET(_SET_DEVICE, cOldDevic)
SET(_SET_PRINTER, lOldPrint)
_ftSetLastKey(nOldLastKey)
RETURN NIL
| popadder.prg | 1219 |
| STATIC FUNCTION | _ftPopMessage
STATIC FUNCTION _ftPopMessage
_ftPopWin()
RETURN NIL
| popadder.prg | 1277 |
| STATIC FUNCTION | _ftQuest(cMessage,xVarVal,cPict,bValid,lNoESC,nWinColor,nTop)
STATIC FUNCTION _ftQuest(cMessage,xVarVal,cPict,bValid,lNoESC,nWinColor,nTop)
LOCAL nOldRow, nOldCol, cOldColor, nMessLen, nWide, nNumRows, nBottom, nLeft
LOCAL nRight, oNewGet, nNumMessRow, nLenLastRow, lGetOnNextLine, nOldCurs
LOCAL cVarType := VALTYPE(xVarVal)
LOCAL nVarLen := IF(cVarType='C',LEN(xVarVal),IF(cVarType='D',8, ;
IF(cVarType='L',1,IF(cVarType='N',IF(cPict=NIL,9, ;
LEN(cPict)),0))))
LOCAL nOldLastKey := LASTKEY()
LOCAL GETLIST := {}, ;
cOldDevice := SET(_SET_DEVICE, 'SCREEN'), ;
lOldPrint := SET(_SET_PRINTER, .F.)
nOldRow := ROW()
nOldCol := COL()
nOldCurs := SETCURSOR(SC_NONE)
cOldColor := SETCOLOR()
lNoESC := IF(lNoESC==NIL,.F.,lNoESC)
nMessLen := LEN(cMessage)+nVarLen+1
nWide := IF(nMessLen>66,66,IF(nMessLen<12,12,nMessLen))
nNumMessRow := MLCOUNT(cMessage,nWide)
nLenLastRow := LEN(TRIM(MEMOLINE(cMessage,nWide,nNumMessRow)))
lGetOnNextLine := (nLenLastRow + nVarLen) > nWide
nNumRows := nNumMessRow + IF(lGetOnNextLine,1,0)
// Center it in the screen
nTop := IF(nTop=NIL,INT((MAXROW() - nNumRows)/2),nTop)
nBottom := nTop+nNumRows+1
nLeft := INT((MAXCOL()-nWide)/2)-4
nRight := nLeft+nWide+4
_ftPushWin(nTop,nLeft,nBottom,nRight,'QUESTION ?',IF(VALTYPE(xVarVal)='C' ;
.AND. nVarLen>nWide,CHR(27)+' scroll '+ CHR(26),NIL),nWinColor)
DISPMESSAGE cMessage,nTop+1,nLeft+2,nBottom-1,nRight-2
oNewGet := GetNew( IF(lGetOnNextLine,Row()+1,Row()), ;
IF(lGetOnNextLine,nLeft+2,Col()+1), ;
{|x| IF(PCOUNT() > 0, xVarVal := x, xVarVal)}, ;
'xVarVal' )
// If the input line is character & wider than window SCROLL
IF lGetOnNextLine .AND. VALTYPE(xVarVal)='C' .AND. nVarLen>nWide
oNewGet:Picture := '@S'+LTRIM(STR(nWide,4,0))+IF(cPict=NIL,'',' '+cPict)
ENDIF
IF cPict != NIL // Use the picture they passed
oNewGet:Picture := cPict
ELSE // Else setup default pictures
IF VALTYPE(xVarVal)='D'
oNewGet:Picture := '99/99/99'
ELSEIF VALTYPE(xVarVal)='L'
oNewGet:Picture := 'Y'
ELSEIF VALTYPE(xVarVal)='N'
oNewGet:Picture := '999999.99' // Guess that they are inputting dollars
ENDIF
ENDIF
oNewGet:PostBlock := IF(bValid=NIL,NIL,bValid)
oNewGet:Display()
SETCURSOR(SC_NORMAL)
DO WHILE .T. // Loop so we can check for
// without reissuing the gets
ReadModal({oNewGet})
IF LASTKEY() == K_ESC .AND. lNoESC // They pressed
_ftError('you cannot Abort! Please enter an answer.')
ELSE
EXIT
ENDIF
ENDDO
_ftPopWin()
SETCURSOR(nOldCurs)
SETCOLOR(cOldColor)
SETPOS(nOldRow,nOldCol)
SET(_SET_DEVICE, cOldDevice)
SET(_SET_PRINTER, lOldPrint)
_ftSetLastKey(nOldLastKey)
RETURN xVarVal
| popadder.prg | 1303 |
| FUNCTION | _ftAdderTapeUDF(mode,cur_elem,rel_pos)
FUNCTION _ftAdderTapeUDF(mode,cur_elem,rel_pos)
LOCAL nKey,nRtnVal
STATIC ac_exit_ok := .F.
HB_SYMBOL_UNUSED( cur_elem )
HB_SYMBOL_UNUSED( rel_pos )
DO CASE
CASE mode == AC_EXCEPT
nKey := LASTKEY()
DO CASE
CASE nKey == 30
nRtnVal := AC_CONT
CASE nKey == K_ESC
KEYBOARD CHR(K_CTRL_PGDN)+CHR(K_RETURN) // Go to last item
ac_exit_ok := .T.
nRtnVal := AC_CONT
CASE ac_exit_ok
nRtnVal := AC_ABORT
ac_exit_ok := .F.
OTHERWISE
nRtnVal := AC_CONT
ENDCASE
OTHERWISE
nRtnVal := AC_CONT
ENDCASE
RETURN nRtnVal
| popadder.prg | 1405 |
| STATIC FUNCTION | _ftError(cMessage, xDontReset)
STATIC FUNCTION _ftError(cMessage, xDontReset)
LOCAL nOldRow,nOldCol,nOldCurs,nTop,nLeft,nBot,nRight,cOldColor, ;
nOldLastKey,cErrorScr,nMessLen,nWide,nNumRows,nKey, ;
cOldDevic,lOldPrint, ;
lResetLKey := IF(xDontReset==NIL, .T., .F.)
nOldLastKey := LASTKEY()
nOldRow := ROW()
nOldCol := COL()
nOldCurs := SETCURSOR(SC_NONE)
cOldColor:= _ftSetSCRColor(STD_ERROR)
cOldDevic := SET(_SET_DEVICE, 'SCREEN')
lOldPrint := SET(_SET_PRINTER, .F.)
cMessage := "I'm sorry but, " + cMessage
nMessLen := LEN(cMessage)
nWide := IF(nMessLen>66,66,IF(nMessLen<12,12,nMessLen))
nNumRows := MLCOUNT(cMessage,nWide)
nTop := INT((MAXROW() - nNumRows)/2) // Center it in the screen
nBot := nTop+3+nNumRows
nLeft := INT((MAXCOL()-nWide)/2)-2
nRight := nLeft+nWide+4
cErrorScr:=SAVESCREEN(nTop,nLeft,nBot+1,nRight+2)
_ftShadow(nBot+1,nLeft+2,nBot+1,nRight+2,8)
_ftShadow(nTop+1,nRight+1,nBot ,nRight+2,8)
@ nTop,nLeft,nBot,nRight BOX B_SINGLE
@ nTop,nLeft+INT(nWide/2)-1 SAY ' ERROR '
@ nBot-1,nLeft+INT(nWide-28)/2+3 SAY 'Press any key to continue...'
DISPMESSAGE cMessage,nTop+1,nLeft+3,nBot-2,nRight-3
TONE(70,5)
FT_INKEY 0 TO nKey
RESTSCREEN(nTop,nLeft,nBot+1,nRight+2,cErrorScr)
SETCURSOR(nOldCurs)
SETCOLOR(cOldColor)
SETPOS(nOldRow,nOldCol)
IF lResetLKey
_ftSetLastKey(nOldLastKey)
ENDIF
SET(_SET_DEVICE, cOldDevic)
SET(_SET_PRINTER, lOldPrint)
RETURN NIL
| popadder.prg | 1449 |
| STATIC FUNCTION | _ftStuffComma(cStrToStuff,lTrimStuffedStr)
STATIC FUNCTION _ftStuffComma(cStrToStuff,lTrimStuffedStr)
LOCAL nDecPosit, x, ;
nOrLen := LEN(cStrToStuff)
lTrimStuffedStr := IF(lTrimStuffedStr=NIL,.F.,lTrimStuffedStr)
IF !('.' $ cStrToStuff)
cStrToStuff := _ftPosIns(cStrToStuff,'.',IF('C'$cStrToStuff .OR. ;
'E'$cStrToStuff .OR. '+'$cStrToStuff .OR. '-'$cStrToStuff ;
.OR. 'X'$cStrToStuff .OR. '*'$cStrToStuff .OR. ;
''$cStrToStuff .OR. '/'$cStrToStuff .OR. '='$cStrToStuff,;
LEN(cStrToStuff)-1,LEN(cStrToStuff)+1))
IF ASC(cStrToStuff) == K_SPACE .OR. ASC(cStrToStuff) == K_ZERO
cStrToStuff := SUBSTR(cStrToStuff, 2)
ENDIF
ENDIF
nDecPosit := AT('.',cStrToStuff)
IF LEN(LEFT(LTRIM(_ftCharRem('-',cStrToStuff)), ;
AT('.',LTRIM(_ftCharRem('-',cStrToStuff)))-1))>3
IF lTrimStuffedStr // Do we trim the number each time we insert a comma
FOR x=nDecPosit-3 TO 2+_ftCountLeft(cStrToStuff,' ') STEP -4
cStrToStuff := SUBSTR(_ftPosIns(cStrToStuff,',',x),2)
NEXT
ELSE
FOR x=nDecPosit-3 TO 2+_ftCountLeft(cStrToStuff,' ') STEP -3
cStrToStuff := _ftPosIns(cStrToStuff,',',x)
NEXT
ENDIF
ENDIF
RETURN cStrToStuff
| popadder.prg | 1510 |
| STATIC FUNCTION | _ftSetSCRColor(nStd,nEnh,nBord,nBack,nUnsel)
STATIC FUNCTION _ftSetSCRColor(nStd,nEnh,nBord,nBack,nUnsel)
IF EMPTY(aWinColor)
_ftInitColors()
ENDIF
nStd := IF(nStd == NIL, 8, nStd)
nEnh := IF(nEnh == NIL, 8, nEnh)
nBord := IF(nBord == NIL, 8, nBord)
nBack := IF(nBack == NIL, 8, nBack)
nUnsel:= IF(nUnsel == NIL, nEnh, nUnsel)
RETURN SETCOLOR(aStdColor[nStd]+','+aStdColor[nEnh]+','+aStdColor[nBord]+','+;
aStdColor[nBack]+','+aStdColor[nUnsel])
| popadder.prg | 1568 |
| STATIC FUNCTION | _ftPushWin(t,l,b,r,cTitle,cBotTitle,nWinColor)
STATIC FUNCTION _ftPushWin(t,l,b,r,cTitle,cBotTitle,nWinColor)
LOCAL lAutoWindow := nWinColor==NIL
nWinColor := IF(nWinColor=NIL,_ftNextWinColor(),nWinColor)
AADD(aWindow,{t,l,b,r,nWinColor,SAVESCREEN(t,l,b+1,r+2),lAutoWindow})
_ftShadow(b+1,l+2,b+1,r+2)
_ftShadow(t+1,r+1,b,r+2)
_ftSetWinColor(nWinColor,W_BORDER)
@ t,l,b,r BOX B_SINGLE
IF cTitle!=NIL
_ftSetWinColor(nWinColor,W_TITLE)
_ftWinTitle(cTitle)
ENDIF
IF cBotTitle!=NIL
_ftSetWinColor(nWinColor,W_TITLE)
_ftWinTitle(cBotTitle,'bot')
ENDIF
_ftSetWinColor(nWinColor,W_SCREEN,W_VARIAB)
@ t+1,l+1 CLEAR TO b-1,r-1
RETURN NIL
| popadder.prg | 1619 |
| STATIC FUNCTION | _ftPopWin
STATIC FUNCTION _ftPopWin
LOCAL nNumWindow:=LEN(aWindow)
RESTSCREEN(aWindow[nNumWindow,1],aWindow[nNumWindow,2], ;
aWindow[nNumWindow,3]+1,aWindow[nNumWindow,4]+2, ;
aWindow[nNumWindow,6])
IF aWindow[nNumWindow,7]
_ftLastWinColor()
ENDIF
ASHRINK(aWindow)
IF !EMPTY(aWindow)
_ftSetWinColor(W_CURR,W_SCREEN,W_VARIAB)
ELSE
_ftSetSCRColor(STD_SCREEN,STD_VARIABLE)
ENDIF
RETURN NIL
| popadder.prg | 1665 |
| STATIC FUNCTION | _ftSetWinColor(nWin,nStd,nEnh,nBord,nBack,nUnsel)
STATIC FUNCTION _ftSetWinColor(nWin,nStd,nEnh,nBord,nBack,nUnsel)
nWin := IF(nWin == NIL, nWinColor, nWin)
nStd := IF(nStd == NIL, 7, nStd)
nEnh := IF(nEnh == NIL, 7, nEnh)
nBord := IF(nBord == NIL, 7, nBord)
nBack := IF(nBack == NIL, 7, nBack)
nUnsel:= IF(nUnsel == NIL, nEnh, nUnsel)
RETURN SETCOLOR(aWinColor[nStd,nWin]+','+aWinColor[nEnh,nWin]+','+ ;
aWinColor[nBord,nWin]+','+aWinColor[nBack,nWin]+','+aWinColor[nUnsel,nWin])
| popadder.prg | 1713 |
| STATIC FUNCTION | _ftShadow( nTop, nLeft, nBottom, nRight )
STATIC FUNCTION _ftShadow( nTop, nLeft, nBottom, nRight )
LOCAL theShadow := SAVESCREEN(nTop, nLeft, nBottom, nRight)
RESTSCREEN( nTop, nLeft, nBottom, nRight, ;
TRANSFORM( theShadow,REPLICATE("X", LEN(theShadow)/2 ) ) )
RETURN NIL
| popadder.prg | 1746 |
| STATIC FUNCTION | _ftLastWinColor
STATIC FUNCTION _ftLastWinColor
RETURN nWinColor := IF(nWinColor=1,4,nWinColor-1)
| popadder.prg | 1773 |
| STATIC FUNCTION | _ftNextWinColor
STATIC FUNCTION _ftNextWinColor
IF EMPTY(aWinColor)
_ftInitColors()
ENDIF
RETURN nWinColor := (IF(nWinColor<4,nWinColor+1,1))
| popadder.prg | 1795 |
| STATIC FUNCTION | _ftWinTitle(cTheTitle,cTopOrBot)
STATIC FUNCTION _ftWinTitle(cTheTitle,cTopOrBot)
LOCAL nCurWin :=LEN(aWindow), ;
nLenTitle:=LEN(cTheTitle)
@ aWindow[nCurWin,IF(cTopOrBot=NIL,1,3)],(aWindow[nCurWin,4]- ;
aWindow[nCurWin,2]-nLenTitle)/2+aWindow[nCurWin,2] SAY ' '+cTheTitle+' '
RETURN NIL
| popadder.prg | 1820 |
| STATIC FUNCTION | _ftInitColors
STATIC FUNCTION _ftInitColors
aWinColor := { {'GR+/BG','GR+/G', 'B+/RB', 'G+/R'} , ;
{'R+/N', 'W+/RB','W+/BG','GR+/B'} , ;
{'GR+/N', 'GR+/N','GR+/N', 'GR+/N'} , ;
{ 'B/BG','BG+/G', 'W+/RB','BG+/R'} , ;
{ 'W+/BG', 'W+/G','GR+/RB', 'W+/R'} , ;
{'GR+/B', 'GR+/R', 'R+/B', 'W+/BG'}, ;
{ 'N/N', 'N/N', 'N/N', 'N/N'} }
aStdColor := { 'BG+*/RB' , ;
'GR+/R' , ;
'GR+/N' , ;
'W/B' , ;
'GR+/N' , ;
'GR+/GR' , ;
{ 'W+/B', 'W/B','G+/B','R+/B', ;
'GR+/B','BG+/B','B+/B','G+/B'}, ;
'N/N' }
RETURN NIL
| popadder.prg | 1845 |
| STATIC FUNCTION | _ftCharOdd(cString)
STATIC FUNCTION _ftCharOdd(cString)
cString := TRANSFORM(cString,REPLICATE("X", LEN(cString)/2 ) )
RETURN STRTRAN(cString,'')
| popadder.prg | 1883 |
| STATIC FUNCTION | _ftPosRepl(cString,cChar,nPosit)
STATIC FUNCTION _ftPosRepl(cString,cChar,nPosit)
RETURN STRTRAN(cString,'9',cChar,nPosit,1)+''
| popadder.prg | 1905 |
| STATIC FUNCTION | _ftCharRem(cChar,cString)
STATIC FUNCTION _ftCharRem(cChar,cString)
RETURN STRTRAN(cString,cChar)
| popadder.prg | 1925 |
| STATIC FUNCTION | _ftCountLeft(cString)
STATIC FUNCTION _ftCountLeft(cString)
RETURN LEN(cString)-LEN(LTRIM(cString))
| popadder.prg | 1947 |
| STATIC FUNCTION | _ftPosIns(cString,cChar,nPosit)
STATIC FUNCTION _ftPosIns(cString,cChar,nPosit)
RETURN LEFT(cString,nPosit-1)+cChar+SUBSTR(cString,nPosit)
| popadder.prg | 1968 |
| prtesc.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN( cParm1 )
FUNCTION MAIN( cParm1 )
*-------------------------------------------------------
* Sample routine to test function from command line
*-------------------------------------------------------
IF PCount() > 0
? FT_ESCCODE( cParm1 )
ELSE
? "Usage: PRT_ESC 'escape code sequence' "
? " outputs converted code to standard output"
?
ENDIF
RETURN (nil)
#endif
| prtesc.prg | 28 |
| FUNCTION | FT_ESCCODE( cInput )
FUNCTION FT_ESCCODE( cInput )
LOCAL cOutput := "" ,;
cCurrent ,;
nPointer := 1 ,;
nLen := Len( cInput )
DO WHILE nPointer <= nLen
cCurrent := Substr( cInput, nPointer, 1 )
DO CASE
CASE cCurrent == "\" .AND. ;
IsDigit(Substr(cInput, nPointer+1, 1) ) .AND. ;
IsDigit(Substr(cInput, nPointer+2, 1) ) .AND. ;
IsDigit(Substr(cInput, nPointer+3, 1) )
cOutput += Chr(Val(Substr(cInput, nPointer+1,3)))
nPointer += 4
CASE cCurrent == "\" .AND. ;
Substr(cInput, nPointer+1, 1) == "\"
cOutput += "\"
nPointer += 2
OTHERWISE
cOutput += cCurrent
nPointer++
ENDCASE
ENDDO
RETURN cOutput
| prtesc.prg | 74 |
| pvid.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_PushVid()
function FT_PushVid()
AAdd( aVideo, { row(), ;
col(), ;
setcolor(), ;
savescreen( 0, 0, maxrow(), maxcol() ), ;
set( _SET_CURSOR ), ;
setblink(), ;
nosnow(), ;
maxrow() + 1, ;
maxcol() + 1, ;
set( _SET_SCOREBOARD ) } )
return len( aVideo )
| pvid.prg | 68 |
| FUNCTION | FT_PopVid()
function FT_PopVid()
local nNewSize := len( aVideo ) - 1
local aBottom := ATail( aVideo )
if nNewSize >= 0
setmode( aBottom[ PV_MAXROW ], aBottom[ PV_MAXCOL ] )
set( _SET_CURSOR, aBottom[ PV_CURSOR ] )
nosnow( aBottom[ PV_NOSNOW ] )
setblink( aBottom[ PV_BLINK ] )
restscreen( 0, 0, maxrow(), maxcol(), aBottom[ PV_IMAGE ] )
setcolor( aBottom[ PV_COLOR ] )
setpos( aBottom[ PV_ROW ], aBottom[ PV_COL ] )
set( _SET_SCOREBOARD, aBottom[ PV_SCORE ] )
aSize( aVideo, nNewSize )
endif
return len( aVideo )
| pvid.prg | 112 |
| qtr.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_QTR(dGivenDate,nQtrNum)
FUNCTION FT_QTR(dGivenDate,nQtrNum)
LOCAL lIsQtr, nTemp, aRetVal
IF !(VALTYPE(dGivenDate) $ 'ND')
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'N'
nQtrNum := dGivenDate
dGivenDate := DATE()
ENDIF
aRetval := FT_YEAR(dGivenDate)
lIsQtr := ( VALTYPE(nQtrNum) == 'N' )
IF lIsQtr
IF( nQtrNum < 1 .OR. nQtrNum > 4, nQtrNum := 4, )
dGivenDate := FT_MADD(aRetVal[2], 3*(nQtrNum - 1) )
ENDIF
nTemp := MONTH( dGivenDate ) - MONTH( aRetVal[2] )
nTemp += IF( nTemp >= 0, 1, 13 )
nTemp := INT( (nTemp - 1) / 3 )
aRetVal[1] += PADL(LTRIM(STR( nTemp + 1, 2)), 2, '0')
aRetVal[2] := FT_MADD( aRetVal[2], nTemp * 3 )
aRetVal[3] := FT_MADD( aRetVal[2], 3 ) - 1
RETURN aRetVal
| qtr.prg | 88 |
| rand1.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | main()
function main()
local x
for x := 1 to 100
outstd( int( ft_rand1(100) ) )
outstd( chr(13) + chr(10) )
next
return nil
| rand1.prg | 63 |
| FUNCTION | ft_rand1(nMax)
function ft_rand1(nMax)
static nSeed
local m := 100000000, b := 31415621
nSeed := iif( nSeed == NIL, seconds(), nSeed ) // init_seed()
return( nMax * ( ( nSeed := mod( nSeed*b+1, m ) ) / m ) )
| rand1.prg | 75 |
| restsets.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_RESTSETS(aOldSets)
FUNCTION FT_RESTSETS(aOldSets)
AEVAL(aOldSets, ;
{ | xElement, nElementNo | ;
SET(nElementNo, xElement) }, ;
1, _SET_COUNT )
FT_SETCENTURY(aOldSets[FT_SET_CENTURY])
SETBLINK(aOldSets[FT_SET_BLINK])
RETURN (NIL) // FT_RestSets
| restsets.prg | 62 |
| savearr.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | DispArray(aTest)
FUNCTION DispArray(aTest)
LOCAL nk
FOR nk := 1 TO LEN(aTest)
? aTest[nk, 1]
?? ' '
?? DTOC(aTest[nk, 2])
?? ' '
?? STR(aTest[nk, 3])
?? ' '
?? IF(aTest[nk, 4], 'true', 'false')
NEXT
RETURN Nil
#endif
| savearr.prg | 59 |
| FUNCTION | FT_SAVEARR(aArray, cFileName, nErrorCode)
FUNCTION FT_SAVEARR(aArray, cFileName, nErrorCode)
LOCAL nHandle, lRet
nHandle = FCREATE(cFileName)
nErrorCode = FError()
IF nErrorCode = 0
lRet := _ftsavesub(aArray, nHandle, @nErrorCode)
FCLOSE(nHandle)
IF (lRet) .AND. (FERROR() # 0)
nErrorCode = FERROR()
lRet = .F.
ENDIF
ELSE
lRet = .F.
ENDIF
RETURN lRet
| savearr.prg | 132 |
| STATIC FUNCTION | _ftsavesub(xMemVar, nHandle, nErrorCode)
STATIC FUNCTION _ftsavesub(xMemVar, nHandle, nErrorCode)
LOCAL cValType, nLen, cString
PRIVATE lRet // accessed in code block
lRet := .T.
cValType := ValType(xMemVar)
FWrite(nHandle, cValType, 1)
IF FError() = 0
DO CASE
CASE cValType = "A"
nLen := Len(xMemVar)
FWrite(nHandle, L2Bin(nLen), 4)
IF FError() = 0
AEVAL(xMemVar, {|xMemVar1| lRet := _ftsavesub(xMemVar1, nHandle) } )
ELSE
lRet = .F.
ENDIF
CASE cValType = "B"
lRet := .F.
CASE cValType = "C"
nLen := Len(xMemVar)
FWrite(nHandle, L2Bin(nLen), 4)
FWrite(nHandle, xMemVar)
CASE cValType = "D"
nLen := 8
FWrite(nHandle, L2Bin(nLen), 4)
FWrite(nHandle, DTOC(xMemVar))
CASE cValType = "L"
nLen := 1
FWrite(nHandle, L2Bin(nLen), 4)
FWrite(nHandle, IF(xMemVar, "T", "F") )
CASE cValType = "N"
cString := STR(xMemVar)
nLen := LEN(cString)
FWrite(nHandle, L2Bin(nLen), 4)
FWrite(nHandle, cString)
ENDCASE
ELSE
lRet = .F.
ENDIF
nErrorCode = FError()
RETURN lRet
| savearr.prg | 148 |
| FUNCTION | FT_RESTARR(cFileName, nErrorCode)
FUNCTION FT_RESTARR(cFileName, nErrorCode)
LOCAL nHandle, aArray
nHandle := FOPEN(cFileName)
nErrorCode := FError()
IF nErrorCode = 0
aArray := _ftrestsub(nHandle, @nErrorCode)
FCLOSE(nHandle)
ELSE
aArray := {}
ENDIF
RETURN aArray
| savearr.prg | 238 |
| STATIC FUNCTION | _ftrestsub(nHandle, nErrorCode)
STATIC FUNCTION _ftrestsub(nHandle, nErrorCode)
LOCAL cValType, nLen, cLenStr, xMemVar, cMemVar, nk
cValType := ' '
FREAD(nHandle, @cValType, 1)
cLenStr := SPACE(4)
FREAD(nHandle, @cLenStr, 4)
nLen = Bin2L(cLenStr)
nErrorCode = FError()
IF nErrorCode = 0
DO CASE
CASE cValType = "A"
xMemVar := {}
FOR nk := 1 TO nLen
AADD(xMemVar, _ftrestsub(nHandle)) // Recursive call
NEXT
CASE cValType = "C"
xMemVar := SPACE(nLen)
FREAD(nHandle, @xMemVar, nLen)
CASE cValType = "D"
cMemVar = SPACE(8)
FREAD(nHandle, @cMemVar,8)
xMemVar := CTOD(cMemVar)
CASE cValType = "L"
cMemVar := ' '
FREAD(nHandle, @cMemVar, 1)
xMemVar := (cMemVar = "T")
CASE cValType = "N"
cMemVar := SPACE(nLen)
FREAD(nHandle, @cMemVar, nLen)
xMemVar = VAL(cMemVar)
ENDCASE
nErrorCode := FERROR()
ENDIF
RETURN xMemVar
| savearr.prg | 250 |
| savesets.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN
FUNCTION MAIN
LOCAL ASETS := FT_SAVESETS()
INKEY(0)
RETURN Nil
| savesets.prg | 67 |
| FUNCTION | FT_SAVESETS()
FUNCTION FT_SAVESETS()
LOCAL aOldSets := ARRAY(_SET_COUNT + FT_EXTRA_SETS)
AEVAL(aOldSets, ;
{ | xElement, nElementNo | HB_SYMBOL_UNUSED( xElement ), ;
aOldSets[nElementNo] := SET(nElementNo) } )
aOldSets[FT_SET_CENTURY] := FT_SETCENTURY()
aOldSets[FT_SET_BLINK] := SETBLINK()
RETURN (aOldSets) // FT_SaveSets
| savesets.prg | 73 |
| scancode.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | main()
FUNCTION main()
LOCAL getlist, cKey
CLEAR
QOut("Press any key, ESCape to exit:")
while .t.
cKey := FT_SCANCODE()
QOUT( "chr(" + str(asc(substr(cKey,1,1)),3) + ")+chr(" + str(asc(substr(cKey,2,1)),3) + ")" )
if cKey == SCANCODE_ESCAPE
exit
endif
end
RETURN nil
| scancode.prg | 86 |
| FUNCTION | FT_SCANCODE()
FUNCTION FT_SCANCODE()
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] = MAKEHI( 0 )
FT_INT86( KEYB, aRegs )
RETURN ( chr(LOWBYTE( aRegs[AX] )) + chr(HIGHBYTE( aRegs[AX] )) )
| scancode.prg | 102 |
| scregion.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_SAVRGN(nTop, nLeft, nBottom, nRight)
FUNCTION FT_SAVRGN(nTop, nLeft, nBottom, nRight)
RETURN (CHR(nTop) + CHR(nLeft) + CHR(nBottom) + CHR(nRight) + ;
SAVESCREEN(nTop, nLeft, nBottom, nRight))
| scregion.prg | 68 |
| FUNCTION | FT_RSTRGN(cScreen, nTop, nLeft)
FUNCTION FT_RSTRGN(cScreen, nTop, nLeft)
IF PCOUNT() == 3
RESTSCREEN(nTop, nLeft, (nTop - ASC(cScreen)) + ASC(SUBSTR(cScreen, 3)), ;
(nLeft - ASC(SUBSTR(cScreen, 2))) + ASC(SUBSTR(cScreen, 4)), ;
SUBSTR(cScreen, 5))
ELSE
RESTSCREEN(ASC(cScreen), ASC(SUBSTR(cScreen, 2)), ASC(SUBSTR(cScreen, 3)), ;
ASC(SUBSTR(cScreen, 4)), SUBSTR(cScreen, 5))
ENDIF
RETURN NIL
| scregion.prg | 120 |
| FUNCTION | FT_RGNSTACK(cAction, nTop, nLeft, nBottom, nRight)
FUNCTION FT_RGNSTACK(cAction, nTop, nLeft, nBottom, nRight)
STATIC nStackPtr := 0
LOCAL nPopTop
IF cAction == "push"
ASIZE(aRgnStack, ++nStackPtr)[nStackPtr] = ;
FT_SAVRGN(nTop, nLeft, nBottom, nRight)
ELSEIF cAction == "pop" .OR. cAction = "pop all"
nPopTop = IIF("all" $ cAction, 0, nStackPtr-1)
DO WHILE nStackPtr > nPopTop
FT_RSTRGN(aRgnStack[nStackPtr--])
ENDDO
ASIZE(aRgnStack, nStackPtr)
ENDIF
RETURN NIL
| scregion.prg | 206 |
| setdate.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN( cDate )
FUNCTION MAIN( cDate )
cDate := iif( cDate == nil, dtoc( date() ), cDate )
QOut( "Setting date to: " + cDate + "... " )
FT_SETDATE( ctod( cDate ) )
Qout( "Today is now: " + dtoc( date() ) )
return ( nil )
| setdate.prg | 81 |
| FUNCTION | FT_SETDATE( dDate )
function FT_SETDATE( dDate )
local aRegs[ INT86_MAX_REGS ]
dDate := iif( valtype(dDate) != "D", date(), dDate )
aRegs[ AX ] = SETDATE * ( 2 ^ 8 )
aregs[ CX ] = year( dDate )
aregs[ DX ] = ( month( dDate ) * ( 2 ^ 8 ) ) + day( dDate )
return( FT_INT86( DOS, aRegs ) )
| setdate.prg | 91 |
| settime.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN( cTime )
FUNCTION MAIN( cTime )
cTime := iif( cTime == nil, time(), cTime )
QOut( "Setting time to: " + cTime + "... " )
FT_SETTIME( cTime )
Qout( "Time is now: " + time() )
return ( nil )
| settime.prg | 82 |
| FUNCTION | FT_SETTIME( cTime )
function FT_SETTIME( cTime )
local aRegs[ INT86_MAX_REGS ]
cTime := iif( cTime == nil, time(), cTime )
// -------- High Byte ------ ----- Low Byte -------
aRegs[ AX ] = SETTIME * ( 2 ^ 8 )
aRegs[ CX ] = HRS( cTime ) * ( 2 ^ 8 ) + MINS( cTime )
aRegs[ DX ] = SECS( cTime ) * ( 2 ^ 8 )
return( FT_INT86( DOS, aRegs ) )
| settime.prg | 90 |
| sinkey.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_SINKEY(waittime)
FUNCTION FT_SINKEY(waittime)
LOCAL key, cblock
DO CASE
/* if no WAITTIME passed, go straight through */
CASE pcount() == 0
key := inkey()
/* dig this... if you pass inkey(NIL), it is identical to INKEY(0)!
therefore, I allow you to pass FT_SINKEY(NIL) -- hence this mild bit
of convolution */
CASE waittime == NIL .AND. Pcount() == 1
key := inkey(0)
OTHERWISE
key := inkey(waittime)
ENDCASE
cblock := Setkey(key)
IF cblock != NIL
// run the code block associated with this key and pass it the
// name of the previous procedure and the previous line number
Eval(cblock, Procname(1), Procline(1), NIL)
ENDIF
RETURN key
| sinkey.prg | 62 |
| sleep.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN(nSleep)
FUNCTION MAIN(nSleep)
? "Time is now: " + time()
FT_SLEEP(VAL(nSleep))
? "Time is now: " + time()
RETURN ( nil )
#endif
| sleep.prg | 30 |
| FUNCTION | FT_SLEEP( nSeconds, nInitial )
FUNCTION FT_SLEEP( nSeconds, nInitial )
IF nInitial == NIL .OR. VALTYPE( nInitial ) != "N"
nInitial := SECONDS()
ENDIF
// correct for running at midnight
IF nInitial + nSeconds > 86399
nInitial -= 86399
* Wait until midnight
DO WHILE SECONDS() > 100 // no problem with a _very_ slow machine
ENDDO
ENDIF
// calculate final time
nSeconds += ninitial
// Loop until we are done
DO WHILE ( SECONDS() < nSeconds )
ENDDO
RETURN NIL
| sleep.prg | 88 |
| sqzn.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | ft_sqzn(nValue,nSize,nDecimals)
function ft_sqzn(nValue,nSize,nDecimals)
local tmpstr,cCompressed,k
nSize := if(nSize ==NIL,10,nSize )
nDecimals := if(nDecimals==NIL, 0,nDecimals )
nValue := nValue * (10**nDecimals)
nSize := if(nSize/2!=int(nSize/2),nSize+1,nSize)
tmpstr := str( abs(nValue),nSize )
tmpstr := strtran(tmpstr," ","0")
cCompressed := chr( val(substr(tmpstr,1,2))+if(nValue<0,128,0) )
for k := 3 to len(tmpstr) step 2
cCompressed += chr(val(substr(tmpstr,k,2)))
next
return cCompressed
| sqzn.prg | 59 |
| FUNCTION | ft_unsqzn(cCompressed,nSize,nDecimals)
function ft_unsqzn(cCompressed,nSize,nDecimals)
local tmp:="",k,cValue,multi:=1
nSize := if(nSize ==NIL,10,nSize )
nDecimals := if(nDecimals==NIL, 0,nDecimals)
cCompressed := if(multi ==-1,substr(cCompressed,2),cCompressed)
nSize := if(nSize/2!=int(nSize/2),nSize+1,nSize)
if asc(cCompressed) > 127
tmp := str(asc(cCompressed)-128,2)
multi := -1
else
tmp := str(asc(cCompressed),2)
endif
for k := 2 to len(cCompressed)
tmp += str(asc(substr(cCompressed,k,1)),2)
next
tmp := strtran(tmp," ","0")
cValue := substr(tmp,1,nSize-nDecimals)+"."+substr(tmp,nSize-nDecimals+1)
return val(cValue) * multi
| sqzn.prg | 117 |
| sysmem.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN()
FUNCTION MAIN()
QOut( "Conventional memory: " + str( FT_SYSMEM() ) + "K installed" )
return ( nil )
| sysmem.prg | 65 |
| FUNCTION | FT_SYSMEM()
FUNCTION FT_SYSMEM()
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] := 0
FT_INT86( MEMSIZE, aRegs )
RETURN ( aRegs[ AX ] )
| sysmem.prg | 70 |
| tbwhile.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | TBWHILE()
FUNCTION TBWHILE()
LOCAL aFields := {}, cKey := "O", cOldColor
LOCAL nFreeze := 1, lSaveScrn := .t., nRecSel
LOCAL cColorList := "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R"
LOCAL cColorShad := "N/N"
FIELD last, first
MEMVAR GetList
IF ! FILE( "TBNAMES.DBF" )
MAKE_DBF()
ENDIF
USE TBNames
IF ! FILE( "TBNAMES.NTX" )
INDEX ON last + first TO TBNAMES
ENDIF
SET INDEX TO TBNAMES
* Pass Heading as character and Field as Block including Alias
* To eliminate the need to use FIELDWBLOCK() function in FT_BRWSWHL()
AADD(aFields, {"Last Name" , {||TBNames->Last} } )
AADD(aFields, {"First Name", {||TBNames->First} } )
AADD(aFields, {"City" , {||TBNames->City} } )
cOldColor := SetColor("N/BG")
CLEAR SCREEN
@ 5,10 SAY "Enter First Letter Of Last Name:" GET cKey PICTURE "!"
READ
* TBNames->Last = cKey is the Conditional Block passed to this function
* you can make it as complicated as you want, but you would then
* have to modify TBWhileSet() to find first and last records
* matching your key.
nRecSel := FT_BRWSWHL( aFields, {||TBNames->Last = cKey}, cKey, nFreeze,;
lSaveScrn, cColorList, cColorShad, 3, 6, MaxRow() - 2, MaxCol() - 6)
* Note you can use Compound Condition
* such as cLast =: "Pierce " and cFirst =: "Hawkeye "
* by changing above block to:
* {||TBNames->Last = cLast .AND. TBNames->First = cFirst}
* and setting cKey := cLast + cFirst
?
IF nRecSel == 0
? "Sorry, NO Records Were Selected"
ELSE
? "You Selected " + TBNames->Last +" "+ ;
TBNames->First +" "+ TBNames->City
ENDIF
?
WAIT
SetColor(cOldColor)
CLEAR SCREEN
RETURN nil
| tbwhile.prg | 81 |
| STATIC FUNCTION | make_dbf
STATIC FUNCTION make_dbf
LOCAL x, aData := { ;
{ "SHAEFER","KATHRYN","415 WEST CITRUS ROAD #150","LOS ANGELES","CA","90030" },;
{ "OLSON","JAMES","225 NORTH RANCH ROAD","LOS ANGELES","CA","90023" },;
{ "KAYBEE","JOHN","123 SANDS ROAD","CAMARILLO","CA","93010" },;
{ "HERMAN","JIM","123 TOON PAGE ROAD","VENTURA","CA","93001" },;
{ "BURNS","FRANK","123 VIRGINA STREET","OXNARD","CA","93030" },;
{ "PIERCE","HAWKEYE","123 OLD TOWN ROAD","PORT MUGU","CA","93043" },;
{ "MORGAN","JESSICA","123 FRONTAGE ROAD","CAMARILLO","CA","93010" },;
{ "POTTER","ROBERT","123 FIR STREET","OXNARD","CA","93030" },;
{ "WORTH","MARY","123-1/2 JOHNSON DRIVE","OXNARD","CA","93033" },;
{ "JOHNSON","SUSAN","123 QUEENS STREET","OXNARD","CA","93030" },;
{ "SAMSON","SAM","215 MAIN STREET","OXNARD","CA","93030" },;
{ "NEWNAME","JAMES","215 MAIN STREET","LOS ANGELES","CA","90000" },;
{ "OLEANDAR","JILL","425 FLORAL PARK DRIVE","FLORAL PARK","NY","10093" },;
{ "SUGARMAN","CANDY","1541 SWEETHEART ROAD","HERSHEY","PA","10132" } }
DbCreate( "TBNAMES", { { "LAST ", "C", 18, 0, } ,;
{ "FIRST", "C", 9, 0, } ,;
{ "ADDR ", "C", 28, 0, } ,;
{ "CITY ", "C", 21, 0, } ,;
{ "STATE", "C", 2, 0, } ,;
{ "ZIP ", "C", 9, 0, } } )
USE tbnames
FOR x := 1 TO Len( aData )
APPEND BLANK
Aeval( aData[x], {|e,n| FieldPut( n, e ) } )
NEXT
USE
RETURN NIL
#endif
/* ------------------------------------------------------------------- */
| tbwhile.prg | 139 |
| FUNCTION | FT_BRWSWHL(aFields, bWhileCond, cKey, nFreeze, lSaveScrn, cColorList, cColorShad, nTop, nLeft, nBottom, nRight )
FUNCTION FT_BRWSWHL(aFields, bWhileCond, cKey, nFreeze, lSaveScrn, ;
cColorList, cColorShad, nTop, nLeft, nBottom, nRight )
LOCAL b, column, i
LOCAL cHead, bField, lKeepScrn, cScrnSave
LOCAL cColorSave, cColorBack, nCursSave
LOCAL lMore, nKey, nPassRec
DEFAULT nFreeze TO 0, ;
lSaveScrn TO .t., ;
cColorList TO "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R", ;
cColorShad TO "N/N", ;
nTop TO 2, ;
nLeft TO 2, ;
nBottom TO MaxRow() - 2, ;
nRight TO MaxCol() - 2
lKeepScrn := (PCOUNT() > 6)
SEEK cKey
IF .NOT. FOUND() .OR. LASTREC() == 0
RETURN(0)
ENDIF
/* make new browse object */
b := TBrowseDB(nTop, nLeft, nBottom, nRight)
/* default heading and column separators */
b:headSep := "ÍÑÍ"
b:colSep := " ³ "
b:footSep := "ÍÏÍ"
/* add custom 'TbSkipWhil' (to handle passed condition) */
b:skipBlock := {|x| TbSkipWhil(x, bWhileCond)}
/* Set up substitute goto top and goto bottom */
/* with While's top and bottom records */
b:goTopBlock := {|| TbWhileTop(cKey)}
b:goBottomBlock := {|| TbWhileBot(cKey)}
/* colors */
b:colorSpec := cColorList
/* add a column for each field in the current workarea */
FOR i = 1 TO LEN(aFields)
cHead := aFields[i, 1]
bField := aFields[i, 2]
/* make the new column */
column := TBColumnNew( cHead, bField )
/* these are color setups from tbdemo.prg from Nantucket */
* IF ( cType == "N" )
* column:defColor := {5, 6}
* column:colorBlock := {|x| if( x < 0, {7, 8}, {5, 6} )}
*ELSE
* column:defColor := {3, 4}
*ENDIF
/* To simplify I just used 3rd and 4th colors from passed cColorList */
/* This way 1st is SAY, 2nd is GET, 3rd and 4th are used here,
/* 5th is Unselected Get, extras can be used as in tbdemo.prg */
column:defColor := {3, 4}
b:addColumn(column)
NEXT
/* freeze columns */
IF nFreeze != 0
b:freeze := nFreeze
ENDIF
/* save old screen and colors */
IF lSaveScrn
cScrnSave = SAVESCREEN(0, 0, MaxRow(), MaxCol())
ENDIF
cColorSave := SetColor()
/* Background Color Is Based On First Color In Passed cColorList
cColorBack := IF(',' $ cColorList, ;
SUBSTR(cColorList, 1, AT(',', cColorList) - 1), cColorList )
IF .NOT. lKeepScrn
SetColor(cColorBack)
CLEAR SCREEN
ENDIF
/* make a window shadow */
SetColor(cColorShad)
@ nTop+1, nLeft+1 CLEAR TO nBottom+1, nRight+1
SetColor(cColorBack)
@ nTop, nLeft CLEAR TO nBottom, nRight
SetColor(cColorSave)
nCursSave := SetCursor(0)
lMore := .t.
WHILE (lMore)
/* stabilize the display */
nKey := 0
DISPBEGIN()
DO WHILE nKey == 0 .AND. .NOT. b:stable
b:stabilize()
nKey := InKey()
ENDDO
DISPEND()
IF ( b:stable )
/* display is stable */
IF ( b:hitTop .OR. b:hitBottom )
Tone(125, 0)
ENDIF
// Make sure that the current record is showing
// up-to-date data in case we are on a network.
DISPBEGIN()
b:refreshCurrent()
DO WHILE .NOT. b:stabilize()
ENDDO
DISPEND()
/* everything's done; just wait for a key */
nKey := INKEY(0)
ENDIF
/* process key */
DO CASE
CASE ( nKey == K_DOWN )
b:down()
CASE ( nKey == K_UP )
b:up()
CASE ( nKey == K_PGDN )
b:pageDown()
CASE ( nKey == K_PGUP )
b:pageUp()
CASE ( nKey == K_CTRL_PGUP )
b:goTop()
CASE ( nKey == K_CTRL_PGDN )
b:goBottom()
CASE ( nKey == K_RIGHT )
b:right()
CASE ( nKey == K_LEFT )
b:left()
CASE ( nKey == K_HOME )
b:home()
CASE ( nKey == K_END )
b:end()
CASE ( nKey == K_CTRL_LEFT )
b:panLeft()
CASE ( nKey == K_CTRL_RIGHT )
b:panRight()
CASE ( nKey == K_CTRL_HOME )
b:panHome()
CASE ( nKey == K_CTRL_END )
b:panEnd()
CASE ( nKey == K_ESC )
nPassRec := 0
lMore := .f.
CASE ( nKey == K_RETURN )
nPassRec := RECNO()
lMore := .f.
ENDCASE
ENDDO // for WHILE (lmore)
/* restore old screen */
IF lSaveScrn
RESTSCREEN(0, 0, MaxRow(), MaxCol(), cScrnSave)
ENDIF
SetCursor(nCursSave)
SetColor(cColorSave)
RETURN (nPassRec)
| tbwhile.prg | 262 |
| STATIC FUNCTION | TbSkipWhil(n, bWhileCond)
STATIC FUNCTION TbSkipWhil(n, bWhileCond)
LOCAL i := 0
IF n == 0 .OR. LASTREC() == 0
SKIP 0 // significant on a network
ELSEIF ( n > 0 .AND. RECNO() != LASTREC() + 1)
WHILE ( i < n )
SKIP 1
IF ( EOF() .OR. .NOT. Eval(bWhileCond) )
SKIP -1
EXIT
ENDIF
i++
ENDDO
ELSEIF ( n < 0 )
WHILE ( i > n )
SKIP -1
IF ( BOF() )
EXIT
ELSEIF .NOT. Eval( (bWhileCond) )
SKIP
EXIT
ENDIF
i--
ENDDO
ENDIF
RETURN (i)
* EOFcn TbSkipWhil()
| tbwhile.prg | 450 |
| STATIC FUNCTION | TbWhileTop(cKey)
STATIC FUNCTION TbWhileTop(cKey)
SEEK cKey
RETURN NIL
| tbwhile.prg | 482 |
| STATIC FUNCTION | TbWhileBot(cKey)
STATIC FUNCTION TbWhileBot(cKey)
* SeekLast: Finds Last Record For Matching Key
* Developed By Jon Cole
* With softseek set on, seek the first record after condition.
* This is accomplished by incrementing the right most character of the
* string cKey by one ascii character. After SEEKing the new string,
* back up one record to get to the last record which matches cKey.
#include "set.ch"
LOCAL cSoftSave := SET(_SET_SOFTSEEK, .t.)
SEEK LEFT(cKey, LEN(cKey) -1) + CHR( ASC( RIGHT(cKey,1) ) +1)
SET(_SET_SOFTSEEK, cSoftSave)
SKIP -1
RETURN NIL
| tbwhile.prg | 488 |
| tempfile.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_TEMPFIL( cPath, lHide, nHandle )
FUNCTION FT_TEMPFIL( cPath, lHide, nHandle )
LOCAL cRet,aRegs[3]
cPath := iif( valType(cPath) != "C", ;
replicate( chr(0),13) , ;
cPath += replicate( chr(0), 13 ) ;
)
lHide := iif( valType(lHide) != "L", .f., lHide )
/*
aRegs[AX] := MAKEHI( TEMPNAME )
aRegs[CX] := iif( lHide, 2, 0 )
aRegs[DS] := cPath
aRegs[DX] := REG_DS
FT_INT86( DOS, aRegs )
*/
aRegs:=_ft_tempfil(cPath,lHide)
/* If carry flag is clear, then call succeeded and a file handle is
* sitting in AX that needs to be closed.
*/
if !ft_isBitOn( aRegs[3], FLAG_CARRY )
if hb_isbyref( @nHandle )
nHandle = aRegs[1]
else
fclose( aRegs[1] )
endif
cRet := alltrim( strtran( aRegs[2], chr(0) ) )
else
cRet := ""
endif
RETURN cRet
| tempfile.prg | 106 |
| FUNCTION | FT_TEMPFIL( cPath, lHide, nHandle )
FUNCTION FT_TEMPFIL( cPath, lHide, nHandle )
LOCAL cFile
Default cPath to ".\"
Default lHide to .f.
cPath = alltrim( cPath )
nHandle := HB_FTempCreate( cPath, nil, if( lHide, FC_HIDDEN, FC_NORMAL ), @cFile )
if !hb_isbyref( @nHandle )
fclose( nHandle )
endif
RETURN cFile
| tempfile.prg | 146 |
| FUNCTION | MAIN( cPath, cHide )
FUNCTION MAIN( cPath, cHide )
LOCAL cFile, nHandle
cFile := FT_TEMPFIL( cPath, (cHide == "Y") )
if !empty( cFile )
QOut( cFile )
nHandle := fopen( cFile, 1 )
fwrite( nHandle, "This is a test!" )
fclose( nHandle )
else
Qout( "An error occurred" )
endif
RETURN nil
| tempfile.prg | 166 |
| vertmenu.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN
FUNCTION MAIN
LOCAL MAINMENU := ;
{ { "DATA ENTRY", "ENTER DATA", { || FT_MENU2(datamenu) } }, ;
{ "Reports", "Hard copy", { || FT_MENU2(repmenu) } }, ;
{ "Maintenance","Reindex files, etc.",{ || FT_MENU2(maintmenu) } }, ;
{ "Quit", "See ya later" } }
local datamenu := { { "Customers", , { || cust() } } , ;
{ "Invoices", , { || inv() } } , ;
{ "Vendors", , { || vendors() } }, ;
{ "Exit", "Return to Main Menu" } }
local repmenu := { { "Customer List", , { || custrep() } } , ;
{ "Past Due", , { || pastdue() } } , ;
{ "Weekly Sales", , { || weeksales() } }, ;
{ "Monthly P&L", , { || monthpl() } } , ;
{ "Vendor List", , { || vendorrep() } }, ;
{ "Exit", "Return to Main Menu" } }
local maintmenu := { { "Reindex", "Rebuild index files", { || re_ntx() } } , ;
{ "Backup", "Backup data files" , { || backup() } } , ;
{ "Compress", "Compress data files", { || compress()} }, ;
{ "Exit", "Return to Main Menu" } }
FT_MENU2(mainmenu)
return nil
| vertmenu.prg | 73 |
| STATIC FUNCTION | cust
static function cust
| vertmenu.prg | 101 |
| STATIC FUNCTION | inv
static function inv
| vertmenu.prg | 102 |
| STATIC FUNCTION | vendors
static function vendors
| vertmenu.prg | 103 |
| STATIC FUNCTION | custrep
static function custrep
| vertmenu.prg | 104 |
| STATIC FUNCTION | pastdue
static function pastdue
| vertmenu.prg | 105 |
| STATIC FUNCTION | weeksales
static function weeksales
| vertmenu.prg | 106 |
| STATIC FUNCTION | monthpl
static function monthpl
| vertmenu.prg | 107 |
| STATIC FUNCTION | vendorrep
static function vendorrep
| vertmenu.prg | 108 |
| STATIC FUNCTION | re_ntx
static function re_ntx
| vertmenu.prg | 109 |
| STATIC FUNCTION | backup
static function backup
| vertmenu.prg | 110 |
| STATIC FUNCTION | compress
static function compress
#endif
| vertmenu.prg | 111 |
| FUNCTION | ft_menu2( aMenuInfo, cColors )
FUNCTION ft_menu2( aMenuInfo, cColors )
LOCAL nChoice := 1 ,;
nOptions := Len( aMenuInfo ) ,;
nMaxwidth := 0 ,;
nLeft ,;
x ,;
cOldscreen ,;
nTop ,;
lOldwrap := Set( _SET_WRAP, .T. ) ,;
lOldcenter := Set( _SET_MCENTER, .T. ),;
lOldmessrow := Set( _SET_MESSAGE ) ,;
cOldcolor := Set( _SET_COLOR )
IF cColors # NIL
Set( _SET_COLOR, cColors )
ENDIF
/* if no message row has been established, use bottom row */
IF lOldmessrow == 0
Set( _SET_MESSAGE, Maxrow() )
ENDIF
/* determine longest menu option */
Aeval( aMenuInfo, { | ele | nMaxwidth := max( nMaxwidth, len( ele[1] ) ) } )
/* establish top and left box coordinates */
nLeft := ( ( Maxcol() + 1 ) - nMaxwidth ) / 2
nTop := ( ( Maxrow() + 1 ) - ( nOptions + 2 ) ) / 2
DO WHILE nChoice != 0 .AND. nChoice != nOptions
cOldscreen := Savescreen( nTop, nLeft - 1, nTop + nOptions + 1, nLeft + nMaxwidth )
@ nTop, nLeft - 1, nTop + nOptions + 1, nLeft + nMaxwidth BOX B_SINGLE + ' '
Devpos( nTop, nLeft )
FOR x := 1 to Len( aMenuInfo )
IF Len( aMenuInfo[x] ) > 1 .AND. aMenuInfo[x,2] != NIL
@ Row() + 1, nLeft PROMPT Padr( aMenuInfo[x, 1], nMaxwidth ) ;
MESSAGE aMenuInfo[x,2]
ELSE
@ Row() + 1, nLeft PROMPT Padr( aMenuInfo[x,1], nMaxwidth )
ENDIF
NEXT
MENU TO nChoice
Restscreen( nTop, nLeft - 1, nTop + nOptions + 1, nLeft + nMaxwidth, cOldscreen )
/* execute action block attached to this option if there is one */
IF nChoice > 0 .AND. Len( aMenuInfo[ nChoice ] ) == 3
Eval( aMenuInfo[nChoice,3] )
ENDIF
ENDDO
/* restore previous message and wrap settings */
Set( _SET_MESSAGE, lOldmessrow )
Set( _SET_MCENTER, lOldcenter )
Set( _SET_WRAP, lOldwrap )
Set( _SET_COLOR, cOldcolor )
RETURN NIL
| vertmenu.prg | 119 |
| vidcur.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_SETVCUR( nPage, nRow, nCol )
FUNCTION FT_SETVCUR( nPage, nRow, nCol )
LOCAL aRegs[ INT86_MAX_REGS ]
nPage := iif( nPage == nil, FT_GETVPG() , nPage )
nRow := iif( nRow == nil, 0 , nRow )
nCol := iif( nCol == nil, 0 , nCol )
aRegs[ AX ] := MAKEHI( 2 )
aRegs[ BX ] := MAKEHI( nPage )
aRegs[ DX ] := MAKEHI( nRow ) + nCol
FT_INT86( VIDEO, aRegs )
RETURN ( NIL )
| vidcur.prg | 71 |
| FUNCTION | FT_GETVCUR( nPage )
FUNCTION FT_GETVCUR( nPage )
LOCAL aRegs[ INT86_MAX_REGS ]
nPage := iif( nPage == nil, FT_GETVPG(), nPage )
aRegs[ AX ] := MAKEHI( 3 )
aRegs[ BX ] := MAKEHI( nPage )
FT_INT86( VIDEO, aRegs )
RETURN ( { HIGHBYTE( aRegs[CX] ), LOWBYTE( aRegs[CX] ), HIGHBYTE( aRegs[DX] ), LOWBYTE( aRegs[DX] ) } )
| vidcur.prg | 132 |
| vidmode.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN( cMode )
FUNCTION MAIN( cMode )
FT_SETMODE( val( cMode ) )
QOut( "Video mode is: " + str( FT_GETMODE() ) )
return ( nil )
#endif
| vidmode.prg | 38 |
| FUNCTION | FT_SETMODE( nMode )
FUNCTION FT_SETMODE( nMode )
/*
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] = nMode
FT_INT86( VIDEO, aRegs )
*/
_ft_setmode(nMode)
RETURN( NIL )
| vidmode.prg | 78 |
| FUNCTION | FT_GETMODE()
FUNCTION FT_GETMODE()
/*
LOCAL aRegs[INT86_MAX_REGS]
aRegs[ AX ] := MAKEHI( GETMODE )
FT_INT86( VIDEO, aRegs )
RETURN ( LOWBYTE( aRegs[ AX ] ) )
*/
RETURN _ft_getmode()
| vidmode.prg | 121 |
| wda.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | main( cDate, cDays )
function main( cDate, cDays )
local nDays := ft_addWkDy( ctod(cDate), val(cDays) )
qout( "Num days to add: " + str( nDays ) )
qout( "New date: " + dtoc( ctod( cDate ) + nDays ) )
return nil
| wda.prg | 69 |
| FUNCTION | ft_addWkDy( dStart, nDys )
FUNCTION ft_addWkDy( dStart, nDys )
LOCAL nDc := dow( dStart )
RETURN ( iif( nDc == 7, ;
(nDys-1) % 5 + 7 * int( (nDys-1) / 5 ) + 2, ;
(nDys+nDc-2) % 5 + 7 * int( (nDys+nDc-2) / 5 ) + 2 - nDc ;
) ;
)
| wda.prg | 77 |
| week.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_WEEK( dGivenDate, nWeekNum )
FUNCTION FT_WEEK( dGivenDate, nWeekNum )
LOCAL lIsWeek, nTemp, aRetVal, dTemp
IF ! (VALTYPE(dGivenDate) $ 'ND')
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'N'
nWeekNum := dGivenDate
dGivenDate := DATE()
ENDIF
aRetVal := FT_YEAR(dGivenDate)
dTemp := aRetVal[2]
aRetVal[2] -= FT_DAYTOBOW( aRetVal[2] )
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
dGivenDate += ( 6 - FT_DAYTOBOW(dGivenDate) ) // end of week
aRetVal[1] += PADL(LTRIM(STR(INT( (dGivenDate - ;
aRetVal[2]) / 7 ) + 1, 2)), 2, '0')
aRetVal[2] := MAX( dGivenDate - 6, dTemp )
aRetVal[3] := MIN( dGivenDate, aRetVal[3] )
RETURN aRetVal
| week.prg | 88 |
| workdays.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | main( cStart, cStop )
function main( cStart, cStop )
return qout( ft_workdays( ctod( cStart ), ctod( cStop ) ) )
| workdays.prg | 61 |
| FUNCTION | FT_WorkDays( dStart, dStop )
FUNCTION FT_WorkDays( dStart, dStop )
LOCAL nWorkDays := 0, nDays, nAdjust
IF dStart # NIL .AND. dStop # NIL
IF dStart # dStop
IF dStart > dStop // Swap the values
nAdjust := dStop
dStop := dStart
dStart := nAdjust
ENDIF
IF ( nDays := Dow( dStart ) ) == 1 // Sunday (change to next Monday)
dStart++
ELSEIF nDays == 7 // Saturday (change to next Monday)
dStart += 2
ENDIF
IF ( nDays := Dow( dStop ) ) == 1 // Sunday (change to prev Friday)
dStop -= 2
ELSEIF nDays == 7 // Saturday (change to prev Friday)
dStop--
ENDIF
nAdjust := ( nDays := dStop - dStart + 1 ) % 7
IF Dow( dStop ) + 1 < Dow( dStart ) // Weekend adjustment
nAdjust -= 2
ENDIF
nWorkDays := Int( nDays / 7 ) * 5 + nAdjust
ELSEIF ( Dow( dStart ) # 1 .AND. Dow( dStart ) # 7 )
nWorkDays := 1
ENDIF
ENDIF
RETURN ( IIF(nWorkDays>0,nWorkDays,0) )
| workdays.prg | 66 |
| woy.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN( cCent )
FUNCTION MAIN( cCent )
LOCAL lCentOn := .F., cDate
MEMVAR getlist
IF VALTYPE( cCent) == "C" .AND. "CENT" $ UPPER( cCent)
SET CENTURY ON
lCentOn := .T.
END
DO WHILE .T.
CLEAR
@ 2,10 SAY "Date to Test"
IF lCentOn
cDate := SPACE(10)
@ 2,24 GET cDate PICTURE "##/##/####"
ELSE
cDate := SPACE(8)
@ 2,24 GET cDate PICTURE "##/##/##"
END
READ
IF EMPTY(cDate)
EXIT
END
IF DTOC( CTOD( cDate) ) = " "
QQOUT( CHR( 7) )
@ 4,24 SAY "INVALID DATE"
INKEY(2)
LOOP
END
@ 4,10 SAY "Is Day Number " + STR( FT_DOY( CTOD( cDate)) ,3)
@ 6,10 SAY "Is in Week Number " + STR( FT_WOY( CTOD( cDate)) ,2)
@ 7,0
WAIT
END
CLEAR
RETURN nil
#endif
| woy.prg | 33 |
| FUNCTION | FT_WOY(dInDate)
FUNCTION FT_WOY(dInDate)
LOCAL nFirstDays, nDayOffset, nWkNumber, cCentury
IF VALTYPE( dInDate) != "D"
nWkNumber := NIL
ELSE
// resolve century issue
IF LEN( DTOC( dInDate) ) > 8 // CENTURY is on
cCentury := SUBSTR( DTOC( dInDate) ,7 ,4)
ELSE
cCentury := SUBSTR( DTOC( dInDate) ,7 ,2)
END
// find number of days in first week of year
nFirstDays := 8 - (DOW (CTOD ("01/01/" + cCentury) ) )
nWkNumber := 1
// find how many days after first week till dInDate
nDayOffset := (dInDate - ;
CTOD ("01/01/" + cCentury) ) - nFirstDays + 1
// count weeks in offset period
DO WHILE nDayOffset > 0
++nWkNumber
nDayOffset -= 7
END
END
RETURN (nWkNumber)
| woy.prg | 123 |
| FUNCTION | FT_DOY(dInDate)
FUNCTION FT_DOY(dInDate)
LOCAL nDayNum, cCentury
IF VALTYPE(dInDate) != "D"
nDayNum := NIL
ELSE
// resolve century issue
IF LEN( DTOC( dInDate) ) > 8 // CENTURY is on
cCentury := SUBSTR( DTOC( dInDate) ,7 ,4)
ELSE
cCentury := SUBSTR( DTOC( dInDate) ,7 ,2)
END
// calculate
nDayNum := (dInDate - CTOD ("01/01/" + cCentury)) + 1
END
RETURN (nDayNum)
| woy.prg | 207 |
| xbox.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | MAIN()
FUNCTION MAIN()
local i
setcolor('W/B')
* clear screen
for i = 1 to 24
@ i, 0 say replicate('@', 80)
next
FT_XBOX(,,,,,,,'This is a test','of the XBOX() function')
FT_XBOX('L','W','D','GR+/R','W/B',1,10,'It is so nice',;
'to not have to do the messy chore',;
'of calculating the box size!')
FT_XBOX(,'W','D','GR+/R','W/B',16,10,'It is so nice',;
'to not have to do the messy chore',;
'of calculating the box size!',;
'Even though this line is way too long, and is in fact more than 80 characters long, if you care to check!')
return ( nil )
| xbox.prg | 113 |
| FUNCTION | FT_XBOX(cJustType, cRetWait, cBorType, cBorColor, cBoxColor, nStartRow, nStartCol, cLine1, cLine2, cLine3, cLine4, cLine5, cLine6, cLine7, cLine8)
FUNCTION FT_XBOX(cJustType,; // "L" = left, otherwise centered
cRetWait, ; // "W" = wait for keypress before continuing
cBorType, ; // "D" = double, anything else single border
cBorColor,; // color string for border
cBoxColor,; // color string for text
nStartRow,; // upper row of box. 99=center vertically
nStartCol,; // left edge of box. 99=center horizontally
cLine1, cLine2, cLine3, cLine4, cLine5, cLine6, cLine7, cLine8)
LOCAL nLLen := 0, ;
cOldColor, ;
nLCol, ;
nRCol, ;
nTRow, ;
nBRow, ;
nLoop, ;
nSayRow, ;
nSayCol, ;
nNumRows, ;
aLines_[8]
// validate parameters
cJustType := if(ValType(cJustType)='C',Upper(cJustType),'')
cRetWait := if(ValType(cRetWait )='C',Upper(cRetWait), '')
cBorType := if(ValType(cBorType )='C',Upper(cBorType), '')
cBorColor := if(ValType(cBoxColor)='C',cBorColor, 'N/W')
cBoxColor := if(ValType(cBoxColor)='C',cBoxColor, 'W/N')
nStartRow := if(ValType(nStartRow)='N',nStartRow,99)
nStartCol := if(ValType(nStartCol)='N',nStartCol,99)
nNumRows := Min(PCount()-7,8)
//establish array of strings to be displayed
aLines_[1] := if(ValType(cLine1) = 'C',AllTrim(SubStr(cLine1,1,74)),'')
aLines_[2] := if(ValType(cLine2) = 'C',AllTrim(SubStr(cLine2,1,74)),'')
aLines_[3] := if(ValType(cLine3) = 'C',AllTrim(SubStr(cLine3,1,74)),'')
aLines_[4] := if(ValType(cLine4) = 'C',AllTrim(SubStr(cLine4,1,74)),'')
aLines_[5] := if(ValType(cLine5) = 'C',AllTrim(SubStr(cLine5,1,74)),'')
aLines_[6] := if(ValType(cLine6) = 'C',AllTrim(SubStr(cLine6,1,74)),'')
aLines_[7] := if(ValType(cLine7) = 'C',AllTrim(SubStr(cLine7,1,74)),'')
aLines_[8] := if(ValType(cLine8) = 'C',AllTrim(SubStr(cLine8,1,74)),'')
ASize(aLines_,Min(nNumRows,8))
// determine longest line
nLoop := 1
AEVAL(aLines_,{|| nLLen:=Max(nLLen,Len(aLines_[nLoop])),nLoop++})
// calculate corners
nLCol = if(nStartCol=99,Int((76-nLLen)/2),Min(nStartCol,74-nLLen))
nRCol = nLCol+nLLen+3
nTRow = if(nStartRow=99,INT((24-nNumRows)/2),Min(nStartRow,22-nNumRows))
nBRow = nTRow+nNumRows+1
// form box and border
// save screen color and set new color
cOldColor = SetColor(cBoxColor)
@ nTRow,nLCol Clear to nBRow,nRCol
// draw border
SetColor(cBorColor)
IF cBorType = "D"
@ nTRow,nLCol TO nBRow,nRCol double
ELSE
@ nTRow,nLCol TO nBRow,nRCol
ENDIF
// write shadow
FT_SHADOW(nTRow,nLCol,nBRow,nRCol)
// print text in box
SetColor(cBoxColor)
nLoop :=1
AEVAL(aLines_,{|cSayStr|;
nSayRow := nTRow+nLoop,;
nSayCol := if(cJustType = 'L',;
nLCol+2,;
nLCol+2+(nLLen-Int(Len(aLines_[nLoop])))/2),;
nLoop++,;
_FTSAY(nSayRow,nSayCol,cSayStr);
})
// wait for keypress if desired
IF cRetWait ='W'
Inkey(0)
ENDIF
RETURN NIL
| xbox.prg | 134 |
| STATIC FUNCTION | _FTSAY(nSayRow,nSayCol,cSayStr)
STATIC FUNCTION _FTSAY(nSayRow,nSayCol,cSayStr)
@ nSayRow,nSayCol SAY cSayStr
RETURN NIL
| xbox.prg | 225 |
| year.prg |
| Type | Function | Source | Line |
|---|
| FUNCTION | FT_YEAR(dGivenDate)
FUNCTION FT_YEAR(dGivenDate)
LOCAL aRetVal[3], cFY_Start, cDateFormat
cFY_Start := FT_DATECNFG()[1]
cDateFormat := SET(_SET_DATEFORMAT, "yyyy.mm.dd")
IF( VALTYPE(dGivenDate) != 'D', dGivenDate := DATE(), )
aRetVal[2] := CTOD(STR( YEAR(dGivenDate) - IF(MONTH(dGivenDate) < ;
MONTH(CTOD(cFY_Start)), 1, 0), 4) + ;
SUBSTR(cFY_Start, 5, 6) )
aRetval[3] := FT_MADD(aRetVal[2], 12) - 1
aRetVal[1] := STR(YEAR(aRetVal[3]),4) // End of Year
SET(_SET_DATEFORMAT, cDateFormat)
RETURN aRetVal
| year.prg | 79 |
|