HB_FUNC( FT_ALT )
{
   HB_GT_INFO gtInfo;

   gtInfo.pNewVal = gtInfo.pResult = NULL;
   hb_gtInfo( HB_GTI_KBDSHIFTS, >Info );
   hb_retl( ( hb_itemGetNI( gtInfo.pResult ) & HB_GTI_KBD_ALT ) != 0 );
   if( gtInfo.pResult )
      hb_itemRelease( gtInfo.pResult );
}

HB_FUNC( FT_CAPLOCK )
{
   int iState = 0, iNewState;
   HB_GT_INFO gtInfo;

   gtInfo.pNewVal = gtInfo.pResult = NULL;
   hb_gtInfo( HB_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 | HB_GTI_KBD_CAPSLOCK ) :
                                 ( iState & ~HB_GTI_KBD_CAPSLOCK );
      gtInfo.pNewVal = hb_itemPutNI( gtInfo.pNewVal, iNewState );
      hb_gtInfo( HB_GTI_KBDSHIFTS, >Info );
   }

   if( gtInfo.pNewVal )
      hb_itemRelease( gtInfo.pNewVal );
   if( gtInfo.pResult )
      hb_itemRelease( gtInfo.pResult );

   hb_retl( ( iState & HB_GTI_KBD_CAPSLOCK ) != 0 );
}

HB_FUNC( FT_CHDIR)
{
   hb_retl( ISCHAR( 1 ) && hb_fsChDir( ( BYTE * ) hb_parc(1) ) );
}

HB_FUNC( FT_COLOR2N )
{
   int iRet = 0;

   if( ISCHAR( 1 ) )
   {
      iRet = hb_gtColorToN( hb_parc( 1 ) );
      if( iRet == -1 )
         iRet = 0;
   }

   hb_retni( iRet );
}

HB_FUNC( FT_CTRL )
{
   HB_GT_INFO gtInfo;

   gtInfo.pNewVal = gtInfo.pResult = NULL;
   hb_gtInfo( HB_GTI_KBDSHIFTS, >Info );
   hb_retl( ( hb_itemGetNI( gtInfo.pResult ) & HB_GTI_KBD_CTRL ) != 0 );
   if( gtInfo.pResult )
      hb_itemRelease( gtInfo.pResult );
}

HB_FUNC( FT_DESCEND )
{
#if defined(HB_OS_DOS) || defined(HB_OS_WIN_32)
   {

      auto PHB_ITEM iP = hb_itemParam( 1 );
      auto HB_TYPE 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
}

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;
}

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);
}

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;
    }
}

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;
    }
}

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( ( SHORT ) sline, ( SHORT ) scol, ( SHORT ) eline, ( SHORT ) ecol, vseg );
}

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();
        }
}

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();
        }
}

static void linedown()
{
    if ( winrow < eline )       /* if cursor not at last line */
        winrow += 1;
    else                        /* otherwise adjust the window top variable */
        windown();
}

static void lineup()
{
    if ( winrow > sline )
        winrow -= 1;
    else
        winup();
}

static void filetop()
{
    if ( buffoffset != 0 )
    {
        buffoffset = getblock(0L);

        buff_align();
    }

    refresh = YES;
    wintop  = (int) buffoffset;
    winrow  = sline;
    wincol  = 0;

    win_align();
}

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();
}

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( ( SHORT ) sline, ( SHORT ) scol, ( SHORT ) eline, ( SHORT ) 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( ( SHORT ) sline, ( SHORT ) scol, ( SHORT ) eline, ( SHORT ) ecol, vseg );

    }

    hb_retni(rval);
}

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);
    }
}

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( ( SHORT ) sline, ( SHORT ) scol, ( SHORT ) eline, ( SHORT ) ecol, vseg );

            /* main processing loop -- terminated by user key press */

        do
        {
            if ( refresh == YES )           /* redraw window contents? */
                disp_update(wintop);

                hb_gtRest( ( SHORT ) sline, ( SHORT ) scol, ( SHORT ) eline, ( SHORT ) ecol, vseg );

                /* if not browse, highlight the current line */

            if ( brows == NO )
                chattr(0, winrow - sline, width, hlight);

            hb_gtRest( ( SHORT ) sline, ( SHORT ) scol, ( SHORT ) eline, ( SHORT ) ecol, vseg );

            hb_gtSetPos( ( SHORT ) winrow, ( SHORT ) 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( ( SHORT ) sline, ( SHORT ) scol, ( SHORT ) eline, ( SHORT ) 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 );
}

static int keyin()
{
    return hb_inkey( TRUE, 0.0, INKEY_ALL );
}

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;
}

HB_FUNC( FT_SAVEATT )
{
   USHORT uiTop    = ( USHORT ) hb_parni( 1 ); /* Defaults to zero on bad type */
   USHORT uiLeft   = ( USHORT ) hb_parni( 2 ); /* Defaults to zero on bad type */
   USHORT uiMaxRow = hb_gtMaxRow();
   USHORT uiMaxCol = hb_gtMaxCol();
   USHORT uiBottom = ISNUM( 3 ) ? ( USHORT ) hb_parni( 3 ) : uiMaxRow;
   USHORT uiRight  = ISNUM( 4 ) ? ( USHORT ) 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$
 *
 */

HB_FUNC( FT_RESTATT )
{
   ULONG ulLen = hb_parclen( 5 );
   if( ulLen )
   {
      USHORT uiTop    = ( USHORT ) hb_parni( 1 ); /* Defaults to zero on bad type */
      USHORT uiLeft   = ( USHORT ) hb_parni( 2 ); /* Defaults to zero on bad type */
      USHORT uiMaxRow = hb_gtMaxRow();
      USHORT uiMaxCol = hb_gtMaxCol();
      USHORT uiBottom = ISNUM( 3 ) ? ( USHORT ) hb_parni( 3 ) : hb_gtMaxRow();
      USHORT uiRight  = ISNUM( 4 ) ? ( USHORT ) 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;
         }
      }
   }
}

HB_FUNC(FT_Idle)
{
   hb_idleState();
}

HB_FUNC( FT_ISPRINT )
{
   HB_FUNC_EXEC( HB_ISPRINT )
}

HB_FUNC( FT_SHADOW )
{
   HB_FUNC_EXEC( HB_SHADOW );
}

HB_FUNC( FT_SETATTR )
{
   hb_gtSetAttribute( ( SHORT ) hb_parni( 1 ), 
                      ( SHORT ) hb_parni( 2 ),
                      ( SHORT ) hb_parni( 3 ), 
                      ( SHORT ) hb_parni( 4 ), 
                      ( BYTE ) hb_parni( 5 ) );
}

HB_FUNC( FTSETINT )
{
   doInt ^= 0xFF;
}

HB_FUNC( FT_FOFFSET )
{
   hb_retnl( offset[area] );
}

HB_FUNC( FT_FUSE )
{
   int attr = ISNUM( 2 ) ? hb_parni(2) : FO_READWRITE|FO_DENYNONE;

   error[area] = 0;

   if ( ISCHAR(1) )
   {
      handles[area] = hb_fsOpen( ( BYTE * ) hb_parc(1), ( USHORT ) attr ) ;
      if( handles[area] <= 0 )
         error[area] = hb_fsError();
      offset[area] = 0 ;
      recno[area] = 1;
      lastbyte[area] = hb_fsSeek( handles[area], 0L, FS_END );
      hb_retni( handles[area] );
   }
   else
   {
      if ( handles[area] != 0 )
      {
         hb_fsClose( handles[area] );
         hb_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;
      }
   }
}

HB_FUNC( FT_FSELECT )
{
   int   oldarea = area + 1;
   int   newArea;

   if ( ISNUM(1) )
   {
      newArea = hb_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;
      }
   }
   hb_retni( oldarea );
}

HB_FUNC( FT_FGOTOP )
{
   error[area]  = 0;
   offset[area] = 0L;
   recno[area]  = 1L;
   isBof[area]  = FALSE;
   isEof[area]  = FALSE;
}

HB_FUNC( FT_FERROR )
{
   hb_retni( error[area] );
}

HB_FUNC( FT_FRECNO )
{
   hb_retnl( recno[area] );
}

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;

}

HB_FUNC( FT_FSKIP )
{
   if ( ISNUM(1) )
   {
       if( hb_parnl(1) )
          hb_retnl( _ft_skip( hb_parnl(1) ) );
       else
          hb_retnl( 0L );
   }
   else
      hb_retnl( _ft_skip(1L) );
}

static long _ft_skip( long iRecs )
{

   int          iByteCount;
   int          iBytesRead, iBytesRemaining;
   BYTE *       cPtr;
   long         iSkipped = 0;

   BYTE *       cBuff    = ( BYTE * ) 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 */
         hb_fsSeek( handles[area], fpOffset, FS_SET );

         /* read a chunk */
         iBytesRead = hb_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]    = hb_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        = hb_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 */
            hb_fsSeek( handles[area], fpOffset, FS_SET );

            /* read a chunk */
            iBytesRead =
                  hb_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] = hb_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 );
}

HB_FUNC( FT_FREADLN )
{

   int        iByteCount;
   int        iBytesRead;
   BYTE *     cPtr = ( BYTE * ) hb_xgrab( BUFFSIZE );

   hb_fsSeek( handles[area], offset[area], FS_SET );
   iBytesRead = (int) hb_fsReadLarge( handles[area], cPtr, BUFFSIZE );

   error[area] = 0;

   if( !iBytesRead )
   {
      error[area] = hb_fsError();
   }

   iByteCount = _findeol( cPtr, iBytesRead );

   if( iByteCount )
      hb_retclen( ( char * ) cPtr, iByteCount-2 );
   else
      hb_retclen( ( char * ) cPtr, iBytesRead );

   hb_xfree( ( void * ) cPtr );
}

HB_FUNC( FT_FDELETE )
{
   int    iBytesRead ;
   long   srcPtr     ;
   long   destPtr    ;
   long   cur_rec  = recno[area];
   long   cur_off  = offset[area];
   BYTE * Buff     = ( BYTE * ) hb_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 ) ? hb_parni( 1 ) : 1 ) ) ;
   srcPtr = hb_fsSeek( handles[area], offset[area], FS_SET );

   /* buffer read retained data, write atop old data */
   do
   {
      hb_fsSeek( handles[area], srcPtr, FS_SET );
      iBytesRead  = hb_fsRead( handles[area], Buff , BUFFSIZE );   /* now read in a big glob */
      srcPtr  += iBytesRead;
      hb_fsSeek( handles[area], destPtr, FS_SET );
      destPtr += hb_fsWriteLarge( handles[area], Buff, iBytesRead );
   } while( iBytesRead > 0 );


   /* move DOS EOF marker */
   hb_fsSeek( handles[area],  srcPtr, FS_SET );
   hb_fsWrite( handles[area], Buff, 0 );

   error[area] = hb_fsError();

   /* restore pointers */
   recno[area] = cur_rec;
   offset[area]= cur_off;

   /* re_calc EOF */
   lastbyte[area] = hb_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 );

   hb_retl( (error[area]) ? 0 : 1 );
}

HB_FUNC( FT_FINSERT )
{
   int   no_lines = ( ISNUM( 1 ) ? hb_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] = hb_fsError();
            err = 0;
            break;
         }
   }

   hb_retl( err );
}

