home *** CD-ROM | disk | FTP | other *** search
/ Software of the Month Club 1995 December / SOFM_Dec1995.bin / pc / os2 / vpascal / examples / test / testcrt.pas next >
Pascal/Delphi Source File  |  1995-10-31  |  9KB  |  362 lines
  1. {█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█}
  2. {█                                                       █}
  3. {█      Virtual Pascal Examples. Version 1.0.            █}
  4. {█      Crt unit test example.                           █}
  5. {█      ─────────────────────────────────────────────────█}
  6. {█      Copyright (C) 1995 B&M&T Corporation             █}
  7. {█      ─────────────────────────────────────────────────█}
  8. {█      Written by Vitaly Miryanov                       █}
  9. {█                                                       █}
  10. {▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀}
  11.  
  12. program TestCrt;
  13.  
  14. uses Crt, Use32;
  15.  
  16. var
  17.   I,OrigMode: Word;
  18.   ForeColor,BackColor: Byte;
  19.   S: String;
  20.  
  21. procedure RemoveKey;
  22. begin
  23.   repeat if ReadKey = #0 then ReadKey; until not KeyPressed;
  24. end;
  25.  
  26. { Note frequencies }
  27. const
  28.   noteC         = 523;          { Middle C }
  29.   noteD         = 587;
  30.   noteE         = 659;
  31.   noteF         = 698;
  32.   noteG         = 784;
  33.   noteA         = 880;
  34.   noteB         = 988;
  35.  
  36. {$IFNDEF OS2}
  37.  
  38. procedure PlaySound(Freq,Duration: Word);
  39. begin
  40.   Sound(Freq);
  41.   Delay(Duration);
  42.   NoSound;
  43. end;
  44.  
  45. {$ENDIF}
  46.  
  47. const
  48.   Pause = 0;
  49.   Delta: Integer = 1;
  50.   noteFd = (noteG + noteF) div 2;
  51.   noteGd = (noteA + noteG) div 2;
  52.  
  53. type
  54.   NoteRec = record
  55.     Note:     Integer;
  56.     Duration: ShortInt;
  57.     Octavo:   ShortInt;
  58.   end;
  59.  
  60. const
  61.   Music: array [1..59] of NoteRec =
  62.   (( Note: noteA; Duration: 8; Octavo: -1),
  63.    ( Note: noteC; Duration: 8; Octavo:  0),
  64.    ( Note: noteE; Duration: 8; Octavo:  0),
  65.    ( Note: noteC; Duration: 8; Octavo:  0),
  66.  
  67.    ( Note: noteD; Duration: 4; Octavo:  0),
  68.    ( Note: noteC; Duration: 8; Octavo:  0),
  69.    ( Note: noteB; Duration: 8; Octavo: -1),
  70.  
  71.    ( Note: noteE; Duration: 4; Octavo:  0),
  72.    ( Note: noteD; Duration: 4; Octavo:  0),
  73.  
  74.    ( Note: noteA; Duration: 4; Octavo: -1),
  75.    ( Note: Pause; Duration: 4; Octavo:  0),
  76.  
  77.    ( Note: noteC; Duration: 8; Octavo:  0),
  78.    ( Note: noteE; Duration: 8; Octavo:  0),
  79.    ( Note: noteG; Duration: 8; Octavo:  0),
  80.    ( Note: noteG; Duration: 8; Octavo:  0),
  81.  
  82.    ( Note: noteA; Duration: 4; Octavo:  0),
  83.    ( Note: noteG; Duration: 8; Octavo:  0),
  84.    ( Note: noteF; Duration: 8; Octavo:  0),
  85.  
  86.    ( Note: noteE; Duration: 2; Octavo:  0),
  87.  
  88.    ( Note: noteFd;Duration: 4; Octavo:  0), { Repeated: 1 }
  89.    ( Note: noteGd;Duration: 4; Octavo:  0),
  90.  
  91.    ( Note: noteB; Duration: 8; Octavo:  0),
  92.    ( Note: noteA; Duration: 8; Octavo:  0),
  93.    ( Note: noteE; Duration: 4; Octavo:  0),
  94.  
  95.    ( Note: Pause; Duration: 4; Octavo:  0),
  96.    ( Note: noteC; Duration: 8; Octavo:  0),
  97.    ( Note: noteA; Duration: 8; Octavo: -1),
  98.  
  99.    ( Note: noteE; Duration: 8; Octavo:  0),
  100.    ( Note: noteD; Duration: 8; Octavo:  0),
  101.    ( Note: noteF; Duration: 4; Octavo:  0),
  102.  
  103.    ( Note: Pause; Duration: 4; Octavo:  0),
  104.    ( Note: noteG; Duration: 8; Octavo:  0),
  105.    ( Note: noteF; Duration: 8; Octavo:  0),
  106.  
  107.    ( Note: noteE; Duration: 4; Octavo:  0),
  108.    ( Note: noteD; Duration: 8; Octavo:  0),
  109.    ( Note: noteC; Duration: 8; Octavo:  0),
  110.  
  111.    ( Note: noteE; Duration: 4; Octavo:  0),
  112.    ( Note: noteD; Duration: 4; Octavo:  0),
  113.  
  114.    ( Note: noteA; Duration: 2; Octavo: -1),
  115.  
  116.    ( Note: noteFd;Duration: 4; Octavo:  0),  { Repeated: 2 }
  117.    ( Note: noteGd;Duration: 4; Octavo:  0),
  118.  
  119.    ( Note: noteB; Duration: 8; Octavo:  0),
  120.    ( Note: noteA; Duration: 8; Octavo:  0),
  121.    ( Note: noteE; Duration: 4; Octavo:  0),
  122.  
  123.    ( Note: Pause; Duration: 4; Octavo:  0),
  124.    ( Note: noteC; Duration: 8; Octavo:  0),
  125.    ( Note: noteA; Duration: 8; Octavo: -1),
  126.  
  127.    ( Note: noteE; Duration: 8; Octavo:  0),
  128.    ( Note: noteD; Duration: 8; Octavo:  0),
  129.    ( Note: noteF; Duration: 4; Octavo:  0),
  130.  
  131.    ( Note: Pause; Duration: 4; Octavo:  0),
  132.    ( Note: noteG; Duration: 8; Octavo:  0),
  133.    ( Note: noteF; Duration: 8; Octavo:  0),
  134.  
  135.    ( Note: noteE; Duration: 4; Octavo:  0),
  136.    ( Note: noteD; Duration: 8; Octavo:  0),
  137.    ( Note: noteC; Duration: 8; Octavo:  0),
  138.  
  139.    ( Note: noteE; Duration: 4; Octavo:  0),
  140.    ( Note: noteD; Duration: 4; Octavo:  0),
  141.  
  142.    ( Note: noteA; Duration: 2; Octavo: -1)
  143.   );
  144.  
  145. procedure PlayNote(ANote: NoteRec);
  146. var
  147.   MS: Integer;
  148. begin
  149.   with ANote do
  150.   begin
  151.     MS := 2000 div Duration;
  152.     if Note = Pause then Delay(MS)
  153.    else
  154.     begin
  155.       Inc(Octavo,Delta);
  156.       while Octavo > 0 do
  157.       begin
  158.         Note := Note * 2;
  159.         Dec(Octavo);
  160.       end;
  161.       while Octavo < 0 do
  162.       begin
  163.         Note := Note div 2;
  164.         Inc(Octavo);
  165.       end;
  166.       PlaySound(Note,MS);
  167.     end;
  168.   end;
  169. end;
  170.  
  171. procedure StarSky;
  172. const
  173.   MAX_STARS        = 40;
  174.   STARS_IN_PROCESS = 4;
  175.   STAR_DELAY       = 120;
  176.   DUMMY_POS        = 255;
  177.   DUMMY_NO         = 255;
  178.  
  179. var
  180.   I,CurPass,CurStar: Integer;
  181.   Ch: Char;
  182.   StarArray: array [0..MAX_STARS] of Char;
  183.   PosX:      array [0..MAX_STARS] of Byte;
  184.   PosY:      array [0..MAX_STARS] of Byte;
  185.   CurStarNo:   array [1..STARS_IN_PROCESS] of Byte;
  186.   CurStarPass: array [1..STARS_IN_PROCESS] of Byte;
  187.  
  188. procedure Display_Char;
  189. var
  190.   Color: Byte;
  191. begin
  192.   case ch of
  193.     '·','∙': Color := LightCyan
  194.     else     Color := White;
  195.   end;
  196.   TextColor(Color);
  197.   GotoXY(PosX[I]+1, PosY[I]+1);
  198.   Write(ch);
  199. end;
  200.  
  201. { Normal Star }
  202.  
  203. procedure Star_Display;
  204. begin
  205.   Display_Char;
  206.   if CurPass = 3 then StarArray[I] := 'e';
  207. end;
  208.  
  209. { Explosive star }
  210.  
  211. procedure Star_Explode;
  212. begin
  213.   case CurPass of
  214.     1: ch := '+';
  215.     2: ch := '■';
  216.     3: ch := '';
  217.     4: begin
  218.          ch := '';
  219.          StarArray[I] := 'e';
  220.        end;
  221.   end;
  222.   Display_Char;
  223. end;
  224.  
  225. procedure Star_Initialize;
  226. var
  227.   X,Y: Word;
  228.   No,J: Integer;
  229.   Found: Boolean;
  230. begin
  231.   PosX[I] := DUMMY_POS;
  232.   PosY[I] := DUMMY_POS;
  233.   repeat
  234.     X := Random(Lo(WindMax)-Lo(WindMin));
  235.     Y := Random(Hi(WindMax)-Hi(WindMin));
  236.     Found := False;
  237.     for J := Low(PosX) to High(PosX) do
  238.       if (X = PosX[J]) and (Y = PosY[J]) then
  239.       begin
  240.         Found := True;
  241.         Break;
  242.       end;
  243.   until not Found;
  244.   PosX[I] := X;
  245.   PosY[I] := Y;
  246.   if Random(4) = 0 then ch := 'X' else ch := '·';
  247.   StarArray[I] := ch;
  248.   if ch = 'X' then ch := ' ';
  249.   Display_Char;
  250.   CurStarNo[CurStar] := DUMMY_NO;
  251.   repeat
  252.     No := Random(MAX_STARS);
  253.     Found := False;
  254.     for J := Low(CurStarNo) to High(CurStarNo) do
  255.     begin
  256.       if No = CurStarNo[J] then
  257.       begin
  258.         Found := True;
  259.         Break;
  260.       end;
  261.     end;
  262.   until not Found;
  263.   CurStarNo[CurStar] := No;
  264.   CurPass := 0;
  265. end;
  266.  
  267. procedure Star_Erase;
  268. begin
  269.   ch := ' ';
  270.   Display_Char;
  271.   Star_Initialize;
  272. end;
  273.  
  274. begin
  275.   Randomize;
  276.   for I := Low(CurStarNo) to High(CurStarNo) do
  277.   begin
  278.     CurStarNo[I]   := I;
  279.     CurStarPass[I] := 1;
  280.   end;
  281.   FillChar(StarArray, SizeOf(StarArray), ' ');
  282.   FillChar(PosX, SizeOf(PosX), DUMMY_POS);
  283.   FillChar(PosY, SizeOf(PosY), DUMMY_POS);
  284.   repeat
  285.     for CurStar := Low(CurStarNo) to High(CurStarNo) do
  286.     begin
  287.       I := CurStarNo[CurStar];
  288.       CurPass := CurStarPass[CurStar];
  289.       ch := StarArray[I];
  290.       case ch of
  291.         ' ': Star_Initialize;
  292.         '·': Star_Display;
  293.         'X': Star_Explode;
  294.         else Star_Erase;
  295.       end;
  296.       CurStarPass[CurStar] := CurPass + 1;
  297.       Delay(STAR_DELAY);
  298.       if KeyPressed then Exit;
  299.     end;
  300.   until False;
  301. end;
  302.  
  303. procedure BigLetterTitle(const S: String);
  304. begin
  305.   TextMode(CO40);
  306.   GotoXY((40-Length(S)) div 2, 10);
  307.   Write(S);
  308.   GotoXY(12, 20);
  309.   Write('Press any key...');
  310.   RemoveKey;
  311. end;
  312.  
  313. begin
  314.   CheckBreak := False;          { Disable Ctrl-Break }
  315.   OrigMode := LastMode;
  316.   BigLetterTitle('1. Music');
  317.   TextMode(CO80);
  318.   TextColor(LightGreen);
  319.   TextBackGround(Blue);
  320.   Window(20, 5, 60, 20);
  321.   ForeColor := Black;
  322.   BackColor := Black;
  323.   I := Low(Music);
  324.   repeat
  325.     TextColor(ForeColor);
  326.     TextBackGround(BackColor);
  327.     Write('**Press any key**');
  328.     Inc(ForeColor);
  329.     if ForeColor > White then
  330.     begin
  331.       ForeColor := Black;
  332.       Inc(BackColor);
  333.       if BackColor > LightGray then BackColor := Black;
  334.     end;
  335.     PlayNote(Music[I]);
  336.     Inc(I);
  337.     if I > High(Music) then
  338.     begin
  339.       I := Low(Music);
  340.       Dec(Delta);
  341.       if Delta = -2 then Delta := 1;
  342.     end;
  343.   until KeyPressed;
  344.   RemoveKey;
  345.   repeat
  346.     GotoXY(Random(Lo(WindMax)-Lo(WindMin))+1, Random(Hi(WindMax)-Hi(WindMin))+1);
  347.     Delay(1000);
  348.     case Random(3) of
  349.       0: ClrEol;
  350.       1: InsLine;
  351.       2: DelLine;
  352.     end;
  353.   until KeyPressed;
  354.   RemoveKey;
  355.   BigLetterTitle('2. Star sky');
  356.   TextMode(CO80);
  357.   TextBackground(Black);
  358.   ClrScr;
  359.   StarSky;
  360.   TextMode(OrigMode);
  361. end.
  362.