jopl instrument editor

jopl.c

@@ -88,6 +88,17 @@ void f_dtextemitattr() {
   dtext_emitattr(dtext_attr);
 }
 
+void f_poll_ser() {
+  static char line[128] = { 0 };
+
+  if (ser_getline(line)) {
+    PUSHS(line);
+    f_runstring("DBG send");
+    f_taskloop();
+    line[0] = '\0';
+  }
+}
+
 void do_repl(char *exe) {
   adlib_init();
 
@@ -130,6 +141,7 @@ void do_repl(char *exe) {
 	f_execcp(ontick);
       }
     }
+    f_poll_ser();
     f_taskloop();
   }
 }

jopl.jor

@@ -1,4 +1,6 @@
 ' putc task-emit !
+:noname s" debug.jor" loadfile ; execute
+
 s" jopl.log" open seekend fdeactivate const LOGFILE
 : emit-log fdeactivate LOGFILE factivate fputc fdeactivate drop factivate ;
 : quit LOGFILE factivate close _quit ;
@@ -6,13 +8,20 @@ s" jopl.log" open seekend fdeactivate const LOGFILE
 : DBG :| ' seremit task-emit ! execute cr |; 0 task-emit preserving ;
 : DTYPE ' type DBG ;
 
+: dorepl begin receive loadstring s" ok" type cr again ;
 : start-repl activate
   ' putc task-emit ! ' emit-log task-echo !
   s" .:: J O P L ( jean OPL2 print loop) ::." type cr
-  begin receive loadstring s" ok" type cr again ;
+  dorepl ;
 task const REPL
 REPL start-repl
 
+: start-dbg activate ' seremit task-emit !
+  s" .:: J D B G ( jean debugger) ::." type cr
+  dorepl ;
+task const DBG
+DBG start-dbg
+
 var voice
 var op
 
@@ -48,12 +57,20 @@ var op
   >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 -- )
-  create b, b, b, b, b, b, b, b, b, b, b, does>
+  array b, b, b, b, b, b, b, b, b, b, b, ;
-  dup dup 5 + op1 readop op2 readop
+: blank-instrument array 11 allot ;
+: copy-instrument ( s d -- )
+  0 11 for over i + b@ over i + b! next drop drop ;
+: loadinst ( p -- ) dup dup 5 + op1 readop op2 readop
   10 + b@ ar-alg adlib! ;
 
 0 0x01 0x10 0xf0 0x77 0 0x01 0x00 0xf0 0x77 0 instrument default
+blank-instrument current
+: current! current copy-instrument ;
 
+: swap-op ( inst -- )
+  0 5 for dup ub@ over 5 + ub@ >r over 5 + b! <r over b! 1 + next ;
+ 
 : freqon ( oct freq -- )
   dup 0xff & ar-freq adlib!
   8 >> 0x03 & swap 2 << | 0x20 | ar-note adlib! ;
@@ -76,23 +93,35 @@ array semitones
 : note dup 12 / 8 % swap 12 % cells semitones + @ 440 swap *<ratio ;
 : noteon noteoff note freqon ;
 
+
 : read-sbi-reg ( reg-cp -- )
   fgetc swap execute adlib! ;
 
-: read-sbi-op-reg ( reg-cp -- )
+: read-sbi-op-reg ( offset -- )
-  dup op1 read-sbi-reg
+  dup 5 + current + fgetc swap b!
-  op2 read-sbi-reg ;
+  current + fgetc swap b! ;
 
 : loadsbi ( filename -- )
   open 36 seek
-  ' ar-flags read-sbi-op-reg
+  4 -1 for i read-sbi-op-reg next
-  ' ar-level read-sbi-op-reg
+  fgetc current 10 + b!
-  ' ar-ad read-sbi-op-reg
+  close
-  ' ar-sr read-sbi-op-reg
+  current loadinst ; userword
-  ' ar-wave read-sbi-op-reg
+
-  fgetc ar-alg adlib!
+: write-sbi-op-reg ( offset -- )
+  dup current + b@ fputc current + 5 + b@ fputc ;
+
+: writezeros ( n -- ) 0 for 0 fputc next ;
+: savesbi ( filename -- )
+  overwrite
+  [ key S lit ] fputc [ key B lit ] fputc [ key I lit ] fputc 0x1a fputc
+  32 writezeros
+  4 -1 for i write-sbi-op-reg next
+  10 current + b@ fputc
+  5 writezeros
   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
@@ -225,24 +254,40 @@ var t2
   0x42 0x04 adlib! ;
 
 : ontick startt2 player
-  :| status trackstatus |; 0 textleft textx texty preserving ;
+  :| status ( trackstatus ) |; 0 textleft textx texty preserving ;
+
+41 const ^~
+52 const ^.
+51 const ^,
+78 const ^#+
+74 const ^#-
+75 const ^LEFT
+77 const ^RIGHT
+72 const ^UP
+80 const ^DOWN
+73 const ^PGUP
+81 const ^PGDN
+28 const ^ENTER
+26 const ^[
+27 const ^]
 
 : 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,
 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 ; userword
+  drop ^, key-pressed if 15 else 0 then ; userword
 
 : 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
+  ^#+ key-pressed if 1 octave +! then
-  74 key-pressed if -1 octave +! then
+  ^#- key-pressed if -1 octave +! then ;
-  75 key-pressed if -1 +voice! then
+  ^[ key-pressed if -1 +voice! then
-  77 key-pressed if 1 +voice! then ;
+  ^] key-pressed if 1 +voice! then ;
 
 : dokeys ( cp -- )
   >r 0 stopkeys ! key-start begin
@@ -265,16 +310,15 @@ var stopkeys
   0x4f textattr !
   :| stoponesc voicekeys
      ' setnote onkeynote
