ducks, space, mark user words

boot.jor

@@ -8,6 +8,7 @@ key ) const ')'
 key  const sp
 
 128 const F_IMMEDIATE
+0x100 const F_USERWORD
 
 : cr '\n' emit ;
 : bl sp emit ;

defs.jor

@@ -19,9 +19,11 @@
 : f! ( b v flag -- )
   >rot >r r@ @ >rot ( val flag b r: v )
   if | else ~ & then <r ! ;
-: f@ ( v flag -- ) swap @ & ;
+: f@ ( v flag -- b ) swap @ & ;
 : fnot! ( v flag -- ) over @ ^ swap ! ;
 
+: userword 1 latest wordflags F_USERWORD f! ;
+
 : expile state if , else execute then ;
 
 : :noname here $DOCOLON , ] ;
@@ -99,9 +101,14 @@
   while
     dup ` dup if type drop else drop . then bl ( cp i )
     1 + ( cp i+1 )
-  repeat drop drop then drop ;
+  repeat drop drop then drop ; userword
 
-: words latest links each dup wordname type bl more ;
+: words
+  latest links each
+    dup wordflags F_USERWORD f@ if
+      dup wordname type bl
+    then
+  more ;
 
 ( tasks )
 : mailbox 2 cells + ;
@@ -114,14 +121,14 @@
 : .wordin ( ptr -- )
   latest links each
     2dup > if wordname type drop 0 break then
-  more dup if . else drop then ;
+  more dup if . else drop then ; userword
 
 : tasks.s
   tasks links each
     dup .wordin s" : " type
     dup task-sp @ over task-stack ( task stackLim stack )
     begin 2dup > while dup @ . cell + repeat
-    cr drop drop more ;
+    cr drop drop more ; userword
 
 : doactivate ( task ip -- )
   over task-ip !

entity.jor

@@ -1,14 +1,14 @@
 0 const EVTICK
 1 const EVTOUCH
 
-: world>tile 4 >> swap 4 >> swap ;
+: world>tile 4 >> swap 4 >> swap ; userword
-: tile>world 4 << swap 4 << swap ;
+: tile>world 4 << swap 4 << swap ; userword
 
 : +pos ( x1 y1 x2 y2 -- x y )
-  <rot + >rot + swap ;
+  <rot + >rot + swap ; userword
 
 : -pos ( x1 y1 x2 y2 -- x y )
-  negate swap negate swap +pos ;
+  negate swap negate swap +pos ; userword
 
 : defentity ( x y dir anim -- ) array ' drop , , , tile>world , , ;
 : entity.x 4 cells + ;
@@ -16,8 +16,8 @@
 : entity.dir 2 cells + ;
 : entity>sprite cell + @ execute ;
 : entity>do ( entity event ) swap @ execute ;
-: entity>pos dup entity.x @ swap entity.y @ ;
+: entity>pos dup entity.x @ swap entity.y @ ; userword
-: entity.pos! ( x y entity ) <rot over entity.x ! entity.y ! ;
+: entity.pos! ( x y entity ) <rot over entity.x ! entity.y ! ; userword
 
 var entity-defstate
 : entitydo-ev ( [cp ifhere] ev -- )
@@ -71,6 +71,7 @@ array frames
 ( 6: jeanne stand ) 30 32 34 36 frame
 ( 7: jeanne walk ) 31 33 35 37 frame
 ( 8: boat w/ pete ) 42 41 40 39 frame
+( 9: duck ) 44 45 44 45 frame
 
 : sprindex ( dir frame ) 2 << frames + + b@ ;
 : defstatic ( frame -- ) create b, does> b@ sprindex ;
@@ -98,8 +99,10 @@ array frames
 38 defsingle {fridge}
 43 defsingle {boat}
 8 defstatic {boat-pete}
+9 defstatic {duck}
+46 defsingle {aliem}
 
 : sprite-bob ( x y sprindex -- x y sprindex )
-  ticks 40 % 20 < if
+  dup 39 >= over 46 <= and if
-    dup 39 >= over 43 <= and if swap 1 + swap then
+    >rot 2dup + ticks + 40 % 20 < if 1 + then <rot
   then ;

footer.jor

@@ -61,14 +61,14 @@ var texttimer
   s"                                  " dup dup 10 statusy 20 statusy 30 statusy
   text-color !
   textleft @ textx !
-  10 texty ! ;
+  10 texty ! ; userword
 
 : show-footer 48 10 footer-y move-to ;
 : hide-footer 0 10 footer-y move-to ;
 
 : footer-wait show-footer ^ENTER wait-key ;
 
-: say ( s -- ) textleftsay clear show-footer slowtext footer-wait ;
+: say ( s -- ) textleftsay clear show-footer slowtext footer-wait ; userword
 : say" [ ' s" , ] ' say expile ; immediate
 
 defer choosegen
@@ -106,11 +106,11 @@ var cchoose
 : character ( iportrait color ) create , ,
   does> dup @ text-color ! cell + @ draw-portrait ;
 
-0 GREEN character pete
+0 GREEN character pete userword
-1 MAGENTA character mary
+1 MAGENTA character mary userword
-2 BROWN character chuck
+2 BROWN character chuck userword
-3 YELLOW character jeanne
+3 YELLOW character jeanne userword
-4 LGRAY character phone
+4 LGRAY character phone userword
 
 : noone WHITE text-color ! s"     " dup dup dup
-  8 portraity 16 portraity 24 portraity 32 portraity ;
+  8 portraity 16 portraity 24 portraity 32 portraity ; userword

game.jor

@@ -26,20 +26,20 @@ defer entities
   more drop drop ;
 
 ( P L A Y E R )
-var player.state
+var player.state userword
 var player.prevdir
 
-1 const MOVING
+1 const MOVING userword
-2 const DRIVING
+2 const DRIVING userword
-4 const BOATING
+4 const BOATING userword
-8 const NOCLIP
+8 const NOCLIP userword
-16 const ISMARY
+16 const ISMARY userword
-32 const ISJEANNE
+32 const ISJEANNE userword
 
-: noclip player.state NOCLIP fnot! ;
+: noclip player.state NOCLIP fnot! ; userword
 
-: player.driving? player.state DRIVING f@ ;
+: player.driving? player.state DRIVING f@ ; userword
-: player.boating? player.state BOATING f@ ;
+: player.boating? player.state BOATING f@ ; userword
 
 : :playerwalk create , , does>
   player.state MOVING f@ not if cell + then @ execute ;
@@ -117,7 +117,7 @@ defer player-touch ( x y -- b )
 var q-level
 var q-player.x
 var q-player.y
-: queue-level q-level ! q-player.y ! q-player.x ! ;
+: queue-level q-level ! q-player.y ! q-player.x ! ; userword
 
 player :tick
   0 ^LEFT key-down if drop 1 W player entity.dir ! then
@@ -130,7 +130,7 @@ player :tick
 ( S T U F F )
 : reset-level
   :| done |; ' entities redefine
-  :| drop drop 0 |; ' player-touch redefine ;
+  :| drop drop 0 |; ' player-touch redefine ; userword
 
 : mode-move
   entities each EVTICK entity>do more

gameboot.jor

@@ -31,6 +31,7 @@ intern petehous.jor
 intern road.jor
 intern jeanne.jor
 intern trail1.jor
+intern space.jor
 intern mpete.jor
 intern mroad.jor
 intern mjeanne.jor

jiles.jor

@@ -84,7 +84,7 @@ var copysrc
   ^TAB key-pressed if
     jiles-old-draw @ ' draw redefine
     jiles-old-tick @ ' tick redefine
-    mousehide unfuck invalidate-map reloadtiles
+    mousehide unfuck invalidate-map reloadtiles load-footer
   then
   tick-debounce
 ;

jopl.jor

@@ -57,7 +57,7 @@ var op
 : freqon ( oct freq -- )
   dup 0xff & ar-freq adlib!
   8 >> 0x03 & swap 2 << | 0x20 | ar-note adlib! ;
-: noteoff ( -- ) 0 ar-note adlib! ;
+: noteoff ( -- ) 0 ar-note adlib! ; userword
 
 array semitones
 3520 3520 />ratio ,
@@ -91,44 +91,44 @@ array semitones
   ' ar-sr read-sbi-op-reg
   ' ar-wave read-sbi-op-reg
   fgetc ar-alg adlib!
-  close ;
+  close ; userword
 
 : rndbyte 256 rnd dup . ;
 : rndop rndbyte rndbyte rndbyte rndbyte rndbyte s" loadop " type loadop ;
 : rndinst s" op1 " type op1 rndop s" op2 " type op2 rndop
-	  rndbyte s" ar-alg adlib! " type cr ar-alg adlib! ;
+	  rndbyte s" ar-alg adlib! " type cr ar-alg adlib! ; userword
 
-: panic 9 -1 for i voice ! noteoff next ;
+: panic 9 -1 for i voice ! noteoff next ; userword
 
 var songticks
 
 var notestate
 var octave
-: oct+ octave @ 12 * + ;
+: oct+ octave @ 12 * + ; userword
-: rest songticks @ begin suspend dup songticks @ != until drop ;
+: rest songticks @ begin suspend dup songticks @ != until drop ; userword
-: beat begin dup songticks @ swap % 0 != while rest repeat drop ;
+: beat begin dup songticks @ swap % 0 != while rest repeat drop ; userword
-: %O octave ! ;
+: %O octave ! ; userword
-: %V voice ! ;
+: %V voice ! ; userword
 : mknote create b, does> ub@ oct+ notestate @ if b, else noteon rest then ;
-: %loop 0xfe b, , ;
+: %loop 0xfe b, , ; userword
 : mod % ;
-: % notestate @ if 0xf0 b, else rest then ;
+: % notestate @ if 0xf0 b, else rest then ; userword
-: %% 0 for % next ;
+: %% 0 for % next ; userword
-: %- notestate @ if 0xfd b, else noteoff then ;
+: %- notestate @ if 0xfd b, else noteoff then ; userword
-: %do 0xff b, , ;
+: %do 0xff b, , ; userword
 
-11 mknote G#
+11 mknote G# userword
-10 mknote G
+10 mknote G  userword
-9  mknote F#
+9  mknote F# userword
-8  mknote F
+8  mknote F  userword
-7  mknote E
+7  mknote E  userword
-6  mknote D#
+6  mknote D# userword
-5  mknote D
+5  mknote D  userword
-4  mknote C#
+4  mknote C# userword
-3  mknote C
+3  mknote C  userword
-2  mknote B
+2  mknote B  userword
-1  mknote A#
+1  mknote A# userword
-0  mknote A
+0  mknote A  userword
 
 array tracks 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
 
@@ -144,9 +144,9 @@ array tracks 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
 : track-tick ( i -- )
   track dup @ dotrack swap ! ;
 
-: :track create here 1 notestate ! does> voice @ track ! ;
+: :track create here 1 notestate ! does> voice @ track ! ; userword
-: ;track %loop 0 notestate ! ;
+: ;track %loop 0 notestate ! ; userword
-: shush 0 voice @ track ! %- ;
+: shush 0 voice @ track ! %- ; userword
 
 : prev-name ( wordname -- wordname )
   2 cells - @ 2 cells + ;
@@ -167,7 +167,7 @@ array tracks 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
 : emit-track ( 'track -- )
   -1 octave ! dup ` swap 2 cells +
   'name :track type bl swap type bl
