Power-Programmierung/CD1.mdf/pascal/turbo55/install/tcalc.arc/TCSCREEN.PAS

Pascal/Delphi Source File | 1989-05-02 | 15KB | 523 lines

{ Copyright (c) 1989 by Borland International, Inc. }

unit TCScreen;
{ Turbo Pascal 5.5 object-oriented example screen routines.
  This unit is used by TCALC.PAS.
  See TCALC.DOC for an more information about this example.
}

{$S-}

interface

uses Crt, Dos, TCUtil;

const
  ScreenCols = 80;
  ScreenRows = 50;
  MinScreenRows = 25;
  ESCPress = 'Press ESC.';    { Printed in error messages }

type
  Direction = (Up, Down, Left, Right);
  ScreenColRange = 1..ScreenCols;
  ScreenRowRange = 1..ScreenRows;
  VideoTypes = (MDA, CGA, MCGA, EGA, VGA);
  ScreenChar = record
    Data : Char;
    Attrib : Byte;
  end;
  ScreenArray = array[ScreenRowRange, ScreenColRange] of ScreenChar;
  ScreenRow = array[ScreenColRange] of ScreenChar;
  ScreenPointer = ^ScreenArray;
  ScreenPos = record
    Col : ScreenColRange;
    Row : ScreenRowRange;
  end;
  Screen = object
    CurrRows : ScreenRowRange;
    CurrCols : ScreenColRange;
    VideoType : VideoTypes;
    OldCursor : Word;
    InsCursor : Word;
    OldMode : Word;
    constructor Init;
    destructor Done;
    procedure ToggleMaxLinesMode;
    procedure PrintError(Error : String);
    procedure PrintMessage(Message : String);
    procedure ClearMessage;
    procedure PrintHelpLine(CommandString : String);
  end;
  ScreenArea = object
    UpperLeft, LowerRight : ScreenPos;
    Attrib : Byte;
    constructor Init(InitX1 : ScreenColRange; InitY1 : ScreenRowRange;
                     InitX2 : ScreenColRange; InitY2 : ScreenRowRange;
                     InitAttrib : Byte);
    procedure Scroll(Dir : Direction; Amt : Word);
    procedure Clear;
    procedure Erase;
  end;
  ColorTableType = (ColorMono, ColorBW, ColorColor);
  ColorTablePtr = ^ColorTable;
  ColorTable = object
    TableType : ColorTableType;
    BlankColor : Byte;
    ValueCellColor : Byte;
    TextCellColor : Byte;
    FormulaCellColor : Byte;
    RepeatCellColor : Byte;
    ColColor : Byte;
    RowColor : Byte;
    InfoColor : Byte;
    HighlightColor : Byte;
    BlockColor : Byte;
    InputColor : Byte;
    InputArrowColor : Byte;
    ErrorColor : Byte;
    CellErrorColor : Byte;
    MemoryColor : Byte;
    CellDataColor : Byte;
    PromptColor : Byte;
    FileNameColor : Byte;
    ChangedColor : Byte;
    TitleColor : Byte;
    ContentsColor : Byte;
    KeyNameColor : Byte;
    KeyDescColor : Byte;
    MenuHiColor : Byte;
    MenuLoColor : Byte;
    MessageColor : Byte;
    constructor Init;
    procedure FillColorTable;
  end;

const
  NoCursor = $2000;

var
  Colors : ColorTable;
  Scr : Screen;
  ScreenPtr : ScreenPointer;

procedure MoveToScreen(var Source, Dest; Len : Word);

procedure MoveFromScreen(var Source, Dest; Len : Word);

procedure ClrEOLXY(Col : ScreenColRange; Row : ScreenRowRange;
                   Color : Byte);

procedure WriteColor(S : String; Color : Byte);

procedure WriteXY(S : String; Col : ScreenColRange; Row : ScreenRowRange;
                      Color : Byte);

procedure WriteXYClr(S : String; Col : ScreenColRange; Row : ScreenRowRange;
                         Color : Byte);

procedure SetCursor(NewCursor : Word);

function GetCursor : Word;

implementation

const
  TotalColors = 26;
  WhiteOnRed = White + (Red shl 4);
  WhiteOnBlue = White + (Blue shl 4);
  WhiteOnCyan = White + (Cyan shl 4);
  BlackOnGray = LightGray shl 4;
  WhiteOnGray = White + (LightGray shl 4);
  BlinkingLightRed = LightRed + Blink;
  BlinkingWhite = White + Blink;
  LightCyanOnBlue = LightCyan + (Blue shl 4);
  YellowOnBlue = Yellow + (Blue shl 4);

