neuttower/game.jor

180 lines
4.4 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
8 const HASNEUT userword
: noclip player.state NOCLIP fnot! ; userword
: isneut? player.state ISNEUT f@ ; userword
: isjaye? isneut? not ; 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 ;
14 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!
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
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 ;
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 player.state HASNEUT f@ and
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
var quaking
: full-draw
quaking @ not if
player entity.x @ 152 -
player entity.y @ 92 -
scroll
else
0 ticks 3 % 13 * 8 % scroll
then
entities each draw-entity more
party each draw-entity more
player.state HASNEUT f@ if pneut draw-entity then
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