{ ========================================================================== }
{ Qinitest.pas - System configuration test                ver 7.1a, 09-23-93 }
{                                                                            }
{ Tests your video hardware configuration using QWIK71.                      }
{   Copyright (c) 1986,1993 James H. LeMay, Eagle Performance Software       }
{ ========================================================================== }

{ Delete space to include IBM's submodel ID detection: }
{ $Define AddSubModelID }
{^ delete space here }

program QinitTest;

uses
  Crt, Qwik, Strs;

type
  Str9  = string[ 9];
  Str33 = string[33];

var
  NewMode,OldVideoMode: byte;
  Strng:                string;
  Ch:                   char;

const
  CursorDelay = 1500;   { delay between changes in the cursor shape }

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

{ Fast way to clear the screen. }
procedure ClearScr;
begin
  Qfill (1,1,CRTrows,CRTcols,TextAttr,' ');
end;

procedure InitScreen;
begin
  CheckZenith;
  CheckSnow := Qsnow;
  SetMultiTask;
  if InMultiTask then
    DirectVideo := false;
  TextAttr  := Yellow+BlueBG;
  ClearScr;
end;

{ -- Some PC hardware requires equipment flags to be altered before
{    using TextMode. }
procedure PreTextMode (NewVideoMode: byte);
var
  flags: word;
  EquipFlags: word absolute $0040:$0010;
begin
  if QVideoMode<>NewVideoMode then
    begin
      flags := EquipFlags;
      if (NewVideoMode=Mono) then
        begin
          if (AltDispDev=MdaMono) then
            EquipFlags := flags or $30;  { Force to Mono }
        end
      else
        if (QVideoMode=Mono) and (AltDispDev>=MdaMono) then
          EquipFlags := (flags and not $30) or $20;  { Force to Co80 }
    end;
end;

{ -- Converts any number into a Binary character string -- }
function DecToBin (Number: longint; Bits: byte): str33;
const
  D2B: array[0..1] of char = '01';
var
  BinStr: Str33;
  Bit:    byte;
begin
  BinStr:='b';
  for Bit:=0 to pred(Bits) do
    BinStr:=D2B[(Number shr Bit) and 1] + BinStr;
  DecToBin:=BinStr;
end;

{ -- Converts any number into a Hex character string -- }
function DecToHex (Number: longint; HexChars: byte): str9;
const
  D2H: array[0..$F] of char = '0123456789ABCDEF';
var
  HexStr:       Str9;
  HexChar,Bits: byte;
begin
  HexStr:='';
  for HexChar:=0 to pred(HexChars) do
    begin
      Bits:=HexChar shl 2;
      HexStr:=D2H[(Number shr Bits) and $F] + HexStr;
    end;
  DecToHex:='$' + HexStr;
end;

procedure DisplayDev (DD: byte);
begin
  case DD of
    $00: Strng:='No display';
    $01: Strng:='MDA with 5151 monochrome';
    $02: Strng:='CGA with 5153/4 color';
    $04: Strng:='EGA with 5153/4 color';
    $05: Strng:='EGA with 5151 monochrome';
    $06: Strng:='PGC with 5175 color';
    $07: Strng:='VGA with analog monochrome';
    $08: Strng:='VGA with analog color';
    $0B: Strng:='MCGA with analog monochrome';
    $0C: Strng:='MCGA with analog color';
  else Strng:='Reserved';
  end; { case }
end;

function StrTF (TF: boolean): Str9;
begin
  if TF then
       StrTF:='True'
  else StrTF:='False';
end;

procedure DisplaySetCursor (Msg: string; Cursor: word);
begin
  SetCursor (Cursor);
  QwriteEos (SameAttr,Msg+DecToHex(Cursor,4));
  GotoEos;
  delay (CursorDelay);
  EosLn;
end;

procedure DisplayModCursor (Msg: string; Cursor: word);
begin
  ModCursor (Cursor);
  QwriteEos (SameAttr,Msg+DecToHex(Cursor,4)+' '+DecToHex(GetCursor,4));
  GotoEos;
  delay (CursorDelay);
  EosLn;
end;

procedure PromptKey;
begin
  Qwrite (CRTrows,1,SameAttr,'Press any key...');
  GotoEos;
  repeat
    Ch:=ReadKey;
  until not KeyPressed;
end;

procedure ChooseMode;
begin
  OldVideoMode := QVideoMode;
  Qwrite (1,1,SameAttr,'Which text mode [0,1,2,3,7] ? ');
  GotoEos;
  repeat
    Ch := readkey;
  until Ch in ['0'..'3','7'];
  NewMode := ord(Ch)-ord('0');
  if NewMode<>OldVideoMode then
    begin
      PreTextMode (NewMode);
      TextMode (NewMode+hi(LastMode));
      Qinit;
    end;
  InitScreen;
end;

procedure ShowCpuid;
begin
  case CpuID of
    Cpu8086:    Strng:='Intel 8086/88';
    Cpu80186:   Strng:='Intel 80186/188';
    Cpu80286:   Strng:='Intel 80286';
    Cpu80386:   Strng:='Intel 80386';
    Cpu80486:   Strng:='Intel 80486';
    CpuPentium: Strng:='Intel Pentium';
  end;
  Qwrite ( 1,1,SameAttr,'CPU ident         = '+Strng);
end;

procedure ShowSystemID;
begin
  {$IfDef AddSubModelID }
  GetSubModelID;               { Check docs before using this procedure. }
  {$EndIf }
  case SystemID of
    $FF: Strng:='IBM PC';
    $FE: Strng:='IBM PC XT';
    $FD: Strng:='IBM PCjr';
    $FC: case SubModelID of
           $00: Strng:='IBM PC AT (6 MHz)';
           $01: Strng:='IBM PC AT (8 MHz)';
           $02: Strng:='IBM PC XT (286)';
           $04: Strng:='IBM PS/2 Model 50';
           $05: Strng:='IBM PS/2 Model 60';
         else   Strng:='IBM PS/2 VGA type';
         end;
    $FB: Strng:='IBM PC XT (256/640)';
    $FA: case SubModelID of
           $00: Strng:='IBM PS/2 Model 30';
           $01: Strng:='IBM PS/2 Model 25';
         else   Strng:='IBM PS/2 MCGA type';
         end;
    $F9: Strng:='IBM PC convertible';
    $F8: case SubModelID of
           $00: Strng:='IBM PS/2 Model 80 (16 MHz)';
           $01: Strng:='IBM PS/2 Model 80 (20 MHz)';
           $09: Strng:='IBM PS/2 Model 70 (16 MHz)';
         else   Strng:='IBM PS/2 Model 70/80 type';
         end;
  else Strng:='Unknown, not an IBM';
  end;  { case }
  Qwrite ( 2,1,SameAttr,'System ID         = '+DecToHex(SystemID,2));
  {$IfDef AddSubModelID }
  Qwrite ( 3,1,SameAttr,'SubModel ID       = '+StrL (SubModelID));
  {$Else }
  Qwrite ( 3,1,SameAttr,'SubModel ID       = ??');
  {$EndIf }
  Qwrite ( 4,3,SameAttr, Strng);
end;

procedure ShowVideoHardware;
begin
  Qwrite ( 5,1,SameAttr,'Have PS/2 video   = '+StrTF (HavePS2));
  Qwrite ( 6,1,SameAttr,'IBM 3270 PC       = '+StrTF (Have3270));
  Qwrite ( 7,1,SameAttr,'Prior video mode  = '+StrL  (OldVideoMode));
  Qwrite ( 8,1,SameAttr,'Video mode now    = '+StrL  (QvideoMode));
  Qwrite ( 9,1,SameAttr,'Wait-for-retrace  = '+StrTF (Qsnow));
  Qwrite (10,1,SameAttr,'Max page #        = '+StrL  (MaxPage));
  if Have3270 then
    begin
      Qwrite (11,1,SameAttr,
              'Disp Dev 3270     = '+DecToHex(ActiveDispDev3270,2));
      case ActiveDispDev3270 of
        $00: Strng:='5151 or 5272 display and adapter';
        $01: Strng:='3295 display and adapter';
        $02: Strng:='5151 or 5272, adapter, XGA graphics';
        $03: Strng:='5279 display, 3270 PC G adapter';
        $04: Strng:='5379 C01 display, 3270 PC GX adapter';
        $05: Strng:='5379 M01 display, 3270 PC GX adapter';
        $FF: Strng:='Unknown, not a 3270 PC';
      else Strng:='Reserved';
      end;
      Qwrite (12,3,SameAttr,Strng);
    end
  else
    begin
      DisplayDev (ActiveDispDev);
      Qwrite (11,1,SameAttr,'Active Disp Dev   = '+DecToHex(ActiveDispDev,2));
      Qwrite (12,3,SameAttr,Strng);

      if SystemID=$F9 then    { PC convertible }
        Qwrite (13,1,SameAttr,
                'Alt Disp Dev PC Conv = '+DecToHex(AltDispDevPCC,4))
      else
        begin
          DisplayDev (AltDispDev);
          Qwrite (13,1,SameAttr,'Alt Disp Dev      = '+DecToHex(AltDispDev,2));
          Qwrite (14,3,SameAttr,Strng);
        end;

      Qwrite (15,1,SameAttr,'Hercules model    = '+StrL(HercModel));
      if (AltDispDev=MdaMono) and (OldVideoMode<>Mono) then
        Strng := 'Mono card not given Hercules test'
      else
        case HercModel of
          0: Strng:='Non-Hercules card';
          1: Strng:='Hercules Graphics Card';
          2: Strng:='Hercules Graphics Card Plus';
          3: Strng:='Hercules InColor Card';
        end;
      Qwrite (16,3,SameAttr,Strng);
    end;
end;

procedure ShowDispDim;
begin
  Qwrite (17,1,SameAttr,'CRT rows          = '+StrL(CRTrows));
  Qwrite (18,1,SameAttr,'CRT columns       = '+StrL(CRTcols));
  Qwrite (19,1,SameAttr,'Cursor start      = '+DecToHex(hi(CursorInitial),2));
  Qwrite (20,1,SameAttr,'Cursor end        = '+DecToHex(lo(CursorInitial),2));
  if (ActiveDispDev>=EgaColor) and (ActiveDispDev<=McgaColor) then
    begin
      Qwrite (21,1,SameAttr,'EGA rows          = '+StrL(EgaRows));
      Qwrite (22,1,SameAttr,'EGA FontSize      = '+StrL(EgaFontSize));
      Qwrite (23,1,SameAttr,'EGA Info          = '+DecToBin(EgaInfo,8));
      Qwrite (24,1,SameAttr,'EGA Switches      = '+DecToBin(EgaSwitches,8));
    end;
end;

procedure ShowCursors;
begin
  ClearScr;
  QwriteC (1,1,CRTcols,SameAttr,'Cursor Modes Test:');
  Qwrite (3,1,SameAttr,'SET              MODE');
  Qwrite (4,1,SameAttr,'-------------   -----');
  EosLn;
  DisplaySetCursor ('Initial       = ',CursorInitial);
  DisplaySetCursor ('Underline     = ',CursorUnderline);
  DisplaySetCursor ('Half-block    = ',CursorHalfBlock);
  DisplaySetCursor ('Block         = ',CursorBlock);
  EosLn;
  QwriteEos (SameAttr,'MODIFY           MASK  MODE');
  Qwrite (succ(EosR),1,SameAttr,'-------------   ----- -----');
  EosLn;
  DisplayModCursor ('Off           = ',CursorOff);
  DisplayModCursor ('On            = ',CursorOn);
  DisplayModCursor ('Erratic Blink = ',CursorBlink);
  SetCursor (CursorUnderline);
end;

procedure RestoreVideo;
begin
  PreTextMode (OldVideoMode);
  TextMode (OldVideoMode+hi(LastMode));
  SetCursor (CursorInitial);
end;

begin
  InitScreen;
  ChooseMode;
  ShowCpuID;
  ShowSystemID;
  ShowVideoHardware;
  ShowDispDim;
  PromptKey;
  ShowCursors;
  PromptKey;
  RestoreVideo;
end.