[Back to MENU SWAG index] [Back to Main SWAG index] [Original]
{ features include }
{ automatic string resizing }
{ hack proof, just leave the menucnst.pas available for general use}
{ easy to change colors }
{ automatic centring }
{ easy to use hot keys }
{ function to return value }
{ first declared is = 0, second is = 1, etc, etc }
{ if you use this program we take no responsiblity for anything that may
happen to your computer }
{ THE ANDAL PROGRAMMING CORPORATION }
{ any bugs or ideas or help with dos or menus etc, please contact
us at FERRET_@HOTMAIL.COM}
uses
crt,menubox;
var
a:byte;
x:menu;
begin
x.setup;
x.additem(' m~e~nu item 1'); {example of a hotkey }
x.additem(' menu item 2'); {without a hotkey }
x.additem(' ~m~enu item 3'); {with one again}
x.additem(' menu item 4');
a := x.run(' this is a little demo ',true);
x.shutdown;
end.
{ ---------------- UNITS NEEDED HERE ------------ }
UNIT MenuBox;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
INTERFACE
USES CRT,Shorten,MenuCnst;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ -- CONSTANT VALUES -- }
CONST
Up = TRUE; {Up arrow goes up -); }
Down = FALSE; {Down arrow does the opposite}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ -- THE MENU OBJECT -- }
TYPE
Menu = OBJECT {The Whole Kit + Kabodal }
Items : ARRAY [0..24] OF ^STRING; {Pointers to 25 strings }
NoItems : BYTE; {How many items do I have?? }
CurItem : BYTE; {Which Item am I up to?? }
PROCEDURE Setup; {Call this every time you run}
PROCEDURE AddItem(Str : STRING); {Call to add an item new line}
PROCEDURE ShutDown; {Dynamic shutdown }
FUNCTION Run(TitleStr : STRING; {Run!!! - returns value = to }
DrawTitle : BOOLEAN) : BYTE; {the item number 0 = the 1st }
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ -- PUBLIC PROCEDURES -- }
PROCEDURE MenuExit;
{ -- PUBLIC VARIABLES -- }
VAR
M : Menu;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
IMPLEMENTATION
{ -- PRIVATE CALLS -- }
{PROCEDURE MWriteXY(Index : BYTE);}
{PROCEDURE Main(Dir : BOOLEAN);}
{PROCEDURE ElseAnalyse;}
{ -- PRIVATE VARIABLES -- }
VAR
ExitPtr : POINTER;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE Menu.Setup; {Do the standard object VAR }
BEGIN {setup sequence, set to 0 }
NoItems := 0;
CurItem := 0;
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE Menu.AddItem(Str : STRING); {Get's a bit tricky here... }
BEGIN
GETMEM(Items[NoItems],SIZEOF(STRING)); {allocate memory for a string}
Items[NoItems]^ := Str; {give it the value of param }
INC(NoItems); {you now have another item! }
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE Menu.ShutDown; { >>> MUST BE CALLED <<< }
VAR
DelNo : BYTE; {Counter variable }
BEGIN
IF NoItems >= 1 THEN
FOR DelNo := 0 TO NoItems-1 DO {Start at start + do all items}
FreeMem(Items[DelNo],SIZEOF(STRING)); {deallocate all mem }
NoItems := 0; {reset stand. vars for next }
CurItem := 0; {time }
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE ResizeString(VAR Str : STRING; { >>>> PRIVATE <<<< }
CONST Maxl : BYTE); {Cannot be called out of unit}
VAR {Procedure to do Auto resize }
StrL : BYTE; {on any strings }
D1 : BYTE; { It will append ' ' to end}
C : BYTE; { + start of the string till }
BEGIN {it reaches the right length }
StrL := LENGTH(Str); { Save String length }
IF POS('~',Str) <> 0 THEN { Adjust for '~' chars }
DEC(StrL,2);
StrL := MaxL - StrL; {find how many chars out it }
D1 := StrL SHR 1; {is. Half that number }
StrL := StrL - D1; {put half in D1, other in }
FOR C := 1 TO D1 DO {StrL. Then append ' '''s }
Str := ' ' + Str;
FOR C := 1 TO StrL DO
Str := Str + ' ';
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
FUNCTION Menu.Run(TitleStr : STRING; { THIS IS IT BOYS + GIRLS }
DrawTitle : BOOLEAN) : BYTE; {Title + whether to write it }
VAR
X1 : BYTE; {frame co - ordinates }
Y1 : BYTE;
X2 : BYTE;
Y2 : BYTE;
Ch : CHAR; {letter to be read in }
Stop : BOOLEAN; {stop check variable }
Count : BYTE; {multipurpose counting VAR }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ -- PRIVATE CALL -- }
PROCEDURE MWriteXY(Index : BYTE); {Menu Write at (X,Y) }
VAR {index is the string number }
I : BYTE; {to write. I is a counter }
H : BOOLEAN; {H is do hotkey colors?? }
BEGIN
GOTOXY(X1+1,Y1+1+Index); {Move into position }
H := FALSE; {hotkey starts 'OFF' }
FOR I := 1 TO LENGTH(Items[Index]^) DO {Check each letter }
BEGIN
IF Items[Index]^[I] <> '~' THEN {if it's a after a '~' then }
BEGIN {write in Hot Key Colors }
IF H THEN
BEGIN
TC(HKCol);
WRITE(Items[Index]^[I]);
END
ELSE {... else do it standard cols}
BEGIN
TC(TCol);
WRITE(Items[Index]^[I]);
END;
END
ELSE {code to switch from hot to }
BEGIN {non hot }
IF H THEN
H := FALSE
ELSE
H := TRUE
END;
END;
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ -- PRIVATE CALL -- }
PROCEDURE Main(Dir : BOOLEAN); {Movement of status bar proc }
BEGIN {unhighlight last item }
TBG(BKCol);
MWriteXY(CurItem);
IF Dir = Up THEN {if it's going up then ... }
BEGIN
IF CurItem <> 0 THEN {... go up ... }
DEC(CurItem)
ELSE
CurItem := NoItems - 1; {... unless its at top then }
END {go back to the bottom }
ELSE
BEGIN {as for up - but down -); }
IF CurItem <> NoItems -1 THEN
INC(CurItem)
ELSE
CurItem := 0;
END;
TBG(HCol); {Textcolor = Highlight color }
MWriteXY(CurItem); {Write proper item highlit }
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ -- PRIVATE CALL -- }
PROCEDURE ElseAnalyse; {analyse non arrow key stroke}
VAR
I : BYTE; {multipurpose counting vars }
I2 : BYTE;
L : CHAR;
BEGIN
Ch := UPCASE(Ch); {set it to upper case }
IF Ch = Enter THEN BEGIN Run := CurItem; Stop := TRUE; END
ELSE {enter conditions ... }
FOR I := 0 TO NoItems-1 DO { ... otherwise get Uppercase}
BEGIN {of each hotkey + compare it }
FOR I2 := 1 TO LENGTH(Items[I]^) DO {to that }
IF Items[I]^[I2] = '~' THEN
BEGIN
L := UPCASE(Items[I]^[I2+1]);
BREAK; {NB//: Break = Quit loop }
END;
IF Ch = L THEN BEGIN Run := I; Stop := TRUE; EXIT; END;
END; {if it is stop run + set it }
END; {to string number }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
BEGIN {BODY OF RUN PROCEDURE}
{ - INITIALIZATION PART - }
CursorOff;
Stop := FALSE;
{ - RANGE CHECKING ON STRINGS - }
IF NoItems <= 1 THEN {If no items have been added }
BEGIN {then tell the user that and }
TBG(BKCol); {then quit }
TC(BKCol + 2);
WriteC('Not enough Strings Initialized - Cannot Run Menu',12);
WriteC('Press Any Key To Quit ...',13);
READKEY;
HALT;
END;
{ - FRAME X DIMENSION - }
X1 := LENGTH(TitleStr); {Init max len var to title }
FOR Count := 0 TO NoItems-1 DO {Do this for all items }
BEGIN
X2 := LENGTH(Items[Count]^); {Init tmp len var to str len }
IF POS('~',Items[Count]^) <> 0 THEN {if it has 2 '~' chars then }
DEC(X2,2); {minus them }
IF X2 > X1 THEN {if tmp var is > max then }
X1 := X2; {reset max to show this. }
END;
{ - FRAME X DIMENSIONS (SUBBLOCK):- STRING RESIZING - }
FOR Count := 0 TO NoItems-1 DO
ResizeString(Items[Count]^,X1); {Do string autoresize }
{ - FRAME X DIMENSIONS - }
INC(X1);
Count := X1; {move x1 so we can use it }
X1 := (80 - Count) SHR 1; {define the edges of the }
X2 := X1 + Count; {menu to a const for speed }
{ - FRAME Y DIMENSIONS - }
Count := NoItems+1; {box size = number of items+1}
IF DrawTitle THEN {unless you want a title }
INC(Count,TBlockSize);
Y1 := (25 - Count) SHR 1; {calc y co - ords }
Y2 := Y1 + count;
{ - BASIC SCREEN SETUP - }
FBG(FBGS); {Fill Background to constant }
TBG(BKCol); {Set Text background color }
TC(BCol); {Set Text Color }
Frame(X1,Y1,X2,Y2,BTyp,TRUE,' '); {Draw the frame }
IF DrawTitle THEN {draw the title block }
BEGIN
GOTOXY(X1,Y1+TBlockSize);
IF BTyp = 1 THEN {adjust chars for style 1 }
BEGIN
WRITE('Ã');
REPEAT
WRITE('Ä');
UNTIL WHEREX = X2;
WRITE('´');
END;
IF BTyp = 2 THEN {adjust chars for style 2 }
BEGIN
WRITE('Ì');
REPEAT
WRITE('Í');
UNTIL WHEREX = X2;
WRITE('¹');
END;
WriteC(TitleStr,Y1 + (TBlockSize SHR 1));
INC(Y1,TBlockSize); {write in the title block + }
END; {adjust Y1 for it }
{ MENU ITEM LAYOUT }
FOR Count := 1 TO NoItems-1 DO {do the original write up }
MWriteXY(Count); {unhighlit }
TBG(HCol);
MWriteXY(0); {highlighted }
REPEAT {Repeat chance to read in }
Ch := READKEY; {key strokes }
IF Ch = #0 THEN {trap function keys }
BEGIN
Ch := READKEY;
CASE Ch OF
#91 : HALT; {SHIFT F8 IS THE AUTO QUIT }
UpArrow : Main(Up); {left arrow }
DownArrow : Main(Down); {right arrow }
END;
END
ELSE
ElseAnalyse; {if not left or right analyse}
UNTIL Stop; {stop when condition is true }
CursorOn {turn the cursor on }
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ --=THINGS TO DO AFTER THE PROGRAM=-- }
{$F+}
PROCEDURE MenuExit;
BEGIN
EXITPROC := ExitPtr;
M.ShutDown;
END;
{$F+}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ --=THINGS TO DO BEFORE RUNNING THE PROGRAM=-- }
BEGIN
ExitPtr := EXITPROC;
EXITPROC := @MenuExit;
M.SetUp;
END.
---------------------------- = [Cut Here] = ---------------------------------
UNIT MenuCnst;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
INTERFACE
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
CONST
HKCol = 10; {Text Hot Key Color }
TCol = 15; {Standard Text Color }
BKCol = 1; {Standard Background Color }
HCol = 3; {Highlight Background Color }
BTyp = 2; {Boarder Type }
BCol = 15; {Boarder Color }
FBGS = 6576; {Fill Back Ground Style }
TBlockSize = 2; {Title Block Size }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
IMPLEMENTATION
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
END.
---------------------------- = [Cut Here] = ---------------------------------
UNIT shorten;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
INTERFACE
USES
crt,graph;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
TYPE
Pallette = ARRAY [0..255,1..3] OF BYTE;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
CONST
UpArrow = #72; {special keyboard calls}
DownArrow = #80;
LeftArrow = #75;
RightArrow = #77;
ESC = #27;
ALTX = #45;
Enter = #13;
DUpLeft = #201; {double line box operators}
DUpRight = #187;
DLowLeft = #200;
DLowRight = #188;
DStraight = #205;
DDown = #186;
SUpLeft = #218; {single line box operators}
SUpRight = #191;
SLowLeft = #192;
SLowRight = #217;
SStraight = #196;
SDown = #179;
Theta = #233; {math operator symbols}
PIsym = #227;
SumOf = #228;
ExactEqual = #240;
ApproxEqual= #247;
GTOET = #242;
LTOET = #243;
ElementOf = #238;
Intersection = #239;
Heart = #3; {card symbol operators}
Spade = #5;
Diamond = #4;
Club = #6;
HighBG = FALSE;
LowBG = TRUE;
MyBG = 20144; {fill back ground styles}
BlueGrayBG = 5040;
BlueWhiteBG = 8112;
LBlueBlueBG = 6576;
ScreenX = 640; {BGI screen size constants}
ScreenY = 480;
HalfX = 320;
HalfY = 240;
VGA = $A000; {Screen memory position}
MCGA = $A000;
DosScreen = $B800;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ -- BGI BASIC INTERFACE -- }
PROCEDURE GrInit; {Initiate the BGI }
PROCEDURE GrShutDown; {Close down the BGI }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ -- PALLETTE MANIPULATION -- }
PROCEDURE Pal(Col : BYTE;
R : BYTE;
G : BYTE;
B : BYTE);
PROCEDURE GetPal(Col : BYTE;
VAR R : BYTE;
VAR G : BYTE;
VAR B : BYTE);
PROCEDURE WaitRetrace;
PROCEDURE SavePallette(VAR Pall : Pallette);
PROCEDURE RestorePallette(Pall : Pallette);
PROCEDURE FadeToBlack;
PROCEDURE FadeUp(Pall : Pallette);
PROCEDURE BlackOut;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ -- CURSOR MANAGEMENT -- }
PROCEDURE CursorOn;
PROCEDURE CursorOff;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ -- MISCELL. FORMATTING ROUTINES -- }
PROCEDURE WriteXY(Str : STRING;
X : BYTE;
Y : BYTE);
PROCEDURE WriteC(Str : STRING;
Y : BYTE);
PROCEDURE Frame(x1, y1, x2, y2 : byte; {corner coords}
typ : byte; {type of frame}
clr : boolean; {clear inside?}
clrch : char); {clear with what}
PROCEDURE UpString(VAR Str : STRING);
FUNCTION GetCh(X : BYTE;
Y : BYTE) : WORD;
PROCEDURE TBG(X : BYTE); {Change textbackground --> abbr. }
PROCEDURE TC(X : BYTE); {change textcolor --> abbr. }
PROCEDURE FBG(Col : WORD); {fill background to a word }
PROCEDURE FBG2(Where : WORD; {fill bg --> to a vaddr or }
Ascii : BYTE; {to a specific ascii / color }
Col : BYTE); {scheme }
PROCEDURE SetBG(Back : BOOLEAN); {turn on / off hi background cols}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ -- FILE MANAGEMENT ROUTINES -- }
FUNCTION CheckForExtension(FileStr : STRING) : BOOLEAN;
FUNCTION Exist(FileName : STRING): BOOLEAN;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ -- EXIT PROCEDURE -- }
PROCEDURE MyExit;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ -- GLOBAL VARIABLES -- }
VAR
BackUpPalletteStorage : Pallette;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
IMPLEMENTATION
{ -- PRIVATE VARIABLES -- }
VAR
ExitPtr : POINTER;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE Frame(x1, y1, x2, y2 : byte; {corner coords}
typ : byte; {type of frame}
clr : boolean; {clear inside?}
clrch : char); {clear with what}
TYPE fchars = (ulc, top, urc, side, lrc, llc);
CONST fc : ARRAY[0..2] OF ARRAY[fchars] OF CHAR =
(' ', #218#196#191#179#217#192,
#201#205#187#186#188#200);
VAR
ro,co : Byte;
S : String[80];
BEGIN
FillChar(S, SizeOf(S), fc[typ][top]);
S[0] := char(pred(x2-x1));
GotoXY(x1, y1);
Write(fc[typ][ulc], S, fc[typ][urc]);
GotoXY(x1, y2);
Write(fc[typ][llc], S, fc[typ][lrc]);
FillChar(S[1], pred(SizeOf(S)), clrch);
FOR ro := succ(y1) TO pred(y2) DO
IF clr THEN
BEGIN
GotoXY(x1, ro);
Write(fc[typ][side], S, fc[typ][side])
END
ELSE
BEGIN
GotoXY(x1, ro); Write(fc[typ][side]);
GotoXY(x2, ro); Write(fc[typ][side]);
END;
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE FBG(Col : WORD); ASSEMBLER;
ASM
push es {Save ES segment on the stack }
mov ax,0B800h {Put $0B800 in ax, start screen mem }
mov es,ax {ES now points locat. in ax }
mov cx,2000 {CX := 2000 }
xor di,di {Fast way of making di = 0 }
mov ax,[Col] {Hold the color in the AX register }
rep stosw {start at ES ($B800), write AX (Fill)}
{to memory at ES + DI, add 1 to DI }
{Stop when DI = CX (2000) }
pop es {Restore ES off the stack }
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE FBG2(Where : WORD;
Ascii : BYTE;
Col : BYTE); ASSEMBLER;
ASM
push es {Save ES segment on the stack }
mov cx,2000 {CX := 2000 }
mov ax,[where]
mov es,ax {ES now points at start mem location }
xor di,di {Fast way of making di = 0 }
mov al,[Ascii] {Hold the character in the AX registr}
mov ah,[Col] {Hold the color in the AX register }
rep stosw {start at ES ($B800), write AX (Fill)}
{to memory at ES + DI, add 1 to DI }
{Stop when DI = CX (2000) }
pop es {Restore ES off the stack }
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE SetBG(Back : BOOLEAN); ASSEMBLER;
ASM
mov AX,$1003
mov BL,Back
int $10
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE Pal(Col : BYTE;
R : BYTE;
G : BYTE;
B : BYTE); ASSEMBLER;
{ This sets the Red, Green and Blue values of a certain color }
ASM
mov dx,3c8h
mov al,[col]
out dx,al
inc dx
mov al,[r]
out dx,al
mov al,[g]
out dx,al
mov al,[b]
out dx,al
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE GetPal(Col : BYTE;
VAR R : BYTE;
VAR G : BYTE;
VAR B : BYTE);
{ This gets the Red, Green and Blue values of a certain color }
VAR
rr : BYTE;
gg : BYTE;
bb : BYTE;
BEGIN
ASM
mov dx,3c7h
mov al,col
out dx,al
add dx,2
in al,dx
mov [rr],al
in al,dx
mov [gg],al
in al,dx
mov [bb],al
END;
r := rr;
g := gg;
b := bb;
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE WaitRetrace; ASSEMBLER;
LABEL
l1, l2;
ASM
mov dx,3DAh
l1:
in al,dx
and al,08h
jnz l1
l2:
in al,dx
and al,08h
jz l2
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE SavePallette(VAR Pall : Pallette);
VAR
loop1 : INTEGER;
BEGIN
FOR loop1 := 0 TO 255 DO
GetPal (loop1,pall[loop1,1],pall[loop1,2],pall[loop1,3]);
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE RestorePallette(Pall : Pallette);
{ This procedure restores the origional pallette }
VAR
loop1 : INTEGER;
BEGIN
WaitRetrace;
For loop1:=0 to 255 do
Pal (loop1,Pall[loop1,1],Pall[loop1,2],Pall[loop1,3]);
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure FadeToBlack;
{ This procedure fades the screen out to black. }
VAR loop1,loop2:integer;
Tmp : Array [1..3] of byte;
{ This is temporary storage for the values of a color }
BEGIN
For loop1:=1 to 64 do BEGIN
WaitRetrace;
For loop2:=0 to 255 do BEGIN
Getpal (loop2,Tmp[1],Tmp[2],Tmp[3]);
If Tmp[1]>0 then dec (Tmp[1]);
If Tmp[2]>0 then dec (Tmp[2]);
If Tmp[3]>0 then dec (Tmp[3]);
{ If the Red, Green or Blue values of color loop2 are not yet zero,
then, decrease them by one. }
Pal (loop2,Tmp[1],Tmp[2],Tmp[3]);
{ Set the new, altered pallette color. }
END;
END;
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Fadeup(Pall : Pallette);
{ This procedure slowly fades up the new screen }
VAR loop1,loop2:integer;
Tmp : Array [1..3] of byte;
{ This is temporary storage for the values of a color }
BEGIN
For loop1:=1 to 64 do BEGIN
{ A color value for Red, green or blue is 0 to 63, so this loop only
need be executed a maximum of 64 times }
WaitRetrace;
For loop2:=0 to 255 do BEGIN
Getpal (loop2,Tmp[1],Tmp[2],Tmp[3]);
If Tmp[1]<Pall[loop2,1] then inc (Tmp[1]);
If Tmp[2]<Pall[loop2,2] then inc (Tmp[2]);
If Tmp[3]<Pall[loop2,3] then inc (Tmp[3]);
{ If the Red, Green or Blue values of color loop2 are less then they
should be, increase them by one. }
Pal (loop2,Tmp[1],Tmp[2],Tmp[3]);
{ Set the new, altered pallette color. }
END;
END;
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Blackout;
{ This procedure blackens the screen by setting the pallette values of
all the colors to zero. }
VAR loop1:integer;
BEGIN
WaitRetrace;
For loop1:=0 to 255 do
Pal (loop1,0,0,0);
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE CursorOff; ASSEMBLER;
ASM
mov ah,3
mov bh,0
int 10h
mov ah,1
mov cx,$100
int 10h
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE CursorOn; ASSEMBLER;
ASM
mov ah,1
mov cx,3342
int 10h
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
FUNCTION GetCh(X : BYTE;
Y : BYTE) : WORD;
VAR
OffSet : WORD;
ScrPtr :^WORD;
begin
OffSet := (((Y - 1) * 80) + X - 1) * 2;
ScrPtr := PTR($B800,offset);
GetCh := ScrPtr^;
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE WriteXY(Str : STRING;
X : BYTE;
Y : BYTE);
BEGIN
GOTOXY(X,Y);
WRITE(Str);
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE grinit;
VAR
gd : INTEGER;
gm : INTEGER;
BEGIN
gd := DETECT;
INITGRAPH(gd, gm, '');
IF GRAPHRESULT <> grOk THEN
BEGIN
gd := DETECT;
INITGRAPH(gd, gm, 'C:\TP\BGI');
IF GRAPHRESULT <> grOk THEN
BEGIN
WRITELN('GRAPHICS DRIVERS MALFUNCTION');
READKEY;
HALT;
END;
END;
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE GrShutDown;
BEGIN
CLEARDEVICE;
CLOSEGRAPH;
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE TBG(X : BYTE);
BEGIN
TEXTBACKGROUND(X);
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE TC(X : BYTE);
BEGIN
TEXTCOLOR(X);
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE UpString(VAR Str : STRING);
VAR
StrLen : BYTE; {The total Length of the string }
StrPos : BYTE; {Where in the string am I }
BEGIN
StrLen := LENGTH(Str); {Get the length of the string }
StrPos := 1; {The first char in the string is 1 }
REPEAT {Start repeating }
Str[StrPos] := UPCASE(Str[StrPos]);
{Change each letter to uppercase }
INC(StrPos); {Move to the next letter }
UNTIL StrPos = StrLen+1; {Stop repeating when the word is finish }
END; {UpString}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
FUNCTION CheckForExtension(FileStr : STRING) : BOOLEAN;
VAR
StrLen : BYTE; {The total Length of the string }
StrPos : BYTE; {Where in the string am I }
Found : BOOLEAN; {Was a period found }
BEGIN
StrLen := LENGTH(FileStr); {Get the length of the string }
StrPos := 1; {Standard Pascal strings start at byte 1}
Found := FALSE; {Default is no period }
REPEAT {Start Repeating }
IF FileStr[StrPos] = '.' THEN {Stop repeating if a full stop is found }
Found := True; {If you find a full stop get organised..}
INC(StrPos); {move to the next spot in the string }
UNTIL Found OR (StrPos = StrLen);
IF Found THEN {if you did find an extension output it }
CheckForExtension := TRUE
ELSE {else tell it you didn't }
CheckForExtension := FALSE;
END; {CheckForExtension}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE WriteC(Str : STRING;
Y : BYTE);
BEGIN
GOTOXY(40 - (LENGTH(Str) DIV 2),Y);
WRITE(Str);
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
function Exist(FileName: String): Boolean;
{ Boolean function that returns True if the file exists;otherwise,
it returns False. Closes the file if it exists. }
var
F: file;
begin
{$I-}
Assign(F, FileName);
FileMode := 0; { Set file access to read only }
Reset(F);
Close(F);
{$I+}
Exist := (IOResult = 0) and (FileName <> '');
end; {Exist}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ --=THINGS TO DO AFTER THE PROGRAM=-- }
{F+}
PROCEDURE MyExit;
BEGIN
EXITPROC := ExitPtr;
NOSOUND;
RestorePallette(BackUpPalletteStorage);
CursorOn;
TEXTBACKGROUND(0);
TEXTCOLOR(7);
CLRSCR;
END;
{$F-}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ --=THINGS TO DO BEFORE RUNNING THE PROGRAM=-- }
BEGIN
ExitPtr := EXITPROC;
EXITPROC := @MyExit;
RANDOMIZE;
SavePallette(BackUpPalletteStorage);
TEXTBACKGROUND(0);
TEXTCOLOR(7);
CLRSCR;
END.
---------------------------- = [Cut Here] = ---------------------------------
[Back to MENU SWAG index] [Back to Main SWAG index] [Original]