home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / progmisc / nfsrc21.zip / ACH2TB.PRG < prev    next >
Text File  |  1992-10-17  |  35KB  |  847 lines
  1. /*
  2.  * File......: ACH2TB.PRG
  3.  * Author....: Steve Kolterman
  4.  * CIS ID....: 76320,37
  5.  * Date......: $Date:   17 Oct 1992 16:26:12  $
  6.  * Revision..: $Revision:   1.4  $
  7.  * Log file..: $Logfile:   C:/nanfor/src/ach2tb.prv  $
  8.  * 
  9.  * This is an original work by Steve Kolterman and is placed in the
  10.  * public domain.
  11.  *
  12.  * Modification history:
  13.  * ---------------------
  14.  *
  15.  * $Log:   C:/nanfor/src/ach2tb.prv  $
  16.  * 
  17.  *    Rev 1.4   17 Oct 1992 16:26:12   GLENN
  18.  * Leo cleaned up the documentation block.
  19.  * 
  20.  *    Rev 1.3   07 Oct 1992 23:31:10   GLENN
  21.  * Latest Kolterman updates.
  22.  * 
  23.  *    Rev 1.2   15 Aug 1991 23:17:48   GLENN
  24.  * Last minute fix sent in by Steve Kolterman
  25.  * 
  26.  *    Rev 1.1   15 Aug 1991 23:06:16   GLENN
  27.  * Forest Belt proofread/edited/cleaned up doc
  28.  * 
  29.  *    Rev 1.0   14 Jun 1991 04:14:14   GLENN
  30.  * Initial revision.
  31.  *
  32.  */
  33.  
  34. /*  $DOC$
  35.  *  $FUNCNAME$
  36.  *     FT_Ach2tb()
  37.  *  $CATEGORY$
  38.  *     Menus/Prompts
  39.  *  $ONELINER$
  40.  *     Replace ACHOICE() with a Tbrowse object & multiple features.
  41.  *  $SYNTAX$
  42.  *     FT_Ach2tb( <nToprow>,<nTopcol>[,<nBotrow>][,<nBotcol>],<aArrey>,     ;
  43.  *           [<cBoxtype>],[<cBoxcolor>],[<cBoxtitle>],[<nTitlePos>],        ;
  44.  *           [<cUselcolor>],[<cTitlecolor>],[<cBarcolor>],[<cHkcolor>],     ;
  45.  *           [<lShadow>],[<lExecute>],[<nMsgrow>],[<nMsgcol>],              ;
  46.  *           [<cMsg.color>],[cElevbar],[cEbarcolor],[<cEbarside>],          ;
  47.  *           [<cNoSelcolor>],[<cTagch>],[<nStartelem>],[<lRscreen>],        ;
  48.  *           [<nTimeout>],[<nTimeoutval>],[<cUserfunc>] )
  49.  *      --> nOption
  50.  *
  51.  *  $ARGUMENTS$
  52.  *
  53.  *  <nToprow>   is the top row of the box to be drawn.  Required.
  54.  *
  55.  *  <nTopcol>   is the top column of the box to be drawn.  Required.
  56.  *
  57.  *  <nBotrow>   is the bottom row of the box to be drawn.  The default is
  58.  *     <nToprow>+Len(<aArrey>)+1 or maxrow()-2, whichever is less.
  59.  *
  60.  *  <nBotcol>   is the bottom column of the box to be drawn.  The default
  61.  *     is <nTopcol>+width of the widest element in <aArrey> +2.
  62.  *
  63.  *     It's been pointed out that the number of commas required to default
  64.  *     the <nBotrow> and <nBotcol> params. is at least slightly confusing.
  65.  *     So, some documentation on the requirements:
  66.  *     Default both:                           7,9,,   ARRAY:
  67.  *     Default <nBotrow>, specify <nBotcol>:   7,9,,20 ARRAY:
  68.  *     Default <nBotcol>, specify <nBotrow>:   7,9,15, ARRAY:
  69.  *
  70.  *  <aArrey>    is the arrey of options to present to the user.  Each
  71.  *     element can hold as many as five subelements, or as few as one.
  72.  *     Required.  Additional documentation below.
  73.  *
  74.  *  <cnBoxtype> is the type of box to draw.  Uses DispBox().  The
  75.  *     default is a double-line box.
  76.  *
  77.  *  <cBoxcolor> is the color with which to draw the box.  The default is
  78.  *     Setcolor().
  79.  *
  80.  *  <cBoxtitle> is title of the box drawn on <nToprow>.  The default is
  81.  *     no title.
  82.  *
  83.  *  <nTitlepos>  is the starting column position (to the right of
  84.  *     <nTopcol>) at which to draw <cBoxtitle>.  The default is 1.
  85.  *
  86.  *  <cUselcolor> is the color with which to draw unselected options.
  87.  *     The default is Setcolor().
  88.  *
  89.  *  <cTitlecolor> is the color with which to draw the box title.  The
  90.  *     default is yellow on red.
  91.  *
  92.  *  <cBarcolor>  is the color with which to draw the selection bar.
  93.  *     The default is yellow on black.
  94.  *
  95.  *  <cHkcolor>  is the default color with which to draw the hotkeys for
  96.  *     for each option.  This is used when no hotkey color is supplied
  97.  *     in <aArrey>.  The default is hiwhite on the current background
  98.  *     color.
  99.  *
  100.  *  <cShadow>   is a character string, either "L" or "R" (for left or
  101.  *     right) to designate the side of the box where a shadow will appear.
  102.  *     Leave this NIL to avoid drawing a shadow.  You might also leave
  103.  *     this NIL if you choose to use a .C or .ASM shadow function, which
  104.  *     is a good idea.  Shadoww(), included below, is flat-out SLOW.
  105.  *
  106.  *  <lExecute>  turn on/off execution of option when first letter is
  107.  *     pressed.  Rule:  setting in element 5 of each <aArrey> subarray
  108.  *     overrides <lexecute>.  If that element is left NIL, the <lexecute>
  109.  *     setting is used.  If <lexecute> is not passed and element 5 is NIL,
  110.  *     auto execution is turned ON.
  111.  *
  112.  *  <nMsgrow>  is the row on which to draw a message for each option.
  113.  *     The default is two rows below the bottom of the box.
  114.  *
  115.  *  <nMsgcol>  is the column at which to draw a message for each option.
  116.  *     The default is <nTopcol> +2.  To CENTER the message, pass "C".
  117.  *
  118.  *  <cMsgcolor>  is the default color with which to draw messages.  This
  119.  *     color is used when element 4 of each <aArrey> subarray is left NIL.
  120.  *     The default is Setcolor().
  121.  *
  122.  *  <cElevbar>  is the ASCII character to use as the elevator bar drawn
  123.  *     on the box.  Leave this NIL to draw no elevator bar.
  124.  *
  125.  *  <cEbarcolor>  is the color with which to draw the elevator bar.
  126.  *     This is ignored if <cElevbar> is NIL.
  127.  *
  128.  *  <cEbarside>  is a character string, either "L" or "R" (for left or
  129.  *     right) to designate the side of the box on which to draw the
  130.  *     elevator bar.  This is ignored if <cElevbar> is NIL.
  131.  *
  132.  *  <cNoselcolor>  is the color with which to draw unselectable options.
  133.  *     The default is white on black.
  134.  *
  135.  *  <cTagchar> is the ASCII character to use to draw tags that would
  136.  *     appear to the right of each option.  The default is *DIS*abled
  137.  *     tagging.  The default tag is "√" (chr(251)).
  138.  *
  139.  *  <nStartelem>  is the number of the option where the selection bar
  140.  *     will first be placed.  Leave this NIL to begin at option 1.
  141.  *
  142.  *  <lRestscrn>  is a logical to designate whether or not the screen
  143.  *     coordinates occupied by the box and/or shadow should be restored
  144.  *     before FT_Ach2tb() returns.  The default is .T.
  145.  *
  146.  *  <nTimeout>  is the number of seconds after which FT_ACH2TB() will
  147.  *     timeout and return to the function/proced. which called it.  The
  148.  *     default is 0.
  149.  *
  150.  *  <nTimeoutVal> is an optional alternative numeric value FT_ACH2TB() will
  151.  *     RETURN when/if it times out.  The default is the current element
  152.  *     number.
  153.  *
  154.  *  <bUserfunc>  is a code block containing a function call to be
  155.  *     executed after each key press.  You need to write just two formal
  156.  *     parameters to allow the run-time passing of the key pressed and the
  157.  *     current element number, e.g.:
  158.  *               { |key,num| Myfunc( key,num [,other params.] ) }
  159.  *     Unlimited extra parameters may be passed.  Of course, make certain
  160.  *     to also write 'receptors' for them in 'Myfunc()' itself...as in the
  161.  *     above example.  The default is NO user function.
  162.  *
  163.  *  $RETURNS$
  164.  *     the number of the selected option, or 0 if [Esc] is pressed.
  165.  *
  166.  *  $DESCRIPTION$
  167.  *     FT_Ach2tb() is a greatly enhanced, fully featured, and now mouse-
  168.  *     supported replacement for Achoice(), based on a Tbrowse object. 
  169.  *     Each element of <aArray> (the array you pass to it) is itself an
  170.  *     array.  Each element can solely composed of "Option" (below), but
  171.  *     may be composed as follows to take full advantage of the function's
  172.  *     features:
  173.  *
  174.  *         Option   ,     Message      ,HotKeyPos,HotKeyColor,Selectable
  175.  *     { "Utilities","System Utilities", 3       ,"+gr/b"    ,.T. }
  176.  *
  177.  *     All elements except for the first, the option itself, are optional.
  178.  *     IF 'Message' is NIL, no message is displayed.  'HotKeyPos' is the
  179.  *     position within 'Option' of the hotkey.  In the example above, the
  180.  *     hotkey for 'Utilities' is the first 'i', i.e., at position 3.  The
  181.  *     default is 1.  'HotKeyColor' is the color to use for the hotkey
  182.  *     display.  The default is hiwhite  on the current background color.
  183.  *     'Selectable' is a logical indicating whether or not that option can
  184.  *     be selected.  The default is .T.
  185.  *
  186.  *     The A_CHOICE() UDC in FT_ACH2T.CH makes using FT_ACH2TB() a breeze.
  187.  *     The myriad of parameters can be written in any order.  Only <nToprow>,
  188.  *     <nTopcol>, and <aArrey> are required.  See the example below.
  189.  *
  190.  *     There may be some confusion over 'unselected' and 'unselectable'
  191.  *     options.  The former refers to any option not currently covered
  192.  *     by the selection bar.  The latter refers to options you have
  193.  *     designated unselectable in subelement 5 of <aArray>, i.e., by
  194.  *     writing .F.
  195.  *
  196.  *     To enable tagging, pass any ASCII character as <cTagchar>.  To
  197.  *     tag/untag all options, press [SPACE].  To tag/untag individual
  198.  *     options, press [+] and [-] respectively.  On press of [+], browse
  199.  *     moves to the next element in the display.  To test for the tagged
  200.  *     status of an option, use the WAS_TAGGED() UDC in FT_ACH2T.CH. To
  201.  *     check the entire array for tags, use Aeval() in conjunction with
  202.  *     Was_Tagged() as in the example below.  When tagging is enabled, the
  203.  *     string "Tags" will be written across the bottom row of the box in
  204.  *     hiwhite on the current background color.
  205.  *
  206.  *     Because FT_ACH2TB() takes over the [SPACE],[+], and [-] keys, it saves
  207.  *     any SET KEY procedures you might have set them to, and restores same
  208.  *     on returning.  Any other procedures you might have SET KEYs to will
  209.  *     fly when FT_ACH2TB() is called...thanks to the Inkey() replacement,
  210.  *     SKINkey().
  211.  *
  212.  *     The piéce de resistance of FT_ACH2TB() is its ability to execute
  213.  *     a user function designed entirely by you.  It is called after each
  214.  *     keypress, and because it is completely open-ended, extends the
  215.  *     the reach of FT_ACH2TB() to the limits of Clipper.  See the docu-
  216.  *     mentation under <bUserfunc> above.
  217.  *
  218.  *
  219.  *     Test compile:  CLIPPER ft_ach2t /n/w/m/dFT_TEST
  220.  *     Test link   :  RTLINK FI ft_ach2t LIB nanfor /pll:base50
  221.  *
  222.  *
  223.  *     Mouse support
  224.  *     =============
  225.  *     Mouse support is provided via the Nanforum Toolkit FT_M* functions.
  226.  *     Most actions are tied to the left button.  The equivalent of pressing
  227.  *     [Esc] comes via the right button.  These left button clicks will
  228.  *     produce the designated actions:
  229.  *
  230.  *     Mouse cursor outside box                :  K_ENTER (select option)
  231.  *     Mouse cursor at box top left corner     :  browse:goTop()
  232.  *                         bottom left corner  :  browse:goBottom()
  233.  *                         top right corner    :  browse:pageUp()
  234.  *                         bottom right corner :  browse:pageDown()
  235.  *
  236.  *     Mouse cursor at option, tagging ENabled
  237.  *     --------------------------------------------
  238.  *     Selection bar moves to option, subsequent press to tag or untag.  Do
  239.  *     this for as many options as you want to tag/untag, then move mouse
  240.  *     cursor outside the box.  Press again to select.  Tagging overrides
  241.  *     <lExecute>, so with tagging on and <lExecute> .F., subsequent presses
  242.  *     while inside the box coordinates simply tag/untag.
  243.  *
  244.  *     Mouse cursor at option, tagging DISabled
  245.  *     ---------------------------------------------
  246.  *     IF <lExecute> is turned on, the option is immediately selected.  If
  247.  *     turned off, selection bar moves to option.  Press again to select.
  248.  *
  249.  *     To Disable Mouse Support
  250.  *     ------------------------
  251.  *     Compile with /dNOMOUSE
  252.  *
  253.  *
  254.  *  $EXAMPLES$
  255.  *  nOpt := A_CHOICE( 7,9,, ARRAY:t_array )   // the minimum
  256.  *
  257.  *  nOpt := A_CHOICE( 7,9,, ;
  258.  *            ARRAY:t_arrey ;
  259.  *            USERFUNC:{|a,b| UserFunc(a,b,any1)};
  260.  *            BOXTYPE:B_SINGLE  ;
  261.  *            BOXTITLE:title  ;
  262.  *            SHADOW:"FT" ;
  263.  *            TAGCHAR:chr(17) ;
  264.  *            REST_SCREEN:.F. ;
  265.  *            AUTOEXEC:.F. ;
  266.  *            MES_COLOR:MSG_COLOR ;
  267.  *            ELEVBAR:"▒" ;
  268.  *            NOSELCOLOR:"bg/n" ;
  269.  *            MES_COL:"C" )
  270.  *
  271.  *  Check only the RETURNed element for whether tagged:
  272.  *  IF( Was_Tagged(chr(17),t_arrey,nOpt), MoreProcessing(), )
  273.  *
  274.  *  Check entire 't_arrey':
  275.  *  Aeval( t_arrey,{|e,n| IF( Was_Tagged(chr(17),t_arrey,n ), ;
  276.  *                            MoreProcessing(t_arrey),NIL ) } )
  277.  *
  278.  *
  279.  *  $END$
  280.  */
  281.  
  282. #include "inkey.ch"
  283. #include "box.ch"
  284. #include "setcurs.ch"
  285. #include "ft_ach2t.ch"
  286.  
  287. #define KEY_ELEM         1
  288. #define BLK_ELEM         2
  289. #define AOPT             1
  290. #define AMSG             2
  291. #define AHOT             3
  292. #define ACLR             4
  293. #define ASEL             5
  294. #define OUTTA_TIME       999
  295. #define TIMED_OUT        (lkey==OUTTA_TIME)
  296. #define HOTKEY_PRESS     (aelem > 0)
  297. #define METHOD_PRESS     (meth_num > 0 .and. meth_num <= 10)
  298. #define TAGS             (tagchar<>NIL)
  299. #define TAG_PRESS        (TAGS .and. (meth_num > 11))
  300. #define CONTINUING       (lkey <> K_ESC)
  301. #define OUTTA_HERE       EXIT
  302. #define ATTOP            (aindex==1)
  303. #define ATBOTT           (aindex==Len(arrey))
  304. #define USEL_COLOR       FG(Setcolor())+"/"+BG(Setcolor())
  305. #define BARCOLOR         if(iscolor(),"+gr/n","n/w")
  306. #define TITLECOLOR       if(iscolor(),"+gr/r","n/w")
  307. #define DEMOCOLOR        if(iscolor(),"+gr/b","+w/n")
  308. #define HK_COLOR         if(iscolor(),"w+/"+ BG(setcolor()),"w+/n")
  309. #define SELECTABLE       (if(len(arrey[aindex])==5 .and. arrey[aindex][5]<> NIL,;
  310.                          arrey[aindex][5],aexec))
  311. #define NOSELECT         (len(arrey[aindex])==5 .and. !(arrey[aindex][5]))
  312. #define DEFAULT_TAG      "√"
  313. #define UP_ARROW_POS     t+2,col4bar
  314. #define DN_ARROW_POS     b-2,col4bar
  315. #define UP_ARROW         if(top_elem > 1,chr(24),chr(25))
  316. #define DN_ARROW         if(bot_elem < num_elems,chr(25),chr(24))
  317. #define GOING_UP         (meth_num==10 .or. Ltrim(str(meth_num)) $ "2468")
  318. #define GOING_DOWN       (Ltrim(str(meth_num)) $ "13579")
  319. #define MESG_LEN         aMsgdata[1]
  320. #define MESG_COL         aMsgdata[2]
  321.  
  322. #xtranslate DISPMSG(<r>,<c>,<msg>[,<color>])           => ;
  323.             SetPos(<r>,<c>); DispOut(<msg>[,<color>])
  324. #translate  Clear([<t>,<l>,<b>,<r>])                   => ;
  325.             SCROLL([<t>,<l>,<b>,<r>])
  326. #command    DEFAULT <p> TO <val> [,<pn> TO <valn>]     => ;
  327.             IF( <p> == NIL, <p> := <val>, ) ;
  328.             [; IF( <pn> == NIL, <pn> := <valn>,) ]
  329. #command    STABILIZE <o> => WHILE !<o>:stabilize() ; ENDDO
  330.  
  331. #ifndef K_SPACEBAR
  332. #define K_SPACEBAR 32
  333. #endif
  334. #ifndef K_PLUS
  335. #define K_PLUS  43
  336. #define K_MINUS 45
  337. #endif
  338.  
  339. STATIC aMsgData[2],aSaveArr:= {},oSaveobj
  340.  
  341. #ifdef FT_TEST
  342.  
  343. Function Test( passes )
  344.  
  345. //                 Item       Msg         HotKeyPos/HotkeyColor/Selectable
  346. LOCAL t_arrey:= { {"Larry"   ,"larry"    ,   ,"w+/b"          },;
  347.                   {"Dick"    ,"dick"     ,   ,"b/r"           },;
  348.                   {"Harry"   ,           ,  3,       ,.F.     },;
  349.                   {"Steve"   ,"steve"    ,  4,"g/bg"          },;
  350.                   {"Michelle","michelle"                      },;
  351.                   {"Barnabas",           ,  6,"gr+/w"         },;
  352.                   {"Fred"    ,"fred"                          },;
  353.                   {"Lisa"    ,"lisa"     ,  3,"n/r"           },;
  354.                   {"Eleanor" ,"eleanor"  ,  4,"bg/r"          },;
  355.                   {"Anthony" ,"anthony"  ,  3                 },;
  356.                   {"Charles" ,"charles"  ,   ,       ,.F.     },;
  357.                   {"Ollie"   ,"ollie"    ,  4,"r/w"           },;
  358.                   {"George"  ,           ,  5                 },;
  359.                   {"Paula"   ,"paula"                         },;
  360.                   {"Jack"    ,"jack"     ,  4                 },;
  361.                   {"Quinten" ,"quinten"                       },;
  362.                   {"Nancy"   ,"nancy"    ,  5,"w/n"           },;
  363.                   {"Warren"  ,"warren"   ,  1,"n/gr*"         } }
  364. LOCAL t_arrey2:= {{"Warren"  ,"warren"   ,   ,"w+/b"          },;
  365.                   {"Charles" ,"charles"                       },;
  366.                   {"Ollie"   ,"ollie"    ,  4,"r/w"           },;
  367.                   {"George"  ,           ,  5                 },;
  368.                   {"Paula"   ,"paula"    ,  3,"gr+/bg"        },;
  369.                   {"Harry"   ,           ,  3,       ,.F.     },;
  370.                   {"Michelle","michelle" ,   ,"gr+/gr"        },;
  371.                   {"Anthony" ,"anthony"  ,  2                 } }
  372.  
  373.  
  374. LOCAL title:= " SK Test ",ret1,xx,o_color:= Setcolor( DEMOCOLOR ),o_blink
  375. LOCAL any1:= "User function called!",ret2
  376. LOCAL any2:= "User function2 called!"
  377.  
  378. DEFAULT passes to 3; passes:= IF(valtype(passes)=="C",val(passes),passes)
  379.  
  380. Clear()
  381.  
  382. o_blink:= SetBlink(.F.)
  383. #ifndef NOMOUSE
  384.  FT_MReset() ; FT_MCursor(.T.)
  385. #endif
  386.  
  387. FOR xx:= 1 to passes
  388.   ret1:= A_CHOICE( 7,9,, ARRAY:t_arrey TITLEPOS:2 START_ELEM:ret1 ;
  389.            USERFUNC:{|a,b| UserFunc(a,b,any1,.F.,1,.T.)} ;
  390.            BOXTYPE:B_SINGLE  BOXTITLE:title  SHADOW:"FT" TAGCHAR:chr(17);
  391.            REST_SCREEN:.F. AUTOEXEC:.F. MES_COLOR:"+w/b" ELEVBAR:"▒" )
  392.   @ 1,0 say "Returned element "+Ltrim(str(ret1))+" "
  393.   IF ret1 > 0
  394.      @ 2,0 say "That was "+IF( Was_Tagged(chr(17),t_arrey,ret1) ,;
  395.                "a Tagged","an UNtagged")+"  element  "
  396.   ENDIF
  397.   @ 3,0 say "Press, Please "; inkey(0)
  398.   Clear()
  399.   ret2:= A_CHOICE( 5,9,20,40 ARRAY:t_arrey2  BOXTYPE:B_DOUBLE ELEVBAR:"░" ;
  400.             BOXTITLE:" SK Test2 " AUTOEXEC:.T. ELEVBAR_COLOR:"+w/r" ;
  401.             MES_COLOR:"+w/gr" USERFUNC:{|a,b| UserFunc(a,b,any2,.T.,3,.F.,4)} ;
  402.             REST_SCREEN:.F. ELEVBAR_SIDE:"R" TIME_OUT:4 MES_COL:"C" ;
  403.             START_ELEM:3 SHADOW:"L" BAR_COLOR:"+r/gr*" TIME_OUT VALUE:-999 )
  404.  
  405.   @ 1,0 say "Returned element "+Ltrim(str(ret2))+" "
  406.   IF ret2 > 0
  407.     @ 2,0 say "That was "+IF( Was_Tagged(DEFAULT_TAG,t_arrey2,ret2) ,;
  408.                "a Tagged","an UNtagged")+"  element  "
  409.   ENDIF
  410.   @ 3,0 say "Press, Please "; inkey(0)
  411.   Clear()
  412.   
  413. NEXT
  414.  
  415. SetBlink(o_blink)
  416. QUIT
  417. RETURN NIL
  418.  
  419. #endif
  420.  
  421. FUNCTION FT_Ach2tb( t,l,b,r,arrey,boxtp,boxcolor,boxttl,ttlpos,uselcolor,;
  422.          ttlcolor,barcolor,hkcolor,shad,aexec,msg_row,msg_col,msg_color,;
  423.          ebar,ebarcolor,ebarside,noselcolor,tagchar,start_elem,r_screen,;
  424.          timeout,timeout_val,u_func )
  425.  
  426. LOCAL o_curs,lkey:= 0,meth_num:= 0,num_elems:= Len(arrey),ach_scrn,;
  427.       o_color,aelem:= 0,ex_req:= .F.,uf_cont:= .T.,top_elem,bot_elem,;
  428.       dm_color,o_blink,first_entry:= .T.,col4bar,didtag:=.F.,aindex, ;
  429.       a_chscrn,o_row:= Row(),o_col:= Col(),hotkeys[3],ab_methods,ab,;
  430.       lDecr:= .F.,lCansel:= .T.,dir:= "D"
  431.  
  432. DEFAULT boxtp TO B_DOUBLE,       ttlcolor TO TITLECOLOR,;
  433.         barcolor TO BARCOLOR,    r_screen TO .T. ,;
  434.         msg_col TO l+2,          noselcolor TO "w/n" ,;
  435.         msg_color TO USEL_COLOR, boxcolor TO Setcolor(),;
  436.         uselcolor TO USEL_COLOR, aexec TO .T. ,;
  437.         ebarcolor TO Setcolor(), ;
  438.         ebarside TO "L",         start_elem TO 1 ,;
  439.         timeout TO 0,            ttlpos TO 1
  440.  
  441. o_curs := SetCursor(SC_NONE)
  442. SR_keys( "S",hotkeys )
  443. IF b==NIL
  444.    b:= IF( (t+Len(arrey)+1) >= maxrow()-2,maxrow()-2,(t+Len(arrey)+1) )
  445. ENDIF
  446. DEFAULT msg_row TO b+2
  447. r:= PrepArray( arrey,l,r,TAGS,tagchar )
  448. ach_scrn := SaveScreen( t,l-2,b+2,r+2 )
  449.  
  450. IF arrey==aSaveArr
  451.    aindex:= oSaveobj:cargo[1]
  452.    ab:= oSaveObj ; ab:inValidate()
  453. ELSE
  454.    aindex:= 1
  455.    ab:= tbrowsenew( t+1,l+1,b-1,r-1 )
  456.    ab:addcolumn(tbcolumnnew("",{|| arrey[aindex][AOPT]} ))
  457.    ab:getcolumn(1):width   := (r-1 -l)
  458.    ab:gotopblock           := {|| aindex := 1}
  459.    ab:gobottomblock        := {|| aindex := num_elems}
  460.    ab:skipblock            := {|n| ASkip( n,@aindex,arrey )}
  461.    ab:colorspec            += ","+uselcolor+","+barcolor+","+noselcolor
  462.    ab:getcolumn(1):colorblock:= { || ;
  463.                    IF(NOSELECT,{8},{6}) ,;
  464.                    ab:getcolumn(1):defcolor:= IF(NOSELECT,{8,8},{6,7}) }
  465.    ab:cargo:= Array(1)
  466. ENDIF
  467.  
  468. aSaveArr:= AClone(arrey)
  469. lCanSel:= ( Ascan(arrey,{|e| Len(e)==ASEL .and. (e[ASEL]==NIL ;
  470.                              .or. e[ASEL]) }) ) == 0
  471. ab_methods:= Curs_Methods()
  472. PaintBox( t,l,b,r,boxtp,boxcolor,boxttl,ttlcolor,ttlpos,shad,TAGS )
  473. col4bar  := IF(upper(ebarside)=="L",l,r)
  474. IF( ebar <> NIL,ElevBar( t+1,col4bar,b,ebar,ebarcolor,ebarside ), )
  475.  
  476. ab:autolite(.F.)
  477.  
  478. WHILE CONTINUING
  479.  
  480.    DispBegin()
  481.    STABILIZE ab
  482.  
  483.    IF lCanSel         // at least one option is selectable.
  484.       WHILE NOSELECT
  485.          IF( dir=="U",IF(ATTOP,ab:goBottom(),ab:up()) ,;
  486.                       IF(ATBOTT,ab:goTop(),ab:down() ) )
  487.          STABILIZE ab
  488.       ENDDO
  489.    ENDIF
  490.  
  491.    top_elem:= 1+aindex-ab:rowPos; bot_elem:= top_elem+ab:rowcount-1
  492.  
  493.    IF first_entry .and. start_elem > 1
  494.       dir:= HotKeyPress( ab,arrey,start_elem,aindex,top_elem,bot_elem )
  495.       aindex:= start_elem
  496.       top_elem:= 1+aindex-ab:rowPos; bot_elem:= top_elem+ab:rowcount-1
  497.    ENDIF
  498.  
  499.    HotKeyColor( t,l,top_elem,arrey,ab:rowcount,hkcolor )
  500.  
  501.    DispMsgg( msg_row,msg_col,arrey,aindex,msg_color )
  502.    IF ebar <> NIL
  503.       DispMsg( UP_ARROW_POS,UP_ARROW,ebarcolor )
  504.       DispMsg( DN_ARROW_POS,DN_ARROW,ebarcolor )
  505.    ENDIF
  506.  
  507.    ab:hilite()
  508.    DispEnd()
  509.  
  510.    // idle mode...of sorts.
  511.    IF valtype(u_func)=="B"
  512.       uf_cont:= Eval( u_func,lkey,IF(didtag .and. lDecr,aindex-1,aindex) )
  513.    ENDIF
  514.  
  515.    IF ex_req .or. !uf_cont; OUTTA_HERE; ELSE; lkey:= 0; ENDIF
  516.  
  517.    **************************************************************************
  518.    lkey     := SKInkey( timeout,ab,arrey,aindex,t,l,b,r,TAGS,tagchar,aexec )
  519.    **************************************************************************
  520.  
  521.    meth_num := Ascan( ab_methods, {|e| lkey == e})
  522.    aelem    := Ascan( arrey,{|e| IF(Len(e) >= AHOT .and. e[AHOT]<>NIL,;
  523.                       upper(chr(lkey)) == upper(subs(Ltrim(e[AOPT]),e[AHOT],1)) ,;
  524.                       upper(chr(lkey)) == upper(left(Ltrim(e[AOPT]),1)) ) } )
  525.  
  526.    DO CASE
  527.    CASE TIMED_OUT
  528.       ex_req:= .T. ; timeout_val:= IF(timeout_val==NIL,aindex,timeout_val)
  529.    CASE HOTKEY_PRESS
  530.       dir   := HotKeyPress(ab,arrey,aelem,aindex,top_elem,bot_elem)
  531.       ex_req:= SELECTABLE; aindex:= aelem
  532.    CASE METHOD_PRESS .or. lkey==K_ENTER
  533.       ExecKey( lKey,ab,ATTOP,ATBOTT )
  534.       ex_req:= ((lkey==K_ENTER) .and. !NOSELECT)
  535.    CASE TAG_PRESS
  536.       didtag:= TagPress( ab,arrey,aindex,lkey,tagchar,@lDecr )
  537.    ENDCASE
  538.  
  539.    dir   := IF(GOING_UP,"U",IF(GOING_DOWN,"D",dir) )
  540.    ex_req:= IF( lkey==0,.T.,ex_req ) ; first_entry:= .F.
  541.  
  542. ENDDO
  543.  
  544. ab:cargo[1]:= aindex ; oSaveobj:= ab
  545. Aeval( arrey,{|e| e[AOPT]:= Ltrim(e[AOPT]) } )
  546. SetPos(o_row,o_col); SetCursor(o_curs)
  547. IF( r_screen,RestScreen( t,l-2,b+2,r+2,ach_scrn ), )
  548. SR_keys( "R",hotkeys ) ; aMsgData:= Array(2)
  549. RETURN IF( lkey==K_ESC, 0, IF(TIMED_OUT,timeout_val,aindex) )
  550. ************************************************************************
  551. STATIC FUNCTION Askip(num_elems, aindex, arrey)
  552. LOCAL save_aindex := aindex
  553. aindex:= IF( aindex+num_elems > Len(arrey), Len(arrey),;
  554.          IF( aindex+num_elems < 1, 1, aindex+num_elems ))
  555. RETURN (aindex - save_aindex)
  556. *************************************************************************
  557. STATIC FUNCTION HotKeyPress( ab,arrey,elem,aindex,top_elem,bot_elem )
  558. LOCAL cur_elem:= aindex,new_elem:= elem,dest,dir:= "D"
  559.  
  560. WHILE cur_elem < new_elem            // descending
  561.    dest:= MIN( new_elem,bot_elem ) ; dir:= "D"
  562.    WHILE cur_elem < dest; ab:down(); cur_elem++; ENDDO    // speeding
  563.    STABILIZE ab
  564.    WHILE cur_elem < new_elem 
  565.       ab:down() ; STABILIZE ab
  566.       cur_elem++
  567.    ENDDO
  568. ENDDO
  569. WHILE cur_elem > new_elem            // ascending
  570.    dest:= MAX( new_elem,top_elem ) ; dir:= "U"
  571.    WHILE cur_elem > dest; ab:up(); cur_elem--; ENDDO      // speeding
  572.    STABILIZE ab
  573.    WHILE cur_elem > new_elem
  574.       ab:up() ; STABILIZE ab
  575.       cur_elem--
  576.    ENDDO
  577. ENDDO
  578.  
  579. RETURN dir
  580. *************************************************************************
  581. STATIC FUNCTION DispMsgg( r,c,arrey,pos,msg_color )
  582. LOCAL color2use
  583. IF MESG_LEN==NIL ; MESG_LEN:= 0 ; MESG_COL:= 99; ENDIF
  584. IF( MESG_LEN > 0,Clear( r,MESG_COL,r,MESG_COL+MESG_LEN -1 ), )
  585. IF Len(arrey[pos]) >= AMSG .and. arrey[pos][AMSG] <> NIL  // if msg. to disp.
  586.    color2use:= IF(Len(arrey[pos]) >= ACLR .and. arrey[pos][ACLR]<>NIL,;
  587.               arrey[pos][ACLR],msg_color)
  588.    IF valtype(c)== "C" .and. c=="C"  // indicating Centering
  589.       c:= Int( ((maxcol()+1)/2) - (Len(arrey[pos][AMSG])/2) )
  590.    ENDIF
  591.    DispMsg( r,c,arrey[pos][AMSG],color2use )
  592.    MESG_LEN:= Len(arrey[pos][AMSG]) ; MESG_COL:= c
  593. ENDIF
  594. RETURN NIL
  595. *************************************************************************
  596. /*
  597. this is here for test purposes.  the default is NO user func.
  598. */
  599. #ifdef FT_TEST
  600.  
  601. FUNCTION UserFunc( key,elem_num,anything,aexec,st_elem,tag,tmout )
  602. LOCAL ret_val:= .T.
  603. DEFAULT tmout TO 0
  604. @ 09,45 say "            LASTKEY: "+Ltrim(str(key))+"  "
  605. @ 10,45 say "CURRENT ELEMENT NUM: "+Ltrim(str(elem_num))+"  "
  606. @ 11,45 say "  AUTO-EXECUTION IS: "+if(aexec,"ON ","OFF")
  607. @ 12,45 say "STARTING AT ELEMENT: "+ltrim(str(st_elem))
  608. @ 13,45 say "         TAGGING IS: "+if(tag,"ENABLED ","DISABLED")
  609. @ 14,45 say "            TIMEOUT: "+if(tmout >0,ltrim(str(tmout))+" secs.  ",;
  610.                                     "INACTIVE      ")
  611. IF anything <> NIL; @ 16,45 say anything; ENDIF
  612.  
  613. /*
  614. return .F. if you want to leave FT_ACH2TB() after whatever
  615. processing you do here.
  616. */
  617.  
  618. RETURN (ret_val)
  619. #endif
  620.  
  621. **************************************************************************
  622. #define ELEM2USE    arrey[top_elem+i]
  623. #define CANT_SELECT (len(ELEM2USE)==5 .and. !ELEM2USE[ASEL])
  624.  
  625. STATIC FUNCTION HotKeyColor( t,l,top_elem,arrey,rowcount,hkcolor )
  626. LOCAL i:= 0,color2use,col2use,charpos,xx,nUpper:= MIN(Len(arrey),rowcount)
  627. FOR xx:= 1 TO nUpper
  628.     color2use:= IF( Len(ELEM2USE) >=ACLR .and. ELEM2USE[ACLR]<>NIL,;
  629.                 ELEM2USE[ACLR], IF(hkcolor<>NIL,hkcolor,HK_COLOR) )
  630.     col2use:=   IF(len(ELEM2USE) >=AHOT .and. ELEM2USE[AHOT]<>NIL,;
  631.                 l+1+ELEM2USE[AHOT],l+2)
  632.     charpos:=   IF(len(ELEM2USE) >=AHOT .and. ELEM2USE[AHOT]<>NIL,;
  633.                 ELEM2USE[AHOT],1 )
  634.     IF !CANT_SELECT
  635.        SetPos( t+xx,col2use )
  636.        DispOut( SUBS(Ltrim(ELEM2USE[AOPT]),charpos,1),color2use )
  637.     ENDIF
  638.     i++
  639. NEXT
  640. RETURN NIL
  641. ****************************************************************************
  642. STATIC FUNCTION Curs_Methods()
  643. RETURN (  { ;
  644.           K_DOWN,     ;
  645.           K_UP,       ;
  646.           K_PGDN,     ;
  647.           K_PGUP,     ;
  648.           K_CTRL_PGDN,;
  649.           K_CTRL_PGUP,;
  650.           K_CTRL_END ,;
  651.           K_CTRL_HOME,;
  652.           K_END,      ;
  653.           K_HOME,     ;
  654.           K_ENTER,    ;
  655.           K_SPACEBAR, ;
  656.           K_PLUS,     ;
  657.           K_MINUS } )
  658. ****************************************************************************
  659. STATIC FUNCTION ExecKey( lKey,ab,lTop,lBot )
  660. DO CASE
  661.    CASE lKey==K_DOWN       ; IF(lBot,ab:goTop(),ab:down())
  662.    CASE lKey==K_UP         ; IF(lTop,ab:goBottom(),ab:up())
  663.    CASE lKey==K_PGDN       ; IF(lBot,ab:goTop(),ab:pagedown())
  664.    CASE lKey==K_PGUP       ; IF(lTop,ab:goBottom(),ab:pageup())
  665.    CASE lKey==K_CTRL_PGDN .or. lKey==K_CTRL_END .or. lKey==K_END
  666.                              IF(lBot,ab:goTop(),ab:gobottom())
  667.    CASE lKey==K_CTRL_PGUP .or. lKey==K_CTRL_HOME .or. lKey==K_HOME
  668.                              IF(lTop,ab:goBottom(),ab:goTop())
  669. ENDCASE
  670. RETURN NIL
  671. ****************************************************************************
  672. STATIC FUNCTION ElevBar( t,col4bar,b,ebar,bcolor )
  673. LOCAL c:= 0
  674. Aeval( Array(b-t),{ |e,n| SetPos(t+c,col4bar),DispOut(ebar,bcolor),c++ })
  675. RETURN NIL
  676. ****************************************************************************
  677. #define TARGET   arrey[pos][AOPT]
  678. #define TAGGED   (tagchar $TARGET)
  679. #define AEV_TARG arrey[n][AOPT]
  680. #define AEV_TAGD (tagchar $AEV_TARG)
  681.  
  682. STATIC FUNCTION TagPress( ab,arrey,pos,lkey,tagchar,lDecr )
  683. LOCAL didtag:= .F.
  684.  
  685. IF (lkey==K_PLUS .and. !TAGGED) .or. (lkey==K_MINUS .and. TAGGED)
  686.    TARGET:= IF( (lkey==K_PLUS .and. !TAGGED) ,;
  687.                 Left(TARGET,Len(TARGET)-1)+tagchar ,;
  688.             IF( (lkey==K_MINUS .and. TAGGED) ,;
  689.                 Strtran(TARGET,tagchar," ")  ,;
  690.                 TARGET ))
  691.    ab:refreshcurrent(); didtag:= .T.
  692.    IF lKey==K_PLUS .and. TAGGED
  693.       ab:down() ; lDecr:= (pos < Len(arrey))
  694.    ENDIF
  695. ENDIF
  696. IF lkey==K_SPACEBAR
  697.    IF !(Ascan(arrey,{|e| tagchar $ e[AOPT] }) > 0)
  698.       Aeval(arrey,{|e,n| AEV_TARG:= Left(AEV_TARG,Len(AEV_TARG)-1)+tagchar })
  699.    ELSE
  700.       Aeval(arrey,{|e,n| AEV_TARG:= Strtran(AEV_TARG,tagchar," ") })
  701.    ENDIF
  702.    ab:refreshall() ; didtag:= .T.
  703. ENDIF
  704. RETURN (didtag)
  705. ****************************************************************************
  706. #translate CenterB( <b>,<l>,<r>,<msg>[,<color>] ) => ;
  707.            SetPos(<b>,(<l>+Int((<r>-<l> -Len(<msg>))/2) ) ) ;;
  708.            DispOut(<msg>[,<color>])
  709.  
  710. STATIC FUNCTION PaintBox( t,l,b,r,boxtp,boxcolor,boxttl,ttlcolor,ttlpos,shad,tags )
  711.  IF shad <> NIL
  712.     IF( shad=="FT",FT_Shadow( t,l+1,b,r ), )
  713.     IF( shad $"LR",Shadoww( t,l,b,r,upper(shad) ), )
  714.  ENDIF
  715.  DispBox( t,l,b,r,boxtp,boxcolor )
  716.  IF boxttl <> NIL; DispMsg( t,l+ttlpos,boxttl,ttlcolor ); ENDIF
  717.  IF tags .and. (r-l) >= Len("tags")
  718.     CenterB( b,l,r,"Tags","+w/"+BG(boxcolor) )
  719.  ENDIF
  720. RETURN NIL
  721. ****************************************************************************
  722. STATIC FUNCTION PrepArray( arrey,l,r,tags,tagchar )
  723. Aeval( arrey,{|e| e[AOPT]:= " " +AllTrim( ;
  724.                   IF(tags,StrTran(e[AOPT],tagchar),e[AOPT]) ) } )
  725. IF valtype(r)=="N"
  726.    Aeval( arrey,{|e| e[AOPT]:= Padr(e[AOPT],r-l-1) })
  727. ELSEIF (r==NIL); r:= 0
  728.    Aeval( arrey,{|e| r:= MAX( r,Len(e[AOPT]) ) })
  729.    r+= IF( !tags,(l+2),(l+3) )
  730.    IF( tags,Aeval( arrey,{|e| e[AOPT]:= Padr(e[AOPT],r-l-1) }), )
  731. ENDIF
  732. RETURN (r)
  733. *****************************************************************************
  734. STATIC FUNCTION BG( color )
  735. LOCAL startpos:= AT("/",color)+1
  736. LOCAL endpos:= IF( "," $ color,AT(",",color),len(color)+1 )
  737. RETURN upper(subs( color,startpos,(endpos-startpos) ))
  738. *****************************************************************************
  739. STATIC FUNCTION FG( color )
  740. RETURN upper(subs( color,1,AT("/",color)-1 ))
  741. *****************************************************************************
  742. STATIC FUNCTION SKInkey( nSecs,ab,arrey,aindex,t,l,b,r,tags,tagchar,aexec )
  743. LOCAL bBlock,nKey:= 0,lLooping:= .T.
  744. WHILE lLooping
  745. #ifndef NOMOUSE
  746.     nKey:= Mouser( nSecs,ab,arrey,aindex,t,l,b,r,tags,tagchar,aexec )
  747.     lLooping:= .F.
  748.     IF nKey==0 .and. Nextkey() <> 0
  749.        FT_MShowcrs()
  750. #endif
  751.        nKey:= Inkey( nSecs )
  752.        IF ( bBlock := Setkey(nKey) ) <> NIL
  753.           Eval( bBlock, Procname(1), Procline(1), Readvar(),Getactive() )
  754.        ELSE; lLooping:= .F.
  755.        ENDIF
  756. #ifndef NOMOUSE
  757.     ENDIF
  758. #endif
  759.  
  760. ENDDO
  761. RETURN (nKey)
  762. ****************************************************************************
  763. #ifndef NOMOUSE
  764.  
  765. STATIC FUNCTION Mouser( nSecs,ab,arrey,aindex,t,l,b,r,tags,tagchar,aexec )
  766. LOCAL nR:= 0,nCurrow,nNumpos:= 0,nKey:= 0,cur_elem,pos,lLooping:= .T.,;
  767.       lDown:= .F.,nTime:= Seconds()
  768.    // while no button or key pressed.
  769.  
  770.    WHILE lLooping .and. Nextkey()==0
  771.       FT_MShowcrs()
  772.  
  773.       IF nSecs > 0 .and. (Seconds() >= nTime+nSecs)
  774.          nKey:= OUTTA_TIME ; lLooping:= .F.
  775.       ELSEIF FT_Mbutprs(1)==2               // right button == ESC
  776.          nKey:= K_ESC ; lLooping:= .F.
  777.       ELSEIF FT_Mbutprs(0)==1           // left button pressed
  778.          DO CASE
  779.            CASE FT_Minregion( t,l,t,l ) .or. FT_Minregion( b,l,b,l )
  780.                 nKey:= IF( FT_Minregion( t,l,t,l ),K_CTRL_PGUP,;  // upper left
  781.                        IF( FT_Minregion( b,l,b,l ),K_CTRL_PGDN,nKey) ) // lower left
  782.                 lLooping:= .F.
  783.            CASE FT_Minregion( t,r,t,r ) .or. FT_Minregion( b,r,b,r )
  784.                 nKey:= IF( FT_Minregion( t,r,t,r ),K_PGUP, ;      //upper right corner
  785.                        IF( FT_Minregion( b,r,b,r ),K_PGDN,nKey )) //lower left corner
  786.                 lLooping:= .F.
  787.            CASE !(FT_Minregion(t,l,b,r))
  788.                 nKey:= K_ENTER ; lLooping:= .F.
  789.            OTHERWISE
  790.                 IF FT_MInregion(t+1,l+1,b-1,r-1)
  791.                    // mouse row.
  792.                    nR:= FT_MgetX()
  793.                    // what row does current elem occupy?
  794.                    nCurrow:= ab:nTop+ab:rowPos-1
  795.                    // difference between this and nR is number of positions to move.
  796.                    nNumpos:= IF( nR==nCurrow,0,ABS(nR-nCurrow))
  797.                    cur_elem:= arrey[ aindex+ IF( nR > nCurrow,nNumpos,-nNumpos ) ]
  798.                    IF nNumpos==0
  799.                       nKey:= IF(tags, ;
  800.                              IF(tagchar $ cur_elem[1],K_MINUS,K_PLUS),;
  801.                                 K_ENTER)
  802.                       lLooping:= .F.
  803.                    ENDIF
  804.                    IF nNumpos > 0
  805.                       // if no hotkeys, we'll move ourselves and return -1.
  806.                       // -1 indicating no handling in the main loop.
  807.                       lDown:= (nR > nCurrow)
  808.                       WHILE nR > nCurrow ; ab:down(); nCurrow++ ; ENDDO
  809.                       WHILE nR < nCurrow ; ab:up()  ; nCurrow-- ; ENDDO
  810.                       // if element is unselectable, move one above or below.
  811.                       IF Len(cur_elem)==ASEL .and. cur_elem[ASEL]<>NIL .and. ;
  812.                          !cur_elem[ASEL]
  813.                          IF(lDown,ab:down(),ab:up())
  814.                       ENDIF
  815.                       nKey:= IF(tags .or. !aexec, -1, K_ENTER)
  816.                       lLooping:= .F.
  817.                    ENDIF
  818.                 ENDIF
  819.          ENDCASE
  820.       ENDIF
  821.    ENDDO
  822. FT_MHidecrs()
  823. RETURN (nKey)
  824.  
  825. #endif
  826.  
  827. ****************************************************************************
  828. STATIC FUNCTION SR_Keys( action,hotkeys )
  829. IF action=="S"
  830.    hotkeys[1] := Setkey(K_SPACEBAR) ; Setkey(K_SPACEBAR,NIL)
  831.    hotkeys[2] := Setkey(K_PLUS)     ; Setkey(K_PLUS,NIL)
  832.    hotkeys[3] := Setkey(K_MINUS)    ; Setkey(K_MINUS,NIL)
  833. ELSEIF action=="R"
  834.    Setkey(K_SPACEBAR,hotkeys[1])
  835.    Setkey(K_PLUS,hotkeys[2])
  836.    Setkey(K_MINUS,hotkeys[3])
  837. ENDIF
  838. RETURN NIL
  839. ****************************************************************************
  840. STATIC FUNCTION Shadoww( t,l,b,r,side )
  841. LOCAL bx
  842. DEFAULT side TO "R"
  843. l+= IF(side=="R",2,-2); r+= IF(side=="R",2,-2)
  844. bx:= SaveScreen( ++t,l,++b,r )
  845. RestScreen( t,l,b,r,Transf( bx,Replic("x"+chr(8),len(bx)/2) ) )
  846. RETURN NIL
  847.