home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
progm
/
tot4.zip
/
TOTFAST.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-02-11
|
57KB
|
2,116 lines
{ Copyright 1991 TechnoJock Software, Inc. }
{ All Rights Reserved }
{ Restricted by License }
{ Build # 1.00 }
Unit totFAST;
{$I TOTFLAGS.INC}
{
Development Notes:
6) Add save of display attr (TextColor and TextBackground)
7) Add save of display mode
}
INTERFACE
uses DOS, CRT, totSYS, totLOOK, totINPUT;
TYPE
StrScreen = string[255]; {alter as necessary}
StrVisible = string[80]; {alter as necessary}
tDirection = (Up, Down, Left, Right, Vert, Horiz);
tCoords = record
X1,Y1,X2,Y2:shortint;
end;
tByteCoords = record
X1,Y1,X2,Y2:byte;
end;
ShadowPosition = (UpLeft,UpRight,DownLeft,DownRight);
WritePtr = ^WriteOBJ;
pWriteOBJ = ^WriteOBJ;
WriteOBJ = object
vWidth: byte; {how wide is screen}
vScreenPtr: pointer; {memory location of screen data}
vWindow: tByteCoords; {active screen area}
vWindowOn: boolean; {is window area active}
vWindowIgnore: boolean; {ignore window settings}
{methods...}
constructor Init;
procedure SetScreen(var P:Pointer; W:byte);
function WindowOff: boolean;
procedure SetWinIgnore(On:Boolean);
procedure WindowOn;
procedure WindowCoords(var Coords: tByteCoords);
function WindowActive: boolean;
function WinX: byte;
function WinY: byte;
procedure GetWinCoords(var X1,Y1,X2,Y2:byte);
procedure WriteAT(X,Y,attr:byte;Str:string); VIRTUAL;
procedure WritePlain(X,Y:byte;Str:string); VIRTUAL;
procedure Write(Str:string); VIRTUAL;
procedure WriteLn(Str:string); VIRTUAL;
procedure GotoXY(X,Y: word); VIRTUAL;
function WhereX: word; VIRTUAL;
function WhereY: word; VIRTUAL;
procedure SetWindow(X1,Y1,X2,Y2: byte); VIRTUAL;
procedure ResetWindow; VIRTUAL;
procedure ChangeAttr(X,Y,Att:byte;Len:word); VIRTUAL;
procedure MoveFromScreen(var Source,Dest;Len:Word); VIRTUAL;
procedure MoveToScreen(var Source,Dest; Len:Word); VIRTUAL;
procedure Clear(Att:byte;Ch:char); VIRTUAL;
destructor Done; VIRTUAL;
end; {WriteOBJ}
ScreenPtr = ^ScreenOBJ;
pScreenOBJ = ^ScreenOBJ;
ScreenOBJ = object
vWidth: byte; {how wide is screen}
vDepth: byte; {how many lines}
vScreenPtr: pointer; {memory location of screen data}
vCursX: byte; {cursor location}
vCursY: byte; { -"- }
vCursTop: byte; {cursor size}
vCursBot: byte; { -"- }
oWritePtr: WritePtr; {screen writing and moving object}
vHiMarker: char; {character to indicate attribute change}
vVisible: boolean; {is the screen mapped to visible display}
vOnScreen:boolean;
{methods...}
constructor Init;
procedure DesqViewTest;
procedure SetHiMarker(M:char);
function HiMarker:char;
procedure AssignWriteOBJ(var Wri: WriteOBJ);
procedure SetWindow(X1,Y1,X2,Y2: byte);
procedure SetWinIgnore(On:Boolean);
procedure ResetWindow;
function WindowOff:boolean;
procedure WindowOn;
procedure WindowCoords(var Coords: tByteCoords);
function WindowActive: boolean;
function OnScreen:boolean;
function CharHeight: integer;
procedure CursReset;
procedure CursSave;
procedure GotoXY(X,Y: word);
procedure CursSize(T,B: byte);
function WhereX: word;
function WhereY: word;
function CursTop: byte;
function CursBot: byte;
procedure CursHalf;
procedure CursFull;
procedure CursOn;
procedure CursOff;
procedure Exists;
procedure MoveToScreen(var Source, Dest; Length:word);
procedure MoveFromScreen(var Source, Dest; Length:word);
procedure Save;
procedure Create(X,Y,Attr:byte);
function Width: byte;
function Depth: byte;
function ScreenPtr: pointer;
procedure Display;
procedure PartDisplay(X1,Y1,X2,Y2,X,Y:byte);
procedure PartSlideDisplay(X1,Y1,X2,Y2:byte;Way:tDirection);
procedure SlideDisplay(Way: tDirection);
procedure PartSave (X1,Y1,X2,Y2:byte; VAR Dest);
procedure PartRestore (X1,Y1,X2,Y2:byte; VAR Source);
procedure CopyScreenBlock(X1,Y1,X2,Y2,X,Y:byte);
procedure MoveScreenBlock(X1,Y1,X2,Y2,X,Y:byte);
procedure Scroll(Way:tDirection;X1,Y1,X2,Y2:byte);
procedure Write(Str:string);
procedure WriteLn(Str:string);
procedure WriteAT(X,Y,attr:byte;Str:string);
procedure WriteHi(X,Y,AttrHi,Attr:byte;Str:string);
procedure WritePlain(X,Y:byte;Str:string);
procedure WriteCap(X,Y,AttrCap,Attr:byte;Str:string);
procedure WriteClick(X,Y,attr:byte;Str:string);
procedure WriteCenter(Y,Attr:byte;Str:string);
procedure WriteBetween(X1,X2,Y,Attr:byte;Str:string);
procedure WriteRight(X,Y,Attr:byte;Str:string);
procedure WriteVert(X,Y,Attr:byte;Str:string);
procedure Attrib(X1,Y1,X2,Y2,Attr:byte);
procedure Clear(Att:byte;Ch:char);
procedure PartClear(X1,Y1,X2,Y2,Att:byte;Ch:char);
procedure ClearText(X1,Y1,X2,Y2:byte);
procedure ReadWord(X,Y:byte;var Attr:byte; var Ch : char);
function ReadChar(X,Y:byte):char;
function ReadAttr(X,Y:byte):byte;
function ReadStr(X1,X2,Y:byte):string;
procedure BoxEngine(X1,Y1,X2,Y2,LeftPad,RightPad,Battr,Tattr,Mattr,style:byte;
Filled:boolean;
Title:string);
procedure TitleEngine(X1,Y1,X2,Y2,LeftPad,RightPad,Battr,Tattr:byte;Str,Title:string);
procedure Box(X1,Y1,X2,Y2,attr,style:byte);
procedure FillBox(X1,Y1,X2,Y2,attr,style:byte);
procedure ShadFillBox(X1,Y1,X2,Y2,attr,style:byte);
procedure TitledBox(X1,Y1,X2,Y2,Battr,Tattr,Mattr,style:byte;Title:string);
procedure HorizLine(X1,X2,Y,Attr,Style : byte);
procedure VertLine(X,Y1,Y2,Attr,Style:byte);
procedure SmartVertLine(X,Y1,Y2,Attr,Style:byte);
procedure SmartHorizLine(X1,X2,Y,Attr,Style:byte);
procedure WriteHScrollBar(X1,X2,Y,Attr: byte; Current,Max: longint);
procedure WriteVScrollBar(X,Y1,Y2,Attr: byte; Current,Max: longint);
destructor Done;
end; {ScreenOBJ}
pScrollOBJ = ^ScrollOBJ;
ScrollOBJ = object
vUpArrowChar: char;
vDownArrowChar: char;
vLeftArrowChar: char;
vRightArrowChar: char;
vElevatorChar: char;
vBackgroundChar: char;
{methods...}
constructor Init;
procedure SetDefaults;
procedure SetScrollChars(U,D,L,R,E,B:char);
function UpChar: char;
function DownChar: char;
function LeftChar: char;
function RightChar: char;
function ElevatorChar: char;
function BackgroundChar: char;
destructor Done;
end; {ScrollOBJ}
pShadowOBJ = ^ShadowOBJ;
ShadowOBJ = object
vShadPos: ShadowPosition; {where is shadow}
vShadAttr: byte; {shadow attribute}
vShadChar: char; {shadow character - ' ' is see-through}
vShadWidth: byte; {shadow width in characters}
vShadDepth: byte; {shadow depth in characters}
{methods...}
constructor Init;
procedure SetDefaults;
procedure SetShadowStyle(ShadP:ShadowPosition; ShadA:byte; ShadC: char);
procedure SetShadowSize(ShadW,ShadD:byte);
function ShadWidth: byte;
function ShadDepth: byte;
function ShadAttr: byte;
function ShadChar: char;
function ShadPos: ShadowPosition;
procedure DrawShadow(Border:tCoords);
procedure DrawShadowXY(X1,Y1,X2,Y2:integer);
procedure OuterCoords(Border:tCoords;var Outer:tCoords);
procedure OuterXY(var X1,Y1,X2,Y2: integer);
destructor Done;
end; {ShadowOBJ}
VAR
Screen: ScreenOBJ;
ScrollTOT: ^ScrollOBJ;
ShadowTOT: ^ShadowOBJ;
SnowProne : byte;
function CAttr(F,B:byte):byte;
function FAttr(A:byte): byte;
function BAttr(A:byte): byte;
function Replicate(N : byte; Character:char): string;
procedure fastINIT;
IMPLEMENTATION
Const
TitPos:string[6] = '<+>^|_'; {characters signifying box title position}
WinCursX: byte = 1;
WinCursY: byte = 1;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{ }
{ U N I T P R O C E D U R E S & F U N C T I O N S }
{ }
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
procedure Error(Err:byte);
{temp routine to display error - replace with object}
const
Header = 'totFAST error: ';
var
Msg : string;
begin
Case Err of
1: Msg := 'Not enough memory to initialize screen';
2: Msg := 'Cannot write to inactive screen';
3: Msg := 'Not enough memory for screen move/copy';
else Msg := 'Unknown Error';
end; {case}
Writeln(Header,Msg);
halt;
end; {Error}
function CAttr(F,B:byte):byte;
{converts foreground(F) and background(B) colors to combined Attribute byte}
begin
CAttr := (B Shl 4) or F;
end; {CAttr}
function FAttr(A:byte): byte;
{returns the foreground color from an attribute Byte}
begin
FAttr := A and 15;
end; {FAttr}
function BAttr(A:byte): byte;
{returns the background color from an attribute Byte}
begin
BAttr := (A and 112) shr 4;
end; {FAttr}
function Replicate(N : byte; Character:char): string;
{returns a string with Character repeated N times}
var tempstr: string;
begin
If N = 0 then
TempStr := ''
else
begin
Fillchar(tempstr,N+1,Character);
Tempstr[0] := chr(N);
end;
Replicate := Tempstr;
end; {replicate}
{$L totFAST}
{$F+}
procedure AsmWrite(var scrptr; Wid,Col,Row,Attr:byte; St:String); external;
procedure AsmPWrite(var scrptr; Wid,Col,Row:byte; St:String); external;
procedure AsmAttr(var scrptr; Wid,Col,Row,Attr,Len:byte); external;
Procedure AsmMoveFromScreen(var Source,Dest;Length:Word); external;
Procedure AsmMoveToScreen(var Source,Dest; Length:Word); external;
{$IFNDEF OVERLAY}
{$F-}
{$ENDIF}
{|||||||||||||||||||||||||||||||||||||||||}
{ }
{ W r i t e O B J M E T H O D S }
{ }
{|||||||||||||||||||||||||||||||||||||||||}
constructor WriteOBJ.Init;
{}
begin
vWindowOn := false;
vWindowIgnore := false;
end; {WriteOBJ.Init}
procedure WriteOBJ.SetScreen(var P:Pointer; W:byte);
{}
begin
vScreenPtr := P;
vWidth := W;
end; {WriteOBJ.SetScreen}
procedure WriteOBJ.SetWindow(X1,Y1,X2,Y2: byte);
{}
begin
CRT.Window(X1,Y1,X2,Y2);
vWindow.X1 := X1;
vWindow.Y1 := Y1;
vWindow.X2 := X2;
vWindow.Y2 := Y2;
vWindowOn := true;
end; {WriteOBJ.SetWindow}
procedure WriteOBJ.GetWinCoords(var X1,Y1,X2,Y2:byte);
{}
begin
X1 := vWindow.X1;
Y1 := vWindow.Y1;
X2 := vWindow.X2;
Y2 := vWindow.Y2;
end; {WriteOBJ.GetWinCoords}
procedure WriteOBJ.ResetWindow;
{}
var H,W: byte;
begin
W := Monitor^.Width;
H := Monitor^.Depth;
CRT.Window(1,1,W,H);
vWindow.X1 := 1;
vWindow.Y1 := 1;
vWindow.X2 := W;
vWindow.Y2 := H;
vWindowOn := false;
end; {WriteOBJ.ResetWindow}
function WriteOBJ.WindowOff:boolean;
{}
begin
if vWindowOn then
begin
vWindowOn := false;
WinCursX := WhereX;
WinCursY := WhereY;
CRT.window(1,1,Monitor^.Width,Monitor^.Depth);
WindowOff := true;
end
else
WindowOff := false;
end; {WriteOBJ.WindowOff}
procedure WriteOBJ.WindowOn;
{}
begin
vWindowOn := true;
window(vWindow.X1,vWindow.Y1,vWindow.X2,vWindow.Y2);
GotoXY(WinCursX,WinCursY);
end; {WriteOBJ.WindowOn}
procedure WriteOBJ.WindowCoords(var Coords: tByteCoords);
{}
begin
Coords := vWindow;
end; {WriteOBJ.WindowCoords}
function WriteOBJ.WindowActive: boolean;
{}
begin
WindowActive := vWindowOn;
end; {WriteOBJ.WindowActive}
procedure WriteOBJ.SetWinIgnore(On:Boolean);
{}
begin
vWindowIgnore := On;
end; {WriteOBJ.SetWinIgnore}
function WriteOBJ.WinX: byte;
{}
begin
if vWindowOn and not vWindowIgnore then
WinX := vWindow.X1
else
WinX := 1;
end; {WriteOBJ.WinX}
function WriteOBJ.WinY: byte;
{}
begin
if vWindowOn and not vWindowIgnore then
WinY := vWindow.Y1
else
WinY := 1;
end; {WriteOBJ.WinY}
procedure WriteOBJ.WriteAT(X,Y,attr:byte;Str:string);
{}
begin
if not vWindowOn or vWindowIgnore then
ASMWrite(vScreenPtr^,vWidth,X,Y,attr,Str)
else
begin
Str := copy(Str,1,vWindow.X2 - pred(X) - pred(vWindow.X1));
if Y + pred(vWindow.Y1) <= vWindow.Y2 then
ASMWrite(vScreenPtr^,vWidth,pred(vWindow.X1)+X,
pred(vWindow.Y1)+Y,
attr,Str);
end;
end; {WriteOBJ.WriteAT}
procedure WriteOBJ.WritePlain(X,Y:byte;Str:string);
{}
begin
if not vWindowOn or vWindowIgnore then
ASMPWrite(vScreenPtr^,vWidth,X,Y,Str)
else
begin
Str := copy(Str,1,vWindow.X2 - pred(X) - pred(vWindow.X1));
if Y + pred(vWindow.Y1) <= vWindow.Y2 then
ASMPWrite(vScreenPtr^,vWidth,pred(vWindow.X1)+X,
pred(vWindow.Y1)+Y,
Str);
end;
end; {WriteOBJ.WritePlain}
procedure WriteOBJ.Write(Str:string);
{}
begin
System.Write(Str)
end; {WriteOBJ.Write}
procedure WriteOBJ.WriteLn(Str:string);
{}
begin
System.WriteLn(Str);
end; {WriteOBJ.WriteLn}
procedure WriteOBJ.GotoXY(X,Y: word);
{}
begin
CRT.GotoXY(X,Y);
end; {WriteOBJ.GotoXY}
function WriteOBJ.WhereX: word;
{}
begin
WhereX := CRT.WhereX;
end; {WriteOBJ.WhereX}
function WriteOBJ.WhereY: word;
{}
begin
WhereY := CRT.WhereY;
end; {WriteOBJ.WhereY}
procedure WriteOBJ.ChangeAttr(X,Y,Att:byte;Len:word);
{}
begin
if not vWindowOn or vWindowIgnore then
ASMAttr(vScreenPtr^,vWidth,X,Y,Att,Len)
else
begin
inc(X,pred(vWindow.X1));
inc(Y,pred(vWindow.Y1));
if (X <= vWindow.X2) and (Y <= vWindow.Y2) then
begin
if X + Len > vWindow.X2 then
Len := vWindow.X2 - pred(X);
ASMAttr(vScreenPtr^,vWidth,X,Y,Att,Len)
end;
end;
end; {WriteOBJ.ChangeAttr}
procedure WriteOBJ.MoveFromScreen(var Source,Dest;Len:Word);
{}
begin
ASMMoveFromScreen(Source,Dest,Len);
end; {WriteOBJ.MoveFromScreen}
procedure WriteOBJ.MoveToScreen(var Source,Dest; Len:Word);
{}
begin
ASMMoveToScreen(Source,Dest,Len);
end; {WriteOBJ.MoveToScreen}
procedure WriteOBJ.Clear(Att:byte;Ch:char);
{}
var
I : integer;
S : string;
begin
with vWindow do
begin
S := Replicate(Succ(X2-X1),Ch);
for I := 1 to succ(Y2-Y1) do
begin
ChangeAttr(X1,Y1,Att,succ(X2-X1));
WritePlain(1,I,S);
end;
end;
end; {WriteOBJ.Clear}
destructor WriteOBJ.Done;
{}
begin
end; {WriteOBJ.Done}
{|||||||||||||||||||||||||||||||||||||||||||}
{ }
{ S c r e e n O B J M E T H O D S }
{ }
{|||||||||||||||||||||||||||||||||||||||||||}
constructor ScreenOBJ.Init;
{}
begin
vScreenPtr := nil;
vHiMarker := '~';
vVisible := false;
vOnScreen := false;
New(oWritePtr,Init);
oWritePtr^.SetScreen(vScreenPtr,vWidth);
ResetWindow;
end; {ScreenOBJ.Init}
procedure ScreenOBJ.SetHiMarker(M:char);
{}
begin
vHiMarker := M;
end; {ScreenOBJ.SetHiMarker}
function ScreenOBJ.HiMarker:char;
{}
begin
Himarker := vHiMarker;
end; {ScreenOBJ.Himarker}
procedure ScreenOBJ.AssignWriteOBJ(var Wri: WriteOBJ);
{}
begin
Dispose(oWritePtr,Done);
oWritePtr := @Wri;
oWritePtr^.SetScreen(vScreenPtr,vWidth);
end; {ScreenOBJ.AssignWriteOBJ}
procedure ScreenOBJ.SetWindow(X1,Y1,X2,Y2: byte);
{}
begin
oWritePtr^.SetWindow(X1,Y1,X2,Y2);
end; {ScreenOBJ.SetWindow}
procedure ScreenOBJ.SetWinIgnore(On:Boolean);
{}
begin
oWritePtr^.SetWinIgnore(On);
end; {ScreenOBJ.SetWinIgnore}
procedure ScreenOBJ.ResetWindow;
{}
begin
oWritePtr^.ResetWindow;
end; {ScreenOBJ.ResetWindow}
function ScreenOBJ.WindowOff:boolean;
{}
begin
WindowOff := oWritePtr^.WindowOff;
end; {ScreenOBJ.WindowOff}
procedure ScreenOBJ.WindowOn;
{}
begin
oWritePtr^.WindowOn;
end; {ScreenOBJ.WindowOn}
procedure ScreenOBJ.WindowCoords(var Coords: tByteCoords);
{}
begin
oWritePtr^.WindowCoords(Coords);
end; {ScreenOBJ.WindowCoords}
function ScreenOBJ.WindowActive: boolean;
{}
begin
WindowActive := oWritePtr^.WindowActive;
end; {ScreenOBJ.WindowActive}
{|||||||||||||||||||||||||||||||||}
{ C U R S O R S T U F F }
{|||||||||||||||||||||||||||||||||}
function ScreenOBJ.OnScreen: boolean;
{is this instance the visible screen}
begin
OnScreen := vOnScreen;
end; {ScreenOBJ.OnScreen}
function ScreenOBJ.CharHeight: integer;
{get height of text mode characters for cursor manipulation}
var
Regs: Registers;
begin
if OnScreen then
begin
case Monitor^.DisplayType of
Mono: CharHeight := 14;
EGACol,
CGA : CharHeight := 8;
else
with Regs do
begin
Ah := $11;
Al := $30;
BX := $0;
Intr($10,Regs);
CharHeight := CX;
end; {with}
end; {case}
end
else {virtual screen assume normal mode}
begin
if Monitor^.DisplayType = Mono then
CharHeight := 14
else
CharHeight := 8;
end;
end; {ScreenOBJ.CharHeight}
procedure ScreenOBJ.CursReset;
{}
begin
GotoXY(1,1);
CursOn;
end; {ScreenOBJ.CursReset}
procedure ScreenOBJ.CursSave;
{updates instance with visible Cursor details}
var Reg : registers;
begin
with Reg do
begin
Ax := $0F00; {get page in Bx}
intr($10,reg);
Ax := $0300;
intr($10,reg);
vCursX := lo(Dx) + 1;
vCursY := hi(Dx) + 1;
vCursTop := Hi(Cx) and $0F;
vCursBot := Lo(Cx) and $0F;
end;
end; {ScreenOBJ.CursSave}
procedure ScreenOBJ.CursSize(T,B : byte);
{}
var Reg: registers;
begin
if OnScreen then {writing to a visible screen}
begin
with reg do
begin
AX := $0100;
if (T=0) and (B=0) then
CX := $2000
else
begin
(*
If you have an odd video bios and cursor changes
are strange, enable this next line.
mem[$40:$87] := mem[$40:$87] or $01; {get cursor ownership from BIOS}
*)
Ch := T;
Cl := B;
end;
intr($10,Reg);
end;
end;
vCursTop := T;
vCursBot := B;
end; {ScreenOBJ.CursSize}
function ScreenOBJ.WhereX: word;
{}
begin
if OnScreen then {writing to a visible screen}
WhereX := oWritePtr^.WhereX
else
WhereX := vCursX;
end; {ScreenOBJ.WhereX}
function ScreenOBJ.WhereY: word;
{}
begin
if OnScreen then {writing to a visible screen}
WhereY := oWritePtr^.WhereY
else
WhereY := vCursY;
end; {ScreenOBJ.WhereY}
procedure ScreenOBJ.GotoXY(X,Y:word);
{}
begin
if OnScreen then {writing to a visible screen}
oWritePtr^.GotoXY(X,Y)
else
begin
vCursX := X;
vCursY := Y;
end;
end; {ScreenOBJ.CursGotoXY}
function ScreenOBJ.CursTop: byte;
{}
begin
CursTop := vCursTop;
end; {ScreenOBJ.CursTOP}
function ScreenOBJ.CursBot: byte;
{}
begin
CursBot := vCursBot;
end; {ScreenOBJ.CursBot}
procedure ScreenOBJ.CursHalf;
{}
var Charsize: byte;
begin
CharSize := CharHeight;
CursSize(CharSize div 2, pred(CharSize));
end; {ScreenOBJ.CursHalf}
procedure ScreenOBJ.CursFull;
{}
var Charsize: byte;
begin
CharSize := CharHeight;
CursSize(0,CharSize);
end; {ScreenOBJ.CursFull}
procedure ScreenOBJ.CursOn;
{}
var Charsize: byte;
begin
CharSize := CharHeight;
CursSize(CharSize-3, CharSize-2);
end; {ScreenOBJ.CursOn}
procedure ScreenOBJ.CursOff;
{}
begin
CursSize(0,0);
end; {ScreenOBJ.CursOff}
{||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{ S C R E E N S A V E & R E S T O R E }
{||||||||||||||||||||||||||||||||||||||||||||||||||||||}
procedure ScreenOBJ.Exists;
{makes sure there is a screen on the heap}
begin
if ScreenPtr = nil then
Error(2);
end; {ScreenOBJ.Exists}
procedure ScreenOBJ.DesqViewTest;
{}
var Regs: Registers;
begin
with Regs do
begin
AX := $2B01;
CX := $4445;
DX := $5351;
intr($21,Regs);
if Al <> $FF then {DesqView present}
begin
Ah := $FE;
Intr($10,Regs);
vScreenPtr := ptr(ES,DI);
end;
end;
end; {ScreenOBJ.DesqViewTest}
procedure ScreenOBJ.Create(X,Y,Attr:byte);
{}
var MemoryNeeded: longint;
begin
MemoryNeeded := X*Y*2;
If MaxAvail < MemoryNeeded then
Error(1)
else
begin
If (X = 0) and (Y = 0) then {map to physical screen}
begin
vWidth := Monitor^.Width;
(*
vDepth := 50; {set to max for extended line displays}
*)
vDepth := Monitor^.Depth;
vVisible := true;
vScreenPtr := ptr(Monitor^.vBaseOfScreen,0);
oWritePtr^.SetScreen(vScreenPtr,vWidth);
vOnScreen := true;
DesqViewTest;
CursSave;
ResetWindow;
end
else
begin
vWidth := X;
vDepth := Y;
GetMem(vScreenPtr,MemoryNeeded);
oWritePtr^.SetScreen(vScreenPtr,vWidth);
SetWindow(1,1,X,Y);
Clear(Attr,' ');
CursReset;
end;
end;
end; {ScreenOBJ.Create}
procedure ScreenOBJ.MoveFromScreen(var Source, Dest; Length:word);
{}
begin
oWritePtr^.MoveFromScreen(Source,Dest,Length);
end; {ScreenOBJ.MoveFromScreen}
procedure ScreenOBJ.MoveToScreen(var Source, Dest; Length:word);
{}
begin
oWritePtr^.MoveToScreen(Source,Dest,Length);
end; {ScreenOBJ.MoveToScreen}
procedure ScreenOBJ.Save;
{saves current screen to instance}
var
MemoryNeeded: longint;
MVisible: boolean;
WinCoords: tByteCoords;
begin
If ScreenPtr <> nil then
Freemem(vScreenPtr,Width*Depth*2);
MemoryNeeded := Monitor^.Width*Monitor^.Depth*2;
If MaxAvail < MemoryNeeded then
Error(1)
else
begin
vWidth := Monitor^.Width;
vDepth := Monitor^.Depth;
GetMem(vScreenPtr,MemoryNeeded);
MVisible := Mouse.Visible;
if MVisible then
Mouse.Hide;
MoveFromScreen(Monitor^.BaseOfScreen^,ScreenPtr^,vWidth*vDepth);
CursSave;
oWritePtr^.SetScreen(vScreenPtr,vWidth);
Screen.WindowCoords(WinCoords);
with WinCoords do
SetWindow(X1,Y1,X2,Y2);
if MVisible then
Mouse.Show;
end;
end; {ScreenOBJ.Save}
function ScreenOBJ.Width: byte;
{}
begin
Width := vWidth;
end; {ScreenOBJ.Width}
function ScreenOBJ.Depth: byte;
{}
begin
if vVisible then
begin
Depth := Monitor^.Depth
end
else
Depth := vDepth;
end; {ScreenOBJ.Depth}
function ScreenOBJ.ScreenPtr: pointer;
{}
begin
ScreenPtr := vScreenPtr;
end; {ScreenOBJ.ScrPtr}
procedure ScreenOBJ.Display;
{}
var
Wid,Dep:byte;
MVisible:boolean;
WinCoords: tByteCoords;
begin
{$IFNDEF FINAL}
Exists;
{$ENDIF}
MVisible := Mouse.Visible;
if MVisible then
Mouse.Hide;
if Width = Monitor^.Width then {one big move}
MoveToScreen(ScreenPtr^,Monitor^.BaseOfScreen^, width*Monitor^.Depth)
else
begin
Wid := Monitor^.Width;
if Wid > vWidth then
Wid := vWidth;
Dep := Monitor^.Depth;
if Dep > vDepth then
Dep := vDepth;
PartDisplay(1,1,Wid,Dep,1,1);
end;
{now restore cursor details}
Screen.GotoXY(WhereX,WhereY);
Screen.CursSize(CursTop,CursBot);
WindowCoords(WinCoords);
with WinCoords do
Screen.SetWindow(X1,Y1,X2,Y2);
if MVisible then (* Change to restore Mouse Details *)
Mouse.Show;
end; {ScreenOBJ.Display}
procedure ScreenOBJ.PartDisplay(X1,Y1,X2,Y2,X,Y:byte);
{}
var
MonitorWidth,
ScreenWidth,
SectionWidth : byte;
I : integer;
VisibleAdr,
VirtualAdr : word;
VisiblePtr,
VirtualPtr : pointer;
MVisible:boolean;
begin
if X2 > vWidth then
X2 := vWidth;
if Y2 > vDepth then
Y2 := vDepth;
SectionWidth := succ(X2- X1);
MonitorWidth := Monitor^.Width;
ScreenWidth := Width;
VirtualPtr := ScreenPtr;
VisiblePtr := Monitor^.BaseOfScreen;
MVisible := Mouse.Visible;
if MVisible then
Mouse.Hide;
For I := Y1 to Y2 do
begin
VisibleAdr := pred(Y+I-Y1)*MonitorWidth*2 + pred(X)*2;
VirtualAdr := pred(I)*ScreenWidth*2 + Pred(X1)*2;
MoveToScreen(Mem[Seg(VirtualPtr^):ofs(VirtualPtr^)+VirtualAdr],
Mem[Seg(VisiblePtr^):ofs(VisiblePtr^)+VisibleAdr],
Sectionwidth);
end;
if MVisible then
Mouse.Show;
end; {ScreenOBJ.PartDisplay}
procedure ScreenOBJ.PartSlideDisplay(X1,Y1,X2,Y2:byte;Way:tDirection);
{}
var
I : integer;
begin
Case Way of
Up : begin
for I := Y2 downto Y1 do
begin
PartDisplay(X1,Y1,X2,Y1+Y2-I,X1,I);
Delay(50);
end;
end;
Down : begin
for I := Y1 to Y2 do
begin
PartDisplay(X1,Y1+Y2 -I,X2,Y2,X1,Y1);
Delay(50); {savor the moment!}
end;
end;
Left : begin
for I := X1 to X2 do
begin
PartDisplay(X1,Y1,I,Y2,X1+X2-I,Y1);
end;
end;
Right : begin
for I := X2 downto X1 do
begin
PartDisplay(I,Y1,X2,Y2,X1,Y1);
end;
end;
Vert: for I := Y1 to Y1 + (Y2 - Y1) div 2 do
begin
PartDisplay(X1,I,X2,I,X1,I);
PartDisplay(X1,Y2+Y1-I,X2,Y2+Y1-I,X1,Y2+Y1-I);
Delay(50);
end;
Horiz: for I := X1 to X1 + succ(X2 -X1) div 2 do
begin
PartDisplay(I,Y1,I,Y2,I,Y1);
PartDisplay((X2)+X1-I,Y1,(X2)+X1-I,Y2,(X2)+X1-I,Y1);
Delay(10);
end;
end; {case}
end; {ScreenOBJ.PartSlideDisplay}
procedure ScreenOBJ.SlideDisplay(Way: tDirection);
{}
var
WinCoords: tByteCoords;
X,Y,Top,Bot : byte;
begin
X := Monitor^.Width;
if X > vWidth then
X := vWidth;
Y := Monitor^.Depth;
if Y > vDepth then
Y := vDepth;
PartSlideDisplay(1,1,X,Y,Way);
{now restore cursor details}
X := WhereX;
Y := WhereY;
Top := CursTop;
Bot := CursBot;
Screen.GotoXY(X,Y);
Screen.CursSize(Top,Bot);
WindowCoords(WinCoords);
with WinCoords do
Screen.SetWindow(X1,Y1,X2,Y2);
end; {ScreenOBJ.SlideDisplay}
procedure ScreenOBJ.PartSave (X1,Y1,X2,Y2:byte; VAR Dest);
{transfers data from active virtual screen to Dest}
var
I,wid : byte;
ScreenAdr: integer;
MVisible: boolean;
begin
wid := succ(X2- X1);
MVisible := Mouse.Visible;
if MVisible then
Mouse.Hide;
For I := Y1 to Y2 do
begin
ScreenAdr := Pred(I)*160 + Pred(X1)*2;
MoveFromScreen(Mem[seg(vScreenPtr^):ofs(vScreenPtr^)+ScreenAdr],
Mem[seg(Dest):ofs(dest)+(I-Y1)*wid*2],
wid);
end;
if MVisible then
Mouse.Show;
end; {ScreenOBJ.PartSave}
procedure ScreenOBJ.PartRestore (X1,Y1,X2,Y2:byte; VAR Source);
{restores data from Source and transfers to active virtual screen
- used internally}
var
I,wid : byte;
ScreenAdr: integer;
MVisible: boolean;
begin
wid := succ(X2- X1);
MVisible := Mouse.Visible;
if MVisible then
Mouse.Hide;
For I := Y1 to Y2 do
begin
ScreenAdr := Pred(I)*160 + Pred(X1)*2;
MoveToScreen(Mem[Seg(Source):ofs(Source)+(I-Y1)*wid*2],
Mem[seg(vScreenPtr^):ofs(vScreenPtr^)+ScreenAdr],
wid);
end;
if MVisible then
Mouse.Show;
end; {ScreenOBJ.PartRestore}
procedure ScreenOBJ.CopyScreenBlock(X1,Y1,X2,Y2,X,Y:byte);
{copies text and attributes from one part of screen to another}
Var
S : word;
SPtr : pointer;
MVisible: boolean;
begin
S := succ(Y2-Y1)*succ(X2-X1)*2;
If Maxavail < S then
Error(3)
else
begin
MVisible := Mouse.Visible;
if MVisible then
Mouse.Hide;
GetMem(SPtr,S);
PartSave(X1,Y1,X2,Y2,SPtr^);
PartRestore(X,Y,X+X2-X1,Y+Y2-Y1,SPtr^);
FreeMem(Sptr,S);
if MVisible then
Mouse.Show;
end;
end; {ScreenOBJ.CopyScreenBlock}
procedure ScreenOBJ.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
S : word;
SPtr : pointer;
I : Integer;
ST : string;
MVisible: boolean;
begin
S := succ(Y2-Y1)*succ(X2-X1)*2;
If Maxavail < S then
Error(3)
else
begin
MVisible := Mouse.Visible;
if MVisible then
Mouse.Hide;
GetMem(SPtr,S);
PartSave(X1,Y1,X2,Y2,SPtr^);
St := Replicate(succ(X2-X1),Replace_Char);
For I := Y1 to Y2 do
WritePlain(X1,I,St);
PartRestore(X,Y,X+X2-X1,Y+Y2-Y1,SPtr^);
FreeMem(Sptr,S);
if MVisible then
Mouse.Show;
end;
end; {ScreenOBJ.MoveScreenBlock}
procedure ScreenOBJ.Scroll(Way:tDirection;X1,Y1,X2,Y2:byte);
{used for screen scrolling, uses Copy & Plainwrite for speed}
const
Replace_Char = ' ';
var
I : integer;
begin
Case Way of
Up : begin
CopyScreenBlock(X1,succ(Y1),X2,Y2,X1,Y1);
WritePlain(X1,Y2,replicate(succ(X2-X1),Replace_Char));
end;
Down : begin
CopyScreenBlock(X1,Y1,X2,pred(Y2),X1,succ(Y1));
WritePlain(X1,Y1,replicate(succ(X2-X1),Replace_Char));
end;
Left : begin
CopyScreenBlock(succ(X1),Y1,X2,Y2,X1,Y1);
For I := Y1 to Y2 do
WritePlain(X2,I,Replace_Char);
end;
Right: begin
CopyScreenBlock(X1,Y1,pred(X2),Y2,succ(X1),Y1);
For I := Y1 to Y2 do
WritePlain(X1,I,Replace_Char);
end;
end; {case}
end; {ScreenOBJ.Scroll}
{||||||||||||||||||||||||||||||||||||}
{ S C R E E N W R I T E S }
{||||||||||||||||||||||||||||||||||||}
procedure ScreenOBJ.Write(Str:string);
{write at the cursor position using the default attributes, and
moves cursor to end of string}
var
X,Y:byte;
MVisible: boolean;
begin
{$IFNDEF FINAL}
Exists;
{$ENDIF}
MVisible := Mouse.Visible;
X := WhereX + pred(oWritePtr^.WinX);
Y := WhereY + pred(oWritePtr^.WinY);
if MVisible and Mouse.InZone(X,Y,X+length(Str),Y) then
begin
Mouse.Hide;
oWritePtr^.Write(Str);
Mouse.Show;
end
else
oWritePtr^.Write(Str);
end; {ScreenOBJ.Write}
procedure ScreenOBJ.WriteLn(Str:string);
{write at the cursor position using the default attributes, and
moves cursor to next line}
var
X,Y:byte;
MVisible: boolean;
begin
{$IFNDEF FINAL}
Exists;
{$ENDIF}
MVisible := Mouse.Visible;
X := WhereX+ pred(oWritePtr^.WinX);
Y := WhereY+ pred(oWritePtr^.WinY);
if MVisible and Mouse.InZone(X,Y,X+length(Str),Y) then
begin
Mouse.Hide;
oWritePtr^.WriteLn(Str);
Mouse.Show;
end
else
oWritePtr^.WriteLn(Str);
end; {ScreenOBJ.WriteLn}
procedure ScreenOBJ.WriteAT(X,Y,attr:byte;Str:string);
{}
var
MVisible: boolean;
GlobalX,GlobalY: byte;
begin
{$IFNDEF FINAL}
Exists;
{$ENDIF}
if Attr = 0 then
WritePlain(X,Y,Str)
else
begin
MVisible := Mouse.Visible;
GlobalX := X + pred(oWritePtr^.WinX);
GlobalY := Y + pred(oWritePtr^.WinY);
if MVisible and Mouse.InZone(GlobalX,GlobalY,GlobalX+length(Str),GlobalY) then
begin
Mouse.Hide;
oWritePtr^.WriteAT(X,Y,attr,Str);
Mouse.Show;
end
else
oWritePtr^.WriteAT(X,Y,attr,Str);
end;
end; {ScreenOBJ.WriteAT}
procedure ScreenOBJ.WriteHi(X,Y,AttrHi,Attr:byte;Str:string);
{}
var
P:byte;
Hi : Boolean;
procedure WriteBit(Str:string);
begin
if Hi then
WriteAt(X,Y,AttrHi,Str)
else
WriteAt(X,Y,Attr,Str);
end;
begin
Hi := False;
P := Pos(vHiMarker,Str);
While P <> 0 do
begin
if P > 1 then
WriteBit(copy(Str,1,pred(P)));
Delete(Str,1,P);
inc(X,pred(P));
P := Pos(vHiMarker,Str);
Hi := not Hi;
end;
WriteBit(Str);
end; {ScreenOBJ.WriteHi}
procedure ScreenOBJ.WritePlain(X,Y:byte;Str:string);
{}
var
MVisible: boolean;
GlobalX,GlobalY: byte;
begin
{$IFNDEF FINAL}
Exists;
{$ENDIF}
MVisible := Mouse.Visible;
GlobalX := X + pred(oWritePtr^.WinX);
GlobalY := Y + pred(oWritePtr^.WinY);
if MVisible and Mouse.InZone(GlobalX,GlobalY,GlobalX+length(Str),GlobalY) then
begin
Mouse.Hide;
oWritePtr^.WritePlain(X,Y,Str);
Mouse.Show;
end
else
oWritePtr^.WritePlain(X,Y,Str);
end; {ScreenOBJ.WritePlain}
procedure ScreenOBJ.WriteCap(X,Y,AttrCap,Attr:byte;Str:string);
{Writes a string with the first capital letter in a different color}
var
CapPos : byte;
begin
If Str <> '' then
begin
WriteAt(X,Y,Attr,Str); {write whole string in default cols}
CapPos := 1;
While (CapPos <= length(Str))
and ((Str[CapPos] in [#65..#90]) = false) do
inc(CapPos);
If CapPos <= length(Str) then
WriteAt(X + pred(CapPos),Y,AttrCap,Str[CapPos]);
end;
end; {ScreenOBJ.WriteCap}
procedure ScreenOBJ.WriteClick(X,Y,attr:byte;Str:string);
{writes text to the screen with a click!}
var
I : Integer;
L : byte;
begin
L := length(Str);
If OnScreen then
for I := L downto 1 do
begin
WriteAt(X,Y,Attr,copy(Str,I,succ(L-I)));
sound(500);delay(20);nosound;delay(30);
end
else
WriteAt(X,Y,attr,Str); {don't click if not visible}
end; {ScreenOBJ.WriteClick}
procedure ScreenOBJ.WriteCenter(Y,Attr:byte;Str:string);
{}
var
X1,Y1,X2,Y2: byte;
X : integer;
begin
if oWritePtr^.WindowActive then
begin
oWritePtr^.GetWinCoords(X1,Y1,X2,Y2);
X := (succ(X2-X1) - length(Str)) div 2;
end
else
X := (Width - length(Str)) div 2;
if X < 1 then
X := 1;
WriteAt(X,Y,attr,Str);
end; {ScreenOBJ.WriteCenter}
procedure ScreenOBJ.WriteBetween(X1,X2,Y,Attr:byte;Str:string);
{}
var X : integer;
begin
if length(Str) >= X2 - X1 + 1 then
WriteAt(X1,Y,attr,Str)
else
begin
X := X1 + (X2 - X1 + 1 - length(Str)) div 2 ;
WriteAt(X,Y,attr,Str);
end;
end; {ScreenOBJ.WriteBetween}
procedure ScreenOBJ.WriteRight(X,Y,Attr:byte;Str:string);
{writes a right-justified string to the screen}
var X1 : integer;
begin
X1 := succ(X-length(Str));
if X1 < 1 then
X1 := 1;
WriteAT(X1,Y,attr,Str);
end; {ScreenOBJ.WriteRight}
procedure ScreenOBJ.WriteVert(X,Y,Attr:byte;Str:string);
{}
var
L: byte;
I: integer;
begin
L := length(Str);
If L > succ(Monitor^.Depth) - Y then
L := succ(Monitor^.Depth) - Y;
for I := 1 to L do
WriteAt(X,Y-1+I,attr,Str[I]);
end; {ScreenOBJ.WriteVert}
procedure ScreenOBJ.Attrib(X1,Y1,X2,Y2,Attr:byte);
{changes color attrib at specified coords}
var
I: integer;
X: byte;
MVisible: boolean;
begin
{$IFNDEF FINAL}
Exists;
{$ENDIF}
MVisible := Mouse.Visible;
if MVisible then
Mouse.Hide;
X := Succ(X2-X1);
for I := Y1 to Y2 do
oWritePtr^.ChangeAttr(X1,I,Attr,X);
if MVisible then
Mouse.Show;
end; {ScreenOBJ.Attrib}
procedure ScreenOBJ.Clear(Att:byte;Ch:char);
{}
begin
PartClear(1,1,Width,Depth,Att,Ch);
end; {ScreenOBJ.Clear}
procedure ScreenOBJ.PartClear(X1,Y1,X2,Y2,Att:byte;Ch:char);
{}
var
I : integer;
S : string;
begin
Attrib(X1,Y1,X2,Y2,Att);
S := Replicate(Succ(X2-X1),Ch);
for I := Y1 to Y2 do
WritePlain(X1,I,S);
end; {ScreenOBJ.PartClear}
procedure ScreenOBJ.ClearText(X1,Y1,X2,Y2:byte);
{}
var
I : integer;
S : string;
begin
S := Replicate(Succ(X2-X1),' ');
for I := Y1 to Y2 do
WritePlain(X1,I,S);
end; {ScreenOBJ.ClearText}
procedure ScreenOBJ.ReadWord(X,Y:byte;var Attr:byte; var Ch : char);
{updates vars Attr and Ch with attribute and character bytes in screen
location (X,Y) of the active screen}
Type
ScreenWordRec = record
Ch : char;
Attr : byte;
end;
var
VisiblePtr: pointer;
VisibleAdr : word;
SW : ScreenWordRec;
begin
X := X + pred(oWritePtr^.WinX);
Y := Y + pred(oWritePtr^.WinY);
VisiblePtr := Monitor^.BaseOfScreen;
VisibleAdr := pred(Y)*Monitor^.Width*2 + pred(X)*2;
MoveFromScreen(mem[Seg(VisiblePtr^):ofs(VisiblePtr^)+VisibleAdr],
mem[seg(SW):ofs(SW)],1);
Attr := SW.Attr;
Ch := SW.Ch;
end; {ScreenOBJ.ReadWord}
function ScreenOBJ.ReadChar(X,Y:byte):char;
var
A : byte;
C : char;
begin
ReadWord(X,Y,A,C);
ReadChar := C;
end; {ScreenOBJ.ReadChar}
function ScreenOBJ.ReadAttr(X,Y:byte):byte;
var
A : byte;
C : char;
begin
ReadWord(X,Y,A,C);
ReadAttr := A;
end; {ScreenOBJ.ReadAttr}
function ScreenOBJ.ReadStr(X1,X2,Y:byte):string;
var
I : integer;
Str: string;
begin
Str := '';
for I := X1 to X2 do
Str := Str + ReadChar(I,Y);
ReadStr := Str;
end; {ScreenOBJ.ReadStr}
procedure ScreenOBJ.TitleEngine(X1,Y1,X2,Y2,LeftPad,RightPad,Battr,Tattr:byte;
Str, Title: string);
{}
var
TitVert: byte; {0-top, 1-dropbox, 2-bottom}
TitHoriz:byte; {0-left, 1-center, 2-right}
MaxWidth:integer;
X,Y : byte;
begin
if (Title[2] in [TitPos[1],TitPos[2],TitPos[3]])
and (Title[1] in [TitPos[4],TitPos[5],TitPos[6]]) then {swap 'em}
begin
insert(Title[2],Title,1);
delete(Title,3,1);
end;
if Title[1] = TitPos[1] then
TitHoriz := 0
else if Title[1] = TitPos[3] then
TitHoriz := 2
else
TitHoriz := 1;
if Title[1] in [TitPos[1],TitPos[2],TitPos[3]] then
delete(Title,1,1);
if Title = '' then exit;
if (Title[1] = TitPos[5]) and (Y2-Y1 > 1) then
TitVert := 1
else if Title[1] = TitPos[6] then
TitVert := 2
else
TitVert := 0;
if Title[1] in [TitPos[4],TitPos[5],TitPos[6]] then
delete(Title,1,1);
if Title = '' then exit;
{check title is narrow enough to fit}
if TitVert = 1 then
MaxWidth := pred(X2-X1)
else
MaxWidth := X2-X1-3;
if TitVert = 0 then
dec(MaxWidth,LeftPad+RightPad);
if MaxWidth <= 0 then
Title := ''
else
delete(Title,succ(MaxWidth),255); {truncate title}
Case Titvert of
0: begin
Case TitHoriz of
0 : WriteAt(succ(X1)+LeftPad,Y1,Tattr,Title);
1 : WriteBetween(succ(X1)+LeftPad,pred(X2)-RightPad,y1,Tattr,Title);
else WriteRight(pred(X2)-RightPad,Y1,Tattr,Title);
end; {case}
end;
1: begin
WriteAt(X1,Y1+2,Battr,str[8]+
replicate(pred(X2-X1),str[2])+
Str[5]);
Case TitHoriz of
0 : WriteAt(succ(X1),succ(Y1),Tattr,Title);
1 : WriteBetween(X1,X2,succ(y1),Tattr,Title);
else WriteRight(pred(X2),succ(Y1),Tattr,Title);
end; {case}
end;
2: begin
Case TitHoriz of
0 : WriteAt(succ(X1),Y2,Tattr,Title);
1 : WriteBetween(X1,X2,Y2,Tattr,Title);
else WriteRight(pred(X2),Y2,Tattr,Title);
end; {case}
end;
end; {case}
end; {ScreenOBJ.TitleEngine}
procedure ScreenOBJ.BoxEngine(X1,Y1,X2,Y2,LeftPad,RightPad,Battr,Tattr,MAttr,style:byte;
Filled: boolean;
Title: string);
{Used internally by Box and FBox}
const
Style1:string[10] = '┌─┐│┤┘└├│─';
Style2:string[10] = '╔═╗║╣╝╚╠║═';
Style3:string[10] = '╓─╖║╢╜╙╟║─';
Style4:string[10] = '╒═╕│╡╛╘╞│═';
Style5:string[10] = '┌─╖│╡╝╘╞║═';
var
Line,
FLine,
Str: string;
I: integer;
begin
if Style = 6 then
begin
PartClear(X1,Y1,X2,Y2,Mattr,' ');
WriteAT(X1,Y1,BAttr,replicate(X2-pred(X1),char(223)));
WriteAT(X1,Y1+2,BAttr,replicate(X2-pred(X1),'_'));
WriteBetween(X1,X2,succ(Y1),Tattr,Title);
end
else
begin
case Style of
0 : Str := ' ';
1 : Str := Style1;
2 : Str := Style2;
3 : Str := Style3;
4 : Str := Style4;
5 : Str := Style5;
else Str := Replicate(10,chr(style));
end;
WriteAt(X1,Y1,Battr,Str[1]);
Line := replicate(pred(X2-X1),Str[2]);
WriteAt(X1+1,Y1,Battr,Line);
WriteAt(X2,Y1,Battr,Str[3]);
for I := Y1+1 to Y2-1 do
begin
WriteAt(X1,I,Battr,Str[4]);
WriteAt(X2,I,Battr,Str[9]);
end;
if Filled then
PartClear(succ(X1),succ(Y1),pred(X2),pred(Y2),MAttr,' ');
WriteAt(X1,Y2,Battr,Str[7]);
Line := replicate(pred(X2-X1),Str[10]);
WriteAt(X1+1,Y2,Battr,Line);
WriteAt(X2,Y2,Battr,Str[6]);
{now the title: extract the first two character positions, and draw it}
if Title <> '' then
TitleEngine(X1,Y1,X2,Y2,LeftPad,RightPad,Battr,Tattr,Str,Title);
end;
end; {BoxEngine}
procedure ScreenOBJ.Box(X1,Y1,X2,Y2,attr,style:byte);
{draws box and leaves internal area as is}
begin
BoxEngine(X1,Y1,X2,Y2,0,0,attr,attr,attr,Style,false,'');
end; {ScreenOBJ.Box}
procedure ScreenOBJ.FillBox(X1,Y1,X2,Y2,attr,style:byte);
{draws box and erases internal area}
begin
BoxEngine(X1,Y1,X2,Y2,0,0,attr,attr,attr,Style,true,'');
end; {ScreenOBJ.FillBox}
procedure ScreenOBJ.ShadFillBox(X1,Y1,X2,Y2,attr,style:byte);
{draws box and erases internal area}
begin
BoxEngine(X1,Y1,X2,Y2,0,0,attr,attr,attr,Style,true,'');
ShadowTOT^.DrawShadowXY(X1,Y1,X2,Y2);
end; {ScreenOBJ.ShadFillBox}
procedure ScreenOBJ.TitledBox(X1,Y1,X2,Y2,Battr,Tattr,MAttr,style:byte;Title:string);
{}
begin
BoxEngine(X1,Y1,X2,Y2,0,0,Battr,Tattr,MAttr,Style,true,title);
end; {ScreenOBJ.TitledFillBox}
procedure ScreenOBJ.HorizLine(X1,X2,Y,Attr,Style : byte);
var
I : integer;
LineChar : char;
begin
case Style of
0 : LineChar := ' ';
2,4 : LineChar := '═';
1,3 : LineChar := '─';
else LineChar := Chr(Style);
end; {case}
WriteAt(X1,Y,Attr,replicate(X2-X1+1,LineChar))
end; {ScreenOBJ.HorizLine}
procedure ScreenOBJ.VertLine(X,Y1,Y2,Attr,Style:byte);
{}
var
I : integer;
LineChar : char;
begin
case Style of
0 : LineChar := ' ';
2,4 : LineChar := '║';
1,3 : LineChar := '│';
else LineChar := Chr(Style);
end; {case}
for I := Y1 to Y2 do
WriteAt(X,I,Attr,LineChar)
end; {ScreenOBJ.VertLine}
procedure ScreenOBJ.SmartVertLine(X,Y1,Y2,Attr,Style:byte);
{draws box character and adjust any lines it overlays}
var
I : integer;
LineStr : string[19];
TestCh,
Ch : char;
StringOffset : byte;
function AdjacentChar(X,Y:byte): char;
{}
begin
if (X < 1) or (X > width) then
AdjacentChar := ' '
else
AdjacentChar := ReadChar(X,Y);
end; {AdjacentChar}
function LineCh(X,Y:byte): char;
{}
const
LeftSingle: string[13] = '─┬┐┼┤┴┘╥╖╫╢╨╜';
LeftDouble: string[13] = '═╦╗╬╣╩╝╤╕╪╡╧╛';
RightSingle:string[13] = '┌─┬├┼└┴╓╥╟╫╙╨';
RightDouble:string[13] = '╔═╦╠╬╚╩╒╤╞╪╘╧';
var
LineStyle : char;
begin
LineStyle := AdjacentChar(pred(X),Y);
if pos(LineStyle,RightSingle) > 0 then
LineStyle := '─'
else if pos(LineStyle,RightDouble) > 0 then
LineStyle := '═'
else
LineStyle := ' ';
case LineStyle of
'─': if pos(AdjacentChar(succ(X),Y),leftSingle) > 0 then
Ch := LineStr[2+StringOffset]
else
Ch := LineStr[3+StringOffset];
'═': if pos(AdjacentChar(succ(X),Y),LeftDouble) > 0 then
Ch := LineStr[4+StringOffset]
else
Ch := LineStr[5+StringOffset];
else TestCh := AdjacentChar(succ(X),Y);
If pos(TestCh,LeftSingle) > 0 then
Ch := LineStr[6+StringOffset]
else if pos(TestCh,LeftDouble) > 0 then
Ch := LineStr[7+StringOffset]
else
Ch := LineStr[1];
end; {case}
LineCh := Ch;
end; {LineCh}
begin
if Style in [2,4] then
LineStr := '║╥╖╦╗╓╔╫╢╬╣╟╠╨╜╩╝╙╚'
else
LineStr := '│┬┐╤╕┌╒┼┤╪╡├╞┴┘╧╛└╘';
{draw first character}
StringOffSet := 0;
WriteAt(X,Y1,attr,LineCh(X,Y1));
StringOffSet := 6;
for I := succ(Y1) to pred(Y2) do
WriteAt(X,I,attr,LineCh(X,I));
StringOffSet := 12;
WriteAt(X,Y2,attr,LineCh(X,Y2));
end; {ScreenOBJ.SmartVertLine}
procedure ScreenOBJ.SmartHorizLine(X1,X2,Y,Attr,Style:byte);
{draws box character and adjust any lines it overlays}
var
I : integer;
LineStr : string[19];
TestCh,
Ch : char;
StringOffset : byte;
function AdjacentChar(X,Y:byte): char;
{}
begin
if (Y < 1) or (Y > depth) then
AdjacentChar := ' '
else
AdjacentChar := ReadChar(X,Y);
end; {AdjacentChar}
function LineCh(X,Y:byte): char;
{}
const
DownSingle: string[13] = '┌┬┐│├┼┤╒╤╕╞╪╡';
DownDouble: string[13] = '╔╦╗║╠╬╣╓╥╖╟╫╢';
UpSingle: string[13] = '│├┼┤└┴┘╞╪╡╘╧╛';
UpDouble: string[13] = '║╠╬╣╚╩╝╟╫╢╙╨║';
var
LineStyle : char;
begin
LineStyle := AdjacentChar(X,pred(Y));
If pos(LineStyle,DownSingle) > 0 then
LineStyle := '│'
else if pos(LineStyle,DownDouble) > 0 then
LineStyle := '║'
else
LineStyle := ' ';
case LineStyle of
'│': if pos(AdjacentChar(X,succ(Y)),UpSingle) > 0 then
Ch := LineStr[2+StringOffset]
else
Ch := LineStr[3+StringOffset];
'║': if pos(AdjacentChar(X,succ(Y)),UpDouble) > 0 then
Ch := LineStr[4+StringOffset]
else
Ch := LineStr[5+StringOffset];
else TestCh := AdjacentChar(X,succ(Y));
If pos(TestCh,UpSingle) > 0 then
Ch := LineStr[6+StringOffset]
else if pos(TestCh,UpDouble) > 0 then
Ch := LineStr[7+StringOffset]
else
Ch := LineStr[1];
end; {case}
LineCh := Ch;
end; {LineCh}
begin
if Style in [2,4] then
LineStr := '═╞╘╠╚╒╔╪╧╬╩╤╦╡╛╣╝╕╗ '
else
LineStr := '─├└╟╙┌╓┼┴╫╨┬╥┤┘╢╜┐╖';
{draw first character}
StringOffSet := 0;
WriteAt(X1,Y,attr,LineCh(X1,Y));
StringOffSet := 6;
for I := succ(X1) to pred(X2) do
WriteAt(I,Y,attr,LineCh(I,Y));
StringOffSet := 12;
WriteAt(X2,Y,attr,LineCh(X2,Y));
end; {ScreenOBJ.SmartHorizLine}
procedure ScreenOBJ.WriteHScrollBar(X1,X2,Y,Attr: byte; Current,Max: longint);
{}
var
X,LineLength : integer;
begin
WriteAT(X1,Y,Attr,ScrollTOT^.LeftChar);
WriteAT(X2,Y,Attr,ScrollTOT^.RightChar);
WriteAT(succ(X1),Y,Attr,replicate(pred(X2-X1),ScrollTOT^.BackgroundChar));
if (Current > 0) and (Max >= Current) then
begin
LineLength := X2 - succ(X1);
if LineLength > 0 then
begin
X := (Current * LineLength) div Max;
if Current >= Max then
X := pred(LineLength);
if (X < 0) or (Current = 1) then
X := 0;
WriteAT(succ(X1) + X,Y,Attr,ScrollTOT^.ElevatorChar);
end;
end;
end; {ScreenOBJ.WriteHScrollBar}
procedure ScreenOBJ.WriteVScrollBar(X,Y1,Y2,Attr: byte; Current,Max: longint);
{}
var
BC : char;
I,Y,LineLength : integer;
begin
WriteAT(X,Y1,Attr,ScrollTOT^.UpChar);
WriteAT(X,Y2,Attr,ScrollTOT^.DownChar);
BC := ScrollTOT^.BackgroundChar;
for I := succ(Y1) to pred(Y2) do
WriteAT(X,I,Attr,BC);
if (Current > 0) and (Max >= Current) then
begin
LineLength := Y2 - succ(Y1);
if LineLength > 0 then
begin
Y := (Current * LineLength) div Max;
if Current >= Max then
Y := pred(LineLength);
if (Y < 0) or (Current = 1) then
Y := 0;
WriteAT(X,succ(Y1)+Y,Attr,ScrollTOT^.ElevatorChar);
end;
end;
end; {ScreenOBJ.WriteVScrollBar}
destructor ScreenOBJ.Done;
{}
var MemoryUsed: longint;
begin
If not OnScreen then
begin
MemoryUsed := Width*Depth*2;
freemem(vScreenPtr,MemoryUsed);
dispose(oWritePtr,Done);
end;
end; {ScreenOBJ.Done}
{|||||||||||||||||||||||||||||||||||||||||||}
{ }
{ S c r o l l O B J M E T H O D S }
{ }
{|||||||||||||||||||||||||||||||||||||||||||}
constructor ScrollOBJ.Init;
{}
begin
SetDefaults;
end; {ScrollOBJ.Init}
procedure ScrollOBJ.SetDefaults;
{}
begin
SetScrollChars('','',char(27),char(26),'','░');
end; {of ScrollOBJ.SetDefaults}
procedure ScrollOBJ.SetScrollChars(U,D,L,R,E,B:char);
{}
begin
vUpArrowChar := U;
vDownArrowChar := D;
vLeftArrowChar := L;
vRightArrowChar := R;
vElevatorChar := E;
vBackgroundChar := B;
end; {of ScrollOBJ.SetScrollChars}
function ScrollOBJ.UpChar:char;
{}
begin
UpChar := vUpArrowChar;
end; {ScrollOBJ.UpChar}
function ScrollOBJ.DownChar:char;
{}
begin
DownChar := vDownArrowChar;
end; {ScrollOBJ.DownChar}
function ScrollOBJ.LeftChar:char;
{}
begin
LeftChar := vLeftArrowChar;
end; {ScrollOBJ.LeftChar}
function ScrollOBJ.RightChar:char;
{}
begin
RightChar := vRightArrowChar;
end; {ScrollOBJ.RightChar}
function ScrollOBJ.ElevatorChar:char;
{}
begin
ElevatorChar := vElevatorChar;
end; {ScrollOBJ.ElevatorChar}
function ScrollOBJ.BackgroundChar:char;
{}
begin
BackgroundChar := vBackgroundChar;
end; {ScrollOBJ.BackgroundChar}
destructor ScrollOBJ.Done;
begin end;
{|||||||||||||||||||||||||||||||||||||||||||}
{ }
{ S h a d o w O B J M E T H O D S }
{ }
{|||||||||||||||||||||||||||||||||||||||||||}
constructor ShadowOBJ.Init;
{}
begin
SetDefaults;
end; {ShadowOBJ.Init}
procedure ShadowOBJ.SetDefaults;
{}
begin
vShadWidth := 2;
vShadDepth := 1;
vShadPos := DownRight;
vShadAttr := 7;
vShadChar := ' ';
end; {ShadowOBJ.SetDefaults}
procedure ShadowOBJ.DrawShadow(Border:tCoords);
{}
var
Outer: tCoords;
procedure DrawPartofShadow(X1,Y1,X2,Y2:byte);
begin
if (X1 > X2) or (Y1 > Y2) then exit;
if vShadChar = ' ' then {attribute change}
Screen.Attrib(X1,Y1,X2,Y2,vShadAttr)
else
Screen.PartClear(X1,Y1,X2,Y2,vShadAttr,vShadChar);
end; {of sub proc DrawPartofShadow}
begin
OuterCoords(Border,Outer);
case vShadPos of
UpLeft: begin
DrawPartofShadow(Outer.X1,Outer.Y1,pred(Border.X1),Border.Y2-vShadDepth);
DrawPartofShadow(Border.X1,Outer.Y1,Border.X2-vShadWidth,pred(Border.Y1));
end;
UpRight: begin
DrawPartofShadow(Border.X1+vShadWidth,Outer.Y1,Outer.X2,pred(Border.Y1));
DrawPartofShadow(succ(Border.X2),Border.Y1,Outer.X2,Border.Y2-vShadDepth);
end;
DownLeft: begin
DrawPartofShadow(Outer.X1,Border.Y1+vShadDepth,pred(Border.X1),Outer.Y2);
DrawPartofShadow(Border.X1,succ(Border.Y2),Border.X2-vShadWidth,Outer.Y2);
end;
DownRight:begin
DrawPartofShadow(Border.X1+vShadWidth,succ(Border.Y2),Outer.X2,Outer.Y2);
DrawPartofShadow(succ(Border.X2),Border.Y1+vShadDepth,Outer.X2,Border.Y2);
end;
end; {case}
end; {ShadowOBJ.DrawShadow}
procedure ShadowOBJ.DrawShadowXY(X1,Y1,X2,Y2:integer);
{}
var
Border: tCoords;
begin
Border.X1 := X1;
Border.Y1 := Y1;
Border.X2 := X2;
Border.Y2 := Y2;
DrawShadow(Border);
end; {ShadowOBJ.DrawShadowXY}
procedure ShadowOBJ.SetShadowStyle(ShadP:ShadowPosition; ShadA:byte; ShadC:char);
{}
begin
vShadPos := ShadP;
vShadAttr := ShadA;
vShadChar := ShadC;
end; {ShadowOBJ.SetShadowStyle}
procedure ShadowOBJ.SetShadowSize(ShadW,ShadD:byte);
{}
begin
vShadWidth := ShadW;
vShadDepth := ShadD;
end; {ShadowOBJ.SetShadowSize}
function ShadowOBJ.ShadWidth: byte;
{}
begin
ShadWidth := vShadWidth;
end; {ShadowOBJ.ShadWidth}
function ShadowOBJ.ShadDepth: byte;
{}
begin
ShadDepth := vShadDepth;
end; {ShadowOBJ.ShadDepth}
function ShadowOBJ.ShadAttr: byte;
{}
begin
ShadAttr := vShadAttr;
end; {ShadowOBJ.ShadAttr}
function ShadowOBJ.ShadChar: char;
{}
begin
ShadChar := vShadChar;
end; {ShadowOBJ.ShadChar}
function ShadowOBJ.ShadPos: ShadowPosition;
{}
begin
ShadPos := vShadPos;
end; {ShadowOBJ.ShadPos}
procedure ShadowOBJ.OuterCoords(Border:tCoords;var Outer:tCoords);
{}
begin
Case vShadPos of
UpLeft: begin
Outer.X1 := Border.X1-vShadWidth;
Outer.Y1 := Border.Y1-vShadDepth;
Outer.X2 := Border.X2;
Outer.Y2 := Border.Y2;
end;
UpRight: begin
Outer.X1 := Border.X1;
Outer.Y1 := Border.Y1-vShadDepth;
Outer.X2 := Border.X2+vShadWidth;
Outer.Y2 := Border.Y2;
end;
DownLeft: begin
Outer.X1 := Border.X1-vShadWidth;
Outer.Y1 := Border.Y1;
Outer.X2 := Border.X2;
Outer.Y2 := Border.Y2+vShadDepth;
end;
DownRight:begin
Outer.X1 := Border.X1;
Outer.Y1 := Border.Y1;
Outer.X2 := Border.X2+vShadWidth;
Outer.Y2 := Border.Y2+vShadDepth;
end;
end; {case}
if Outer.X1 < 1 then Outer.X1 := 1;
if Outer.Y1 < 1 then Outer.Y1 := 1;
if Outer.X2 > Screen.Width then Outer.X2 := Screen.Width;
if Outer.Y2 > Screen.Depth then Outer.Y2 := Screen.Depth;
end; {ShadowOBJ.OuterCoords}
procedure ShadowOBJ.OuterXY(var X1,Y1,X2,Y2: integer);
{}
var Temp1,Temp2:tCoords;
begin
Temp1.X1 := X1;
Temp1.Y1 := Y1;
Temp1.X2 := X2;
Temp1.Y2 := Y2;
OuterCoords(Temp1,Temp2);
X1 := Temp2.X1;
Y1 := Temp2.Y1;
X2 := Temp2.X2;
Y2 := Temp2.Y2;
end; {ShadowOBJ.OuterXY}
destructor ShadowOBJ.Done;
begin end;
{|||||||||||||||||||||||||||||||||||||||||||||||}
{ }
{ U N I T I N I T I A L I Z A T I O N }
{ }
{|||||||||||||||||||||||||||||||||||||||||||||||}
procedure FastInit;
{initilizes objects and global variables}
begin
Screen.Init;
Screen.Create(0,0,0);
new(ScrollTOT,Init);
new(ShadowTOT,Init);
end; {FastInit}
{end of unit - add intialization routines below}
{$IFNDEF OVERLAY}
begin
FastInit;
{$ENDIF}
end.