{█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█}
{█ █}
{█ Virtual Pascal Examples. Version 1.10 █}
{█ Crt unit test example. █}
{█ ─────────────────────────────────────────────────█}
{█ Copyright (C) 1995-96 fPrint UK Ltd █}
{█ █}
{▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀}
program TestCrt;
{&PMTYPE VIO}
uses Crt{, Use32};
{$IFDEF VPDEMO}
{$Dynamic VP11Demo.Lib}
{$ENDIF}
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 OS2}
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.
