unit Tiles;

{

{$I SETTINGS.INC}

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

Menus, ExtCtrls, ComCtrls, StdCtrls, Grids, jpeg, ToolWin, Buttons, SZPCX;

const

TRANS_COLOR : Integer = $FF + $00 * $100 + $FF * $10000;

TRANS_COLOR_REPLACEMENT : Integer = $FF + $04 * $100 + $FF * $10000;

SPECIAL_COLOR = $F5 + $55 * $100 + $CD * $10000;

SPECIAL_COLOR1 = $01 + $02 * $100 + $03 * $10000;

SPECIAL_COLOR2 = $FE + $FD * $100 + $FC * $10000;

const

MIRROR_MASK = $8000;

UPS_MASK = $4000;

ROTATE_MASK = $2000;

TILE_MASK = $1FFF;

type

RGBInt = array[0..2] of Byte;

type

OldMapCellRec =

record

Back,

Mid,

Front: SmallInt;

MapCode: Byte;

Bounds: Byte;

end;

{

MapCellRec =

record

Back,

Mid,

Front: SmallInt;

MapCode: Byte;

Bounds: ShortInt;

Tag: SmallInt;

end;

type

aaMapCellRec = array of array of MapCellRec;

type

LayerMapPtr = ^LayerMap;

LayerMap =

record

Id: string;

Map: aaMapCellRec;

fx,

fy: string;

SkipExport: Boolean; // 2.2

end;

type

MapSetPtr = ^MapSet;

MapSet =

record

aMaps: array of LayerMap;

CurMap: Integer;

end;

type

RefreshDataRec =

record

OrgFilename: string;

OrgTransX, OrgTransY: Integer;

OrgTransList: array of Integer;

OrgSkipX, OrgSkipY,

OrgSkipW, OrgSkipH: Integer;

OrgReadBounds: Boolean;

OrgRemoveDuplicates: Boolean;

end;

type

TileBitmapRec =

record

W, H: Integer;

Trans: Integer;

TileCount: Integer;

TileBitmap: TBitmap;

Bounds: array of Integer;

Maps: MapSet;

Clip: MapSet;

Seq: MapSet;

BackGr: Integer;

Current: Integer;

Filename: string;

mcr: MapCellRec;

BackMidFront: Integer; { -1, 0, 1 }

LastScale: Integer;

Initialized: Boolean;

Counter: Integer;

PaletteNumber: Integer; // 2.0

Overlap: Integer; // 2.0

RefreshData: RefreshDataRec; // 2.0

SkipExport: Boolean; // 2.2

OffsetX,

OffsetY: array of Integer; // 2.4

LastW, LastH: Integer; // 2.5

LastExportW, LastExportH: Integer; // 3.0

LastExportTransX, LastExportTransY: Integer; // 3.0

end;

var

DebugStr: string;

function FindMapName (var tbr: TileBitmapRec; MapName: string): Integer; { -1: not found }

procedure SetMapSize (var map: aaMapCellRec; W, H: Integer);

function NewMap (var tbr: TileBitmapRec; MapName: string; MapW, MapH: Integer): Boolean;

function SelectMap (var tbr: TileBitmapRec; MapName: string): LayerMapPtr;

function NewClipMap (var tbr: TileBitmapRec; MapW, MapH: Integer): Boolean;

function SelectClipMap (var tbr: TileBitmapRec; N: Integer): LayerMapPtr;

procedure RemoveClip (var tbr: TileBitmapRec; N: Integer);

procedure RemoveCurrentMap (var tbr: TileBitmapRec);

procedure ClearMCR (var mcr: MapCellRec);

function EmptyMCR (var mcr: MapCellRec): Boolean;

function NewSeqMap (var tbr: TileBitmapRec; MapW, MapH: Integer): Boolean;

function SelectSeqMap (var tbr: TileBitmapRec; N: Integer): LayerMapPtr;

procedure RemoveSeq (var tbr: TileBitmapRec; N: Integer);

function AddRect (TR1, TR2: TRect): TRect;

function MakeRect (X, Y, W, H: Integer): TRect;

function Inside (X, Y: Integer; R: TRect): Boolean;

procedure ExtendArea (var R: TRect; X, Y: Integer);

function MakeArea (X1, Y1, X2, Y2: Integer): TRect;

function CreateNewTBR (TileWidth, TileHeight: Integer): TileBitmapRec;

procedure FreeTBR (var tbr: TileBitmapRec);

function ReadTileBitmap (Filename: string;

BlockWidth, BlockHeight: Integer;

TransX, TransY: Integer;

const TransList: array of Integer;

SkipX, SkipY, SkipW, SkipH: Integer;

var ProgressBar: TProgressBar;

ReadBounds: Boolean;

RemoveDuplicates: Boolean;

bRefresh: Boolean;

tbr: TileBitmapRec): TileBitmapRec;

function WriteTileBitmap (Filename: string;

MaxWidth: Integer;

TransColor,

EdgeColor: Integer;

BetweenX, BetweenY, EdgeX, EdgeY: Integer;

var tbr: TileBitmapRec;

var ProgressBar: TProgressBar;

TransRightBottom,

StoreBounds: Boolean;

PixelFormat: Integer): Boolean;

function CreateNewTile (var tbr: TileBitmapRec): Boolean;

function RemoveTile (var tbr: TileBitmapRec): Boolean;

function CountTileUsed (var tbr: TileBitmapRec): Integer;

function MoveLeft (var tbr: TileBitmapRec; upd: Boolean): Boolean;

function MoveRight (var tbr: TileBitmapRec; upd: Boolean): Boolean;

function InsertNewTile (var tbr: TileBitmapRec; MultEmpty: Boolean): Boolean;

function RemoveDuplicates (var tbr: TileBitmapRec;

var ProgressBar: TProgressBar): Boolean;

procedure SetBound (var tbr: TileBitmapRec; NewBound: Integer);

function GetBound (var tbr: TileBitmapRec; n: Integer): Integer;

function HasNoTiles (var tbr: TileBitmapRec): Boolean;

function CopyTiles (var src: TileBitmapRec;

var dst: TileBitmapRec;

SrcStart, SrcCount: Integer;

DstStart: Integer;

Overwrite,

Stretch,

UseScaler,

CopyBounds,

Same: Boolean;

ProgressBar: TProgressBar): Integer;

function ReadTBR (var F: File;

var ID: string;

var TBR: TileBitmapRec;

var Unknown: Boolean): Boolean;

function SaveTBR (var F: File;

ID: string;

var TBR: TileBitmapRec): Boolean;

const

AllowMultEmptyTiles: Boolean = FALSE;

procedure WriteBitmapToPNGFile (OutputFilename: string; Bitmap: TBitmap; TransparentColor: Integer);

procedure ReadBitmapFromPNGFile (InputFilename: string; Bitmap: TBitmap);

uses

PNGImage;

procedure WriteBitmapToPNGFile (OutputFilename: string; Bitmap: TBitmap; TransparentColor: Integer);

var

png: TPngObject;

i, j: Integer;

begin

png := TPngObject.Create ();

png.AssignHandle(Bitmap.Handle, True, TransparentColor);

png.CreateAlpha ();

png.SaveToFile (OutputFilename);

png.Free;

end;

procedure ReadBitmapFromPNGFile (InputFilename: string; Bitmap: TBitmap);

var

png: TPngObject;

begin

png := TPngObject.Create ();

png.AssignHandle(Bitmap.Handle, png.TransparentColor <> clNone, png.TransparentColor);

png.Free;

end;

uses

PNGUnit;

procedure WriteBitmapToPNGFile (OutputFilename: string; Bitmap: TBitmap; TransparentColor: Integer);

begin

PNGUnit.WriteBitmapToPNGFile (OutputFilename, Bitmap, TransparentColor);

end;

procedure ReadBitmapFromPNGFile (InputFilename: string; Bitmap: TBitmap);

begin

PNGUnit.ReadBitmapFromPngFile (InputFilename, Bitmap)

end;

procedure Msg (s: string);

begin

MessageDlg (s, mtInformation, [mbOk], 0);

end;

type

TMapUpdate = (muInsert,

muDelete,

muSwap,

muReplace,

muRemoveSeq,

muCount);

procedure UpdateMaps (var tbr: TileBitmapRec;

mu: TMapUpdate;

data1, data2: Integer);

procedure UpdateTile (var tile: SmallInt);

var

i: Integer;

begin

if Tile <> -1 then

begin

i := Tile and (not TILE_MASK);

Tile := Tile and TILE_MASK;

case mu of

muInsert:

if Tile >= data1 then

Inc (Tile);

muDelete:

if Tile = data1 then

Tile := -1

else

if Tile > data1 then

Dec (Tile);

muSwap:

if Tile = data1 then

Tile := data2

else

if Tile = data2 then

Tile := data1;

muReplace:

if Tile = data1 then

Tile := data2;

muCount:

if Tile = data1 then

Inc (tbr.Counter);

end;

if Tile <> -1 then

Tile := Tile or i;

end;

end;

procedure UpdateMCR (var mcr: MapCellRec);

begin

with mcr do

case mu of

muRemoveSeq:

if Bounds and $40 <> 0 then

begin

if (Back = -1) and (Mid = -1) and (Front = -1) then

if MapCode = data1 then

begin

Bounds := 0;

MapCode := 0;

end

else

if MapCode > data1 then

Dec (MapCode);

end;

else

begin

UpdateTile (Back);

UpdateTile (Mid);

UpdateTile (Front);

end;

end;

end;

var

i, j, k: Integer;

begin

with tbr.Maps do

for k := 0 to Length (aMaps) - 1 do

for j := 0 to Length (aMaps[k].Map) - 1 do

for i := 0 to Length (aMaps[k].Map[j]) - 1 do

UpdateMCR (aMaps[k].Map[j, i]);

with tbr.Clip do

for k := 0 to Length (aMaps) - 1 do

for j := 0 to Length (aMaps[k].Map) - 1 do

for i := 0 to Length (aMaps[k].Map[j]) - 1 do

UpdateMCR (aMaps[k].Map[j, i]);

with tbr.Seq do

for k := 0 to Length (aMaps) - 1 do

for j := 0 to Length (aMaps[k].Map) - 1 do

for i := 0 to Length (aMaps[k].Map[j]) - 1 do

UpdateMCR (aMaps[k].Map[j, i]);

if mu <> muCount then // bug fix

UpdateMCR (tbr.mcr);

end;

function FindMapName (var tbr: TileBitmapRec; MapName: string): Integer;

var

i: Integer;

begin

Result := -1;

with tbr.Maps do

for i := 0 to Length (aMaps) - 1 do

if aMaps[i].Id = MapName then

Result := i;

end;

procedure SetMapSize (var map: aaMapCellRec; W, H: Integer);

var

i, j, k, l: Integer;

begin

l := Length (map);

for j := H to l - 1 do

SetLength (map[j], 0);

SetLength (map, H);

for j := 0 to H - 1 do

begin

k := Length (map[j]);

SetLength (map[j], W);

for i := k to Length (map[j]) - 1 do

ClearMCR (map[j, i]);

end;

end;

function NewMap (var tbr: TileBitmapRec; MapName: string; MapW, MapH: Integer): Boolean;

begin

with tbr do

with Maps do

begin

CurMap := Length (aMaps);

SetLength (aMaps, CurMap + 1);

with aMaps[CurMap] do

begin

Id := MapName;

SetMapSize (Map, MapW, MapH);

fx := 'x';

fy := 'y';

SkipExport := FALSE; // 2.2

end;

end;

NewMap := TRUE;

end;

function SelectMap (var tbr: TileBitmapRec; MapName: string): LayerMapPtr;

var

i: Integer;

begin

Result := nil;

with tbr.Maps do

for i := 0 to Length (aMaps) - 1 do

if aMaps[i].Id = MapName then

begin

Result := @aMaps[i];

CurMap := i;

end;

end;

function NewClipMap (var tbr: TileBitmapRec; MapW, MapH: Integer): Boolean;

begin

with tbr do

with Clip do

begin

CurMap := Length (aMaps);

SetLength (aMaps, CurMap + 1);

with aMaps[CurMap] do

SetMapSize (Map, MapW, MapH);

end;

NewClipMap := TRUE;

end;

function SelectClipMap (var tbr: TileBitmapRec; N: Integer): LayerMapPtr;

begin

with tbr.Clip do

if N <= Length (aMaps) - 1 then

begin

Result := @aMaps[N];

CurMap := N;

end

else

Result := nil;

end;

procedure RemoveClip (var tbr: TileBitmapRec; N: Integer);

var

i: Integer;

begin

with tbr do

if N < Length (tbr.Clip.aMaps) then

with tbr.Clip do

begin

SetMapSize (aMaps[N].Map, 0, 0);

for i := N + 1 to Length (aMaps) - 1 do

aMaps[i - 1] := aMaps[i];

SetLength (aMaps, Length (aMaps) - 1);

end;

end;

procedure ClearMCR (var mcr: MapCellRec);

begin

with mcr do

begin

Back := -1;

Mid := -1;

Front := -1;

MapCode := 0;

Bounds := 0;

end;

end;

function EmptyMCR (var mcr: MapCellRec): Boolean;

begin

with mcr do

EmptyMCR := (Back = -1) and (Mid = -1) and (Front = -1) and

(MapCode = 0) and (Bounds = 0);

end;

procedure RemoveCurrentMap (var tbr: TileBitmapRec);

var

i: Integer;

begin

with tbr do

with tbr.Maps do

begin

SetMapSize (aMaps[CurMap].Map, 0, 0);

for i := CurMap + 1 to Length (aMaps) - 1 do

aMaps[i - 1] := aMaps[i];

SetLength (aMaps, Length (aMaps) - 1);

end;

end;

function NewSeqMap (var tbr: TileBitmapRec; MapW, MapH: Integer): Boolean;

begin

with tbr do

with Seq do

begin

CurMap := Length (aMaps);

SetLength (aMaps, CurMap + 1);

with aMaps[CurMap] do

SetMapSize (Map, MapW, MapH);

end;

NewSeqMap := TRUE;

end;

function SelectSeqMap (var tbr: TileBitmapRec; N: Integer): LayerMapPtr;

begin

with tbr.Seq do

if N <= Length (aMaps) - 1 then

begin

Result := @aMaps[N];

CurMap := N;

end

else

Result := nil;

end;

procedure RemoveSeq (var tbr: TileBitmapRec; N: Integer);

var

i: Integer;

begin

with tbr do

if N < Length (tbr.Seq.aMaps) then

with tbr.Seq do

begin

UpdateMaps (tbr, muRemoveSeq, N, 0);

SetMapSize (aMaps[N].Map, 0, 0);

for i := N + 1 to Length (aMaps) - 1 do

aMaps[i - 1] := aMaps[i];

SetLength (aMaps, Length (aMaps) - 1);

end;

end;

function MakeRect (X, Y, W, H: Integer): TRect;

begin

MakeRect := Rect (X, Y, X + W, Y + H);

end;

function AddRect (TR1, TR2: TRect): TRect;

begin

AddRect := Rect (TR1.Left + TR2.Left,

TR1.Top + TR2.Top,

TR1.Right + TR2.Right,

TR1.Bottom + TR2.Bottom);

end;

function Inside (X, Y: Integer; R: TRect): Boolean;

begin

Inside := (X >= R.Left) and (X <= R.Right) and

(Y >= R.Top) and (Y <= R.Bottom);

end;

procedure ExtendArea (var R: TRect; X, Y: Integer);

begin

if X < R.Left then

R.Left := X;

if Y < R.Top then

R.Top := Y;

if X > R.Right then

R.Right := X;

if Y > R.Bottom then

R.Bottom := Y;

end;

function MakeArea (X1, Y1, X2, Y2: Integer): TRect;

var

R: TRect;

begin

if X1 < X2 then

begin

R.Left := X1;

R.Right := X2;

end

else

begin

R.Right := X1;

R.Left := X2;

end;

if Y1 < Y2 then

begin

R.Top := Y1;

R.Bottom := Y2;

end

else

begin

R.Bottom := Y1;

R.Top := Y2;

end;

MakeArea := R;

end;

function CreateNewTBR (TileWidth, TileHeight: Integer): TileBitmapRec;

var

tbr: TileBitmapRec;

begin

with tbr do

begin

W := TileWidth;

H := TileHeight;

Trans := TRANS_COLOR;

TileCount := 0;

Current := 0;

TileBitmap := TBitmap.Create;

TileBitmap.PixelFormat := pf24bit;

TileBitmap.Transparent := TRUE;

TileBitmap.TransparentColor := TRANS_COLOR;

TileBitmap.Width := 0;

TileBitmap.Height := H;

Filename := '';

BackMidFront := 0;

ClearMCR (mcr);

PaletteNumber := -1;

Overlap := 0;

RefreshData.OrgFilename := '';

SkipExport := FALSE; // 2.2

tbr.LastExportW := 0; // 3.0

tbr.LastExportH := 0;

tbr.LastExportTransX := -1;

tbr.LastExportTransY := -1;

Initialized := TRUE;

end;

CreateNewTBR := tbr;

end;

procedure FreeTBR (var tbr: TileBitmapRec);

var

i: Integer;

begin

if tbr.Initialized then

with tbr do

begin

tbr.TileCount := 0;

tbr.TileBitmap.Free;

SetLength (tbr.Bounds, 0);

SetLength (tbr.OffsetX, 0); // 2.4

SetLength (tbr.OffsetY, 0);

for i := Length (tbr.Maps.aMaps) - 1 downto 0 do

begin

tbr.Maps.CurMap := i;

RemoveCurrentMap (tbr);

end;

for i := Length (tbr.Clip.aMaps) - 1 downto 0 do

RemoveClip (tbr, i);

for i := Length (tbr.Seq.aMaps) - 1 downto 0 do

RemoveSeq (tbr, i);

if Length (RefreshData.OrgTransList) > 0 then

SetLength (RefreshData.OrgTransList, 0);

Initialized := FALSE;

end;

end;

procedure RemoveEmptyTiles (var tbr: TileBitmapRec);

var

i, j, x: Integer;

begin

with tbr do

begin

if TileBitmap.Width div W > TileCount then

TileBitmap.Width := TileCount * W;

repeat

x := (TileCount - 1) * W;

for j := 0 to H - 1 do

for i := 0 to W - 1 do

begin

if TileBitmap.Canvas.Pixels[x + i, j] <> Trans then

begin

TileBitmap.Width := TileCount * W;

SetLength (Bounds, TileCount);

SetLength (OffsetX, TileCount); // 2.4

SetLength (OffsetY, TileCount);

Exit;

end;

end;

Dec (TileCount);

until (TileCount = 0);

TileBitmap.Width := 0;

end;

end;

function GetChkSumChar (var tbr: TileBitmapRec; n: Integer): Char;

var

x, y: Integer;

chk: Integer;

begin

with tbr do

begin

chk := Bounds[n];

chk := chk xor (OffsetX[n] xor OffsetY[n]); // 2.4

for y := 0 to H - 1 do

for x := 0 to W - 1 do

begin

chk := chk xor (chk shr 1);

Inc (chk, TileBitmap.Canvas.Pixels[n * W + x, y]);

end;

end;

GetChkSumChar := Chr (chk and $FF);

end;

function CompareTiles (var tbr: TileBitmapRec; n1, n2: Integer): Boolean;

var

x, y: Integer;

begin

CompareTiles := FALSE;

with tbr do

begin

if Bounds[n1] <> Bounds[n2] then

Exit;

if OffsetX[n1] <> OffsetX[n2] then

Exit;

if OffsetY[n1] <> OffsetY[n2] then

Exit;

n1 := n1 * W;

n2 := n2 * W;

for y := 0 to H - 1 do

for x := 0 to W - 1 do

with TileBitmap.Canvas do

if Pixels[n1 + x, y] <> Pixels[n2 + x, y] then

Exit;

end;

CompareTiles := TRUE;

end;

function ReadTileBitmap (Filename: string;

BlockWidth, BlockHeight: Integer;

TransX, TransY: Integer;

const TransList: array of Integer;

SkipX, SkipY, SkipW, SkipH: Integer;

var ProgressBar: TProgressBar;

ReadBounds: Boolean;

RemoveDuplicates: Boolean;

bRefresh: Boolean;

tbr: TileBitmapRec): TileBitmapRec;

var

WW, HH, BW, BH: Integer;

TempBitmap: TBitmap;

i, j, x, y, z: Integer;

Src, Dst: TRect;

bnd: Integer;

bResult: Boolean;

Error: Boolean;

Img: TImage;

ChkSum: string;

MapTiles: array of Integer;

MapW, MapH: Integer;

a, b: Integer;

const

BLOCK_W = 64;

BLOCK_H = 64;

function NewTileIsUnique: Boolean;

var

c: Char;

i: Integer;

tile: Integer;

FoundAt: Integer;

begin

with tbr do

begin

c := GetChkSumChar (tbr, TileCount);

while (TileCount + 1 > length (ChkSum)) do

ChkSum := ChkSum + c;

ChkSum[TileCount + 1] := c;

tile := TileCount;

FoundAt := -1;

for i := 0 to TileCount - 1 do

if c = ChkSum[i + 1] then

if CompareTiles (tbr, i, TileCount) then

begin

FoundAt := i;

tile := i;

end;

end;

i := Length (MapTiles);

SetLength (MapTiles, i + 1);

MapTiles[i] := tile;

Result := FoundAt = -1;

end;

begin

if bRefresh then

begin

with tbr.RefreshData do

begin

Filename := OrgFilename;

TransX := OrgTransX;

TransY := OrgTransY;

{

SkipX := OrgSkipX;

SkipY := OrgSkipY;

SkipW := OrgSkipW;

SkipH := OrgSkipH;

ReadBounds := OrgReadBounds;

RemoveDuplicates := OrgRemoveDuplicates;

end;

end

else

begin

tbr := CreateNewTBR (BlockWidth, BlockHeight);

with tbr.RefreshData do

begin

OrgFilename := Filename;

OrgTransX := TransX;

OrgTransY := TransY;

SetLength (OrgTransList, Length (TransList));

for i := 0 to Length (OrgTransList) - 1 do

OrgTransList[i] := TransList[i];

OrgSkipX := SkipX;

OrgSkipY := SkipY;

OrgSkipW := SkipW;

OrgSkipH := SkipH;

OrgReadBounds := ReadBounds;

OrgRemoveDuplicates := RemoveDuplicates;

end;

end;

Error := FALSE;

if ReadBounds then

if (SkipX < 1) or (SkipY < 1) then

ReadBounds := FALSE;

if Progressbar <> nil then // 2.5

begin

ProgressBar.Min := 0;

ProgressBar.Position := 0;

end;

TempBitmap := TBitmap.Create;

TempBitmap.PixelFormat := pf24bit;

bResult := TRUE;

tbr.Filename := Filename;

with tbr do

begin

if Uppercase (ExtractFileExt (Filename)) = '.PNG' then

ReadBitmapFromPngFile (Filename, TempBitmap)

else

begin

// if Uppercase (ExtractFileExt (Filename)) = '.PCX' then

begin

Img := TImage.Create (nil);

Img.Picture.LoadFromFile(Filename);

// TempBitmap := Img.Picture.Bitmap; /// todo: this doesn't work properly, so:

TempBitmap.LoadFromFile (Filename);

if Img.Picture.Bitmap.PixelFormat = pf8bit then

begin

// to do: store palette

end;

Img.Free;

end

// else

// TempBitmap.LoadFromFile (Filename);

end;

TempBitmap.PixelFormat := pf24bit;

if bResult then

begin

W := BlockWidth;

H := BlockHeight;

BW := W + SkipW;

BH := H + SkipH;

WW := TempBitmap.Width - SkipX;

HH := TempBitmap.Height - SkipY;

MapW := WW div BW;

MapH := HH div BH;

if Progressbar <> nil then

ProgressBar.Max := MapW * MapH;

if (WW >= W) and (HH >= H) then

begin

TransX := (TransX + WW) mod WW;

TransY := (TransY + HH) mod HH;

if Length (RefreshData.OrgTransList) <> 1 then

Trans := -1

else

Trans := TempBitmap.Canvas.Pixels[TransX, TransY];

if (Trans <> TRANS_COLOR) or (Length (RefreshData.OrgTransList) > 1) then

begin

if Progressbar <> nil then

with ProgressBar do

begin

Min := -TempBitmap.Height * 8;

Position := Min;

end;

for y := 0 to TempBitmap.Height - 1 do

begin

for x := 0 to TempBitmap.Width - 1 do

begin

if Trans = -1 then

begin

if Length (RefreshData.OrgTransList) = 0 then

begin

if TempBitmap.Canvas.Pixels[x, y] = TRANS_COLOR then

TempBitmap.Canvas.Pixels[x, y] := TRANS_COLOR_REPLACEMENT;

end

else