SID sounds test tool (verbose), written in COMAL-80

sidtest.comal

auto 100,4

// SID test mini
// in COMAL-80

// ----------
// procedures
// ----------

proc wait(count)
 for i:=0 to count do null
endproc wait 

proc init
 dim wforms(4)  // waveforms
 dim sregs(8)   // sid registers+1 (8: duration)
 init'sregs
 col:=646       // text color
 sid:=54272     // sid start
 scr:=53280     // frame (+1: backgr.)
 u$:=chr$(18)   // invers chars:on
 v$:=chr$(146)  // invers chars:off
 w$:=chr$(221)  // vertical bar
 t$:=""         // title header
 t$:=u$+chr$(220)                    // invers:on + left-start
 t$:+" SID test mini "    +chr$(234) // title + vertical break
 t$:+"              v0.4 "+v$        // version + invers:off
 z$:=""
 poke scr+0,11  // gray frame
 poke scr+1,11  // gray background
 for i:=0 to 35 do
  z$:+chr$(192)
 endfor i
 wforms(1):= %00010001  //  17: triangle
 wforms(2):= %00100001  //  33: sawtooth
 wforms(3):= %01000001  //  65: pulse ("rectangle")
 wforms(4):= %10000001  // 129: white noise
 randomize
endproc init 
 
proc init'sregs
 sregs(1):=3
 sregs(2):=40
 sregs(5):=17
 sregs(6):=175
 sregs(7):=50
 sregs(8):=99
endproc init'sregs

proc play'sound
 poke sid+24,15       // volume: max
 poke sid+0,sregs(1)  // freq.low
 poke sid+1,sregs(2)  // freq.high
 poke sid+5,sregs(6)  // env.: ad
 poke sid+6,sregs(7)  // env.: sr
 poke sid+4,sregs(5)  // waveform
 wait(sregs(8))       // delay
 poke sid+4,0         // release voice #1
endproc play'sound

proc random'sound
 sregs(1):= rnd(0,255)
 sregs(2):= rnd(0,255)
 sregs(5):= wforms(rnd(1,4))
 sregs(6):= rnd(0,15) + 16*rnd(0,15)
 sregs(7):= rnd(0,15) + 16*rnd(0,15)
 sregs(8):= rnd(10,990)
endproc random'sound

proc mutate'sound
 for j:=0 to 3 do
 for i:=1 to 8 do
  sregs(i):+rnd(-1,1)
  if sregs(i)<0 then sregs(i)=0
 endfor i
 endfor j
 sregs(5):= wforms(rnd(1,4))
endproc mutate'sound

proc menu'screen
 page
 cursor 5,1  
 print chr$(14)        // 2nd charset (a-z,A-Z)
 poke col,1
 print " ", chr$(240), // 1st long line
 print z$ , chr$(238)  // with corners
 poke col,15
 print " ", w$,
 poke col,3
 print t$,
 poke col,15
 print w$;
 poke col,12
 print " ", chr$(235), // 2nd long line
 print z$ , chr$(243)  // with corners
 
 poke col,3
 print " " , w$, " s+", u$, "0", v$, " (fq-l):",str$(sregs(1)),tab(20);
 print "s+", u$, "1"  , v$, " (fq-h):";              sregs(2), tab(39), w$
 print " " , w$, " s+", u$, "4", v$, " (wavf):",str$(sregs(5)),tab(20);
 print "s+", u$, "5"  , v$, "/", u$, "6", v$, " (a):";
 print str$(sregs(6)),"/", str$(sregs(7)), tab(39), w$
 print " " , w$, " ", u$, "l", v$, "ength    :", str$(sregs(8)),tab(20);
 print u$  , "d"    , v$, "efault"             , tab(39), w$
 print " " , w$, " ", u$, "r", v$, "andomize"  , tab(20);
 print u$  , "m"    , v$, "utate"              , tab(39), w$
 print " ! ",u$, "p", v$, "lay (or ret.)", tab(20);
 print "e"  ,u$, "x", v$, "it"           , tab(38); w$
 
 poke col,15
 print " ", chr$(237), // closing line
 print z$ , chr$(253); // with corners
 poke col,1
endproc menu'screen

// ---------
// main loop
// ---------

proc main

 escape:=false
 
 repeat
 
  menu'screen
  aa:=0
  a$:=""
  print 
  input " item >": a$;
  case a$ of
    when "p", "P", ""
        play'sound
    when "r", "R"
        random'sound
    when "l", "L"
        a$:="7"
    when "m", "M"
        mutate'sound
    when "d", "D"
        init'sregs
    when "x", "X", "exit"
        escape:=true
    otherwise
      trap
       aa:=val(a$)
      handler
       print " no command or register"
       wait(2000)
       goto no'op
      endtrap
      if aa<0 or aa>7 then 
       print " invalid register"
       wait(2000)
       goto no'op
      endif  
      trap
       input " val. >": sv;
      handler
       print " number required"
       wait(2000)
       goto no'op
      endtrap 
      sregs(aa+1):=sv
no'op:      
  endcase

 until escape
 
endproc main
  
proc done
 poke scr, 14    // back to
 poke scr+1,6    // system colors
 poke col, 14
 page            // cls
 print chr$(142) // 1st charset again
endproc done

// -----------
// entry point
// -----------

 init
 main
 done