-     41 key-pressed if 0xfd setnote then
+     ^~ key-pressed if 0xfd setnote then
-     52 key-down if 0xf0 setnote then
+     ^. key-down if 0xf0 setnote then
   |; dokeys
   0x1f textattr ! ; userword
 
 : jamkeys
   stoponesc voicekeys
   ' noteon onkeynote
-  41 key-pressed if noteoff then
+  ^~ key-pressed if noteoff then ;
-  88 key-pressed if rndinst then ;
 
 : jam ( todo: print? ) ' jamkeys dokeys ; userword
 
@@ -316,10 +360,10 @@ defer onselect
 : key-menu ( -- redraw )
   :|
     0 ( redraw )
-    72 key-pressed if -1 change-selection then
+    ^UP key-pressed if -1 change-selection then
-    80 key-pressed if 1 change-selection then
+    ^DOWN key-pressed if 1 change-selection then
-    73 key-pressed if -10 page-selection then
+    ^PGUP key-pressed if -10 page-selection then
-    81 key-pressed if 10 page-selection then
+    ^PGDN key-pressed if 10 page-selection then
   |; draw-menu ;
 
 : draw-filemenu ( glob -- )
@@ -333,14 +377,118 @@ defer onselect
   :| s" *.sbi" draw-filemenu
      :| jamkeys
 	key-menu if s" *.sbi" draw-filemenu then
-	28 key-pressed if 1 stopkeys ! then
+	^ENTER key-pressed if 1 stopkeys ! then
      |; dokeys
   |; 66 1 13 menu-at ; userword
 
-: dune ( -- ) s" dune" chdir inst s" .." chdir ; userword
+: shift-from-mask ( mask -- shift )
+  0 swap begin dup 1 & not while 1 >> swap 1 + swap repeat drop ;
+
+: bf! ( v addr mask -- )
+  >r dup ub@ r@ ~ & <rot ( addr dstv srcv r:mask )
+  r@ shift-from-mask << <r & | swap b! ;
+
+: bf@ ( addr mask -- v ) >r ub@ r@ & <r shift-from-mask >> ;
+
+: poly! ( v [...] get set -- ) swap drop execute ;
+: poly@ ( [...] get set -- v ) drop execute ;
+: poly-bf ' bf@ ' bf! ;
+: poly-noop ' 0 ' drop ;
+
+: bitfield ( byteoffset mask -- )
+  create b, b, does> ( addr bf -- addr mask )
+  >r r@ 1 + ub@ + <r ub@ ;
+
+: wordchain create 0 , 0 , does> ( l ) dup cell + swap @ if
+    @ ( link creation mode done; fetch the head )
+  else ( make new link )
+    here over @ , swap ! latest ,
+  then ;
+: endwordchain ( cp -- ) 2 cells + 1 swap ! ;
+: linkedval ( link -- val ) cell + @ ;
+: nth-linkedval ( link c -- val )
+  begin dup while 1 - swap @ swap repeat drop linkedval ;
+
+wordchain opbits
+4 0x80 bitfield @ampmod opbits
+4 0x40 bitfield @vib opbits
+4 0x20 bitfield @egtype opbits
+4 0x10 bitfield @ksr opbits
+4 0x0f bitfield @mod-freq-mult opbits
+3 0xc0 bitfield @scaling-level opbits
+3 0x3f bitfield @output-level opbits
+2 0xf0 bitfield @attack opbits
+2 0x0f bitfield @decay opbits
+1 0xf0 bitfield @sustain opbits
+1 0x0f bitfield @release 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 ;
+opbits count-links const #opbits
+
+wordchain algbits
+10 0x0e bitfield @feedback algbits
+10 0x01 bitfield @decay-alg algbits
+' algbits endwordchain
+algbits count-links const #algbits
+
+: lookup-nth-bitfield ( n inst link -- p mask )
+  <rot nth-linkedval codepointer execute ;
+
+: instfield ( n -- [...] get set )
+  dup 1 < if
+    drop :| op @ 1 & |; :| if op2 else op1 then |;
+  else 1 - dup #opbits < if
+    c+op opbits lookup-nth-bitfield poly-bf
+  else #opbits - dup #algbits < if
+    current algbits lookup-nth-bitfield poly-bf
+  else drop poly-noop then then then ;
+
+: draw-wordchain ( i link -- i )
+  links each
+    dup linkedval wordname type 25 rpad
+    over instfield poly@ . 30 rpad cr
+    swap 1 + swap
+  more ;
+
+: draw-inst
+  :| s" operator" type 25 rpad 0 instfield poly@ . 30 rpad cr
+     1 opbits draw-wordchain
+       algbits draw-wordchain drop |; draw-menu ;
+
+: redraw-instfield ( n -- )
+  dup if
+    :| 25 textx ! dup texty +! instfield poly@ . 30 rpad |;
+    0 textx texty preserving
+  else
+    draw-inst ( 0 is operator - need to redraw all values )
+  then ;
+
+: modify-instfield ( n cp -- )
+  over instfield poly@ swap execute over instfield poly!
+  redraw-instfield
+  op @ current loadinst op ! ;
+
+: edinst
+  :| draw-inst
+     :| jamkeys
+	key-menu if draw-inst then
+	^LEFT key-pressed if menuy @ :| 1 - |; modify-instfield then
+	^RIGHT key-pressed if menuy @ :| 1 + |; modify-instfield then
+	^ENTER key-pressed if 1 stopkeys ! then
+     |; dokeys
+  |; 0 1 30 menu-at ; userword
+
+: dune ( -- ) s" dune" chdir inst s" .." chdir ;
+
 
 :noname
-  9 -1 for i voice ! default next
+  9 -1 for i voice ! default loadinst next
   startt2
   ' emit-direct task-emit !
 ; ' onload redefine