Game Hack 1/GHM01.ZIP/XUNIT.PAS

Pascal/Delphi Source File | 1994-03-03 | 12.1 KB | 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.