162 lines
3.7 KiB
Plaintext
Executable file
162 lines
3.7 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 party
|
|
defer entities
|
|
|
|
: 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
|
|
var player.prevdir
|
|
|
|
1 const MOVING
|
|
2 const DRIVING
|
|
4 const NOCLIP
|
|
8 const ISMARY
|
|
|
|
: player.driving? player.state DRIVING f@ ;
|
|
|
|
: {player}
|
|
player.driving? if {car}
|
|
else player.state MOVING f@ if
|
|
player.state ISMARY f@ if {mary-walk} else {pete-walk} then
|
|
else
|
|
player.state ISMARY f@ if {mary} else {pete-stand} then
|
|
then then ;
|
|
|
|
: player.canmove? ( x y -- )
|
|
player.state NOCLIP f@ not if
|
|
player.driving? if DRIVABLE else WALKABLE then mapflag?
|
|
else drop drop 1 then ;
|
|
|
|
12 9 N ' {player} defentity player
|
|
|
|
: move-player
|
|
1 player.state MOVING f!
|
|
player move-entity
|
|
player.prevdir @ party each
|
|
dup player != if
|
|
dup entity.dir @ >r
|
|
dup >rot entity.dir !
|
|
move-entity <r
|
|
else entity.dir @ player.prevdir ! then more drop
|
|
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 ;
|
|
|
|
defer player-touch ( x y -- b )
|
|
|
|
: touch-begin each 2dup more >rot drop drop ;
|
|
: touch-next dup if rdrop done then drop rswap ;
|
|
: touch-last ' done , ; immediate
|
|
: ;touch [ ' touch-last , ' [ , ] ; immediate
|
|
|
|
: check-player-touch ( x y -- b )
|
|
touch-begin entity-at dup if EVTOUCH entity>do 1 then
|
|
touch-next player-touch
|
|
touch-next out-of-bounds
|
|
touch-next player.canmove? not ;touch
|
|
|
|
: try-move-player
|
|
player entity-dst check-player-touch not if move-player then ;
|
|
|
|
: follow ( e -- )
|
|
player entity>pos <rot entity.pos! NODIR player.prevdir ! ;
|
|
|
|
: check-entity-touch
|
|
touch-begin entity-at
|
|
touch-next out-of-bounds
|
|
touch-next WALKABLE mapflag? ;touch
|
|
|
|
: try-move-entity ( e -- )
|
|
dup entity-dst check-entity-touch not if move-entity then ;
|
|
|
|
var q-level
|
|
var q-player.x
|
|
var q-player.y
|
|
: queue-level q-level ! q-player.y ! q-player.x ! ;
|
|
|
|
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 )
|
|
: reset-level
|
|
:| done |; ' entities redefine
|
|
:| drop drop 0 |; ' player-touch redefine ;
|
|
|
|
: mode-move
|
|
entities each EVTICK entity>do more
|
|
party each EVTICK entity>do more
|
|
tick-mapedit
|
|
tick-debounce
|
|
q-level @ dup if
|
|
0 q-level !
|
|
reset-level
|
|
loadlevel
|
|
q-player.x @ q-player.y @ tile>world player entity.pos!
|
|
party each follow more
|
|
else drop then ;
|
|
|
|
' 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 ;
|
|
|
|
var showmouse
|
|
1 showmouse !
|
|
: full-draw
|
|
player entity.x @ 152 -
|
|
player entity.y @ 92 -
|
|
scroll
|
|
|
|
entities each draw-entity more
|
|
party each draw-entity more
|
|
|
|
showmouse @ if
|
|
mouseworldpos 4 draw-sprite
|
|
then
|
|
draw-screen
|
|
draw-footer ;
|
|
|
|
:noname
|
|
reset-level
|
|
MODE-MOVE @ ' tick redefine
|
|
' full-draw ' draw redefine
|
|
; ' onload redefine |