Split game.jor into multiple .jor files, add ability to specify code to run post-load for side effects
This commit is contained in:
parent
ad0f3fbf6c
commit
a5ec79c88a
37
boot.jor
37
boot.jor
|
@ -49,17 +49,44 @@ key " const '"'
|
||||||
: load-input swap-input r> r> interpreter r< r< swap-input ;
|
: load-input swap-input r> r> interpreter r< r< swap-input ;
|
||||||
: loadstring ' key-string load-input drop drop ;
|
: loadstring ' key-string load-input drop drop ;
|
||||||
|
|
||||||
: loadimage-if-uptodate ( filename -- b )
|
( image loading )
|
||||||
dup image-uptodate if imagefilename open loadimage close else drop 0 then ;
|
: noop ;
|
||||||
|
|
||||||
: loadjor ( filename -- )
|
: defer word new-word $DODEFERRED , ' noop , ;
|
||||||
|
: redefine ( cp cpdeferred ) cell + ! ;
|
||||||
|
: definition ( cpdeferred ) cell + @ ;
|
||||||
|
|
||||||
|
defer onload
|
||||||
|
: postload onload ' noop ' onload redefine ;
|
||||||
|
|
||||||
|
: loadimage ( -- [0 | onload] )
|
||||||
|
fget fget fget fget fget ( onload tasks latest size start )
|
||||||
|
here != if tell + seek drop drop drop 0 else
|
||||||
|
dup here fread here + here! latest! tasks! then ;
|
||||||
|
|
||||||
|
: saveimage ( herestart -- )
|
||||||
|
' onload definition here drop fput
|
||||||
|
tasks fput
|
||||||
|
latest fput
|
||||||
|
dup here swap - fput
|
||||||
|
dup fput
|
||||||
|
dup here swap - swap fwrite ;
|
||||||
|
|
||||||
|
( file loading )
|
||||||
|
: loadimage-if-uptodate ( filename -- b )
|
||||||
|
dup image-uptodate if imagefilename open loadimage close else drop 0 then
|
||||||
|
dup if execute 1 then ;
|
||||||
|
|
||||||
|
: interpretjor ( filename -- )
|
||||||
open fdeactivate ' key-file load-input drop factivate close ;
|
open fdeactivate ' key-file load-input drop factivate close ;
|
||||||
|
|
||||||
|
: loadjor fdeactivate swap interpretjor postload factivate ;
|
||||||
|
|
||||||
: loadfile ( filename -- )
|
: loadfile ( filename -- )
|
||||||
( active file is preserved for the currently-loading file, but the
|
( active file is preserved for the currently-loading file, but the
|
||||||
new file is always loaded with no active files )
|
new file is always loaded with no active files )
|
||||||
fdeactivate swap
|
fdeactivate swap
|
||||||
dup loadimage-if-uptodate not if
|
dup loadimage-if-uptodate not if
|
||||||
dup here swap loadjor
|
dup here swap interpretjor
|
||||||
swap imagefilename overwrite saveimage close
|
swap imagefilename overwrite saveimage close postload
|
||||||
else drop then factivate ;
|
else drop then factivate ;
|
||||||
|
|
26
defs.jor
26
defs.jor
|
@ -9,8 +9,6 @@
|
||||||
: 2= ( a b c d -- a=c&b=d )
|
: 2= ( a b c d -- a=c&b=d )
|
||||||
r> <rot = swap r< = and ;
|
r> <rot = swap r< = and ;
|
||||||
|
|
||||||
: noop ;
|
|
||||||
|
|
||||||
: ~ -1 ^ ;
|
: ~ -1 ^ ;
|
||||||
: f! ( b v flag -- )
|
: f! ( b v flag -- )
|
||||||
r> dup @ ( b v val r: flag )
|
r> dup @ ( b v val r: flag )
|
||||||
|
@ -26,9 +24,6 @@
|
||||||
: :| inline| $DOCOLON , ; immediate
|
: :| inline| $DOCOLON , ; immediate
|
||||||
: |; ' ret , |inline ; immediate
|
: |; ' ret , |inline ; immediate
|
||||||
|
|
||||||
: defer word new-word $DODEFERRED , ' noop , ;
|
|
||||||
: redefine ( cp cpdeferred ) cell + ! ;
|
|
||||||
|
|
||||||
: array word new-word $DOVAR , ;
|
: array word new-word $DOVAR , ;
|
||||||
: create word new-word $DOCREATE , 0 , ;
|
: create word new-word $DOCREATE , 0 , ;
|
||||||
|
|
||||||
|
@ -56,6 +51,8 @@
|
||||||
: dobreak yield 0 ;
|
: dobreak yield 0 ;
|
||||||
: break ' rdrop , ' dobreak , ; immediate
|
: break ' rdrop , ' dobreak , ; immediate
|
||||||
|
|
||||||
|
: links begin yield @ dup not until ;
|
||||||
|
|
||||||
: min ( x y -- x|y ) 2dup > if swap then drop ;
|
: min ( x y -- x|y ) 2dup > if swap then drop ;
|
||||||
: max ( x y -- x|y ) 2dup < if swap then drop ;
|
: max ( x y -- x|y ) 2dup < if swap then drop ;
|
||||||
|
|
||||||
|
@ -76,6 +73,18 @@
|
||||||
: task-stack task-user-size 3 + cells + ;
|
: task-stack task-user-size 3 + cells + ;
|
||||||
: task-rstack task-stack stacksize cells + ;
|
: task-rstack task-stack stacksize cells + ;
|
||||||
|
|
||||||
|
: .wordin ( ptr -- )
|
||||||
|
latest links each
|
||||||
|
2dup > if wordname type drop 0 break then
|
||||||
|
more dup if . else drop then ;
|
||||||
|
|
||||||
|
: tasks.s
|
||||||
|
tasks links each
|
||||||
|
dup .wordin s" : " type
|
||||||
|
dup task-sp @ over task-stack ( task stackLim stack )
|
||||||
|
begin 2dup > while dup @ . cell + repeat
|
||||||
|
cr drop drop more ;
|
||||||
|
|
||||||
: doactivate ( task ip -- )
|
: doactivate ( task ip -- )
|
||||||
over task-ip !
|
over task-ip !
|
||||||
dup task-stack over task-sp !
|
dup task-stack over task-sp !
|
||||||
|
@ -89,11 +98,16 @@
|
||||||
' ret ,
|
' ret ,
|
||||||
; immediate
|
; immediate
|
||||||
|
|
||||||
: send ( val task -- )
|
: try-send ( val task -- b )
|
||||||
|
mailbox dup @ if drop drop 0 else ! 1 then ;
|
||||||
|
|
||||||
|
: wait-send ( val task -- )
|
||||||
mailbox
|
mailbox
|
||||||
begin dup @ while suspend repeat ( wait for empty mailbox )
|
begin dup @ while suspend repeat ( wait for empty mailbox )
|
||||||
! ;
|
! ;
|
||||||
|
|
||||||
|
: send ( val task -- ) try-send drop ;
|
||||||
|
|
||||||
: receive ( -- val )
|
: receive ( -- val )
|
||||||
running mailbox
|
running mailbox
|
||||||
begin dup @ not while suspend repeat ( wait for mail )
|
begin dup @ not while suspend repeat ( wait for mail )
|
||||||
|
|
BIN
entity.jim
Executable file
BIN
entity.jim
Executable file
Binary file not shown.
50
entity.jor
Executable file
50
entity.jor
Executable file
|
@ -0,0 +1,50 @@
|
||||||
|
0 const EVTICK
|
||||||
|
1 const EVTOUCH
|
||||||
|
|
||||||
|
: defentity ( x y dir anim -- ) array ' drop , , , 4 << , 4 << , ;
|
||||||
|
: entity.x 4 cells + ;
|
||||||
|
: entity.y 3 cells + ;
|
||||||
|
: entity.dir 2 cells + ;
|
||||||
|
: entity>sprite cell + @ execute ;
|
||||||
|
: entity>do ( entity event ) swap @ execute ;
|
||||||
|
|
||||||
|
var entity-defstate
|
||||||
|
: entitydo-ev ( [cp ifhere] ev -- )
|
||||||
|
entity-defstate @ if swap [ ' then , ]
|
||||||
|
else 1 entity-defstate ! :noname swap then
|
||||||
|
' dup , lit ' = , [ ' if , ] ;
|
||||||
|
: :touch EVTOUCH entitydo-ev ; immediate
|
||||||
|
: :tick EVTICK entitydo-ev ; immediate
|
||||||
|
: ;entity ( entity cp ifhere -- )
|
||||||
|
[ ' then , ] ' drop , [ ' ; , ]
|
||||||
|
0 entity-defstate ! swap ! ; immediate
|
||||||
|
|
||||||
|
0 const W
|
||||||
|
1 const E
|
||||||
|
2 const N
|
||||||
|
3 const S
|
||||||
|
|
||||||
|
: dir>pos ( dir -- dx dy )
|
||||||
|
dup W = if drop -1 0 ret then
|
||||||
|
dup E = if drop 1 0 ret then
|
||||||
|
N = if 0 -1
|
||||||
|
else 0 1 then ;
|
||||||
|
|
||||||
|
: frame ( s n e w ) b, b, b, b, ;
|
||||||
|
array frames
|
||||||
|
( 0: car ) 3 1 0 2 frame
|
||||||
|
( 1: pete stand ) 11 9 7 5 frame
|
||||||
|
( 2: pete walk ) 12 10 8 6 frame
|
||||||
|
|
||||||
|
: sprindex ( dir frame ) 2 << frames + + b@ ;
|
||||||
|
: defstatic ( frame -- ) create b, does> b@ sprindex ;
|
||||||
|
: defanim ( frame... framecount ticks-per-frame -- )
|
||||||
|
create b, dup b, 0 for b, next
|
||||||
|
does> ( dir a -- )
|
||||||
|
dup dup 1 + b@ swap b@ ( dir a count tpf )
|
||||||
|
ticks swap / swap % ( dir a index )
|
||||||
|
2 + + b@ sprindex ;
|
||||||
|
|
||||||
|
0 defstatic {car}
|
||||||
|
1 defstatic {pete-stand}
|
||||||
|
1 2 2 5 defanim {pete-walk}
|
BIN
footer.jim
Executable file
BIN
footer.jim
Executable file
Binary file not shown.
79
footer.jor
Executable file
79
footer.jor
Executable file
|
@ -0,0 +1,79 @@
|
||||||
|
( 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 !
|
||||||
|
|
||||||
|
: statusy 7 swap <rot text-color @ text ;
|
||||||
|
: status0 10 statusy ;
|
||||||
|
: status1 20 statusy ;
|
||||||
|
: status2 30 statusy ;
|
||||||
|
|
||||||
|
var textx
|
||||||
|
var texty
|
||||||
|
2 const textspeed
|
||||||
|
|
||||||
|
: nltext 7 textx ! 10 texty +! ;
|
||||||
|
: inctextx
|
||||||
|
textx @ 1 + dup 38 <= if textx !
|
||||||
|
else drop nltext then ;
|
||||||
|
|
||||||
|
key \ const '\'
|
||||||
|
: statusc
|
||||||
|
dup dup '\' = swap '\n' = or if drop nltext
|
||||||
|
else dup '\r' = if drop
|
||||||
|
else textx @ texty @ <rot text-color @ textc inctextx 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 status0 status1 status2
|
||||||
|
text-color !
|
||||||
|
7 textx !
|
||||||
|
10 texty ! ;
|
||||||
|
|
||||||
|
: show-footer 48 10 footer-y move-to ;
|
||||||
|
: hide-footer 0 10 footer-y move-to ;
|
||||||
|
|
||||||
|
: footer-wait show-footer ^ENTER wait-key ;
|
||||||
|
|
||||||
|
: say ( s -- ) clear show-footer slowtext footer-wait ;
|
||||||
|
: say" [ ' s" , ] ' say expile ; immediate
|
||||||
|
|
||||||
|
: character ( iportrait color ) create , ,
|
||||||
|
does> dup @ text-color ! cell + @ draw-portrait ;
|
||||||
|
|
||||||
|
0 GREEN character pete
|
||||||
|
1 MAGENTA character mary
|
||||||
|
2 BROWN character chuck
|
||||||
|
|
298
game.jor
298
game.jor
|
@ -7,275 +7,16 @@ blah
|
||||||
task const REPL
|
task const REPL
|
||||||
REPL start-repl
|
REPL start-repl
|
||||||
|
|
||||||
1 const ^ESC
|
|
||||||
28 const ^ENTER
|
|
||||||
29 const ^CTRL
|
|
||||||
51 const ^<
|
|
||||||
52 const ^>
|
|
||||||
56 const ^ALT
|
|
||||||
57 const ^SPACE
|
|
||||||
72 const ^UP
|
|
||||||
75 const ^LEFT
|
|
||||||
77 const ^RIGHT
|
|
||||||
80 const ^DOWN
|
|
||||||
|
|
||||||
: wait-key ( k -- ) begin dup key-pressed not while suspend repeat drop ;
|
|
||||||
: udelta ( u u -- u )
|
|
||||||
2dup u> if
|
|
||||||
swap -1 swap - + 1 +
|
|
||||||
else
|
|
||||||
swap -
|
|
||||||
then ;
|
|
||||||
: sleep ( count -- )
|
|
||||||
ticks swap begin over ticks udelta over u< while suspend repeat drop drop ;
|
|
||||||
|
|
||||||
defer tick
|
defer tick
|
||||||
defer draw
|
defer draw
|
||||||
|
|
||||||
0 const EVTICK
|
:noname
|
||||||
1 const EVTOUCH
|
s" input.jor" loadfile
|
||||||
|
s" entity.jor" loadfile
|
||||||
: defentity ( x y dir anim -- ) array ' drop , , , 4 << , 4 << , ;
|
s" timer.jor" loadfile
|
||||||
: entity.x 4 cells + ;
|
s" footer.jor" loadfile
|
||||||
: entity.y 3 cells + ;
|
s" map.jor" loadfile
|
||||||
: entity.dir 2 cells + ;
|
; execute
|
||||||
: entity>sprite cell + @ execute ;
|
|
||||||
: entity>do ( entity event ) swap @ execute ;
|
|
||||||
|
|
||||||
var entity-defstate
|
|
||||||
: entitydo-ev ( [cp ifhere] ev -- )
|
|
||||||
entity-defstate @ if swap [ ' then , ]
|
|
||||||
else 1 entity-defstate ! :noname swap then
|
|
||||||
' dup , lit ' = , [ ' if , ] ;
|
|
||||||
: :touch EVTOUCH entitydo-ev ; immediate
|
|
||||||
: :tick EVTICK entitydo-ev ; immediate
|
|
||||||
: ;entity ( entity cp ifhere -- )
|
|
||||||
[ ' then , ] ' drop , [ ' ; , ]
|
|
||||||
0 entity-defstate ! swap ! ; immediate
|
|
||||||
|
|
||||||
0 const W
|
|
||||||
1 const E
|
|
||||||
2 const N
|
|
||||||
3 const S
|
|
||||||
|
|
||||||
: dir>pos ( dir -- dx dy )
|
|
||||||
dup W = if drop -1 0 ret then
|
|
||||||
dup E = if drop 1 0 ret then
|
|
||||||
N = if 0 -1
|
|
||||||
else 0 1 then ;
|
|
||||||
|
|
||||||
: frame ( s n e w ) b, b, b, b, ;
|
|
||||||
array frames
|
|
||||||
( 0: car ) 3 1 0 2 frame
|
|
||||||
( 1: pete stand ) 11 9 7 5 frame
|
|
||||||
( 2: pete walk ) 12 10 8 6 frame
|
|
||||||
|
|
||||||
: sprindex ( dir frame ) 2 << frames + + b@ ;
|
|
||||||
: defstatic ( frame -- ) create b, does> b@ sprindex ;
|
|
||||||
: defanim ( frame... framecount ticks-per-frame -- )
|
|
||||||
create b, dup b, 0 for b, next
|
|
||||||
does> ( dir a -- )
|
|
||||||
dup dup 1 + b@ swap b@ ( dir a count tpf )
|
|
||||||
ticks swap / swap % ( dir a index )
|
|
||||||
2 + + b@ sprindex ;
|
|
||||||
|
|
||||||
0 defstatic {car}
|
|
||||||
1 defstatic {pete-stand}
|
|
||||||
1 2 2 5 defanim {pete-walk}
|
|
||||||
|
|
||||||
( timer + lerping )
|
|
||||||
: clamp0 ( range val -- i )
|
|
||||||
2dup <= if drop else
|
|
||||||
dup 0 <= if drop drop 0 else
|
|
||||||
swap drop then then ;
|
|
||||||
: >ratio ( range value -- f )
|
|
||||||
over swap clamp0 swap />ratio ;
|
|
||||||
: <ratio ( range ratio -- v ) *<ratio ;
|
|
||||||
: >range ( start end -- start range ) over - ;
|
|
||||||
: <range ( start range -- start end ) over + ;
|
|
||||||
: lerpr ( start end ratio ) r> >range r< <ratio + ;
|
|
||||||
: lerpn ( start1 end1 start2 end2 val )
|
|
||||||
r> >range r< <rot - >ratio lerpr ;
|
|
||||||
: lerp ( start end duration start -- i )
|
|
||||||
ticks udelta ( start end duration delta )
|
|
||||||
>ratio lerpr ;
|
|
||||||
|
|
||||||
: triggered ( duration timer -- b )
|
|
||||||
dup r> @ ticks udelta ( duration delta )
|
|
||||||
2dup <= if drop r< +! 1 else drop drop rdrop 0 then ;
|
|
||||||
|
|
||||||
: now! ( timer -- ) ticks swap ! ;
|
|
||||||
: advance! ( timer -- delta )
|
|
||||||
dup @ ticks udelta ( timer delta )
|
|
||||||
dup <rot +! ;
|
|
||||||
|
|
||||||
( 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 !
|
|
||||||
|
|
||||||
: statusy 7 swap <rot text-color @ text ;
|
|
||||||
: status0 10 statusy ;
|
|
||||||
: status1 20 statusy ;
|
|
||||||
: status2 30 statusy ;
|
|
||||||
|
|
||||||
var textx
|
|
||||||
var texty
|
|
||||||
2 const textspeed
|
|
||||||
|
|
||||||
: nltext 7 textx ! 10 texty +! ;
|
|
||||||
: inctextx
|
|
||||||
textx @ 1 + dup 38 <= if textx !
|
|
||||||
else drop nltext then ;
|
|
||||||
|
|
||||||
key \ const '\'
|
|
||||||
: statusc
|
|
||||||
dup dup '\' = swap '\n' = or if drop nltext
|
|
||||||
else dup '\r' = if drop
|
|
||||||
else textx @ texty @ <rot text-color @ textc inctextx 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 status0 status1 status2
|
|
||||||
text-color !
|
|
||||||
7 textx !
|
|
||||||
10 texty ! ;
|
|
||||||
|
|
||||||
: move-to ( target speed p -- )
|
|
||||||
dup r> @ >rot ticks ( from to duration start )
|
|
||||||
begin
|
|
||||||
4dup lerp r@ !
|
|
||||||
<rot dup r@ @ != ( from duration start to !done )
|
|
||||||
while
|
|
||||||
>rot suspend
|
|
||||||
repeat rdrop drop drop drop drop ;
|
|
||||||
|
|
||||||
: show-footer 48 10 footer-y move-to ;
|
|
||||||
: hide-footer 0 10 footer-y move-to ;
|
|
||||||
|
|
||||||
: footer-wait show-footer ^ENTER wait-key ;
|
|
||||||
|
|
||||||
: say ( s -- ) clear show-footer slowtext footer-wait ;
|
|
||||||
: say" [ ' s" , ] ' say expile ; immediate
|
|
||||||
|
|
||||||
: character ( iportrait color ) create , ,
|
|
||||||
does> dup @ text-color ! cell + @ draw-portrait ;
|
|
||||||
|
|
||||||
0 GREEN character pete
|
|
||||||
1 MAGENTA character mary
|
|
||||||
2 BROWN character chuck
|
|
||||||
|
|
||||||
( M O U S E )
|
|
||||||
|
|
||||||
var prevbutton
|
|
||||||
: tick-debounce
|
|
||||||
mousebuttons prevbutton ! ;
|
|
||||||
|
|
||||||
1 const MOUSEL
|
|
||||||
2 const MOUSER
|
|
||||||
: mousedown ( button -- bool ) mousebuttons & ;
|
|
||||||
: clicked ( button -- bool )
|
|
||||||
dup mousedown not swap
|
|
||||||
prevbutton @ & and ;
|
|
||||||
|
|
||||||
( M A P )
|
|
||||||
: +pos ( x1 y1 x2 y2 -- x y )
|
|
||||||
<rot + >rot + swap ;
|
|
||||||
|
|
||||||
var tileselect
|
|
||||||
8 const MAXTILE
|
|
||||||
|
|
||||||
: mouseworldpos mousepos scrollpos +pos ;
|
|
||||||
: world>tile 4 >> swap 4 >> swap ;
|
|
||||||
: mousetile mouseworldpos world>tile ;
|
|
||||||
: tile ( x y -- ptr ) mapsize drop * + map + ;
|
|
||||||
|
|
||||||
1 const WALKABLE
|
|
||||||
2 const DRIVABLE
|
|
||||||
|
|
||||||
array tileflags
|
|
||||||
( grass ) WALKABLE b,
|
|
||||||
( dirt ) WALKABLE b,
|
|
||||||
( water ) 0 b,
|
|
||||||
( pavement ) WALKABLE DRIVABLE | b,
|
|
||||||
( brick ) 0 b,
|
|
||||||
( forest ) 0 b,
|
|
||||||
( roof ) 0 b,
|
|
||||||
( brick ) 0 b,
|
|
||||||
( window ) 0 b,
|
|
||||||
|
|
||||||
: mapflag? ( x y flag -- b ) >rot tile b@ tileflags + b@ & ;
|
|
||||||
: walkable? ( x y -- b ) WALKABLE mapflag? ;
|
|
||||||
: drivable? ( x y -- b ) DRIVABLE mapflag? ;
|
|
||||||
|
|
||||||
: tick-mapedit
|
|
||||||
tileselect @
|
|
||||||
^< key-pressed if 1 - then
|
|
||||||
^> key-pressed if 1 + then
|
|
||||||
dup 0 < if drop MAXTILE then
|
|
||||||
dup MAXTILE > if drop 0 then
|
|
||||||
tileselect !
|
|
||||||
|
|
||||||
MOUSEL mousedown if tileselect @ mousetile tile b! then
|
|
||||||
MOUSER clicked if mouseworldpos world>tile swap . . then ;
|
|
||||||
|
|
||||||
: copy-mapseg ( neww oldw y -- )
|
|
||||||
r> ( oldw neww r: y )
|
|
||||||
2dup min >rot ( copyw neww oldw )
|
|
||||||
r@ * map + ( copyw neww src )
|
|
||||||
swap r< * map + ( copyw src dst )
|
|
||||||
swap <rot memmove ;
|
|
||||||
|
|
||||||
: resize-map ( neww newh -- )
|
|
||||||
swap mapsize r> ( newh neww oldw r: oldh )
|
|
||||||
2dup < if 1 r< else r< 1 - 0 then ( newh neww copyw ystart ylim )
|
|
||||||
for 2dup i copy-mapseg next
|
|
||||||
drop swap mapsize! ;
|
|
||||||
|
|
||||||
: save-map ( filename -- )
|
|
||||||
fdeactivate swap overwrite
|
|
||||||
mapsize swap fput fput
|
|
||||||
mapsize * map fwrite
|
|
||||||
factivate ;
|
|
||||||
|
|
||||||
: load-map ( filename -- )
|
|
||||||
fdeactivate swap open
|
|
||||||
fget fget
|
|
||||||
2dup * map fread
|
|
||||||
mapsize!
|
|
||||||
factivate ;
|
|
||||||
|
|
||||||
( J O B )
|
( J O B )
|
||||||
var MODE-MOVE
|
var MODE-MOVE
|
||||||
|
@ -294,6 +35,7 @@ JOB listen-for-jobs
|
||||||
|
|
||||||
( T I C K )
|
( T I C K )
|
||||||
defer entities
|
defer entities
|
||||||
|
:noname 0 ; ' entities redefine
|
||||||
|
|
||||||
: entity-at ( x y -- entity|0 )
|
: entity-at ( x y -- entity|0 )
|
||||||
0 >rot
|
0 >rot
|
||||||
|
@ -371,8 +113,6 @@ player :tick
|
||||||
|
|
||||||
( S T U F F )
|
( S T U F F )
|
||||||
: hello-world
|
: hello-world
|
||||||
mary say" Hello, world!"
|
|
||||||
say" How are you\today?"
|
|
||||||
player.state DRIVING f@ not player.state DRIVING f! ;
|
player.state DRIVING f@ not player.state DRIVING f! ;
|
||||||
|
|
||||||
: mode-move
|
: mode-move
|
||||||
|
@ -404,24 +144,6 @@ player :tick
|
||||||
MODE-MOVE @ ' tick redefine
|
MODE-MOVE @ ' tick redefine
|
||||||
' full-draw ' draw redefine
|
' full-draw ' draw redefine
|
||||||
|
|
||||||
( P E T E )
|
|
||||||
|
|
||||||
8 8 E ' {car} defentity car
|
|
||||||
|
|
||||||
var cartimer
|
|
||||||
cartimer now!
|
|
||||||
car :tick 60 cartimer triggered if
|
|
||||||
:| car entity.dir @ E = if W else E then car entity.dir !
|
|
||||||
car try-move-entity |; JOB send
|
|
||||||
then
|
|
||||||
:touch pete say" What an old rustbucket.
|
|
||||||
Hasn't driven in years."
|
|
||||||
;entity
|
|
||||||
|
|
||||||
:noname
|
:noname
|
||||||
player yield
|
s" pete.jor" loadfile
|
||||||
car yield
|
; ' onload redefine
|
||||||
0 ;
|
|
||||||
' entities redefine
|
|
||||||
|
|
||||||
s" pete.map" load-map
|
|
||||||
|
|
32
input.jor
Executable file
32
input.jor
Executable file
|
@ -0,0 +1,32 @@
|
||||||
|
( K E Y B O A R D )
|
||||||
|
1 const ^ESC
|
||||||
|
28 const ^ENTER
|
||||||
|
29 const ^CTRL
|
||||||
|
51 const ^<
|
||||||
|
52 const ^>
|
||||||
|
56 const ^ALT
|
||||||
|
57 const ^SPACE
|
||||||
|
72 const ^UP
|
||||||
|
75 const ^LEFT
|
||||||
|
77 const ^RIGHT
|
||||||
|
80 const ^DOWN
|
||||||
|
|
||||||
|
: wait-key ( k -- ) begin dup key-pressed not while suspend repeat drop ;
|
||||||
|
: udelta ( u u -- u )
|
||||||
|
2dup u> if
|
||||||
|
swap -1 swap - + 1 +
|
||||||
|
else
|
||||||
|
swap -
|
||||||
|
then ;
|
||||||
|
|
||||||
|
( M O U S E )
|
||||||
|
var prevbutton
|
||||||
|
: tick-debounce
|
||||||
|
mousebuttons prevbutton ! ;
|
||||||
|
|
||||||
|
1 const MOUSEL
|
||||||
|
2 const MOUSER
|
||||||
|
: mousedown ( button -- bool ) mousebuttons & ;
|
||||||
|
: clicked ( button -- bool )
|
||||||
|
dup mousedown not swap
|
||||||
|
prevbutton @ & and ;
|
17
jorth.c
17
jorth.c
|
@ -62,6 +62,20 @@ void f_latest() {
|
||||||
PUSHCP(LATEST);
|
PUSHCP(LATEST);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
void f_latest_set() {
|
||||||
|
LATEST = TOP().p;
|
||||||
|
DROP(1);
|
||||||
|
}
|
||||||
|
|
||||||
|
void f_tasks() {
|
||||||
|
PUSHCP(TASKS);
|
||||||
|
}
|
||||||
|
|
||||||
|
void f_tasks_set() {
|
||||||
|
TASKS = TOP().p;
|
||||||
|
DROP(1);
|
||||||
|
}
|
||||||
|
|
||||||
void f_state() {
|
void f_state() {
|
||||||
PUSHC(STATE);
|
PUSHC(STATE);
|
||||||
}
|
}
|
||||||
|
@ -948,6 +962,9 @@ void f_init() {
|
||||||
CDEF("here", f_here);
|
CDEF("here", f_here);
|
||||||
CDEF("here!", f_here_set);
|
CDEF("here!", f_here_set);
|
||||||
CDEF("latest", f_latest);
|
CDEF("latest", f_latest);
|
||||||
|
CDEF("latest!", f_latest_set);
|
||||||
|
CDEF("tasks", f_tasks);
|
||||||
|
CDEF("tasks!", f_tasks_set);
|
||||||
CDEF("state", f_state);
|
CDEF("state", f_state);
|
||||||
CDEF("'", f_quote); f_immediate();
|
CDEF("'", f_quote); f_immediate();
|
||||||
CDEF("`", f_revlookup);
|
CDEF("`", f_revlookup);
|
||||||
|
|
32
keyboard.jor
Executable file
32
keyboard.jor
Executable file
|
@ -0,0 +1,32 @@
|
||||||
|
( K E Y B O A R D )
|
||||||
|
1 const ^ESC
|
||||||
|
28 const ^ENTER
|
||||||
|
29 const ^CTRL
|
||||||
|
51 const ^<
|
||||||
|
52 const ^>
|
||||||
|
56 const ^ALT
|
||||||
|
57 const ^SPACE
|
||||||
|
72 const ^UP
|
||||||
|
75 const ^LEFT
|
||||||
|
77 const ^RIGHT
|
||||||
|
80 const ^DOWN
|
||||||
|
|
||||||
|
: wait-key ( k -- ) begin dup key-pressed not while suspend repeat drop ;
|
||||||
|
: udelta ( u u -- u )
|
||||||
|
2dup u> if
|
||||||
|
swap -1 swap - + 1 +
|
||||||
|
else
|
||||||
|
swap -
|
||||||
|
then ;
|
||||||
|
|
||||||
|
( M O U S E )
|
||||||
|
var prevbutton
|
||||||
|
: tick-debounce
|
||||||
|
mousebuttons prevbutton ! ;
|
||||||
|
|
||||||
|
1 const MOUSEL
|
||||||
|
2 const MOUSER
|
||||||
|
: mousedown ( button -- bool ) mousebuttons & ;
|
||||||
|
: clicked ( button -- bool )
|
||||||
|
dup mousedown not swap
|
||||||
|
prevbutton @ & and ;
|
66
map.jor
Executable file
66
map.jor
Executable file
|
@ -0,0 +1,66 @@
|
||||||
|
( M A P )
|
||||||
|
: +pos ( x1 y1 x2 y2 -- x y )
|
||||||
|
<rot + >rot + swap ;
|
||||||
|
|
||||||
|
var tileselect
|
||||||
|
8 const MAXTILE
|
||||||
|
|
||||||
|
: mouseworldpos mousepos scrollpos +pos ;
|
||||||
|
: world>tile 4 >> swap 4 >> swap ;
|
||||||
|
: mousetile mouseworldpos world>tile ;
|
||||||
|
: tile ( x y -- ptr ) mapsize drop * + map + ;
|
||||||
|
|
||||||
|
1 const WALKABLE
|
||||||
|
2 const DRIVABLE
|
||||||
|
|
||||||
|
array tileflags
|
||||||
|
( grass ) WALKABLE b,
|
||||||
|
( dirt ) WALKABLE b,
|
||||||
|
( water ) 0 b,
|
||||||
|
( pavement ) WALKABLE DRIVABLE | b,
|
||||||
|
( brick ) 0 b,
|
||||||
|
( forest ) 0 b,
|
||||||
|
( roof ) 0 b,
|
||||||
|
( brick ) 0 b,
|
||||||
|
( window ) 0 b,
|
||||||
|
|
||||||
|
: mapflag? ( x y flag -- b ) >rot tile b@ tileflags + b@ & ;
|
||||||
|
: walkable? ( x y -- b ) WALKABLE mapflag? ;
|
||||||
|
: drivable? ( x y -- b ) DRIVABLE mapflag? ;
|
||||||
|
|
||||||
|
: tick-mapedit
|
||||||
|
tileselect @
|
||||||
|
^< key-pressed if 1 - then
|
||||||
|
^> key-pressed if 1 + then
|
||||||
|
dup 0 < if drop MAXTILE then
|
||||||
|
dup MAXTILE > if drop 0 then
|
||||||
|
tileselect !
|
||||||
|
|
||||||
|
MOUSEL mousedown if tileselect @ mousetile tile b! then
|
||||||
|
MOUSER clicked if mouseworldpos world>tile swap . . then ;
|
||||||
|
|
||||||
|
: copy-mapseg ( neww oldw y -- )
|
||||||
|
r> ( oldw neww r: y )
|
||||||
|
2dup min >rot ( copyw neww oldw )
|
||||||
|
r@ * map + ( copyw neww src )
|
||||||
|
swap r< * map + ( copyw src dst )
|
||||||
|
swap <rot memmove ;
|
||||||
|
|
||||||
|
: resize-map ( neww newh -- )
|
||||||
|
swap mapsize r> ( newh neww oldw r: oldh )
|
||||||
|
2dup < if 1 r< else r< 1 - 0 then ( newh neww copyw ystart ylim )
|
||||||
|
for 2dup i copy-mapseg next
|
||||||
|
drop swap mapsize! ;
|
||||||
|
|
||||||
|
: save-map ( filename -- )
|
||||||
|
fdeactivate swap overwrite
|
||||||
|
mapsize swap fput fput
|
||||||
|
mapsize * map fwrite
|
||||||
|
factivate ;
|
||||||
|
|
||||||
|
: load-map ( filename -- )
|
||||||
|
fdeactivate swap open
|
||||||
|
fget fget
|
||||||
|
2dup * map fread
|
||||||
|
mapsize!
|
||||||
|
factivate ;
|
24
pete.jor
Executable file
24
pete.jor
Executable file
|
@ -0,0 +1,24 @@
|
||||||
|
( P E T E )
|
||||||
|
|
||||||
|
8 8 E ' {car} defentity car
|
||||||
|
|
||||||
|
var cartimer
|
||||||
|
car :tick 60 cartimer triggered if
|
||||||
|
:| car entity.dir @ E = if W else E then car entity.dir !
|
||||||
|
car try-move-entity |; JOB send
|
||||||
|
then
|
||||||
|
:touch pete say" What an old rustbucket.
|
||||||
|
Hasn't driven in years."
|
||||||
|
;entity
|
||||||
|
|
||||||
|
:noname
|
||||||
|
:|
|
||||||
|
player yield
|
||||||
|
car yield
|
||||||
|
0 |;
|
||||||
|
' entities redefine
|
||||||
|
|
||||||
|
cartimer now!
|
||||||
|
s" pete.map" load-map
|
||||||
|
; ' onload redefine
|
||||||
|
|
37
timer.jor
Executable file
37
timer.jor
Executable file
|
@ -0,0 +1,37 @@
|
||||||
|
( timer + lerping )
|
||||||
|
: clamp0 ( range val -- i )
|
||||||
|
2dup <= if drop else
|
||||||
|
dup 0 <= if drop drop 0 else
|
||||||
|
swap drop then then ;
|
||||||
|
: >ratio ( range value -- f )
|
||||||
|
over swap clamp0 swap />ratio ;
|
||||||
|
: <ratio ( range ratio -- v ) *<ratio ;
|
||||||
|
: >range ( start end -- start range ) over - ;
|
||||||
|
: <range ( start range -- start end ) over + ;
|
||||||
|
: lerpr ( start end ratio ) r> >range r< <ratio + ;
|
||||||
|
: lerpn ( start1 end1 start2 end2 val )
|
||||||
|
r> >range r< <rot - >ratio lerpr ;
|
||||||
|
: lerp ( start end duration start -- i )
|
||||||
|
ticks udelta ( start end duration delta )
|
||||||
|
>ratio lerpr ;
|
||||||
|
|
||||||
|
: triggered ( duration timer -- b )
|
||||||
|
dup r> @ ticks udelta ( duration delta )
|
||||||
|
2dup <= if drop r< +! 1 else drop drop rdrop 0 then ;
|
||||||
|
|
||||||
|
: now! ( timer -- ) ticks swap ! ;
|
||||||
|
: advance! ( timer -- delta )
|
||||||
|
dup @ ticks udelta ( timer delta )
|
||||||
|
dup <rot +! ;
|
||||||
|
|
||||||
|
: move-to ( target speed p -- )
|
||||||
|
dup r> @ >rot ticks ( from to duration start )
|
||||||
|
begin
|
||||||
|
4dup lerp r@ !
|
||||||
|
<rot dup r@ @ != ( from duration start to !done )
|
||||||
|
while
|
||||||
|
>rot suspend
|
||||||
|
repeat rdrop drop drop drop drop ;
|
||||||
|
|
||||||
|
: sleep ( count -- )
|
||||||
|
ticks swap begin over ticks udelta over u< while suspend repeat drop drop ;
|
Loading…
Reference in a new issue