jopl: implement interactive instrument loading menu

defs.jor

@@ -64,6 +64,8 @@
 : min ( x y -- x|y ) 2dup > if swap then drop ;
 : max ( x y -- x|y ) 2dup < if swap then drop ;
 
+: +!pos ( n var -- ) dup @ <rot + 0 max swap ! ;
+
 : checkpoint ( cp -- )
   create here 4 cells + , latest , tasks , ,
   does> dup @ here!
@@ -73,6 +75,13 @@
 
 : intern create latest wordname , does> @ ;
 
+: preserving ( cp 0 vars... -- )
+  0 r> begin dup while dup @ r> r> repeat drop
+  execute
+  begin r@ while r< r< swap ! repeat rdrop ;
+: preserve ( cp var -- ) 0 swap preserves ;
+
+
 : decompile
   word lookup if 1 begin ( cp i )
     2dup cells + @ ( cp i @cp+i )

jopl.c

@@ -3,6 +3,7 @@
 #include "adlib.h"
 #include "kbd.h"
 #include "timer.h"
+#include "serial.h"
 
 cell ontick = 0;
 void f_adlib_read() {
@@ -64,12 +65,22 @@ char *gather_input() {
   return NULL;
 }
 
+void f_seremit() {
+  ser_write_byte(TOP().i);
+  if (TOP().i == '\n') {
+    ser_write_byte('\r');
+  }
+  DROP(1);
+}
+
 void do_repl(char *exe) {
   adlib_init();
 
   timer_init(TIMER_18HZ);
   f_init(exe);
 
+  ser_init(SER_COM2, BAUD_19200, SER_8N1);
+  CDEF("seremit", f_seremit);
   CDEF("_quit", f_quit);
   CDEF("adlib!", f_adlib_write);
   CDEF("adlib@", f_adlib_read);

jopl.jor

@@ -3,6 +3,10 @@ s" jopl.log" open seekend fdeactivate const LOGFILE
 : emit-log fdeactivate LOGFILE factivate fputc fdeactivate drop factivate ;
 : quit LOGFILE factivate close _quit ;
 
+
+: DBG :| ' seremit task-emit ! execute cr |; 0 task-emit preserving ;
+: DTYPE ' type DBG ;
+
 : start-repl activate
   ' putc task-emit ! ' emit-log task-echo !
   s" .:: J O P L ( jean OPL2 print loop) ::." type cr
@@ -164,6 +168,7 @@ array tracks 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
 var textx
 var texty
 var textattr
+var textleft
 0x1f textattr !
 
 : out-direct ( c -- )
@@ -171,6 +176,12 @@ var textattr
   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 @ +
@@ -180,12 +191,15 @@ var textattr
 : +textx! ( n -- )
   textx @ + dup 80 >= if drop cr else textx ! then ;
 : emit-direct ( c -- )
-  dup '\n' = if 0 textx ! 1 texty +! drop else
+  dup '\n' = if textleft @ textx ! 1 texty +! drop else
   dup '\r' = if drop else
   out-direct 1 +textx! then then ;
 
+: rpad ( n -- )
+  textleft @ + textx @ for bl next ;
+
 : status
-  0 textx ! 0 texty !
+  0 textx ! 0 texty ! 0 textleft !
   s"  V: " type voice @ .
   s"  O: " type octave @ .
   s"  T: " type songticks @ .
@@ -225,7 +239,7 @@ var t2
   t2 @ 0x03 adlib!
   0x42 0x04 adlib! ;
 
-: ontick startt2 player status trackstatus ;
+: ontick startt2 player ' status 0 textleft textx texty preserving ( trackstatus ) ;
 
 : 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,
@@ -236,16 +250,18 @@ var t2
 
 : onkeynote ( cp -- ) keynote dup if oct+ swap execute else drop drop then ;
 
+var stopkeys
+: stoponesc 1 key-pressed if 1 stopkeys ! then ;
+: voicekeys
+  78 key-pressed if 1 octave +! then
+  74 key-pressed if -1 octave +! then
+  75 key-pressed if -1 +voice! then
+  77 key-pressed if 1 +voice! then ;
+
 : dokeys ( cp -- )
-  r> key-start begin
+  r> 0 stopkeys ! key-start begin
-    key-debounce 1 key-pressed not while
+    key-debounce r@ execute suspend
-    78 key-pressed if 1 octave +! then
+  stopkeys @ until key-end rdrop ;
-    74 key-pressed if -1 octave +! then
-    75 key-pressed if -1 +voice! then
-    77 key-pressed if 1 +voice! then
-    r@ execute
-    suspend
-  repeat key-end rdrop ;
 
 : nextnote ( ip -- ip )
   dup if
@@ -261,16 +277,66 @@ var t2
 
 : record
   0x4f textattr !
-  :| ' setnote onkeynote
+  :| stoponesc voicekeys
+     ' setnote onkeynote
      41 key-pressed if 0xfd setnote then
      52 key-down if 0xf0 setnote then
   |; dokeys
   0x1f textattr ! ;
 
-: jam
+: jamkeys
-  :| ' noteon onkeynote
+  stoponesc voicekeys
-     41 key-pressed if noteoff then
+  ' noteon onkeynote
-  |; dokeys ;
+  41 key-pressed if noteoff then ;
+
+: jam ' jamkeys dokeys ;
+
+var menuscroll
+var menuy
+
+: menu-at ( cp x y -- )
+  :| texty ! dup textx ! textleft ! ' emit-direct task-emit !
+     0 menuscroll ! 0 menuy !
+     execute |;
+  0 textleft task-emit preserving ;
+
+: menu-lines ( -- count ) 24 texty @ - ;
+: menu-skip menuscroll @ 0 max ;
+: menu-selectedy menuy @ menu-skip - texty @ + ;
+: draw-menu ( cp -- ) 0 texty textattr preserving ;
+
+: menuitem-bg ( w attr -- )
+  :| menu-selectedy texty !
+     textleft @ textx !
+     textattr ! setattr-to |;
+  0 texty textx textattr preserving ;
+
+: deselect-menu ( w -- ) 0x1f menuitem-bg ;
+: select-menu ( w -- ) 0x30 menuitem-bg ;
+
+: key-menu ( w -- redraw )
+  :|
+    0 r>
+    72 key-pressed if dup deselect-menu -1 menuy +!pos dup select-menu then
+    80 key-pressed if dup deselect-menu 1 menuy +!pos dup select-menu then
+    73 key-pressed if rdrop 1 r> -10 menuscroll +!pos then
+    81 key-pressed if rdrop 1 r> 10 menuscroll +!pos then
+    drop r<
+  |; draw-menu ;
+
+: draw-filemenu ( glob -- )
+  :| findfile
+     menu-skip 0 for drop nextfile next
+     menu-lines 0 for dup if type else drop then 13 rpad cr nextfile next
+     drop |; draw-menu ;
+
+: filemenu ( glob -- filename )
+  :| dup draw-filemenu 13 select-menu
+     :| jamkeys
+	13 key-menu if dup draw-filemenu then
+	28 key-pressed if ( todo: get filename ) 1 stopkeys ! then
+     |; dokeys
+  |; 66 1 menu-at ;
 
 :noname
   9 -1 for i voice ! default next

jorth.c

@@ -427,6 +427,14 @@ void f_printstack() {
   }
 }
 
+void f_printrstack() {
+  cell *v = RUNNING + RSTACK_OFFSET;
+  while (v != rstack) {
+    PUSHC(*v++);
+    f_dot();
+  }
+}
+
 void f_cr() {
   PUSHI('\n');
   f_emit();
@@ -761,9 +769,9 @@ struct ffblk findfile;
 void f_findfirst() {
   int result = findfirst(TOP().s, &findfile, 0);
   if (result == 0) {
-    PUSHS(findfile.ff_name);
+    TOP().s = findfile.ff_name;
   } else {
-    PUSHU(0);
+    TOP().u = 0;
   }
 }
 
@@ -776,6 +784,11 @@ void f_findnext() {
   }
 }
 
+void f_chdir() {
+  chdir(TOP().s);
+  DROP(1);
+}
+
 void f_swapinput() {
   cell *key = RUNNING + TASK_USER_KEY;
   cell *keysrc = RUNNING + TASK_USER_KEYSRC;
@@ -1152,6 +1165,7 @@ void f_init(char *exe) {
   CDEF("u.", f_udot);
   CDEF("type", f_puts);
   CDEF(".s", f_printstack);
+  CDEF(".rs", f_printrstack);
   CDEF(",", f_comma);
   CDEF("b,", f_bcomma);
   CDEF("open", f_open);
@@ -1171,6 +1185,7 @@ void f_init(char *exe) {
   CDEF("fread", f_fread);
   CDEF("findfile", f_findfirst);
   CDEF("nextfile", f_findnext);
+  CDEF("chdir", f_chdir);
   CDEF("imagefilename", f_imagefilename);
   CDEF("image-uptodate", f_image_up_to_date);
   CDEF("loadimage", f_loadimage);

jorth.h

@@ -2,7 +2,7 @@
 
 #define MEM_SIZE 16384
 #define STACK_SIZE 64
-#define RSTACK_SIZE 32
+#define RSTACK_SIZE 64
 
 void f_init(char *exe);