JOPL improvements, Gord can sit in chairs now

dtext.c

@@ -0,0 +1,29 @@
+#include <dos.h>
+#include "dtext.h"
+
+int dtext_x = 0;
+int dtext_y = 0;
+int dtext_left = 0;
+int dtext_attr = 0x1f;
+
+void dtext_emit(char c) {
+  if (c == '\n') {
+    dtext_cr();
+    return;
+  }
+  if (c == '\r') return;
+  WDTEXT[dtext_x + (dtext_y * 80)] = (c) | (dtext_attr << 8);
+  dtext_x ++;
+  if (dtext_x >= 80) {
+    dtext_cr();
+  }
+
+}
+
+void dtext_emitattr(char attr) {
+  DTEXT[(dtext_x << 1) + (dtext_y * 160) + 1] = attr;
+  dtext_x ++;
+  if (dtext_x >= 80) {
+    dtext_cr();
+  }
+}

dtext.h

@@ -0,0 +1,13 @@
+/* D I R E C T   T E X T M O D E */
+
+extern int dtext_x;
+extern int dtext_y;
+extern int dtext_left;
+extern int dtext_attr;
+
+#define DTEXT ((volatile char far *)MK_FP(0xb800, 0))
+#define WDTEXT ((volatile int far *)MK_FP(0xb800, 0))
+
+#define dtext_cr() { dtext_x = dtext_left; dtext_y ++; }
+void dtext_emit(char c);
+void dtext_emitattr(char attr);

end.jor

@@ -1,10 +1,9 @@
 ( E N D )
 
 :noname
-  reset-level
-
   s" end.map" load-map
   7 11 tile>world Jaye entity.pos!
   6 12 tile>world Neut entity.pos!
+  with-gord
 
 ; ' onload redefine

entity.jor

@@ -58,6 +58,8 @@ var _responder
       0 > if E else NODIR then then then then ;
 
 : facing ( x1 y1 x2 y2 -- dir ) -pos pos>dir ;
+: face ( e1 e2 -- )
+  over swap entity>pos <rot entity>pos facing swap entity.dir ! ;
 
 : entity-dst ( e -- x y )
   >r r@ entity.dir @ dir>pos
@@ -94,7 +96,8 @@ array frames
   does> ( dir a -- ) swap drop lookup-frame ;
 
 -1 defsingle {blank}
-0 defsingle {gord-sit}
+0 defsingle {gord-floor}
+1 defsingle {gord-sit}
 0 defstatic {gord-stand}
 0 1 2 5 defanim {gord-walk}
 2 defstatic {jaye-stand}

game.jor

@@ -14,6 +14,7 @@ var player.prevdir
 4 const HASNEUT userword
 8 const HASGORD userword
 16 const ISPROG userword
+32 const GORDSIT userword
 
 1 player.state HASNEUT f!
 
@@ -32,9 +33,9 @@ var posessed-rexx
 
 : {gord}
   player.state HASGORD f@ if
-    isjaye? player.state MOVING f@ and
+    isjaye? player.state MOVING f@ and player.state GORDSIT f@ or
     if {gord-walk} else {gord-stand} then
-  else {gord-sit} then ;
+  else player.state GORDSIT f@ if {gord-sit} else {gord-floor} then then ;
 
 : player.canmove? ( x y -- )
   player.state NOCLIP f@ not if
@@ -100,24 +101,44 @@ var posessed-rexx
   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 )
+defer touch-override ( x y -- b )
 
 : rexx-touch ( x y -- b )
-  2dup RUBBLE mapflag? if
+  2dup RUBBLE mapflag? isrexx? and if
     tile 3 swap b! invalidate-map 0
-  else 2dup tile b@ REXX-POD = if
+  else tile b@ REXX-POD = 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 ;
+    1
+  else 0 then then ;
 
-: player-touch
-  isneut? if neut-touch else
-  isrexx? if rexx-touch else
-	     jaye-touch then then ;
+defer on-gord-sit
+
+: do-gord-sit ( x y -- b )
+  player.state HASGORD f@ isjaye? 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 entity-at EVTOUCH entity>do ;
+
+: activate-gord
+  Gord entity>pos world>tile
+  2dup N activate-dir
+  2dup S activate-dir
+  2dup E activate-dir
+       W activate-dir ;
 
 : touch-begin each 2dup more >rot drop drop ;
 : touch-next dup if rdrop done then drop rswap ;
@@ -126,7 +147,9 @@ defer neut-touch ( x y -- b )
 
 : check-player-touch ( x y -- b )
   touch-begin entity-at dup if EVTOUCH entity>do 1 then
-  touch-next player-touch
+  touch-next touch-override
+  touch-next rexx-touch
+  touch-next do-gord-sit
   touch-next out-of-bounds
   touch-next player.canmove? not ;touch
 
@@ -142,7 +165,6 @@ defer neut-touch ( x y -- b )
   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
