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
|
15KB
|
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!)