{
Copyright (C) 1998-99 Free Software Foundation, Inc.

Author: Frank Heckenbach <frank@pascal.gnu.de>

CRT (Crt Replacement Tool) -- BP compatible CRT unit

This unit needs the ncurses library which should be available for
almost any system. For Dos systems, where ncurses is not availale,
AFAIK, it is configured to use PDCurses 2.3 instead (file curse23.zip).
On Unix systems with X11, it can also use PDCurses to produce pure X11
programs. The advantage is that they don't need an xterm with a valid
terminfo entry, but the disadvantage is that they will only run under X.

NOTES:

- When an X11 version under Unix is wanted, give `-DXCURSES' when compiling
  crt.pas and crtc.c (or when compiling crt.pas with automake). On X11R6,
  give -DX11R6 additionally, but it might also work without that. You might
  also have to give the path to the X11 libraries, e.g. `-L /usr/X11/lib'.

- Sound, NoSound, most of TextMode (except changing between color and
  monochrome mode which always works), GetShiftState and the interrupt
  signal (Ctrl-C) handling cannot be done in a portable way, and have to
  be implemented for different systems individually. Currently, there is
  a version for Linux on an x86 processor (crtlinux386.h), one for generic
  Unix systems (crtunix.h), one for Dos using PDCurses (crtdospc.h) and a
  dummy file (crtdummy.h) that will be used when no appropriate system
  specific file is present. Please see the notes in those files for details.

- All the other things (including most details) should be compatible to
  BP's CRT unit now.

- When trying to write portable programs, don't rely on exactly the same
  look of your output and the availability of all the key combinations.
  Some kinds of terminals support only some of the display attributes
  and characters, and only with PDCurses, all the key codes listed below
  are really available. Therefore, it's safer to provide the same function
  on different key combinations and to not use the more exotic ones.


This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Library General Public License as published by
the Free Software Foundation, version 2.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public
License for more details.

You should have received a copy of the GNU Library General Public License
along with this library; see the file COPYING.LIB.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
MA 02111-1307, USA.
}

{$if __GPC_RELEASE__ < 19981206}
{$error This unit requires GPC release 19981206 or newer}
{$endif}

unit CRT;

interface

uses GPC;

const

{ CRT modes }

  BW40          = 0;            { 40x25 B/W on Color Adapter }
  CO40          = 1;            { 40x25 Color on Color Adapter }
  BW80          = 2;            { 80x25 B/W on Color Adapter }
  CO80          = 3;            { 80x25 Color on Color Adapter }
  Mono          = 7;            { 80x25 on Monochrome Adapter }
  Font8x8       = 256;          { Add-in for 80x43 or 80x50 mode }

{ Mode constants for Turbo Pascal 3.0 compatibility }

  C40           = CO40;
  C80           = CO80;

{ Foreground and background color constants }

  Black         = 0;
  Blue          = 1;
  Green         = 2;
  Cyan          = 3;
  Red           = 4;
  Magenta       = 5;
  Brown         = 6;
  LightGray     = 7;

{ Foreground color constants }

  DarkGray      = 8;
  LightBlue     = 9;
  LightGreen    = 10;
  LightCyan     = 11;
  LightRed      = 12;
  LightMagenta  = 13;
  Yellow        = 14;
  White         = 15;

{ Add-in for blinking }

  Blink         = 128;

type
  TTextAttr = Byte;

var

