home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / sound / tandy100 / noiz.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-07-28  |  11.5 KB  |  497 lines
  1. unit noiz;   { NOIZ.PAS  Copyright (c) 1990 DSoft Specialties }
  2. interface    { Sound routines for the Tandy 1000 and/or PCJr. See NOIZ.SIM }
  3.  
  4. { All I ask is if you use any of these routines in your program
  5.   please mention DSoft in the docs or in a copyright message }
  6.  
  7. const
  8.   inturbo: boolean = true;
  9.  
  10. type
  11.   voices = 0..3;
  12.   attenuations = 0..15;
  13.   styles = 1..4;
  14.  
  15. const
  16.   A1 = 27;  A2 = 55;  A3 = 110;  A4 = 220;  A5 = 440;  A6 = 880;  A7 = 1760;
  17.   B1 = 31;  B2 = 62;  B3 = 123;  B4 = 247;  B5 = 494;  B6 = 988;  B7 = 1976;
  18.   C1 = 33;  C2 = 65;  C3 = 131;  C4 = 262;  C5 = 523;  C6 = 1047; C7 = 2093;
  19.   D1 = 37;  D2 = 74;  D3 = 147;  D4 = 294;  D5 = 588;  D6 = 1175; D7 = 2349;
  20.   E1 = 41;  E2 = 83;  E3 = 165;  E4 = 330;  E5 = 660;  E6 = 1320; E7 = 2640;
  21.   F1 = 44;  F2 = 88;  F3 = 175;  F4 = 350;  F5 = 700;  F6 = 1400; F7 = 2800;
  22.   G1 = 49;  G2 = 98;  G3 = 196;  G4 = 392;  G5 = 784;  G6 = 1568; G7 = 3136;
  23.  
  24.   A8 = 3520;  A9 = 7040;  A10 = 14080;
  25.   B8 = 3952;  B9 = 7904;  B10 = 15808;
  26.   C8 = 4160;  C9 = 8320;  C10 = 16640;
  27.   D8 = 4704;  D9 = 9408;  D10 = 18816;
  28.   E8 = 5280;  E9 = 10560;
  29.   F8 = 5600;  F9 = 11200;
  30.   G8 = 6272;  G9 = 12544;
  31.  
  32.   AS1 = 29; AS2 = 58; AS3 = 116; AS4 = 231; AS5 = 466; AS6 = 928; AS7 = 1856;
  33.   CS1 = 34; CS2 = 69; CS3 = 139; CS4 = 277; CS5 = 554; CS6 = 1108;CS7 = 2240;
  34.   DS1 = 39; DS2 = 78; DS3 = 156; DS4 = 311; DS5 = 622; DS6 = 1244;DS7 = 2496;
  35.   FS1 = 46; FS2 = 93; FS3 = 185; FS4 = 370; FS5 = 740; FS6 = 1480;FS7 = 2960;
  36.   GS1 = 26; GS2 = 52; GS3 = 208; GS4 = 415; GS5 = 830; GS6 = 1660;GS7 = 3320;
  37.  
  38.   AS8 = 3712;  AS9 = 7424;  AS10 = 14848;
  39.   CS8 = 4480;  CS9 = 8960;  CS10 = 17920;
  40.   DS8 = 4992;  DS9 = 9984;  DS10 = 19968;
  41.   FS8 = 5920;  FS9 = 11840;
  42.   GS8 = 6640;  GS9 = 13280;
  43.  
  44. const
  45.   stacatto: boolean = false;   legato: boolean = false;
  46.   zetto:    boolean = false;   xetto:  boolean = false;
  47.   dtime:    integer = 80;
  48.  
  49. procedure wait(dt: longint);
  50. procedure delay(dt: longint);
  51. procedure sound(freq: word);
  52. procedure nosound;
  53. procedure sound_level(voice: voices;atten: attenuations);
  54. procedure sound_period(voice: voices;period: integer);
  55. procedure sound_pitch(voice: voices;freq: real);
  56. procedure sound_off;
  57. procedure extsound(freq,dur: integer;level: attenuations;voice: voices);
  58. procedure plays(freq,dur: word;attack,decay: integer;voice: voices);
  59. procedure chord(freq1,freq2,freq3,dur,level: integer);
  60. procedure play(freq,dur: integer;v: voices;style: styles);
  61. procedure noise(ch: char;sr,atten,dur: word);
  62. procedure note1(freq,dura: word);
  63. procedure note4(note,dura: integer);
  64. procedure dubend(freq1,freq2,dt: integer);
  65. procedure bend(tone,tone1,tonedur,dur,reps: integer);
  66. procedure scale(freq1,freq2,freq3: integer;a,b,c,d,e,f,g,aa: integer);
  67. procedure scale2(a,b,c,d,e,f,g,z: integer;dtime,attack,decay: integer;
  68.                  v: voices);
  69.  
  70. procedure snd(freq: integer);
  71. procedure snd2(freq: integer);
  72. procedure nosnd;
  73. procedure nosnd2;
  74. procedure quiet;
  75. function fkey: char;
  76. function keyhit: boolean;
  77.  
  78. implementation
  79.  
  80. uses dos;
  81.  
  82. procedure wait(dt: longint);
  83. const
  84.   inturb = 32;
  85.   indos = 60;
  86. var tt,ir,tr: longint;
  87. begin
  88.   if inturbo then
  89.     tt:=inturb
  90.   else
  91.     tt:=indos;
  92.   for ir:=1 to dt do
  93.     for tr:=1 to tt do
  94. end;
  95.  
  96. procedure delay(dt: longint);
  97. begin
  98.   wait(dt);
  99. end;
  100.  
  101. {$F+}
  102. procedure sound(freq: word);
  103. begin
  104.   inline(
  105.   $8B/$5E/$06/$B8/$DD/$34/
  106.   $BA/$12/$00/$39/$DA/
  107.   $73/$1A/$F7/$F3/$89/$C3/
  108.   $E4/$61/$A8/$03/$75/$08/
  109.   $0C/$03/$E6/$61/$B0/$B6/
  110.   $E6/$43/$88/$D8/$E6/$42/
  111.   $88/$F8/$E6/$42);
  112. end;
  113. {$F-}
  114.  
  115. procedure nosound;
  116. begin
  117.   inline($E4/$61/$24/$FC/$E6/$61);
  118. end;
  119.  
  120. procedure sound_level(voice: voices;atten: attenuations);
  121. { change the level (atten) of a voice }
  122. begin
  123.   if (atten < 0) then
  124.     atten:=0
  125.   else
  126.   if (atten > 15) then atten:=15;
  127.   port[$C0]:=($90 + (voice shl 5) + (atten and $0F));
  128. end;
  129.  
  130. procedure sound_period(voice: voices;period: integer);
  131. { change the sound divider (period) of a voice }
  132. begin
  133.   port[$C0]:=($80 + (voice shl 5) + (period and $0F)); { lo 4 bits }
  134.   port[$C0]:=((period shr 4) and $3F);                 { hi 6 bits }
  135. end;
  136.  
  137. procedure sound_pitch(voice: voices;freq: real);
  138. { change the pitch (freq) of a voice }
  139. var period: real;
  140.  
  141.   function chip_freq(freq: real): word;
  142.   begin
  143.     chip_freq:=round(((3.579 * 1000000) / (freq * 32)));
  144.   end;
  145.  
  146. begin
  147.   if (freq = 0.0) then
  148.     period:=0
  149.   else
  150.     period:=chip_freq(freq);
  151.   if (period <= 1) or (period > $3FF) then period:=1;
  152.   sound_period(voice,round(period));
  153. end;
  154.  
  155. procedure sound_off;
  156. var v: voices;
  157. begin
  158.   for v:=0 to 3 do
  159.   begin
  160.     sound_level(v,15);
  161.     sound_pitch(v,0);
  162.   end;
  163. end;
  164.  
  165. procedure extsound(freq,dur: integer;level: attenuations;voice: voices);
  166. begin
  167.   sound_level(voice,level div 4);
  168.   if ((freq < A3) or (voice = 3)) then
  169.     sound(freq)
  170.   else
  171.     sound_pitch(voice,freq);
  172.   wait(dur);
  173. end;
  174.  
  175. procedure plays(freq,dur: word;attack,decay: integer;voice: voices);
  176. var i,j,k: integer;
  177. begin
  178.   if (dur < 4) then dur:=4;
  179.   if (freq < A3) then
  180.   begin
  181.     sound(freq);
  182.     wait(dur);
  183.   end else
  184.   begin
  185.     sound_pitch(voice,freq);
  186.     for i:=attack downto 0 do
  187.     begin
  188.       sound_level(voice,i);
  189.       wait(2);
  190.     end;
  191.     wait(dur-(attack-decay)-4);
  192.     for i:=0 to decay do
  193.     begin
  194.       sound_level(voice,i);
  195.       wait(2);
  196.     end;
  197.   end;
  198. end;
  199.  
  200. procedure chord(freq1,freq2,freq3,dur,level: integer);
  201. var i,j,k: integer;
  202. begin
  203.   if (level > 15) then
  204.   begin
  205.     for i:=15 downto (level - 15) do
  206.     begin
  207.       extsound(freq1,dur div 2,i,0);
  208.       extsound(freq2,dur div 2,i,1);
  209.       extsound(freq3,dur div 2,i,2);
  210.     end;
  211.     extsound(freq1,dur,level,0);
  212.     extsound(freq2,dur,level,1);
  213.     extsound(freq3,dur,level,2);
  214.     wait(dur);
  215.     exit;
  216.   end else
  217.   for i:=1 to level do
  218.   begin
  219.     extsound(freq1,dur div 2,i,0);
  220.     extsound(freq2,dur div 2,i,1);
  221.     extsound(freq3,dur div 2,i,2);
  222.   end;
  223.   extsound(freq1,dur,level,0);
  224.   extsound(freq2,dur,level,1);
  225.   extsound(freq3,dur,level,2);
  226.   wait(dur);
  227. end;
  228.  
  229. procedure play(freq,dur: integer;v: voices;style: styles);
  230. var zz,z,x,xx,i: integer;
  231. begin
  232.   x:=dur div 3;
  233.   xx:=dur div 2;
  234.   z:=xx-x;
  235.   zz:=x div 2;
  236.   case style of
  237.     1: begin
  238.          extsound(freq,z,3,v);
  239.          for i:=15 downto 1 do extsound(freq,zz,i,v);
  240.          for i:=1 to 13 do extsound(freq,zz,i,v);
  241.          extsound(freq,xx,2,v);
  242.          exit;
  243.        end;
  244.     2: begin
  245.          extsound(freq,xx+z,4,v);
  246.          for i:=1 to 15 do
  247.          begin
  248.            extsound(freq,zz,5 xor i,v);
  249.            if (v >= 2) then
  250.              extsound(freq,zz,i,v-1)
  251.            else
  252.              extsound(freq,zz,i,v+1);
  253.          end;
  254.          exit;
  255.        end;
  256.     3: begin
  257.          for i:=15 downto 1 do
  258.          begin
  259.            extsound(freq*2,1,i,v);
  260.            if (v >=2) then
  261.              extsound(freq,zz,i,v-1)
  262.            else
  263.              extsound(freq,zz,i,v+1);
  264.          end;
  265.          extsound(freq,zz,10,v);
  266.          for i:=15 downto 7 do extsound(freq,zz,i,v);
  267.          extsound(freq,xx,2,v);
  268.          exit;
  269.        end;
  270.     4: begin
  271.          for i:=0 to 15 do extsound(freq,1,i,v);
  272.          for i:=15 downto 0 do
  273.          begin
  274.            if (v >= 2) then
  275.              extsound(freq*2,zz,i,v-1)
  276.            else
  277.              extsound(freq*2,zz,i,v+1);
  278.          end;
  279.          for i:=7 to 15 do extsound(freq,zz,i,v);
  280.          extsound(freq,xx,10,v);
  281.          exit;
  282.        end;
  283.   end;
  284. end;
  285.  
  286. procedure noise(ch: char;sr,atten,dur: word);
  287. var portpass1: integer;
  288. begin
  289.   portpass1:=224;
  290.   if (ch in ['W','w']) then portpass1:=portpass1 + 4;
  291.   case sr of
  292.     10: portpass1:=portpass1 + 1;
  293.     20: portpass1:=portpass1 + 2;
  294.   end;
  295.   port[$C0]:=240+atten;
  296.   port[$C0]:=portpass1;
  297.   wait(dur);
  298. end;
  299.  
  300. procedure note1(freq,dura: word);
  301. var x: integer;
  302. begin
  303.   if keyhit then
  304.   begin
  305.     quiet;
  306.     exit;
  307.   end;
  308.   if (legato=true) then
  309.   begin
  310.     sound(freq); wait(dura-7); sound(freq); wait(7);
  311.   end else
  312.   if (stacatto=true) then
  313.   begin
  314.     sound(freq); wait(dura-11);
  315.     nosound; wait(11);
  316.   end else
  317.   if (zetto=true) then
  318.   begin
  319.     x:=dura div 3;
  320.     sound(freq); wait(x);
  321.     nosound; wait(x*2);
  322.   end else
  323.   if (xetto=true) then
  324.   begin
  325.     x:=dura div 5;
  326.     sound(freq); wait(x);
  327.     nosound; wait(x*4);
  328.   end else
  329.   begin
  330.     sound(freq); wait(dura);
  331.     nosound;
  332.   end;
  333. end;
  334.  
  335. procedure note4(note,dura: integer);
  336. var x: integer;
  337. begin
  338.   if keyhit then
  339.   begin
  340.     quiet; exit;
  341.   end;
  342.   if (legato=true) then
  343.   begin
  344.     extsound(note,dura-7,0,0);
  345.     extsound(note,7,0,0);
  346.   end else
  347.   if (stacatto=true) then
  348.   begin
  349.     extsound(note,dura-11,0,0);
  350.     sound_level(1,15);
  351.     wait(11);
  352.   end else
  353.   if (zetto=true) then
  354.   begin
  355.     x:=dura div 3;
  356.     extsound(note,x,0,0);
  357.     sound_level(1,15); wait(x*2);
  358.   end else
  359.   if (xetto=true) then
  360.   begin
  361.     x:=dura div 5;
  362.     extsound(note,x,0,0);
  363.     sound_level(1,15); wait(x*4);
  364.   end else
  365.   begin
  366.     extsound(note,dura,0,0);
  367.     sound_level(1,15);
  368.   end;
  369. end;
  370.  
  371. procedure dubend(freq1,freq2,dt: integer);
  372. var i: integer;
  373. begin
  374.   for i:=freq1 to freq2 do extsound(i,dt,1,0);
  375.   sound_level(0,15);
  376. end;
  377.  
  378. procedure bend(tone,tone1,tonedur,dur,reps: integer);
  379. var i,j: integer;
  380. begin
  381.   if (tone1 > tone) then
  382.   begin
  383.     for i:=1 to reps do
  384.     begin
  385.       extsound(tone1,tonedur,1,0);
  386.       dubend(tone,tone1,dur);
  387.       sound_level(0,15); wait(10);
  388.     end;
  389.   end else
  390.   if (tone > tone1) then
  391.   begin
  392.     for i:=1 to reps do
  393.     begin
  394.       for j:=tone downto tone1 do extsound(j,dur,1,0);
  395.       extsound(tone1,tonedur,1,0);
  396.     end;
  397.     sound_level(0,15);
  398.   end;
  399. end;
  400.  
  401. procedure scale(freq1,freq2,freq3: integer;a,b,c,d,e,f,g,aa: integer);
  402. begin
  403.   chord(freq1,freq2,freq3,1,5);
  404.   if (freq1 >= A3) then
  405.   begin
  406.     note1(a,dtime); note1(b,dtime); note1(c,dtime); note1(d,dtime);
  407.     note1(e,dtime); note1(f,dtime); note1(g,dtime); note1(aa,dtime);
  408.   end else
  409.   if (freq1 < A3) then
  410.   begin
  411.     note4(a,dtime); note4(b,dtime); note4(c,dtime); note4(d,dtime);
  412.     note4(e,dtime); note4(f,dtime); note4(g,dtime); note4(aa,dtime);
  413.   end;
  414.   quiet;
  415. end;
  416.  
  417. procedure scale2(a,b,c,d,e,f,g,z: integer;dtime,attack,decay: integer;
  418.                  v: voices);
  419. begin
  420.   plays(a,dtime,attack,decay,v);
  421.   plays(b,dtime,attack,decay,v);
  422.   plays(c,dtime,attack,decay,v);
  423.   plays(d,dtime,attack,decay,v);
  424.   plays(e,dtime,attack,decay,v);
  425.   plays(f,dtime,attack,decay,v);
  426.   plays(g,dtime,attack,decay,v);
  427.   plays(z,dtime,attack,decay,v);
  428. end;
  429.  
  430. procedure snd(Freq: integer);
  431. var Count: integer;
  432. begin
  433.   Count:=$1B1AAA div Freq;
  434.   Port[$C0]:=$A5;
  435.   port[$C0]:=$15;
  436.   port[$C0]:=$A0;
  437.   port[$C0]:=$A5;
  438.   port[$C0]:=hi(count);
  439.   port[$C0]:=$A0;
  440. end;
  441.  
  442. procedure snd2(Freq: integer);
  443. var Count: integer;
  444. begin
  445.   Count:=$1B1AAA div Freq;
  446.   Port[$C0]:=$C5;
  447.   port[$C0]:=$15;
  448.   port[$C0]:=$C0;
  449.   port[$C0]:=$C5;
  450.   port[$C0]:=hi(count);
  451.   port[$C0]:=$C0;
  452. end;
  453.  
  454. procedure Nosnd;
  455. var sport: Byte;
  456. begin
  457.   SPort:=Port[$C0];
  458.   port[$C0]:=$BF;
  459. end;
  460.  
  461. procedure Nosnd2;
  462. var sport: Byte;
  463. begin
  464.   SPort:=Port[$C0];
  465.   port[$C0]:=$DF;
  466.   port[$C0]:=$BF;
  467. end;
  468.  
  469. procedure quiet;
  470. begin
  471.   nosound;
  472.   nosnd; nosnd2;
  473.   sound_off;
  474.   port[$C0]:=$9F;
  475. end;
  476.  
  477. function fkey: char;
  478. var regs: registers;
  479. begin
  480.   regs.AH:=0;
  481.   intr($16,regs);
  482.   if regs.AL=0 then
  483.     fkey:=chr(regs.AH+128)
  484.   else
  485.     fkey:=chr(regs.AL)
  486. end;
  487.  
  488. function keyhit: boolean;
  489. var regs: registers;
  490. begin
  491.   regs.AH:=1;
  492.   intr($16,regs);
  493.   keyhit:=(regs.flags and 64)=0;
  494. end;
  495.  
  496. end.
  497.