{ =========================================================================== }
{ Qbench.pas - produces a 'Screens/second' table for       ver 5.xa, 03-04-89 }
{              QWIK Screen utilities.                                         }
{ This will just give you a good feel for speed.  The time is adjusted for    }
{ an average 8 second test for each condition - total of 56 seconds.  For     }
{ more accurate results, change TestTime:=16.  Or for a quicker but less      }
{ accurate test, change TestTime:=2.                                          }
{   Be sure to see how fast virtual screens are!                              }
{   Also try this out in a multi-tasking environment.                         }
{   Test is for 80x25 screens only.                                           }
{ =========================================================================== }

{$M 16000,0,0}

uses CRT,Qwik;

{$i timerd12.inc}

type
  Attrs = (Attr,NoAttr);
  Procs = (Qwrites,Qfills,Qattrs,Qstores,Qscrolls);

const
  TestTime = 4;  { TestTime in seconds for each case.  8 gives +/- 1% }

var
  Attrib, Count:        integer;
  Screens:              word;
  Row, Col, Rows, Cols: byte;
  ScrPerSec: array[Qwrites..Qscrolls] of array[Attr..NoAttr] of real;
  Strng:     string[80];
  Proc:      Procs;
  A:         Attrs;
  Names:     array[Qwrites..Qscrolls] of string[80];
  FV:        text;
  ToDisk,ToVirtual: boolean;
  Ch:        char;
  OldScrRec: VScrRecType;
  Scr1,Scr2: array[1..4000] of word;

