unit VScreen;      (* Unit to handle VirtualScreens on the Heap     *)

interface

{$F+}

const
  Rows = 25;       (* Change for EGA 43 x 80, or VGA 50 x 80 lines  *)
  Collumns = 80;
  VsWordSize = Rows * Collumns;
  VsByteSize = Rows * Collumns * 2;

type
  FnString = string[12];      (* FileName string size               *)
  VsPtr = ^VirtualScreenArray; (* Virtual-screen pointer type       *)
  VirtualScreenArray = array[1..VsWordSize] of word;
  Xstring = string[Collumns]; (* Xaxis length string-type           *)
  Ystring = string[Rows];     (* Yaxis length string-type           *)
  ScrollTypes = (Up, Down, Left, Right, FlipY, FlipX);

var
  MainScreen : VsPtr;        (* Pointer to use Vscreen routines     *)
                             (* directly on the video-memory        *)
  ColorMode  : boolean;

                   (* Procedure to initialize a Vscreen pointer on  *)
                   (* the Heap                                      *)
  procedure VsInit(var VsPointer : VsPtr);

                   (* Procedure to re-initialize the Vscreen unit   *)
  procedure ReInitVsUnit;

                   (* Procedure to clear a Vscreen, with a          *)
                   (* color-attribute.                              *)
  procedure ClrVscr(VsPointer: VsPtr; CAttr : byte);

                   (* Procedure to clear a window within a Vscreen  *)
                   (* with a color-attribute.                       *)
  procedure ClrVscrWindow(VsPointer : VsPtr;
                          LxAxis, RxAxis,
                          TopYaxis, BotYaxis, CAttr : byte);

                   (* Procedure to write an integer to a Vscreen    *)
  procedure WriteIntVs(VsPointer : VsPtr;
                       IntNum : longint;
                       Width, Xaxis,
                       Yaxis, CAttr : byte);

                   (* Procedure to vertically write an integer to a *)
                   (* Vscreen                                       *)
  procedure VwriteIntVs(VsPointer : VsPtr;
                        IntNum : longint;
                        Width, Xaxis,
                        Yaxis, CAttr : byte);

                   (* Procedure to write a real to a Vscreen        *)
  procedure WriteRealVs(VsPointer : VsPtr;
                        RealNum : real;
                        Width, Decimals,
                        Xaxis, Yaxis, CAttr : byte);

                   (* Procedure to vertically write a real to a     *)
                   (* Vscreen                                       *)
  procedure VwriteRealVs(VsPointer : VsPtr;
                         RealNum : real;
                         Width, Decimals,
                         Xaxis, Yaxis, CAttr : byte);

                  (* Procedure to write a string to a Vscreen       *)
                  (* Wrap defines whether a string will wrap around *)
                  (* to the next line, it is not the bottom-line.   *)
  procedure WriteStringVs(VsPointer : VsPtr;
                          InString: Xstring;
                          Wrap : boolean;
                          Xaxis, Yaxis, CAttr : byte);

                   (* Procedure to vertically write a string to a   *)
                   (* Vscreen                                       *)
  procedure VWriteStringVs(VsPointer : VsPtr;
                           InString: Ystring;
                           Xaxis, Yaxis, CAttr : byte);

                   (* Procedure to save the current-screen display  *)
                   (* to a Vscreen                                  *)
  procedure SaveToVs(VsPointer : VsPtr);

                   (* Procedure to display a Vscreen                *)
  procedure DisplayVs(VsPointer : VsPtr);

                   (* Procedure to change AttrsToChange number of   *)
                   (* Vscreen color-attributes                      *)
  procedure SetVsXYattr(VsPointer : VsPtr;
                        AttrsToChange, Xaxis,
                        Yaxis, CAttr : byte);

                   (* Procedure to vertically change AttrsToChange  *)
                   (* number of Vscreen color-attributes            *)
  procedure VSetVsXYattr(VsPointer : VsPtr;
                         AttrsToChange, Xaxis,
                         Yaxis, CAttr : byte);

                  (* Procedure to change a window-block of Vscreen  *)
                  (* color-attributes                               *)
  procedure SetVsWindowAttr(VsPointer : VsPtr;
                            LxAxis, RxAxis,
                            TopYaxis, BotYaxis, CAttr : byte);

                   (* Procedure to set the color-attribute for      *)
                   (* the entire Vscreen                            *)
  procedure SetVsAttr(VsPointer : VsPtr; CAttr : byte);

                   (* Procedure to Save a Vscreen to a disk-file.   *)
                   (* ScreenNumber is the Vscreen record-number     *)
  procedure SaveVsToDisk(VsPointer : VsPtr;
                         FileName : FnString;
                         ScreenNumber : word);

                   (* Procedure to Load a Vscreen from a disk-file. *)
                   (* ScreenNumber is the Vscreen record-number     *)
  procedure LoadVsFromDisk(VsPointer : VsPtr;
                           FileName : FnString;
                           ScreenNumber : word);

                   (* Function that returns the attribute byte of   *)
                   (* a Vscreen char at position X,Y.               *)
  function GetVsXYattr(VsPointer : VsPtr; Xaxis, Yaxis : byte) : byte;

                   (* Function that returns a text-char from a      *)
                   (* Vscreen                                       *)
  function GetVsXYchar(VsPointer : VsPtr; Xaxis, Yaxis : byte) : char;

                   (* Function that returns a StringSize text-      *)
                   (* string from a Vscreen                         *)
  function GetVsXYstring(VsPointer : VsPtr;
                         Xaxis, Yaxis, StringSize : byte) : string;

                   (* Function that returns a vertical StringSize   *)
                   (* text-string from a Vscreen                    *)
  function VGetVsXYstring(VsPointer : VsPtr;
                          Xaxis, Yaxis, StringSize : byte) : string;

                   (* Procedure to scroll a Vscreen by ScrollNum    *)
                   (* in one of the folling directions: Up, Down,   *)
                   (* Right, Left. Two other options are available. *)
                   (* FlipY : which will reverse the order of the   *)
                   (* Vscreen rows.
                   (*   ie: Row 1 becomes Row 25, ect...            *)
                   (* FlipX : which will reverse the order of the   *)
                   (* Vscreen collumns.                             *)
                   (*   ie: Collumn 1 becomes Collumn 80, ect...    *)
                   (* ScrollNum is ignored with these routines...   *)
  procedure ScrollVs(VsPointer1 : VsPtr;
                     VsPointer2 : VsPtr;
                     Direction  : ScrollTypes;
                     ScrollNum  : word);

                   (* Procedure to move a character from Vscreen1   *)
                   (* to Vscreen2.                                  *)
  procedure MoveVsChar(VsPointer1 : VsPtr; Xaxis1, Yaxis1 : byte;
                       VsPointer2 : VsPtr; Xaxis2, Yaxis2 : byte);

                   (* Procedure to move a block of Vscreen1 to      *)
                   (* Vscreen2. CharsToMove determines the block-   *)
                   (* size.                                         *)
  procedure MoveVsBlock(VsPointer1 : VsPtr; Xaxis1, Yaxis1 : byte;
                        VsPointer2 : VsPtr; Xaxis2, Yaxis2 : byte;
                        CharsToMove : word);

                  (* Procedure to move a window-block from Vscreen1 *)
                  (* Vscreen2.                                      *)
  procedure MoveVsWindowBlock(VsPointer1 : VsPtr;
                              LxAxis1, RxAxis1,
                              TopYaxis1, BotYaxis1 : byte;
                              VsPointer2 : VsPtr;
                              LxAxis2, RxAxis2,
                              TopYaxis2, BotYaxis2 : byte);

implementation

uses
  Crt;

var                          (* Pointer to VideoDisplay Address     *)
  VideoAddress : VsPtr;

  procedure VsInit(var VsPointer : VsPtr);
  begin
    if VsPointer = Nil then
      begin
        New(VsPointer);      (* Allocate array on the Heap          *)
        FillChar(VsPointer^, SizeOf(VirtualScreenArray), 0)
      end;
  end;

  procedure ClrVscr(VsPointer: VsPtr; CAttr : byte);
  type
    ClrArrayType = array[1..(VsWordSize - 1)] of word;
  var
    ClrPtr1,
    ClrPtr2 : ^ClrArrayType;
  begin
    if VsPointer <> Nil then
      begin
        if CAttr = 0 then
          FillChar(VsPointer^, VsByteSize, 0)
        else
          begin
            ClrPtr1 := Addr(VsPointer^[1]);
            ClrPtr2 := Addr(VsPointer^[2]);
            ClrPtr1^[1] := (32 + (CAttr Shl 8));
            ClrPtr2^ := ClrPtr1^;
          end;
      end;
  end;

  procedure WriteIntVs(VsPointer : VsPtr;
                       IntNum : longint;
                       Width, Xaxis,
                       Yaxis, CAttr : byte);
  const
    TempString : Xstring = '';
  var
    TsIndex  : byte;
    VsOffset : word;
  begin
    if VsPointer <> Nil then
      begin
        if (Yaxis > Rows) then
          Yaxis := Rows;
        Str(IntNum:Width, TempString);
        if (Yaxis = Rows)
          and ((length(TempString) + Xaxis) > Collumns) then
            TempString[0] := char((Collumns + 1) - Xaxis);
        VsOffset := (((Yaxis - 1) * Collumns) + Xaxis);
        for TsIndex := 0 to (length(TempString) - 1) do
          VsPointer^[VsOffset + TsIndex] :=
                       (byte(TempString[(TsIndex + 1)]) + (CAttr Shl 8))
      end;
  end;

  procedure VwriteIntVs(VsPointer : VsPtr;
                        IntNum : longint;
                        Width, Xaxis,
                        Yaxis, CAttr : byte);
  const
    TempString : Ystring = '';
  var
    TSindex  : byte;
    VsOffset : word;
  begin
    if VsPointer <> Nil then
      begin
        if (Yaxis > Rows) then
          Yaxis := Rows;
        if (Xaxis > Collumns) then
          Xaxis := Collumns;
        VsOffset := (((Yaxis - 1) * Collumns) + Xaxis);
        Str(IntNum:Width, TempString);
        if ((length(TempString) + Yaxis) > Rows) then
          TempString[0] := char((Rows + 1) - Yaxis);
        for TSindex := 0 to (length(TempString) - 1) do
          VsPointer^[VsOffset + (TSindex * Collumns)] :=
                       (byte(TempString[(TSindex + 1)]) + (CAttr Shl 8))
      end;
  end;

  procedure WriteRealVs(VsPointer : VsPtr;
                        RealNum : real;
                        Width, Decimals,
                        Xaxis, Yaxis, CAttr : byte);
  const
    TempString : Xstring = '';
  var
    TsIndex  : byte;
    VsOffset : word;
  begin
    if VsPointer <> Nil then
      begin
        if (Yaxis > Rows) then
          Yaxis := Rows;
        VsOffset := (((Yaxis - 1) * Collumns) + Xaxis);
        Str(RealNum:Width:Decimals, TempString);
        if (Yaxis = Rows)
          and ((length(TempString) + Xaxis) > Collumns) then
            TempString[0] := char((Collumns + 1) - Xaxis);
        for TsIndex := 0 to (length(TempString) - 1) do
          VsPointer^[VsOffset + TsIndex] :=
                       (byte(TempString[(TsIndex + 1)]) + (CAttr Shl 8))
      end
  end;

  procedure VwriteRealVs(VsPointer : VsPtr;
                         RealNum : real;
                         Width, Decimals,
                         Xaxis, Yaxis, CAttr : byte);
  const
    TempString : Ystring = '';
  var
    TSindex  : byte;
    VsOffset : word;
  begin
    if VsPointer <> Nil then
      begin
        if (Yaxis > Rows) then
          Yaxis := Rows;
        if (Xaxis > Collumns) then
          Xaxis := Collumns;
        VsOffset := (((Yaxis - 1) * Collumns) + Xaxis);
        Str(RealNum:Width:Decimals, TempString);
        if ((length(TempString) + Yaxis) > Rows) then
          TempString[0] := char((Rows + 1) - Yaxis);
        for TSindex := 0 to (length(TempString) - 1) do
          VsPointer^[VsOffset + (TSindex * Collumns)] :=
                       (byte(TempString[(TSindex + 1)]) + (CAttr Shl 8))
      end
  end;

  procedure WriteStringVs(VsPointer : VsPtr;
                          InString: Xstring;
                          Wrap : boolean;
                          Xaxis, Yaxis, CAttr : byte);
  var
    ISindex  : byte;
    VsOffset : word;
  begin
    if VsPointer <> Nil then
      begin
        if (Yaxis > Rows) then
          Yaxis := Rows;
        VsOffset := (((Yaxis - 1) * Collumns) + Xaxis);
        if (Yaxis = Rows) then
          Wrap := false;
        if NOT Wrap then
          if ((length(InString) + Xaxis) > Collumns) then
            InString[0] := char((Collumns + 1) - Xaxis);
        for ISindex := 0 to (length(InString) - 1) do
          VsPointer^[VsOffset + ISindex] :=
                         (byte(InString[(ISindex + 1)]) + (CAttr Shl 8))
      end
  end;

  procedure VWriteStringVs(VsPointer : VsPtr;
                           InString: Ystring;
                           Xaxis, Yaxis, CAttr : byte);
  var
    IsIndex  : byte;
    VsOffset : word;
  begin
    if VsPointer <> Nil then
      begin
        if (Yaxis > Rows) then
          Yaxis := Rows;
        if (Xaxis > Collumns) then
          Xaxis := Collumns;
        VsOffset := (((Yaxis - 1) * Collumns) + Xaxis);
        if ((length(InString) + Yaxis) > Rows) then
          InString[0] := char((Rows + 1) - Yaxis);
        for IsIndex := 0 to (length(InString) - 1) do
          VsPointer^[VsOffset + (IsIndex * Collumns)] :=
                         (byte(InString[(IsIndex + 1)]) + (CAttr Shl 8));
      end;
  end;

  procedure ClrVscrWindow(VsPointer : VsPtr;
                          LxAxis, RxAxis,
                          TopYaxis, BotYaxis, CAttr : byte);
  var
    VsIndex,
    LineSize,
    VsOffset : word;
  begin
    if VsPointer <> Nil then
      begin
        VsOffset := (((TopYaxis - 1) * Collumns) + LxAxis);
        LineSize := (RxAxis - LxAxis) + 1;
        for VsIndex := 0 to (LineSize - 1) do
          VsPointer^[VsOffset + VsIndex] := (32 + (CAttr Shl 8));
        for VsIndex := 1 to (BotYaxis - TopYaxis) do
          move(VsPointer^[VsOffset], VsPointer^[VsOffset +
               (VsIndex * Collumns)], (LineSize * 2));
      end;
  end;

  procedure SaveToVs(VsPointer : VsPtr);
  begin
    if VsPointer <> Nil then
      begin
        if VsPointer <> Nil then
          VsPointer^ := VideoAddress^
      end;
  end;

  procedure DisplayVs(VsPointer : VsPtr);
  begin
    if VsPointer <> Nil then
      begin
        if VsPointer <> Nil then
          VideoAddress^ := VsPointer^
      end;
  end;

  procedure SetVsXYattr(VsPointer : VsPtr;
                          AttrsToChange, Xaxis,
                          Yaxis, CAttr : byte);
  var
    AttrIndex : byte;
    VsOffset  : word;
  begin
    if VsPointer <> Nil then
      begin
        if (Yaxis > Rows) then
          Yaxis := Rows;
        VsOffset := (((Yaxis - 1) * Collumns) + Xaxis);
        if (Yaxis = Rows) and ((AttrsToChange + Xaxis) > Collumns) then
          AttrsToChange := ((Collumns + 1) - Xaxis);
        for AttrIndex := 0 to (AttrsToChange - 1) do
          begin
            VsPointer^[VsOffset + AttrIndex] :=
              Lo(VsPointer^[VsOffset + AttrIndex]) + (CAttr Shl 8);
          end;
      end;
  end;

  procedure VSetVsXYattr(VsPointer : VsPtr;
                         AttrsToChange, Xaxis,
                         Yaxis, CAttr : byte);
  var
    AttrIndex : byte;
    VsOffset  : word;
  begin
    if VsPointer <> Nil then
      begin
        if (Yaxis > Rows) then
          Yaxis := Rows;
        if (Xaxis > Collumns) then
          Xaxis := Collumns;
        VsOffset := (((Yaxis - 1) * Collumns) + Xaxis);
        if ((AttrsToChange + Yaxis) > Rows) then
          AttrsToChange := ((Rows + 1) - Yaxis);
        for AttrIndex := 0 to (AttrsToChange - 1) do
          begin
            VsPointer^[VsOffSet + (AttrIndex * Collumns)] :=
              Lo(VsPointer^[VsOffSet + (AttrIndex * Collumns)]) +
                                                         (CAttr Shl 8);
          end;
      end;
  end;

  procedure SetVsWindowAttr(VsPointer : VsPtr;
                            LxAxis, RxAxis,
                            TopYaxis, BotYaxis, CAttr : byte);
  var
    LineSize,
    VsOffSet,
    VsIndex1,
    VsIndex2 : word;
  begin
    if VsPointer <> Nil then
      begin
        VsOffset := (((TopYaxis - 1) * Collumns) + LxAxis);
        LineSize := (RxAxis - LxAxis);
        for VsIndex1 := 0 to (BotYaxis - TopYaxis) do
          begin
            for VsIndex2 := 0 to LineSize do
              VsPointer^[VsOffset + VsIndex2] :=
                    Lo(VsPointer^[VsOffset + VsIndex2]) + (CAttr Shl 8);
            Inc(VsOffset,  Collumns);
          end;
      end;
  end;

  procedure SetVsAttr(VsPointer : VsPtr; CAttr : byte);
  type
    VsAttrArray =  array[1..VsByteSize] of byte;
  var
    VsAaPtr       : ^VsAttrArray;
    AttrIndex     : word;
  begin
    if VsPointer <> Nil then
      begin
        VsAaPtr := Addr(VsPointer^);
        For AttrIndex := 1 to VsWordSize do
          VsAaPtr^[AttrIndex * 2] := CAttr
      end
  end;

  procedure SaveVsToDisk(VsPointer : VsPtr;
                         FileName : FnString;
                         ScreenNumber : word);
  var
    ScreenFile : file of VirtualScreenArray;
  begin
    if VsPointer <> Nil then
      begin
        Assign(ScreenFile, FileName);
        {$I-}
        ReSet(ScreenFile);
        {$I+}
        if IoResult <> 0 then
          begin
            {$I-}
            ReWrite(ScreenFile);
            {$I+}
            if IoResult <> 0 then
              Exit;
          end;
        Seek(ScreenFile, (ScreenNumber - 1));
        Write(ScreenFile, VsPointer^);
        Close(ScreenFile)
      end
  end;

  procedure LoadVsFromDisk(VsPointer : VsPtr;
                           FileName : FnString;
                           ScreenNumber : word);
  var
    ScreenFile : file of VirtualScreenArray;
  begin
    if VsPointer <> Nil then
      begin
        Assign(ScreenFile, FileName);
        {$I-}
        ReSet(ScreenFile);
        {$I+}
        if IoResult <> 0 then
          Exit;
        Seek(ScreenFile, (ScreenNumber - 1));
        Read(ScreenFile, VsPointer^);
        Close(ScreenFile)
     end
  end;

  function GetVsXYattr(VsPointer : VsPtr; Xaxis, Yaxis : byte) : byte;
  var
    VsOffset : word;
  begin
    if VsPointer <> Nil then
      begin
        if (Yaxis > Rows) then
          Yaxis := Rows;
        if (Xaxis > Collumns) then
          Xaxis := Collumns;
        VsOffset := (((Yaxis - 1) * Collumns) + Xaxis);
        GetVsXYattr := Hi(VsPointer^[VsOffset]);
      end
  end;

  function GetVsXYchar(VsPointer : VsPtr; Xaxis, Yaxis : byte) : char;
  var
    VsOffset : word;
  begin
    if VsPointer <> Nil then
      begin
        if (Yaxis > Rows) then
          Yaxis := Rows;
        if (Xaxis > Collumns) then
          Xaxis := Collumns;
        VsOffset := (((Yaxis - 1) * Collumns) + Xaxis);
        GetVsXYchar := char(Lo(VsPointer^[VsOffset]));
      end
  end;

  function GetVsXYstring(VsPointer : VsPtr;
                         Xaxis, Yaxis, StringSize : byte) : string;
  const
    TempString : Xstring = '';
  var
    TsIndex,
    VsOffset : word;
  begin
    if VsPointer <> Nil then
      begin
        if (Yaxis > Rows) then
          Yaxis := Rows;
        VsOffset := (((Yaxis - 1) * Collumns) + Xaxis);
        if (Yaxis = Rows) and ((Xaxis + StringSize) > Collumns) then
          TempString[0] := char((Collumns + 1) - Xaxis)
        else
          TempString[0] := char(StringSize);
        for TsIndex := 0 to (length(TempString) - 1) do
          TempString[(TsIndex + 1)] :=
                               char(Lo(VsPointer^[VsOffset + TsIndex]));
        GetVsXYstring := TempString;
      end
  end;

  function VGetVsXYstring(VsPointer : VsPtr;
                          Xaxis, Yaxis, StringSize : byte) : string;
  const
    TempString : Ystring = '';
  var
    TsIndex,
    VsOffset : word;
  begin
    if VsPointer <> Nil then
      begin
        if (Yaxis > Rows) then
          Yaxis := Rows;
        if (Xaxis > Collumns) then
          Xaxis := Collumns;
        VsOffset := (((Yaxis - 1) * Collumns) + Xaxis);
        if ((StringSize + Yaxis) > Rows) then
          TempString[0] := char((Rows + 1) - Yaxis)
        else
          TempString[0] := char(StringSize);
        for TsIndex := 0 to (length(TempString) - 1) do
          TempString[(TsIndex + 1)] := char(Lo(VsPointer^[VsOffset +
                                             (TsIndex * Collumns)]));
        VGetVsXYstring := TempString;
      end
  end;

  procedure ScrollVs(VsPointer1 : VsPtr;
                     VsPointer2 : VsPtr;
                     Direction  : ScrollTypes;
                     ScrollNum  : word);
  var
    S1, S2 : word;
  begin
    if (VsPointer1 <> Nil)
      and (VsPointer2 <> Nil)
        and (VsPointer1 <> VsPointer2) then
      begin
        case Direction of
          Up    : move(VsPointer1^[(ScrollNum * Collumns) + 1],
                       VsPointer2^[1], (VsByteSize - (ScrollNum *
                       Collumns * 2)));
          Down  : move(VsPointer1^[1],
                       VsPointer2^[(ScrollNum * Collumns) + 1],
                       (VsByteSize - (ScrollNum * Collumns * 2)));
          Right : for S1 := 0 to (Rows - 1) do
                    move(VsPointer1^[1 + (S1 * Collumns)],
                         VsPointer2^[1 + (S1 * Collumns) + ScrollNum],
                         ((Collumns - ScrollNum) * 2));
          Left  : for S1 := 0 to (Rows - 1) do
                    move(VsPointer1^[1 + (S1 * Collumns) + ScrollNum],
                         VsPointer2^[1 + (S1 * Collumns)],
                         ((Collumns - ScrollNum) * 2));
          FlipX : for S1 := 0 to (Rows - 1) do
                    for S2 := 0 to (Collumns - 1) do
                      VsPointer2^[(Collumns - S2) + (S1 * Collumns)] :=
                        VsPointer1^[(S2 + 1) + (S1 * Collumns)];
          FlipY : for S1 := 0 to (Rows - 1) do
                    move(VsPointer1^[1 + (S1 * Collumns)],
                         VsPointer2^[1 + ((Rows - (S1 + 1))
                         * Collumns)], (Collumns * 2));
        end;       (* case Direction of...                           *)
      end;
  end;

  procedure MoveVsChar(VsPointer1 : VsPtr; Xaxis1, Yaxis1 : byte;
                       VsPointer2 : VsPtr; Xaxis2, Yaxis2 : byte);
  var
    VsOffset1,
    VsOffset2 : word;
  begin
    if (VsPointer1 <> Nil)
      and (VsPointer2 <> Nil)
        and (VsPointer1 <> VsPointer2)