HB_FUNC( FT_FAPPEND )
{
   int   no_lines = ( ISNUM( 1 ) ? hb_parni( 1 ) : 1 );
   int   iRead;
   int   iByteCount;

   BYTE  * buff = ( BYTE * ) hb_xgrab( BUFFSIZE );

   error[area] = 0;

/* go to end of file */

   HB_FUNC_EXEC( FT_FGOBOT );

/* find end of record */

   hb_fsSeek( handles[area], offset[area], FS_SET );
   iRead = hb_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( ( BYTE * ) buff, iRead );
   if( iByteCount == 0 )
      hb_fsSeek( handles[area], 0, FS_END );
   else
   {
      offset[area] = hb_fsSeek( handles[area], offset[area] + iByteCount, FS_SET );
      recno[area]++;
      no_lines--;
   }

   while( no_lines-- )
   {
      if( !_writeeol( handles[area] ) )
      {
         error[area] = hb_fsError();
         break;
      }
      recno[area]++;
      offset[area] = hb_fsSeek( handles[area], 0, FS_RELATIVE );
/*    no_lines--;  !Harbour FIX! */
   }

   if( !error[area] )
   {
      /* move DOS eof marker */
      hb_fsWrite( handles[area], buff, 0 );
      error[area] = hb_fsError();
   }

   /* force recalc of last record/offset */
   last_rec[area] = 0;

   hb_xfree( ( void * ) buff );

   hb_retl( (error[area]) ? 0 : 1 );

}

HB_FUNC( FT_FWRITEL )
{
   BYTE *   theData  = ( BYTE * ) hb_parc( 1 );
   int      iDataLen = hb_parclen( 1 );
   int      lInsert  = ( ISLOG( 2 ) ? hb_parl( 2 ) : 0 );
   int      err;
   int      iLineLen = 0;
   int      iRead, iEOL;

   BYTE *   buffer;


   /* position file pointer to insertion point */
   hb_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 )
      {
         hb_fsSeek( handles[area], offset[area], FS_SET );
         err = _writeLine( theData, iDataLen );
      }
   }
   else
   {
      /* overwrite mode, determine how many bytes over/under */
      buffer = ( BYTE * ) hb_xgrab( BUFFSIZE );

      /* find length of current line, loop if longer than buffer */
      do
      {
         iRead = hb_fsRead( handles[area], buffer, BUFFSIZE );
         iEOL  = _findeol( ( BYTE * ) 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 */
         hb_fsWriteLarge( handles[area], theData, iDataLen );
        }
      else
      {
         /* insert extra bytes into current record */
         _ins_buff( iDataLen - iLineLen + 2 );

         /* write the new record's contents */
         hb_fsWriteLarge( handles[area], theData, iDataLen );
      }
      error[area] = hb_fsError();
      err = (error[area]) ? 0 : 1;
   }
   hb_retl( err );
}

HB_FUNC( FT_FLASTRE )
{
   long cur_rec;
   long cur_offset;

   cur_rec      = recno[area];
   cur_offset   = offset[area];

   HB_FUNC_EXEC( FT_FGOBOT );
   hb_retnl( last_rec[area] );

   recno[area]  = cur_rec;
   offset[area] = cur_offset;
}

HB_FUNC( FT_FEOF )
{
   hb_retl( isEof[area] );
}

HB_FUNC( FT_FBOF )
{
   hb_retl( isBof[area] );
}

HB_FUNC( FT_FGOTO )
{
   long   target = hb_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] = hb_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)

------------------------------------------------------------------------*/
static int _findeol( BYTE * 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).

------------------------------------------------------------------------*/
static int _findbol( BYTE * buf, int buf_len )
{
   int tmp = buf_len - 1;

   if( tmp != 0 )
   {
      BYTE * 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() */

/* 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 )
{

   BYTE *   ReadBuff    = ( BYTE * ) hb_xgrab( BUFFSIZE );
   BYTE *   WriteBuff   = ( BYTE * ) hb_xgrab( BUFFSIZE );
   BYTE *   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 */
   hb_fsSeek( handles[area], fpRead, FS_SET );
   WriteLen = hb_fsRead( handles[area], WriteBuff, BUFFSIZE );
   fpRead += WriteLen;

   ReadLen = hb_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( hb_fsSeek( handles[area], fpWrite, FS_SET ) != (unsigned long) fpWrite )
         {
            error[area] = hb_fsError();
            break;
         }

         SaveLen = hb_fsWriteLarge( handles[area], WriteBuff, WriteLen );

         if( !SaveLen )
         {
            error[area] = hb_fsError();
            break;
         }

         /* move write pointer */
         fpWrite += SaveLen;

         if(  SaveLen != WriteLen )
         {
            /* error, fetch errcode and quit */
            error[area] = hb_fsError();
            break;
         }
         /* WriteLen = SaveLen; */

         /* swap buffers */
         SaveBuff  = WriteBuff;
         WriteBuff = ReadBuff ;
         ReadBuff  = SaveBuff ;
         WriteLen  = ReadLen  ;

         /* return to read area and read another buffer */
         hb_fsSeek( handles[area], fpRead, FS_SET );
         ReadLen = hb_fsRead( handles[area], ReadBuff, BUFFSIZE );
         fpRead += ReadLen;
      }

      iLen = __min( iLenRemaining, BUFFSIZE );
      iLenRemaining -= iLen;
   }

   /* store length in bytes, set EOF marker for DOS */
   lastbyte[area] = hb_fsSeek( handles[area], fpWrite, FS_SET );
   hb_fsWrite( handles[area], WriteBuff, 0 );

   /* clear last_rec so next gobot will recount the records */
   last_rec[area] = 0L;
   hb_fsSeek( handles[area], offset[area], FS_SET );

   hb_xfree( ( void * ) ReadBuff  );
   hb_xfree( ( void * ) WriteBuff );

   return error[area];
}

static int _del_buff( int iLen )
{
   BYTE *   WriteBuff   = ( BYTE * ) 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 */
   hb_fsSeek( handles[area], fpRead, FS_SET );
   WriteLen = hb_fsRead( handles[area], WriteBuff, BUFFSIZE );
   fpRead += WriteLen;

   error[area] = 0;

   while( WriteLen > 0 )
   {
      /* position to beginning of write area */
      hb_fsSeek( handles[area], fpWrite, FS_SET );
      SaveLen = hb_fsWriteLarge( handles[area], WriteBuff, WriteLen );

      /* move write pointer */
      fpWrite += SaveLen;

      if(  SaveLen != WriteLen )
      {
         /* error, fetch errcode and quit */
         error[area] = hb_fsError();
         break;
      }

      /* return to read area and read another buffer */
      hb_fsSeek( handles[area], fpRead, FS_SET );
      WriteLen = hb_fsRead( handles[area], WriteBuff, BUFFSIZE );
      fpRead  += WriteLen;
   }


   /* store length in bytes, set EOF marker for DOS */
   lastbyte[area] = hb_fsSeek( handles[area], fpWrite, FS_SET );
   hb_fsWrite( handles[area], WriteBuff, 0 );

   /* clear last_rec so next gobot will recount the records */
   last_rec[area] = 0L;
   hb_fsSeek( handles[area], offset[area], FS_SET );

   hb_xfree( ( void * ) WriteBuff );

   return error[area];
}

static int _writeLine( BYTE * theData, ULONG iDataLen )
{
   int   err   = 0;

   if( !( hb_fsWriteLarge( handles[area], theData, iDataLen ) == ( ULONG ) iDataLen ) )
   {
      err = 1;
      error[area] = hb_fsError();
   }
   else
      if( !_writeeol( handles[area] ) )
      {
         err = 1;
         error[area] = hb_fsError();
      }
   return err;
}

static BOOL _writeeol( HB_FHANDLE fhnd )
{
   char * crlf = hb_conNewLine();
   ULONG len = strlen( crlf );

   return hb_fsWriteLarge( fhnd, ( BYTE * ) crlf, len ) == ( ULONG ) len;
}

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(HB_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_xgrab( 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 */
            hb_strncat( buffer, environ[x], buffsize );
            /* add crlf at end of each string */
            hb_strncat( buffer, CRLF, buffsize );
         }
         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;
      LPTCH lpEnviron = GetEnvironmentStrings();
      char *sCurEnv;
      int x;
      int buffsize = 0;
      int rettype = NORETURN;

      char * szEnviron = HB_TCHAR_CONVFROM( lpEnviron );

      if( ISCHAR( 1 ) )
         rettype = CHARTYPE;
      if( ISARRAY( 1 ) )
         rettype = ARRAYTYPE;

      if( rettype == CHARTYPE )
         /* scan strings first and add up total size */
      {
         for( sCurEnv = szEnviron; *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 );

            while( *sCurEnv )
               sCurEnv++;
         }
         /* 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_xgrab( buffsize + 1 );
         buffer[0] = '\0';
      }
      x = 0;
      for( sCurEnv = szEnviron; *sCurEnv; sCurEnv++ )
      {
         if( !*sCurEnv )
            /* null string, we're done */
            break;

         if( rettype == CHARTYPE )
         {
            /* tack string onto end of buffer */
            hb_strncat( buffer, ( char * ) sCurEnv, buffsize );
            /* add crlf at end of each string */
            hb_strncat( buffer, CRLF, buffsize );
         }

         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 );

      HB_TCHAR_FREE( szEnviron );
      FreeEnvironmentStrings( ( LPTSTR ) lpEnviron );
   }

#endif
}

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
}

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 );
}

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 );
}

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
}

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 );
}

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 );
   }
}

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 );
}

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
}

HB_FUNC( FT_IAMIDLE )
{
   hb_releaseCPU();
}

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
}

HB_FUNC(FT_MKDIR)
{
   hb_retl( ISCHAR( 1 ) && hb_fsMkDir( ( BYTE * ) hb_parc(1) ) );
}

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 );
}

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
}

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 );
   }
}

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 );
}

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 );
}

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 );
}

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
}

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
}

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 );
   }
}

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 );
   }
}

HB_FUNC( _MSE_SHOWCURS )
{
#if defined(HB_OS_DOS)
   {
      union REGS regs;
      regs.HB_XREGS.ax = 1;
      HB_DOS_INT86( 0x33, ®s, ®s );
   }
#endif
}

HB_FUNC( _MSE_MHIDECRS )
{
#if defined(HB_OS_DOS)
   {
      union REGS regs;
      regs.HB_XREGS.ax = 2;
      HB_DOS_INT86( 0x33, ®s, ®s );
   }
#endif
}

HB_FUNC( _MSE_GETPOS )
{
   int iHori;
   int iVert;
#if defined(HB_OS_DOS)
   {
      union REGS regs;
      regs.HB_XREGS.ax = 3;
      HB_DOS_INT86( 0x33, ®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 );
   }
}

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 );
}

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 );
}

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
}

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
}

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
}

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
}

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 );
   }
}

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
}

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
}

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 );
   }
}

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 );
}

HB_FUNC( FT_NUMLOCK )
{
   int iState = 0, iNewState;
   HB_GT_INFO gtInfo;

   gtInfo.pNewVal = gtInfo.pResult = NULL;
   hb_gtInfo( HB_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 | HB_GTI_KBD_NUMLOCK ) :
                                 ( iState & ~HB_GTI_KBD_NUMLOCK );
      gtInfo.pNewVal = hb_itemPutNI( gtInfo.pNewVal, iNewState );
      hb_gtInfo( HB_GTI_KBDSHIFTS, >Info );
   }

   if( gtInfo.pNewVal )
      hb_itemRelease( gtInfo.pNewVal );
   if( gtInfo.pResult )
      hb_itemRelease( gtInfo.pResult );

   hb_retl( ( iState & HB_GTI_KBD_NUMLOCK ) != 0 );
}

static void cdecl TickTock( void )
{
   auto unsigned int ProtMode = cpmiIsProtected();
   auto LONGPTR Timer;
   auto HB_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;

      hb_evalNew( &eval, codeBlock );

      hb_itemRelease( hb_evalLaunch( &eval ) );
   }

   if ( ProtMode ) cpmiFreeSelector( Timer.Pointer.Segment );

   Exit: inProgress = 0;

   return;
}