type
  ColorArray = array[1..TotalColors] of Byte;

const
  ColorColors : ColorArray = (White, LightCyan, White, LightMagenta, White,
                              WhiteOnRed, WhiteOnRed, WhiteOnCyan,
                              WhiteOnBlue, WhiteOnCyan, White, LightCyan,
                              WhiteOnRed, BlinkingLightRed, LightRed,
                              LightGreen, Yellow, LightCyan, Yellow,
                              LightMagenta, Yellow, LightCyanOnBlue,
                              YellowOnBlue, LightCyan, White,
                              BlinkingLightRed);
  BWColors : ColorArray = (White, White, White, White, White, BlackOnGray,
                           BlackOnGray, WhiteOnGray, WhiteOnGray, BlackOnGray,
                           White, White, White, BlinkingWhite, White, White,
                           White, White, White, White, White, BlackOnGray,
                           White, White, LightGray, BlinkingWhite);
  MonoColors : ColorArray = (White, White, White, White, White, BlackOnGray,
                             BlackOnGray, BlackOnGray, BlackOnGray,
                             BlackOnGray, White, White, White, BlinkingWhite,
                             White, White, White, White, White, White, White,
                             BlackOnGray, White, White, LightGray,
                             BlinkingWhite);

const
  InsCursorSmall = $0007;
  InsCursorLarge = $000D;

var
  SavedExitProc : Pointer;

procedure ClearScreen(X1, Y1, X2, Y2, Attrib : Word);
{ Clears an area of the screen }
var
  Reg : Registers;
begin
  if (X1 > X2) or (Y1 > Y2) then   { Illegal values }
    Exit;
  with Reg do
  begin
    AX := $0600;              { Clear screen through the BIOS }
    BH := Attrib;
    CH := Pred(Y1);
    CL := Pred(X1);
    DH := Pred(Y2);
    DL := Pred(X2);
    Intr($10, Reg);
  end; { with }
end; { ClearScreen }

{$L TCMVSMEM}

procedure MoveToScreen(var Source, Dest; Len : Word); external;
{ Moves screen memory from normal RAM to screen memory - see TCMVSMEM.ASM
  for source }

procedure MoveFromScreen(var Source, Dest; Len : Word); external;
{ Moves screen memory to normal RAM from screen memory - see TCMVSMEM.ASM
  for source }

procedure MoveText(OldX1, OldY1, OldX2, OldY2, NewX1, NewY1 : Word);
{ Moves an area of text to a new position on the screen }
var
  Counter, Len : Word;
begin
  if (OldX2 < OldX1) or (OldY2 < OldY1) then
    Exit;
  Len := Succ(OldX2 - OldX1) shl 1;
  if NewY1 < OldY1 then
  begin                    { Move it row by row, going forwards }
    for Counter := 0 to OldY2 - OldY1 do
      MoveFromScreen(ScreenPtr^[OldY1 + Counter, OldX1],
                     ScreenPtr^[NewY1 + Counter, NewX1], Len)
  end
  else begin               { Move it row by row, going backwards }
    for Counter := OldY2 - OldY1 downto 0 do
      MoveFromScreen(ScreenPtr^[OldY1 + Counter, OldX1],
                     ScreenPtr^[NewY1 + Counter, NewX1], Len)
  end;
end; { MoveText }

