
program CGALoRes;

(*--------------------------------------------------------------------------*)
(*                                                                          *)
(*          This low resolution graphics mode provides resolution           *)
(*          of 160 horizontal by 100 vertical pixels in 16 colors.          *)
(*          This mode is not directly supported by the IBM PC BIOS,         *)
(*          special programming of the CRT registers is required.           *)
(*          The PCjr has a similar 160x200 standard graph mode.             *)
(*                                                                          *)
(*          This new version incorporates the ability to write              *)
(*          alphanumeric text using both the low and high ascii             *)
(*          character maps that are standard in the rom of an IBM           *)
(*          PCjr. The PC does not have the high set in rom and it           *)
(*          must either be hard-coded or read from disk. I created          *)
(*          both disk files ( LO_ASCII.FNT and HI_ASCII.FNT ) by            *)
(*          copying them from the rom of an IBM PCjr. Procedures to         *)
(*          blank the screen and disable blink were also included.          *)
(*                                                                          *)
(*          The plot and draw routines are originally by Philip Burns       *)
(*          ( see PC SIG Turbo Disk No. 7 (#427) for PIBLORES.PAS )         *)
(*          and the CRT controller re-programming comes from an article     *)
(*          (using Basic) by Bernie Lawrence in  PC WORLD (Apr 1985).       *)
(*          Philip asked for a routine to do text - here it is.             *)
(*          I took some liberties in rewriting and shortening the           *)
(*          previous programs. This new program will run on a PCjr.         *)
(*          It will run on a CGA, but not an EGA which does not use a       *)
(*          6845 CRT controller chip. This is not a very portable routine.  *)
(*                                                                          *)
(*    With the Color Graphics Adapter            Donald L. Pavia            *)
(*    a satisfactory solution to the             Dept. of Chemistry - WWU   *)
(*    the problem of snow remains to be          Bellingham, WA.  98225     *)
(*    solved. I used a 2nd graphics              January 1986               *)
(*    page here to avoid the problem.                                       *)
(*    Snow is no problem on the PCjr.                                       *)
(*--------------------------------------------------------------------------*)

const ColorSeg  = $B800; ColorOfs  = $0000;

      ModeReg    = $3D8; ColorReg  = $3D9;               { control registers }

      ModeSave   = $465; ColorSave = $466;       { BIOS saves registers here }

      CRTReg     = $3D4; CRTData   = $3D5;   { 6845 CRT controller registers }

      RetraceReg = $3DA; PCjrVGA   = $3DA;     {   vertical retrace register }
                                               {   video gate array for PCjr }
      HiResMode  = 1;    VideoMode = 8;        { lores is form of 80x25 text }

      OffSet     = 0;

      RegData : array[0..11] of integer               { 6845 register data  }

             = ( 113,              (* Horizontal total          *)
                 80,               (* Horizontal displayed      *)
                 90,               (* Horizontal sync position  *)
                 10,               (* Horizontal sync width     *)
                 127,              (* Vertical total            *)
                 6,                (* Vertical adjust           *)
                 100,              (* Vertical displayed        *)
                 112,              (* Vertical sync position    *)
                 2,                (* Non-interlace mode        *)
                 1,                (* Maximum scan line address *)
                 32,               (* Disable cursor display    *)
                 0    );           (* Cursor end                *)

type  str20 = string[20];
      ScreenType = array[0..16383] of byte;
      ScreenPointer = ^ScreenType;
      ScreenFile = file of ScreenType;

var   Register,Mode,Current : integer;
      i,PixCol,Color,X,Y,T  : integer;
      ColorScreen  : ScreenType absolute $B800:$0000;
      ScreenBuffer : ScreenType;
      LoFonts,HiFonts : array[1..1024] of byte;   { in an IBM you could have }
      CRTStatus : byte; Wait : char;              { an absolute address for  }
      Screen : ScreenPointer;                     { LoFonts, rather than     }
                                                  { loading it from disk     }
{----------------------------------------------------------------------------}
procedure SaveScreen (FileName : str20);

  var  FileToSave : ScreenFile;

  begin
       Screen := ptr (ColorSeg,ColorOfs);
       assign (FileToSave,FileName);
       rewrite (FileToSave);
       write (FileToSave,Screen^);
       close (FileToSave);
  end;
{----------------------------------------------------------------------------}
procedure LoadScreen (FileName : str20);

  var  DisplayFile : ScreenFile;

  begin
       Screen := ptr (ColorSeg,Offset);
       assign (DisplayFile,FileName);
       reset (DisplayFile);
       read (DisplayFile,Screen^);
       close (DisplayFile);
  end;
{----------------------------------------------------------------------------}
procedure AwaitVRetrace;                         { to eliminate snow on CGA }

begin
     repeat CRTStatus := Port[RetraceReg]; until ((CRTStatus and 8) = 0);

     while ((CRTStatus and 8) = 0) do CRTStatus := Port[RetraceReg];
end;
{----------------------------------------------------------------------------}
procedure BlankScreen;                                       { turn off CRT }

begin  MemW[CSeg : ModeSave] := Mode;  Port[ModeReg] := Mode and $F7;  end;

{----------------------------------------------------------------------------}
procedure RestoreScreen;                                     { turn on  CRT }

begin  MemW[CSeg : ModeSave] := Mode;  Port[ModeReg] := Mode or $08;   end;

{----------------------------------------------------------------------------}
procedure ClrLoResScreen;                   (*   byte = { **B* ***F }   *)
                                            (*    sum of *'s = 222      *)
begin FillChar (ColorScreen ,16383,0);
      for i := 0 to 7999 do ColorScreen[2*i] := 222;
end;
{----------------------------------------------------------------------------}
procedure ClrLoResBuff;                         { clear the screen buffer }

begin FillChar (ScreenBuffer,16383,0);
      for i := 0 to 7999 do ScreenBuffer[2*i] := 222;
end;
{----------------------------------------------------------------------------}
procedure Show;               { transfer to screen in bursts to prevent snow }
                              { 50 x 320 + 384 = 16384  might be safer than  }
var   i,k : integer;          { the currently used  40 x 400 + 384  combo    }

begin
      if mem[$F000:$FFFE] = $FD then move (ScreenBuffer,ColorScreen,16383)

      else
           begin k := 0;
                 for i := 1 to 40 do begin
                    AwaitVRetrace;
                    move (ScreenBuffer[k],ColorScreen[k],400);
                    k := k + 400;
                 end;
                 AwaitVRetrace;
                 move (ScreenBuffer[k],ColorScreen[k],384);
           end;
end;
{----------------------------------------------------------------------------}
procedure DisableBlink;         { the earlier version did NOT have 16 colors }
                                { the blink bit must be disabled for that.   }
                                { Enable it again to see the difference.     }
begin
      if mem[$F000:$FFFE] = $FD then                                 { PCjr }
        begin Port[PCjrVGA] := 3; Port[PCjrVGA] := 0; end
      else begin                                                       { PC }
            Current := mem[$0000:$465]; Port[$03D8] := Current and $DF;
      end;
end;
{----------------------------------------------------------------------------}
procedure LoResGraphMode;                         { set lores graphics mode }

begin
      Mode := HiResMode + VideoMode;
      MemW[CSeg : ModeSave] := Mode; Port[ModeReg] := Mode;

      for Register := 0 TO 11 do                 { reprogram 6845 for lores }
        begin
           Port[CrtReg]  := Register; Port[CrtData] := RegData[Register];
        end;

      DisableBlink;

      BlankScreen;                          { to prevent display of garbage }
      ClrLoResScreen;
      RestoreScreen;

end;  { LoResGraphMode }
{----------------------------------------------------------------------------}
procedure LoResPlot (X,Y,PixCol : integer);        { plots to hidden screen }
                                                   { to avoid snow          }

                             { Plots point in low-resolution graphics mode  }
                             { X      -- Horizontal postion (0 through 159) }
                             { Y      -- Vertical position (0 through 119)  }
                             { PixCol -- Color (0 through 15) of point      }
                             {         calls outside range are ignored      }

var  Pixel,PixelAddr,Nibble : integer;
     Legal: boolean;

begin
     Legal := (x >= 0) and (x <= 159) and (y >= 0) and (y <= 119) and
                                        (PixCol >= 0) and (PixCol <= 15);
     if Legal then
        begin
             Pixel      := X + ( Y * 160 );
             PixelAddr  := ( Pixel and $FFFE ) + 1;
             Nibble     := Pixel mod 2;

            { AwaitVRetrace; }     { works great, but really slows output ! }
                                   { to see, remove SHOW's in main program }
                                   { and change ScreenBuffer to ColorScreen }
                                   { in this procedure                      }
             if Nibble = 0 then
                ScreenBuffer[PixelAddr] :=
                       ( ScreenBuffer[PixelAddr] and $0F ) + PixCol * 16
             else
                ScreenBuffer[PixelAddr] :=
                       ( ScreenBuffer[PixelAddr] and $F0 ) + PixCol;
        end;

end;   { LoResPlot }
{----------------------------------------------------------------------------}
procedure LoResDraw (X1,Y1,X2,Y2,LineCol : integer);

var  X,Y,Xinc,Yinc,CorrecInc :  integer;  Dx,Cdx,Dy,Cdy : integer;
     Plotit: boolean;

begin
      X  := X1; Y  := Y1;                { starting point }

      Dx := X2 - X1; Dy := Y2 - Y1;      { changes in (x,y) directions }

                                         { set increments }

      if Dx > 0 then Xinc := 1 else  begin Xinc := -1; Dx := -Dx;  end;
      if Dy > 0 then Yinc := 1 else  begin Yinc := -1; Dy := -Dy;  end;

                                         { CorrecInc is correction value }

      if Dy > Dx then CorrecInc := Dy else CorrecInc := Dx;

      Cdx := CorrecInc; Cdy := CorrecInc;

      LoResPlot( X, Y, LineCol );           { plot first point }

      while ( (X <> X2) and (Y <> Y2)) do   { plot remaining points }
        begin
             PlotIt := false; Cdx := Cdx - Dx;

             if Cdx < 0 then
               begin
                    PlotIt := true; X := X + Xinc; Cdx := Cdx + CorrecInc;
               end;

             Cdy := Cdy - Dy;

             if Cdy < 0 then
               begin
                    PlotIt := true; Y := Y + Yinc; Cdy := Cdy + CorrecInc;
               end;

             if PlotIt then LoResPlot( X, Y, LineCol );
        end;

end;  { LoResDraw }
{----------------------------------------------------------------------------}
function BitSet (InByte : byte; WhichBit : integer) : boolean;

begin if ((InByte div WhichBit) mod 2) = 1 then BitSet := true
                                           else BitSet := false;
end;
{----------------------------------------------------------------------------}
procedure LoResChar (CharNum,x,y,color : integer);

var  Index,i,xx,yy : integer; InByte : byte;

begin
     if CharNum < 128 then Index := (CharNum * 8)
                      else Index := ((CharNum - 128) * 8);
     xx := x - 8; yy := y - 8;

     for i := 1 to 8 do begin

          if CharNum < 128 then InByte := LoFonts[Index+i]
                           else InByte := HiFonts[Index+i];

          if BitSet (InByte,128) then LoResPlot (xx+1,yy+i,Color);
          if BitSet (InByte, 64) then LoResPlot (xx+2,yy+i,Color);
          if BitSet (InByte, 32) then LoResPlot (xx+3,yy+i,Color);
          if BitSet (InByte, 16) then LoResPlot (xx+4,yy+i,Color);
          if BitSet (InByte,  8) then LoResPlot (xx+5,yy+i,Color);
          if BitSet (InByte,  4) then LoResPlot (xx+6,yy+i,Color);
          if BitSet (InByte,  2) then LoResPlot (xx+7,yy+i,Color);
          if BitSet (InByte,  1) then LoResPlot (xx+8,yy+i,Color);
     end;

end;
{----------------------------------------------------------------------------}
procedure LoResString (DisplayString : str20; col,row,color : integer);

var  i,x,y,AsciiNum : integer;
     Valid : boolean;

begin
     Valid := (col >= 1) and (col <= 20) and (row >= 1) and (row <= 12);

     if Valid then begin
       x := (8 * col) ; y := (8 * row) ;
       for i := 1 to length(DisplayString) do
          begin
             AsciiNum := ord(DisplayString[i]);
             LoResChar (AsciiNum,x,y,color);
             x := x + 8;
          end;
     end;

end;
{----------------------------------------------------------------------------}
procedure LoadFonts;              { these files have to be on the disk ! }
                                  { or you can read then from rom if you }
var  FontFile : file;             { have a PCjr. Only the first one is   }
                                  { in rom in a PC.                      }
begin
     assign (FontFile,'LO_ASCII.FNT');
     reset  (FontFile);                       { you could have an absolute }
     BlockRead (FontFile,LoFonts,8);          { address for LoFonts if you }
     close (FontFile);                        { if you have an IBM         }

     assign (FontFile,'HI_ASCII.FNT');
     reset  (FontFile);
     BlockRead (FontFile,HiFonts,8);
     close (FontFile);
end;
(*--------------------------------------------------------------------------*)
(*                      NewLoRes --- Main Program                           *)
(*--------------------------------------------------------------------------*)

BEGIN  (* program NewLoRes *)

      ClrScr; LoadFonts;
      gotoxy (5,5);
      write ('Press the <ENTER> key now to see 160x100 LoRes Graphics ');
      gotoxy (5,7);
      write ('Then press it again after each display.');
      gotoxy (5,9);
      write ('After pressing <ENTER> there will be about a 10 sec wait ');
      gotoxy (5,10); write ('while I set up.  ');
      read (Kbd,Wait);

      LoResGraphMode; ClrLoResBuff;

      LoResDraw (0,0,100,100,5);
      for i := 0 to 159 do LoResPlot   (i,0,6);
      for i := 0 to  99 do LoResPlot (159,i,2);
      for i := 0 to  99 do LoResPlot   (0,i,3);
      for i := 0 to 159 do LoResPlot  (i,99,4);
      SHOW;

      for i := 0 to 7 do
                   LoResString ('16 Colors',i+3,i+1,i);
      SHOW;

      LoResString ('NEW',1,5,12);
      LoResString ('VIDEO',1,6,11);
      LoResString ('MODE',1,7,14);
      LoResString ('LOW RES',1,8,9);
      LoResString ('16 COLOR',1,9,10);
      LoResString ('GRAPHICS',1,10,15);
      LoResString ('160x100',1,11,13);
      Delay (1500);
      SHOW;

      LoResString ('D.Pavia',3,12,8);
      LoResString ('Jan 86',14,1,8);
      LoResString (#240+#241+#242+#243+#244+#245+#246+#247,12,10,3);
      LoResString (#224+#225+#226+#227+#228+#229,14,12,1);
      Delay (2500);
      SHOW;

      read (Kbd,Wait);
      BlankScreen; SaveScreen ('LORES.PIC'); RestoreScreen;
      GraphMode; TextMode (c80); clrscr;

      gotoxy (5,5);
      write ('This is TextMode (80x25). But I Saved Your Screen in Memory.');
      gotoxy (5,8); write ('Press <ENTER> to See It.. ');

      read (Kbd,Wait); LoResGraphMode;
      SHOW;

      read (Kbd,Wait); GraphMode; TextMode (c80); clrscr;

      gotoxy (5,5);
      write ('While You are Reading This I am Preparing a New Screen. ');
      write ('Wait Please. ');

      ClrLoResBuff;
      for i := 1 to 7 do LoResString ('This is New !',i,i+1,i);
      gotoxy (5,8); write ('READY ...... ');

      read (Kbd,Wait); LoResGraphMode;
      SHOW;

      read (Kbd,Wait); GraphMode; TextMode (c80); clrscr;

      gotoxy (5,5); write ('I also Saved Your Screen on Disk !!!');
      gotoxy (5,8); write ('Press <ENTER> to See ...  ');

      read (Kbd,Wait); LoResGraphMode;

      BlankScreen; LoadScreen ('LORES.PIC'); RestoreScreen;

      read (Kbd,Wait); GraphMode; TextMode( C80 ); clrscr;
      gotoxy (15,10); write ('Thank You for Watching the Show !!!');
      gotoxy (40,14); write ('Donald L. Pavia');
      gotoxy (40,15); write ('January 20, 1986');
      gotoxy (30,24); write ('Press <ENTER> to Quit  ');

      read (Kbd,Wait);
      GraphMode; TextMode (c80); clrscr;    { exit gracefully, restore 6845 }

END.   (* program CGALoRes *)