@@ -153,6 +175,9 @@ var q-level
     player.state ISPROG fnot!
     isprog? if prog-view else human-view then
   then
+  ^Z key-pressed player.state GORDSIT f@ and isjaye? and if
+    activate-gord
+  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
@@ -160,22 +185,19 @@ var q-level
   if ' try-move-player sched then ;
 
 ( S T U F F )
-: reset-level
-  0 objects !
-  :| player.state HASGORD f@ not gord-present? and if Gord yield then
-     done |; ' entities redefine
-  :| drop drop 0 |; ' jaye-touch redefine
-  :| drop drop 0 |; ' neut-touch redefine ; userword
+defer reset-level userword
 
 : mode-move
   player-tick
-(  objects @ if objects @ links each dup obj-entity EVTICK entity>do more )
+
+(  objects @ if objects @ links each dup obj-entity EVTICK entity>do more
   entities each EVTICK entity>do more
   party each EVTICK entity>do more
-  Neut EVTICK entity>do
+  Neut EVTICK entity>do )
 
   DEV if tick-mapedit jiles then
   tick-debounce
+
   q-level @ dup if
     0 q-level !
     reset-level
@@ -200,7 +222,8 @@ var quaking
     0 ticks 3 % 13 * 8 % scroll
   then
 
-  party each draw-entity more
+  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
     objects @ links each dup obj-entity draw-entity more
@@ -337,10 +360,25 @@ var _dorubber
 
 Gord :noname
   dup EVTOUCH = isjaye? and player.state HASGORD f@ not and if
-    move-player
-    with-gord
+    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
+  0 objects !
+  Gord gord-listener listener!
+  ' noop ' on-gord-sit redefine
+  :| player.state HASGORD f@ not gord-present? and if Gord yield then
+     done |; ' entities redefine
+  :| drop drop 0 |; ' touch-override redefine ; ' reset-level redefine
 
 :noname
   reset-level

gameboot.jor

@@ -1,7 +1,7 @@
 : blah ' seremit task-emit ! ;
 blah
 
-0 const DEV
+1 const DEV
 
 : devon 1 ' DEV redefine ;
 
@@ -35,10 +35,11 @@ intern lev00001.jor
 intern lev00002.jor
 intern lev00003.jor
 intern lev00004.jor
+intern lev00005.jor
 intern end.jor
 
 :noname loadfile ; checkpoint _loadlevel
 ' _loadlevel ' loadlevel redefine
 
-lev00004.jor loadlevel
+lev00005.jor loadlevel
 

jopl.c

@@ -6,6 +6,7 @@
 #include "kbd.h"
 #include "timer.h"
 #include "serial.h"
