home *** CD-ROM | disk | FTP | other *** search
/ Power CD-ROM!! 7 / POWERCD7.ISO / prgmming / clipper / getchoic.prg < prev    next >
Text File  |  1994-08-29  |  8KB  |  298 lines
  1. /*
  2.  * File......: getchoic.prg
  3.  * Author....: Andy M Leighton
  4.  * BBS.......: The Dark Knight Returns
  5.  * Net/Node..: 050/069
  6.  * User Name.: Andy Leighton
  7.  * Date......: 08/06/93
  8.  * Revision..: 1.0
  9.  * Log file..: $Logfile$
  10.  *
  11.  * This is an original work by Andy M Leighton and is placed in the
  12.  * public domain.
  13.  *
  14.  * Modification history:
  15.  * ---------------------
  16.  *
  17.  * Rev 1.0  8/6/93
  18.  * Initial Revision
  19.  */
  20.  
  21. /*  $DOC$
  22.  *  $FUNCNAME$
  23.  *      @ <row>, <col> GET <var> [...] FROM <aChoices> [...]
  24.  *  $CATEGORY$
  25.  *      Get Reader
  26.  *  $ONELINER$
  27.  *      Get from an array of choices via a menu
  28.  *  $SYNTAX$
  29.  *      @ <row>, <col> GET <var> [...] FROM <aChoices> [....]
  30.  *  $ARGUMENTS$
  31.  *      Not Applicable
  32.  *  $RETURNS$
  33.  *      Not Applicable
  34.  *  $DESCRIPTION$
  35.  *      This is a get reader.
  36.  *      It allows the user to choose a value from an array of strings.
  37.  *      It correctly handles arrays that are longer than available
  38.  *      screen space (see Examples).
  39.  *      If the choices menu is too wide for the screen it will generate
  40.  *      a meaningful error message
  41.  *      The colours cannot be changed at the moment without altering the
  42.  *      code.  If someone wants to add an optional colours clause see the
  43.  *      information about the cargo that follows.
  44.  *
  45.  *      For those who are interested (it is not neccessary to know this
  46.  *      to use the reader) the following data is stored in the cargo
  47.  *      slot of the reader.
  48.  *          oGet:cargo[1]     -  The array of menu choices
  49.  *          oGet:cargo[2]     -  The current choice (only changes when in
  50.  *                               the getreader itself)
  51.  *          oGet:cargo[3]     -  Colours array
  52.  *          oGet:cargo[3][1]  -  Normal colour
  53.  *          oGet:cargo[3][2]  -  Selection bar colour
  54.  *          oGet:cargo[3][3]  -  Frame colour
  55.  *
  56.  *      NOTE: this function is not standalone, you also need the following
  57.  *            functions from the GTLIB - GT_AComp(), GT_SaveScr() and
  58.  *            GT_RestScr()
  59.  *
  60.  *  $EXAMPLES$
  61.  *
  62.  *      local choices  := { "Yes", "No", "Not Sure" }
  63.  *      local choices2 := {}
  64.  *      local var1     := ""
  65.  *      local var2     := ""
  66.  *      local i
  67.  *
  68.  *      for i := 1 to 99
  69.  *         aAdd(choices2, "Choice " + str(i, 2))
  70.  *      next
  71.  *
  72.  *      @ 10, 10 say "Choice 1" get var1 from choices
  73.  *      @ 10, 50 say "Choice 2" get var2 from choices2
  74.  *
  75.  *      GT_Read(getlist)
  76.  *
  77.  *  $SEEALSO$
  78.  *  $END$
  79.  */
  80.  
  81. #include "gt_Lib.ch"
  82. #include "error.ch"
  83.  
  84. // works a bit like the one in FuncKy
  85.  
  86. #translate aMaxStrLen(<a>)      =>     len(GT_AComp(<a>, AC_MAXLEN))
  87.  
  88. function GT_ChoiceReader(oGet)
  89.  
  90.    local cSaveScr
  91.    local cOldCols := setColor()
  92.    local oCurs    := setCursor(SC_NONE)
  93.  
  94.    // read the GET if the WHEN condition is satisfied
  95.  
  96.    if GetPreValidate(oGet)
  97.       // activate the GET for reading and position
  98.       // cursor on the right side
  99.       oGet:setFocus()
  100.       oGet:pos := len(oGet:buffer)
  101.  
  102.       // default the initial pointer to the current value
  103.  
  104.       oGet:cargo[2] := ascan(oGet:cargo[1], oGet:original)
  105.  
  106.       if oGet:cargo[2] == 0            // make the element pointer point to
  107.          oGet:cargo[2] := 1            // the first element of the array
  108.       endif
  109.  
  110.       gGtSetColours(oGet)
  111.  
  112.       cSaveScr := gGtsaveBack(oGet)
  113.  
  114.       gGtdispChoices(oGet)
  115.  
  116.       do while oGet:exitState == GE_NOEXIT
  117.  
  118.          // check for initial typeout (no editable positions)
  119.          if oGet:typeOut
  120.             oGet:exitState := GE_ENTER
  121.          endif
  122.  
  123.          // apply keystrokes until exit
  124.          do while oGet:exitState == GE_NOEXIT
  125.             gGtApplyKey(oGet, inkey(0))
  126.             gGtdispChoices(oGet)
  127.          enddo
  128.  
  129.          // disallow exit if the VALID condition is not satisfied
  130.          if !GetPostValidate(oGet)
  131.             oGet:exitState := GE_NOEXIT
  132.          endif
  133.       enddo
  134.  
  135.       GT_RestScr(cSaveScr)
  136.       setColor(cOldCols)
  137.       setCursor(oCurs)
  138.  
  139.       // de-activate the GET
  140.       @ oGet:row, oGet:col say oGet:cargo[1][oGet:cargo[2]]
  141.       oGet:killFocus()
  142.    endif
  143.  
  144. return NIL
  145.  
  146. // Internal functions exist below this point
  147.  
  148. /*
  149.  * Apply keystrokes to the get
  150.  *
  151.  * *YOU* may want to change the keystrokes for PGUP and PGDN
  152.  * so that they page thru the menu
  153.  */
  154.  
  155. static function gGtApplyKey(oGet, nKey)
  156.  
  157.    local lTranBack := TRUE
  158.  
  159.    do case
  160.       case nKey == K_UP
  161.          oGet:cargo[2] := max(oGet:cargo[2] - 1, 1)
  162.          lTranBack     := FALSE
  163.  
  164.       case nKey == K_DOWN
  165.          oGet:cargo[2] := min(oGet:cargo[2] + 1, len(oGet:cargo[1]))
  166.          lTranBack     := FALSE
  167.  
  168.       case nKey == K_HOME
  169.          oGet:cargo[2] := 1
  170.          lTranBack     := FALSE
  171.  
  172.       case nKey == K_END
  173.          oGet:cargo[2] := len(oGet:cargo[1])
  174.          lTranBack     := FALSE
  175.  
  176.       case nKey == K_SH_TAB
  177.          oGet:exitState := GE_UP
  178.  
  179.       case nKey == K_TAB
  180.          oGet:exitState := GE_DOWN
  181.  
  182.       case nKey == K_ENTER
  183.          oGet:exitState := GE_ENTER
  184.  
  185.       case nKey == K_ESC
  186.          if Set(_SET_ESCAPE)
  187.             oGet:undo()
  188.             oGet:exitState := GE_ESCAPE
  189.             lTranBack     := FALSE
  190.          endif
  191.  
  192.       case nKey == K_PGUP
  193.          oGet:exitState := GE_WRITE
  194.  
  195.       case nKey == K_PGDN
  196.          oGet:exitState := GE_WRITE
  197.  
  198.       case nKey == K_CTRL_END
  199.          oGet:exitState := GE_BOTTOM
  200.  
  201.    endcase
  202.  
  203.    if lTranBack
  204.       oGet:varPut(oGet:cargo[1][oGet:cargo[2]])
  205.    endif
  206.  
  207. return NIL
  208.  
  209. /*
  210.  * displays a menu of choices with the current choice
  211.  * highlighted
  212.  */
  213.  
  214. static function gGtdispChoices(oGet)
  215.  
  216.    local  nCLen := len(oGet:cargo[1])
  217.    local  nCWid := aMaxStrLen(oGet:cargo[1])
  218.    local  nLoop
  219.    static nSt   := 1
  220.  
  221.    if oGet:row + nClen > maxRow() - 1
  222.       nClen := maxRow() - 1 - oGet:row
  223.    endif
  224.  
  225.    do while oGet:cargo[2] > (nSt + nCLen - 1)
  226.       nSt++
  227.    enddo
  228.    do while oGet:cargo[2] < nSt
  229.       nSt--
  230.    enddo
  231.  
  232.    if len(oGet:cargo[1]) - nCLen < (nSt - 1)
  233.       nSt := len(oGet:cargo[1]) - nCLen
  234.    endif
  235.  
  236.  
  237.    dispBegin()
  238.  
  239.    @ oGet:row - 1, oGet:col - 1, oGet:row + nCLen, oGet:col + nCWid        ;
  240.                                box B_SINGLE + " "  color oGet:cargo[3][3]
  241.  
  242.    for nLoop := nSt to nSt + nCLen - 1
  243.       if nLoop == oGet:cargo[2]
  244.          setColor(oGet:cargo[3][1])
  245.       else
  246.          setColor(oGet:cargo[3][2])
  247.       endif
  248.  
  249.       @ oGet:row - nSt + nLoop, oGet:col say oGet:cargo[1][nLoop]
  250.    next
  251.  
  252.    dispEnd()
  253.  
  254. return NIL
  255.  
  256.  
  257. /*
  258.  * save the background where the menu is going to appear
  259.  */
  260.  
  261. static function gGtsaveBack(oGet)
  262.  
  263.    local nCLen := len(oGet:cargo[1])
  264.    local nCWid := aMaxStrLen(oGet:cargo[1])
  265.    local oError
  266.  
  267.    if oGet:row + nClen > maxcol() - 1
  268.       nClen := maxcol() - 1 - oGet:row
  269.    endif
  270.  
  271.    if nCWid + oGet:col > maxcol()
  272.       oError := ErrorNew()
  273.       oError:description := "Choices menu too wide for this screen postion"
  274.       oError:subcode := 1
  275.       oError:subsystem := "GT_ChoiceReader"
  276.       oError:severity := ES_ERROR
  277.       eval(ErrorBlock(),oError)                 // Fire up the error system
  278.    endif
  279.  
  280. return GT_SaveScr(oGet:row - 1, oGet:col - 1,                     ;
  281.                   oGet:row + nCLen, oGet:col + nCWid)
  282.  
  283.  
  284.  
  285. /*
  286.  * if anyone can add the right clause and code to get the colors
  287.  * setting correctly please modify it.
  288.  */
  289.  
  290.  
  291. static function gGTSetColours(oGet)
  292.  
  293.    oGet:cargo[3][1] :=  "GB/R"
  294.    oGet:cargo[3][2] :=  "R/BG"
  295.    oGet:cargo[3][3] :=  "GR+/BG"
  296.  
  297. return NIL
  298.