{Fill is unstable for circles with radii greater than 49? Wierd rounding???}
{$A+}
{$G+}
{$N+,E-}
unit Graphics;
interface
type
{Some memory for a screen}
MCGAScreenType = array[0..63900] of byte;
{The main data structure for a page}
PageType = record
Page:^MCGAScreenType;
Segment,Offset:word;
end; {record}
const
{the color constants}
Black = 0;
Blue = 1;
Green = 2;
Cyan = 3;
Red = 4;
Magenta = 5;
Brown = 6;
LightGray = 7;
DarkGray = 8;
LightBlue = 9;
LightGreen = 10;
LightCyan = 11;
LightRed = 12;
LightMagenta = 13;
Yellow = 14;
White = 15;
{We only have one screen mode, so these can be constants}
MinX = 0; MinY = 0;
MaxX = 319; MaxY = 199;
{Constants used in paging and movies to determine whether to draw
the palette}
PaletteEnabled = TRUE;
PaletteDisabled = FALSE;
{An unusual name (most likely not used as an hot-area indentifier)
used in the PollHotAreas function}
Nothing = 'FooF'; {An unusual name}
{A constant that points to the video buffer}
TheScreen:PageType = (Page:ptr($a000,0000);Segment:$a000;Offset:0000);
type
{Records the elements of a color}
ColorType = record
Red,Green,Blue:byte;
end; {record}
{Used to store the sin and cos lookup tables}
TableType = array[0..45,0..300] of integer;
{SubRange for the speed of a FadeDown}
SpeedRangeType = 0..10;
{Used to store an image}
ImageType = record
deltaX,deltaY:integer;
vSegment,vOffset:word;
Image:pointer;
end; {record}
{Font size... useless because I don't want to do anything}
SizeSubRange = 1..10;
{Which direction to play a movie in}
DirectionType = (Foreward,Backward);
{Which font type... useless because there is only regular}
FontEnumeratedType = (Regular);
{Useless stuff about a font}
FontType = record
Size:SizeSubRange;
end; {record}
{Variables that determine the characteristics of a fire}
FireType = record
c,last:word;
x1,y1,x2,y2:word;
PalBegin,PalEnd,PalLen:byte;
end; {record}
{Defines a point in the gradated palette}
ColorRecordType = record
Color:ColorType;
IsAPoint:Boolean;
Location:byte;
end; {record}
{Defines a coordinate}
CordType = record
x,y:word;
end; {record}
MapNodePtr = ^MapNodeType;
{Defines one node (area) of an image map}
MapNodeType = record
next:MapNodePtr;
name:string;
number:integer;
b1,e1,b2,e2:CordType;
end; {record}
{The large map-type definition}
MapType = record
Render:PageType;
Rendered:boolean;
First,Last:MapNodePtr;
NumItems:word;
end; {record}
{A palette}
PaletteType = array[0..255] of ColorType;
PaletteTypePtr = ^PaletteType;
MovieNodePtr = ^MovieNode;
{Defines one node (frame) of a movie}
MovieNode = record
Picture:ImageType;
Palette:PaletteTypePtr;
prev,next:MovieNodePtr;
end; {record}
{Defines a movie}
MovieType = record
Front,Last:MovieNodePtr;
NumFrames:word;
end; {record}
{Defines a gradated palette; max 256 colors}
GradatedPalType = array[0..255] of ColorRecordType;
GradatedPaletteType = ^GradatedPalType;
{The palette for a picture}
SomePaletteType = array[0..255] of ColorType;
{A Picture!!! I love my TGAs and PCXes}
PictureType = record
picture:ImageType;
Palette:^SomePaletteType;
end; {record}
procedure InitGraph;
procedure CloseGraph;
procedure SetColor(AColor:byte);
function GetColor:byte;
procedure PutPixel(x,y:word);
function GetPixel(x,y:word):byte;
procedure SetPalette(ColorNumber:byte;AColor:ColorType);
procedure GetPalette(ColorNumber:byte;var TheColor:ColorType);
procedure FadeScreen(Speed:SpeedRangeType);
procedure RotatePalette(Start,Finish:byte);
procedure SavePalette(FileName:string);
procedure LoadPalette(FileName:string);
procedure InitGradatedPalette(var SomePalette:GradatedPaletteType);
procedure AddKeyPoint(var SomePalette:GradatedPaletteType;Location:byte;Color:ColorType);
procedure GeneratePalette(SomePalette:GradatedPaletteType);
procedure KillGradatedPalette(var SomePalette:GradatedPaletteType);
procedure ClearScreen;
procedure Circle(x,y,Radius:word);
procedure Line(x1,y1,x2,y2:word);
procedure Bar(BeginX,BeginY,EndX,EndY:word);
procedure Rectangle(BeginX,BeginY,EndX,EndY:word);
procedure Fill(x,y:word;FillColor,Border:byte);
procedure InitFire(var SomeFire:FireType;x1,y1,x2,y2:word;BeginPal,EndPal:byte);
procedure DoFire(SomeFire:FireType);
procedure GetImage(var Image:ImageType;x1,y1,x2,y2:word);
procedure PutImage(Image:ImageType;x1,y1:word);
procedure KillImage(var Image:ImageType);
procedure PutChar(Font:FontEnumeratedType;xc,yc:word;AChar:char);
procedure WriteStringXY(Font:FontEnumeratedType;xc,yc:word;Thing:string);
procedure WriteString(Font:FontEnumeratedType;Thing:string);
procedure LoadPCX(var Image:PictureType;FileName:string);
procedure LoadTGA(var Image:PictureType;FileName:string);
procedure DrawPicture(x1,y1:word;Image:PictureType;BeginPart,EndPart:byte);
procedure KillPicture(var Image:PictureType);
procedure InitPage(var SomePage:PageType);
procedure SetActivePage(SomePage:PageType);
procedure CopyPage(Source:PageType;var Destination:PageType);
procedure CopyPageToVGA(SomePage:PageType);
procedure CopyVGAToPage(var SomePage:PageType);
procedure KillPage(SomePage:PageType);
procedure InitMap(var SomeMap:MapType);
procedure AddHotArea(var SomeMap:MapType;Name:string;bx1,by1,ex1,ey1,bx2,by2,ex2,ey2:word);
procedure RenderHotAreas(var SomeMap:MapType);
function PollHotAreas(SomeMap:MapType):string;
procedure KillMap(var SomeMap:MapType);
procedure FlipImage(var SomeImage:ImageType);
procedure MirrorImage(var SomeImage:ImageType);
procedure InitMovie(var SomeMovie:MovieType);
procedure AddSomeFrame(var SomeMovie:MovieType;x1,y1,x2,y2:word);
procedure PlayMovie(SomeMovie:MovieType;pX,pY:word;UsePalette:boolean;Direction:DirectionType);
procedure KillMovie(var SomeMovie:MovieType);
implementation
uses CRT,Mouse,Memory;
const
PI = 3.1415926;
VGA:Word = $a000;
IOOk = 0;
type
ByteBitType = array[1..8] of boolean;
PaletteFileType = file of ColorType;
YAsmLookUpType = array[0..300] of word;
var
{Hold the sin and cos tables}
SinRadiusTable,CosRadiusTable:TableType;
{The current drawing color used in practically every procedure}
CurrentDrawingColor:byte;
{Determines if InitGraph has been called}
HasBeenInitialized:boolean;
{Point to the location of the invisible cursor (WriteString)}
CurrentTextX,CurrentTextY:word;
{A lookup table for the y cords. (y-1)*320}
AsmLookUp:YAsmLookUpType;
{The current page}
ActivePage:PageType;
{The segment and offset of the current page}
CurSeg,CurOfs:word;
{Converts degrees to radians}
function DegreesToRadians(Degrees:real):real;
begin
DegreesToRadians:=PI*Degrees/180;
end; {DegreeesToRadians}
{Converts radians to degrees}
function RadiansToDegrees(Radians:real):real;
begin
RadiansToDegrees:=180*Radians/PI;
end; {RadiansToDegrees}
{If you don't call InitGraph, feel the wrath!}
procedure AnnoyingErrorMessage;
begin
if not HasBeenInitialized then begin
writeln('Error #666: The screen has not be initialized. Please call InitGraph;');
halt;
end; {if}
end; {AnnoyingErrorMessage}
{Goes into 320x200x256 mode}
procedure SetMCGA;
begin
asm
mov ax,0013h
int 10h
end; {asm}
end; {SetMCGA}
{Sets MCGA mode and does some lookup tables}
procedure InitGraph;
var
x,Radius:integer;
Constant:real;
ymov,tymov:word;
begin
HasBeenInitialized:=TRUE;
Constant:=PI/180;
writeln('Computing y lookup table...');
for x:=0 to 200 do begin
ymov:=x shl 6;
tymov:=ymov;
ymov:=ymov shl 2;
ymov:=ymov+tymov;
AsmLookUp[x]:=ymov;
end; {for}
writeln('Computing sine and cosine lookup tables...');
for Radius:=0 to 300 do
for x:=0 to 45 do begin
SinRadiusTable[x,Radius]:=trunc(sin(x*Constant)*Radius);
CosRadiusTable[x,Radius]:=trunc(cos(x*Constant)*Radius);
end; {for}
CurrentTextX:=0; CurrentTextY:=0;
SetMCGA;
SetColor(15);
ActivePage:=TheScreen;
CurSeg:=$a000;
CurOfs:=0000;
TheScreen.Segment:=$a000;
TheScreen.Offset:=$0000;
TheScreen.Page:=ptr($a000,0000);
end; {InitGraph}
{Returns to text mode}
procedure CloseGraph;
begin
asm
mov ax,0003h
int 10h
end; {asm}
writeln('This program uses Mark Rosen''s graphics library.');
writeln('Send E-Mail to mrosen@peganet.com for more information');
end; {CloseGraph}
{Sets the current color}
procedure SetColor(AColor:byte);
begin
AnnoyingErrorMessage;
CurrentDrawingColor:=AColor;
end; {SetColor}
{Returns the current color}
function GetColor:byte;
begin
AnnoyingErrorMessage;
GetColor:=CurrentDrawingColor;
end; {GetColor}
{Draws a pixel at (x,y)}
procedure PutPixel(x,y:word);
var
t:word;
begin
t:=AsmLookUp[y];
asm
mov es,[CurSeg]
mov di,[t]
add di,[CurOfs]
add di,[X]
mov al,[CurrentDrawingColor]
mov es:[di],al
end; {asm}
end; {PutPixel}
{Returns the color at (x,y)}
function GetPixel(x,y:word):byte;
var
TempColor:byte;
t:word;
begin
AnnoyingErrorMessage;
t:=AsmLookUp[y mod 320];
x:=x mod 320;
asm
mov es,[CurSeg]
mov di,[t]
add di,[CurOfs]
add di,[x]
mov al,es:[di]
mov [TempColor],al
end; {asm}
GetPixel:=TempColor;
end; {GetPixel}
{Sets a color register to a color}
procedure SetPalette(ColorNumber:byte;AColor:ColorType);
begin
AnnoyingErrorMessage;
asm
mov dx,3c8h
mov al,[ColorNumber]
out dx,al
inc dx
mov al,[AColor.Red]
out dx,al
mov al,[AColor.Green]
out dx,al
mov al,[AColor.Blue]
out dx,al
end; {asm}
end; {SetAPaletteEntry}
{Returns the contents of a color register}
procedure GetPalette(ColorNumber:byte;var TheColor:ColorType);
var
Rt,Gt,Bt:byte;
begin
AnnoyingErrorMessage;
Rt:=TheColor.Red; Gt:=TheColor.Green; Bt:=TheColor.Blue;
asm
mov dx, 3c7h
mov al, [ColorNumber]
out dx, al
inc dx
inc dx
in al, dx
mov [Rt],al
in al, dx
mov [Gt],al
in al, dx
mov [Bt],al
end; {asm}
TheColor.Red:=Rt; TheColor.Green:=Gt; TheColor.Blue:=Bt;
end; {GetAPaletteEntry}
{Fades the screen to black, destroying the palette}
procedure FadeScreen(Speed:SpeedRangeType);
var
HaveChangedSomething:boolean;
CurrentColor:ColorType;
x,Counter:integer;
begin
AnnoyingErrorMessage;
HaveChangedSomething:=TRUE;
while HaveChangedSomething do begin
Delay(5*(10-Speed));
HaveChangedSomething:=FALSE;
for x:=0 to 255 do begin
GetPalette(x,CurrentColor);
if CurrentColor.Red<>0 then begin
dec(CurrentColor.Red);
HaveChangedSomething:=TRUE;
end; {if}
if CurrentColor.Green<>0 then begin
dec(CurrentColor.Green);
HaveChangedSomething:=TRUE;
end; {if}
if CurrentColor.Blue<>0 then begin
dec(CurrentColor.Blue);
HaveChangedSomething:=TRUE;
end; {if}
SetPalette(x,CurrentColor);
end; {for}
end; {while}
end; {FadeScreen}
{Rotates all colors from Start to Finish}
procedure RotatePalette(Start,Finish:byte);
var
x:byte;
Holding,Temp:ColorType;
begin
AnnoyingErrorMessage;
GetPalette(Start,Holding);
for x:=Start+1 to Finish do begin
GetPalette(x,Temp);
SetPalette(x-1,Temp);
end; {for}
SetPalette(Finish,Holding);
end; {RotatePalette}
{Stores the contents of a file into FileName}
procedure SavePalette(FileName:string);
var
Food:PaletteFileType;
TempColor:ColorType;
x:byte;
begin
AnnoyingErrorMessage;
assign(Food,FileName);
rewrite(Food);
for x:=0 to 255 do begin
GetPalette(x,TempColor);
write(Food,TempColor);
end; {for}
close(Food);
end; {SavePalette}
{Loads a palette from disk; must be valid}
procedure LoadPalette(FileName:string);
var
Food:PaletteFileType;
TempColor:ColorType;
x:byte;
begin
AnnoyingErrorMessage;
assign(Food,FileName);
{$I-}
Reset(Food);
{$I+}
if IOResult=IOOk then begin
for x:=0 to 255 do begin
Read(Food,TempColor);
SetPalette(x,TempColor);
end; {for}
Close(Food);
end; {if}
end; {LoadPalette}
{Draws a circle on the screen; a bit irregular because of rounding errors}
procedure Circle(x,y,Radius:word);
var
Angle,RealX,RealY,
XPlusRealX,XMinusRealX,XPlusRealY,XMinusRealY,
YPlusRealY,YMinusRealY,YPlusRealX,YMinusRealX:word;
begin
for Angle:=0 to 45 do begin
RealX:=CosRadiusTable[Angle,Radius];
RealY:=SinRadiusTable[Angle,Radius];
XPlusRealX:=x+RealX; XPlusRealY:=x+RealY;
XMinusRealX:=x-RealX; XMinusRealY:=x-RealY;
YPlusRealY:=y+RealY; YPlusRealX:=y+RealX;
YMinusRealY:=y-RealY; YMinusRealX:=y-RealX;
putpixel(XPlusRealX,YPlusRealY);
putpixel(XPlusRealX,YMinusRealY);
putpixel(XMinusRealX,YPlusRealY);
putpixel(XMinusRealX,YMinusRealY);
putpixel(XPlusRealY,YPlusRealX);
putpixel(XPlusRealY,YMinusRealX);
putpixel(XMinusRealY,YPlusRealX);
putpixel(XMinusRealY,YMinusRealX);
end; {for}
end; {Circle}
procedure SwapW(var a,b:word);
var
Temp:word;
begin
Temp:=a;
a:=b;
b:=Temp;
end; {SwapW}
procedure SwapB(var a,b:byte);
var
Temp:word;
begin
Temp:=a;
a:=b;
b:=Temp;
end; {SwapB}
{Draws a vertical line on the screen}
procedure VerticalLine(BeginX,BeginY,EndY:word);
var
y:word;
begin
if BeginY>EndY then swapW(BeginY,EndY);
for y:=BeginY to EndY do
putpixel(BeginX,y);
end; {VerticalLine}
{Draws a horizontal line on the screen really quickly}
procedure HorizontalLine(BeginX,EndX,BeginY:word);
var
t,size:word;
begin
t:=AsmLookUp[BeginY mod 200];
size:=abs(EndX-BeginX);
asm
mov es,[CurSeg]
mov di,[t]
add di,[BeginX]
add di,[CurOfs]
mov al,[CurrentDrawingColor]
mov cx,[size]
rep stosb
end; {asm}
end; {HorizontalLine}
{Draws a line from (x1,y1) to (x2,y2) using Bresenham's algorithm}
procedure Line(x1, y1, x2, y2 : word);
var i,DeltaX,DeltaY,numpixels,
d,dinc1,dinc2,
x,xinc1,xinc2,
y,yinc1,yinc2:integer;
begin
DeltaX:=abs(x2-x1);
DeltaY:=abs(y2-y1);
if x1=x2 then
VerticalLine(x1,y2,y2)
else if y1=y2 then
HorizontalLine(x1,x2,y1)
else begin
if DeltaX>=deltay then begin
numpixels:=DeltaX+1;
d:= (2*deltay)-DeltaX;
dinc1:=deltay shl 1;
dinc2:=(deltay-DeltaX) shl 1;
xinc1:=1;
xinc2:=1;
yinc1:=0;
yinc2:=1;
end {if}
else begin
numpixels:=deltay+1;
d:=(2*DeltaX)-deltay;
dinc1:=DeltaX shl 1;
dinc2:=(DeltaX-deltay) shl 1;
xinc1:= 0;
xinc2:= 1;
yinc1:=1;
yinc2:=1;
end; {else}
if x1 > x2 then begin
xinc1:=-xinc1;
xinc2:=-xinc2;
end; {if}
if y1>y2 then begin
yinc1:=-yinc1;
yinc2:=-yinc2;
end; {if}
x:=x1;
y:=y1;
for i := 1 to numpixels do begin
PutPixel(x,y);
if d < 0 then begin
d:= d+dinc1;
x:= x+xinc1;
y:= y+yinc1;
end {f}
else begin
d:= d+dinc2;
x:= x+xinc2;
y:= y+yinc2;
end; {else}
end; {for}
end; {else}
end; {Line}
{Draws a filled box on the screen}
procedure Bar(BeginX,BeginY,EndX,EndY:word);
var
y,t,x:word;
size:word;
begin
AnnoyingErrorMessage;
size:=abs(EndX-BeginX);
for y:=BeginY to EndY do begin
t:=AsmLookUp[y];
asm
mov cx,[size]
mov al,[CurrentDrawingColor]
mov es,[CurSeg]
mov di,[t]
add di,[CurOfs]
add di,[BeginX]
rep stosb
mov di,[t]
add di,[CurOfs]
add di,[size]
add di,[BeginX]
stosb
end; {asm}
end; {for}
end; {Box}
{Draws a rectangle on the screen}
procedure Rectangle(BeginX,BeginY,EndX,EndY:word);
begin
AnnoyingErrorMessage;
HorizontalLine(BeginX,EndX,BeginY);
HorizontalLine(BeginX,EndX,EndY);
VerticalLine(BeginX,BeginY,EndY);
VerticalLine(EndX,BeginY,EndY);
end; {Rectangle}
{Allocates some memory and stores parts of the screen into it}
procedure GetImage(var Image:ImageType;x1,y1,x2,y2:word);
var
yImg,yShl,x,y,size,vSeg,vOfs:word;
begin
Image.DeltaX:=abs(x1-x2); Image.DeltaY:=abs(y1-y2);
GetMem(Image.Image,(Image.DeltaX+1)*(Image.DeltaY+1));
Image.vSegment:=seg(Image.Image^); vSeg:=Image.vSegment;
Image.vOffset:=ofs(Image.Image^); vOfs:=Image.vOffset;
size:=Image.DeltaX+1;
yImg:=0;
for y:=0 to Image.DeltaY do begin
YShl:=AsmLookUp[y+y1];
asm
mov cx,[size]
@1:
mov es,[CurSeg]
mov di,[CurOfs]
add di,[YShl]
add di,cx
add di,[x1]
dec di
mov al,es:[di]
mov es,[vSeg]
mov di,[vOfs]
add di,[YImg]
add di,cx
dec di
mov es:[di],al
dec cx
jnz @1
end; {asm}
yImg:=yImg+Image.DeltaX+1;
end; {for}
end; {GetImage}
{Transfers a stored image from memory to the screen}
procedure PutImage(Image:ImageType;x1,y1:word);
var
yImg,yShl:word;
x,y:word;
begin
yImg:=0;
for y:=0 to Image.DeltaY do begin
yShl:=AsmLookUp[y+y1];
asm
mov cx,[Image.DeltaX]
inc cx
@1:
mov es,[Image.vSegment]
mov di,[Image.vOffset]
add di,[yImg]
add di,cx
dec di
mov al,es:[di]
mov es,[CurSeg]
mov di,[CurOfs]
add di,[yShl]
add di,[x1]
add di,cx
dec di
mov es:[di],al
dec cx
jnz @1
end; {asm}
yImg:=yImg+Image.DeltaX+1;
end; {for}
end; {PutImage}
{Deallocates the memory used by the image}
procedure KillImage(var Image:ImageType);
begin
AnnoyingErrorMessage;
FreeMem(Image.Image,(Image.DeltaX+1)*(Image.DeltaY+1));
end; {KillImage}
{I can't remember the exp(ln) thing}
function Exp(base,exponent:word):word;
var
Temp,x:word;
begin
Temp:=1;
for x:=1 to exponent do
Temp:=Temp*base;
Exp:=Temp;
end; {Exp}
{Converts a byte to binary notation (array of booleans)}
procedure ConvertDecimalToBinary(Something:byte;var Bin:ByteBitType);
var
x:byte;
temp:word;
begin
for x:=1 to 8 do
Bin[x]:=FALSE;
for x:=7 downto 0 do begin
temp:=trunc(Something div Exp(2,x));
if temp>0 then Something:=Something-Exp(2,x);
if temp=1 then
Bin[x+1]:=TRUE;
end; {for}
end; {ConvertDecimalToBinary}
{Draws a character on the screen from ROM}
procedure PutChar(Font:FontEnumeratedType;xc,yc:word;AChar:char);
var
x,y:word;
Line:byte;
Temp:ByteBitType;
begin
AnnoyingErrorMessage;
for y:=0 to 7 do begin
Line:=Mem[$F000:$FA6E+(ord(AChar)*8)+y];
ConvertDecimalToBinary(Line,Temp);
for x:=1 to 8 do
if Temp[x] then putpixel((9-x)+xc,y+yc);
end;
end; {PutChar}
{Draws a string at (x,y), looping at the end of the screen}
procedure WriteStringXY(Font:FontEnumeratedType;xc,yc:word;Thing:string);
var
TempX,TempY:word;
x:byte;
begin
AnnoyingErrorMessage;
TempX:=xc; TempY:=yc;
for x:=1 to ord(Thing[0]) do begin
PutChar(Font,TempX,TempY,Thing[x]);
TempX:=TempX+8;
if TempX>311 then begin
TempX:=1;
TempY:=TempY+8;
end; {if}
end; {for}
end; {WriteStringXY}
{Draws a string at the current text location, wrapping at the end}
procedure WriteString(Font:FontEnumeratedType;Thing:string);
var
TempX,TempY:word;
x:byte;
begin
AnnoyingErrorMessage;
TempX:=CurrentTextX; TempY:=CurrentTextY;
for x:=1 to ord(Thing[0]) do begin
PutChar(Font,TempX,TempY,Thing[x]);
TempX:=TempX+8;
if TempX>311 then begin
TempX:=1;
TempY:=TempY+8;
end; {if}
end; {for}
CurrentTextX:=CurrentTextX+TempX;
CurrentTextY:=CurrentTextY+TempY;
end; {WriteString}
{Flips an image from left-right}
procedure FlipImage(var SomeImage:ImageType);
var
ey,by,HalfY,x,y:word;
p1seg,p1ofs,p2seg,p2ofs:word;
DeltaXPlus,DeltaYPlus:word;
Temp:byte;
begin
DeltaXPlus:=SomeImage.DeltaX+1; DeltaYPlus:=SomeImage.DeltaY+1;
HalfY:=((DeltaYPlus) div 2)-1;
by:=SomeImage.vOffset; ey:=SomeImage.vOffset+(DeltaXPlus*DeltaYPlus);
p1seg:=SomeImage.vSegment; p2seg:=SomeImage.vSegment;
for y:=0 to HalfY do begin
ey:=ey-DeltaXPlus;
for x:=0 to SomeImage.DeltaX do begin
Temp:=Mem[p1seg:by];
Mem[p1seg:by]:=Mem[p2seg:ey];
Mem[p2seg:ey]:=Temp;
inc(ey);
inc(by);
end; {for}
ey:=ey-DeltaXPlus;
end; {for}
end; {FlipImage}
{Loads a valid PCX file onto the screen}
procedure LoadPCX(var Image:PictureType;FileName:string);
var
fp:file;
numbytes,index,pSeg,pOfs,vSeg,vOfs:word;
count,imgSize,fpcnt,x,size:word;
dataval:byte;
ImagePtr:pointer;
TempColor:ColorType;
begin
assign(fp, FileName);
{$I-}
reset(fp,1);
{$I+}
if IOResult<>IOOk then begin
CloseGraph;
writeln('Error 111: You specified an invalid file name when calling LoadPCX');
halt;
end; {if}
size:=filesize(fp);
GetMem(ImagePtr,size);
blockread(fp,ImagePtr^,size);
vSeg:=seg(ImagePtr^); vOfs:=ofs(ImagePtr^);
new(Image.palette);
Image.Picture.DeltaX:=Mem[vSeg:vOfs+8] + (Mem[vSeg:vOfs+9] shl 8);
Image.Picture.DeltaY:=Mem[vSeg:vOfs+10] + (Mem[vSeg:vOfs+11] shl 8);
imgSize:=(Image.Picture.DeltaX+1)*(Image.Picture.DeltaY+1);
GetMem(image.picture.image,imgSize);
pSeg:=seg(Image.Picture.Image^); pOfs:=ofs(Image.Picture.Image^);
Image.Picture.vSegment:=pSeg; Image.Picture.vOffset:=pOfs;
count:=0;
fpcnt:=128;
while count<imgSize do begin
dataval:=Mem[vSeg:vOfs+fpcnt];
inc(fpcnt);
if (dataval>=192) and (dataval<=255) then begin
numbytes:=dataval-192;
dataval:=Mem[vSeg:vOfs+fpcnt];
inc(fpcnt);
asm
mov cx,[numbytes]
mov es,[pSeg]
mov di,[pOfs]
add di,[count]
mov al,[dataval]
rep stosb
end; {Asm}
count:=count+numbytes;
end {if}
else begin
asm
mov es,[pSeg]
mov di,[pOfs]
add di,[count]
mov al,[dataval]
mov es:[di],al
end; {asm}
count:=count+1;
end; {else}
end; {for}
fpcnt:=size-768;
for x:=0 to 255 do begin
index:=3*x;
TempColor.Red:=Mem[vSeg:vOfs+index+fpcnt] shr 2;
TempColor.Green:=Mem[vSeg:vOfs+index+1+fpcnt] shr 2;
TempColor.Blue:=Mem[vSeg:vOfs+index+2+fpcnt] shr 2;
image.palette^[x]:=TempColor;
end; {for}
FreeMem(ImagePtr,size);
close(fp);
end; {LoadPCX}
{Loads a valid TGA onto the screen}
procedure LoadTGA(var Image:PictureType;FileName:string);
var
fp:file;
TempPalAndHeadPtr:pointer;
TempImage:ImageType;
vSeg,vOfs,x:word;
TempColor:ColorType;
begin
assign(fp,FileName);
reset(fp,1); {no error checking as of yet}
GetMem(TempPalAndHeadPtr,786);
new(Image.Palette);
BlockRead(fp,TempPalAndHeadPtr^,786);
vSeg:=seg(TempPalAndHeadPtr^); vOfs:=ofs(TempPalAndHeadPtr^);
Image.Picture.DeltaX:=(Mem[vSeg:vOfs+13] shl 8)+Mem[vSeg:vOfs+12]-1;
Image.Picture.DeltaY:=(Mem[vSeg:vOfs+15] shl 8)+Mem[vSeg:vOfs+14]-1;
vOfs:=vOfs+18;
for x:=0 to 255 do begin
TempColor.Blue:=Mem[vSeg:vOfs] shr 2;
vOfs:=vOfs+1;
TempColor.Green:=Mem[vSeg:vOfs] shr 2;
vOfs:=vOfs+1;
TempColor.Red:=Mem[vSeg:vOfs] shr 2;
vOfs:=vOfs+1;
Image.Palette^[x]:=TempColor;
end; {for}
GetMem(Image.Picture.Image,(Image.Picture.DeltaX+1)*(Image.Picture.DeltaY+1));
Image.Picture.vSegment:=seg(Image.Picture.Image^);
Image.Picture.vOffset:=ofs(Image.Picture.Image^);
seek(fp,786);
BlockRead(fp,Image.Picture.Image^,(Image.Picture.DeltaX+1)*(Image.Picture.DeltaY+1));
FreeMem(TempPalAndHeadPtr,786);
FlipImage(Image.Picture);
close(fp);
end; {LoadTGA}
{Draws a picture and a specifed part of the palette}
procedure DrawPicture(x1,y1:word;Image:PictureType;BeginPart,EndPart:byte);
var
x,vSeg,vOfs:word;
Color:byte;
begin
for x:=BeginPart to EndPart do
setpalette(x,Image.Palette^[x]);
PutImage(Image.Picture,x1,y1);
end; {DrawPicture}
{Deallocates the memory used by a picture}
procedure KillPicture(var Image:PictureType);
begin
KillImage(Image.Picture);
dispose(Image.Palette);
end; {KillPicture}
{Initializes the array structure for a gradated palette}
procedure InitGradatedPalette(var SomePalette:GradatedPaletteType);
var
Black:ColorType;
x:byte;
begin
AnnoyingErrorMessage;
new(SomePalette);
Black.Red:=0; Black.Green:=0; Black.Blue:=0;
for x:=0 to 255 do begin
SomePalette^[x].Color:=Black;
SomePalette^[x].IsAPoint:=FALSE;
end; {for}
end; {InitGradatedPalette}
{Adds a key point to the gradated palette}
procedure AddKeyPoint(var SomePalette:GradatedPaletteType;Location:byte;
Color:ColorType);
begin
AnnoyingErrorMessage;
SomePalette^[Location].Color:=Color;
SomePalette^[Location].IsAPoint:=TRUE;
SomePalette^[Location].Location:=Location;
end; {AddKeyPoint}
{Generates a palette based on the current key points}
procedure GeneratePalette(SomePalette:GradatedPaletteType);
var
TempColor:ColorType;
Temp1,Temp2:ColorRecordType;
Location1,Location2:byte;
x,y:byte;
Number:byte;
Temp:array[0..255] of ColorRecordType;
RealRed,RealGreen,RealBlue,
IncRed,IncGreen,IncBlue:real;
DeltaLoc:word;
begin
AnnoyingErrorMessage;
Number:=0;
{Condense the palette into only hot points}
for x:=0 to 255 do begin
if SomePalette^[x].IsAPoint then begin
Temp[Number]:=SomePalette^[x];
Number:=Number+1;
end; {if}
end; {for}
{actually gradate the palette}
for x:=0 to Number-1 do begin
Location1:=Temp[x].Location;
Location2:=Temp[x+1].Location;
DeltaLoc:=abs(Location2-Location1);
RealRed:=Temp[x].Color.Red; RealGreen:=Temp[x].Color.Green;
RealBlue:=Temp[x].Color.Blue;
IncRed:=(Temp[x+1].Color.Red-Temp[x].Color.Red)/DeltaLoc;
IncGreen:=(Temp[x+1].Color.Green-Temp[x].Color.Green)/DeltaLoc;
IncBlue:=(Temp[x+1].Color.Blue-Temp[x].Color.Blue)/DeltaLoc;
for y:=Location1 to Location2 do begin
TempColor.Red:=trunc(RealRed); TempColor.Green:=trunc(RealGreen);
TempColor.Blue:=trunc(RealBlue);
setpalette(y,TempColor);
RealRed:=RealRed+IncRed;
RealGreen:=RealGreen+IncGreen;
RealBlue:=RealBlue+IncBlue;
end; {for}
end; {for}
end; {GeneratePalette}
{Deallocates the memory used by a gradated palette}
procedure KillGradatedPalette(var SomePalette:GradatedPaletteType);
begin
AnnoyingErrorMessage;
dispose(SomePalette);
end; {KillGradatedPalette}
{Initalizes the characteristics of a fire}
procedure InitFire(var SomeFire:FireType;x1,y1,x2,y2:word;BeginPal,EndPal:byte);
var
Test:GradatedPaletteType;
Temp:ColorType;
x:byte;
ymov,tymov:word;
begin
InitGradatedPalette(Test);
Temp.Red:=63; Temp.Green:=63; Temp.Blue:=0;
AddKeyPoint(Test,EndPal,Temp);
Temp.Red:=63; Temp.Green:=0; Temp.Blue:=0;
AddKeyPoint(Test,(BeginPal+EndPal) div 2,Temp);
Temp.Red:=0; Temp.Green:=0; Temp.Blue:=0;
AddKeyPoint(Test,BeginPal,Temp);
GeneratePalette(Test);
SomeFire.c:=y1+abs(y2-y1) div 2;
SomeFire.last:=AsmLookUp[y2];
SomeFire.x1:=x1; SomeFire.y1:=y1;
SomeFire.x2:=x2; SomeFire.y2:=y2;
SomeFire.PalBegin:=BeginPal;
SomeFire.PalEnd:=EndPal;
SomeFire.PalLen:=abs(BeginPal-EndPal);
end; {InitFire}
{Actually draws one iteration of the fire onto the screen}
procedure DoFire(SomeFire:FireType);
var
x,y,cury,curyn:word;
t1,t2,t:byte;
begin
cury:=somefire.last;
for x:=SomeFire.x1 to SomeFire.x2 do begin
t:=random(SomeFire.PalLen)+SomeFire.PalBegin;
asm
mov es,[CurSeg]
mov di,[Cury]
add di,[CurOfs]
add di,[X]
mov al,[t]
mov es:[di],al
end; {asm}
end; {for}
for y:=SomeFire.y2-1 downto SomeFire.y1+1 do begin
cury:=AsmLookUp[y];
curyn:=AsmLookUp[y+1];
for x:=SomeFire.x1+1 to SomeFire.x2-1 do begin
asm
mov es,[CurSeg]
mov di,[curyn]
add di,[X]
add di,[CurOfs]
mov al,es:[di-1]
mov [t1],al
mov al,es:[di+1]
mov [t2],al
end;
t:=(t1+t2) shr 1;
if (t>0) and (y<SomeFire.c) then t:=t-1;
if t<SomeFire.PalBegin then t:=SomeFire.PalBegin;
asm
mov es,[CurSeg]
mov di,[cury]
add di,[CurOfs]
add di,[X]
mov al,[t]
mov es:[di],al
end; {asm}
end; {for}
end; {for}
end; {DoFire}
{Clears the screen really quickly}
procedure ClearScreen;
begin
CurrentTextX:=0;
CurrentTextY:=0;
asm
mov ax,0
mov es,[CurSeg]
mov di,[CurOfs]
{A word is two bytes}
mov cx,32000
rep stosw
end; {asm}
end; {ClearScreen}
{Initaizlizes the dynamic music used by a page}
procedure InitPage(var SomePage:PageType);
var
vseg,vofs:word;
begin
new(SomePage.page);
SomePage.Segment:=seg(SomePage.Page^);
SomePage.Offset:=ofs(SomePage.Page^);
vseg:=SomePage.Segment;
vofs:=SomePage.Offset;
asm
mov ax,0
mov es,[vseg]
mov di,[vofs]
mov cx,32000
rep stosw
end; {asm}
end; {InitPage}
{Sets the active page}
procedure SetActivePage(SomePage:PageType);
begin
ActivePage:=SomePage;
CurSeg:=SomePage.Segment;
CurOfs:=SomePage.Offset;
end; {SetActivePage}
{Copies the contents of a page into another page}
procedure CopyPage(Source:PageType;var Destination:PageType);
var
v1seg,v1ofs,v2seg,v2ofs:word;
begin
v1Seg:=Source.Segment; v1ofs:=Source.Offset;
v2Seg:=Destination.segment; v2ofs:=Destination.offset;
asm
mov cx,64000
mov bx,[v1ofs]
mov dx,[v2ofs]
@1:
mov es,[v1seg]
mov di,cx
add di,bx
mov al,es:[di]
mov es,[v2seg]
mov di,cx
add di,dx
mov es:[di],al
dec cx
jnz @1
end; {asm}
end; {CopyPage}
{Optimized for copying the contents of a page into the VGA memory}
procedure CopyPageToVGA(SomePage:PageType);
var
vaddr:word;
begin
vaddr:=SomePage.segment;
asm
mov cx,64000
mov bx,OFFSET [SomePage]
@1:
mov es,[vaddr]
mov di,cx
add di,bx
mov al,es:[di]
mov es,[VGA]
mov es:[di],al
dec cx
jnz @1
end; {asm}
end; {CopyPageToVGA}
{Copies the contents of the Video buffer into a page}
procedure CopyVGAToPage(var SomePage:PageType);
var
vaddr:word;
begin
vaddr:=SomePage.Segment;
asm
mov cx,64000
mov bx,OFFSET [SomePage]
@1:
mov es,[VGA]
mov al,es:[di]
mov es,[vaddr]
mov di,cx
add di,bx
mov es:[di],al
dec cx
jnz @1
end; {asm}
end; {CopyPageToVGA}
{Disposes the dynamic memory used by the paging procedures}
procedure KillPage(SomePage:PageType);
begin
dispose(SomePage.Page);
end; {KillPage}
{Initializes the linked-list structure used by the maps}
procedure InitMap(var SomeMap:MapType);
begin
SomeMap.First:=nil;
SomeMap.Last:=nil;
SomeMap.NumItems:=0;
InitPage(SomeMap.Render);
SomeMap.Rendered:=FALSE;
end; {InitMap}
{Adds a hot area, defined by four coordinates, to the linked list}
procedure AddHotArea(var SomeMap:MapType;Name:string;bx1,by1,ex1,ey1,bx2,by2,ex2,ey2:word);
var
Temp:MapNodePtr;
TempCord:CordType;
begin
new(Temp);
{nothing in the list}
if SomeMap.First=nil then begin
SomeMap.First:=Temp;
SomeMap.Last:=Temp;
end {if}
else
SomeMap.Last^.next:=Temp;
SomeMap.Last:=Temp;
Temp^.next:=nil;
Temp^.Name:=Name;
TempCord.x:=bx1; TempCord.y:=by1;
Temp^.b1:=TempCord;
TempCord.x:=ex1; TempCord.y:=ey1;
Temp^.e1:=TempCord;
TempCord.x:=bx2; TempCord.y:=by2;
Temp^.b2:=TempCord;
TempCord.x:=ex2; TempCord.y:=ey2;
Temp^.e2:=TempCord;
SomeMap.NumItems:=SomeMap.NumItems+1;
Temp^.number:=SomeMap.NumItems;
end; {AddHotArea}
{Checks and sees if the mouse is inside some area}
function CheckIfMouseInside(CurrentNode:MapNodeType):boolean;
begin
CheckIfMouseInside:=(GetPixel(GetMouseX,GetMouseY)=CurrentNode.Number) and ButtonDown;
end; {CheckIfMouseInside}
{For efficency, the image mapping procedures use a page that denotes
the pre-rendered locations of each hot-area}
procedure RenderHotAreas(var SomeMap:MapType);
var
Temp:MapNodePtr;
OldPage:PageType;
OldSeg,OldOfs:word;
OldColor:byte;
begin
OldColor:=GetColor;
OldSeg:=CurSeg; OldOfs:=CurOfs;
OldPage:=ActivePage;
SetActivePage(SomeMap.Render);
Temp:=SomeMap.First;
{There are only 256 colors in the display, so you will get some
errors if you try to add more than 256 hot-areas}
while (Temp<>nil) do begin
setcolor(Temp^.number);
line(Temp^.b1.x,Temp^.b1.y,Temp^.e1.x,Temp^.e1.y);
line(Temp^.e1.x,Temp^.e1.y,Temp^.b2.x,Temp^.b2.y);
line(Temp^.b2.x,Temp^.b2.y,Temp^.e2.x,Temp^.e2.y);
line(Temp^.e2.x,Temp^.e2.y,Temp^.b1.x,Temp^.b1.y);
Fill((Temp^.b1.x+Temp^.e1.x) div 2,(Temp^.b1.y+Temp^.b2.y) div 2,Temp^.number,Temp^.number);
Temp:=Temp^.next;
end; {while}
ActivePage:=OldPage;
CurSeg:=OldSeg;
CurOfs:=OldOfs;
SetColor(OldColor);
end; {RenderHotAreas}
{Sees if the user has clicked on a hot area}
function PollHotAreas(SomeMap:MapType):string;
var
Temp:MapNodePtr;
OldPage:PageType;
OldSeg,OldOfs:word;
begin
OldSeg:=CurSeg; OldOfs:=CurOfs;
OldPage:=ActivePage;
SetActivePage(SomeMap.Render);
Temp:=SomeMap.First;
while (Temp<>nil) and not CheckIfMouseInside(Temp^) do
Temp:=Temp^.next;
if Temp=nil then
PollHotAreas:=Nothing
else
PollHotAreas:=Temp^.name;
ActivePage:=OldPage;
CurSeg:=OldSeg; CurOfs:=OldOfs;
end; {PollHotAreas}
{Deallocates the dynamic memory used in the mapping procedures}
procedure KillMap(var SomeMap:MapType);
var
TempPtr,NextPtr:MapNodePtr;
begin
TempPtr:=SomeMap.First;
while (TempPtr<>nil) do begin
NextPtr:=TempPtr^.next;
dispose(TempPtr);
TempPtr:=NextPtr;
end; {while}
KillPage(SomeMap.Render);
end; {KillMap}
{Mirrors an image from top-bottom}
procedure MirrorImage(var SomeImage:ImageType);
var
TempImage:ImageType;
p1Seg,p1Ofs,p2Seg,p2Ofs,HalfX,x,y:word;
DeltaXPlus,DeltaYPlus:word;
Temp:byte;
begin
DeltaXPlus:=SomeImage.DeltaX+1; DeltaYPlus:=SomeImage.DeltaY+1;
HalfX:=((DeltaXPlus) div 2)-1;
for x:=0 to HalfX do begin
for y:=0 to SomeImage.DeltaY do begin
p1seg:=SomeImage.vSegment;
p1ofs:=SomeImage.vOffset+(y*(DeltaXPlus))+x;
p2seg:=SomeImage.vSegment;
p2ofs:=SomeImage.vOffset+(y*(DeltaXPlus))+abs(SomeImage.DeltaX-x);
Temp:=Mem[p1seg:p1ofs];
Mem[p1seg:p1ofs]:=Mem[p2seg:p2ofs];
Mem[p2seg:p2ofs]:=Temp;
end; {for}
end; {for}
end; {MirrorImage}
{Initializes the movie doubly linked-list structure}
procedure InitMovie(var SomeMovie:MovieType);
begin
SomeMovie.Front:=nil;
SomeMovie.Last:=nil;
SomeMovie.NumFrames:=0;
end; {InitMovie}
{Adds a frame to the end of the movie linked list}
procedure AddSomeFrame(var SomeMovie:MovieType;x1,y1,x2,y2:word);
var
TempPtr:MovieNodePtr;
TempColor:ColorType;
x:word;
begin
new(TempPtr);
new(TempPtr^.Palette);
GetImage(TempPtr^.Picture,x1,y1,x2,y2);
for x:=0 to 255 do
getpalette(x,TempPtr^.Palette^[x]);
TempPtr^.next:=nil;
{No items in the list}
if (SomeMovie.Front=nil) then begin
SomeMovie.Front:=TempPtr;
TempPtr^.Prev:=nil;
end {if}
{Otherwise, do stuff}
else begin
SomeMovie.Last^.next:=TempPtr;
TempPtr^.Prev:=SomeMovie.Last;
end; {else}
SomeMovie.Last:=TempPtr;
SomeMovie.NumFrames:=SomeMovie.NumFrames+1;
end; {AddSomeFrame}
{Waits until the video card has completed the vertical retrace}
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; {WaitRetrace}
{Draws a frame on the screen}
procedure DrawSomething(SomeFrame:MovieNodePtr;pX,pY:word;UsePalette:boolean);
var
x:byte;
begin
WaitRetrace;
PutImage(SomeFrame^.Picture,pX,pY);
if UsePalette then begin
for x:=0 to 255 do begin
SetPalette(x,SomeFrame ^.Palette^[x]);
end; {for}
end; {if}
end; {DrawSomething}
{Plays a movie in the specified direction}
procedure PlayMovie(SomeMovie:MovieType;pX,pY:word;UsePalette:boolean;Direction:DirectionType);
var
x:integer;
TempPtr:MovieNodePtr;
begin
if Direction=Foreward then begin
TempPtr:=SomeMovie.Front;
for x:=1 to SomeMovie.NumFrames do begin
DrawSomething(TempPtr,pX,pY,UsePalette);
TempPtr:=TempPtr^.next;
end; {for}
end {if}
else if Direction=Backward then begin
TempPtr:=SomeMovie.Last;
for x:=1 to SomeMovie.NumFrames do begin
DrawSomething(TempPtr,pX,pY,UsePalette);
TempPtr:=TempPtr^.prev;
end; {for}
end; {if}
end; {PlayMovie}
{Disposes the dynamic memory used by the movie procedures}
procedure KillMovie(var SomeMovie:MovieType);
var
TempPtr,NextPtr:MovieNodePtr;
begin
TempPtr:=SomeMovie.Front;
while (TempPtr<>nil) do begin
NextPtr:=TempPtr^.next;
dispose(TempPtr);
TempPtr:=NextPtr;
end; {while}
SomeMovie.Front:=nil;
SomeMovie.Last:=nil;
SomeMovie.NumFrames:=0;
end; {KillMovie}
{Draws a pixel at the current position at at all the other surreounding
positions}
procedure RecursiveFill(x,y:word;FillColor,Border:byte);
var
Direction:byte;
begin
if (GetPixel(x,y)<>FillColor) and (GetPixel(x,y)<>Border) then begin
putpixel(x,y);
for Direction:=1 to 4 do begin
if (Direction=1) and (y>0) then
RecursiveFill(x,y-1,FillColor,Border)
else if (Direction=2) and (x<319) then
RecursiveFill(x+1,y,FillColor,Border)
else if (Direction=3) and (y<199) then
RecursiveFill(x,y+1,FillColor,Border)
else if (Direction=4) and (x>0) then
RecursiveFill(x-1,y,FillColor,Border);
end; {for}
end; {if}
end; {RecursiveFill}
{The main procedures the initiates the recursive filling}
procedure Fill(x,y:word;FillColor,Border:byte);
var
OldColor:byte;
begin
OldColor:=GetColor;
setcolor(FillColor);
RecursiveFill(x,y,FillColor,Border);
SetColor(OldColor);
end; {Fill}
begin
{The default is no initialization}
HasBeenInitialized:=FALSE;
end. {Graphics}
