Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TTT405.ZIP/WINTTT.PAS

Pascal/Delphi Source File | 1988-07-17 | 14.7 KB | 506 lines

{ $S-,R-,V-,D-,T-}
{\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}
{         TechnoJocks Turbo Toolkit v4.05           Released: Jul 18, 1988    }
{                                                                             }
{         Module: WinTTT   --   screen saving, cursor and windowing procs     }
{                                                                             }
{                  Copyright R. D. Ainsbury (c) 1986-88                       }
{\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}

unit WinTTT;

interface

uses CRT,FastTTT,DOS;

Type
 Direction = (Up, Down, Left, Right);
Const
 Shadow = 5;
Var
 Shadcolor : byte;

Procedure MoveFromScreen(var Source,Dest;Length:Word);
Procedure MoveToScreen(var Source,Dest; Length:Word);
Procedure Attrib(X1,Y1,X2,Y2,F,B:byte);
Procedure SizeCursor(ScanTop,ScanBot:byte);
Procedure FindCursor(var X,Y,ScanTop,ScanBot:byte);
Procedure PosCursor(X,Y: integer);
Procedure Fullcursor;
Procedure HalfCursor;
Procedure OnCursor;
Procedure OffCursor;
Procedure SaveScreen(Page:byte);
Procedure RestoreScreen(Page:byte);
Procedure PartRestoreScreen(Page,X1,Y1,X2,Y2,X,Y:byte);
Procedure SlideRestoreScreen(Page:byte;Way:Direction);
Procedure DisposeScreen(Page:byte);
Procedure CopyScreenBlock(X1,Y1,X2,Y2,X,Y:byte);
Procedure MoveScreenBlock(X1,Y1,X2,Y2,X,Y:byte);
Procedure ScrollUp(X1,Y1,X2,Y2:byte);
Procedure PartSave (X1,Y1,X2,Y2:byte; VAR Dest);
Procedure PartRestore (X1,Y1,X2,Y2:byte; VAR Source);
Procedure Mkwin(x1,y1,x2,y2,F,B,boxtype:integer);
Procedure GrowMkwin(x1,y1,x2,y2,F,B,boxtype:integer);
Procedure Rmwin;
Procedure FillScreen(X1,Y1,X2,Y2:byte; F,B:byte; C:char);
Procedure TempMessage(X,Y,F,B:integer;St:string);

implementation

Const
    Max_Windows = 10;          {Change this constant as necessary}
    Max_Screens = 10;          {Change this constant as necessary}
    WindowCounter : byte = 0;
    ScreenCounter : byte = 0;
    DisplayLines = 25;         {Change this constant as necessary}
    Screen_Size = 4000;        {Change this to 8000 for VGA 50 line Mode}
    MonoAdr =$b000;
Type
    Image = array[1..DisplayLines,1..80] of word;
    ScreenImage = record
                       ScreenSnap: Image;
                       CursorX : byte;
                       CursorY : byte;
                       ScanTop : byte;
                       ScanBot : byte;
                  end;
    ScreenPtr = ^ScreenImage;
    WindowImage = record
                       ScreenPtr: Pointer;             {pointer to screen data}
                       Coord    : array[1..4] of byte; {window coords}
                       CursorX  : byte;                {cursor location}
                       CursorY  : byte;
                       ScanTop  : byte;                {cursor shape}
                       ScanBot  : byte;
                  end;
    WindowPtr = ^WindowImage;

Var
    Screen : array[1..Max_Screens] of ScreenPtr;
    Win    : array[1..Max_Windows] of WindowPtr;


{$L WINTTT}

{$F+}
  Procedure Attribute(Col,Row,Attr:byte; Number:Word); external;
  Procedure MoveFromScreen(var Source,Dest;Length:Word); external;
  Procedure MoveToScreen(var Source,Dest; Length:Word); external;
{$F-}

Procedure WinTTT_Error(No : byte);
{Display error message and halts program}
var Msg : String;
begin
    Case No of
    1 : Msg := '1) -- Max_Screens exceeded.';
    2 : Msg := '2) -- Screen not previously saved, cannot Restore.';
    3 : Msg := '3) -- Screen not previously saved, cannot Dispose.';
    4 : Msg := '4) -- Max_Windows exceeded.';
    5 : Msg := '5) -- Insufficient memory to create window.';
    else Msg := '?) -- Utterly confused';
    end; {Case}
    Msg := 'Fatal Error (WinTTT No. '+Msg;
    Writeln(Msg);
    Delay(5000);    {display long enough to read if child process}
    Halt;
