171 lines
4.2 KiB
Plaintext
Executable file
171 lines
4.2 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 NOCLIP userword
|
|
4 const ISNEUT userword
|
|
|
|
: noclip player.state NOCLIP fnot! ; userword
|
|
|
|
: isneut? player.state ISNEUT f@ ; userword
|
|
|
|
: {jaye}
|
|
isneut? not player.state MOVING f@ and
|
|
if {jeanne-walk} else {jeanne} then ;
|
|
|
|
: player.canmove? ( x y -- )
|
|
player.state NOCLIP f@ not if
|
|
isneut? if NEUTABLE else WALKABLE then mapflag?
|
|
else drop drop 1 then ;
|
|
|
|
12 9 N ' {jaye} defentity pjaye
|
|
17 5 N ' {neut} defentity pneut
|
|
|
|
: player isneut? if pneut else pjaye then ;
|
|
|
|
: 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
|
|
isneut? not if ( only jaye can have a party )
|
|
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
|
|
then ;
|
|
|
|
: 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 jaye-touch ( x y -- b )
|
|
defer neut-touch ( x y -- b )
|
|
|
|
: player-touch isneut? if neut-touch else jaye-touch then ;
|
|
|
|
: 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 -- )
|
|
s" try-move-entity" type cr
|
|
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
|
|
^SPACE key-pressed if player.state ISNEUT fnot! then
|
|
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 ;
|
|
|
|
( S T U F F )
|
|
: reset-level
|
|
:| done |; ' entities redefine
|
|
:| drop drop 0 |; ' jaye-touch redefine
|
|
:| drop drop 0 |; ' neut-touch redefine ; userword
|
|
|
|
: mode-move
|
|
player-tick
|
|
entities each EVTICK entity>do more
|
|
party each EVTICK entity>do more
|
|
pneut EVTICK entity>do
|
|
|
|
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
|
|
pneut draw-entity
|
|
|
|
showmouse @ if
|
|
mouseworldpos 4 draw-sprite
|
|
then
|
|
glitchlevel @ glitch
|
|
draw-screen
|
|
draw-footer ;
|
|
|
|
:noname
|
|
reset-level
|
|
MODE-MOVE @ ' tick redefine
|
|
' full-draw ' draw redefine
|
|
:| pjaye yield done |; ' party redefine
|
|
:| MODE-WAIT @ ' tick redefine |; ' any-job-started redefine
|
|
:| MODE-MOVE @ ' tick redefine hide-footer |; ' all-jobs-complete redefine
|
|
; ' onload redefine
|