Category : Pascal Source Code
Archive   : TSPA3370.ZIP
Filename : TSUNTC.TST

(* This is a test program for the TSUNTC.TPU unit
Updated 19-Aug-89, 12-Nov-89, 14-Jul-90, 26-Aug-92, 23-Jan-93
*)

uses Dos,
Crt,
TSUNTC;

procedure LOGO;
begin
writeln;
writeln ('TSUNTC unit test by Prof. Timo Salmi, 23-Jan-93');
writeln ('University of Vaasa, Finland, [email protected]');
{$IFDEF VER40}
writeln ('TP version 4.0');
{$ENDIF}
{$IFDEF VER50}
writeln ('TP version 5.0');
{$ENDIF}
{$IFDEF VER55}
writeln ('TP version 5.5');
{$ENDIF}
{$IFDEF VER60}
writeln ('TP version 6.0');
{$ENDIF}
{$IFDEF VER70}
writeln ('TP version 7.0');
{$ENDIF}
writeln;
end; (* logo *)

(* Don't play it again, Sam *)
procedure TEST1;
const tune : array [1..7] of string[2]
= ('c ', 'd ', 'e ', 'f ', 'g ', 'a ', 'b ');
var i : byte;
begin
Delay (100);
for i := 1 to 7 do PLAYNOTE (tune[i], 4, 400);
PLAYNOTE ('c', 5, 400);
end; (* test1 *)

(* Display something in reverse *)
procedure TEST2;
begin
TextColor (Black);
TextBackground (Brown);
ClrScr;
LOGO;
REVCOLOR;
writeln ('Display something in reverse');
REVCOLOR;
writeln ('All back to norbal :-)');
writeln ('Rats!')
end; (* test2 *)

(* Demo of high-intesity BackGround *)
procedure TEST3;
begin
HIBACK;
TextColor (blink);
TextBackground (Blue);
ClrScr;
TextColor (Black+blink);
TextBackground (Brown);
write ('When BLINKOFF has been set, blink in ');
TextColor (LightRed+blink);
write ('TextColor');
TextColor (Black+blink);
writeln (' produces');
writeln ('a high-intensity background instead of a blinking text.');
writeln ('An MCGA, EGA or VGA is required for this feat. ');
TextColor (Black);
TextBackground (Brown);
writeln;
writeln ('Else than that all systems are just fine (snafu, right :-).');
end; (* test3 *)

(* Main program
If you don't want a particular test, comment it away.
Q: Why don't software firms test their programs properly themselves
but leave it to the gullible user?
A: Because it is such a testing task (do I detect audible groans 🙂
*)
begin
TEST1;
TEST2;
write ('Press <-'' '); readln;
TEST3;
write ('Press <-'' '); readln;
end. (* tsuntc.tst *)