pete286/slide.jor

182 lines
4.4 KiB
Plaintext
Executable file

( 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 ;
:noname :| player yield done |; ' party redefine
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 ;
:noname :| player yield done |; ' party redefine
1 player.state DRIVING f! E player entity.dir ! ;
:noname :| done |; dup ' party redefine ' entities redefine 0 showmouse ! ;
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