end;

Procedure Attrib(X1,Y1,X2,Y2,F,B:byte);
{changes color attrib at specified coords}
var
  I,X,A : byte;
begin
    A := Attr(F,B);
    X := Succ(X2-X1);
    For I := Y1 to Y2 do
        Attribute(X1,I,A,X);
end; {Proc Attrib}

Procedure FindCursor(var X,Y,ScanTop,ScanBot:byte);
var
   Reg : registers;
begin
  Reg.Ax := $0F00;              {get page in Bx}
  Intr($10,Reg);
  Reg.Ax := $0300;
  Intr($10,Reg);
  With Reg do
  begin
    X := lo(Dx) + 1;
    Y := hi(Dx) + 1;
    ScanTop := Hi(Cx) and $0F;
    ScanBot := Lo(Cx) and $0F;
  end;
end;

Procedure PosCursor(X,Y: integer);
var Reg : registers;
begin
  Reg.Ax := $0F00;              {get page in Bx}
  Intr($10,Reg);
  with Reg do
  begin
    Ax := $0200;
    Dx := ((Y-1) shl 8) or ((X-1) and $00FF);
  end;
  Intr($10,Reg);
end;

Procedure SizeCursor(ScanTop,ScanBot:byte);
var Reg : registers;
begin
    with Reg do
    begin
      ax := 1 shl 8;
      cx := Scantop shl 8 + Scanbot;
      INTR($10,Reg);
    end;
end;

Procedure HalfCursor;
begin
    If BaseOfScreen = MonoAdr then
       SizeCursor(8,13)
    else
       SizeCursor(5,7);
end; {Proc HalfCursor}

Procedure Fullcursor;
begin
    If BaseOfScreen = MonoAdr then
       SizeCursor(0,13)
    else
       SizeCursor(0,7);
end;

Procedure OnCursor;
begin
    If BaseOfScreen = MonoAdr then
       SizeCursor(12,13)
    else
       SizeCursor(6,7);
end;

Procedure OffCursor;
begin
    Sizecursor(14,0);
end;


Procedure FillScreen(X1,Y1,X2,Y2:byte; F,B:byte; C:char);
var
   I : integer;
   S : string;
begin
    Attrib(X1,Y1,X2,Y2,F,B);
    S := Replicate(Succ(X2-x1),C);
    For I := Y1 to Y2 do
        PlainWrite(X1,I,S);
end;

{
****************************
* Screen Saving Procedures *
****************************
}
Procedure Initialize_Screens;
{set Pointers to nil for validity check in RestoreScreen}
Var I : integer;
begin
 For I := 1 to Max_Screens do
  Screen[I] := nil;
end;

Procedure PartSave (X1,Y1,X2,Y2:byte; VAR Dest);
{transfers data from video display to Dest}
var
   I,width : byte;
   ScreenAdr: integer;
begin
    width := succ(X2- X1);
    For I :=  Y1 to Y2 do
    begin
     SCreenAdr := Pred(I)*160 + Pred(X1)*2;
     MoveFromScreen(Mem[BaseOfScreen:ScreenAdr],
                    Mem[seg(Dest):ofs(dest)+(I-Y1)*width*2],
                    width);
    end;
end;

Procedure PartRestore (X1,Y1,X2,Y2:byte; VAR Source);
{restores data from Source and transfers to video display}
var
   I,width : byte;
   ScreenAdr: integer;
begin
    width := succ(X2- X1);
    For I :=  Y1 to Y2 do
    begin
     ScreenAdr := Pred(I)*160 + Pred(X1)*2;
     MoveToScreen(Mem[Seg(Source):ofs(Source)+(I-Y1)*width*2],
                  Mem[BaseOfScreen:ScreenAdr],
                  width);
    end;
end;

Procedure SaveScreen(Page:byte);
{Save screen display and cursor details}
begin
    If (Page > Max_Screens) then
      WinTTT_Error(1);
    If MaxAvail < Screen_Size then
       WinTTT_Error(5);
    GetMem(Screen[Page],Screen_Size);
    MoveFromScreen(Mem[BaseOfScreen:0],Screen[Page]^.ScreenSnap, Screen_Size div 2);
    FindCursor(Screen[Page]^.CursorX,         {Save Cursor posn. and shape}
               Screen[Page]^.CursorY,
               Screen[Page]^.ScanTop,
               Screen[Page]^.ScanBot);
end;