CLIPPER FT_OnTick( void )
{
   if ( hb_itemType( codeBlock ) == BLOCK ) hb_itemRelease( codeBlock );

   codeBlock = hb_itemParam( 1 );

   if ( hb_itemType( codeBlock ) == BLOCK )
   {
      Interval = hb_parnl( 2 );

      _evLow( 5, TickTock, TRUE );
   }
   else
      _evLow( 5, TickTock, FALSE );

   return;
}

HB_FUNC( FT_ORIGIN )
{
   hb_retc( hb_cmdargARGV()[ 0 ] );
}

HB_FUNC(FT_PEEK)
{
   auto unsigned int ProtMode = cpmiIsProtected();
   auto unsigned char * bytePtr;

   if ( ( PCOUNT >= 2 ) && ( ISNUM( 1 ) ) && ( ISNUM( 2 ) ) )
   {
      FP_SEG( bytePtr ) = hb_parni( 1 );
      FP_OFF( bytePtr ) = hb_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: hb_retni( -1 );

   return;
}

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 ) = hb_parni( 1 );
      FP_OFF( bytePtr ) = hb_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 ) hb_parni( 3 );

      if ( ProtMode ) hb_cpmiFreeSelector( FP_SEG( bytePtr ) );

      hb_retl( TRUE );
   }
   else
      Bogus: hb_retl( FALSE );

   return;
}

static char _ftToLower( char c )
{
  return(c >= 'A' && c <= 'Z' ? c - 'A' + 'a' : c);
}

static char _ftToUpper( char c )
{
  return(c >= 'a' && c <= 'z' ? c - 'a' + 'A' : c);
}

static int _ftIsUpper( char c )
{
  return(c >= 'A' && c <= 'Z');
}

static int _ftIsLower( char c )
{
  return(c >= 'a' && c <= 'z');
}

static int _ftIsAlpha( char c )
{
  return( _ftIsUpper(c) || _ftIsLower(c));
}

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 );
}

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
}

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 );
}

HB_FUNC(FT_RMDIR)
{
   hb_retl( ISCHAR( 1 ) && hb_fsRmDir( ( BYTE * ) hb_parc(1) ) );
}

HB_FUNC( FT_SETKEYS )
{
   HB_FUNC_EXEC( HB_SETKEYSAVE )
}

HB_FUNC( FT_LASTKEY )
{
   HB_FUNC_EXEC( HB_SETLASTKEY )
}

HB_FUNC( FT_SHIFT )
{
   HB_GT_INFO gtInfo;

   gtInfo.pNewVal = gtInfo.pResult = NULL;
   hb_gtInfo( HB_GTI_KBDSHIFTS, >Info );
   hb_retl( ( hb_itemGetNI( gtInfo.pResult ) & HB_GTI_KBD_SHIFT ) != 0 );
   if( gtInfo.pResult )
      hb_itemRelease( gtInfo.pResult );
}

HB_FUNC(FT_STOD)
{
   hb_retds( hb_parclen( 1 ) >= 8 ? hb_parc( 1 ) : NULL );
}

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

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 )

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 iif(IS_NOT_ARRAY(aArray) .OR. LEN(aArray) == 0, ;
              0, ;
              FT_ASUM(aArray, nStartIndex, nEndIndex) / ;
                 (nEndIndex - nStartIndex + 1))

FUNCTION FT_ACCTADJ(dGivenDate, lIsEnd)
 
  LOCAL nTemp
 
  IF !( VALTYPE(dGivenDate) == "D" )
    dGivenDate := DATE()
  ENDIF

  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--
  ENDIF
 
RETURN dGivenDate

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
    ENDIF
    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

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
    ENDIF
    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

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
     ENDIF
     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

FUNCTION FT_ACCTYEAR(dGivenDate)
 
  LOCAL nYTemp, aRetVal
 
  IF !( VALTYPE(dGivenDate) == "D" )
    dGivenDate := DATE()
  ENDIF
 
  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

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 } ))

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

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 )

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

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 )

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  ] ;
            => ;
             := iif( == NIL,,) ;
         [;  := iif( == NIL,,)]

FUNCTION FT_AMEDIAN( aArray, nStart, nEnd )

   LOCAL nTemplen, aTemparray, nMiddle1, nMiddle2, nMedian

   DEFAULT nStart TO 1, ;
           nEnd   TO LEN( aArray )

   // Make Sure Bounds are in Range
   FORCE_BETWEEN(1, nEnd,   LEN( aArray ))
   FORCE_BETWEEN(1, nStart, nEnd)

   // Length of aTemparray
   nTemplen := ( nEnd - nStart ) + 1

   // Initialize aTemparray
   aTemparray := ACOPY( aArray, ARRAY( nTemplen ), nStart, nTemplen )

   // Sort aTemparray
   aTemparray := ASORT( aTemparray )

   // Determine middle value(s)
   IF ( nTemplen % 2 ) == 0
      nMiddle1 := aTemparray[ (nTemplen / 2) ]
      nMiddle2 := aTemparray[ INT(nTemplen / 2) +1 ]
      nMedian :=  INT( ( nMIddle1 + nMiddle2 ) / 2 )
   ELSE
      nMedian := aTemparray[ INT( nTemplen / 2 ) + 1 ]
   ENDIF

   RETURN ( nMedian )

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

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 := iif(IS_CHAR(xValueToConvert), ;
                                      ; // Convert from a Character
                               CTOD(xValueToConvert), ;
                               iif(IS_NUMERIC(xValueToConvert), ;
                                      ; // Convert from a Number
                                  xValueToConvert + EARLIEST_DATE, ;
                                  iif(IS_LOGICAL(xValueToConvert), ;
                                      ; // Convert from a Logical
                                     iif(xValueToConvert, DATE(), BLANK_DATE), ;
                                      ; // Unsupported Type
                                     BLANK_DATE)))

      CASE cTypeToConvertTo == "N" .AND.; // They Want a Number
           IS_NOT_NUMERIC(xValueToConvert)


         xValueToConvert := iif(IS_CHAR(xValueToConvert), ;
                                      ; // Convert from a Character
                               VAL(xValueToConvert), ;
                               iif(IS_DATE(xValueToConvert), ;
                                      ; // Convert from a Date
                                  xValueToConvert - EARLIEST_DATE, ;
                                  iif(IS_LOGICAL(xValueToConvert), ;
                                      ; // Convert from a Logical
                                     iif(xValueToConvert, 1, 0), ;
                                      ; // Unsupported Type
                                     0)))

      CASE cTypeToConvertTo == "L" .AND.; // They Want a Logical
           IS_NOT_LOGICAL(xValueToConvert)


         xValueToConvert := iif(IS_CHAR(xValueToConvert), ;
                                      ; // Convert from a Character
                               UPPER(xValueToConvert) == iif(lWantYesNo,"Y",".T."), ;
                               iif(IS_DATE(xValueToConvert), ;
                                      ; // Convert from a Date
                                  ! EMPTY(xValueToConvert), ;
                                  iif(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

   PROCEDURE Test
      * Thanks to Jim Gale for helping me understand the basics
      LOCAL i, ar[3, 26], aBlocks[3], aHeadings[3], nElem := 1, bGetFunc, cRet
      * set up 2 dimensional array ar[]
      FOR i = 1 TO 26
         ar[1, i] := i          //  1  ->  26  Numeric
         ar[2, i] := CHR(i+64)  // "A" -> "Z"  Character
         ar[3, i] := CHR(91-i)  // "Z" -> "A"  Character
      NEXT i
      * Set Up aHeadings[] for column headings
      aHeadings  := { "Numbers", "Letters", "Reverse" }
      * Set Up Blocks Describing Individual Elements in Array ar[]
      aBlocks[1] := {|| STR(ar[1, nElem], 2)}  // to prevent default 10 spaces
      aBlocks[2] := {|| ar[2, nElem]}
      aBlocks[3] := {|| ar[3, nElem]}
      * Set up TestGet() as bGetFunc
      bGetFunc   := {|b, ar, nDim, nElem|TestGet(b, ar, nDim, nElem)}

      SET SCOREBOARD OFF
      SetColor( "W/N")
      CLEAR SCREEN
      @ 21,4 SAY "Use Cursor Keys To Move Between Fields,  = Delete Row,  = Add Row"
      @ 22,7 SAY " = Quit Array Edit,  or  Edits Element"
      SetColor( "N/W, W/N, , , W/N" )
      cRet := FT_ArEdit(3, 5, 18, 75, ar, @nElem, aHeadings, aBlocks, bGetFunc)
      SetColor( "W/N")
      CLEAR SCREEN
      ? cRet
      ? "Lastkey() = ESC:", LASTKEY() == K_ESC
   RETURN

   FUNCTION TestGet( b, ar, nDim, nElem)
      LOCAL GetList   := {}
      LOCAL nRow      := ROW()
      LOCAL nCol      := COL()
      LOCAL cSaveScrn := SAVESCREEN(21, 0, 22, MaxCol())
      LOCAL cOldColor := SetColor( "W/N")
      @ 21, 0 CLEAR TO 22, MaxCol()
      @ 21,29 SAY "Editing Array Element"
      SetColor(cOldColor)
      DO CASE
         CASE nDim == 1
            @ nRow, nCol GET ar[1, nElem] PICTURE "99"
            READ
            b:refreshAll()
         CASE nDim == 2
            @ nRow, nCol GET ar[2, nElem] PICTURE "!"
            READ
            b:refreshAll()
         CASE nDim == 3
            @ nRow, nCol GET ar[3, nElem] PICTURE "!"
            READ
            b:refreshAll()
      ENDCASE
      RESTSCREEN(21, 0, 22, MaxCol(), cSaveScrn)
      @ nRow, nCol SAY ""
   RETURN(.t.)

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 iif(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 iif( VALTYPE(bGetFunc) == NIL .AND. nKey == K_ESC, ;
            0, ar[b:colPos, nElem] )
* EOFcn FT_ArEdit()

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, ;
                           iif(IS_CHAR(xElement),LEN(xElement),0) }) }, ;
         nStartIndex, nEndIndex - nStartIndex + 1)

   RETURN (nSumTotal)                   // FT_ASum

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

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 )

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 )

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

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

  FUNCTION MAIN()
     FT_BLINK( "WAIT", 5, 10 )
     return ( nil )

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 := iif( nRow == NIL, ROW(), nRow )
  nCol := iif( 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( iif( ("*" $ 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

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

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

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

FUNCTION FT_BYTENEG(cByte)
RETURN   iif(valtype(cByte) != "C", NIL, chr((256 - asc(cByte)) % 256))

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

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

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

  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 )

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

 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) )

 STATIC FUNCTION VALS (cString, nOffset, nChar)
 RETURN ( VAL(SUBSTR(cString,nOffset,nChar)) )

* end of calendar.prg

  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 := iif( "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

*------------------------------------------------

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 )

*------------------------------------------------

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

*------------------------------------------------

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

*------------------------------------------------

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

*------------------------------------------------

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

*------------------------------------------------

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 )

*------------------------------------------------

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

*------------------------------------------------

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

*------------------------------------------------

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

*------------------------------------------------

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

*------------------------------------------------

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

*------------------------------------------------

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

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

  function main( cNum, cPrec )
     DEFAULT cPrec TO str( DEFAULT_PRECISION )
     return qout( ft_d2e( val(cNum), val(cPrec) ) )

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 ) ) )

  FUNCTION DEMO()
     LOCAL nNum, dDate, aTestData := {}, aTemp, cFY_Start, nDOW_Start

*    SET DATE American                         // User's normal date format
     aTemp      := FT_DATECNFG()               // Get/Set cFY_Start & nDOW_Start.
