522 lines
14 KiB
Plaintext
Executable file
522 lines
14 KiB
Plaintext
Executable file
' putc task-emit !
|
|
:noname s" debug.jor" loadfile ; execute
|
|
' seremit dbg-emit !
|
|
|
|
-1 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 ;
|
|
|
|
: 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
|
|
dorepl ;
|
|
task const 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
|
|
|
|
: +voice! voice @ + 10 % voice ! ;
|
|
|
|
: op-with-voice voice @
|
|
dup 5 > if 5 + then
|
|
dup 2 > if 5 + then
|
|
+ op @ + ;
|
|
: opreg create b, does> ub@ op-with-voice ;
|
|
: voicereg create b, does> ub@ voice @ + ;
|
|
|
|
0x20 opreg ar-flags
|
|
0x40 opreg ar-level
|
|
0x60 opreg ar-ad
|
|
0x80 opreg ar-sr
|
|
0xe0 opreg ar-wave
|
|
0xc0 voicereg ar-alg
|
|
|
|
0xa0 voicereg ar-freq
|
|
0xb0 voicereg ar-note
|
|
|
|
: op2 3 op ! ;
|
|
: op1 0 op ! ;
|
|
: loadop ( flags level ad sr wave -- )
|
|
ar-wave adlib!
|
|
ar-sr adlib!
|
|
ar-ad adlib!
|
|
ar-level adlib!
|
|
ar-flags adlib! ;
|
|
|
|
: readop ( v -- )
|
|
>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 -- )
|
|
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!
|
|
8 >> 0x03 & swap 2 << | 0x20 | ar-note adlib! ;
|
|
: noteoff ( -- ) 0 ar-note adlib! ; userword
|
|
|
|
array semitones
|
|
3520 3520 />ratio ,
|
|
3729 3520 />ratio ,
|
|
3951 3520 />ratio ,
|
|
4186 3520 />ratio ,
|
|
4435 3520 />ratio ,
|
|
4699 3520 />ratio ,
|
|
4978 3520 />ratio ,
|
|
5274 3520 />ratio ,
|
|
5588 3520 />ratio ,
|
|
5920 3520 />ratio ,
|
|
6272 3520 />ratio ,
|
|
6645 3520 />ratio ,
|
|
|
|
: 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 ( offset -- )
|
|
dup 5 + current + fgetc swap b!
|
|
current + fgetc swap b! ;
|
|
|
|
: loadsbi ( filename -- )
|
|
open 36 seek
|
|
4 -1 for i read-sbi-op-reg next
|
|
fgetc current 10 + b!
|
|
close
|
|
current loadinst ; userword
|
|
|
|
: write-sbi-op-reg ( offset -- )
|
|
dup current + 5 + b@ fputc current + 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
|
|
rndbyte s" ar-alg adlib! " type cr ar-alg adlib! ; userword
|
|
|
|
: panic 9 -1 for i voice ! noteoff next ; userword
|
|
|
|
var songticks
|
|
|
|
var beatcount
|
|
4 beatcount !
|
|
|
|
var notestate
|
|
var octave
|
|
: oct+ octave @ 12 * + ; userword
|
|
: rest songticks @ begin suspend dup songticks @ != until drop ; userword
|
|
: beat begin dup songticks @ beatcount @ % 0 != while rest repeat drop ; userword
|
|
: %O octave ! ; userword
|
|
: %V voice ! ; userword
|
|
: %loop 0xfe b, ; userword
|
|
: mod % ;
|
|
: % notestate @ if 0xf0 b, else rest then ; userword
|
|
: %% 0 for % next ; userword
|
|
: %- notestate @ if 0xfd b, else noteoff then ; userword
|
|
|
|
: mknote create b, does> ub@ oct+ notestate @ if b, else noteon rest then ;
|
|
|
|
11 mknote G# userword
|
|
10 mknote G userword
|
|
9 mknote F# userword
|
|
8 mknote F userword
|
|
7 mknote E userword
|
|
6 mknote D# userword
|
|
5 mknote D userword
|
|
4 mknote C# userword
|
|
3 mknote C userword
|
|
2 mknote B userword
|
|
1 mknote A# userword
|
|
0 mknote A userword
|
|
|
|
array tracks 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
|
|
array tracks-start 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
|
|
|
|
: track ( i -- p ) cells tracks + ;
|
|
: vtrack ( -- p ) voice @ track ;
|
|
|
|
: curr-track-start voice @ cells tracks-start + ;
|
|
: track-tick ( -- )
|
|
vtrack @ >r r@ if ( r: track )
|
|
songticks @ curr-track-start @ - ( -- index )
|
|
|
|
( call instrument word if start of track )
|
|
dup not if r@ cell + @ execute then ( index -- index )
|
|
|
|
( call "tick" word )
|
|
dup r@ @ execute ( index -- index )
|
|
|
|
2 cells + r@ + ub@ ( index -- note )
|
|
dup 0xf0 < if noteon
|
|
else dup 0xfd = if noteoff
|
|
else 0xfe = if songticks @ curr-track-start ! track-tick ( loop )
|
|
then then then
|
|
then rdrop ;
|
|
|
|
: pad-track ( start end -- )
|
|
swap - beatcount @ mod ( s e -- cpad )
|
|
dup if 0 for % next else drop then ;
|
|
|
|
: :track create ' drop , ' noop , here 1 notestate ! does>
|
|
beat vtrack ! songticks @ curr-track-start ! ; userword
|
|
|
|
: ;track here pad-track %loop 0 notestate ! ; userword
|
|
: shush 0 voice @ track ! %- ; userword
|
|
|
|
: prev-name ( wordname -- wordname )
|
|
2 cells - @ 2 cells + ;
|
|
: 'name [ ' [ , ' ' , ' ] , ] ` lit ; immediate
|
|
|
|
: emit-octave ( note -- )
|
|
12 / dup octave @ != if dup octave ! . s" %O " type else drop then ;
|
|
|
|
: emit-note ( note -- )
|
|
'name A swap 12 mod 0 for prev-name next type bl ;
|
|
|
|
: emit-cmd ( cmd -- more )
|
|
dup 0xf0 = if s" % " type then
|
|
dup 0xfd = if s" %- " type then
|
|
dup 0xf0 < if dup emit-octave emit-note 1 then
|
|
dup 0xfe = if 'name ;track type cr drop 0 then ;
|
|
|
|
: emit-track ( 'track -- )
|
|
-1 octave ! dup ` swap 2 cells +
|
|
'name :track type bl swap type bl
|
|
begin dup ub@ emit-cmd while 1 + repeat drop ; userword
|
|
|
|
: emit-inst ( pinst -- )
|
|
11 -1 for dup i + ub@ . next drop s" instrument XXX" type cr ;
|
|
|
|
( T E X T )
|
|
|
|
: setattr-to ( w -- ) 0 for attremit next ;
|
|
|
|
: clearline begin 0 emit-direct textx @ textleft @ = until ;
|
|
|
|
: 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 @ .
|
|
s" O: " type octave @ .
|
|
s" T: " type songticks @ .
|
|
clearline ;
|
|
|
|
: emit-status-cmd ( ip -- ip )
|
|
dup ub@ swap 1 + swap
|
|
dup 0xf0 = if s" % " type then
|
|
dup 0xfd = if s" - " type then
|
|
dup 0xf0 < if dup emit-note then
|
|
dup 0xfe = if
|
|
16 textattr +!
|
|
swap @ emit-status-cmd swap
|
|
-16 textattr +!
|
|
then drop ;
|
|
|
|
: showtrack ( n -- )
|
|
dup . s" : " type
|
|
track @ dup if 20 0 for emit-status-cmd next then drop
|
|
clearline ;
|
|
|
|
: trackstatus voice @ showtrack ;
|
|
|
|
var tempo userword 1 tempo !
|
|
: player
|
|
1 songticks +!
|
|
songticks @ tempo @ mod 0 = if
|
|
voice @
|
|
0 10 for i voice ! track-tick next
|
|
voice !
|
|
then ;
|
|
|
|
var t2
|
|
: startt2
|
|
0x60 0x04 adlib!
|
|
0x80 0x04 adlib!
|
|
t2 @ 0x03 adlib!
|
|
0x42 0x04 adlib! ;
|
|
|
|
: ontick startt2 player
|
|
:| 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 ^, 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
|
|
^#+ 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
|
|
key-debounce r@ execute suspend
|
|
stopkeys @ until key-end rdrop ;
|
|
|
|
: nextnote ( ip -- ip )
|
|
dup if
|
|
dup ub@ >r
|
|
r@ 0xff = if drop 0 else
|
|
r@ 0xfe = if 1 + @ nextnote then then
|
|
rdrop
|
|
then ;
|
|
|
|
: setnote ( note -- )
|
|
voice @ track @ nextnote
|
|
dup if b! else drop drop then ;
|
|
|
|
: record
|
|
0x4f textattr !
|
|
:| stoponesc voicekeys
|
|
' setnote onkeynote
|
|
^~ key-pressed if 0xfd setnote then
|
|
^. key-down if 0xf0 setnote then
|
|
|; dokeys
|
|
0x1f textattr ! ; userword
|
|
|
|
: jamkeys
|
|
stoponesc voicekeys
|
|
' noteon onkeynote
|
|
^~ key-pressed if noteoff then ;
|
|
|
|
: jam ( todo: print? ) ' jamkeys dokeys ; userword
|
|
|
|
var menuscroll
|
|
var menuy
|
|
var menuw
|
|
|
|
defer onselect
|
|
|
|
: menu-at ( cp x y w -- )
|
|
:| menuw ! texty ! dup textx ! textleft !
|
|
' emit-direct task-emit ! 0 task-echo !
|
|
0 menuscroll ! 0 menuy !
|
|
execute ' noop ' onselect redefine |;
|
|
0 textleft task-emit task-echo preserving ;
|
|
|
|
: menu-lines ( -- count ) 24 texty @ - ;
|
|
: menu-skip menuscroll @ 0 max ;
|
|
: menu-selectedy menuy @ menu-skip - texty @ + ;
|
|
|
|
: menuitem-bg ( attr -- )
|
|
:| menu-selectedy texty !
|
|
textleft @ textx !
|
|
textattr ! menuw @ setattr-to |;
|
|
0 texty textx textattr preserving ;
|
|
|
|
: deselect-menu ( -- ) 0x1f menuitem-bg ;
|
|
: select-menu ( -- ) 0x30 menuitem-bg ;
|
|
|
|
: 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 ;
|
|
|
|
: page-selection ( redraw dy -- 1 )
|
|
dup menuscroll +!pos menuy +!pos drop 1 ;
|
|
|
|
: key-menu ( -- redraw )
|
|
:|
|
|
0 ( redraw )
|
|
^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 -- )
|
|
:| 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 ;
|
|
|
|
: inst ( -- )
|
|
:| selected-text loadsbi |; ' onselect redefine
|
|
:| s" *.sbi" draw-filemenu
|
|
:| jamkeys
|
|
key-menu if s" *.sbi" draw-filemenu then
|
|
^ENTER key-pressed if 1 stopkeys ! then
|
|
|; dokeys
|
|
|; 66 1 13 menu-at ; 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
|
|
|
|
: 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
|
|
s" jopl.log" open seekend fdeactivate ' LOGFILE redefine
|
|
REPL start-repl
|
|
|
|
9 -1 for i voice ! default loadinst next
|
|
startt2
|
|
' emit-direct task-emit !
|
|
; ' onload redefine
|
|
|
|
2 %O
|
|
:track bassline C % % C % % % G % % % G % % G % % C % % C % % % G 8 %% ;track
|