home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-387-Vol-3of3.iso
/
m
/
msh_ut11.zip
/
MINIWIND.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-05-09
|
17KB
|
607 lines
UNIT MiniWindow;
{-----------------------------------------------------}
{ Jens Pirnay <pirnay@rphs1.physik.uni-regensburg.de> }
{ This file is subject to the copyleft-regulations }
{ of the Free Software Foundation (the guys from GNU) }
{-----------------------------------------------------}
{$R-,S-,V-}
{
Quick'n Dirty - Alert - Boxes, of course
one could improve a lot, so just do it
}
INTERFACE
USES crt, dos;
FUNCTION Alert ( MessageStr : STRING;
QuestionStr : STRING ) : BYTE;
{ Display a window on the screen and offer several possibilities }
PROCEDURE StartInfo (InfoTxt1, InfoTxt2 : STRING);
PROCEDURE UpdateInfo (nr : BYTE; InfoTxt : STRING;
current, maximum : LONGINT);
PROCEDURE EndInfo;
PROCEDURE InputStr (Msg : STRING; BlanksOK : BOOLEAN; VAR inp : STRING);
IMPLEMENTATION
CONST FrameF = Yellow; FrameB = Red;
TextF = White; TextB = Red;
HiF = Black; HiB = LightGray;
FInfoF = Black; FInfoB = White;
TInfoF = Blue; TInfoB = White;
IInfoF = Yellow; IInfoB = Blue;
{ Replace with your own color customization }
TYPE Buffer = ARRAY [0..$8000] OF BYTE;
VAR ScreenPtr : POINTER;
VideoWidth,
VideoDepth : BYTE;
PROCEDURE SaveArea (X1, Y1, X2, Y2 : BYTE; VAR AreaPtr : POINTER);
VAR
I, J : BYTE;
Wid : WORD;
ScreenAdr : INTEGER;
BufAdr : INTEGER;
SSEG, SOfs : WORD;
Pntr : ^Buffer;
MemNeeded : LONGINT;
BEGIN
MemNeeded := SUCC (X2 - X1) * SUCC (Y2 - Y1) * 2;
GETMEM (AreaPtr, MemNeeded);
Pntr := AreaPtr;
SSEG := SEG (ScreenPtr^);
SOfs := OFS (ScreenPtr^);
Wid := VideoWidth * 2;
BufAdr := 0;
FOR I := Y1 TO Y2 DO
BEGIN
ScreenAdr := PRED (I) * Wid + PRED (X1) * 2; { first char }
FOR J := X1 TO X2 DO
BEGIN
Pntr^ [BufAdr ] := Mem [SSEG : SOfs + ScreenAdr];
Pntr^ [BufAdr + 1] := Mem [SSEG : SOfs + ScreenAdr + 1];
INC (BufAdr, 2);
INC (ScreenAdr, 2);
END;
END;
END;
PROCEDURE RestoreArea (X1, Y1, X2, Y2 : BYTE; VAR AreaPtr : POINTER);
{}
VAR
I, J, w : BYTE;
SSEG, SOfs,
Wid : WORD;
ScreenAdr : INTEGER;
BufAdr : INTEGER;
Pntr : ^Buffer;
MemNeeded : LONGINT;
BEGIN
MemNeeded := SUCC (X2 - X1) * SUCC (Y2 - Y1) * 2;
Pntr := AreaPtr;
Wid := VideoWidth * 2;
BufAdr := 0;
SSEG := SEG (ScreenPtr^);
SOfs := OFS (ScreenPtr^);
FOR I := Y1 TO Y2 DO
BEGIN
ScreenAdr := PRED (I) * Wid + PRED (X1) * 2; { first char }
FOR J := X1 TO X2 DO
BEGIN
Mem [SSEG : SOfs + ScreenAdr ] := Pntr^ [BufAdr];
Mem [SSEG : SOfs + ScreenAdr + 1] := Pntr^ [BufAdr + 1];
INC (BufAdr, 2);
INC (ScreenAdr, 2);
END;
END;
FREEMEM (AreaPtr, MemNeeded);
END;
PROCEDURE CheckVideo;
VAR Regs : REGISTERS;
ScreenBase : WORD;
BEGIN
WITH Regs DO
BEGIN
Ax := $0F00;
INTR ($10, Regs); {get video display mode}
IF Al = 7 THEN
ScreenBase := $B000 {Mono}
ELSE
ScreenBase := $B800; {Color}
END;
VideoWidth := SUCC (LO (WindMax) );
VideoDepth := SUCC (HI (WindMax) );
ScreenPtr := PTR (ScreenBase, 0);
{ At last let's look for DesqView }
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);
ScreenPtr := PTR (ES, DI);
END;
END;
END;
PROCEDURE DoFrame (X1, Y1, X2, Y2 : BYTE; FF, FB : BYTE);
CONST Frame : STRING [6] = { '┌┐└┘─│' } { for single top, single side }
{}'╒╕╘╛═│'{} { for double top, single side }
{ '╔╗╚╝═║' } { for double top, double side }
{ '╓╖╙╜─║' } { for single top, double side }
;
VAR i : BYTE; regs : REGISTERS;
BEGIN
{ Frame }
i := ioresult;
TEXTCOLOR (FF); TEXTBACKGROUND (FB);
CLRSCR;
WRITE (Frame [1]);
FOR i := X1 + 1 TO X2 - 1 DO
BEGIN
WRITE (Frame [5]);
END;
WRITE (Frame [2]);
FOR i := Y1 + 1 TO Y2 - 1 DO
BEGIN
GOTOXY (1, i - Y1 + 1); WRITE (Frame [6]); { left }
GOTOXY (X2 - X1 + 1, i - Y1 + 1); WRITE (Frame [6]); { right }
END;
GOTOXY (1, Y2 - Y1 + 1);
WRITE (Frame [3]);
FOR i := X1 + 1 TO X2 - 1 DO
BEGIN
WRITE (Frame [5]);
END;
WITH regs DO BEGIN
ah := 9; al := ORD (Frame [4]);
bh := 0; bl := $8 * FB + FF;
(* bh := 0; bl := $10 * FB + FF; *)
cx := 1; INTR ($10, regs);
END;
END;
VAR InfoArea : POINTER;
IX1, IX2, IY1, IY2 : BYTE;
ILastMin, ILastMax : WORD;
ioldCursX, ioldCursY : BYTE;
LastText : ARRAY [1..2] OF STRING [40];
CONST InfoSize = 25;
PROCEDURE UpdateInfo (nr : BYTE; InfoTxt : STRING;
current, maximum : LONGINT);
VAR rel : LONGINT; i : BYTE;
BEGIN
i := ioresult;
rel := InfoSize;
IF maximum = 0 THEN
rel := 0
ELSE
rel := (current * rel) DIV maximum;
IF InfoTxt <> LastText [nr] THEN
BEGIN
GOTOXY (3, nr * 3);
TEXTCOLOR (TInfoF); TEXTBACKGROUND (TInfoB);
WRITE (InfoTxt);
FOR i := LENGTH (InfoTxt) TO LENGTH (LastText [nr]) DO
WRITE (' ');
LastText [nr] := InfoTxt;
END;
GOTOXY (3, nr * 3 + 1);
TEXTCOLOR (IInfoF); TEXTBACKGROUND (IInfoB);
FOR i := 1 TO rel DO
WRITE ('█');
FOR i := rel + 1 TO InfoSize DO
WRITE ('░');
(*
REPEAT UNTIL KeyPressed; WHILE KeyPressed DO if ReadKey=#27 THEN ;
*)
END;
PROCEDURE StartInfo (InfoTxt1, InfoTxt2 : STRING);
BEGIN
iLastMin := WindMin;
iLastMax := WindMax;
ioldCursX := WHEREX;
ioldCursY := WHEREY;
IX2 := InfoSize;
IY2 := 5;
IX1 := VideoWidth DIV 2 - ( IX2 + 4 ) DIV 2;
IX2 := VideoWidth DIV 2 + ( IX2 + 4 ) DIV 2;
iY1 := VideoDepth DIV 2 - ( IY2 + 4 ) DIV 2;
IY2 := VideoDepth DIV 2 + ( IY2 + 4 ) DIV 2;
SaveArea (IX1, IY1, IX2, IY2, InfoArea);
WINDOW (IX1, IY1, IX2, IY2);
DoFrame (IX1, IY1, IX2, IY2, FInfoF, FInfoB);
LastText [1] := '';
LastText [2] := '';
UpdateInfo (1, InfoTxt1, 0, 100);
UpdateInfo (2, InfoTxt2, 0, 100);
END;
PROCEDURE EndInfo;
BEGIN
NORMVIDEO;
WINDOW (SUCC (LO (ILastMin) ), SUCC (HI (ILastMin) ),
SUCC (LO (ILastMax) ), SUCC (HI (ILastMax) ) );
RestoreArea (IX1, IY1, IX2, IY2, InfoArea);
GOTOXY (ioldCursX, ioldCursY);
END;
FUNCTION Alert ( MessageStr : STRING;
QuestionStr : STRING ) : BYTE;
VAR Res : BYTE;
X1, Y1, X2, Y2 : BYTE;
AreaPtr : POINTER;
LastMin,
LastMax : WORD;
oldCursX,
oldCursY : BYTE;
PROCEDURE ComputeArea (Msg, Ques : STRING; VAR cols, rows : BYTE);
VAR i, j : BYTE;
BEGIN
j := 0;
rows := 1;
cols := 0;
FOR i := 1 TO LENGTH (Msg) DO
BEGIN
IF Msg [i] = '|' THEN
BEGIN
IF j > cols THEN cols := j;
j := 0;
INC (rows);
END
ELSE
INC (j);
END;
IF j > cols THEN cols := j;
j := 0;
FOR i := 1 TO LENGTH (Ques) DO
IF Ques [i] = '|' THEN j := j + 1;
IF cols < LENGTH (Ques) + 2 * j THEN cols := LENGTH (Ques) + 2 * j;
END;
PROCEDURE WriteIt (MessageStr : STRING; X1, Y1, X2, Y2 : BYTE);
VAR i, j : BYTE;
regs : REGISTERS;
Sub : STRING [80];
BEGIN
Sub := '';
j := 2;
FOR i := 1 TO LENGTH (MessageStr) DO
BEGIN
IF MessageStr [i] = '|' THEN
BEGIN
IF Sub <> '' THEN
BEGIN
GOTOXY ( (X2 - X1) DIV 2 - LENGTH (Sub) DIV 2 + 1, j); WRITE (sub);
END;
Sub := '';
INC (j);
END
ELSE
Sub := Sub + MessageStr [i];
END;
IF Sub <> '' THEN
BEGIN
GOTOXY ( (X2 - X1) DIV 2 - LENGTH (Sub) DIV 2 + 1, j); WRITE (sub);
END;
END;
FUNCTION ProcessIt (QuestionStr : STRING; X1, Y1, X2, Y2 : BYTE) : BYTE;
VAR ch : CHAR;
i, j, k, len,
cur, num,
Res : BYTE;
redraw,
ready : BOOLEAN;
Sub : STRING [80];
BEGIN
Res := 255; { Special code for escape }
cur := 1;
num := 1;
FOR i := 1 TO LENGTH (QuestionStr) DO
IF QuestionStr [i] = '|' THEN
INC (num);
len := (LENGTH (QuestionStr) - num + 1) DIV num; { average len }
redraw := TRUE;
REPEAT
IF redraw THEN
BEGIN
IF num > X2 - X1 - LENGTH (QuestionStr) THEN
j := 2
ELSE
j := (X2 - X1 - LENGTH (QuestionStr) - num) DIV 2;
k := 1;
Sub := '';
FOR i := 1 TO LENGTH (QuestionStr) DO
BEGIN
IF QuestionStr [i] = '|' THEN
BEGIN
IF Sub <> '' THEN
BEGIN
GOTOXY (j, (Y2 - Y1) );
IF k = cur THEN
BEGIN
TEXTCOLOR (HiF); TEXTBACKGROUND (HiB);
END
ELSE
BEGIN
TEXTCOLOR (TextF); TEXTBACKGROUND (TextB);
END;
WRITE (Sub);
j := j + LENGTH (Sub) + 3;
Sub := '';
INC (k);
END;
END
ELSE
Sub := Sub + QuestionStr [i];
END;
IF Sub <> '' THEN
BEGIN
GOTOXY (j, (Y2 - Y1) );
IF k = cur THEN
BEGIN
TEXTCOLOR (HiF); TEXTBACKGROUND (HiB);
END
ELSE
BEGIN
TEXTCOLOR (TextF); TEXTBACKGROUND (TextB);
END;
WRITE (Sub);
END;
redraw := FALSE;
END;
ready := FALSE;
ch := READKEY;
CASE ch OF
#0 : BEGIN
IF KEYPRESSED THEN
BEGIN
ch := READKEY;
IF ch = #75 THEN { Left }
BEGIN
DEC (cur); IF cur = 0 THEN cur := num;
redraw := TRUE;
END;
IF ch = #77 THEN { Right }
BEGIN
INC (cur); IF cur > num THEN cur := 1;
redraw := TRUE;
END;
END;
END;
#27 : ready := TRUE;
#13 : BEGIN ready := TRUE; res := cur; END;
END;
UNTIL ready;
ProcessIt := Res;
END;
BEGIN
LastMin := WindMin;
LastMax := WindMax;
oldCursX := WHEREX;
oldCursY := WHEREY;
ComputeArea (MessageStr, QuestionStr, X2, Y2); { Nr. of columns, Nr. of Lines }
X1 := VideoWidth DIV 2 - ( X2 + 4 ) DIV 2;
X2 := VideoWidth DIV 2 + ( X2 + 4 ) DIV 2;
Y1 := VideoDepth DIV 2 - ( Y2 + 4 ) DIV 2;
Y2 := VideoDepth DIV 2 + ( Y2 + 4 ) DIV 2;
SaveArea (X1, Y1, X2, Y2, AreaPtr);
WINDOW (X1, Y1, X2, Y2);
DoFrame (X1, Y1, X2, Y2, FrameF, FrameB);
TEXTCOLOR (TextF); TEXTBACKGROUND (TextB);
WriteIt (MessageStr, X1, Y1, X2, Y2);
Res := ProcessIt (QuestionStr, X1, Y1, X2, Y2);
WINDOW (SUCC (LO (LastMin) ), SUCC (HI (LastMin) ),
SUCC (LO (LastMax) ), SUCC (HI (LastMax) ) );
NORMVIDEO;
RestoreArea (X1, Y1, X2, Y2, AreaPtr);
GOTOXY (oldCursX, oldCursY);
alert := res;
END;
PROCEDURE InputStr (Msg : STRING; BlanksOK : BOOLEAN; VAR inp : STRING);
VAR Res : BYTE;
X1, Y1, X2, Y2 : BYTE;
AreaPtr : POINTER;
LastMin,
LastMax : WORD;
oldCursX,
oldCursY : BYTE;
ready, refresh,
overwrite,
first : BOOLEAN;
SPos, Len : BYTE;
ch : CHAR;
PROCEDURE Cursor(small : BOOLEAN);
VAR regs : Registers;
C, T, B : BYTE;
BEGIN
WITH Regs DO { Get CharHeight-Info }
BEGIN
Ah := $11;
Al := $30;
BX := $0;
INTR ($10, Regs);
C := CX;
END;
if small THEN
begin
t := C DIV 2;
b := PRED (C);
end
else
begin
t := 0;
b := Pred(C);
end;
WITH regs 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, Regs);
END;
END;
BEGIN
LastMin := WindMin;
LastMax := WindMax;
oldCursX := WHEREX;
oldCursY := WHEREY;
X2 := 60;
X1 := VideoWidth DIV 2 - ( X2 + 4 ) DIV 2;
X2 := VideoWidth DIV 2 + ( X2 + 4 ) DIV 2;
Y1 := VideoDepth DIV 2 - 2;
Y2 := VideoDepth DIV 2 + 1;
SaveArea (X1, Y1, X2, Y2, AreaPtr);
WINDOW (X1, Y1, X2, Y2);
DoFrame (X1, Y1, X2, Y2, FrameF, FrameB);
TEXTCOLOR (TextF); TEXTBACKGROUND (TextB);
GOTOXY (3, 2); WRITE (Msg);
TEXTCOLOR (TInfoF); TEXTBACKGROUND (TInfoB);
GOTOXY (3, 3); WRITE (Inp);
TEXTCOLOR (FInfoF); TEXTBACKGROUND (FInfoB);
FOR Spos := 1 TO LENGTH (Inp) DO { all should be capital }
Inp [SPos] := UPCASE (Inp [Spos]);
refresh := FALSE;
ready := FALSE;
first := TRUE;
overwrite := FALSE;
Cursor(overwrite);
spos := LENGTH (Inp) + 1;
REPEAT
IF refresh THEN
BEGIN
TEXTCOLOR (TextF); TEXTBACKGROUND (TextB);
GOTOXY (3, 3); FOR len := 1 TO 60 DO WRITE (' ');
TEXTCOLOR (FInfoF); TEXTBACKGROUND (FInfoB);
GOTOXY (3, 3); WRITE (Inp);
Refresh := FALSE;
END;
GOTOXY (2 + spos, 3);
ch := READKEY;
CASE ch OF
#0 : IF KEYPRESSED THEN
BEGIN
ch := READKEY;
IF first THEN refresh := TRUE;
first := FALSE;
CASE ch OF
#82 : { Insert }
BEGIN
overwrite := NOT overwrite;
Cursor(overwrite);
END;
#83 : { Delete }
IF Spos <= LENGTH (inp) THEN
BEGIN
refresh := TRUE;
DELETE (inp, Spos, 1);
END;
#71 : { Home } Spos := 1;
#75 : { Left } IF spos > 1 THEN DEC (spos);
#77 : { Right } IF spos <= LENGTH (Inp) THEN INC (spos);
#79 : { End } spos := LENGTH (Inp) + 1;
END;
END;
#8 : { backspace }
BEGIN
if first then refresh := TRUE;
first := FALSE;
IF (spos > 1) THEN
BEGIN
DEC (spos);
DELETE (Inp, spos, 1);
refresh := TRUE;
END;
END;
#11 : { CtrlK } BEGIN { delete to end of input }
first := FALSE;
refresh := TRUE;
IF (spos<=Length(Inp)) THEN
BEGIN
Inp[0] := CHR(spos-1); { Cut string }
spos := Length(Inp) + 1;
END;
END;
#13 : { Return } ready := TRUE;
#27 : { Escape } BEGIN ready := TRUE; Inp := ''; END;
#0..#31, #127 : { Non-printable }
IF first THEN
BEGIN
first := FALSE;
refresh := TRUE;
END;
ELSE
{ Valid Characters }
BEGIN
ch := UPCASE (ch);
IF BlanksOK OR (ch<>' ') THEN
BEGIN
IF first THEN
BEGIN
Inp := ch;
spos := 2;
END
ELSE
BEGIN
IF spos > LENGTH (Inp) THEN
Inp := Inp + ch
ELSE
IF overwrite THEN
Inp [spos] := ch
ELSE
INSERT (ch, Inp, spos);
INC (spos);
END;
END;
refresh := TRUE;
first := FALSE;
END;
END;
UNTIL ready;
Cursor(true);
WINDOW (SUCC (LO (LastMin) ), SUCC (HI (LastMin) ),
SUCC (LO (LastMax) ), SUCC (HI (LastMax) ) );
NORMVIDEO;
RestoreArea (X1, Y1, X2, Y2, AreaPtr);
GOTOXY (oldCursX, oldCursY);
END;
BEGIN
CheckVideo;
END.