unit noiz;   { NOIZ.PAS  Copyright (c) 1990 DSoft Specialties }
interface    { Sound routines for the Tandy 1000 and/or PCJr. See NOIZ.SIM }

{ All I ask is if you use any of these routines in your program
  please mention DSoft in the docs or in a copyright message }

const
  inturbo: boolean = true;

type
  voices = 0..3;
  attenuations = 0..15;
  styles = 1..4;

const
  A1 = 27;  A2 = 55;  A3 = 110;  A4 = 220;  A5 = 440;  A6 = 880;  A7 = 1760;
  B1 = 31;  B2 = 62;  B3 = 123;  B4 = 247;  B5 = 494;  B6 = 988;  B7 = 1976;
  C1 = 33;  C2 = 65;  C3 = 131;  C4 = 262;  C5 = 523;  C6 = 1047; C7 = 2093;
  D1 = 37;  D2 = 74;  D3 = 147;  D4 = 294;  D5 = 588;  D6 = 1175; D7 = 2349;
  E1 = 41;  E2 = 83;  E3 = 165;  E4 = 330;  E5 = 660;  E6 = 1320; E7 = 2640;
  F1 = 44;  F2 = 88;  F3 = 175;  F4 = 350;  F5 = 700;  F6 = 1400; F7 = 2800;
  G1 = 49;  G2 = 98;  G3 = 196;  G4 = 392;  G5 = 784;  G6 = 1568; G7 = 3136;

  A8 = 3520;  A9 = 7040;  A10 = 14080;
  B8 = 3952;  B9 = 7904;  B10 = 15808;
  C8 = 4160;  C9 = 8320;  C10 = 16640;
  D8 = 4704;  D9 = 9408;  D10 = 18816;
  E8 = 5280;  E9 = 10560;
  F8 = 5600;  F9 = 11200;
  G8 = 6272;  G9 = 12544;

  AS1 = 29; AS2 = 58; AS3 = 116; AS4 = 231; AS5 = 466; AS6 = 928; AS7 = 1856;
  CS1 = 34; CS2 = 69; CS3 = 139; CS4 = 277; CS5 = 554; CS6 = 1108;CS7 = 2240;
  DS1 = 39; DS2 = 78; DS3 = 156; DS4 = 311; DS5 = 622; DS6 = 1244;DS7 = 2496;
  FS1 = 46; FS2 = 93; FS3 = 185; FS4 = 370; FS5 = 740; FS6 = 1480;FS7 = 2960;
  GS1 = 26; GS2 = 52; GS3 = 208; GS4 = 415; GS5 = 830; GS6 = 1660;GS7 = 3320;

  AS8 = 3712;  AS9 = 7424;  AS10 = 14848;
  CS8 = 4480;  CS9 = 8960;  CS10 = 17920;
  DS8 = 4992;  DS9 = 9984;  DS10 = 19968;
  FS8 = 5920;  FS9 = 11840;
  GS8 = 6640;  GS9 = 13280;

const
  stacatto: boolean = false;   legato: boolean = false;
  zetto:    boolean = false;   xetto:  boolean = false;
  dtime:    integer = 80;

procedure wait(dt: longint);
procedure delay(dt: longint);
procedure sound(freq: word);
procedure nosound;
procedure sound_level(voice: voices;atten: attenuations);
procedure sound_period(voice: voices;period: integer);
procedure sound_pitch(voice: voices;freq: real);
procedure sound_off;
procedure extsound(freq,dur: integer;level: attenuations;voice: voices);
procedure plays(freq,dur: word;attack,decay: integer;voice: voices);
procedure chord(freq1,freq2,freq3,dur,level: integer);
procedure play(freq,dur: integer;v: voices;style: styles);
procedure noise(ch: char;sr,atten,dur: word);
procedure note1(freq,dura: word);
procedure note4(note,dura: integer);
procedure dubend(freq1,freq2,dt: integer);
procedure bend(tone,tone1,tonedur,dur,reps: integer);
procedure scale(freq1,freq2,freq3: integer;a,b,c,d,e,f,g,aa: integer);
procedure scale2(a,b,c,d,e,f,g,z: integer;dtime,attack,decay: integer;
                 v: voices);

procedure snd(freq: integer);
procedure snd2(freq: integer);
procedure nosnd;
procedure nosnd2;
procedure quiet;
function fkey: char;
function keyhit: boolean;

implementation

uses dos;

procedure wait(dt: longint);
const
  inturb = 32;
  indos = 60;
var tt,ir,tr: longint;
begin
  if inturbo then
    tt:=inturb
  else
    tt:=indos;
  for ir:=1 to dt do
    for tr:=1 to tt do
end;

procedure delay(dt: longint);
begin
  wait(dt);
end;

{$F+}
procedure sound(freq: word);
begin
  inline(
  $8B/$5E/$06/$B8/$DD/$34/
  $BA/$12/$00/$39/$DA/
  $73/$1A/$F7/$F3/$89/$C3/
  $E4/$61/$A8/$03/$75/$08/
  $0C/$03/$E6/$61/$B0/$B6/
  $E6/$43/$88/$D8/$E6/$42/
  $88/$F8/$E6/$42);