procedure ScrollText(Dir : Direction; X1, Y1, X2, Y2, Amt, Attrib : Word);
{ Scrolls the screen by an amount in a direction - it does this by moving
  the text to be scrolled and then clearing the area that wasn't scrolled }
begin
  case Dir of
    Up : begin
      MoveText(X1, Y1 + Amt, X2, Y2, X1, Y1);
      ClearScreen(X1, Succ(Y2 - Amt), X2, Y2, Attrib);
    end;
    Down : begin
      MoveText(X1, Y1, X2, Y2 - Amt, X1, Succ(Y1));
      ClearScreen(X1, Y1, X2, Pred(Y1 + Amt), Attrib);
    end;
    Left : begin
      MoveText(X1 + Amt, Y1, X2, Y2, X1, Y1);
      ClearScreen(Succ(X2 - Amt), Y1, X2, Y2, Attrib);
    end;
    Right : begin
      MoveText(X1, Y1, X2 - Amt, Y2, X1 + Amt, Y1);
      ClearScreen(X1, Y1, Pred(X1 + Amt), Y2, Attrib);
    end;
  end; { case }
end; { ScrollText }

function EGAInstalled : Boolean;
{ Tests for the presence of an EGA }
var
  Reg : Registers;
begin
  Reg.AX := $1200;
  Reg.BX := $0010;
  Reg.CX := $FFFF;
  Intr($10, Reg);
  EGAInstalled := Reg.CX <> $FFFF;
end; { EGAInstalled }

function PS2 : Boolean;
{ This function returns True if we are running on a PS/2 type video adapter }
var
  Regs : Registers;
begin
  Regs.AX := $1A00;
  Intr($10, Regs);
  PS2 := ((Regs.AL and $FF) = $1A) and
         ((Regs.BL and $FF) in [$07, $08, $0B, $0C]);
end; { PS2 }

procedure ClrEOLXY(Col : ScreenColRange; Row : ScreenRowRange; Color : Byte);
{ Clears to the end-of-line in a color at a specified position }
begin
  GotoXY(Col, Row);
  TextAttr := Color;
  ClrEOL;
end; { ClrEOLXY }

procedure WriteColor(S : String; Color : Byte);
{ Writes a string in a color }
begin
  TextAttr := Color;
  Write(S);
end; { WriteColor }

procedure WriteXY(S : String; Col : ScreenColRange; Row : ScreenRowRange;
                  Color : Byte);
{ Writes a string in a color at a specified position }
begin
  GotoXY(Col, Row);
  WriteColor(S, Color);
end; { WriteXY }

procedure WriteXYClr(S : String; Col : ScreenColRange; Row : ScreenRowRange;
                     Color : Byte);
{ Clears to the end-of-line in a color at a specified position and then
  writes a string }
begin
  ClrEOLXY(Col, Row, Color);
  Write(S);
end; { WriteXYClr }

procedure SetCursor(NewCursor : Word);
{ Sets the value of the scan lines of the cursor }
var
  Reg : Registers;
begin
  with Reg do
  begin
    AH := 1;
    BH := 0;
    CX := NewCursor;
    Intr($10, Reg);
  end; { with }
end; { SetCursor }

function GetCursor : Word;
{ Returns the value of the scan lines of the cursor }
var
  Reg : Registers;
begin
  with Reg do
  begin
    AH := 3;
    BH := 0;
    Intr($10, Reg);
    GetCursor := CX;
  end; { Reg }
end; { GetCursor }

constructor Screen.Init;
{ Finds what type of video adapter is being run on, and initializes various
  variables based on this information }
var
  Reg : Registers;
begin
  OldMode := LastMode;
  Reg.AH := $0F;
  Intr($10, Reg);                    { Check for the current video mode }
  if Reg.AL <> 7 then
  begin
    if EGAInstalled then
    begin
      if PS2 then
        VideoType := VGA
      else
        VideoType := EGA;
    end
    else begin
      if PS2 then
        VideoType := MCGA
      else
        VideoType := CGA;
    end;
    ScreenPtr := Ptr($B800, 0);
    if Reg.AL < 2 then
      CurrCols := 40
    else
      CurrCols := 80;
  end
  else begin
    VideoType := MDA;
    ScreenPtr := Ptr($B000, 0);
    CurrCols := 80;
  end;
  CurrRows := Succ(Hi(WindMax));
  OldCursor := GetCursor;
  if (CurrRows = MinScreenRows) and (VideoType <> CGA) then
    InsCursor := InsCursorLarge
  else
    InsCursor := InsCursorSmall;
end; { Screen.Init }

destructor Screen.Done;
{ Restores the screen mode and cursor that existed at the start of the
  program }
begin
  TextMode(OldMode);
  SetCursor(OldCursor);
  ExitProc := SavedExitProc;
end; { Screen.Done }

procedure Screen.ToggleMaxLinesMode;
{ Toggles the display in and out of 43/50-line mode }
begin
  if CurrRows = MinScreenRows then
  begin
    TextMode(Lo(LastMode) + Font8x8);
    InsCursor := InsCursorSmall;
  end
  else begin
    TextMode(Lo(LastMode));
    InsCursor := InsCursorLarge;
  end;
  CurrRows := Succ(Hi(WindMax));
end; { Screen.ToggleMaxLinesMode }

procedure Screen.PrintError(Error : String);
{ Prints an error message at the bottom of the screen }
var
  Ch : Word;
  Buffer : ScreenRow;
begin
  MoveFromScreen(ScreenPtr^[CurrRows, 1], Buffer,
                 SizeOf(ScreenChar) * CurrCols);  { Save bottom line }
  WriteXYClr(CenterStr(Error + '. ' + ESCPress, Pred(CurrCols)), 1, CurrRows,
             Colors.ErrorColor);
  Beep;
  repeat
    Ch := GetKey;
  until Ch = ESC;
  MoveToScreen(Buffer, ScreenPtr^[CurrRows, 1],  { Restore bottom line }
               SizeOf(ScreenChar) * CurrCols);
end; { Screen.PrintError }

procedure Screen.PrintMessage(Message : String);
{ Prints a message }
begin
  WriteXYClr(Message + '...', 1, Pred(CurrRows), Colors.MessageColor);
end; { Screen.PrintMessage }

procedure Screen.ClearMessage;
{ Clears the last printed message }
begin
  ClrEOLXY(1, Pred(CurrRows), Colors.MessageColor);
end; { Screen.ClearMessage }

procedure Screen.PrintHelpLine(CommandString : String);
{ Prints a help line at the bottom of the screen. The command string is
  made up of a series of keys and descriptions separated by backslashes.
  Example: 'F1\Help\F2\Save\F3\Load\Alt-X\Exit'}
var
  P : Integer;
  S : String[ScreenCols];
begin
  CommandString := CommandString + '\';
  ClrEOLXY(1, CurrRows, Colors.KeyDescColor);
  while CommandString <> '' do
  begin
    Write(' ');
    P := Pos('\', CommandString);
    WriteColor(Copy(CommandString, 1, Pred(P)), Colors.KeyNameColor);
    Delete(CommandString, 1, P);
    P := Pos('\', CommandString);
    if CommandString[1] = '\' then
      S := '-'
    else
      S := '-' + Copy(CommandString, 1, Pred(P));
    WriteColor(S, Colors.KeyDescColor);
    Delete(CommandString, 1, P);
  end;
end; { Screen.PrintHelpLine }

constructor ScreenArea.Init(InitX1 : ScreenColRange; InitY1 : ScreenRowRange;
                            InitX2 : ScreenColRange; InitY2 : ScreenRowRange;
                            InitAttrib : Byte);
{ Sets up a screen area }
begin
  UpperLeft.Col := InitX1;
  UpperLeft.Row := InitY1;
  LowerRight.Col := InitX2;
  LowerRight.Row := InitY2;
  Attrib := InitAttrib;
end; { ScreenArea.Init }

procedure ScreenArea.Scroll(Dir : Direction; Amt : Word);
{ Scrolls a screen area an certain amount in a direction }
begin
  ScrollText(Dir, UpperLeft.Col, UpperLeft.Row, LowerRight.Col,
             LowerRight.Row, Amt, Attrib);
end; { ScreenArea.Scroll }

procedure ScreenArea.Clear;
{ Clears a screen area }
begin
  ClearScreen(UpperLeft.Col, UpperLeft.Row, LowerRight.Col, LowerRight.Row,
              Attrib);
end; { ScreenArea.Clear }

procedure ScreenArea.Erase;
{ Erases a screen area by writing over it in black }
begin
  ClearScreen(UpperLeft.Col, UpperLeft.Row, LowerRight.Col, LowerRight.Row,
              Black);
end; { ScreenArea.Erase }

constructor ColorTable.Init;
{ Initializes the color table by finding the video mode that is being used }
begin
  case Lo(LastMode) of
    BW40, BW80 : TableType := ColorBW;
    CO40, CO80 : TableType := ColorColor;
    Mono : TableType := ColorMono;
  end; { case }
  FillColorTable;
end; { ColorTable.Init }

procedure ColorTable.FillColorTable;
{ Moves the correct built-in color table to the program's color table }
var
  P : Pointer;
begin
  case TableType of
    ColorColor : P := @ColorColors;
    ColorBW : P := @BWColors;
    ColorMono : P := @MonoColors;
  end; { case }
  Move(P^, BlankColor, TotalColors);
end; { ColorTable.FillColorTable }

{$F+}

procedure ScreenExit;
{ Clears the screen at exit }
begin
  Scr.Done;
end; { ScreenExit }

{$F-}

begin
  SavedExitProc := ExitProc;
  ExitProc := @ScreenExit;
  TextMode(LastMode);
  Scr.Init;
  Colors.Init;
end.