{ÛßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÛ}
{Û                                                       Û}
{Û      Virtual Pascal Examples. Version 2.1.            Û}
{Û      Crt unit test example.                           Û}
{Û      ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÛ}
{Û      Copyright (C) 1995-2000 vpascal.com              Û}
{Û                                                       Û}
{ßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßß}

program TestCrt;

{&PMTYPE VIO}

uses Crt;

var
  I,OrigMode: Word;
  ForeColor,BackColor: Byte;
  S: String;

procedure RemoveKey;
begin
  repeat if ReadKey = #0 then ReadKey; until not KeyPressed;
end;

{ Note frequencies }
const
  noteC         = 523;          { Middle C }
  noteD         = 587;
  noteE         = 659;
  noteF         = 698;
  noteG         = 784;
  noteA         = 880;
  noteB         = 988;

{$IFNDEF VIRTUALPASCAL}

procedure PlaySound(Freq,Duration: Word);
begin
  Sound(Freq);
  Delay(Duration);
  NoSound;
end;

{$ENDIF}

const
  Pause = 0;
  Delta: Integer = 1;
  noteFd = (noteG + noteF) div 2;
  noteGd = (noteA + noteG) div 2;

type
  NoteRec = record
    Note:     Integer;
    Duration: ShortInt;
    Octavo:   ShortInt;
  end;

const
  Music: array [1..59] of NoteRec =
  (( Note: noteA; Duration: 8; Octavo: -1),
   ( Note: noteC; Duration: 8; Octavo:  0),
   ( Note: noteE; Duration: 8; Octavo:  0),
   ( Note: noteC; Duration: 8; Octavo:  0),

   ( Note: noteD; Duration: 4; Octavo:  0),
   ( Note: noteC; Duration: 8; Octavo:  0),
   ( Note: noteB; Duration: 8; Octavo: -1),

   ( Note: noteE; Duration: 4; Octavo:  0),
   ( Note: noteD; Duration: 4; Octavo:  0),

   ( Note: noteA; Duration: 4; Octavo: -1),
   ( Note: Pause; Duration: 4; Octavo:  0),

   ( Note: noteC; Duration: 8; Octavo:  0),
   ( Note: noteE; Duration: 8; Octavo:  0),
   ( Note: noteG; Duration: 8; Octavo:  0),
   ( Note: noteG; Duration: 8; Octavo:  0),

   ( Note: noteA; Duration: 4; Octavo:  0),
   ( Note: noteG; Duration: 8; Octavo:  0),
   ( Note: noteF; Duration: 8; Octavo:  0),

   ( Note: noteE; Duration: 2; Octavo:  0),

   ( Note: noteFd;Duration: 4; Octavo:  0), { Repeated: 1 }
   ( Note: noteGd;Duration: 4; Octavo:  0),

   ( Note: noteB; Duration: 8; Octavo:  0),
   ( Note: noteA; Duration: 8; Octavo:  0),
   ( Note: noteE; Duration: 4; Octavo:  0),

   ( Note: Pause; Duration: 4; Octavo:  0),
   ( Note: noteC; Duration: 8; Octavo:  0),
   ( Note: noteA; Duration: 8; Octavo: -1),

   ( Note: noteE; Duration: 8; Octavo:  0),
   ( Note: noteD; Duration: 8; Octavo:  0),
   ( Note: noteF; Duration: 4; Octavo:  0),

   ( Note: Pause; Duration: 4; Octavo:  0),
   ( Note: noteG; Duration: 8; Octavo:  0),
   ( Note: noteF; Duration: 8; Octavo:  0),

   ( Note: noteE; Duration: 4; Octavo:  0),
   ( Note: noteD; Duration: 8; Octavo:  0),
   ( Note: noteC; Duration: 8; Octavo:  0),

   ( Note: noteE; Duration: 4; Octavo:  0),
   ( Note: noteD; Duration: 4; Octavo:  0),

   ( Note: noteA; Duration: 2; Octavo: -1),

   ( Note: noteFd;Duration: 4; Octavo:  0),  { Repeated: 2 }
   ( Note: noteGd;Duration: 4; Octavo:  0),

   ( Note: noteB; Duration: 8; Octavo:  0),
   ( Note: noteA; Duration: 8; Octavo:  0),
   ( Note: noteE; Duration: 4; Octavo:  0),

   ( Note: Pause; Duration: 4; Octavo:  0),
   ( Note: noteC; Duration: 8; Octavo:  0),
   ( Note: noteA; Duration: 8; Octavo: -1),

   ( Note: noteE; Duration: 8; Octavo:  0),
   ( Note: noteD; Duration: 8; Octavo:  0),
   ( Note: noteF; Duration: 4; Octavo:  0),

   ( Note: Pause; Duration: 4; Octavo:  0),
   ( Note: noteG; Duration: 8; Octavo:  0),
   ( Note: noteF; Duration: 8; Octavo:  0),

   ( Note: noteE; Duration: 4; Octavo:  0),
   ( Note: noteD; Duration: 8; Octavo:  0),
   ( Note: noteC; Duration: 8; Octavo:  0),

   ( Note: noteE; Duration: 4; Octavo:  0),
   ( Note: noteD; Duration: 4; Octavo:  0),

   ( Note: noteA; Duration: 2; Octavo: -1)
  );

procedure PlayNote(ANote: NoteRec);
var
  MS: Integer;