end;
{$F-}

procedure nosound;
begin
  inline($E4/$61/$24/$FC/$E6/$61);
end;

procedure sound_level(voice: voices;atten: attenuations);
{ change the level (atten) of a voice }
begin
  if (atten < 0) then
    atten:=0
  else
  if (atten > 15) then atten:=15;
  port[$C0]:=($90 + (voice shl 5) + (atten and $0F));
end;

procedure sound_period(voice: voices;period: integer);
{ change the sound divider (period) of a voice }
begin
  port[$C0]:=($80 + (voice shl 5) + (period and $0F)); { lo 4 bits }
  port[$C0]:=((period shr 4) and $3F);                 { hi 6 bits }
end;

procedure sound_pitch(voice: voices;freq: real);
{ change the pitch (freq) of a voice }
var period: real;

  function chip_freq(freq: real): word;
  begin
    chip_freq:=round(((3.579 * 1000000) / (freq * 32)));
  end;

begin
  if (freq = 0.0) then
    period:=0
  else
    period:=chip_freq(freq);
  if (period <= 1) or (period > $3FF) then period:=1;
  sound_period(voice,round(period));
end;

procedure sound_off;
var v: voices;
begin
  for v:=0 to 3 do
  begin
    sound_level(v,15);
    sound_pitch(v,0);
  end;
end;

procedure extsound(freq,dur: integer;level: attenuations;voice: voices);
begin
  sound_level(voice,level div 4);
  if ((freq < A3) or (voice = 3)) then
    sound(freq)
  else
    sound_pitch(voice,freq);
  wait(dur);
end;

procedure plays(freq,dur: word;attack,decay: integer;voice: voices);
var i,j,k: integer;
begin
  if (dur < 4) then dur:=4;
  if (freq < A3) then
  begin
    sound(freq);
    wait(dur);
  end else
  begin
    sound_pitch(voice,freq);
    for i:=attack downto 0 do
    begin
      sound_level(voice,i);
      wait(2);
    end;
    wait(dur-(attack-decay)-4);
    for i:=0 to decay do
    begin
      sound_level(voice,i);
      wait(2);
    end;
  end;
end;

procedure chord(freq1,freq2,freq3,dur,level: integer);
var i,j,k: integer;
begin
  if (level > 15) then
  begin
    for i:=15 downto (level - 15) do
    begin
      extsound(freq1,dur div 2,i,0);
      extsound(freq2,dur div 2,i,1);
      extsound(freq3,dur div 2,i,2);
    end;
    extsound(freq1,dur,level,0);
    extsound(freq2,dur,level,1);
    extsound(freq3,dur,level,2);
    wait(dur);
    exit;
  end else
  for i:=1 to level do
  begin
    extsound(freq1,dur div 2,i,0);
    extsound(freq2,dur div 2,i,1);
    extsound(freq3,dur div 2,i,2);
  end;
  extsound(freq1,dur,level,0);
  extsound(freq2,dur,level,1);
  extsound(freq3,dur,level,2);
  wait(dur);
end;

procedure play(freq,dur: integer;v: voices;style: styles);
var zz,z,x,xx,i: integer;
begin
  x:=dur div 3;
  xx:=dur div 2;
  z:=xx-x;
  zz:=x div 2;
  case style of
    1: begin
         extsound(freq,z,3,v);
         for i:=15 downto 1 do extsound(freq,zz,i,v);
         for i:=1 to 13 do extsound(freq,zz,i,v);
         extsound(freq,xx,2,v);
         exit;
       end;
    2: begin
         extsound(freq,xx+z,4,v);
         for i:=1 to 15 do
         begin
           extsound(freq,zz,5 xor i,v);
           if (v >= 2) then
             extsound(freq,zz,i,v-1)
           else
             extsound(freq,zz,i,v+1);
         end;
         exit;
       end;
    3: begin
         for i:=15 downto 1 do
         begin
           extsound(freq*2,1,i,v);
           if (v >=2) then
             extsound(freq,zz,i,v-1)
           else
             extsound(freq,zz,i,v+1);
         end;
         extsound(freq,zz,10,v);
         for i:=15 downto 7 do extsound(freq,zz,i,v);
         extsound(freq,xx,2,v);
         exit;
       end;
    4: begin
         for i:=0 to 15 do extsound(freq,1,i,v);
         for i:=15 downto 0 do
         begin
           if (v >= 2) then
             extsound(freq*2,zz,i,v-1)
           else
             extsound(freq*2,zz,i,v+1);
         end;
         for i:=7 to 15 do extsound(freq,zz,i,v);
         extsound(freq,xx,10,v);
         exit;
       end;
  end;
end;

procedure noise(ch: char;sr,atten,dur: word);
var portpass1: integer;
begin
  portpass1:=224;
  if (ch in ['W','w']) then portpass1:=portpass1 + 4;
  case sr of
    10: portpass1:=portpass1 + 1;
    20: portpass1:=portpass1 + 2;
  end;
  port[$C0]:=240+atten;
  port[$C0]:=portpass1;
  wait(dur);