*    aTemp      := FT_DATECNFG("03/01/80", 1)  // Date string in user's format.
     cFY_Start  := aTemp[1]                    // See FT_DATECNFG() in ft_date0.prg
     NDOW_START := ATEMP[2]                    // FOR PARAMETERS.
     DDATE      := DATE()
*    dDate      := CTOD("02/29/88")            // Test date, in user's normal date format

     cls
     ?    "Given       Date:  "
     ??   dDate
     ??   " cFY_Start: "+ cFY_Start
     ??   " nDOW_Start:" + STR(nDOW_Start,2)
     ?    "---- Fiscal Year Data -----------"

     aTestData := FT_YEAR(dDate)
     ? "FYYear     ", aTestData[1]+"  ", aTestData[2], aTestData[3]

     aTestData := FT_QTR(dDate)
     ? "FYQtr      ", aTestData[1], aTestData[2], aTestData[3]

     nNum      := VAL(SUBSTR(aTestData[1],5,2))
     aTestData := FT_QTR(dDate,nNum)
     ? "FYQtr    "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3]

     aTestData := FT_MONTH(dDate)
     ? "FYMonth    ", aTestData[1], aTestData[2], aTestData[3]

     nNum := VAL(SUBSTR(aTestData[1],5,2))
     aTestData := FT_MONTH(dDate,nNum)
     ? "FYMonth  "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3]

     aTestData := FT_WEEK(dDate)
     ? "FYWeek     ", aTestData[1], aTestData[2], aTestData[3]

     nNum      := VAL(SUBSTR(aTestData[1],5,2))
     aTestData := FT_WEEK(dDate,nNum)
     ? "FYWeek   "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3]

     aTestData := FT_DAYOFYR(dDate)
     ? "FYDay     ", aTestData[1], aTestData[2], aTestData[3]

     nNum      := VAL(SUBSTR(aTestData[1],5,3))
     aTestData := FT_DAYOFYR(dDate,nNum)
     ? "FYDAY   "+STR(nNum,3), aTestData[1], aTestData[2], aTestData[3]

     ?
     ? "---- Accounting Year Data -------"

     aTestData := FT_ACCTYEAR(dDate)
     ? "ACCTYear   ", aTestData[1]+"  ", aTestData[2], aTestData[3],;
           STR( (aTestData[3] - aTestData[2] + 1) /7, 3 ) + " Weeks"

     aTestData := FT_ACCTQTR(dDate)
     ? "ACCTQtr    ", aTestData[1], aTestData[2], aTestData[3],;
        STR( (aTestData[3] - aTestData[2] + 1) /7, 3 ) + " Weeks"

     nNum      := VAL(SUBSTR(aTestData[1],5,2))
     aTestData := FT_ACCTQTR(dDate,nNum)
     ? "ACCTQtr  "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3]

     aTestData := FT_ACCTMONTH(dDate)
     ? "ACCTMonth  ", aTestData[1], aTestData[2], aTestData[3],;
        STR( (aTestData[3] - aTestData[2] + 1) /7, 3 ) + " Weeks"

     nNum      := VAL(SUBSTR(aTestData[1],5,2))
     aTestData := FT_ACCTMONTH(dDate,nNum)
     ? "ACCTMonth"+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3]

     aTestData := FT_ACCTWEEK(dDate)
     ? "ACCTWeek   ", aTestData[1], aTestData[2], aTestData[3]

     nNum      := VAL(SUBSTR(aTestData[1],5,2))
     aTestData := FT_ACCTWEEK(dDate,nNum)
     ? "ACCTWeek "+STR(nNum,2), aTestData[1], aTestData[2], aTestData[3]

     aTestData := FT_DAYOFYR(dDate,,.T.)
     ? "ACCTDay   ", aTestData[1], aTestData[2], aTestData[3]

     nNum      := VAL(SUBSTR(aTestData[1],5,3))
     aTestData := FT_DAYOFYR(dDate,nNum,.T.)
     ? "ACCTDay "+STR(nNum,3), aTestData[1], aTestData[2], aTestData[3]

     WAIT

     FT_CAL(dDate)
     FT_CAL(dDate,1)

  RETURN NIL


  * DEMO Monthly Calendar function.
  * nType : 0 = FT_MONTH, 1 = FT_ACCTMONTH
  *

  FUNCTION FT_CAL(dGivenDate,nType)
     LOCAL nTemp, dTemp, aTemp, cFY_Start, dStart, dEnd

     aTemp     := FT_DATECNFG()
     cFY_Start := aTemp[1]

     IF dGivenDate == NIL .OR. !VALTYPE(dGivenDate) $ 'ND'
        dGivenDate := DATE()
     ELSEIF VALTYPE(dGivenDate) == 'N'
        nType := dGivenDate
        dGivenDate := DATE()
     ENDIF

     nType := iif(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

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 )

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
     ENDIF
     aRetVal[1] := aRetVal[2] + nDayNum - 1
  ELSE
     aRetVal[1] += PADL(LTRIM(STR( dGivenDate - aRetVal[2] + 1, 3)), 3, '0')
  ENDIF

RETURN aRetVal

FUNCTION FT_DAYTOBOW( dGivenDate )

  LOCAL nRetVal, nDOW_Start

  nDOW_Start := FT_DATECNFG()[2]

  IF VALTYPE(dGivenDate) != 'D'
    dGivenDate := DATE()
  ENDIF

  nRetVal := DOW( dGivenDate ) - nDOW_Start
  IF nRetVal < 0
    nRetVal += 7
  ENDIF

RETURN nRetVal

FUNCTION MAIN
LOCAL X
FOR X = 1 TO 255
   QOUT( FT_DEC2BIN( x ))
next
return nil

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

    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)

function FT_DFSETUP(cInFile, nTop, nLeft, nBottom, nRight,;
                    nStart, nCNormal, nCHighlight, cExitKeys,;
                    lBrowse, nColSkip, nRMargin, nBuffSize )

  local rval := 0

  if File(cInFile)
     nTop    := iif(ValType(nTop)    == "N", nTop,           0)
     nLeft   := iif(ValType(nLeft)   == "N", nLeft,          0)
     nBottom := iif(ValType(nBottom) == "N", nBottom, MaxRow())
     nRight  := iif(ValType(nRight)  == "N", nRight,  MaxCol())

     nCNormal    := iif(ValType(nCNormal)    == "N", nCNormal,     7)
     nCHighlight := iif(ValType(nCHighlight) == "N", nCHighlight, 15)

     nStart    := iif(ValType(nStart)    == "N", nStart,      1)
     nColSkip  := iif(ValType(nColSkip)  == "N", nColSkip,    1)
     lBrowse   := iif(ValType(lBrowse)   == "L", lBrowse,   .F.)

     nRMargin  := iif(ValType(nRMargin)  == "N", nRMargin,   255)
     nBuffSize := iif(ValType(nBuffSize) == "N", nBuffSize, 4096)

     cExitKeys := iif(ValType(cExitKeys) == "C", cExitKeys,  "")

     cExitKeys := iif(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)

function FT_DFCLOSE()

  if ( nHandle > 0 )
     _FT_DFCLOS()

     FClose(nHandle)

     nHandle := 0
  endif

  return (NIL)

  FUNCTION MAIN( cDrv )

     QOut("Disk size:   " + str( FT_DSKSIZE() ) )
     QOut("Free bytes:  " + str( FT_DSKFREE() ) )

  return ( nil )

FUNCTION FT_DSKSIZE( cDrive )
   local nDrive
   nDrive := iif( cDrive == NIL, 0, at( upper(cDrive), DRVTABLE ) )

Return DISKSPACE(nDrive,3)

FUNCTION FT_DSKFREE( cDrive )
   local nDrive
   nDrive := iif( cDrive == NIL, 0, at( upper(cDrive), DRVTABLE ) )


RETURN    DISKSPACE(nDrive,1)

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

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

  FUNCTION MAIN()
  QOut( "Dos version: " + FT_DOSVER() )
  return ( nil )

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 )

  function main( sNumE )
     return qout( 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 )

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" ) )

function FT_ELAPMIN(cTIME1,cTIME2)
  return ((VAL(LEFT(cTIME2,2))*60) + (VAL(RIGHT(cTIME2,2)))) - ;
         ((VAL(LEFT(cTIME1,2))*60) + (VAL(RIGHT(cTIME1,2))))

  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)
    ?? " "
    ?? iif(n == 1, 'Days', iif( n== 2, 'Hours', iif( n == 3, 'Mins.', 'Secs.')))
  NEXT
  RETURN NIL

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' ; ENDIF
  IF VALTYPE(cTimeEnd)   != 'C' ; cTimeEnd   := '00:00:00' ; ENDIF

  nTotalSec  := (dEnd - dStart) * 86400                              + ;
                VAL(cTimeEnd)   *  3600                              + ;
                VAL(SUBSTR(cTimeEnd,AT(':', cTimeEnd)+1,2)) * 60     + ;
                iif(RAT(':', cTimeEnd) == AT(':', cTimeEnd), 0,        ;
                VAL(SUBSTR(cTimeEnd,RAT(':', cTimeEnd)+1)))          - ;
                VAL(cTimeStart) * 3600                               - ;
                VAL(SUBSTR(cTimeStart,AT(':', cTimeStart)+1,2)) * 60 - ;
                iif(RAT(':', cTimeStart) == AT(':', cTimeStart), 0,    ;
                VAL(SUBSTR(cTimeStart,RAT(':', cTimeStart)+1)))

  nTemp := nTotalSec

  FOR nCtr = 1 to 4
     nConstant := iif(nCtr == 1, 86400, iif(nCtr == 2, 3600, iif( nCtr == 3, 60, 1)))
     aRetVal[nCtr,1] := INT(nTemp/nConstant)
     aRetval[nCtr,2] := nTotalSec / nConstant
     nTemp -= aRetVal[nCtr,1] * nConstant
  NEXT

RETURN aRetVal

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)

  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

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 (iif(nWhichOccurrence == 1, ;
              AT(cCheckFor, cCheckIn), ;
              iif((nIthOccurrence := AT(cCheckFor, ;
                                      STRTRAN(cCheckIn, cCheckFor, ;
                                              NULL, 1, ;
                                              nWhichOccurrence-1))) == 0, ;
                 0, ;
                 nIthOccurrence + ((nWhichOccurrence - 1) * LEN(cCheckFor)))))

FUNCTION FT_FDAY(dDateToChk)

   IF Valtype(dDatetoChk) # "D"
      dDatetoChk := Date()
   ENDIF

   RETURN dDateToChk - (DAY(dDateToChk)-1)

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

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

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

STATIC PROCEDURE _ResetDisketteSystem()
      LOCAL aRegs[INT86_MAX_REGS]

      aRegs[AX] := 0

      FT_INT86( 1*16+3, aRegs )

RETURN

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

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

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

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

  FUNCTION MAIN( cNum1, cNum2 )
     RETURN OUTSTD( STR(FT_GCD( val(cNum1), val(cNum2) )) + CHR(13) + CHR(10) )

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

  FUNCTION MAIN( cHexNum )
     QOut( FT_HEX2DEC( cHexNum ) )
     return ( nil )

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

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 := iif("*" $ cDsrdColor, "*", NULL) + ;
                 iif("+" $ 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, "+"), "*"))

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

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)

  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

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()

