{$S-,R-,I-,V-,B-}

  {*********************************************************}
  {*                    TPCRT.PAS 4.03                     *}
  {*        Copyright (c) TurboPower Software 1987.        *}
  {* Portions copyright (c) Sunny Hill Software 1985, 1986 *}
  {*     and used under license to TurboPower Software     *}
  {*                 All rights reserved.                  *}
  {*********************************************************}


unit TPCrt;
  {-Alternate CRT interface unit. Replaces Turbo's CRT unit.}

interface

type
  FrameCharType = (ULeft, LLeft, URight, LRight, Horiz, Vert);
  FrameArray = array[FrameCharType] of char;
const
  {video mode constants}
  BW40 = 0;
  CO40 = 1;
  C40 = CO40;
  BW80 = 2;
  CO80 = 3;
  C80 = CO80;
  Mono = 7;
  Font8x8 = 256;

  {color constants}
  Black = 0;
  Blue = 1;
  Green = 2;
  Cyan = 3;
  Red = 4;
  Magenta = 5;
  Brown = 6;
  LightGray = 7;
  DarkGray = 8;
  LightBlue = 9;
  LightGreen = 10;
  LightCyan = 11;
  LightRed = 12;
  LightMagenta = 13;
  Yellow = 14;
  White = 15;
  Blink = 128;

  FrameChars : FrameArray = 'ÕÔ¸¾Í³';

  MapColors : Boolean = True; {True to let MapColor map colors for mono visibility}
  BiosScroll : Boolean = True;

  {Set to True to allow programs to run as background tasks under
   DesqView/TaskView. Must be set False for TSR's.}
  DetectMultitasking : Boolean = False;

type
  DisplayType = (MonoHerc, CGA, MCGA, EGA, VGA);

  {record used to save/restore window coordinates}
  WindowCoordinates = record
                        XL, YL, XH, YH : Byte;
                      end;
var
  {from Turbo's CRT unit}
  CheckBreak : Boolean;      {enable Ctrl-Break checking}
  CheckEOF : Boolean;        {enable Ctrl-Z checking}
  DirectVideo : Boolean;     {write directly to screen?}
  CheckSnow : Boolean;       {True to prevent snow on CGA's}
  TextAttr : Byte;           {current video attribute}
  WindMin : Word;            {Window XLow and YLow: 0..24, 0..79 format}
  WindMax : Word;            {Window XHigh and YHigh: 0..24, 0..79 format}
  SaveInt1B : Pointer;       {old INT $1B handler}
  LastMode : Word;           {current video mode in low byte /
                              8x8 flag in high byte}

  {unique to Turbo Professional version}
  CtrlBreakFlag : Boolean;   {set to true when ^Break pressed}
  CurrentPage : Byte;        {current video page}
  CurrentMode : Byte absolute LastMode; {current video mode}
  CurrentWidth : Word;       {current width of display}
  CurrentHeight : Word;      {current height of display - 1}
  CurrentDisplay : DisplayType; {currently selected display adapter}
  EnhancedDisplay : DisplayType; {meaningful only if set to MCGA, VGA, or EGA}
  InTextMode : Boolean;      {set to false when in graphics mode}
  NormalAttr : Byte;         {attribute for NormVideo}
  VideoSegment : Word;       {current segment for video memory}
  BufLen : Word;             {maximum length of string for Read/Ln -- valid
                              range is 1-126, reset to 126 after each Read}
  MultiTaskingOn : Boolean;  {needed to support DesqView, TaskView}
  OneMS : Word;              {loop count used for a 1 ms delay}

procedure TextMode(Mode : Word);
  {-Switch to/set text mode}

procedure Window(XLow, YLow, XHigh, YHigh : Byte);
  {-Set current window coordinates}

procedure ClrScr;
  {-Clear the current window}

procedure ClrEol;
  {-Clear the remainder of the current screen line}

procedure InsLine;
  {-Insert a new line at the position of the cursor}

procedure DelLine;
  {-Delete current screen line}

procedure GoToXY(X, Y : Byte);
  {-Move cursor to column X, row Y, relative to Window}

function WhereX : Byte;
  {-Return column coordinate of cursor, relative to Window}

function WhereY : Byte;
  {-Return row coordinate of cursor, relative to Window}

procedure TextColor(Color : Byte);
  {-Set foreground color for screen writes}

procedure TextBackground(Color : Byte);
  {-Set background color for screen writes}

procedure LowVideo;
  {-Select low intensity}

procedure HighVideo;
  {-Select high intensity}

procedure NormVideo;
  {-Select video attribute used at start of program}

function KeyPressed : Boolean;
  {-Return true if a key has been pressed}

function ReadKey : Char;
  {-Read a character from the keyboard}

procedure AssignCrt(var F : Text);
  {-Routes input and output through our routines}

procedure Delay(MS : Word);
  {-Delay for MS milliseconds}

procedure Sound(Hz : Word);
  {-Turn on the sound at the designated frequency}

procedure NoSound;
  {-Turn off the sound}

  {****** extensions to Turbo's CRT unit ******}

function GetCrtMode : Byte;
  {-Get the current video mode. Also reinitializes internal variables. May
    reset: CurrentMode, CurrentWidth, CurrentHeight, CurrentPage, and
    VideoSegment.}

procedure GotoXYAbs(X, Y : Byte);
  {-Move cursor to column X, row Y. No error checking done.}

function WhereXY : Word;
  {-Return absolute row and column coordinates of cursor. High byte has current
    row (Y), low byte has current column (X).}

function WhereYAbs : Byte;
  {-Return absolute row coordinate of cursor}

function WhereXAbs : Byte;
  {-Return absolute column coordinate of cursor}

procedure SetVisiblePage(PageNum : Byte);
  {-Set current video page}

procedure ScrollWindowUp(XLo, YLo, XHi, YHi, Lines : Byte);
  {-Scrolls the designated window up the specified number of lines.}

procedure ScrollWindowDown(XLo, YLo, XHi, YHi, Lines : Byte);
  {-Scrolls the designated window down the specified number of lines.}

function CursorTypeSL : Word;
  {-Returns a word. High byte has starting scan line, low byte has ending.}

function CursorStartLine : Byte;
  {-Returns the starting scan line of the cursor}

function CursorEndLine : Byte;
  {-Returns the ending scan line of the cursor.}

procedure SetCursorSize(Startline, EndLine : Byte);
  {-Sets the cursor's starting and ending scan lines.}

procedure NormalCursor;
  {-Set normal scan lines for cursor based on current video mode}

procedure FatCursor;
  {-Set larger scan lines for cursor based on current video mode}

procedure BlockCursor;
  {-Set scan lines for a block cursor}

procedure HiddenCursor;
  {-Hide the cursor}

function ReadCharAtCursor : Char;
  {-Returns character at the current cursor location on the selected page.}

procedure GetCursorState(var XY, ScanLines : Word);
  {-Return the current position and size of the cursor}

procedure RestoreCursorState(XY, ScanLines : Word);
  {-Reset the cursor to a position and size saved with GetCursorState}

procedure FastWrite(St : string; Row, Col, Attr : Byte);
  {-Write St at Row,Col in Attr (video attribute) without snow}

procedure FastText(St : string; Row, Col : Byte);
  {-Write St at Row,Col without changing the underlying video attribute.}

procedure FastWriteWindow(S : string; Row, Col, Attr : Byte);
  {-Write a string using window-relative coordinates}

procedure FastRead(Number, Row, Col : Byte; var St : string);
  {-Read Number bytes from the screen into St starting at Row,Col}

procedure ChangeAttribute(Number : Word; Row, Col, Attr : Byte);
  {-Change Number video attributes to Attr starting at Row,Col}

procedure MoveScreen(var Source, Dest; Length : Word);
  {-Move Length words from Source to Dest without snow}

function Font8x8Selected : Boolean;
  {-Return True if EGA or VGA is active and in 8x8 font}

procedure SelectFont8x8(On : Boolean);
  {-Toggle 8x8 font on or off. Does not reset Window() or clear the screen!}

function KbdFlags : Byte;
  {-Returns keyboard status flags as a bit-coded byte}

function ReadKeyWord : Word;
  {-Waits for keypress, then returns scan and character codes together. Low
    byte is character, high byte is extended code.}

function CheckKbd(var KeyCode : Word) : Boolean;
  {-Returns True (and the key codes) if a keystroke is waiting}

procedure ReInitCrt;
  {-Reinitialize CRT unit's internal variables. For TSR's or programs with
    DOS shells. May reset: CurrentMode, CurrentHeight, WindMin/WindMax,
    CurrentPage, CurrentDisplay, CheckSnow, and VideoSegment.}

function SaveWindow(XLow, YLow, XHigh, YHigh : Byte; Allocate : Boolean;
                    var Covers : Pointer) : Boolean;
  {-Allocate buffer space if requested and save window contents}

procedure RestoreWindow(XLow, YLow, XHigh, YHigh : Byte;
                        Deallocate : Boolean; var Covers : Pointer);
  {-Restore screen contents and deallocate buffer space if requested}

procedure SetFrameChars(Vertical, Horizontal, LowerRight, UpperRight,
                        LowerLeft, UpperLeft : Char);
  {-Sets the frame characters to be used on subsequent FrameWindow calls.}

procedure FrameWindow(LeftCol, TopRow, RightCol, BotRow, FAttr, HAttr : Byte;
                      Header : String);
  {-Draws a frame around a window}

function MapColor(c : Byte) : Byte;
  {-Map a video attribute for visibility on mono/bw displays}

procedure StoreWindowCoordinates(var WC : WindowCoordinates);
  {-Store the window coordinates for the active window}

procedure RestoreWindowCoordinates(WC : WindowCoordinates);
  {-Restore previously saved window coordinates}

  {==========================================================================}

implementation

type
  BufPtr = ^BufferArray;
  BufferArray = array[0..MaxInt] of Char;
var
  BiosScanLines : Word absolute $40 : $60;
  IsCompaq : Boolean;
  CompaqBiosName : array[1..6] of Char absolute $FFFE:$000A;
  IsZenith : Boolean absolute IsCompaq;
  ZenithBiosName : array[1..6] of Char absolute $FB00:$0000;
  NextChar : Byte;

  {$L TPCRT.OBJ}
  {$L TPCRT2.OBJ}
  {$L TPFAST.OBJ}
  {$L TPCMISC.OBJ}

  procedure TextMode(Mode : Word);
    external {TPCRT2} ;

  procedure Window(XLow, YLow, XHigh, YHigh : Byte);
    external {TPCRT2} ;

  procedure ClrScr;
    external {TPCRT2} ;

  procedure ClrEol;
    external {TPCMISC} ;

  procedure InsLine;
    external {TPCMISC} ;

  procedure DelLine;
    external {TPCMISC} ;

  procedure GoToXY(X, Y : Byte);
    external {TPCRT2} ;

  function WhereX : Byte;
    external {TPCRT2} ;

  function WhereY : Byte;
    {-Return row coordinate of cursor, relative to Window}
    external {TPCRT2} ;

  procedure TextColor(Color : Byte);
    external {TPCRT2} ;

  procedure TextBackground(Color : Byte);
    external {TPCRT2} ;

  procedure LowVideo;
    external {TPCRT2} ;

  procedure HighVideo;
    external {TPCRT2} ;

  procedure NormVideo;
    external {TPCRT2} ;

  function KeyPressed : Boolean;
    external {TPCRT2} ;

  function ReadKey : Char;
    external {TPCRT} ;

  procedure AssignCrt(var F : Text);
    external {TPCRT} ;

  procedure Delay(MS : Word);
    external {TPCRT2} ;

  procedure Sound(Hz : Word);
    external {TPCMISC} ;

  procedure NoSound;
    external {TPCMISC} ;

  {****** extensions to Turbo's CRT unit ******}

  function GetCrtMode : Byte;
    external {TPCRT2} ;

  procedure GotoXYAbs(X, Y : Byte);
    external {TPCRT2} ;

  function WhereXY : Word;
    external {TPCMISC} ;

  function WhereXAbs : Byte;
    external {TPCMISC} ;

  function WhereYAbs : Byte;
    external {TPCMISC} ;

  procedure SetVisiblePage(PageNum : Byte);
    external {TPCMISC} ;

  procedure ScrollWindowUp(XLo, YLo, XHi, YHi, Lines : Byte);
    external {TPCMISC} ;

  procedure ScrollWindowDown(XLo, YLo, XHi, YHi, Lines : Byte);
    external {TPCMISC} ;

  function CursorTypeSL : Word;
    external {TPCMISC} ;

  function CursorStartLine : Byte;
    external {TPCMISC} ;

  function CursorEndLine : Byte;
    external {TPCMISC} ;

  procedure SetCursorSize(Startline, EndLine : Byte);
    external {TPCMISC} ;

  procedure NormalCursor;
    {-Set normal scan lines for cursor based on current video mode}
  var
    ScanLines : Word;
  begin
    if Font8x8Selected then
      ScanLines := $0507
    else
      if CurrentMode = 7 then
        ScanLines := $0B0C
      else
        ScanLines := $0607;
    SetCursorSize(Hi(ScanLines), Lo(ScanLines));
  end;

  procedure FatCursor;
    {-Set larger scan lines for cursor based on current video mode}
  var
    ScanLines : Word;
  begin
    if Font8x8Selected then
      ScanLines := $0307
    else
      if CurrentMode = 7 then
        ScanLines := $090C
      else
        ScanLines := $0507;
    SetCursorSize(Hi(ScanLines), Lo(ScanLines));
  end;

  procedure BlockCursor;
    {-Set scan lines for a block cursor}
  var
    EndLine : Byte;
  begin
    if Font8x8Selected or (CurrentMode <> 7) then
      EndLine := $07
    else
      EndLine := $0C;
    SetCursorSize(0, EndLine);
  end;

  procedure HiddenCursor;
    {-Hide the cursor}
  begin
    SetCursorSize($20, 0);
  end;

  procedure GetCursorState(var XY, ScanLines : Word);
    {-Return the current position and size of the cursor}
  begin
    XY := WhereXY;
    ScanLines := CursorTypeSL;
  end;

  procedure RestoreCursorState(XY, ScanLines : Word);
    {-Reset the cursor to a position and size saved with GetCursorState}
  begin
    SetCursorSize(Hi(ScanLines), Lo(ScanLines));
    GotoXYAbs(Lo(XY), Hi(XY));
  end;

  function ReadCharAtCursor : Char;
    external {TPCRT2} ;

  procedure FastWrite(St : string; Row, Col, Attr : Byte);
    external {TPFAST} ;

  procedure FastText(St : string; Row, Col : Byte);
    external {TPFAST} ;

  procedure FastWriteWindow(S : string; Row, Col, Attr : Byte);
    external {TPFAST} ;

  procedure FastRead(Number, Row, Col : Byte; var St : string);
    external {TPFAST} ;

  procedure ChangeAttribute(Number : Word; Row, Col, Attr : Byte);
    external {TPFAST} ;

  procedure MoveScreen(var Source, Dest; Length : Word);
    external {TPFAST} ;

  function Font8x8Selected : Boolean;
    external {TPCRT2} ;

  procedure SelectFont8x8(On : Boolean);
    external {TPCRT2} ;

  function KbdFlags : Byte;
    external {TPCMISC} ;

  function ReadKeyWord : Word;
    external {TPCRT2} ;

  function CheckKbd(var KeyCode : Word) : Boolean;
    external {TPCMISC} ;

  procedure ReInitCrt;
    external {TPCRT} ;

  function SaveWindow(XLow, YLow, XHigh, YHigh : Byte; Allocate : Boolean;
                      var Covers : Pointer) : Boolean;
    {-Allocate buffer space if requested and save window contents}
  var
    CoversP : BufPtr absolute Covers;
    WordsPerRow : Word;
    BufBytes : Word;
    SrcPos : Word;
    DestPos : Word;
    Row : Word;
  begin
    {assume success}
    SaveWindow := True;

    {compute number of words to move per row}
    WordsPerRow := Succ(XHigh-XLow);

    if Allocate then begin
      {compute bytes needed for screen buffer}
      BufBytes := (WordsPerRow*Succ(YHigh-YLow)) shl 1;

      {make sure enough memory is available}
      if MaxAvail < LongInt(BufBytes) then begin
        SaveWindow := False;
        Exit;
      end
      else
        {allocate the screen buffer}
        GetMem(CoversP, BufBytes);
    end;

    {save current contents to the screen buffer}
    DestPos := 0;
    SrcPos := (Pred(YLow)*CurrentWidth+Pred(XLow)) shl 1;
    for Row := YLow to YHigh do begin
      MoveScreen(Mem[VideoSegment:SrcPos], CoversP^[DestPos], WordsPerRow);
      Inc(SrcPos, CurrentWidth shl 1);
      Inc(DestPos, WordsPerRow shl 1);
    end;
  end;

  procedure RestoreWindow(XLow, YLow, XHigh, YHigh : Byte;
                          Deallocate : Boolean; var Covers : Pointer);
    {-Restore screen contents and deallocate buffer space if requested}
  var
    CoversP : BufPtr absolute Covers;
    WordsPerRow : Word;
    SrcPos : Word;
    DestPos : Word;
    Row : Word;
  begin
    {compute number of words to move per row}
    WordsPerRow := Succ(XHigh-XLow);

    {Restore current contents to the screen buffer}
    DestPos := 0;
    SrcPos := (Pred(YLow)*CurrentWidth+Pred(XLow)) shl 1;
    for Row := YLow to YHigh do begin
      MoveScreen(CoversP^[DestPos], Mem[VideoSegment:SrcPos], WordsPerRow);
      Inc(SrcPos, CurrentWidth shl 1);
      Inc(DestPos, WordsPerRow shl 1);
    end;

    {deallocate buffer space if requested}
    if Deallocate then begin
      FreeMem(CoversP, (WordsPerRow*Succ(YHigh-YLow)) shl 1);
      CoversP := nil;
    end;
  end;

  procedure SetFrameChars(Vertical, Horizontal, LowerRight, UpperRight,
                          LowerLeft, UpperLeft : Char);
    {-Sets the frame characters to be used on subsequent FrameWindow calls.}
  begin
    FrameChars[ULeft] := UpperLeft;
    FrameChars[LLeft] := LowerLeft;
    FrameChars[URight] := UpperRight;
    FrameChars[LRight] := LowerRight;
    FrameChars[Horiz] := Horizontal;
    FrameChars[Vert] := Vertical;
  end;

  procedure FrameWindow(LeftCol, TopRow, RightCol, BotRow, FAttr, HAttr : Byte;
                        Header : String);
    {-Draws a frame around a window}
  var
    HeaderLen : Byte absolute Header;
    Row, Width, HeaderPos : Byte;
    Span : String[80];
    SpanLen : Byte absolute Span;
  begin
    {calculate width of window and position of header}
    SpanLen := Succ(RightCol-LeftCol);
    Width := SpanLen-2;

    {construct the upper border and draw it}
    FillChar(Span[2], Width, FrameChars[Horiz]);
    Span[1] := FrameChars[ULeft];
    Span[SpanLen] := FrameChars[URight];
    FastWrite(Span, TopRow, LeftCol, FAttr);

    {draw the vertical bars}
    for Row := Succ(TopRow) to Pred(BotRow) do begin
      FastWrite(FrameChars[Vert], Row, LeftCol, FAttr);
      FastWrite(FrameChars[Vert], Row, RightCol, FAttr);
    end;

    {draw the bottom border}
    Span[1] := FrameChars[LLeft];
    Span[SpanLen] := FrameChars[LRight];
    FastWrite(Span, BotRow, LeftCol, FAttr);

    if HeaderLen > 0 then begin
      if HeaderLen > Width then
        HeaderLen := Width;
      HeaderPos := (SpanLen-HeaderLen) shr 1;
      FastWrite(Header, TopRow, LeftCol+HeaderPos, HAttr);
    end;
  end;

  function MapColor(c : Byte) : Byte;
    {-Map a video attribute for visibility on mono/bw displays}
  const
    MonoTable : array[0..15] of Byte =
    (0, 1, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 15, 15);
  var
    Fore, Back : Byte;
  begin
    if MapColors then begin
      Fore := c and $F;
      Back := c shr 4;
      case CurrentMode of
        0, 2, 7 :
          {B&W modes}
          begin
            Fore := MonoTable[Fore];
            Back := MonoTable[Back];
          end;
      end;
      if CurrentMode = 7 then begin
        {Monochrome mode}
        Back := Back and $07;
        if (Fore or Back) <> 0 then
          {Not black on black}
          if (Fore = 0) or (Back = $07) then begin
            {Force to reverse video}
            Fore := 0;
            Back := $7;
          end
          else
            if Back <> 0 then
              {Force to black background}
              Back := 0;
        if (c and $80) <> 0 then
          {Set blink}
          Back := Back or $10;
      end;
      MapColor := (Back shl 4) or Fore;
    end
    else
      MapColor := c;
  end;

  procedure StoreWindowCoordinates(var WC : WindowCoordinates);
    {-Store the window coordinates for the active window}
  type
    XY = record
           X, Y : Byte;
         end;
  begin
    with WC do begin
      XL := Succ(XY(WindMin).X);
      YL := Succ(XY(WindMin).Y);
      XH := Succ(XY(WindMax).X);
      YH := Succ(XY(WindMax).Y);
    end;
  end;

  procedure RestoreWindowCoordinates(WC : WindowCoordinates);
    {-Restore previously saved window coordinates}
  begin
    with WC do
      Window(XL, YL, XH, YH);
  end;

  {local routines in TPCRT.OBJ}
  procedure ReadCursorPrim; external;
  procedure SetCursorPrim;  external;
  procedure GetCursorPrim;  external;
  procedure GetCrtModePrim; external;
  procedure ScrollUpPrim;   external;
  procedure ScrollDownPrim; external;
  procedure AdapterCheck;   external;
  procedure DelayMS;        external;
  procedure GetCharAttr;    external;
  procedure SetWindowPrim;  external;
  procedure FullWindow;     external;
  procedure GetAttribute;   external;
  procedure InitCrt;        external;

begin
  {initialize global variables}
  CheckBreak := True;
  CheckEOF := False;
  DirectVideo := True;

  {for internal use}
  IsCompaq := (CompaqBiosName = 'COMPAQ');
  if (ZenithBiosName = 'Zenith') then
    IsZenith := True;

  {initialize internal variables}
  InitCrt;

  {reopen Input}
  AssignCrt(Input);
  Reset(Input);

  {reopen Output}
  AssignCrt(Output);
  Rewrite(Output);

  {correct some BIOS bugs involving cursor scan lines}
  case BiosScanLines of
    $0607 :
      if CurrentMode = 7 then
        {mono adapter, but CGA scan lines -- happens on most mono systems}
        BiosScanLines := $0B0C;
    $0067 :
      {incorrect scan lines bug -- most often seen on Compaqs}
      BiosScanLines := $0607;
  end;
end.
