2020-02-02 23:33:07 +00:00
|
|
|
( F O O T E R )
|
|
|
|
|
var footer-y
|
|
|
|
|
0 footer-y !
|
|
|
|
|
|
|
|
|
|
: draw-footer footer-y @ split-screen ;
|
|
|
|
|
|
|
|
|
|
0 const BLACK
|
|
|
|
|
1 const BLUE
|
|
|
|
|
2 const GREEN
|
|
|
|
|
3 const CYAN
|
|
|
|
|
4 const RED
|
|
|
|
|
5 const MAGENTA
|
|
|
|
|
6 const BROWN
|
|
|
|
|
7 const LGRAY
|
|
|
|
|
8 const DGRAY
|
|
|
|
|
9 const LBLUE
|
|
|
|
|
10 const LGREEN
|
|
|
|
|
11 const LCYAN
|
|
|
|
|
12 const PINK
|
|
|
|
|
13 const LMAGENTA
|
|
|
|
|
14 const YELLOW
|
|
|
|
|
15 const WHITE
|
|
|
|
|
|
|
|
|
|
var text-color
|
|
|
|
|
WHITE text-color !
|
|
|
|
|
: textxy ( s x y ) <rot text-color @ text ;
|
|
|
|
|
: portraity 1 swap textxy ;
|
|
|
|
|
: statusy 6 swap textxy ;
|
|
|
|
|
|
|
|
|
|
var textx
|
|
|
|
|
var texty
|
2020-02-02 23:30:22 +00:00
|
|
|
: textspeed DEV if 100 else 2 then ;
|
|
|
|
|
|
2020-02-02 23:33:07 +00:00
|
|
|
var textleft
|
|
|
|
|
: textleftsay 6 textleft ! ;
|
|
|
|
|
: textleftchoice 8 textleft ! ;
|
|
|
|
|
|
|
|
|
|
: nltext textleft @ textx ! 10 texty +! ;
|
|
|
|
|
: inctextx
|
|
|
|
|
textx @ 1 + dup 38 <= if textx !
|
|
|
|
|
else drop nltext inctextx then ;
|
|
|
|
|
|
|
|
|
|
key \ const '\'
|
|
|
|
|
: statusc
|
|
|
|
|
dup dup '\' = swap '\n' = or if drop nltext
|
|
|
|
|
else dup '\r' = if drop
|
|
|
|
|
else inctextx textx @ texty @ <rot text-color @ textc then then ;
|
|
|
|
|
|
|
|
|
|
var texttimer
|
|
|
|
|
: textnextc ( s -- s )
|
|
|
|
|
dup b@ dup if statusc 1 + else drop then ;
|
|
|
|
|
|
|
|
|
|
: slowtext ( s -- )
|
|
|
|
|
texttimer now!
|
|
|
|
|
begin dup b@ while
|
|
|
|
|
texttimer advance! textspeed * 0 for textnextc next
|
|
|
|
|
suspend repeat drop ;
|
|
|
|
|
|
|
|
|
|
: clear
|
|
|
|
|
text-color @
|
|
|
|
|
WHITE text-color !
|
|
|
|
|
s" " dup dup 10 statusy 20 statusy 30 statusy
|
|
|
|
|
text-color !
|
|
|
|
|
textleft @ textx !
|
|
|
|
|
10 texty ! ; userword
|
|
|
|
|
|
|
|
|
|
: show-footer 48 10 footer-y move-to ;
|
|
|
|
|
: hide-footer 0 10 footer-y move-to ;
|
|
|
|
|
|
2020-03-28 20:58:47 +00:00
|
|
|
: do-footer-wait show-footer ^ENTER wait-key ;
|
|
|
|
|
defer footer-wait
|
|
|
|
|
: dont-footer-wait ' do-footer-wait ' footer-wait redefine ;
|
|
|
|
|
dont-footer-wait
|
2020-02-02 23:33:07 +00:00
|
|
|
|
2020-03-28 20:58:47 +00:00
|
|
|
: runon ' dont-footer-wait ' footer-wait redefine ; userword
|
2020-02-02 23:33:07 +00:00
|
|
|
: say ( s -- ) textleftsay clear show-footer slowtext footer-wait ; userword
|
|
|
|
|
: say" [ ' s" , ] ' say expile ; immediate
|
|
|
|
|
|
|
|
|
|
defer choosegen
|
|
|
|
|
var ichoose
|
|
|
|
|
var cchoose
|
|
|
|
|
: countchoosegen ( -- )
|
|
|
|
|
0 choosegen each drop drop 1 + more cchoose ! ;
|
|
|
|
|
|
|
|
|
|
: getchoice ( -- s cp )
|
|
|
|
|
0 choosegen
|
|
|
|
|
each <rot dup ichoose @ < if 1 + >rot drop drop else drop break then more ;
|
|
|
|
|
|
|
|
|
|
: canchooseleft ichoose @ 0 > ;
|
|
|
|
|
: canchooseright ichoose @ cchoose @ 1 - < ;
|
|
|
|
|
|
|
|
|
|
: displaychoice
|
|
|
|
|
clear
|
|
|
|
|
canchooseleft if s" <" 6 20 textxy then
|
|
|
|
|
canchooseright if s" >" 38 20 textxy then
|
|
|
|
|
getchoice drop slowtext ;
|
|
|
|
|
|
|
|
|
|
: navchoice ( -- done )
|
|
|
|
|
0 begin suspend
|
|
|
|
|
^LEFT key-pressed canchooseleft and if drop 1 -1 ichoose +! then
|
|
|
|
|
^RIGHT key-pressed canchooseright and if drop 1 1 ichoose +! then
|
|
|
|
|
^ENTER key-pressed if drop 2 then
|
|
|
|
|
dup until 1 - ;
|
|
|
|
|
|
|
|
|
|
: choose ( gen -- )
|
|
|
|
|
' choosegen redefine countchoosegen 0 ichoose !
|
|
|
|
|
textleftchoice clear show-footer
|
|
|
|
|
begin displaychoice navchoice until
|
|
|
|
|
getchoice swap drop execute ;
|
|
|
|
|
|
|
|
|
|
: character ( iportrait color ) create , ,
|
|
|
|
|
does> dup @ text-color ! cell + @ draw-portrait ;
|
|
|
|
|
|
2020-02-02 23:29:49 +00:00
|
|
|
0 LGREEN character neut userword
|
2020-02-18 01:43:14 +00:00
|
|
|
1 YELLOW character rexx userword
|
2020-02-02 23:29:49 +00:00
|
|
|
3 LBLUE character jaye userword
|
2020-02-17 02:36:02 +00:00
|
|
|
5 CYAN character gord userword
|
2020-03-28 20:58:47 +00:00
|
|
|
6 LMAGENTA character pady userword
|
2020-03-31 02:27:37 +00:00
|
|
|
4 LGREEN character term userword
|
|
|
|
|
8 RED character libb userword
|
2020-04-10 15:27:25 +00:00
|
|
|
9 BLUE character disk userword
|
2020-02-02 23:33:07 +00:00
|
|
|
|
|
|
|
|
: noone WHITE text-color ! s" " dup dup dup
|
|
|
|
|
8 portraity 16 portraity 24 portraity 32 portraity ; userword
|
