TPU Screen

{***************************************************************************}
{*                                                                         *}
{*   Модуль поддержки работы с окнами (расширенный CRT) версия 4           *}
{*   Для большой программы                                                 *}
{*   Написано Я.Н.Стерховым.    Язык Турбо-Паскаль 5.0/7.0                 *}
{*                                                                         *}
{***************************************************************************}
{$F+,O+,N+,E+,D+}
UNIT Screen;
INTERFACE
USES CRT,DOS;

TYPE
  {Структура символа с атрибутом}
  ChAttr = RECORD
             ASCII :Char;
             Attr  :Byte;
  END;

  {Массив цветных символов - максимальный размер: весь экран }
  Image = RECORD
           Chars       :PACKED ARRAY[1..80,1..25] OF ChAttr;
           Heigh,Width :Byte;
          END;
  PImage = ^Image;

  {Прямоугольник}
  Rect = RECORD
          left,top,right,bottom :Byte;
  END;
  {Окно}
  TWindow = RECORD
             Title    : String[78];
             WinRect  : Rect;
             OutPut   : Rect;
             FrameAttr,
             TextAttr : Byte;
             Visible  : Boolean;
             Back     : PImage;
  END;
  PWindow = ^TWindow;

CONST
  {Прямоугольник экрана}
  ScreenRect:Rect = (left:1; top:1; right:80 ;bottom:25);
  {Флаг глобальных координат (т.е. сущестует ли
                           в данный момент контекст окна)}
  GlobalOut :Boolean = TRUE;

VAR
  CurWindow    :PWindow; {Указатель на тек.окно}
  CursorOn     :Boolean; {Флаг зажженого курсора}
  ScreenWindow :PWindow; {Окно для экрана по умолчанию (см. инициализацию)}

{ВЫВОД}
{Вызов процедуры Window для параметра-прямоугольника}
PROCEDURE WindowRect(r:Rect);
{Пишет строку, учитывая систему координат и цвет}
PROCEDURE WriteString(X,Y:Byte; Str:String; Attr:Byte);
{Пишет строку, центрируя и обрезая/перенося ее }
PROCEDURE CenterString(row:Byte; Str:String; Split:Boolean; Attr:Byte);
{Пишет строку вертикально}
PROCEDURE WriteColumn(col,row:Byte; Str:String; Attr:Byte);
{Заполняет прямоугольник ук. символом и цветом}
PROCEDURE FillRect(r:Rect; Ch:Char; Attr:Byte);

{Считывает прямоугольник с экрана}
PROCEDURE ReadImage(var r:Rect; var Im:PImage);
{Пишет прямоугольник на экран}
PROCEDURE WriteImage(x,y:Byte; Im:PImage);

{Включить/выключить курсор}
PROCEDURE ShowCursor;
PROCEDURE HideCursor;
{Включить/выключить оконные координаты}
PROCEDURE GlobalON;
PROCEDURE GlobalOFF;

