home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TMODEM.ZIP / MUSIC.INC < prev    next >
Encoding:
Text File  |  1987-06-15  |  13.1 KB  |  312 lines
  1. var
  2.    milleseconds   : real;
  3.  
  4. (****************************************************************************)
  5. (*                       INITIALIZE MUSIC VARIABLES                         *)
  6. (****************************************************************************)
  7.    procedure
  8.       initialize_music;
  9.    var
  10.       j,k    : integer;
  11.    begin
  12.  
  13.       { Frequencies for Octave 4. }
  14.  
  15.       scale[  0 ]  := 1661.220;  { A }
  16.       scale[  1 ]  := 1760.000;
  17.       scale[  2 ]  := 1864.640;
  18.  
  19.       scale[  3 ]  := 1864.640;  { B }
  20.       scale[  4 ]  := 1975.540;
  21.       scale[  5 ]  := 1975.540;
  22.  
  23.       scale[  6 ]  :=  987.770;  { C }
  24.       scale[  7 ]  := 1046.500;
  25.       scale[  8 ]  := 1108.740;
  26.  
  27.       scale[  9 ]  := 1108.740;  { D }
  28.       scale[ 10 ]  := 1174.700;
  29.       scale[ 11 ]  := 1244.500;
  30.  
  31.       scale[ 12 ]  := 1244.500;  { E }
  32.       scale[ 13 ]  := 1318.500;
  33.       scale[ 14 ]  := 1318.500;
  34.  
  35.       scale[ 15 ]  := 1318.500;  { F }
  36.       scale[ 16 ]  := 1396.900;
  37.       scale[ 17 ]  := 1479.980;
  38.  
  39.       scale[ 18 ]  := 1479.980;  { G }
  40.       scale[ 19 ]  := 1568.000;
  41.       scale[ 20 ]  := 1661.224;
  42.  
  43.       factor[ 0 ] := 0.0625;
  44.       factor[ 1 ] := 0.1250;
  45.       factor[ 2 ] := 0.2500;
  46.       factor[ 3 ] := 0.5000;
  47.       factor[ 4 ] := 1.0000;
  48.       factor[ 5 ] := 2.0000;
  49.       factor[ 6 ] := 4.0000;
  50.  
  51.       notes[ 49 ] := 1047;
  52.       notes[ 50 ] := 1109;
  53.       notes[ 51 ] := 1175;
  54.       notes[ 52 ] := 1245;
  55.       notes[ 53 ] := 1319;
  56.       notes[ 54 ] := 1397;
  57.       notes[ 55 ] := 1480;
  58.       notes[ 56 ] := 1568;
  59.       notes[ 57 ] := 1661;
  60.       notes[ 58 ] := 1760;
  61.       notes[ 59 ] := 1865;
  62.       notes[ 60 ] := 1976;
  63.       k := 48;
  64.       while k > 0 do begin
  65.          notes[ k ] := notes[ k+12 ] div 2;
  66.          k := k - 1;
  67.       end;
  68.       k := 61;
  69.       while k < 85 do begin
  70.          notes[ k ] := notes[ k-12 ] * 2;
  71.          k := k + 1;
  72.       end;
  73.  
  74.       dnote[ 0 ]  := 1.0;
  75.       dnote[ 1 ]  := 1.5;
  76.       dnote[ 2 ]  := 1.75;
  77.       dnote[ 3 ]  := 1.875;
  78.       dnote[ 4 ]  := 1.9375;
  79.       dnote[ 5 ]  := 1.96875;
  80.       dnote[ 6 ]  := 1.984375;
  81.  
  82.       milleseconds := wait_increment * 3.003003;
  83.       tempo        := 120.0;
  84.       music_mode   := 0.875;
  85.       rest_mode    := 0.125;
  86.       octave       := 4;
  87.       note_length  := 4;
  88.       tune_number := round(random * 3.0);
  89.    end;
  90.  
  91.    procedure
  92.       play_note( note,length,dcnt : integer );
  93.    var
  94.       dur                : real;
  95.    begin
  96.       dur  := 240.0 / tempo * milleseconds / length * dnote[dcnt] - 2.0;
  97.       if note > 100 then
  98.          sound( notes[ note - 100 ] )
  99.       else
  100.          if note <= 20 then
  101.             sound( round( scale[ note ] * factor[ octave ] ) )
  102.          else
  103.             nosound;
  104.       delay( round(dur * music_mode) );
  105.       if rest_mode > 0.09 then begin
  106.          nosound;
  107.          delay( round(dur * rest_mode) );
  108.       end;
  109.    end;
  110.  
  111.    function
  112.       mval( s : strtype; var i : integer ) : integer;
  113.    var
  114.       v  : integer;
  115.    begin
  116.       v:=0;
  117.       i:=i+1;
  118.       while s[i] in [ '0'..'9' ] do begin
  119.          v:= ( v * 10 ) + ord(s[i]) - ord('0');
  120.          i:=i+1;
  121.       end;
  122.       mval:=v;
  123.    end;
  124.  
  125.    procedure
  126.       play( ms : strtype );
  127.    var
  128.       i   : integer;
  129.       l   : integer;
  130.       n   : integer;
  131.    begin
  132.       if silent_mode then exit;
  133.       i := 1;
  134.       while i < length( ms ) do begin
  135.          if ms[i] in [ 'A'..'G','P' ] then begin
  136.             n := ( ( ord(ms[i]) - ord('A') ) * 3 ) + 1;
  137.             case ms[i+1] of
  138.                '#','+' : begin
  139.                             i:=i+1;
  140.                             n:=n+1;
  141.                          end;
  142.                '-'     : begin
  143.                             i:=i+1;
  144.                             n:=n-1;
  145.                          end;
  146.             end;
  147.             l:=mval( ms,i );
  148.             if l=0 then l:=note_length;
  149.             dots:=0;
  150.             while ms[i]='.' do begin
  151.                i:=i+1;
  152.                dots:=dots+1;
  153.             end;
  154.             play_note(n,l,dots);
  155.          end
  156.          else begin
  157.             case ms[i] of
  158.                'T' : begin
  159.                         tempo:=mval( ms,i );
  160.                         if tempo<32  then tempo:=32;
  161.                         if tempo>255 then tempo:=255;
  162.                      end;
  163.                'O' : begin
  164.                         octave:=mval( ms,i );
  165.                         if octave>6 then octave:=6;
  166.                      end;
  167.                '>' : begin
  168.                         if octave < 6 then octave := octave + 1;
  169.                         i:=i+1;
  170.                      end;
  171.                '<' : begin
  172.                         if octave > 0 then octave := octave - 1;
  173.                         i:=i+1;
  174.                      end;
  175.                'L' : begin
  176.                         note_length:=mval( ms,i );
  177.                         if note_length=0 then note_length:=4;
  178.                      end;
  179.                'N' : begin
  180.                         n:=mval( ms,i )+100;
  181.                         if n>184 then n:=184;
  182.                         dots:=0;
  183.                         while ms[i]='.' do begin
  184.                            i:=i+1;
  185.                            dots:=dots+1;
  186.                         end;
  187.                         play_note(n,note_length,dots);
  188.                      end;
  189.                'M' : begin
  190.                         i:=i+1;
  191.                         case ms[i] of
  192.                            'N' : begin
  193.                                     music_mode := 0.875;
  194.                                     rest_mode  := 0.125;
  195.                                  end;
  196.                            'L' : begin
  197.                                     music_mode := 1.0;
  198.                                     rest_mode  := 0.0;
  199.                                  end;
  200.                            'S' : begin
  201.                                     music_mode := 0.75;
  202.                                     rest_mode  := 0.25;
  203.                                  end;
  204.                         end;
  205.                         i:=i+1;
  206.                      end;
  207.             else
  208.                i:=i+1;
  209.             end;
  210.          end;
  211.       end;
  212.       nosound;
  213.       escape_mode := false;
  214.    end;
  215.  
  216. procedure
  217.  music_box;
  218. begin
  219.  case tune_number of
  220.   0 : begin
  221.    play('L16T155O2MNB4P8MSBBMNB4P8MSBBB8G#8E8G#8B8G#8B8O3E8O2B8G#8E8G#8B8G#8B8O3E8O2MNB4P8MSBBMNB4 ');
  222.    play('P8MSBBMNB4P8MSBBMNB4P8MSBBB8BBB8B8B8BBB8B8B8BBB8B8B8BBB8B8MLB2B2B8P8P4P4P8MSO1BBB8BBB8BBO2E8F#8G#8O1BB ');
  223.    play('B8BBO2E8G#G#F#8D#8O1B8BBB8BBB8BBO2E8F#8G#8EG#MLB4BMSAG#F#E8G#8E8O3BBB8BBB8BBO4E8F#8 ');
  224.    play('G#8O3BBB8BBO4E8G#G#F#8D#8O3B8BBB8BBB8BBO4E8F#8G#8MLEG#B4BAG#F#MSE8G#8E8O3G#G#G#8G#G#G#8G#G# ');
  225.    play('G#8O4C#8O3G#8O4C#8O3G#8O4C#8O3G#8F#8E8D#8C#8G#G#G#8G#G#G#8G#G#G#8O4C#8O3G#8O4C#8O3G#8O4C#8 ');
  226.    play('O3B8A#8B8A#8B8G#G#G#8G#G#G#8G#G#G#8O4C#8O3G#8O4C#8O3G#8O4C#8O3G#8F#8 ');
  227.    play('E8D#8C#8G#G#G#8G#G#G#8G#G#G#8O4C#8O3G#8O4C#8O3G#8O4C#8O3B8A#8B8O2BBB8F#F#F#8F#F#F#8G#8A8F#4MNA8MSG#8MNE4 ');
  228.    play('MSG#8F#8F#8F#8O3F#F#F#8F#F#F#8G#8A8MNF#4MSA8G#8MNE4MSG#8F#8O2BBB8O1BBB8BBB8BBO2MNE8F#8G#8O1BB ');
  229.    play('B8BBO2E8G#G#F#8D#8O1B8BBB8BBB8BBO2E8F#8G#8EG#MLB4MNBAG#F#E8G#8E8O3BBB8BBB8BBO4E8F#8 ');
  230.    play('G#8O3BBB8BBO4E8G#G#F#8D#8O3B8BBB8BBB8BBO4E8F#8G#8MLEG#MLB4MNBAG#F#MNE8G#8E8 ');
  231.    play('O3MLE56F56G56A56B56O4C56D56MNE8EEE8E8G#4.F#8E8D#8E8C#8MSO3BO4C#O3BO4C#O3B ');
  232.    play('O4C#D#EO3ABABABO4C#D#O3G#AG#AG#ABO4C#O3F#G#F#G#F#G#F#G#F#G#F#D#O2BO3MLBO4C#D#E8D#8E8 ');
  233.    play('C#8O3MSBO4C#O3BO4C#O3BO4C#D#EO3ABABABO4C#D#O3G#AG#AG#ABO4C#O3F#G#F#G#F#AF#EMNE8P8MLC#4 ');
  234.    play('MNC#O2CMSO3C#O2CO3D#C#O2BAAG#EC#C#C#C#C#ED#O1CG#G#G#G#G#G#O2C#EG#O3C#C#C#C#C#O2CO3C#O2CO3D# ');
  235.    play('C#O2BAAG#EC#C#C#C#C#ED#O1CG#G#G#G#G#MNG#O2C#EG#O3MSC#ED#C#D#O2CG#G#G#O3G#EC#D#O2CG#G#G# ');
  236.    play('O3G#EC#D#O2BG#G#A#GD#D#G#GG#GG#AG#F#EO1BA#BO2EO1BO2F#O1BO2G#ED#EG#EAF#BO3G#F#ED# ');
  237.    play('F#EC#O2BO3C#O2BO3C#D#EF#G#O2ABABO3C#D#EF#O2G#AG#ACO3C#D#EO2F#G#F#G#F#G#F#G#F#G#F#D#O1B ');
  238.    play('CO2C#D#EO1BA#BO2EO1BO2F#O1BO2G#ED#EG#EAF#BO3G#F#ED#F#EC#O2BO3C#O2BO3C#D#EF#G#O2ABABO3C# ');
  239.    play('D#EF#O2G#AG#ABO3C#D#EO2F#O3C#O2CO3C#D#C#O2AF#MNEO3MLEF#G#ABO4C#D#MNE8MSEEE8E8G#4. ');
  240.    play('MSF8MSE8D#8E8C#8O3BO4C#O3BO4C#O3BO4C#D#EO3ABABABO4C#D#O3G#AG#AG#ABO4C#O3F#G#F#G#F# ');
  241.    play('G#F#G#F#G#F#D#O2BO3MLBO4C#D#MNE8EEE8E8G#4.MSF#8E8D#8E8C#8O3BO4C#O3BO4C#O3B ');
  242.    play('O4C#D#EO3ABABABO4C#D#O3G#AG#AG#ABO4C#O3F#G#F#G#F#AG#F#E8O2B8O3E8G#G#G#8MNG#G#G#8 ');
  243.    play('G#G#G#8O4C#8O3G#8O4C#8O3G#8O4C#8O3G#8F#8E8D#8C#8G#G#G#8G#G#G#8G#G#G#8O4C#8O3G#8 ');
  244.    play('O4C#8O3G#8O4C#8O3B8A#8B8A#8B8G#G#G#8G#G#G#8G#G#G#8O4C#8O3G#8O4C#8O3G#8O4C#8O3G#8 ');
  245.    play('F#8E8D#8C#8G#G#G#8G#G#G#8G#G#G#8O4C#8O3G#8O4C#8O3G#8O4C#8O3B8A#8B8A#8B8 ');
  246.    play('O2F#F#F#8F#F#F#8G#8A8F#4A8G#8E4G#8F#8O0B8O1B8O2F#F#F#8F#F#F#8G#8A8F#4A8G#8E4G#8F#8 ');
  247.    play('BBB8O1BBB8BBB8BBO2E8F#8G#8O1BBB8BBO2E8G#G#F#8D#8O1B8BBB8BBB8BBO2E8F#8G#8EG#MLB4MNB ');
  248.    play('AG#F#E8O1B8O2E8O3BBB8BBB8BBO4E8F#8G#8O3BBB8BBO4E8G#G#F#8D#8O3B8BBB8BBB8BBO4E8F#8G#8O3EG#MLB4 ');
  249.    play('MNBAG#F#MLEF#G#MNAMLG#ABO4MNC#MLO3BO4C#D#MNEMLD#EF#MNG#AO3BO4AO3BO4AO3BO4AO3BO4AO3BO4AO3BO4AO3BO4AO3BMLE ');
  250.    play('F#G#MNAMLG#ABMNO4C#MLO3BO4C#D#MNEMLD#EF#MNG#AO3BO4AO3BO4AO3BO4AO3BO4AO3BO4AO3BO4AO3BO4AO3BP16 ');
  251.    play('MLG#O4G#O3MNG#P16MLD#O4D#O3MND#P16MLEO4EO3MNEP16MLAO4AO3MNAP16MLG#O4G#O3MNG#P16MLD#O4D#O3MND#P16MLEO4EO3MNEP16 ');
  252.   end;
  253.   1 : begin
  254.    play('L32T70 O1E-CE-GO2CE-DCO1BGBO2DGFE-DE-CE-G ');
  255.    play('L32T70 O3CE-DCDCO2BAGFE-DE-CE-GO3C ');
  256.    play('L32T70O2 E-DCO2BBBO3DGFE-FE- ');
  257.    play('L32T70 O3CE-GO4CE-DCDCO3BAGFE-DE-CO2GE- ');
  258.    play('L32T70O2 CO4CO3GE-A-O1FA-O2CFA-O3CE-DO2B-FDO1B- ');
  259.    play('L32T70 O3B-FDGO1E-GB-O2E-GB-O3DCO2AG#AO3CO2 ');
  260.    play('L32T70O2 AGAO3E-CO2GAO3E-CO2GAO3DCO2F#A ');
  261.    play('L32T70 O3ACO2F#AO3F#CO2DAO3CO2AF#DB- ');
  262.    play('L32T70 O0GB-O1DGB-AGF#DF#AO2DCO1B-A ');
  263.    play('L32T70O2 B-GB-O2DGB-AGAGF#EDCO1B-AB-A-B-O2DGB-AGF#DF# ');
  264.    play('L32T70O2 AO3DCO2B-A-B-GB-O3DGB-AGAGF#AO2DCO1B-AB-GB-O3D ');
  265.    play('L32T70O2 GDO2B-GP32O3GDO2BGBO3DGP32O2GO3G ');
  266.    play('L32T70 O2GP32O2GO3GO2GO2B-GO3GO2GO2DGO3GO2G ');
  267.    play('L32T70 O3E-CE-GO4CO3GE-CP32O4CO2GECEGO4C ');
  268.    play('L32T70 P32O3CO4CO3CO2AO3CO4CO3CO2GO3CB-CP32O3CB-CAO0 ');
  269.    play('L32T70O2 FA-O1CFA-GFECEGO2CO1B-A-GFGFAO2CFAGFGFEDCO1B-A-GA-FA-C ');
  270.    play('L32T70O2 FA-GFECEGO3CO2B-A-GA-FA-CO3FA-GFGFEDC ');
  271.    play('L32T70O2 B-A-GA-O3FCO2A-FO3CO2A-FCA-FCO1A-O2FCO1A-O0L16D-.P32 ');
  272.    play('L32T70 O3A-FEFGFEFO0L16C.P32L32O2AFEFGF ');
  273.    play('L32T70O2 EFO0L16B-.P32L32O4DO3FGA-GFE-D ');
  274.    play('L32T70 O3E-GO4DO3GB-A-GFEL16O0E-P16L32O3E-.L64E-DE-DC ');
  275.    play('L32T70O2 DO2E-GO3GO2GO0CO2GO3GO2GO0B-O2GO3FO2GO0DO2GO3FO2GB-G ');
  276.    play('L32T70 O3EO2GP32O2GO3EO2GL64FAL32O3E-O5CO3E-L64O3FAL32O3E-O5C ');
  277.    play('L32T70 O3E-O1A-O2FO3DO2FO1A-O2FO3DO2FL64E-GL32O3D-O4B- ');
  278.    play('L32T70 O0F#O2E-O3CO2E-P32O2E-O3CO2E-P32E- ');
  279.    play('L32T70 O3CO2E-O0F#O3CO4CO3CO0F#O3CO4CO3CO0GO3CE-G ');
  280.    play('L32T70 O4CO3GE-CGE-CO2GO3FDO2BFE-O1CE-GO2CE-DCO1BGBO2DGFE-DE-CE-GO3CE-D ');
  281.    play('L32T70O2 CDCO2BAGFE-DE-CE-GO3CE-DCO2BGBO3DGFE-DE-CE- ');
  282.    play('L32T70O2 GO4CE-DO3BO4C ');
  283.   end;
  284.   2 : begin
  285.    play('T120O3L32P32B-O4CDCO3L16B-O4FDB-FDL32FE-DE-L16FO3B-O4DO3FA-GL32E-FGFL16E-B-GO4E-O3B-GL32B-A-GA- ');
  286.    play('L16B-E-GCE-O2AL32O3CDE-DL16CAFO4CO3AO4E-L32O3FGAGL16FO4CO3AO4FCD4P4P16L32GFE-FL16GC8P8P16 ');
  287.    play('L32FE-DE-F16O3B-8P8P16E-DCDE-16O3A16O4CO3B-AB-O4C16O3F8P8O4F8O3F8A8O4C8F4P4 ');
  288.    play('P8O3F8B-8O4D8F4P4P8O3G8B-8O4C8E4P4P16O3FGAGL16FO4CO3AO4FCAL32E-DCD ');
  289.    play('L16E-O3AO4CO3F+AL8B-O4DO3B-GA-O4FO3AFG16L32CDE-DL16CGE-O4CO3GO4DL32 ');
  290.    play('O3A-GFGL16A-DFO2BO3GE-8P8P16L32CDE-DC16O4C8.O3B-16A-16FGA-GF16O4F8.E-16D16O3B-O4CDCO3B-16 ');
  291.    play('O4B-8.A-16G16B-A-GA-B-16E-16GFE-FG16C16E-DCDE-16O3A16O4CDE-DC16F16O3A-GFGA-16G16B- ');
  292.    play('O4CDCO3B-16O4E-16O3GFE-FG16F16AB-O4CO3B-A16O4D16O3FE-DE-F16E-16GAB-AG16O4C16O3E-DCDE-16D16 ');
  293.    play('P8.P16B-O4CDCO3B-16L16O4FDB-FDL32FE-DE-L16FO3B-O4E-O3B-O4E-O3GL32E-FGFL16E-B-GO4E-O3B-G ');
  294.    play('L32B-A-GA-B-16E-8O4E-8E-16E-DCDE-16O3E-8O4E-8E-16CDE-DC16F16DCO3B-O4CD16L16O3FB-O4CO3A-B-2P2 ');
  295.   end;
  296.   3 : begin
  297.    play('T175O2G+8A8O3C8E-4D8D-8C8O2G+8A8O3C8E-4D8D-8C8O2G+8A8O3C8E-8O2G+8A8O3C8E-8O2G+8A8O3C8 ');
  298.    play('E-4D8D-8C8O2C+8D8F8A-4G8G-8F8C+8D8F8A-4G8G-8F8G+8A8O3C8E-4D8D-8C8O2G+8A8O3C8 ');
  299.    play('E-4D8D-8C8O2D+8E8G8B-4A8A-8A8C+8D8F8A-4G8G-8F8G+8A8O3C8P8F3F4F8F3C8O2F3P4 ');
  300.    play('O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8 ');
  301.    play('O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8 ');
  302.    play('C+8D8F8C+8D8F8C+8D8F8C+8D8F8C+8D8F8C+8D8F8C+8D8F8C+8D8F8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8 ');
  303.    play('O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8O2G+8A8O3C8D+8E8G8E8E3P4C+8D8F8D8D3P4 ');
  304.    play('P8F3F4F8F4C8D8O2F8P8G+8A8O3C8O2G+8A8O3C8E-4D8D-8C8O2G+8A8O3C8E-8O2G+8A8O3C8E-8O2G+8A8O3C8 ');
  305.    play('E-4D8D-8C8O2C+8D8F8A-4G8G-8F8C+8D8F8A-4G8G-8F8G+8A8O3C8E-4D8D-8C8O2G+8A8O3C8 ');
  306.    play('E-4D8D-8C8O2D+8E8G8B-4A8A-8A8C+8D8F8A-4G8G-8F8G+8A8O3C8P8F3F4F8F3C8O2F3P4 ');
  307.   end;
  308.  end;
  309.  tune_number := tune_number + 1;
  310.  if tune_number > 3 then tune_number := 0;
  311. end;
  312.