172 lines
4 KiB
Plaintext
Executable file
172 lines
4 KiB
Plaintext
Executable file
' putc task-emit !
|
|
|
|
: start-repl activate ' putc task-emit !
|
|
s" .:: J O P L ( jean OPL2 print loop) ::." type cr
|
|
begin receive loadstring s" ok" type cr again ;
|
|
task const REPL
|
|
REPL start-repl
|
|
|
|
var voice
|
|
var op
|
|
|
|
: op-with-voice voice @
|
|
dup 2 > if 5 + then
|
|
dup 5 > 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 -- )
|
|
create b, b, b, b, b, b, b, b, b, b, b, does>
|
|
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
|
|
|
|
: freqon ( oct freq -- )
|
|
dup 0xff & ar-freq adlib!
|
|
8 >> 0x03 & swap 2 << | 0x20 | ar-note adlib! ;
|
|
: noteoff ( -- ) 0 ar-note adlib! ;
|
|
|
|
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 ( reg-cp -- )
|
|
dup op1 read-sbi-reg
|
|
op2 read-sbi-reg ;
|
|
|
|
: 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!
|
|
close ;
|
|
|
|
: panic 9 -1 for i voice ! noteoff next ;
|
|
|
|
var songticks
|
|
|
|
var notestate
|
|
var octave
|
|
: rest songticks @ begin dup songticks @ != until drop ;
|
|
: beat begin dup songticks @ swap % 0 != while rest repeat drop ;
|
|
: %O octave ! ;
|
|
: %V voice ! ;
|
|
: mknote create b, does> ub@ octave @ 12 * + notestate @ if b, else noteon rest then ;
|
|
: %loop 0xfe b, , ;
|
|
: % notestate @ if 0xf0 b, else rest then ;
|
|
: %% 0 for % next ;
|
|
: %- notestate @ if 0xfd b, else noteoff then ;
|
|
: %do 0xff b, , ;
|
|
0 mknote A
|
|
1 mknote A#
|
|
2 mknote B
|
|
3 mknote C
|
|
4 mknote C#
|
|
5 mknote D
|
|
6 mknote D#
|
|
7 mknote E
|
|
8 mknote F
|
|
9 mknote F#
|
|
10 mknote G
|
|
11 mknote G#
|
|
|
|
array tracks 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
|
|
|
|
: track ( i -- p ) cells tracks + ;
|
|
: dotrack ( ip -- ip )
|
|
dup if dup 1 + swap ub@ r>
|
|
r@ 0xff = if dup @ swap cell + swap execute then
|
|
r@ 0xfe = if @ dotrack then
|
|
r@ 0xfd = if noteoff then
|
|
r@ 0xf0 < if r@ noteon then
|
|
rdrop then ;
|
|
|
|
: track-tick ( i -- )
|
|
track dup @ dotrack swap ! ;
|
|
|
|
: :track create here 1 notestate ! does> voice @ track ! ;
|
|
: ;track %loop 0 notestate ! ;
|
|
: shush 0 voice @ track ! %- ;
|
|
|
|
: player
|
|
songticks @ 1 + songticks !
|
|
voice @
|
|
0 10 for i voice ! i track-tick next
|
|
voice ! ;
|
|
|
|
var t2
|
|
: startt2
|
|
0x60 0x04 adlib!
|
|
0x80 0x04 adlib!
|
|
t2 @ 0x03 adlib!
|
|
0x42 0x04 adlib! ;
|
|
|
|
: ontick adlib@ 0x20 & if startt2 player then ;
|
|
|
|
: files findfile begin dup while yield findnext repeat ;
|
|
|
|
: 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 ;
|
|
|
|
: keyboard
|
|
key-start begin
|
|
key-debounce 1 key-pressed not while
|
|
keynote dup if octave @ 12 * + noteon else drop then
|
|
78 key-pressed if 1 octave +! then
|
|
74 key-pressed if -1 octave +! then
|
|
41 key-pressed if noteoff then
|
|
rest
|
|
repeat key-end ;
|
|
|
|
:noname
|
|
default
|
|
startt2
|
|
; ' onload redefine
|