gered/fruit-popper
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity
fruit-popper/GDLIB/GDGFX.PAS

2141 lines
61 KiB
Plaintext
Raw Normal View History

initial commit of "completed" sources, binaries and assets as of july 4th, 2021
2021-07-07 17:10:18 -04:00
{ GDlib Core VGA mode 13h Graphics routines
Gered King, 2018-2021 }
{
TODO list:
- palette loading/saving to binary .pal files
- custom font support, including variable-width fonts
- allowing usage of EMS memory to have extra gfx layers located in EMS
- clip-region stack, with push/pop type api
- blit sprite routine that allows blitting all non-transparent colours
using a single specified solid colour (e.g. for sprite flashing effect)
- translucent/blending colour table mapping and drawing routines
- scaled/rotated blit routines ... ?
}
{$A+,B-,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit GDGfx;
interface
const
MAX_LAYERS = 5;
MAX_EXTRA_LAYERS = 5;
SCREEN_LAYER = 0;
SCREEN_LEFT = 0;
SCREEN_TOP = 0;
SCREEN_RIGHT = 319;
SCREEN_BOTTOM = 199;
SCREEN_WIDTH = 320;
SCREEN_HEIGHT = 200;
CHAR_WIDTH = 8;
CHAR_HEIGHT = 8;
LAYERFLAG_ALIASEDMEM = $1;
ClipRegionLeft : integer = SCREEN_LEFT;
ClipRegionTop : integer = SCREEN_TOP;
ClipRegionRight : integer = SCREEN_RIGHT;
ClipRegionBottom : integer = SCREEN_BOTTOM;
ClipRegionWidth : integer = SCREEN_WIDTH;
ClipRegionHeight : integer = SCREEN_HEIGHT;
type
Color = byte;
PColor = ^Color;
PalResult = (PalNotFound, PalIOError, PalBadFile, PalBadArgs, PalOk);
Palette = array[0..255,0..2] of byte;
PaletteEntry = array[0..2] of byte;
PPalette = ^Palette;
PPaletteEntry = ^PaletteEntry;
Pixelbuffer = array[0..63999] of Color;
PPixelbuffer = ^Pixelbuffer;
BiosFontTable = array[0..255,0..7] of byte;
BiosFontChar = array[0..7] of byte;
BiosFontCharWidths = array[0..255] of byte;
PBiosFontChar = ^BiosFontChar;
FontResult = (FontNotFound, FontIOError, FontBadFile, FontBadArgs, FontOk);
Font = record
chars : BiosFontTable;
widths : BiosFontCharWidths;
height : byte;
end;
PFont = ^Font;
Bitmap = record
Width, Height : word;
Pixels : byte; { take pointer of this to get full pixels mem }
end;
PBitmap = ^Bitmap;
var
VgaFramebuffer : Pixelbuffer absolute $a000:$0000;
procedure InitGraphics(layers: integer);
procedure CloseGraphics;
function IsGraphicsInitialized: boolean;
procedure UseLayer(layer: integer);
procedure Cls(color: Color);
procedure Flip(layer: integer);
procedure CopyLayer(layer: integer);
procedure WaitForVsync;
function GetBoundLayerIndex : integer;
function GetBoundLayerSegment : word;
function GetBoundLayerOffset : word;
function GetBoundLayerOffsetAt(x, y: integer) : word;
function GetBoundLayerPointerAt(x, y: integer) : pointer;
procedure SetClipRegion(x1, y1, x2, y2: integer);
procedure ResetClipRegion;
procedure Pset(x, y: integer; color: Color);
procedure Psetf(x, y: integer; color: Color);
function Pget(x, y: integer) : Color;
function Pgetf(x, y: integer) : Color;
procedure Line(x1, y1, x2, y2: integer; color: Color);
procedure Linef(x1, y1, x2, y2: integer; color: Color);
procedure HLine(x1, x2, y: integer; color: Color);
procedure HLinef(x1, x2, y: integer; color: Color);
procedure VLine(x, y1, y2: integer; color: Color);
procedure VLinef(x, y1, y2: integer; color: Color);
procedure Box(x1, y1, x2, y2: integer; color: Color);
procedure Boxf(x1, y1, x2, y2: integer; color: Color);
procedure FilledBox(x1, y1, x2, y2: integer; color: Color);
procedure FilledBoxf(x1, y1, x2, y2: integer; color: Color);
procedure UseFont(font : PFont);
procedure DrawSubString(x, y: integer; color: Color; const text: string; textStart, textEnd: integer);
procedure DrawString(x, y: integer; color: Color; const text: string);
procedure DrawStringf(x, y: integer; color: Color; const text: string);
procedure PrintAt(x, y: integer);
procedure PrintShortInt(value: shortint; color: Color);
procedure PrintInt(value: integer; color: Color);
procedure PrintLongInt(value: longint; color: Color);
procedure PrintByte(value: byte; color: Color);
procedure PrintWord(value: word; color: Color);
procedure PrintReal(value: real; color: Color);
procedure PrintRealFmt(value: real; decimals: integer; color: Color);
procedure PrintSingle(value: single; color: Color);
procedure PrintSingleFmt(value: single; decimals: integer; color: Color);
procedure PrintDouble(value: double; color: Color);
procedure PrintDoubleFmt(value: double; decimals: integer; color: Color);
procedure PrintString(const text: string; color: Color);
procedure AllocBitmap(width, height: word; var bmp: PBitmap);
procedure FreeBitmap(bmp: PBitmap);
procedure GrabBitmap(x, y: integer; width, height: word; bmp: PBitmap);
procedure BlitSubset(srcX, srcY, srcWidth, srcHeight, destX, destY: integer; const bmp: PBitmap);
procedure BlitSubsetf(srcX, srcY, srcWidth, srcHeight, destX, destY: integer; const bmp: PBitmap);
procedure Blit(x, y: integer; const bmp: PBitmap);
procedure Blitf(x, y: integer; const bmp: PBitmap);
procedure BlitSpriteSubset(srcX, srcY, srcWidth, srcHeight, destX, destY: integer; const bmp: PBitmap);
procedure BlitSpriteSubsetf(srcX, srcY, srcWidth, srcHeight, destX, destY: integer; const bmp: PBitmap);
procedure BlitSprite(x, y: integer; const bmp: PBitmap);
procedure BlitSpritef(x, y: integer; const bmp: PBitmap);
procedure SetColor(color, r, g, b: byte);
procedure GetColor(color: byte; var r, g, b: byte);
procedure SetPalette(const pal: PPalette);
procedure GetPalette(pal: PPalette);
function FadeColor(color, r, g, b: byte; step: integer) : boolean;
procedure FadeRangeToColor(colorStart, colorEnd, r, g, b: byte; step: integer);
procedure FadeRangeToPalette(colorStart, colorEnd: byte; const pal: PPalette; step: integer);
function LoadFont(const filename: string; font: PFont) : FontResult;
function LoadPalette(const filename: string; pal: PPalette) : FontResult;
implementation
uses GDClip, Toolbox;
type
GraphicsLayer = record
flags : word;
pixels : PPixelbuffer;
end;
const
_graphicsInitialized : boolean = false;
var
_layers : array[0..(MAX_LAYERS+1)] of GraphicsLayer;
_boundLayerIndex : integer;
_boundLayerSeg : word;
_boundLayerOfs : word;
_biosFont : BiosFontTable absolute $ffa6:$000e;
_boundFont : PFont;
_valueString : string[100];
_currentTextX : integer;
_currentTextY : integer;
_currentTextStartX : integer;
procedure InitGraphics(layers: integer);
{ initializes vga mode 13h graphics and allocates memory for any requested
layers in addition to the vga framebuffer layer }
var
i : integer;
begin
if _graphicsInitialized then
exit;
if layers > MAX_LAYERS then
RunError(255);
_layers[SCREEN_LAYER].flags := LAYERFLAG_ALIASEDMEM;
_layers[SCREEN_LAYER].pixels := Ptr($a000,$0);
for i := 1 to layers do begin
_layers[i].flags := 0;
GetMem(_layers[i].pixels, SizeOf(Pixelbuffer));
MemFill(_layers[i].pixels, 0, SizeOf(PixelBuffer));
end;
{ zero out remaining layer info (if there is any leftovers) }
if layers < MAX_LAYERS then begin
for i := (layers+1) to MAX_LAYERS do begin
_layers[i].flags := 0;
_layers[i].pixels := nil;
end;
end;
ResetClipRegion;
UseLayer(SCREEN_LAYER);
Cls(0);
asm
mov ax, 13h
int 10h
end;
_currentTextX := 0;
_currentTextY := 0;
_currentTextStartX := 0;
_boundFont := nil;
_graphicsInitialized := true;
end;
procedure CloseGraphics;
{ resets the screen mode back to text mode, and frees memory allocated for
any allocated layers }
var
i : integer;
begin
if (not _graphicsInitialized) then
exit;
UseLayer(0);
for i := 0 to MAX_LAYERS do begin
if (_layers[i].flags and LAYERFLAG_ALIASEDMEM) = 0 then begin
if _layers[i].pixels <> nil then
FreeMem(_layers[i].pixels, SizeOf(Pixelbuffer));
end;
_layers[i].flags := 0;
_layers[i].pixels := nil;
end;
asm
mov ax, 03h
int 10h
end;
_graphicsInitialized := false;
end;
function IsGraphicsInitialized: boolean;
begin
IsGraphicsInitialized := _graphicsInitialized;
end;
procedure UseLayer(layer: integer);
{ switches the active graphics layer }
var
pixelsPtr : pointer;
begin
pixelsPtr := _layers[layer].pixels;
if pixelsPtr = nil then
RunError(255);
_boundLayerIndex := layer;
_boundLayerSeg := PtrSeg(pixelsPtr);
_boundLayerOfs := PtrOfs(pixelsPtr);
end;
procedure Cls(color: Color);
{ clears the current bound layer with the specified color }
begin
MemFill(Ptr(_boundLayerSeg, _boundLayerOfs), color, 64000);
end;
procedure Flip(layer: integer);
{ 'flips' the specified layer onto the vga framebuffer }
var
layerPixelsPtr : pointer;
begin
if layer = SCREEN_LAYER then
exit;
layerPixelsPtr := _layers[layer].pixels;
if layerPixelsPtr = nil then
RunError(255);
MemCopy(Ptr($a000, 0), layerPixelsPtr, 64000);
end;
procedure CopyLayer(layer: integer);
{ copies the entire contents of the specified layer onto the currently
bound layer }
var
layerPixelsPtr : pointer;
begin
if layer = _boundLayerIndex then
exit;
layerPixelsPtr := _layers[layer].pixels;
if layerPixelsPtr = nil then
RunError(255);
MemCopy(Ptr(_boundLayerSeg, _boundLayerOfs), layerPixelsPtr, 64000);
end;
procedure WaitForVsync;
{ blocks until the next v-sync occurs }
assembler;
asm
mov dx, 3dah
@first:
in al, dx
and al, 8
jnz @first
@second:
in al, dx
and al, 8
jz @second
end;
function GetBoundLayerIndex : integer;
{ returns the number/index of the currently bound layer }
begin
GetBoundLayerIndex := _boundLayerIndex;
end;
function GetBoundLayerSegment : word;
{ returns the address segment of the currently bound layer }
begin
GetBoundLayerSegment := _boundLayerSeg;
end;
function GetBoundLayerOffset : word;
{ returns the offset of the currently bound layer (this will be the offset
that corresponds with X=0,Y=0 on the layer). }
begin
GetBoundLayerOffset := _boundLayerOfs;
end;
function GetBoundLayerOffsetAt(x, y: integer) : word;
{ returns the memory offset that the pixel at position x,y is located at
within any of the screen layers }
assembler;
asm
mov ax, y { ax = y * 320 }
mov bx, ax
shl ax, 6
shl bx, 8
add ax, bx
add ax, x { ax = ax + x }
add ax, _boundLayerOfs
end;
function GetBoundLayerPointerAt(x, y: integer) : pointer;
{ returns a pointer to the pixel at position x,y on the currently bound
layer }
assembler;
asm
mov ax, y { ax = y * 320 }
mov bx, ax
shl ax, 6
shl bx, 8
add ax, bx
add ax, x { ax = ax + x }
{ return pointer in dx:ax (segment:offset) }
add ax, _boundLayerOfs
mov dx, _boundLayerSeg
end;
function GetBitmapOffsetAt(x, y: integer; const bmp: PBitmap) : word;
{ returns the memory offset that the pixel at position x,y is located at
within the given bitmap }
begin
GetBitmapOffsetAt := (y * bmp^.Width) + x + Ofs(bmp^.Pixels);
end;
procedure SetClipRegion(x1, y1, x2, y2: integer);
{ changes the current boundaries for all clipped drawing operations.
affects all layers. }
begin
if x1 < SCREEN_LEFT then
ClipRegionLeft := SCREEN_LEFT
else
ClipRegionLeft := x1;
if y1 < SCREEN_TOP then
ClipRegionTop := SCREEN_TOP
else
ClipRegionTop := y1;
if x2 > SCREEN_RIGHT then
ClipRegionRight := SCREEN_RIGHT
else
ClipRegionRight := x2;
if y2 > SCREEN_BOTTOM then
ClipRegionBottom := SCREEN_BOTTOM
else
ClipRegionBottom := y2;
ClipRegionWidth := ClipRegionRight - ClipRegionLeft + 1;
ClipRegionHeight := ClipRegionBottom - ClipRegionTop + 1;
end;
procedure ResetClipRegion;
{ resets the current boundaries for all clipped drawing operations to
match the full screen boundaries }
begin
ClipRegionLeft := SCREEN_LEFT;
ClipRegionTop := SCREEN_TOP;
ClipRegionRight := SCREEN_RIGHT;
ClipRegionBottom := SCREEN_BOTTOM;
ClipRegionWidth := SCREEN_WIDTH;
ClipRegionHeight := SCREEN_HEIGHT;
end;
procedure Pset(x, y: integer; color: Color);
{ draws a pixel on the current layer at x,y using the given color.
nothing is drawn if x,y are out of bounds of the current clipping region }
assembler;
asm
mov ax, x
cmp ax, ClipRegionLeft { off the left edge? }
jl @done
cmp ax, ClipRegionRight { off the right edge? }
jg @done
mov di, y
cmp di, ClipRegionTop { off the top edge? }
jl @done
cmp di, ClipRegionBottom { off the bottom edge? }
jg @done
mov bx, di { di = y * 320 + x }
shl di, 6
shl bx, 8
add di, bx
add di, ax
add di, _boundLayerOfs
mov al, color
mov es, _boundLayerSeg { write pixel to current layer }
mov es:[di], al
@done:
end;
procedure Psetf(x, y: integer; color: Color);
{ draws a pixel on the current layer at x,y using the given color.
does not perform any bounds checking. }
assembler;
asm
mov ax, x
mov di, y
mov bx, di { di = y * 320 + x }
shl di, 6
shl bx, 8
add di, bx
add di, ax
add di, _boundLayerOfs
mov al, color
mov es, _boundLayerSeg { write pixel to current layer }
mov es:[di], al
end;
function Pget(x, y: integer) : Color;
{ gets a pixel from the current layer at x,y, returning the color.
returns zero if x,y are out of bounds of the current clipping region }
assembler;
asm
xor ax, ax
mov cx, x
cmp cx, ClipRegionLeft { off the left edge? }
jl @done
cmp cx, ClipRegionRight { off the right edge? }
jg @done
mov si, y
cmp si, ClipRegionTop { off the top edge? }
jl @done
cmp si, ClipRegionBottom { off the bottom edge? }
jg @done
mov bx, si { si = y * 320 + x }
shl si, 6
shl bx, 8
add si, bx
add si, cx
add si, _boundLayerOfs
push ds
mov ds, _boundLayerSeg { read pixel from current layer }
mov al, ds:[si]
pop ds
@done:
end;
function Pgetf(x, y: integer) : Color;
{ gets a pixel from the current layer at x,y, returning the color.
does not perform any bounds checking. }
assembler;
asm
xor ax, ax
mov cx, x
mov si, y
mov bx, si { si = y * 320 + x }
shl si, 6
shl bx, 8
add si, bx
add si, cx
add si, _boundLayerOfs
push ds
mov ds, _boundLayerSeg { read pixel from current layer }
mov al, ds:[si]
pop ds
end;
procedure Line(x1, y1, x2, y2: integer; color: Color);
{ draws a line from x1,y1 to x2,y2. the line is clipped at the edges of the
current clipping region if necessary. }
var
deltaX, deltaY : integer;
deltaXabs, deltaYabs : integer;
deltaXsign, deltaYsign : integer;
x, y, i, dx, dy, loops : integer;
offset : integer;
offsetXinc, offsetYinc : integer;
dest : PColor;
begin
dx := x1;
dy := y1;
deltaX := x2 - x1;
deltaY := y2 - y1;
deltaXabs := Abs(deltaX);
deltaYabs := Abs(deltaY);
deltaXsign := SignInt(deltaX);
deltaYsign := SignInt(deltaY);
x := deltaYabs div 2;
y := deltaYabs div 2;
offsetXinc := deltaXsign;
offsetYinc := deltaYsign * SCREEN_WIDTH;
dest := GetBoundLayerPointerAt(x1, y1);
if ((dx >= ClipRegionLeft)
and (dy >= ClipRegionTop)
and (dx <= ClipRegionRight)
and (dy <= ClipRegionBottom)) then
dest^ := color;
if deltaXabs >= deltaYabs then begin
loops := deltaXabs - 1;
for i := 0 to loops do begin
inc(y, deltaYabs);
if y >= deltaXabs then begin
dec(y, deltaXabs);
inc(dy, deltaYsign);
inc(dest, offsetYinc);
end;
inc(dx, deltaXsign);
inc(dest, offsetXinc);
if ((dx >= ClipRegionLeft)
and (dy >= ClipRegionTop)
and (dx <= ClipRegionRight)
and (dy <= ClipRegionBottom)) then
dest^ := color;
end;
end else begin
loops := deltaYabs - 1;
for i := 0 to loops do begin
inc(x, deltaXabs);
if x >= deltaYabs then begin
dec(x, deltaYabs);
inc(dx, deltaXsign);
inc(dest, offsetXinc);
end;
inc(dy, deltaYsign);
inc(dest, offsetYinc);
if ((dx >= ClipRegionLeft)
and (dy >= ClipRegionTop)
and (dx <= ClipRegionRight)
and (dy <= ClipRegionBottom)) then
dest^ := color;
end;
end;
end;
procedure Linef(x1, y1, x2, y2: integer; color: Color);
{ draws a line from x1,y1 to x2,y2. no clipping is performed. }
var
deltaX, deltaY : integer;
deltaXabs, deltaYabs : integer;
deltaXsign, deltaYsign : integer;
x, y, i, loops : integer;
offsetXinc, offsetYinc : integer;
dest : PColor;
begin
deltaX := x2 - x1;
deltaY := y2 - y1;
deltaXabs := Abs(deltaX);
deltaYabs := Abs(deltaY);
deltaXsign := SignInt(deltaX);
deltaYsign := SignInt(deltaY);
x := deltaYabs div 2;
y := deltaYabs div 2;
offsetXinc := deltaXsign;
offsetYinc := deltaYsign * SCREEN_WIDTH;
dest := GetBoundLayerPointerAt(x1, y1);
dest^ := color;
if deltaXabs >= deltaYabs then begin
loops := deltaXabs - 1;
for i := 0 to loops do begin
inc(y, deltaYabs);
if y >= deltaXabs then begin
dec(y, deltaXabs);
inc(dest, offsetYinc);
end;
inc(dest, offsetXinc);
dest^ := color;
end;
end else begin
loops := deltaYabs - 1;
for i := 0 to loops do begin
inc(x, deltaXabs);
if x >= deltaYabs then begin
dec(x, deltaYabs);
inc(dest, offsetXinc);
end;
inc(dest, offsetYinc);
dest^ := color;
end;
end;
end;
procedure HLine(x1, x2, y: integer; color: Color);
{ draws a horizontal line. automatically compensates for incorrect ordering
of the x coordinates and also clips the line to the current clipping
region. }
begin
if x2 < x1 then
SwapInts(x1, x2);
if not ClampToClipRegion(x1, y, x2, y) then
exit;
HLinef(x1, x2, y, color);
end;
procedure HLinef(x1, x2, y: integer; color: Color);
{ draws a horizontal line. x1 must be less than x2. no clipping is
performed. }
var
dest : pointer;
length : integer;
begin
dest := GetBoundLayerPointerAt(x1, y);
length := x2 - x1 + 1;
MemFill(dest, color, length);
end;
procedure VLine(x, y1, y2: integer; color: Color);
{ draws a vertical line. automatically compensates for incorrect ordering
of the y coordinates and also clips the line to the current clipping
region. }
begin
if y2 < y1 then
SwapInts(y1, y2);
if not ClampToClipRegion(x, y1, x, y2) then
exit;
VLinef(x, y1, y2, color);
end;
procedure VLinef(x, y1, y2: integer; color: Color);
{ draws a vertical line. y1 must be less than y2. no clipping is
performed. }
var
offs : word;
linesLeft : integer;
begin
offs := GetBoundLayerOffsetAt(x, y1);
linesLeft := y2 - y1 + 1;
asm
mov cx, linesLeft
test cx, cx { make sure there are > 0 lines to draw }
jz @done
mov al, color
mov es, _boundLayerSeg
mov di, offs
@draw:
mov es:[di], al
add di, SCREEN_WIDTH
dec cx
jnz @draw
@done:
end;
end;
procedure DrawTwoVerticalLines(leftOffs, rightOffs: word;
color: Color;
height: integer);
assembler;
asm
mov es, _boundLayerSeg
mov si, leftOffs
mov di, rightOffs
mov al, color
mov cx, height
@draw:
mov es:[si], al
mov es:[di], al
add si, SCREEN_WIDTH
add di, SCREEN_WIDTH
dec cx
jnz @draw
@done:
end;
procedure DrawVerticalLine(offs: word;
color: Color;
height: integer);
assembler;
asm
mov es, _boundLayerSeg
mov di, offs
mov al, color
mov cx, height
@draw:
mov es:[di], al
add di, SCREEN_WIDTH
dec cx
jnz @draw
@done:
end;
procedure Box(x1, y1, x2, y2: integer; color: Color);
{ draws an empty box. automatically compensates if coordinate pairs are
swapped so that x1 < x2 and y1 < y2. clips the box to the current clipping
region boundaries. }
var
clippedX1, clippedY1, clippedX2, clippedY2 : integer;
clippedWidth, clippedHeight : integer;
offs, offs1, offs2 : word;
begin
if x2 < x1 then
SwapInts(x1, x2);
if y2 < y1 then
SwapInts(y1, y2);
clippedX1 := x1;
clippedY1 := y1;
clippedWidth := x2 - x1 + 1;
clippedHeight := y2 - y1 + 1;
if not ClipToClipRegion(clippedX1, clippedY1,
clippedWidth, clippedHeight) then
exit;
clippedX2 := clippedX1 + clippedWidth - 1;
clippedY2 := clippedY1 + clippedHeight - 1;
{ top line, only if y1 was within bounds }
if y1 = clippedY1 then begin
offs := GetBoundLayerOffsetAt(clippedX1, clippedY1);
MemFill(Ptr(_boundLayerSeg, offs), color, clippedWidth);
end;
{ bottom line, only if y2 was within bounds }
if y2 = clippedY2 then begin
offs := GetBoundLayerOffsetAt(clippedX1, clippedY2);
MemFill(Ptr(_boundLayerSeg, offs), color, clippedWidth);
end;
{ draw both left and right lines if neither x1 nor x2 were clipped }
if (x1 = clippedX1) and (x2 = clippedX2) then begin
offs1 := GetBoundLayerOffsetAt(clippedX1, clippedY1);
offs2 := GetBoundLayerOffsetAt(clippedX2, clippedY1);
DrawTwoVerticalLines(offs1, offs2, color, clippedHeight);
{ draw left line if x1 was not clipped }
end else if x1 = clippedX1 then begin
offs := GetBoundLayerOffsetAt(clippedX1, clippedY1);
DrawVerticalLine(offs, color, clippedHeight);
{ draw right line if x2 was not clipped }
end else if x2 = clippedX2 then begin
offs := GetBoundLayerOffsetAt(clippedX2, clippedY1);
DrawVerticalLine(offs, color, clippedHeight);
end;
end;
procedure Boxf(x1, y1, x2, y2: integer; color: Color);
{ draws an empty box. x1 must be less than x2, and y1 must be less than y2.
no clipping is performed. }
var
offs, offsLeft, offsRight : word;
width, linesLeft : integer;
begin
width := x2 - x1 + 1;
linesLeft := y2 - y1;
offs := GetBoundLayerOffsetAt(x1, y1);
offsLeft := offs;
offsRight := offs + width - 1;
asm
mov al, color { spread color byte over all of EAX so we can }
mov ah, al { draw 4 pixels at once horizontally. }
db $66; shl ax, 8 { shl eax, 8 }
mov al, ah
db $66; shl ax, 8 { shl eax, 8 }
mov al, ah
db $66; xor cx, cx { xor ecx, ecx }
mov es, _boundLayerSeg
mov dx, width
mov cx, linesLeft
mov di, offsLeft
mov si, offsRight
test cx, cx { do we have any vertical height to draw? }
jz @draw_horiz1 { if not, skip to horizontal drawing ... }
@draw_vert:
{ draw both vertical lines }
mov es:[di], al
mov es:[si], al
add di, SCREEN_WIDTH
add si, SCREEN_WIDTH
dec cx
jnz @draw_vert
@draw_horiz1:
{ di will be at (x1,y2) currently. this is the correct location to draw
the bottom horizontal line }
mov cx, dx { cx = number of dwords to draw }
mov bx, cx { bx = remaining number of pixels to draw }
shr cx, 2
and bx, 3
db $f3,$66,$ab { rep stosd - draw dwords }
mov cx, bx
rep stosb { draw remaining pixels }
@draw_horiz2:
{ now draw the top line. reposition to (x1,y1) }
mov di, offsLeft
mov cx, dx { cx = number of dwords to draw }
mov bx, cx { bx = remaining number of pixels to draw }
shr cx, 2
and bx, 3
db $f3,$66,$ab { rep stosd - draw dwords }
mov cx, bx
rep stosb { draw remaining pixels }
@done:
end;
end;
procedure FilledBox(x1, y1, x2, y2: integer; color: Color);
{ draws a filled box. automatically compensates if coordinate pairs are
swapped so that x1 < x2 and y1 < y2. clips the box to the current clipping
region boundaries. }
begin
if x2 < x1 then
SwapInts(x1, x2);
if y2 < y1 then
SwapInts(y1, y2);
if not ClampToClipRegion(x1, y1, x2, y2) then
exit;
FilledBoxf(x1, y1, x2, y2, color);
end;
procedure FilledBoxf(x1, y1, x2, y2: integer; color: Color);
{ draws a filled box. x1 must be less than x2, and y1 must be less than y2.
no clipping is performed. }
var
offs : word;
width, linesLeft, remainder : integer;
begin
width := x2 - x1 + 1;
linesLeft := y2 - y1 + 1;
offs := GetBoundLayerOffsetAt(x1, y1);
asm
mov si, linesLeft
test si, si { stop if there are 0 lines to draw }
jz @nothing_to_draw
mov al, color { spread color byte over all of EAX so we can }
mov ah, al { draw 4 pixels at once horizontally. }
db $66; shl ax, 8 { shl eax, 8 }
mov al, ah
db $66; shl ax, 8 { shl eax, 8 }
mov al, ah
mov bx, width
mov di, offs
mov es, _boundLayerSeg
mov dx, SCREEN_WIDTH { dx = y-inc to next line after drawing horiz }
sub dx, bx
{ *** WARNING: no stack/vars access after this! *** }
push bp
mov bp, bx
and bp, 3 { bp = remaining number of pixels to draw }
shr bx, 2 { bx = number of dwords to draw }
db $66; xor cx, cx { xor ecx, ecx }
test bp, bp
jz @draw
@draw_with_remainder:
mov cx, bx
db $f3,$66,$ab { rep stosd - draw dwords }
mov cx, bp
rep stosb { draw remainder pixel }
add di, dx { move to start of next line }
dec si { decrease line counter }
jnz @draw_with_remainder { keep drawing if there are more lines }
jmp @done
@draw:
mov cx, bx
db $f3,$66,$ab { rep stosd - draw dwords }
add di, dx { move to start of next line }
dec si { decrease line counter }
jnz @draw { keep drawing if there are more lines }
jmp @done
@done:
pop bp
@nothing_to_draw:
end;
end;
procedure UseFont(font : PFont);
{ binds the specified font. all subsequent text/string drawing will be
done using this font until this is called again with a different font.
pass nil to revert back to using the standard VGA BIOS font. }
begin
if font = nil then
_boundFont := nil { means to use VGA BIOS font instead }
else
_boundFont := font;
end;
{ TODO: rewrite this function. it is poopy and sad. }
procedure DrawChar(x, y, drawX, drawY, width, height: integer;
color: Color;
ch: char);
var
dest, fontSrc : word;
cx, cy : integer;
offsetX, offsetY : integer;
destWidth, destHeight : integer;
fontCharMap : PBiosFontChar;
fontCharLine : byte;
pixel : byte;
begin
dest := GetBoundLayerOffsetAt(drawX, drawY);
if _boundFont <> nil then
fontCharMap := @_boundFont^.chars[Ord(ch), 0]
else
fontCharMap := @_biosFont[Ord(ch), 0];
{ get offset x,y to start drawing char from (will be in range 0-7) }
offsetX := drawX - x;
offsetY := drawY - y;
destWidth := width + offsetX - 1;
destHeight := height + offsetY - 1;
{ cx,cy are always in "char coordinate space" (that is, 0-7) }
for cy := offsetY to destHeight do begin
fontCharLine := fontCharMap^[cy];
for cx := offsetX to destWidth do begin
pixel := ((fontCharLine) and (1 shl ((CHAR_WIDTH - 1) - cx)));
if pixel > 0 then
mem[_boundLayerSeg:(dest + (cx - offsetX))] := color;
end;
inc(dest, SCREEN_WIDTH);
end;
end;
procedure DrawSubString(x, y: integer;
color: Color;
const text: string;
textStart, textEnd: integer);
{ draws a sub-string starting from the top-left coordinate (x,y). handles
multi-line strings automatically. the text is clipped to the current
clipping region boundaries as needed. only part of the string is drawn,
as specified by textStart and textEnd (non-inclusive end) }
var
ch : char;
i, currentX, currentY : integer;
width, height, length : integer;
spaceWidth : integer;
clippedX, clippedY : integer;
clippedWidth, clippedHeight : integer;
begin
currentX := x;
currentY := y;
width := CHAR_WIDTH;
if _boundFont <> nil then begin
height := _boundFont^.height;
spaceWidth := _boundFont^.widths[Ord(' ')];
end else begin
height := CHAR_HEIGHT;
spaceWidth := CHAR_WIDTH;
end;
for i := textStart to textEnd do begin
ch := text[i];
case ch of
{ move to next line }
#10: begin
currentX := x;
inc(currentY, height);
end;
#13: begin;
end;
{ skip a character ahead, no need to "draw" a space char (empty) }
' ': inc(currentX, spaceWidth);
else begin
if _boundFont <> nil then
width := _boundFont^.widths[Ord(ch)];
clippedX := currentX;
clippedY := currentY;
clippedWidth := width;
clippedHeight := height;
if ClipToClipRegion(clippedX, clippedY, clippedWidth, clippedHeight) then
DrawChar(currentX, currentY, clippedX, clippedY, clippedWidth, clippedHeight, color, ch);
inc(currentX, width);
end;
end;
end;
end;
procedure DrawString(x, y: integer; color: Color; const text: string);
{ draws a string starting from the top-left coordinate (x,y). handles
multi-line strings automatically. the text is clipped to the current
clipping region boundaries as needed. }
begin
DrawSubString(x, y, color, text, 1, length(text));
end;
procedure DrawStringf(x, y: integer; color: Color; const text: string);
{ draws a string starting from the top-left coordinate (x,y). handles
multi-line strings automatically. no clipping is performed. }
var
ch : char;
i, currentX, currentY : integer;
width, height, len : integer;
spaceWidth : integer;
begin
currentX := x;
currentY := y;
width := CHAR_WIDTH;
len := length(text);
if _boundFont <> nil then begin
height := _boundFont^.height;
spaceWidth := _boundFont^.widths[Ord(' ')];
end else begin
height := CHAR_HEIGHT;
spaceWidth := CHAR_WIDTH;
end;
for i := 1 to len do begin
ch := text[i];
case ch of
{ move to next line }
#10: begin
currentX := x;
inc(currentY, height);
end;
#13: begin;
end;
{ skip a character ahead, no need to "draw" a space char (empty) }
' ': inc(currentX, spaceWidth);
else begin
if _boundFont <> nil then
width := _boundFont^.widths[Ord(ch)];
DrawChar(currentX, currentY, currentX, currentY, width, height, color, ch);
inc(currentX, width);
end;
end;
end;
end;
procedure PrintAt(x, y: integer);
{ sets the text position for subsequent calls to any of the PrintXxx
functions. }
begin
if x > SCREEN_RIGHT then
exit;
if y > SCREEN_BOTTOM then
exit;
_currentTextX := x;
_currentTextY := y;
_currentTextStartX := x;
end;
procedure PrintShortInt(value: shortint; color: Color);
{ displays a short-integer value at the current text position. clipping is
performed as necessary. }
begin
Str(value, _valueString);
DrawString(_currentTextX, _currentTextY, color, _valueString);
inc(_currentTextX, length(_valueString) * CHAR_WIDTH);
end;
procedure PrintInt(value: integer; color: Color);
{ displays an integer value at the current text position. clipping is
performed as necessary. }
begin
Str(value, _valueString);
DrawString(_currentTextX, _currentTextY, color, _valueString);
inc(_currentTextX, length(_valueString) * CHAR_WIDTH);
end;
procedure PrintLongInt(value: longint; color: Color);
{ displays a long-integer value at the current text position. clipping is
performed as necessary. }
begin
Str(value, _valueString);
DrawString(_currentTextX, _currentTextY, color, _valueString);
inc(_currentTextX, length(_valueString) * CHAR_WIDTH);
end;
procedure PrintByte(value: byte; color: Color);
{ displays a byte value at the current text position. clipping is performed
as necessary. }
begin
Str(value, _valueString);
DrawString(_currentTextX, _currentTextY, color, _valueString);
inc(_currentTextX, length(_valueString) * CHAR_WIDTH);
end;
procedure PrintWord(value: word; color: Color);
{ displays a word value at the current text position. clipping is performed
as necessary. }
begin
Str(value, _valueString);
DrawString(_currentTextX, _currentTextY, color, _valueString);
inc(_currentTextX, length(_valueString) * CHAR_WIDTH);
end;
procedure PrintReal(value: real; color: Color);
{ displays a real value at the current text position. clipping is performed
as necessary. }
begin
Str(value, _valueString);
DrawString(_currentTextX, _currentTextY, color, _valueString);
inc(_currentTextX, length(_valueString) * CHAR_WIDTH);
end;
procedure PrintRealFmt(value: real; decimals: integer; color: Color);
{ displays a real value using a specific number of decimal points at the
current text position. clipping is performed as necessary. }
begin
Str(value:0:decimals, _valueString);
DrawString(_currentTextX, _currentTextY, color, _valueString);
inc(_currentTextX, length(_valueString) * CHAR_WIDTH);
end;
procedure PrintSingle(value: single; color: Color);
{ displays a single-precision value at the current text position. clipping
is performed as necessary. }
begin
Str(value, _valueString);
DrawString(_currentTextX, _currentTextY, color, _valueString);
inc(_currentTextX, length(_valueString) * CHAR_WIDTH);
end;
procedure PrintSingleFmt(value: single; decimals: integer; color: Color);
{ displays a single-precision value using a specific number of decimal points
at the current text position. clipping is performed as necessary. }
begin
Str(value:0:decimals, _valueString);
DrawString(_currentTextX, _currentTextY, color, _valueString);
inc(_currentTextX, length(_valueString) * CHAR_WIDTH);
end;
procedure PrintDouble(value: double; color: Color);
{ displays a double-precision value at the current text position. clipping
is performed as necessary. }
begin
Str(value, _valueString);
DrawString(_currentTextX, _currentTextY, color, _valueString);
inc(_currentTextX, length(_valueString) * CHAR_WIDTH);
end;
procedure PrintDoubleFmt(value: double; decimals: integer; color: Color);
{ displays a double-precision value using a specific number of decimal points
at the current text position. clipping is performed as necessary. }
begin
Str(value:0:decimals, _valueString);
DrawString(_currentTextX, _currentTextY, color, _valueString);
inc(_currentTextX, length(_valueString) * CHAR_WIDTH);
end;
procedure PrintString(const text: string; color: Color);
{ displays a string at the current text position. handles multi-line strings
automatically. clipping is performed as necessary. }
var
ch : char;
i, width, height, len : integer;
spaceWidth : integer;
clippedX, clippedY : integer;
clippedWidth, clippedHeight : integer;
begin
width := CHAR_WIDTH;
len := length(text);
if _boundFont <> nil then begin
height := _boundFont^.height;
spaceWidth := _boundFont^.widths[Ord(' ')];
end else begin
height := CHAR_HEIGHT;
spaceWidth := CHAR_WIDTH;
end;
for i := 1 to len do begin
ch := text[i];
case ch of
{ move to next line }
#10: begin
_currentTextX := _currentTextStartX;
inc(_currentTextY, height);
end;
#13: begin;
end;
{ skip a character ahead, no need to "draw" a space char (empty) }
' ': inc(_currentTextX, spaceWidth);
else begin
if _boundFont <> nil then
width := _boundFont^.widths[Ord(ch)];
clippedX := _currentTextX;
clippedY := _currentTextY;
clippedWidth := width;
clippedHeight := height;
if ClipToClipRegion(clippedX, clippedY, clippedWidth, clippedHeight) then
DrawChar(_currentTextX, _currentTextY, clippedX, clippedY, clippedWidth, clippedHeight, color, ch);
inc(_currentTextX, width);
end;
end;
end;
end;
procedure AllocBitmap(width, height: word; var bmp: PBitmap);
{ allocates the memory necessary for a bitmap of the specified size }
begin
GetMem(bmp, SizeOf(Bitmap) + (width * height) - 1);
bmp^.Width := width;
bmp^.Height := height;
end;
procedure FreeBitmap(bmp: PBitmap);
{ frees previously allocated memory for the given bitmap. the bitmap should
not be used again after this unless re-allocated via AllocBitmap }
begin
if bmp = nil then exit;
FreeMem(bmp, SizeOf(Bitmap) + (bmp^.width * bmp^.height) - 1);
end;
procedure GrabBitmap(x, y: integer; width, height: word; bmp: PBitmap);
{ copies a region of pixels from the current layer onto the specified bitmap.
the bitmap must have already been allocated, and be large enough to hold
pixel data of the provided dimensions. }
var
line : word;
src, dest : ^byte;
begin
src := GetBoundLayerPointerAt(x, y);
dest := @bmp^.Pixels;
{ TODO: re-write this in inline-assembly }
for line := 0 to (height - 1) do begin
MemCopy(dest, src, width);
inc(src, SCREEN_WIDTH);
inc(dest, width);
end;
end;
{ "Low-Level" Solid Blit routines. These are only really intended to be
called by the main "BlitXXX" functions, but possibly could be used directly
by applications when the utmost speed is required ...
These functions DO NOT perform any argument validation or clipping, etc! }
procedure LLBlit4(width, height, destYinc, srcYinc: integer;
destOffs, srcSeg, srcOffs: word);
{ blit a block of memory to the given destination. assumes the source
pixels have an exact dword-sized width. }
assembler;
asm
push ds
mov dx, height { dx = line loop counter }
test dx, dx { stop now if there's zero lines to draw }
jz @done
db $66; xor cx, cx { xor ecx, ecx }
mov ax, width
mov di, destOffs
mov si, srcOffs
mov es, _boundLayerSeg
mov ds, srcSeg
shr ax, 2 { ax = number of dwords to draw per line }
@draw_line:
mov cx, ax
db $f3,$66,$a5 { rep movsd - draw dwords }
add si, srcYinc { move to next line }
add di, destYinc
dec dx { decrease line loop counter }
jnz @draw_line
@done:
pop ds
end;
procedure LLBlit4r(width, height, destYinc, srcYinc: integer;
destOffs, srcSeg, srcOffs: word);
{ blit a block of memory to the given destination. assumes the source
pixels have a width composed of some dword-sized portion PLUS a remainder
of 1-3 pixels at the end. }
assembler;
asm
push ds
mov dx, height { dx = line loop counter }
test dx, dx { stop now if there's zero lines to draw }
jz @done
db $66; xor cx, cx { xor ecx, ecx }
mov ax, width
mov di, destOffs
mov si, srcOffs
mov es, _boundLayerSeg
mov ds, srcSeg
mov bx, ax
shr ax, 2 { ax = number of dwords to draw per line }
and bx, 3 { bx = remaining number of pixels }
@draw_line:
mov cx, ax
db $f3,$66,$a5 { rep movsd - draw dwords }
mov cx, bx
rep movsb { draw remainder pixels }
add si, srcYinc { move to next line }
add di, destYinc
dec dx { decrease line loop counter }
jnz @draw_line
@done:
pop ds
end;
procedure LLBlitRemainder(width, height, destYinc, srcYinc: integer;
destOffs, srcSeg, srcOffs: word);
{ blit a block of memory to the given destination. will just use a simple
rep movsb for each line. intended only for blits whose width is <= 3. }
assembler;
asm
push ds
mov dx, height { dx = line loop counter }
test dx, dx { stop now if there's zero lines to draw }
jz @done
mov ax, width
mov di, destOffs
mov si, srcOffs
mov es, _boundLayerSeg
mov ds, srcSeg
@draw_line:
mov cx, ax
rep movsb { draw pixels }
add si, srcYinc { move to next line }
add di, destYinc
dec dx { decrease line loop counter }
jnz @draw_line
@done:
pop ds
end;
{ End of Low-Level Solid Blit functions ^^^ }
procedure BlitSubset(srcX, srcY, srcWidth, srcHeight, destX, destY: integer;
const bmp: PBitmap);
{ draws the specified subset/region of the bitmap onto the current layer. the
bitmap is clipped to the current clipping region boundaries. }
begin
if not ClipBlitToClipRegion(srcX, srcY, srcWidth, srcHeight, destX, destY) then
exit;
BlitSubsetf(srcX, srcY, srcWidth, srcHeight, destX, destY, bmp);
end;
procedure BlitSubsetf(srcX, srcY, srcWidth, srcHeight, destX, destY: integer;
const bmp: PBitmap);
{ draws the specified subset/region of the bitmap onto the current layer. no
clipping is performed. }
var
srcSeg, srcOffs, destOffs : word;
srcYinc, destYinc : integer;
width4, widthRemainder : integer;
begin
srcSeg := Seg(bmp^.Pixels);
srcOffs := GetBitmapOffsetAt(srcX, srcY, bmp);
destOffs := GetBoundLayerOffsetAt(destX, destY);
srcYinc := bmp^.Width - srcWidth;
destYinc := SCREEN_WIDTH - srcWidth;
width4 := srcWidth div 4;
widthRemainder := srcWidth and 3;
if ((width4 > 0) and (widthRemainder = 0)) then begin
LLBlit4(srcWidth, srcHeight, destYinc, srcYinc, destOffs, srcSeg, srcOffs);
end else if ((width4 > 0) and (widthRemainder > 0)) then begin
LLBlit4r(srcWidth, srcHeight, destYinc, srcYinc, destOffs, srcSeg, srcOffs);
end else begin
LLBlitRemainder(srcWidth, srcHeight, destYinc, srcYinc, destOffs, srcSeg, srcOffs);
end
end;
procedure Blit(x, y: integer; const bmp: PBitmap);
{ draws the given bitmap onto the current layer. the bitmap is clipped to
the current clipping region boundaries. }
var
srcX, srcY : integer;
srcWidth, srcHeight : integer;
begin
srcX := 0;
srcY := 0;
srcWidth := bmp^.Width;
srcHeight := bmp^.Height;
if not ClipBlitToClipRegion(srcX, srcY, srcWidth, srcHeight, x, y) then
exit;
BlitSubsetf(srcX, srcY, srcWidth, srcHeight, x, y, bmp);
end;
procedure Blitf(x, y: integer; const bmp: PBitmap);
{ draws the given bitmap onto the current layer. no clipping is performed. }
begin
BlitSubsetf(0, 0, bmp^.Width, bmp^.Height, x, y, bmp);
end;
{ "Low-Level" Transparent Blit routines. These are only really intended to be
called by the main "BlitXXX" functions, but possibly could be used directly
by applications when the utmost speed is required ...
These functions DO NOT perform any argument validation or clipping, etc! }
procedure LLBlitSprite8(width8, height, destYinc, srcYinc: integer;
destOffs, srcSeg, srcOffs: word);
{ blit a block of memory to the given destination, treating colour 0 as the
transparent pixel which will be skipped over. assumes the source pixels
have an exact double-dword-sized width (that is, an exact multiple of 8). }
assembler;
asm
push ds
mov dx, height { dx = line loop counter }
test dx, dx { stop now if there's zero lines to draw }
jz @done
mov ax, width8
mov di, destOffs
mov si, srcOffs
mov es, _boundLayerSeg
mov ds, srcSeg
@draw_line:
mov cx, ax { cx = number of 8-pixel runs left to draw }
@draw_px_0:
mov bx, ds:[si+0] { load two pixels }
test bl, bl
jz @draw_px_1 { if it is color 0, skip it }
mov es:[di+0], bl { otherwise, draw it }
@draw_px_1:
test bh, bh { bh has the second loaded pixel }
jz @draw_px_2
mov es:[di+1], bh
@draw_px_2:
mov bx, ds:[si+2]
test bl, bl
jz @draw_px_3
mov es:[di+2], bl
@draw_px_3:
test bh, bh
jz @draw_px_4
mov es:[di+3], bh
@draw_px_4:
mov bx, ds:[si+4]
test bl, bl
jz @draw_px_5
mov es:[di+4], bl
@draw_px_5:
test bh, bh
jz @draw_px_6
mov es:[di+5], bh
@draw_px_6:
mov bx, ds:[si+6]
test bl, bl
jz @draw_px_7
mov es:[di+6], bl
@draw_px_7:
test bh, bh
jz @end_run
mov es:[di+7], bh
@end_run:
add si, 8 { mov src and dest up 8 pixels }
add di, 8
dec cx { decrease 8-pixel run loop counter }
jnz @draw_px_0 { if there are still more runs, draw them }
@end_line:
add si, srcYinc { move to next line }
add di, destYinc
dec dx { decrease line loop counter }
jnz @draw_line
@done:
pop ds
end;
procedure LLBlitSprite4(width4, height, destYinc, srcYinc: integer;
destOffs, srcSeg, srcOffs: word);
{ blit a block of memory to the given destination, treating colour 0 as the
transparent pixel which will be skipped over. assumes the source pixels
have an exact dword-sized width (that is, an exact multiple of 4). }
assembler;
asm
push ds
mov dx, height { dx = line loop counter }
test dx, dx { stop now if there's zero lines to draw }
jz @done
mov ax, width4
mov di, destOffs
mov si, srcOffs
mov es, _boundLayerSeg
mov ds, srcSeg
@draw_line:
mov cx, ax { cx = number of 4-pixel runs left to draw }
@draw_px_0:
mov bx, ds:[si+0] { load two pixels }
test bl, bl
jz @draw_px_1 { if it is color 0, skip it }
mov es:[di+0], bl { otherwise, draw it }
@draw_px_1:
test bh, bh { bh has the second loaded pixel }
jz @draw_px_2
mov es:[di+1], bh
@draw_px_2:
mov bx, ds:[si+2]
test bl, bl
jz @draw_px_3
mov es:[di+2], bl
@draw_px_3:
test bh, bh
jz @end_run
mov es:[di+3], bh
@end_run:
add si, 4 { mov src and dest up 4 pixels }
add di, 4
dec cx { decrease 4-pixel run loop counter }
jnz @draw_px_0 { if there are still more runs, draw them }
@end_line:
add si, srcYinc { move to next line }
add di, destYinc
dec dx { decrease line loop counter }
jnz @draw_line
@done:
pop ds
end;
procedure LLBlitSprite8r(width8, height, widthRemainder, destYinc, srcYinc: integer;
destOffs, srcSeg, srcOffs: word);
{ blit a block of memory to the given destination, treating colour 0 as the
transparent pixel which will be skipped over. assumes the source pixels
have a width that is composed of a double-dword-sized section (that is,
some segment that is a multiple of 8) plus some remainder bit that is
<= 7 pixels long. }
assembler;
asm
push ds
mov dx, height { dx = line loop counter }
test dx, dx { stop now if there's zero lines to draw }
jz @done
mov ax, width8
mov di, destOffs
mov si, srcOffs
mov es, _boundLayerSeg
mov ds, srcSeg
@draw_line:
mov cx, ax { cx = number of 8-pixel runs left to draw }
@draw_px_0:
mov bx, ds:[si+0] { load two pixels }
test bl, bl
jz @draw_px_1 { if it is color 0, skip it }
mov es:[di+0], bl { otherwise, draw it }
@draw_px_1:
test bh, bh { bh has the second loaded pixel }
jz @draw_px_2
mov es:[di+1], bh
@draw_px_2:
mov bx, ds:[si+2]
test bl, bl
jz @draw_px_3
mov es:[di+2], bl
@draw_px_3:
test bh, bh
jz @draw_px_4
mov es:[di+3], bh
@draw_px_4:
mov bx, ds:[si+4]
test bl, bl
jz @draw_px_5
mov es:[di+4], bl
@draw_px_5:
test bh, bh
jz @draw_px_6
mov es:[di+5], bh
@draw_px_6:
mov bx, ds:[si+6]
test bl, bl
jz @draw_px_7
mov es:[di+6], bl
@draw_px_7:
test bh, bh
jz @end_run
mov es:[di+7], bh
@end_run:
add si, 8 { mov src and dest up 8 pixels }
add di, 8
dec cx { decrease 8-pixel run loop counter }
jnz @draw_px_0 { if there are still more runs, draw them }
@start_remainder_run: { now draw remaining pixels ( <= 7 pixels ) }
mov cx, widthRemainder
@draw_pixel:
mov bl, ds:[si] { load pixel }
inc si
test bl, bl { if zero, skip to next pixel }
jz @end_pixel
mov es:[di], bl { else, draw the pixel }
@end_pixel:
inc di
dec cx
jnz @draw_pixel
@end_line:
add si, srcYinc { move to next line }
add di, destYinc
dec dx { decrease line loop counter }
jnz @draw_line
@done:
pop ds
end;
procedure LLBlitSprite4r(width4, height, widthRemainder, destYinc, srcYinc: integer;
destOffs, srcSeg, srcOffs: word);
{ blit a block of memory to the given destination, treating colour 0 as the
transparent pixel which will be skipped over. assumes the source pixels
have a width that is composed of a dword-sized section (that is, some
segment that is a multiple of 4) plus some remainder bit that is
<= 3 pixels long. }
assembler;
asm
push ds
mov dx, height { dx = line loop counter }
test dx, dx { stop now if there's zero lines to draw }
jz @done
mov ax, width4
mov di, destOffs
mov si, srcOffs
mov es, _boundLayerSeg
mov ds, srcSeg
@draw_line:
mov cx, ax { cx = number of 4-pixel runs left to draw }
@draw_px_0:
mov bx, ds:[si+0] { load two pixels }
test bl, bl
jz @draw_px_1 { if it is color 0, skip it }
mov es:[di+0], bl { otherwise, draw it }
@draw_px_1:
test bh, bh { bh has the second loaded pixel }
jz @draw_px_2
mov es:[di+1], bh
@draw_px_2:
mov bx, ds:[si+2]
test bl, bl
jz @draw_px_3
mov es:[di+2], bl
@draw_px_3:
test bh, bh
jz @end_run
mov es:[di+3], bh
@end_run:
add si, 4 { mov src and dest up 4 pixels }
add di, 4
dec cx { decrease 4-pixel run loop counter }
jnz @draw_px_0 { if there are still more runs, draw them }
@start_remainder_run: { now draw remaining pixels ( <= 3 pixels ) }
mov cx, widthRemainder
@draw_pixel:
mov bl, ds:[si] { load pixel }
inc si
test bl, bl { if zero, skip to next pixel }
jz @end_pixel
mov es:[di], bl { else, draw the pixel }
@end_pixel:
inc di
dec cx
jnz @draw_pixel
@end_line:
add si, srcYinc { move to next line }
add di, destYinc
dec dx { decrease line loop counter }
jnz @draw_line
@done:
pop ds
end;
procedure LLBlitSpriteRemainder(width, height, destYinc, srcYinc: integer;
destOffs, srcSeg, srcOffs: word);
{ blit a block of memory to the given destination, treating colour 0 as the
transparent pixel which will be skipped over. this is the slowest of the
transparent blit routines, that technically can draw at any width, but
is really intended for widths <= 7 only. }
assembler;
asm
push ds
mov dx, height { dx = line loop counter }
test dx, dx { stop now if there's zero lines to draw }
jz @done
mov ax, width
mov di, destOffs
mov si, srcOffs
mov es, _boundLayerSeg
mov ds, srcSeg
@draw_line:
mov cx, ax { cx = number of pixels to draw }
@draw_pixel:
mov bl, ds:[si] { load pixel }
inc si
test bl, bl { if zero, skip to next pixel }
jz @end_pixel
mov es:[di], bl { else, draw the pixel }
@end_pixel:
inc di
dec cx
jnz @draw_pixel { loop while there's still pixels left }
@end_line:
add si, srcYinc { move to next line }
add di, destYinc
dec dx { decrease line loop counter }
jnz @draw_line
@done:
pop ds
end;
{ End of Low-Level Transparent Blit functions ^^^ }
procedure BlitSpriteSubset(srcX, srcY, srcWidth, srcHeight, destX, destY: integer;
const bmp: PBitmap);
{ draws the specified subset/region of the given bitmap onto the current
layer, ignoring color 0 (treated as transparent). the bitmap is clipped to
the current clipping region boundaries. }
begin
if not ClipBlitToClipRegion(srcX, srcY, srcWidth, srcHeight, destX, destY) then
exit;
BlitSpriteSubsetf(srcX, srcY, srcWidth, srcHeight, destX, destY, bmp);
end;
procedure BlitSpriteSubsetf(srcX, srcY, srcWidth, srcHeight, destX, destY: integer;
const bmp: PBitmap);
{ draws the specified subset/region of the given bitmap onto the current
layer, ignoring color 0 (treated as transparent). no clipping is
performed. }
var
srcSeg, srcOffs, destOffs : word;
srcYinc, destYinc : integer;
width4, widthRemainder : integer;
begin
srcSeg := Seg(bmp^.Pixels);
srcOffs := GetBitmapOffsetAt(srcX, srcY, bmp);
destOffs := GetBoundLayerOffsetAt(destX, destY);
srcYinc := bmp^.Width - srcWidth;
destYinc := SCREEN_WIDTH - srcWidth;
width4 := srcWidth div 4;
widthRemainder := srcWidth and 3;
if (width4 > 0) and (widthRemainder = 0) then begin
if ((width4 and 1) = 0) then begin
{ width is actually an even multiple of 8! }
LLBlitSprite8(width4 div 2, srcHeight, destYinc, srcYinc, destOffs, srcSeg, srcOffs);
end else begin
{ width is a multiple of 4 (no remainder) }
LLBlitSprite4(width4, srcHeight, destYinc, srcYinc, destOffs, srcSeg, srcOffs);
end;
end else if (width4 > 0) and (widthRemainder > 0) then begin
if ((width4 and 1) = 0) then begin
{ width is mostly made up of an even multiple of 8. but there is also
a small remainder }
LLBlitSprite8r(width4 div 2, srcHeight, widthRemainder, destYinc, srcYinc, destOffs, srcSeg, srcOffs);
end else begin
{ width is >= 4 with a remainder }
LLBlitSprite4r(width4, srcHeight, widthRemainder, destYinc, srcYinc, destOffs, srcSeg, srcOffs);
end;
end else begin
{ width is <= 3 }
LLBlitSpriteRemainder(widthRemainder, srcHeight, destYinc, srcYinc, destOffs, srcSeg, srcOffs);
end;
end;
procedure BlitSprite(x, y: integer; const bmp: PBitmap);
{ draws the given bitmap onto the current layer, ignoring color 0 (treated
as transparent). the bitmap is clipped to the current clipping region
boundaries. }
var
srcX, srcY : integer;
srcWidth, srcHeight : integer;
begin
srcX := 0;
srcY := 0;
srcWidth := bmp^.Width;
srcHeight := bmp^.Height;
if not ClipBlitToClipRegion(srcX, srcY, srcWidth, srcHeight, x, y) then
exit;
BlitSpriteSubsetf(srcX, srcY, srcWidth, srcHeight, x, y, bmp);
end;
procedure BlitSpritef(x, y: integer; const bmp: PBitmap);
{ draws the given bitmap onto the current layer, ignoring color 0 (treated
as transparent). no clipping is performed. }
begin
BlitSpriteSubsetf(0, 0, bmp^.Width, bmp^.Height, x, y, bmp);
end;
procedure SetColor(color, r, g, b: byte);
{ changes the VGA color palette for the color specified }
begin
port[$3c6] := $ff;
port[$3c8] := color;
port[$3c9] := r;
port[$3c9] := g;
port[$3c9] := b;
end;
procedure GetColor(color: byte; var r, g, b: byte);
{ reads the current VGA color palette RGB values for the color specified }
begin
port[$3c6] := $ff;
port[$3c7] := color;
r := port[$3c9];
g := port[$3c9];
b := port[$3c9];
end;
procedure SetPalette(const pal: PPalette);
{ sets the current VGA color palette to the given one }
var
i : integer;
begin
for i := 0 to 255 do begin
SetColor(i, pal^[i, 0], pal^[i, 1], pal^[i, 2]);
end;
end;
procedure GetPalette(pal: PPalette);
{ reads the current VGA color palette, storing all RGB values in the
provided Palette structure }
var
i : integer;
begin
for i := 0 to 255 do begin
GetColor(i, pal^[i, 0], pal^[i, 1], pal^[i, 2]);
end;
end;
function FadeColor(color, r, g, b: byte; step: integer) : boolean;
{ fades (in/out) the specified color towards the given RGB values by 'step'
amount. returns true if the color's RGB values have reached the target
RGB values, false otherwise. }
var
red, green, blue : byte;
diffR, diffG, diffB : byte;
modified : boolean;
begin
modified := false;
GetColor(color, red, green, blue);
if red <> r then begin
modified := true;
diffR := Abs(red - r);
if red > r then
dec(red, Min(step, diffR))
else
inc(red, Min(step, diffR));
end;
if green <> g then begin
modified := true;
diffG := Abs(green - g);
if green > g then
dec(green, Min(step, diffG))
else
inc(green, Min(step, diffG));
end;
if blue <> b then begin
modified := true;
diffB := Abs(blue - b);
if blue > b then
dec(blue, Min(step, diffB))
else
inc(blue, Min(step, diffB));
end;
if modified then
SetColor(color, red, green, blue);
FadeColor := ((red = r) and (green = g) and (blue = b));
end;
procedure FadeRangeToColor(colorStart, colorEnd, r, g, b: byte;
step: integer);
{ fades a range of colors in the current VGA color palette towards the
given RGB values. blocks, looping until the fade is complete. }
var
i : integer;
done : boolean;
begin
done := false;
step := Abs(step);
while not done do begin
done := true;
WaitForVsync;
for i := colorStart to colorEnd do begin
if not FadeColor(i, r, g, b, step) then
done := false;
end;
end;
end;
procedure FadeRangeToPalette(colorStart, colorEnd: byte;
const pal: PPalette;
step: integer);
{ fades a range of colors in the current VGA color palette towards the
given color palette. blocks, looping until the fade is complete. }
var
i : integer;
done : boolean;
begin
done := false;
step := Abs(step);
while not done do begin
done := true;
WaitForVsync;
for i := colorStart to colorEnd do begin
if not FadeColor(i, pal^[i, 0], pal^[i, 1], pal^[i, 2], step) then
done := false;
end;
end;
end;
function LoadFont(const filename: string; font: PFont) : FontResult;
{ loads a font from the given file, storing it in the Font instance
provided. returns FontOk on success. }
var
f : file;
x : integer;
label ioError;
begin
if font = nil then begin
LoadFont := FontBadArgs;
exit;
end;
Assign(f, filename);
Reset(f, 1);
if IOResult <> 0 then begin
Close(f);
x := IOResult; { clear i/o error flag }
LoadFont := FontNotFound;
exit;
end;
{ this font format is the same as the one DirectQB uses. it is a simple
format that i think works pretty well, so why not re-use it here ... }
with font^ do begin
{ standard BIOS-like format list of full ASCII 0-255 characters.
8-bytes per character }
BlockRead(f, chars, SizeOf(BiosFontTable));
if IOResult <> 0 then goto ioError;
{ 255 bytes, each byte representing the width of each ASCII character }
BlockRead(f, widths, SizeOf(BiosFontCharWidths));
if IOResult <> 0 then goto ioError;
{ single byte, the global character height. that is, this is the max
height of any of the 256 ASCII characters in this font. will be <= 8 }
BlockRead(f, height, 1);
if IOResult <> 0 then goto ioError;
end;
Close(f);
x := IOResult; { clear i/o error flag (just in case) }
LoadFont := FontOk;
exit;
ioError:
Close(f);
x := IOResult; { clear i/o error flag }
LoadFont := FontIOError;
end;
function LoadPalette(const filename: string; pal: PPalette) : FontResult;
begin
end;
begin
if Test8086 < 2 then begin
writeln('The GDGFX unit requires a 386 cpu or higher!');
halt;
end;
end.
Reference in a new issue Copy permalink