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

initial commit of "completed" sources, binaries and assets

Browse source 
as of july 4th, 2021
This commit is contained in:
Gered 2021-07-07 17:10:18 -04:00
commit 0286c2df03
36 changed files with 10543 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

180
ASSETS.PAS Normal file
View file

@ -0,0 +1,180 @@
{$A+,B-,E+,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit Assets;
interface
uses GDGfx, GDIFF, Maps, Shared;
type
UIFrameBitmaps = array[0..9] of PBitmap;
var
pal : Palette;
fnt : Font;
chunkyFnt : Font;
tiles : array[0..99] of PBitmap;
sprites : array[0..99] of PBitmap;
titleMain : PBitmap;
titleSelectLevel : PBitmap;
titleChooseFruit : PBitmap;
titleHelp : PBitmap;
titleResults : PBitmap;
titlePause : PBitmap;
uiTomatoFrame : UIFrameBitmaps;
uiGrapesFrame : UIFrameBitmaps;
uiGeneralFrame : UIFrameBitmaps;
function LoadTilesAndSprites(filename : string) : boolean;
function LoadImages(filename : string) : boolean;
function LoadMap(filename : string) : boolean;
implementation
uses Toolbox;
function LoadTilesAndSprites(filename : string) : boolean;
var
i, x, y, offset : integer;
puiFrame : ^UIFrameBitmaps;
label return;
begin
LoadTilesAndSprites := false;
UseLayer(BACKBUFFER_LAYER);
if LoadIFF(filename, @pal) <> IFFOk then goto return;
{ environment tiles are on the left }
offset := 0;
i := 0;
for y := 0 to 9 do begin
for x := 0 to 9 do begin
AllocBitmap(16, 16, tiles[i]);
GrabBitmap((x*16)+offset, y*16, 16, 16, tiles[i]);
inc(i);
end;
end;
{ sprites are on the right }
offset := 160;
i := 0;
for y := 0 to 9 do begin
for x := 0 to 9 do begin
AllocBitmap(16, 16, sprites[i]);
GrabBitmap((x*16)+offset, y*16, 16, 16, sprites[i]);
inc(i);
end;
end;
{ other things that are not in a uniform 16x16 grid }
for i := 0 to 2 do begin
case i of
0: puiFrame := @uiTomatoFrame;
1: puiFrame := @uiGrapesFrame;
2: puiFrame := @uiGeneralFrame;
end;
x := i * 48;
AllocBitmap(16, 16, puiFrame^[0]);
AllocBitmap(8, 8, puiFrame^[1]);
AllocBitmap(16, 16, puiFrame^[2]);
AllocBitmap(8, 8, puiFrame^[3]);
AllocBitmap(8, 8, puiFrame^[4]);
AllocBitmap(8, 8, puiFrame^[5]);
AllocBitmap(16, 16, puiFrame^[6]);
AllocBitmap(8, 8, puiFrame^[7]);
AllocBitmap(16, 16, puiFrame^[8]);
GrabBitmap(x+0, 176, 16, 16, puiFrame^[0]);
GrabBitmap(x+16, 176, 8, 8, puiFrame^[1]);
GrabBitmap(x+32, 176, 16, 16, puiFrame^[2]);
GrabBitmap(x+0, 184, 8, 8, puiFrame^[3]);
GrabBitmap(x+8, 184, 8, 8, puiFrame^[4]);
GrabBitmap(x+40, 184, 8, 8, puiFrame^[5]);
GrabBitmap(x+0, 184, 16, 16, puiFrame^[6]);
GrabBitmap(x+16, 192, 8, 8, puiFrame^[7]);
GrabBitmap(x+32, 184, 16, 16, puiFrame^[8]);
end;
LoadTilesAndSprites := true;
return:
UseLayer(SCREEN_LAYER);
end;
function LoadImages(filename : string) : boolean;
label return;
begin
LoadImages := false;
UseLayer(BACKBUFFER_LAYER);
if LoadIFF(filename, nil) <> IFFOk then goto return;
AllocBitmap(98, 38, titlePause);
GrabBitmap(3, 2, 98, 38, titlePause);
AllocBitmap(124, 39, titleResults);
GrabBitmap(121, 2, 124, 39, titleResults);
AllocBitmap(164, 37, titleSelectLevel);
GrabBitmap(2, 42, 164, 37, titleSelectLevel);
AllocBitmap(262, 35, titleChooseFruit);
GrabBitmap(2, 79, 262, 35, titleChooseFruit);
AllocBitmap(196, 40, titleHelp);
GrabBitmap(2, 112, 196, 40, titleHelp);
AllocBitmap(272, 48, titleMain);
GrabBitmap(2, 150, 272, 48, titleMain);
LoadImages := true;
return:
UseLayer(SCREEN_LAYER);
end;
function LoadMap(filename : string) : boolean;
var
f : file;
n : integer;
header : array[0..2] of char;
label ioError;
begin
LoadMap := false;
Assign(f, filename);
Reset(f, 1);
if IOResult <> 0 then begin
Close(f);
n := IOResult; { clear i/o error flag }
exit;
end;
{ validate file type by checking for expected header }
BlockRead(f, header, SizeOf(header));
if (header[0] <> 'M') or (header[1] <> 'A') or (header[2] <> 'P') then
goto ioError;
MemFill(@map, 0, SizeOf(map));
BlockRead(f, map, SizeOf(map), n);
if n <> SizeOf(map) then goto ioError;
isMapDirty := true;
LoadMap := true;
Close(f);
n := IOResult; { clear i/o error flag }
exit;
ioError:
LoadMap := false;
Close(f);
n := IOResult; { clear i/o error flag }
end;
end.

BIN
CHUNKY.FNT Normal file
View file

Binary file not shown.

93
DESIGN.TXT Normal file
View file

@ -0,0 +1,93 @@
******** GDR 4x4x4 Design Challenge - June 2021 *****************************
Entry By: Gered King <gered@blarg.ca>
Emojis Selected: Tomato / Thumbtack / Two Users / Grapes
-------- CONCEPT ------------------------------------------------------------
"Head-to-Head Fruit Popper"
Play against a friend (or the computer), squaring-off in a garden with fruit
magically growing quickly and at random. Be the fastest to pop the most fruit
with your magical thumb-tack within the time limit! Your thumb-tack has been
magically attuned to only one of two different types of fruit, while your
opponent will be seeking out the opposite type of fruit.
-------- PRESENTATION -------------------------------------------------------
2D, top-down, single-screen arena. Kind of like Bomberman without the bombs?
Players represented by character sprites that they control directly to move
around the arena. The arena will have different (non-hazardous?) obstacles
(walls), and fruit will be randomly spawning / dropping-in / etc as the game
timer counts down.
16x16 sprites/tiles.
MS-DOS VGA Mode 13h.
-------- CONTROLS -----------------------------------------------------------
Keyboard.
Single-player:
- Arrow keys for movement, 4 directional, N/S/E/W.
- Spacebar to use thumb-tack.
Two-player:
- Player 1:
- Arrow keys / Num-pad for movement.
- Num-pad 0 / Num-pad Enter to use thumb-tack.
- Player 2:
- ASDW for movement
- Spacebar to use thumb-tack.
Nice extra: Allow use of game controller (e.g. Gravis Gamepad).
-------- GAMEPLAY -----------------------------------------------------------
Players select their preferred fruit. Cannot be the same selection, so once
one player selects a fruit, the other player is automatically assigned the
other. Tomato or Grape.
Once the match begins, the main objective is to pop the most fruit matching
the player's fruit of choice.
Popping the right fruit does not cause any penalty or other sort of effect
to the other player, it simply increments the players score and the fruit
vanishes.
Popping the wrong fruit does not cause a penalty for the player that popped
it, but the player receives no score for it.
However, popping the wrong fruit causes your magically attuned thumbtack to
trigger the fruit to explode, which does not harm you, but will "splash"
toxic fruit juice over a 3x3 (TBD) tile area which will debuff the other
player if they are within that area, causing them to move at 50% speed until
the debuff wears off (2-3 seconds? TBD). Additionally, any other fruit of the
same type within a 5x5 (TBD) tile area will magically vanish. So players may
want to strategically pop the other players fruit to deny them score and slow
them down.
Players can "prick" each other with their thumbtacks. Players cannot be killed
but they can use their thumbtacks to push the other player out of the way
slightly, possibly also throwing them off a bit in the process. Pricking
another player causes them to get pushed ahead by 1-2 tiles, but causes no
other harm.
Matches are timed. Once the match is over, the score is displayed, and the
winner is the player who popped the most fruit.
-------- EXTRAS -------------------------------------------------------------
If time allows ...
- Sound effects. Use of Qbasic "SoundLab" utility to generate sound effects?
- Gravis Gamepad support
- Network play? Use of mTCP? Almost certainly won't have time for this ...
- Random "enemies" that spawn and snatch fruit before the players can get
them? Mutant-oversized fruit flys perhaps ... ? Or some kind of Locust
swarm maybe?

BIN
DP.FNT Normal file
View file

Binary file not shown.

489
DRAW.PAS Normal file
View file

@ -0,0 +1,489 @@
{$A+,B-,E+,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit Draw;
interface
uses GDGfx, Entities, Assets;
procedure DrawMap;
procedure DrawPlayer(const player : Player);
procedure DrawAllFruit;
procedure DrawAllParticles;
procedure DrawGameStatusBackdrop;
procedure DrawPlayerStatuses;
procedure DrawMatchStatus;
procedure DrawBackdrop;
procedure DrawUIFrame(x1, y1, width, height : integer;
const frameBitmaps : UIFrameBitmaps);
procedure FadeOut;
procedure FadeIn;
procedure FadeOutAndIn(delay : word);
procedure BlackOutPalette;
procedure BlitSpriteScaled(x, y: integer; xs, ys: word; const bmp: PBitmap);
implementation
uses GDTimer, FixedP, Toolbox, Maps, Shared;
const
TOMATO_X = 0;
GRAPES_X = 208;
GENERAL_X = 112;
STATUS_Y = 176;
procedure DrawMap;
var
x, y : word;
currentMapTile : ^byte;
oldLayer : integer;
begin
oldLayer := GetBoundLayerIndex;
UseLayer(SCREEN_MAP_LAYER);
currentMapTile := @map.map[0];
for y := 0 to 10 do begin
for x := 0 to 19 do begin
Blitf(x*16, y*16, tiles[currentMapTile^]);
inc(currentMapTile);
end;
end;
UseLayer(oldLayer);
isMapDirty := false;
end;
procedure DrawPlayer(const player : Player);
var
playerIndex, thumbTackIndex : word;
tx, ty : integer;
dir : Direction;
fruit : FruitKind;
skip : boolean;
begin
with player do begin
dir := entity.direction;
fruit := fruitPref;
skip := ((stabbedDebuffTime > 0) or (splashedDebuffTime > 0)) and skipRenderFlag;
{ compute the current final sprite index from the player's
current animation state and facing direction.
note that this value still needs to be added to playerSpriteOffsets
to get the real final sprite index for the correct player sprite set
(based on the player's chosen fruit type). }
playerIndex := GetAnimationFrame(
entity.animation,
playerAnimations[ord(state)],
dir
);
{ if the player is currently stabbing, then also get the thumbtack
sprite index to use }
if state = Stabbing then begin
thumbTackIndex := ord(dir) + thumbTackSpriteOffsets[ord(fruit)];
end;
end;
with player.entity.position do begin
if player.state = Stabbing then begin
{ the player is currently stabbing with their thumb tack, so we
need to render the thumb tack sprite too. the exact position
of the thumb tack sprite varies depending on the player's
facing direction (so as to position it in the player's hand) }
GetThumbTackRenderCoords(player, tx, ty);
if dir = North then begin
{ if we're facing north, the thumb tack sprite should be
rendered first, so that it is layered underneath the player
sprite }
BlitSpritef(tx, ty, sprites[thumbTackIndex]);
if not skip then
BlitSpritef(
FixToInt(x),
FixToInt(y),
sprites[playerIndex + playerSpriteOffsets[ord(fruit)]]
);
end else begin
{ but for every other direction, render the thumb tack sprite
layered on top of the player sprite }
if not skip then
BlitSpritef(
FixToInt(x),
FixToInt(y),
sprites[playerIndex + playerSpriteOffsets[ord(fruit)]]
);
BlitSpritef(tx, ty, sprites[thumbTackIndex]);
end;
end else begin
{ not stabbing, so just render the player sprite itself }
if not skip then
BlitSpritef(
FixToInt(x),
FixToInt(y),
sprites[playerIndex + playerSpriteOffsets[ord(fruit)]]
);
end;
end;
end;
procedure DrawAllFruit;
var
i, index : word;
value, offset : integer;
begin
for i := 0 to numDirtTiles-1 do begin
with dirtTiles[i] do begin
if not hasFruit then continue;
{ compute the final sprite index of the fruit based on its current
animation. note that not all states of the fruit entity actually
use real "animations" ... some are just an animation sequence of
1 frame, and is just being abused to fit into this general
framework ... :-) }
with fruit do begin
index := GetAnimationFrame(
entity.animation,
fruitAnimations[ord(state)],
South
);
end;
case fruit.state of
Plant: begin
{ just a simple plant }
with fruit.entity.position do begin
BlitSpritef(FixToInt(x), FixToInt(y), sprites[index]);
end;
end;
Growing: begin
{ render the fruit sprite, scaled. }
if fruit.isGold then inc(index, GOLD_FRUIT_TILE_OFFSET);
with fruit.entity.position do begin
value := fruit.value; { the pixel width/height of the
fruit sprite }
offset := 8-(value div 2); { the x/y coordinate offset used
to center the fruit sprite
within the map tile it is on }
BlitSpriteScaled(
FixToInt(x) + offset,
FixToInt(y) + offset,
value,
value,
sprites[index + fruitSpriteOffsets[ord(fruit.kind)]]
);
end;
end;
Grown, Popped: begin
{ render the fruit sprite }
if fruit.isGold then inc(index, GOLD_FRUIT_TILE_OFFSET);
with fruit.entity.position do begin
BlitSpritef(
FixToInt(x),
FixToInt(y),
sprites[index + fruitSpriteOffsets[ord(fruit.kind)]]
);
end;
end;
end;
end;
end;
end;
procedure DrawAllParticles;
var
i, index : word;
begin
for i := 0 to MAX_PARTICLES-1 do begin
with particles[i] do begin
if not active then continue;
if animation <> nil then begin
{ particle is a "sprite-animated" particle type. get its current
"final" sprite index based on its animation state }
index := GetAnimationFrame(
entity.animation,
animation^,
entity.direction
);
with entity.position do begin
BlitSpritef(FixToInt(x), FixToInt(y), sprites[index]);
end;
end else begin
{ TODO: "pixel" particle types ... }
end;
end;
end;
end;
procedure DrawGameStatusBackdrop;
var
i, oldLayer : integer;
begin
oldLayer := GetBoundLayerIndex;
UseLayer(SCREEN_MAP_LAYER);
{ tomato player status }
DrawUIFrame(TOMATO_X, STATUS_Y, 112, 24, uiTomatoFrame);
BlitSpritef(TOMATO_X+8, STATUS_Y+4, sprites[PLAYER_TOMATO_TILE_START]);
BlitSpritef(TOMATO_X+28, STATUS_Y+4, sprites[FRUIT_TOMATO_TILE_START]);
{ grapes player status }
DrawUIFrame(GRAPES_X, STATUS_Y, 112, 24, uiGrapesFrame);
BlitSpritef((SCREEN_RIGHT-16)-8, STATUS_Y+4, sprites[PLAYER_GRAPES_TILE_START]);
BlitSpritef((SCREEN_RIGHT-16)-28, STATUS_Y+4, sprites[FRUIT_GRAPES_TILE_START]);
{ general match info }
DrawUIFrame(GENERAL_X, STATUS_Y, 96, 24, uiGeneralFrame);
UseLayer(oldLayer);
isStatusBackdropDirty := false;
end;
procedure DrawPlayerStatuses;
const
TEXT_Y = STATUS_Y+13;
var
x, value : integer;
s : string[3];
begin
UseFont(@chunkyFnt);
with tomatoPlayer^ do begin
{ number of popped tomatoes }
Str(score:3, s);
DrawStringf(TOMATO_X+28, TEXT_Y, TOMATO_TEXT_COLOR, s);
x := TOMATO_X+56;
{ 'stabbed' debuff icon and time left }
if stabbedDebuffTime > 0 then begin
BlitSpritef(x, STATUS_Y+4, sprites[GRAPES_THUMBTACK_TILE]);
value := stabbedDebuffTime div 1000;
Str(value:3, s);
DrawStringf(x, TEXT_Y, DEBUFF_TEXT_COLOR, s);
inc(x, 28);
end;
{ 'splashed' debuff icon and time left }
if splashedDebuffTime > 0 then begin
BlitSpritef(x, STATUS_Y+4, sprites[SPLASH_GRAPES_TILE_START]);
value := splashedDebuffTime div 1000;
Str(value:3, s);
DrawStringf(x, TEXT_Y, DEBUFF_TEXT_COLOR, s);
end;
end;
with grapesPlayer^ do begin
{ number of popped tomatoes }
Str(score:3, s);
DrawStringf(GRAPES_X+67, TEXT_Y, GRAPES_TEXT_COLOR, s);
x := GRAPES_X+67-28;
{ 'stabbed' debuff icon and time left }
if stabbedDebuffTime > 0 then begin
BlitSpritef(x, STATUS_Y+4, sprites[TOMATO_THUMBTACK_TILE]);
value := stabbedDebuffTime div 1000;
Str(value:3, s);
DrawStringf(x, TEXT_Y, DEBUFF_TEXT_COLOR, s);
dec(x, 28);
end;
{ 'splashed' debuff icon and time left }
if splashedDebuffTime > 0 then begin
BlitSpritef(x, STATUS_Y+4, sprites[SPLASH_TOMATO_TILE_START]);
value := splashedDebuffTime div 1000;
Str(value:3, s);
DrawStringf(x, TEXT_Y, DEBUFF_TEXT_COLOR, s);
end;
end;
UseFont(nil);
end;
procedure DrawMatchStatus;
var
totalSeconds, minutes, seconds, seconds10 : word;
s : string[2];
begin
BlitSpritef(GENERAL_X+8, STATUS_Y+4, sprites[TIMER_SPRITE]);
UseFont(nil);
PrintAt(GENERAL_X+8+16+6, STATUS_Y+8);
totalSeconds := matchTime div 1000;
minutes := totalSeconds div 60;
seconds := totalSeconds mod 60;
seconds10 := (matchTime mod 1000) div 100;
Str(minutes:2, s);
PrintString(s, 15);
PrintString(':', 15);
if seconds < 10 then PrintString('0', 15);
PrintWord(seconds, 15);
PrintString('.', 15);
PrintWord(seconds10, 15);
end;
procedure DrawBackdrop;
begin
if isMapDirty then DrawMap;
if isStatusBackdropDirty then DrawGameStatusBackdrop;
CopyLayer(SCREEN_MAP_LAYER);
end;
procedure DrawUIFrame(x1, y1, width, height : integer;
const frameBitmaps : UIFrameBitmaps);
var
i, n, x, y : integer;
middleTilesX, middleTilesY : integer;
begin
{ TODO: this drawing routine will not look so great with dimensions
that are not some multiple of 8 (both width and height) ... }
{ smallest reasonable dimensions that could really work given
the tiles we're currently using for these ... }
if width < 24 then width := 24;
if height < 24 then height := 24;
middleTilesX := (width - (2*8)) div 8;
if middleTilesX < 0 then middleTilesX := 0;
middleTilesY := (height - (2*8)) div 8;
if middleTilesY < 0 then middleTilesY := 0;
{ middle }
for y := 0 to middleTilesY-1 do begin
for x := 0 to middleTilesX-1 do begin
Blitf(x1+8+(x*8), y1+8+(y*8), frameBitmaps[4]);
end;
end;
{ top and bottom border }
for i := 0 to middleTilesX-2 do begin
Blitf(x1+16+(i*8), y1, frameBitmaps[1]);
Blitf(x1+16+(i*8), y1+height-8, frameBitmaps[7]);
end;
{ left and right borders }
for i := 0 to middleTilesY-2 do begin
Blitf(x1, y1+16+(i*8), frameBitmaps[3]);
Blitf(x1+width-8, y1+16+(i*8), frameBitmaps[5]);
end;
{ top-left corner }
BlitSpritef(x1, y1, frameBitmaps[0]);
{ bottom-left corner }
BlitSpritef(x1, y1+height-16, frameBitmaps[6]);
{ top-right corner }
BlitSpritef(x1+width-16, y1, frameBitmaps[2]);
{ bottom-right corner }
BlitSpritef(x1+width-16, y1+height-16, frameBitmaps[8]);
end;
{ ----------------------------------------------------------------------- }
procedure FadeOut;
begin
FadeRangeToColor(0, 255, 0, 0, 0, 4);
end;
procedure FadeIn;
begin
FadeRangeToPalette(0, 255, @pal, 4);
end;
procedure FadeOutAndIn(delay : word);
var
elapsed : word;
begin
FadeRangeToColor(0, 255, 0, 0, 0, 4);
if delay > 0 then begin
elapsed := 0;
MarkTimer;
while elapsed < delay do begin
inc(elapsed, MarkTimer);
end;
end;
FadeRangeToPalette(0, 255, @pal, 4);
end;
procedure BlackOutPalette;
begin
FadeRangeToColor(0, 255, 0, 0, 0, 255);
end;
{ ----------------------------------------------------------------------- }
procedure BlitSpriteScaled(x, y: integer; xs, ys: word; const bmp: PBitmap);
var
width, height : word;
xStep, yStep : fixed;
xIndex, yIndex : fixed;
srcOffset, destOffset : word;
src, dest : PByteArray;
dx, dy : integer;
pixel : byte;
begin
{ TODO: clipping support }
{ TODO: re-write the render loop in assembly }
width := bmp^.Width;
height := bmp^.Height;
xStep := FixDiv(IntToFix(width), IntToFix(xs));
yStep := FixDiv(IntToFix(height), IntToFix(ys));
dest := GetBoundLayerPointerAt(x, y);
destOffset := 0;
src := ptr(Seg(bmp^.Pixels), Ofs(bmp^.Pixels));
srcOffset := 0;
yIndex := 0;
for dy := 0 to (ys-1) do begin
xIndex := 0;
for dx := 0 to (xs-1) do begin
pixel := src^[srcOffset + FixToInt(xIndex)];
if pixel > 0 then
dest^[destOffset + dx] := pixel;
inc(xIndex, xStep);
end;
inc(yIndex, yStep);
inc(destOffset, SCREEN_WIDTH);
srcOffset := width * FixToInt(yIndex);
end;
end;
end.

BIN
EDGES.MAP Normal file
View file

Binary file not shown.

1121
ENTITIES.PAS Normal file
View file

File diff suppressed because it is too large Load diff

BIN
FRUITPOP.EXE Normal file
View file

Binary file not shown.

119
FRUITPOP.PAS Normal file
View file

@ -0,0 +1,119 @@
{$A+,B-,E+,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
program FruitPopper;
uses GDGfx, GDKeybrd, GDTimer, GDEvents, FixedP, Math, MathFP, Toolbox,
Assets, Entities, Maps, Draw, Shared,
MainMenu, LevelSel, FruitSel, Match, Results, Help;
procedure FatalExit(message : string);
begin
CloseEvents;
CloseTimer;
CloseKeyboard;
CloseGraphics;
WriteLn('Fatal error. Exiting.');
if length(message) > 0 then
WriteLn('Cause: ', message);
Halt(1);
end;
procedure LoadEverything;
var
s : string[32];
begin
UseLayer(SCREEN_LAYER);
s := 'Loading 1/4 ...';
Cls(0);
DrawString(100, 96, 15, s);
if LoadFont('dp.fnt', @fnt) <> FontOk then
FatalExit('Failed loading font dp.fnt');
s := 'Loading 2/4 ...';
Cls(0);
DrawString(100, 96, 15, s);
if LoadFont('chunky.fnt', @chunkyFnt) <> FontOk then
FatalExit('Failed loading font chunky.fnt');
s := 'Loading 3/4 ...';
Cls(0);
DrawString(100, 96, 15, s);
if (not LoadTilesAndSprites('tiles.lbm')) then
FatalExit('Failed loading graphics tiles.lbm');
s := 'Loading 4/4 ...';
Cls(0);
DrawString(100, 96, 15, s);
if (not LoadImages('images.lbm')) then
FatalExit('Failed loading images images.lbm');
FadeOut;
Cls(0);
SetPalette(@pal);
end;
procedure DoIntro;
begin
UseLayer(SCREEN_LAYER);
UseFont(@fnt);
Cls(0);
BlackOutPalette;
WaitForTime(500);
DrawString(50, 96, 15, '... a GDR 4x4x4 Challenge Entry ...');
FadeIn;
WaitForTime(2000);
FadeOut;
WaitForTime(500);
Cls(0);
DrawString(50, 96, 15, '... created despite much slacking ...');
FadeIn;
WaitForTime(2000);
FadeOut;
WaitForTime(500);
Cls(0);
end;
begin
Randomize;
InitGraphics(2);
InitKeyboard;
InitTimer(TIMER_FREQ);
InitTrigTablesFP;
LoadEverything;
DoIntro;
currentGameState := StateMainMenu;
while currentGameState <> StateQuit do begin
case currentGameState of
StateMainMenu: DoMainMenu;
StateLevelSelect: DoLevelSelect;
StateFruitSelect: DoFruitSelect;
StateHelp: DoHelp;
StateMatch: begin
StartMatch;
MainLoop;
end;
StateResults: DoResults;
end;
end;
CloseEvents;
CloseTimer;
CloseKeyboard;
CloseGraphics;
end.

127
FRUITSEL.PAS Normal file
View file

@ -0,0 +1,127 @@
{$A+,B-,E+,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit FruitSel;
interface
procedure DoFruitSelect;
implementation
uses GDGfx, GDKeybrd, GDTimer, GDEvents, Assets, Draw, Entities, Shared;
var
randomSelection : integer;
procedure DrawFruitSelect;
var
uiFrame : ^UIFrameBitmaps;
playerTile, fruitTile : word;
begin
Cls(0);
BlitSpritef(29, 10, titleChooseFruit);
UseFont(@fnt);
if randomSelection = -1 then
DrawString(62, 60, 15, 'Choosing by random selection ...')
else
DrawString(92, 60, 15, 'Fruit has been chosen!');
if randomSelection = -1 then begin
DrawUIFrame(60, 90, 64, 64, uiGeneralFrame);
DrawString(68, 98, 15, 'Player 1');
BlitSpritef(72, 122, sprites[PLAYER_NEUTRAL_TILE]);
DrawUIFrame(196, 90, 64, 64, uiGeneralFrame);
DrawString(204, 98, 15, 'Player 2');
BlitSpritef(208, 122, sprites[PLAYER_NEUTRAL_TILE]);
end else begin
if player1Selection = Tomato then begin
uiFrame := @uiTomatoFrame;
playerTile := PLAYER_TOMATO_TILE_START;
fruitTile := FRUIT_TOMATO_TILE_START;
end else begin
uiFrame := @uiGrapesFrame;
playerTile := PLAYER_GRAPES_TILE_START;
fruitTile := FRUIT_GRAPES_TILE_START;
end;
DrawUIFrame(60, 90, 64, 64, uiFrame^);
DrawString(68, 98, 15, 'Player 1');
BlitSpritef(72, 122, sprites[playerTile]);
BlitSpritef(72+16+8, 122, sprites[fruitTile]);
if player2Selection = Tomato then begin
uiFrame := @uiTomatoFrame;
playerTile := PLAYER_TOMATO_TILE_START;
fruitTile := FRUIT_TOMATO_TILE_START;
end else begin
uiFrame := @uiGrapesFrame;
playerTile := PLAYER_GRAPES_TILE_START;
fruitTile := FRUIT_GRAPES_TILE_START;
end;
DrawUIFrame(196, 90, 64, 64, uiFrame^);
DrawString(204, 98, 15, 'Player 2');
BlitSpritef(208, 122, sprites[playerTile]);
BlitSpritef(208+16+8, 122, sprites[fruitTile]);
end;
WaitForVsync;
Flip(BACKBUFFER_LAYER);
end;
procedure DoFruitSelect;
var
quit : boolean;
aborted : boolean;
event : PInputEvent;
begin
UseLayer(BACKBUFFER_LAYER);
randomSelection := -1;
DrawFruitSelect;
FadeIn;
InitEvents;
quit := false;
aborted := false;
while not quit do begin
while not IsEventsEmpty do begin
event := PollEvents;
if IsKeyReleasedEvent(event, KEY_ESC) then begin
quit := true;
aborted := true;
end;
if IsKeyReleasedEvent(event, KEY_ENTER) then begin
if randomSelection = -1 then begin
randomSelection := random(2);
if randomSelection = 0 then begin
player1Selection := Tomato;
player2Selection := Grapes;
end else begin
player1Selection := Grapes;
player2Selection := Tomato;
end;
end else
quit := true;
end;
end;
DrawFruitSelect;
end;
CloseEvents;
FadeOut;
if (aborted) or (randomSelection = -1) then
currentGameState := StateMainMenu
else
currentGameState := StateMatch;
end;
end.

193
GDLIB/FIXEDP.PAS Normal file
View file

@ -0,0 +1,193 @@
{ Fixed-point math type definition, constants and functions.
Gered King, 2019-2020 }
{$A+,B-,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit FixedP;
interface
const
FP_INT_SHIFT = 16;
FP_FLOAT_SHIFT = 65536.0;
FP_DIV_ERROR = $7fffffff;
FP_1 = trunc(1 * FP_FLOAT_SHIFT);
FP_2 = trunc(2 * FP_FLOAT_SHIFT);
FP_3 = trunc(3 * FP_FLOAT_SHIFT);
FP_4 = trunc(4 * FP_FLOAT_SHIFT);
FP_5 = trunc(5 * FP_FLOAT_SHIFT);
FP_6 = trunc(6 * FP_FLOAT_SHIFT);
FP_7 = trunc(7 * FP_FLOAT_SHIFT);
FP_8 = trunc(8 * FP_FLOAT_SHIFT);
FP_9 = trunc(9 * FP_FLOAT_SHIFT);
FP_10 = trunc(10 * FP_FLOAT_SHIFT);
FP_16 = trunc(16 * FP_FLOAT_SHIFT);
FP_32 = trunc(32 * FP_FLOAT_SHIFT);
FP_64 = trunc(64 * FP_FLOAT_SHIFT);
FP_128 = trunc(128 * FP_FLOAT_SHIFT);
FP_256 = trunc(256 * FP_FLOAT_SHIFT);
FP_0_1 = trunc(0.1 * FP_FLOAT_SHIFT);
FP_0_2 = trunc(0.2 * FP_FLOAT_SHIFT);
FP_0_3 = trunc(0.3 * FP_FLOAT_SHIFT);
FP_0_4 = trunc(0.4 * FP_FLOAT_SHIFT);
FP_0_5 = trunc(0.5 * FP_FLOAT_SHIFT);
FP_0_6 = trunc(0.6 * FP_FLOAT_SHIFT);
FP_0_7 = trunc(0.7 * FP_FLOAT_SHIFT);
FP_0_8 = trunc(0.8 * FP_FLOAT_SHIFT);
FP_0_9 = trunc(0.9 * FP_FLOAT_SHIFT);
FP_0_25 = trunc(0.25 * FP_FLOAT_SHIFT);
FP_0_75 = trunc(0.75 * FP_FLOAT_SHIFT);
FP_1_OVER_3 = trunc((1 / 3) * FP_FLOAT_SHIFT);
FP_2_OVER_3 = trunc((2 / 3) * FP_FLOAT_SHIFT);
type
Fixed = LongInt;
{ turbo pascal's "inline" used here solely for functions that we want to be
inlined for best performance. in c/c++, these would've been written
as macros, but turbo pascal unfortunately lacks macro support. so we
are using "inline" as a poor way to get a sort of function inlining... }
function IntToFix(x : integer) : fixed;
inline(
$58/ { pop ax }
$8B/$D0/ { mov dx, ax }
$33/$C0 { xor ax, ax }
);
function FixToInt(x : fixed) : integer;
inline(
$66/$58/ { pop eax }
$66/$C1/$E8/FP_INT_SHIFT { shr eax, FP_INT_SHIFT }
);
function FloatToFix(x : single) : fixed;
function FixToFloat(x : fixed) : single;
function FixMul(a, b : fixed) : fixed;
inline(
$66/$5B/ { pop ebx }
$66/$58/ { pop eax }
$66/$F7/$EB/ { imul ebx }
$66/$0F/$AC/$D0/FP_INT_SHIFT/ { shrd eax, edx, FP_INT_SHIFT }
$66/$C1/$C0/FP_INT_SHIFT/ { rol eax, FP_INT_SHIFT }
$8B/$D0/ { mov dx, ax }
$66/$C1/$C0/FP_INT_SHIFT { rol eax, FP_INT_SHIFT }
);
function FixDiv(a, b : fixed) : fixed;
inline(
$66/$5B/ { pop ebx }
$66/$58/ { pop eax }
$66/$33/$C9/ { xor ecx, ecx }
$66/$0B/$C0/ { or eax, eax }
$79/$05/ { jns checkDivisorSign }
$66/$F7/$D8/ { neg eax }
$66/$41/ { inc ecx }
{ checkDivisorSign: }
$66/$0B/$DB/ { or ebx, ebx }
$79/$05/ { jns divide }
$66/$F7/$DB/ { neg ebx }
$66/$41/ { inc ecx }
{ divide: }
$66/$33/$D2/ { xor edx, edx }
$66/$0F/$A4/$C2/FP_INT_SHIFT/ { shld edx, eax, FP_INT_SHIFT }
$66/$C1/$E0/FP_INT_SHIFT/ { shl eax, FP_INT_SHIFT }
$66/$3B/$D3/ { cmp edx, ebx }
$73/$08/ { jae error }
$66/$F7/$F3/ { div ebx }
$66/$0B/$C0/ { or eax, eax }
$79/$08/ { jns restoreSignBit }
{ error: }
$66/$B8/$FF/$FF/$FF/$7F/ { mov eax, FP_DIV_ERROR }
$EB/$09/ { jmp done }
{ restoreSignBit: }
$66/$83/$F9/$01/ { cmp ecx, 1 }
$75/$03/ { jne done }
$66/$F7/$D8/ { neg eax }
{ done: }
$66/$C1/$C0/FP_INT_SHIFT/ { rol eax, FP_INT_SHIFT }
$8B/$D0/ { mov dx, ax }
$66/$C1/$C0/FP_INT_SHIFT { rol eax, FP_INT_SHIFT }
);
function FixDivFast(a, b : fixed) : fixed;
inline(
$66/$5B/ { pop ebx }
$66/$58/ { pop eax }
$66/$99/ { cdq }
$66/$0F/$A4/$C2/FP_INT_SHIFT/ { shld edx, eax, FP_INT_SHIFT }
$66/$C1/$E0/FP_INT_SHIFT/ { shl eax, FP_INT_SHIFT }
$66/$F7/$FB/ { idiv ebx }
$66/$C1/$C0/FP_INT_SHIFT/ { rol eax, FP_INT_SHIFT }
$8B/$D0/ { mov dx, ax }
$66/$C1/$C0/FP_INT_SHIFT { rol eax, FP_INT_SHIFT }
);
function FixSqr(x : fixed) : fixed;
inline(
$66/$58/ { pop eax }
$66/$F7/$E8/ { imul eax }
$66/$0F/$AC/$D0/FP_INT_SHIFT/ { shrd eax, edx, FP_INT_SHIFT }
$66/$C1/$C0/FP_INT_SHIFT/ { rol eax, FP_INT_SHIFT }
$8B/$D0/ { mov dx, ax }
$66/$C1/$C0/FP_INT_SHIFT { rol eax, FP_INT_SHIFT }
);
function FixSqrt(x : fixed) : fixed;
implementation
function FloatToFix(x : single) : fixed;
begin
FloatToFix := trunc(x * FP_FLOAT_SHIFT);
end;
function FixToFloat(x : fixed) : single;
begin
FixToFloat := x / FP_FLOAT_SHIFT;
end;
function FixSqrt(x : fixed) : fixed;
assembler;
asm
db $66; mov bx, x.word { mov ebx, x }
db $66,$b9,$00,$00,$00,$40 { mov ecx, $40000000 }
db $66; xor ax, ax { xor eax, eax }
@@1:
db $66; mov dx, ax { mov edx, eax }
db $66; add dx, cx { add edx, ecx }
db $66; cmp bx, dx { cmp ebx, edx }
jl @@2
db $66; sub bx, dx { sub ebx, edx }
db $66; mov ax, dx { mov eax, edx }
db $66; add ax, cx { add eax, ecx }
@@2:
db $66; shl bx, 1 { shl ebx, 1 }
db $66; shr cx, 1 { shr ecx, 1 }
db $66; cmp cx, 40h { cmp ecx, $40 }
jg @@1
db $66; shr ax, 8 { shr eax, 8 }
db $66; rol ax, FP_INT_SHIFT { rol eax, FP_INT_SHIFT }
mov dx, ax
db $66; rol ax, FP_INT_SHIFT { rol eax, FP_INT_SHIFT }
end;
begin
if Test8086 < 2 then begin
writeln('The FIXEDP unit requires a 386 cpu or higher!');
halt;
end;
end.

392
GDLIB/GDCLIP.PAS Normal file
View file

@ -0,0 +1,392 @@
{ GDlib Coordinate/Region/Screen Clipping Utilities
Gered King, 2018 }
{$A+,B-,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit GDClip;
interface
function IsPointInScreen(x, y: integer) : boolean;
function IsPointInClipRegion(x, y: integer) : boolean;
function IsRegionInScreen(x1, y1, x2, y2: integer) : boolean;
function IsRegionInClipRegion(x1, y1, x2, y2: integer) : boolean;
function ClampToScreen(var x1, y1, x2, y2: integer) : boolean;
function ClampToClipRegion(var x1, y1, x2, y2: integer) : boolean;
function ClipToScreen(var x, y, width, height: integer) : boolean;
function ClipToClipRegion(var x, y, width, height: integer) : boolean;
function ClipBlitToScreen(var srcX, srcY, srcWidth, srcHeight, destX, destY: integer) : boolean;
function ClipBlitToClipRegion(var srcX, srcY, srcWidth, srcHeight, destX, destY: integer) : boolean;
implementation
uses GDGfx;
function IsPointInScreen(x, y: integer) : boolean;
{ returns true if the given point is within the screen boundaries }
begin
IsPointInScreen := ((x < SCREEN_LEFT)
or (y < SCREEN_TOP)
or (x > SCREEN_RIGHT)
or (y > SCREEN_BOTTOM));
end;
function IsPointInClipRegion(x, y: integer) : boolean;
{ returns true if the given point is within the current clipping region }
begin
IsPointInClipRegion := ((x < ClipRegionLeft)
or (y < ClipRegionTop)
or (x > ClipRegionRight)
or (y > ClipRegionBottom));
end;
function IsRegionInScreen(x1, y1, x2, y2: integer) : boolean;
{ returns true if the given region is partially or completely within the
screen boundaries }
begin
IsRegionInScreen := false;
if (y1 < SCREEN_TOP) and (y2 < SCREEN_TOP) then
exit;
if (y1 > SCREEN_BOTTOM) and (y2 > SCREEN_BOTTOM) then
exit;
if (x1 < SCREEN_LEFT) and (x2 < SCREEN_LEFT) then
exit;
if (x1 > SCREEN_RIGHT) and (x2 > SCREEN_RIGHT) then
exit;
IsRegionInScreen := true;
end;
function IsRegionInClipRegion(x1, y1, x2, y2: integer) : boolean;
{ returns true if the given region is partially or completely within the
current clipping region }
begin
IsRegionInClipRegion := false;
if (y1 < ClipRegionTop) and (y2 < ClipRegionTop) then
exit;
if (y1 > ClipRegionBottom) and (y2 > ClipRegionBottom) then
exit;
if (x1 < ClipRegionLeft) and (x2 < ClipRegionLeft) then
exit;
if (x1 > ClipRegionRight) and (x2 > ClipRegionRight) then
exit;
IsRegionInClipRegion := true;
end;
function ClampToScreen(var x1, y1, x2, y2: integer) : boolean;
{ if the given region is visible on screen (either partially or completely)
the coordinates are checked individually against each edge of the screen
and adjusted if need-be to keep them within bounds. if the region is not
visible at all, then nothing is changed and false is returned. }
begin
ClampToScreen := false;
if (not IsRegionInScreen(x1, y1, x2, y2)) then
exit;
{ we now know the given region is at least partially visible }
ClampToScreen := true;
if (y1 < SCREEN_TOP) then
y1 := SCREEN_TOP;
if (y1 > SCREEN_BOTTOM) then
y1 := SCREEN_BOTTOM;
if (y2 < SCREEN_TOP) then
y2 := SCREEN_TOP;
if (y2 > SCREEN_BOTTOM) then
y2 := SCREEN_BOTTOM;
if (x1 < SCREEN_LEFT) then
x1 := SCREEN_LEFT;
if (x1 > SCREEN_RIGHT) then
x1 := SCREEN_RIGHT;
if (x2 < SCREEN_LEFT) then
x2 := SCREEN_LEFT;
if (x2 > SCREEN_RIGHT) then
x2 := SCREEN_RIGHT;
end;
function ClampToClipRegion(var x1, y1, x2, y2: integer) : boolean;
{ if the given region is within the current clipping region (either
partially or completely) the coordinates are checked individually
against each edge of the clipping region and adjusted if need-be to keep
them within bounds. if the region is not visible at all, then nothing is
changed and false is returned. }
begin
ClampToClipRegion := false;
if (not IsRegionInClipRegion(x1, y1, x2, y2)) then
exit;
{ we now know the given region is at least partially visible }
ClampToClipRegion := true;
if (y1 < ClipRegionTop) then
y1 := ClipRegionTop;
if (y1 > ClipRegionBottom) then
y1 := ClipRegionBottom;
if (y2 < ClipRegionTop) then
y2 := ClipRegionTop;
if (y2 > ClipRegionBottom) then
y2 := ClipRegionBottom;
if (x1 < ClipRegionLeft) then
x1 := ClipRegionLeft;
if (x1 > ClipRegionRight) then
x1 := ClipRegionRight;
if (x2 < ClipRegionLeft) then
x2 := ClipRegionLeft;
if (x2 > ClipRegionRight) then
x2 := ClipRegionRight;
end;
function ClipToScreen(var x, y, width, height: integer) : boolean;
{ clips a region to the screen by adjusting the top-left x,y coordinate
and/or the width/height of the region as appropriate. returns false if a
"completely out of bounds" scenario was encountered. returns true if the
region was completely in bounds (no clipping/clamping needed) or if the
region was clipped to the screen and is still partially in bounds. }
var
right, bottom, offset : integer;
begin
ClipToScreen := false;
right := x + width - 1;
bottom := y + height - 1;
{ off the left edge? }
if x < SCREEN_LEFT then begin
{ completely off the left edge? }
if right < SCREEN_LEFT then
exit;
offset := SCREEN_LEFT - x;
inc(x, offset);
dec(width, offset);
end;
{ off the right edge? }
if x > (SCREEN_WIDTH - width) then begin
{ completely off the right edge? }
if x > SCREEN_RIGHT then
exit;
offset := x + width - SCREEN_WIDTH;
dec(width, offset);
end;
{ off the top edge? }
if y < SCREEN_TOP then begin
{ completely off the top edge? }
if bottom < SCREEN_TOP then
exit;
offset := SCREEN_TOP - y;
inc(y, offset);
dec(height, offset);
end;
{ off the bottom edge? }
if y > (SCREEN_HEIGHT - height) then begin
{ completely off the bottom edge? }
if y > SCREEN_BOTTOM then
exit;
offset := y + height - SCREEN_HEIGHT;
dec(height, offset);
end;
ClipToScreen := true;
end;
function ClipToClipRegion(var x, y, width, height: integer) : boolean;
{ clips a region to the current clipping region by adjusting the top-left
x,y coordinate and/or the width/height of the region as appropriate.
returns false if a "completely out of bounds" scenario was encountered.
returns true if the region was completely in bounds (no clipping/clamping
needed) or if the region was clipped to the clipping region and is still
partially in bounds. }
var
right, bottom, offset : integer;
begin
ClipToClipRegion := false;
right := x + width - 1;
bottom := y + height - 1;
{ off the left edge? }
if x < ClipRegionLeft then begin
{ completely off the left edge? }
if right < ClipRegionLeft then
exit;
offset := ClipRegionLeft - x;
inc(x, offset);
dec(width, offset);
end;
{ off the right edge? }
if (x - ClipRegionLeft) > (ClipRegionWidth - width) then begin
{ completely off the right edge? }
if x > ClipRegionRight then
exit;
offset := (x - ClipRegionLeft) + (width - ClipRegionWidth);
dec(width, offset);
end;
{ off the top edge? }
if y < ClipRegionTop then begin
{ completely off the top edge? }
if bottom < ClipRegionTop then
exit;
offset := ClipRegionTop - y;
inc(y, offset);
dec(height, offset);
end;
{ off the bottom edge? }
if (y - ClipRegionTop) > (ClipRegionHeight - height) then begin
{ completely off the bottom edge? }
if y > ClipRegionBottom then
exit;
offset := (y - ClipRegionTop) + (height - ClipRegionHeight);
dec(height, offset);
end;
ClipToClipRegion := true;
end;
function ClipBlitToScreen(var srcX, srcY: integer;
var srcWidth, srcHeight: integer;
var destX, destY: integer) : boolean;
{ clips a source bitmap blit region to the screen by adjusting the source
blit region and the destination x,y coordinate as appropriate.
returns false if a "completely out of bounds" scenario was encountered.
returns true if the region was either completely in bounds (no
clipping/clamping needed), or if the region was clipped to the screen
and is still partially in bounds. }
var
right, bottom, offset : integer;
begin
ClipBlitToScreen := false;
right := srcX + srcWidth - 1;
bottom := srcY + srcHeight - 1;
{ off the left edge? }
if destX < SCREEN_LEFT then begin
{ completely off the left edge? }
if (destX + srcWidth - 1) < SCREEN_LEFT then
exit;
offset := srcX - destX;
destX := SCREEN_LEFT;
inc(srcX, offset);
dec(srcWidth, offset);
end;
{ off the right edge? }
if destX > (SCREEN_WIDTH - srcWidth) then begin
{ completely off the right edge? }
if destX > SCREEN_RIGHT then
exit;
offset := destX + srcWidth - SCREEN_WIDTH;
dec(srcWidth, offset);
end;
{ off the top edge? }
if destY < SCREEN_TOP then begin
{ completely off the top edge? }
if (destY + srcHeight - 1) < SCREEN_TOP then
exit;
offset := srcY - destY;
destY := SCREEN_TOP;
inc(srcY, offset);
dec(srcHeight, offset);
end;
{ off the bottom edge? }
if destY > (SCREEN_HEIGHT - srcHeight) then begin
{ completely off the bottom edge? }
if destY > SCREEN_BOTTOM then
exit;
offset := destY + srcHeight - SCREEN_HEIGHT;
dec(srcHeight, offset);
end;
ClipBlitToScreen := true;
end;
function ClipBlitToClipRegion(var srcX, srcY: integer;
var srcWidth, srcHeight: integer;
var destX, destY: integer) : boolean;
{ clips a source bitmap blit region to the current clipping region by
adjusting the source blit region and the destination x,y coordinate as
appropriate.
returns false if a "completely out of bounds" scenario was encountered.
returns true if the region was either completely in bounds (no
clipping/clamping needed), or if the region was clipped to the clipping
region and is still partially in bounds. }
var
right, bottom, offset : integer;
begin
ClipBlitToClipRegion := false;
right := srcX + srcWidth - 1;
bottom := srcY + srcHeight - 1;
{ off the left edge? }
if destX < ClipRegionLeft then begin
{ completely off the left edge? }
if (destX + srcWidth - 1) < ClipRegionLeft then
exit;
offset := srcX - destX;
destX := ClipRegionLeft;
inc(srcX, offset);
dec(srcWidth, offset);
end;
{ off the right edge? }
if destX > (ClipRegionWidth - srcWidth) then begin
{ completely off the right edge? }
if destX > ClipRegionRight then
exit;
offset := destX + srcWidth - ClipRegionWidth;
dec(srcWidth, offset);
end;
{ off the top edge? }
if destY < ClipRegionTop then begin
{ completely off the top edge? }
if (destY + srcHeight - 1) < ClipRegionTop then
exit;
offset := srcY - destY;
destY := ClipRegionTop;
inc(srcY, offset);
dec(srcHeight, offset);
end;
{ off the bottom edge? }
if destY > (ClipRegionHeight - srcHeight) then begin
{ completely off the bottom edge? }
if destY > ClipRegionBottom then
exit;
offset := destY + srcHeight - ClipRegionHeight;
dec(srcHeight, offset);
end;
ClipBlitToClipRegion := true;
end;
end.

229
GDLIB/GDEVENTS.PAS Normal file
View file

@ -0,0 +1,229 @@
{ GDlib Input device events
Gered King, 2018 }
{$A+,B-,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit GDEvents;
interface
uses GDKeybrd, GDMouse;
const
EVENT_TYPE_KEYBOARD = 1;
EVENT_TYPE_MOUSE_MOTION = 2;
EVENT_TYPE_MOUSE_BUTTON = 3;
EVENT_ACTION_PRESSED = 1;
EVENT_ACTION_RELEASED = 2;
EVENT_ACTION_HELD = 3;
type
EventType = byte;
EventAction = byte;
InputEvent = record
case Event: EventType of
EVENT_TYPE_KEYBOARD: (
KB_Key : Key;
KB_Action : EventAction;
KB_Modifier : word;
);
EVENT_TYPE_MOUSE_MOTION: (
MM_X : integer;
MM_Y : integer;
MM_DeltaX : integer;
MM_DeltaY : integer;
MM_Buttons : MouseButton;
);
EVENT_TYPE_MOUSE_BUTTON: (
MB_X : integer;
MB_Y : integer;
MB_Button : MouseButton;
MB_Action : EventAction;
);
end;
PInputEvent = ^InputEvent;
function InitEvents : boolean;
function CloseEvents : boolean;
function IsEventsInitialized : boolean;
function IsEventsEmpty : boolean;
function PollEvents : PInputEvent;
function PeekEvents : PInputEvent;
procedure ClearEvents;
function PushEvent : PInputEvent;
function IsKeyPressedEvent(event : PInputEvent; k : Key) : boolean;
function IsKeyReleasedEvent(event : PInputEvent; k : Key) : boolean;
function IsKeyHeldEvent(event : PInputEvent; k : Key) : boolean;
implementation
uses Toolbox;
const
EVENT_BUFFER_SIZE = 16;
_eventsInitialized : boolean = false;
_bufferStart : integer = 0;
_bufferEnd : integer = 0;
var
_buffer : array[0..(EVENT_BUFFER_SIZE-1)] of InputEvent;
function InitEvents : boolean;
{ initializes the events system, returning true if successful }
begin
if IsEventsInitialized then begin
InitEvents := false;
exit;
end;
ClearEvents;
_eventsInitialized := true;
InitEvents := true;
end;
function CloseEvents : boolean;
{ closes the events system, returning true if successful. }
begin
if not IsEventsInitialized then begin
CloseEvents := true;
exit;
end;
_eventsInitialized := false;
ClearEvents;
CloseEvents := true;
end;
function IsEventsInitialized : boolean;
{ returns true if the events system has been initialized }
begin
IsEventsInitialized := _eventsInitialized;
end;
function IsEventsEmpty : boolean;
{ returns true if there are no events to be processed currently }
begin
IsEventsEmpty := (_bufferStart = _bufferEnd);
end;
function PollEvents : PInputEvent;
{ returns the next input event in the buffer, or nil if there was none.
calling this function moves the input event buffer head to the next event }
begin
if IsEventsEmpty then begin
PollEvents := nil;
exit;
end;
asm cli end;
{ return a pointer to the event at the buffer queue head currently }
PollEvents := @_buffer[_bufferStart];
{ move the buffer queue head to the following event }
inc(_bufferStart);
if _bufferStart >= EVENT_BUFFER_SIZE then
_bufferStart := 0;
asm sti end;
end;
function PeekEvents : PInputEvent;
{ returns the next input event in the buffer, or nil if there was none.
calling this function does not modify the input event buffer in any way
(subsequent calls will return the same event, and/or PollEvents can be
used immediately after to return the same event) }
begin
if IsEventsEmpty then begin
PeekEvents := nil;
exit;
end;
{ return a pointer to the event at the buffer queue head currently }
PeekEvents := @_buffer[_bufferStart];
end;
procedure ClearEvents;
{ clears the event buffer of all events }
begin
asm cli end;
MemFill(@_buffer, 0, SizeOf(_buffer));
_bufferStart := 0;
_bufferEnd := 0;
asm sti end;
end;
function PushEvent : PInputEvent;
{ returns a pointer to the last event on the buffer queue. it is up to the
caller to fill that event structure with the information about the event to
be "pushed" onto the queue. the buffer end pointer is incremented each
time this is called (so it won't return the same pointer for subsequent
calls). this function was mainly intended to be used by GDlib keyboard and
mouse handlers. }
begin
{ return pointer to the last event in the buffer queue (which ensures
FIFO queue behaviour when adding new events) }
PushEvent := @_buffer[_bufferEnd];
{ advance the end pointer }
inc(_bufferEnd);
if _bufferEnd >= EVENT_BUFFER_SIZE then
_bufferEnd := 0;
{ is the events buffer full? (if the end meets up to the start, it is) }
if _bufferEnd = _bufferStart then begin
{ move the start up. this ensures the start always points to the oldest
event in the buffer }
inc(_bufferStart);
if _bufferStart >= EVENT_BUFFER_SIZE then
_bufferStart := 0;
end;
end;
function IsKeyPressedEvent(event : PInputEvent; k : Key) : boolean;
{ returns true if this event is a 'key pressed' event for the given key }
begin
if event = nil then
IsKeyPressedEvent := false
else
with event^ do begin
IsKeyPressedEvent := (Event = EVENT_TYPE_KEYBOARD)
and (KB_Action = EVENT_ACTION_PRESSED)
and (KB_Key = k);
end;
end;
function IsKeyReleasedEvent(event : PInputEvent; k : Key) : boolean;
{ returns true if this event is a 'key released' event for the given key }
begin
if event = nil then
IsKeyReleasedEvent := false
else
with event^ do begin
IsKeyReleasedEvent := (Event = EVENT_TYPE_KEYBOARD)
and (KB_Action = EVENT_ACTION_RELEASED)
and (KB_Key = k);
end;
end;
function IsKeyHeldEvent(event : PInputEvent; k : Key) : boolean;
{ returns true if this event is a 'key held' event for the given key }
begin
if event = nil then
IsKeyHeldEvent := false
else
with event^ do begin
IsKeyHeldEvent := (Event = EVENT_TYPE_KEYBOARD)
and (KB_Action = EVENT_ACTION_HELD)
and (KB_Key = k);
end;
end;
end.

2140
GDLIB/GDGFX.PAS Normal file
View file

File diff suppressed because it is too large Load diff

709
GDLIB/GDIFF.PAS Normal file
View file

@ -0,0 +1,709 @@
{ GDlib IFF (LBM, BBM) file load/save support.
Gered King, 2019 }
{$A+,B-,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit GDIFF;
interface
uses GDGfx;
const IFF_DEFAULT = 0;
const IFF_UNCOMPRESSED = 1;
const IFF_INTERLEAVED = 2;
type
IFFResult = (IFFNotFound, IFFIOError, IFFBadFile, IFFOk);
function LoadIFFTo(const filename: string; pal: PPalette; dest: pointer; destPitch: word) : IFFResult;
function LoadIFFToBitmap(const filename: string; pal: PPalette; bmp: PBitmap) : IFFResult;
function LoadIFF(const filename: string; pal: PPalette) : IFFResult;
function SaveIFFFrom(const filename: string; pal: PPalette; src: pointer; srcWidth, srcHeight: word; format: byte) : IFFResult;
function SaveIFFFromBitmap(const filename: string; pal: PPalette; const bmp: PBitmap; format: byte) : IFFResult;
function SaveIFF(const filename: string; pal: PPalette; format: byte) : IFFResult;
implementation
uses Toolbox;
const FORM_ID = (ord('F')) or (ord('O') shl 8) or (ord('R') shl 16) or (ord('M') shl 24);
const ILBM_ID = (ord('I')) or (ord('L') shl 8) or (ord('B') shl 16) or (ord('M') shl 24);
const PBM_ID = (ord('P')) or (ord('B') shl 8) or (ord('M') shl 16) or (ord(' ') shl 24);
const BMHD_ID = (ord('B')) or (ord('M') shl 8) or (ord('H') shl 16) or (ord('D') shl 24);
const CMAP_ID = (ord('C')) or (ord('M') shl 8) or (ord('A') shl 16) or (ord('P') shl 24);
const BODY_ID = (ord('B')) or (ord('O') shl 8) or (ord('D') shl 16) or (ord('Y') shl 24);
type
IFFID = record
case Integer of
0: (id: longint);
1: (ch: array[0..3] of char);
end;
FormChunkHeader = record
ChunkID : IFFID;
Size : longint;
TypeID : IFFID;
end;
SubChunkHeader = record
ChunkID : IFFID;
Size : longint;
end;
BMHDChunk = record
Width : word;
Height : word;
Left : word;
Top : word;
Bitplanes : byte;
Masking : byte;
Compress : byte;
Padding : byte;
Transparency : word;
XAspectRatio : byte;
YAspectRatio : byte;
PageWidth : word;
PageHeight : word;
end;
procedure MergeBitplane(plane: integer;
src, dest: pointer;
rowSize: integer);
{ takes planar pixel data (for the specified plane only) from the source
pointer and merges into into existing "chunky" pixel data in the
destination pointer }
var
data, bitMask : byte;
srcArray, destArray : PByteArray;
x, i : integer;
begin
bitMask := (1 shl plane);
srcArray := PByteArray(src);
destArray := PByteArray(dest);
for x := 0 to (rowSize-1) do begin
data := srcArray^[x];
if (data and 128) > 0 then begin
i := x * 8;
destArray^[i] := destArray^[i] or bitMask;
end;
if (data and 64) > 0 then begin
i := x * 8 + 1;
destArray^[i] := destArray^[i] or bitMask;
end;
if (data and 32) > 0 then begin
i := x * 8 + 2;
destArray^[i] := destArray^[i] or bitMask;
end;
if (data and 16) > 0 then begin
i := x * 8 + 3;
destArray^[i] := destArray^[i] or bitMask;
end;
if (data and 8) > 0 then begin
i := x * 8 + 4;
destArray^[i] := destArray^[i] or bitMask;
end;
if (data and 4) > 0 then begin
i := x * 8 + 5;
destArray^[i] := destArray^[i] or bitMask;
end;
if (data and 2) > 0 then begin
i := x * 8 + 6;
destArray^[i] := destArray^[i] or bitMask;
end;
if (data and 1) > 0 then begin
i := x * 8 + 7;
destArray^[i] := destArray^[i] or bitMask;
end;
end;
end;
procedure ExtractBitplane(plane: integer;
src, dest: pointer;
rowSize: integer);
{ takes "chunky" pixel data from the source pointer, and extracts planar
pixel data from it, from the specified plane only, storing it at the
destination pointer }
var
data, bitMask : byte;
srcArray, destArray : PByteArray;
x, i : integer;
begin
bitMask := (1 shl plane);
srcArray := PByteArray(src);
destArray := PByteArray(dest);
i := 0;
for x := 0 to (rowSize-1) do begin
data := 0;
if (srcArray^[i] and bitMask) <> 0 then
data := (data or 128);
if (srcArray^[i+1] and bitMask) <> 0 then
data := (data or 64);
if (srcArray^[i+2] and bitMask) <> 0 then
data := (data or 32);
if (srcArray^[i+3] and bitMask) <> 0 then
data := (data or 16);
if (srcArray^[i+4] and bitMask) <> 0 then
data := (data or 8);
if (srcArray^[i+5] and bitMask) <> 0 then
data := (data or 4);
if (srcArray^[i+6] and bitMask) <> 0 then
data := (data or 2);
if (srcArray^[i+7] and bitMask) <> 0 then
data := (data or 1);
inc(i, 8);
destArray^[x] := data;
end;
end;
function LoadBODYPlanar(var f: file;
const bmhd: BMHDChunk;
dest: pointer;
destPitch: word) : boolean;
{ loads an interleaved (planar) ILBM-format BODY chunk. automatically
handles compressed or uncompressed formats. }
var
p : ^byte;
rowBytes : word;
i, y : integer;
plane : integer;
buffer : array[0..(((SCREEN_WIDTH + 15) shr 4) shl 1)-1] of byte;
label ioError;
begin
p := dest;
rowBytes := ((bmhd.Width + 15) shr 4) shl 1;
for y := 0 to (bmhd.Height-1) do begin
{ planar data is stored for each bitplane in sequence for the scanline.
that is, ALL of bitplane1, followed by ALL of bitplane2, etc, NOT
alternating after each pixel. if compression is enabled, it does NOT
cross bitplane boundaries. each bitplane is compressed individually.
bitplanes also do NOT cross the scanline boundary. basically, each
scanline of pixel data, and within that, each of the bitplanes of
pixel data found in each scanline can all be treated as they are all
their own self-contained bit of data as far as this loading process
is concerned (well, except that we merge all of the scanline's
bitplanes together at the end of each line) }
{ read all the bitplane rows per scanline }
for plane := 0 to (bmhd.Bitplanes-1) do begin
if bmhd.Compress = 1 then begin
{ decompress packed line for this bitplane only }
if (not UnpackBytes(f, @buffer, rowBytes)) then
goto ioError;
{ or, if not compressed }
end else begin
{ TODO: check this. maybe rowBytes is wrong. i don't think DP2 or
GRAFX2 ever output uncompressed interleaved files anyway. }
{ just read all this bitplane's line data in as-is }
BlockRead(f, buffer[0], rowBytes);
if IOResult <> 0 then goto ioError;
end;
{ merge this bitplane data into the final destination. after all of
the bitplanes have been loaded and merged in this way for this
scanline, the destination pointer will contain VGA-friendly
"chunky pixel"-format pixel data. }
MergeBitplane(plane, @buffer, p, rowBytes);
end;
inc(p, destPitch);
end;
LoadBODYPlanar := true;
exit;
ioError:
LoadBODYPlanar := false;
end;
function LoadBODYChunky(var f: file;
const bmhd: BMHDChunk;
dest: pointer;
destPitch: word) : boolean;
{ loads a PBM-format BODY chunk. reads it in compressed or uncompressed
format depending on the BMHD chunk provided }
var
p : ^byte;
data : byte;
n, x, y : integer;
count : integer;
rawBuffer : array[0..SCREEN_RIGHT] of byte;
label ioError;
begin
p := dest;
for y := 0 to (bmhd.Height-1) do begin
if bmhd.Compress = 1 then begin
{ for compression-enabled, read row of pixels using PackBits }
if (not UnpackBytes(f, p, bmhd.Width)) then
goto ioError;
inc(p, bmhd.Width + (destPitch - bmhd.Width));
end else begin
{ for uncompressed, read row of pixels literally }
x := 0;
while x < bmhd.Width do begin
{ continously load buffer-size (or less) pixel chunks from this
scanline and copy to destination as-is }
count := bmhd.Width - x;
if count > sizeof(rawBuffer) then
count := sizeof(rawBuffer);
BlockRead(f, rawBuffer, count);
if IOResult <> 0 then goto ioError;
MemCopy(p, @rawBuffer, count);
inc(p, count);
inc(x, count);
end;
inc(p, (destPitch - bmhd.Width));
end;
end;
LoadBODYChunky := true;
exit;
ioError:
LoadBODYChunky := false;
end;
function LoadIFFTo(const filename: string;
pal: PPalette;
dest: pointer;
destPitch: word) : IFFResult;
{ loads an IFF file, storing the loaded pixel data at the pointer given.
both compressed and uncompressed files using either planar/interleaved
(ILBM) or chunky (PBM) pixel formats are supported. if a palette is
provided, the palette data from the IFF file will also be loaded.
returns IFFOk if successful. }
var
f : file;
form : FormChunkHeader;
header : SubChunkHeader;
bmhd : BMHDChunk;
i, n : integer;
chunkDataPos : longint;
result, chunky : boolean;
label ioError;
begin
Assign(f, filename);
Reset(f, 1);
if IOResult <> 0 then begin
Close(f);
n := IOResult; { clear i/o error flag }
LoadIFFTo := IFFNotFound;
exit;
end;
{ read "FORM" chunk header }
BlockRead(f, form, SizeOf(FormChunkHeader));
if IOResult <> 0 then goto ioError;
form.Size := ByteFlipDWord(form.Size);
{ only supporting "ILBM" and "PBM" types }
if (form.ChunkID.id <> FORM_ID)
or ((form.TypeID.id <> ILBM_ID)
and (form.TypeID.id <> PBM_ID)) then begin
Close(f);
LoadIFFTo := IFFBadFile;
exit;
end;
chunky := (form.TypeID.id = PBM_ID);
{ chunks can apparently appear in any order, so loop until we've read
everything that we need.
the one exception (maybe??) is that "BODY" chunks should normally occur
before the only other chunks we care about. }
while (not eof(f)) do begin
{ read next subchunk header }
BlockRead(f, header, SizeOf(SubChunkHeader));
if IOResult <> 0 then goto ioError;
header.Size := ByteFlipDWord(header.Size);
if (header.Size and 1) = 1 then
inc(header.Size); { account for padding byte }
chunkDataPos := FilePos(f);
{ bitmap header chunk }
if header.ChunkID.id = BMHD_ID then begin
BlockRead(f, bmhd, SizeOf(BMHDChunk));
if IOResult <> 0 then goto ioError;
bmhd.Width := ByteFlipWord(bmhd.Width);
bmhd.Height := ByteFlipWord(bmhd.Height);
bmhd.Left := ByteFlipWord(bmhd.Left);
bmhd.Top := ByteFlipWord(bmhd.Top);
bmhd.Transparency := ByteFlipWord(bmhd.Transparency);
bmhd.PageWidth := ByteFlipWord(bmhd.PageWidth);
bmhd.PageHeight := ByteFlipWord(bmhd.PageHeight);
{ only supporting 8-bit without masking }
if (bmhd.Bitplanes <> 8)
or (bmhd.Masking = 1) then begin
Close(f);
LoadIFFTo := IFFBadFile;
exit;
end;
{ color map (aka palette) chunk }
end else if header.ChunkID.id = CMAP_ID then begin
if pal <> nil then begin
{ we're only supporting 256 color palettes }
if header.Size <> 768 then begin
Close(f);
LoadIFFTo := IFFBadFile;
exit;
end;
BlockRead(f, pal^, SizeOf(Palette));
if IOResult <> 0 then goto ioError;
{ convert from 0-255 RGB to VGA RGB format (0-63) }
for i := 0 to 255 do begin
pal^[i, 0] := pal^[i, 0] shr 2;
pal^[i, 1] := pal^[i, 1] shr 2;
pal^[i, 2] := pal^[i, 2] shr 2;
end;
end;
{ body chunk, where all the magic happens }
end else if header.ChunkID.id = BODY_ID then begin
if not chunky then
result := LoadBODYPlanar(f, bmhd, dest, destPitch)
else
result := LoadBODYChunky(f, bmhd, dest, destPitch);
if not result then goto ioError;
end;
{ move to start of next chunk }
Seek(f, chunkDataPos + header.Size);
end;
Close(f);
n := IOResult; { clear i/o error flag (just in case) }
LoadIFFTo := IFFOk;
exit;
ioError:
Close(f);
n := IOResult; { clear i/o error flag }
LoadIFFTo := IFFIOError;
end;
function LoadIFFToBitmap(const filename: string;
pal: PPalette;
bmp: PBitmap) : IFFResult;
{ loads an IFF file onto the given bitmap. both compressed and uncompressed
files using either planar/interleaved (ILBM) or chunky (PBM) pixel formats
are supported. the destination bitmap should be pre-allocated to a size
sufficient to hold the IFF file being loaded. if a palette is provided,
the palette data from the IFF file will also be loaded. returns IFFOk if
successful. }
var
dest : pointer;
begin
dest := @bmp^.Pixels;
LoadIFFToBitmap := LoadIFFTo(filename, pal, dest, bmp^.Width);
end;
function LoadIFF(const filename: string;
pal: PPalette) : IFFResult;
{ loads an IFF file onto the currently bound layer. both compressed and
uncompressed files using either planar/interleaved (ILBM) or chunky (PBM)
pixel formats are supported. the IFF file being loaded should not contain
an image larger then 320x200. if a palette is provided, the palette data
from the IFF file will also be loaded. returns IFFOk if successful. }
var
dest : pointer;
begin
dest := ptr(GetBoundLayerSegment, GetBoundLayerOffset);
LoadIFF := LoadIFFTo(filename, pal, dest, SCREEN_WIDTH);
end;
function WriteBODYPlanar(var f: file;
const bmhd: BMHDChunk;
src: pointer;
srcPitch: word) : boolean;
{ writes a compressed interleaved (planar) ILBM-format BODY chunk }
var
p : ^byte;
width, height : integer;
y, plane : integer;
rowBytes : word;
buffer : array[0..(((SCREEN_WIDTH + 15) shr 4) shl 1)-1] of byte;
label ioError;
begin
p := src;
width := ByteFlipWord(bmhd.Width);
height := ByteFlipWord(bmhd.Height);
rowBytes := ((width + 15) shr 4) shl 1;
for y := 0 to (height-1) do begin
for plane := 0 to (bmhd.Bitplanes-1) do begin
ExtractBitplane(plane, p, @buffer, rowBytes);
if bmhd.Compress = 1 then begin
{ for compression-enabled, write this plane's pixels using PackBits }
if (not PackBytes(@buffer, f, rowBytes)) then
goto ioError;
end else begin
{ TODO: check this. maybe rowBytes is wrong. i don't think DP2 or
GRAFX2 ever output uncompressed interleaved files anyway. }
{ for uncompressed, write this plane's pixels literally }
MemCopy(@buffer, p, rowBytes);
BlockWrite(f, buffer, rowBytes);
if IOResult <> 0 then goto ioError;
end;
end;
inc(p, width + (srcPitch - width));
end;
WriteBODYPlanar := true;
exit;
ioError:
WriteBODYPlanar := false;
end;
function WriteBODYChunky(var f: file;
const bmhd: BMHDChunk;
src: pointer;
srcPitch: word) : boolean;
{ writes a PBM-format BODY chunk. writes it in compressed or uncompressed
format depending on the BMHD chunk provided }
var
p : ^byte;
y, width, height : integer;
buffer : array[0..SCREEN_RIGHT] of byte;
label ioError;
begin
p := src;
width := ByteFlipWord(bmhd.Width);
height := ByteFlipWord(bmhd.Height);
for y := 0 to (height-1) do begin
if bmhd.Compress = 1 then begin
{ for compression-enabled, write row of pixels using PackBits }
if (not PackBytes(p, f, width)) then
goto ioError;
end else begin
{ for uncompressed, write out the row of pixels literally }
MemCopy(@buffer, p, width);
BlockWrite(f, buffer, width);
if IOResult <> 0 then goto ioError;
end;
inc(p, width + (srcPitch - width));
end;
WriteBODYChunky := true;
exit;
ioError:
WriteBODYChunky := false;
end;
function SaveIFFFrom(const filename: string;
pal: PPalette;
src: pointer;
srcWidth, srcHeight: word;
format: byte) : IFFResult;
{ saves the pixel data located at the given pointer (with the given
dimensions) to an IFF file. if a palette is provided, that palette is saved
to the file, otherwise the current VGA palette is saved instead. returns
IFFOk if successful. }
var
f : file;
form : FormChunkHeader;
header : SubChunkHeader;
bmhd : BMHDChunk;
i, n : integer;
b : byte;
fileSizePos : longint;
bodySizePos : longint;
eofPos : longint;
sizeBuffer : longint;
rgb : array[0..2] of Color;
result, compress, chunky : boolean;
label ioError;
begin
if format = IFF_DEFAULT then begin
chunky := true;
compress := true;
end else begin
chunky := (format and IFF_INTERLEAVED) = 0;
compress := (format and IFF_UNCOMPRESSED) = 0;
end;
Assign(f, filename);
Rewrite(f, 1);
if IOResult <> 0 then goto ioError;
{ write IFF "FORM" chunk header }
form.ChunkID.id := FORM_ID;
form.Size := 0; { will fill this in at the end }
if chunky then
form.TypeID.id := PBM_ID
else
form.TypeID.id := ILBM_ID;
{ this is the position we need to come back to at the very end, and write
the final file size to }
fileSizePos := 4;
BlockWrite(f, form, SizeOf(FormChunkHeader));
if IOResult <> 0 then goto ioError;
{ write "BMHD" chunk }
header.ChunkID.id := BMHD_ID;
header.Size := ByteFlipDWord(SizeOf(BMHDChunk));
BlockWrite(f, header, SizeOf(SubChunkHeader));
if IOResult <> 0 then goto ioError;
bmhd.Width := ByteFlipWord(srcWidth);
bmhd.Height := ByteFlipWord(srcHeight);
bmhd.Left := 0;
bmhd.Top := 0;
bmhd.Bitplanes := 8;
bmhd.Masking := 0;
if compress then bmhd.Compress := 1 else bmhd.Compress := 0;
bmhd.Padding := 0;
bmhd.Transparency := 0;
bmhd.XAspectRatio := 5; { this is what DP2 writes for 320x200. meh. }
bmhd.YAspectRatio := 6;
bmhd.PageWidth := ByteFlipWord(320);
bmhd.PageHeight := ByteFlipWord(200);
BlockWrite(f, bmhd, SizeOf(BMHDChunk));
if IOResult <> 0 then goto ioError;
{ write "CMAP" chunk }
header.ChunkID.id := CMAP_ID;
header.Size := ByteFlipDWord(768);
BlockWrite(f, header, SizeOf(SubChunkHeader));
if IOResult <> 0 then goto ioError;
{ write out provided palette, or the current VGA palette }
if pal <> nil then begin
for i := 0 to 255 do begin
rgb[0] := pal^[i, 0] shl 2;
rgb[1] := pal^[i, 1] shl 2;
rgb[2] := pal^[i, 2] shl 2;
BlockWrite(f, rgb, 3);
if IOResult <> 0 then goto ioError;
end;
end else begin
for i := 0 to 255 do begin
GetColor(i, rgb[0], rgb[1], rgb[2]);
rgb[0] := rgb[0] shl 2;
rgb[1] := rgb[1] shl 2;
rgb[2] := rgb[2] shl 2;
BlockWrite(f, rgb, 3);
if IOResult <> 0 then goto ioError;
end;
end;
{ write "BODY" chunk }
header.ChunkID.id := BODY_ID;
header.Size := 0; { will come back and write this at the end }
{ save the position we need to come back to, to write the "BODY" chunk
size at }
bodySizePos := FilePos(f) + SizeOf(IFFID);
BlockWrite(f, header, SizeOf(SubChunkHeader));
if IOResult <> 0 then goto ioError;
if chunky then
result := WriteBODYChunky(f, bmhd, src, SCREEN_WIDTH)
else
result := WriteBODYPlanar(f, bmhd, src, SCREEN_WIDTH);
if not result then goto ioError;
eofPos := FilePos(f);
{ write a chunk body padding byte if needed }
if (eofPos and 1) = 1 then begin
b := 0;
BlockWrite(f, b, 1);
if IOResult <> 0 then goto ioError;
inc(eofPos);
end;
{ "BODY" chunk header size }
Seek(f, bodySizePos);
sizeBuffer := ByteFlipDWord((eofPos - bodySizePos - 4));
BlockWrite(f, sizeBuffer, 4);
if IOResult <> 0 then goto ioError;
{ IFF "FORM" chunk header size }
Seek(f, fileSizePos);
sizeBuffer := ByteFlipDWord(eofPos - 8);
BlockWrite(f, sizeBuffer, 4);
if IOResult <> 0 then goto ioError;
Close(f);
n := IOResult; { clear i/o error flag (just in case) }
SaveIFFFrom := IFFOk;
exit;
ioError:
Close(f);
n := IOResult; { clear i/o error flag }
SaveIFFFrom := IFFIOError;
end;
function SaveIFFFromBitmap(const filename: string;
pal: PPalette;
const bmp: PBitmap;
format: byte) : IFFResult;
{ saves the specified bitmap to an IFF file. if a palette is provided, that
palette is saved to the file, otherwise the current VGA palette is saved
instead. returns IFFOk if successful. }
var
src : pointer;
begin
src := @bmp^.Pixels;
SaveIFFFromBitmap := SaveIFFFrom(filename,
pal,
src,
bmp^.Width,
bmp^.Height,
format);
end;
function SaveIFF(const filename: string;
pal: PPalette;
format: byte) : IFFResult;
{ saves the currently bound layer to an IFF file. if a palette is provided,
that palette is saved to the file, otherwise the current VGA palette is
saved instead. returns IFFOk if successful. }
var
src : pointer;
begin
src := ptr(GetBoundLayerSegment, GetBoundLayerOffset);
SaveIFF := SaveIFFFrom(filename,
pal,
src,
SCREEN_WIDTH,
SCREEN_HEIGHT,
format);
end;
end.

417
GDLIB/GDKEYBRD.PAS Normal file
View file

@ -0,0 +1,417 @@
{ GDlib Keyboard Handler
Gered King, 2018 }
{$A+,B-,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit GDKeybrd;
interface
const
KEY_ESC = $01;
KEY_1 = $02;
KEY_2 = $03;
KEY_3 = $04;
KEY_4 = $05;
KEY_5 = $06;
KEY_6 = $07;
KEY_7 = $08;
KEY_8 = $09;
KEY_9 = $0a;
KEY_0 = $0b;
KEY_MINUS = $0c;
KEY_EQUALS = $0d;
KEY_BACKSPACE = $0e;
KEY_TAB = $0f;
KEY_Q = $10;
KEY_W = $11;
KEY_E = $12;
KEY_R = $13;
KEY_T = $14;
KEY_Y = $15;
KEY_U = $16;
KEY_I = $17;
KEY_O = $18;
KEY_P = $19;
KEY_LEFT_BRACKET = $1a;
KEY_RIGHT_BRACKET = $1b;
KEY_ENTER = $1c;
KEY_CTRL = $1d;
KEY_A = $1e;
KEY_S = $1f;
KEY_D = $20;
KEY_F = $21;
KEY_G = $22;
KEY_H = $23;
KEY_J = $24;
KEY_K = $25;
KEY_L = $26;
KEY_SEMICOLON = $27;
KEY_APOSTROPHE = $28;
KEY_TILDE = $29;
KEY_LEFT_SHIFT = $2a;
KEY_BACKSLASH = $2b;
KEY_Z = $2c;
KEY_X = $2d;
KEY_C = $2e;
KEY_V = $2f;
KEY_B = $30;
KEY_N = $31;
KEY_M = $32;
KEY_COMMA = $33;
KEY_PERIOD = $34;
KEY_FORWARDSLASH = $35;
KEY_RIGHT_SHIFT = $36;
KEY_ASTERISK = $37;
KEY_ALT = $38;
KEY_SPACE = $39;
KEY_CAPS_LOCK = $3a;
KEY_F1 = $3b;
KEY_F2 = $3c;
KEY_F3 = $3d;
KEY_F4 = $3e;
KEY_F5 = $3f;
KEY_F6 = $40;
KEY_F7 = $41;
KEY_F8 = $42;
KEY_F9 = $43;
KEY_F10 = $44;
KEY_NUM_LOCK = $45;
KEY_SCROLL_LOCK = $46;
KEY_HOME = $47;
KEY_UP = $48;
KEY_PAGE_UP = $49;
KEY_NUM_MINUS = $4a;
KEY_LEFT = $4b;
KEY_NUM_5 = $4c;
KEY_RIGHT = $4d;
KEY_NUM_PLUS = $4e;
KEY_END = $4f;
KEY_DOWN = $50;
KEY_PAGE_DOWN = $51;
KEY_INSERT = $52;
KEY_DELETE = $53;
KEY_F11 = $57;
KEY_F12 = $58;
KB_FLAGS_SCROLL_LOCK = $10;
KB_FLAGS_NUM_LOCK = $20;
KB_FLAGS_CAPS_LOCK = $40;
KB_MOD_EXTENDED = $01;
KB_MOD_SHIFT = $02;
KB_MOD_NUM_LOCK = $04;
KB_MOD_CAPS_LOCK = $08;
type
Key = byte;
var
Keys : array[0..127] of bytebool;
KeybrdFlags : word absolute $0040:$0017;
KeyFlags : word;
KeyMod : word;
function InitKeyboard : boolean;
function CloseKeyboard : boolean;
function IsKeyboardInitialized : boolean;
function WaitForAnyKey : Key;
procedure WaitForNoKeys;
procedure WaitForKey(k: Key);
procedure WaitUntilKeyNotPressed(k: Key);
implementation
uses Dos, GDEvents, Toolbox;
const
PIC_CTRL_PORT = $20;
KBRD_DATA_PORT = $60;
KBRD_CTRL_PORT = $61;
KBRD_STATUS_PORT = $64;
KBRD_CMD_SET_LED = $ed;
KBRD_LED_SCROLL_LOCK = $01;
KBRD_LED_NUM_LOCK = $02;
KBRD_LED_CAPS_LOCK = $04;
KEY_EXTENDED = $e0;
_KeyboardInstalled : boolean = false;
var
_keyLastScan : Key;
_keyScan : Key;
_oldKeybrdInterrupt : pointer;
_keyboardEvent : PInputEvent;
procedure ResetKeyState;
begin
_keyLastScan := 0;
_keyScan := 0;
KeyFlags := 0;
KeyMod := 0;
MemFill(@Keys, 0, 128);
end;
procedure WaitKeybrdDataRead;
{ waits until the keyboard status port indicates the data port can be
read from once again }
begin
while (port[KBRD_STATUS_PORT] and 1) = 0 do begin
end;
end;
procedure WaitKeybrdDataWrite;
{ waits until the keyboard status port indicates the data port can be
written to once again }
begin
while (port[KBRD_STATUS_PORT] and 2) <> 0 do begin
end;
end;
function SendKeybrdData(data: byte) : boolean;
{ sends data to the keyboard data port. checks for success and returns
true if the data write succeeded }
var
result: byte;
begin
WaitKeybrdDataWrite;
port[KBRD_DATA_PORT] := data;
WaitKeybrdDataRead;
result := port[KBRD_DATA_PORT];
SendKeybrdData := (result = $fa);
end;
function UpdateKeybrdLED(flags: byte) : boolean;
{ updates the keyboard indicator LEDs from the num/caps/scroll lock flags
provided. returns false if the LEDs could not be updated (if the writes
to the keyboard data port fail for any reason). }
var
data: byte;
begin
UpdateKeybrdLED := false;
if not SendKeybrdData(KBRD_CMD_SET_LED) then
exit;
data := (flags shr 4) and 7; { restrict to only the 3 led flags }
if not SendKeybrdData(data) then
exit;
UpdateKeybrdLED := true;
end;
procedure PushKeyboardEvent(key: Key; action: EventAction);
begin
if not IsEventsInitialized then
exit;
_keyboardEvent := PushEvent;
with _keyboardEvent^ do begin
Event := EVENT_TYPE_KEYBOARD;
KB_Key := key;
KB_Action := action;
KB_Modifier := KeyMod;
end;
end;
function HandlerFilterKeys : boolean;
{ returns true if the key interrupt event should not be handled (at least
as far as updating key state is concerned) }
begin
HandlerFilterKeys := false;
if (KeyMod and KB_MOD_EXTENDED) <> 0 then begin
{ extended key + leftshift comes with cursor key presses when
numlock is enabled ... }
if (_keyScan and $7f) = KEY_LEFT_SHIFT then
HandlerFilterKeys := true;
end;
end;
procedure HandlerUpdateFlagsAndLEDs;
{ maintains BIOS keyboard flags/led toggle states (caps/num/scroll lock) }
begin
case _keyScan of
KEY_CAPS_LOCK: begin
KeyFlags := KeyFlags xor KB_FLAGS_CAPS_LOCK;
UpdateKeybrdLED(KeyFlags);
KeybrdFlags := KeyFlags;
end;
KEY_NUM_LOCK: begin
KeyFlags := KeyFlags xor KB_FLAGS_NUM_LOCK;
UpdateKeybrdLED(KeyFlags);
KeybrdFlags := KeyFlags;
end;
KEY_SCROLL_LOCK: begin
KeyFlags := KeyFlags xor KB_FLAGS_SCROLL_LOCK;
UpdateKeybrdLED(KeyFlags);
KeybrdFlags := KeyFlags;
end;
end;
end;
procedure HandlerUpdateModifiers;
begin
if (KeyFlags and KB_FLAGS_NUM_LOCK) <> 0 then
KeyMod := KeyMod or KB_MOD_NUM_LOCK
else
KeyMod := KeyMod and not KB_MOD_NUM_LOCK;
if (KeyFlags and KB_FLAGS_CAPS_LOCK) <> 0 then
KeyMod := KeyMod or KB_MOD_CAPS_LOCK
else
KeyMod := KeyMod and not KB_MOD_CAPS_LOCK;
if Keys[KEY_LEFT_SHIFT] or Keys[KEY_RIGHT_SHIFT] then
KeyMod := KeyMod or KB_MOD_SHIFT
else
KeyMod := KeyMod and not KB_MOD_SHIFT;
end;
procedure KeybrdHandler;
{ custom keyboard interrupt handler. called on every keyboard event }
interrupt;
begin
{ read scan code of key that was just pressed (or released) }
_keyScan := port[KBRD_DATA_PORT];
{ handle updating key state and flags/modifiers }
if _keyScan = KEY_EXTENDED then begin
KeyMod := KeyMod or KB_MOD_EXTENDED;
end else begin
if not HandlerFilterKeys then begin
if (_keyScan and $80) <> 0 then begin
{ high bit set indicates key was released. clear high bit to get
the actual key scan code }
_keyScan := _keyScan and $7f;
Keys[_keyScan] := false;
HandlerUpdateModifiers;
PushKeyboardEvent(_keyScan, EVENT_ACTION_RELEASED);
end else begin
if Keys[_keyScan] then begin
PushKeyboardEvent(_keyScan, EVENT_ACTION_HELD);
end else begin
Keys[_keyScan] := true;
{ toggling of states only needs to be done for a key down event }
HandlerUpdateFlagsAndLEDs;
HandlerUpdateModifiers;
PushKeyboardEvent(_keyScan, EVENT_ACTION_PRESSED);
end;
end;
_keyLastScan := _keyScan;
end;
{ clear extended modifier for the following event(s) in any case }
KeyMod := KeyMod and not KB_MOD_EXTENDED;
end;
{ indicate key event was processed to the keyboard controller }
_keyScan := (port[KBRD_CTRL_PORT] or $80);
port[KBRD_CTRL_PORT] := _keyScan;
port[KBRD_CTRL_PORT] := (_keyScan and $7f);
port[PIC_CTRL_PORT] := $20;
end;
function InitKeyboard : boolean;
{ installs a custom keyboard interrupt handler. returns false if the
keyboard interrupt handler could not be installed for some reason, or if
the custom handler was already installed. }
begin
if _keyboardInstalled then begin
InitKeyboard := false;
exit;
end;
ResetKeyState;
KeyFlags := KeybrdFlags;
{ bad hacky way to maybe-sortof-possibly not get into weird states
depending on what keys are held down as this executes.
a proper fix would involve updating our key handler to handle ALL
of the bios key flag bits. }
KeyFlags := KeyFlags and not $f38f;
HandlerUpdateModifiers;
GetIntVec(9, _oldKeybrdInterrupt);
SetIntVec(9, @KeybrdHandler);
KeybrdFlags := KeyFlags;
_keyboardInstalled := true;
InitKeyboard := true;
end;
function CloseKeyboard : boolean;
{ removes a previously installed custom keyboard interrupt handler. }
begin
if not _keyboardInstalled then begin
CloseKeyboard := true;
exit;
end;
SetIntVec(9, _oldKeybrdInterrupt);
ResetKeyState;
_keyboardInstalled := false;
CloseKeyboard := true;
end;
function IsKeyboardInitialized : boolean;
{ returns true if our custom keyboard handler has been initialized }
begin
IsKeyboardInitialized := _keyboardInstalled;
end;
function WaitForAnyKey : Key;
{ waits indefinitely until any key is pressed, and returns the key scan code
of the key that was pressed. }
begin
_keyLastScan := 0;
while _keyLastScan = 0 do begin
end;
WaitForAnyKey := _keyLastScan;
end;
procedure WaitForNoKeys;
{ waits indefinitely until there are no keys pressed. }
var
i : word;
foundPressed : boolean;
begin
repeat
foundPressed := false;
for i := 0 to 127 do begin
if Keys[i] then begin
foundPressed := true;
break;
end;
end;
until (not foundPressed);
end;
procedure WaitForKey(k: Key);
{ waits indefinitely until the specified key is pressed }
begin
_keyLastScan := 0;
while _keyLastScan <> k do begin
end;
end;
procedure WaitUntilKeyNotPressed(k: Key);
{ waits indefinitely until the specified key is not pressed }
begin
while Keys[k] do begin
end;
end;
begin
MemFill(@Keys, 0, SizeOf(Keys));
end.

192
GDLIB/GDKEYCHR.PAS Normal file
View file

@ -0,0 +1,192 @@
{ GDlib Keyboard Handler - Keycode-to-Char Conversion Support
Gered King, 2020 }
{$A+,B-,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit GDKeyChr;
interface
uses GDKeybrd;
function KeyToChar(k: Key; modifiers: word) : char;
implementation
const
LookupKeyToChar : array[0..127] of char = (
#0, #0, '1', '2', '3', '4', '5', '6', { 00 - 07 }
'7', '8', '9', '0', '-', '=', #0, #9, { 08 - 0f }
'q', 'w', 'e', 'r', 't', 'y', 'u', 'i', { 10 - 17 }
'o', 'p', '[', ']', #0, #0, 'a', 's', { 18 - 1f }
'd', 'f', 'g', 'h', 'j', 'k', 'l', ';', { 20 - 27 }
'''', '`', #0, '\', 'z', 'x', 'c', 'v', { 28 - 2f }
'b', 'n', 'm', ',', '.', '/', #0, '*', { 30 - 37 }
#0, ' ', #0, #0, #0, #0, #0, #0, { 38 - 3f }
#0, #0, #0, #0, #0, #0, #0, #0, { 40 - 47 }
#0, #0, #0, #0, #0, #0, #0, #0, { 48 - 4f }
#0, #0, #0, #0, #0, #0, #0, #0, { 50 - 57 }
#0, #0, #0, #0, #0, #0, #0, #0, { 58 - 5f }
#0, #0, #0, #0, #0, #0, #0, #0, { 60 - 67 }
#0, #0, #0, #0, #0, #0, #0, #0, { 68 - 6f }
#0, #0, #0, #0, #0, #0, #0, #0, { 70 - 77 }
#0, #0, #0, #0, #0, #0, #0, #0 { 78 - 7f }
);
LookupKeyToCharShift : array[0..127] of char = (
#0, #0, '!', '@', '#', '$', '%', '^', { 00 - 07 }
'&', '*', '(', ')', '_', '+', #0, #9, { 08 - 0f }
'Q', 'W', 'E', 'R', 'T', 'Y', 'U', 'I', { 10 - 17 }
'O', 'P', '{', '}', #0, #0, 'A', 'S', { 18 - 1f }
'D', 'F', 'G', 'H', 'J', 'K', 'L', ':', { 20 - 27 }
'"', '~', #0, '|', 'Z', 'X', 'C', 'V', { 28 - 2f }
'B', 'N', 'M', '<', '>', '?', #0, '*', { 30 - 37 }
#0, ' ', #0, #0, #0, #0, #0, #0, { 38 - 3f }
#0, #0, #0, #0, #0, #0, #0, #0, { 40 - 47 }
#0, #0, #0, #0, #0, #0, #0, #0, { 48 - 4f }
#0, #0, #0, #0, #0, #0, #0, #0, { 50 - 57 }
#0, #0, #0, #0, #0, #0, #0, #0, { 58 - 5f }
#0, #0, #0, #0, #0, #0, #0, #0, { 60 - 67 }
#0, #0, #0, #0, #0, #0, #0, #0, { 68 - 6f }
#0, #0, #0, #0, #0, #0, #0, #0, { 70 - 77 }
#0, #0, #0, #0, #0, #0, #0, #0 { 78 - 7f }
);
LookupKeyToCharCaps : array[0..127] of char = (
#0, #0, '1', '2', '3', '4', '5', '6', { 00 - 07 }
'7', '8', '9', '0', '-', '=', #0, #9, { 08 - 0f }
'Q', 'W', 'E', 'R', 'T', 'Y', 'U', 'I', { 10 - 17 }
'O', 'P', '[', ']', #0, #0, 'A', 'S', { 18 - 1f }
'D', 'F', 'G', 'H', 'J', 'K', 'L', ';', { 20 - 27 }
'''', '`', #0, '\', 'Z', 'X', 'C', 'V', { 28 - 2f }
'B', 'N', 'M', ',', '.', '/', #0, '*', { 30 - 37 }
#0, ' ', #0, #0, #0, #0, #0, #0, { 38 - 3f }
#0, #0, #0, #0, #0, #0, #0, #0, { 40 - 47 }
#0, #0, #0, #0, #0, #0, #0, #0, { 48 - 4f }
#0, #0, #0, #0, #0, #0, #0, #0, { 50 - 57 }
#0, #0, #0, #0, #0, #0, #0, #0, { 58 - 5f }
#0, #0, #0, #0, #0, #0, #0, #0, { 60 - 67 }
#0, #0, #0, #0, #0, #0, #0, #0, { 68 - 6f }
#0, #0, #0, #0, #0, #0, #0, #0, { 70 - 77 }
#0, #0, #0, #0, #0, #0, #0, #0 { 78 - 7f }
);
LookupKeyToCharCapsShift : array[0..127] of char = (
#0, #0, '!', '@', '#', '$', '%', '^', { 00 - 07 }
'&', '*', '(', ')', '_', '+', #0, #9, { 08 - 0f }
'q', 'w', 'e', 'r', 't', 'y', 'u', 'i', { 10 - 17 }
'o', 'p', '{', '}', #0, #0, 'a', 's', { 18 - 1f }
'd', 'f', 'g', 'h', 'j', 'k', 'l', ':', { 20 - 27 }
'"', '~', #0, '|', 'z', 'x', 'c', 'v', { 28 - 2f }
'b', 'n', 'm', '<', '>', '?', #0, '*', { 30 - 37 }
#0, ' ', #0, #0, #0, #0, #0, #0, { 38 - 3f }
#0, #0, #0, #0, #0, #0, #0, #0, { 40 - 47 }
#0, #0, #0, #0, #0, #0, #0, #0, { 48 - 4f }
#0, #0, #0, #0, #0, #0, #0, #0, { 50 - 57 }
#0, #0, #0, #0, #0, #0, #0, #0, { 58 - 5f }
#0, #0, #0, #0, #0, #0, #0, #0, { 60 - 67 }
#0, #0, #0, #0, #0, #0, #0, #0, { 68 - 6f }
#0, #0, #0, #0, #0, #0, #0, #0, { 70 - 77 }
#0, #0, #0, #0, #0, #0, #0, #0 { 78 - 7f }
);
LookupKeyToCharNumpad : array[0..127] of char = (
#0, #0, #0, #0, #0, #0, #0, #0, { 00 - 07 }
#0, #0, #0, #0, #0, #0, #0, #0, { 08 - 0f }
#0, #0, #0, #0, #0, #0, #0, #0, { 10 - 17 }
#0, #0, #0, #0, #0, #0, #0, #0, { 18 - 1f }
#0, #0, #0, #0, #0, #0, #0, #0, { 20 - 27 }
#0, #0, #0, #0, #0, #0, #0, #0, { 28 - 2f }
#0, #0, #0, #0, #0, #0, #0, #0, { 30 - 37 }
#0, #0, #0, #0, #0, #0, #0, #0, { 38 - 3f }
#0, #0, #0, #0, #0, #0, #0, #0, { 40 - 47 }
#0, #0, '-', #0, #0, #0, '+', #0, { 48 - 4f }
#0, #0, #0, #0, #0, #0, #0, #0, { 50 - 57 }
#0, #0, #0, #0, #0, #0, #0, #0, { 58 - 5f }
#0, #0, #0, #0, #0, #0, #0, #0, { 60 - 67 }
#0, #0, #0, #0, #0, #0, #0, #0, { 68 - 6f }
#0, #0, #0, #0, #0, #0, #0, #0, { 70 - 77 }
#0, #0, #0, #0, #0, #0, #0, #0 { 78 - 7f }
);
LookupKeyToCharNumpadNumlock : array[0..127] of char = (
#0, #0, #0, #0, #0, #0, #0, #0, { 00 - 07 }
#0, #0, #0, #0, #0, #0, #0, #0, { 08 - 0f }
#0, #0, #0, #0, #0, #0, #0, #0, { 10 - 17 }
#0, #0, #0, #0, #0, #0, #0, #0, { 18 - 1f }
#0, #0, #0, #0, #0, #0, #0, #0, { 20 - 27 }
#0, #0, #0, #0, #0, #0, #0, #0, { 28 - 2f }
#0, #0, #0, #0, #0, #0, #0, #0, { 30 - 37 }
#0, #0, #0, #0, #0, #0, #0, #0, { 38 - 3f }
#0, #0, #0, #0, #0, #0, #0, '7', { 40 - 47 }
'8', '9', '-', '4', '5', '6', '+', '1', { 48 - 4f }
'2', '3', '0', '.', #0, #0, #0, #0, { 50 - 57 }
#0, #0, #0, #0, #0, #0, #0, #0, { 58 - 5f }
#0, #0, #0, #0, #0, #0, #0, #0, { 60 - 67 }
#0, #0, #0, #0, #0, #0, #0, #0, { 68 - 6f }
#0, #0, #0, #0, #0, #0, #0, #0, { 70 - 77 }
#0, #0, #0, #0, #0, #0, #0, #0 { 78 - 7f }
);
LookupKeyToCharExtended : array[0..127] of char = (
#0, #0, #0, #0, #0, #0, #0, #0, { 00 - 07 }
#0, #0, #0, #0, #0, #0, #0, #0, { 08 - 0f }
#0, #0, #0, #0, #0, #0, #0, #0, { 10 - 17 }
#0, #0, #0, #0, #0, #0, #0, #0, { 18 - 1f }
#0, #0, #0, #0, #0, #0, #0, #0, { 20 - 27 }
#0, #0, #0, #0, #0, #0, #0, #0, { 28 - 2f }
#0, #0, #0, #0, #0, '/', #0, #0, { 30 - 37 }
#0, #0, #0, #0, #0, #0, #0, #0, { 38 - 3f }
#0, #0, #0, #0, #0, #0, #0, #0, { 40 - 47 }
#0, #0, #0, #0, #0, #0, #0, #0, { 48 - 4f }
#0, #0, #0, #0, #0, #0, #0, #0, { 50 - 57 }
#0, #0, #0, #0, #0, #0, #0, #0, { 58 - 5f }
#0, #0, #0, #0, #0, #0, #0, #0, { 60 - 67 }
#0, #0, #0, #0, #0, #0, #0, #0, { 68 - 6f }
#0, #0, #0, #0, #0, #0, #0, #0, { 70 - 77 }
#0, #0, #0, #0, #0, #0, #0, #0 { 78 - 7f }
);
function KeyToChar(k: Key; modifiers: word) : char;
{ returns the equivalent character for the given key scan code and keyboard
modifiers (num/caps/scroll lock, shift status, etc.) }
begin
if (modifiers and KB_MOD_EXTENDED) <> 0 then begin
KeyToChar := LookupKeyToCharExtended[k];
end else if (k >= $47) and (k <= $53) then begin
{ handle numpad keys specially }
if (modifiers and KB_MOD_NUM_LOCK) <> 0 then begin
if (modifiers and KB_MOD_SHIFT) <> 0 then
KeyToChar := LookupKeyToCharNumpad[k]
else
KeyToChar := LookupKeyToCharNumpadNumLock[k];
end else begin
if (modifiers and KB_MOD_SHIFT) <> 0 then
KeyToChar := LookupKeyToCharNumpadNumLock[k]
else
KeyToChar := LookupKeyToCharNumpad[k];
end;
end else begin
{ everything else }
if (modifiers and KB_MOD_CAPS_LOCK) <> 0 then begin
if (modifiers and KB_MOD_SHIFT) <> 0 then
KeyToChar := LookupKeyToCharCapsShift[k]
else
KeyToChar := LookupKeyToCharCaps[k];
end else begin
if (modifiers and KB_MOD_SHIFT) <> 0 then
KeyToChar := LookupKeyToCharShift[k]
else
KeyToChar := LookupKeyToChar[k];
end;
end;
end;
end.

473
GDLIB/GDMOUSE.PAS Normal file
View file

@ -0,0 +1,473 @@
{ GDlib Mouse Handler
Gered King, 2018 }
{$A+,B-,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit GDMouse;
interface
type
MouseButton = byte;
CursorBitmap = array[0..63] of byte;
PCursorBitmap = ^CursorBitmap;
const
MOUSE_LEFT_BUTTON = $01;
MOUSE_RIGHT_BUTTON = $02;
MOUSE_MIDDLE_BUTTON = $04;
CURSOR_WIDTH = 16;
CURSOR_HEIGHT = 16;
MouseX : integer = 0;
MouseY : integer = 0;
MouseButtons : word = 0;
MouseDeltaX : integer = 0;
MouseDeltaY : integer = 0;
function InitMouse : boolean;
function CloseMouse : boolean;
function IsMouseInitialized : boolean;
function IsMousePresent : boolean;
procedure ShowMouse;
procedure HideMouse;
procedure SetMouseBounds(minX, minY, maxX, maxY: integer);
procedure SetMouseCursor(const bitmap: PCursorBitmap; hotspotX, hotspotY: integer);
procedure DrawMouseCursor;
implementation
uses GDGfx, GDClip, GDEvents, Toolbox;
const
MOUSE_FILL_COLOR = 15;
MOUSE_OUTLINE_COLOR = 0;
_hasMouse : boolean = false;
_mouseInstalled : boolean = false;
_mouseVisible : boolean = false;
_cursorHotspotX : integer = 0;
_cursorHotspotY : integer = 0;
{ copy of the default microsoft mouse driver's cursor in graphics modes }
_defaultCursorBitmap : CursorBitmap = (
$ff,$3f,$ff,$1f,$ff,$0f,$ff,$07,
$ff,$03,$ff,$01,$ff,$00,$7f,$00,
$3f,$00,$1f,$00,$ff,$01,$ff,$00,
$ff,$30,$7f,$f8,$7f,$f8,$ff,$fc,
$00,$00,$00,$40,$00,$60,$00,$70,
$00,$78,$00,$7c,$00,$7e,$00,$7f,
$80,$7f,$00,$7c,$00,$6c,$00,$46,
$00,$06,$00,$03,$00,$03,$00,$00
);
var
_currentCursorBitmap : CursorBitmap;
_mouseEvent : PInputEvent;
_mousePrevButtons : word;
procedure ResetMouseState;
begin
MouseX := 0;
MouseY := 0;
MouseButtons := 0;
_mousePrevButtons := 0;
MouseDeltaX := 0;
MouseDeltaY := 0;
end;
function InitMouseDriver : boolean;
begin
asm
mov ax, 0
int 33h
mov @Result, al { ax = 0 if it failed }
end;
{ reset our copy of the current mouse cursor bitmap at the same time }
MemCopy(@_currentCursorBitmap, @_defaultCursorBitmap, SizeOf(CursorBitmap));
_cursorHotspotX := 0;
_cursorHotspotY := 0;
end;
procedure UpdateMouseState;
assembler;
asm
mov ax, 3
int 33h
shr cx, 1
mov MouseX, cx { MouseX = cx / 2 }
mov MouseY, dx
mov ax, MouseButtons
mov _mousePrevButtons, ax { MousePrevButtons = MouseButtons }
mov MouseButtons, bx
mov MouseDeltaX, 0
mov MouseDeltaY, 0
end;
procedure PushMotionEvent;
begin
_mouseEvent := PushEvent;
with _mouseEvent^ do begin
Event := EVENT_TYPE_MOUSE_MOTION;
MM_X := MouseX;
MM_Y := MouseY;
MM_DeltaX := MouseDeltaX;
MM_DeltaY := MouseDeltaY;
MM_Buttons := MouseButtons;
end;
end;
procedure PushButtonEvent(action: EventAction; button: MouseButton);
begin
_mouseEvent := PushEvent;
with _mouseEvent^ do begin
Event := EVENT_TYPE_MOUSE_BUTTON;
MB_X := MouseX;
MB_Y := MouseY;
MB_Action := action;
MB_Button := button;
end;
end;
procedure ProcessMouseEvents;
begin
if not IsEventsInitialized then
exit;
if (MouseDeltaX <> 0) or (MouseDeltaY <> 0) then
PushMotionEvent;
if MouseButtons <> _mousePrevButtons then begin
if (MouseButtons and MOUSE_LEFT_BUTTON) <>
(_mousePrevButtons and MOUSE_LEFT_BUTTON) then begin
if (MouseButtons and MOUSE_LEFT_BUTTON) > 0 then
PushButtonEvent(EVENT_ACTION_PRESSED, MOUSE_LEFT_BUTTON)
else
PushButtonEvent(EVENT_ACTION_RELEASED, MOUSE_LEFT_BUTTON);
end;
if (MouseButtons and MOUSE_RIGHT_BUTTON) <>
(_mousePrevButtons and MOUSE_RIGHT_BUTTON) then begin
if (MouseButtons and MOUSE_RIGHT_BUTTON) > 0 then
PushButtonEvent(EVENT_ACTION_PRESSED, MOUSE_RIGHT_BUTTON)
else
PushButtonEvent(EVENT_ACTION_RELEASED, MOUSE_RIGHT_BUTTON);
end;
if (MouseButtons and MOUSE_MIDDLE_BUTTON) <>
(_mousePrevButtons and MOUSE_MIDDLE_BUTTON) then begin
if (MouseButtons and MOUSE_MIDDLE_BUTTON) > 0 then
PushButtonEvent(EVENT_ACTION_PRESSED, MOUSE_MIDDLE_BUTTON)
else
PushButtonEvent(EVENT_ACTION_RELEASED, MOUSE_MIDDLE_BUTTON);
end;
end;
end;
procedure MouseHandler;
{ our custom mouse handler.
this is written as an 'assembler' proc because the mouse driver passes it
the mouse status via registers. using a pascal 'interrupt' proc would
kind of work also, except that we would have to do a hacky return to ensure
the registers are popped correctly and that a 'retf' is used for the
return (instead of an 'iret' which is what pascal would otherwise do).
doing this with an 'assembler' proc instead just seemed cleaner to me... }
far;
assembler;
asm
{ inputs provided by mouse driver:
AX = event trigger bit
BX = button state
CX = X coordinate
DX = Y coordinate
DI = horizontal mickeys
SI = vertical mickeys }
pusha
mov ax, seg @Data { restore DS so that we can access pascal vars }
mov ds, ax
shr cx, 1 { mouse x coordinate is doubled for some reason }
mov ax, MouseButtons
mov _mousePrevButtons, ax { MousePrevButtons := MouseButtons }
mov MouseButtons, bx
mov ax, cx
sub ax, MouseX
mov MouseDeltaX, ax { MouseDeltaX := CX - MouseX }
mov ax, dx
sub ax, MouseY
mov MouseDeltaY, ax { MouseDeltaY := DX - MouseX }
mov MouseX, cx
mov MouseY, dx
call ProcessMouseEvents
popa
end;
function InitMouse : boolean;
{ initializes the mouse driver (if there is one present) and then installs
our custom mouse event handler. returns true if the mouse was set up
successfully or if there is no mouse device connected (check
IsMousePresent() to be sure). returns false if an error occured setting
up the mouse or if it was already initialized. }
begin
if _mouseInstalled then begin
InitMouse := false;
exit;
end;
ResetMouseState;
_hasMouse := InitMouseDriver;
if not _hasMouse then begin
_mouseInstalled := true;
InitMouse := true;
exit;
end;
UpdateMouseState;
asm
mov ax, 0ch
mov cx, 31
mov dx, seg MouseHandler
mov es, dx
mov dx, offset MouseHandler
int 33h
end;
_mouseVisible := false;
_mouseInstalled := true;
InitMouse := true;
end;
function CloseMouse : boolean;
{ removes a previously installed custom mouse event handler and resets the
mouse driver to it's initial state. }
begin
if not _mouseInstalled then begin
CloseMouse := true;
exit;
end;
if not _hasMouse then begin
_mouseInstalled := false;
CloseMouse := true;
exit;
end;
asm
mov ax, 0ch
mov cx, 0
int 33h
end;
ResetMouseState;
InitMouseDriver;
_mouseVisible := false;
_mouseInstalled := false;
CloseMouse := true;
end;
function IsMouseInitialized : boolean;
{ returns true if the mouse driver was initialized successfully }
begin
IsMouseInitialized := _mouseInstalled;
end;
function IsMousePresent : boolean;
{ returns true if a mouse device is currently connected to the computer }
begin
IsMousePresent := _hasMouse;
end;
procedure ShowMouse;
{ shows the mouse cursor. if the mouse cursor is currently shown, this does
nothing }
begin
if not _hasMouse then
exit;
if _mouseVisible then
exit;
asm
mov ax, 1
int 33h
end;
_mouseVisible := true;
end;
procedure HideMouse;
{ hides the mouse cursor. if the mouse cursor is not currently shown, this
does nothing }
begin
if not _hasMouse then
exit;
if not _mouseVisible then
exit;
asm
mov ax, 2
int 33h;
end;
_mouseVisible := false;
end;
procedure SetMouseBounds(minX, minY, maxX, maxY: integer);
{ sets the pixel boundaries for the mouse cursor }
begin
if not _hasMouse then
exit;
asm
mov ax, 7
mov cx, minX
mov dx, maxX
int 33h
mov ax, 8
mov cx, minY
mov dx, maxY
int 33h
end;
end;
procedure SetMouseCursor(const bitmap: PCursorBitmap;
hotspotX, hotspotY: integer);
{ changes the mouse cursor to the specified bitmap. if the bitmap is nil,
resets the cursor back to the original bitmap }
begin
{ make a copy of the bitmap, solely for DrawMouseCursor to use it.
(there is no mouse driver function for reading the current cursor
bitmap?) }
if bitmap = nil then
MemCopy(@_currentCursorBitmap, @_defaultCursorBitmap, SizeOf(CursorBitmap))
else
MemCopy(@_currentCursorBitmap, bitmap, SizeOf(CursorBitmap));
_cursorHotspotX := hotspotX;
_cursorHotspotY := hotspotY;
asm
mov ax, 9h
mov bx, hotspotX
mov cx, hotspotY
mov dx, seg _currentCursorBitmap
mov es, dx
mov dx, offset _currentCursorBitmap
int 33h
end;
end;
procedure LLBlitMouseCursor(width, height, destYinc, leftClipBits: integer;
destOffs, srcSeg, srcOffs: word);
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
call far ptr GetBoundLayerSegment
mov es, ax
mov di, destOffs
mov ds, srcSeg
mov si, srcOffs
@draw_line:
mov ax, ds:[si] { load next screen mask word }
mov bx, ds:[si+32] { load next shape mask word }
mov cx, leftClipBits
test cx, cx
jz @done_bits_clipping { trim off left bits (for clipping) if needed }
shl ax, cl
shl bx, cl
@done_bits_clipping:
mov cx, width { cx = number of pixels to draw }
{ ax = screen mask word }
{ bx = shape mask word }
@draw_pixel:
shl ax, 1
jc @skip_pixel { screen mask bit is 1? skip this pixel }
shl bx, 1
jnc @draw_cursor_outline_px
@draw_cursor_color_px: { draw inner color if shape bit is 1 }
mov es:[di], byte(MOUSE_FILL_COLOR)
jmp @end_pixel
@draw_cursor_outline_px: { or, draw outline color if shape bit is 0 }
mov es:[di], byte(MOUSE_OUTLINE_COLOR)
jmp @end_pixel
@skip_pixel:
shl bx, 1 { skipping this pixel, need to also shift the }
{ shape mask word to keep them both at the }
{ same location }
@end_pixel:
inc di { move to the next pixel }
dec cx { decrease pixel drawing counter }
jnz @draw_pixel
@end_line:
add si, 2 { move to next line }
add di, destYinc
dec dx { decrease line loop counter }
jnz @draw_line
@done:
pop ds
end;
procedure DrawMouseCursor;
{ draws the mouse cursor at it's current location. this draws it completely
independently from the mouse driver. it should only be used after a call
to HideMouse and when your application is redrawing the entire screen
every frame. otherwise, the built-in mouse driver cursor rendering is
probably the best choice. }
var
x, y: integer;
srcX, srcY, srcWidth, srcHeight: integer;
srcOffs, destOffs: word;
destYinc: integer;
begin
if not _mouseInstalled then
exit;
{ destination always at current mouse cursor position (adjusted by
hotspot X/Y, which is how the normal mouse driver does it) }
x := MouseX - _cursorHotspotX;
y := MouseY - _cursorHotspotY;
srcX := 0;
srcY := 0;
srcWidth := CURSOR_WIDTH;
srcHeight := CURSOR_HEIGHT;
if not ClipBlitToScreen(srcX, srcY, srcWidth, srcHeight, x, y) then
exit;
srcOffs := Ofs(_currentCursorBitmap[srcY * 2]);
destOffs := GetBoundLayerOffsetAt(x, y);
destYinc := SCREEN_WIDTH - srcWidth;
LLBlitMouseCursor(srcWidth, srcHeight,
destYinc, srcX,
destOffs,
Seg(_currentCursorBitmap), srcOffs);
end;
end.

356
GDLIB/GDPCX.PAS Normal file
View file

@ -0,0 +1,356 @@
{ GDlib PCX file load/save support
Gered King, 2018 }
{$A+,B-,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit GDPCX;
interface
uses GDGfx;
type
PCXResult = (PCXNotFound, PCXIOError, PCXBadFile, PCXOk);
function LoadPCXTo(const filename: string; pal: PPalette; dest: pointer; bytesPerLine: word) : PCXResult;
function LoadPCXToBitmap(const filename: string; pal: PPalette; bmp: PBitmap) : PCXResult;
function LoadPCX(const filename: string; pal: PPalette) : PCXResult;
function SavePCXFrom(const filename: string; pal: PPalette; src: pointer; srcWidth, srcHeight: word) : PCXResult;
function SavePCXFromBitmap(const filename: string; pal: PPalette; const bmp: PBitmap) : PCXResult;
function SavePCX(const filename: string; pal: PPalette) : PCXResult;
implementation
uses Toolbox;
type
PCXHeader = record
Manufacturer : byte;
Version : byte;
Encoding : byte;
Bpp : byte;
X, Y : word;
Width, Height : word;
HorizontalDpi : word;
VerticalDpi : word;
EgaPalette : array[0..47] of byte;
Reserved : byte;
NumColorPlanes : byte;
BytesPerLine : word;
PaletteType : word;
HorizontalSize : word;
VerticalSize : word;
Padding : array[0..53] of byte;
end;
function LoadPCXTo(const filename: string;
pal: PPalette;
dest: pointer;
bytesPerLine: word) : PCXResult;
{ loads a PCX file, storing the loaded pixel data at the pointer given. if
a palette is provided, the palette data from the PCX file will also be
loaded. returns PCXOk if successful. }
var
p : ^byte;
linePtrInc : word;
f : file;
header : PCXHeader;
i, count, x, y : integer;
pcxWidth : integer;
pcxHeight : integer;
data : byte;
label ioError;
begin
Assign(f, filename);
Reset(f, 1);
if IOResult <> 0 then begin
Close(f);
x := IOResult; { clear i/o error flag }
LoadPCXTo := PCXNotFound;
exit;
end;
{ read PCX header }
BlockRead(f, header, SizeOf(PCXHeader));
if IOResult <> 0 then goto ioError;
{ validate header. we only support about 256 color PCX files }
if (header.Manufacturer <> 10)
or (header.Version <> 5)
or (header.Encoding <> 1)
or (header.Bpp <> 8) then begin
Close(f);
LoadPCXTo := PCXBadFile;
exit;
end;
pcxWidth := header.Width;
pcxHeight := header.Height;
p := dest;
linePtrInc := (bytesPerLine - pcxWidth - 1);
for y := 0 to pcxHeight do begin
{ write pixels out per-scanline }
x := 0;
while x < header.BytesPerLine do begin
{ read pixel (or RLE count ...) }
BlockRead(f, data, 1);
if IOResult <> 0 then goto ioError;
if (data and $c0) = $c0 then begin
{ it was an RLE count, actual pixel is the next byte ... }
count := data and $3f;
BlockRead(f, data, 1);
if IOResult <> 0 then goto ioError;
end else begin
count := 1;
end;
{ store this pixel color the specified number of times }
while count > 0 do begin
if x <= pcxWidth then
p^ := data;
inc(p);
inc(x);
dec(count);
end;
end;
inc(p, linePtrInc);
end;
{ read palette, if needed }
if pal <> nil then begin
Seek(f, FileSize(f) - 768);
BlockRead(f, pal^, SizeOf(Palette));
if IOResult <> 0 then goto ioError;
{ convert PCX palette format to VGA RGB format }
for i := 0 to 255 do begin
pal^[i, 0] := pal^[i, 0] shr 2;
pal^[i, 1] := pal^[i, 1] shr 2;
pal^[i, 2] := pal^[i, 2] shr 2;
end;
end;
Close(f);
x := IOResult; { clear i/o error flag (just in case) }
LoadPCXTo := PCXOk;
exit;
ioError:
Close(f);
x := IOResult; { clear i/o error flag }
LoadPCXTo := PCXIOError;
end;
function LoadPCXToBitmap(const filename: string;
pal: PPalette;
bmp: PBitmap) : PCXResult;
{ loads a PCX file onto the given bitmap. the destination bitmap should be
pre-allocated to a size sufficient to hold the PCX file being loaded. if a
palette is provided, the palette data from the PCX file will also be
loaded. returns PCXOk if successful. }
var
dest : pointer;
begin
dest := @bmp^.Pixels;
LoadPCXToBitmap := LoadPCXTo(filename, pal, dest, bmp^.Width);
end;
function LoadPCX(const filename: string;
pal: PPalette) : PCXResult;
{ loads a PCX file onto the currently bound layer. the PCX file being loaded
should not contain an image larger then 320x200. if a palette is provided,
the palette data from the PCX file will also be loaded. returns PCXOk if
successful. }
var
dest : pointer;
begin
dest := ptr(GetBoundLayerSegment, GetBoundLayerOffset);
LoadPCX := LoadPCXTo(filename, pal, dest, SCREEN_WIDTH);
end;
function WritePCXData(var f: file;
const runCount: integer;
pixel: byte) : boolean;
var
data : byte;
begin
WritePCXData := true;
if (runCount > 1) or ((pixel and $c0) = $c0) then begin
data := $c0 or runCount;
BlockWrite(f, data, 1);
if IOResult <> 0 then begin
WritePCXData := false;
exit;
end;
end;
BlockWrite(f, pixel, 1);
if IOResult <> 0 then begin
WritePCXData := false;
exit;
end;
end;
function SavePCXFrom(const filename: string;
pal: PPalette;
src: pointer;
srcWidth, srcHeight: word) : PCXResult;
{ saves the pixel data located at the given pointer (with the given
dimensions) to a PCX file. if a palette is provided, that palette is saved
to the file, otherwise the current VGA palette is saved instead. returns
PCXOk if successful. }
var
p : ^byte;
linePtrInc : word;
f : file;
x, y, runCount, i : integer;
pixel, runPixel : byte;
rgb : array[0..2] of byte;
header : PCXHeader;
srcRight : word;
srcBottom : word;
label ioError;
begin
Assign(f, filename);
Rewrite(f, 1);
if IOResult <> 0 then goto ioError;
srcRight := srcWidth - 1;
srcBottom := srcHeight - 1;
MemFill(@header, 0, SizeOf(PCXHeader));
header.Manufacturer := 10;
header.Version := 5;
header.Encoding := 1;
header.Bpp := 8;
header.X := 0;
header.Y := 0;
header.Width := srcRight;
header.Height := srcBottom;
header.HorizontalDpi := 0;
header.VerticalDpi := 0;
header.NumColorPlanes := 1;
header.BytesPerLine := srcWidth;
header.PaletteType := 1;
header.HorizontalSize := 320;
header.VerticalSize := 200;
BlockWrite(f, header, SizeOf(PCXHeader));
if IOResult <> 0 then goto ioError;
{ write image data }
p := src;
i := 0;
for y := 0 to srcBottom do begin
{ write one scanline at a time. breaking runs that could have continued
across scanlines in the process, as per the pcx standard }
runCount := 0;
runPixel := 0;
for x := 0 to srcRight do begin
pixel := p^;
inc(p);
if runCount = 0 then begin
runCount := 1;
runPixel := pixel;
end else begin
if (pixel <> runPixel) or (runCount >= 63) then begin
if (not WritePCXData(f, runCount, runPixel)) then goto ioError;
runCount := 1;
runPixel := pixel;
end else begin
inc(runCount);
end;
end;
end;
{ end the scanline, writing out whatever run we might have had going }
if (not WritePCXData(f, runCount, runPixel)) then
goto ioError;
end;
pixel := 12;
BlockWrite(f, pixel, 1);
if IOResult <> 0 then goto ioError;
{ write out provided palette, or the current VGA palette }
if pal <> nil then begin
for i := 0 to 255 do begin
rgb[0] := pal^[i, 0] shl 2;
rgb[1] := pal^[i, 1] shl 2;
rgb[2] := pal^[i, 2] shl 2;
BlockWrite(f, rgb, 3);
if IOResult <> 0 then goto ioError;
end;
end else begin
for i := 0 to 255 do begin
GetColor(i, rgb[0], rgb[1], rgb[2]);
rgb[0] := rgb[0] shl 2;
rgb[1] := rgb[1] shl 2;
rgb[2] := rgb[2] shl 2;
BlockWrite(f, rgb, 3);
if IOResult <> 0 then goto ioError;
end;
end;
Close(f);
x := IOResult; { clear i/o error flag (just in case) }
SavePCXFrom := PCXOk;
exit;
ioError:
Close(f);
x := IOResult; { clear i/o error flag }
SavePCXFrom := PCXIOError;
end;
function SavePCXFromBitmap(const filename: string;
pal: PPalette;
const bmp: PBitmap) : PCXResult;
{ saves the specified bitmap to a PCX file. if a palette is provided, that
palette is saved to the file, otherwise the current VGA palette is saved
instead. returns PCXOk if successful. }
var
src : pointer;
begin
src := @bmp^.Pixels;
SavePCXFromBitmap := SavePCXFrom(filename,
pal,
src,
bmp^.Width,
bmp^.Height);
end;
function SavePCX(const filename: string;
pal: PPalette) : PCXResult;
{ saves the currently bound layer to a PCX file. if a palette is provided,
that palette is saved to the file, otherwise the current VGA palette is
saved instead. returns PCXOk if successful. }
var
src : pointer;
begin
src := ptr(GetBoundLayerSegment, GetBoundLayerOffset);
SavePCX := SavePCXFrom(filename,
pal,
src,
SCREEN_WIDTH,
SCREEN_HEIGHT);
end;
end.

198
GDLIB/GDTIMER.PAS Normal file
View file

@ -0,0 +1,198 @@
{ GDlib Higher Frequency Timer Utilities
Gered King, 2021 }
{$A+,B-,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit GDTimer;
interface
const
{ count of the number of times the timer interrupt has been raised.
this will be incremented 'freq' times per second once InitTimer
has been called. }
TimerTicks : longint = 0;
function InitTimer(freq: word) : boolean;
function CloseTimer : boolean;
function GetTimerFrequency : word;
function MarkTimer : longint;
procedure WaitForTime(delay : word);
implementation
uses Dos;
const
PIC_CTRL_PORT = $20;
CHANNEL_0_PORT = $40;
COMMAND_PORT = $43;
TIMER_FREQ_SET_COMMAND = $36; { mode 2 (rate generator),
read/write lo-byte of counter,
read/write hi-byte of counter }
TIMER_CLOCK_RATE = 1193180; { 1.19318 mhz }
ORIGINAL_TIMER_FREQ = 18.2065;
_timerInstalled : boolean = false;
_timerFreq : word = 0;
_lastMarkedAt : longint = 0;
var
_oldTimerCounter : longint;
_oldTimerTriggerAt : longint;
_oldTimerInterrupt : pointer;
procedure SetTimerFrequency(freq: word);
{ configures the PC 8253 timer to trigger interrupt 8 at the given frequency.
the value provided here should simply be just that: the number of times
per second that interrupt 8 should be triggered per second. }
var
counter0 : word;
begin
if freq = 0 then
counter0 := 0
else
counter0 := TIMER_CLOCK_RATE div freq;
{ calculate the number of timer interrupt ticks that will need to elapse
(at our new timer frequency) before our custom interrupt should call the
original timer interrupt handler to ensure it is still called at the
original 18.2hz frequency }
_oldTimerTriggerAt := round(freq / ORIGINAL_TIMER_FREQ);
port[COMMAND_PORT] := TIMER_FREQ_SET_COMMAND;
port[CHANNEL_0_PORT] := Lo(counter0);
port[CHANNEL_0_PORT] := Hi(counter0);
_timerFreq := freq;
end;
procedure TimerHandler;
{ custom timer (interrupt 8) handler.
this has been written as a 'raw' assembler procedure instead of using
a more typical pascal 'interrupt' procedure just to keep this as lean
as possible since it will potentially be called hundreds (or more)
times per second }
far;
assembler;
asm
push ds
db $66; push ax
mov ax, seg @Data { restore DS so that we can access pascal vars }
mov ds, ax
db $66; inc word ptr [TimerTicks]
{ house-keeping to ensure the original interrupt 8 handler is still
called at the rate it should be (18.2hz) }
db $66; inc word ptr [_oldTimerCounter]
{ if _oldTimerCounter < _oldTimerTriggerAt, then skip calling the
original interrupt 8 handler }
db $66; mov ax, word(_oldTimerCounter)
db $66; cmp ax, word(_oldTimerTriggerAt)
jl @done
{ otherwise (if _oldTimerCounter >= _oldTimerTriggerAt), then,
reset the counter back to zero and call the original interrupt 8
handler }
db $66; xor ax, ax
db $66; mov word(_oldTimerCounter), ax
pushf
call [_oldTimerInterrupt]
@done:
{ tell the PIC that we're done }
mov al, $20
out PIC_CTRL_PORT, al
db $66; pop ax
pop ds
iret
end;
function InitTimer(freq: word) : boolean;
{ installs a custom timer interrupt handler (interrupt 8). returns false if
the timer interrupt handler could not be installed for some reason, or if
the custom handler was already installed. }
begin
InitTimer := false;
if _timerInstalled then exit;
TimerTicks := 0;
_oldTimerCounter := 0;
_lastMarkedAt := 0;
asm cli end;
SetTimerFrequency(freq);
GetIntVec(8, _oldTimerInterrupt);
SetIntVec(8, @TimerHandler);
asm sti end;
_timerInstalled := true;
InitTimer := true;
end;
function CloseTimer : boolean;
{ removes a previously installed custom timer interrupt handler. }
begin
CloseTimer := false;
if not _timerInstalled then exit;
asm cli end;
SetTimerFrequency(0); { resets back to the normal 18.2hz }
SetIntVec(8, _oldTimerInterrupt);
asm sti end;
TimerTicks := 0;
_oldTimerCounter := 0;
_oldTimerInterrupt := nil;
_timerInstalled := false;
CloseTimer := true;
end;
function GetTimerFrequency : word;
{ returns the frequency that the installed custom timer interrupt handler
is being triggered at. if no custom timer interrupt handler is installed,
returns 0 }
begin
GetTimerFrequency := _timerFreq;
end;
function MarkTimer : longint;
{ used to calculate time differences between subsequent calls to this
function. the very first time it is called, the return value should
probably be ignored (will be the ticks since the timer subsystem was
initialized). }
var
newMarkedAt : longint;
begin
newMarkedAt := TimerTicks;
MarkTimer := newMarkedAt - _lastMarkedAt;
_lastMarkedAt := newMarkedAt;
end;
procedure WaitForTime(delay : word);
{ waits indefinitely for specified number of ticks to elapse }
var
startedAt : longint;
begin
if not _timerInstalled then exit;
startedAt := TimerTicks;
while (TimerTicks - startedAt) < delay do begin
end;
end;
begin
if Test8086 < 2 then begin
writeln('The GDTIMER unit requires a 386 cpu or higher!');
halt;
end;
end.

543
GDLIB/MATH.PAS Normal file
View file

@ -0,0 +1,543 @@
{ Math helper functions and lookup tables.
Gered King, 2019 }
{ You MUST manually call 'InitTrigTables' in your programs before using
any of these functions that use trig!! }
{$A+,B-,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit Math;
interface
const
PI = 3.141592654;
PI_OVER_180 = PI / 180.0;
DEG_TO_RAD = PI_OVER_180;
RAD_TO_DEG = 1.0 / PI_OVER_180;
DEG_TO_BIN = 1024 / 360;
BIN_TO_DEG = 1.0 / (DEG_TO_BIN);
RAD_TO_BIN = 512 / PI;
BIN_TO_RAD = 1.0 / (RAD_TO_BIN);
{ note: might want to define these manually ... ?
trunc vs round makes this fun if you ever change the binangle range.. }
BIN_ANGLE_1 = round(1 * DEG_TO_BIN);
BIN_ANGLE_45 = round(45 * DEG_TO_BIN);
BIN_ANGLE_90 = round(90 * DEG_TO_BIN);
BIN_ANGLE_135 = round(135 * DEG_TO_BIN);
BIN_ANGLE_180 = round(180 * DEG_TO_BIN);
BIN_ANGLE_225 = round(225 * DEG_TO_BIN);
BIN_ANGLE_270 = round(270 * DEG_TO_BIN);
BIN_ANGLE_315 = round(315 * DEG_TO_BIN);
BIN_ANGLE_359 = round(359 * DEG_TO_BIN);
BIN_ANGLE_360 = round(360 * DEG_TO_BIN);
BIN_ANGLE_TAN_MASK = BIN_ANGLE_180-1;
BIN_ANGLE_MASK = BIN_ANGLE_360-1;
M33_11 = 0;
M33_12 = 3;
M33_13 = 6;
M33_21 = 1;
M33_22 = 4;
M33_23 = 7;
M33_31 = 2;
M33_32 = 5;
M33_33 = 8;
type
BinAngle = integer; { binary angles, where 0-1023 = full circle }
Vec2 = record
X, Y : single;
end;
PVec2 = ^Vec2;
Mtx33 = record
m : array[0..8] of single;
end;
PMtx33 = ^Mtx33;
const
ZERO_VEC2 : Vec2 = (X: 0.0; Y: 0.0);
IDENTITY_MTX33 : Mtx33 = (m: (1.0, 0.0, 0.0,
0.0, 1.0, 0.0,
0.0, 0.0, 1.0));
var
SinTable : array[0..1023] of single;
CosTable : array[0..1023] of single;
TanTable : array[0..511] of single;
procedure InitTrigTables;
function Lerp(a, b, t: single) : single;
function InvLerp(a, b, lerped: single) : single;
function Atan(x : single) : binangle;
function Atan2(y, x : single) : binangle;
function AngleBetween(x1, y1, x2, y2: single) : binangle;
procedure AngleToDir2D(angle: binangle; var outX, outY: single);
procedure AngleToVec2D(angle: binangle; var out: Vec2);
procedure Vec2_Set(var out : Vec2; x, y : single);
procedure Vec2_Zero(var out : Vec2);
procedure Vec2_Add(var out : Vec2; const a, b : Vec2);
procedure Vec2_AddTo(var out : Vec2; const v : Vec2);
procedure Vec2_Sub(var out : Vec2; const a, b : Vec2);
procedure Vec2_SubFrom(var out : Vec2; const v : Vec2);
procedure Vec2_Scale(var out : Vec2; const a : Vec2; n : single);
function Vec2_Distance(const a, b : Vec2) : single;
function Vec2_DistanceSqr(const a, b : Vec2) : single;
function Vec2_Dot(const a, b : Vec2) : single;
function Vec2_Length(const a : Vec2) : single;
function Vec2_LengthSqr(const a : Vec2) : single;
procedure Vec2_Normalize(var out : Vec2; const a : Vec2);
procedure Vec2_NormalizeThis(var out : Vec2);
procedure Vec2_SetLength(var out : Vec2; const a : Vec2; length : single);
procedure Vec2_SetThisLength(var out : Vec2; length : single);
procedure Vec2_Lerp(var out : Vec2; const a, b : Vec2; t : single);
procedure Mtx33_Identity(var out : Mtx33);
procedure Mtx33_RotationX(var out : Mtx33; angle : binangle);
procedure Mtx33_RotationY(var out : Mtx33; angle : binangle);
procedure Mtx33_RotationZ(var out : Mtx33; angle : binangle);
procedure Mtx33_Mul(var out, a, b : Mtx33);
procedure Mtx33_Transform2D(var out : Vec2; var m : Mtx33; var v : Vec2);
procedure Mtx33_Translation2D(var out : Mtx33; x, y : single);
procedure Mtx33_Scaling2D(var out : Mtx33; x, y : single);
procedure Mtx33_Rotation2D(var out : Mtx33; angle : binangle);
implementation
function Fequ(a, b: single) : boolean;
begin
{ TODO: lol, this is maybe somewhat 'ok', but rewrite this garbage }
Fequ := (abs(a - b) <= 0.00005);
end;
procedure InitTrigTables;
{ populates the trig lookup tables with sin/cos/tan values for the entire
range of binary angles supported (0 to BIN_ANGLE_MASK). }
var
angle : binangle;
r, s, c : single;
begin
for angle := 0 to BIN_ANGLE_MASK do begin
r := angle * BIN_TO_RAD;
s := sin(r);
c := cos(r);
SinTable[angle] := s;
CosTable[angle] := c;
if angle <= BIN_ANGLE_TAN_MASK then begin
if (angle = BIN_ANGLE_90) or (angle = BIN_ANGLE_270) then
TanTable[angle] := 0
else
TanTable[angle] := (s / c);
end;
end;
end;
function Lerp(a, b, t: single) : single;
{ returns the interpolated value between the ranged defined by a and b. }
begin
Lerp := a + (b - a) * t;
end;
function InvLerp(a, b, lerped: single) : single;
{ returns the 't' value used in a call to Lerp that returned the given
'lerped' value using the range a to b (approximately, anyway). }
begin
InvLerp := (lerped - a) / (b - a);
end;
function Atan(x : single) : binangle;
{ calculates the arctangent of X. returns the result as a binary angle.
functionally equivalent to ArcTan(). }
var
a, b, c : integer;
d : single;
begin
if x >= 0 then begin
a := 0;
b := (BIN_ANGLE_90 - 1);
end else begin
a := BIN_ANGLE_90;
b := (BIN_ANGLE_180 - 1);
end;
repeat
c := (a + b) div 2;
d := x - TanTable[c];
if d > 0.0 then
a := c + 1
else if d < 0.0 then
b := c - 1;
until ((a > b) or (d = 0.0));
if x >= 0 then
Atan := c
else
Atan := -BIN_ANGLE_180 + c;
end;
function Atan2(y, x : single) : binangle;
{ calculates the arctangent of Y/X. returns the result as a binary angle.
functionally equivalent to atan2() from the C runtime library. }
var
r : single;
b : binangle;
begin
if x = 0.0 then begin
if y = 0.0 then begin
Atan2 := 0;
end else begin
if y < 0.0 then
Atan2 := -BIN_ANGLE_90
else
Atan2 := BIN_ANGLE_90;
end;
exit;
end;
r := y / x;
b := Atan(r);
if x >= 0.0 then
Atan2 := b
else if y >= 0.0 then
Atan2 := BIN_ANGLE_180 + b
else
Atan2 := b - BIN_ANGLE_180;
end;
function AngleBetween(x1, y1, x2, y2: single) : binangle;
{ calculates the binary angle between the two points }
var
deltaX, deltaY : single;
begin
deltaX := x2 - x1;
deltaY := y2 - y1;
if (Fequ(deltaX, 0.0) and Fequ(deltaY, 0.0)) then
AngleBetween := 0
else
AngleBetween := Atan2(deltaY, deltaX);
end;
procedure AngleToDir2D(angle: binangle;
var outX, outY: single);
{ for a given binary angle, calculates a normalized 2D direction vector
that points in the same direction as the angle }
begin
outX := CosTable[angle and BIN_ANGLE_MASK];
outY := SinTable[angle and BIN_ANGLE_MASK];
end;
procedure AngleToVec2D(angle: binangle;
var out: Vec2);
{ for a given binary angle, calculates a normalized Vec2 that points in the
same direction as the angle }
begin
with out do begin
X := CosTable[angle and BIN_ANGLE_MASK];
Y := SinTable[angle and BIN_ANGLE_MASK];
end;
end;
procedure Vec2_Set(var out : Vec2; x, y : single);
begin
out.X := x;
out.Y := y;
end;
procedure Vec2_Zero(var out : Vec2);
begin
with out do begin
X := 0.0;
Y := 0.0;
end;
end;
procedure Vec2_Add(var out : Vec2; const a, b : Vec2);
begin
with out do begin
X := a.X + b.X;
Y := a.Y + b.Y;
end;
end;
procedure Vec2_AddTo(var out : Vec2; const v : Vec2);
begin
with out do begin
X := X + v.X;
Y := Y + v.Y;
end;
end;
procedure Vec2_Sub(var out : Vec2; const a, b : Vec2);
begin
with out do begin
X := a.X - b.X;
Y := a.Y - b.Y;
end;
end;
procedure Vec2_SubFrom(var out : Vec2; const v : Vec2);
begin
with out do begin
X := X - v.X;
Y := Y - v.Y;
end;
end;
procedure Vec2_Scale(var out : Vec2; const a : Vec2; n : single);
begin
with out do begin
X := a.X * n;
Y := a.Y * n;
end;
end;
function Vec2_Distance(const a, b : Vec2) : single;
var
j, k : single;
begin
j := b.X - a.X;
k := b.Y - a.Y;
Vec2_Distance := Sqrt((j * j) + (k * k));
end;
function Vec2_DistanceSqr(const a, b : Vec2) : single;
var
j, k : single;
begin
j := b.X - a.X;
k := b.Y - a.Y;
Vec2_DistanceSqr := (j * j) + (k * k);
end;
function Vec2_Dot(const a, b : Vec2) : single;
begin
Vec2_Dot := (a.X * b.X) + (a.Y * b.Y);
end;
function Vec2_Length(const a : Vec2) : single;
begin
with a do begin
Vec2_Length := Sqrt((X * X) + (Y * Y));
end;
end;
function Vec2_LengthSqr(const a : Vec2) : single;
begin
with a do begin
Vec2_LengthSqr := (X * X) + (Y * Y);
end;
end;
procedure Vec2_Normalize(var out : Vec2; const a : Vec2);
var
inverseLength : single;
begin
inverseLength := 1.0 / Vec2_Length(a);
with out do begin
X := a.X * inverseLength;
Y := a.Y * inverseLength;
end;
end;
procedure Vec2_NormalizeThis(var out : Vec2);
var
inverseLength : single;
begin
inverseLength := 1.0 / Vec2_Length(out);
with out do begin
X := X * inverseLength;
Y := Y * inverseLength;
end;
end;
procedure Vec2_SetLength(var out : Vec2; const a : Vec2; length : single);
var
scale : single;
begin
scale := length / Vec2_Length(a);
with out do begin
X := a.X * scale;
Y := a.Y * scale;
end;
end;
procedure Vec2_SetThisLength(var out : Vec2; length : single);
var
scale : single;
begin
scale := length / Vec2_Length(out);
with out do begin
X := X * scale;
Y := Y * scale;
end;
end;
procedure Vec2_Lerp(var out : Vec2; const a, b : Vec2; t : single);
begin
with out do begin
X := a.X + (b.X - a.X) * t;
Y := a.Y + (b.Y - a.Y) * t;
end;
end;
procedure Mtx33_Identity(var out : Mtx33);
begin
with out do begin
m[M33_11] := 1.0;
m[M33_12] := 0.0;
m[M33_13] := 0.0;
m[M33_21] := 0.0;
m[M33_22] := 1.0;
m[M33_23] := 0.0;
m[M33_31] := 0.0;
m[M33_32] := 0.0;
m[M33_33] := 1.0;
end;
end;
procedure Mtx33_RotationX(var out : Mtx33; angle : binangle);
var
s, c : single;
begin
s := SinTable[angle and BIN_ANGLE_MASK];
c := CosTable[angle and BIN_ANGLE_MASK];
with out do begin
m[M33_11] := 1.0;
m[M33_12] := 0.0;
m[M33_13] := 0.0;
m[M33_21] := 0.0;
m[M33_22] := c;
m[M33_23] := -s;
m[M33_31] := 0.0;
m[M33_32] := s;
m[M33_33] := c;
end;
end;
procedure Mtx33_RotationY(var out : Mtx33; angle : binangle);
var
s, c : single;
begin
s := SinTable[angle and BIN_ANGLE_MASK];
c := CosTable[angle and BIN_ANGLE_MASK];
with out do begin
m[M33_11] := c;
m[M33_12] := 0.0;
m[M33_13] := s;
m[M33_21] := 0.0;
m[M33_22] := 1.0;
m[M33_23] := 0.0;
m[M33_31] := -s;
m[M33_32] := 0.0;
m[M33_33] := c;
end;
end;
procedure Mtx33_RotationZ(var out : Mtx33; angle : binangle);
var
s, c : single;
begin
s := SinTable[angle and BIN_ANGLE_MASK];
c := CosTable[angle and BIN_ANGLE_MASK];
with out do begin
m[M33_11] := c;
m[M33_12] := -s;
m[M33_13] := 0.0;
m[M33_21] := s;
m[M33_22] := c;
m[M33_23] := 0.0;
m[M33_31] := 0.0;
m[M33_32] := 0.0;
m[M33_33] := 1.0;
end;
end;
procedure Mtx33_Mul(var out, a, b : Mtx33);
begin
with out do begin
m[M33_11] := a.m[M33_11] * b.m[M33_11] + a.m[M33_12] * b.m[M33_21] + a.m[M33_13] * b.m[M33_31];
m[M33_12] := a.m[M33_11] * b.m[M33_12] + a.m[M33_12] * b.m[M33_22] + a.m[M33_13] * b.m[M33_32];
m[M33_13] := a.m[M33_11] * b.m[M33_13] + a.m[M33_12] * b.m[M33_23] + a.m[M33_13] * b.m[M33_33];
m[M33_21] := a.m[M33_21] * b.m[M33_11] + a.m[M33_22] * b.m[M33_21] + a.m[M33_23] * b.m[M33_31];
m[M33_22] := a.m[M33_21] * b.m[M33_12] + a.m[M33_22] * b.m[M33_22] + a.m[M33_23] * b.m[M33_32];
m[M33_23] := a.m[M33_21] * b.m[M33_13] + a.m[M33_22] * b.m[M33_23] + a.m[M33_23] * b.m[M33_33];
m[M33_31] := a.m[M33_31] * b.m[M33_11] + a.m[M33_32] * b.m[M33_21] + a.m[M33_33] * b.m[M33_31];
m[M33_32] := a.m[M33_31] * b.m[M33_12] + a.m[M33_32] * b.m[M33_22] + a.m[M33_33] * b.m[M33_32];
m[M33_33] := a.m[M33_31] * b.m[M33_13] + a.m[M33_32] * b.m[M33_23] + a.m[M33_33] * b.m[M33_33];
end;
end;
procedure Mtx33_Transform2D(var out : Vec2; var m : Mtx33; var v : Vec2);
begin
with out do begin
X := v.X * m.m[M33_11] + v.Y * m.m[M33_12] + m.m[M33_13];
Y := v.X * m.m[M33_21] + v.Y * m.m[M33_22] + m.m[M33_23];
X := X + m.m[M33_31];
Y := Y + m.m[M33_32];
end;
end;
procedure Mtx33_Translation2D(var out : Mtx33; x, y : single);
begin
with out do begin
m[M33_11] := 1.0;
m[M33_12] := 0.0;
m[M33_13] := 0.0;
m[M33_21] := 0.0;
m[M33_22] := 1.0;
m[M33_23] := 0.0;
m[M33_31] := x;
m[M33_32] := y;
m[M33_33] := 1.0;
end;
end;
procedure Mtx33_Scaling2D(var out : Mtx33; x, y : single);
begin
with out do begin
m[M33_11] := x;
m[M33_12] := 0.0;
m[M33_13] := 0.0;
m[M33_21] := 0.0;
m[M33_22] := y;
m[M33_23] := 0.0;
m[M33_31] := 0.0;
m[M33_32] := 0.0;
m[M33_33] := 1.0;
end;
end;
procedure Mtx33_Rotation2D(var out : Mtx33; angle : binangle);
begin
Mtx33_RotationZ(out, angle);
end;
end.

528
GDLIB/MATHFP.PAS Normal file
View file

@ -0,0 +1,528 @@
{ Math helper functions and lookup tables.
Fixed-point alternatives to the stuff located in the Math unit.
Gered King, 2019 }
{ You MUST manually call 'InitTrigTablesFP' in your programs before using
any of these functions that use trig!! }
{$A+,B-,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit MathFP;
interface
uses Math, FixedP;
const
FP_PI = trunc(PI * FP_FLOAT_SHIFT);
FP_PI_OVER_180 = trunc(PI_OVER_180 * FP_FLOAT_SHIFT);
FP_DEG_TO_RAD = trunc(DEG_TO_RAD * FP_FLOAT_SHIFT);
FP_RAD_TO_DEG = trunc(RAD_TO_DEG * FP_FLOAT_SHIFT);
FP_DEG_TO_BIN = trunc(DEG_TO_BIN * FP_FLOAT_SHIFT);
FP_BIN_TO_DEG = trunc(BIN_TO_DEG * FP_FLOAT_SHIFT);
FP_RAD_TO_BIN = trunc(RAD_TO_BIN * FP_FLOAT_SHIFT);
FP_BIN_TO_RAD = trunc(BIN_TO_RAD * FP_FLOAT_SHIFT);
type
Vec2FP = record
X, Y : fixed;
end;
PVec2FP = ^Vec2FP;
Mtx33FP = record
m : array[0..8] of fixed;
end;
PMtx33FP = ^Mtx33FP;
const
ZERO_VEC2FP : Vec2FP = (X: 0; Y: 0);
IDENTITY_MTX33FP : Mtx33FP = (m: (FP_1, 0, 0,
0, FP_1, 0,
0, 0, FP_1));
var
SinTableFP : array[0..1023] of fixed;
CosTableFP : array[0..1023] of fixed;
TanTableFP : array[0..511] of fixed;
procedure InitTrigTablesFP;
function LerpFP(a, b, t: fixed) : fixed;
function InvLerpFP(a, b, lerped: fixed) : fixed;
function AtanFP(x : fixed) : binangle;
function Atan2FP(y, x : fixed) : binangle;
function AngleBetweenFP(x1, y1, x2, y2: fixed) : binangle;
procedure AngleToDir2DFP(angle: binangle; var outX, outY: fixed);
procedure AngleToVec2DFP(angle: binangle; var out: Vec2FP);
procedure Vec2FP_Set(var out : Vec2FP; x, y : fixed);
procedure Vec2FP_Zero(var out : Vec2FP);
procedure Vec2FP_Add(var out : Vec2FP; const a, b : Vec2FP);
procedure Vec2FP_AddTo(var out : Vec2FP; const v : Vec2FP);
procedure Vec2FP_Sub(var out : Vec2FP; const a, b : Vec2FP);
procedure Vec2FP_SubFrom(var out : Vec2FP; const v : Vec2FP);
procedure Vec2FP_Scale(var out : Vec2FP; const a : Vec2FP; n : fixed);
procedure Vec2FP_ScaleThis(var out : Vec2FP; n : fixed);
function Vec2FP_Distance(const a, b : Vec2FP) : fixed;
function Vec2FP_DistanceSqr(const a, b : Vec2FP) : fixed;
function Vec2FP_Dot(const a, b : Vec2FP) : fixed;
function Vec2FP_Length(const a : Vec2FP) : fixed;
function Vec2FP_LengthSqr(const a : Vec2FP) : fixed;
procedure Vec2FP_Normalize(var out : Vec2FP; const a : Vec2FP);
procedure Vec2FP_NormalizeThis(var out : Vec2FP);
procedure Vec2FP_SetLength(var out : Vec2FP; const a : Vec2FP; length : fixed);
procedure Vec2FP_SetThisLength(var out : Vec2FP; length : fixed);
procedure Vec2FP_Lerp(var out : Vec2FP; const a, b : Vec2FP; t : fixed);
procedure Mtx33FP_Identity(var out : Mtx33FP);
procedure Mtx33FP_RotationX(var out : Mtx33FP; angle : binangle);
procedure Mtx33FP_RotationY(var out : Mtx33FP; angle : binangle);
procedure Mtx33FP_RotationZ(var out : Mtx33FP; angle : binangle);
procedure Mtx33FP_Mul(var out, a, b : Mtx33FP);
procedure Mtx33FP_Transform2D(var out : Vec2FP; var m : Mtx33FP; var v : Vec2FP);
procedure Mtx33FP_Translation2D(var out : Mtx33FP; x, y : fixed);
procedure Mtx33FP_Scaling2D(var out : Mtx33FP; x, y : fixed);
procedure Mtx33FP_Rotation2D(var out : Mtx33FP; angle : binangle);
implementation
procedure InitTrigTablesFP;
{ populates the trig lookup tables with sin/cos/tan values for the entire
range of binary angles supported (0 to BIN_ANGLE_MASK).
fixed-point version of Math.InitTrigTables. }
var
angle : binangle;
r, s, c : single;
begin
for angle := 0 to BIN_ANGLE_MASK do begin
r := angle * BIN_TO_RAD;
s := sin(r);
c := cos(r);
SinTableFP[angle] := FloatToFix(s);
CosTableFP[angle] := FloatToFix(c);
if angle <= BIN_ANGLE_TAN_MASK then begin
if (angle = BIN_ANGLE_90) or (angle = BIN_ANGLE_270) then
TanTableFP[angle] := 0
else
TanTableFP[angle] := FloatToFix((s / c));
end;
end;
end;
function LerpFP(a, b, t: fixed) : fixed;
{ returns the interpolated value between the ranged defined by a and b.
fixed-point version of Math.Lerp. }
begin
LerpFP := a + FixMul((b - a), t);
end;
function InvLerpFP(a, b, lerped: fixed) : fixed;
{ returns the 't' value used in a call to Lerp that returned the given
'lerped' value using the range a to b (approximately, anyway).
fixed-point version of Math.InvLerp. }
begin
InvLerpFP := FixDiv((lerped - a), (b - a));
end;
function AtanFP(x : fixed) : binangle;
{ calculates the arctangent of X. returns the result as a binary angle.
functionally equivalent to ArcTan().
fixed-point version of Math.Atan. }
var
a, b, c : integer;
d : fixed;
begin
if x >= 0 then begin
a := 0;
b := (BIN_ANGLE_90 - 1);
end else begin
a := BIN_ANGLE_90;
b := (BIN_ANGLE_180 - 1);
end;
repeat
c := (a + b) div 2;
d := x - TanTableFP[c];
if d > 0 then
a := c + 1
else if d < 0 then
b := c - 1;
until ((a > b) or (d = 0));
if x >= 0 then
AtanFP := c
else
AtanFP := -BIN_ANGLE_180 + c;
end;
function Atan2FP(y, x : fixed) : binangle;
{ calculates the arctangent of Y/X. returns the result as a binary angle.
functionally equivalent to atan2() from the C runtime library.
fixed-point version of Math.Atan2. }
var
r : fixed;
b : binangle;
begin
if x = 0 then begin
if y = 0 then begin
Atan2FP := 0;
end else begin
if y < 0 then
Atan2FP := -BIN_ANGLE_90
else
Atan2FP := BIN_ANGLE_90;
end;
exit;
end;
r := FixDiv(y, x);
b := AtanFP(r);
if x >= 0 then
Atan2FP := b
else if y >= 0 then
Atan2FP := BIN_ANGLE_180 + b
else
Atan2FP := b - BIN_ANGLE_180;
end;
function AngleBetweenFP(x1, y1, x2, y2: fixed) : binangle;
{ calculates the binary angle between the two points.
fixed-point version of Math.AngleBetween. }
var
deltaX, deltaY : fixed;
begin
deltaX := x2 - x1;
deltaY := y2 - y1;
if (deltaX = 0) and (deltaY = 0) then
AngleBetweenFP := 0
else
AngleBetweenFP := Atan2FP(deltaY, deltaX);
end;
procedure AngleToDir2DFP(angle: binangle;
var outX, outY: fixed);
{ for a given binary angle, calculates a normalized 2D direction vector
that points in the same direction as the angle.
fixed-point version of Math.AngleToDir2D. }
begin
outX := CosTableFP[angle and BIN_ANGLE_MASK];
outY := SinTableFP[angle and BIN_ANGLE_MASK];
end;
procedure AngleToVec2DFP(angle: binangle;
var out: Vec2FP);
{ for a given binary angle, calculates a normalized Vec2 that points in the
same direction as the angle.
fixed-point version of Math.AngleToVec2D. }
begin
with out do begin
X := CosTableFP[angle and BIN_ANGLE_MASK];
Y := SinTableFP[angle and BIN_ANGLE_MASK];
end;
end;
procedure Vec2FP_Set(var out : Vec2FP; x, y : fixed);
begin
out.X := x;
out.Y := y;
end;
procedure Vec2FP_Zero(var out : Vec2FP);
begin
with out do begin
X := 0;
Y := 0;
end;
end;
procedure Vec2FP_Add(var out : Vec2FP; const a, b : Vec2FP);
begin
with out do begin
X := a.X + b.X;
Y := a.Y + b.Y;
end;
end;
procedure Vec2FP_AddTo(var out : Vec2FP; const v : Vec2FP);
begin
inc(out.X, v.X);
inc(out.Y, v.Y);
end;
procedure Vec2FP_Sub(var out : Vec2FP; const a, b : Vec2FP);
begin
with out do begin
X := a.X - b.X;
Y := a.Y - b.Y;
end;
end;
procedure Vec2FP_SubFrom(var out : Vec2FP; const v : Vec2FP);
begin
dec(out.X, v.X);
dec(out.Y, v.Y);
end;
procedure Vec2FP_Scale(var out : Vec2FP; const a : Vec2FP; n : fixed);
begin
with out do begin
X := FixMul(a.X, n);
Y := FixMul(a.Y, n);
end;
end;
procedure Vec2FP_ScaleThis(var out : Vec2FP; n : fixed);
begin
with out do begin
X := FixMul(X, n);
Y := FixMul(Y, n);
end;
end;
function Vec2FP_Distance(const a, b : Vec2FP) : fixed;
var
j, k : fixed;
begin
j := b.X - a.X;
k := b.Y - a.Y;
Vec2FP_Distance := FixSqrt(FixSqr(j) + FixSqr(k));
end;
function Vec2FP_DistanceSqr(const a, b : Vec2FP) : fixed;
var
j, k : fixed;
begin
j := b.X - a.X;
k := b.Y - a.Y;
Vec2FP_DistanceSqr := FixSqr(j) + FixSqr(k);
end;
function Vec2FP_Dot(const a, b : Vec2FP) : fixed;
begin
Vec2FP_Dot := FixMul(a.X, b.X) + FixMul(a.Y, b.Y);
end;
function Vec2FP_Length(const a : Vec2FP) : fixed;
begin
with a do begin
Vec2FP_Length := FixSqrt(FixSqr(X) + FixSqr(Y));
end;
end;
function Vec2FP_LengthSqr(const a : Vec2FP) : fixed;
begin
with a do begin
Vec2FP_LengthSqr := FixSqr(X) + FixSqr(Y);
end;
end;
procedure Vec2FP_Normalize(var out : Vec2FP; const a : Vec2FP);
var
inverseLength : fixed;
begin
inverseLength := FixDiv(FP_1, Vec2FP_Length(a));
with out do begin
X := FixMul(a.X, inverseLength);
Y := FixMul(a.Y, inverseLength);
end;
end;
procedure Vec2FP_NormalizeThis(var out : Vec2FP);
var
inverseLength : fixed;
begin
inverseLength := FixDiv(FP_1, Vec2FP_Length(out));
with out do begin
X := FixMul(X, inverseLength);
Y := FixMul(Y, inverseLength);
end;
end;
procedure Vec2FP_SetLength(var out : Vec2FP; const a : Vec2FP; length : fixed);
var
scale : fixed;
begin
scale := FixDiv(length, Vec2FP_Length(a));
with out do begin
X := FixMul(a.X, scale);
Y := FixMul(a.Y, scale);
end;
end;
procedure Vec2FP_SetThisLength(var out : Vec2FP; length : fixed);
var
scale : fixed;
begin
scale := FixDiv(length, Vec2FP_Length(out));
with out do begin
X := FixMul(X, scale);
Y := FixMul(Y, scale);
end;
end;
procedure Vec2FP_Lerp(var out : Vec2FP; const a, b : Vec2FP; t : fixed);
begin
with out do begin
X := a.X + FixMul((b.X - a.X), t);
Y := a.Y + FixMul((b.Y - a.Y), t);
end;
end;
procedure Mtx33FP_Identity(var out : Mtx33FP);
begin
with out do begin
m[M33_11] := FP_1;
m[M33_12] := 0;
m[M33_13] := 0;
m[M33_21] := 0;
m[M33_22] := FP_1;
m[M33_23] := 0;
m[M33_31] := 0;
m[M33_32] := 0;
m[M33_33] := FP_1;
end;
end;
procedure Mtx33FP_RotationX(var out : Mtx33FP; angle : binangle);
var
s, c : fixed;
begin
s := SinTableFP[angle and BIN_ANGLE_MASK];
c := CosTableFP[angle and BIN_ANGLE_MASK];
with out do begin
m[M33_11] := FP_1;
m[M33_12] := 0;
m[M33_13] := 0;
m[M33_21] := 0;
m[M33_22] := c;
m[M33_23] := -s;
m[M33_31] := 0;
m[M33_32] := s;
m[M33_33] := c;
end;
end;
procedure Mtx33FP_RotationY(var out : Mtx33FP; angle : binangle);
var
s, c : fixed;
begin
s := SinTableFP[angle and BIN_ANGLE_MASK];
c := CosTableFP[angle and BIN_ANGLE_MASK];
with out do begin
m[M33_11] := c;
m[M33_12] := 0;
m[M33_13] := s;
m[M33_21] := 0;
m[M33_22] := FP_1;
m[M33_23] := 0;
m[M33_31] := -s;
m[M33_32] := 0;
m[M33_33] := c;
end;
end;
procedure Mtx33FP_RotationZ(var out : Mtx33FP; angle : binangle);
var
s, c : fixed;
begin
s := SinTableFP[angle and BIN_ANGLE_MASK];
c := CosTableFP[angle and BIN_ANGLE_MASK];
with out do begin
m[M33_11] := c;
m[M33_12] := -s;
m[M33_13] := 0;
m[M33_21] := s;
m[M33_22] := c;
m[M33_23] := 0;
m[M33_31] := 0;
m[M33_32] := 0;
m[M33_33] := FP_1;
end;
end;
procedure Mtx33FP_Mul(var out, a, b : Mtx33FP);
begin
with out do begin
m[M33_11] := FixMul(a.m[M33_11], b.m[M33_11]) + FixMul(a.m[M33_12], b.m[M33_21]) + FixMul(a.m[M33_13], b.m[M33_31]);
m[M33_12] := FixMul(a.m[M33_11], b.m[M33_12]) + FixMul(a.m[M33_12], b.m[M33_22]) + FixMul(a.m[M33_13], b.m[M33_32]);
m[M33_13] := FixMul(a.m[M33_11], b.m[M33_13]) + FixMul(a.m[M33_12], b.m[M33_23]) + FixMul(a.m[M33_13], b.m[M33_33]);
m[M33_21] := FixMul(a.m[M33_21], b.m[M33_11]) + FixMul(a.m[M33_22], b.m[M33_21]) + FixMul(a.m[M33_23], b.m[M33_31]);
m[M33_22] := FixMul(a.m[M33_21], b.m[M33_12]) + FixMul(a.m[M33_22], b.m[M33_22]) + FixMul(a.m[M33_23], b.m[M33_32]);
m[M33_23] := FixMul(a.m[M33_21], b.m[M33_13]) + FixMul(a.m[M33_22], b.m[M33_23]) + FixMul(a.m[M33_23], b.m[M33_33]);
m[M33_31] := FixMul(a.m[M33_31], b.m[M33_11]) + FixMul(a.m[M33_32], b.m[M33_21]) + FixMul(a.m[M33_33], b.m[M33_31]);
m[M33_32] := FixMul(a.m[M33_31], b.m[M33_12]) + FixMul(a.m[M33_32], b.m[M33_22]) + FixMul(a.m[M33_33], b.m[M33_32]);
m[M33_33] := FixMul(a.m[M33_31], b.m[M33_13]) + FixMul(a.m[M33_32], b.m[M33_23]) + FixMul(a.m[M33_33], b.m[M33_33]);
end;
end;
procedure Mtx33FP_Transform2D(var out : Vec2FP; var m : Mtx33FP; var v : Vec2FP);
begin
with out do begin
X := FixMul(v.X, m.m[M33_11]) + FixMul(v.Y, m.m[M33_12]) + m.m[M33_13];
Y := FixMul(v.X, m.m[M33_21]) + FixMul(v.Y, m.m[M33_22]) + m.m[M33_23];
X := X + m.m[M33_31];
Y := Y + m.m[M33_32];
end;
end;
procedure Mtx33FP_Translation2D(var out : Mtx33FP; x, y : fixed);
begin
with out do begin
m[M33_11] := FP_1;
m[M33_12] := 0;
m[M33_13] := 0;
m[M33_21] := 0;
m[M33_22] := FP_1;
m[M33_23] := 0;
m[M33_31] := x;
m[M33_32] := y;
m[M33_33] := FP_1;
end;
end;
procedure Mtx33FP_Scaling2D(var out : Mtx33FP; x, y : fixed);
begin
with out do begin
m[M33_11] := x;
m[M33_12] := 0;
m[M33_13] := 0;
m[M33_21] := 0;
m[M33_22] := y;
m[M33_23] := 0;
m[M33_31] := 0;
m[M33_32] := 0;
m[M33_33] := FP_1;
end;
end;
procedure Mtx33FP_Rotation2D(var out : Mtx33FP; angle : binangle);
begin
Mtx33FP_RotationZ(out, angle);
end;
end.

513
GDLIB/TOOLBOX.PAS Normal file
View file

@ -0,0 +1,513 @@
{ Miscellaneous helpers and utilities.
Gered King, 2018 }
{$A+,B-,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit Toolbox;
interface
uses FixedP;
const
Bit0 = $0001;
Bit1 = $0002;
Bit2 = $0004;
Bit3 = $0008;
Bit4 = $0010;
Bit5 = $0020;
Bit6 = $0040;
Bit7 = $0080;
Bit8 = $0100;
Bit9 = $0200;
Bit10 = $0400;
Bit11 = $0800;
Bit12 = $1000;
Bit13 = $2000;
Bit14 = $4000;
Bit15 = $8000;
BiosTicksPerSec = 1000.0 / 55.0;
BiosTicksPerSecFP = trunc((1000.0 / 55.0) * FP_FLOAT_SHIFT);
type
{ convenience for accessing a byte pointer as an array (cast to this) }
ByteArray = array[0..63999] of byte;
PByteArray = ^ByteArray;
WordArray = array[0..31999] of byte;
PWordArray = ^WordArray;
{ convenient way to go from pointer <-> segment/offset automatically }
PointerEx = record
case Integer of
0: (ptr: Pointer);
1: (ofs, seg: Word);
end;
var
BiosTicks: word absolute $0040:$006c;
function ByteFlipWord(x : word) : word;
function ByteFlipDWord(x : longint) : longint;
function SignInt(x: integer) : integer;
procedure SwapInts(var a, b: integer);
function Max(a, b: integer) : integer;
function Min(a, b: integer) : integer;
function Fequ(a, b: single) : boolean;
function FequX(a, b, tolerance: single) : boolean;
function ClampInt(value, low, high: integer) : integer;
function ClampFloat(value, low, high: single) : single;
function ClampFixed(value, low, high: fixed) : fixed;
function ScaleRange(value, oldMin, oldMax, newMin, newMax: single) : single;
function ScaleRangeFixed(value, oldMin, oldMax, newMin, newMax: fixed) : fixed;
function BiosTimeSeconds : single;
function BiosTimeSecondsFP : fixed;
function PtrSeg(const p: pointer) : word;
function PtrOfs(const p: pointer) : word;
procedure MemCopy(const dest, src: pointer; bytes: word);
procedure MemCopy16(const dest, src: pointer; bytes: word);
procedure MemFill(const dest: pointer; value: byte; bytes: word);
function HashString(const s: string) : word;
function PackBytes(const src: pointer; var dest: file; srcLength: word) : boolean;
function UnpackBytes(var src: file; const dest: pointer; unpackedSize: integer) : boolean;
implementation
function ByteFlipWord(x : word) : word;
{ returns the value with its bytes flipped, changing its endianess }
assembler;
asm
mov ax, x
xchg al, ah
end;
function ByteFlipDWord(x : longint) : longint;
{ returns the value with its bytes flipped, changing its endianess }
assembler;
asm
mov dx, word(x);
mov ax, word(x+2);
xchg al, ah
xchg dl, dh
end;
function SignInt(x: integer) : integer;
{ return 1 if x is positive, -1 if x is negative, or 0 if x is zero. }
assembler;
asm
mov bx, x
xor ax, ax
test bx, bx
jz @done { if x == 0, then return 0 }
mov ax, 1 { assume x is positive (return 1) }
and bx, 8000h { check sign bit }
jz @done { if sign bit == 0, return 1 (x is positive) }
mov ax, -1 { x is negative, return -1 }
@done:
end;
procedure SwapInts(var a, b: integer);
{ swaps the values of a and b }
var
temp: integer;
begin
temp := a;
a := b;
b := temp;
end;
function Max(a, b: integer) : integer;
{ returns the highest of the two given integers }
begin
if b > a then Max := b else Max := a;
end;
function Min(a, b: integer) : integer;
{ returns the lowest of the two given integers }
begin
if b < a then Min := b else Min := a;
end;
function Fequ(a, b: single) : boolean;
begin
Fequ := (abs(a - b) <= 0.00005);
end;
function FequX(a, b, tolerance: single) : boolean;
begin
FequX := (abs(a - b) <= tolerance);
end;
function ClampInt(value, low, high: integer) : integer;
{ returns the given value, clamped to fall within the low-high range. }
begin
if value < low then
ClampInt := low
else if value > high then
ClampInt := high
else
ClampInt := value;
end;
function ClampFloat(value, low, high: single) : single;
{ returns the given value, clamped to fall within the low-high range. }
begin
if value < low then
ClampFloat := low
else if value > high then
ClampFloat := high
else
ClampFloat := value;
end;
function ClampFixed(value, low, high: fixed) : fixed;
{ returns the given value, clamped to fall within the low-high range. }
begin
if value < low then
ClampFixed := low
else if value > high then
ClampFixed := high
else
ClampFixed := value;
end;
function ScaleRange(value, oldMin, oldMax, newMin, newMax: single) : single;
{ takes a value that should be between oldMin and oldMax, and scales it so
that it is within newMin and newMax at the same relative position within
the new min/max range }
begin
ScaleRange := (newMax - newMin) *
(value - oldMin) /
(oldMax - oldMin) + newMin;
end;
function ScaleRangeFixed(value, oldMin, oldMax, newMin, newMax: fixed) : fixed;
{ takes a value that should be between oldMin and oldMax, and scales it so
that it is within newMin and newMax at the same relative position within
the new min/max range }
begin
ScaleRangeFixed := FixDiv(
FixMul((newMax - newMin), (value - oldMin)),
(oldMax - oldMin) + newMin
);
end;
function BiosTimeSeconds : single;
{ returns the current bios tick count in seconds (time since midnight) }
begin
BiosTimeSeconds := BiosTicks / BiosTicksPerSec;
end;
function BiosTimeSecondsFP : fixed;
{ returns the current bios tick count in seconds (time since midnight) }
begin
BiosTimeSecondsFP := FixDiv(IntToFix(BiosTicks), BiosTicksPerSecFP);
end;
{ TODO: is there some better built-in way to do what the below two functions,
PtrSeg and PtrOfs, do? ... }
function PtrSeg(const p: pointer) : word;
{ returns the segment portion of the memory address in the given pointer }
assembler;
asm
mov ax, word [p+2]
end;
function PtrOfs(const p: pointer) : word;
{ returns the offset portion of the memory address in the given pointer }
assembler;
asm
mov ax, word [p]
end;
procedure MemCopy(const dest, src: pointer;
bytes: word);
{ copy specified number of bytes from src to dest. uses a 32-bit copy
via 'rep movsd' }
assembler;
asm
push ds
db $66,$33,$c9 { xor ecx, ecx }
mov cx, bytes
les di, dest
lds si, src
mov bx, cx
shr cx, 2 { cx = number of dwords to copy }
and bx, 3 { bx = number of remainder bytes to copy }
db $f3,$66,$a5 { rep movsd }
mov cx, bx
rep movsb
@done:
pop ds
end;
procedure MemCopy16(const dest, src: pointer;
bytes: word);
{ copy specified number of bytes from src to dest. uses 16-bit copy
via 'rep movsw' }
assembler;
asm
push ds
xor cx, cx
mov cx, bytes
les di, dest
lds si, src
mov bx, cx
shr cx, 1 { cx = number of words to copy }
and bx, 1 { bx = number of remainder bytes to copy }
rep movsw
mov cx, bx
rep movsb
@done:
pop ds
end;
procedure MemFill(const dest: pointer;
value: byte;
bytes: word);
{ fill the specified length of memory starting at dest with the given value }
assembler;
asm
db $66,$33,$c9 { xor ecx, ecx }
mov cx, bytes
mov al, value
les di, dest
mov ah, al { set all bytes of eax with value to fill with }
db $66 { shl ax => shl eax }
shl ax, 8
mov al, ah
db $66 { shl ax => shl eax }
shl ax, 8
mov al, ah
mov bx, cx
shr cx, 2 { cx = number of dwords to set }
and bx, 3 { bx = number of remainder bytes to set }
db $f3,$66,$ab { rep stosd }
mov cx, bx
rep stosb
end;
function HashString(const s: string) : word;
{ computes the hash of a string, using the djb2 algorithm }
var
hash : word;
i, c, len : integer;
begin
len := length(s);
for i := 1 to len do begin
c := ord(s[i]);
hash := ((hash shl 5) + hash) + c;
end;
HashString := hash;
end;
function PackBytes(const src: pointer;
var dest: file;
srcLength: word) : boolean;
{ packs the bytes located at the given pointer using the PackBits algorithm.
the packed output is written to the destination file as it is being
packed. srcLength is the size of the unpacked (original) data. packing
(and writing to the file) will stop once that many bytes have been read
from the source pointer. returns true on success, or false if there was
an IO error. assumes that the record size for the file being written is
set to 1.
this routine is based on PACKBITS.C from the Animator-Pro sources. }
const
MIN_RUN = 3;
MAX_RUN = 128;
MAX_BUFFER = 128;
type
PackMode = (PackDump, PackRun);
var
srcBytes : ^byte;
b, lastb : byte;
n, runStart : integer;
buffer : array[0..((MAX_RUN*2)-1)] of byte;
mode : PackMode;
fdata : byte;
label ioError;
begin
srcBytes := src;
mode := PackDump;
runStart := 0;
{ read initial source byte to start things off }
lastb := srcBytes^;
buffer[0] := lastb;
inc(srcBytes);
n := 1;
dec(srcLength);
while srcLength > 0 do begin
{ read next byte, add it to the temp buffer }
b := srcBytes^;
inc(srcBytes);
buffer[n] := b;
inc(n);
if mode = PackDump then begin
{ check if we need to flush the temp buffer to the file }
if n > MAX_BUFFER then begin
fdata := n - 2;
BlockWrite(dest, fdata, 1);
if IOResult <> 0 then goto ioError;
BlockWrite(dest, buffer, n-1);
if IOResult <> 0 then goto ioError;
buffer[0] := b;
n := 1;
runStart := 0;
{ detect the start of a run of identical bytes }
end else if b = lastb then begin
if (n - runStart) >= MIN_RUN then begin
if runStart > 0 then begin
{ we've found a run, flush the buffer we have currently and then
switch to "run" mode }
fdata := runStart - 1;
BlockWrite(dest, fdata, 1);
if IOResult <> 0 then goto ioError;
BlockWrite(dest, buffer, runStart);
if IOResult <> 0 then goto ioError;
end;
mode := PackRun;
end else if runStart = 0 then begin
mode := PackRun;
end;
end else begin
runStart := n-1;
end;
end else begin
{ detect the end of a run of identical bytes }
if (b <> lastb) or ((n - runStart) > MAX_RUN) then begin
{ the identical byte run has ended, write it to the file
(just two bytes, the count and the actual byte) }
fdata := -(n - runStart - 2);
BlockWrite(dest, fdata, 1);
if IOResult <> 0 then goto ioError;
fdata := lastb;
BlockWrite(dest, fdata, 1);
if IOResult <> 0 then goto ioError;
{ clear the temp buffer for our switch back to "dump" mode }
buffer[0] := b;
n := 1;
runStart := 0;
mode := PackDump;
end;
end;
lastb := b;
dec(srcLength);
end;
{ the source bytes have all been read, but we still might have to
flush our temp buffer or finish writing out a run of identical bytes }
if mode = PackDump then begin
fdata := n - 1;
BlockWrite(dest, fdata, 1);
if IOResult <> 0 then goto ioError;
BlockWrite(dest, buffer, n);
if IOResult <> 0 then goto ioError;
end else begin
fdata := -(n - runStart - 1);
BlockWrite(dest, fdata, 1);
if IOResult <> 0 then goto ioError;
fdata := lastb;
BlockWrite(dest, fdata, 1);
if IOResult <> 0 then goto ioError;
end;
n := IOResult; { clear i/o error flag }
PackBytes := true;
exit;
ioError:
n := IOResult; { clear i/o error flag }
PackBytes := false;
end;
function UnpackBytes(var src: file;
const dest: pointer;
unpackedSize: integer) : boolean;
{ unpacks a stream of bytes from a file into the destination buffer using
the PackBits algorithm. unpackedSize is the expected size of the
unpacked data, reading/unpacking will stop once this many bytes have been
written to the destination buffer. this function assumes that the file
will contain this much data and will not reach EOF before then. returns
true on success, or false if there was an IO error.
assumes that the record size for the file being read is 1.
this routine is based on PACKBITS.C from the Animator-Pro sources. }
var
destBytes : ^byte;
size, n : integer;
fdata, runLength : byte;
label ioError;
begin
destBytes := dest;
size := 0;
while size < unpackedSize do begin
{ read next "code" byte (run-length byte) that determines how to process
the subsequent bytes }
BlockRead(src, runLength, 1);
if IOResult <> 0 then goto ioError;
{ 129-255 = repeat next byte in file 257-n times }
if runLength > 128 then begin
runLength := 257 - runLength;
{ read the next byte and repeat it }
BlockRead(src, fdata, 1);
if IOResult <> 0 then goto ioError;
MemFill(destBytes, fdata, runLength);
inc(destBytes, runLength);
inc(size, runLength);
{ 0-128 = copy next n-1 bytes in file as-is }
end else if runLength < 128 then begin
inc(runLength);
{ read next set of bytes directly into destination buffer }
BlockRead(src, destBytes^, runLength);
if IOResult <> 0 then goto ioError;
inc(destBytes, runLength);
inc(size, runLength);
end;
{ 128 = no-op (does this even ever appear in any files??) }
end;
n := IOResult; { clear i/o error flag }
UnpackBytes := true;
exit;
ioError:
n := IOResult; { clear i/o error flag }
UnpackBytes := false;
end;
begin
if Test8086 < 2 then begin
writeln('Toolbox unit requires a 386 cpu or higher!');
halt;
end;
end.

139
HELP.PAS Normal file
View file

@ -0,0 +1,139 @@
{$A+,B-,E+,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit Help;
interface
procedure DoHelp;
implementation
uses GDGfx, GDKeybrd, GDTimer, GDEvents, Assets, Draw, Shared;
var
page : integer;
procedure DrawBaseHelpScreen;
begin
Cls(0);
BlitSpritef(62, 10, titleHelp);
DrawUIFrame(16, 60, 288, 136, uiGeneralFrame);
UseFont(@fnt);
end;
procedure ShowPage1;
begin
DrawBaseHelpScreen;
PrintAt(24, 68);
UseFont(@chunkyFnt);
PrintString('OBJECTIVE'#10, 14);
UseFont(@fnt);
PrintString('Using your thumbtack, pop more fruit than'#10'your opponent.'#10, 15);
PrintString('Each player chooses their fruit preference'#10'and they will only gain points by popping'#10, 15);
PrintString('matching fruit.'#10#10, 15);
PrintString(' Tomatos'#10#10, TOMATO_TEXT_COLOR);
PrintString(' Grapes'#10#10, GRAPES_TEXT_COLOR);
BlitSpritef(176, 118, sprites[FRUIT_TOMATO_TILE_START]);
BlitSpritef(176+24, 118, sprites[PLAYER_TOMATO_TILE_START]);
BlitSpritef(176, 118+16, sprites[FRUIT_GRAPES_TILE_START]);
BlitSpritef(176+24, 118+16, sprites[PLAYER_GRAPES_TILE_START]);
PrintString('New fruit plants will appear randomly. Wait'#10'until they grow into fruit before stabbing!'#10#10, 15);
PrintString(' Fruit Plant'#10#10, PLANT_TEXT_COLOR);
BlitSpritef(176, 174, sprites[4]);
WaitForVsync;
Flip(BACKBUFFER_LAYER);
end;
procedure ShowPage2;
begin
DrawBaseHelpScreen;
PrintAt(24, 68);
UseFont(@fnt);
PrintString('You have until the time runs out to pop as'#10'much fruit as you can!'#10#10, 15);
PrintString('If you are splashed by the opposite fruit'#10'being popped near you, you will lose speed'#10, 15);
PrintString('temporarily! Be careful.'#10#10, 15);
PrintString('Keep an eye out for golden fruit!'#10#10, 15);
BlitSpritef(128, 140, sprites[FRUIT_TOMATO_TILE_START+2]);
BlitSpritef(176, 140, sprites[FRUIT_GRAPES_TILE_START+2]);
WaitForVsync;
Flip(BACKBUFFER_LAYER);
end;
procedure ShowPage3;
begin
DrawBaseHelpScreen;
PrintAt(24, 68);
UseFont(@chunkyFnt);
PrintString('CONTROLS'#10#10, 14);
UseFont(@fnt);
PrintString('Player 1'#10, 128);
PrintString('Arrow keys to move. Spacebar to stab.'#10#10, 15);
PrintString('Player 2'#10, 128);
PrintString('A/S/D/W keys to move. T to stab.'#10#10, 15);
PrintString('Press ESC to pause and/or to exit out of'#10'an active match before the timer ends.', 15);
WaitForVsync;
Flip(BACKBUFFER_LAYER);
end;
procedure DoHelp;
var
event : PInputEvent;
begin
UseLayer(BACKBUFFER_LAYER);
page := 0;
ShowPage1;
FadeIn;
InitEvents;
while (page < 3) do begin
while not IsEventsEmpty do begin
event := PollEvents;
if IsKeyReleasedEvent(event, KEY_ENTER) then inc(page);
if IsKeyReleasedEvent(event, KEY_SPACE) then inc(page);
if IsKeyReleasedEvent(event, KEY_ESC) then inc(page);
if IsKeyReleasedEvent(event, KEY_UP)
or IsKeyReleasedEvent(event, KEY_LEFT) then begin
dec(page);
if page < 0 then page := 0;
end;
if IsKeyReleasedEvent(event, KEY_DOWN)
or IsKeyReleasedEvent(event, KEY_RIGHT) then begin
inc(page);
if page >= 2 then page := 2;
end;
end;
case page of
0: ShowPage1;
1: ShowPage2;
2: ShowPage3;
end;
end;
CloseEvents;
FadeOut;
currentGameState := StateMainMenu;
end;
end.

BIN
IMAGES.LBM Normal file
View file

Binary file not shown.

189
LEVELSEL.PAS Normal file
View file

@ -0,0 +1,189 @@
{$A+,B-,E+,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit LevelSel;
interface
procedure DoLevelSelect;
implementation
uses Dos, GDGfx, GDKeybrd, GDTimer, GDEvents,
Assets, Maps, Draw, Shared, Toolbox;
const
MAX_MAP_FILES = 127; { because i am lazy right now }
type
FoundMapFile = record
filename : string[12];
header : MapHeader;
end;
var
mapFilesList : array[0..MAX_MAP_FILES] of FoundMapFile;
mapFilesCount : word;
menuSelection : integer;
function ReadMapFileHeader(filename : string; var header : MapHeader) : boolean;
var
f : file;
n : integer;
ident : array[0..2] of char;
label ioError;
begin
ReadMapFileHeader := false;
Assign(f, filename);
Reset(f, 1);
if IOResult <> 0 then begin
Close(f);
n := IOResult; { clear i/o error flag }
exit;
end;
{ validate file type by checking for expected header }
BlockRead(f, ident, SizeOf(ident));
if (ident[0] <> 'M') or (ident[1] <> 'A') or (ident[2] <> 'P') then
goto ioError;
MemFill(@header, 0, SizeOf(header));
BlockRead(f, header, SizeOf(header), n);
if n <> SizeOf(header) then goto ioError;
ReadMapFileHeader := true;
ioError:
Close(f);
n := IOResult; { clear i/o error flag }
end;
procedure ScanForMapFiles;
var
search : SearchRec;
header : MapHeader;
i : integer;
begin
i := 0;
MemFill(@mapFilesList, 0, SizeOf(mapFilesList));
FindFirst('*.map', AnyFile, search);
while DosError = 0 do begin
ReadMapFileHeader(search.Name, header);
if search.Name <> 'TEST.MAP' then begin
mapFilesList[i].filename := search.Name;
mapFilesList[i].header := header;
inc(i);
end;
FindNext(search);
end;
mapFilesCount := i;
end;
procedure DrawLevelSelect;
var
i, x, y : integer;
idx : integer;
uiFrame : ^UIFrameBitmaps;
begin
Cls(0);
BlitSpritef(80, 10, titleSelectLevel);
UseFont(@fnt);
x := 16;
y := 70;
for i := -1 to 1 do begin;
idx := i + menuSelection;
if i = 0 then
uiFrame := @uiTomatoFrame
else
uiFrame := @uiGeneralFrame;
if (idx < 0) or (idx >= mapFilesCount) then
{DrawUIFrame(x, y, 288, 32, uiFrame^)}
else begin
with mapFilesList[idx] do begin
DrawUIFrame(x, y, 288, 32, uiFrame^);
DrawString(x+8, y+8, 15, filename);
SetClipRegion(x+8, y+16, x+8+288-16, y+16+32-16);
DrawString(x+8, y+16, 15, header.Name);
ResetClipRegion;
end;
end;
inc(y, 32);
end;
WaitForVsync;
Flip(BACKBUFFER_LAYER);
end;
procedure DoLevelSelect;
var
quit : boolean;
aborted : boolean;
event : PInputEvent;
begin
UseLayer(BACKBUFFER_LAYER);
menuSelection := 0;
ScanForMapFiles;
DrawLevelSelect;
FadeIn;
InitEvents;
quit := false;
aborted := false;
while not quit do begin
while not IsEventsEmpty do begin
event := PollEvents;
if IsKeyReleasedEvent(event, KEY_ESC) then begin
quit := true;
aborted := true;
end;
if IsKeyReleasedEvent(event, KEY_UP) then begin
dec(menuSelection);
if menuSelection < 0 then
menuSelection := 0;
end;
if IsKeyReleasedEvent(event, KEY_DOWN) then begin
inc(menuSelection);
if menuSelection >= mapFilesCount then
menuSelection := mapFilesCount-1;
end;
if IsKeyReleasedEvent(event, KEY_ENTER) then begin
if mapFilesCount > 0 then
selectedMap := mapFilesList[menuSelection].filename
else
selectedMap := '';
quit := true;
end;
end;
DrawLevelSelect;
end;
CloseEvents;
FadeOut;
if aborted then
currentGameState := StateMainMenu
else
currentGameState := StateFruitSelect;
end;
end.

124
MAINMENU.PAS Normal file
View file

@ -0,0 +1,124 @@
{$A+,B-,E+,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit MainMenu;
interface
procedure DoMainMenu;
implementation
uses GDGfx, GDKeybrd, GDTimer, GDEvents, Assets, Draw, Shared;
var
menuSelection : integer;
procedure DrawMainMenu;
var
c : color;
x, y : integer;
begin
Cls(0);
BlitSpritef(24, 10, titleMain);
DrawUIFrame(68, 110, 184, 72, uiGeneralFrame);
UseFont(@fnt);
{ --- }
x := 100; y := 120;
if menuSelection = 0 then begin
c := 14;
BlitSpritef(x, y, sprites[18]);
end else
c := 15;
DrawString(x+16+8, y+4, c, 'Play!');
x := 100; y := 140;
if menuSelection = 1 then begin
c := 14;
BlitSpritef(x, y, sprites[18]);
end else
c := 15;
DrawString(x+16+8, y+4, c, 'Instructions');
x := 100; y := 160;
if menuSelection = 2 then begin
c := 14;
BlitSpritef(x, y, sprites[18]);
end else
c := 15;
DrawString(x+16+8, y+4, c, 'Quit');
{ --- }
UseFont(@chunkyFnt);
DrawString(94, 70, 22, 'GDR 4X4X4 CHALLENGE');
x := 112;
y := 80;
BlitSpritef(x, y, sprites[0]);
inc(x, 24);
BlitSpritef(x, y, sprites[6]);
inc(x, 24);
BlitSpritef(x, y, sprites[1]);
inc(x, 24);
BlitSpritef(x, y, sprites[5]);
DrawString(178, 193, 22, 'BY: GERED KING, 2021');
WaitForVsync;
Flip(BACKBUFFER_LAYER);
end;
procedure DoMainMenu;
var
quit : boolean;
event : PInputEvent;
begin
UseLayer(BACKBUFFER_LAYER);
menuSelection := 0;
DrawMainMenu;
FadeIn;
InitEvents;
quit := false;
while not quit do begin
while not IsEventsEmpty do begin
event := PollEvents;
if IsKeyReleasedEvent(event, KEY_ESC) then begin
menuSelection := 2;
quit := true;
end;
if IsKeyReleasedEvent(event, KEY_DOWN) then begin
inc(menuSelection);
if menuSelection > 2 then menuSelection := 0;
end;
if IsKeyReleasedEvent(event, KEY_UP) then begin
dec(menuSelection);
if menuSelection < 0 then menuSelection := 2;
end;
if IsKeyReleasedEvent(event, KEY_ENTER) then quit := true;
end;
DrawMainMenu;
end;
CloseEvents;
FadeOut;
case menuSelection of
0: currentGameState := StateLevelSelect;
1: currentGameState := StateHelp;
2: currentGameState := StateQuit;
end;
end;
end.

142
MAPEDIT.PAS Normal file
View file

@ -0,0 +1,142 @@
{$A+,B-,E+,F-,G+,I+,N+,P-,Q-,R-,S-,T-,V-,X+}
program MapEdit;
uses Maps;
procedure SaveMap(const filename : string; var map : MapFile);
var
f : file;
header : array[0..2] of char;
begin
Assign(f, filename);
Rewrite(f, 1);
header[0] := 'M'; header[1] := 'A'; header[2] := 'P';
BlockWrite(f, header, SizeOf(header));
BlockWrite(f, map, SizeOf(map));
end;
procedure SaveSimpleMap;
const
filename : string = 'simple.map';
data : MapArray = (
74,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,75,
73,26,24,38,24,38,24,39,16,16,16,16,40,24,38,24,38,24,27,73,
73,25,70,25,70,25,70,18,15,15,15,15,19,70,25,70,25,70,25,73,
73,44,24,54,24,52,16,33,15,15,15,15,32,16,53,24,54,24,47,73,
73,25,70,25,70,18,15,15,15,15,15,15,15,15,19,70,25,70,25,73,
73,44,24,54,24,36,15,15,15,15,15,15,15,15,37,24,54,24,47,73,
73,25,70,25,70,18,15,15,15,15,15,15,15,15,19,70,25,70,25,73,
73,44,24,54,24,50,17,31,15,15,15,15,30,17,51,24,54,24,47,73,
73,25,70,25,70,25,70,18,15,15,15,15,19,70,25,70,25,70,25,73,
73,28,24,41,24,41,24,42,17,17,17,17,43,24,41,24,41,24,29,73,
76,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,72,77
);
var
map : MapFile;
begin
FillChar(map, SizeOf(MapFile), 0);
with map do begin
with header do begin
name := 'Just a simple fruit garden';
time := 120;
initialFruit := 10;
maxFruit := 32;
player1x := 7;
player1y := 5;
player2x := 12;
player2y := 5;
end;
map := data;
end;
writeln('Saving ', filename);
SaveMap(filename, map);
writeln('Done!');
end;
procedure SaveSmallMap;
const
filename : string = 'small.map';
data : MapArray = (
70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,
70,00,00,00,00,00,02,01,01,01,01,01,01,03,00,00,00,00,00,70,
70,00,02,01,03,00,04,01,01,05,00,04,01,01,11,06,06,08,00,70,
70,02,01,01,05,00,00,20,21,71,20,21,00,04,13,06,06,06,08,70,
70,01,01,05,70,00,00,18,32,16,33,19,00,00,70,06,06,06,10,70,
70,01,01,00,00,00,00,22,31,15,15,32,21,00,02,13,06,10,00,70,
70,04,05,00,00,07,08,00,18,30,17,31,32,21,01,01,01,03,00,70,
70,00,00,70,07,06,10,00,22,23,00,22,17,23,01,01,01,01,00,70,
70,00,70,00,09,10,00,81,72,80,00,00,00,00,04,01,01,05,00,70,
70,00,00,00,00,00,00,00,00,00,00,00,00,00,00,00,00,00,00,70,
70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70
);
var
map : MapFile;
begin
FillChar(map, SizeOf(MapFile), 0);
with map do begin
with header do begin
name := 'Not a lot of growing space ...';
time := 120;
initialFruit := 10;
maxFruit := 6;
player1x := 7;
player1y := 5;
player2x := 12;
player2y := 5;
end;
map := data;
end;
writeln('Saving ', filename);
SaveMap(filename, map);
writeln('Done!');
end;
procedure SaveEdgesMap;
const
filename : string = 'edges.map';
data : MapArray = (
70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,
70,70,70,00,00,20,16,16,21,00,70,00,00,00,00,70,00,20,21,70,
70,70,00,02,03,22,17,17,32,21,00,00,00,00,00,00,20,33,19,70,
70,70,00,04,01,03,00,00,22,23,00,70,00,70,00,00,22,17,19,70,
70,00,00,70,04,05,02,01,03,00,07,08,00,00,70,70,00,00,25,70,
70,00,00,70,70,00,04,01,05,70,06,06,70,02,03,70,70,00,25,70,
70,00,00,00,00,70,00,70,02,01,13,14,05,01,01,01,03,20,48,70,
70,20,21,00,00,00,00,00,04,01,01,05,00,04,01,01,05,18,19,70,
70,18,32,16,21,02,11,08,70,04,20,16,16,16,21,00,70,22,23,70,
70,22,17,17,23,04,13,10,00,00,22,17,17,17,23,00,00,00,00,70,
70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70,70
);
var
map : MapFile;
begin
FillChar(map, SizeOf(MapFile), 0);
with map do begin
with header do begin
name := 'Growing space along the edges.';
time := 120;
initialFruit := 10;
maxFruit := 10;
player1x := 5;
player1y := 4;
player2x := 14;
player2y := 6;
end;
map := data;
end;
writeln('Saving ', filename);
SaveMap(filename, map);
writeln('Done!');
end;
begin
SaveSimpleMap;
SaveSmallMap;
SaveEdgesMap;
end.

260
MAPS.PAS Normal file
View file

@ -0,0 +1,260 @@
{$A+,B-,E+,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit Maps;
interface
uses Entities;
const
SCREEN_MAP_LAYER = 2;
SCREEN_MAP_WIDTH = 20;
SCREEN_MAP_HEIGHT = 11;
SCREEN_MAP_SIZE = SCREEN_MAP_WIDTH*SCREEN_MAP_HEIGHT;
MAP_RIGHT = SCREEN_MAP_WIDTH - 1;
MAP_BOTTOM = SCREEN_MAP_HEIGHT - 1;
{ every tile beginning with this index should be
considered 'solid' for collision-purposes }
SOLID_TILE_START = 70;
{ inclusive start/end tile indices marking the range in which all
possible "dirt" tiles are found within }
DIRT_TILES_START = 15;
DIRT_TILES_END = 54;
type
DirtTile = record
fruit : Fruit;
hasFruit : bytebool;
x, y : word;
mapIndex : word;
end;
PDirtTile = ^DirtTile;
MapArray = array[0..(SCREEN_MAP_SIZE-1)] of byte;
MapHeader = record
name : string[32]; { display name }
time : word; { match time in seconds }
initialFruit : word; { initial amount of fruit plants to spawn }
maxFruit : word; { max number of fruit/plants that can be
active. once reached, no more will spawn
until some of the existing ones are
removed }
player1x : word; { player 1 starting tile coordinates }
player1y : word;
player2x : word; { player 2 starting tile coordinates }
player2y : word;
end;
MapFile = record
header : MapHeader;
map : MapArray;
end;
MapToDirtTileArray = array[0..(SCREEN_MAP_SIZE-1)] of PDirtTile;
{ even though this is sized identically to the map itself, the actual
number of indices used will be less. AND these indices DO NOT
correspond to the same indices in the map itself! }
DirtTileArray = array[0..(SCREEN_MAP_SIZE-1)] of DirtTile;
const
{ if true, the map should be re-rendered to SCREEN_MAP_LAYER }
isMapDirty : boolean = false;
var
map : MapFile;
{ a mapping of map x,y coordinates to DirtTile instances. any index
where the value in this array is nil means that that x,y coordinate
is not for a dirt tile }
dirtTileMapping : MapToDirtTileArray;
{ contains all of the dirt tiles. the indices in this array DO NOT
correspond to map x,y coordinates. use the above dirtTileMapping
array to find a dirt tile located in this array given a set of x,y
coordinates. }
{ TODO: perhaps this should be implemented as a linked-list? }
dirtTiles : DirtTileArray;
numDirtTiles : word;
numActiveDirtTiles : word;
function IsMapCollision(x, y : integer) : boolean;
function DoesEntityOverlapMapTile(const entity : Entity;
xt, yt : integer) : boolean;
procedure InitDirtTiles;
function GetUnusedDirtTileIndex : integer;
function GetRandomUnusedDirtTileIndex : integer;
implementation
uses FixedP, Toolbox, Shared;
function IsMapCollision(x, y : integer) : boolean;
{ returns true if an entity-sized object located at the given x,y
coordinates (which indicate the top-left of the entity) will collide
with any 'solid' tiles on the map. }
const
EDGE = 2;
var
left, right, top, bottom : integer;
cx, cy : integer;
index : word;
begin
IsMapCollision := false;
{ TODO: something to make collision feel less "sticky" and a bit more
forgiving ... }
left := (x+EDGE) div TILE_SIZE;
right := ((x-EDGE) + ENTITY_SIZE-1) div TILE_SIZE;
top := (y+EDGE) div TILE_SIZE;
bottom := ((y-EDGE) + ENTITY_SIZE-1) div TILE_SIZE;
if left < 0 then left := 0;
if right > MAP_RIGHT then right := MAP_RIGHT;
if top < 0 then top := 0;
if bottom > MAP_BOTTOM then bottom := MAP_BOTTOM;
with map do begin
for cy := top to bottom do begin
for cx := left to right do begin
index := (cy * SCREEN_MAP_WIDTH) + cx;
if map[index] >= SOLID_TILE_START then begin
IsMapCollision := true;
exit;
end else if (dirtTileMapping[index] <> nil)
and (dirtTileMapping[index]^.hasFruit) then begin
IsMapCollision := true;
exit;
end;
end;
end;
end;
end;
function DoesEntityOverlapMapTile(const entity : Entity;
xt, yt : integer) : boolean;
{ returns true if the given entity fully or partially overlaps the boundaries
of the given map tile coordinates. the x and y coordinates given should be
tile coordinates, not pixel coordinates. }
const
EDGE = 2;
var
ex1, ey1, ex2, ey2 : integer;
x2, y2 : integer;
begin
DoesEntityOverlapMapTile := false;
with entity.position do begin
ex1 := FixToInt(x)+EDGE;
ey1 := FixToInt(y)+EDGE;
ex2 := ex1 + (ENTITY_SIZE-1)-EDGE;
ey2 := ey1 + (ENTITY_SIZE-1)-EDGE;
end;
xt := xt * TILE_SIZE;
yt := yt * TILE_SIZE;
x2 := xt + (TILE_SIZE-1);
y2 := yt + (TILE_SIZE-1);
if (ey1 < yt) and (ey2 < yt) then
exit;
if (ey1 > y2) and (ey2 > y2) then
exit;
if (ex1 < xt) and (ex2 < xt) then
exit;
if (ex1 > x2) and (ex2 > x2) then
exit;
DoesEntityOverlapMapTile := true;
end;
procedure InitDirtTiles;
{ after a map has been freshly loaded, call this to scan the map for
all its dirt tiles. x,y coord to DirtTile instance mapping information
will be prepared as well as initializing the dirt tiles array itself }
var
mapIdx, dirtIdx, x, y : word;
tile : byte;
begin
MemFill(@dirtTileMapping, 0, SizeOf(dirtTileMapping));
MemFill(@dirtTiles, 0, SizeOf(dirtTiles));
dirtIdx := 0;
for y := 0 to SCREEN_MAP_HEIGHT-1 do begin
for x := 0 to SCREEN_MAP_WIDTH-1 do begin
mapIdx := (y * SCREEN_MAP_WIDTH) + x;
tile := map.map[mapIdx];
{ if this map location contains a dirt tile ... }
if (tile >= DIRT_TILES_START) and (tile <= DIRT_TILES_END) then begin
{ set up this next DirtTile instance with coordinate info about
this map location }
dirtTiles[dirtIdx].x := x;
dirtTiles[dirtIdx].y := y;
dirtTiles[dirtIdx].mapIndex := mapIdx;
{ and add a pointer for this map coordinate index to the table }
dirtTileMapping[mapIdx] := @dirtTiles[dirtIdx];
inc(dirtIdx);
end;
end;
end;
numDirtTiles := dirtIdx;
numActiveDirtTiles := 0;
end;
function GetUnusedDirtTileIndex : integer;
{ returns the index of the next unused/inactive dirt tile from dirtTiles.
returns -1 if there is no free index }
var
idx : integer;
begin
GetUnusedDirtTileIndex := -1;
for idx := 0 to numDirtTiles-1 do begin
if dirtTiles[idx].hasFruit then begin
GetUnusedDirtTileIndex := idx;
exit;
end;
end;
end;
function GetRandomUnusedDirtTileIndex : integer;
{ returns the index of a random unused/inactive dirt tile from dirtTiles.
returns -1 if there is no free index }
const
MAX_TRIES = 10; { TODO: LOL, this is a bad way to do this }
var
try, idx : integer;
begin
GetRandomUnusedDirtTileIndex := -1;
for try := 0 to MAX_TRIES do begin
idx := random(numDirtTiles);
{ make sure there is no fruit in this tile ... }
if not dirtTiles[idx].hasFruit then begin
with dirtTiles[idx] do begin
{ and also make sure that neither player is currently anywhere
within this tile either }
if (not DoesEntityOverlapMapTile(player1.entity, x, y))
and (not DoesEntityOverlapMapTile(player2.entity, x, y)) then begin
{ now we know for sure that this tile is clear }
GetRandomUnusedDirtTileIndex := idx;
exit;
end;
end;
end;
end;
end;
end.

237
MATCH.PAS Normal file
View file

@ -0,0 +1,237 @@
{$A+,B-,E+,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit Match;
interface
function StartMatch : boolean;
procedure MainLoop;
implementation
uses GDGfx, GDKeybrd, GDTimer, GDEvents, FixedP, Math, MathFP, Toolbox,
Assets, Entities, Maps, Draw, Shared;
var
menuSelection : integer;
function StartMatch : boolean;
var
i : integer;
begin
StartMatch := false;
if (not LoadMap(selectedMap)) then exit;
InitDirtTiles;
UseLayer(BACKBUFFER_LAYER);
Cls(0);
with map.header do begin
matchTime := time;
matchTime := matchTime * 1000; { time is a word, matchTime is longint }
InitPlayer(player1, player1x*16, player1y*16, player1Selection);
InitPlayer(player2, player2x*16, player2y*16, player2Selection);
for i := 1 to initialFruit do
SpawnRandomFruit;
end;
StartMatch := true;
end;
procedure DrawPauseMenu;
var
c : color;
x, y : integer;
begin
BlitSpritef(111, 10, titlePause);
DrawUIFrame(76, 90, 168, 56, uiGeneralFrame);
UseFont(@fnt);
x := 92; y := 100;
if menuSelection = 0 then begin
c := 14;
BlitSpritef(x, y, sprites[18]);
end else
c := 15;
DrawString(x+16+8, y+4, c, 'Resume Game');
x := 92; y := 120;
if menuSelection = 1 then begin
c := 14;
BlitSpritef(x, y, sprites[18]);
end else
c := 15;
DrawString(x+16+8, y+4, c, 'Back to Main Menu');
WaitForVsync;
Flip(BACKBUFFER_LAYER);
end;
function DoPauseMenu : boolean;
var
quit : boolean;
event : PInputEvent;
begin
UseLayer(BACKBUFFER_LAYER);
menuSelection := 0;
DrawPauseMenu;
InitEvents;
quit := false;
while not quit do begin
while not IsEventsEmpty do begin
event := PollEvents;
if IsKeyReleasedEvent(event, KEY_ESC) then begin
menuSelection := 0;
quit := true;
end;
if IsKeyReleasedEvent(event, KEY_DOWN) then begin
inc(menuSelection);
if menuSelection > 1 then menuSelection := 0;
end;
if IsKeyReleasedEvent(event, KEY_UP) then begin
dec(menuSelection);
if menuSelection < 0 then menuSelection := 1;
end;
if IsKeyReleasedEvent(event, KEY_ENTER) then quit := true;
end;
DrawPauseMenu;
end;
CloseEvents;
{ return true if the menu selection was 'quit' }
DoPauseMenu := (menuSelection = 1);
end;
procedure MainLoop;
var
frames, fps : word;
elapsed : longint;
quit : boolean;
aborted : boolean;
begin
frames := 0;
fps := 0;
elapsed := 0;
quit := false;
aborted := false;
isMapDirty := true;
isStatusBackdropDirty := true;
fruitSpawnTimer := 0;
UseLayer(BACKBUFFER_LAYER);
DrawBackdrop;
DrawAllFruit;
DrawPlayer(player1);
DrawPlayer(player2);
DrawAllParticles;
DrawPlayerStatuses;
DrawMatchStatus;
Flip(BACKBUFFER_LAYER);
FadeIn;
MarkTimer;
while not quit do begin
if Keys[KEY_ESC] then begin
WaitUntilKeyNotPressed(KEY_ESC);
quit := DoPauseMenu;
if quit then aborted := true;
{ reset timer mark, so if the pause menu is open for a long time,
our timing / elapsed time tracking doesn't time travel forward }
MarkTimer;
end;
frameTicks := MarkTimer;
inc(elapsed, frameTicks);
inc(fruitSpawnTimer, frameTicks);
dec(matchTime, frameTicks);
if matchTime < 0 then matchTime := 0;
{ player 1 }
if Keys[KEY_LEFT] then MovePlayer(player1, West);
if Keys[KEY_RIGHT] then MovePlayer(player1, East);
if Keys[KEY_UP] then MovePlayer(player1, North);
if Keys[KEY_DOWN] then MovePlayer(player1, South);
if Keys[KEY_SPACE] then StabPlayer(player1);
{ player 2 }
if Keys[KEY_A] then MovePlayer(player2, West);
if Keys[KEY_D] then MovePlayer(player2, East);
if Keys[KEY_W] then MovePlayer(player2, North);
if Keys[KEY_S] then MovePlayer(player2, South);
if Keys[KEY_T] then StabPlayer(player2);
{ update state }
UpdatePlayer(player1);
UpdatePlayer(player2);
UpdateAllFruit;
UpdateAllParticles;
{ render }
DrawBackdrop;
DrawAllFruit;
DrawPlayer(player1);
DrawPlayer(player2);
DrawAllParticles;
DrawPlayerStatuses;
DrawMatchStatus;
{ update fps stats }
inc(frames);
{ once per second, update the FPS value }
if elapsed >= TIMER_FREQ then begin
fps := frames;
frames := 0;
elapsed := 0;
end;
{
UseFont(@fnt);
PrintAt(0, 0); PrintInt(fps, 15);
PrintString(' ', 15); PrintInt(frameTicks, 15);
}
{ wait for vsync only if our frames are running at or beyond our
target framerate ... }
if frameTicks <= TARGET_FRAME_TICKS then
WaitForVsync;
Flip(BACKBUFFER_LAYER);
{ forcefully end the match once the timer is done ... }
if matchTime <= 0 then quit := true;
end;
FadeOut;
if aborted then
currentGameState := StateMainMenu
else
currentGameState := StateResults;
end;
end.

125
RESULTS.PAS Normal file
View file

@ -0,0 +1,125 @@
unit Results;
interface
procedure DoResults;
implementation
uses GDGfx, GDKeybrd, GDTimer, GDEvents, Assets, Draw, Entities, Shared;
procedure DrawResults;
var
uiFrame : ^UIFrameBitmaps;
playerTile, fruitTile : word;
c : color;
s : string[3];
player1win, player2win : boolean;
begin
Cls(0);
BlitSpritef(98, 10, titleResults);
UseFont(@fnt);
if player1.score > player2.score then begin
DrawString(120, 60, 15, 'Player 1 Wins!');
player1win := true;
player2win := false;
end else if player2.score > player1.score then begin
DrawString(120, 60, 15, 'Player 2 Wins!');
player1win := false;
player2win := true;
end else begin
DrawString(130, 60, 16, 'It''s A Tie!');
player1win := false;
player2win := false;
end;
if player1Selection = Tomato then begin
uiFrame := @uiTomatoFrame;
playerTile := PLAYER_TOMATO_TILE_START;
fruitTile := FRUIT_TOMATO_TILE_START;
c := TOMATO_TEXT_COLOR;
end else begin
uiFrame := @uiGrapesFrame;
playerTile := PLAYER_GRAPES_TILE_START;
fruitTile := FRUIT_GRAPES_TILE_START;
c := GRAPES_TEXT_COLOR;
end;
if player1win then
inc(playerTile, 16)
else if player2win then
inc(playerTile, 17);
UseFont(@fnt);
DrawUIFrame(60, 90, 64, 64, uiFrame^);
DrawString(68, 98, 15, 'Player 1');
BlitSpritef(72, 122, sprites[playerTile]);
BlitSpritef(72+16+8, 122, sprites[fruitTile]);
UseFont(@chunkyFnt);
Str(player1.score:3, s);
DrawStringf(72+16+8, 132, c, s);
if player2Selection = Tomato then begin
uiFrame := @uiTomatoFrame;
playerTile := PLAYER_TOMATO_TILE_START;
fruitTile := FRUIT_TOMATO_TILE_START;
c := TOMATO_TEXT_COLOR;
end else begin
uiFrame := @uiGrapesFrame;
playerTile := PLAYER_GRAPES_TILE_START;
fruitTile := FRUIT_GRAPES_TILE_START;
c := GRAPES_TEXT_COLOR;
end;
if player2win then
inc(playerTile, 16)
else if player1win then
inc(playerTile, 17);
UseFont(@fnt);
DrawUIFrame(196, 90, 64, 64, uiFrame^);
DrawString(204, 98, 15, 'Player 2');
BlitSpritef(208, 122, sprites[playerTile]);
BlitSpritef(208+16+8, 122, sprites[fruitTile]);
UseFont(@chunkyFnt);
Str(player2.score:3, s);
DrawStringf(208+16+8, 132, c, s);
WaitForVsync;
Flip(BACKBUFFER_LAYER);
end;
procedure DoResults;
var
quit : boolean;
event : PInputEvent;
begin
UseLayer(BACKBUFFER_LAYER);
DrawResults;
FadeIn;
InitEvents;
quit := false;
while not quit do begin
while not IsEventsEmpty do begin
event := PollEvents;
if IsKeyReleasedEvent(event, KEY_ESC) then quit := true;
if IsKeyReleasedEvent(event, KEY_ENTER) then quit := true;
end;
DrawResults;
end;
CloseEvents;
FadeOut;
currentGameState := StateMainMenu;
end;
end.

315
SHARED.PAS Normal file
View file

@ -0,0 +1,315 @@
{$A+,B-,E+,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+}
unit Shared;
interface
uses FixedP, Entities;
const
TIMER_FREQ = 1000;
TIMER_FREQ_FP = trunc(TIMER_FREQ * FP_FLOAT_SHIFT);
TARGET_FPS = 70;
TARGET_FRAME_TICKS = TIMER_FREQ / TARGET_FPS;
TILE_SIZE = 16;
ENTITY_SIZE = 16;
BACKBUFFER_LAYER = 1;
MAX_PARTICLES = 32;
PLAYER_TOMATO_TILE_START = 40;
PLAYER_GRAPES_TILE_START = 60;
PLAYER_NEUTRAL_TILE = 80;
FRUIT_TOMATO_TILE_START = 0;
FRUIT_GRAPES_TILE_START = 1;
SPLASH_TOMATO_TILE_START = 10;
SPLASH_GRAPES_TILE_START = 20;
GOLD_FRUIT_TILE_OFFSET = 2;
TOMATO_TACK_TILE_START = 16;
GRAPES_TACK_TILE_START = 26;
TOMATO_THUMBTACK_TILE = 6;
GRAPES_THUMBTACK_TILE = 7;
TIMER_SPRITE = 39;
HEAD_TO_HEAD_TILE = 5;
TOMATO_SCORE_UP_TILE = 8;
GRAPES_SCORE_UP_TILE = 9;
OW_TILE = 38;
TOMATO_TEXT_COLOR = 224;
GRAPES_TEXT_COLOR = 160;
DEBUFF_TEXT_COLOR = 67;
PLANT_TEXT_COLOR = 96;
GOLD_FRUIT_SPAWN_CHANCE = 5;
type
GameState = (StateMainMenu,
StateLevelSelect,
StateFruitSelect,
StateHelp,
StateMatch,
StateResults,
StateQuit);
var
currentGameState : GameState;
selectedMap : string[12];
player1Selection : FruitKind;
player2Selection : FruitKind;
frameTicks : word;
fruitSpawnTimer : word;
player1, player2 : Player;
tomatoPlayer : PPlayer;
grapesPlayer : PPlayer;
playerAnimations : array[0..ord(Defeat)] of AnimationDesc;
playerSpriteOffsets : array[0..ord(Grapes)] of word;
thumbTackSpriteOffsets : array[0..ord(Grapes)] of word;
thumbTackRenderOffsetsX : array[0..ord(West)] of integer;
thumbTackRenderOffsetsY : array[0..ord(West)] of integer;
thumbTackPointOffsetsX : array[0..ord(West)] of integer;
thumbTackPointOffsetsY : array[0..ord(West)] of integer;
fruitAnimations : array[0..ord(Popped)] of AnimationDesc;
fruitSpriteOffsets : array[0..ord(Grapes)] of word;
splashSpriteOffsets : array[0..ord(Grapes)] of word;
particles : array[0..(MAX_PARTICLES-1)] of Particle;
tomatoSplashAnimation : AnimationDesc;
grapesSplashAnimation : AnimationDesc;
stabFlashAnimation : AnimationDesc;
plantDestroyAnimation : AnimationDesc;
tomatoScoreUpAnimation : AnimationDesc;
grapesScoreUpAnimation : AnimationDesc;
owAnimation : AnimationDesc;
isStatusBackdropDirty : boolean;
matchTime : longint;
implementation
uses Toolbox;
begin
{ defaults for convenient testing purposes during development ... }
selectedMap := 'test.map';
player1Selection := Tomato;
player2Selection := Grapes;
playerSpriteOffsets[ord(Tomato)] := PLAYER_TOMATO_TILE_START;
playerSpriteOffsets[ord(Grapes)] := PLAYER_GRAPES_TILE_START;
thumbTackSpriteOffsets[ord(Tomato)] := TOMATO_TACK_TILE_START;
thumbTackSpriteOffsets[ord(Grapes)] := GRAPES_TACK_TILE_START;
thumbTackRenderOffsetsX[ord(North)] := 5;
thumbTackRenderOffsetsY[ord(North)] := -5;
thumbTackRenderOffsetsX[ord(South)] := -3;
thumbTackRenderOffsetsY[ord(South)] := 8;
thumbTackRenderOffsetsX[ord(West)] := -8;
thumbTackRenderOffsetsY[ord(West)] := 2;
thumbTackRenderOffsetsX[ord(East)] := 8;
thumbTackRenderOffsetsY[ord(East)] := 3;
thumbTackPointOffsetsX[ord(North)] := 7;
thumbTackPointOffsetsY[ord(North)] := 3;
thumbTackPointOffsetsX[ord(South)] := 7;
thumbTackPointOffsetsY[ord(South)] := 12;
thumbTackPointOffsetsX[ord(West)] := 2;
thumbTackPointOffsetsY[ord(West)] := 8;
thumbTackPointOffsetsX[ord(East)] := 13;
thumbTackPointOffsetsY[ord(East)] := 8;
fruitSpriteOffsets[ord(Tomato)] := FRUIT_TOMATO_TILE_START;
fruitSpriteOffsets[ord(Grapes)] := FRUIT_GRAPES_TILE_START;
splashSpriteOffsets[ord(Tomato)] := SPLASH_TOMATO_TILE_START;
splashSpriteOffsets[ord(Grapes)] := SPLASH_GRAPES_TILE_START;
MemFill(@particles, 0, SizeOf(particles));
MemFill(@playerAnimations, 0, SizeOf(playerAnimations));
with playerAnimations[ord(Idle)] do begin
frames[0] := 0;
count := 1;
delay := 0;
loops := true;
base := 0;
dirLength := 3;
end;
with playerAnimations[ord(Walking)] do begin
frames[0] := 1;
frames[1] := 0;
frames[2] := 2;
frames[3] := 0;
count := 4;
delay := 80;
loops := true;
base := 0;
dirLength := 3;
time := count * delay;
end;
with playerAnimations[ord(Stabbing)] do begin
frames[0] := 0;
count := 1;
delay := 160;
base := 12;
dirLength := 1;
loops := false;
time := count * delay;
end;
with playerAnimations[ord(Victory)] do begin
frames[0] := 0;
count := 1;
delay := 0;
loops := true;
base := 16;
dirLength := 0;
end;
with playerAnimations[ord(Defeat)] do begin
frames[0] := 0;
count := 1;
delay := 0;
loops := true;
base := 17;
dirLength := 0;
end;
MemFill(@fruitAnimations, 0, SizeOf(fruitAnimations));
with fruitAnimations[ord(Plant)] do begin
frames[0] := 0;
count := 1;
loops := true;
base := 4;
end;
with fruitAnimations[ord(Growing)] do begin
frames[0] := 0;
count := 1;
loops := false;
base := 0;
end;
with fruitAnimations[ord(Grown)] do begin
frames[0] := 0;
count := 1;
loops := true;
base := 0;
end;
with fruitAnimations[ord(Popped)] do begin
frames[0] := 0;
count := 1;
loops := false;
delay := 240;
base := 0;
end;
MemFill(@tomatoSplashAnimation, 0, SizeOf(tomatoSplashAnimation));
with tomatoSplashAnimation do begin
base := 10;
frames[0] := 0;
frames[1] := 1;
frames[2] := 2;
frames[3] := 3;
frames[4] := 4;
frames[5] := 5;
count := 6;
delay := 80;
loops := false;
time := count * delay;
end;
MemFill(@grapesSplashAnimation, 0, SizeOf(grapesSplashAnimation));
with grapesSplashAnimation do begin
base := 20;
frames[0] := 0;
frames[1] := 1;
frames[2] := 2;
frames[3] := 3;
frames[4] := 4;
frames[5] := 5;
count := 6;
delay := 80;
loops := false;
time := count * delay;
end;
MemFill(@stabFlashAnimation, 0, SizeOf(stabFlashAnimation));
with stabFlashAnimation do begin
base := 30;
frames[0] := 0;
frames[1] := 1;
frames[2] := 2;
count := 3;
delay := 40;
loops := false;
time := count * delay;
end;
MemFill(@plantDestroyAnimation, 0, SizeOf(plantDestroyAnimation));
with plantDestroyAnimation do begin
base := 33;
frames[0] := 0;
frames[1] := 1;
frames[2] := 2;
count := 3;
delay := 60;
loops := false;
time := count * delay;
end;
MemFill(@tomatoScoreUpAnimation, 0, SizeOf(tomatoScoreUpAnimation));
with tomatoScoreUpAnimation do begin
base := TOMATO_SCORE_UP_TILE;
frames[0] := 0;
count := 1;
delay := 2000;
loops := false;
time := count * delay;
end;
MemFill(@grapesScoreUpAnimation, 0, SizeOf(grapesScoreUpAnimation));
with grapesScoreUpAnimation do begin
base := GRAPES_SCORE_UP_TILE;
frames[0] := 0;
count := 1;
delay := 2000;
loops := false;
time := count * delay;
end;
MemFill(@owAnimation, 0, SizeOf(owAnimation));
with owAnimation do begin
base := OW_TILE;
frames[0] := 0;
count := 1;
delay := 1000;
loops := false;
time := count * delay;
end;
end.

BIN
SIMPLE.MAP Normal file
View file

Binary file not shown.

BIN
SMALL.MAP Normal file
View file

Binary file not shown.

BIN
TEST.MAP Normal file
View file

Binary file not shown.

BIN
TILES.LBM Normal file
View file

Binary file not shown.