catalog, jopl track rewrite, some sound effects

debug.jor

@@ -5,6 +5,7 @@
 var brk-xp
 var dbg-ip
 var dbg-task
+var dbg-emit
 defer dbg-cmd
 
 : dbg-first-ip ( xp -- [ip|0] )
@@ -27,8 +28,10 @@ defer dbg-cmd
   ' dbg-cmd tail
 
 : .dbg ( ip -- ip )
+  task-emit @ >r dbg-emit @ dup if task-emit ! else drop then
   cr dup .wordin s"  ip: " type dup . dup get-dbg-xp ` type cr
-  >r .s <r cr ;
+  >r .s <r cr
+  <r task-emit ! ;
 
 : debugger <r .dbg ' DBG-WAIT tail userword
 : debug ( xp -- ) dbg-first-ip .dbg ' DBG-WAIT tail userword

egamap.h

@@ -9,7 +9,7 @@
 #define SIZE_PORTRAITS (NUM_PORTRAITS << 7)
 
 #define OFF_FOOTER 0
-#define OFF_PAGE1 (OFF_FOOTER + SIZE_FOOTER)
-#define OFF_PAGE2 (OFF_PAGE1 + SIZE_PAGE)
+#define OFF_PAGE1 (((OFF_FOOTER + SIZE_FOOTER) + 0x100) & 0xff00)
+#define OFF_PAGE2 (((OFF_PAGE1 + SIZE_PAGE) + 0x100) & 0xff00)
 #define OFF_TILES (OFF_PAGE2 + SIZE_PAGE)
 #define OFF_PORTRAITS (OFF_TILES + SIZE_TILES)

game.jor

@@ -126,6 +126,7 @@ defer touch-override ( x y -- b )
 : rexx-touch ( x y -- b )
   2dup RUBBLE mapflag? isrexx? and if
     tile 3 swap b! invalidate-map 0
+    sfx-garbage
   else tile b@ REXX-POD = if
     move-player
     S posessed-rexx @ entity.dir !
@@ -359,7 +360,11 @@ does>
 
 : door-listener ( ev -- )
   dup entering-door? if move-player then
-  DOOR-OPENED DOOR-CLOSED handle-onoff ;
+  DOOR-CLOSED responder>tile? swap
+  DOOR-OPENED DOOR-CLOSED handle-onoff
+  DOOR-CLOSED responder>tile? != if
+    DOOR-CLOSED responder>tile? if sfx-doorclose else sfx-dooropen then
+  then ;
 
 : door create-object ' door-listener listener! ;
 
@@ -416,6 +421,7 @@ does>
   EVTOUCH = isneut? and COMP-ON responder>tile? and if
     linked-entity dup computer-on? if
       entity>pos Neut entity.pos!
+      sfx-zoop
     else drop then
   then ;
 

gameboot.jor

@@ -27,6 +27,7 @@ s" input.jor" loadfile
 s" timer.jor" loadfile
 s" entity.jor" loadfile
 s" footer.jor" loadfile
+s" sound.jor" loadfile
 s" title.jor" loadfile
 ; execute
 

jopl.jor

@@ -1,7 +1,8 @@
 ' putc task-emit !
 :noname s" debug.jor" loadfile ; execute
+' seremit dbg-emit !
 
-s" jopl.log" open seekend fdeactivate const LOGFILE
+-1 const LOGFILE
 : emit-log fdeactivate LOGFILE factivate fputc fdeactivate drop factivate ;
 : quit LOGFILE factivate close _quit ;
 
@@ -14,7 +15,6 @@ s" jopl.log" open seekend fdeactivate const LOGFILE
   s" .:: J O P L ( jean OPL2 print loop) ::." type cr
   dorepl ;
 task const REPL
-REPL start-repl
 
 : start-dbg activate ' seremit task-emit !
   s" .:: J D B G ( jean debugger) ::." type cr
@@ -109,7 +109,7 @@ array semitones
   current loadinst ; userword
 
 : write-sbi-op-reg ( offset -- )
-  dup current + b@ fputc current + 5 + b@ fputc ;
+  dup current + 5 + b@ fputc current + b@ fputc ;
 
 : writezeros ( n -- ) 0 for 0 fputc next ;
 : savesbi ( filename -- )
@@ -131,20 +131,23 @@ array semitones
 
 var songticks
 
+var beatcount
+4 beatcount !
+
 var notestate
 var octave
 : oct+ octave @ 12 * + ; userword
 : rest songticks @ begin suspend dup songticks @ != until drop ; userword
-: beat begin dup songticks @ swap % 0 != while rest repeat drop ; userword
+: beat begin dup songticks @ beatcount @ % 0 != while rest repeat drop ; userword
 : %O octave ! ; userword
 : %V voice ! ; userword
-: mknote create b, does> ub@ oct+ notestate @ if b, else noteon rest then ;
-: %loop 0xfe b, , ; userword
+: %loop 0xfe b, ; userword
 : mod % ;
 : % notestate @ if 0xf0 b, else rest then ; userword
 : %% 0 for % next ; userword
 : %- notestate @ if 0xfd b, else noteoff then ; userword
-: %do 0xff b, , ; userword
+
+: mknote create b, does> ub@ oct+ notestate @ if b, else noteon rest then ;
 
 11 mknote G# userword
 10 mknote G  userword
@@ -160,21 +163,37 @@ var octave
 0  mknote A  userword
 
 array tracks 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
+array tracks-start 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
 
 : track ( i -- p ) cells tracks + ;
-: dotrack ( ip -- ip )
-  dup if dup 1 + swap ub@ >r
-    r@ 0xff = if dup @ swap cell + swap execute then
-    r@ 0xfe = if @ dotrack then
-    r@ 0xfd = if noteoff then
-    r@ 0xf0 < if r@ noteon then
-  rdrop then ;
+: vtrack ( -- p ) voice @ track ;
 
-: track-tick ( i -- )
-  track dup @ dotrack swap ! ;
+: curr-track-start voice @ cells tracks-start + ;
+: track-tick ( -- )
+  vtrack @ >r r@ if ( r: track )
+    songticks @ curr-track-start @ - ( -- index )
 
-: :track create here 1 notestate ! does> voice @ track ! ; userword
-: ;track %loop 0 notestate ! ; userword
+    ( call instrument word if start of track )
+    dup not if r@ cell + @ execute then ( index -- index )
+
+    ( call "tick" word )
+    dup r@ @ execute ( index -- index )
+
+    2 cells + r@ + ub@ ( index -- note )
+    dup 0xf0 < if noteon
+    else dup 0xfd = if noteoff
+    else 0xfe = if songticks @ curr-track-start ! track-tick ( loop )
+    then then then
+  then rdrop ;
+
+: pad-track ( start end -- )
+  swap - beatcount @ mod ( s e -- cpad )
+  dup if 0 for % next else drop then ;
+
+: :track create ' drop , ' noop , here 1 notestate ! does>
+  beat vtrack ! songticks @ curr-track-start ! ; userword
+
+: ;track here pad-track %loop 0 notestate ! ; userword
 : shush 0 voice @ track ! %- ; userword
 
 : prev-name ( wordname -- wordname )
@@ -198,6 +217,9 @@ array tracks 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
   'name :track type bl swap type bl
   begin dup ub@ emit-cmd while 1 + repeat drop ; userword
 
+: emit-inst ( pinst -- )
+  11 -1 for dup i + ub@ . next drop s" instrument XXX" type cr ;
+
 ( T E X T )
 
 : setattr-to ( w -- ) 0 for attremit next ;
@@ -242,7 +264,7 @@ var tempo userword 1 tempo !
   1 songticks +!
   songticks @ tempo @ mod 0 = if
     voice @
-    0 10 for i voice ! i track-tick next
+    0 10 for i voice ! track-tick next
     voice !
   then ;
 
@@ -329,10 +351,11 @@ var menuw
 defer onselect
 
 : menu-at ( cp x y w -- )
-  :| menuw ! texty ! dup textx ! textleft ! ' emit-direct task-emit !
+  :| menuw ! texty ! dup textx ! textleft !
+     ' emit-direct task-emit ! 0 task-echo !
      0 menuscroll ! 0 menuy !
      execute ' noop ' onselect redefine |;
-  0 textleft task-emit preserving ;
+  0 textleft task-emit task-echo preserving ;
 
 : menu-lines ( -- count ) 24 texty @ - ;
 : menu-skip menuscroll @ 0 max ;
@@ -424,8 +447,6 @@ wordchain opbits
 0 0x03 bitfield @wave opbits
 ' opbits endwordchain
 
-array instreg ' ar-wave , ' ar-sr , ' ar-ad , ' ar-level , ' ar-flags ,
-
 : c+op current op @ not if 5 + then ;
 
 : count-links 0 swap links each swap 1 + swap more ;
@@ -488,7 +509,13 @@ algbits count-links const #algbits
 
 
 :noname
+  s" jopl.log" open seekend fdeactivate ' LOGFILE redefine
+  REPL start-repl
+
   9 -1 for i voice ! default loadinst next
   startt2
   ' emit-direct task-emit !
 ; ' onload redefine
+
+2 %O
+:track bassline C % % C % % % G % % % G % % G % % C % % C % % % G 8 %% ;track

lev00001.jor

@@ -1,6 +1,10 @@
 ( L E V E L 0 0 0 0 1 )
 
+202 13 128 0 17 244 0 39 201 241 18 0 instrument quake
+: sfx-quake quake 0 loadsfx %D ;
+
 : intro
+  sfx-quake
   30 sleep
   1 quaking !
   30 sleep
@@ -8,6 +12,7 @@
   hide-footer
   10 sleep
   0 quaking !
+  noteoff
   jaye say" That was an earthquake!"
 ;
 

sound.jor

@@ -0,0 +1,95 @@
+var voice
+var op
+
+: op-with-voice voice @
+  dup 5 > if 5 + then
+  dup 2 > if 5 + then
+  + op @ + ;
+: opreg create b, does> ub@ op-with-voice ;
+: voicereg create b, does> ub@ voice @ + ;
+
+0x20 opreg ar-flags
+0x40 opreg ar-level
+0x60 opreg ar-ad
+0x80 opreg ar-sr
+0xe0 opreg ar-wave
+0xc0 voicereg ar-alg
+
+0xa0 voicereg ar-freq
+0xb0 voicereg ar-note
+
+: op2 3 op ! ;
+: op1 0 op ! ;
+: loadop ( flags level ad sr wave -- )
+  ar-wave adlib!
+  ar-sr adlib!
+  ar-ad adlib!
+  ar-level adlib!
+  ar-flags adlib! ;
+
+: readop ( v -- )
+  >r r@ 4 + b@ r@ 3 + b@ r@ 2 + b@ r@ 1 + b@ <r b@ loadop ;
+
+: instrument ( alg f1 l1 ad1 sr1 w1 f2 l2 ad2 sr2 w2 -- )
+  array b, b, b, b, b, b, b, b, b, b, b, ;
+
+: loadinst ( p -- ) dup dup 5 + op1 readop op2 readop
+  10 + b@ ar-alg adlib! ;
+
+: freqon ( oct freq -- )
+  dup 0xff & ar-freq adlib!
+  8 >> 0x03 & swap 2 << | 0x20 | ar-note adlib! ;
+: noteoff ( -- ) 0 ar-note adlib! ; userword
+
+array semitones
+3520 3520 />ratio ,
+3729 3520 />ratio ,
+3951 3520 />ratio ,
+4186 3520 />ratio ,
+4435 3520 />ratio ,
+4699 3520 />ratio ,
+4978 3520 />ratio ,
+5274 3520 />ratio ,
+5588 3520 />ratio ,
+5920 3520 />ratio ,
+6272 3520 />ratio ,
+6645 3520 />ratio ,
+
+: note dup 12 / 8 % swap 12 % cells semitones + @ 440 swap *<ratio ;
+: noteon noteoff note freqon ;
+
+: panic 9 -1 for i voice ! noteoff next ; userword
+
+var octave
+: oct+ octave @ 12 * + ;
+: rest 2 sleep ;
+: mknote create b, does> ub@ oct+ noteon ;
+
+11 mknote %G# userword
+10 mknote %G  userword
+9  mknote %F# userword
+8  mknote %F  userword
+7  mknote %E  userword
+6  mknote %D# userword
+5  mknote %D  userword
+4  mknote %C# userword
+3  mknote %C  userword
+2  mknote %B  userword
+1  mknote %A# userword
+0  mknote %A  userword
+
+202 14 24 0 244 2 3 16 3 52 119 1 instrument garbinst
+202 1 4 0 248 190 0 0 39 214 79 0 instrument bink
+202 4 37 0 67 52 3 1 80 54 119 0 instrument zoop
+202 10 134 129 239 1 0 1 3 152 241 0 instrument doorinst
+
+task const SFX
+SFX :noname activate begin receive execute again ; execute
+
+: loadsfx ( inst oct -- ) octave ! loadinst ;
+: sfx-garbage garbinst 4 loadsfx %C ;
+: sfx-bink bink 6 loadsfx %C ;
+: sfx-confirm bink 6 loadsfx %C rest %E rest %C rest %G rest ;
+: sfx-zoop zoop 5 loadsfx %C ;
+: sfx-dooropen :| doorinst 4 loadsfx %C rest %E |; SFX send ;
+: sfx-doorclose :| doorinst 4 loadsfx %E rest %C |; SFX send ;

testbed.c

@@ -269,6 +269,7 @@ void game_init() {
   kbd_init();
   timer_init(TIMER_30HZ);
   text_init();
+  adlib_init();
 
   loadscr("title");
 /*  f = fopen("TITLE.TIF", "rb");
@@ -439,6 +440,13 @@ void f_loadscr() {
   DROP(1);
 }
 
+void f_system() {
+  kbd_cleanup();
+  system(TOP().s);
+  DROP(1);
+  kbd_init();
+}
+
 /* JILES */
 #define SCREEN_STRIDE 40
 
@@ -817,6 +825,8 @@ void game_f_init(char *exe, char *bootjor) {
   CDEF("loadscr", f_loadscr);
   CDEF("fuck", f_resetvideo);
   CDEF("boss", f_showboss);
+  CDEF("system", f_system);
+  CDEF("adlib!", f_adlib);
 
   CDEF("mouseshow", f_mouseshow);
   CDEF("mousehide", f_mousehide);
@@ -858,23 +868,6 @@ void f_poll() {
   }
 }
 
-void do_repl(char *exe) {
-  char buf[128];
-
-  f_init(exe);
-  CDEF("quit", f_quit);
-  CDEF("adlib", f_adlib);
-
-  f_loadfile("repl.jor");
-  f_taskloop();
-
-  while (!DONE) {
-    PUSHS(gets(buf));
-    f_runstring("REPL send");
-    f_taskloop();
-  }
-}
-
 int main(int argc, char *argv[]) {
   char *bootjor = "gameboot.jor";
 

title.jor

@@ -32,10 +32,11 @@ defer redraw-menu
   s" New Game" :| 1 startgame |; yield
   s" Continue" savedlevel @ if :| savedlevel @ startgame |; else 0 then yield
   s" Help" ' help yield
+  s" Catalog" :| s" catalog.exe" system fuck show-title-bg redraw-menu |; yield
   s" Quit" ' quit yield
   done ;
 var menu-selected
-: menu-y ( i -- y ) 12 * 90 + ;
+: menu-y ( i -- y ) 12 * 88 + ;
 : draw-menu
   0 menu-opts each
     if over menu-selected @ = if LGREEN else WHITE then else RED then
@@ -45,16 +46,16 @@ var menu-selected
     dup menu-selected @ = if 15 else sp then optionbg
     1 +
   more drop ;
-:noname WHITE text-color ! 21 9 8 72 box draw-menu ; ' redraw-menu redefine
+:noname WHITE text-color ! 21 10 8 72 box draw-menu ; ' redraw-menu redefine
 
 : exec-selected 0 menu-opts each swap drop
     over menu-selected @ = if
-      dup if execute else drop then break else drop
+      dup if sfx-confirm execute else drop then break else drop
     then 1 +
   more drop ;
 
 : menu-count 0 menu-opts each drop drop 1 + more ;
-: menu-select ( di -- ) menu-selected menu-count +!cycle draw-menu ;
+: menu-select ( di -- ) menu-selected menu-count +!cycle draw-menu sfx-bink ;
 
 :noname
   save.sav open fget close savedlevel !