neuttower/game.jor

( T I C K )
defer cheat-tick
defer party
defer entities
var objects
var ticking-objects
var visible-objects

0 const rubber-on?
: rubber rubber-on? not ' rubber-on? redefine ;
: {tileent} rubber-on? if {duck} else {blank} then ;
: visible-objects@ rubber-on? if objects else visible-objects then @ ;

defer touchable-objects
' objects ' touchable-objects redefine

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

( P L A Y E R )
var player.state userword
var player.prevdir

1 const MOVING userword
2 const NOCLIP userword
4 const HASNEUT userword
8 const HASGORD userword
16 const ISPROG userword
32 const GORDSIT userword
64 const HASLIBB userword

: noclip player.state NOCLIP fnot! ; userword

var posessed-rexx

: isprog? player.state ISPROG f@ ;
: isneut? isprog? posessed-rexx @ not and ; userword
: isjaye? isprog? not ; userword
: isrexx? isprog? posessed-rexx @ and ; userword
: gord-follow? player.state HASGORD f@ ;
: haslibb? player.state HASLIBB f@ ;

: {jaye}
  isjaye? player.state MOVING f@ and
  if {jaye-walk} else {jaye-stand} then ;

: {gord}
  gord-follow? if
    isjaye? player.state MOVING f@ and player.state GORDSIT f@ or
    if {gord-walk} else {gord-stand} then
  else player.state GORDSIT f@ if {gord-sit} else {gord-floor} then 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 Jaye
17 5 N ' {neut} defentity Neut
-10 -10 N ' {gord} defentity Gord
-10 -10 N ' {libb} defentity Libb

: entity-present? entity>pos drop 0 >= ;
: gord-present? Gord entity-present? ;

: player
  isrexx? if posessed-rexx @ else
  isneut? if Neut else Jaye then then ;

: replace-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 ;

: single-entity-at ( x y entity|0 entity -- x y entity|0 )
  over not if replace-entity-at then drop ;

: entity-at ( x y -- entity|0 )
  0 entities each replace-entity-at if break then more
  dup not touchable-objects @ and if
    touchable-objects @ links each
      >r r@ obj-entity replace-entity-at if rdrop break else <r then
    more
  then
  Neut single-entity-at
  Jaye single-entity-at
  >rot drop drop ;

: touchable-entity-at ( x y -- entity|0 )
  2dup ENTITY mapflag? not if
    ' visible-objects ' touchable-objects redefine
    entity-at
    ' objects ' touchable-objects redefine
  else entity-at then ;

: sched-move-entity ( entity -- ) :| jobdata move-entity |; sched-with ;
: move-player
  player entity>pos world>tile touchable-entity-at
  dup if EVUNTOUCH entity>do else drop then

  1 player.state MOVING f!

  isjaye? 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 touch-override ( x y -- b )

: rexx-touch ( x y -- b )
  0 >r isrexx? if
    2dup RUBBLE mapflag? if
      tile 3 swap b! invalidate-map
      sfx-garbage
    else tile b@ REXX-POD = if
      move-player
      S posessed-rexx @ entity.dir !
      posessed-rexx @ entity>pos Neut entity.pos!
      0 posessed-rexx !
      rdrop 1 >r
    then then
  else drop drop then <r ;

defer on-gord-sit

: do-gord-sit ( x y -- b )
  isjaye? gord-follow? and if
    tile b@ CHAIR = if
      1 player.state GORDSIT f!
      player.prevdir @ Gord entity.dir !
      Gord move-entity
      player entity.dir @ Gord entity.dir !
      Gord move-entity
      0 player.state HASGORD f!
      on-gord-sit
      1
    else 0 then
  else drop drop 0 then ;

: activate-dir ( x y dir -- )
  dir>pos +pos touchable-entity-at EVTOUCH entity>do ;

: activate-gord
  player.state GORDSIT f@ if
    :| Gord entity>pos world>tile
       2dup N activate-dir
       2dup S activate-dir
       2dup E activate-dir
	    W activate-dir |; sched
  then ;
