pete286/jopl.jor

' putc task-emit !
s" jopl.log" open seekend fdeactivate const LOGFILE
: emit-log fdeactivate LOGFILE factivate fputc fdeactivate drop factivate ;
: quit LOGFILE factivate close _quit ;

: 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 ;
task const REPL
REPL start-repl

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 -- )
  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
: oct+ octave @ 12 * + ;
: rest songticks @ begin suspend dup songticks @ != until drop ;
: beat begin dup songticks @ swap % 0 != while rest repeat drop ;
: %O octave ! ;
: %V voice ! ;
: mknote create b, does> ub@ oct+ notestate @ if b, else noteon rest then ;
: %loop 0xfe b, , ;
: mod % ;
: % notestate @ if 0xf0 b, else rest then ;
: %% 0 for % next ;
: %- notestate @ if 0xfd b, else noteoff then ;
: %do 0xff b, , ;

11 mknote G#
10 mknote G
9  mknote F#
8  mknote F
7  mknote E
6  mknote D#
5  mknote D
4  mknote C#
3  mknote C
2  mknote B
1  mknote A#
0  mknote A

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 ! %- ;

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

var textx
var texty
var textattr
0x1f textattr !

: out-direct ( c -- )
  textattr @ 8 << |
  texty @ 160 * textx @ 1 << +
  0xb800 !far ;

: clearline
  textattr @ 8 <<
  texty @ 80 * textx @ +
  texty @ 1 + 80 *
  for dup i 1 << 0xb800 !far next drop ;

: +textx! ( n -- )
  textx @ + dup 80 >= if drop cr else textx ! then ;
: emit-direct ( c -- )
  dup '\n' = if 0 textx ! 1 texty +! drop else
  dup '\r' = if drop else
  out-direct 1 +textx! then then ;

: status
  0 textx ! 0 texty !
  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 cr voice @ showtrack ;

var tempo 1 tempo !
: player
  1 songticks +!
  songticks @ tempo @ mod 0 = if
    voice @
    0 10 for i voice ! i 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 ;

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

: onkeynote ( cp -- ) keynote dup if oct+ swap execute else drop drop then ;

: dokeys ( cp -- )
  r> key-start begin
    key-debounce 1 key-pressed not while
    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
    r@ execute
    suspend
  repeat 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 !
  :| ' setnote onkeynote
     41 key-pressed if 0xfd setnote then
     52 key-down if 0xf0 setnote then
  |; dokeys
  0x1f textattr ! ;

: jam
  :| ' noteon onkeynote
     41 key-pressed if noteoff then
  |; dokeys ;

:noname
  9 -1 for i voice ! default next
  startt2
  ' emit-direct task-emit !
; ' onload redefine