[Back to TEXTWNDW SWAG index] [Back to Main SWAG index] [Original]
Unit TextWin;
{
ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ
ÛÛÛÝÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÞÛÛÛ±±
ÛÛÛÝÛÛ ÛÛÞÛÛÛ±±
ÛÛÛÝÛÛ Textual windows unit ÛÛÞÛÛÛ±±
ÛÛÛÝÛÛ ÛÛÞÛÛÛ±±
ÛÛÛÝÛÛ Aleksandar Dlabac ÛÛÞÛÛÛ±±
ÛÛÛÝÛÛ (C) 1992. Dlabac Bros. Company ÛÛÞÛÛÛ±±
ÛÛÛÝÛÛ ------------------------------ ÛÛÞÛÛÛ±±
ÛÛÛÝÛÛ adlabac@urcpg.urc.cg.ac.yu ÛÛÞÛÛÛ±±
ÛÛÛÝÛÛ adlabac@urcpg.pmf.cg.ac.yu ÛÛÞÛÛÛ±±
ÛÛÛÝÛÛ ÛÛÞÛÛÛ±±
ÛÛÛÝßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÞÛÛÛ±±
ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ±±
±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
}
Interface
Uses Crt, Dos;
Type TextMem = array [1..80,1..25] of Record
Char, Attr : byte
End;
MenuInfo = Record
Border, Text, Bar, Hot : byte
End;
Const MaxWindow = 10;
MaxDepth = 5;
Save = True; DontSave = False;
LeftUp = 0; RightUp = 1; LeftDown = 2; RightDown = 3;
ActivW : byte = 0;
ESC = #27; Up = #72; Down = #80; CR = #13;
BAKSP = #8; Home = #71; Endt = #79; Empty = #255;
Var MaxX, MaxY : integer;
TextModeInfo : Record
Adress : word;
Wid : byte;
CharH : byte
End;
Function InKey : char;
{ InKey is similar to ReadKey, but do not wait if key is not pressed, in
which case returns value "Empty" (#255). }
Function Attribute (Color,Background:byte) : byte;
{ Returns corresponding attribute for given color and backgroung. }
Procedure TestTextMode;
{ Gets informations about current text mode: number of collumns and
video address segment. }
Procedure HideCursor;
{ Make cursor invisible. }
Procedure ShowCursor;
{ Make cursor visible. }
Function GetChar (X,Y:byte) : byte;
{ Returns ASCII code of character at screen position (X,Y) }
Function GetAttr (X,Y:byte) : byte;
{ Returns attributes of character at screen position (X,Y) }
Procedure PutChar (X,Y,Char,Attr:byte);
{ Puts character on screen. Parameters are:
X, Y - Screen coordinates where character will be placed.
Char - ASCII code of character to write.
Attr - Attribute of character to write. }
Procedure GetScrPart (X,Y,W,H:integer; var A:TextMem);
{ Stores a part of screen to buffer. Parameters are:
X, Y - Coordinates of upper left corner of rectangular area to
be stored.
W, H - Width and height of rectangular area to be sotred,
respectivelly.
A - Buffer variable. }
Procedure PutScrPart (X,Y,W,H:integer; A:TextMem);
{ Restores a part of screen from buffer. Parameters are the same as
in procedure GetScrPart. }
Procedure TextRectangle (X,Y,W,H,Attr:byte);
{ Draws a rectangle. Parameters are:
X, Y - Coordinates of upper left corner of rectangle.
W, H - Width and height of rectangle, respectivelly. }
Function AvailableWindow : byte;
{ AvailableWindow returns Number of first available window handle }
Procedure OpenWindow (Wn:byte; X,Y,W,H:integer; Attr:byte; SaveFlg:Boolean);
{ Opens a new window. Parameters are:
Wn - window handle (0-MaxWindow) of new window. There must not be
another window with same handle. Recomended use od
AvailableWindow function.
X, Y - Coordinates of upper left corner of window.
W, H - Width and height of window.
Attr - Atributes of window border. Color inside window will be the
same color settled by TextColor/TextBackground procedures.
SaveFlg - If set to True content of screen will be restored after
closing this window. }
Procedure ActiveWindow (Wn:byte);
{ Sets active window to window which handle is Ws.
WARNING: Should not be used if there is overlaped windows (except 0).
Should be used for latest opened window only.}
Procedure CloseWindow;
{ Closes active window }
Procedure MoveWindow (Wn:byte; X,Y:integer);
{ Moves window Wn to new coordinate (X,Y) }
Procedure OpenMenu (X,Y:integer; Corn:byte; Menu:string; var Answer:byte; Info:MenuInfo);
{ OpenMenu opens a menu. Parameters are:
X, Y - Coordinates of one corner.
Corn - Defines which corner is given by (X,Y). Values of Corn can be
LeftUp, RightUp, LeftDown, RightDown.
Menu - String containing menu items. Items should be separated by
comma (","). Maximum "MaxOpt" (20) options allowed. For
example if Menu='First,Second,tHird', menu on screen will
have three options:
First
Second
tHird
First upper case in option is hotkey. Pressing "H" key when
menu is oppened will cause selecting of third option.
Answer - If nonzero returns Number of selecter option, otherwise
ESC taster is pressed, or clicked outside of the menu.
Info - Menu color informations. }
Procedure OpenBox (X,Y,W,H,Corn,Attr:byte);
{ Opens a temporary window (for messages, for example) with single border.
Parameters are:
X, Y, Corn - Same like in OpenMenu.
W, H - Width and height of box.
Attr - atributes of box. }
Procedure CloseTemp;
{ Closes temporary window }
Implementation
Const Depth : shortint = -1;
Var Windat : array [0..MaxWindow] of Record
Open, SaveFlag : Boolean;
Xw, Yw, Ww, Hw,
Xcur, Ycur : integer;
TextBit : TextMem;
PrevWind : byte
End;
Gd, Gm : integer;
Function InKey : char;
Var T : char;
Begin
If KeyPressed then T:=ReadKey else T:=Empty;
InKey:=T
End;
Function Attribute (Color,Background:byte) : byte;
Begin
Attribute:=Background shl 4+Color and $0F
End;
Procedure TestTextMode;
Begin
With TextModeInfo do
Begin
If Mem [$0000:$0449]=7 then Adress:=$B000
else Adress:=$B800;
Case Mem [$0000:$0449] of
0, 1 : Wid:=40;
2, 3, 7 : Wid:=80;
else Wid:=0
End;
CharH:=Mem [$0000:$0485]
End
End;
Procedure HideCursor;
Var Regs : registers;
Begin
With Regs do
Begin
AH:=01;
CH:=$20;
CL:=$20
End;
Intr ($10,Regs)
End;
Procedure ShowCursor;
Var Regs : registers;
Begin
With Regs do
Begin
AH:=01;
CH:=TextModeInfo.CharH-3;
CL:=TextModeInfo.CharH-2
End;
Intr ($10,Regs)
End;
Function GetChar (X,Y:byte) : byte;
Begin
GetChar:=Mem [TextModeInfo.Adress:((Y-1)*80+X-1)*2]
End;
Function GetAttr (X,Y:byte) : byte;
Begin
GetAttr:=Mem [TextModeInfo.Adress:((Y-1)*80+X-1)*2+1]
End;
Procedure PutChar (X,Y,Char,Attr:byte);
Begin
Mem [TextModeInfo.Adress:((Y-1)*80+X-1)*2]:=Char;
Mem [TextModeInfo.Adress:((Y-1)*80+X-1)*2+1]:=Attr
End;
Procedure GetScrPart (X,Y,W,H:integer; var A:TextMem);
Var I, J : integer;
Begin
Dec (W);
Dec (H);
For I:=1 to 80 do
For J:=1 to 25 do
Begin
A [I,J].Char:=0; A [I,J].Attr:=0
End;
With TextModeInfo do
Begin
If (X<=Wid) and (Y<=25) then
Begin
If X+W>Wid then W:=Wid-X;
If Y+H>25 then H:=25-Y;
For I:=Y to Y+H do
For J:= X to X+W do
With A [J-X+1,I-Y+1] do
Begin
Char:=GetChar (J,I);
Attr:=GetAttr (J,I);
End
End
End
End;
Procedure PutScrPart (X,Y,W,H:integer; A:TextMem);
Var I, J : integer;
Begin
Dec (W);
Dec (H);
With TextModeInfo do
Begin
If (X<=Wid) and (Y<=25) then
Begin
If X+W>Wid then W:=Wid-X;
If Y+H>25 then H:=25-Y;
For I:=Y to Y+H do
For J:= X to X+W do
With A [J-X+1,I-Y+1] do
PutChar (J,I,Char,Attr)
End
End
End;
Procedure TextRectangle (X,Y,W,H,Attr:byte);
Var I : integer;
Begin
If X<1 then X:=1;
If Y<1 then Y:=1;
If W<0 then
Begin
W:=-W; Dec (X,W);
End;
If H<0 then
Begin
H:=-H; Dec (Y,H);
End;
If (X<1) or (Y<1) or (W<2) or (H<2) or
(W>TextModeInfo.Wid-X+1) or (H>26-Y) then Exit;
For I:=Y+1 to Y+H-2 do
Begin
PutChar (X,I,179,Attr);
PutChar (X+W-1,I,179,Attr)
End;
For I:=X+1 to X+W-2 do
Begin
PutChar (I,Y,196,Attr);
PutChar (I,Y+H-1,196,Attr)
End;
PutChar (X,Y,218,Attr);
PutChar (X+W-1,Y,191,Attr);
PutChar (X,Y+H-1,192,Attr);
PutChar (X+W-1,Y+H-1,217,Attr)
End;
Function AvailableWindow : byte;
Var Temp : byte;
Begin
Temp:=1;
While (Temp<=MaxWindow) and WinDat [Temp].Open do Inc (Temp);
If Temp>MaxWindow then Temp:=0;
AvailableWindow:=Temp
End;
Procedure OpenWindow (Wn:byte; X,Y,W,H:integer; Attr:byte; SaveFlg:Boolean);
Var I, J : integer;
Begin
If (W>TextModeInfo.Wid) or (H>25) then Exit;
If W<0 then
Begin
W:=-W; Dec (X,W)
End;
If H<0 then
Begin
H:=-H; Dec (Y,H)
End;
If X<1 then X:=1;
If Y<1 then Y:=1;
With TextModeInfo do If X+W-1>Wid then X:=Wid-W+1;
If Y+H-1>25 then Y:=26-H;
If Wn<=MaxWindow then
With windat [Wn] do
Begin
With windat [ActivW] do
Begin
Xcur:=WhereX; Ycur:=WhereY
End;
PrevWind:=ActivW;
ActivW:=Wn;
If W<0 then
Begin
W:=-W; Dec (X,W)
End;
If H<0 then
Begin
H:=-H; Dec (Y,H)
End;
MaxX:=W; MaxY:=H; Xw:=X; Yw:=Y; Hw:=H; Ww:=W;
Xcur:=1; Ycur:=1;
SaveFlag:=SaveFlg;
Open:=True;
If SaveFlag=Save then GetScrPart (X,Y,Ww,Hw,TextBit);
End;
TextRectangle (X,Y,W,H,Attr);
Window (X+1,Y+1,X+W-2,Y+H-2);
ClrScr
End;
Procedure ActiveWindow (Wn:byte);
Begin
If Wn<=MaxWindow then
Begin
With Windat [ActivW] do
Begin
Xcur:=WhereX; Ycur:=WhereY
End;
With Windat [Wn] do
If Open then
Begin
ActivW:=Wn;
Window (Xw+1,Yw+1,Xw+Ww-2,Yw+Hw-2);
MaxX:=Ww-1; MaxY:=Hw-1;
GoToXY (Xcur,Ycur)
End
End
End;
Procedure CloseWindow;
Begin
With Windat [ActivW] do
If (ActivW>0) and Open then
Begin
Open:=False;
Xcur:=WhereX; Ycur:=WhereY;
Window (Xw,Yw,Xw+Ww,Yw+Hw);
If SaveFlag=Save then PutScrPart (Xw,Yw,Ww,Hw,TextBit)
else ClrScr;
If Windat [PrevWind].Open then ActiveWindow (PrevWind)
else ActiveWindow (0)
End
End;
Procedure MoveWindow (Wn:byte; X,Y:integer);
Var P : TextMem;
Begin
If (Wn>0) and (Wn<=MaxWindow) then
with windat [Wn] do
If Open then
Begin
If (X+Ww-1>TextModeInfo.Wid) or (Y+Hw-1>25) then Exit;
Xcur:=WhereX; Ycur:=WhereY;
GetScrPart (Xw,Yw,Ww,Hw,P);
If SaveFlag then PutScrPart (Xw,Yw,Ww,Hw,TextBit)
else ClrScr;
Xw:=X; Yw:=Y;
If SaveFlag then GetScrPart (X,Y,Ww,Hw,TextBit);
PutScrPart (X,Y,Ww,Hw,P);
Window (X+1,Y+1,X+Ww-1,Y+Hw-1);
GoToXY (Xcur,Ycur)
End
End;
Procedure OpenMenu (X,Y:integer; Corn:byte; Menu:string; var Answer:byte; Info:MenuInfo);
Const Maxopt = 23;
Var Posib : array [1..Maxopt] of Record
Beg, Wid : byte
End;
Options : string [Maxopt];
I, J, W, H, Nopt, Width : byte;
Procedure GetPossib;
Var I, J, K : byte;
Begin
Options:='';
I:=0; Width:=0; Nopt:=0;
Repeat
J:=Pos (',',Menu);
If J>0 then
Begin
Inc (Nopt);
Menu [J] := ';';
Posib [Nopt].Beg := I+1;
Posib [Nopt].Wid := J-I-1;
K:=I;
Repeat
Inc (K);
If Menu [K] in ['A'..'Z'] then Options:=Options+Menu [K];
Until (K=J) or (menu [K] in ['A'..'Z']);
If K=J then Options:=Options+' ';
With Posib [Nopt] do If Wid>Width then Width:=Wid;
End;
I:=J
Until (I=0) or (Nopt=MaxOpt)
End;
Procedure MakeChoice;
Var I, Lin : byte;
Key, Ctrl : char;
Begin
Window (1,1,TextModeInfo.Wid,25);
GoToXY (TextModeInfo.Wid,25);
HideCursor;
Lin:=1;
With Info do
Repeat
For I:=1 to Width+2 do
Begin
PutChar (X+I,Lin+Y,GetChar (X+I,Lin+Y),Bar);
End;
Repeat
Key:=Upcase (ReadKey)
Until (Pos (Key, CR+ESC+Options) > 0) or (Key=#0);
For I:=1 to Width+2 do
If (Options [Lin]<>' ') and (Options [Lin]=Menu [Posib [Lin].Beg+I-2]) then
PutChar (X+I,Lin+Y,GetChar (X+I,Lin+Y),Hot)
else
PutChar (X+I,Lin+Y,GetChar (X+I,Lin+Y),Text);
If Key=#0 then
Begin
Ctrl:=ReadKey;
If (Ctrl=Down) and (Lin<Nopt) then Inc (Lin);
If (Ctrl=Up) and (Lin>1) then Dec (Lin);
If Ctrl=Home then Lin:=1;
If Ctrl=Endt then Lin:=Nopt
End;
Until Key>#0;
If Key=CR then Answer:=Lin else Answer:=Pos (Key,Options);
ShowCursor
End;
Begin
If Depth<MaxDepth-1 then
Begin
Menu:=Menu+',';
Inc (Depth);
GetPossib;
H:=Nopt+2; W:=Width+4;
If Corn>RightUp then H:=-H;
If (Corn=RightUp) or (Corn=RightDown) then W:=-W;
TextColor (Info.Text and $0F);
TextBackground (Info.Text shr 4);
OpenWindow (MaxWindow-Depth,X,Y,W,H,Info.Border,Save);
For I:=1 to Nopt do
With Posib [I] do
For J:=1 to Width do
If J<=Wid then
If (Options [I]<>' ') and (Options [I]=Menu [Beg+J-1]) then
PutChar (X+J+1,I+Y,Ord (Menu [Beg+J-1]),Info.Hot)
else
PutChar (X+J+1,I+Y,Ord (Menu [Beg+J-1]),Info.Text)
else
PutChar (X+J+1,I+Y,32,Info.Text);
MakeChoice
End
End;
Procedure OpenBox (X,Y,W,H,Corn,Attr:byte);
Var Wsgn, Hsgn : integer;
Begin
If Depth<MaxDepth-1 then
Begin
Inc (Depth);
If Corn>RightUp then Hsgn:=-1 else Hsgn:=1;
If (Corn=RightUp) or (Corn=RightDown) then Wsgn:=-1 else Wsgn:=1;
OpenWindow (MaxWindow-Depth,X,Y,Wsgn*W,Hsgn*H,Attr,Save)
End
End;
Procedure CloseTemp;
Var Actual : byte;
Begin
If Depth>-1 then
Begin
If ActivW<>MaxWindow-Depth then
Begin
Actual:=ActivW;
ActiveWindow (MaxWindow-Depth);
CloseWindow;
ActiveWindow(Actual)
End
else
CloseWindow;
Dec (Depth);
End
End;
Begin
TestTextMode
End.
{ ---------------------- Demo program ---------------------- }
Program TextWinDemo;
Uses Crt, TextWin;
Var I, X, Y : integer;
Answer : byte;
S : string;
Info : MenuInfo;
Procedure WaitKey;
Begin
Repeat Until InKey<>Empty
End;
Procedure WriteTitle (Title:string);
Begin
TextColor (Yellow);
TextBackground (Blue);
ClrScr;
GoToXY (40-Length (Title) div 2,2);
Write (Title)
End;
Begin
TextColor (Yellow);
TextBackground (Blue);
OpenWindow (0,1,1,80,25,Attribute (White,Green),DontSave);
WriteTitle ('You can open up to 10 windows (or more if you change MaxWindow constant).');
Randomize;
For I:=1 to MaxWindow do
Begin
Str (I,S);
TextColor (I+1);
TextBackground (7-(I+1) mod 8);
OpenWindow (I,8+Random (30),5+Random (5),12+Random (30),7+Random (8),Attribute (I,7-I mod 8),Save);
Writeln ('Window #',S);
Delay (100)
End;
Writeln;
Write ('Any key...');
WaitKey;
For I:=1 to MaxWindow do
Begin
CloseWindow;
Delay (100)
End;
WriteTitle ('Press any key to hide cursor...');
WaitKey;
HideCursor;
WriteTitle ('Press any key to show cursor...');
WaitKey;
ShowCursor;
WriteTitle ('Menu demo');
With Info do
Begin
Border:=Attribute (Black,LightGray);
Text:=Attribute (Black,LightGray);
Bar:=Attribute (White,Blue);
Hot:=Attribute (Red,LightGray)
End;
OpenMenu (30,10,LeftUp,'An item,Also an item,One more',Answer,Info);
If Answer<>0 then
Begin
OpenMenu (32,11+Answer,LeftUp,'New first option,New second option,New third option',Answer,Info);
CloseTemp
End;
CloseTemp;
TextColor (Yellow);
TextBackground (Blue);
Writeln;
Writeln;
Case Answer of
0 : Write ('You choosed nothing...');
1 : Write ('You choosed first option...');
2 : Write ('You choosed second option...');
3 : Write ('You choosed third option...')
End;
WaitKey;
WriteTitle ('Box demo...');
OpenBox (30,11,20,3,LeftUp,Attribute (Black,LightGray));
Write (' This is a box...');
WaitKey;
CloseTemp;
WriteTitle ('Any key to exit...');
WaitKey;
Window (1,1,TextModeInfo.Wid,25);
TextColor (LightGray);
TextBackground (Black);
ClrScr
End.
[Back to TEXTWNDW SWAG index] [Back to Main SWAG index] [Original]