neuttower/game.jor

( T I C K )
defer party
defer entities
var objects

: obj-entity ( optr -- entity ) cell + @ ;

: single-entity-at ( x y 0 entity -- x y entity|0 b )
  swap drop >r 2dup ( x y x y r:e )
  r@ entity>pos world>tile 2= ( x y b r:e )
  if <r else rdrop 0 then dup ;

: entity-at ( x y -- entity|0 )
  0 entities each single-entity-at if break then more
  dup not objects @ and if
    objects @ links each
      >r r@ obj-entity single-entity-at if rdrop break else <r then
    more
  then
  >rot 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

1 player.state HASNEUT f!

: noclip player.state NOCLIP fnot! ; userword

: isneut? player.state ISNEUT f@ ; userword
: isjaye? isneut? not ; userword

: {jaye}
  isjaye? 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
  player entity>pos world>tile entity-at
  dup if EVUNTOUCH entity>do else drop then

  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 -- )
  pjaye 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
: queue-level q-level ! ; userword

: player-tick
  ^SPACE key-pressed player.state HASNEUT f@ and if
    player.state ISNEUT fnot!
    isneut? if night else day then
  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
  0 objects !
  :| done |; ' entities redefine
  :| drop drop 0 |; ' jaye-touch redefine
  :| drop drop 0 |; ' neut-touch redefine ; userword

: mode-move
  player-tick
(  objects @ if objects @ links each dup obj-entity EVTICK entity>do more )
  entities each EVTICK entity>do more
  party each EVTICK entity>do more
  pneut EVTICK entity>do

  DEV if tick-mapedit jiles then
  tick-debounce
  q-level @ dup if
    0 q-level !
    reset-level
    loadlevel
    party each follow more
  else drop then ;

: draw-entity
  >r r@ entity.x @ r@ entity.y @
  r@ entity.dir @ <r entity>sprite
  sprite-bob draw-sprite ;

var glitchlevel
var quaking

var _dorubber
: rubber _dorubber @ not _dorubber ! ;

: full-draw
  quaking @ not if
    player entity.x @ 152 -
    player entity.y @ 92 -
    scroll
  else
    0 ticks 3 % 13 * 8 % scroll
  then

  _dorubber @ objects @ and if
    objects @ links each dup obj-entity draw-entity more
  then
  entities each draw-entity more
  party each draw-entity more
  player.state HASNEUT f@ if pneut draw-entity then

  DEV if
    mouseworldpos 4 draw-sprite
  then
  glitchlevel @ glitch
  draw-screen
  draw-footer ;

var defining-objects-head
var defining-objects-ptr
: objects: create here 0 ,
  0 defining-objects-head !
  defining-objects-ptr !
does> @ objects ! ;

: link-object ( entity -- )
  here defining-objects-head @ , swap ,
  dup defining-objects-head !
  defining-objects-ptr @ ! ;

 4 const COMP-OFF
 5 const COMP-ON
 9 const DOOR-CLOSED
10 const DOOR-OPENED
11 const SWITCH-OFF
12 const SWITCH-ON
20 const SCAN-OFF
21 const SCAN-ON

: entity>tile ( entity -- tile ) entity>pos world>tile tile ;
: entity>tile? ( entity expected - b ) swap entity>tile b@ = ;
: responder>tile? ( expected - b ) responder swap entity>tile? ;

: toggleval ( off on val -- off|on ) over = not if swap then drop ;
: toggletile ( entity off on -- )
  <rot >r r@ entity>tile b@ toggleval <r entity>tile b! invalidate-map ;

: respondertile! ( tile -- ) responder entity>tile b! invalidate-map ;

: handle-onoff ( ev on off -- )
  <rot dup EVDEACT = if drop swap drop respondertile! else
       dup EVACT = if drop drop respondertile! else
       dup EVTOG = if drop responder >rot toggletile else
  drop drop drop then then then ;
: statechange? ( ev -- b )
  dup EVACT = over EVDEACT = or swap EVTOG = or ;

: blankentity array here >r N ' {duck} allotentity <r ;

: linked-entity responder entity.user @ execute ;

: handle-link ( ev ontile -- )
  swap statechange? if
    responder>tile? if EVACT else EVDEACT then
    linked-entity swap entity>do
  else drop then ;

: computer-on? ( entity -- b ) COMP-ON entity>tile? ;

: handle-teleport ( ev -- )
  EVTOUCH = isneut? and COMP-ON responder>tile? and if
    linked-entity dup computer-on? if
      entity>pos pneut entity.pos!
    else drop then
  then ;

: create-object blankentity dup link-object ;
: create-linked-object blankentity swap , dup link-object ;
: listener! ( entity listener ) swap ! ;

: entering-door? ( ev -- b )
  EVTOUCH = isjaye? and DOOR-OPENED responder>tile? and ;

: door-listener ( ev -- )
  dup entering-door? if move-player then
  DOOR-OPENED DOOR-CLOSED handle-onoff ;

: door create-object ' door-listener listener! ;

: exitdoor create-linked-object
  :| dup door-listener entering-door? if
    responder entity.user @ queue-level
  then |; listener! ;

: switch create-linked-object
  :| dup EVTOUCH = isneut? and if move-player then
     dup EVTOUCH = if
       responder EVTOG entity>do
       isjaye? if wait-for-arrow-up then
     then
     dup SWITCH-ON SWITCH-OFF handle-onoff
     SWITCH-ON handle-link |; listener! ;

: computer blankentity swap , dup link-object
  :| dup EVTOUCH = isjaye? and if responder EVACT entity>do then
     dup EVTOUCH = isneut? and COMP-ON responder>tile? and if move-player then
     dup COMP-ON COMP-OFF handle-onoff
     handle-teleport |; listener! ;

: scanner create-linked-object
  :| dup EVTOUCH = isneut? and if
       move-player
       responder EVACT entity>do
     then
     dup EVUNTOUCH = isneut? and if responder EVDEACT entity>do then
     dup SCAN-ON SCAN-OFF handle-onoff
     SCAN-ON handle-link |; listener! ;

0 const unconnected

( usage: entity :noname [ ev -- ev ] ... chain-listener ;
  ONLY works with :noname at top-level interpretation time - not :| |;
  compiles a reference to the previous listener into the :noname func
  and sets the listener of the entity on the stack to the new func )

: chain-listener ( entity xp -- ) swap dup @ , ! ; immediate

:noname
  reset-level
  ' mode-move ' tick redefine
  ' full-draw ' draw redefine
  :| pjaye yield done |; ' party redefine
  :| ' tick-debounce ' tick redefine |; ' any-job-started redefine
  :| ' mode-move ' tick redefine hide-footer |; ' all-jobs-complete redefine
; ' onload redefine