home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 5 / 05.iso / a / a067 / 1.img / GRUMP501.EXE / COLORPAL.PRG < prev    next >
Encoding:
Text File  |  1991-08-28  |  5.6 KB  |  180 lines
  1. /*
  2.      Program: COLORPAL()
  3.      System: GRUMPFISH LIBRARY
  4.      Author: Greg Lief
  5.      Copyright (c) 1988-89, Greg Lief
  6.      Clipper 5.x Version
  7.      Compile instructions: clipper colorpal /n/w/a
  8.      Allows user to select color from interactive palette
  9.      Procs & Fncts: COLORPAL()
  10.      Calls: COLOR_N2S()   (function in COLORS.PRG)
  11. */
  12.  
  13. //───── begin preprocessor directives
  14.  
  15. #include "inkey.ch"
  16. #include "grump.ch"
  17.  
  18. //───── end preprocessor directives
  19.  
  20. function colorpal(curr_color, pal_top, pal_left, redrawfunc)
  21. static palette := []
  22. local mrow, mcol, keypress := 0, xx, oldcolor := setcolor(), ;
  23.       use_sample := .f., num_colors, palbuffer, pal_bot, ;
  24.       colorstrng := 'N  B  G  BG R  BR GR W  N+ B+ G+ BG+R+ BR+GR+W+ '
  25.  
  26. GFSaveEnv(.t., 0)           // shut off cursor
  27.  
  28.  
  29. //───── establish top row and leftmost column for palette if not passed
  30. pal_top  := IF(pal_top = NIL, IF(setblink(), 16, 8), ;
  31.             IF(pal_top < 6, 6, MIN(pal_top, IF(setblink(), 16, 8))))
  32. pal_bot  := pal_top + IF(setblink(), 8, 16)
  33. pal_left := IF(pal_left = NIL, maxcol()-15, MIN(pal_left, maxcol()-15))
  34.  
  35. /*
  36.    establish color sample UDF.  there are three options:
  37.    a) user did not pass fourth parameter --- use default
  38.    b) user passed a code block as fourth parameter - use that unchanged
  39.    c) user passed character string as parameter (such as "whatever()") --
  40.       compile it to a code block
  41. */
  42. if valtype(redrawfunc) == 'C'
  43.    redrawfunc := MakeBlock(redrawfunc)
  44. elseif valtype(redrawfunc) != 'B'
  45.    redrawfunc := { | a, b | colorsample(a, b) }
  46.    use_sample := .T.
  47.    keyboard chr(255)    // force color sample to be drawn immediately
  48. endif
  49.  
  50. //───── set start-up color to current color if no parameter passed
  51. curr_color := if(curr_color == NIL, setcolor(), upper(curr_color))
  52.  
  53. //───── if this is a blinking color but enhanced background colors
  54. //───── are not available, strip out the asterisk
  55. if setblink() .and. "*" $ curr_color
  56.    curr_color := strtran(curr_color, "*", "")
  57. endif
  58.  
  59. //───── convert the string to a number
  60. curr_color := color_s2n(curr_color)
  61.  
  62. /*
  63.    create character string of text/color attributes for color palette
  64.    if it was not already created on a previous visit to colorpal()
  65.    note: we must do a secondary test based on the current setting of
  66.    SETBLINK(), because if it was changed, the palette must either be
  67.    doubled to halved accordingly (SETBLINK(.T.)=128 colors, .F. = 256 colors)
  68. */
  69. if len(palette) != ( num_colors := if(setblink(), 127, 255)+1) * 2
  70.    palette := []
  71.    for xx = 0 to num_colors
  72.       palette += chr(4) + chr(xx)
  73.    next
  74. endif
  75. restscreen(pal_top, pal_left, pal_bot - 1, pal_left+15, palette)
  76. ColorSet(C_MESSAGE)
  77. scroll(pal_bot, pal_left, pal_bot, pal_left+15, 00)
  78. @ pal_bot, pal_left      ssay chr(24)+chr(25)+chr(27)+chr(26)
  79. @ pal_bot, pal_left + 7  ssay chr(17) + chr(217)
  80. @ pal_bot, pal_left + 13 ssay 'Esc'
  81.  
  82. //───── determine starting row and column within palette
  83. mrow := pal_top + int(curr_color / 16)
  84. mcol := pal_left + curr_color % 16
  85.  
  86. //───── commence main keypress loop
  87. do while keypress != K_ESC .and. keypress != K_ENTER
  88.    setcolor(Color_N2S(curr_color))
  89.    //───── draw blinking diamond to mark current color and get keypress
  90.    @ mrow,mcol ssay chr(219)
  91.    keypress := ginkey(0)
  92.  
  93.    //───── clear blinking diamond
  94.    @ mrow,mcol ssay chr(4)
  95.  
  96.    //───── process keystroke
  97.    do case
  98.       case keypress == K_DOWN
  99.          //───── if we are at the bottom, jump to the top
  100.          IF mrow == pal_bot - 1
  101.             curr_color -= (pal_bot - 1 - (mrow := pal_top) ) * 16
  102.          else
  103.             mrow++
  104.             curr_color += 16
  105.          endif
  106.  
  107.       case keypress == K_UP
  108.          //───── if we are at the top, jump to the bottom
  109.          if mrow == pal_top
  110.             curr_color += ( (mrow := pal_bot - 1) - pal_top) * 16
  111.          else
  112.             mrow--
  113.             curr_color -= 16
  114.          endif
  115.  
  116.       case keypress == K_RIGHT
  117.          if mcol < pal_left + 15
  118.             mcol++
  119.             curr_color++
  120.          else
  121.             mcol := pal_left
  122.             curr_color -= 15
  123.          endif
  124.  
  125.       case keypress == K_LEFT
  126.          if mcol > pal_left
  127.             mcol--
  128.             curr_color--
  129.          else
  130.             mcol := pal_left + 15
  131.             curr_color += 15
  132.          endif
  133.  
  134.       case keypress == K_PGDN
  135.          curr_color += (pal_bot - 1 - mrow) * 16
  136.          mrow := pal_bot - 1
  137.  
  138.       case keypress == K_PGUP
  139.          curr_color -= (mrow - pal_top) * 16
  140.          mrow := pal_top
  141.  
  142.       case keypress == K_ENTER .or. keypress == K_ESC
  143.          exit
  144.  
  145.    endcase
  146.    setcolor(color_n2s(curr_color))
  147.    dispbegin()
  148.    if ! use_sample
  149.       palbuffer := savescreen(pal_top, pal_left, pal_bot, pal_left+15)
  150.    endif
  151.    eval(redrawfunc, pal_top, pal_left)
  152.    if ! use_sample
  153.       restscreen(pal_top, pal_left, pal_bot, pal_left+15, palbuffer)
  154.    endif
  155.    dispend()
  156. enddo
  157.  
  158. //───── restore environment
  159. GFRestEnv()
  160. //───── if user pressed esc to abort, return the old color
  161. return (if(keypress == K_ESC, oldcolor, color_n2s(curr_color)))
  162.  
  163. * end function ColorPal()
  164. *--------------------------------------------------------------------*
  165.  
  166.  
  167. /*
  168.    ColorSample(): draw sample box showing current selection
  169. */
  170. static function ColorSample(pal_top, pal_left)
  171. DOUBLEBOX(pal_top-6, pal_left, pal_top-3, pal_left+15)
  172. @ pal_top-5, pal_left+3 ssay "Sample of"
  173. @ pal_top-4, pal_left+1 ssay "current color"
  174. return NIL
  175.  
  176. * end static function ColorSample()
  177. *--------------------------------------------------------------------*
  178.  
  179. * eof colorpal.prg
  180.