end;

procedure note1(freq,dura: word);
var x: integer;
begin
  if keyhit then
  begin
    quiet;
    exit;
  end;
  if (legato=true) then
  begin
    sound(freq); wait(dura-7); sound(freq); wait(7);
  end else
  if (stacatto=true) then
  begin
    sound(freq); wait(dura-11);
    nosound; wait(11);
  end else
  if (zetto=true) then
  begin
    x:=dura div 3;
    sound(freq); wait(x);
    nosound; wait(x*2);
  end else
  if (xetto=true) then
  begin
    x:=dura div 5;
    sound(freq); wait(x);
    nosound; wait(x*4);
  end else
  begin
    sound(freq); wait(dura);
    nosound;
  end;
end;

procedure note4(note,dura: integer);
var x: integer;
begin
  if keyhit then
  begin
    quiet; exit;
  end;
  if (legato=true) then
  begin
    extsound(note,dura-7,0,0);
    extsound(note,7,0,0);
  end else
  if (stacatto=true) then
  begin
    extsound(note,dura-11,0,0);
    sound_level(1,15);
    wait(11);
  end else
  if (zetto=true) then
  begin
    x:=dura div 3;
    extsound(note,x,0,0);
    sound_level(1,15); wait(x*2);
  end else
  if (xetto=true) then
  begin
    x:=dura div 5;
    extsound(note,x,0,0);
    sound_level(1,15); wait(x*4);
  end else
  begin
    extsound(note,dura,0,0);
    sound_level(1,15);
  end;
end;

procedure dubend(freq1,freq2,dt: integer);
var i: integer;
begin
  for i:=freq1 to freq2 do extsound(i,dt,1,0);
  sound_level(0,15);
end;

procedure bend(tone,tone1,tonedur,dur,reps: integer);
var i,j: integer;
begin
  if (tone1 > tone) then
  begin
    for i:=1 to reps do
    begin
      extsound(tone1,tonedur,1,0);
      dubend(tone,tone1,dur);
      sound_level(0,15); wait(10);
    end;
  end else
  if (tone > tone1) then
  begin
    for i:=1 to reps do
    begin
      for j:=tone downto tone1 do extsound(j,dur,1,0);
      extsound(tone1,tonedur,1,0);
    end;
    sound_level(0,15);
  end;
end;

procedure scale(freq1,freq2,freq3: integer;a,b,c,d,e,f,g,aa: integer);
begin
  chord(freq1,freq2,freq3,1,5);
  if (freq1 >= A3) then
  begin
    note1(a,dtime); note1(b,dtime); note1(c,dtime); note1(d,dtime);
    note1(e,dtime); note1(f,dtime); note1(g,dtime); note1(aa,dtime);
  end else
  if (freq1 < A3) then
  begin
    note4(a,dtime); note4(b,dtime); note4(c,dtime); note4(d,dtime);
    note4(e,dtime); note4(f,dtime); note4(g,dtime); note4(aa,dtime);
  end;
  quiet;
end;

procedure scale2(a,b,c,d,e,f,g,z: integer;dtime,attack,decay: integer;
                 v: voices);
begin
  plays(a,dtime,attack,decay,v);
  plays(b,dtime,attack,decay,v);
  plays(c,dtime,attack,decay,v);
  plays(d,dtime,attack,decay,v);
  plays(e,dtime,attack,decay,v);
  plays(f,dtime,attack,decay,v);
  plays(g,dtime,attack,decay,v);
  plays(z,dtime,attack,decay,v);
end;

procedure snd(Freq: integer);
var Count: integer;
begin
  Count:=$1B1AAA div Freq;
  Port[$C0]:=$A5;
  port[$C0]:=$15;
  port[$C0]:=$A0;
  port[$C0]:=$A5;
  port[$C0]:=hi(count);
  port[$C0]:=$A0;
end;

procedure snd2(Freq: integer);
var Count: integer;
begin
  Count:=$1B1AAA div Freq;
  Port[$C0]:=$C5;
  port[$C0]:=$15;
  port[$C0]:=$C0;
  port[$C0]:=$C5;
  port[$C0]:=hi(count);
  port[$C0]:=$C0;
end;

procedure Nosnd;
var sport: Byte;
begin
  SPort:=Port[$C0];
  port[$C0]:=$BF;
end;

procedure Nosnd2;
var sport: Byte;
begin
  SPort:=Port[$C0];
  port[$C0]:=$DF;
  port[$C0]:=$BF;
end;

procedure quiet;
begin
  nosound;
  nosnd; nosnd2;
  sound_off;
  port[$C0]:=$9F;
end;

function fkey: char;
var regs: registers;
begin
  regs.AH:=0;
  intr($16,regs);
  if regs.AL=0 then
    fkey:=chr(regs.AH+128)
  else
    fkey:=chr(regs.AL)
end;

function keyhit: boolean;
var regs: registers;
begin
  regs.AH:=1;
  intr($16,regs);
  keyhit:=(regs.flags and 64)=0;
end;

end.