From 475be0bf98aa04cbab9326eaee7fc856a5638af1 Mon Sep 17 00:00:00 2001 From: Viktor Szakats Date: Tue, 3 Aug 1999 17:11:50 +0000 Subject: [PATCH] *** empty log message *** --- harbour/ChangeLog | 13 + harbour/include/box.ch | 6 + harbour/include/box.h | 2 + harbour/include/directry.ch | 10 +- harbour/include/memoedit.ch | 26 +- harbour/source/rtl/Makefile | 1 + harbour/source/rtl/achoice.prg | 628 ++++++++++++++++++++++++++++++ harbour/tests/working/Makefile | 1 + harbour/tests/working/ac_test.prg | 221 +++++++++++ 9 files changed, 892 insertions(+), 16 deletions(-) create mode 100644 harbour/source/rtl/achoice.prg create mode 100644 harbour/tests/working/ac_test.prg diff --git a/harbour/ChangeLog b/harbour/ChangeLog index 95f082f2f5..71faf47a7c 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -1,3 +1,16 @@ +19990803-19:00 GMT+1 Victor Szel + * source/rtl/achoice.prg + source/rtl/Makefile + tests/working/ac_test.prg + tests/working/Makefile + + ACHOICE() plus test program AC_TEST added. + (Please update other makefiles accordingly) + * include/box.ch + include/box.h + + XBase++ compatible B_THIN, B_FAT border types added. + * include/memoedit.ch + + Some XBase++ extensions added. + 19990803-16:50 GMT+1 Victor Szel * config/win32/gcc.cf config/os2/gcc.cf (not tested) diff --git a/harbour/include/box.ch b/harbour/include/box.ch index 40bdb1316f..cf598f10c3 100644 --- a/harbour/include/box.ch +++ b/harbour/include/box.ch @@ -23,4 +23,10 @@ #define B_DOUBLE_SINGLE ( Chr(213) + Chr(205) + Chr(184) + Chr(179) + ; Chr(190) + Chr(205) + Chr(212) + Chr(179) ) +#define B_THIN ( Chr(219) + Chr(223) + Chr(219) + Chr(219) + ; + Chr(219) + Chr(220) + Chr(219) + Chr(219) ) + +#define B_FAT ( Chr(219) + Chr(219) + Chr(219) + Chr(219) + ; + Chr(219) + Chr(219) + Chr(219) + Chr(219) ) + #endif /* _BOX_CH */ diff --git a/harbour/include/box.h b/harbour/include/box.h index 9b2d93d855..1a2df3e38a 100644 --- a/harbour/include/box.h +++ b/harbour/include/box.h @@ -12,5 +12,7 @@ #define B_DOUBLE "ÉÍ»º¼ÍȺ" #define B_SINGLE_DOUBLE "ÖÄ·º½ÄÓº" #define B_DOUBLE_SINGLE "Õ͸³¾ÍÔ³" +#define B_THIN "ÛßÛÛÛÜÛÛ" +#define B_FAT "ÛÛÛÛÛÛÛÛ" #endif /* HB_BOX_H_ */ diff --git a/harbour/include/directry.ch b/harbour/include/directry.ch index 2edb3d4d0e..e5e0eae95a 100644 --- a/harbour/include/directry.ch +++ b/harbour/include/directry.ch @@ -6,11 +6,11 @@ #define _DIRECTRY_CH /* Positions for DIRECTORY() array */ -#define F_NAME 1 -#define F_SIZE 2 -#define F_DATE 3 -#define F_TIME 4 -#define F_ATTR 5 +#define F_NAME 1 /* File name */ +#define F_SIZE 2 /* File size */ +#define F_DATE 3 /* File date (write) */ +#define F_TIME 4 /* File time (write) */ +#define F_ATTR 5 /* File attribute */ /* Length of DIRECTORY() array */ #define F_LEN 5 diff --git a/harbour/include/memoedit.ch b/harbour/include/memoedit.ch index 91dd450497..163e7c56e6 100644 --- a/harbour/include/memoedit.ch +++ b/harbour/include/memoedit.ch @@ -6,19 +6,23 @@ #define _MEMOEDIT_CH /* User callback status modes */ -#define ME_IDLE 0 /* Idle, all keys processed */ -#define ME_UNKEY 1 /* Unknown key, memo unaltered */ -#define ME_UNKEYX 2 /* Unknown key, memo altered */ -#define ME_INIT 3 /* Initialization mode */ +#define ME_IDLE 0 /* Idle, all keys processed */ +#define ME_UNKEY 1 /* Unknown key, memo unaltered */ +#define ME_UNKEYX 2 /* Unknown key, memo altered */ +#define ME_INIT 3 /* Initialization mode */ +#define ME_REQUEST 4 /* Memoedit requests an input from */ + /* the user function, e.g. after */ + /* ME_PASTE */ /* XBase++ extension */ /* User callback return codes */ -#define ME_DEFAULT 0 /* Perform default action */ -#define ME_IGNORE 32 /* Ignore unknown key */ -#define ME_DATA 33 /* Treat unknown key as data */ -#define ME_TOGGLEWRAP 34 /* Toggle word-wrap mode */ -#define ME_TOGGLESCROLL 35 /* Toggle scrolling mode */ -#define ME_WORDRIGHT 100 /* Perform word-right operation */ -#define ME_BOTTOMRIGHT 101 /* Perform bottom-right operation */ +#define ME_DEFAULT 0 /* Perform default action */ +#define ME_IGNORE 32 /* Ignore unknown key */ +#define ME_DATA 33 /* Treat unknown key as data */ +#define ME_TOGGLEWRAP 34 /* Toggle word-wrap mode */ +#define ME_TOGGLESCROLL 35 /* Toggle scrolling mode */ +#define ME_WORDRIGHT 100 /* Perform word-right operation */ +#define ME_BOTTOMRIGHT 101 /* Perform bottom-right operation */ +#define ME_PASTE 110 /* Paste string into buffer */ /* XBase++ extension */ /* NOTE: Return codes 1-31 cause MEMOEDIT() to perform the */ /* edit action corresponding to the key whose value is returned. */ diff --git a/harbour/source/rtl/Makefile b/harbour/source/rtl/Makefile index 3d66caee25..8138f8b695 100644 --- a/harbour/source/rtl/Makefile +++ b/harbour/source/rtl/Makefile @@ -35,6 +35,7 @@ C_SOURCES=\ msgxxx.c \ PRG_SOURCES=\ + achoice.prg \ alert.prg \ asort.prg \ devoutp.prg \ diff --git a/harbour/source/rtl/achoice.prg b/harbour/source/rtl/achoice.prg new file mode 100644 index 0000000000..191b9419cf --- /dev/null +++ b/harbour/source/rtl/achoice.prg @@ -0,0 +1,628 @@ +/* + * $Id$ + */ + +/* + Harbour Project source code + www - http://www.Harbour-Project.org + + A pure Clipper emulation of the ACHOICE function. + + Author: Peter Townsend + Code donated to the Public Domain +*/ + +#include "inkey.ch" +#include "setcurs.ch" +#include "set.ch" +#include "achoice.ch" +#include "common.ch" + +/* $DOC$ + * $FUNCNAME$ + * ACHOICE() + * + * $ONELINER$ + * Allows selection of an element from an array + * + * $SYNTAX$ + * ACHOICE(, , , , + * , + * [ | ], + * [], + * [], + * []) --> nPosition + * + * $ARGUMENTS$ + * nTop - topmost row used to display array (default 0) + * nLeft - leftmost row used to display array (default 0) + * nBottom - bottommost row used to display array (default MAXROW()) + * nRight - rightmost row used to display array (default MAXCOL()) + * acMenuItems - the character array of items from which to select + * alSelectableItems - an array of items, either logical or character, + * which is used to determine if a particular item + * may be selected. If the type of a given item is + * character, it is macro evaluated, and the result + * is expected to be a logical. A value of .T. means + * that the item may be selected, .F. that it may not. + * (See next argument: lSelectableItems) + * lSelectableItems - a logical value which is used to apply to all + * items in acMenuItems. If .T., all items may be + * selected; if .F., none may be selected. + * (See previous argument: alSelectableItems) + * Default .T. + * cUserFunction - the name of a function to be called which may + * effect special processing of keystrokes. It is + * specified without parentheses or parameters. + * When it is called, it will be supplied with the + * parameters: nMode, nCurElement, and nRowPos. + * Default NIL. + * nInitialItem - the number of the element to be highlighted as + * the current item when the array is initally + * displayed. 1 origin. Default 1. + * nWindowRow - the number of the window row on which the initial + * item is to be displayed. 0 origin. Default 0. + * + * $RETURNS$ + * nPosition - the number of the item to be selected, or 0 if the + * selection was aborted. + * + * $DESCRIPTION$ + * Allows selection of an element from an array. + * Please see standard Clipper documentation for ACHOICE for + * additional detail. + * + * $EXAMPLES$ + * aItems := { "One", "Two", "Three" } + * nChoice := ACHOICE( 10, 10, 20, 20, aItems ) + * IF nChoice == 0 + * ? "You did not choose an item" + * ELSE + * ? "You chose element " + LTRIM( STR( nChoice ) ) + * ?? " which has a value of " + aItems[ nChoice ] + * ENDIF + * + * $SEEALSO$ + * ACHOICE() - as supplied in Clipper + * + * $INCLUDE$ + * common.ch + * inkey.ch + * set.ch + * setcurs.ch + * achoice.ch + * + * $END$ + */ + +*+-------------------------------------------------------------------- +*+ +*+ Function achoice() +*+ +*+-------------------------------------------------------------------- +*+ +function achoice( nTop, nLft, nBtm, nRyt, acItems, xSelect, cUserFunc, nPos, nHiLytRow ) + +local nNumCols := 0 // Number of columns in the window +local nNumRows := 0 // Number of rows in the window +local acCopy := {} // A padded copy of the items +local alSelect := {} // Select permission +local nNewPos := 0 // The next item to be selected +local lFinished := .F. // Is processing finished? +local nKey := 0 // The keystroke to be processed +local nMode := AC_IDLE // The current operating mode +local nAtTop := 1 // The number of the item at the top +local nAtBtm := 1 // The number of the item at the bottom +local nItems := 0 // The number of items +local nGap := 0 // The number of lines between top and current lines + // Block used to search for items +local bScan := { | cX | if( left( cX, 1 ) == upper( chr( nKey ) ), .T., .F. ) } + // Is a user function to be used? +local lUserFunc := ( !empty( cUserFunc ) ) +local nUserFunc := 0 // Return value from user function +local bUserFunc := { || AC_ABORT } // Block form of user function +local cLoClr := Before( ",", setcolor() ) +local cHiClr := Before( ",", After( ",", setcolor() ) ) +local cUnClr := After( ",", After( ",", After( ",", After( ",", setcolor() ) ) ) ) +local nSaveCsr := setcursor( SC_NONE ) +local nFrstItem := 0 +local nLastItem := 0 +local nCntr + +IF lUserFunc + bUserFunc := cUserFunc +endif + +IF empty( cHiClr ) + cHiClr := After( "/", cLoClr ) + "/" + Before( "/", cLoClr ) +endif + +IF empty( cUnClr ) + cUnClr := cLoClr +endif + +DEFAULT nTop to 0 // The topmost row of the window +DEFAULT nLft to 0 // The leftmost column of the window +DEFAULT nBtm to maxrow() + 1 // The bottommost row of the windows +DEFAULT nRyt to maxcol() + 1 // The rightmost column of the window +DEFAULT acItems to {} // The items from which to choose +DEFAULT xSelect to .T. // Array or logical, what is selectable +DEFAULT cUserFunc to NIL // Optional function for key exceptions +DEFAULT nPos to 1 // The number of the selected item +DEFAULT nHiLytRow to 0 // The row to be highlighted + +nNumCols := nRyt - nLft + 1 +nNumRows := nBtm - nTop + 1 +aeval( acItems, { | x, n | if( valtype( x ) == "C", aadd( acCopy, padr( x, nNumCols ) ), .F. ) } ) +nItems := len( acCopy ) + +alSelect := array( nItems ) +IF valtype( xSelect ) == "A" + afill( alSelect, .T. ) + for nCntr := 1 to len( xSelect ) + IF nCntr <= nItems + IF valtype( xSelect[ nCntr ] ) == "C" + IF empty( xSelect[ nCntr ] ) + lFinished := .T. + nPos := 0 + else +/* TODO: When macro evaluation will work, this should be commented out: + alSelect[ nCntr ] := &( xSelect[ nCntr ] ) +*/ + endif + else + alSelect[ nCntr ] := xSelect[ nCntr ] + endif + else + nCntr := len( xSelect ) + 1 + endif + next +else + afill( alSelect, xSelect ) +endif + +IF !lFinished + + nFrstItem := ascan( alSelect, .T. ) // First valid item + + IF nFrstItem == 0 + nLastItem := 0 + nPos := 0 + nMode := AC_NOITEM + else + nMode := AC_IDLE + nLastItem := nItems // Last valid item + do while ( !alSelect[ nLastItem ] ) + nLastItem -- + enddo + endif + + // Ensure hilighted item can be selected + nPos := Between( nFrstItem, nPos, nLastItem ) + + // Force hilighted row to be valid + nHiLytRow := Between( 0, nHiLytRow, nNumRows - 1 ) + + // Force the topmost item to be a valid index of the array + nAtTop := Between( 1, max( 1, nPos - nHiLytRow ), nItems ) + + // Ensure as much of the selection area as possible is covered + if ( nAtTop + nNumRows - 1 ) > nItems + nAtTop := max( 1, nItems - nNumrows + 1 ) + endif + + DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr ) + +endif + +do while ( !lFinished ) + + IF nMode != AC_GOTO .and. nMode != AC_NOITEM + nKey := Inkey( 0 ) + nMode := AC_IDLE + endif + + do case + case ( ( nKey == K_ESC ) .or. ( nMode == AC_NOITEM ) ) .and. ( !lUserFunc ) + nMode := AC_ABORT + nPos := 0 + lFinished := .T. + + case nKey == K_UP + IF nPos == nFrstItem + nMode := AC_HITTOP + IF nAtTop > max( 1, nPos - nNumRows + 1 ) + nAtTop := max( 1, nPos - nNumRows + 1 ) + DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr ) + endif + else + nNewPos := nPos - 1 + do while !alSelect[ nNewPos ] + nNewPos -- + enddo + IF InRange( nAtTop, nNewPos, nAtTop + nNumRows - 1 ) + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr ) + nPos := nNewPos + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T., cLoClr, cHiClr, cUnClr ) + else + dispbegin() + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr ) + scroll( nTop, nLft, nBtm, nRyt, ( nNewPos - ( nAtTop + nNumRows - 1 ) ) ) + nAtTop := nNewPos + nPos := max( nPos, nAtTop + nNumRows - 1 ) + do while nPos > nNewPos + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr ) + nPos -- + enddo + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T., cLoClr, cHiClr, cUnClr ) + dispend() + endif + endif + + case nKey == K_DOWN + * Find the next selectable item to display + IF nPos == nLastItem + nMode := AC_HITBOTTOM + IF nAtTop < min( nPos, nItems - nNumRows + 1 ) + nAtTop := min( nPos, nItems - nNumRows + 1 ) + DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr ) + endif + else + + nNewPos := nPos + 1 + + do while !alSelect[ nNewPos ] + nNewPos ++ + enddo + + IF InRange( nAtTop, nNewPos, nAtTop + nNumRows - 1 ) + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr ) + nPos := nNewPos + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T., cLoClr, cHiClr, cUnClr ) + else + dispbegin() + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr ) + scroll( nTop, nLft, nBtm, nRyt, ( nNewPos - ( nAtTop + nNumRows - 1 ) ) ) + nAtTop := nNewPos - nNumRows + 1 + nPos := max( nPos, nAtTop ) + do while nPos < nNewPos + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr ) + nPos ++ + enddo + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T., cLoClr, cHiClr, cUnClr ) + dispend() + endif + + endif + + case ( ( nKey == K_HOME ) .or. ( nKey == K_CTRL_PGUP ) ) .and. ( !lUserFunc ) + IF nPos == nFrstItem + IF nAtTop == max( 1, nPos - nNumRows + 1 ) + nMode := AC_HITTOP + else + nAtTop := max( 1, nPos - nNumRows + 1 ) + DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr ) + endif + else + nPos := nFrstItem + nAtTop := nPos + DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr ) + endif + + case ( ( nKey == K_END ) .or. ( nKey == K_CTRL_PGDN ) ) .and. ( !lUserFunc ) + IF nPos == nLastItem + IF nAtTop == min( nLastItem, nItems - nNumRows + 1 ) + nMode := AC_HITBOTTOM + else + nAtTop := min( nLastItem, nItems - nNumRows + 1 ) + DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr ) + endif + else + IF InRange( nAtTop, nLastItem, nAtTop + nNumRows - 1 ) + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr ) + nPos := nLastItem + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T., cLoClr, cHiClr, cUnClr ) + else + nPos := nLastItem + nAtTop := max( 1, nPos - nNumRows + 1 ) + DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr ) + endif + endif + + case nKey == K_CTRL_HOME + IF nPos == nFrstItem + IF nAtTop == max( 1, nPos - nNumRows + 1 ) + nMode := AC_HITTOP + else + nAtTop := max( 1, nPos - nNumRows + 1 ) + DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr ) + endif + else + nNewPos := nAtTop + do while !alSelect[ nNewPos ] + nNewPos ++ + enddo + IF nNewPos != nPos + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr ) + nPos := nNewPos + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T., cLoClr, cHiClr, cUnClr ) + endif + endif + + case nKey == K_CTRL_END + IF nPos == nLastItem + IF nAtTop == min( nPos, nItems - nNumRows + 1 ) + nMode := AC_HITBOTTOM + else + nAtTop := min( nPos, nItems - nNumRows + 1 ) + DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr ) + endif + else + nNewPos := nAtTop + nNumRows - 1 + do while !alSelect[ nNewPos ] + nNewPos -- + enddo + IF nNewPos != nPos + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr ) + nPos := nNewPos + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T., cLoClr, cHiClr, cUnClr ) + endif + endif + + case nKey == K_PGUP + IF nPos == nFrstItem + nMode := AC_HITTOP + IF nAtTop > max( 1, nPos - nNumRows + 1 ) + nAtTop := max( 1, nPos - nNumRows + 1 ) + DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr ) + endif + else + IF InRange( nAtTop, nFrstItem, nAtTop + nNumRows - 1 ) + * On same page as nFrstItem + nPos := nFrstItem + nAtTop := max( nPos - nNumRows + 1, 1 ) + DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr ) + else + if ( nPos - nNumRows + 1 ) < nFrstItem + nPos := nFrstItem + nAtTop := nFrstItem + else + nPos := max( nFrstItem, nPos - nNumRows + 1 ) + nAtTop := max( 1, nAtTop - nNumRows + 1 ) + do while ( nPos > nFrstItem ) .and. ( !alSelect[ nPos ] ) + nPos -- + nAtTop -- + enddo + nAtTop := max( 1, nAtTop ) + endif + DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr ) + endif + endif + + case nKey == K_PGDN + IF nPos == nLastItem + nMode := AC_HITBOTTOM + IF nAtTop < min( nPos, nItems - nNumRows + 1 ) + nAtTop := min( nPos, nItems - nNumRows + 1 ) + DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr ) + endif + else + IF InRange( nAtTop, nLastItem, nAtTop + nNumRows - 1 ) + * On the same page as nLastItem + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr ) + nPos := nLastItem + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T., cLoClr, cHiClr, cUnClr ) + else + nGap := nPos - nAtTop + nPos := min( nLastItem, nPos + nNumRows - 1 ) + if ( nPos + nNumRows - 1 ) > nLastItem + * On the last page + nAtTop := nLastItem - nNumRows + 1 + nPos := min( nLastItem, nAtTop + nGap ) + else + * Not on the last page + nAtTop := nPos - nGap + endif + * Make sure that the item is selectable + do while ( nPos < nLastItem ) .and. ( !alSelect[ nPos ] ) + nPos ++ + nAtTop ++ + enddo + * Don't leave blank space on the page + do while ( nAtTop + nNumRows - 1 ) > nItems + nAtTop -- + enddo + DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr ) + endif + endif + + case ( nKey == K_ENTER ) .and. ( !lUserFunc ) + nMode := AC_SELECT + lFinished := .T. + + case ( nKey == K_RIGHT ) .and. ( !lUserFunc ) + nPos := 0 + lFinished := .T. + + case ( nKey == K_LEFT ) .and. ( !lUserFunc ) + nPos := 0 + lFinished := .T. + + case InRange( 32, nKey, 255 ) .and. ( ( !lUserFunc ) .or. ( nMode == AC_GOTO ) ) + * Find next selectable item + nNewPos := ascan( acCopy, bScan, nPos + 1 ) + do while InRange( nPos, nNewPos, nLastItem ) .and. ( !alSelect[ nNewPos ] ) + nNewPos := ascan( acCopy, bScan, nNewPos + 1 ) + enddo + + IF nNewPos == 0 + * Loop back to beginning item, if there is one + nNewPos := ascan( acCopy, bScan ) + do while InRange( 1, nNewPos, nLastItem ) .and. ( !alSelect[ nNewPos ] ) + nNewPos := ascan( acCopy, bScan, nNewPos + 1 ) + enddo + endif + + IF InRange( nFrstItem, nNewPos, nLastItem ) .and. alSelect[ nNewPos ] + IF InRange( nAtTop, nNewPos, nAtTop + nNumRows - 1 ) + * On same page + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr ) + nPos := nNewPos + DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T., cLoClr, cHiClr, cUnClr ) + else + * On different page + nPos := nNewPos + nAtTop := Between( 1, nPos - nNumRows + 1, nItems ) + DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr ) + endif + endif + + nMode := AC_IDLE + + case ( nMode == AC_GOTO ) + * Garbage collect gotos which aren't valid ASCII characters + nMode := AC_IDLE + + otherwise + IF nKey == 0 // No keystroke + nMode := AC_IDLE + else + nMode := AC_EXCEPT + endif + + endcase + + IF lUserFunc + nUserFunc := do( bUserFunc, nMode, nPos, nPos - nAtTop ) + // DISPVAR nUserFunc + do case + case nUserFunc == AC_ABORT + lFinished := .T. + nPos := 0 + case nUserFunc == AC_SELECT + lFinished := .T. + case nUserFunc == AC_CONT + * Do nothing + case nUserFunc == AC_GOTO + * Do nothing. The next keystroke won't be read and + * this keystroke will be processed as a goto. + nMode := AC_GOTO + endcase + endif + +enddo + +setcursor( nSaveCsr ) + +return ( nPos ) + +*+-------------------------------------------------------------------- +*+ +*+ Static Function DispPage() +*+ +*+ Called from ( achoice.prg ) 15 - function achoice() +*+ +*+-------------------------------------------------------------------- +*+ +static function DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr ) + +local nCntr +local nRow // Screen row +local nIndex // Array index +local nSaveRow := row() // Position at start of routine +local nSaveCol := col() // Position at start of routine +local nArrLen := len( acCopy ) + +dispbegin() +for nCntr := 1 to nNumRows + nRow := nTop + nCntr - 1 + nIndex := nCntr + nAtTop - 1 + IF InRange( 1, nIndex, nArrLen ) + DispLine( acCopy[ nIndex ], nRow, nLft, alSelect[ nIndex ], nIndex == nPos, cLoClr, cHiClr, cUnClr ) + else + @ nRow, nLft say space( len( acCopy[ 1 ] ) ) color cLoClr + endif +next +dispend() + +setpos( nSaveRow, nSaveCol ) + +return ( NIL ) + +*+-------------------------------------------------------------------- +*+ +*+ Static Function DispLine() +*+ +*+ Called from ( achoice.prg ) 20 - function achoice() +*+ 1 - static function disppage() +*+ +*+-------------------------------------------------------------------- +*+ +static function DispLine( cLine, nRow, nCol, lSelect, lHiLyt, cLoClr, cHiClr, cUnClr ) + +DEFAULT lHiLyt to .F. + +@ nRow, nCol say cLine color if( lSelect, if( lHiLyt, cHiClr, cLoClr ), cUnClr ) + +return ( NIL ) + +*+-------------------------------------------------------------------- +*+ +*+ Static Function InRange() +*+ +*+ Called from ( achoice.prg ) 10 - function achoice() +*+ 1 - static function disppage() +*+ +*+-------------------------------------------------------------------- +*+ +static function InRange( xLo, xVal, xHi ) + +return ( ( xVal >= xLo ) .and. ( xVal <= xHi ) ) + +*+-------------------------------------------------------------------- +*+ +*+ Static Function Between() +*+ +*+ Called from ( achoice.prg ) 4 - function achoice() +*+ +*+-------------------------------------------------------------------- +*+ +static function Between( xLo, xVal, xHi ) + +return ( min( max( xLo, xVal ), xHi ) ) + +*+-------------------------------------------------------------------- +*+ +*+ Static Function Before() +*+ +*+ Called from ( achoice.prg ) 3 - function achoice() +*+ +*+-------------------------------------------------------------------- +*+ +static function Before( cDelim, cValue ) + +local cRetVal := cValue + +IF cDelim $ cValue + cRetVal := left( cValue, at( cDelim, cValue ) - 1 ) +endif + +return ( cRetVal ) + +*+-------------------------------------------------------------------- +*+ +*+ Static Function After() +*+ +*+ Called from ( achoice.prg ) 6 - function achoice() +*+ +*+-------------------------------------------------------------------- +*+ +static function After( cDelim, cValue ) + +local cRetVal := "" + +IF cDelim $ cValue + cRetVal := substr( cValue, at( cDelim, cValue ) + 1 ) +endif + +return ( cRetVal ) diff --git a/harbour/tests/working/Makefile b/harbour/tests/working/Makefile index a67516b08b..9ea84a0535 100644 --- a/harbour/tests/working/Makefile +++ b/harbour/tests/working/Makefile @@ -16,6 +16,7 @@ ifeq ($(PM),) endif ifeq ($(PM),) # PM not defined = build all files PRG_SOURCES=\ + ac_test.prg \ ainstest.prg \ and_or.prg \ array16.prg \ diff --git a/harbour/tests/working/ac_test.prg b/harbour/tests/working/ac_test.prg new file mode 100644 index 0000000000..e9fadbac60 --- /dev/null +++ b/harbour/tests/working/ac_test.prg @@ -0,0 +1,221 @@ +*+==================================================================== +*+ +*+ Source Module => E:\MULTI\AC_TEST.PRG +*+ +*+ Released to Public Domain. +*+ +*+ Functions: Procedure test() +*+ Function cUserFunction() +*+ +*+ Tables: use vendor exclusive +*+ +*+ Reformatted by Click! 1.10 on Aug-13-1997 at 11:39 pm +*+ +*+==================================================================== + +#include "achoice.ch" +#include "inkey.ch" + +*+-------------------------------------------------------------------- +*+ +*+ Procedure test() +*+ +*+-------------------------------------------------------------------- +*+ +procedure main() + +local aPrompts := {; + "AGRI-PLANTS" ,; + "ALAN R. SMITH GREENHOUSES" ,; + "ALLAN MURRAY NURSERY, INC." ,; + "APOPKA FOREST" ,; + "LIGHT HOUSE NURSERIES" ,; + "BAUCOM'S" ,; + "BAY HILL NURSERY, INC." ,; + "BAYWOOD NURSERIES" ,; + "BIG OAK NURSERY" ,; + "C & N NURSERY" ,; + "CHARLES QUALITY PLANTS" ,; + "CONNELL FARMS" ,; + "DEWAR NURSERIES, INC." ,; + "DIAMOND T NURSERY" ,; + "DISTINCTIVE PALMS NURSERIES" ,; + "DONKAY NURSERY" ,; + "DOUG INGRAM & SONS NURSERY" ,; + "DRIFTWOOD GARDENS, INC." ,; + "ELVA PLANT NURSERY, INC." ,; + "ERINON" ,; + "EVANS NURSERY" ,; + "FANCY PLANTS" ,; + "FL.PLANT GROWERSCOOP" ,; + "FLORIDA CACTUS INC." ,; + "FLOWERING TREE GROWERS, INC." ,; + "FLOWERWOOD NURSERY" ,; + "FOLIAGE FACTORY TOO" ,; + "GATOR GROWERS NURSERY, INC." ,; + "GAZEBO LANDSCAPE DESIGN, INC." ,; + "GEM ORNAMENTALS" ,; + "GRANNY'S GARDEN" ,; + "GRAY'S ORNAMENTALS" ,; + "GREEN MASTERS INC." ,; + "GREEN MEADOW NURSERY" ,; + "PIXLEY'S PLANT PLACE" ,; + "HARRISON'S NURSERY, INC." ,; + "G & G FOLIAGE" ,; + "IVEY'S NURSERY, INC." ,; + "JB NURSERIES, INC." ,; + "JON'S NURSERY" ,; + "JONES & JONES NURSERY, INC." ,; + "KAGER'S NURSERY" ,; + "KIRKLAND'S NURSERY" ,; + "LAND OF BROMELIADS" ,; + "LANDSCAPE NURSERY, INC." ,; + "LIEWALD'S NURSERY INC." ,; + "LLOYD & RINGS NURSERY" ,; + "LONG VAN DOUNG" ,; + "MAPEL'S LANDSCAPE NURSERY" ,; + "MILESTONE AGRICULTURE, INC." ,; + "MOJICA NURSERY & FRUITS" ,; + "NELSON'S ROSES" ,; + "PARK GARDENS" ,; + "PAUL LUKAS INC." ,; + "PECKETT'S INC." ,; + "PENANG NURSERY, INC." ,; + "PINES III NURERIES" ,; + "PINEVIEW NURSERY" ,; + "POUL JENSEN NURSERY" ,; + "R.P. WELKER" ,; + "RICHARD ROGERS NURSERY, INC." ,; + "SPRING HILL NURSERY" ,; + "T.O. MAHAFFEY, JR." ,; + "TUCKER NURSERY" ,; + "TURTLE POND NURSERY" ,; + "TUTTLE'S NURSERY INC." ,; + "VALLEY CACTUS" ,; + "WHISPER WINDS, INC." ,; + "WHITE ROSE NURSERIES INC." ,; + "WOODWAY" ,; + "FLORI-DESIGN" ,; + "GREEN ACRES FOLIAGE, INC" ,; + "FLORAL EXPO" ,; + "TORRES NURSERY" ,; + "DARRYL KOON" ,; + "TRISTAR NURSERY" ,; + "KAY WEST NURSERY" ,; + "JAYMAR NURSERY" ,; + "J D F LANDSCAPE NURSERY" ,; + "DEROOSE PLANTS, INC." ,; + "THE TREEHOUSE" ,; + "COSTELLO'S ARECAS, INC." ,; + "FLORICO FOLIAGE" ,; + "THE NATIVES" ,; + "GREENS NURSERY" ,; + "STEWART NURSERIES" ,; + "G & T FOLIAGE, INC." ,; + "GOOD TIMES NURSERY" ,; + "CONCEPTS IN GREENERY, INC." ,; + "DUNN BROTHERS CITRUS, INC." ,; + "JOHN PLANK GREENHOUSES" ,; + "GREENER PASTURES NURSERY" ,; + "MULVEHILL NURSERY" ,; + "A NU LEAF" ,; + "IVY DESIGNS, INC." ,; + "B & C TROPICALS" ,; + "SPANISH RIVER NURSERY, INC." ,; + "JACK CHRISTMAS & ASSOCIATES" ,; + "SPECIALIST GROWERS" ,; + "HOMRICH NURSERY, INC." ,; + "COUNTRYSIDE FOLIAGE, INC." ,; + "RFJ COMPANY" ,; + "LAKE BRANTLEY PLANT CORP." ,; + "MARISTYME" ,; + "MERISTEM NURSERY, INC." ,; + "TROPIC DECOR - EARL WILSON" ,; + "URQUHART'S NURSERY" ,; + "ACE PLANT NURSERY" ,; + "HATTAWAYS GREENHOUSE, INC." ,; + "Florida Plant Growers" ,; + "Junior Nursery" ,; + "Fox's Nurseries, Inc." ,; + "Vaughan Nursery" ,; + "MERRYGRO FARMS" ,; + "ALL SEASONS NURSERY" ,; + "BENCHMARK FOLIAGE" ,; + "SAMMY'S NURSERY" ,; + "SUNSHINE GROWERS" ,; + "Blooming-Fields Nursery" } + +local aPermits := {} +local x := 1 +local nChoice +local ncntr + +clear screen + +setcolor( 'GB+/B,GR+/R,,,W/N' ) + +asize( aPermits, Len( aPrompts ) ) + +for x := 1 to Len( aPrompts ) + aPermits[ x ] := !( 'V' $ aPrompts[ x ] ) +next + +#define TEST1 +#ifdef TEST1 +for ncntr := 1 to 17 + aPermits[ nCntr ] := .F. + aPermits[ Len( aPrompts ) - nCntr + 1 ] := .F. +next +aPermits[ 32 ] := .F. +aPermits[ 33 ] := .F. +aPermits[ 34 ] := .F. +#endif + +nChoice := achoice( 5, 10, 20, 70, aPrompts, aPermits, "cUserFunction" ) + +setpos( 0, 0 ) +* clear screen +? nChoice + +if nChoice > 0 + ? aPrompts[ nChoice ] +endif +setpos( maxrow() - 2, 0 ) + +return + +*+-------------------------------------------------------------------- +*+ +*+ Function cUserFunction() +*+ +*+-------------------------------------------------------------------- +*+ +function cUserFunction( nMode, nCurElement, nRowPos ) + +local nRetVal := AC_CONT // Default, Continue +local nKey := lastkey() +do case + // After all pending keys are processed, display message +case nMode == AC_IDLE + @ 0, 0 say padr( ltrim( str( nCurElement ) ), 10 ) + nRetVal := AC_CONT // Continue ACHOICE() +case nMode == AC_HITTOP // Attempt to go past Top + @ 0, 0 say "Hit Top " +// tone( 100, 3 ) +case nMode == AC_HITBOTTOM // Attempt to go past Bottom + @ 0, 0 say "Hit Bottom" +// tone( 100, 3 ) +case nMode == AC_EXCEPT // Key Exception + @ 0, 0 say "Exception " + do case + case nKey == K_RETURN // If RETURN key, select + nRetVal := AC_SELECT + case nKey == K_ESC // If ESCAPE key, abort + nRetVal := AC_ABORT + otherwise + nRetVal := AC_GOTO // Otherwise, go to item + endcase +endcase +return nRetVal + +*+ EOF: AC_TEST.PRG