home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 5 / 05.iso / a / a067 / 1.img / GRUMP501.EXE / APICK.PRG < prev    next >
Encoding:
Text File  |  1991-08-28  |  12.8 KB  |  360 lines
  1. /*
  2.    Program: APICK.PRG
  3.    System: GRUMPFISH LIBRARY
  4.    Author: Greg Lief
  5.    Copyright (c) 1988-90, Greg Lief
  6.    Clipper 5.01 Version
  7.    Compile instructions: clipper apick /n/w/a
  8. */
  9.  
  10.  
  11. //───── begin preprocessor directives
  12.  
  13. #include "inkey.ch"
  14. #include "grump.ch"
  15. #define ISCHAR(a)        valtype(a) == "C"
  16.  
  17. //───── end preprocessor directives
  18.  
  19.  
  20. //───── global declarations
  21.  
  22. static searchstr       // used for additive searches
  23.  
  24. //───── end global declarations
  25.  
  26. function apick(mtop, mleft, mbottom, mright, marray, cboxcolor, ;
  27.                cbarcolor, cstatcolor, actual_len, ltagging, cunselected, ;
  28.                chighlight, ele, cselected, cunavailable, ctitle, lwrap)
  29.  
  30. local browse, column, key, xx, max_ele, temp, telem, oldscrn, maxwidth, ;
  31.       choice, available := {}, drawthebar, bar_line, oldrow, midpoint
  32.  
  33. GFSaveEnv(, 0)        // shut off cursor
  34.  
  35. /*
  36.    establish colors for box, status bar, and indicator (see
  37.    COLORSET.PRG for default settings).  Pay attention to the second
  38.    parameter -- this tells ColorSet() to merely return the default
  39.    value rather than actually changing the color
  40. */
  41. default cboxcolor to ColorSet(C_APICK_BOXOUTLINE, .T.)
  42. default cbarcolor to ColorSet(C_APICK_STATUSBAR, .T.)
  43. default cstatcolor to ColorSet(C_APICK_INDICATOR, .T.)
  44. default cunselected to ColorSet(C_APICK_UNSELECTED, .T.)
  45. default chighlight to ColorSet(C_APICK_CURRENT, .T.)
  46. default cselected to ColorSet(C_APICK_TAGGED, .T.) + ',' + ;
  47.                      ColorSet(C_APICK_TAGGEDCURRENT, .T.)
  48. default cunavailable to ColorSet(C_APICK_UNAVAILABLE, .T.) + ',' + ;
  49.                         ColorSet(C_APICK_UNAVAILABLECURRENT, .T.)
  50. default ele to 1        // this will serve as our placeholder in the array
  51. default ctitle to ''    // title for APICK() box
  52. default lwrap to .t.    // enable wraparound from top to bottom of array
  53. default ltagging to .f. // do not allow tagging unless specified
  54. searchstr := []         // reset search string for additive search
  55.  
  56. //───── determine # of last element by grabbing length of array,
  57. //───── unless of course the actual length was passed as parameter #9
  58. max_ele := if(valtype(actual_len) != "N", len(marray), actual_len)
  59.  
  60. //───── determine maximum width for the column
  61. //───── use length of box title as a starting point
  62. maxwidth := len(ctitle) + 4
  63. aeval(marray, { | a | maxwidth := if(ISCHAR(a), ;
  64.                       MAX(maxwidth, len(a)), maxwidth) } )
  65.  
  66. //───── if the maximum width was changed in the AEVAL() above, and
  67. //───── if we are allowing tagging, we must increment it by one so
  68. //───── that the checkmark will actually appear!
  69. if ltagging .and. maxwidth > len(ctitle) + 4
  70.    maxwidth++
  71. endif
  72.  
  73. //───── establish coordinates if not passed as parameters
  74. default mtop to if(max_ele > maxrow() - 2, 6, int((maxrow() - max_ele - 1) / 2))
  75. default mleft to int( maxcol() - maxwidth - 2) / 2
  76. default mbottom to if(max_ele > maxrow() - 2, maxrow() - 6, mtop + max_ele + 1)
  77. if mright = NIL .or. mright < mleft + maxwidth + 1
  78.    mright = mleft + maxwidth + 1
  79. endif
  80.  
  81. //───── if we are allowing the user to tag elements, we must add a space to
  82. //───── each array element to hold the ubiquitous checkmark (√)
  83. default ltagging to .f.
  84. if ltagging
  85.    aeval(marray, { | a, b | if(ISCHAR(marray[b]), marray[b] += " ", NIL) } )
  86. endif
  87.  
  88. //───── establish parallel array to hold logicals (selectable vs. unselectable)
  89. aeval(marray, { | a | aadd(available, ;
  90.                       if(ISCHAR(a), substr(a, 1, 1) != '~', .f.) ) } )
  91.  
  92. //───── determine coordinates for displaying the search string
  93. midpoint := mleft + int((mright - mleft) / 2) - 5
  94.  
  95. //───── Create tbrowse object set to the appropriate coordinates
  96. browse := TBrowseNew(mtop + 1, mleft + 1, mbottom - 1, mright - 1)
  97. browse:colorSpec := cunselected + "," + chighlight + "," + cselected + ;
  98.                     "," + cunavailable
  99. //───── establish navigation blocks for the tbrowse object
  100. browse:skipBlock := { |SkipCnt| AwSkipIt(@ele, SkipCnt, max_ele) }
  101. browse:goTopBlock := { || ele := 1 }
  102. browse:goBottomBlock := { || ele := max_ele }
  103.  
  104. //───── look for horizontal lines -- any elements like so: "~─"
  105. for xx = 1 to max_ele
  106.    if ISCHAR(marray[xx])
  107.       if substr(marray[xx], 1, 1) = '~'
  108.          marray[xx] = substr(marray[xx], 2)
  109.          //───── see if they want to draw a horizontal line - if so,
  110.          //───── trimmed length of this array element will now be one.
  111.          if len(trim(marray[xx])) = 1
  112.             marray[xx] := replicate(trim(marray[xx]), maxwidth)
  113.          endif
  114.       endif
  115.    endif
  116. next
  117.  
  118. //───── create column for the browse object
  119. column := TBColumnNew("", { | | marray[ele] } )
  120. column:width = maxwidth
  121.  
  122. /*
  123.     establish color setup - use the following pairs for these items:
  124.        unselected/available options  --> {1, 2}
  125.        tagged/available options      --> {3, 4}
  126.        unavailable options           --> {5, 6}
  127.  
  128.    these numbers correspond to colors as follows:
  129.    1) unselected          2) hilight                  3) tagged (unselected)
  130.    4) tagged (selected)   5) unavailable (unselected) 6) unavailable (selected)
  131. */
  132. column:colorBlock := {|x| if(! available[ele], {5, 6}, ;
  133.                       if(right(x, 1) = chr(251), {3, 4}, {1, 2} ))}
  134.  
  135. //───── add this column to the browse object and get ready for browsing fun
  136. browse:AddColumn( column )
  137.  
  138. //───── draw box and status bar, using box title if it was passed
  139. setcolor(cboxcolor)
  140. oldscrn := ShadowBox(mtop, mleft, mbottom, mright, 1, ctitle)
  141. //───── draw status bar if not all of the array elements fit in the window
  142. bar_line := mtop + 2
  143. if (drawthebar := (max_ele > mbottom - mtop - 1))
  144.    @ mtop + 1, mright, mbottom - 1, mright box chr(176) color cbarcolor
  145. endif
  146.  
  147. /*
  148.    If the initially highlighted element is NOT the first element of
  149.    the array, we will send the appropriate number of down() method
  150.    calls to the TBrowse object.  This is so that the highlighted element
  151.    is not shown as the top element in the window, which would present
  152.    the misleading impression that there are no elements above it for
  153.    selection.  (Modification prompted by Dangerous Dave Harrington.)
  154. */
  155. if ele > 1
  156.    do while ele-- > 1
  157.       browse:down()
  158.    enddo
  159.    ele := 1
  160. endif
  161.  
  162. do while .t.
  163.  
  164.    //───── wait for the display to stabilize, which will
  165.    //───── loop once for each row in the browse window.
  166.    //───── allow a keypress to bust out of this loop
  167.    dispbegin()
  168.    do while ! browse:stabilize() .and. (key := inkey()) = 0
  169.    enddo
  170.    dispend()
  171.  
  172.    if browse:stable .and. drawthebar
  173.       oldrow := row()
  174.       //───── draw arrows if there are elements beyond top or bottom of window
  175.       //───── first the bottom
  176.       @ mbottom, mright ssay if(max_ele - ele >= mbottom - oldrow, ;
  177.                                chr(25), chr(188)) color cboxcolor
  178.       //───── then the top
  179.       @ mtop,mright ssay if(oldrow - ele < mtop, chr(24), chr(187))
  180.  
  181.       //───── if status bar position has changed...
  182.       if bar_line != mtop + 1 + ;
  183.                      int((ele / max_ele) * (mbottom - mtop - 2))
  184.          //───── first, blank out previous status bar
  185.          @ bar_line, mright ssay chr(176) color cbarcolor
  186.          //───── then recalculate position of status bar
  187.          bar_line := mtop + 1 + int((ele / max_ele) * ;
  188.                                 (mbottom - mtop - 2))
  189.          //───── finally, redraw it
  190.          @ bar_line, mright ssay CHR(219) color cstatcolor
  191.       endif
  192.    endif
  193.  
  194.    if browse:stable
  195.       key := ginkey(0, ele)            // pass along array subscript
  196.    endif
  197.  
  198.    //───── deal with the keypress
  199.    do case
  200.  
  201.       case key == 32 .and. available[ele] .and. ltagging  // tag 'em, Dan-O
  202.          marray[ele] = left(marray[ele], ;
  203.                        len(marray[ele]) - 1) + ;
  204.                        if(right(marray[ele], 1) = chr(251), chr(32), chr(251))
  205.          searchstr := []
  206.          showstring(mbottom, midpoint, cboxcolor, mleft)
  207.          //───── force redrawing this item to change its color
  208.          browse:refreshCurrent()
  209.  
  210.       case key == K_F8 .and. ltagging     // tag 'em all, Dan-O
  211.          aeval(marray, { | a, b | marray[b] := if(available[b], ;
  212.                        left(marray[b], len(marray[b]) - 1) + chr(251), ;
  213.                        marray[b]) } )
  214.          //───── force redrawing entire window to change color of all items
  215.          browse:refreshAll()
  216.  
  217.       case key == K_F9 .and. ltagging     // set 'em free, Dan-O
  218.          aeval(marray, { | a, b | marray[b] := if(available[b], ;
  219.                             left(marray[b], len(marray[b]) - 1) + chr(32), ;
  220.                             marray[b]) } )
  221.          //───── force redrawing entire window to change color of all items
  222.          browse:refreshAll()
  223.  
  224.       case key == K_F10 .and. ltagging   // switch all tags (Chinese Fire Drill)
  225.          aeval(marray, { | a, b | marray[b] := if(available[b], ;
  226.                        left(marray[b], len(marray[b]) - 1) + ;
  227.                        if(right(marray[b], 1) = chr(32), chr(251), chr(32)), ;
  228.                        marray[b]) } )
  229.          //───── force redrawing entire window to change color of all items
  230.          browse:refreshAll()
  231.  
  232.       case key == K_UP          // up one row
  233.          //───── if we are already at the top element, wrap to bottom
  234.          if ele == 1
  235.             if lwrap
  236.                browse:goBottom()
  237.             endif
  238.          else
  239.             browse:up()
  240.          endif
  241.  
  242.       case key == K_DOWN        // down one row
  243.          //───── if we are already at the bottom element, wrap to top
  244.          if ele == max_ele
  245.             if lwrap
  246.                browse:goTop()
  247.             endif
  248.          else
  249.             browse:down()
  250.          endif
  251.  
  252.       case key == K_CTRL_PGUP  // take it to the top, Jerome!
  253.          browse:goTop()
  254.  
  255.       case key == K_CTRL_PGDN  // goin' down.... down.... down ........
  256.          browse:goBottom()
  257.  
  258.       case key == K_PGUP .or. key == K_HOME   // top o' window
  259.          browse:pageUp()
  260.  
  261.       case key == K_PGDN .or. key == K_END    // bottom o' window
  262.          browse:pageDown()
  263.  
  264.       case key == K_ESC                        // aloha, you quitter
  265.          choice := 0
  266.          exit
  267.  
  268.       case key > 31 .and. key < 255      // search 'em
  269.          if (telem := Ascan2(marray, searchstr + chr(key))) > 0
  270.             searchstr += chr(key)
  271.             //───── if moving backwards (up) through the array,
  272.             //───── we have to handle it manually
  273.             if ele > telem
  274.                for xx := 1 to ele - telem
  275.                   browse:up()
  276.                next
  277.             elseif ele != telem
  278.                browse:refreshAll()
  279.                ele := telem
  280.             endif
  281.             showstring(mbottom, midpoint, cboxcolor, mleft)
  282.          endif
  283.  
  284.       case key == K_BS .OR. key == K_LEFT  // truncate the search string
  285.          if len(searchstr) > 0
  286.             searchstr := substr(searchstr, 1, len(searchstr) - 1)
  287.             if (telem := Ascan2(marray, searchstr)) > 0
  288.                ele := telem
  289.                browse:refreshAll()
  290.             endif
  291.             showstring(mbottom, midpoint, cboxcolor, mleft)
  292.          endif
  293.  
  294.       case key = K_ENTER .and. available[ele]   // select if available
  295.         choice := ele
  296.         exit
  297.  
  298.    endcase
  299. enddo
  300. ByeByeBox(oldscrn)
  301. GFRestEnv()
  302. return choice
  303.  
  304. * end function APick()
  305. *--------------------------------------------------------------------*
  306.  
  307.  
  308. /*
  309.    Function: AwSkipIt()
  310.    Purpose:  Custom Skip UDF for TBROWSE() above
  311. */
  312. static function AwSkipIt(ele, skip_cnt, maxval)
  313. local movement := 0 // this will be returned to TBROWSE
  314. if skip_cnt > 0
  315.    do while ele + movement < maxval .and. movement < skip_cnt
  316.       movement++
  317.    enddo
  318. elseif skip_cnt < 0
  319.    if ele = 1 .and. skip_cnt = -1
  320.       movement := maxval - 1
  321.    else
  322.       do while ele + movement > 1 .and. movement > skip_cnt
  323.          movement--
  324.       enddo
  325.    endif
  326. endif
  327. ele += movement
  328. return movement
  329.  
  330. * end static function AwSkipIt()
  331. *--------------------------------------------------------------------*
  332.  
  333.  
  334. /*
  335.    Function: ShowString()
  336.    Purpose:  Display the search string
  337. */
  338. static function showstring(row, col, ccolor, mleft)
  339. @ row, col ssay if(len(searchstr) == 0, ;
  340.                 if(col == mleft, chr(200), chr(205)) + ;
  341.                 replicate(chr(205), 9), ;
  342.                 "[" + pad(searchstr, 8) + "]") color ccolor
  343. return NIL
  344.  
  345. * end static function ShowString()
  346. *--------------------------------------------------------------------*
  347.  
  348.  
  349. /*
  350.      Function: AScan2()
  351.      Purpose:  Perform case-insensitive ASCAN()
  352. */
  353. static function AScan2(array, value)
  354. return ascan(array, { | a | if(ISCHAR(a), upper(a) = upper(value), .F.) }, 1)
  355.  
  356. * end static function AScan2()
  357. *--------------------------------------------------------------------*
  358.  
  359. * eof apick.prg
  360.