{ДОПОЛНИТЕЛЬНЫЕ ПРОЦЕДУРЫ}
{Пишет символ с, начиная с (x,y) Count раз}
PROCEDURE WriteChar(x,y:Byte; c:Char; Count:Word; Attr:Byte);
{читает символ с экрана}
PROCEDURE ReadChar(x,y:Byte; var C:ChAttr);
{генерирует байт атрибута}
FUNCTION  Attrib(TextCol,BackCol:Byte):Byte;
{Присваивает Rect'у некое значение}
PROCEDURE AssignRect(var R:Rect; x1,y1,x2,y2:Byte);
{Создает структуру окна}
PROCEDURE CreateWindow(var W:PWindow; Title:String; Win,Out:Rect;
                                                fa,ta:Byte; Vis:Boolean);
{ОКНА}
{Делает окно видимым}
PROCEDURE ShowWindow(var W:PWindow);
{Делает окно невидимым}
PROCEDURE HideWindow(var W:PWindow);
{Ликвидирует окно }
PROCEDURE DisposeWindow(var W:PWindow);


IMPLEMENTATION

{Вызов процедуры Window для параметра-прямоугольника}
PROCEDURE WindowRect(r:Rect);
BEGIN
  Window(r.Left,r.Top,r.Right,r.Bottom);
END;

{Пишет строку, учитывая систему координат и цвет}
PROCEDURE WriteString(X,Y:Byte; Str:String; Attr:Byte);
BEGIN
  IF GlobalOut THEN WindowRect(ScreenRect)
    ELSE WindowRect(CurWindow^.OutPut);
  TextAttr :=Attr;
  GotoXY(x,y);
  Write(Str);
END;

PROCEDURE CenterString(row:Byte; Str:String; Split:Boolean; Attr:Byte);
VAR
  RowWid,Beg,Len:Byte;
  Str2 :String;
BEGIN
  IF Length(Str)=0 THEN Exit;
  IF GlobalOut THEN WindowRect(ScreenRect)
    ELSE WindowRect(CurWindow^.OutPut);

  TextAttr := Attr;
  RowWid := Lo(WindMax)-Lo(WindMin)+1;
  IF Length(Str) > RowWid THEN BEGIN
     Len := RowWid - 4;
     IF Split THEN BEGIN
        Str2 := Copy(Str,Len+1,Ord(Str[0])-Len);
        CenterString(row+1,Str2,Split,Attr);
     END;
     Str[0]:=Chr(Len);
  END;
  Beg := (RowWid - Length(Str)) div 2 + 1;
  GotoXY(Beg,Row);
  Write(Str);
END;

PROCEDURE WriteColumn(col,row:Byte; Str:String; Attr:Byte);
VAR
  ColHigh,i:Byte;
BEGIN
  IF Length(Str)=0 THEN Exit;
  IF GlobalOut THEN WindowRect(ScreenRect)
    ELSE WindowRect(CurWindow^.OutPut);

  ColHigh := Hi(WindMax)-Row;
  TextAttr := Attr;
  IF Length(Str)-1 < ColHigh THEN ColHigh:=Length(Str)-1;
  FOR I:=0 TO ColHigh DO BEGIN
    GotoXY(col,row+I);
    Write(Str[I+1]);
  END;
END;

PROCEDURE FillRect(r:Rect; Ch:Char; Attr:Byte);
VAR i :Byte;
BEGIN
  IF NOT GlobalOut THEN BEGIN
    Inc(r.Top,   CurWindow^.OutPut.Top-1);
    Inc(r.Bottom,CurWindow^.OutPut.Top-1);
    Inc(r.Left,  CurWindow^.OutPut.Left-1);
    Inc(r.Right, CurWindow^.OutPut.Left-1);
  END;
  FOR I:=r.top TO r.Bottom DO
     WriteChar(r.Left,I, Ch, r.Right-r.Left+1, Attr);
END;

PROCEDURE WriteChar(x,y:Byte; c:Char; Count:Word; Attr:Byte);
VAR r:Registers;
BEGIN
  IF GlobalOut THEN WindowRect(ScreenRect)
    ELSE WindowRect(CurWindow^.OutPut);
  GotoXY(x,y);
  r.AH:=9;
  r.BH:=0;
  r.Al:=Ord(c);
  r.BL:=Attr;
  r.CX:=Count;
  Intr($10,r);
END;

PROCEDURE ReadChar(x,y:Byte; var C:ChAttr);
VAR r:Registers;
BEGIN
  IF GlobalOut THEN WindowRect(ScreenRect)
    ELSE WindowRect(CurWindow^.OutPut);
  GotoXY(x,y);  {указываем место на экране}
  r.AH:= 08;    {видеофункция 8}
  r.BH:= 00;    {видеостраница 0}
  Intr($10,r);
  C.ASCII := Chr(r.AL);
  C.Attr := r.AH;
END;

PROCEDURE ReadImage(var r:Rect; var Im:PImage);
VAR I,J :Byte;
BEGIN
  New(Im);
  Im^.Heigh := r.Bottom - r.Top + 1;
  Im^.Width := r.Right - r.Left + 1;
  FOR I:= r.Left TO r.Right DO
    FOR J:= r.Top TO r.Bottom DO
      ReadChar(I,J,Im^.Chars[I - r.Left + 1, J - r.Top + 1]);
END;

PROCEDURE WriteImage(x,y:Byte; Im:PImage);
VAR I,J:Byte;
BEGIN
  IF Im = nil THEN Exit;
  FOR I:= x TO Im^.Width + x - 1 DO
    FOR J:= y TO Im^.Heigh + y - 1 DO
      WriteChar(I,J,
                Im^.Chars[I-x+1,J-y+1].ASCII, 1,
                Im^.Chars[I-x+1,J-y+1].Attr);
END;

PROCEDURE ShowCursor;
VAR r:Registers;
BEGIN
  CursorOn:=TRUE;
  r.AH:=01;
  r.CH:=11;    {13 и 14 - стандартные значения для VGA }
  r.CL:=12;    {Для EGA - заменить на 11 и 12}
  Intr($10,r);
END;

PROCEDURE HideCursor;
VAR r:Registers;
BEGIN
  CursorON:=FALSE;
  r.AH:=01;
  r.CH:=$FF;    {все биты выключены - курсор не виден!}
  r.CL:=$FF;
  Intr($10,r);
END;

PROCEDURE GlobalON;
BEGIN GlobalOut := TRUE; END;

PROCEDURE GlobalOFF;
BEGIN GlobalOut := FALSE; END;

FUNCTION  Attrib(TextCol,BackCol:Byte):Byte;
BEGIN
  Attrib := (TextCol AND $0F) + (BackCol AND $0F)*16;
END;

PROCEDURE AssignRect(var R:Rect; x1,y1,x2,y2:Byte);
BEGIN
  R.Left  := x1;
  R.Top   := y1;
  R.Right := x2;
  R.Bottom:= y2;
END;

PROCEDURE WriteFrame(r:Rect;Attr:Byte);
VAR I,J:Byte;
BEGIN
   FillRect(r,' ',Attr);
   TextAttr:=Attr;
   FOR I:=r.Top+1 TO r.Bottom-1 DO BEGIN
     GotoXY(r.Left,I); Write('║');
     GotoXY(r.Right,I); Write('║');
   END;
   FOR I:=r.Left+1 TO r.Right-1 DO BEGIN
     GotoXY(I,r.Top); Write('═');
     GotoXY(I,r.Bottom); Write('═');
   END;
   GotoXY(r.Left,r.Top);Write('╔');
   GotoXY(r.Right,r.Top);Write('╗');
   GotoXY(r.Left,r.Bottom);Write('╚');
   GotoXY(r.Right,r.Bottom);Write('╝');
END;

PROCEDURE WriteShadow(r:Rect);
BEGIN
   Inc(r.Top); Inc(r.Bottom);
   Inc(r.Left); Inc(r.Right);
   FillRect(r,' ',Attrib(DarkGray,DarkGray));
END;

PROCEDURE ShowWindow(var W:PWindow);
VAR r:Rect;
BEGIN
   IF W = nil THEN Exit;
   IF W^.Visible THEN Exit;
   GlobalON;
   W^.Visible:=TRUE;

   r:=W^.WinRect; Inc(r.Right); Inc(r.Bottom);
   ReadImage(r,W^.Back);

   WriteShadow(W^.WinRect);
   WriteFrame(W^.WinRect,W^.FrameAttr);

   r:= W^.OutPut; W^.OutPut := W^.WinRect;
   WindowRect(W^.WinRect);
   CurWindow := W;
   GlobalOFF;
   CenterString(1,' '+W^.Title+' ',FALSE,W^.FrameAttr);
   W^.OutPut := r;
   CurWindow := W;
   WindowRect(W^.OutPut);
END;

PROCEDURE HideWindow(var W:PWindow);
BEGIN
  IF W<>CurWindow THEN Exit;
  IF W^.Visible THEN W^.Visible:=FALSE ELSE Exit;
  GlobalON;
  CurWindow:=@ScreenWindow;
  WriteImage(W^.WinRect.Left,W^.WinRect.Top,W^.Back);
END;

PROCEDURE CreateWindow(var W:PWindow;Title:String; Win,Out:Rect; fa,ta:Byte; Vis:Boolean);
BEGIN
  IF W=nil THEN New(W);
  W^.Title:= Title;
  W^.WinRect:=Win;
  W^.OutPut:=Out;
  W^.FrameAttr:=fa;
  W^.TextAttr:=ta;
  W^.Visible := FALSE;
  if Vis then ShowWindow(W);
END;

PROCEDURE DisposeWindow(var W:PWindow);
BEGIN
  IF W = nil THEN Exit;
  IF W^.Visible THEN HideWindow(W);
  IF W^.Back<>nil THEN Dispose(W^.Back);
  Dispose(W);
END;

{Инициализация}
BEGIN
  ClrScr;
  CheckSnow := TRUE;
  CreateWindow(ScreenWindow,'',ScreenRect,ScreenRect,$0F,$0F,FAlse);
  CurWindow := ScreenWindow;
  HideCursor;
END.