jopl instrument editor

This commit is contained in:
Jeremy Penner 2020-04-11 23:47:05 -04:00
parent 41bfd439db
commit 09d017c872
10 changed files with 189 additions and 29 deletions

BIN
boot.jim

Binary file not shown.

BIN
debug.jim

Binary file not shown.

BIN
defs.jim

Binary file not shown.

BIN
jazz2.sbi Executable file

Binary file not shown.

12
jopl.c
View file

@ -88,6 +88,17 @@ void f_dtextemitattr() {
dtext_emitattr(dtext_attr); 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) { void do_repl(char *exe) {
adlib_init(); adlib_init();
@ -130,6 +141,7 @@ void do_repl(char *exe) {
f_execcp(ontick); f_execcp(ontick);
} }
} }
f_poll_ser();
f_taskloop(); f_taskloop();
} }
} }

BIN
jopl.exe

Binary file not shown.

BIN
jopl.jim Executable file

Binary file not shown.

206
jopl.jor
View file

@ -1,4 +1,6 @@
' putc task-emit ! ' putc task-emit !
:noname s" debug.jor" loadfile ; execute
s" jopl.log" open seekend fdeactivate const LOGFILE s" jopl.log" open seekend fdeactivate const LOGFILE
: emit-log fdeactivate LOGFILE factivate fputc fdeactivate drop factivate ; : emit-log fdeactivate LOGFILE factivate fputc fdeactivate drop factivate ;
: quit LOGFILE factivate close _quit ; : 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 ; : DBG :| ' seremit task-emit ! execute cr |; 0 task-emit preserving ;
: DTYPE ' type DBG ; : DTYPE ' type DBG ;
: dorepl begin receive loadstring s" ok" type cr again ;
: start-repl activate : start-repl activate
' putc task-emit ! ' emit-log task-echo ! ' putc task-emit ! ' emit-log task-echo !
s" .:: J O P L ( jean OPL2 print loop) ::." type cr s" .:: J O P L ( jean OPL2 print loop) ::." type cr
begin receive loadstring s" ok" type cr again ; dorepl ;
task const REPL task const REPL
REPL start-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 voice
var op var op
@ -48,11 +57,19 @@ var op
>r r@ 4 + b@ r@ 3 + b@ r@ 2 + b@ r@ 1 + b@ <r b@ loadop ; >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 -- ) : 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! ; 10 + b@ ar-alg adlib! ;
0 0x01 0x10 0xf0 0x77 0 0x01 0x00 0xf0 0x77 0 instrument default 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 -- ) : freqon ( oct freq -- )
dup 0xff & ar-freq adlib! dup 0xff & ar-freq adlib!
@ -76,23 +93,35 @@ array semitones
: note dup 12 / 8 % swap 12 % cells semitones + @ 440 swap *<ratio ; : note dup 12 / 8 % swap 12 % cells semitones + @ 440 swap *<ratio ;
: noteon noteoff note freqon ; : noteon noteoff note freqon ;
: read-sbi-reg ( reg-cp -- ) : read-sbi-reg ( reg-cp -- )
fgetc swap execute adlib! ; 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 -- ) : loadsbi ( filename -- )
open 36 seek 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 close ; userword
: rndbyte 256 rnd dup . ; : rndbyte 256 rnd dup . ;
: rndop rndbyte rndbyte rndbyte rndbyte rndbyte s" loadop " type loadop ; : rndop rndbyte rndbyte rndbyte rndbyte rndbyte s" loadop " type loadop ;
: rndinst s" op1 " type op1 rndop s" op2 " type op2 rndop : rndinst s" op1 " type op1 rndop s" op2 " type op2 rndop
@ -225,24 +254,40 @@ var t2
0x42 0x04 adlib! ; 0x42 0x04 adlib! ;
: ontick startt2 player : 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| : 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, 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, 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, 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 |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 ; : onkeynote ( cp -- ) keynote dup if oct+ swap execute else drop drop then ;
var stopkeys var stopkeys
: stoponesc 1 key-pressed if 1 stopkeys ! then ; : stoponesc 1 key-pressed if 1 stopkeys ! then ;
: voicekeys : 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 -- ) : dokeys ( cp -- )
>r 0 stopkeys ! key-start begin >r 0 stopkeys ! key-start begin
@ -265,16 +310,15 @@ var stopkeys
0x4f textattr ! 0x4f textattr !
:| stoponesc voicekeys :| stoponesc voicekeys
' setnote onkeynote ' 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 |; dokeys
0x1f textattr ! ; userword 0x1f textattr ! ; userword
: jamkeys : jamkeys
stoponesc voicekeys stoponesc voicekeys
' noteon onkeynote ' 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 : jam ( todo: print? ) ' jamkeys dokeys ; userword
@ -316,10 +360,10 @@ defer onselect
: key-menu ( -- redraw ) : key-menu ( -- redraw )
:| :|
0 ( 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-menu ;
: draw-filemenu ( glob -- ) : draw-filemenu ( glob -- )
@ -333,14 +377,118 @@ defer onselect
:| s" *.sbi" draw-filemenu :| s" *.sbi" draw-filemenu
:| jamkeys :| jamkeys
key-menu if s" *.sbi" draw-filemenu then key-menu if s" *.sbi" draw-filemenu then
28 key-pressed if 1 stopkeys ! then ^ENTER key-pressed if 1 stopkeys ! then
|; dokeys |; dokeys
|; 66 1 13 menu-at ; userword |; 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 :noname
9 -1 for i voice ! default next 9 -1 for i voice ! default loadinst next
startt2 startt2
' emit-direct task-emit ! ' emit-direct task-emit !
; ' onload redefine ; ' onload redefine

BIN
jopl.prj

Binary file not shown.

BIN
newbass.sbi Executable file

Binary file not shown.