2019-04-26 01:55:23 +00:00
|
|
|
( K E Y B O A R D )
|
|
|
|
|
57 const ^SPACE
|
|
|
|
|
75 const ^LEFT
|
|
|
|
|
77 const ^RIGHT
|
|
|
|
|
51 const ^<
|
|
|
|
|
52 const ^>
|
|
|
|
|
31 const ^S
|
|
|
|
|
59 const ^F1
|
|
|
|
|
|
|
|
|
|
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
|
|
|
|
|
|
|
|
|
|
: rungame
|
|
|
|
|
0 player.state DRIVING f!
|
|
|
|
|
1 showmouse !
|
|
|
|
|
[ MODE-MOVE @ lit ] dup MODE-MOVE ! ' tick redefine
|
|
|
|
|
' full-draw ' draw redefine
|
|
|
|
|
12 11 tile>world player entity.pos!
|
|
|
|
|
bgi-off 320x200 loadportraits
|
|
|
|
|
s" pete.jor" loadfile
|
|
|
|
|
begin suspend again ;
|
|
|
|
|
|
|
|
|
|
( S L I D E )
|
|
|
|
|
var skip
|
|
|
|
|
var autoslide
|
|
|
|
|
: pause
|
|
|
|
|
skip @ not if
|
|
|
|
|
begin
|
|
|
|
|
suspend 0
|
|
|
|
|
^< key-pressed if drop 1 1 skip ! -1 autoslide ! then
|
|
|
|
|
^> key-pressed if drop 1 1 skip ! 1 autoslide ! then
|
|
|
|
|
^S key-pressed if drop 1 1 skip ! then
|
|
|
|
|
^RIGHT key-pressed ^SPACE key-pressed or if drop 1 then
|
|
|
|
|
^F1 key-pressed if rungame then
|
|
|
|
|
until
|
|
|
|
|
then ;
|
|
|
|
|
|
|
|
|
|
defer write
|
|
|
|
|
: y pos swap drop ;
|
|
|
|
|
: nexty ( dy -- y ) y + ;
|
|
|
|
|
: writeline ( s x dy ) nexty <rot outtext moveto ;
|
|
|
|
|
|
|
|
|
|
: header :| 320 50 writeline |; ' write redefine
|
|
|
|
|
wipe BLUE bg! 1 5 font 1 justify WHITE color! 320 10 moveto ;
|
|
|
|
|
|
|
|
|
|
: bullet :| 30 30 writeline |; ' write redefine
|
|
|
|
|
3 3 font 0 justify LCYAN color! 30 y 30 + moveto ;
|
|
|
|
|
|
|
|
|
|
: goof :| 320 60 writeline |; ' write redefine
|
|
|
|
|
wipe 4 7 font 1 justify CYAN color! 320 100 moveto ;
|
|
|
|
|
|
|
|
|
|
( S L I D E S )
|
|
|
|
|
|
|
|
|
|
' noop
|
|
|
|
|
:noname 12 11 tile>world player entity.pos!
|
|
|
|
|
s" pete.jor" loadfile ;
|
2019-04-30 23:32:20 +00:00
|
|
|
:noname :| player yield done |; ' entities redefine
|
2019-04-26 01:55:23 +00:00
|
|
|
0 player.state DRIVING f!
|
|
|
|
|
1 showmouse ! MODE-MOVE @ ' tick redefine
|
|
|
|
|
12 11 tile>world player entity.pos!
|
|
|
|
|
loadportraits ;
|
|
|
|
|
:noname s" hide-footer" REPL send ;
|
|
|
|
|
:noname s" show-footer" REPL send ;
|
2019-04-30 23:32:20 +00:00
|
|
|
:noname :| player yield done |; ' entities redefine
|
2019-04-26 01:55:23 +00:00
|
|
|
1 player.state DRIVING f! E player entity.dir ! ;
|
2019-04-30 23:32:20 +00:00
|
|
|
:noname :| done |; ' entities redefine 0 showmouse ! ;
|
2019-04-26 01:55:23 +00:00
|
|
|
array demostates , , , , , , ,
|
|
|
|
|
var demostate
|
|
|
|
|
|
|
|
|
|
: enterdemostate
|
|
|
|
|
demostate @ cells demostates + @ execute ;
|
|
|
|
|
|
|
|
|
|
: tick-nextslide
|
|
|
|
|
^SPACE key-pressed if 1 demostate +! enterdemostate then ;
|
|
|
|
|
|
|
|
|
|
: demotick
|
|
|
|
|
tick-nextslide
|
|
|
|
|
0 ^LEFT key-down if 3 - then
|
|
|
|
|
^RIGHT key-down if 3 + then
|
|
|
|
|
0 ^UP key-down if 3 - then
|
|
|
|
|
^DOWN key-down if 3 + then
|
|
|
|
|
player entity.y +!
|
|
|
|
|
player entity.x +!
|
|
|
|
|
tick-mapedit
|
|
|
|
|
tick-debounce ;
|
|
|
|
|
|
|
|
|
|
: autoadvance autoslide @ not if 1 autoslide ! then ;
|
|
|
|
|
: demo ( endstate startstate -- )
|
|
|
|
|
bgi-off 320x200
|
|
|
|
|
' full-draw ' draw redefine
|
|
|
|
|
' demotick ' tick redefine
|
|
|
|
|
demostate ! enterdemostate
|
|
|
|
|
begin suspend dup demostate @ <= until drop
|
|
|
|
|
' noop ' draw redefine
|
|
|
|
|
' noop ' tick redefine
|
|
|
|
|
bgi-on autoadvance ;
|
|
|
|
|
|
|
|
|
|
var demorepldone
|
|
|
|
|
: quit 1 demorepldone ! ;
|
|
|
|
|
: start-demorepl activate ' putc task-emit !
|
|
|
|
|
s" .:: J O R T H ( jean forth) ::." type cr
|
|
|
|
|
begin receive loadstring s" ok" type cr again ;
|
|
|
|
|
task const DEMOREPL
|
|
|
|
|
array replbuf 256 allot
|
|
|
|
|
|
|
|
|
|
: demorepl
|
|
|
|
|
bgi-off key-end 0 demorepldone !
|
|
|
|
|
DEMOREPL start-demorepl suspend
|
|
|
|
|
begin replbuf gets DEMOREPL send suspend
|
|
|
|
|
demorepldone @ until
|
|
|
|
|
bgi-on key-start autoadvance ;
|
|
|
|
|
|
|
|
|
|
array filenamebuf 13 allot
|
|
|
|
|
var filenameindex
|
|
|
|
|
: store-fn-char filenamebuf filenameindex @ + b! ;
|
|
|
|
|
: filename-emit
|
|
|
|
|
dup [ key lit ] != if
|
|
|
|
|
store-fn-char
|
|
|
|
|
1 filenameindex +!
|
|
|
|
|
0 store-fn-char
|
|
|
|
|
else drop then ;
|
|
|
|
|
|
|
|
|
|
: slidefilename ( i -- s )
|
|
|
|
|
task-emit @
|
|
|
|
|
' filename-emit task-emit !
|
|
|
|
|
0 filenameindex !
|
|
|
|
|
s" slide" type
|
|
|
|
|
swap .
|
|
|
|
|
s" .jor" type
|
|
|
|
|
task-emit !
|
|
|
|
|
filenamebuf ;
|
|
|
|
|
|
|
|
|
|
var slidecount
|
|
|
|
|
var slideindex
|
|
|
|
|
|
|
|
|
|
: skipto ( i -- )
|
|
|
|
|
slideindex @ - autoslide ! 1 skip ! ;
|
|
|
|
|
|
|
|
|
|
: fixindex
|
|
|
|
|
slideindex @ 0 < if slidecount @ 1 - slideindex ! else
|
|
|
|
|
slideindex @ slidecount @ >= if 0 slideindex ! then then ;
|
|
|
|
|
|
|
|
|
|
: show ( i -- ) 0 skip ! 0 autoslide ! slidefilename loadjor ;
|
|
|
|
|
: nextslide
|
|
|
|
|
autoslide @ if
|
|
|
|
|
autoslide @ slideindex +!
|
|
|
|
|
else
|
|
|
|
|
begin
|
|
|
|
|
suspend
|
|
|
|
|
^LEFT key-pressed ^< key-pressed or
|
|
|
|
|
if -1 else
|
|
|
|
|
^RIGHT key-pressed ^SPACE key-pressed or ^> key-pressed or
|
|
|
|
|
if 1 else 0 then then
|
|
|
|
|
dup if dup slideindex +! then
|
|
|
|
|
until
|
|
|
|
|
then fixindex ;
|
|
|
|
|
|
|
|
|
|
: slideshow activate blah
|
|
|
|
|
bgi-on ' noop ' draw redefine ' noop ' tick redefine
|
|
|
|
|
begin slideindex @ show nextslide again ;
|
|
|
|
|
task const SLIDESHOW
|
|
|
|
|
SLIDESHOW slideshow
|
|
|
|
|
|
|
|
|
|
:noname
|
|
|
|
|
0 begin dup slidefilename exists while 1 + repeat slidecount !
|
|
|
|
|
:| tick-nextslide [ MODE-MOVE @ , ] |; MODE-MOVE !
|
|
|
|
|
; ' onload redefine
|