Procedure RestoreScreen(Page:byte);
{Display a screen that was previously saved}
begin
    If Screen[Page] = nil then
       WinTTT_Error(2);
        MoveToScreen(Screen[Page]^.ScreenSnap,mem[BaseOfScreen:0], Screen_Size div 2);
    PosCursor(Screen[Page]^.CursorX,Screen[Page]^.CursorY);
    SizeCursor(Screen[Page]^.ScanTop,Screen[Page]^.ScanBot);
end;  {Proc RestoreScreen}


Procedure PartRestoreScreen(Page,X1,Y1,X2,Y2,X,Y:byte);
{Move from heap to screen, part of saved screen}
Var
   I,width     : byte;
   ScreenAdr,
   PageAdr     : integer;
begin
    If Screen[Page] = nil then
       WinTTT_Error(2);
    Width := succ(X2- X1);
    For I :=  Y1 to Y2 do
    begin
        ScreenAdr := pred(Y+I-Y1)*160 + Pred(X)*2;
        PageAdr   := Pred(I)*160 + Pred(X1)*2;
        MoveToScreen(Mem[Seg(Screen[Page]^):ofs(Screen[Page]^)+PageAdr],
                     Mem[BaseOfScreen:ScreenAdr],
                     width);
    end;
end;

Procedure SlideRestoreScreen(Page:byte;Way:Direction);
{Display a screen that was previously saved, with fancy slide}
Var I : byte;
begin
    If Screen[Page] = nil then
       WinTTT_Error(2);
    Case Way of
    Up    : begin
                For I := DisplayLines downto 1 do
                begin
                    PartRestoreScreen(Page,
                                      1,1,80,succ(DisplayLines -I),
                                      1,I);
                    Delay(50);
                end;
            end;
    Down  : begin
                For I := 1 to DisplayLines do
                begin
                    PartRestoreScreen(Page,
                                      1,succ(DisplayLines -I),80,DisplayLines,
                                      1,1);
                    Delay(50);  {savor the moment!}
                end;
            end;
    Left  : begin
                For I := 1 to 80 do
                begin
                    PartRestoreScreen(Page,
                                      1,1,I,DisplayLines,
                                      succ(80-I),1);
                end;
            end;
    Right : begin
                For I := 80 downto 1 do
                begin
                    PartRestoreScreen(Page,
                                      I,1,80,DisplayLines,
                                      1,1);
                end;
            end;
    end; {case}
    PosCursor(Screen[Page]^.CursorX,Screen[Page]^.CursorY);
    SizeCursor(Screen[Page]^.ScanTop,Screen[Page]^.ScanBot);
end;   {Proc SlideRestoreScreen}

Procedure DisposeScreen(Page:byte);
{Free memory that was allocated by SvaeScreen}
begin
    If Screen[Page] = nil then
       WinTTT_Error(3);
    FreeMem(Screen[Page],Screen_Size);
end;

Procedure CopyScreenBlock(X1,Y1,X2,Y2,X,Y:byte);
{copies text and attributes from one part of screen to another}
Var
   I,width     : byte;
   SourceAdr,
   TargetAdr   : integer;
   TempLine    : array[1..160] of byte;
begin
    Width := succ(X2- X1);
    For I :=  Y1 to Y2 do
    begin
        SourceAdr := Pred(I)*160 + Pred(X1)*2;
        TargetAdr := Pred(Y+I-Y1)*160 + Pred(X)*2;
        MoveFromScreen(Mem[BaseOfScreen:SourceAdr],
                       TempLine,
                       width);
        MoveToScreen(TempLine,
                     Mem[BaseOfScreen:TargetAdr],
                     width);
    end;
end; {CopyScreenBlock}

Procedure MoveScreenBlock(X1,Y1,X2,Y2,X,Y:byte);
{Moves text and attributes from one part of screen to another,
 replacing with Replace_Char}
const
  Replace_Char = ' ';
Var
   I,width     : byte;
   SourceAdr,
   TargetAdr   : integer;
   TempLine    : array[1..160] of byte;
begin
    Width := succ(X2- X1);
    For I :=  Y1 to Y2 do
    begin
        SourceAdr := Pred(I)*160 + Pred(X1)*2;
        TargetAdr := Pred(Y+I-Y1)*160 + Pred(X)*2;
        MoveFromScreen(Mem[BaseOfScreen:SourceAdr],
                       TempLine,
                       width);
        PlainWrite(X1,I,replicate(succ(X2-X1),Replace_Char));
        MoveToScreen(TempLine,
                     Mem[BaseOfScreen:TargetAdr],
                     width);
    end;
end; {Proc MoveScreenBlock}

