home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / pascal / tspa3260.zip / TSUNTC.TST < prev    next >
Text File  |  1993-01-23  |  2KB  |  92 lines
  1. (* This is a test program for the TSUNTC.TPU unit
  2.    Updated 19-Aug-89, 12-Nov-89, 14-Jul-90, 26-Aug-92, 23-Jan-93
  3. *)
  4.  
  5. uses Dos,
  6.      Crt,
  7.      TSUNTC;
  8.  
  9. procedure LOGO;
  10. begin
  11.   writeln;
  12.   writeln ('TSUNTC unit test by Prof. Timo Salmi, 23-Jan-93');
  13.   writeln ('University of Vaasa, Finland, ts@uwasa.fi');
  14. {$IFDEF VER40}
  15.   writeln ('TP version 4.0');
  16. {$ENDIF}
  17. {$IFDEF VER50}
  18.   writeln ('TP version 5.0');
  19. {$ENDIF}
  20. {$IFDEF VER55}
  21.   writeln ('TP version 5.5');
  22. {$ENDIF}
  23. {$IFDEF VER60}
  24.   writeln ('TP version 6.0');
  25. {$ENDIF}
  26. {$IFDEF VER70}
  27.   writeln ('TP version 7.0');
  28. {$ENDIF}
  29.   writeln;
  30. end;  (* logo *)
  31.  
  32. (* Don't play it again, Sam *)
  33. procedure TEST1;
  34. const tune : array [1..7] of string[2]
  35.            = ('c ', 'd ', 'e ', 'f ', 'g ', 'a ', 'b ');
  36. var i : byte;
  37. begin
  38.   Delay (100);
  39.   for i := 1 to 7 do PLAYNOTE (tune[i], 4, 400);
  40.   PLAYNOTE ('c', 5, 400);
  41. end;  (* test1 *)
  42.  
  43. (* Display something in reverse *)
  44. procedure TEST2;
  45. begin
  46.   TextColor (Black);
  47.   TextBackground (Brown);
  48.   ClrScr;
  49.   LOGO;
  50.   REVCOLOR;
  51.   writeln ('Display something in reverse');
  52.   REVCOLOR;
  53.   writeln ('All back to norbal :-)');
  54.   writeln ('Rats!')
  55. end;  (* test2 *)
  56.  
  57. (* Demo of high-intesity BackGround *)
  58. procedure TEST3;
  59. begin
  60.   HIBACK;
  61.   TextColor (blink);
  62.   TextBackground (Blue);
  63.   ClrScr;
  64.   TextColor (Black+blink);
  65.   TextBackground (Brown);
  66.   write   ('When BLINKOFF has been set, blink in ');
  67.   TextColor (LightRed+blink);
  68.   write   ('TextColor');
  69.   TextColor (Black+blink);
  70.   writeln (' produces');
  71.   writeln ('a high-intensity background instead of a blinking text.');
  72.   writeln ('An MCGA, EGA or VGA is required for this feat.         ');
  73.   TextColor (Black);
  74.   TextBackground (Brown);
  75.   writeln;
  76.   writeln ('Else than that all systems are just fine (snafu, right :-).');
  77. end;  (* test3 *)
  78.  
  79. (* Main program
  80.    If you don't want a particular test, comment it away.
  81.    Q: Why don't software firms test their programs properly themselves
  82.       but leave it to the gullible user?
  83.    A: Because it is such a testing task (do I detect audible groans :-)
  84. *)
  85. begin
  86.   TEST1;
  87.   TEST2;
  88.   write ('Press <-'' '); readln;
  89.   TEST3;
  90.   write ('Press <-'' '); readln;
  91. end.  (* tsuntc.tst *)
  92.