home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / QWIK55.ZIP / QBENCH.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-08-24  |  8.5 KB  |  309 lines
  1. { =========================================================================== }
  2. { Qbench.pas - produces a 'Screens/second' table for        ver 5.5, 08-24-89 }
  3. {              QWIK Screen utilities.                                         }
  4. { This will just give you a good feel for speed.  The time is adjusted for    }
  5. { an average 8 second test for each condition - total of 56 seconds.  For     }
  6. { more accurate results, change TestTime:=16.  Or for a quicker but less      }
  7. { accurate test, change TestTime:=2.                                          }
  8. {   Be sure to see how fast virtual screens are!                              }
  9. {   Also try this out in a multi-tasking environment.                         }
  10. {   Test is for 80x25 screens only.                                           }
  11. { =========================================================================== }
  12.  
  13. {$M 16000,0,0}
  14.  
  15. uses CRT,Qwik;
  16.  
  17. {$i timerd12.inc}
  18.  
  19. type
  20.   Attrs = (Attr,NoAttr);
  21.   Procs = (Qwrites,Qfills,Qattrs,Qstores,Qscrolls);
  22.  
  23. const
  24.   TestTime = 4;  { TestTime in seconds for each case.  8 gives +/- 1% }
  25.  
  26. var
  27.   Attrib, Count:        integer;
  28.   Screens:              word;
  29.   Row, Col, Rows, Cols: byte;
  30.   ScrPerSec: array[Qwrites..Qscrolls] of array[Attr..NoAttr] of real;
  31.   Strng:     string[80];
  32.   Proc:      Procs;
  33.   A:         Attrs;
  34.   Names:     array[Qwrites..Qscrolls] of string[80];
  35.   FV:        text;
  36.   ToDisk,ToVirtual: boolean;
  37.   Ch:        char;
  38.   OldScrRec: VScrRecType;
  39.   Scr1,Scr2: array[1..4000] of word;
  40.  
  41. { Since Zenith doesn't have snow on any CGAs, turn off snow checking }
  42. procedure CheckZenith;
  43. var  ZdsRom: array[1..8] of char absolute $F000:$800C;
  44. begin
  45.   if Qsnow and (ZdsRom='ZDS CORP') then
  46.     begin
  47.       Qsnow    := false;
  48.       CardSnow := false;
  49.     end;
  50. end;
  51.  
  52. procedure ClearScr;
  53. begin
  54.   Qfill  (1,1,CRTrows,CRTcols,White+BlueBG,' ');
  55. end;
  56.  
  57. procedure TimerTest;
  58. var Tests: byte;
  59. begin
  60.   Tests := 0;
  61.   timer (start);
  62.   repeat
  63.     for Count:=1 to Screens do
  64.       for row:=1 to 25 do
  65.         Qwrite (Row,1,Yellow,Strng);
  66.     timer (Stop);
  67.     inc (Tests);
  68.   until (ElapsedTime>=1.0);
  69.   Screens := trunc(Screens*Tests*TestTime/ElapsedTime);
  70. end;
  71.  
  72. procedure CheckTime;
  73. begin
  74.   if Qsnow then
  75.        Screens:=8    { First guess for screens for 1 second test }
  76.   else Screens:=80;
  77.   if ToVirtual then
  78.     Screens := 2;
  79.   Strng:='TimerTest ';
  80.   for Col:=1 to 3 do
  81.     Strng := Strng+Strng;
  82.   TimerTest;
  83. end;
  84.  
  85. procedure AssembleStrng (Proc: Procs; Attrib: integer);
  86. begin
  87.   Strng:=Names[Proc];
  88.   if Qsnow then
  89.        Strng := Strng+' Wait    '
  90.   else Strng := Strng+' No Wait ';
  91.   if Attrib=SameAttr then
  92.        Strng := Strng+' No Attr  '
  93.   else Strng := Strng+' w/ Attr  ';
  94.   fillchar (Strng[32],49,byte(Proc)+49);
  95.   Strng[0] := #80;
  96. end;
  97.  
  98. procedure TimeWriting (Proc: Procs; Attrib: integer);
  99. var  A: Attrs;
  100. begin
  101.   if Attrib=SameAttr then
  102.     begin
  103.       Qattr (1,1,CRTrows,CRTcols,LightGray+BlueBG);
  104.       A := NoAttr;
  105.     end
  106.   else A := Attr;
  107.   AssembleStrng (Proc,Attrib);
  108.   case Proc of
  109.     Qwrites:
  110.        begin
  111.          timer (start);
  112.          for Count:=1 to Screens do
  113.            for Row:=1 to 25 do
  114.              Qwrite (Row,1,Attrib,Strng);
  115.          timer (Stop);
  116.        end;
  117.     Qfills:
  118.        begin
  119.          timer (start);
  120.          for Count:=1 to Screens do
  121.            Qfill (1,1,25,80,Attrib,'f');
  122.          timer (Stop);
  123.        end;
  124.     Qattrs:
  125.        begin
  126.          Qfill (1,1,25,80,Attrib,'a');
  127.          timer (start);
  128.          for Count:=1 to Screens do
  129.            Qattr (1,1,25,80,Attrib);
  130.          timer (Stop);
  131.        end;
  132.     end;  { Case Proc of }
  133.   if ElapsedTime<>0.0 then
  134.     ScrPerSec[Proc,A]:=Screens/ElapsedTime;
  135. end;
  136.  
  137. procedure TimeMoving (Proc: Procs; Attrib: integer);
  138. begin
  139.   AssembleStrng (Proc,Attrib);
  140.   for Row:=1 to 25 do
  141.     Qwrite (Row,1,Attrib,Strng);
  142.   case Proc of
  143.     Qstores:
  144.        begin
  145.          timer (start);
  146.          for Count:=1 to Screens do
  147.            QstoreToMem (1,1,25,80,Scr2);
  148.          timer (Stop);
  149.        end;
  150.     Qscrolls:
  151.        begin
  152.          timer (start);
  153.          for Count:=1 to Screens do
  154.            QscrollUp (1,1,25,80,SameAttr);
  155.          timer (Stop);
  156.        end;
  157.   end;  { Case Proc of }
  158.   ScrPerSec[Proc,Attr] := Screens/ElapsedTime;
  159. end;
  160.  
  161. function GetChoice (Msg: string; Answer1,Answer2: char): boolean;
  162. begin
  163.   ClearScr;
  164.   QwriteC (12,1,CRTcols,SameAttr,Msg);
  165.   GotoEos;
  166.   repeat
  167.     Ch := upcase(ReadKey);
  168.   until (Ch=Answer1) or (Ch=Answer2) or (Ch=^M);
  169.   GetChoice := Ch=Answer2;
  170. end;
  171.  
  172. procedure Initialize;
  173. begin
  174.   CheckZenith;
  175.   SetMultiTask;
  176.   if InMultiTask then
  177.     DirectVideo := false;
  178.   TextAttr := White+BlueBG;
  179.  
  180.   for Proc:=Qwrites to Qscrolls do
  181.     for A:=Attr to NoAttr do
  182.       ScrPerSec[Proc,A] := 0.0;
  183.  
  184.   Names[Qwrites ] := ' Qwrite-     ';
  185.   Names[Qfills  ] := ' Qfill-      ';
  186.   Names[Qattrs  ] := ' Qattr-      ';
  187.   Names[Qstores ] := ' Qstore-     ';
  188.   Names[Qscrolls] := ' Qscroll-    ';
  189.   ClearScr;
  190. end;
  191.  
  192. procedure AskQuestions;
  193. begin
  194.   if Qsnow then
  195.     begin
  196.       Qsnow := false;
  197.       repeat
  198.         repeat
  199.           QwriteC (12,1,80,SameAttr,'Do you see snow? [y/n]?');
  200.           GotoEos;
  201.         until Keypressed;
  202.         Ch := upcase (ReadKey);
  203.       until (Ch='Y') or (Ch='N');
  204.       case Ch of
  205.         'Y': Qsnow:=true;
  206.         'N': begin
  207.                QwriteC (10,1,80,-1,'Congratulations!  You have a card better');
  208.                QwriteC (11,1,80,-1,'than the standard IBM CGA.');
  209.                QwriteC (12,1,80,-1,'However, to make it faster, you will need');
  210.                QwriteC (13,1,80,-1,'to set Qsnow:=false manually.');
  211.                QwriteC (14,1,80,-1,'Please contact us about this.');
  212.                QwriteC (16,1,80,-1,'Press any key ...');
  213.                GotoRC  (16,49);
  214.                Ch := ReadKey;
  215.                if Ch=#00 then
  216.                  Ch := ReadKey;
  217.              end;
  218.       end;
  219.     end;
  220.   ToVirtual := GetChoice ('Normal or Virtual screen [N/v]? ','N','V');
  221.   ToDisk    := GetChoice ('Data to Screen or Disk [S/d]? '  ,'S','D');
  222.   ModCursor (CursorOff);
  223.   ClearScr;
  224.   OldScrRec := QScrRec;
  225. end;
  226.  
  227. procedure RunTests;
  228. begin
  229.   if ToVirtual then
  230.     begin
  231.       Str (7*TestTime,Strng);
  232.       QwriteC (12,1,CRTcols,SameAttr,'Please wait '+Strng+' seconds ...');
  233.       QScrPtr := @Scr1;
  234.       Qsnow   := false;
  235.     end;
  236.   CheckTime;
  237.   TimeWriting (Qwrites ,Yellow+BlueBG);
  238.   TimeWriting (Qwrites ,SameAttr);
  239.   TimeWriting (Qfills  ,Yellow+BlueBG);
  240.   TimeWriting (Qfills  ,SameAttr);
  241.   TimeWriting (Qattrs  ,Yellow+BlueBG);
  242.   TimeMoving  (Qstores ,Yellow+BlueBG);
  243.   TimeMoving  (Qscrolls,Yellow+BlueBG);
  244. end;
  245.  
  246. procedure PrintResults;
  247. begin
  248.   QScrRec := OldScrRec;
  249.   ClearScr;
  250.   if ToDisk then
  251.        assign    (FV,'Qbench.dta')
  252.   else assignCRT (FV);
  253.   rewrite (FV);
  254.   GotoRC (1,1);
  255.   writeln (FV,'S C R E E N S / S E C O N D');
  256.   writeln (FV,'             Chng');
  257.   writeln (FV,'Procedure    Attr S/sec  Typical for these procedures:');
  258.   write   (FV,'---------    ---- -----  -----------------------------');
  259.   writeln (FV,'------------------');
  260.   for Proc:=Qwrites to Qfills do
  261.   for A:=Attr to NoAttr do
  262.     begin
  263.       if A=Attr then
  264.            write (FV,Names[Proc])
  265.       else write (FV,'             ');
  266.       if A=Attr then
  267.            write (FV,'Yes ')
  268.       else write (FV,'No  ');
  269.       write (FV,ScrPerSec[Proc,A]:6:1,'  ');
  270.       if A=Attr then
  271.         case Proc of
  272.           Qwrites:
  273.             writeln (FV,'Qwrite, QwriteC, QwriteA, QwriteEos, QwriteEosA');
  274.           Qfills:  writeln (FV,'Qfill, QfillC, QfillEos');
  275.         end
  276.       else writeln (FV);
  277.     end;
  278.   for Proc:=Qattrs to Qscrolls do
  279.     begin
  280.       write (FV,Names[Proc]);
  281.       if Proc=Qattrs then
  282.            write (FV,'Yes  ')
  283.       else write (FV,'n/a  ');
  284.       write (FV,ScrPerSec[Proc,Attr]:5:1,'  ');
  285.       case Proc of
  286.         Qattrs:  writeln (FV,'Qattr, QattrEos');
  287.         Qstores:
  288.           writeln (FV,'QstoreToMem, QstoreToScr, QscrToVscr, QVscrToScr');
  289.         Qscrolls:writeln (FV,'QscrollUp, QscrollDown');
  290.       end
  291.     end;
  292.   GotoRC  (13,1);
  293.   writeln (FV,'SystemID         = ',SystemID);
  294.   writeln (FV,'CPU ID           = ',CpuID);
  295.   writeln (FV,'Wait-for-retrace = ',Qsnow);
  296.   writeln (FV,'Virtual screen   = ',ToVirtual);
  297.   writeln (FV,'Screens/test     = ',Screens);
  298.   close   (FV);
  299.   GotoRC  (24,1);
  300.   SetCursor (CursorInitial);
  301. end;
  302.  
  303. begin
  304.   Initialize;
  305.   AskQuestions;
  306.   RunTests;
  307.   PrintResults;
  308. end.
  309.