home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / select.seq < prev    next >
Text File  |  1991-03-30  |  15KB  |  380 lines
  1. \ SELECT.SEQ            Menu selection utility          by Tom Zimmer
  2.  
  3. only forth also definitions hidden also
  4.  
  5. anew selector
  6.  
  7. 16 array #buf
  8.  
  9. : %#input       ( x y d1 bgclr fgclr -- d1 f1 )     \ f1 = true for success
  10.                 ' noop save!> >edattrib
  11.                 savecursor cursor-on >fg >bg
  12.                 2over 2>r
  13.                 #buf 10 blank
  14.                 <# #s #> #buf place
  15.                 on> autoclear
  16.                 #buf 6 lineeditor >r
  17.                 $2020 #buf count + !
  18.                 #buf count upper
  19.                 #buf %number r> and
  20.                 2r> at #buf count 5 min 5 over - spaces type space
  21.                 restcursor
  22.                 restore> >edattrib ;
  23.  
  24. : #input        ( x y d1 -- d1 f1 )     \ f1 = true for success
  25.                 ltgray black %#input ;
  26.  
  27. : ?upc          ( c1 -- c2 )            \ uppercase if not function key
  28.                 dup 128 <
  29.                 if      upc
  30.                 then    ;
  31.  
  32. 0 value curwin          \ current window
  33. 0 value winline#        \ current window line being compiled
  34. 0 value wbgstuff?       \ is window bgstuff active?
  35.  
  36. : winitem       ( n1 | name -- )        \ window subfield defining word
  37.                 create over c, +
  38.                 does> c@ curwin + ;
  39.  
  40. 0
  41. 1 winitem worgx         \ window x origin
  42. 1 winitem worgy         \ window y origin
  43. 1 winitem wrows         \ window rows
  44. 1 winitem wcols         \ window columns
  45. 1 winitem wx            \ current window x position
  46. 1 winitem wy            \ current window y position
  47. 1 winitem wbase         \ window base
  48. 1 winitem wexit         \ non zero flag if we want to leave window
  49. 1 winitem wbg           \ window background color
  50. 1 winitem wfg           \ window forground color
  51. 1 winitem wexitkey      \ window exit key       (defaults to ESC)
  52. 2 winitem wexitfunc     \ window exit function  (defaults to NOOP)
  53. 2 winitem wescfunc      \ window ESC key function IF NOT EXIT!
  54. 2 winitem wshow         \ window additional display information
  55. 2 winitem wintitle      \ window title line
  56. 2 winitem winbottom     \ bottom of window message
  57. 2 winitem wptr          \ window save pointer
  58. 2 winitem wokey         \ function to do when other keys are pressed
  59. 2 winitem f1key         \ function to do when F1 pressed
  60. 2 winitem wbgstuff      \ window background operation
  61. 1 winitem wshown        \ has window been shown?
  62. 1 winitem whilite       \ hilited line number
  63. 0 winitem winlines      \ start of text for window  ** MUST BE LAST ITEM **
  64. value winrsize
  65.  
  66. : window        ( c r | name -- )       \ define window c=columns r=rows
  67.                 create here !> curwin           \ set as current window
  68.                        winrsize allot
  69.                 curwin winrsize erase
  70.                 1 max wrows c!                  \ default window size
  71.                 1 max wcols c!
  72.                 $0A wbase c!                    \ default base DECIMAL
  73.                 ltgray wfg c!                   \ default colors
  74.                 black wbg c!
  75.                 27 wexitkey c!                  \ default exit is ESC
  76.                 ['] noop wexitfunc !            \ default exit func NOOP
  77.                 ['] noop wescfunc !             \ default ESC func NOOP
  78.                 ['] noop wshow !                \ default extra show info
  79.                 ['] drop wokey !                \ default for other keys
  80.                 ['] noop f1key !                \ default F1 help
  81.                 ['] noop wbgstuff !             \ default background ops
  82.                 here wrows c@ 2* dup allot erase
  83.                 off> winline#                   \ reset current line cnt
  84.                 does>   !> curwin ;
  85.  
  86. : dowbgstuff    ( -- f )
  87.                 defers bgstuff
  88.                 wbgstuff?
  89.                 if      wbgstuff perform
  90.                 then    ;
  91.  
  92. ' dowbgstuff is bgstuff
  93.  
  94. : dohilite      ( -- )                  \ perform function for hilited line
  95.                 curwin >r
  96.                 whilite c@ 2* winlines + @ 1+
  97.                 count + @ execute
  98.                 r> !> curwin ;
  99.  
  100. : winexit       ( -- )
  101.                 1 wexit c! ;
  102.  
  103. : winline"      ( c1 | txt" func -- )   \ install text as line of window
  104.                 winline#
  105.                 dup wrows c@ >= abort" TOO MANY lines for this window!"
  106.                 here swap 2* winlines + !       \ install pointer to text
  107.                 c,                              \ activation key
  108.                 ," ' ,                          \ compile in text to here
  109.                 incr> winline# ;                \ bump to next line
  110.  
  111. : wintitle"     ( | txt" -- )           \ title of window
  112.                 here wintitle !
  113.                 ," ;
  114.  
  115. : winbottom"    ( | txt" -- )           \ bottom line message
  116.                 here winbottom !
  117.                 ," ;
  118.  
  119. : winorg!       ( x y -- )              \ set origin of current window
  120.                 dup worgy c! 1+ wy c!
  121.                 dup worgx c! 1+ wx c! ;
  122.  
  123. : winbg!        ( n1 -- )               \ set window background color
  124.                 wbg c! ;
  125.  
  126. : winfg!        ( n1 -- )               \ set window forground color
  127.                 wfg c! ;
  128.  
  129. : winat         ( x y -- )              \ move to relative pos in window
  130.                 -1 max worgy c@ 1+ + wy c!
  131.                  0max  worgx c@ 1+ + wx c!
  132.                 wx c@ wy c@ 2dup at !> bline 1- !> tx ;
  133.  
  134. : wincr         ( -- )                  \ move to beginning of next win line
  135.                 worgx c@ 1+ dup wx c!
  136.                 wy c@ 1+ dup wy c! at ;
  137.  
  138. : .wintitle     ( -- )
  139.                 wintitle @ 0= ?exit
  140.                 ?cs: wintitle @ count
  141.                 wcols c@ over - 0max 2/ worgx c@ + 1+ worgy c@ at \typeL ;
  142.  
  143. : .winbottom    ( -- )
  144.                 winbottom @ 0= ?exit
  145.                 worgx c@ 2+ worgy c@ wrows c@ + 1+ at
  146.                 ?cs: winbottom @ count \typeL ;
  147.  
  148. : .info         ( -- )
  149.                 worgx c@ wcols c@ + 1+ worgy c@
  150.                 2dup               at ." \6"
  151.                 2dup swap 6 - swap at ."  Home "
  152.                 wrows c@ + 1+
  153.                 2dup               at ." \6"
  154.                      swap 5 - swap at ."  End " ;
  155.  
  156. : winshow       ( -- )
  157.                 savescr
  158.                 wbg c@ >bg wfg c@ >fg
  159.                 worgx c@ worgy c@ 2dup
  160.                 wcols c@ 1+ wrows c@ 1+ d+ box&fill
  161.                 .wintitle
  162.                 .winbottom
  163.                 .info
  164.                 1 wshown c! ;
  165.  
  166. : whilite+      ( n1 -- )       \ increment hilited by signed n1
  167.                 begin   whilite c@ over + wrows c@ mod whilite c!
  168.                         winlines whilite c@ 2* + @
  169.                         c@
  170.                 until   drop ;
  171.  
  172. : towhome       ( -- )
  173.                 0 whilite c!
  174.                 winlines @ c@ 0=
  175.                 if      1 whilite+
  176.                 then    ;
  177.  
  178. : towend        ( -- )
  179.                 wrows c@ 1- whilite c!
  180.                 winlines wrows c@ 1- 2* + @ c@ 0=
  181.                 if      -1 whilite+
  182.                 then    ;
  183.  
  184. : %wintype      ( a1 n1 n2 -- )         \ display special for line n2
  185.                 save> attrib cyan >bg black >fg space
  186.                 >r
  187.                 over 1+ c@ '#' =                \ number edit?
  188.                 if      winlines r@ 2* + @ 1+
  189.                         count + @
  190.                         wbase c@ save!> base
  191.                         >body @ @ 5 u.r 2 spaces
  192.                         restore> base
  193.                         8 /string
  194.                 else    tuck '▒' skip 2dup 2>r nip - >r
  195.                         winlines 3 rpick 2* + @ 1+
  196.                         count + @
  197.                         >body @ count r> 2dup swap - 0max >r
  198.                         min type r> spaces 2r>
  199.                 then    r>drop
  200.                 restore> attrib type ;
  201.  
  202. : wintype       ( a1 n1 n2 -- )         \ display window text for line n2
  203.                 >r                                      \ save line
  204.                 2dup '▒' scan 2dup 2>r nip - type       \ show leading text
  205.                 2r> dup
  206.                 if      r@ %wintype
  207.                 else    2drop
  208.                 then    r>drop ;
  209.  
  210. : windshow      ( -- )
  211.                 winlines whilite c@ 2* + @ c@ 0=
  212.                 if      1 whilite+
  213.                 then    0 0 winat
  214.                 wbg c@ >bg wfg c@ >fg
  215.                 attrib @ winlines wrows c@ 0
  216.                 ?do     over attrib ! space
  217.                         whilite c@ i =
  218.                         if attrib c@ $10 /mod swap $10 * + attrib c! then
  219.                         2 spaces dup i 2* + @ 1+
  220.                         count i over >r wintype
  221.                         wcols c@ r> - 5 - 0max spaces
  222.                         bcr
  223.                 loop    2drop wshow perform ;
  224.  
  225. : winhide       ( -- )
  226.                 wshown c@ 0= ?exit
  227.                 restscr
  228.                 0 wshown c! ;
  229.  
  230. : dowinkey      ( c1 -- )       \ check & perform c1 function
  231.                 ?upc winlines           \ for window mechanism to handle key
  232.                 wrows c@ 0
  233.                 ?do     2dup i 2* + @ c@ ?upc =
  234.                                 if      i whilite c!
  235.                                         windshow 50 ms
  236.                                         dohilite
  237.                                         swap 0= swap    \ change key to NULL
  238.                                         leave
  239.                                 then
  240.                 loop    drop
  241.                 wokey perform ;         \ do other key operation
  242.                                         \ wokey is passed a NULL if key was
  243.                                         \ processed by window mechanism
  244.  
  245. : doeditvar     ( a1 | name -- )
  246.                 create , does>
  247.                 save> base wbase c@ base !
  248.                 @ dup @ >r                              \ s=a1  r=n1
  249.                 winlines whilite c@ 2* + @ 1+
  250.                 count                                   \ s=a1, n1
  251.                     tuck '▒' scan nip -                 \ s=offset
  252.                 wx c@ 4 + + wy c@ whilite c@ +          \ s=x, y
  253.                 r> 0 cyan black ( fldcolor ) %#input
  254.                 if      drop swap !
  255.                 else    2drop drop
  256.                 then    restore> base ;
  257.  
  258. : doedit$       ( a1 | name -- )
  259.                 create , does>
  260.                 ' noop save!> >edattrib
  261.                 savecursor cursor-on
  262.                 cyan >bg black >fg ( fldcolor )
  263.                 @ >r                                    \ r=a1
  264.                 winlines whilite c@ 2* + @ 1+
  265.                 count                                   \ s=a1, n1
  266.                     tuck '▒' scan 2dup 2>r nip -        \ s=offset
  267.                 wx c@ 4 + + wy c@ whilite c@ +          \ s=x, y
  268.                 2r> tuck '▒' skip          nip -        \ s=x, y, length
  269.                 r> swap lineeditor drop
  270.                 restcursor
  271.                 restore> >edattrib ;
  272.  
  273. : dofunc$      ( a1 a2 | name -- )      \ a1=string, a2=function
  274.                 create swap , , does> length swap perform ;
  275.  
  276. cyan value grayfg
  277. blue value graybg
  278.  
  279. : graywind      ( -- )                  \ gray prev window
  280.                 ?vmode 7 = ?exit
  281.                 savecursor
  282.                 wfg c@ wbg c@
  283.                 grayfg wfg c!
  284.                 graybg wbg c!
  285.                 windshow
  286.                 wbg c! wfg c!
  287.                 restcursor ;
  288.  
  289. : dowindow      ( a1 | name -- )
  290.                 create curwin , does> @ !> curwin
  291.                 savecursor
  292.                 0 wexit c!
  293.                 winshow
  294.                 begin   windshow wexit c@ 0=
  295.                         if      key dup ?upc wexitkey c@ =
  296.                                 if      1 wexit c!              \ mark exit
  297.                                         wexitfunc perform
  298.                                 then
  299.                         else    0
  300.                         then    wexit c@ 0=
  301.                 while   case
  302.         ( home )        199 of  towhome                 endof
  303.         ( up   )        200 of  -1 whilite+             endof
  304.         ( down )        208 of   1 whilite+             endof
  305.         ( end  )        207 of  towend                  endof
  306.                         $0D of  dohilite                endof
  307.                          bl of   1 whilite+             endof
  308.                          27 of  wescfunc perform        endof
  309.         ( F1 )          187 of  f1key    perform        endof
  310.                                 dowinkey
  311.                         endcase
  312.                 repeat  drop
  313.                 winhide
  314.                 restcursor ;
  315.  
  316. only forth also definitions     \ restore vocabulary search sequence
  317.  
  318. cr .( Type "322 LOAD" to load the demo code )
  319.  
  320. \S      ****************  Stop Here  ******************
  321.  
  322. \ ***** Now define the windows for our demonstation *****
  323.  
  324.  
  325.         40 03 window mywin3     \ define a new window of size 40x03
  326.         mywin3                  \ select the window just defined
  327.         28 05 winorg!           \ x y origin of current window
  328.         ltgray winfg!           \ forground  color of current window
  329.         blue   winbg!           \ background color of current window
  330.         wintitle" \6 My Window 3"
  331.         'H' winline" Hello There!"         beep
  332.         'T' winline" This is a test"       noop
  333.         'D' winline" do no window"         noop
  334.         winbottom" \6 ESC=Exit window "
  335.  
  336. mywin3 dowindow dowin3
  337.  
  338.         40 03 window mywin2     \ define a new window of size 40x03
  339.         mywin2                  \ select the window just defined
  340.         24 04 winorg!           \ x y origin of current window
  341.         ltgray winfg!           \ forground  color of current window
  342.         blue   winbg!           \ background color of current window
  343.          wintitle" \6 My Window 2 "
  344.         'H' winline" Hello There! 2"       beep
  345.         'T' winline" This is a test 2"     noop
  346.         'D' winline" dowindow3"            dowin3
  347.         winbottom" \6 ESC=Exit window "
  348.  
  349. mywin2 dowindow dowin2
  350.  
  351. variable mahalovar                      \ define the variable
  352.          mahalovar doeditvar mahalo     \ define a word to edit the variable
  353.  
  354. create mahalostring ," a test" 32 allot
  355.        mahalostring doedit$ mahalo$
  356.  
  357.        mahalostring ' drop dofunc$ mahalo$2
  358.  
  359.         40 06 window mywin      \ define a new window of size 40x03
  360.         mywin                   \ select the window just defined
  361.         20 03 winorg!           \ x y origin of current window
  362.         ltgray winfg!           \ forground  color of current window
  363.         blue   winbg!           \ background color of current window
  364.          wintitle" \6 My Window "
  365.          0  winline"  "                               noop
  366.         'H' winline"  Hello There!1  ▒#▒▒▒▒▒"          mahalo
  367.         'D' winline"  do window 2"                     dowin2
  368.         'T' winline"  This is        ▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒" mahalo$
  369.         'T' winline"  test2  ▒▒▒▒▒▒▒▒▒▒▒▒▒▒"           mahalo$2
  370.          0  winline"  "                               noop
  371.         winbottom" \6 ESC=Exit window "
  372.  
  373. mywin dowindow SDEMO            \ <<-- This is the demo entry word.
  374.  
  375. cr .( Type SDEMO to see a demonstration of the menu selection utility!)
  376.  
  377.  
  378.  
  379.  
  380.