unit Xlib;
interface
type
ColorType = record
Red,Green,Blue:byte;
end; {record}
TableType = array[0..45,0..300] of integer;
SpeedRangeType = 0..10;
SizeSubRange = 1..10;
ImageType = record
deltaX,deltaY:longint;
vSegment,vOffset:word;
Image:pointer;
end; {record}
FontEnumeratedType = (Regular);
FontType = record
Size:SizeSubRange;
end; {record}
SomePaletteType = array[0..255] of ColorType;
PictureType = record
picture:ImageType;
Palette:^SomePaletteType;
end; {record}
ColorRecordType = record
Color:ColorType;
IsAPoint:Boolean;
Location:byte;
end; {record}
GradatedPalType = array[0..255] of ColorRecordType;
GradatedPaletteType = ^GradatedPalType;
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 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 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 LoadTGA(var Image:PictureType;FileName:string);
procedure DrawPicture(x1,y1:word;Image:PictureType;BeginPart,EndPart:byte);
procedure KillPicture(var Image:PictureType);
procedure InitGradatedPalette(var SomePalette:GradatedPaletteType);
procedure AddKeyPoint(var SomePalette:GradatedPaletteType;Location:byte;Color:ColorType);
procedure GeneratePalette(SomePalette:GradatedPaletteType);
procedure KillGradatedPalette(var SomePalette:GradatedPaletteType);
implementation
uses CRT;
const
PI = 3.1415926;
VGA:Word = $a000;
IOOk=0;
Video=$10;
Crtc_addr=$3d4;
Sequ_addr=$3c4;
TGASize:longint = 64000;
type
ByteBitType = array[1..8] of boolean;
PCXFileType = file of char;
EGAPalType = array[0..47] of byte;
JunkType = array[0..57] of byte;
PCXHeaderType = record
Manufacturer:char; {for some reason, always 10}
Version:char; {who cares}
Encoding:char; {always 1 for RLE}
BitDepth:char; {should be eight - wierd things if not}
x,y:word; {upper left corner of the image}
width,height:word; {Duh}
HRes,VRes:word; {Number of pixels in x & y direction}
EGAPalette:EGAPalType; {who cares, we use MCGA+}
Reserved:char; {Nothing}
ColorPlanes:char; {Number of color planes in the image}
BytesPerLine:word; {Number of bytes per line}
PaletteType:word; {Unimportant}
Padding:JunkType; {Fat at the end of the file}
end; {PCXHeaderType}
PaletteFileType = file of ColorType;
PortLookUpType = array[0..640] of word;
yLookUpType = array[0..400] of word;
var
SinRadiusTable,CosRadiusTable:TableType;
CurrentDrawingColor:byte;
HasBeenInitialized:boolean;
CurrentTextX,CurrentTextY:word;
PortLookUp:PortLookUpType;
yLookUp:yLookUpType;
CurrentPort:word;
function Abs(x:integer):word;
begin
if x<0 then
Abs:=-x
else
Abs:=x;
end; {Abs}
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}
procedure SetXtended;
begin
asm
mov ax, $4F02
mov bx, $100
int VIDEO
end;
{ Turn the VGA screen off }
Port[SEQU_ADDR] := 1;
Port[SEQU_ADDR + 1] := Port[SEQU_ADDR + 1] or $20;
{ Turn off the Chain-4 bit (bit 3 at index 4, port 0x3c4) }
PortW[SEQU_ADDR] := $0604;
{ Turn off word mode, by setting the Mode Control register
of the CRT Controller (index 0x17, port 0x3d4) }
PortW[CRTC_ADDR] := $E317;
{ Turn off doubleword mode, by setting the Underline Location
register (index 0x14, port 0x3d4) }
PortW[CRTC_ADDR] := $0014;
{ Clear entire video memory, by selecting all four planes, then writing
color 0 to the entire segment. Stoopid FillChar fills 1 byte too short! }
PortW[SEQU_ADDR] := $0F02;
FillChar(Mem[$A000 : 0], $8000, 0);
FillChar(Mem[$A000 : $8000], $8000, 0);
{ Give a small delay to let the screen sort itself out }
Delay(100);
{ Turn the screen back on }
Port[SEQU_ADDR] := 1;
Port[SEQU_ADDR + 1] := Port[SEQU_ADDR + 1] and $DF;
end; {SetXtended}
procedure InitGraph;
var
x,Radius:integer;
Constant:real;
ymov,tymov:word;
begin
HasBeenInitialized:=TRUE;
Constant:=PI/180;
writeln('Computing port lookup table...');
for x:=0 to 640 do
PortLookUp[x]:=$100 shl (x and 3) + 2;
writeln('Computing y lookup table...');
for x:=0 to 400 do
yLookUp[x]:=x shl 7 + x shl 5;
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;
SetXtended;
SetColor(15);
CurrentPort:=PortLookUp[0];
end; {InitGraph}
procedure CloseGraph;
begin
AnnoyingErrorMessage;
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}
procedure SetColor(AColor:byte);
begin
AnnoyingErrorMessage;
CurrentDrawingColor:=AColor mod 256;
end; {SetColor}
function GetColor:byte;
begin
AnnoyingErrorMessage;
GetColor:=CurrentDrawingColor;
end; {GetColor}
procedure PutPixel(x,y:word);
var
t:word;
begin
if CurrentPort<>PortLookUp[x] then begin
PortW[SEQU_ADDR] := PortLookUp[x];
CurrentPort:=PortLookUp[x];
end; {if}
{ Calculate address (y * 160 + x div 4) and write pixel }
Mem[$A000 : yLookUp[y]+x shr 2] := CurrentDrawingColor;
end; {PutPixel}
function GetPixel(x,y:word):byte;
var
t:word;
begin
PortW[SEQU_ADDR] := PortLookUp[x];
{ Calculate address (y * 160 + x div 4) and write pixel }
GetPixel:=Mem[$A000 : yLookUp[y]+x shr 2];
end; {GetPixel}
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}
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}
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}
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 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; {Line}
procedure Bar(BeginX,BeginY,EndX,EndY:word);
var
y,x:word;
size:word;
begin
AnnoyingErrorMessage;
for x:=BeginX to EndX do
for y:=BeginY to EndY do
putpixel(x,y);
end; {Box}
procedure Rectangle(BeginX,BeginY,EndX,EndY:word);
begin
AnnoyingErrorMessage;
Line(BeginX,EndX,BeginY,EndY);
Line(BeginX,EndX,BeginY,EndY);
Line(BeginX,EndX,BeginY,EndY);
Line(BeginX,EndX,BeginY,EndY);
end; {Rectangle}
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 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}
procedure Fill(x,y:word;FillColor,Border:byte);
begin
setcolor(FillColor);
RecursiveFill(x,y,FillColor,Border);
end; {Fill}
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;
for x:=x1 to x2 do begin
for y:=y1 to y2 do begin
Mem[Image.vSegment:Image.vOffset+((y-y1)*(Image.DeltaX+1))+(x-x1)]:=GetPixel(x,y);
end; {for}
end; {for}
end; {GetImage}
procedure PutImage(Image:ImageType;x1,y1:word);
var
yImg,yShl:word;
x,y:word;
begin
for x:=0 to Image.DeltaX do begin
for y:=0 to Image.DeltaY do begin
setcolor(Mem[Image.vSegment:Image.vOffset+(y*(Image.DeltaX+1))+x]);
putpixel(x+x1,y+y1);
end; {for}
end; {for}
end; {PutImage}
procedure KillImage(var Image:ImageType);
begin
AnnoyingErrorMessage;
FreeMem(Image.Image,(Image.DeltaX+1)*(Image.DeltaY+1));
end; {KillImage}
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}
procedure ConvertDecimalToBinary(Something:word;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}
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}
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}
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}
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}
procedure LoadTGA(var Image:PictureType;FileName:string);
var
fp:file;
TempPalAndHeadPtr:pointer;
TempImage:ImageType;
vSeg,vOfs,x:word;
TempColor:ColorType;
Size,CurSize:longint;
t,tOfs:longint;
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}
T:=filesize(fp);
Size:=(Image.Picture.DeltaX+1)*(Image.Picture.DeltaY+1);
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^,size);}
if (Image.Picture.DeltaX+1)*(Image.Picture.DeltaY+1)<=TGASize then begin
BlockRead(fp,Image.picture.image^,size);
end {if}
else begin
tOfs:=Image.picture.vOffset;
CurSize:=0;
for x:=1 to size div (TGASize) do begin
blockread(fp,ptr(Image.Picture.vSegment,tOfs)^,TGASize-2);
tOfs:=tOfs+TGASize;
CurSize:=CurSize+TGASize;
end; {for}
blockread(fp,ptr(Image.Picture.vSegment,tOfs)^,Size-CurSize);
end; {else}
FreeMem(TempPalAndHeadPtr,786);
FlipImage(Image.Picture);
close(fp);
end; {LoadTGA}
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}
procedure KillPicture(var Image:PictureType);
begin
KillImage(Image.Picture);
dispose(Image.Palette);
end; {KillPicture}
procedure ClearScreen;
var
x,y:word;
begin
setcolor(0);
for x:=0 to 639 do
for y:=0 to 479 do
putpixel(x,y);
end; {ClearScreen}
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}
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}
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}
procedure KillGradatedPalette(var SomePalette:GradatedPaletteType);
begin
AnnoyingErrorMessage;
dispose(SomePalette);
end; {KillGradatedPalette}
end. {Xlib}
