Pascal Graphics2
Pascal
Download (.zip)
{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}
|