180 lines
4.6 KiB
Plaintext
Executable file
180 lines
4.6 KiB
Plaintext
Executable file
var MODE-MOVE
|
|
var MODE-WAIT
|
|
|
|
|
|
( 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 userword
|
|
var player.prevdir
|
|
|
|
1 const MOVING userword
|
|
2 const DRIVING userword
|
|
4 const BOATING userword
|
|
8 const NOCLIP userword
|
|
16 const ISMARY userword
|
|
32 const ISJEANNE userword
|
|
|
|
: noclip player.state NOCLIP fnot! ; userword
|
|
|
|
: player.driving? player.state DRIVING f@ ; userword
|
|
: player.boating? player.state BOATING f@ ; userword
|
|
|
|
: :playerwalk create , , does>
|
|
player.state MOVING f@ not if cell + then @ execute ;
|
|
|
|
' {mary} ' {mary-walk} :playerwalk {pmary}
|
|
' {pete-stand} ' {pete-walk} :playerwalk {ppete}
|
|
' {jeanne} ' {jeanne-walk} :playerwalk {pjeanne}
|
|
|
|
: {player}
|
|
player.driving? if {car-drive}
|
|
else player.boating? if {boat-pete}
|
|
else
|
|
player.state ISMARY f@ if {pmary}
|
|
else player.state ISJEANNE f@ if {pjeanne}
|
|
else {ppete} then then
|
|
then then ;
|
|
|
|
: player.canmove? ( x y -- )
|
|
player.state NOCLIP f@ not if
|
|
player.driving? if DRIVABLE else
|
|
player.boating? if BOATABLE else WALKABLE then then mapflag?
|
|
else drop drop 1 then ;
|
|
|
|
12 9 N ' {player} defentity player
|
|
|
|
: sched-move-entity ( entity -- ) :| jobdata move-entity |; sched-with ;
|
|
: move-player
|
|
:| 1 player.state MOVING f!
|
|
player move-entity
|
|
0 player.state MOVING f!
|
|
|; sched
|
|
player.prevdir @ party each
|
|
dup player != if
|
|
dup entity.dir @ >r
|
|
dup >rot entity.dir !
|
|
sched-move-entity <r
|
|
else entity.dir @ player.prevdir ! then more drop ;
|
|
|
|
: 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 ! ; userword
|
|
|
|
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 sched then
|
|
;entity
|
|
|
|
( S T U F F )
|
|
: reset-level
|
|
:| done |; ' entities redefine
|
|
:| drop drop 0 |; ' player-touch redefine ; userword
|
|
|
|
: mode-move
|
|
entities each EVTICK entity>do more
|
|
party each EVTICK entity>do more
|
|
tick-mapedit jiles
|
|
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
|
|
sprite-bob draw-sprite ;
|
|
|
|
var showmouse
|
|
1 showmouse !
|
|
var glitchlevel
|
|
|
|
: 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
|
|
glitchlevel @ glitch
|
|
draw-screen
|
|
draw-footer ;
|
|
|
|
16 18 W ' {horse} defentity p_chuck
|
|
16 18 W ' {pjeanne} defentity p_jeanne
|
|
|
|
:noname
|
|
reset-level
|
|
MODE-MOVE @ ' tick redefine
|
|
' full-draw ' draw redefine
|
|
:| player yield
|
|
player.state ISMARY f@ if p_jeanne yield then
|
|
CHUCK-FOLLOW flag@ if p_chuck yield then
|
|
done |; ' party redefine
|
|
:| MODE-WAIT @ ' tick redefine |; ' any-job-started redefine
|
|
:| MODE-MOVE @ ' tick redefine hide-footer |; ' all-jobs-complete redefine
|
|
; ' onload redefine
|