' 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 ;

:noname
  default
  startt2
; ' onload redefine