begin
  with ANote do
  begin
    MS := 2000 div Duration;
    if Note = Pause then Delay(MS)
   else
    begin
      Inc(Octavo,Delta);
      while Octavo > 0 do
      begin
        Note := Note * 2;
        Dec(Octavo);
      end;
      while Octavo < 0 do
      begin
        Note := Note div 2;
        Inc(Octavo);
      end;
      PlaySound(Note,MS);
    end;
  end;
end;

procedure StarSky;
const
  MAX_STARS        = 40;
  STARS_IN_PROCESS = 4;
  STAR_DELAY       = 120;
  DUMMY_POS        = 255;
  DUMMY_NO         = 255;

var
  I,CurPass,CurStar: Integer;
  Ch: Char;
  StarArray: array [0..MAX_STARS] of Char;
  PosX:      array [0..MAX_STARS] of Byte;
  PosY:      array [0..MAX_STARS] of Byte;
  CurStarNo:   array [1..STARS_IN_PROCESS] of Byte;
  CurStarPass: array [1..STARS_IN_PROCESS] of Byte;

procedure Display_Char;
var
  Color: Byte;
begin
  case ch of
    'ú','ù': Color := LightCyan
    else     Color := White;
  end;
  TextColor(Color);
  GotoXY(PosX[I]+1, PosY[I]+1);
  Write(ch);
end;

{ Normal Star }

procedure Star_Display;
begin
  Display_Char;
  if CurPass = 3 then StarArray[I] := 'e';
end;

{ Explosive star }

procedure Star_Explode;
begin
  case CurPass of
    1: ch := '+';
    2: ch := 'þ';
    3: ch := ' ';
    4: begin
         ch := ' ';
         StarArray[I] := 'e';
       end;
  end;
  Display_Char;
end;

procedure Star_Initialize;
var
  X,Y: Word;
  No,J: Integer;
  Found: Boolean;
begin
  PosX[I] := DUMMY_POS;
  PosY[I] := DUMMY_POS;
  repeat
    X := Random(Lo(WindMax)-Lo(WindMin));
    Y := Random(Hi(WindMax)-Hi(WindMin));
    Found := False;
    for J := Low(PosX) to High(PosX) do
      if (X = PosX[J]) and (Y = PosY[J]) then
      begin
        Found := True;
        Break;
      end;
  until not Found;
  PosX[I] := X;
  PosY[I] := Y;
  if Random(4) = 0 then ch := 'X' else ch := 'ú';
  StarArray[I] := ch;
  if ch = 'X' then ch := ' ';
  Display_Char;
  CurStarNo[CurStar] := DUMMY_NO;
  repeat
    No := Random(MAX_STARS);
    Found := False;
    for J := Low(CurStarNo) to High(CurStarNo) do
    begin
      if No = CurStarNo[J] then
      begin
        Found := True;
        Break;
      end;
    end;
  until not Found;
  CurStarNo[CurStar] := No;
  CurPass := 0;
end;

procedure Star_Erase;
begin
  ch := ' ';
  Display_Char;
  Star_Initialize;
end;

begin
  Randomize;
  for I := Low(CurStarNo) to High(CurStarNo) do
  begin
    CurStarNo[I]   := I;
    CurStarPass[I] := 1;
  end;
  FillChar(StarArray, SizeOf(StarArray), ' ');
  FillChar(PosX, SizeOf(PosX), DUMMY_POS);
  FillChar(PosY, SizeOf(PosY), DUMMY_POS);
  repeat
    for CurStar := Low(CurStarNo) to High(CurStarNo) do
    begin
      I := CurStarNo[CurStar];
      CurPass := CurStarPass[CurStar];
      ch := StarArray[I];
      case ch of
        ' ': Star_Initialize;
        'ú': Star_Display;
        'X': Star_Explode;
        else Star_Erase;
      end;
      CurStarPass[CurStar] := CurPass + 1;
      Delay(STAR_DELAY);
      if KeyPressed then Exit;
    end;
  until False;
end;

procedure BigLetterTitle(const S: String);
begin
  TextMode(CO40);
  GotoXY((40-Length(S)) div 2, 10);
  Write(S);
  GotoXY(12, 20);
  Write('Press any key...');
  RemoveKey;
end;

begin
  CheckBreak := False;          { Disable Ctrl-Break }
  OrigMode := LastMode;
  BigLetterTitle('1. Music');
  TextMode(CO80);
  TextColor(LightGreen);
  TextBackGround(Blue);
  Window(20, 5, 60, 20);
  ForeColor := Black;
  BackColor := Black;
  I := Low(Music);
  repeat
    TextColor(ForeColor);
    TextBackGround(BackColor);
    Write('**Press any key**');
    Inc(ForeColor);
    if ForeColor > White then
    begin
      ForeColor := Black;
      Inc(BackColor);
      if BackColor > LightGray then BackColor := Black;
    end;
    PlayNote(Music[I]);
    Inc(I);
    if I > High(Music) then
    begin
      I := Low(Music);
      Dec(Delta);
      if Delta = -2 then Delta := 1;
    end;
  until KeyPressed;
  RemoveKey;
  repeat
    GotoXY(Random(Lo(WindMax)-Lo(WindMin))+1, Random(Hi(WindMax)-Hi(WindMin))+1);
    Delay(1000);
    case Random(3) of
      0: ClrEol;
      1: InsLine;
      2: DelLine;
    end;
  until KeyPressed;
  RemoveKey;
  BigLetterTitle('2. Star sky');
  TextMode(CO80);
  TextBackground(Black);
  ClrScr;
  StarSky;
  RemoveKey;
  TextMode(OrigMode);
end.
