home *** CD-ROM | disk | FTP | other *** search
/ SPACE 2 / SPACE - Library 2 - Volume 1.iso / program / 167 / pascal / musscale.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-08-19  |  6.4 KB  |  245 lines
  1. PROGRAM MusicalScale;
  2.   CONST
  3.     Off  = 0;              {By: Merlin Hanson Genie:M.L.HANSON}
  4.     On   = 1;
  5.     Down = 0;
  6.     Up   = 1;
  7.   VAR
  8.     Period    : integer ;
  9.     C4        : real;
  10.     Volume    : 1..15;
  11.     Key       : char;
  12.     OldWord   : long_integer;
  13.     PeriodArr : ARRAY [1..13] OF integer;
  14.     Index     : 1..13;
  15.  
  16.   {$P-}   {Pointer range checking off.}
  17.   PROCEDURE KeyClicker(OnOff : integer);
  18.     TYPE
  19.       Pointer = ^long_integer;
  20.     VAR
  21.       Funny : RECORD
  22.                 CASE boolean OF
  23.                   TRUE  : (A : long_integer);
  24.                   FALSE : (P : Pointer);
  25.               END {record};
  26.       SSP : long_integer;
  27.  
  28.     FUNCTION Super
  29.      (StackPointer : long_integer)
  30.                    : long_integer;
  31.       GEMDOS($20);
  32.  
  33.     FUNCTION Peek( address: long_integer ): long_integer;
  34.       BEGIN
  35.         Funny.A := Address;
  36.         Peek    := Funny.P^;
  37.       END;
  38.  
  39.     PROCEDURE Poke( address, value: long_integer );
  40.       BEGIN
  41.         Funny.A  := Address;
  42.         Funny.P^ := Value;
  43.       END;
  44.  
  45.     BEGIN     {keyclicker}
  46.       SSP := Super(0);
  47.       CASE OnOff OF
  48.         OFF : BEGIN
  49.                 OldWord := Peek($484);
  50.                 Poke($484,OldWord & $FEFFFFFF);
  51.               END;
  52.         ON  : Poke($484,OldWord);
  53.       END {case};
  54.       SSP := Super(SSP);
  55.     END {keyclicker};
  56.   {$P=}
  57.  
  58.     {------------------ Following from CURSOR.PAS ------------------}
  59.   PROCEDURE out_char( c: integer );
  60.     CONST
  61.       screen = 2;
  62.  
  63.     PROCEDURE bconout( device, c: integer );
  64.       BIOS(3);
  65.  
  66.       BEGIN {out_char}
  67.         bconout( screen, c );
  68.       END;   {out_char}
  69.  
  70.   { Put a two-character escape sequence to the console device (an escape
  71.     followed by a single character) }
  72.   PROCEDURE out_escape( c: char );
  73.     CONST
  74.       escape = 27;
  75.     BEGIN
  76.       out_char( escape );
  77.       out_char( ord(c) );
  78.     END;
  79.  
  80.   { Clear the screen and move the cursor to the upper left position }
  81.   PROCEDURE ClrScr;
  82.     BEGIN
  83.       out_escape( 'E' )
  84.     END {clrscr};
  85.  
  86.   { Move to a specific screen coordinate.  Home is (1,1). }
  87.   PROCEDURE GotoXY( x, y: integer );
  88.     BEGIN
  89.       out_escape( 'Y' ); out_char( 31+x ); out_char( 31+y );
  90.     END {gotoxy};
  91.  
  92.       {----------------------- End of CURSOR.PAS ------------------}
  93.  
  94.   PROCEDURE FillPeriodArray;
  95.     CONST
  96.       Ratio = 0.943874313;  {  1 / (2 ^ [1/12] ) from a calculator. }
  97.       {For frequency, the ratio for adjacent semitones is
  98.        2 ^ (1/12) but the sound chip is based on period, rather than
  99.        frequency, so the reciprocal is used. }
  100.     VAR
  101.       PeriodReal : real;
  102.       i          : integer;
  103.  
  104.     BEGIN    {fillperiodarray}
  105.       PeriodReal   := C4;  {Change this slightly to tune.}
  106.       PeriodArr[1] := ROUND(PeriodReal);
  107.       FOR i := 2 TO 13 DO
  108.         BEGIN
  109.           PeriodReal   := PeriodReal * Ratio;
  110.           PeriodArr[i] := ROUND(PeriodReal);
  111.         END
  112.     END {fillperiodarray};
  113.  
  114.   PROCEDURE DisplayText;
  115.     BEGIN
  116.       ClrScr;
  117.       GOTOXY(9,37);
  118.       WriteLn('TUNING');
  119.       GOTOXY(11,25);
  120.       WriteLn('The current period for C4 is: 478'      );
  121.       WriteLn;
  122.       WriteLn('The nominal period is:        478' :57);
  123.     END {displayText};
  124.  
  125.   PROCEDURE Tune(UpDown : integer);
  126.     BEGIN
  127.       CASE UpDown OF
  128.         {Up means higher frequency, so lower period.}
  129.         Up   : C4 := C4 - 1;
  130.         Down : C4 := C4 + 1;
  131.       END {case};
  132.       FillPeriodArray;
  133.       {Remember the number printed is a *period*, so a larger
  134.       number is actually a *lower* frequency.  Its not very
  135.       appealing to the intuition.}
  136.       GOTOXY(11,55);
  137.       WriteLn(ROUND(C4));
  138.     END {tune};
  139.  
  140.   FUNCTION gia_read
  141.              (data : integer;
  142.           register : integer)
  143.                    : integer ;
  144.     XBIOS( 28 ) ;
  145.  
  146.   PROCEDURE gia_write
  147.                (data : integer;
  148.             register : integer) ;
  149.     XBIOS( 28 ) ;
  150.  
  151.   PROCEDURE EnableChannelA;
  152.     CONST
  153.       Reg7 = 7;       {The 'master control' register.}
  154.     VAR
  155.       dummy  : integer;
  156.       OldReg : integer;
  157.     BEGIN   {enablechannelA}
  158.       OldReg := gia_read(dummy,Reg7);
  159.       Gia_Write(OldReg & ($FE),       {Preserve PortA,PortB status.}
  160.                 Reg7 + 128);
  161.     END {enablechannelA};
  162.  
  163.   PROCEDURE Sound
  164.          (Period : integer;
  165.           Volume : integer);
  166.     CONST
  167.       Reg0 = 0;       {8 low-order  bits of period.}
  168.       Reg1 = 1;       {4 high-order bits of period.}
  169.       Reg8 = 8;       {Volume for channel A.       }
  170.     BEGIN      {sound}
  171.       gia_write(Volume      , Reg8 + 128);
  172.       gia_write(Period & $FF, Reg0 + 128);
  173.       Gia_Write(SHR(Period,8),Reg1 + 128);
  174.     END {sound};
  175.  
  176.   FUNCTION ConsoleInputNoEcho : char;
  177.     {Get one character from the console.
  178.      Don't print it on the monitor.}
  179.     GEMDOS ($07);
  180.  
  181.   PROCEDURE Silence;
  182.     {A brief moment of silence to take care of the case
  183.      where two adjacent notes are the same.}
  184.     VAR
  185.       k    : integer;
  186.       junk : real;
  187.     BEGIN
  188.       Sound(0,0);
  189.       junk  := 0;    {Avoid possible overflow.}
  190.       FOR k := 1 TO 500 Do
  191.         junk := junk * junk;
  192.     END{silence};
  193.  
  194.   PROCEDURE CleanUp;
  195.     CONST
  196.       Reg7 = 7;   {The 'master control' register.}
  197.     VAR
  198.       dummy  : integer;
  199.       OldReg : integer;
  200.     BEGIN
  201.       {Turn the volume down.}
  202.       Sound(0,0);
  203.       {Return ports to original state.}
  204.       OldReg := gia_read(dummy,Reg7);
  205.       {Force 6 low order bits to 1, sound off on all channels.}
  206.       gia_write(OldReg | $3F, Reg7 + 128);
  207.       KeyClicker(On);
  208.     END {cleanup};
  209.  
  210.   BEGIN        {main}
  211.     DisplayText;
  212.     KeyClicker(Off);
  213.     C4 := 478;
  214.     FillPeriodArray;
  215.     EnableChannelA;
  216.     Volume := 10;
  217.     LOOP
  218.       Key := ConsoleInputNoEcho;
  219.       EXIT IF Key IN ['q','Q'];
  220.       CASE Key OF
  221.         '+' : Tune(Up);
  222.         '-' : Tune(Down);
  223.         'c' : Index :=  1;
  224.         'd' : Index :=  3;
  225.         'e' : Index :=  5;
  226.         'f' : Index :=  6;
  227.         'g' : Index :=  8;
  228.         'a' : Index := 10;
  229.         'b' : Index := 12;
  230.         'C' : Index := 13;
  231.         {sharps and flats only provided for tuning.}
  232.         '1' : Index :=  2;   { C# }
  233.         '2' : Index :=  4;   { D# }
  234.  
  235.         '3' : Index :=  7;   { F# }
  236.         '4' : Index :=  9;   { G# }
  237.         '5' : Index := 11;   { A# }
  238.       END {case};
  239.       Silence;
  240.       Period := PeriodArr[Index];
  241.       Sound(Period,Volume);
  242.     END {loop};
  243.     CleanUp;
  244. END. {program}
  245.