var hack-handled
: hacked 1 hack-handled ! ;
: hack-override? ( e -- e b )
  dup EVHACK = if hacked drop EVNOP 1 else 0 then ;

: activate-libb
  haslibb? if Libb entity-present? not if
    :| 0 hack-handled !
       Neut entity>pos world>tile touchable-entity-at EVHACK entity>do
       hack-handled @ not if
	 libb say" don't think i can hack that."
       then |; sched
  then 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

: neut-touch-libb ( x y -- b )
  Libb entity>pos world>tile 2= isneut? and if
    move-player
    -100 -100 Libb entity.pos!
    1
  else 0 then ;

: check-player-touch ( x y -- b )
  touch-begin neut-touch-libb
  touch-next touchable-entity-at dup if EVTOUCH entity>do 1 then
  touch-next touch-override
  touch-next rexx-touch
  touch-next do-gord-sit
  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 -- )
  Jaye entity>pos <rot entity.pos! NODIR player.prevdir ! ;

var q-level
: queue-level q-level ! ; userword

: player-tick
  ^SPACE key-pressed if player.state HASNEUT f@ if
    player.state ISPROG fnot!
    isprog? if prog-view else human-view then
  then then
  ^Z key-pressed if
    isprog? if activate-libb else activate-gord 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 )
defer reset-level userword

67 const ^F9

: boss-tick
  ^F9 key-pressed if
    ticks boss
    unfuck invalidate-map reloadtiles reloadportraits
    ticks!
  then ;

: quit-game hide-footer LEV_QUIT queue-level ;
: quit-tick
  ^ESC key-pressed if :|
    disk :|
      s" Resume play" ' noop yield
      s" Save and quit to title" :| savegame quit-game |; yield
      s" Don't save and quit to title" ' quit-game yield
    done |; choose
  |; sched then ;

: mode-move
  player-tick
  boss-tick
  quit-tick
  cheat-tick

  ticking-objects @ if
    ticking-objects @ links
    each dup obj-entity EVTICK entity>do more
  then

  DEV if tick-mapedit jiles then
  tick-debounce

  q-level @ dup if
    0 q-level !
    reset-level
    dup LEV_QUIT = if
      drop clear-pages title
    else
      loadlevel
      party each follow more
    then
  else drop then ;

: mode-wait tick-debounce boss-tick ;

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

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

  party each dup Jaye != if draw-entity else drop then more
  Jaye draw-entity
  player.state HASNEUT f@ if Neut draw-entity then
  Libb entity-present? if Libb draw-entity then
  visible-objects@ if
    visible-objects@ links each dup obj-entity draw-entity more
  then
  entities each draw-entity more

  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 , 0 ,
  0 defining-objects-head !
  defining-objects-ptr !
does>
  dup @ objects !
  dup cell + @ ticking-objects !
  2 cells + @ visible-objects ! ;

: obj-link-head! ( index -- )
  cells defining-objects-ptr @ + defining-objects-head @ swap ! ;

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

: obj-ticking! 1 obj-link-head! ;
: obj-visible! 2 obj-link-head! ;

: 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 ;

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

: linked-entity responder entity.user @ execute ;

: timer>count ( e -- count ) entity.user cell + @ ; userword
: timer.start ( e -- p ) entity.user 2 cells + ; userword
: timer>donewaiting? ( e -- b )
  dup timer>count swap timer.start @ still-waiting? not ; userword

: create-object blankentity dup link-object ;
: create-linked-object blankentity swap , dup link-object ;
: create-extra-linked-object blankentity swap , swap ,
  dup link-object ;
: create-timed-object blankentity swap , swap , 0 ,
  dup link-object obj-ticking! ;

: listener! ( entity listener ) swap ! ;

: 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 ;

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

: door-listener ( ev -- )
  dup entering-door? if move-player then
  DOOR-CLOSED responder>tile? swap
  DOOR-OPENED DOOR-CLOSED handle-onoff
  DOOR-CLOSED responder>tile? != if
    DOOR-CLOSED responder>tile? if sfx-doorclose else sfx-dooropen then
  then ;

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