{ Since Zenith doesn't have snow on any CGAs, turn off snow checking }
procedure CheckZenith;
var  ZdsRom: array[1..8] of char absolute $F000:$800C;
begin
  if Qsnow and (ZdsRom='ZDS CORP') then
    begin
      Qsnow    := false;
      CardSnow := false;
    end;
end;

procedure ClearScr;
begin
  Qfill  (1,1,CRTrows,CRTcols,White+BlueBG,' ');
end;

procedure TimerTest;
var Tests: byte;
begin
  Tests := 0;
  timer (start);
  repeat
    for Count:=1 to Screens do
      for row:=1 to 25 do
        Qwrite (Row,1,Yellow,Strng);
    timer (Stop);
    inc (Tests);
  until (ElapsedTime>=1.0);
  Screens := trunc(Screens*Tests*TestTime/ElapsedTime);
end;

procedure CheckTime;
begin
  if Qsnow then
       Screens:=8    { First guess for screens for 1 second test }
  else Screens:=80;
  if ToVirtual then
    Screens := 2;
  Strng:='TimerTest ';
  for Col:=1 to 3 do
    Strng := Strng+Strng;
  TimerTest;
end;

procedure AssembleStrng (Proc: Procs; Attrib: integer);
begin
  Strng:=Names[Proc];
  if Qsnow then
       Strng := Strng+' Wait    '
  else Strng := Strng+' No Wait ';
  if Attrib=SameAttr then
       Strng := Strng+' No Attr  '
  else Strng := Strng+' w/ Attr  ';
  fillchar (Strng[32],49,byte(Proc)+49);
  Strng[0] := #80;
end;

procedure TimeWriting (Proc: Procs; Attrib: integer);
var  A: Attrs;
begin
  if Attrib=SameAttr then
    begin
      Qattr (1,1,CRTrows,CRTcols,LightGray+BlueBG);
      A := NoAttr;
    end
  else A := Attr;
  AssembleStrng (Proc,Attrib);
  case Proc of
    Qwrites:
       begin
         timer (start);
         for Count:=1 to Screens do
           for Row:=1 to 25 do
             Qwrite (Row,1,Attrib,Strng);
         timer (Stop);
       end;
    Qfills:
       begin
         timer (start);
         for Count:=1 to Screens do
           Qfill (1,1,25,80,Attrib,'f');
         timer (Stop);
       end;
    Qattrs:
       begin
         Qfill (1,1,25,80,Attrib,'a');
         timer (start);
         for Count:=1 to Screens do
           Qattr (1,1,25,80,Attrib);
         timer (Stop);
       end;
    end;  { Case Proc of }
  if ElapsedTime<>0.0 then
    ScrPerSec[Proc,A]:=Screens/ElapsedTime;
end;

procedure TimeMoving (Proc: Procs; Attrib: integer);
begin
  AssembleStrng (Proc,Attrib);
  for Row:=1 to 25 do
    Qwrite (Row,1,Attrib,Strng);
  case Proc of
    Qstores:
       begin
         timer (start);
         for Count:=1 to Screens do
           QstoreToMem (1,1,25,80,Scr2);
         timer (Stop);
       end;
    Qscrolls:
       begin
         timer (start);
         for Count:=1 to Screens do
           QscrollUp (1,1,25,80,SameAttr);
         timer (Stop);
       end;
  end;  { Case Proc of }
  ScrPerSec[Proc,Attr] := Screens/ElapsedTime;
end;

function GetChoice (Msg: string; Answer1,Answer2: char): boolean;
begin
  ClearScr;
  QwriteC (12,1,CRTcols,SameAttr,Msg);
  GotoEos;
  repeat
    Ch := upcase(ReadKey);
  until (Ch=Answer1) or (Ch=Answer2) or (Ch=^M);
  GetChoice := Ch=Answer2;
end;

procedure Initialize;
begin
  CheckZenith;
  SetMultiTask;
  if InMultiTask then
    DirectVideo := false;
  TextAttr := White+BlueBG;

  for Proc:=Qwrites to Qscrolls do
    for A:=Attr to NoAttr do
      ScrPerSec[Proc,A] := 0.0;

  Names[Qwrites ] := ' Qwrite-     ';
  Names[Qfills  ] := ' Qfill-      ';
  Names[Qattrs  ] := ' Qattr-      ';
  Names[Qstores ] := ' Qstore-     ';
  Names[Qscrolls] := ' Qscroll-    ';
  ClearScr;
end;

procedure AskQuestions;
begin
  if Qsnow then
    begin
      Qsnow := false;
      repeat
        repeat
          QwriteC (12,1,80,SameAttr,'Do you see snow? [y/n]?');
          GotoEos;
        until Keypressed;
        Ch := upcase (ReadKey);
      until (Ch='Y') or (Ch='N');
      case Ch of
        'Y': Qsnow:=true;
        'N': begin
               QwriteC (10,1,80,-1,'Congratulations!  You have a card better');
               QwriteC (11,1,80,-1,'than the standard IBM CGA.');
               QwriteC (12,1,80,-1,'However, to make it faster, you will need');
               QwriteC (13,1,80,-1,'to set Qsnow:=false manually.');
               QwriteC (14,1,80,-1,'Please contact us about this.');
               QwriteC (16,1,80,-1,'Press any key ...');
               GotoRC  (16,49);
               Ch := ReadKey;
               if Ch=#00 then
                 Ch := ReadKey;
             end;
      end;
    end;
  ToVirtual := GetChoice ('Normal or Virtual screen [N/v]? ','N','V');
  ToDisk    := GetChoice ('Data to Screen or Disk [S/d]? '  ,'S','D');
  ModCursor (CursorOff);
  ClearScr;
  OldScrRec := QScrRec;
end;

procedure RunTests;
begin
  if ToVirtual then
    begin
      Str (7*TestTime,Strng);
      QwriteC (12,1,CRTcols,SameAttr,'Please wait '+Strng+' seconds ...');
      QScrPtr := @Scr1;
      Qsnow   := false;
    end;
  CheckTime;
  TimeWriting (Qwrites ,Yellow+BlueBG);
  TimeWriting (Qwrites ,SameAttr);
  TimeWriting (Qfills  ,Yellow+BlueBG);
  TimeWriting (Qfills  ,SameAttr);
  TimeWriting (Qattrs  ,Yellow+BlueBG);
  TimeMoving  (Qstores ,Yellow+BlueBG);
  TimeMoving  (Qscrolls,Yellow+BlueBG);
end;

procedure PrintResults;
begin
  QScrRec := OldScrRec;
  ClearScr;
  if ToDisk then
       assign    (FV,'Qbench.dta')
  else assignCRT (FV);
  rewrite (FV);
  GotoRC (1,1);
  writeln (FV,'S C R E E N S / S E C O N D');
  writeln (FV,'             Chng');
  writeln (FV,'Procedure    Attr S/sec  Typical for these procedures:');
  write   (FV,'---------    ---- -----  -----------------------------');
  writeln (FV,'------------------');
  for Proc:=Qwrites to Qfills do
  for A:=Attr to NoAttr do
    begin
      if A=Attr then
           write (FV,Names[Proc])
      else write (FV,'             ');
      if A=Attr then
           write (FV,'Yes ')
      else write (FV,'No  ');
      write (FV,ScrPerSec[Proc,A]:6:1,'  ');
      if A=Attr then
        case Proc of
          Qwrites:
            writeln (FV,'Qwrite, QwriteC, QwriteA, QwriteEos, QwriteEosA');
          Qfills:  writeln (FV,'Qfill, QfillC, QfillEos');
        end
      else writeln (FV);
    end;
  for Proc:=Qattrs to Qscrolls do
    begin
      write (FV,Names[Proc]);
      if Proc=Qattrs then
           write (FV,'Yes  ')
      else write (FV,'n/a  ');
      write (FV,ScrPerSec[Proc,Attr]:5:1,'  ');
      case Proc of
        Qattrs:  writeln (FV,'Qattr, QattrEos');
        Qstores:
          writeln (FV,'QstoreToMem, QstoreToScr, QscrToVscr, QVscrToScr');
        Qscrolls:writeln (FV,'QscrollUp, QscrollDown');
      end
    end;
  GotoRC  (13,1);
  writeln (FV,'SystemID         = ',SystemID);
  writeln (FV,'CPU ID           = ',CpuID);
  writeln (FV,'Wait-for-retrace = ',Qsnow);
  writeln (FV,'Virtual screen   = ',ToVirtual);
  writeln (FV,'Screens/test     = ',Screens);
  close   (FV);
  GotoRC  (24,1);
  SetCursor (CursorInitial);
end;

begin
  Initialize;
  AskQuestions;
  RunTests;
  PrintResults;
end.