Implement basic character-swapping mechanics, tutorial / intro level

entity.jor

@@ -1,5 +1,8 @@
 0 const EVTICK
 1 const EVTOUCH
+2 const EVACT
+3 const EVDEACT
+4 const EVTOG
 
 : world>tile 4 >> swap 4 >> swap ; userword
 : tile>world 4 << swap 4 << swap ; userword
@@ -10,12 +13,21 @@
 : -pos ( x1 y1 x2 y2 -- x y )
   negate swap negate swap +pos ; userword
 
-: defentity ( x y dir anim -- ) array ' drop , , , tile>world , , ;
+: allotentity ( x y dir anim -- ) ' drop , , , tile>world , , ;
+: defentity ( x y dir anim -- ) array allotentity ;
+var _responder
+: responder _responder @ ;
+: entity.user 5 cells + ;
 : entity.x 4 cells + ;
 : entity.y 3 cells + ;
 : entity.dir 2 cells + ;
 : entity>sprite cell + @ execute ;
-: entity>do ( entity event ) swap @ execute ;
+: entity>do ( entity event )
+  swap dup if
+    dup _responder !
+    @ execute
+  else drop drop then ;
+
 : entity>pos dup entity.x @ swap entity.y @ ; userword
 : entity.pos! ( x y entity ) <rot over entity.x ! entity.y ! ; userword
 
