home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Game Hack 1
/
GHM01.ZIP
/
XUNIT.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1994-03-02
|
12KB
|
372 lines
Unit XUnit;
{$F+}
Interface
Type
AlphaType=Array [0..6,30..126] of Byte;
RGB=Record
Red:Byte;
Grn:Byte;
Blu:Byte;
End;
PaletteRegType=Array [0..255] of RGB;
Var
Alphafile:File of Byte;
AlphaChar:^AlphaType;
Procedure XSet320x240Mode;
Procedure XSet80x25Mode;
Procedure XPutPix(X,Y,PageBase,Color:Word);
Procedure XFillRect(StartX,StartY,EndX,EndY,PageBase,Color:Word);
Procedure XClrScr(PageBase:Word);
Procedure XGetRGB(PaletteNum:Byte;var RGBVal:RGB);
Procedure XPutRGB(PaletteNum:Byte;RGBVal:RGB);
Procedure XRGB2Buf(var PBuf:PaletteRegType);
Procedure XBuf2RGB(PBuf:PaletteRegType);
Procedure XWriteString(Scale,X,Y:Integer;TheString:String;
PageBase,Color:Integer);
Procedure XWriteCenter(Scale,Y:Integer;TheString:String;
PageBase,Color:Integer);
Procedure XWriteDrop(Scale,X,Y:Integer;TheString:String;
PageBase,ColorFG,ColorDrop:Integer);
Procedure XWriteCenterDrop(Scale,Y:Integer;TheString:String;
PageBase,ColorFG,ColorDrop:Integer);
Implementation
Uses CRT,DOS;
Var
Reg:Registers;
Procedure XSet320x240Mode;
{ This procedure performs 2 functions:
1. Sets up the VGA to Mode X 320x240
2. Since the call to Mode 13h screws up the mouse parameters, these
are set to default values (full-screen, sensitivity in both X and
Y equal, and located in the center of the screen)
It is always possible to set mouse parameters here because the mouse
driver has always been set up as part of the initialization routine for
this unit.}
Const
CRTParams:Array[0..9] of Word=($0d06,$3e07,$4109,$ea10,$ac11,$df12,
$0014,$e715,$0616,$e317);
Begin
asm
push bp
push si
push di
mov ax,13h
int 10h
mov dx,03c4h {SC_INDEX}
mov ax,0604h
out dx,ax {Disable Chain4 Mode}
mov ax,0100h {Synchronous reset while switching clocks}
out dx,ax
mov dx,03c2h {Misc Output}
mov al,0e3h
out dx,al {28 MHz dot clock/60 Hz scan rate}
mov dx,03c4h
mov ax,0300h
out dx,ax {Undo reset (restart sequencer)}
mov dx,03d4h {CTRC_INDEX}
mov al,11h {VSync End reg contains register ...}
out dx,al {... write protect bit}
inc dx
in al,dx
and al,7fh
out dx,al
dec dx
cld
mov si,offset CRTParams
mov cx,10
@SetCRTParmsLoop:
lodsw
out dx,ax
loop @SetCRTParmsLoop
mov dx,03c4h
mov ax,0f02h
out dx,ax
mov ax,SegA000 {Get Screen Segment from Pascal}
mov es,ax
sub di,di
sub ax,ax
mov cx,0FFFFh
rep stosw
pop di
pop si
pop bp
End;
End;
Procedure XSet80x25Mode;
Begin
asm
push bp
mov ax,3
int 10h
pop bp
end;
End;
Procedure XPutPix(X,Y,PageBase,Color:Word);
Begin
asm
mov ax,80
mul Y {offset of pixel's scan line in page}
mov bx,X {X value to bx register}
mov cl,bl {Lower byte to cl, we'll use it later}
shr bx,1 {Divide X by 4 ...}
shr bx,1 {... X/4 = offset of pixel in scan line}
add bx,ax {offset of pixel in page}
add bx,PageBase {Offset of pixel in display memory}
mov ax,SegA000 {Get Screen seg from Pascal}
mov es,ax {point ES:BX to the pixel's address}
and cl,011b {CL = pixel's plane}
mov ax,0102h {AL = index in SC of Map Mask reg}
shl ah,cl {set only the bit for the pixel's plane to 1}
mov dx,03C4H {set the Map Mask to enable only the ...}
out dx,ax { ... pixel's plane}
mov al,byte ptr [Color]
mov es:[bx],al {draw the pixel in the desired color}
end;
End;
Procedure XFillRect(StartX,StartY,EndX,EndY,PageBase,Color:Word);
Const
LMask:Array[0..3] of Byte=($f,$e,$c,$8);
RMask:Array[0..3] of Byte=($f,$1,$3,$7);
Begin
asm
push bp {save away regs we'll use here}
push si
cld
mov ax,80
mul StartY {offset in page of top rectangle scan line}
mov di,StartX
shr di,1 {X/4 = offset of first rectangle pixel in ... }
shr di,1 {... scan line}
add di,ax {offset of first rectangle pixel in page}
add di,PageBase {offset of first rectangle pixel in disp memory}
mov ax,SegA000 {point ES:DI to the first rectangle}
mov es,ax {pixel's address}
mov dx,03C4H {set the Sequence Controller Index to ... }
mov al,02H {...point to the Map Mask register}
out dx,al
inc dx {point DX to the SC Data register}
mov si,StartX
and si,0003h {look up left edge plane mask}
mov bh,byte ptr LMask[si] {to clip & put in BH}
mov si,EndX
and si,0003h {look up right edge plane}
mov bl,byte ptr RMask[si] {mask to clip & put in BL}
mov cx,EndX {calculate # of addresses across rect}
mov si,StartX
cmp cx,si
jle @FillDone {skip if 0 or negative width}
dec cx
and si,not 011b
sub cx,si
shr cx,1
shr cx,1 {# of addrs across rectangle to fill - 1}
jnz @MasksSet {there's more than one byte to draw}
and bh,bl {there's only one byte, so combine the left ...
... and right edge clip masks}
@MasksSet:
mov si,EndY
sub si,StartY {BX = height of rectangle}
jle @FillDone {skip if 0 or negative height}
mov ah,byte ptr [Color] {color with which to fill}
mov bp,80 {stack frame isn't needed any more}
sub bp,cx {distance from end of one scan line to start ...}
dec bp {... of next}
@FillRowsLoop:
push cx {remember width in addresses - 1}
mov al,bh {put left-edge clip mask in AL}
out dx,al {set the left-edge plane (clip) mask}
mov al,ah {put color in AL}
stosb {draw the left edge}
dec cx {count off left edge byte}
js @FillLoopBottom {that's the only byte}
jz @DoRightEdge {there are only two bytes}
mov al,00fh {middle addresses are drawn 4 pixels at a pop}
out dx,al {set the middle pixel mask to no clip}
mov al,ah {put color in AL}
rep stosb {draw the middle addresses four pixels apiece}
@DoRightEdge:
mov al,bl {put right-edge clip mask in AL}
out dx,al {set the right-edge plane (clip) mask}
mov al,ah {put color in AL}
stosb {draw the right edge}
@FillLoopBottom:
add di,bp {point to the start of the next scan line of ...
... rectangle}
pop cx {retrieve width in addresses - 1}
dec si {count down scan lines}
jnz @FillRowsLoop
@FillDone:
pop si
pop bp {restore caller's stack frame}
End;
End;
Procedure XClrScr(PageBase:Word);
{ Clears screen PageBase. More exactly, fills screen PageBase with palette #
zero's, which is usually set to black.}
Begin
XFillRect(0,0,320,240,PageBase,0);
End;
Procedure XGetRGB(PaletteNum:Byte;var RGBVal:RGB);
{ Return RGB values for PaletteNum into var RGBVal }
Begin
Reg.AX:=$1015;
Reg.BL:=PaletteNum;
Intr($10,Reg);
RGBVal.Red:=Reg.DH;
RGBVal.Grn:=Reg.CH;
RGBVal.Blu:=Reg.CL;
End;
Procedure XPutRGB(PaletteNum:Byte;RGBVal:RGB);
{ Write RGBVal to PaletteNum }
Begin
Reg.AX:=$1010;
Reg.BX:=PaletteNum;
Reg.DH:=RGBVal.Red;
Reg.CH:=RGBVal.Grn;
Reg.CL:=RGBVal.Blu;
Intr($10,Reg);
End;
Procedure XRGB2Buf(var PBuf:PaletteRegType);
{ Copy all RGB Palette values to a buffer, PBuf }
Begin
Reg.AX:=$1017;
Reg.BX:=$0000;
Reg.CX:=256;
Reg.ES:=Seg(PBuf);
Reg.DX:=Ofs(PBuf);
Intr($10,Reg);
End;
Procedure XBuf2RGB(PBuf:PaletteRegType);
{ Copy values from PBuf into RGB Palettes }
Begin
Reg.AX:=$1012;
Reg.BX:=$0000;
Reg.CX:=256;
Reg.ES:=Seg(PBuf);
Reg.DX:=Ofs(PBuf);
Intr($10,Reg);
End;
Procedure LoadFonts;
Var
I,J:Integer;
Begin
Assign(AlphaFile,'FONT7X7.DAT');
{$I-}
Reset(AlphaFile);
{$I+}
If IOResult<>0 then
Begin
XSet80x25Mode;
WriteLn('Error: Font file FONT7X7.DAT not found.');
Halt(0);
End;
New(AlphaChar);
For I:=0 to 6 do For J:=33 to 126 do
Read(AlphaFile,AlphaChar^[I,J]);
Close(AlphaFile);
End;
Procedure XWriteString(Scale,X,Y:Integer;TheString:String;
PageBase,Color:Integer);
{ This procedure writes a string using the 7x7 font set loaded by the
LoadFonts procedure. The parameters are:
Scale: An integer. If 1, each font is 7x7 pixels with 1 1-pixel space
between each character. If 2, each font is 14x14 pixels with a 2-pixel
space between each letter. I have tried scales up to 4, but it should
work with any reasonable integer number.
X,Y: The X,Y pixel coordinates (in real screen coordinates, [0,0] being
the upper left of the screen, [319,239] being the lower right) of the
bottom left corner of the text to be written.
TheString: The string to be written.
PageBase: Offset into screen memory.
Color: A number from 0 to 255. This is actually the palette number to use
for the text, not the color. The actual colors are defined by the PutRGB
and/or the Buf2RGB procedures. }
Var
I,CharPos,CharNum,PixNum:Byte;
Begin
Y:=Y-(7*Scale-1); {Shift Y so that text bottom falls at specified Y}
For CharPos:=1 to Length(TheString) do {For each character in the string}
Begin
CharNum:=Ord(TheString[CharPos]); {Get ASCII code of that character}
{Next, if character is lowercase, make it uppercase. This is because
I have not defined fonts for lowercase letters.}
If CharNum in [96..123] then CharNum:=CharNum-32;
{If the character is not a space, then draw it}
If CharNum<>32 then For I:=0 to (7*Scale-1) do
For PixNum:=0 to (7*Scale-1) do
Begin
{For each bit set to 1 in the font map Alphachar^[Row,Code], light
up the pixel corresponding to that bit position. If you wish, remove
the curly-braces from "and (X+PixNum<319)", and then pixels whose X
coordinates are greater than 319 will be clipped. No checks have been
made for wrapping in the Y direction.}
If ((AlphaChar^[(I div Scale),CharNum] Shr (7-(PixNum div Scale)))
and $01 = $01) {and (X+PixNum<319)} then
XPutPix(X+PixNum,Y+I,PageBase,Color);
End;
X:=X+8*Scale; {Step X to prepare for next letter}
End;
End;
Procedure XWriteCenter(Scale,Y:Integer;TheString:String;
PageBase,Color:Integer);
{ This procedure writes a string using the 7x7 font set loaded by the
LoadFonts procedure. The text is centered on the screen in the X
direction, so no X coordinate is passed to this procedure. X is cal-
culated within this procedure, then a call is made to WriteString,
the most primitive string writing procedure. For parameter meanings
see XWriteString procedure}
Begin
XWriteString(Scale,159-Length(TheString)*4*Scale,Y,TheString,PageBase,
Color);
End;
Procedure XWriteDrop(Scale,X,Y:Integer;TheString:String;
PageBase,ColorFG,ColorDrop:Integer);
{ This is like XWriteString, but writes the string with a drop-shadow one
pixel below and to the left of the font. ColorFG is the foreground color,
ColoroDrop is the drop-shadow color. As before, "color" actually refers
to palette number, not the true color.}
Begin
XWriteString(Scale,X-1,Y+1,TheString,PageBase,ColorDrop);
XWriteString(Scale,X,Y,TheString,PageBase,ColorFG);
End;
Procedure XWriteCenterDrop(Scale,Y:Integer;TheString:String;
PageBase,ColorFG,ColorDrop:Integer);
{Write string centered on the screen in X, with drop shadow. See XWrite-
Center procedure.}
Begin
XWriteString(Scale,158-Length(TheString)*4*Scale,Y+1,TheString,PageBase,
ColorDrop);
XWriteCenter(Scale,Y,TheString,PageBase,ColorFG);
End;
Begin
LoadFonts;
End.