Power-Programmierung

home *** CD-ROM | disk | FTP | other *** search

/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / select.seq < prev next >

Wrap

Text File | 1991-03-30 | 15.1 KB | 380 lines

\ SELECT.SEQ Menu selection utility by Tom Zimmer only forth also definitions hidden also anew selector 16 array #buf : %#input ( x y d1 bgclr fgclr -- d1 f1 ) \ f1 = true for success ' noop save!> >edattrib savecursor cursor-on >fg >bg 2over 2>r #buf 10 blank <# #s #> #buf place on> autoclear #buf 6 lineeditor >r $2020 #buf count + ! #buf count upper #buf %number r> and 2r> at #buf count 5 min 5 over - spaces type space restcursor restore> >edattrib ; : #input ( x y d1 -- d1 f1 ) \ f1 = true for success ltgray black %#input ; : ?upc ( c1 -- c2 ) \ uppercase if not function key dup 128 < if upc then ; 0 value curwin \ current window 0 value winline# \ current window line being compiled 0 value wbgstuff? \ is window bgstuff active? : winitem ( n1 | name -- ) \ window subfield defining word create over c, + does> c@ curwin + ; 0 1 winitem worgx \ window x origin 1 winitem worgy \ window y origin 1 winitem wrows \ window rows 1 winitem wcols \ window columns 1 winitem wx \ current window x position 1 winitem wy \ current window y position 1 winitem wbase \ window base 1 winitem wexit \ non zero flag if we want to leave window 1 winitem wbg \ window background color 1 winitem wfg \ window forground color 1 winitem wexitkey \ window exit key (defaults to ESC) 2 winitem wexitfunc \ window exit function (defaults to NOOP) 2 winitem wescfunc \ window ESC key function IF NOT EXIT! 2 winitem wshow \ window additional display information 2 winitem wintitle \ window title line 2 winitem winbottom \ bottom of window message 2 winitem wptr \ window save pointer 2 winitem wokey \ function to do when other keys are pressed 2 winitem f1key \ function to do when F1 pressed 2 winitem wbgstuff \ window background operation 1 winitem wshown \ has window been shown? 1 winitem whilite \ hilited line number 0 winitem winlines \ start of text for window ** MUST BE LAST ITEM ** value winrsize : window ( c r | name -- ) \ define window c=columns r=rows create here !> curwin \ set as current window winrsize allot curwin winrsize erase 1 max wrows c! \ default window size 1 max wcols c! $0A wbase c! \ default base DECIMAL ltgray wfg c! \ default colors black wbg c! 27 wexitkey c! \ default exit is ESC ['] noop wexitfunc ! \ default exit func NOOP ['] noop wescfunc ! \ default ESC func NOOP ['] noop wshow ! \ default extra show info ['] drop wokey ! \ default for other keys ['] noop f1key ! \ default F1 help ['] noop wbgstuff ! \ default background ops here wrows c@ 2* dup allot erase off> winline# \ reset current line cnt does> !> curwin ; : dowbgstuff ( -- f ) defers bgstuff wbgstuff? if wbgstuff perform then ; ' dowbgstuff is bgstuff : dohilite ( -- ) \ perform function for hilited line curwin >r whilite c@ 2* winlines + @ 1+ count + @ execute r> !> curwin ; : winexit ( -- ) 1 wexit c! ; : winline" ( c1 | txt" func -- ) \ install text as line of window winline# dup wrows c@ >= abort" TOO MANY lines for this window!" here swap 2* winlines + ! \ install pointer to text c, \ activation key ," ' , \ compile in text to here incr> winline# ; \ bump to next line : wintitle" ( | txt" -- ) \ title of window here wintitle ! ," ; : winbottom" ( | txt" -- ) \ bottom line message here winbottom ! ," ; : winorg! ( x y -- ) \ set origin of current window dup worgy c! 1+ wy c! dup worgx c! 1+ wx c! ; : winbg! ( n1 -- ) \ set window background color wbg c! ; : winfg! ( n1 -- ) \ set window forground color wfg c! ; : winat ( x y -- ) \ move to relative pos in window -1 max worgy c@ 1+ + wy c! 0max worgx c@ 1+ + wx c! wx c@ wy c@ 2dup at !> bline 1- !> tx ; : wincr ( -- ) \ move to beginning of next win line worgx c@ 1+ dup wx c! wy c@ 1+ dup wy c! at ; : .wintitle ( -- ) wintitle @ 0= ?exit ?cs: wintitle @ count wcols c@ over - 0max 2/ worgx c@ + 1+ worgy c@ at \typeL ; : .winbottom ( -- ) winbottom @ 0= ?exit worgx c@ 2+ worgy c@ wrows c@ + 1+ at ?cs: winbottom @ count \typeL ; : .info ( -- ) worgx c@ wcols c@ + 1+ worgy c@ 2dup at ." \6" 2dup swap 6 - swap at ." Home " wrows c@ + 1+ 2dup at ." \6" swap 5 - swap at ." End " ; : winshow ( -- ) savescr wbg c@ >bg wfg c@ >fg worgx c@ worgy c@ 2dup wcols c@ 1+ wrows c@ 1+ d+ box&fill .wintitle .winbottom .info 1 wshown c! ; : whilite+ ( n1 -- ) \ increment hilited by signed n1 begin whilite c@ over + wrows c@ mod whilite c! winlines whilite c@ 2* + @ c@ until drop ; : towhome ( -- ) 0 whilite c! winlines @ c@ 0= if 1 whilite+ then ; : towend ( -- ) wrows c@ 1- whilite c! winlines wrows c@ 1- 2* + @ c@ 0= if -1 whilite+ then ; : %wintype ( a1 n1 n2 -- ) \ display special for line n2 save> attrib cyan >bg black >fg space >r over 1+ c@ '#' = \ number edit? if winlines r@ 2* + @ 1+ count + @ wbase c@ save!> base >body @ @ 5 u.r 2 spaces restore> base 8 /string else tuck '▒' skip 2dup 2>r nip - >r winlines 3 rpick 2* + @ 1+ count + @ >body @ count r> 2dup swap - 0max >r min type r> spaces 2r> then r>drop restore> attrib type ; : wintype ( a1 n1 n2 -- ) \ display window text for line n2 >r \ save line 2dup '▒' scan 2dup 2>r nip - type \ show leading text 2r> dup if r@ %wintype else 2drop then r>drop ; : windshow ( -- ) winlines whilite c@ 2* + @ c@ 0= if 1 whilite+ then 0 0 winat wbg c@ >bg wfg c@ >fg attrib @ winlines wrows c@ 0 ?do over attrib ! space whilite c@ i = if attrib c@ $10 /mod swap $10 * + attrib c! then 2 spaces dup i 2* + @ 1+ count i over >r wintype wcols c@ r> - 5 - 0max spaces bcr loop 2drop wshow perform ; : winhide ( -- ) wshown c@ 0= ?exit restscr 0 wshown c! ; : dowinkey ( c1 -- ) \ check & perform c1 function ?upc winlines \ for window mechanism to handle key wrows c@ 0 ?do 2dup i 2* + @ c@ ?upc = if i whilite c! windshow 50 ms dohilite swap 0= swap \ change key to NULL leave then loop drop wokey perform ; \ do other key operation \ wokey is passed a NULL if key was \ processed by window mechanism : doeditvar ( a1 | name -- ) create , does> save> base wbase c@ base ! @ dup @ >r \ s=a1 r=n1 winlines whilite c@ 2* + @ 1+ count \ s=a1, n1 tuck '▒' scan nip - \ s=offset wx c@ 4 + + wy c@ whilite c@ + \ s=x, y r> 0 cyan black ( fldcolor ) %#input if drop swap ! else 2drop drop then restore> base ; : doedit$ ( a1 | name -- ) create , does> ' noop save!> >edattrib savecursor cursor-on cyan >bg black >fg ( fldcolor ) @ >r \ r=a1 winlines whilite c@ 2* + @ 1+ count \ s=a1, n1 tuck '▒' scan 2dup 2>r nip - \ s=offset wx c@ 4 + + wy c@ whilite c@ + \ s=x, y 2r> tuck '▒' skip nip - \ s=x, y, length r> swap lineeditor drop restcursor restore> >edattrib ; : dofunc$ ( a1 a2 | name -- ) \ a1=string, a2=function create swap , , does> length swap perform ; cyan value grayfg blue value graybg : graywind ( -- ) \ gray prev window ?vmode 7 = ?exit savecursor wfg c@ wbg c@ grayfg wfg c! graybg wbg c! windshow wbg c! wfg c! restcursor ; : dowindow ( a1 | name -- ) create curwin , does> @ !> curwin savecursor 0 wexit c! winshow begin windshow wexit c@ 0= if key dup ?upc wexitkey c@ = if 1 wexit c! \ mark exit wexitfunc perform then else 0 then wexit c@ 0= while case ( home ) 199 of towhome endof ( up ) 200 of -1 whilite+ endof ( down ) 208 of 1 whilite+ endof ( end ) 207 of towend endof $0D of dohilite endof bl of 1 whilite+ endof 27 of wescfunc perform endof ( F1 ) 187 of f1key perform endof dowinkey endcase repeat drop winhide restcursor ; only forth also definitions \ restore vocabulary search sequence cr .( Type "322 LOAD" to load the demo code ) \S **************** Stop Here ****************** \ ***** Now define the windows for our demonstation ***** 40 03 window mywin3 \ define a new window of size 40x03 mywin3 \ select the window just defined 28 05 winorg! \ x y origin of current window ltgray winfg! \ forground color of current window blue winbg! \ background color of current window wintitle" \6 My Window 3" 'H' winline" Hello There!" beep 'T' winline" This is a test" noop 'D' winline" do no window" noop winbottom" \6 ESC=Exit window " mywin3 dowindow dowin3 40 03 window mywin2 \ define a new window of size 40x03 mywin2 \ select the window just defined 24 04 winorg! \ x y origin of current window ltgray winfg! \ forground color of current window blue winbg! \ background color of current window wintitle" \6 My Window 2 " 'H' winline" Hello There! 2" beep 'T' winline" This is a test 2" noop 'D' winline" dowindow3" dowin3 winbottom" \6 ESC=Exit window " mywin2 dowindow dowin2 variable mahalovar \ define the variable mahalovar doeditvar mahalo \ define a word to edit the variable create mahalostring ," a test" 32 allot mahalostring doedit$ mahalo$ mahalostring ' drop dofunc$ mahalo$2 40 06 window mywin \ define a new window of size 40x03 mywin \ select the window just defined 20 03 winorg! \ x y origin of current window ltgray winfg! \ forground color of current window blue winbg! \ background color of current window wintitle" \6 My Window " 0 winline" " noop 'H' winline" Hello There!1 ▒#▒▒▒▒▒" mahalo 'D' winline" do window 2" dowin2 'T' winline" This is ▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒" mahalo$ 'T' winline" test2 ▒▒▒▒▒▒▒▒▒▒▒▒▒▒" mahalo$2 0 winline" " noop winbottom" \6 ESC=Exit window " mywin dowindow SDEMO \ <<-- This is the demo entry word. cr .( Type SDEMO to see a demonstration of the menu selection utility!)