home *** CD-ROM | disk | FTP | other *** search
/ Piper's Pit BBS/FTP: ibm 0010 - 0019 / ibm0010-0019 / ibm0010.tar / ibm0010 / CLIPB52.ZIP / LIEF.ZIP / GCHOICE.PRG next >
Encoding:
Text File  |  1990-06-02  |  8.1 KB  |  247 lines
  1. *!******************************************************
  2. *!
  3. *!   Program: YesItWorks
  4. *!   Purpose: To demonstrate GHOICE(), extra-strength
  5. *!            heavy-duty ACHOICE() shell
  6. *!   Author:  Greg Lief
  7. *!
  8. *!******************************************************
  9. #include "gkeys.ch"
  10. #translate FAKE_KEY => __Keyboard(CHR(255))
  11.  
  12. LOCAL MyArray, mrow := 5, mcol := 25, xx, oldcursor := SETCURSOR(0)
  13. PRIVATE oldcolor
  14. MyArray := {"BASS ", "BLUEGILL ", "GRUMPFISH ", ;
  15.     "ROCKFISH ", "SAILFISH ", "COD ", "HADDOCK ", ;
  16.     "HOLY MACKEREL ", "MACKEREL ", "HERRING ", ;
  17.     "SALMON ", "TUNA ", "BARRACUDA ", "PIRANHA ", ;
  18.     "DOLPHIN ", "HATCHET ", "STICKLEBACK ", ;
  19.     "SCALED BLENNY ", "PUFFER ", "SARGASSUM ", ;
  20.     "VIPERFISH ", "LAMPREY ", "BLOWFISH ", "CATFISH ", ;
  21.     "ANGELFISH ", "FIGHTING FISH ", "TRIGGERFISH ", ;
  22.     "ROSEFISH "}
  23. Ghoice(MyArray)
  24. CLEAR
  25. oldcolor := SETCOLOR("+W/RB")
  26. BOX1(4, 23, 19, 56)
  27. CENTER(4, "[ Selected Fish ]")
  28. FOR xx = 1 TO 28
  29.    IF RIGHT(MyArray[xx], 1) = CHR(251)
  30.       @ mrow, mcol SAY SUBSTR(MyArray[xx], 1, ;
  31.                        LEN(MyArray[xx]) - 1)
  32.       IF mcol = 25
  33.          mcol = 42
  34.       ELSE
  35.          mcol = 25
  36.          mrow++
  37.       ENDIF
  38.    ENDIF
  39. NEXT
  40. INKEY(0)
  41. SETCURSOR(oldcursor)
  42. SETCOLOR(oldcolor)
  43. RETURN
  44.  
  45.  
  46. *!******************************************************
  47. *!
  48. *! Function: Ghoice()
  49. *!  Purpose: Shell for ACHOICE() that provides:
  50. *!           (a) elevator status bar showing relative
  51. *!               position (particularly useful when not
  52. *!               all array elements appear on screen at
  53. *!               the same time)
  54. *!           (b) search provision by typing first
  55. *!               letters of desired element
  56. *!           (c) ability to tag one or all array
  57. *!               elements for future batch processing
  58. *!  Author:   Greg Lief
  59. *!  Copyright (c) 1989-90 Greg Lief
  60. *!
  61. *!******************************************************
  62. FUNCTION Ghoice
  63. PARAMETERS marray, mtop, mleft, mbottom, mright
  64. LOCAL xx, maxwidth, oldcolor, oldscrn
  65. PRIVATE rel_elem, rel_row, buffer, searchstr, ;
  66.         last_ele, unsel_clr, box_clr, bar_clr, ;
  67.         hilite_clr, bar_line
  68. last_ele := LEN(marray)
  69. IF PCOUNT() = 1
  70.    *** determine widest array element
  71.    maxwidth := 0
  72.    AEVAL(marray, { | a | maxwidth := MAX(maxwidth, LEN(a)) } )
  73.    mright := (mleft := INT((78 - maxwidth) / 2)) + maxwidth + 1
  74.    mtop := 7
  75.    mbottom := 17
  76. ENDIF
  77. searchstr := []
  78. rel_elem := rel_row := 1
  79. box_clr  := IF(ISCOLOR(), 'W/B', 'W/N')
  80. bar_clr  := 'W/N, I'
  81. stat_clr := '+GR/N'
  82. unsel_clr := box_clr
  83. hilite_clr := 'I'
  84. draw_bar := (last_ele > mbottom - mtop - 1)
  85. *** force status bar to be drawn on first pass
  86. bar_line := mtop + 2
  87. oldcolor := SETCOLOR(box_clr)
  88. oldscrn := SAVESCREEN(mtop, mleft, mbottom, mright)
  89. BOX2(mtop, mleft, mbottom, mright)
  90. IF draw_bar
  91.    SETCOLOR(bar_clr)
  92.    FOR xx = mtop + 1 TO mbottom - 1
  93.       @ xx, mright SAY CHR(176)
  94.    NEXT
  95. ENDIF
  96. SETCOLOR(box_clr + ',' + hilite_clr + ',,,' + ;
  97.          unsel_clr)
  98. FAKE_KEY
  99. DO WHILE .T.
  100.    ACHOICE(mtop+1, mleft+1, mbottom-1, mright-1,;
  101.          marray, NIL, 'KeyTest', rel_elem, rel_row)
  102.    IF LASTKEY() = ENTER .OR. LASTKEY() = ESC
  103.       EXIT
  104.    ENDIF
  105. ENDDO
  106. RESTSCREEN(mtop, mleft, mbottom, mright, oldscrn)
  107. SETCOLOR(oldcolor)
  108. RETURN NIL
  109.  
  110.  
  111. *!******************************************************
  112. *!
  113. *!       Function: KeyTest()
  114. *!       Purpose:  Handle keystroke exceptions etc
  115. *!       Author:   Greg Lief
  116. *!       Copyright (c) 1989-90 Greg Lief
  117. *!
  118. *!******************************************************
  119. FUNCTION KeyTest(status, curr_elem, curr_row)
  120. LOCAL xx, oldrow := ROW(), oldcol := COL(), ;
  121.       ret_val := CONTINUE, oldcolor, key
  122. key := LASTKEY()
  123. DO CASE
  124.  
  125.    CASE status = PAST_TOP
  126.       rel_elem := last_ele
  127.       FAKE_KEY             && force status bar display
  128.       ret_val := ABORT     && force ACHOICE() to restart
  129.  
  130.    CASE status = PAST_BOTTOM
  131.       rel_elem := 1
  132.       FAKE_KEY             && force status bar display
  133.       ret_val := ABORT     && force ACHOICE() to restart
  134.  
  135.    CASE status = IDLE  .OR. key = 255
  136.       oldcolor := SETCOLOR()
  137.       IF draw_bar
  138.          *** draw arrows if there are elements beyond
  139.          *** top or bottom of window
  140.          ** first, the bottom
  141.          @ mbottom, mright SAY ;
  142.            IF(last_ele - curr_elem >= mbottom - oldrow, ;
  143.                                       CHR(25), CHR(188))
  144.          ** then the top
  145.          @ mtop,mright SAY ;
  146.            IF(oldrow - curr_elem < mtop, ;
  147.                                       CHR(24), CHR(187))
  148.  
  149.          ** if status bar position has changed...
  150.          IF bar_line != mtop + 1 + ;
  151.                         INT((curr_elem / last_ele) * ;
  152.                         (mbottom - mtop - 2))
  153.             *** first, blank out previous status bar
  154.             SETCOLOR(bar_clr)
  155.             @ bar_line, mright SAY CHR(176)
  156.             *** then recalculate position of status bar
  157.             bar_line := mtop + 1 + ;
  158.                         INT( (curr_elem / last_ele) * ;
  159.                         (mbottom - mtop - 2) )
  160.             SETCOLOR(stat_clr)
  161.             *** finally, redraw it
  162.             @ bar_line, mright SAY CHR(219)
  163.          ENDIF
  164.       ENDIF
  165.       SETCOLOR(oldcolor)
  166.  
  167.    CASE key = SPACEBAR         && toggle this fish on/off
  168.       marray[curr_elem] := LEFT(marray[curr_elem], ;
  169.          LEN(marray[curr_elem]) - 1) + ;
  170.          IF(RIGHT(marray[curr_elem], 1) = " ", "√", " ")
  171.       rel_elem := curr_elem + 1
  172.       rel_row := curr_row + 1
  173.       searchstr := []          && reset search string
  174.       @ mbottom, 33 SAY REPLICATE(CHR(205), 14)
  175.       ret_val := ABORT         && Force ACHOICE redisplay
  176.  
  177.    CASE key = ENTER .OR. key = ESC
  178.       ret_val := ABORT         && prepare to fall out
  179.  
  180.    CASE key = HOME
  181.       KEYBOARD CHR(CTRL_PGUP)
  182.  
  183.    CASE key = END
  184.       KEYBOARD CHR(CTRL_PGDN)
  185.  
  186.    CASE key = F8               && tag all items
  187.       FOR xx = 1 TO last_ele
  188.          marray[xx] = LEFT(marray[xx], ;
  189.                       LEN(marray[xx]) - 1) + CHR(251)
  190.       NEXT
  191.       rel_elem := curr_elem    && save current position
  192.       rel_row := curr_row      && and relative position
  193.       ret_val := ABORT         && Force ACHOICE redisplay
  194.  
  195.    CASE key = F9               && clear all tags
  196.       FOR xx = 1 TO last_ele
  197.          marray[xx] := LEFT(marray[xx], ;
  198.                      LEN(marray[xx]) - 1) + CHR(SPACEBAR)
  199.       NEXT
  200.       rel_elem := curr_elem    && save current position
  201.       rel_row := curr_row      && and relative position
  202.       ret_val := ABORT         && Force ACHOICE redisplay
  203.  
  204.    CASE key = F10              && reverse all tags
  205.       FOR xx = 1 TO last_ele
  206.          marray[xx] := LEFT(marray[xx], ;
  207.               LEN(marray[xx]) - 1) + ;
  208.               IF(RIGHT(marray[xx], 1) = " ", "√", " ")
  209.       NEXT
  210.       rel_elem := curr_elem    && save current position
  211.       rel_row := curr_row      && and relative position
  212.       ret_val := ABORT         && Force ACHOICE redisplay
  213.  
  214.    *** letter key
  215.    CASE Isalpha(CHR(key))   && see STD.CH
  216.       searchstr += CHR(key)
  217.       telem := ASCAN2(marray, searchstr)
  218.       rel_elem := IF(telem = 0, curr_elem, telem)
  219.       @ mbottom, 36 SAY "[" + PAD(searchstr, 6) + "]"
  220.       ret_val := ABORT         && Force ACHOICE redisplay
  221.  
  222.    CASE key = BACKSPACE .OR. key = LTARROW
  223.       IF LEN(searchstr) > 0
  224.          searchstr := SUBSTR(searchstr, 1, ;
  225.                       LEN(searchstr) - 1)
  226.          telem := ASCAN2(marray, searchstr)
  227.          rel_elem := IF(telem = 0, curr_elem, telem)
  228.       ENDIF
  229.       @ mbottom, 36 SAY IF(LEN(searchstr) = 0, ;
  230.                         REPLICATE(DOUBLE_LINE, 8), ;
  231.                         "[" + PAD(searchstr, 6) + "]")
  232.       ret_val := ABORT         && Force ACHOICE redisplay
  233.  
  234. ENDCASE
  235. RETURN ret_val
  236.  
  237.  
  238. *!******************************************************
  239. *!
  240. *!       Function: AScan2()
  241. *!       Purpose:  Perform case-insensitive ASCAN()
  242. *!       Author:   Greg Lief
  243. *!
  244. *!******************************************************
  245. FUNCTION AScan2(array, value)
  246. RETURN ASCAN(array, { | a | UPPER(a) = UPPER(value) } )
  247.