finish level 5, some Jorth improvements, add timed switches

boot.jor

@@ -1,8 +1,8 @@
+0 const 0
+1 const 1
 2 const cell
 : cells cell * ;
 
-key ) const ')'
-
 10 const '\n'
 13 const '\r'
 key  const sp
@@ -23,8 +23,8 @@ key  const sp
 : again ' GOTO_ , , ; immediate
 : until ' BZ_ , , ; immediate
 
-: ( begin key ')' = until ; immediate
 : lit ' LIT_ , , ;
+: ( begin key [ key ) lit ] = until ; immediate
 
 : inline| ' INLINEDATA_ , here 0 , ;
 : |inline [ ' then , ] ;
@@ -33,10 +33,8 @@ key  const sp
 : :| inline| $DOCOLON , ; immediate
 : |; ' ret , |inline ; immediate
 
-key " const '"'
-
 : s" state if inline| else here then
-    begin key dup '"' != over 0 != and while b, repeat drop 0 b,
+    begin key dup [ key " lit ] != over 0 != and while b, repeat drop 0 b,
     state if |inline else dup here! then ; immediate
 
 : interpretword F_IMMEDIATE & state not or if execute else , then ;

defs.jor

@@ -114,6 +114,11 @@
     then
   more ;
 
+: lazy here $DODEFERRED , ' noop , ;
+: >lazy! latest codepointer swap redefine ;
+
+: dbg" [ ' s" , ] :| type bl .s cr |; expile ; immediate
+
 ( tasks )
 : mailbox 2 cells + ;
 : task-ip task-user-size cells + ;

game.jor

@@ -2,6 +2,8 @@
 defer party
 defer entities
 var objects
+var ticking-objects
+var visible-objects
 
 : obj-entity ( optr -- entity ) cell + @ ;
 
@@ -26,13 +28,14 @@ var posessed-rexx
 : isneut? isprog? posessed-rexx @ not and ; userword
 : isjaye? isprog? not ; userword
 : isrexx? isprog? posessed-rexx @ and ; userword
+: gord-follow? player.state HASGORD f@ ;
 
 : {jaye}
   isjaye? player.state MOVING f@ and
   if {jaye-walk} else {jaye-stand} then ;
 
 : {gord}
-  player.state HASGORD f@ if
+  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 ;
@@ -117,7 +120,7 @@ defer touch-override ( x y -- b )
 defer on-gord-sit
 
 : do-gord-sit ( x y -- b )
-  player.state HASGORD f@ isjaye? and if
+  isjaye? gord-follow? and if
     tile b@ CHAIR = if
       1 player.state GORDSIT f!
       player.prevdir @ Gord entity.dir !
@@ -171,13 +174,15 @@ var q-level
 : queue-level q-level ! ; userword
 
 : player-tick
-  ^SPACE key-pressed player.state HASNEUT f@ and if
+  ^SPACE key-pressed if player.state HASNEUT f@ if
     player.state ISPROG fnot!
     isprog? if prog-view else human-view then
-  then
+  then then
-  ^Z key-pressed player.state GORDSIT f@ and isjaye? and if
+  ^Z key-pressed if player.state GORDSIT f@ if
+    isprog? 0 player.state ISPROG f!
     activate-gord
-  then
+    player.state ISPROG f!
+  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
@@ -190,8 +195,12 @@ defer reset-level userword
 : mode-move
   player-tick
 
-(  objects @ if objects @ links each dup obj-entity EVTICK entity>do more
+  ticking-objects @ if
-  entities each EVTICK entity>do more
+    ticking-objects @ links
+    each dup obj-entity EVTICK entity>do more
+  then
+
+( entities each EVTICK entity>do more
   party each EVTICK entity>do more
   Neut EVTICK entity>do )
 
@@ -210,6 +219,11 @@ defer reset-level userword
   r@ entity.dir @ <r entity>sprite
   sprite-bob draw-sprite ;
 
+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 @ ;
+
 var glitchlevel
 var quaking
 
@@ -225,8 +239,8 @@ var quaking
   party each dup Jaye != if draw-entity else drop then more
   Jaye draw-entity
   player.state HASNEUT f@ if Neut draw-entity then
-  objects @ if
+  visible-objects@ if
-    objects @ links each dup obj-entity draw-entity more
+    visible-objects@ links each dup obj-entity draw-entity more
   then
   entities each draw-entity more
 
@@ -239,15 +253,23 @@ var quaking
 
 var defining-objects-head
 var defining-objects-ptr
-: objects: create here 0 ,
+: objects: create here 0 , 0 , 0 ,
   0 defining-objects-head !
   defining-objects-ptr !
-does> @ objects ! ;
+does>
+  dup @ objects !
+  dup cell + @ ticking-objects !
+  dup 2 cells + @ visible-objects ! ;
+
+: obj-link-head! ( index -- )
+  cells defining-objects-ptr @ + defining-objects-head @ swap ! ;
 
 : link-object ( entity -- )
-  here defining-objects-head @ , swap ,
+  here defining-objects-head @ , swap , defining-objects-head !
-  dup defining-objects-head !
+  0 obj-link-head! ;
-  defining-objects-ptr @ ! ;
+
+: 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@ = ;
@@ -259,16 +281,20 @@ does> @ objects ! ;
 
 : respondertile! ( tile -- ) responder entity>tile b! invalidate-map ;
 
-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 ;
 
+: 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-timed-object blankentity swap , swap , 0 ,
+  dup link-object obj-ticking! ;
+
 : listener! ( entity listener ) swap ! ;
 
 : handle-onoff ( ev on off -- )
@@ -288,7 +314,7 @@ var _dorubber
 
 : exitdoor create-linked-object
   :| dup door-listener entering-door? if
-    player.state HASGORD f@ not gord-present? and if
+    gord-follow? not gord-present? and if
       jaye say" I'm not leaving Gord behind."
     else
       responder entity.user @ queue-level
@@ -304,14 +330,31 @@ var _dorubber
     linked-entity swap entity>do
   else drop then ;
 
-: switch create-linked-object
+: handle-switch-touch ( ev -- )
-  :| dup EVTOUCH = isneut? and if move-player then
+  dup EVTOUCH = isneut? and if move-player then
-     dup EVTOUCH = isrexx? not and if
+  dup EVTOUCH = isrexx? not and if
-       responder EVTOG entity>do
+    responder EVTOG entity>do
-       isjaye? if wait-for-arrow-up then
+    isjaye? if wait-for-arrow-up then
-     then
+  then
-     dup SWITCH-ON SWITCH-OFF handle-onoff
+  dup SWITCH-ON SWITCH-OFF handle-onoff
-     SWITCH-ON handle-link |; listener! ;
+  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? ;
 
@@ -339,7 +382,7 @@ var _dorubber
      SCAN-ON handle-link |; listener! ;
 
 : defrexx array here >r S ' {rexx} allotentity <r
-  dup link-object
+  dup link-object obj-visible!
   :| EVTOUCH = isneut? and if
        move-player
        responder posessed-rexx !
@@ -359,7 +402,7 @@ var _dorubber
 : with-gord Gord follow 1 player.state HASGORD f! ;
 
 Gord :noname
-  dup EVTOUCH = isjaye? and player.state HASGORD f@ not and if
+  dup EVTOUCH = isjaye? and gord-follow? not and if
     player.state GORDSIT f@ if
       1 player.state HASGORD f!
       Gord player face
@@ -373,10 +416,10 @@ Gord @ const gord-listener
 : chain-gord-listener gord-listener execute ;
 
 :noname
-  0 objects !
+  0 objects ! 0 ticking-objects ! 0 visible-objects !
   Gord gord-listener listener!
   ' noop ' on-gord-sit redefine
-  :| player.state HASGORD f@ not gord-present? and if Gord yield then
+  :| gord-follow? not gord-present? and if Gord yield then
      done |; ' entities redefine
   :| drop drop 0 |; ' touch-override redefine ; ' reset-level redefine
 
@@ -385,7 +428,7 @@ Gord @ const gord-listener
   ' mode-move ' tick redefine
   ' full-draw ' draw redefine
   :| Jaye yield
-     player.state HASGORD f@ if Gord yield then
+     gord-follow? if Gord yield then
      done |; ' party redefine
   :| ' tick-debounce ' tick redefine |; ' any-job-started redefine
   :| ' mode-move ' tick redefine hide-footer |; ' all-jobs-complete redefine

jorth.c

@@ -1,6 +1,7 @@
 //#define TRACE
 
 #include <stdio.h>
+#include <stdlib.h>
 #include <sys/stat.h>
 #include <dos.h>
 #include <dir.h>
@@ -1072,6 +1073,10 @@ void f_taskusersize() {
   PUSHU(TASK_USER_SIZE);
 }
 
+void f_rand() {
+  PUSHI(rand());
+}
+
 void f_init(char *exe) {
   f_calc_imagemagic(exe);
 
@@ -1202,6 +1207,7 @@ void f_init(char *exe) {
   CDEF("stacksize", f_stacksize);
   CDEF("rstacksize", f_rstacksize);
   CDEF("task-user-size", f_taskusersize);
+  CDEF("rand", f_rand);
   PCONST("$DOCREATE", f_docreate);
   PCONST("$DOVAR", f_dovar);
   PCONST("$DODEFERRED", f_dodeferred);

lev00005.jor

@@ -2,25 +2,96 @@
 
 objects: O
 
+lazy 60 over 19 9 timedswitch ts
+
 16 7 defrexx Rexx
+9 3 defrexx Rexx2
+
+13 6 door d1
+10 9 door d2
+5 6 door d3 >lazy!
+10 2 door d4
+end.jor 5 12 exitdoor dx
+
+lazy dup 11 3 computer c1
+' c1 7 11 computer c2 >lazy!
+lazy dup 7 5 computer c3
+' c3 2 11 computer c4 >lazy!
+
+' d2 10 10 scanner s1
+' dx 4 12 scanner sx
+
+' d4 7 1 switch b1
+' d1 19 3 switch b2
 
 :noname 0 MAXTILE for i tileflags + b@ RUBBLE & if i b, then next ;
 array rubbletiles execute
 here rubbletiles - 1 - const MAXRUBBLE
 
-: randomrubble ticks MAXRUBBLE % rubbletiles + b@ ;
+: randomrubble rand MAXRUBBLE % rubbletiles + b@ ;
 
 : rexx-pos ( -- x y ) Rexx entity>pos world>tile ;
 : rexx-dest ( -- x y ) rexx-pos Rexx entity.dir @ dir>pos +pos ;
 
-: can-drop-rubble? ( -- b ) rexx-pos tile b@ CARPET = ;
+: can-drop-rubble? ( -- b )
+  rexx-pos tile b@ CARPET =
+  rexx-dest tile b@ CARPET = and ;
+
 : not-picking-up? ( -- b ) rexx-dest RUBBLE mapflag? not ;
 
 : touch ( x y -- b )
-  drop drop
+  drop 13 <= isrexx? and posessed-rexx @ Rexx = and if
-  not-picking-up? can-drop-rubble? and isrexx? and if
+    3 glitchlevel !
-    randomrubble rexx-pos tile b! invalidate-map
+    rexx say" PaRiTy ErrRor!!"
-  then 0 ;
+    0 glitchlevel !
+    1
+  else
+    not-picking-up? can-drop-rubble? and isrexx? and if
+      randomrubble rexx-pos tile b! invalidate-map
+    then 0
+  then ;
+
+var first-rexx-touch
+Rexx :noname
+  dup EVTOUCH = isneut? and first-rexx-touch @ not and if
+    1 first-rexx-touch !
+    rexx say" bOSssS..."
+    rexx say" i doN'T fEEl so\gooOO00dddDdDd..."
+  then chain-listener ;
+
+var first-rexx2-touch
+Rexx2 :noname
+  dup EVTOUCH = isneut? and first-rexx2-touch @ not and if
+    1 first-rexx2-touch !
+    neut say" REXX UNIT\PERFORM FULL DIAGNOSTIC SCAN"
+    rexx say" I'm in tip-top shape, boss!"
+    neut say" ACTIVATING RELIEF SUBROUTINE"
+  then chain-listener ;
+
+: mr ( dir -- ) Rexx entity.dir ! Rexx move-entity ;
+
+d2 :noname
+  dup entering-door?
+  isjaye? and
+  gord-follow? not and
+  Rexx entity>pos drop 0 > and
+  if
+    move-player
+    W mr
+    rexx say" daaAiisSyyy, daAAIIsYY..." hide-footer
+    W mr
+    W mr
+    rexx say" gIVe mE YOur AnSwerR\doOO0OO0o0oooOO..." hide-footer
+    N mr
+    N mr
+    rexx say" uh oh" hide-footer
+    Rexx entity>pos world>tile -1 -1 +pos
+    dup 3 + for dup over 3 + i >rot for i over ( x y )
+      tile randomrubble swap b! invalidate-map 1 sleep
+    next drop next drop
+    -100 -100 Rexx entity.pos!
+    drop EVNOP
+  then chain-listener ;
 
 :noname O
 

testbed.c

@@ -3,6 +3,8 @@
 #include <dos.h>
 #include <alloc.h>
 #include <ctype.h>
+#include <stdlib.h>
+#include <time.h>
 
 #include "video.h"
 #include "kbd.h"
@@ -742,6 +744,7 @@ int main(int argc, char *argv[]) {
   if (argc > 1) {
     bootjor = argv[1];
   }
+  randomize();
   ser_init(SER_COM2, BAUD_19200, SER_8N1);
   game_init();
   game_f_init(argv[0], bootjor);

timer.jor

@@ -33,5 +33,6 @@
     >rot suspend
   repeat rdrop drop drop drop drop ;
 
+: still-waiting? ( count ticks-start -- ) ticks udelta u> ;
 : sleep ( count -- )
-  ticks swap begin over ticks udelta over u< while suspend repeat drop drop ;
+  ticks begin 2dup still-waiting? while suspend repeat drop drop ;