{ Interface variables }

  CheckBreak: Boolean;    { If False, catch interrupt signal (SIGINT; Ctrl-C), and other flow control characters as well as SIGTERM }
  CheckEOF: Boolean;      { If True, replace Ctrl-Z by #0 in input }
  DirectVideo: Boolean;   { Ignored -- meaningless in this context }
  CheckSnow: Boolean;     { Ignored -- curses should take care of that }
  LastMode: Word;         { Current text mode }
  TextAttr: TTextAttr;    { Current text attribute }
  WindMin: Word;          { Window upper left coordinates }
  WindMax: Word;          { Window lower right coordinates }

{ Interface procedures }

procedure AssignCRT(var F: Text);
function KeyPressed: Boolean;            asmname 'crt_keypressed';
function ReadKey: Char;                  asmname 'crt_readkey';
procedure TextMode(Mode: Integer);
procedure Window(X1,Y1,X2,Y2: Integer);
procedure GotoXY(X,Y: Integer);          asmname 'crt_gotoxy';
function WhereX: Integer;                asmname 'crt_wherex';
function WhereY: Integer;                asmname 'crt_wherey';
procedure ClrScr;                        asmname 'crt_clrscr';
procedure ClrEol;                        asmname 'crt_clreol';
procedure InsLine;                       asmname 'crt_insline';
procedure DelLine;                       asmname 'crt_delline';
procedure TextColor(Color: TTextAttr);
procedure TextBackground(Color: TTextAttr);
procedure LowVideo;
procedure HighVideo;
procedure NormVideo;
procedure Delay(MS: Word);               asmname 'crt_delay';
procedure Sound(Hz: Word);               asmname 'crt_sound';   { Not implemented on all platforms }
procedure NoSound;                       asmname 'crt_nosound'; { Not implemented on all platforms }

{ ======================== Extensions over BP's CRT ======================== }

{ These routines must be called before and after a child process is
  executed which accesses the terminal. The Dos unit's Exec procedure
  takes care of this automatically, if used together with this unit. }
procedure CRTInitExec; asmname 'crt_init_exec';
procedure CRTDoneExec; asmname 'crt_done_exec';

{ Keyboard and character graphics constants -- BP compatible! =:-) }
{$i crt.inc}

var
  PCCharSet       : Boolean = True;  { If True, interpret non-ASCII characters as PC ROM, not system dependent, characters }
  UseControlChars : Boolean = True;  { If True, interpret #7, #8, #10, #13 as control, not graphics, characters }
  VisualBell      : Boolean = False; { If True, Beep does a Flash instead }

type
  TKey = Word;
  TCursorShape = (CursorHidden, CursorNormal, CursorFat, CursorBlock);
  TPoint = record
    X, Y : Integer
  end;

  TWindowXY = record
    {$ifdef __BYTES_BIG_ENDIAN__} Y, X {$else} X, Y {$endif} : Byte
  end;

  PCharAttr = ^TCharAttr;
  TCharAttr = record
    Ch   : Char;
    Attr : TTextAttr
  end;

  PCharAttrs = ^TCharAttrs;
  TCharAttrs = array [1 .. MaxInt] of TCharAttr;

var
  WindowMin : TWindowXY absolute WindMin;
  WindowMax : TWindowXY absolute WindMax;

  ScreenSize : TPoint; { Contains the size of the screen }

  IsMonoMode : Boolean; { Tells whether the current mode is monochrome }

  { This value can be set to a combination of the shFoo constants and will
    be ORed to the actual shift state in GetShiftState. This can be used to
    easily simulate shift keys on systems where they can't be accessed. }
  ShiftState : Integer = 0;

{ Tell which modifier keys are currently pressed. The result is a
  combination of the shFoo constants defined in crt.inc, or 0 on
  systems where this function is not supported. If supported, kbIns
  and kbDel keys are automatically converted to kbShIns and kbShDel,
  resp., if shift is pressed. }
function  GetShiftState : Integer; asmname 'crt_getshiftstate';

{ Determines when the screen is updated on some systems (currently, on
  ncurses, not PDCurses). Possible values:
  0: Update before Delay and input statements, unless typeahead is detected.
  1: Update before Delay and input statements.
  2: Update it as soon as possible without causing too much refresh.
     This uses a timer on some systems (currently, Unix with ncurses).
     This is the default for BP compatibility, but for many applications,
     a lower value causes less flickering output, and additionally, timer
     signals won't disturb other operations.
  3: Always update immediately. This can be very slow. }
procedure SetCRTUpdate (Update : Integer); asmname 'crt_setupdatelevel';

{ Returns Ord (key) for normal keys and $100 * Ord (fkey) for function keys }
function  ReadKeyWord : TKey; asmname 'crt_readkeyword';

{ Extract the character and scan code from a TKey value }
function  Key2Char (k : TKey) : Char;
function  Key2Scan (k : TKey) : Char;

{ Convert a key to upper/lower case if it is a letter, leave it unchanged
  otherwise }
function  UpCaseKey (k : TKey) : TKey;
function  LoCaseKey (k : TKey) : TKey;

{ Produce a beep or a screen flash }
procedure Beep;  asmname 'crt_beep';
procedure Flash; asmname 'crt_flash';

{ Get size of current window (calculated from WindMin and WindMax) }
function  GetXMax : Integer;
function  GetYMax : Integer;

{ Get/goto an absolute position }
function  WhereXAbs : Integer;
function  WhereYAbs : Integer;
procedure GotoXYAbs (X, Y : Integer);

procedure SetCursorShape (Shape : TCursorShape); asmname 'crt_setcursorshape';
function  GetCursorShape : TCursorShape;         asmname 'crt_getcursorshape';

procedure HideCursor;
procedure HiddenCursor;
procedure NormalCursor;
procedure FatCursor;
procedure BlockCursor;

function  GetTextColor : Integer;
function  GetBackColor : Integer;

{ Write string at the given position without moving the cursor. Truncated
  at right margin. }
procedure WriteStrAt (x, y : Integer; s : String; Attr : TTextAttr);

{ Write (several copies of) a char at then given position without moving
  the cursor. Truncated at right margin. }
procedure WriteCharAt (x, y, Count : Integer; Ch : Char; Attr : TTextAttr);

{ Write characters with specified attributes at the given position without
  moving the cursor. Truncated at right margin. }
procedure WriteCharAttrAt (x, y, Count : Integer; CharAttr : PCharAttrs); asmname 'crt_writecharattrat';

{ Write a char while moving the cursor }
procedure WriteChar (Ch : Char);

{ Read a character from a screen posistion }
procedure ReadChar (x, y : Integer; var Ch : Char; var Attr : TTextAttr); asmname 'crt_readchar';

{ Change only text attribute, leave character. Truncated at right margin. }
procedure ChangeTextAttr (x, y, Count : Integer; NewAttr : TTextAttr);

{ Fill current window }
procedure FillWin (Ch : Char; Attr : TTextAttr); asmname 'crt_fillwin';

{ Calculate size of memory required for ReadWin in current window. }
function  WinSize : SizeType; asmname 'crt_winsize';

{ Save window contents. Buf must be WinSize bytes large. }
procedure ReadWin (var Buf); asmname 'crt_readwin';

{ Restore window contents saved by ReadWin. The size of the current window
  must match the size of the window from which ReadWin was used, but the
  position may be different. }
procedure WriteWin (const Buf); asmname 'crt_writewin';

type
  WinState = record
    case Boolean of
      False : (WindMin, WindMax : Word;
               WhereX, WhereY : Integer;
               TextAttr : TTextAttr;
               CursorShape : TCursorShape;
               NewWindMin, NewWindMax : Word;
               TextMode : Integer;
               Buffer : ^Byte);
      True  : (WindowMin, WindowMax : TWindowXY)
  end;

{ Save window position and size, cursor position, text attribute and cursor
  shape -- NOT the window contents. }
procedure SaveWin (var State : WinState);

{ Make a new window (like Window), and save the contents of the screen
  below the window as well as the position and size, cursor position,
  text attribute and cursor shape of the old window. }
procedure MakeWin (var State : WinState; x1, y1, x2, y2 : Integer);

{ Create window in full size, save previous text mode and all values
  that MakeWin does. }
procedure SaveScreen (var State : WinState);

{ Restore the data saved by SaveWin, MakeWin or SaveScreen. }
procedure RestoreWin (var State : WinState);

{ TPCRT compatibility }
{ Write a string at the given position without moving the cursor. Truncated
  at right margin. }
procedure WriteString (const s : String; y, x : Integer);

{ Write a string at the given position with the given attribute without
  moving the cursor. Truncated at right margin. }
procedure FastWriteWindow (const s : String; y, x : Integer; Attr : TTextAttr);

{ Write a string at the given absolute position with the given attribute
  without moving the cursor. Truncated at right margin. }
procedure FastWrite       (const s : String; y, x : Integer; Attr : TTextAttr);

{ WinCrt compatibility }
procedure InitWinCrt; { Does nothing here }
procedure DoneWinCrt; { Halts the program }
procedure WriteBuf (Buffer : PChar; Count : SizeType);
function  ReadBuf (Buffer : PChar; Count : SizeType) : SizeType;
procedure CursorTo (x, y : Integer);

implementation

{$I-,B-}

{$ifdef XCURSES} {$L XCurses, Xaw, Xmu, Xt, X11} {$ifdef X11R6} {$L SM, ICE, Xext} {$endif}
{$elif defined(USE_PDCURSES)} {$L curso}
{$else} {$L ncurses} {$endif}

{$L crtc.c}
procedure CRT_Init; C;
procedure CRT_Done; C;
procedure CRT_Init_TextMode; C;
procedure CRT_Delete_W; C;
procedure CRT_SetTextMode (Columns40, Lines50: Boolean); C;
procedure CRT_Scroll (State : Boolean); C;
procedure CRT_UnGetCh (k : TKey); C;
function  CRT_Read  (var PrivateData; var   Buffer; Size : SizeType) : SizeType; C;
function  CRT_Write (var PrivateData; const Buffer; Size : SizeType) : SizeType; C;

const
  MonoModes = [BW40, BW80, Mono];

var
  ColorFlag : asmname 'crt_ColorFlag' Boolean;
  NormAttr  : asmname 'crt_NormAttr'  TTextAttr;
  HasColors : asmname 'crt_HasColors' Boolean;

procedure TextColor (Color: TTextAttr);
begin
  if Color and $F0<>0 then Color := (Color and $F) or Blink;
  TextAttr := (TextAttr and $70) or Color
end;

procedure TextBackground(Color: TTextAttr);
begin
  TextAttr := (TextAttr and $8F) or ((Color and 7) shl 4)
end;

function  GetTextColor : Integer;
begin
  GetTextColor := TextAttr and $8F
end;

function  GetBackColor : Integer;
begin
  GetBackColor := (TextAttr and $70) shr 4
end;

procedure LowVideo;
begin
  TextAttr := TextAttr and not 8
end;

procedure HighVideo;
begin
  TextAttr := TextAttr or 8
end;

procedure NormVideo;
begin
  TextAttr := NormAttr
end;

procedure TextMode(Mode: Integer);
begin
  ColorFlag := HasColors and not ((Mode and $ff) in MonoModes);
  CRT_Delete_W;
  CRT_SetTextMode ((Mode and $ff) in [BW40, CO40], Mode and Font8x8 <> 0);
  CRT_Init_TextMode;
  IsMonoMode := (LastMode and $ff) in MonoModes;
  ClrScr
end;

procedure Window(X1,Y1,X2,Y2: Integer);
begin
  if (X1 >= 1) and (X1 <= X2) and (X2 <= ScreenSize.X) and
     (Y1 >= 1) and (Y1 <= Y2) and (Y2 <= ScreenSize.Y) then
    begin
      WindowMin.X := X1 - 1;
      WindowMin.Y := Y1 - 1;
      WindowMax.X := X2 - 1;
      WindowMax.Y := Y2 - 1;
      GotoXY (1, 1)
    end
end;

procedure AssignCRT(var F: Text);
begin
  AssignTFDD (F, TOpenProc (nil), CRT_Read, CRT_Write, TFlushProc (nil), TCloseProc (nil), TDoneProc (nil), nil)
end;

procedure WriteStrAt (x, y : Integer; s : String; Attr : TTextAttr);
var OrigAttr : TTextAttr;
begin
  OrigAttr := TextAttr;
  TextAttr := Attr;
  WriteString (s, y, x);
  TextAttr := OrigAttr
end;

procedure WriteCharAt (x, y, Count : Integer; Ch : Char; Attr : TTextAttr);
var
  OrigAttr : TTextAttr;
  Temp : array [1 .. Count] of Char;
  i : Integer;
begin
  for i := 1 to Count do Temp [i] := Ch;
  OrigAttr := TextAttr;
  TextAttr := Attr;
  WriteString (Temp, y, x);
  TextAttr := OrigAttr
end;

procedure WriteChar (Ch : Char);
var Dummy : Integer;
begin
  Dummy := CRT_Write (Dummy, Ch, 1)
end;

procedure WriteString (const s : String; y, x : Integer);
var
  OrigX, OrigY, Dummy, Size : Integer;
  UseControlCharsSave : Boolean;
begin
  OrigX := WhereX;
  OrigY := WhereY;
  GotoXY (x, y);
  UseControlCharsSave := UseControlChars;
  UseControlChars := False;
  CRT_Scroll (False);
  Size := Min (Length (s), GetXMax - x + 1);
  if Size > 0 then Dummy := CRT_Write (Dummy, s [1], Size);
  CRT_Scroll (True);
  UseControlChars := UseControlCharsSave;
  GotoXY (OrigX, OrigY)
end;

procedure FastWriteWindow (const s : String; y, x : Integer; Attr : TTextAttr);
begin
  WriteStrAt (x, y, s, Attr)
end;

procedure FastWrite (const s : String; y, x : Integer; Attr : TTextAttr);
begin
  WriteStrAt (x - WindowMin.X, y - WindowMin.Y, s, Attr)
end;

procedure ChangeTextAttr (x, y, Count : Integer; NewAttr : TTextAttr);
var
  OrigX, OrigY, i : Integer;
  Ch : Char;
  OrigAttr, Attr : TTextAttr;
begin
  OrigAttr := TextAttr;
  OrigX := WhereX;
  OrigY := WhereY;
  GotoXY (x, y);
  CRT_Scroll (False);
  for i := 1 to Min (Count, GetXMax - WhereX + 1) do
    begin
      ReadChar (WhereX, WhereY, Ch, Attr);
      TextAttr := NewAttr;
      WriteChar (Ch)
    end;
  CRT_Scroll (True);
  GotoXY (OrigX, OrigY);
  TextAttr := OrigAttr
end;

function Key2Char (k : TKey) : Char;
begin
  if k div $100 <> 0
    then Key2Char := #0
    else Key2Char := Chr (k)
end;

function Key2Scan (k : TKey) : Char;
begin
  Key2Scan := Chr (k div $100)
end;

function UpCaseKey (k : TKey) : TKey;
var ch : Char;
begin
  ch := Key2Char (k);
  if ch = #0
    then UpCaseKey := k
    else UpCaseKey := Ord (UpCase (ch))
end;

function LoCaseKey (k : TKey) : TKey;
var ch : Char;
begin
  ch := Key2Char (k);
  if ch = #0
    then LoCaseKey := k
    else LoCaseKey := Ord (LoCase (ch))
end;

function GetXMax : Integer;
begin
  GetXMax := WindowMax.X - WindowMin.X + 1
end;

function GetYMax : Integer;
begin
  GetYMax := WindowMax.Y - WindowMin.Y + 1
end;

function WhereXAbs : Integer;
begin
  WhereXAbs := WhereX + WindowMin.X
end;

function WhereYAbs : Integer;
begin
  WhereYAbs := WhereY + WindowMin.Y
end;

procedure GotoXYAbs (X, Y : Integer);
begin
  GotoXY (X - WindowMin.X, Y - WindowMin.Y)
end;

procedure HideCursor;
begin
  SetCursorShape (CursorHidden)
end;

procedure HiddenCursor;
begin
  SetCursorShape (CursorHidden)
end;

procedure NormalCursor;
begin
  SetCursorShape (CursorNormal)
end;

procedure FatCursor;
begin
  SetCursorShape (CursorFat)
end;

procedure BlockCursor;
begin
  SetCursorShape (CursorBlock)
end;

procedure SaveWin (var State : WinState);
begin
  State.WindMin     := WindMin;
  State.WindMax     := WindMax;
  State.NewWindMin  := WindMin;
  State.NewWindMax  := WindMax;
  State.WhereX      := WhereX;
  State.WhereY      := WhereY;
  State.TextAttr    := TextAttr;
  State.CursorShape := GetCursorShape;
  State.TextMode    := - 1;
  State.Buffer      := nil
end;

procedure MakeWin (var State : WinState; x1, y1, x2, y2 : Integer);
begin
  SaveWin (State);
  Window (x1, y1, x2, y2);
  State.NewWindMin := WindMin;
  State.NewWindMax := WindMax;
  GetMem (State.Buffer, WinSize);
  ReadWin (State.Buffer^)
end;

procedure SaveScreen (var State : WinState);
begin
  MakeWin (State, 1, 1, ScreenSize.X, ScreenSize.Y);
  State.TextMode := LastMode
end;

procedure RestoreWin (var State : WinState);
begin
  if State.TextMode <> - 1 then
    begin
      if State.TextMode <> LastMode then TextMode (State.TextMode);
      Window (1, 1, ScreenSize.X, ScreenSize.Y)
    end;
  if State.Buffer <> nil then
    begin
      WindMin := State.NewWindMin;
      WindMax := State.NewWindMax;
      WriteWin (State.Buffer^);
      FreeMem (State.Buffer);
      State.Buffer := nil
    end;
  WindMin := State.WindMin;
  WindMax := State.WindMax;
  GotoXY (State.WhereX, State.WhereY);
  TextAttr := State.TextAttr;
  SetCursorShape (State.CursorShape)
end;

procedure InitWinCrt;
begin
end;

procedure DoneWinCrt;
begin
  Halt
end;

procedure WriteBuf (Buffer : PChar; Count : SizeType);
var Dummy : Integer;
begin
  if Count > 0 then Dummy := CRT_Write (Dummy, Buffer^, Count)
end;

function  ReadBuf (Buffer : PChar; Count : SizeType) : SizeType;
var Dummy : Integer;
begin
  ReadBuf := CRT_Read (Dummy, Buffer^, Count)
end;

procedure CursorTo (x, y : Integer);
begin
  GotoXY (x + 1, y + 1)
end;

procedure Int_Handler (Signal : Integer); asmname 'crt_int_handler';
procedure Int_Handler (Signal : Integer);
begin
  if CheckBreak
    then
      begin
        Writeln ('^C');
        Halt (255)
      end
    else CRT_UnGetCh (kbInt)
end;

procedure Term_Handler (Signal : Integer); asmname 'crt_term_handler';
procedure Term_Handler (Signal : Integer);
begin
  if CheckBreak
    then Halt (255)
    else CRT_UnGetCh (kbTerm)
end;

to begin do
begin
  CheckBreak := True;
  CheckEOF := False;
  DirectVideo := True;
  CheckSnow := False;
  NormAttr := LightGray + $10 * Black;
  CRT_Init;
  IsMonoMode := (LastMode and $ff) in MonoModes;
  AssignCRT (Input);
  Reset (Input);
  AssignCRT (Output);
  Rewrite (Output);
  AssignCRT (StdErr);
  Rewrite (StdErr);
end;

to end do
  CRT_Done;

end.