: exitdoor create-linked-object
  :| dup door-listener entering-door? if
    gord-follow? not gord-present? and if
      jaye say" I'm not leaving Gord behind."
    else Libb entity-present? if
      neut say" I SHOULD PROBABLY RETRIEVE\LIBB."
    else
      responder entity.user @ queue-level
    then then
  then |; listener! ;

: statechange? ( ev -- b )
  dup EVACT = over EVDEACT = or swap EVTOG = or ;

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

: handle-switch-touch ( ev -- )
  dup EVTOUCH = isneut? and if move-player then
  dup EVTOUCH = isrexx? not and if
    responder EVTOG entity>do
    isjaye? if wait-for-arrow-up then
  then
  dup SWITCH-ON SWITCH-OFF handle-onoff
  SWITCH-ON handle-link ;

: switch create-linked-object ' handle-switch-touch listener! ;

: timedswitch create-timed-object
  :| dup EVTICK = if SWITCH-ON responder>tile? if
       drop responder timer>donewaiting? if
	 EVDEACT
       else ret then
     then then
     dup EVTOUCH = over EVACT = or if SWITCH-ON responder>tile? if
       dup EVTOUCH = isneut? and if move-player then
       drop EVNOP
     then then
     dup handle-switch-touch
     statechange? if SWITCH-ON responder>tile? if
       ticks responder timer.start !
     then then |; listener! ;

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

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


: 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 EVHACK = if hacked libb say" nothing interesting on this one." then
     COMP-OFF responder>tile? swap
     dup COMP-ON COMP-OFF handle-onoff
     handle-teleport
     COMP-OFF responder>tile? != if
       COMP-OFF responder>tile? if sfx-termoff else sfx-termon then
     then |; listener! ;

: scanner create-linked-object
  :| dup EVTOUCH = isneut? and if
       move-player
       responder EVACT entity>do
     then
     dup EVHACK = if
       sfx-libb
       libb say" that's easy."
       responder entity>pos Libb entity.pos!
       hacked
     then
     dup EVUNTOUCH = isneut? and if
       Libb entity>pos responder entity>pos 2= not if
	 responder EVDEACT entity>do
       then
     then
     dup SCAN-ON SCAN-OFF handle-onoff
     SCAN-ON handle-link |; listener! ;

: defrexx array here >r S ' {rexx} allotentity <r
  dup link-object obj-visible!
  :| EVTOUCH = isneut? and if
       move-player
       responder posessed-rexx !
       -100 -100 Neut entity.pos!
       sfx-rexx
     then |; 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
: cancel-ev ( ev -- EVNOP ) drop EVNOP ;

: with-gord Gord follow 1 player.state HASGORD f! ;
: with-libb 1 player.state HASLIBB f! ;

Gord :noname
  dup EVTOUCH = isjaye? and gord-follow? not and if
    player.state GORDSIT f@ if
      1 player.state HASGORD f!
      Gord player face
      Gord move-entity
      0 player.state GORDSIT f!
      Gord follow
    else move-player with-gord then
  then chain-listener ;

Gord @ const gord-listener
: chain-gord-listener gord-listener execute ;

:noname
  ' norm-rexxinst ' rexxinst redefine
  HASNEUT player.state !
  human-view
  0 objects ! 0 ticking-objects ! 0 visible-objects !
  Gord gord-listener listener!
  ' noop ' on-gord-sit redefine
  :| gord-follow? not gord-present? and if Gord yield then
     done |; ' entities redefine
  :| drop drop 0 |; ' touch-override redefine ; ' reset-level redefine

:noname
  reset-level
  ' mode-move ' tick redefine
  ' full-draw ' draw redefine
  :| Jaye yield
     gord-follow? if Gord yield then
     done |; ' party redefine
  :| ' mode-wait ' tick redefine |; ' any-job-started redefine
  :| hide-footer ' mode-move ' tick redefine |; ' all-jobs-complete redefine
; ' onload redefine