commit 0286c2df0391f7c15a296ab13c19d25aaecfeb6f Author: gered Date: Wed Jul 7 17:10:18 2021 -0400 initial commit of "completed" sources, binaries and assets as of july 4th, 2021 diff --git a/ASSETS.PAS b/ASSETS.PAS new file mode 100644 index 0000000..c1825f6 --- /dev/null +++ b/ASSETS.PAS @@ -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. diff --git a/CHUNKY.FNT b/CHUNKY.FNT new file mode 100644 index 0000000..56376dd Binary files /dev/null and b/CHUNKY.FNT differ diff --git a/DESIGN.TXT b/DESIGN.TXT new file mode 100644 index 0000000..a1c5747 --- /dev/null +++ b/DESIGN.TXT @@ -0,0 +1,93 @@ +******** GDR 4x4x4 Design Challenge - June 2021 ***************************** + +Entry By: Gered King + +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? + diff --git a/DP.FNT b/DP.FNT new file mode 100644 index 0000000..038ecc6 Binary files /dev/null and b/DP.FNT differ diff --git a/DRAW.PAS b/DRAW.PAS new file mode 100644 index 0000000..b8c3924 --- /dev/null +++ b/DRAW.PAS @@ -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. diff --git a/EDGES.MAP b/EDGES.MAP new file mode 100644 index 0000000..d51037c Binary files /dev/null and b/EDGES.MAP differ diff --git a/ENTITIES.PAS b/ENTITIES.PAS new file mode 100644 index 0000000..97aa66a --- /dev/null +++ b/ENTITIES.PAS @@ -0,0 +1,1121 @@ +{$A+,B-,E+,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+} + +unit Entities; + +interface + +uses FixedP, MathFP; + +const + PLAYER_WALK_SPEED = FP_0_6; + PLAYER_TACK_PUSH_FORCE = FP_8; + + ENTITY_FRICTION = FP_0_2; + FORCE_FRICTION = FP_0_7; + + PRICK_RADIUS = 4; + + SCORE_UP_PARTICLE_SPEED = -trunc(0.075 * FP_FLOAT_SHIFT); + OW_PARTICLE_SPEED = -trunc(0.1 * FP_FLOAT_SHIFT); + + { cooldowns/times are all specified in terms of frame ticks } + STAB_COOLDOWN = 80; + STABBED_DEBUFF_TIME = 5000; + SPLASHED_DEBUFF_TIME = 5000; + +type + Direction = (South, North, East, West); + + + { used to statically define an animation sequence } + AnimationDesc = record + frames : array[0..5] of word; { 6 frames total ever ... } + count : word; { number of frames (max of 6) } + delay : word; { frame timer/delay between switching to next frame } + time : word; { total time. = count * delay } + loops : bytebool; { true = animation loops } + base : word; { spritesheet index of first frame. if + multi-directional, this should be the index of the + first frame for the south direction } + dirLength : word; { number of frames from the start of one direction + to the start of the next direction. if not a + multi-directional animation, this must be set to 0 } + end; + PAnimationDesc = ^AnimationDesc; + + { state needed for a currently running animation sequence. will be used + in conjunction with an AnimationDesc that defines the animation sequence + itself } + AnimationState = record + complete : bytebool; { true = current animation sequence is complete } + frameIndex : word; { index of the current animation sequence frame } + time : word; { current frame timer } + end; + PAnimationState = ^AnimationState; + + + + { general entity properties. an instance of this should be included + in the actual entity's specific record-type. not all entity types + actually use all of these properties. } + Entity = record + position : Vec2FP; + velocity : Vec2FP; + force : Vec2FP; + direction : Direction; + animation : AnimationState; + noCollision : bytebool; + end; + + + { particle entity properties. sprite-animation-based particles + have their lifetime directly linked to the length of the animation. + TODO: non-sprite-animation-based particles. } + Particle = record + active : bytebool; + entity : Entity; + animation : PAnimationDesc; { if non-nil, particle is a + sprite-animation-based particle } + end; + + + FruitKind = (Tomato, Grapes); + FruitState = (Plant, Growing, Grown, Popped); + + { fruit entity properties } + Fruit = record + entity : Entity; + kind : FruitKind; + state : FruitState; + { the meaning of these two values depends on the 'state' value } + counter : word; + value : word; + isGold : bytebool; + end; + + PlayerState = (Idle, Walking, Stabbing, Victory, Defeat); + + { holds player state. duh. } + Player = record + entity : Entity; + fruitPref : FruitKind; + state : PlayerState; + stabCooldown : word; + stabbedDebuffTime : word; + splashedDebuffTime : word; + skipRenderFlag : bytebool; + score : word; + end; + PPlayer = ^Player; + + +procedure ResetAnimationState(var animation : AnimationState); +function GetAnimationFrame(const state : AnimationState; + const desc : AnimationDesc; + direction : Direction) : word; +procedure UpdateAnimation(var entity : Entity; + const animation : AnimationDesc); + +function DoEntitiesOverlap(const a, b : Entity) : boolean; +function DoesEntityOverlap(const entity : Entity; + x1, y1, x2, y2 : integer) : boolean; +function IsEntityPositionValid(const entity : Entity) : boolean; +function MoveEntity(var entity : Entity) : boolean; +function IsEntityStopped(const entity : Entity) : boolean; +procedure UpdateEntity(var entity : Entity); + +procedure SetPlayerState(var player : Player; state : PlayerState); +procedure GetThumbTackPointCoords(const player : Player; var out_x, out_y : integer); +procedure GetThumbTackRenderCoords(const player : Player; var out_x, out_y : integer); +procedure UpdatePlayer(var player : Player); +procedure InitPlayer(var player : Player; x, y : integer; fruit: FruitKind); +procedure MovePlayer(var player : Player; dir : Direction); +procedure StabPlayer(var player : Player); +procedure DoThumbTackStabAt(px, py : integer; player : PPlayer); + +function SpawnRandomFruit : integer; +procedure PopAllFruit(kind : FruitKind; player : PPlayer); +procedure PopFruitAt(x, y : integer; player : PPlayer); +procedure UpdateAllFruit; + +function GetUnusedParticleIndex : integer; +function SpawnTomatoSplash(x, y : integer) : integer; +function SpawnGrapesSplash(x, y : integer) : integer; +function SpawnPlantSplash(x, y : integer) : integer; +function SpawnStabFlash(x, y : integer) : integer; +function SpawnScoreUp(x, y : integer; kind : FruitKind) : integer; +function SpawnOw(x, y : integer) : integer; +procedure UpdateAllParticles; + + +implementation + +uses Math, Toolbox, Maps, Assets, Shared; + +procedure ResetAnimationState(var animation : AnimationState); +{ resets the given animation state, so it can be used to start an + animation sequence from the very beginning } +begin + with animation do begin + complete := false; + frameIndex := 0; + time := 0; + end; +end; + +function GetAnimationFrame(const state : AnimationState; + const desc : AnimationDesc; + direction : Direction) : word; +{ returns the current spritesheet bitmap index that should be blitted + to draw an entity based on it's animation state and facing direction } +begin + with desc do begin + GetAnimationFrame := frames[state.frameIndex] + + (ord(direction) * dirLength) + + base; + end; +end; + +procedure UpdateAnimation(var entity : Entity; + const animation : AnimationDesc); +{ cycles the entity's animation state. the passed AnimationDesc should be + the corresponding animation descriptor/definition for the animation state + that the entity is currently in } +begin + with entity.animation do begin + if not complete then begin + inc(time, frameTicks); + if time >= animation.delay then begin + { move to next frame in the current animation sequence } + time := 0; + if frameIndex = (animation.count-1) then begin + { we're at the last frame in the current animation sequence } + if not animation.loops then begin + complete := true; + end else + frameIndex := 0; + end else + inc(frameIndex); + end; + end; + end; +end; + +{ ------------------------------------------------------------------------ } + +function DoEntitiesOverlap(const a, b : Entity) : boolean; +{ returns true if the given entities overlap fully or partially } +const + EDGE = 2; +var + ax1, ay1, ax2, ay2 : integer; + bx1, by1, bx2, by2 : integer; +begin + DoEntitiesOverlap := false; + + with a.position do begin + ax1 := FixToInt(x)+EDGE; + ay1 := FixToInt(y)+EDGE; + ax2 := ax1 + (ENTITY_SIZE-1)-EDGE; + ay2 := ay1 + (ENTITY_SIZE-1)-EDGE; + end; + with b.position do begin + bx1 := FixToInt(x)+EDGE; + by1 := FixToInt(y)+EDGE; + bx2 := bx1 + (ENTITY_SIZE-1)-EDGE; + by2 := by1 + (ENTITY_SIZE-1)-EDGE; + end; + + if (ay1 < by1) and (ay2 < by1) then + exit; + if (ay1 > by2) and (ay2 > by2) then + exit; + if (ax1 < bx1) and (ax2 < bx1) then + exit; + if (ax1 > bx2) and (ax2 > bx2) then + exit; + + DoEntitiesOverlap := true; +end; + +function DoesEntityOverlap(const entity : Entity; + x1, y1, x2, y2 : integer) : boolean; +{ returns true if the entity partially or fully overlaps with the given + area (specified in pixel coordinates) } +const + EDGE = 2; +var + ex1, ey1, ex2, ey2 : integer; +begin + DoesEntityOverlap := 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; + + if (ey1 < y1) and (ey2 < y1) then + exit; + if (ey1 > y2) and (ey2 > y2) then + exit; + if (ex1 < x1) and (ex2 < x1) then + exit; + if (ex1 > x2) and (ex2 > x2) then + exit; + + DoesEntityOverlap := true; +end; + +function IsEntityPositionValid(const entity : Entity) : boolean; +{ returns true if the given entity is currently located in a position + that is "valid", meaning completely free of collisions with anything. } +begin + IsEntityPositionValid := true; + + with entity.position do begin + { any collision with the map? either collidable tiles or fruit ... } + if IsMapCollision(FixToInt(x), FixToInt(y)) then + IsEntityPositionValid := false + + else begin + { TODO: this seems a bit clumsy ...? } + + { make sure we don't compare against ourself. since this function + operates on generic Entity's, we kinda have to check this way } + if @entity = @player1.entity then begin + IsEntityPositionValid := (not DoEntitiesOverlap(entity, + player2.entity)); + end else begin + IsEntityPositionValid := (not DoEntitiesOverlap(entity, + player1.entity)); + end; + end; + + end; +end; + +function MoveEntity(var entity : Entity) : boolean; +{ updates the entity's X and Y position based on their current movement + velocity and any force velocity. checks for map collisions and prevents + movement along the X and/or Y axis if any collisions are found. returns + true if the entity collided against something. } +const + { number of movement+collision sub-steps to divide this movement into } + NUM_STEPS = 2; + + { reciprocal (also as fixed point) just so that we can use Vec2FP_Scale } + STEP_SCALE = trunc((1 / NUM_STEPS) * FP_FLOAT_SHIFT); +var + stepVelocity : Vec2FP; + i : integer; +begin + MoveEntity := false; + + with entity do begin + { calculate the sub-step velocity for the below loop ... } + Vec2FP_Add(stepVelocity, velocity, force); + if (stepVelocity.x = 0) and (stepVelocity.y = 0) then exit; + + { if this entity skips collision checks, just move it and return } + if noCollision then begin + Vec2FP_AddTo(position, stepVelocity); + exit; + end; + + { we're dividing the movement and collision checks into sub-steps! + this is a possibly-hacky solution to fix issues with any frame-timings + that might result in us (without using sub-steps) moving entities + more than 1 pixel per loop. this could cause problems! e.g. the player + might not be able to move into a 1-tile-wide gap because their + movement keeps skipping over 1 pixel too much ... } + Vec2FP_ScaleThis(stepVelocity, STEP_SCALE); + for i := 1 to NUM_STEPS do begin + { add velocity X to player's position, then test for collisions using + this new position. if a collision occurs, we cannot move the player + in the X direction by this amount, so we back it out } + inc(position.x, stepVelocity.x); + if not IsEntityPositionValid(entity) then begin + MoveEntity := true; + dec(position.x, stepVelocity.x); + end; + + { same thing for the velocity Y now. note that, if no collision occured + in the X direction, the position that is tested for here will also + include the velocity X component ... } + inc(position.y, stepVelocity.y); + if not IsEntityPositionValid(entity) then begin + MoveEntity := true; + dec(position.y, stepVelocity.y); + end; + end; + end; +end; + +function IsEntityStopped(const entity : Entity) : boolean; +{ returns true if the entity's movement velocity is slow enough that they + could be considered stopped. this does not take into account the entity's + force velocity } +const + THRESHOLD = trunc(0.05 * FP_FLOAT_SHIFT); +begin + with entity.velocity do begin + IsEntityStopped := (abs(x) < THRESHOLD) and (abs(y) < THRESHOLD); + end; +end; + +procedure UpdateEntity(var entity : Entity); +{ updates general entity state. this includes applying velocity/force + vectors to the entity's position and also applying friction to those + velocity/force vecotrs too } +begin + { move entity in the direction of their velocity and any combined force + that is currently being applied to them. also handles collision. } + MoveEntity(entity); + + with entity do begin + { slow both the velocity and force down by friction } + { TODO: probably for the force vector, we should use something other + than friction ... ? some per-force specific value maybe? } + Vec2FP_ScaleThis(velocity, ENTITY_FRICTION); + Vec2FP_ScaleThis(force, FORCE_FRICTION); + end; +end; + +{ ------------------------------------------------------------------------ } + +procedure SetPlayerState(var player : Player; state : PlayerState); +{ switches the player state to the one specified, also resetting the + player's current animation state } +begin + if state = player.state then exit; + player.state := state; + ResetAnimationState(player.entity.animation); +end; + +procedure GetThumbTackPointCoords(const player : Player; + var out_x, out_y : integer); +{ computes the pixel coordinate of where the player's thumb tack's point + should be (assuming they are currently stabbing). } +var + dir : Direction; +begin + { lol, perhaps just computing, say, 8-16 pixels out in a line directly + centered on the player and outward in their facing direction and using + that as the point coordinate would be best ... ? + this all seems silly now that i've written it ... } + with player.entity do begin + dir := direction; + with position do begin + out_x := FixToInt(x) + + thumbTackRenderOffsetsX[ord(dir)] + + thumbTackPointOffsetsX[ord(dir)]; + out_y := FixToInt(y) + + thumbTackRenderOffsetsY[ord(dir)] + + thumbTackPointOffsetsY[ord(dir)]; + end; + end; +end; + +procedure GetThumbTackRenderCoords(const player : Player; + var out_x, out_y : integer); +{ computes the pixel coordinate of where the player's thumb tack sprite + should be (assuming they are currently stabbing). } +var + dir : Direction; +begin + with player.entity do begin + dir := direction; + with position do begin + out_x := FixToInt(x) + thumbTackRenderOffsetsX[ord(dir)]; + out_y := FixToInt(y) + thumbTackRenderOffsetsY[ord(dir)]; + end; + end; +end; + +procedure UpdatePlayer(var player : Player); +{ updates player (and general entity) state. this includes entity + movement, as well as player animation state } +var + animation : ^AnimationDesc; + i : integer; + px, py : integer; + dir : Direction; +begin + with player do begin + { do general entity updates first ... this will handle movement via + any velocity/force vectors } + UpdateEntity(entity); + + if state = Stabbing then begin + + if (entity.animation.frameIndex = 0) + and (entity.animation.time = 0) + and (not entity.animation.complete) then begin + { only for the very first frame of the stabbing animation, + check for any fruit that collide with the thumb tack's pointy + end and should be popped } + dir := entity.direction; + with entity.position do begin + GetThumbTackPointCoords(player, px, py); + DoThumbTackStabAt(px, py, @player); + end; + end; + + if entity.animation.complete then begin + { keep player in the stabbing state until that animation has + completed. } + SetPlayerState(player, Idle); + + stabCooldown := STAB_COOLDOWN; + + { stab/attack cooldown time quadrupled when afflicted by either + the 'stabbed' or 'splashed' cooldown } + if (stabbedDebuffTime > 0) or (splashedDebuffTime > 0) then + stabCooldown := stabCooldown * 4; + end; + + end else if (state <> Victory) and (state <> Defeat) then begin + { set player idle/walking based on their velocity. + note that this check ignores their force velocity! } + if IsEntityStopped(entity) then + SetPlayerState(player, Idle) + else + SetPlayerState(player, Walking); + end; + + + + UpdateAnimation(entity, playerAnimations[ord(state)]); + + + { update cooldowns / debuff timers } + + if stabCooldown > 0 then + if stabCooldown > frameTicks then + dec(stabCooldown, frameTicks) + else + stabCooldown := 0; + + if stabbedDebuffTime > 0 then + if stabbedDebuffTime > frameTicks then + dec(stabbedDebuffTime, frameTicks) + else + stabbedDebuffTime := 0; + + if splashedDebuffTime > 0 then + if splashedDebuffTime > frameTicks then + dec(splashedDebuffTime, frameTicks) + else + splashedDebuffTime := 0; + + if (stabbedDebuffTime > 0) or (splashedDebuffTime > 0) then + skipRenderFlag := not skipRenderFlag; + end; +end; + +procedure InitPlayer(var player : Player; x, y : integer; fruit: FruitKind); +begin + MemFill(@player, 0, SizeOf(Player)); + player.entity.position.x := IntToFix(x); + player.entity.position.y := IntToFix(y); + player.entity.direction := South; + player.fruitPref := fruit; + + case fruit of + Tomato: tomatoPlayer := @player; + Grapes: grapesPlayer := @player; + end; + + SetPlayerState(player, Idle); +end; + +procedure MovePlayer(var player : Player; dir : Direction); +{ sets the given player in motion in the given direction. this function + does not actually adjust the players position in any way. it only sets + their velocity } +var + speed : fixed; +begin + with player do begin + if stabCooldown > 0 then exit; + if (state <> Idle) and (state <> Walking) then exit; + + { movement speed is halved when afflicted by 'splashed' } + if splashedDebuffTime > 0 then + speed := FixMul(PLAYER_WALK_SPEED, FP_0_5) + { movement speed is cut by 30% when afflicted by 'stabbed' } + else if stabbedDebuffTime > 0 then + speed := FixMul(PLAYER_WALK_SPEED, FP_0_7) + else + speed := PLAYER_WALK_SPEED; + + case dir of + North: begin + with entity do begin + dec(velocity.y, speed); + direction := North; + end; + end; + South: begin + with entity do begin + inc(velocity.Y, speed); + direction := South; + end; + end; + West: begin + with entity do begin + dec(velocity.x, speed); + direction := West; + end; + end; + East: begin + with entity do begin + inc(velocity.x, speed); + direction := East; + end; + end; + end; + end; +end; + +procedure StabPlayer(var player : Player); +{ switches the player into the 'stabbing' state, which will start the + animation as well as bring out the player's thumb tack (during the + next player update anyway) } +begin + with player do begin + if stabCooldown > 0 then exit; + if (state <> Idle) and (state <> Walking) then exit; + + SetPlayerState(player, Stabbing); + end; +end; + +procedure DoThumbTackStabAt(px, py : integer; player : PPlayer); +{ determines what, if anything, a thumb tack stab with the pixel coordinates + of the point provided, collided with and what should happen. the player + passed should be the player who owns the thumb tack. } +var + otherPlayer : PPlayer; + dir : Direction; +begin + { always pop any fruit / destroy any plants at this position } + PopFruitAt(px, py, player); + + + { did we also hit the other player? } + + { determine which player is which ... } + if player = @player1 then + otherPlayer := @player2 + else + otherPlayer := @player1; + + { now check if this thumb tack point collided with that other player } + if DoesEntityOverlap(otherPlayer^.entity, + px - PRICK_RADIUS, + py - PRICK_RADIUS, + px + PRICK_RADIUS, + py + PRICK_RADIUS) then begin + { we hit the other player. push the other player in the direction + that this player is facing } + + dir := player^.entity.direction; + + with otherPlayer^.entity do begin + case dir of + North: AngleToVec2DFP(BIN_ANGLE_270, force); + South: AngleToVec2DFP(BIN_ANGLE_90, force); + West: AngleToVec2DFP(BIN_ANGLE_180, force); + East: AngleToVec2DFP(0, force); + end; + Vec2FP_ScaleThis(force, PLAYER_TACK_PUSH_FORCE); + end; + + { also apply the 'stabbed' debuff to the other player } + otherPlayer^.stabbedDebuffTime := STABBED_DEBUFF_TIME; + + { finally, spawn a 'ow' particle as another indication that a player + was stabbed } + with otherPlayer^.entity.position do begin + SpawnOw(FixToInt(x), FixToInt(y)); + end; + + end; +end; + +{ ------------------------------------------------------------------------ } + +procedure SetFruitState(var fruit : Fruit; state : FruitState); +begin + if state = fruit.state then exit; + fruit.state := state; + fruit.counter := 0; + fruit.value := 0; + ResetAnimationState(fruit.entity.animation); +end; + +function GetPlantRandomLifeTime : word; +const + MINIMUM_TIME = 3000; + STEP_SIZE = 2000; +begin + GetPlantRandomLifeTime := MINIMUM_TIME + + ((1+random(5)) * STEP_SIZE) + - random(STEP_SIZE); +end; + +function SpawnRandomFruit : integer; +{ spawns a new fruit (starting it off as a plant) in any random available + dirt tile on the map. spawning may fail (if a free dirt tile could not + be found randomly). returns the dirtTiles index of the new fruit, or + -1 if spawning failed } +var + idx : integer; +begin + SpawnRandomFruit := -1; + + { find a random spot to spawn a new fruit in } + idx := GetRandomUnusedDirtTileIndex; + if idx = -1 then exit; + + SpawnRandomFruit := idx; + + with dirtTiles[idx] do begin + { important! this marks the dirt tile as being 'used' } + hasFruit := true; + inc(numActiveDirtTiles); + + { zero out the fruit, and then fill in its starter properties } + + MemFill(@fruit, 0, SizeOf(fruit)); + + SetFruitState(fruit, Plant); + + if random(2) = 0 then + fruit.kind := Tomato + else + fruit.kind := Grapes; + + fruit.value := GetPlantRandomLifeTime; + + fruit.isGold := (random(100) < GOLD_FRUIT_SPAWN_CHANCE); + + fruit.entity.position.x := IntToFix(x*16); + fruit.entity.position.y := IntToFix(y*16); + end; +end; + +procedure PopFruitIn(var tile : DirtTile; player : PPlayer); +{ switches any fruit entity located within the given dirt tile into the + 'popped' state, as well as starting up any relevant animations. if + there is no fruit in this tile, or the fruit is not in the 'grown' + state yet, nothing happens. the player passed in here will be the one + given 'credit' for popping the fruit (or if nil, no credit is given to + any player). } +var + fx, fy : integer; +begin + with tile do begin + if not hasFruit then exit; + + case fruit.state of + Plant, Growing: begin + { no score credit for stabbing a fruit plant, or a growing + but not yet full grown fruit. just despawn it. } + hasFruit := false; + dec(numActiveDirtTiles); + + with fruit.entity.position do begin + SpawnPlantSplash(FixToInt(x), FixToInt(y)); + end; + end; + + Grown: begin + { stabbing fully grown fruit } + SetFruitState(fruit, Popped); + with fruit.entity.position do begin + fx := FixToInt(x); + fy := FixToInt(y); + + { if the stabbing player's fruit choice matches the popped + fruit, then give the player score credit } + if fruit.kind = player^.fruitPref then begin + SpawnScoreUp(fx, fy, fruit.kind); + inc(player^.score); + end; + + if fruit.isGold then + PopAllFruit(fruit.kind, player); + + SpawnStabFlash(fx, fy); + end; + end; + end; + end; +end; + +procedure PopAllFruit(kind : FruitKind; player : PPlayer); +var + idx : integer; +begin + for idx := 0 to numDirtTiles-1 do begin + with dirtTiles[idx] do begin + if not hasFruit then continue; + + if (fruit.kind = kind) and (fruit.state = Grown) then begin + PopFruitIn(dirtTiles[idx], player); + end; + end; + end; +end; + +procedure PopFruitAt(x, y : integer; player : PPlayer); +{ switches any fruit located near the given x/y coordinates into the + 'popped' state, assuming that the fruit are already in the 'grown' + state (otherwise, they will not be changed). these x/y coordinates + would normally be the pixel coordinates corresponding to a player's + thumb tack point. the player passed in here will be the one given + 'credit' for popping the fruit (or if nil, no credit is given to + any player). } +var + left, right, top, bottom : integer; + cx, cy : integer; + dirtTile : PDirtTile; +begin + { get the map tile x/y region to check for dirt tiles within } + left := (x - PRICK_RADIUS) div TILE_SIZE; + right := (x + PRICK_RADIUS) div TILE_SIZE; + top := (y - PRICK_RADIUS) div TILE_SIZE; + bottom := (y + PRICK_RADIUS) 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; + + { for all dirt tiles located within this region, pop the fruit + in them } + for cy := top to bottom do begin + for cx := left to right do begin + dirtTile := dirtTileMapping[(cy * SCREEN_MAP_WIDTH) + cx]; + if dirtTile <> nil then begin + PopFruitIn(dirtTile^, player); + end; + end; + end; +end; + +procedure UpdateAllFruit; +{ updates the state of all fruit currently active within dirtTiles } +const + GROW_STEP_TIME = 40; + SPRITE_MAX_SIZE = 16; +var + i, fx, fy : integer; +begin + { periodically spawn more fruit } + if (fruitSpawnTimer >= 1000) + and (numActiveDirtTiles < map.header.maxFruit) then begin + SpawnRandomFruit; + fruitSpawnTimer := 0; + end; + + for i := 0 to numDirtTiles-1 do begin + with dirtTiles[i] do begin + if not hasFruit then continue; + + case fruit.state of + Plant: begin + { count time into the plant has been a plant for 'value' time + at which point it should 'grow' into a fruit } + with fruit do begin + inc(counter, frameTicks); + if counter >= value then begin + SetFruitState(fruit, Growing); + value := 2; + end; + end; + end; + + Growing: begin + { the fruit "grows" by scaling it's size up from zero to it's + normal pixel sprite size. the size increments by 1 every + so often } + with fruit do begin + if value < SPRITE_MAX_SIZE then begin + inc(counter, frameTicks); + if counter >= GROW_STEP_TIME then begin + inc(value); + counter := 0; + end; + end else begin + SetFruitState(fruit, Grown); + end; + end; + end; + + Grown: begin + end; + + Popped: begin + { when the popped "animation" (not really an animation, just + abusing a 1-frame sequence with long delay as a timer) + completes, we can deactivate this dirt tile and fruit } + if fruit.entity.animation.complete then begin + hasFruit := false; + dec(numActiveDirtTiles); + + with fruit.entity.position do begin + fx := FixToInt(x); + fy := FixToInt(y); + end; + + if fruit.kind = Tomato then begin + SpawnTomatoSplash(fx, fy); + + { if the grapes-preference player is nearby this tomato + splash, then spawn an extra tomato splash at their exact + position and afflict them with the 'splashed' debuff } + with grapesPlayer^ do begin + if DoesEntityOverlap(entity, + fx-32, + fy-32, + fx+48, + fy+48) then begin + with entity.position do + SpawnTomatoSplash(FixToInt(x), FixToInt(y)); + splashedDebuffTime := SPLASHED_DEBUFF_TIME; + end; + end; + + end else begin + SpawnGrapesSplash(fx, fy); + + { if the tomato-preference player is nearby this grapes + splash, then spawn an extra grapes splash at their exact + position and afflict them with the 'splashed' debuff } + with tomatoPlayer^ do begin + if DoesEntityOverlap(entity, + fx-32, + fy-32, + fx+48, + fy+48) then begin + with entity.position do + SpawnGrapesSplash(FixToInt(x), FixToInt(y)); + splashedDebuffTime := SPLASHED_DEBUFF_TIME; + end; + end; + end; + + continue; + end; + end; + end; + + with fruit do begin + UpdateAnimation(entity, fruitAnimations[ord(state)]); + end; + end; + end; +end; + +{ ------------------------------------------------------------------------ } + +function GetUnusedParticleIndex : integer; +{ returns the index of the next unused/inactive particle. returns -1 if + there is no free index } +var + i : integer; +begin + GetUnusedParticleIndex := -1; + + for i := 0 to MAX_PARTICLES-1 do begin + if not particles[i].active then begin + GetUnusedParticleIndex := i; + exit; + end; + end; +end; + +function InitNewParticle(x, y : integer) : integer; +var + i : integer; +begin + InitNewParticle := -1; + + i := GetUnusedParticleIndex; + if i = -1 then exit; + + MemFill(@particles[i], 0, SizeOf(Particle)); + with particles[i] do begin + active := true; + with entity do begin + noCollision := true; + position.x := IntToFix(x); + position.y := IntToFix(y); + end; + end; + + InitNewParticle := i; +end; + +function SpawnTomatoSplash(x, y : integer) : integer; +{ spawns a new 'tomato splash' particle at the given coordinates. + returns the index of the spawned particle if successful, or -1 if there + was no free particle index } +var + i : integer; +begin + SpawnTomatoSplash := -1; + + i := InitNewParticle(x, y); + if i = -1 then exit; + + with particles[i] do begin + animation := @tomatoSplashAnimation; + end; + + SpawnTomatoSplash := i; +end; + +function SpawnGrapesSplash(x, y : integer) : integer; +{ spawns a new 'grapes splash' particle at the given coordinates. + returns the index of the spawned particle if successful, or -1 if there + was no free particle index } +var + i : integer; +begin + SpawnGrapesSplash := -1; + + i := InitNewParticle(x, y); + if i = -1 then exit; + + with particles[i] do begin + animation := @grapesSplashAnimation; + end; + + SpawnGrapesSplash := i; +end; + +function SpawnPlantSplash(x, y : integer) : integer; +{ spawns a new 'plant splash' (for when a plant is destroyed) particle at + the given coordinates. returns the index of the spawned particle if + successful, or -1 if there was no free particle index } +var + i : integer; +begin + SpawnPlantSplash := -1; + + i := InitNewParticle(x, y); + if i = -1 then exit; + + with particles[i] do begin + animation := @plantDestroyAnimation; + end; + + SpawnPlantSplash := i; +end; + +function SpawnStabFlash(x, y : integer) : integer; +{ spawns a new 'stab flash' particle at the given coordinates. + returns the index of the spawned particle if successful, or -1 if there + was no free particle index } +var + i : integer; +begin + SpawnStabFlash := -1; + + i := InitNewParticle(x, y); + if i = -1 then exit; + + with particles[i] do begin + animation := @stabFlashAnimation; + end; + + SpawnStabFlash := i; +end; + +function SpawnScoreUp(x, y : integer; kind : FruitKind) : integer; +{ spawns a new '+1' score particle at the given coordinates, for the + specified fruit (affects how it is displayed). + returns the index of the spawned particle if successful, or -1 if there + was no free particle index } +var + i : integer; +begin + SpawnScoreUp := -1; + + i := InitNewParticle(x, y); + if i = -1 then exit; + + with particles[i] do begin + if kind = Tomato then + animation := @tomatoScoreUpAnimation + else + animation := @grapesScoreUpAnimation; + + with entity do begin + velocity.y := SCORE_UP_PARTICLE_SPEED; + end; + end; + + SpawnScoreUp := i; +end; + +function SpawnOw(x, y : integer) : integer; +{ spawns a new 'ow' particle (to indicate a player was stabbed) at the given + coordinates. + returns the index of the spawned particle if successful, or -1 if there + was no free particle index } +var + i : integer; +begin + SpawnOw := -1; + + i := InitNewParticle(x, y); + if i = -1 then exit; + + with particles[i] do begin + animation := @owAnimation; + + with entity do begin + velocity.y := OW_PARTICLE_SPEED; + end; + end; + + SpawnOw := i; +end; + +procedure UpdateAllParticles; +var + i : word; +begin + for i := 0 to MAX_PARTICLES-1 do begin + with particles[i] do begin + if not active then continue; + + MoveEntity(entity); + + if animation <> nil then begin + { particle is a "sprite-animated" particle type. + this means its lifetime is tied to the animation. update it's + animation, and when it is complete, kill the particle } + if entity.animation.complete then + active := false + else + UpdateAnimation(entity, animation^); + + end else begin + { TODO: "pixel" particle types ... } + + end; + end; + end; +end; + +end. + + diff --git a/FRUITPOP.EXE b/FRUITPOP.EXE new file mode 100644 index 0000000..f701eac Binary files /dev/null and b/FRUITPOP.EXE differ diff --git a/FRUITPOP.PAS b/FRUITPOP.PAS new file mode 100644 index 0000000..b4ecd8c --- /dev/null +++ b/FRUITPOP.PAS @@ -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. diff --git a/FRUITSEL.PAS b/FRUITSEL.PAS new file mode 100644 index 0000000..46a14b3 --- /dev/null +++ b/FRUITSEL.PAS @@ -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. diff --git a/GDLIB/FIXEDP.PAS b/GDLIB/FIXEDP.PAS new file mode 100644 index 0000000..e3de53e --- /dev/null +++ b/GDLIB/FIXEDP.PAS @@ -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. diff --git a/GDLIB/GDCLIP.PAS b/GDLIB/GDCLIP.PAS new file mode 100644 index 0000000..0487ee3 --- /dev/null +++ b/GDLIB/GDCLIP.PAS @@ -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. diff --git a/GDLIB/GDEVENTS.PAS b/GDLIB/GDEVENTS.PAS new file mode 100644 index 0000000..a21c4da --- /dev/null +++ b/GDLIB/GDEVENTS.PAS @@ -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. diff --git a/GDLIB/GDGFX.PAS b/GDLIB/GDGFX.PAS new file mode 100644 index 0000000..af576b2 --- /dev/null +++ b/GDLIB/GDGFX.PAS @@ -0,0 +1,2140 @@ +{ GDlib Core VGA mode 13h Graphics routines + Gered King, 2018-2021 } + +{ + TODO list: + - palette loading/saving to binary .pal files + - custom font support, including variable-width fonts + - allowing usage of EMS memory to have extra gfx layers located in EMS + - clip-region stack, with push/pop type api + - blit sprite routine that allows blitting all non-transparent colours + using a single specified solid colour (e.g. for sprite flashing effect) + - translucent/blending colour table mapping and drawing routines + - scaled/rotated blit routines ... ? +} + +{$A+,B-,F-,G+,I-,N+,P-,Q-,R-,S-,T-,V-,X+} + +unit GDGfx; + +interface + +const + MAX_LAYERS = 5; + MAX_EXTRA_LAYERS = 5; + SCREEN_LAYER = 0; + + SCREEN_LEFT = 0; + SCREEN_TOP = 0; + SCREEN_RIGHT = 319; + SCREEN_BOTTOM = 199; + SCREEN_WIDTH = 320; + SCREEN_HEIGHT = 200; + + CHAR_WIDTH = 8; + CHAR_HEIGHT = 8; + + LAYERFLAG_ALIASEDMEM = $1; + + ClipRegionLeft : integer = SCREEN_LEFT; + ClipRegionTop : integer = SCREEN_TOP; + ClipRegionRight : integer = SCREEN_RIGHT; + ClipRegionBottom : integer = SCREEN_BOTTOM; + ClipRegionWidth : integer = SCREEN_WIDTH; + ClipRegionHeight : integer = SCREEN_HEIGHT; + +type + Color = byte; + PColor = ^Color; + + PalResult = (PalNotFound, PalIOError, PalBadFile, PalBadArgs, PalOk); + + Palette = array[0..255,0..2] of byte; + PaletteEntry = array[0..2] of byte; + PPalette = ^Palette; + PPaletteEntry = ^PaletteEntry; + + Pixelbuffer = array[0..63999] of Color; + PPixelbuffer = ^Pixelbuffer; + + BiosFontTable = array[0..255,0..7] of byte; + BiosFontChar = array[0..7] of byte; + BiosFontCharWidths = array[0..255] of byte; + PBiosFontChar = ^BiosFontChar; + + FontResult = (FontNotFound, FontIOError, FontBadFile, FontBadArgs, FontOk); + + Font = record + chars : BiosFontTable; + widths : BiosFontCharWidths; + height : byte; + end; + PFont = ^Font; + + Bitmap = record + Width, Height : word; + Pixels : byte; { take pointer of this to get full pixels mem } + end; + PBitmap = ^Bitmap; + +var + VgaFramebuffer : Pixelbuffer absolute $a000:$0000; + +procedure InitGraphics(layers: integer); +procedure CloseGraphics; +function IsGraphicsInitialized: boolean; +procedure UseLayer(layer: integer); +procedure Cls(color: Color); +procedure Flip(layer: integer); +procedure CopyLayer(layer: integer); +procedure WaitForVsync; +function GetBoundLayerIndex : integer; +function GetBoundLayerSegment : word; +function GetBoundLayerOffset : word; +function GetBoundLayerOffsetAt(x, y: integer) : word; +function GetBoundLayerPointerAt(x, y: integer) : pointer; +procedure SetClipRegion(x1, y1, x2, y2: integer); +procedure ResetClipRegion; +procedure Pset(x, y: integer; color: Color); +procedure Psetf(x, y: integer; color: Color); +function Pget(x, y: integer) : Color; +function Pgetf(x, y: integer) : Color; +procedure Line(x1, y1, x2, y2: integer; color: Color); +procedure Linef(x1, y1, x2, y2: integer; color: Color); +procedure HLine(x1, x2, y: integer; color: Color); +procedure HLinef(x1, x2, y: integer; color: Color); +procedure VLine(x, y1, y2: integer; color: Color); +procedure VLinef(x, y1, y2: integer; color: Color); +procedure Box(x1, y1, x2, y2: integer; color: Color); +procedure Boxf(x1, y1, x2, y2: integer; color: Color); +procedure FilledBox(x1, y1, x2, y2: integer; color: Color); +procedure FilledBoxf(x1, y1, x2, y2: integer; color: Color); +procedure UseFont(font : PFont); +procedure DrawSubString(x, y: integer; color: Color; const text: string; textStart, textEnd: integer); +procedure DrawString(x, y: integer; color: Color; const text: string); +procedure DrawStringf(x, y: integer; color: Color; const text: string); +procedure PrintAt(x, y: integer); +procedure PrintShortInt(value: shortint; color: Color); +procedure PrintInt(value: integer; color: Color); +procedure PrintLongInt(value: longint; color: Color); +procedure PrintByte(value: byte; color: Color); +procedure PrintWord(value: word; color: Color); +procedure PrintReal(value: real; color: Color); +procedure PrintRealFmt(value: real; decimals: integer; color: Color); +procedure PrintSingle(value: single; color: Color); +procedure PrintSingleFmt(value: single; decimals: integer; color: Color); +procedure PrintDouble(value: double; color: Color); +procedure PrintDoubleFmt(value: double; decimals: integer; color: Color); +procedure PrintString(const text: string; color: Color); +procedure AllocBitmap(width, height: word; var bmp: PBitmap); +procedure FreeBitmap(bmp: PBitmap); +procedure GrabBitmap(x, y: integer; width, height: word; bmp: PBitmap); +procedure BlitSubset(srcX, srcY, srcWidth, srcHeight, destX, destY: integer; const bmp: PBitmap); +procedure BlitSubsetf(srcX, srcY, srcWidth, srcHeight, destX, destY: integer; const bmp: PBitmap); +procedure Blit(x, y: integer; const bmp: PBitmap); +procedure Blitf(x, y: integer; const bmp: PBitmap); +procedure BlitSpriteSubset(srcX, srcY, srcWidth, srcHeight, destX, destY: integer; const bmp: PBitmap); +procedure BlitSpriteSubsetf(srcX, srcY, srcWidth, srcHeight, destX, destY: integer; const bmp: PBitmap); +procedure BlitSprite(x, y: integer; const bmp: PBitmap); +procedure BlitSpritef(x, y: integer; const bmp: PBitmap); +procedure SetColor(color, r, g, b: byte); +procedure GetColor(color: byte; var r, g, b: byte); +procedure SetPalette(const pal: PPalette); +procedure GetPalette(pal: PPalette); +function FadeColor(color, r, g, b: byte; step: integer) : boolean; +procedure FadeRangeToColor(colorStart, colorEnd, r, g, b: byte; step: integer); +procedure FadeRangeToPalette(colorStart, colorEnd: byte; const pal: PPalette; step: integer); +function LoadFont(const filename: string; font: PFont) : FontResult; +function LoadPalette(const filename: string; pal: PPalette) : FontResult; + +implementation + +uses GDClip, Toolbox; + +type + GraphicsLayer = record + flags : word; + pixels : PPixelbuffer; + end; + +const + _graphicsInitialized : boolean = false; + +var + _layers : array[0..(MAX_LAYERS+1)] of GraphicsLayer; + _boundLayerIndex : integer; + _boundLayerSeg : word; + _boundLayerOfs : word; + _biosFont : BiosFontTable absolute $ffa6:$000e; + _boundFont : PFont; + _valueString : string[100]; + _currentTextX : integer; + _currentTextY : integer; + _currentTextStartX : integer; + +procedure InitGraphics(layers: integer); +{ initializes vga mode 13h graphics and allocates memory for any requested + layers in addition to the vga framebuffer layer } +var + i : integer; +begin + if _graphicsInitialized then + exit; + if layers > MAX_LAYERS then + RunError(255); + + _layers[SCREEN_LAYER].flags := LAYERFLAG_ALIASEDMEM; + _layers[SCREEN_LAYER].pixels := Ptr($a000,$0); + + for i := 1 to layers do begin + _layers[i].flags := 0; + GetMem(_layers[i].pixels, SizeOf(Pixelbuffer)); + MemFill(_layers[i].pixels, 0, SizeOf(PixelBuffer)); + end; + + { zero out remaining layer info (if there is any leftovers) } + if layers < MAX_LAYERS then begin + for i := (layers+1) to MAX_LAYERS do begin + _layers[i].flags := 0; + _layers[i].pixels := nil; + end; + end; + + ResetClipRegion; + UseLayer(SCREEN_LAYER); + Cls(0); + + asm + mov ax, 13h + int 10h + end; + + _currentTextX := 0; + _currentTextY := 0; + _currentTextStartX := 0; + _boundFont := nil; + _graphicsInitialized := true; +end; + +procedure CloseGraphics; +{ resets the screen mode back to text mode, and frees memory allocated for + any allocated layers } +var + i : integer; +begin + if (not _graphicsInitialized) then + exit; + + UseLayer(0); + + for i := 0 to MAX_LAYERS do begin + if (_layers[i].flags and LAYERFLAG_ALIASEDMEM) = 0 then begin + if _layers[i].pixels <> nil then + FreeMem(_layers[i].pixels, SizeOf(Pixelbuffer)); + end; + _layers[i].flags := 0; + _layers[i].pixels := nil; + end; + + asm + mov ax, 03h + int 10h + end; + + _graphicsInitialized := false; +end; + +function IsGraphicsInitialized: boolean; +begin + IsGraphicsInitialized := _graphicsInitialized; +end; + +procedure UseLayer(layer: integer); +{ switches the active graphics layer } +var + pixelsPtr : pointer; +begin + pixelsPtr := _layers[layer].pixels; + if pixelsPtr = nil then + RunError(255); + + _boundLayerIndex := layer; + _boundLayerSeg := PtrSeg(pixelsPtr); + _boundLayerOfs := PtrOfs(pixelsPtr); +end; + +procedure Cls(color: Color); +{ clears the current bound layer with the specified color } +begin + MemFill(Ptr(_boundLayerSeg, _boundLayerOfs), color, 64000); +end; + +procedure Flip(layer: integer); +{ 'flips' the specified layer onto the vga framebuffer } +var + layerPixelsPtr : pointer; +begin + if layer = SCREEN_LAYER then + exit; + + layerPixelsPtr := _layers[layer].pixels; + if layerPixelsPtr = nil then + RunError(255); + + MemCopy(Ptr($a000, 0), layerPixelsPtr, 64000); +end; + +procedure CopyLayer(layer: integer); +{ copies the entire contents of the specified layer onto the currently + bound layer } +var + layerPixelsPtr : pointer; +begin + if layer = _boundLayerIndex then + exit; + + layerPixelsPtr := _layers[layer].pixels; + if layerPixelsPtr = nil then + RunError(255); + + MemCopy(Ptr(_boundLayerSeg, _boundLayerOfs), layerPixelsPtr, 64000); +end; + +procedure WaitForVsync; +{ blocks until the next v-sync occurs } +assembler; +asm + mov dx, 3dah +@first: + in al, dx + and al, 8 + jnz @first +@second: + in al, dx + and al, 8 + jz @second +end; + +function GetBoundLayerIndex : integer; +{ returns the number/index of the currently bound layer } +begin + GetBoundLayerIndex := _boundLayerIndex; +end; + +function GetBoundLayerSegment : word; +{ returns the address segment of the currently bound layer } +begin + GetBoundLayerSegment := _boundLayerSeg; +end; + +function GetBoundLayerOffset : word; +{ returns the offset of the currently bound layer (this will be the offset + that corresponds with X=0,Y=0 on the layer). } +begin + GetBoundLayerOffset := _boundLayerOfs; +end; + +function GetBoundLayerOffsetAt(x, y: integer) : word; +{ returns the memory offset that the pixel at position x,y is located at + within any of the screen layers } +assembler; +asm + mov ax, y { ax = y * 320 } + mov bx, ax + shl ax, 6 + shl bx, 8 + add ax, bx + + add ax, x { ax = ax + x } + add ax, _boundLayerOfs +end; + +function GetBoundLayerPointerAt(x, y: integer) : pointer; +{ returns a pointer to the pixel at position x,y on the currently bound + layer } +assembler; +asm + mov ax, y { ax = y * 320 } + mov bx, ax + shl ax, 6 + shl bx, 8 + add ax, bx + + add ax, x { ax = ax + x } + + { return pointer in dx:ax (segment:offset) } + add ax, _boundLayerOfs + mov dx, _boundLayerSeg +end; + +function GetBitmapOffsetAt(x, y: integer; const bmp: PBitmap) : word; +{ returns the memory offset that the pixel at position x,y is located at + within the given bitmap } +begin + GetBitmapOffsetAt := (y * bmp^.Width) + x + Ofs(bmp^.Pixels); +end; + +procedure SetClipRegion(x1, y1, x2, y2: integer); +{ changes the current boundaries for all clipped drawing operations. + affects all layers. } +begin + if x1 < SCREEN_LEFT then + ClipRegionLeft := SCREEN_LEFT + else + ClipRegionLeft := x1; + + if y1 < SCREEN_TOP then + ClipRegionTop := SCREEN_TOP + else + ClipRegionTop := y1; + + if x2 > SCREEN_RIGHT then + ClipRegionRight := SCREEN_RIGHT + else + ClipRegionRight := x2; + + if y2 > SCREEN_BOTTOM then + ClipRegionBottom := SCREEN_BOTTOM + else + ClipRegionBottom := y2; + + ClipRegionWidth := ClipRegionRight - ClipRegionLeft + 1; + ClipRegionHeight := ClipRegionBottom - ClipRegionTop + 1; +end; + +procedure ResetClipRegion; +{ resets the current boundaries for all clipped drawing operations to + match the full screen boundaries } +begin + ClipRegionLeft := SCREEN_LEFT; + ClipRegionTop := SCREEN_TOP; + ClipRegionRight := SCREEN_RIGHT; + ClipRegionBottom := SCREEN_BOTTOM; + ClipRegionWidth := SCREEN_WIDTH; + ClipRegionHeight := SCREEN_HEIGHT; +end; + +procedure Pset(x, y: integer; color: Color); +{ draws a pixel on the current layer at x,y using the given color. + nothing is drawn if x,y are out of bounds of the current clipping region } +assembler; +asm + mov ax, x + cmp ax, ClipRegionLeft { off the left edge? } + jl @done + cmp ax, ClipRegionRight { off the right edge? } + jg @done + + mov di, y + cmp di, ClipRegionTop { off the top edge? } + jl @done + cmp di, ClipRegionBottom { off the bottom edge? } + jg @done + + mov bx, di { di = y * 320 + x } + shl di, 6 + shl bx, 8 + add di, bx + add di, ax + add di, _boundLayerOfs + + mov al, color + + mov es, _boundLayerSeg { write pixel to current layer } + mov es:[di], al + +@done: +end; + +procedure Psetf(x, y: integer; color: Color); +{ draws a pixel on the current layer at x,y using the given color. + does not perform any bounds checking. } +assembler; +asm + mov ax, x + mov di, y + + mov bx, di { di = y * 320 + x } + shl di, 6 + shl bx, 8 + add di, bx + add di, ax + add di, _boundLayerOfs + + mov al, color + + mov es, _boundLayerSeg { write pixel to current layer } + mov es:[di], al +end; + +function Pget(x, y: integer) : Color; +{ gets a pixel from the current layer at x,y, returning the color. + returns zero if x,y are out of bounds of the current clipping region } +assembler; +asm + xor ax, ax + + mov cx, x + cmp cx, ClipRegionLeft { off the left edge? } + jl @done + cmp cx, ClipRegionRight { off the right edge? } + jg @done + + mov si, y + cmp si, ClipRegionTop { off the top edge? } + jl @done + cmp si, ClipRegionBottom { off the bottom edge? } + jg @done + + mov bx, si { si = y * 320 + x } + shl si, 6 + shl bx, 8 + add si, bx + add si, cx + add si, _boundLayerOfs + + push ds + + mov ds, _boundLayerSeg { read pixel from current layer } + mov al, ds:[si] + + pop ds + +@done: +end; + +function Pgetf(x, y: integer) : Color; +{ gets a pixel from the current layer at x,y, returning the color. + does not perform any bounds checking. } +assembler; +asm + xor ax, ax + + mov cx, x + mov si, y + + mov bx, si { si = y * 320 + x } + shl si, 6 + shl bx, 8 + add si, bx + add si, cx + add si, _boundLayerOfs + + push ds + + mov ds, _boundLayerSeg { read pixel from current layer } + mov al, ds:[si] + + pop ds +end; + +procedure Line(x1, y1, x2, y2: integer; color: Color); +{ draws a line from x1,y1 to x2,y2. the line is clipped at the edges of the + current clipping region if necessary. } +var + deltaX, deltaY : integer; + deltaXabs, deltaYabs : integer; + deltaXsign, deltaYsign : integer; + x, y, i, dx, dy, loops : integer; + offset : integer; + offsetXinc, offsetYinc : integer; + dest : PColor; +begin + dx := x1; + dy := y1; + deltaX := x2 - x1; + deltaY := y2 - y1; + deltaXabs := Abs(deltaX); + deltaYabs := Abs(deltaY); + deltaXsign := SignInt(deltaX); + deltaYsign := SignInt(deltaY); + x := deltaYabs div 2; + y := deltaYabs div 2; + offsetXinc := deltaXsign; + offsetYinc := deltaYsign * SCREEN_WIDTH; + dest := GetBoundLayerPointerAt(x1, y1); + + if ((dx >= ClipRegionLeft) + and (dy >= ClipRegionTop) + and (dx <= ClipRegionRight) + and (dy <= ClipRegionBottom)) then + dest^ := color; + + if deltaXabs >= deltaYabs then begin + loops := deltaXabs - 1; + for i := 0 to loops do begin + inc(y, deltaYabs); + + if y >= deltaXabs then begin + dec(y, deltaXabs); + inc(dy, deltaYsign); + inc(dest, offsetYinc); + end; + + inc(dx, deltaXsign); + inc(dest, offsetXinc); + + if ((dx >= ClipRegionLeft) + and (dy >= ClipRegionTop) + and (dx <= ClipRegionRight) + and (dy <= ClipRegionBottom)) then + dest^ := color; + end; + + end else begin + loops := deltaYabs - 1; + for i := 0 to loops do begin + inc(x, deltaXabs); + + if x >= deltaYabs then begin + dec(x, deltaYabs); + inc(dx, deltaXsign); + inc(dest, offsetXinc); + end; + + inc(dy, deltaYsign); + inc(dest, offsetYinc); + + if ((dx >= ClipRegionLeft) + and (dy >= ClipRegionTop) + and (dx <= ClipRegionRight) + and (dy <= ClipRegionBottom)) then + dest^ := color; + end; + end; +end; + +procedure Linef(x1, y1, x2, y2: integer; color: Color); +{ draws a line from x1,y1 to x2,y2. no clipping is performed. } +var + deltaX, deltaY : integer; + deltaXabs, deltaYabs : integer; + deltaXsign, deltaYsign : integer; + x, y, i, loops : integer; + offsetXinc, offsetYinc : integer; + dest : PColor; +begin + deltaX := x2 - x1; + deltaY := y2 - y1; + deltaXabs := Abs(deltaX); + deltaYabs := Abs(deltaY); + deltaXsign := SignInt(deltaX); + deltaYsign := SignInt(deltaY); + x := deltaYabs div 2; + y := deltaYabs div 2; + offsetXinc := deltaXsign; + offsetYinc := deltaYsign * SCREEN_WIDTH; + dest := GetBoundLayerPointerAt(x1, y1); + + dest^ := color; + + if deltaXabs >= deltaYabs then begin + loops := deltaXabs - 1; + for i := 0 to loops do begin + inc(y, deltaYabs); + + if y >= deltaXabs then begin + dec(y, deltaXabs); + inc(dest, offsetYinc); + end; + + inc(dest, offsetXinc); + + dest^ := color; + end; + + end else begin + loops := deltaYabs - 1; + for i := 0 to loops do begin + inc(x, deltaXabs); + + if x >= deltaYabs then begin + dec(x, deltaYabs); + inc(dest, offsetXinc); + end; + + inc(dest, offsetYinc); + + dest^ := color; + end; + end; +end; + +procedure HLine(x1, x2, y: integer; color: Color); +{ draws a horizontal line. automatically compensates for incorrect ordering + of the x coordinates and also clips the line to the current clipping + region. } +begin + if x2 < x1 then + SwapInts(x1, x2); + if not ClampToClipRegion(x1, y, x2, y) then + exit; + + HLinef(x1, x2, y, color); +end; + +procedure HLinef(x1, x2, y: integer; color: Color); +{ draws a horizontal line. x1 must be less than x2. no clipping is + performed. } +var + dest : pointer; + length : integer; +begin + dest := GetBoundLayerPointerAt(x1, y); + length := x2 - x1 + 1; + MemFill(dest, color, length); +end; + +procedure VLine(x, y1, y2: integer; color: Color); +{ draws a vertical line. automatically compensates for incorrect ordering + of the y coordinates and also clips the line to the current clipping + region. } +begin + if y2 < y1 then + SwapInts(y1, y2); + if not ClampToClipRegion(x, y1, x, y2) then + exit; + + VLinef(x, y1, y2, color); +end; + +procedure VLinef(x, y1, y2: integer; color: Color); +{ draws a vertical line. y1 must be less than y2. no clipping is + performed. } +var + offs : word; + linesLeft : integer; +begin + offs := GetBoundLayerOffsetAt(x, y1); + linesLeft := y2 - y1 + 1; + + asm + mov cx, linesLeft + test cx, cx { make sure there are > 0 lines to draw } + jz @done + + mov al, color + mov es, _boundLayerSeg + mov di, offs + +@draw: + mov es:[di], al + add di, SCREEN_WIDTH + dec cx + jnz @draw + +@done: + end; +end; + +procedure DrawTwoVerticalLines(leftOffs, rightOffs: word; + color: Color; + height: integer); +assembler; +asm + mov es, _boundLayerSeg + mov si, leftOffs + mov di, rightOffs + mov al, color + mov cx, height + +@draw: + mov es:[si], al + mov es:[di], al + add si, SCREEN_WIDTH + add di, SCREEN_WIDTH + dec cx + jnz @draw + +@done: +end; + +procedure DrawVerticalLine(offs: word; + color: Color; + height: integer); +assembler; +asm + mov es, _boundLayerSeg + mov di, offs + mov al, color + mov cx, height + +@draw: + mov es:[di], al + add di, SCREEN_WIDTH + dec cx + jnz @draw + +@done: +end; + +procedure Box(x1, y1, x2, y2: integer; color: Color); +{ draws an empty box. automatically compensates if coordinate pairs are + swapped so that x1 < x2 and y1 < y2. clips the box to the current clipping + region boundaries. } +var + clippedX1, clippedY1, clippedX2, clippedY2 : integer; + clippedWidth, clippedHeight : integer; + offs, offs1, offs2 : word; +begin + if x2 < x1 then + SwapInts(x1, x2); + if y2 < y1 then + SwapInts(y1, y2); + + clippedX1 := x1; + clippedY1 := y1; + clippedWidth := x2 - x1 + 1; + clippedHeight := y2 - y1 + 1; + + if not ClipToClipRegion(clippedX1, clippedY1, + clippedWidth, clippedHeight) then + exit; + + clippedX2 := clippedX1 + clippedWidth - 1; + clippedY2 := clippedY1 + clippedHeight - 1; + + { top line, only if y1 was within bounds } + if y1 = clippedY1 then begin + offs := GetBoundLayerOffsetAt(clippedX1, clippedY1); + MemFill(Ptr(_boundLayerSeg, offs), color, clippedWidth); + end; + + { bottom line, only if y2 was within bounds } + if y2 = clippedY2 then begin + offs := GetBoundLayerOffsetAt(clippedX1, clippedY2); + MemFill(Ptr(_boundLayerSeg, offs), color, clippedWidth); + end; + + { draw both left and right lines if neither x1 nor x2 were clipped } + if (x1 = clippedX1) and (x2 = clippedX2) then begin + offs1 := GetBoundLayerOffsetAt(clippedX1, clippedY1); + offs2 := GetBoundLayerOffsetAt(clippedX2, clippedY1); + DrawTwoVerticalLines(offs1, offs2, color, clippedHeight); + + { draw left line if x1 was not clipped } + end else if x1 = clippedX1 then begin + offs := GetBoundLayerOffsetAt(clippedX1, clippedY1); + DrawVerticalLine(offs, color, clippedHeight); + + { draw right line if x2 was not clipped } + end else if x2 = clippedX2 then begin + offs := GetBoundLayerOffsetAt(clippedX2, clippedY1); + DrawVerticalLine(offs, color, clippedHeight); + + end; +end; + +procedure Boxf(x1, y1, x2, y2: integer; color: Color); +{ draws an empty box. x1 must be less than x2, and y1 must be less than y2. + no clipping is performed. } +var + offs, offsLeft, offsRight : word; + width, linesLeft : integer; +begin + width := x2 - x1 + 1; + linesLeft := y2 - y1; + offs := GetBoundLayerOffsetAt(x1, y1); + offsLeft := offs; + offsRight := offs + width - 1; + + asm + mov al, color { spread color byte over all of EAX so we can } + mov ah, al { draw 4 pixels at once horizontally. } + db $66; shl ax, 8 { shl eax, 8 } + mov al, ah + db $66; shl ax, 8 { shl eax, 8 } + mov al, ah + + db $66; xor cx, cx { xor ecx, ecx } + mov es, _boundLayerSeg + mov dx, width + mov cx, linesLeft + mov di, offsLeft + mov si, offsRight + + test cx, cx { do we have any vertical height to draw? } + jz @draw_horiz1 { if not, skip to horizontal drawing ... } + +@draw_vert: + { draw both vertical lines } + mov es:[di], al + mov es:[si], al + add di, SCREEN_WIDTH + add si, SCREEN_WIDTH + dec cx + jnz @draw_vert + +@draw_horiz1: + { di will be at (x1,y2) currently. this is the correct location to draw + the bottom horizontal line } + mov cx, dx { cx = number of dwords to draw } + mov bx, cx { bx = remaining number of pixels to draw } + shr cx, 2 + and bx, 3 + + db $f3,$66,$ab { rep stosd - draw dwords } + mov cx, bx + rep stosb { draw remaining pixels } + +@draw_horiz2: + { now draw the top line. reposition to (x1,y1) } + mov di, offsLeft + mov cx, dx { cx = number of dwords to draw } + mov bx, cx { bx = remaining number of pixels to draw } + shr cx, 2 + and bx, 3 + + db $f3,$66,$ab { rep stosd - draw dwords } + mov cx, bx + rep stosb { draw remaining pixels } + +@done: + end; +end; + +procedure FilledBox(x1, y1, x2, y2: integer; color: Color); +{ draws a filled box. automatically compensates if coordinate pairs are + swapped so that x1 < x2 and y1 < y2. clips the box to the current clipping + region boundaries. } +begin + if x2 < x1 then + SwapInts(x1, x2); + if y2 < y1 then + SwapInts(y1, y2); + + if not ClampToClipRegion(x1, y1, x2, y2) then + exit; + + FilledBoxf(x1, y1, x2, y2, color); +end; + +procedure FilledBoxf(x1, y1, x2, y2: integer; color: Color); +{ draws a filled box. x1 must be less than x2, and y1 must be less than y2. + no clipping is performed. } +var + offs : word; + width, linesLeft, remainder : integer; +begin + width := x2 - x1 + 1; + linesLeft := y2 - y1 + 1; + offs := GetBoundLayerOffsetAt(x1, y1); + + asm + mov si, linesLeft + test si, si { stop if there are 0 lines to draw } + jz @nothing_to_draw + + mov al, color { spread color byte over all of EAX so we can } + mov ah, al { draw 4 pixels at once horizontally. } + db $66; shl ax, 8 { shl eax, 8 } + mov al, ah + db $66; shl ax, 8 { shl eax, 8 } + mov al, ah + + mov bx, width + mov di, offs + mov es, _boundLayerSeg + mov dx, SCREEN_WIDTH { dx = y-inc to next line after drawing horiz } + sub dx, bx + + { *** WARNING: no stack/vars access after this! *** } + push bp + mov bp, bx + and bp, 3 { bp = remaining number of pixels to draw } + shr bx, 2 { bx = number of dwords to draw } + + db $66; xor cx, cx { xor ecx, ecx } + + test bp, bp + jz @draw + +@draw_with_remainder: + mov cx, bx + db $f3,$66,$ab { rep stosd - draw dwords } + mov cx, bp + rep stosb { draw remainder pixel } + add di, dx { move to start of next line } + dec si { decrease line counter } + jnz @draw_with_remainder { keep drawing if there are more lines } + jmp @done + +@draw: + mov cx, bx + db $f3,$66,$ab { rep stosd - draw dwords } + add di, dx { move to start of next line } + dec si { decrease line counter } + jnz @draw { keep drawing if there are more lines } + jmp @done + +@done: + pop bp +@nothing_to_draw: + end; +end; + +procedure UseFont(font : PFont); +{ binds the specified font. all subsequent text/string drawing will be + done using this font until this is called again with a different font. + pass nil to revert back to using the standard VGA BIOS font. } +begin + if font = nil then + _boundFont := nil { means to use VGA BIOS font instead } + else + _boundFont := font; +end; + +{ TODO: rewrite this function. it is poopy and sad. } +procedure DrawChar(x, y, drawX, drawY, width, height: integer; + color: Color; + ch: char); +var + dest, fontSrc : word; + cx, cy : integer; + offsetX, offsetY : integer; + destWidth, destHeight : integer; + fontCharMap : PBiosFontChar; + fontCharLine : byte; + pixel : byte; +begin + dest := GetBoundLayerOffsetAt(drawX, drawY); + + if _boundFont <> nil then + fontCharMap := @_boundFont^.chars[Ord(ch), 0] + else + fontCharMap := @_biosFont[Ord(ch), 0]; + + { get offset x,y to start drawing char from (will be in range 0-7) } + offsetX := drawX - x; + offsetY := drawY - y; + destWidth := width + offsetX - 1; + destHeight := height + offsetY - 1; + + { cx,cy are always in "char coordinate space" (that is, 0-7) } + for cy := offsetY to destHeight do begin + fontCharLine := fontCharMap^[cy]; + + for cx := offsetX to destWidth do begin + pixel := ((fontCharLine) and (1 shl ((CHAR_WIDTH - 1) - cx))); + if pixel > 0 then + mem[_boundLayerSeg:(dest + (cx - offsetX))] := color; + end; + + inc(dest, SCREEN_WIDTH); + end; +end; + +procedure DrawSubString(x, y: integer; + color: Color; + const text: string; + textStart, textEnd: integer); +{ draws a sub-string starting from the top-left coordinate (x,y). handles + multi-line strings automatically. the text is clipped to the current + clipping region boundaries as needed. only part of the string is drawn, + as specified by textStart and textEnd (non-inclusive end) } +var + ch : char; + i, currentX, currentY : integer; + width, height, length : integer; + spaceWidth : integer; + clippedX, clippedY : integer; + clippedWidth, clippedHeight : integer; +begin + currentX := x; + currentY := y; + width := CHAR_WIDTH; + + if _boundFont <> nil then begin + height := _boundFont^.height; + spaceWidth := _boundFont^.widths[Ord(' ')]; + end else begin + height := CHAR_HEIGHT; + spaceWidth := CHAR_WIDTH; + end; + + for i := textStart to textEnd do begin + ch := text[i]; + case ch of + { move to next line } + #10: begin + currentX := x; + inc(currentY, height); + end; + #13: begin; + end; + { skip a character ahead, no need to "draw" a space char (empty) } + ' ': inc(currentX, spaceWidth); + else begin + if _boundFont <> nil then + width := _boundFont^.widths[Ord(ch)]; + + clippedX := currentX; + clippedY := currentY; + clippedWidth := width; + clippedHeight := height; + if ClipToClipRegion(clippedX, clippedY, clippedWidth, clippedHeight) then + DrawChar(currentX, currentY, clippedX, clippedY, clippedWidth, clippedHeight, color, ch); + + inc(currentX, width); + end; + end; + end; +end; + +procedure DrawString(x, y: integer; color: Color; const text: string); +{ draws a string starting from the top-left coordinate (x,y). handles + multi-line strings automatically. the text is clipped to the current + clipping region boundaries as needed. } +begin + DrawSubString(x, y, color, text, 1, length(text)); +end; + +procedure DrawStringf(x, y: integer; color: Color; const text: string); +{ draws a string starting from the top-left coordinate (x,y). handles + multi-line strings automatically. no clipping is performed. } +var + ch : char; + i, currentX, currentY : integer; + width, height, len : integer; + spaceWidth : integer; +begin + currentX := x; + currentY := y; + width := CHAR_WIDTH; + len := length(text); + + if _boundFont <> nil then begin + height := _boundFont^.height; + spaceWidth := _boundFont^.widths[Ord(' ')]; + end else begin + height := CHAR_HEIGHT; + spaceWidth := CHAR_WIDTH; + end; + + for i := 1 to len do begin + ch := text[i]; + case ch of + { move to next line } + #10: begin + currentX := x; + inc(currentY, height); + end; + #13: begin; + end; + { skip a character ahead, no need to "draw" a space char (empty) } + ' ': inc(currentX, spaceWidth); + else begin + if _boundFont <> nil then + width := _boundFont^.widths[Ord(ch)]; + + DrawChar(currentX, currentY, currentX, currentY, width, height, color, ch); + inc(currentX, width); + end; + end; + end; +end; + +procedure PrintAt(x, y: integer); +{ sets the text position for subsequent calls to any of the PrintXxx + functions. } +begin + if x > SCREEN_RIGHT then + exit; + if y > SCREEN_BOTTOM then + exit; + + _currentTextX := x; + _currentTextY := y; + _currentTextStartX := x; +end; + +procedure PrintShortInt(value: shortint; color: Color); +{ displays a short-integer value at the current text position. clipping is + performed as necessary. } +begin + Str(value, _valueString); + DrawString(_currentTextX, _currentTextY, color, _valueString); + inc(_currentTextX, length(_valueString) * CHAR_WIDTH); +end; + +procedure PrintInt(value: integer; color: Color); +{ displays an integer value at the current text position. clipping is + performed as necessary. } +begin + Str(value, _valueString); + DrawString(_currentTextX, _currentTextY, color, _valueString); + inc(_currentTextX, length(_valueString) * CHAR_WIDTH); +end; + +procedure PrintLongInt(value: longint; color: Color); +{ displays a long-integer value at the current text position. clipping is + performed as necessary. } +begin + Str(value, _valueString); + DrawString(_currentTextX, _currentTextY, color, _valueString); + inc(_currentTextX, length(_valueString) * CHAR_WIDTH); +end; + +procedure PrintByte(value: byte; color: Color); +{ displays a byte value at the current text position. clipping is performed + as necessary. } +begin + Str(value, _valueString); + DrawString(_currentTextX, _currentTextY, color, _valueString); + inc(_currentTextX, length(_valueString) * CHAR_WIDTH); +end; + +procedure PrintWord(value: word; color: Color); +{ displays a word value at the current text position. clipping is performed + as necessary. } +begin + Str(value, _valueString); + DrawString(_currentTextX, _currentTextY, color, _valueString); + inc(_currentTextX, length(_valueString) * CHAR_WIDTH); +end; + +procedure PrintReal(value: real; color: Color); +{ displays a real value at the current text position. clipping is performed + as necessary. } +begin + Str(value, _valueString); + DrawString(_currentTextX, _currentTextY, color, _valueString); + inc(_currentTextX, length(_valueString) * CHAR_WIDTH); +end; + +procedure PrintRealFmt(value: real; decimals: integer; color: Color); +{ displays a real value using a specific number of decimal points at the + current text position. clipping is performed as necessary. } +begin + Str(value:0:decimals, _valueString); + DrawString(_currentTextX, _currentTextY, color, _valueString); + inc(_currentTextX, length(_valueString) * CHAR_WIDTH); +end; + +procedure PrintSingle(value: single; color: Color); +{ displays a single-precision value at the current text position. clipping + is performed as necessary. } +begin + Str(value, _valueString); + DrawString(_currentTextX, _currentTextY, color, _valueString); + inc(_currentTextX, length(_valueString) * CHAR_WIDTH); +end; + +procedure PrintSingleFmt(value: single; decimals: integer; color: Color); +{ displays a single-precision value using a specific number of decimal points + at the current text position. clipping is performed as necessary. } +begin + Str(value:0:decimals, _valueString); + DrawString(_currentTextX, _currentTextY, color, _valueString); + inc(_currentTextX, length(_valueString) * CHAR_WIDTH); +end; + +procedure PrintDouble(value: double; color: Color); +{ displays a double-precision value at the current text position. clipping + is performed as necessary. } +begin + Str(value, _valueString); + DrawString(_currentTextX, _currentTextY, color, _valueString); + inc(_currentTextX, length(_valueString) * CHAR_WIDTH); +end; + +procedure PrintDoubleFmt(value: double; decimals: integer; color: Color); +{ displays a double-precision value using a specific number of decimal points + at the current text position. clipping is performed as necessary. } +begin + Str(value:0:decimals, _valueString); + DrawString(_currentTextX, _currentTextY, color, _valueString); + inc(_currentTextX, length(_valueString) * CHAR_WIDTH); +end; + +procedure PrintString(const text: string; color: Color); +{ displays a string at the current text position. handles multi-line strings + automatically. clipping is performed as necessary. } +var + ch : char; + i, width, height, len : integer; + spaceWidth : integer; + clippedX, clippedY : integer; + clippedWidth, clippedHeight : integer; +begin + width := CHAR_WIDTH; + len := length(text); + + if _boundFont <> nil then begin + height := _boundFont^.height; + spaceWidth := _boundFont^.widths[Ord(' ')]; + end else begin + height := CHAR_HEIGHT; + spaceWidth := CHAR_WIDTH; + end; + + for i := 1 to len do begin + ch := text[i]; + case ch of + { move to next line } + #10: begin + _currentTextX := _currentTextStartX; + inc(_currentTextY, height); + end; + #13: begin; + end; + { skip a character ahead, no need to "draw" a space char (empty) } + ' ': inc(_currentTextX, spaceWidth); + else begin + if _boundFont <> nil then + width := _boundFont^.widths[Ord(ch)]; + + clippedX := _currentTextX; + clippedY := _currentTextY; + clippedWidth := width; + clippedHeight := height; + if ClipToClipRegion(clippedX, clippedY, clippedWidth, clippedHeight) then + DrawChar(_currentTextX, _currentTextY, clippedX, clippedY, clippedWidth, clippedHeight, color, ch); + + inc(_currentTextX, width); + end; + end; + end; +end; + +procedure AllocBitmap(width, height: word; var bmp: PBitmap); +{ allocates the memory necessary for a bitmap of the specified size } +begin + GetMem(bmp, SizeOf(Bitmap) + (width * height) - 1); + + bmp^.Width := width; + bmp^.Height := height; +end; + +procedure FreeBitmap(bmp: PBitmap); +{ frees previously allocated memory for the given bitmap. the bitmap should + not be used again after this unless re-allocated via AllocBitmap } +begin + if bmp = nil then exit; + FreeMem(bmp, SizeOf(Bitmap) + (bmp^.width * bmp^.height) - 1); +end; + +procedure GrabBitmap(x, y: integer; width, height: word; bmp: PBitmap); +{ copies a region of pixels from the current layer onto the specified bitmap. + the bitmap must have already been allocated, and be large enough to hold + pixel data of the provided dimensions. } +var + line : word; + src, dest : ^byte; +begin + src := GetBoundLayerPointerAt(x, y); + dest := @bmp^.Pixels; + + { TODO: re-write this in inline-assembly } + for line := 0 to (height - 1) do begin + MemCopy(dest, src, width); + inc(src, SCREEN_WIDTH); + inc(dest, width); + end; +end; + + + +{ "Low-Level" Solid Blit routines. These are only really intended to be + called by the main "BlitXXX" functions, but possibly could be used directly + by applications when the utmost speed is required ... + These functions DO NOT perform any argument validation or clipping, etc! } + +procedure LLBlit4(width, height, destYinc, srcYinc: integer; + destOffs, srcSeg, srcOffs: word); +{ blit a block of memory to the given destination. assumes the source + pixels have an exact dword-sized width. } +assembler; +asm + push ds + + mov dx, height { dx = line loop counter } + test dx, dx { stop now if there's zero lines to draw } + jz @done + + db $66; xor cx, cx { xor ecx, ecx } + mov ax, width + mov di, destOffs + mov si, srcOffs + mov es, _boundLayerSeg + mov ds, srcSeg + + shr ax, 2 { ax = number of dwords to draw per line } + +@draw_line: + mov cx, ax + db $f3,$66,$a5 { rep movsd - draw dwords } + + add si, srcYinc { move to next line } + add di, destYinc + dec dx { decrease line loop counter } + jnz @draw_line + +@done: + pop ds +end; + +procedure LLBlit4r(width, height, destYinc, srcYinc: integer; + destOffs, srcSeg, srcOffs: word); +{ blit a block of memory to the given destination. assumes the source + pixels have a width composed of some dword-sized portion PLUS a remainder + of 1-3 pixels at the end. } +assembler; +asm + push ds + + mov dx, height { dx = line loop counter } + test dx, dx { stop now if there's zero lines to draw } + jz @done + + db $66; xor cx, cx { xor ecx, ecx } + mov ax, width + mov di, destOffs + mov si, srcOffs + mov es, _boundLayerSeg + mov ds, srcSeg + + mov bx, ax + shr ax, 2 { ax = number of dwords to draw per line } + and bx, 3 { bx = remaining number of pixels } + +@draw_line: + mov cx, ax + db $f3,$66,$a5 { rep movsd - draw dwords } + mov cx, bx + rep movsb { draw remainder pixels } + + add si, srcYinc { move to next line } + add di, destYinc + dec dx { decrease line loop counter } + jnz @draw_line + +@done: + pop ds +end; + +procedure LLBlitRemainder(width, height, destYinc, srcYinc: integer; + destOffs, srcSeg, srcOffs: word); +{ blit a block of memory to the given destination. will just use a simple + rep movsb for each line. intended only for blits whose width is <= 3. } +assembler; +asm + push ds + + mov dx, height { dx = line loop counter } + test dx, dx { stop now if there's zero lines to draw } + jz @done + + mov ax, width + mov di, destOffs + mov si, srcOffs + mov es, _boundLayerSeg + mov ds, srcSeg + +@draw_line: + mov cx, ax + rep movsb { draw pixels } + + add si, srcYinc { move to next line } + add di, destYinc + dec dx { decrease line loop counter } + jnz @draw_line + +@done: + pop ds +end; + +{ End of Low-Level Solid Blit functions ^^^ } + + + +procedure BlitSubset(srcX, srcY, srcWidth, srcHeight, destX, destY: integer; + const bmp: PBitmap); +{ draws the specified subset/region of the bitmap onto the current layer. the + bitmap is clipped to the current clipping region boundaries. } +begin + if not ClipBlitToClipRegion(srcX, srcY, srcWidth, srcHeight, destX, destY) then + exit; + + BlitSubsetf(srcX, srcY, srcWidth, srcHeight, destX, destY, bmp); +end; + +procedure BlitSubsetf(srcX, srcY, srcWidth, srcHeight, destX, destY: integer; + const bmp: PBitmap); +{ draws the specified subset/region of the bitmap onto the current layer. no + clipping is performed. } +var + srcSeg, srcOffs, destOffs : word; + srcYinc, destYinc : integer; + width4, widthRemainder : integer; +begin + srcSeg := Seg(bmp^.Pixels); + srcOffs := GetBitmapOffsetAt(srcX, srcY, bmp); + destOffs := GetBoundLayerOffsetAt(destX, destY); + + srcYinc := bmp^.Width - srcWidth; + destYinc := SCREEN_WIDTH - srcWidth; + + width4 := srcWidth div 4; + widthRemainder := srcWidth and 3; + + if ((width4 > 0) and (widthRemainder = 0)) then begin + LLBlit4(srcWidth, srcHeight, destYinc, srcYinc, destOffs, srcSeg, srcOffs); + end else if ((width4 > 0) and (widthRemainder > 0)) then begin + LLBlit4r(srcWidth, srcHeight, destYinc, srcYinc, destOffs, srcSeg, srcOffs); + end else begin + LLBlitRemainder(srcWidth, srcHeight, destYinc, srcYinc, destOffs, srcSeg, srcOffs); + end +end; + +procedure Blit(x, y: integer; const bmp: PBitmap); +{ draws the given bitmap onto the current layer. the bitmap is clipped to + the current clipping region boundaries. } +var + srcX, srcY : integer; + srcWidth, srcHeight : integer; +begin + srcX := 0; + srcY := 0; + srcWidth := bmp^.Width; + srcHeight := bmp^.Height; + + if not ClipBlitToClipRegion(srcX, srcY, srcWidth, srcHeight, x, y) then + exit; + + BlitSubsetf(srcX, srcY, srcWidth, srcHeight, x, y, bmp); +end; + +procedure Blitf(x, y: integer; const bmp: PBitmap); +{ draws the given bitmap onto the current layer. no clipping is performed. } +begin + BlitSubsetf(0, 0, bmp^.Width, bmp^.Height, x, y, bmp); +end; + + + +{ "Low-Level" Transparent Blit routines. These are only really intended to be + called by the main "BlitXXX" functions, but possibly could be used directly + by applications when the utmost speed is required ... + These functions DO NOT perform any argument validation or clipping, etc! } + +procedure LLBlitSprite8(width8, height, destYinc, srcYinc: integer; + destOffs, srcSeg, srcOffs: word); +{ blit a block of memory to the given destination, treating colour 0 as the + transparent pixel which will be skipped over. assumes the source pixels + have an exact double-dword-sized width (that is, an exact multiple of 8). } +assembler; +asm + push ds + + mov dx, height { dx = line loop counter } + test dx, dx { stop now if there's zero lines to draw } + jz @done + + mov ax, width8 + mov di, destOffs + mov si, srcOffs + mov es, _boundLayerSeg + mov ds, srcSeg + +@draw_line: + mov cx, ax { cx = number of 8-pixel runs left to draw } + +@draw_px_0: + mov bx, ds:[si+0] { load two pixels } + test bl, bl + jz @draw_px_1 { if it is color 0, skip it } + mov es:[di+0], bl { otherwise, draw it } +@draw_px_1: + test bh, bh { bh has the second loaded pixel } + jz @draw_px_2 + mov es:[di+1], bh +@draw_px_2: + mov bx, ds:[si+2] + test bl, bl + jz @draw_px_3 + mov es:[di+2], bl +@draw_px_3: + test bh, bh + jz @draw_px_4 + mov es:[di+3], bh +@draw_px_4: + mov bx, ds:[si+4] + test bl, bl + jz @draw_px_5 + mov es:[di+4], bl +@draw_px_5: + test bh, bh + jz @draw_px_6 + mov es:[di+5], bh +@draw_px_6: + mov bx, ds:[si+6] + test bl, bl + jz @draw_px_7 + mov es:[di+6], bl +@draw_px_7: + test bh, bh + jz @end_run + mov es:[di+7], bh + +@end_run: + add si, 8 { mov src and dest up 8 pixels } + add di, 8 + dec cx { decrease 8-pixel run loop counter } + jnz @draw_px_0 { if there are still more runs, draw them } + +@end_line: + add si, srcYinc { move to next line } + add di, destYinc + dec dx { decrease line loop counter } + jnz @draw_line + +@done: + pop ds +end; + +procedure LLBlitSprite4(width4, height, destYinc, srcYinc: integer; + destOffs, srcSeg, srcOffs: word); +{ blit a block of memory to the given destination, treating colour 0 as the + transparent pixel which will be skipped over. assumes the source pixels + have an exact dword-sized width (that is, an exact multiple of 4). } +assembler; +asm + push ds + + mov dx, height { dx = line loop counter } + test dx, dx { stop now if there's zero lines to draw } + jz @done + + mov ax, width4 + mov di, destOffs + mov si, srcOffs + mov es, _boundLayerSeg + mov ds, srcSeg + +@draw_line: + mov cx, ax { cx = number of 4-pixel runs left to draw } + +@draw_px_0: + mov bx, ds:[si+0] { load two pixels } + test bl, bl + jz @draw_px_1 { if it is color 0, skip it } + mov es:[di+0], bl { otherwise, draw it } +@draw_px_1: + test bh, bh { bh has the second loaded pixel } + jz @draw_px_2 + mov es:[di+1], bh +@draw_px_2: + mov bx, ds:[si+2] + test bl, bl + jz @draw_px_3 + mov es:[di+2], bl +@draw_px_3: + test bh, bh + jz @end_run + mov es:[di+3], bh + +@end_run: + add si, 4 { mov src and dest up 4 pixels } + add di, 4 + dec cx { decrease 4-pixel run loop counter } + jnz @draw_px_0 { if there are still more runs, draw them } + +@end_line: + add si, srcYinc { move to next line } + add di, destYinc + dec dx { decrease line loop counter } + jnz @draw_line + +@done: + pop ds +end; + +procedure LLBlitSprite8r(width8, height, widthRemainder, destYinc, srcYinc: integer; + destOffs, srcSeg, srcOffs: word); +{ blit a block of memory to the given destination, treating colour 0 as the + transparent pixel which will be skipped over. assumes the source pixels + have a width that is composed of a double-dword-sized section (that is, + some segment that is a multiple of 8) plus some remainder bit that is + <= 7 pixels long. } +assembler; +asm + push ds + + mov dx, height { dx = line loop counter } + test dx, dx { stop now if there's zero lines to draw } + jz @done + + mov ax, width8 + mov di, destOffs + mov si, srcOffs + mov es, _boundLayerSeg + mov ds, srcSeg + +@draw_line: + mov cx, ax { cx = number of 8-pixel runs left to draw } + +@draw_px_0: + mov bx, ds:[si+0] { load two pixels } + test bl, bl + jz @draw_px_1 { if it is color 0, skip it } + mov es:[di+0], bl { otherwise, draw it } +@draw_px_1: + test bh, bh { bh has the second loaded pixel } + jz @draw_px_2 + mov es:[di+1], bh +@draw_px_2: + mov bx, ds:[si+2] + test bl, bl + jz @draw_px_3 + mov es:[di+2], bl +@draw_px_3: + test bh, bh + jz @draw_px_4 + mov es:[di+3], bh +@draw_px_4: + mov bx, ds:[si+4] + test bl, bl + jz @draw_px_5 + mov es:[di+4], bl +@draw_px_5: + test bh, bh + jz @draw_px_6 + mov es:[di+5], bh +@draw_px_6: + mov bx, ds:[si+6] + test bl, bl + jz @draw_px_7 + mov es:[di+6], bl +@draw_px_7: + test bh, bh + jz @end_run + mov es:[di+7], bh + +@end_run: + add si, 8 { mov src and dest up 8 pixels } + add di, 8 + dec cx { decrease 8-pixel run loop counter } + jnz @draw_px_0 { if there are still more runs, draw them } + +@start_remainder_run: { now draw remaining pixels ( <= 7 pixels ) } + mov cx, widthRemainder + +@draw_pixel: + mov bl, ds:[si] { load pixel } + inc si + test bl, bl { if zero, skip to next pixel } + jz @end_pixel + mov es:[di], bl { else, draw the pixel } +@end_pixel: + inc di + dec cx + jnz @draw_pixel + +@end_line: + add si, srcYinc { move to next line } + add di, destYinc + dec dx { decrease line loop counter } + jnz @draw_line + +@done: + pop ds +end; + +procedure LLBlitSprite4r(width4, height, widthRemainder, destYinc, srcYinc: integer; + destOffs, srcSeg, srcOffs: word); +{ blit a block of memory to the given destination, treating colour 0 as the + transparent pixel which will be skipped over. assumes the source pixels + have a width that is composed of a dword-sized section (that is, some + segment that is a multiple of 4) plus some remainder bit that is + <= 3 pixels long. } +assembler; +asm + push ds + + mov dx, height { dx = line loop counter } + test dx, dx { stop now if there's zero lines to draw } + jz @done + + mov ax, width4 + mov di, destOffs + mov si, srcOffs + mov es, _boundLayerSeg + mov ds, srcSeg + +@draw_line: + mov cx, ax { cx = number of 4-pixel runs left to draw } + +@draw_px_0: + mov bx, ds:[si+0] { load two pixels } + test bl, bl + jz @draw_px_1 { if it is color 0, skip it } + mov es:[di+0], bl { otherwise, draw it } +@draw_px_1: + test bh, bh { bh has the second loaded pixel } + jz @draw_px_2 + mov es:[di+1], bh +@draw_px_2: + mov bx, ds:[si+2] + test bl, bl + jz @draw_px_3 + mov es:[di+2], bl +@draw_px_3: + test bh, bh + jz @end_run + mov es:[di+3], bh + +@end_run: + add si, 4 { mov src and dest up 4 pixels } + add di, 4 + dec cx { decrease 4-pixel run loop counter } + jnz @draw_px_0 { if there are still more runs, draw them } + +@start_remainder_run: { now draw remaining pixels ( <= 3 pixels ) } + mov cx, widthRemainder + +@draw_pixel: + mov bl, ds:[si] { load pixel } + inc si + test bl, bl { if zero, skip to next pixel } + jz @end_pixel + mov es:[di], bl { else, draw the pixel } +@end_pixel: + inc di + dec cx + jnz @draw_pixel + +@end_line: + add si, srcYinc { move to next line } + add di, destYinc + dec dx { decrease line loop counter } + jnz @draw_line + +@done: + pop ds +end; + +procedure LLBlitSpriteRemainder(width, height, destYinc, srcYinc: integer; + destOffs, srcSeg, srcOffs: word); +{ blit a block of memory to the given destination, treating colour 0 as the + transparent pixel which will be skipped over. this is the slowest of the + transparent blit routines, that technically can draw at any width, but + is really intended for widths <= 7 only. } +assembler; +asm + push ds + + mov dx, height { dx = line loop counter } + test dx, dx { stop now if there's zero lines to draw } + jz @done + + mov ax, width + mov di, destOffs + mov si, srcOffs + mov es, _boundLayerSeg + mov ds, srcSeg + +@draw_line: + mov cx, ax { cx = number of pixels to draw } + +@draw_pixel: + mov bl, ds:[si] { load pixel } + inc si + test bl, bl { if zero, skip to next pixel } + jz @end_pixel + mov es:[di], bl { else, draw the pixel } +@end_pixel: + inc di + dec cx + jnz @draw_pixel { loop while there's still pixels left } + +@end_line: + add si, srcYinc { move to next line } + add di, destYinc + dec dx { decrease line loop counter } + jnz @draw_line + +@done: + pop ds +end; + +{ End of Low-Level Transparent Blit functions ^^^ } + + + +procedure BlitSpriteSubset(srcX, srcY, srcWidth, srcHeight, destX, destY: integer; + const bmp: PBitmap); +{ draws the specified subset/region of the given bitmap onto the current + layer, ignoring color 0 (treated as transparent). the bitmap is clipped to + the current clipping region boundaries. } +begin + if not ClipBlitToClipRegion(srcX, srcY, srcWidth, srcHeight, destX, destY) then + exit; + + BlitSpriteSubsetf(srcX, srcY, srcWidth, srcHeight, destX, destY, bmp); +end; + +procedure BlitSpriteSubsetf(srcX, srcY, srcWidth, srcHeight, destX, destY: integer; + const bmp: PBitmap); +{ draws the specified subset/region of the given bitmap onto the current + layer, ignoring color 0 (treated as transparent). no clipping is + performed. } +var + srcSeg, srcOffs, destOffs : word; + srcYinc, destYinc : integer; + width4, widthRemainder : integer; +begin + srcSeg := Seg(bmp^.Pixels); + srcOffs := GetBitmapOffsetAt(srcX, srcY, bmp); + destOffs := GetBoundLayerOffsetAt(destX, destY); + + srcYinc := bmp^.Width - srcWidth; + destYinc := SCREEN_WIDTH - srcWidth; + + width4 := srcWidth div 4; + widthRemainder := srcWidth and 3; + + if (width4 > 0) and (widthRemainder = 0) then begin + if ((width4 and 1) = 0) then begin + { width is actually an even multiple of 8! } + LLBlitSprite8(width4 div 2, srcHeight, destYinc, srcYinc, destOffs, srcSeg, srcOffs); + end else begin + { width is a multiple of 4 (no remainder) } + LLBlitSprite4(width4, srcHeight, destYinc, srcYinc, destOffs, srcSeg, srcOffs); + end; + + end else if (width4 > 0) and (widthRemainder > 0) then begin + if ((width4 and 1) = 0) then begin + { width is mostly made up of an even multiple of 8. but there is also + a small remainder } + LLBlitSprite8r(width4 div 2, srcHeight, widthRemainder, destYinc, srcYinc, destOffs, srcSeg, srcOffs); + end else begin + { width is >= 4 with a remainder } + LLBlitSprite4r(width4, srcHeight, widthRemainder, destYinc, srcYinc, destOffs, srcSeg, srcOffs); + end; + + end else begin + { width is <= 3 } + LLBlitSpriteRemainder(widthRemainder, srcHeight, destYinc, srcYinc, destOffs, srcSeg, srcOffs); + end; +end; + +procedure BlitSprite(x, y: integer; const bmp: PBitmap); +{ draws the given bitmap onto the current layer, ignoring color 0 (treated + as transparent). the bitmap is clipped to the current clipping region + boundaries. } +var + srcX, srcY : integer; + srcWidth, srcHeight : integer; +begin + srcX := 0; + srcY := 0; + srcWidth := bmp^.Width; + srcHeight := bmp^.Height; + + if not ClipBlitToClipRegion(srcX, srcY, srcWidth, srcHeight, x, y) then + exit; + + BlitSpriteSubsetf(srcX, srcY, srcWidth, srcHeight, x, y, bmp); +end; + +procedure BlitSpritef(x, y: integer; const bmp: PBitmap); +{ draws the given bitmap onto the current layer, ignoring color 0 (treated + as transparent). no clipping is performed. } +begin + BlitSpriteSubsetf(0, 0, bmp^.Width, bmp^.Height, x, y, bmp); +end; + +procedure SetColor(color, r, g, b: byte); +{ changes the VGA color palette for the color specified } +begin + port[$3c6] := $ff; + port[$3c8] := color; + port[$3c9] := r; + port[$3c9] := g; + port[$3c9] := b; +end; + +procedure GetColor(color: byte; var r, g, b: byte); +{ reads the current VGA color palette RGB values for the color specified } +begin + port[$3c6] := $ff; + port[$3c7] := color; + r := port[$3c9]; + g := port[$3c9]; + b := port[$3c9]; +end; + +procedure SetPalette(const pal: PPalette); +{ sets the current VGA color palette to the given one } +var + i : integer; +begin + for i := 0 to 255 do begin + SetColor(i, pal^[i, 0], pal^[i, 1], pal^[i, 2]); + end; +end; + +procedure GetPalette(pal: PPalette); +{ reads the current VGA color palette, storing all RGB values in the + provided Palette structure } +var + i : integer; +begin + for i := 0 to 255 do begin + GetColor(i, pal^[i, 0], pal^[i, 1], pal^[i, 2]); + end; +end; + +function FadeColor(color, r, g, b: byte; step: integer) : boolean; +{ fades (in/out) the specified color towards the given RGB values by 'step' + amount. returns true if the color's RGB values have reached the target + RGB values, false otherwise. } +var + red, green, blue : byte; + diffR, diffG, diffB : byte; + modified : boolean; +begin + modified := false; + + GetColor(color, red, green, blue); + + if red <> r then begin + modified := true; + diffR := Abs(red - r); + if red > r then + dec(red, Min(step, diffR)) + else + inc(red, Min(step, diffR)); + end; + + if green <> g then begin + modified := true; + diffG := Abs(green - g); + if green > g then + dec(green, Min(step, diffG)) + else + inc(green, Min(step, diffG)); + end; + + if blue <> b then begin + modified := true; + diffB := Abs(blue - b); + if blue > b then + dec(blue, Min(step, diffB)) + else + inc(blue, Min(step, diffB)); + end; + + if modified then + SetColor(color, red, green, blue); + + FadeColor := ((red = r) and (green = g) and (blue = b)); +end; + +procedure FadeRangeToColor(colorStart, colorEnd, r, g, b: byte; + step: integer); +{ fades a range of colors in the current VGA color palette towards the + given RGB values. blocks, looping until the fade is complete. } +var + i : integer; + done : boolean; +begin + done := false; + step := Abs(step); + + while not done do begin + done := true; + WaitForVsync; + for i := colorStart to colorEnd do begin + if not FadeColor(i, r, g, b, step) then + done := false; + end; + end; +end; + +procedure FadeRangeToPalette(colorStart, colorEnd: byte; + const pal: PPalette; + step: integer); +{ fades a range of colors in the current VGA color palette towards the + given color palette. blocks, looping until the fade is complete. } +var + i : integer; + done : boolean; +begin + done := false; + step := Abs(step); + + while not done do begin + done := true; + WaitForVsync; + for i := colorStart to colorEnd do begin + if not FadeColor(i, pal^[i, 0], pal^[i, 1], pal^[i, 2], step) then + done := false; + end; + end; +end; + +function LoadFont(const filename: string; font: PFont) : FontResult; +{ loads a font from the given file, storing it in the Font instance + provided. returns FontOk on success. } +var + f : file; + x : integer; +label ioError; +begin + if font = nil then begin + LoadFont := FontBadArgs; + exit; + end; + + Assign(f, filename); + + Reset(f, 1); + if IOResult <> 0 then begin + Close(f); + x := IOResult; { clear i/o error flag } + LoadFont := FontNotFound; + exit; + end; + + { this font format is the same as the one DirectQB uses. it is a simple + format that i think works pretty well, so why not re-use it here ... } + + with font^ do begin + { standard BIOS-like format list of full ASCII 0-255 characters. + 8-bytes per character } + BlockRead(f, chars, SizeOf(BiosFontTable)); + if IOResult <> 0 then goto ioError; + + { 255 bytes, each byte representing the width of each ASCII character } + BlockRead(f, widths, SizeOf(BiosFontCharWidths)); + if IOResult <> 0 then goto ioError; + + { single byte, the global character height. that is, this is the max + height of any of the 256 ASCII characters in this font. will be <= 8 } + BlockRead(f, height, 1); + if IOResult <> 0 then goto ioError; + end; + + Close(f); + x := IOResult; { clear i/o error flag (just in case) } + LoadFont := FontOk; + exit; + +ioError: + Close(f); + x := IOResult; { clear i/o error flag } + LoadFont := FontIOError; +end; + +function LoadPalette(const filename: string; pal: PPalette) : FontResult; +begin +end; + +begin + if Test8086 < 2 then begin + writeln('The GDGFX unit requires a 386 cpu or higher!'); + halt; + end; +end. diff --git a/GDLIB/GDIFF.PAS b/GDLIB/GDIFF.PAS new file mode 100644 index 0000000..b4004af --- /dev/null +++ b/GDLIB/GDIFF.PAS @@ -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. diff --git a/GDLIB/GDKEYBRD.PAS b/GDLIB/GDKEYBRD.PAS new file mode 100644 index 0000000..7ef74f8 --- /dev/null +++ b/GDLIB/GDKEYBRD.PAS @@ -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. diff --git a/GDLIB/GDKEYCHR.PAS b/GDLIB/GDKEYCHR.PAS new file mode 100644 index 0000000..ce5158f --- /dev/null +++ b/GDLIB/GDKEYCHR.PAS @@ -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. diff --git a/GDLIB/GDMOUSE.PAS b/GDLIB/GDMOUSE.PAS new file mode 100644 index 0000000..8336074 --- /dev/null +++ b/GDLIB/GDMOUSE.PAS @@ -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. diff --git a/GDLIB/GDPCX.PAS b/GDLIB/GDPCX.PAS new file mode 100644 index 0000000..3db445e --- /dev/null +++ b/GDLIB/GDPCX.PAS @@ -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. diff --git a/GDLIB/GDTIMER.PAS b/GDLIB/GDTIMER.PAS new file mode 100644 index 0000000..0032767 --- /dev/null +++ b/GDLIB/GDTIMER.PAS @@ -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. diff --git a/GDLIB/MATH.PAS b/GDLIB/MATH.PAS new file mode 100644 index 0000000..d55becf --- /dev/null +++ b/GDLIB/MATH.PAS @@ -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. diff --git a/GDLIB/MATHFP.PAS b/GDLIB/MATHFP.PAS new file mode 100644 index 0000000..06a08b2 --- /dev/null +++ b/GDLIB/MATHFP.PAS @@ -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. + diff --git a/GDLIB/TOOLBOX.PAS b/GDLIB/TOOLBOX.PAS new file mode 100644 index 0000000..49223f2 --- /dev/null +++ b/GDLIB/TOOLBOX.PAS @@ -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. diff --git a/HELP.PAS b/HELP.PAS new file mode 100644 index 0000000..bf1bc4e --- /dev/null +++ b/HELP.PAS @@ -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. diff --git a/IMAGES.LBM b/IMAGES.LBM new file mode 100644 index 0000000..bbe607a Binary files /dev/null and b/IMAGES.LBM differ diff --git a/LEVELSEL.PAS b/LEVELSEL.PAS new file mode 100644 index 0000000..0e23f8f --- /dev/null +++ b/LEVELSEL.PAS @@ -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. diff --git a/MAINMENU.PAS b/MAINMENU.PAS new file mode 100644 index 0000000..1e75e4e --- /dev/null +++ b/MAINMENU.PAS @@ -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. diff --git a/MAPEDIT.PAS b/MAPEDIT.PAS new file mode 100644 index 0000000..eb20814 --- /dev/null +++ b/MAPEDIT.PAS @@ -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. \ No newline at end of file diff --git a/MAPS.PAS b/MAPS.PAS new file mode 100644 index 0000000..e4ea8db --- /dev/null +++ b/MAPS.PAS @@ -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. diff --git a/MATCH.PAS b/MATCH.PAS new file mode 100644 index 0000000..6322a2b --- /dev/null +++ b/MATCH.PAS @@ -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. diff --git a/RESULTS.PAS b/RESULTS.PAS new file mode 100644 index 0000000..ad7fa17 --- /dev/null +++ b/RESULTS.PAS @@ -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. diff --git a/SHARED.PAS b/SHARED.PAS new file mode 100644 index 0000000..13ea1f4 --- /dev/null +++ b/SHARED.PAS @@ -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. diff --git a/SIMPLE.MAP b/SIMPLE.MAP new file mode 100644 index 0000000..819e7e1 Binary files /dev/null and b/SIMPLE.MAP differ diff --git a/SMALL.MAP b/SMALL.MAP new file mode 100644 index 0000000..854be60 Binary files /dev/null and b/SMALL.MAP differ diff --git a/TEST.MAP b/TEST.MAP new file mode 100644 index 0000000..86a01b7 Binary files /dev/null and b/TEST.MAP differ diff --git a/TILES.LBM b/TILES.LBM new file mode 100644 index 0000000..daa7ca7 Binary files /dev/null and b/TILES.LBM differ