home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / CMSUNIT.ZIP / CMS.PAS next >
Encoding:
Pascal/Delphi Source File  |  1992-07-29  |  6.0 KB  |  255 lines
  1. Unit CMS;
  2. {
  3.   This unit was derived from a C source included in Jerry Joplin's CMS
  4.   guide.  Thanks for the info Jerry.
  5. }
  6.  
  7. {
  8.  
  9. The following Warranty text was "lifted" from Jerry Joplin's CMS guide.
  10. (I'm too lazy to type up my own)
  11.  
  12.                      Warranty and Copyright Policy
  13.  
  14. This document is provided on an "as-is" basis, and its author makes no
  15. warranty or representation, express or implied, with respect to its
  16. quality performance or fitness for a particular purpose.  In no event
  17. will the author of this document be liable for direct, indirect,
  18. special, incidental, or consequential damages arising out of the use or
  19. inability to use the information contained within.  Use of this document
  20. is at your own risk.
  21.  
  22. This file may be used and copied freely so long as the applicable
  23. copyright notices are retained, and no modifications are made to the
  24. text of the document.  No money shall be charged for its distribution
  25. beyond reasonable shipping, handling and duplication costs, nor shall
  26. proprietary changes be made to this document so that it cannot be
  27. distributed freely.  This document may not be included in published
  28. material or commercial packages without the written consent of its
  29. author.
  30.  
  31.   I anyone actually uses this code, please write me:
  32.  
  33.   Bryan Armstrong
  34.  
  35. at my home address
  36.  
  37.   11802 Gardenglen Dr.
  38.   Houston, TX  77070
  39.  
  40. OR my Internet address
  41.  
  42.   BMA7200@ZEUS.TAMU.EDU
  43.  
  44.  
  45. dated: 7/29/92
  46. }
  47.  
  48. Interface
  49.  
  50. Const
  51.      base = $220;
  52.  
  53. Var
  54.    k       : integer;
  55.    Amp     : Array [1..6] of byte;
  56.    Oct     : Array [$10..$12] of byte;
  57.    Frq     : Array [1..6] of byte;
  58.    FrqEn   : byte;
  59.    NoiEn   : byte;
  60.    NsFrq   : byte;
  61.  
  62. Procedure CMSSetReg (cmsport, register, value : integer);
  63. Procedure InitCMS;
  64. Procedure CMSSetAmp (voice, lAmp, rAmp : integer);
  65. Procedure CMSSetFreq (voice, freq : integer);
  66. Procedure CMSSetOctave (voice, octave : integer);
  67. Procedure CMSEnableVoice (voice : integer);
  68. Procedure CMSSetNoiseF (voice, freq : integer);
  69. Procedure CMSEnableNoise (voice : integer);
  70. Procedure CMSSound (voice,lAmp,rAmp,freq,oct : integer);
  71. Procedure CMSNoise (voice,lAmp,rAmp,noisenum : integer);
  72.  
  73. Implementation
  74.  
  75. Procedure CMSSetReg (cmsport, register, value : integer);
  76. Begin
  77.   port [cmsport] := register;
  78.   port [cmsport-1] := value;
  79. End;
  80.  
  81. Procedure InitCMS;
  82. Var
  83.    tport, i : integer;
  84. Begin
  85.   tport := base + 1;    { voice 1-6 registers }
  86.   For i := 0 to $20 Do
  87.     CMSSetReg (tport,i,0);
  88.   CMSSetReg(tport,$1C,$2);
  89.   tport := base + 3;    { voice 7-C registers }
  90.   For i := 0 to $20 Do
  91.     CMSSetReg (tport,i,0);
  92.   CMSSetReg(tport,$1C,$2);
  93.   For i := 1 to 6 Do
  94.     Begin
  95.       Amp [i] := 0;
  96.       Frq [i] := 0;
  97.     End;
  98.   For i := 1 to 3 Do
  99.     Oct [i] := 0;
  100.   FrqEn := 0;
  101.   NoiEn := 0;
  102.   NsFrq := 0;
  103. End;
  104.  
  105. Procedure CMSSetAmp (voice, lAmp, rAmp : integer);
  106. Var
  107.    tport : integer;
  108. Begin
  109.   If voice < 7 Then
  110.     tport := base + 1     { voice 1-6 }
  111.   Else
  112.     Begin
  113.       tport := base + 3;  { voice 7-C }
  114.       voice := voice - 6;
  115.     End;
  116.     Amp[voice] := (Amp[voice] shr 4) shl 4 + lAmp;
  117.     Amp[voice] := (Amp[voice] or 240) - 240 + rAmp shl 4;
  118.   CMSSetReg (tport,voice - 1, Amp[voice]);
  119. End;
  120.  
  121. Procedure CMSSetFreq (voice, freq : integer);
  122. Var
  123.    tport : integer;
  124. Begin
  125.   If voice < 7 Then
  126.     tport := base + 1     { voice 1-6 }
  127.   Else
  128.     Begin
  129.       tport := base + 3;  { voice 7-C }
  130.       voice := voice - 6;
  131.     End;
  132.   CMSSetReg (tport,$8 + voice - 1, freq);
  133. End;
  134.  
  135. Procedure CMSSetOctave (voice, octave : integer);
  136. Var
  137.    tport,
  138.    value,
  139.    reg   : integer;
  140. Begin
  141.   If voice < 7 Then
  142.     tport := base + 1         { voices 1-6 }
  143.   Else
  144.     tport := base + 3;        { voices 7-C }
  145.   If (voice AND 1) <> 0 Then
  146.     value := octave
  147.   Else
  148.     value := octave shl 4;
  149.   Case voice Of
  150.       1,2,7,8 : reg := $10;
  151.      3,4,9,10 : reg := $11;
  152.     5,6,11,12 : reg := $12;
  153.   End;
  154.   If (voice and 1) <> 0 Then
  155.     Oct[reg] := (Oct[reg] shr 4) shl 4 + value
  156.   Else
  157.     Oct[reg] := (Oct[reg] or 240) - 240 + value;
  158.   CMSSetReg (tport,reg,Oct[reg]);
  159. End;
  160.  
  161. Procedure CMSEnableVoice (voice : integer);
  162. Var
  163.    tport,
  164.    value : integer;
  165. Begin
  166.   If voice < 7 Then
  167.     Begin
  168.       tport := base + 1;          { voices 1-6 }
  169.       value := 1 shl (voice - 1);
  170.     End
  171.   Else
  172.     Begin
  173.       tport := base + 3;
  174.       value := 1 shl (voice - 7); { voice 7-C }
  175.     End;
  176.   If voice = 0 Then
  177.     Begin
  178.       CMSSetReg (base + 1,$14,0);
  179.       CMSSetReg (base + 3,$14,0);
  180.     End
  181.   Else
  182.     Begin
  183.       FrqEn := FrqEn or value;
  184.       CMSSetReg (tport,$14,FrqEn);
  185.       CMSSetReg (tport,$1C,1);
  186.     End;
  187. End;
  188.  
  189. Procedure CMSSetNoiseF (voice, freq : integer);
  190. Var
  191.    gen,
  192.    tport : integer;
  193. Begin
  194.   If voice < 7 Then
  195.     tport := base + 1         { voices 1-6 }
  196.   Else
  197.     tport := base + 3;        { voices 7-C }
  198.   Case voice Of
  199.     $1..$3 : gen := 1;
  200.     $4..$6 : gen := 2;
  201.     $7..$9 : gen := 3;
  202.     $A..$C : gen := 4;
  203.   End; { case }
  204.   Case gen Of
  205.     1,3 : NsFrq := (NsFrq shr 2) shl 2 + freq;
  206.     2,4 : NsFrq := (NsFrq or 240) - 240 + freq shl 4;
  207.   End; { case }
  208.   CMSSetReg (tport,$16,NsFrq);
  209. End;
  210.  
  211. Procedure CMSEnableNoise (voice : integer);
  212. Var
  213.    tport,
  214.    value : integer;
  215. Begin
  216.   If voice < 7 Then
  217.     Begin
  218.       tport := base + 1;          { voices 1-6 }
  219.       value := 1 shl (voice - 1);
  220.     End
  221.   Else
  222.     Begin
  223.       tport := base + 3;
  224.       value := 1 shl (voice - 7); { voice 7-C }
  225.     End;
  226.   If voice = 0 Then
  227.     Begin
  228.       CMSSetReg (base + 1,$15,0);
  229.       CMSSetReg (base + 3,$15,0);
  230.     End
  231.   Else
  232.     Begin
  233.       NoiEn := FrqEn or value;
  234.       CMSSetReg (tport,$15,NoiEn);
  235.       CMSSetReg (tport,$1C,1);
  236.     End;
  237. End;
  238.  
  239. Procedure CMSSound (voice,lAmp,rAmp,freq,oct : integer);
  240. Begin
  241.   CMSSetAmp (voice,lAmp,rAmp);
  242.   CMSSetFreq (voice,freq);
  243.   CMSSetOctave (voice,oct);
  244.   CMSEnableVoice (voice);
  245. End;
  246.  
  247. Procedure CMSNoise (voice,lAmp,rAmp,noisenum : integer);
  248. Begin
  249.   CMSSetAmp (voice,lAmp,rAmp);
  250.   CMSSetNoiseF (voice,noisenum);
  251.   CMSEnableNoise (voice);
  252. End;
  253.  
  254. End.
  255.