FUNCTION ft_lday( dDate )
   LOCAL d:= dDate
   IF dDate == NIL
      d:= Date()
   ENDIF
   RETURN ( d+= 45 - Day( d ) ) - Day( d )

  FUNCTION Main
  LOCAL cString
  LOCAL aString := { "TRIM('abc ')",                                     ;
                     "NotARealFunc()",                                   ;
                     "FT_DispMsg()",                                     ;
                     'TRIM(cVar+"abc"+LEFT(cString)), FOUND()',          ;
                     "IsItLinked()",                                     ;
                     "lRetVal := FOUND()",                               ;
                     "!EOF() .AND. MONTH(DATE())=12 .AND. YeeHa()",      ;
                     "!EOF() .AND. MONTH(DATE())=12",                    ;
                     "!EOF() .AND. MONTH(DATE(YeeHa()))=12",             ;
                     "LEFT(SUBSTR(nNum,4,VAL(cChar+ASC(c))))",           ;
                     "EOF(>> Note: Syntax IS NOT checked! <<)"           ;
                   }
  CLS
  @1,0 SAY "String Tested                               Result"
  @2,0 TO 2,MAXCOL()
  AEVAL(aString, {|ele,num| QOUT(ele, SPACE(45-LEN(ele)), FT_Linked(ele)) } )
  @MAXROW()-2,0
  RETURN NIL

#endif

*------------------------------------------------

FUNCTION FT_Linked( cFuncs )

// A function is detected by the left parenthesis, "(", and it begins
// at the space, comma or start-of-string preceeding the "("

// Returns: .T. if all functions are available,
//          .F. if not

LOCAL aFuncArray := {}, nSpace, nComma, nFEnd, lRetVal := .F.

IF AT("(",cFuncs) = 0
   // No functions in string
   ALERT("Warning: Expected function(s) in FT_Linked(), but none were found")
ELSE
   DO WHILE (nFEnd := AT("(",cFuncs)) > 0
      // Add the current function to the array of functions
      AADD( aFuncArray,LEFT(cFuncs,nFEnd)+")" )
      // Remove the current function from the string
      cFuncs := SUBSTR(cFuncs, nFEnd+1)
      nSpace := AT(" ",cFuncs) ; nComma := AT(",",cFuncs)
      DO WHILE  (nComma > 0 .and. nComma < nFEnd) .or. ;
            (nSpace > 0 .and. nSpace < nFEnd)
         // We have extra parameters or spaces prior to the start
         // of the function. Strip them out.
         if nComma > 0
            cFuncs := SUBSTR(cFuncs, nComma+1)
         elseif nSpace > 0
            cFuncs := SUBSTR(cFuncs, nSpace+1)
         endif
         nSpace := AT(" ", cFuncs) ; nComma := AT(",", cFuncs)
      ENDDO
   ENDDO
   // Scan through the array of functions, stop after the first occurence
   // of a function which returns a TYPE() of "U" (hence is not linked in)
   lRetVal := ASCAN(aFuncArray,{|element| TYPE(element)=="U"})=0
ENDIF
RETURN( lRetVal )

