jopl instrument editor
This commit is contained in:
parent
41bfd439db
commit
09d017c872
12
jopl.c
12
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();
|
||||
}
|
||||
}
|
||||
|
|
|
|||
206
jopl.jor
206
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,11 +57,19 @@ 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>
|
||||
dup dup 5 + op1 readop op2 readop
|
||||
array b, b, b, b, b, b, b, b, b, b, b, ;
|
||||
: 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!
|
||||
|
|
@ -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 -- )
|
||||
dup op1 read-sbi-reg
|
||||
op2 read-sbi-reg ;
|
||||
: read-sbi-op-reg ( offset -- )
|
||||
dup 5 + current + fgetc swap b!
|
||||
current + fgetc swap b! ;
|
||||
|
||||
: loadsbi ( filename -- )
|
||||
open 36 seek
|
||||
' ar-flags read-sbi-op-reg
|
||||
' ar-level read-sbi-op-reg
|
||||
' ar-ad read-sbi-op-reg
|
||||
' ar-sr read-sbi-op-reg
|
||||
' ar-wave read-sbi-op-reg
|
||||
fgetc ar-alg adlib!
|
||||
4 -1 for i read-sbi-op-reg next
|
||||
fgetc current 10 + b!
|
||||
close
|
||||
current loadinst ; userword
|
||||
|
||||
: 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
|
||||
74 key-pressed if -1 octave +! then
|
||||
75 key-pressed if -1 +voice! then
|
||||
77 key-pressed if 1 +voice! then ;
|
||||
^#+ key-pressed if 1 octave +! then
|
||||
^#- key-pressed if -1 octave +! then ;
|
||||
^[ 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
|
||||
52 key-down if 0xf0 setnote then
|
||||
^~ key-pressed if 0xfd setnote then
|
||||
^. key-down if 0xf0 setnote then
|
||||
|; dokeys
|
||||
0x1f textattr ! ; userword
|
||||
|
||||
: jamkeys
|
||||
stoponesc voicekeys
|
||||
' noteon onkeynote
|
||||
41 key-pressed if noteoff then
|
||||
88 key-pressed if rndinst then ;
|
||||
^~ key-pressed if noteoff 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
|
||||
80 key-pressed if 1 change-selection then
|
||||
73 key-pressed if -10 page-selection then
|
||||
81 key-pressed if 10 page-selection then
|
||||
^UP key-pressed if -1 change-selection then
|
||||
^DOWN key-pressed if 1 change-selection then
|
||||
^PGUP 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
|
||||
|
|
|
|||
BIN
newbass.sbi
Executable file
BIN
newbass.sbi
Executable file
Binary file not shown.
Loading…
Reference in a new issue