@@ -26,6 +38,7 @@ var entity-defstate
   ' dup , lit ' = , [ ' if , ] ;
 : :touch EVTOUCH entitydo-ev ; immediate
 : :tick EVTICK entitydo-ev ; immediate
+: :act EVACT entitydo-ev ; immediate
 : ;entity ( entity cp ifhere -- )
   [ ' then , ] ' drop , [ ' ; , ]
   0 entity-defstate ! swap ! ; immediate
@@ -88,6 +101,7 @@ array frames
   create b, dup b, 0 for b, next
   does> ( dir a -- ) swap drop lookup-frame ;
 
+-1 defsingle {{blank}}
 0 defstatic {car}
 5 defstatic {car-lit}
 1 defstatic {pete-stand}
@@ -108,6 +122,11 @@ array frames
 46 defsingle {aliem}
 13 14 2 5 defmulti {neut}
 
+var _dorubber
+: {blank} _dorubber @ if {duck} else {{blank}} then ;
+: rubber _dorubber @ not _dorubber ! ;
+
+
 : sprite-bob ( x y sprindex -- x y sprindex )
   dup 13 >= over 14 <= and if
     >rot 2dup + ticks + 40 % 20 < if 1 + then <rot

footer.jor

@@ -29,7 +29,7 @@ WHITE text-color !
 
 var textx
 var texty
-2 const textspeed
+100 ( 2 ) const textspeed
 var textleft
 : textleftsay 6 textleft ! ;
 : textleftchoice 8 textleft ! ;
@@ -106,11 +106,8 @@ var cchoose
 : character ( iportrait color ) create , ,
   does> dup @ text-color ! cell + @ draw-portrait ;
 
-0 GREEN character pete userword
+0 LGREEN character neut userword
-1 MAGENTA character mary userword
+3 LBLUE character jaye userword
-2 BROWN character chuck userword
-3 YELLOW character jeanne userword
-4 LGRAY character phone userword
 
 : noone WHITE text-color ! s"     " dup dup dup
   8 portraity 16 portraity 24 portraity 32 portraity ; userword

game.jor

@@ -21,10 +21,12 @@ 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
@@ -35,17 +37,15 @@ var player.prevdir
     isneut? if NEUTABLE else WALKABLE then mapflag?
   else drop drop 1 then ;
 
-12 9 N ' {jaye} defentity pjaye
+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!
+  1 player.state MOVING f!
-     player move-entity
+
-     0 player.state MOVING f!
-  |; sched
   isneut? not if ( only jaye can have a party )
     player.prevdir @ party each
       dup player != if
@@ -53,7 +53,10 @@ var player.prevdir
 	dup >rot entity.dir !
 	sched-move-entity <r
       else entity.dir @ player.prevdir ! then more drop
-  then ;
+  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 )
@@ -103,7 +106,8 @@ var q-player.y
 : queue-level q-level ! q-player.y ! q-player.x ! ; userword
 
 : player-tick
-  ^SPACE key-pressed if player.state ISNEUT fnot! then
+  ^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
@@ -143,15 +147,20 @@ var q-player.y
 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
-  pneut draw-entity
+  player.state HASNEUT f@ if pneut draw-entity then
 
   showmouse @ if
     mouseworldpos 4 draw-sprite

lev00001.jor

@@ -1,7 +1,100 @@
 ( L E V E L 0 0 0 0 1 )
 
+: intro
+  30 sleep
+  1 quaking !
+  30 sleep
+  jaye say" Woah!!..."
+  hide-footer
+  10 sleep
+  0 quaking !
+  jaye say" That was an earthquake!"
+;
+
+ 4 const COMP-OFF
+ 5 const COMP-ON
+ 9 const DOOR-CLOSED
+10 const DOOR-OPENED
+11 const SWITCH-OFF
+12 const SWITCH-ON
+
+: entity>tile ( entity -- tile ) entity>pos world>tile tile ;
+: entity>tile? ( entity expected - b ) swap entity>tile b@ = ;
+
+: 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 ' {blank} allotentity <r ;
+: door blankentity
+  :| dup EVTOUCH = isjaye? and responder DOOR-OPENED entity>tile? and if
+       move-player
+     then
+     DOOR-OPENED DOOR-CLOSED handle-onoff
+  |; swap ! ;
+
+: handle-link ( ev ontile -- )
+  swap statechange? if
+    responder swap entity>tile? if EVACT else EVDEACT then
+    responder entity.user @ swap entity>do
+  else drop then ;
+
+: switch blankentity swap ,
+  :| dup EVTOUCH = isneut? and if move-player then
+     dup EVTOUCH = if responder EVTOG entity>do then
+     dup SWITCH-ON SWITCH-OFF handle-onoff
+     SWITCH-ON handle-link |; swap ! ;
+
+: computer blankentity swap ,
+  :| dup EVTOUCH = isjaye? and if responder EVACT entity>do then
+     dup EVTOUCH = isneut? and if move-player then
+     dup COMP-ON COMP-OFF handle-onoff
+     COMP-ON handle-link |; swap ! ;
+
+: chainev ( entity xp -- ) swap dup @ , ! ; immediate
+
+12 9 door d1
+d1 :noname
+  dup EVTOUCH = isjaye? and d1 DOOR-CLOSED entity>tile? and if
+    jaye say" It won't open!"
+  then chainev ;
+d1 12 8 switch s1
+0 15 8 computer c1
+
+7 6 door d2
+d2 6 6 switch s2
+
+c1 :noname
+  dup EVTOUCH = isjaye? and if
+    player.state HASNEUT f@ not if
+      jaye say" Maybe Neut can help."
+      neut say" NEUT v0.71.4rc12\ONLINE"
+      neut say" PRESS SPACE TO TAKE CONTROL"
+      c1 entity>pos pneut entity.pos!
+      1 player.state HASNEUT f!
+    else
+      jaye say" Neut is running now.\I can hit the space bar\to control them."
+    then
+  then chainev ;
+
 :noname
-  :| done |; ' entities redefine
+  reset-level
+  :| d1 yield s1 yield c1 yield d2 yield s2 yield done |; ' entities redefine
+
+:| touch-begin 15 8 2= dup if
+then touch-last |; ' jaye-touch redefine
 
   s" lev00001.map" load-map
+(  ' intro sched )
+
 ; ' onload redefine

map.jor

@@ -18,6 +18,11 @@ array tileflags
 ( table )      0 b,
 ( chair )      0 b,
 ( table-brok ) 0 b,
+( door-close ) 0 b,
+( door-open )  WALKABLE b,
+( switch-off ) NEUTABLE b,
+( switch-on )  NEUTABLE b,
+( window )     0 b,
 
 here tileflags - 1 - const MAXTILE
 

testbed.c

@@ -232,7 +232,9 @@ void f_keyIsDown() {
 }
 
 void f_drawSprite() { // ( x y sprite -- )
+  if (TOP().i >= 0) {
     drawSprite(&sprites[TOP().i * SPRITE_STRIDE], ST2().i, ST1().i, NULL);
+  }
   DROP(3);
 }