neuttower/game.jor

360 lines
9.8 KiB
Plaintext
Raw Normal View History

2020-02-02 23:33:07 +00:00
( T I C K )
defer party
defer entities
var objects
: obj-entity ( optr -- entity ) cell + @ ;
2020-02-02 23:33:07 +00:00
( 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
2020-02-22 20:15:00 +00:00
8 const HASGORD userword
16 const ISPROG userword
2020-02-02 23:33:07 +00:00
1 player.state HASNEUT f!
2020-02-02 23:33:07 +00:00
: noclip player.state NOCLIP fnot! ; userword
var posessed-rexx
2020-02-18 01:43:14 +00:00
: isprog? player.state ISPROG f@ ;
: isneut? isprog? posessed-rexx @ not and ; userword
2020-02-18 01:43:14 +00:00
: isjaye? isprog? not ; userword
: isrexx? isprog? posessed-rexx @ and ; userword
2020-02-02 23:33:07 +00:00
: {jaye}
isjaye? player.state MOVING f@ and
2020-02-18 01:43:11 +00:00
if {jaye-walk} else {jaye-stand} then ;
2020-02-02 23:33:07 +00:00
2020-02-22 20:15:00 +00:00
: {gord}
player.state HASGORD f@ if
isjaye? player.state MOVING f@ and
if {gord-walk} else {gord-stand} then
else {gord-sit} then ;
2020-02-02 23:33:07 +00:00
: player.canmove? ( x y -- )
player.state NOCLIP f@ not if
isneut? if NEUTABLE else WALKABLE then mapflag?
else drop drop 1 then ;
2020-02-18 01:43:14 +00:00
14 9 N ' {jaye} defentity Jaye
17 5 N ' {neut} defentity Neut
2020-02-22 20:15:00 +00:00
-10 -10 N ' {gord} defentity Gord
: gord-present? Gord entity>pos drop 0 >= ;
2020-02-18 01:43:14 +00:00
: player
isrexx? if posessed-rexx @ else
isneut? if Neut else Jaye then then ;
2020-02-18 01:43:14 +00:00
: 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 ;
2020-02-02 23:33:07 +00:00
2020-02-18 01:43:14 +00:00
: 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 objects @ and if
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 ;
2020-02-02 23:33:07 +00:00
: 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!
2020-02-18 01:43:14 +00:00
isjaye? if ( only jaye can have a party )
2020-02-02 23:33:07 +00:00
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! ;
2020-02-02 23:33:07 +00:00
: 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 )
2020-02-18 01:43:14 +00:00
: rexx-touch ( x y -- b )
2dup RUBBLE mapflag? if
tile 3 swap b! invalidate-map 0
else 2dup tile b@ 23 = if
move-player
S posessed-rexx @ entity.dir !
posessed-rexx @ entity>pos Neut entity.pos!
0 posessed-rexx !
drop drop 1
else drop drop 0 then then ;
2020-02-18 01:43:14 +00:00
: player-touch
isneut? if neut-touch else
isrexx? if rexx-touch else
jaye-touch then then ;
2020-02-02 23:33:07 +00:00
: 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 -- )
2020-02-18 01:43:14 +00:00
Jaye entity>pos <rot entity.pos! NODIR player.prevdir ! ;
2020-02-02 23:33:07 +00:00
: 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
2020-02-02 23:33:07 +00:00
: player-tick
^SPACE key-pressed player.state HASNEUT f@ and if
2020-02-18 01:43:14 +00:00
player.state ISPROG fnot!
isprog? if prog-view else human-view then
then
2020-02-02 23:33:07 +00:00
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 !
2020-02-22 20:15:00 +00:00
:| player.state HASGORD f@ not gord-present? and if Gord yield then
done |; ' entities redefine
2020-02-02 23:33:07 +00:00
:| 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 )
2020-02-02 23:33:07 +00:00
entities each EVTICK entity>do more
party each EVTICK entity>do more
2020-02-18 01:43:14 +00:00
Neut EVTICK entity>do
2020-02-02 23:33:07 +00:00
DEV if tick-mapedit jiles then
2020-02-02 23:33:07 +00:00
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
2020-02-02 23:33:07 +00:00
: full-draw
quaking @ not if
player entity.x @ 152 -
player entity.y @ 92 -
scroll
else
0 ticks 3 % 13 * 8 % scroll
then
2020-02-02 23:33:07 +00:00
2020-02-18 01:43:14 +00:00
party each draw-entity more
player.state HASNEUT f@ if Neut draw-entity then
objects @ if
objects @ links each dup obj-entity draw-entity more
then
2020-02-02 23:33:07 +00:00
entities each draw-entity more
DEV if
2020-02-02 23:33:07 +00:00
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 ;
2020-02-18 01:43:14 +00:00
var _dorubber
: rubber _dorubber @ not _dorubber ! ;
: {tileent} _dorubber @ if {duck} else {blank} then ;
: blankentity array here >r N ' {tileent} 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
2020-02-18 01:43:14 +00:00
entity>pos Neut 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 )
2020-02-18 01:43:14 +00:00
EVTOUCH = isneut? not 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
2020-02-22 20:15:00 +00:00
player.state HASGORD f@ not gord-present? and if
jaye say" I'm not leaving Gord behind."
else
responder entity.user @ queue-level
then
then |; listener! ;
: switch create-linked-object
:| dup EVTOUCH = isneut? and if move-player then
2020-02-18 01:43:14 +00:00
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 |; 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! ;
: defrexx array here >r S ' {rexx} allotentity <r
dup link-object
:| EVTOUCH = isneut? and if
move-player
responder posessed-rexx !
-100 -100 Neut entity.pos!
then |; listener! ;
2020-02-17 02:36:02 +00:00
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
2020-02-18 01:43:11 +00:00
: cancel-ev ( ev -- EVNOP ) drop EVNOP ;
2020-02-22 20:15:00 +00:00
Gord :noname
dup EVTOUCH = isjaye? and player.state HASGORD f@ not and if
move-player
1 player.state HASGORD f!
Gord follow
then chain-listener ;
2020-02-02 23:33:07 +00:00
:noname
reset-level
2020-02-17 02:36:02 +00:00
' mode-move ' tick redefine
2020-02-02 23:33:07 +00:00
' full-draw ' draw redefine
2020-02-22 20:15:00 +00:00
:| Jaye yield
player.state HASGORD f@ if Gord yield then
done |; ' party redefine
2020-02-17 02:36:02 +00:00
:| ' tick-debounce ' tick redefine |; ' any-job-started redefine
:| ' mode-move ' tick redefine hide-footer |; ' all-jobs-complete redefine
2020-02-02 23:33:07 +00:00
; ' onload redefine