-  begin dup ub@ emit-cmd while 1 + repeat drop ;
+  begin dup ub@ emit-cmd while 1 + repeat drop ; userword
 
 ( T E X T )
 
@@ -234,7 +234,7 @@ var textleft
 
 : trackstatus cr voice @ showtrack ;
 
-var tempo 1 tempo !
+var tempo userword 1 tempo !
 : player
   1 songticks +!
   songticks @ tempo @ mod 0 = if
@@ -257,7 +257,7 @@ var t2
 16 b, 3  b, 17 b, 4  b, 18 b, 19 b, 6  b, 20 b, 7  b, 21 b, 8  b, 22 b,
 23 b, 10 b, 24 b, 11 b, 25 b,
 |inline ] 0 29 for dup i + ub@ key-pressed if drop i 3 + rdrop rdrop ret then next
-  drop 51 key-pressed if 15 else 0 then ;
+  drop 51 key-pressed if 15 else 0 then ; userword
 
 : onkeynote ( cp -- ) keynote dup if oct+ swap execute else drop drop then ;
 
@@ -293,7 +293,7 @@ var stopkeys
      41 key-pressed if 0xfd setnote then
      52 key-down if 0xf0 setnote then
   |; dokeys
-  0x1f textattr ! ;
+  0x1f textattr ! ; userword
 
 : jamkeys
   stoponesc voicekeys
