neuttower/jopl.jor

372 lines
9.4 KiB
Plaintext
Executable file

' 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 ;
: DBG :| ' seremit task-emit ! execute cr |; 0 task-emit preserving ;
: DTYPE ' type DBG ;
: 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! ; 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 ( 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 ; 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 notestate
var octave
: oct+ octave @ 12 * + ; userword
: rest songticks @ begin suspend dup songticks @ != until drop ; userword
: beat begin dup songticks @ swap % 0 != while rest repeat drop ; userword
: %O octave ! ; userword
: %V voice ! ; userword
: mknote create b, does> ub@ oct+ notestate @ if b, else noteon rest then ;
: %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
: %do 0xff b, , ; userword
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 ,
: 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 ! ; userword
: ;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
( T E X T )
var textx
var texty
var textattr
var textleft
0x1f textattr !
: out-direct ( c -- )
textattr @ 8 << |
texty @ 160 * textx @ 1 << +
0xb800 !far ;
: setattr-to ( w -- )
texty @ 80 * textx @ +
dup <rot +
textattr @ >rot
for dup i 1 << 1 + 0xb800 b!far next drop ;
: 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 textleft @ textx ! 1 texty +! drop else
dup '\r' = if drop else
out-direct 1 +textx! then then ;
: 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 cr voice @ showtrack ;
var tempo userword 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 0 textleft textx texty preserving ( trackstatus ) ;
: 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
: 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 ;
: 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
41 key-pressed if 0xfd setnote then
52 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 ;
: jam ' 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 menuscroll ! 0 menuy !
execute ' noop ' onselect redefine |;
0 textleft task-emit 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 )
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
|; 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
28 key-pressed if 1 stopkeys ! then
|; dokeys
|; 66 1 13 menu-at ; userword
: dune ( -- ) s" dune" chdir inst s" .." chdir ; userword
:noname
9 -1 for i voice ! default next
startt2
' emit-direct task-emit !
; ' onload redefine