521 lines
14 KiB
Plaintext
Executable file
521 lines
14 KiB
Plaintext
Executable file
( 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
|