Procedure ScrollUp(X1,Y1,X2,Y2:byte);
{used for screen scrolling, uses Copy & Plainwrite rather than Move for speed}
const
  Replace_Char = ' ';
begin
  CopyScreenBlock(X1,succ(Y1),X2,Y2,X1,Y1);
  PlainWrite(X1,Y2,replicate(succ(X2-X1),Replace_Char));
end;

{
****************************
*   Windowing Procedures   *
****************************
}

procedure CreateWin(x1,y1,x2,y2,F,B,boxtype:integer);
{called by MkWin and GrowMkWin}
begin
    If WindowCounter >= Max_Windows then
       WinTTT_Error(4);
    WindowCounter :=  WindowCounter + 1;
    If MaxAvail < sizeOf(Win[WindowCounter]^) then
       WinTTT_Error(5);
    GetMem(Win[WindowCounter],sizeof(Win[WindowCounter]^));    {allocate space}
    If (BoxType in [5..9]) and (X1 > 1) then     {is there a drop shadow}
    begin
        X1 := pred(X1);    {increase dimensions for the box}
        Y2 := succ(Y2);
    end;
    If MaxAvail < succ(Y2-Y1)*succ(X2-X1)*2 then
       WinTTT_Error(5);
    GetMem(Win[WindowCounter]^.ScreenPtr,succ(Y2-Y1)*succ(X2-X1)*2);
    PartSave(X1,Y1,X2,Y2,Win[WindowCounter]^.ScreenPtr^);
    with Win[WindowCounter]^ do
    begin
      Coord[1] := X1;
      Coord[2] := Y1;
      Coord[3] := X2;
      Coord[4] := Y2;
      FindCursor(CursorX,CursorY,ScanTop,ScanBot);
    end;  {with}
end; {Proc CreateWin}

procedure mkwin(x1,y1,x2,y2,F,B,boxtype:integer);
{Main procedure for creating window}
var I : integer;
begin
    CreateWin(X1,Y1,X2,Y2,F,B,Boxtype);
    If (BoxType in [5..9]) and (X1 > 1) then
       FBox(x1,y1,x2,y2,F,B,boxtype-shadow)
    else
       FBox(x1,y1,x2,y2,F,B,boxtype);
    If (BoxType in [5..9]) and (X1 > 1) then     {is there a drop shadow}
    begin
        For I := succ(Y1) to succ(Y2) do
            WriteAt(pred(X1),I,Shadcolor,black,' ');
        WriteAt(X1,succ(Y2),Shadcolor,black,
                replicate(X2-succ(X1),' '));
    end;
end;

procedure GrowMKwin(x1,y1,x2,y2,F,B,boxtype:integer);
{same as MKwin but window explodes}
var I : integer;
begin
    CreateWin(X1,Y1,X2,Y2,F,B,Boxtype);
    If (BoxType in [5..9]) and (X1 > 1) then
       GrowFBox(x1,y1,x2,y2,F,B,boxtype-shadow)
    else
       GrowFBox(x1,y1,x2,y2,F,B,boxtype);
    If (BoxType in [5..9]) and (X1 > 1) then     {is there a drop shadow}
    begin
        For I := succ(Y1) to succ(Y2) do
            WriteAt(pred(X1),I,Shadcolor,black,' ');
        WriteAt(X1,succ(Y2),Shadcolor,black,
                replicate(X2-succ(X1),' '));
    end;
end;

Procedure RmWin;
begin
    If WindowCounter > 0 then
    begin
        with  Win[WindowCounter]^ do
        begin
            PartRestore(Coord[1],Coord[2],Coord[3],Coord[4],ScreenPtr^);
            PosCursor(CursorX,CursorY);
            SizeCursor(ScanTop,ScanBot);
            FreeMem(ScreenPtr,succ(Coord[4]-coord[2])*succ(coord[3]-coord[1])*2);
            FreeMem(Win[WindowCounter],sizeof(Win[WindowCounter]^));
        end; {with}
        WindowCounter := WindowCounter - 1;
    end;
end;

procedure TempMessage(X,Y,F,B:integer;St:string);
var
 CX,CY,CT,CB,I,locC:integer;
 SavedLine : array[1..160] of byte;
 Ch :char;
begin
    PartSave(X,Y,pred(X)+length(St),Y,SavedLine);
    WriteAT(X,Y,F,B,St);
    Ch := ReadKey;
    PartRestore(X,Y,pred(X)+length(St),Y,SavedLine);
end;

begin
    Initialize_Screens;
    Shadcolor := darkgray;
end.