@@ -301,7 +301,7 @@ var stopkeys
   41 key-pressed if noteoff then
   88 key-pressed if rndinst then ;
 
-: jam ' jamkeys dokeys ;
+: jam ' jamkeys dokeys ; userword
 
 var menuscroll
 var menuy
@@ -360,9 +360,9 @@ defer onselect
 	key-menu if s" *.sbi" draw-filemenu then
 	28 key-pressed if 1 stopkeys ! then
      |; dokeys
-  |; 66 1 13 menu-at ;
+  |; 66 1 13 menu-at ; userword
 
-: dune ( -- ) s" dune" chdir inst s" .." chdir ;
+: dune ( -- ) s" dune" chdir inst s" .." chdir ; userword
 
 :noname
   9 -1 for i voice ! default next

jorth.c

@@ -572,11 +572,12 @@ void f_wordname() {
   TOP().p = TOP().p + 2;
 }
 void f_wordflags() {
-  TOP().u = TOP().p[1].u;
+  TOP().p = TOP().p + 1;
 }
+
 void f_codepointer() {
   unsigned int flags = TOP().p[1].u;
-  TOP().p = CELL_OFFSET(TOP().p + 2, (flags & ~F_IMMEDIATE) + 1);
+  TOP().p = CELL_OFFSET(TOP().p + 2, (flags & F_NAMELEN_MASK) + 1);
 }
 
 void f_lookup() { // name -- (codepointer flags) | (name 0)
@@ -587,8 +588,8 @@ void f_lookup() { // name -- (codepointer flags) | (name 0)
 
   while (entry) {
     PUSHP(entry);
-    f_wordflags();
+    f_wordflags(); f_get();
-    if (len == (TOP().u & ~F_IMMEDIATE)) {
+    if (len == (TOP().u & F_NAMELEN_MASK)) {
       PUSHS(name);
       PUSHP(entry);
       f_wordname();

jorth.h

@@ -36,6 +36,7 @@ extern cell W;
 extern cell *rstack;
 extern cell *stack;
 
+#define F_NAMELEN_MASK 0x7f
 #define F_IMMEDIATE 0x80
 
 #define CELL_OFFSET(cp, b) ((cell*)(((char *)(cp)) + b))

map.jor

@@ -31,6 +31,7 @@ array tileflags
 ( fence )      0 b,
 ( storefront ) 0 b,
 ( space )      0 b,
+( space2 )     BOATABLE b,
 
 here tileflags - 1 - const MAXTILE
 
@@ -61,7 +62,7 @@ here tileflags - 1 - const MAXTILE
   swap mapsize >r ( newh neww oldw r: oldh )
   2dup < if 1 <r else <r 1 - 0 then ( newh neww copyw ystart ylim )
   for 2dup i copy-mapseg next
-  drop swap mapsize! ;
+  drop swap mapsize! ; userword
 
 : mapw mapsize drop ;
 : maph mapsize nip ;
@@ -80,20 +81,20 @@ here tileflags - 1 - const MAXTILE
     3dup <rot memmove
     2dup < if mapw + swap mapw + swap
 	   else mapw - swap mapw - swap then
-  next drop drop drop invalidate-map ;
+  next drop drop drop invalidate-map ; userword
 
 : save-map ( filename -- )
   fdeactivate swap overwrite
   mapsize swap fput fput
   mapsize * map fwrite
-  factivate ;
+  factivate ; userword
 
 : load-map ( filename -- )
   fdeactivate swap open
   fget fget
   2dup * map fread
   mapsize!
-  factivate ;
+  factivate ; userword
 
 : fill-map ( tile -- )
-  0 mapsize * for dup map i + b! next drop invalidate-map ;
+  0 mapsize * for dup map i + b! next drop invalidate-map ; userword

pete.jor

@@ -3,6 +3,8 @@
 13 8 N ' {car} defentity car
 32 5 W ' {horse} defentity e_chuck
 17 10 W ' {boat} defentity boat
+26 10 W ' {duck} defentity duck1
+32 7 E ' {duck} defentity duck2
 
 car :touch
   move-player
@@ -23,6 +25,7 @@ e_chuck :touch
 :| player.driving? not CHUCK-FOLLOW flag@ not and if car yield then
    CHUCK-STOLEN flag@ if e_chuck yield then
    player.boating? not if boat yield then
+   duck1 yield duck2 yield
    done |; ' entities redefine
 
  :|
@@ -32,6 +35,8 @@ touch-begin S leaving? dup
     else move-player 5 10 road.jor queue-level
     then
   then
+touch-next N leaving? dup
+  if move-player 24 49 space.jor queue-level then
 touch-next 13 8 2= player.driving? and dup
   if move-player
     0 player.state DRIVING f!

space.jor

@@ -0,0 +1,26 @@
+( S P A C E )
+
+24 10 N ' {aliem} defentity aliem
+28 28 N ' {pete-bed} defentity bed
+19 21 N ' {phone} defentity e_phone
+
+aliem :touch
+  pete say" hey mr aliem"
+;entity
+
+:noname
+:| aliem yield bed yield e_phone yield done |; ' entities redefine
+
+:| touch-begin S leaving? dup
+  if move-player 0 glitchlevel ! 19 0 pete.jor queue-level then
+touch-next 5 11 2= dup
+  if move-player 41 37 tile>world player entity.pos! then
+touch-next 41 37 2= dup
+  if move-player 5 11 tile>world player entity.pos! then
+touch-next 44 23 2= dup
+  if pete say" It's...." say" home." then
+touch-last |; ' player-touch redefine
+
+s" space.map" load-map
+4 glitchlevel !
+; ' onload redefine

state.jor

@@ -1,10 +1,10 @@
-0 const JEANNE-ANGRY
+0 const JEANNE-ANGRY      userword
-1 const CHUCK-GONE
+1 const CHUCK-GONE        userword
-2 const CHUCK-FOLLOW
+2 const CHUCK-FOLLOW	  userword
-3 const CHUCK-HOME
+3 const CHUCK-HOME	  userword
-4 const CHUCK-STOLEN
+4 const CHUCK-STOLEN	  userword
-5 const CHUCK-EXPLAINED
+5 const CHUCK-EXPLAINED	  userword
-6 const NIGHT
+6 const NIGHT		  userword
 
 7 const FLAG-COUNT
 
@@ -12,12 +12,12 @@ array flags FLAG-COUNT 8 / 1 + allot
 
 : flagstof ( f -- v f ) dup 8 / flags + swap 8 % 1 swap << ;
 : flagsf! ( b f -- ) flagstof f! ;
-: flag@ ( f -- b ) flagstof f@ ;
+: flag@ ( f -- b ) flagstof f@ ; userword
-: setflag 1 swap flagsf! ;
+: setflag 1 swap flagsf! ; userword
-: clearflag 0 swap flagsf! ;
+: clearflag 0 swap flagsf! ; userword
 
-: day s" tiles.gfx" loadtiles invalidate-map NIGHT clearflag ;
+: day s" tiles.gfx" loadtiles invalidate-map NIGHT clearflag ; userword
-: night s" ntiles.gfx" loadtiles invalidate-map NIGHT setflag ;
+: night s" ntiles.gfx" loadtiles invalidate-map NIGHT setflag ; userword
 
 : {car-drive} NIGHT flag@ if {car-lit} else {car} then ;
 

testbed.c

@@ -155,6 +155,13 @@ void f_loadtiles() {
 
 #define TILES_GFX
 
+void f_load_footer() {
+  FILE *f = fopen("FOOTER.TIF", "rb");
+  TifImageMeta_t meta = tifLoadMeta(f);
+  tifLoadEGA(f, meta, 0, 48, 336);
+  fclose(f);
+}
+
 void game_init() {
   FILE *f;
   TifImageMeta_t meta;
@@ -173,10 +180,7 @@ void game_init() {
   tile_init();
   fillMap();
 
-  f = fopen("FOOTER.TIF", "rb");
+  f_load_footer();
-  meta = tifLoadMeta(f);
-  tifLoadEGA(f, meta, 0, 48, 336);
-  fclose(f);
 
   f = fopen("sprite.gfx", "rb");
   freadfar(f, sprites, NUM_SPRITES * SPRITE_STRIDE * 2);
@@ -580,6 +584,7 @@ void game_f_init(char *exe, char *bootjor) {
   CDEF("loadtiles", f_loadtiles);
   CDEF("glitch", f_glitch);
   CDEF("unfuck", tile_init);
+  CDEF("load-footer", f_load_footer);
   CDEF("fuck", f_resetvideo);
 
   CDEF("mouseshow", f_mouseshow);