home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / TSPA2560.ZIP / TSUNTD.TST < prev    next >
Encoding:
Text File  |  1991-01-05  |  5.9 KB  |  246 lines
  1. {$R+}  (* Index range check on *)
  2.  
  3. (* This is a test program for the TSUNTD.TPU unit
  4.    2-Aug-89, Updated 25-Sep-89, 13-Jun-90, 15-Jul-90, 5-Jan-91 *)
  5.  
  6. uses TSUNTB,
  7.      TSUNTD;
  8.  
  9. const loop = 200;   (* If you do want to make it quickly, change this to 1 *)
  10.  
  11. var time : real;    (* For timing the tests *)
  12.  
  13. procedure LOGO;
  14. begin
  15.   writeln;
  16.   writeln ('TSUNTD unit test by Prof. Timo Salmi');
  17.   writeln ('University of Vaasa, Finland, ts@chyde.uwasa.fi');
  18.   writeln;
  19. end;
  20.  
  21. (* Dosdelay function, no Ctr unit needed *)
  22. procedure TEST1;
  23. begin
  24.   time := TIMERFN;
  25.   DOSDELAY (1000);
  26.   time := TIMERFN - time;
  27.   writeln ('DOSDELAY(1000)');
  28.   writeln ('Elapsed ', time:0:2);
  29.   writeln;
  30. end;  (* test1 *)
  31.  
  32. (* Justify a string right *)
  33. procedure TEST2;
  34. var sj1, sj2 : string;
  35.     i        : word;
  36. begin
  37.   writeln ('....:....1....:....2....:....3....:....4....:....5....');
  38.   sj1 := 'TSUNTD';
  39.   time := TIMERFN;
  40.   for i := 1 to loop do sj2 := TRIMRGFN (sj1, 20);
  41.   time := TIMERFN - time;
  42.   writeln (sj1); writeln (sj2);
  43.   writeln ('Elapsed ', time:0:2);
  44. end;  (* test2 *)
  45.  
  46. procedure TEST3;
  47. var sj1, sj2 : string;
  48.     i        : word;
  49. begin
  50.   writeln ('....:....1....:....2....:....3....:....4....:....5....');
  51.   sj1 := 'TSUNTD';
  52.   time := TIMERFN;
  53.   for i := 1 to loop do sj2 := TRIMRGFN (sj1, 4);
  54.   time := TIMERFN - time;
  55.   writeln (sj1); writeln (sj2);
  56.   writeln ('Elapsed ', time:0:2);
  57. end;  (* test3 *)
  58.  
  59. (* Justify a string left *)
  60. procedure TEST4;
  61. var sj1, sj2 : string;
  62.     i        : word;
  63. begin
  64.   writeln ('....:....1....:....2....:....3....:....4....:....5....');
  65.   sj1 := '     TSUNTD';
  66.   time := TIMERFN;
  67.   for i := 1 to loop do sj2 := TRIMLFFN (sj1, 20);
  68.   time := TIMERFN - time;
  69.   writeln (sj1); writeln (sj2);
  70.   writeln ('Elapsed ', time:0:2);
  71. end;  (* test4 *)
  72.  
  73. procedure TEST5;
  74. var sj1, sj2 : string;
  75.     i        : word;
  76. begin
  77.   writeln ('....:....1....:....2....:....3....:....4....:....5....');
  78.   sj1 := '     TSUNTD';
  79.   time := TIMERFN;
  80.   for i := 1 to loop do sj2 := TRIMLFFN (sj1, 4);
  81.   time := TIMERFN - time;
  82.   writeln (sj1); writeln (sj2);
  83.   writeln ('Elapsed ', time:0:2);
  84. end;  (* test5 *)
  85.  
  86. (* Lead a string *)
  87. procedure TEST6;
  88. var sj1, sj2 : string;
  89.     i        : word;
  90. begin
  91.   writeln ('....:....1....:....2....:....3....:....4....:....5....');
  92.   sj1 := 'TSUNTD';
  93.   time := TIMERFN;
  94.   for i := 1 to loop do sj2 := LEADFN (sj1, 20, '.');
  95.   time := TIMERFN - time;
  96.   writeln (sj1); writeln (sj2);
  97.   writeln ('Elapsed ', time:0:2);
  98. end;  (* test6 *)
  99.  
  100. (* Trail a string *)
  101. procedure TEST7;
  102. var sj1, sj2 : string;
  103.     i        : word;
  104. begin
  105.   writeln ('....:....1....:....2....:....3....:....4....:....5....');
  106.   sj1 := 'TSUNTD';
  107.   time := TIMERFN;
  108.   for i := 1 to loop do sj2 := TRAILFN (sj1, 20, '.');
  109.   time := TIMERFN - time;
  110.   writeln (sj1); writeln (sj2);
  111.   writeln ('Elapsed ', time:0:2);
  112. end;  (* test7 *)
  113.  
  114. (* Extract all substrings from a string *)
  115. procedure TEST8;
  116. {$IFNDEF VER40}
  117. const separators : string = ' ' + ',' + #9;
  118. {$ENDIF}
  119. var sj      : string;
  120.     partPtr : parseVectorPtrType;
  121.     n       : integer;
  122.     ok      : boolean;
  123.     i       : byte;
  124. {$IFDEF VER40} var separators : string; {$ENDIF}
  125. begin
  126.   {$IFDEF VER40} separators := ' ' + ',' + #9; {$ENDIF}
  127.   New (partPtr);
  128.   sj := 'TSUNTD unit test by Prof. Timo Salmi';
  129.   PARSE (sj, parse_parts_max, separators,
  130.          n, partPtr, ok);
  131.   if not ok then halt;   {or whatever you want do in case of an error}
  132.   for i := 1 to n do writeln (partPtr^[i]);
  133.   Dispose (partPtr); partPtr := nil;
  134. end;  (* test8 *)
  135.  
  136. (* Alternative method: Extract all substrings from a string *)
  137. procedure TEST9;
  138. var sj      : string;
  139.     n       : integer;
  140.     i       : byte;
  141. var separators : string;
  142. begin
  143.   separators := ' ' + ',' + #9;
  144.   sj := 'TSUNTD unit test by Prof. Timo Salmi';
  145.   n := STRCNTFN (sj, separators);
  146.   for i := 1 to n do writeln (SPARTFN(sj, separators, i));
  147. end;  (* test9 *)
  148.  
  149. (* How does it sound *)
  150. procedure TEST10;
  151. begin
  152.   AUDIO (300, 300); DOSDELAY(20); AUDIO (300, 300); AUDIO (400, 600);
  153. end;  (* test10 *)
  154.  
  155. (* Printer status retort *)
  156. procedure TEST11;
  157. begin
  158.   if PRTONLFN then
  159.     writeln ('Printer ready')
  160.   else
  161.     writeln ('Printer not ready');
  162. end;  (* test11 *)
  163.  
  164. (* Printer status retort, the second method *)
  165. procedure TEST12;
  166. begin
  167.   if LPTONLFN then
  168.     writeln ('Second test: Printer ready')
  169.   else
  170.     writeln ('Second test: Printer not ready');
  171. end;  (* test12 *)
  172.  
  173. (* Print screen *)
  174. procedure TEST13;
  175. begin
  176.   if LPTONLFN then
  177.     PRTSCR
  178.   else
  179.     writeln ('Can''t print the screen: Printer not ready');
  180. end;  (* test13 *)
  181.  
  182. (* Convert to lower case *)
  183. procedure TEST14;
  184. var str : string;
  185.     i,p : byte;
  186. begin
  187.   str := 'Lets See if This Works: ABC XYZ 123 890 fred *?';
  188.   writeln (str);
  189.   p := Length(str);
  190.   i := 1;
  191.   while i <= p do begin
  192.     write (LOWCASFN(str[i]));
  193.     Flush (output);
  194.     Inc(i);
  195.   end;
  196.   writeln;
  197. end;  (* test14 *)
  198.  
  199. (* The current default number of printer retrys before I/O error *)
  200. procedure TEST15;
  201. begin
  202.   writeln ('Printer default retrys = ', GETPRTFN, ' times');
  203.   Flush (output);
  204. end; (* test15 *)
  205.  
  206. (* Number of substrings in a string *)
  207. procedure TEST16;
  208. var s, s1 : string;
  209.     n, i  : integer;
  210.     time  : real;
  211. begin
  212.   repeat
  213.     write ('Give a string (exit to end): '); readln (s);
  214.     writeln ('Number of substrings = ', n);
  215.     for i := 1 to n do
  216.       writeln (PARSERFN (s, i));
  217.   until s = 'exit';
  218. end;  (* test16 *)
  219.  
  220. (* Main program *)
  221. begin
  222.   {}
  223.   LOGO;
  224.   TEST11;
  225.   TEST12;
  226.   TEST13;
  227.   {... Comment the halt away if you want the rest of the tests ...}
  228.   halt;
  229.   {}
  230.   TEST10;
  231.   TEST1;
  232.   TEST2;
  233.   TEST3;
  234.   TEST4;
  235.   write ('Press «═╝ '); readln;
  236.   TEST5;
  237.   TEST6;
  238.   TEST7;
  239.   write ('Press «═╝ '); readln;
  240.   TEST8;
  241.   write ('Press «═╝ '); readln;
  242.   TEST9;
  243.   TEST14;
  244.   TEST15;
  245. end.  (* tsuntd.tst *)
  246.