+#include "dtext.h"
 
 cell ontick = 0;
 void f_adlib_read() {
@@ -79,6 +80,14 @@ void f_random() {
   TOP().i = random(TOP().i);
 }
 
+void f_dtextemit() {
+  dtext_emit(TOP().i);
+  DROP(1);
+}
+void f_dtextemitattr() {
+  dtext_emitattr(dtext_attr);
+}
+
 void do_repl(char *exe) {
   adlib_init();
 
@@ -96,6 +105,13 @@ void do_repl(char *exe) {
   CDEF("key-pressed", f_keyWasPressed);
   CDEF("key-down", f_keydown);
   CDEF("rnd", f_random);
+  PCONST("textx", &dtext_x);
+  PCONST("texty", &dtext_y);
+  PCONST("textleft", &dtext_left);
+  PCONST("textattr", &dtext_attr);
+  CDEF("emit-direct", f_dtextemit);
+  CDEF("attremit", f_dtextemitattr);
+
   f_loadfile("jopl.jor");
   ontick = f_lookupcp("ontick");
   timer_setcallback(timer_callback);

jopl.jor

@@ -171,35 +171,9 @@ array tracks 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
 
 ( T E X T )
 
-var textx
-var texty
-var textattr
-var textleft
-0x1f textattr !
+: setattr-to ( w -- ) 0 for attremit next ;
 
-: out-direct ( c -- )
-  textattr @ 8 << |
-  texty @ 160 * textx @ 1 << +
-  0xb800 !far ;
-
-: setattr-to ( w -- )
-  texty @ 80 * textx @ +
-  dup <rot +
-  textattr @ >rot
-  for dup i 1 << 1 + 0xb800 b!far next drop ;
-
-: clearline
-  textattr @ 8 <<
-  texty @ 80 * textx @ +
-  texty @ 1 + 80 *
-  for dup i 1 << 0xb800 !far next drop ;
-
-: +textx! ( n -- )
-  textx @ + dup 80 >= if drop cr else textx ! then ;
-: emit-direct ( c -- )
-  dup '\n' = if textleft @ textx ! 1 texty +! drop else
-  dup '\r' = if drop else
-  out-direct 1 +textx! then then ;
+: clearline begin 0 emit-direct textx @ textleft @ = until ;
 
 : rpad ( n -- )
   textleft @ + textx @ for bl next ;
@@ -232,7 +206,7 @@ var textleft
   track @ dup if 20 0 for emit-status-cmd next then drop
   clearline ;
 
-: trackstatus cr voice @ showtrack ;
+: trackstatus voice @ showtrack ;
 
 var tempo userword 1 tempo !
 : player
@@ -250,7 +224,8 @@ var t2
   t2 @ 0x03 adlib!
   0x42 0x04 adlib! ;
 
-: ontick startt2 player ' status 0 textleft textx texty preserving ( trackstatus ) ;
+: ontick startt2 player
+  :| status trackstatus |; 0 textleft textx texty preserving ;
 
 : keynote [ inline|
 44 b, 31 b, 45 b, 32 b, 46 b, 47 b, 34 b, 48 b, 35 b, 49 b, 36 b, 50 b,
@@ -301,7 +276,7 @@ var stopkeys
   41 key-pressed if noteoff then
   88 key-pressed if rndinst then ;
 
-: jam ' jamkeys dokeys ; userword
+: jam ( todo: print? ) ' jamkeys dokeys ; userword
 
 var menuscroll
 var menuy

lev00001.jor

@@ -59,8 +59,7 @@ sexit :noname
     jaye say" Neut might be able to\hack it..."
   then chain-listener ;
 
-:noname              
-  reset-level O
+:noname O
 
   s" lev00001.map" load-map
   0 player.state HASNEUT f!

lev00002.jor

@@ -48,8 +48,7 @@ c2 :noname
     neut say" THIS INCIDENT HAS\BEEN REPORTED"
   then chain-listener ;
 
-:noname
-  reset-level O
+:noname O
 
   s" lev00002.map" load-map
   11 11 tile>world Jaye entity.pos!

lev00003.jor

@@ -96,7 +96,10 @@ d2 :noname
   then chain-listener ;
 
 var gord-up
-Gord :noname
+
+:noname O
+
+  Gord :|
   dup EVTOUCH = isrexx? and if
     gord say" AHHH NOOO\NOT GARBAGE\I AM NOT GARBAGE"
     rexx say" Whatever you say, boss!"
@@ -107,7 +110,7 @@ Gord :noname
     jaye say" Here, let me help you up."
     hide-footer
   then
-  dup chain-listener
+  dup chain-gord-listener
   EVTOUCH = isjaye? and gord-up @ not and if
     1 gord-up !
     gord say" Thanks."
@@ -115,10 +118,7 @@ Gord :noname
     jaye say" I can help you get around if\you help me navigate this\maze of a security system."
     gord say" I'm just as eager to get\out of here as you."
     gord say" Let's go."
-  then ;
-
-:noname
-  reset-level O
+  then |; listener!
 
   s" lev00003.map" load-map
   7 11 tile>world Jaye entity.pos!

lev00004.jor

@@ -5,7 +5,7 @@ objects: O
 15 6 door d1
 11 6 door d2
 10 4 door d3
-end.jor 0 4 exitdoor dx
+lev00005.jor 0 4 exitdoor dx
 
 15 11 defrexx Rexx
 
@@ -25,8 +25,16 @@ defer c1-targ
 
 :noname c2 computer-on? if c2 else c3 then ; ' c1-targ redefine
 
-:noname
-  reset-level O
+var first-gord-sit
+
+:noname O
+
+  :| first-gord-sit @ not if
+       1 first-gord-sit !
+       gord say" Phew, it feels good to\rest my leg for a bit."
+       gord say" If you need me to do something\from my chair, you can press\the Z key."
+     then
+  |; ' on-gord-sit redefine
 
   s" lev00004.map" load-map
   18 4 tile>world Jaye entity.pos!

lev00005.jor

@@ -0,0 +1,34 @@
+( L E V 0 0 0 0 5 )
+
+objects: O
+
+16 7 defrexx Rexx
+
+: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@ ;
+
+: 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 = ;
+: not-picking-up? ( -- b ) rexx-dest RUBBLE mapflag? not ;
+
+: touch ( x y -- b )
+  drop drop
+  not-picking-up? can-drop-rubble? and isrexx? and if
+    randomrubble rexx-pos tile b! invalidate-map
+  then 0 ;
+
+:noname O
+
+  ' touch ' touch-override redefine
+
+  s" lev00005.map" load-map
+  18 4 tile>world Jaye entity.pos!
+  19 5 tile>world Neut entity.pos!
+  with-gord
+
+; ' onload redefine

map.jor

@@ -37,8 +37,10 @@ array tileflags
 
 here tileflags - 1 - const MAXTILE
 
+ 3 const CARPET
  4 const COMP-OFF
  5 const COMP-ON
+ 7 const CHAIR
  9 const DOOR-CLOSED
 10 const DOOR-OPENED
 11 const SWITCH-OFF