jopl: interactive instrument loading

jopl.jor

@@ -1,8 +1,7 @@
 ' putc task-emit !
 s" jopl.log" open seekend fdeactivate const LOGFILE
 : emit-log fdeactivate LOGFILE factivate fputc fdeactivate drop factivate ;
-: quit LOGFILE factivate close _quit ;
+: quit LOGFILE factivate close s" C:\src\game" chdir _quit ;
-
 
 : DBG :| ' seremit task-emit ! execute cr |; 0 task-emit preserving ;
 : DTYPE ' type DBG ;
@@ -165,6 +164,8 @@ 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 ;
 
+( T E X T )
+
 var textx
 var texty
 var textattr
@@ -198,6 +199,11 @@ var textleft
 : rpad ( n -- )
   textleft @ + textx @ for bl next ;
 
+: read-direct ( x y -- s )
+  80 * + here swap
+  begin dup 1 << 0xb800 b@far dup sp != while b, 1 + repeat
+  0 b, drop drop dup here! ;
+
 : status
   0 textx ! 0 texty ! 0 textleft !
   s"  V: " type voice @ .
@@ -293,35 +299,42 @@ var stopkeys
 
 var menuscroll
 var menuy
+var menuw
 
-: menu-at ( cp x y -- )
+defer onselect
-  :| texty ! dup textx ! textleft ! ' emit-direct task-emit !
+
+: menu-at ( cp x y w -- )
+  :| menuw ! texty ! dup textx ! textleft ! ' emit-direct task-emit !
      0 menuscroll ! 0 menuy !
-     execute |;
+     execute ' noop ' onselect redefine |;
   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 -- )
+: menuitem-bg ( attr -- )
   :| menu-selectedy texty !
      textleft @ textx !
-     textattr ! setattr-to |;
+     textattr ! menuw @ setattr-to |;
   0 texty textx textattr preserving ;
 
-: deselect-menu ( w -- ) 0x1f menuitem-bg ;
+: deselect-menu ( -- ) 0x1f menuitem-bg ;
-: select-menu ( w -- ) 0x30 menuitem-bg ;
+: select-menu ( -- ) 0x30 menuitem-bg ;
 
-: key-menu ( w -- redraw )
+: selected-text textx @ menu-selectedy read-direct ;
+
+: draw-menu ( cp -- ) 0 texty textattr preserving select-menu ;
+
+: change-selection ( dy -- )
+  deselect-menu menuy +!pos select-menu onselect ;
+: key-menu ( -- redraw )
   :|
-    0 r>
+    0 ( redraw )
-    72 key-pressed if dup deselect-menu -1 menuy +!pos dup select-menu then
+    72 key-pressed if -1 change-selection then
-    80 key-pressed if dup deselect-menu 1 menuy +!pos dup select-menu then
+    80 key-pressed if 1 change-selection then
-    73 key-pressed if rdrop 1 r> -10 menuscroll +!pos then
+    73 key-pressed if drop 1 r> -10 menuscroll +!pos then
-    81 key-pressed if rdrop 1 r> 10 menuscroll +!pos then
+    81 key-pressed if drop 1 r> 10 menuscroll +!pos then
-    drop r<
   |; draw-menu ;
 
 : draw-filemenu ( glob -- )
@@ -330,16 +343,18 @@ var menuy
      menu-lines 0 for dup if type else drop then 13 rpad cr nextfile next
      drop |; draw-menu ;
 
-: filemenu ( glob -- filename )
+: inst ( -- )
-  :| dup draw-filemenu 13 select-menu
+  :| selected-text loadsbi |; ' onselect redefine
+  :| s" *.sbi" draw-filemenu
      :| jamkeys
-	13 key-menu if dup draw-filemenu then
+	key-menu if s" *.sbi" draw-filemenu then
-	28 key-pressed if ( todo: get filename ) 1 stopkeys ! then
+	28 key-pressed if 1 stopkeys ! then
      |; dokeys
-  |; 66 1 menu-at ;
+  |; 66 1 13 menu-at ;
 
 :noname
   9 -1 for i voice ! default next
   startt2
   ' emit-direct task-emit !
+  s" dune" chdir
 ; ' onload redefine