134 lines
3.2 KiB
Plaintext
Executable file
134 lines
3.2 KiB
Plaintext
Executable file
( J O B )
|
|
var MODE-MOVE
|
|
var MODE-WAIT
|
|
|
|
: listen-for-jobs activate blah
|
|
begin receive
|
|
MODE-WAIT @ ' tick redefine
|
|
execute
|
|
hide-footer
|
|
MODE-MOVE @ ' tick redefine
|
|
again ;
|
|
|
|
task const JOB
|
|
JOB listen-for-jobs
|
|
|
|
( T I C K )
|
|
defer entities
|
|
:noname 0 ; ' entities redefine
|
|
|
|
: entity-at ( x y -- entity|0 )
|
|
0 >rot
|
|
entities each r> 2dup ( 0 x y x y r:e )
|
|
r@ entity.x @ r@ entity.y @ world>tile 2= ( 0 x y eq r:e )
|
|
if <rot drop r< >rot break ( e x y )
|
|
else rdrop then ( 0 x y )
|
|
more drop drop ;
|
|
|
|
( P L A Y E R )
|
|
var player.state
|
|
defer player
|
|
|
|
1 const MOVING
|
|
2 const DRIVING
|
|
|
|
: {player}
|
|
player.state DRIVING f@ if {car}
|
|
else player.state MOVING f@ if {pete-walk}
|
|
else {pete-stand} then then ;
|
|
|
|
: player.driving? player.state DRIVING f@ ;
|
|
: player.canmove? ( x y -- )
|
|
player.driving? if DRIVABLE else WALKABLE then mapflag? ;
|
|
|
|
12 9 N ' {player} defentity player
|
|
|
|
: entity-dst ( e -- x y )
|
|
r> r@ entity.dir @ dir>pos
|
|
r@ entity.x @ r< entity.y @ world>tile +pos ;
|
|
|
|
: move-entity ( e -- )
|
|
dup entity.dir @ dir>pos ( e dx dy )
|
|
dup if swap drop swap entity.y
|
|
else drop swap entity.x then
|
|
swap 16 * over @ + 4 <rot move-to ;
|
|
|
|
: move-player
|
|
1 player.state MOVING f!
|
|
player move-entity
|
|
0 player.state MOVING f! ;
|
|
|
|
: out-of-bounds ( x y -- b )
|
|
2dup 0 < swap 0 < or >rot mapsize ( b x y w h )
|
|
<rot <= >rot ( b b x w )
|
|
>= or or ;
|
|
|
|
: leaving? ( x y dir -- b )
|
|
dup N = if drop swap drop 0 < else
|
|
dup W = if drop drop 0 < else
|
|
S = if swap drop mapsize swap drop >= else
|
|
drop mapsize drop >= then then then ;
|
|
|
|
: no-touch drop drop 0 ;
|
|
defer player-touch ( x y -- b )
|
|
' no-touch ' player-touch redefine
|
|
|
|
: check-player-touch ( x y -- b )
|
|
2dup entity-at dup if EVTOUCH entity>do drop drop 1 else drop
|
|
2dup player-touch if drop drop 1 else
|
|
2dup out-of-bounds if drop drop 1 else
|
|
player.canmove? if 0 else 1 then then then then ;
|
|
|
|
: try-move-player
|
|
player entity-dst check-player-touch not if move-player then ;
|
|
|
|
: check-entity-touch ( x y -- b )
|
|
2dup entity-at if drop drop 1 else
|
|
2dup out-of-bounds if 1 else
|
|
WALKABLE mapflag? if 0 else 1 then then then ;
|
|
|
|
: try-move-entity ( e -- )
|
|
dup entity-dst check-entity-touch not if move-entity then ;
|
|
|
|
player :tick
|
|
0 ^LEFT key-down if drop 1 W player entity.dir ! then
|
|
^RIGHT key-down if drop 1 E player entity.dir ! then
|
|
^UP key-down if drop 1 N player entity.dir ! then
|
|
^DOWN key-down if drop 1 S player entity.dir ! then
|
|
if ' try-move-player JOB send then
|
|
;entity
|
|
|
|
( S T U F F )
|
|
: hello-world
|
|
player.state DRIVING f@ not player.state DRIVING f! ;
|
|
|
|
: mode-move
|
|
entities each EVTICK entity>do more
|
|
tick-mapedit
|
|
^SPACE key-pressed if
|
|
' hello-world JOB send
|
|
then
|
|
tick-debounce ;
|
|
|
|
' mode-move MODE-MOVE !
|
|
' tick-debounce MODE-WAIT !
|
|
|
|
: draw-entity
|
|
r> r@ entity.x @ r@ entity.y @
|
|
r@ entity.dir @ r< entity>sprite
|
|
draw-sprite ;
|
|
|
|
: full-draw
|
|
player entity.x @ 152 -
|
|
player entity.y @ 92 -
|
|
scroll
|
|
|
|
entities each draw-entity more
|
|
mouseworldpos 4 draw-sprite
|
|
draw-screen
|
|
draw-footer ;
|
|
|
|
:noname
|
|
MODE-MOVE @ ' tick redefine
|
|
' full-draw ' draw redefine
|
|
; ' onload redefine |