FUNCTION FT_MADD( dGivenDate, nAddMonths, lMakeEOM)
  LOCAL nAdjDay, dTemp, i

  IF VALTYPE(dGivenDate) != 'D' ; dGivenDate := DATE() ; ENDIF
  IF VALTYPE(nAddMonths) != 'N' ; nAddMonths := 0 ; ENDIF
  IF VALTYPE(lMakeEOM)   != 'L' ; lMakeEom := .F. ; ENDIF

  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 += iif( 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

   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 := iif( cCmdLine == NIL, "", cCmdLine )

   lColor := iif( "MONO" $ UPPER( cCmdLine ), .F., ISCOLOR() )

   * Border, Box, Bar, Current, Unselected
   aColors := iif( 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 := iif( lColor, "W+/G", "W+/N" )
   cNormN := iif( lColor, "N/G" , "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"  )

   SAVE SCREEN TO sDosScrn
   nDosRow := ROW()
   nDosCol := COL()
   SETCOLOR( "w/n" )
   CLS
   NOSNOW( ( "NOSNOW" $ UPPER( cCmdLine ) ) )
   IF "VGA" $ UPPER( cCmdLine )
      SETMODE(50,80)
   ENDIF
   nMaxRow := MAXROW()
   SETBLINK(.f.)
   SETCOLOR( cWindN + "*" )
   CLEAR SCREEN
   SETCOLOR( cNormN )
   @ nMaxRow, 0
   @ nMaxRow, 0 SAY " FT_MENU1 1.0 ³ "
   @ NMAXROW,16 SAY "WRITTEN BY PAUL FERRARA [76702,556] FOR NANFORUM.LIB"
   @ NMAXROW,69 SAY "³ "+DTOC( DATE() )

   SETCOLOR( cErrH )
   @ nMaxRow-11, 23, nMaxRow-3, 56 BOX "ÚÄ¿³ÙÄÀ³ "
   @ nMaxRow- 9,23 SAY "ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ´"
   SETCOLOR( cErrN )
   @ nMaxRow-10,33 SAY "Navigation Keys"
   @ nMaxRow- 8,25 SAY "LeftArrow   RightArrow   Alt-E"
   @ nMaxRow- 7,25 SAY "Home        End          Alt-R"
   @ nMaxRow- 6,25 SAY "Tab         Shift-Tab    Alt-D"
   @ nMaxRow- 5,25 SAY "PgUp        PgDn         Alt-M"
   @ nMaxRow- 4,25 SAY "Enter       ESCape       Alt-Q"
   SETCOLOR( cNormN )

   FT_MENU1( aBar, aOptions, aColors )

   SETCOLOR( "W/N" )
   SETCURSOR( SCNORMAL )
   SETBLINK(.t.)
   IF "VGA" $ UPPER( cCmdLine )
      SETMODE(25,80)
   ENDIF
   RESTORE SCREEN FROM sDosScrn
   SETPOS(nDosRow, nDosCol)
   QUIT

   FUNCTION fubar()
   LOCAL OldColor:= SETCOLOR( "W/N" )
   CLEAR SCREEN
   Qout( "Press Any Key" )
   INKEY(0)
   SETCOLOR( OldColor )
   RETURN .t.

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 := iif( 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
         nHpos := iif( nHpos == LEN( aChoices ), 1, nHpos + 1 )
      CASE LASTKEY() == LEFTARROW .OR. LASTKEY() == SHIFTTAB
         nHpos := iif( nHpos == 1, LEN( aChoices ), nHpos - 1 )
      CASE LASTKEY() == ESCAPE
         lLooping := _ftBailOut( cBorder, cBox )
      CASE LASTKEY() == HOME
         nHpos := 1
      CASE LASTKEY() == END
         nHpos := LEN( aChoices )
      CASE LASTKEY() == ENTER
         aLastSel[nHpos] := nVpos
         IF aChoices[nHpos,2,nVpos] != NIL
            SETCANCEL( lCancMode )
            ALTD( ENABLE )
            lLooping := EVAL( aChoices[nHpos,2,nVpos] )
            ALTD( DISABLE )
            SETCANCEL( .f. )
         ENDIF
      CASE ASCAN( aBarKeys, LASTKEY() ) > 0
         nHpos := ASCAN( aBarKeys, LASTKEY() )
      ENDCASE
   ENDDO
   SETCANCEL( lCancMode )
   AltD( ENABLE )
   RESTORE SCREEN FROM sMainScrn
   RETURN NIL

FUNCTION __ftAcUdf( nMode )
   // ACHOICE() user function
   LOCAL nRtnVal := RESUME
   DO CASE
   CASE nMode == HITTOP
      KEYBOARD CHR( CTRLEND )
   CASE nMode == HITBOTTOM
      KEYBOARD CHR( CTRLHOME )
   CASE nMode == KEYEXCEPT
      IF UPPER( CHR( LASTKEY() ) ) $ aValidKeys[ nHpos ]
         IF aChoices[ nHpos, 3, AT( UPPER(CHR(LASTKEY())), aValidKeys[ nHpos ] )]
            KEYBOARD CHR( ENTER )
            nRtnVal := NEXTITEM
         ENDIF
      ELSE
         nRtnVal := MAKESELECT
      ENDIF
   ENDCASE
   RETURN nRtnVal

STATIC FUNCTION _ftWidest( i, aChoices, aBarWidth )
   AEVAL(aChoices[i,1],{|a,b| HB_SYMBOL_UNUSED( a ), aBarWidth[i] := ;
            MAX( aBarWidth[i],LEN(aChoices[i,1,b])) })
   RETURN NIL

STATIC FUNCTION _ftLocat( i, aBarCol, aBarWidth, aBoxLoc, nMaxCol )
   aBoxLoc[i] := iif( aBarCol[i] + aBarWidth[i] + 4 > nMaxCol + 1, ;
                 nMaxCol - 3 - aBarWidth[i], aBarCol[i] )
   RETURN NIL

STATIC FUNCTION _ftBailOut( cBorder, cBox )
   LOCAL cOldColor, sOldScreen, nKeyPress, nOldCursor
   nOldCursor := SETCURSOR( SCNONE )
   sOldScreen := SAVESCREEN(nMaxRow/2-1, 24, nMaxRow/2+2, 55)
   cOldColor := SETCOLOR( cBorder )
   FT_SHADOW( nMaxRow/2-1, 24, nMaxRow/2+2, 55 )
   @ nMaxRow/2-1, 24, nMaxRow/2+2, 55 BOX "ÉÍ»º¼ÍȺ "
   SETCOLOR( cBox )
   @ nMaxRow/2,  26 SAY "Press ESCape To Confirm Exit"
   @ nMaxRow/2+1,27 SAY "Or Any Other Key To Resume"
   nKeyPress := INKEY(0)
   SETCOLOR( cOldColor )
   RESTSCREEN(nMaxRow/2-1, 24, nMaxRow/2+2, 55,sOldScreen )
   SETCURSOR( nOldCursor )
   RETURN !(nKeyPress == ESCAPE)

STATIC FUNCTION _ftValKeys( nNum,aChoices,aValidkeys )
   AEVAL( aChoices[nNum,1], {|x| aValidKeys[nNum] += LEFT( x, 1)} )
   RETURN NIL

FUNCTION FT_FILL( aArray, cMenuOption, bBlock, lAvailable )
   AADD( aArray[1], cMenuOption )
   AADD( aArray[2], bBlock )
   AADD( aArray[3], lAvailable )
   RETURN NIL

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

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

  FUNCTION MAIN()
  LOCAL cJunk  := SPACE( 8000 )
  LOCAL aNames := {}
  LOCAL cName, nElem

  SET( _SET_SCOREBOARD, .F.   )
  SET( _SET_COLOR,      "W/B" )
  CLS

  //  Demo will create an array of names and display in 3 columns
  //  _ftRow() and _ftCol() will calculate the screen co-ordinates
  //  by evaluating the element number

  AADD( aNames, "Adams"        )
  AADD( aNames, "Addams"       )
  AADD( aNames, "Atoms"        )
  AADD( aNames, "Adamson"      )
  AADD( aNames, "Cajun"        )
  AADD( aNames, "Cagen"        )
  AADD( aNames, "Cochy"        )
  AADD( aNames, "Cocci"        )
  AADD( aNames, "Smith"        )
  AADD( aNames, "Smythe"       )
  AADD( aNames, "Naylor"       )
  AADD( aNames, "Nailer"       )
  AADD( aNames, "Holberry"     )
  AADD( aNames, "Wholebary"    )
  AADD( aNames, "Jackson"      )
  AADD( aNames, "Jekksen"      )
  AADD( aNames, "The Source"   )
  AADD( aNames, "The Sores"    )
  AADD( aNames, "Jones"        )
  AADD( aNames, "Johns"        )
  AADD( aNames, "Lennon"       )
  AADD( aNames, "Lenin"        )
  AADD( aNames, "Fischer"      )
  AADD( aNames, "Fisher"       )
  AADD( aNames, "O'Donnell"    )
  AADD( aNames, "O Donald"     )
  AADD( aNames, "Pugh"         )
  AADD( aNames, "Pew"          )
  AADD( aNames, "Heimendinger" )
  AADD( aNames, "Hymendinker"  )
  AADD( aNames, "Knight"       )
  AADD( aNames, "Nite"         )
  AADD( aNames, "Lamb"         )
  AADD( aNames, "Lamb Chops"   )
  AADD( aNames, "Stephens"     )
  AADD( aNames, "Stevens"      )
  AADD( aNames, "Neilson"      )
  AADD( aNames, "Nelson"       )
  AADD( aNames, "Tchaikovski"  )
  AADD( aNames, "Chikofski"    )
  AADD( aNames, "Caton"        )
  AADD( aNames, "Wright"       )
  AADD( aNames, "Write"        )
  AADD( aNames, "Right"        )
  AADD( aNames, "Manual"       )
  AADD( aNames, "Now"          )
  AADD( aNames, "Wheatabix"    )
  AADD( aNames, "Science"      )
  AADD( aNames, "Cinzano"      )
  AADD( aNames, "Lucy"         )
  AADD( aNames, "Reece"        )
  AADD( aNames, "Righetti"     )
  AADD( aNames, "Oppermann"    )
  AADD( aNames, "Bookkeeper"   )
  AADD( aNames, "McGill"       )
  AADD( aNames, "Magic"        )
  AADD( aNames, "McLean"       )
  AADD( aNames, "McLane"       )
  AADD( aNames, "Maclean"      )
  AADD( aNames, "Exxon"        )

  // display names and metaphones in 3 columns on screen
  AEVAL( aNames, ;
         { | cName, nElem | ;
             SETPOS( _ftRow( nElem ), _ftCol( nElem ) ), ;
             QQOUT( PadR( cName, 18, "." ) + FT_METAPH( cName ) ) ;
         } )

  SETPOS( 21, 00 )
  QUIT

  *------------------------------------------------

  STATIC FUNCTION _ftRow( nElem )  //  Determine which row to print on
  RETURN IIF( nElem > 40, nElem - 40, IIF( nElem > 20, nElem - 20, nElem ) )
  *------------------------------------------------

  STATIC FUNCTION _ftCol( nElem )  //  Determine which column to start print
  RETURN IIF( nElem > 40,  55, IIF( nElem > 20, 28, 1 ) )
  *------------------------------------------------

#endif
// End of Test program

*------------------------------------------------

FUNCTION FT_METAPH ( cName, nSize )
//  Calculates the metaphone of a character string

LOCAL cMeta

cName := IIF( cName == NIL, "", cName )  //  catch-all
nSize := IIF( nSize == NIL, 4,  nSize )  //  default size: 4-bytes

//  Remove non-alpha characters and make upper case.
//  The string is padded with 1 space at the beginning & end.
//  Spaces, if present inside the string, are not removed until all
//  the prefix/suffix checking has been completed.
cMeta := " " + _ftMakeAlpha( UPPER( ALLTRIM( cName ) ) ) + " "

//  prefixes which need special consideration
IF " KN"   $ cMeta ;  cMeta := STRTRAN( cMeta, " KN" , " N"  ) ;  ENDIF
IF " GN"   $ cMeta ;  cMeta := STRTRAN( cMeta, " GN" , " N"  ) ;  ENDIF
IF " PN"   $ cMeta ;  cMeta := STRTRAN( cMeta, " PN" , " N"  ) ;  ENDIF
IF " AE"   $ cMeta ;  cMeta := STRTRAN( cMeta, " AE" , " E"  ) ;  ENDIF
IF " X"    $ cMeta ;  cMeta := STRTRAN( cMeta, " X"  , " S"  ) ;  ENDIF
IF " WR"   $ cMeta ;  cMeta := STRTRAN( cMeta, " WR" , " R"  ) ;  ENDIF
IF " WHO"  $ cMeta ;  cMeta := STRTRAN( cMeta, " WHO", " H"  ) ;  ENDIF
IF " WH"   $ cMeta ;  cMeta := STRTRAN( cMeta, " WH" , " W"  ) ;  ENDIF
IF " MCG"  $ cMeta ;  cMeta := STRTRAN( cMeta, " MCG", " MK" ) ;  ENDIF
IF " MC"   $ cMeta ;  cMeta := STRTRAN( cMeta, " MC" , " MK" ) ;  ENDIF
IF " MACG" $ cMeta ;  cMeta := STRTRAN( cMeta, " MACG"," MK" ) ;  ENDIF
IF " MAC"  $ cMeta ;  cMeta := STRTRAN( cMeta, " MAC", " MK" ) ;  ENDIF
IF " GI"   $ cMeta ;  cMeta := STRTRAN( cMeta, " GI",  " K"  ) ;  ENDIF

//  Suffixes which need special consideration
IF "MB " $ cMeta ;  cMeta := STRTRAN( cMeta, "MB " , "M " ) ;  ENDIF
IF "NG " $ cMeta ;  cMeta := STRTRAN( cMeta, "NG " , "N " ) ;  ENDIF

//  Remove inner spaces (1st and last byte are spaces)
IF " " $ SUBSTR( cMeta, 2, LEN( cMeta ) - 2 )
  cMeta := " " + STRTRAN( cMeta, " " , "" ) + " "
ENDIF

//  Double consonants sound much the same as singles
IF "BB"  $ cMeta ;  cMeta := STRTRAN( cMeta, "BB"  , "B"  ) ;  ENDIF
IF "CC"  $ cMeta ;  cMeta := STRTRAN( cMeta, "CC"  , "CH" ) ;  ENDIF
IF "DD"  $ cMeta ;  cMeta := STRTRAN( cMeta, "DD"  , "T"  ) ;  ENDIF
IF "FF"  $ cMeta ;  cMeta := STRTRAN( cMeta, "FF"  , "F"  ) ;  ENDIF
IF "GG"  $ cMeta ;  cMeta := STRTRAN( cMeta, "GG"  , "K"  ) ;  ENDIF
IF "KK"  $ cMeta ;  cMeta := STRTRAN( cMeta, "KK"  , "K"  ) ;  ENDIF
IF "LL"  $ cMeta ;  cMeta := STRTRAN( cMeta, "LL"  , "L"  ) ;  ENDIF
IF "MM"  $ cMeta ;  cMeta := STRTRAN( cMeta, "MM"  , "M"  ) ;  ENDIF
IF "NN"  $ cMeta ;  cMeta := STRTRAN( cMeta, "NN"  , "N"  ) ;  ENDIF
IF "PP"  $ cMeta ;  cMeta := STRTRAN( cMeta, "PP"  , "P"  ) ;  ENDIF
IF "RR"  $ cMeta ;  cMeta := STRTRAN( cMeta, "RR"  , "R"  ) ;  ENDIF
IF "SS"  $ cMeta ;  cMeta := STRTRAN( cMeta, "SS"  , "S"  ) ;  ENDIF
IF "TT"  $ cMeta ;  cMeta := STRTRAN( cMeta, "TT"  , "T"  ) ;  ENDIF
IF "XX"  $ cMeta ;  cMeta := STRTRAN( cMeta, "XX"  , "KS" ) ;  ENDIF
IF "ZZ"  $ cMeta ;  cMeta := STRTRAN( cMeta, "ZZ"  , "S"  ) ;  ENDIF

//  J sounds
IF "DGE" $ cMeta ;  cMeta := STRTRAN( cMeta, "DGE" , "J"  ) ;  ENDIF
IF "DGY" $ cMeta ;  cMeta := STRTRAN( cMeta, "DGY" , "J"  ) ;  ENDIF
IF "DGI" $ cMeta ;  cMeta := STRTRAN( cMeta, "DGI" , "J"  ) ;  ENDIF
IF "GI"  $ cMeta ;  cMeta := STRTRAN( cMeta, "GI"  , "J"  ) ;  ENDIF
IF "GE"  $ cMeta ;  cMeta := STRTRAN( cMeta, "GE"  , "J"  ) ;  ENDIF
IF "GY"  $ cMeta ;  cMeta := STRTRAN( cMeta, "GY"  , "J"  ) ;  ENDIF

//  X sounds (KS)
IF "X"   $ cMeta ;  cMeta := STRTRAN( cMeta, "X"   , "KS" ) ;  ENDIF

// special consideration for SCH
IF "ISCH" $ cMeta;  cMeta := STRTRAN( cMeta, "ISCH", "IX" ) ;  ENDIF
IF "SCH" $ cMeta ;  cMeta := STRTRAN( cMeta, "SCH" , "SK" ) ;  ENDIF

//  sh sounds (X)
IF "CIA" $ cMeta ;  cMeta := STRTRAN( cMeta, "CIA" , "X"  ) ;  ENDIF
IF "SIO" $ cMeta ;  cMeta := STRTRAN( cMeta, "SIO" , "X"  ) ;  ENDIF
IF "C"   $ cMeta ;  cMeta := STRTRAN( cMeta, "SIA" , "X"  ) ;  ENDIF
IF "SH"  $ cMeta ;  cMeta := STRTRAN( cMeta, "SH"  , "X"  ) ;  ENDIF
IF "TIA" $ cMeta ;  cMeta := STRTRAN( cMeta, "TIA" , "X"  ) ;  ENDIF
IF "TIO" $ cMeta ;  cMeta := STRTRAN( cMeta, "TIO" , "X"  ) ;  ENDIF
IF "TCH" $ cMeta ;  cMeta := STRTRAN( cMeta, "TCH" , "X"  ) ;  ENDIF
IF "CH"  $ cMeta ;  cMeta := STRTRAN( cMeta, "CH"  , "X"  ) ;  ENDIF

//  hissing sounds (S)
IF "SCI" $ cMeta ;  cMeta := STRTRAN( cMeta, "SCI" , "S"  ) ;  ENDIF
IF "SCE" $ cMeta ;  cMeta := STRTRAN( cMeta, "SCE" , "S"  ) ;  ENDIF
IF "SCY" $ cMeta ;  cMeta := STRTRAN( cMeta, "SCY" , "S"  ) ;  ENDIF
IF "CI"  $ cMeta ;  cMeta := STRTRAN( cMeta, "CI"  , "S"  ) ;  ENDIF
IF "CE"  $ cMeta ;  cMeta := STRTRAN( cMeta, "CE"  , "S"  ) ;  ENDIF
IF "CY"  $ cMeta ;  cMeta := STRTRAN( cMeta, "CY"  , "S"  ) ;  ENDIF
IF "Z"   $ cMeta ;  cMeta := STRTRAN( cMeta, "Z"   , "S"  ) ;  ENDIF

//  th sound (0)
IF "TH"  $ cMeta ;  cMeta := STRTRAN( cMeta, "TH"  , "0"  ) ;  ENDIF

//  Convert all vowels to 'v' from 3rd byte on
cMeta := LEFT( cMeta, 2 ) + _ftConvVowel( SUBSTR( cMeta, 3 ) )

// Make Y's silent if not followed by vowel
IF "Y"   $ cMeta
  cMeta := STRTRAN( cMeta, "Yv"  , "#"  )  // Y followed by vowel
  cMeta := STRTRAN( cMeta, "Y"   , ""   )  // not followed by vowel
  cMeta := STRTRAN( cMeta, "#"   , "Yv" )  // restore Y and vowel
ENDIF

//  More G sounds, looking at surrounding vowels
IF "GHv" $ cMeta ;  cMeta := STRTRAN( cMeta, "GHv" , "G"  ) ;  ENDIF
IF "vGHT" $ cMeta;  cMeta := STRTRAN( cMeta, "vGHT", "T"  ) ;  ENDIF
IF "vGH" $ cMeta ;  cMeta := STRTRAN( cMeta, "vGH" , "W"  ) ;  ENDIF
IF "GN"  $ cMeta ;  cMeta := STRTRAN( cMeta, "GN"  , "N"  ) ;  ENDIF
IF "G"   $ cMeta ;  cMeta := STRTRAN( cMeta, "G"   , "K"  ) ;  ENDIF

//  H sounds, looking at surrounding vowels
IF "vHv" $ cMeta ;  cMeta := STRTRAN( cMeta, "vHv" , "H"  ) ;  ENDIF
IF "vH"  $ cMeta ;  cMeta := STRTRAN( cMeta, "vH"  , ""   ) ;  ENDIF

//  F sounds
IF "PH"  $ cMeta ;  cMeta := STRTRAN( cMeta, "PH"  , "F"  ) ;  ENDIF
IF "V"   $ cMeta ;  cMeta := STRTRAN( cMeta, "V"   , "F"  ) ;  ENDIF

//  D sounds a bit like T
IF "D"   $ cMeta ;  cMeta := STRTRAN( cMeta, "D"   , "T"  ) ;  ENDIF

//  K sounds
IF "CK"  $ cMeta ;  cMeta := STRTRAN( cMeta, "CK"  , "K"  ) ;  ENDIF
IF "Q"   $ cMeta ;  cMeta := STRTRAN( cMeta, "Q"   , "K"  ) ;  ENDIF
IF "C"   $ cMeta ;  cMeta := STRTRAN( cMeta, "C"   , "K"  ) ;  ENDIF

//  Remove vowels
cMeta := STRTRAN( cMeta, "v", "" )

RETURN PadR( ALLTRIM( cMeta ), nSize )

*------------------------------------------------

STATIC FUNCTION _ftMakeAlpha ( cStr )
//  Strips non-alpha characters from a string, leaving spaces

LOCAL x, cAlpha := ""

FOR x := 1 to LEN( cStr )
  IF SUBSTR( cStr, x, 1 ) == " " .OR. ISALPHA( SUBSTR( cStr, x, 1 ) )
    cAlpha := cAlpha + SUBSTR( cStr, x, 1 )
  ENDIF
NEXT

RETURN cAlpha

*------------------------------------------------

STATIC FUNCTION _ftConvVowel ( cStr )
//  Converts all vowels to letter 'v'

LOCAL x, cConverted := ""

FOR x := 1 to LEN( cStr )
  IF SUBSTR( cStr, x, 1 ) $ "AEIOU"
    cConverted := cConverted + "v"
  ELSE
    cConverted := cConverted + SUBSTR( cStr, x, 1 )
  ENDIF
NEXT

RETURN cConverted

*------------------------------------------------

  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

function FT_MIL2MIN(cMILTIME)
  return int(val(left(cMILTIME,2))*60 + val(right(cMILTIME,2)))

function FT_MIN2MIL(nMIN)
  nMIN := nMIN%1440
  return  right("00" + ltrim(str(INT(nMIN/60))),2) + ;
          right("00" + ltrim(str(INT(nMIN%60))),2)

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

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

function FT_SYS2MIL()
return left(stuff(time(),3,1,""),4)

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_

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
     ENDIF
     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

  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

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

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

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

FUNCTION FT_MINREGION( nTR, nLC, nBR, nRC )
RETURN ( FT_MGETX() >= nTR .and. FT_MGETX() <= nBR .and. ;
         FT_MGETY() >= nLC .and. FT_MGETY() <= nRC )

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

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

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]

FUNCTION FT_MSETPAGE(nPage)

// Set up register
/*
aReg[AX] := 29
aReg[BX] := nPage

// Call interupt

FT_INT86( 51, aReg)
*/
_mset_page(nPage)
RETURN NIL

FUNCTION FT_MGETPAGE()

// Set up register
/*
aReg[AX] := 30

// Call interupt

FT_INT86( 51, aReg)
*/
RETURN _mget_page()

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

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

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

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

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

FUNCTION FT_MGETPOS( nX, nY )
   Local amse:={}
   nX := iif( nX == NIL, 0, nX )
   nY := iif( 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

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

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

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

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

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

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

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

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

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

FUNCTION FT_MGETCOORD( nX, nY )

* Duplicated code from FT_MGETPOS() for speed reasons
local aReg:={}
local iButton
   nX := iif( nX == NIL, 0, nX )
   nY := iif( 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

  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

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

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

FUNCTION FT_MCURSOR( lState )
   local lSavState := lCrsState

   if VALTYPE(lState)="L"
      if ( lCrsState := lState )
         FT_MSHOWCRS()
      else
         FT_MHIDECRS()
      endif
   ENDIF

RETURN lSavState

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

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

FUNCTION FT_MGETPOS( nX, nY )

   nX := iif( nX == NIL, 0, nX )
   nY := iif( 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

FUNCTION FT_MGETCOORD( nX, nY )

* Duplicated code from FT_MGETPOS() for speed reasons

   nX := iif( nX == NIL, 0, nX )
   nY := iif( 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

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

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

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

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

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

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

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

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

  FUNCTION MAIN()
     ? FT_NETPV( 10000, 10, { 10000,15000,16000,17000 } )
  RETURN ( nil )

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)

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 (iif(LEN(cCheckFor) == 0 .OR. LEN(cCheckIn) == 0, ;
              0, ;
              INT((LEN(cCheckIn) - LEN(STRTRAN(cCheckIn, cCheckFor))) / ;
                   LEN(cCheckFor))))

  function main( cNum )
     return qout( ft_ntow( val( cNum ) ) )

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) )

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)

static function sol10( nNumber )
  local sTemp

  sTemp := ltrim( str( int(nNumber), 0) )
  return( len(sTemp) - 1 )

  FUNCTION MAIN()
  QOut( "Logical station: " + str( FT_NWLSTAT() ) )
  return ( nil )

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

  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

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 )

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 )

