home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / CLIPPER / NFSRC.ZIP / MENUTO.PRG < prev    next >
Encoding:
Text File  |  1991-08-16  |  12.2 KB  |  383 lines
  1. /*
  2.  * File......: MENUTO.PRG
  3.  * Author....: Ted Means
  4.  * Date......: $Date:   15 Aug 1991 23:03:54  $
  5.  * Revision..: $Revision:   1.2  $
  6.  * Log file..: $Logfile:   E:/nanfor/src/menuto.prv  $
  7.  * 
  8.  * This is an original work by Ted Means and is placed in the
  9.  * public domain.
  10.  *
  11.  * Modification history:
  12.  * ---------------------
  13.  *
  14.  * $Log:   E:/nanfor/src/menuto.prv  $
  15.  * 
  16.  *    Rev 1.2   15 Aug 1991 23:03:54   GLENN
  17.  * Forest Belt proofread/edited/cleaned up doc
  18.  * 
  19.  *    Rev 1.1   14 Jun 1991 19:52:16   GLENN
  20.  * Minor edit to file header
  21.  * 
  22.  *    Rev 1.0   01 Apr 1991 01:01:42   GLENN
  23.  * Nanforum Toolkit
  24.  *
  25.  */
  26.  
  27.  
  28. /*  $DOC$
  29.  *  $FUNCNAME$
  30.  *     MENU TO
  31.  *  $CATEGORY$
  32.  *     Menus/Prompts
  33.  *  $ONELINER$
  34.  *     Execute light bar menu using prompts created with @...PROMPT
  35.  *  $SYNTAX$
  36.  *     #include "FTMENUTO.CH"
  37.  *
  38.  *     MENU TO <var> [NOSNOW] [KEEP] [COLD]
  39.  *  $ARGUMENTS$
  40.  *     <var> is the name of the variable to assign the result of the
  41.  *     menu selection.
  42.  *
  43.  *     ^bNOSNOW^b implements snow-suppression on CGA monitors.  If not
  44.  *     specified, no snow-suppression will occur.  This option is only
  45.  *     meaningful for CGA displays.
  46.  *
  47.  *     ^bKEEP^b causes the prompt list to be retained after the menu
  48.  *     has been executed, allowing the menu to be executed multiple
  49.  *     times without redefining the prompts.  If not specified, the
  50.  *     prompts will be destroyed once the menu has executed.
  51.  *
  52.  *     ^bCOLD^b suppresses automatic menu termination when a prompt's
  53.  *     hotkey is pressed.  If this clause is present, pressing
  54.  *     a prompt's hotkey will move the highlight to the proper menu
  55.  *     selection but will not terminate the menu.  If not present,
  56.  *     pressing a hot key will terminate the menu, as it does in the
  57.  *     standard Clipper MENU TO command.
  58.  *  $DESCRIPTION$
  59.  *     This enhanced version of MENU TO requires the inclusion of
  60.  *     the header file FTMENUTO.CH in any source file that uses it.
  61.  *     It is compatible with, and may be used in place of, the standard
  62.  *     Clipper MENU TO command.
  63.  *
  64.  *     This command is very similar to the Clipper version.  The
  65.  *     main differences are that you have more control over hotkey
  66.  *     operation, and you can keep the prompts alive after the menu
  67.  *     has executed, if you so desire.  Please be aware that this
  68.  *     function does not qualify as a "wait state" and so do not
  69.  *     expect any wait state-associated activity to occur.
  70.  *     Nevertheless, I have included support for any SET KEY
  71.  *     redirections through the magic of code blocks.  A loop is
  72.  *     used to check to every possible INKEY() value to see if it
  73.  *     has been redirected. This is necessary because Clipper
  74.  *     provides no way to check SET KEY status.  If you're
  75.  *     interested in improving performance, alter the source code
  76.  *     to receive an array of keys that have been redirected, and
  77.  *     remove the previously mentioned loop.  Using the loop does
  78.  *     make the routine a bit more generic, so it's a trade-off.
  79.  *     Your call, do as you see fit.
  80.  *
  81.  *     Note that this command can also be called using function-style
  82.  *     syntax.  See the entry for FT_MENUTO() for further details.
  83.  *
  84.  *     Also note that this command calls an internal routine called
  85.  *     __FTMENUTO(). __FTMENUTO() was written in assembler.  Check
  86.  *     the file TMENU.ASM if you're interested in seeing the
  87.  *     assembler source code.
  88.  *
  89.  *     Header file: FTMENUTO.CH
  90.  *  $EXAMPLES$
  91.  *    #include "FTMENUTO.CH"    // NECESSARY!
  92.  *    // Simple command
  93.  *    MENU TO memvar
  94.  *
  95.  *    // Implement snow-checking for CGA
  96.  *    MENU TO memvar NOSNOW
  97.  *
  98.  *    // Keep the prompts alive when finished
  99.  *    MENU TO memvar KEEP
  100.  *
  101.  *    // Use "cold" hotkeys
  102.  *    MENU TO memvar COLD
  103.  *  $INCLUDE$
  104.  *    FTMENUTO.CH
  105.  *  $SEEALSO$
  106.  *    "@...PROMPT" FT_MENUTO() FT_PROMPT()
  107.  *  $END$
  108.  */
  109.  
  110.  
  111. /*  $DOC$
  112.  *  $FUNCNAME$
  113.  *     FT_MENUTO()
  114.  *  $CATEGORY$
  115.  *     Menus/Prompts
  116.  *  $ONELINER$
  117.  *     Execute light bar menu using prompts created with FT_PROMPT()
  118.  *  $SYNTAX$
  119.  *     FT_MENUTO( <bVarNameBlock>, <cVarName>, ;
  120.  *               [ <lNoSnow> ], [ <lKeep> ], [ <lCold> ]) -> nChoice
  121.  *  $ARGUMENTS$
  122.  *     <bVarNameBlock> is a "get-set" code block which allows the
  123.  *     retrieval and assignment of the variable which will receive
  124.  *     the return value.  Its initial value is used to determine the
  125.  *     initial active prompt.
  126.  *
  127.  *     The code block must be in the form:
  128.  *
  129.  *        {|_1| IIF( _1 == NIL, <var>, <var> := _1 ) }
  130.  *
  131.  *     For example, if the variable to receive the return value is
  132.  *     named "nChoice", the code block would look like:
  133.  *
  134.  *        {|_1| IIF( _1 == NIL, nChoice, nChoice := _1 ) }
  135.  *
  136.  *     Although it is good practice to always declare your variables,
  137.  *     the variable to receive the return value does not need to exist
  138.  *     before calling FT_MENUTO().  If it does exist and is a numeric,
  139.  *     its value will be used to determine the initial prompt.  If it
  140.  *     does not exist, the initial prompt will default to the first one.
  141.  *
  142.  *     If you use this function by way of the MENU TO command along with
  143.  *     the FTMENUTO.CH header file, this code block will automatically
  144.  *     be created for you by the preprocessor.
  145.  *
  146.  *     <cVarName> is the name of the memvar to which the menu
  147.  *     choice is returned.
  148.  *
  149.  *     <lNoSnow> is optional and specifies whether or not to
  150.  *     implement snow-suppression on CGA monitors.  The default is
  151.  *     .F., meaning that no snow-suppression will occur.  This
  152.  *     option is only meaningful for CGA displays.
  153.  *
  154.  *     <lKeep> is optional and indicates whether or not to destroy
  155.  *     the prompt list once the menu has been executed.  If .T.,
  156.  *     then the prompts will be kept, allowing the menu to be
  157.  *     executed multiple times without redefining the prompts.  The
  158.  *     default is .F., meaning the prompts will be destroyed once
  159.  *     the menu has executed.
  160.  *
  161.  *     <lCold> is optional and controls the operation of the
  162.  *     hotkeys.  If .T., then pressing a hotkey will not result in
  163.  *     a menu selection.  Instead, it merely changes the active
  164.  *     prompt.  This allows more than one prompt to have the same
  165.  *     hotkey.  The default is .F., meaning the hotkeys will
  166.  *     function the same way they do in Clipper.
  167.  *  $RETURNS$
  168.  *     A numeric value representing the menu choice selected, or zero
  169.  *     if the ESC key was used to exit the menu.
  170.  *  $DESCRIPTION$
  171.  *     This function is a replacement for Clipper's MENU TO
  172.  *     command.  In fact, you may wish to consult TMENU.CH, which
  173.  *     contains a user-defined command that closely adheres to
  174.  *     standard Clipper syntax and makes this function infinitely
  175.  *     easier to use.  I strongly recommend using the command
  176.  *     version because it is complementary to the associated
  177.  *     @...PROMPT command.
  178.  *
  179.  *     This function is very similar to the Clipper version.  The
  180.  *     main differences are that you have more control over hotkey
  181.  *     operation, and you can keep the prompts alive after the menu
  182.  *     has executed, if you so desire.  Please be aware that this
  183.  *     function does not qualify as a "wait state" and so do not
  184.  *     expect any wait state-associated activity to occur.
  185.  *     Nevertheless, I have included support for any SET KEY
  186.  *     redirections through the magic of code blocks.  A loop is
  187.  *     used to check to every possible INKEY() value to see if it
  188.  *     has been redirected. This is necessary because Clipper
  189.  *     provides no way to check SET KEY status.  If you're
  190.  *     interested in improving performance, alter the source code
  191.  *     to receive an array of keys that have been redirected, and
  192.  *     remove the previously mentioned loop.  Using the loop does
  193.  *     make the routine a bit more generic, so it's a trade-off.
  194.  *     Your call, do as you see fit.
  195.  *
  196.  *     Note that this function calls an internal routine called
  197.  *     __FTMENUTO(). __FTMENUTO() was written in assembler.  Check
  198.  *     the file TMENU.ASM if you're interested in seeing the
  199.  *     assembler source code.
  200.  *
  201.  *     All the examples below use the command version.  If you're
  202.  *     interested in seeing the function version, compile the
  203.  *     examples with the /P switch and then examine the resulting
  204.  *     .PPO file.
  205.  *  $EXAMPLES$
  206.  *    #include "FTMENUTO.CH"
  207.  *    // Simple command
  208.  *    MENU TO memvar
  209.  *
  210.  *    // Implement snow-checking for CGA
  211.  *    MENU TO memvar NOSNOW
  212.  *
  213.  *    // Keep the prompts alive when finished
  214.  *    MENU TO memvar KEEP
  215.  *
  216.  *    // Use "cold" hotkeys
  217.  *    MENU TO memvar COLD
  218.  *  $SEEALSO$
  219.  *    FT_PROMPT()
  220.  *  $END$
  221.  */
  222.  
  223. #include "set.ch"
  224. #include "inkey.ch"
  225. #include "error.ch"
  226.  
  227. function FT_MenuTo( bReadvar, cReadVar, lNoSnow, lKeep, lCold )
  228.  
  229. local nFlags, aKey := {}, aKBlock := {}, bKBlock, i, nScanCode
  230.  
  231. local nActive, bErrorsys, oError
  232.  
  233. if valtype(bReadvar) != "B"
  234.    nActive := 1
  235. else
  236.    bErrorsys := Errorblock( {|e| Break(e) } )
  237.    BEGIN SEQUENCE
  238.       nActive := Eval(bReadvar)
  239.    RECOVER USING oError
  240.       IF oError:gencode == EG_NOVAR
  241.          nActive := 1
  242.       ELSE
  243.          Eval(bErrorsys,oError)
  244.       ENDIF
  245.    END SEQUENCE
  246.    Errorblock(bErrorsys)
  247. endif
  248.  
  249. if valtype(lNoSnow) != "L"
  250.    lNoSnow := .F.
  251. endif
  252.  
  253. if valtype(lKeep) != "L"
  254.    lKeep := .F.
  255. endif
  256.  
  257. if valtype(lCold) != "L"
  258.    lCold := .F.
  259. endif
  260.  
  261. nFlags := iif(lNoSnow,         1, 0) ;
  262.         + iif(lKeep,           2, 0) ;
  263.         + iif(lCold,           4, 0) ;
  264.         + iif(set(_SET_WRAP),  8, 0)
  265.  
  266. for i := -39 to 306
  267.    if (bKBLock := SetKey(i)) != NIL
  268.       _ftScanKey(i, aKey)
  269.       while len(aKBlock) < len(aKey)
  270.          AAdd(aKBlock, bKBlock)
  271.       end
  272.    endif
  273. next
  274.  
  275. nScanCode := __ftMenuTo(nActive, nFlags, aKey)
  276. nActive   := int(nScanCode % (2 ^ 16))
  277. nScanCode := int(nScanCode / (2 ^ 16))
  278.  
  279. while (i := aScan(aKey, nScanCode)) > 0
  280.  
  281.    if valtype(bReadvar) == "B"
  282.       eval(bReadvar,nActive)
  283.    endif
  284.  
  285.    eval(aKBlock[i], ProcName(1), ProcLine(1), Upper(cReadVar))
  286.  
  287.    nFlags := iif(nFlags < 32, nFlags + 32, nFlags)
  288.    nScanCode := __ftMenuTo(nActive, nFlags, aKey)
  289.    nActive   := int(nScanCode % (2 ^ 16))
  290.    nScanCode := int(nScanCode / (2 ^ 16))
  291. end
  292.  
  293. return nActive
  294.  
  295.  
  296. static function _ftScanKey(nInKey, aKey)
  297.  
  298. do case
  299.    case nInKey == K_DEL
  300.       AAdd(aKey, 83 * 256)
  301.       AAdd(aKey, 7)
  302.  
  303.    case nInKey == K_INS
  304.       AAdd(aKey, 82 * 256)
  305.       AAdd(aKey, 22)
  306.  
  307.    case nInKey == K_UP
  308.       AAdd(aKey, 72 * 256)
  309.       AAdd(aKey, 5)
  310.  
  311.    case nInKey == K_DOWN
  312.       AAdd(aKey, 80 * 256)
  313.       AAdd(aKey, 24)
  314.  
  315.    case nInKey == K_LEFT
  316.       AAdd(aKey, 75 * 256)
  317.       AAdd(aKey, 19)
  318.  
  319.    case nInKey == K_RIGHT
  320.       AAdd(aKey, 77 * 256)
  321.       AAdd(aKey, 4)
  322.  
  323.    case nInKey == K_HOME
  324.       AAdd(aKey, 71 * 256)
  325.       AAdd(aKey, 1)
  326.  
  327.    case nInKey == K_END
  328.       AAdd(aKey, 79 * 256)
  329.       AAdd(aKey, 6)
  330.  
  331.    case nInKey == K_PGUP
  332.       AAdd(aKey, 73 * 256)
  333.       AAdd(aKey, 18)
  334.  
  335.    case nInKey == K_PGDN
  336.       AAdd(aKey, 81 * 256)
  337.       AAdd(aKey, 3)
  338.  
  339.    case nInKey == K_CTRL_LEFT
  340.       AAdd(aKey, 115 * 256)
  341.       AAdd(aKey, 26)
  342.  
  343.    case nInKey == K_CTRL_RIGHT
  344.       AAdd(aKey, 116 * 256)
  345.       AAdd(aKey, 2)
  346.  
  347.    case nInKey == K_CTRL_HOME
  348.       AAdd(aKey, 119 * 256)
  349.       AAdd(aKey, 29)
  350.  
  351.    case nInKey == K_CTRL_END
  352.       AAdd(aKey, 117 * 256)
  353.       AAdd(aKey, 23)
  354.  
  355.    case nInKey == K_CTRL_PGUP
  356.       AAdd(aKey, 132 * 256)
  357.       AAdd(aKey, 31)
  358.  
  359.    case nInKey == K_CTRL_PGDN
  360.       AAdd(aKey, 118 * 256)
  361.       AAdd(aKey, 30)
  362.  
  363.    case nInKey >= K_ALT_F10 .and. nInKey <= K_SH_F1
  364.       AAdd(aKey, (abs(nInKey) + 74) * 256)
  365.  
  366.    case nInkey >= K_F10 .and. nInkey <= K_F2
  367.       AAdd(aKey, (abs(nInKey) + 59) * 256)
  368.  
  369.    case nInkey == 28
  370.       AAdd(aKey, 59 * 256)
  371.  
  372.    case (nInKey >= K_SH_TAB .and. nInKey <= K_ALT_P) .or. ;
  373.         (nInKey >= K_ALT_A  .and. nInKey <= K_ALT_L) .or. ;
  374.         (nInKey >= K_ALT_Z  .and. nInKey <= K_ALT_M)
  375.       AAdd(aKey, (nInKey - 256) * 256)
  376.  
  377.    case (nInKey >= 0 .and. nInKey <= 255)
  378.       AAdd(aKey, nInKey)
  379. endcase
  380.  
  381. return NIL
  382. 
  383.