function ft_nwSemWait( nHandle, nTimeout )
  return  _ftnwsem( WAIT_SEMAPHORE, nHandle, nTimeout )

function ft_nwSemSig( nHandle )
  return  _ftnwsem( SIGNAL_SEMAPHORE, nHandle )

function ft_nwSemClose( nHandle )
  return  _ftnwsem( CLOSE_SEMAPHORE, nHandle )

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

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 )

function ft_nwSemUnLock( nHandle )
  return ( ft_nwSemClose( nHandle ) == 0 )

  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 )

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) )  )

FUNCTION FT_SETVPG( nPage )
/*
  LOCAL aRegs[ INT86_MAX_REGS ]

  aRegs[ AX ] = MAKEHI( 5 ) + nPage
  FT_INT86( VIDEO, aRegs )
  */
  _ft_setvpg(nPage)

  RETURN( NIL )

FUNCTION FT_GETVPG()
/*
  LOCAL aRegs[ INT86_MAX_REGS ]

  aRegs[ AX ] := MAKEHI( 15 )
  FT_INT86( VIDEO, aRegs )

  RETURN ( HIGHBYTE( aRegs[ BX ] ) ) */
 Return _ft_getvpg()

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

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()
*--------------------------------------------------------------------*

static function DrawBox(nelement)
setcolor(iif(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()
*--------------------------------------------------------------------*

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()
*--------------------------------------------------------------------*

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

  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 )

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

FUNCTION MAIN
QOUT("You selected " + FT_PICKDAY())
return nil

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]

  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

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    := IIF(lShowRight,40,0)+nLeftOS
  nTapeSpace   := IIF(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  := IIF(lShowRight,40,0)+nLeftOS
        nTapeSpace := IIF(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 IIF(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 " + IIF(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

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

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

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

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

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 == Asc( "." )                 // 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

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

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

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

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

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

STATIC FUNCTION _ftUpdateTrans(aAdder, lTypeTotal, nAmount)

  LOCAL lUseTotal := (nAmount == NIL)

  nAmount := IIF(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(IIF(lUseTotal,nTotal,nAmount),22,nMaxDeci) )
    aTrans[nTotTran] := _ftStuffComma(aTrans[nTotTran], .T.) + " *"+         ;
                                     IIF(lAddError,"ER","")

  ELSE                            // If lTypeTotal=.F. Update from nNumTotal
    AADD(aTrans,STR(IIF(lUseTotal,nTotal,nAmount),22,nMaxDeci))

    aTrans[nTotTran] := _ftStuffComma(aTrans[nTotTran], .T.) +               ;
      IIF(lSubRtn," S",IIF(nAddMode==1," +",IIF(nAddMode==2," -",IF             ;
      (lTotalOk," =",IIF(nAddMode==3," X"," /"))))) + IIF(lAddError,"ER","")

  ENDIF

  IF lTape
    _ftDisplayTape(aAdder)
  ENDIF

RETURN NIL

STATIC FUNCTION _ftEraseTotSubTot(aAdder)
  _ftSetWinColor(W_CURR,W_SCREEN)
  @ 6+nTopOS, 18+nAddSpace SAY "          "
  _ftSetWinColor(W_CURR,W_PROMPT)
RETURN NIL

STATIC FUNCTION _ftRoundIt(nNumber, nPlaces)
  nPlaces := IIF( nPlaces == NIL, 0, nPlaces )
RETURN IIF(nNumber < 0.0, -1.0, 1.0) *                                        ;
       INT( ABS(nNumber) * 10 ^ nPlaces + 0.50 + 10 ^ -12 ) / 10 ^ nPlaces

STATIC FUNCTION _ftDivide(aAdder, nNumerator,nDenominator)
  IF nDenominator==0.0
    lDivError := .T.
    RETU 0
  ELSE
    lDivError := .F.
  ENDIF
RETURN(nNumerator/nDenominator)

STATIC FUNCTION _ftValDeci(oGet)

  LOCAL lRtnValue := .T.

  IF oGet:VarGet() > 8
    _ftError("no more than 8 decimal places please!")
    lRtnValue := .F.
  ENDIF

RETURN lRtnValue

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

STATIC FUNCTION _ftSetLastKey(nLastKey)
  _ftPushKeys()
  KEYBOARD CHR(nLastKey)
  INKEY()
  _ftPopKeys()
RETURN NIL

STATIC FUNCTION _ftPushKeys
  DO WHILE NEXTKEY() != 0
    AADD(aKeys,INKEY())
  ENDDO
RETURN NIL

STATIC FUNCTION _ftPopKeys
  LOCAL cKeys := ""
  IF LEN(aKeys) != 0
    AEVAL(aKeys, {|elem| cKeys += CHR(elem)})
  ENDIF
  KEYBOARD cKeys
  aKeys := {}
RETURN NIL

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   := IIF(nWinColor == NIL, W_CURR, nWinColor)

  cOldDevic := SET(_SET_DEVICE, "SCREEN")
  lOldPrint := SET(_SET_PRINTER, .F.)
  nMessLen  := LEN(cMessage)
  nWide     := IIF(nMessLen>72,72,IIF(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     := IIF(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

STATIC FUNCTION _ftPopMessage
  _ftPopWin()
RETURN NIL

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  := IIF(cVarType=="C",LEN(xVarVal),IIF(cVarType=="D",8,          ;
                       IIF(cVarType=="L",1,IIF(cVarType=="N",IIF(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    := IIF(lNoESC==NIL,.F.,lNoESC)

  nMessLen  := LEN(cMessage)+nVarLen+1
  nWide     := IIF(nMessLen>66,66,IIF(nMessLen<12,12,nMessLen))

  nNumMessRow    := MLCOUNT(cMessage,nWide)
  nLenLastRow    := LEN(TRIM(MEMOLINE(cMessage,nWide,nNumMessRow)))
  lGetOnNextLine := (nLenLastRow + nVarLen) > nWide
  nNumRows       := nNumMessRow + IIF(lGetOnNextLine,1,0)

  // Center it in the screen
  nTop        := IIF(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 ?",IIF(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( IIF(lGetOnNextLine,Row()+1,Row()),                       ;
                     IIF(lGetOnNextLine,nLeft+2,Col()+1),                     ;
                     {|x| IIF(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))+IIF(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 := IIF(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

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

STATIC FUNCTION _ftError(cMessage, xDontReset)
  LOCAL nOldRow,nOldCol,nOldCurs,nTop,nLeft,nBot,nRight,cOldColor,           ;
        nOldLastKey,cErrorScr,nMessLen,nWide,nNumRows,nKey,                  ;
        cOldDevic,lOldPrint,                                                 ;
        lResetLKey := IIF(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    := IIF(nMessLen>66,66,IIF(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

STATIC FUNCTION _ftStuffComma(cStrToStuff,lTrimStuffedStr)

  LOCAL nDecPosit, x,                                                        ;
        nOrLen := LEN(cStrToStuff)

  lTrimStuffedStr := IIF(lTrimStuffedStr==NIL,.F.,lTrimStuffedStr)
  IF !("." $ cStrToStuff)
    cStrToStuff := _ftPosIns(cStrToStuff,".",IIF("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

STATIC FUNCTION _ftSetSCRColor(nStd,nEnh,nBord,nBack,nUnsel)

  IF EMPTY(aWinColor)
    _ftInitColors()
  ENDIF

  nStd  := IIF(nStd   == NIL, 8,    nStd)
  nEnh  := IIF(nEnh   == NIL, 8,    nEnh)
  nBord := IIF(nBord  == NIL, 8,    nBord)
  nBack := IIF(nBack  == NIL, 8,    nBack)
  nUnsel:= IIF(nUnsel == NIL, nEnh, nUnsel)

RETURN SETCOLOR(aStdColor[nStd]+","+aStdColor[nEnh]+","+aStdColor[nBord]+","+;
  aStdColor[nBack]+","+aStdColor[nUnsel])

STATIC FUNCTION _ftPushWin(t,l,b,r,cTitle,cBotTitle,nWinColor)

  LOCAL lAutoWindow := nWinColor==NIL

  nWinColor := IIF(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

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

STATIC FUNCTION _ftSetWinColor(nWin,nStd,nEnh,nBord,nBack,nUnsel)

  nWin  := IIF(nWin   == NIL, nWinColor, nWin)
  nStd  := IIF(nStd   == NIL, 7,         nStd)
  nEnh  := IIF(nEnh   == NIL, 7,         nEnh)
  nBord := IIF(nBord  == NIL, 7,         nBord)
  nBack := IIF(nBack  == NIL, 7,         nBack)
  nUnsel:= IIF(nUnsel == NIL, nEnh,      nUnsel)

RETURN SETCOLOR(aWinColor[nStd,nWin]+","+aWinColor[nEnh,nWin]+","+           ;
  aWinColor[nBord,nWin]+","+aWinColor[nBack,nWin]+","+aWinColor[nUnsel,nWin])

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

STATIC FUNCTION _ftLastWinColor
RETURN nWinColor := IIF(nWinColor==1,4,nWinColor-1)

STATIC FUNCTION _ftNextWinColor
  IF EMPTY(aWinColor)
    _ftInitColors()
  ENDIF

RETURN nWinColor := (IIF(nWinColor<4,nWinColor+1,1))

STATIC FUNCTION _ftWinTitle(cTheTitle,cTopOrBot)

  LOCAL nCurWin  :=LEN(aWindow),                                             ;
        nLenTitle:=LEN(cTheTitle)

  @ aWindow[nCurWin,IIF(cTopOrBot==NIL,1,3)],(aWindow[nCurWin,4]-            ;
    aWindow[nCurWin,2]-nLenTitle)/2+aWindow[nCurWin,2] SAY " "+cTheTitle+" "

RETURN NIL

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

STATIC FUNCTION _ftCharOdd(cString)
  cString := TRANSFORM(cString,REPLICATE("X", LEN(cString)/2 ) )
RETURN STRTRAN(cString,"")

STATIC FUNCTION _ftPosRepl(cString,cChar,nPosit)
RETURN STRTRAN(cString,"9",cChar,nPosit,1)+""

STATIC FUNCTION _ftCharRem(cChar,cString)
RETURN STRTRAN(cString,cChar)

STATIC FUNCTION _ftCountLeft(cString)
RETURN LEN(cString)-LEN(LTRIM(cString))

STATIC FUNCTION _ftPosIns(cString,cChar,nPosit)
RETURN LEFT(cString,nPosit-1)+cChar+SUBSTR(cString,nPosit)

  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)

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

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 )

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 )

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
     ENDIF
     dGivenDate := FT_MADD(aRetVal[2], 3*(nQtrNum - 1) )
  ENDIF

  nTemp := MONTH( dGivenDate ) - MONTH( aRetVal[2] )
  nTemp += iif( 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

  function main()
     local x

     for x := 1 to 100
        outstd( int( ft_rand1(100) ) )
        outstd( chr(13) + chr(10) )
     next
     return nil

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 ) )

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

 FUNCTION DispArray(aTest)
   LOCAL nk
   FOR nk := 1 TO LEN(aTest)
     ? aTest[nk, 1]
     ?? '  '
     ?? DTOC(aTest[nk, 2])
     ?? '  '
     ?? STR(aTest[nk, 3])
     ?? '  '
     ?? iif(aTest[nk, 4], 'true', 'false')
   NEXT
 RETURN Nil

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

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, iif(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

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

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

  FUNCTION MAIN
     LOCAL ASETS := FT_SAVESETS()
     INKEY(0)
     RETURN Nil

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

  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

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] )) )

FUNCTION FT_SAVRGN(nTop, nLeft, nBottom, nRight)

   RETURN (CHR(nTop) + CHR(nLeft) + CHR(nBottom) + CHR(nRight) + ;
      SAVESCREEN(nTop, nLeft, nBottom, nRight))

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

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

  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 )

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 ) )

  FUNCTION MAIN( cTime )
    cTime := iif( cTime == nil, time(), cTime )
    QOut( "Setting time to: " + cTime  + "... " )
    FT_SETTIME( cTime )
    Qout( "Time is now: " + time() )
  return ( nil )

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 ) )

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

  FUNCTION MAIN(nSleep)

       ? "Time is now: " + time()
       FT_SLEEP(VAL(nSleep))
       ? "Time is now: " + time()

  RETURN ( nil )

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

function ft_sqzn(nValue,nSize,nDecimals)
  local tmpstr,cCompressed,k

  nSize       := iif(nSize    ==NIL,10,nSize )
  nDecimals   := iif(nDecimals==NIL, 0,nDecimals )
  nValue      := nValue * (10**nDecimals)
  nSize       := iif(nSize/2!=int(nSize/2),nSize+1,nSize)
  tmpstr      := str( abs(nValue),nSize )
  tmpstr      := strtran(tmpstr," ","0")
  cCompressed := chr( val(substr(tmpstr,1,2))+iif(nValue<0,128,0) )

  for k := 3 to len(tmpstr) step 2
     cCompressed += chr(val(substr(tmpstr,k,2)))
  next
  return cCompressed

function ft_unsqzn(cCompressed,nSize,nDecimals)
  local tmp:="",k,cValue,multi:=1

  nSize       := iif(nSize    ==NIL,10,nSize )
  nDecimals   := iif(nDecimals==NIL, 0,nDecimals)
  cCompressed := iif(multi    ==-1,substr(cCompressed,2),cCompressed)
  nSize       := iif(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

  FUNCTION MAIN()
  QOut( "Conventional memory: " + str( FT_SYSMEM() ) + "K installed" )
  return ( nil )

FUNCTION FT_SYSMEM()
  LOCAL aRegs[ INT86_MAX_REGS ]

  aRegs[ AX ] := 0
  FT_INT86( MEMSIZE, aRegs )

RETURN ( aRegs[ AX ] )

  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

  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

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| iif( 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 := iif(',' $ 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)

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()

STATIC FUNCTION TbWhileTop(cKey)
   SEEK cKey
RETURN NIL

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

  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

  FUNCTION FT_TEMPFIL( cPath, lHide, nHandle )

  LOCAL cFile

  Default cPath to ".\"
  Default lHide to .f.

  cPath = alltrim( cPath )

  nHandle := HB_FTempCreate( cPath, nil, iif( lHide, FC_HIDDEN, FC_NORMAL ), @cFile )

  if !hb_isbyref( @nHandle )
     fclose( nHandle )
  endif

  RETURN cFile

  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

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

static function cust

static function inv

static function vendors

static function custrep

static function pastdue

static function weeksales

static function monthpl

static function vendorrep

static function re_ntx

static function backup

static function compress

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

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 )

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] ) } )

  FUNCTION MAIN( cMode )

     FT_SETMODE( val( cMode ) )
     QOut( "Video mode is: " + str( FT_GETMODE() ) )
     return ( nil )

FUNCTION FT_SETMODE( nMode )
/*
  LOCAL aRegs[ INT86_MAX_REGS ]

  aRegs[ AX ] = nMode
  FT_INT86( VIDEO, aRegs )
*/
_ft_setmode(nMode)
  RETURN( NIL )

FUNCTION FT_GETMODE()
/*
  LOCAL aRegs[INT86_MAX_REGS]

  aRegs[ AX ] := MAKEHI( GETMODE )
  FT_INT86( VIDEO, aRegs )

  RETURN ( LOWBYTE( aRegs[ AX ] ) )
*/
 RETURN _ft_getmode()  

  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

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   ;
                )                                                                   ;
            )

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
     ENDIF
     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

  function main( cStart, cStop )
     return qout( ft_workdays( ctod( cStart ), ctod( cStop ) ) )

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) )

  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

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)

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)

   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 )

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 := iif(ValType(cJustType)='C',Upper(cJustType),'')
  cRetWait  := iif(ValType(cRetWait )='C',Upper(cRetWait), '')
  cBorType  := iif(ValType(cBorType )='C',Upper(cBorType), '')
  cBorColor := iif(ValType(cBoxColor)='C',cBorColor, 'N/W')
  cBoxColor := iif(ValType(cBoxColor)='C',cBoxColor, 'W/N')
  nStartRow := iif(ValType(nStartRow)='N',nStartRow,99)
  nStartCol := iif(ValType(nStartCol)='N',nStartCol,99)

  nNumRows := Min(PCount()-7,8)

  //establish array of strings to be displayed
  aLines_[1] := iif(ValType(cLine1) = 'C',AllTrim(SubStr(cLine1,1,74)),'')
  aLines_[2] := iif(ValType(cLine2) = 'C',AllTrim(SubStr(cLine2,1,74)),'')
  aLines_[3] := iif(ValType(cLine3) = 'C',AllTrim(SubStr(cLine3,1,74)),'')
  aLines_[4] := iif(ValType(cLine4) = 'C',AllTrim(SubStr(cLine4,1,74)),'')
  aLines_[5] := iif(ValType(cLine5) = 'C',AllTrim(SubStr(cLine5,1,74)),'')
  aLines_[6] := iif(ValType(cLine6) = 'C',AllTrim(SubStr(cLine6,1,74)),'')
  aLines_[7] := iif(ValType(cLine7) = 'C',AllTrim(SubStr(cLine7,1,74)),'')
  aLines_[8] := iif(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 = iif(nStartCol==99,Int((76-nLLen)/2),Min(nStartCol,74-nLLen))
  nRCol = nLCol+nLLen+3
  nTRow = iif(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 := iif(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

STATIC FUNCTION _FTSAY(nSayRow,nSayCol,cSayStr)
    @ nSayRow,nSayCol SAY cSayStr
    RETURN NIL

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()
  ENDIF

  aRetVal[2]  := CTOD(STR( YEAR(dGivenDate) - iif(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