diff --git a/Client/Tools/UfrmElevateSettings.lfm b/Client/Tools/UfrmElevateSettings.lfm index 5a5eb33..0c16738 100644 --- a/Client/Tools/UfrmElevateSettings.lfm +++ b/Client/Tools/UfrmElevateSettings.lfm @@ -1,61 +1,120 @@ object frmElevateSettings: TfrmElevateSettings Left = 290 - Height = 65 + Height = 115 Top = 171 - Width = 131 - HorzScrollBar.Page = 130 + Width = 231 + HorzScrollBar.Page = 230 HorzScrollBar.Range = 122 - VertScrollBar.Page = 64 + VertScrollBar.Page = 114 VertScrollBar.Range = 59 ActiveControl = rbRaise AutoScroll = False BorderIcons = [] BorderStyle = bsToolWindow Caption = 'Elevate' - ClientHeight = 65 - ClientWidth = 131 + ClientHeight = 115 + ClientWidth = 231 Font.Height = -11 OnClose = FormClose OnDeactivate = FormDeactivate LCLVersion = '0.9.25' - object rbRaise: TRadioButton + object Panel1: TPanel Left = 8 - Height = 21 + Height = 67 Top = 8 - Width = 58 - Caption = 'Raise' - Checked = True - ParentFont = True - State = cbChecked + Width = 215 + Align = alTop + BorderSpacing.Around = 8 + BevelOuter = bvNone + ClientHeight = 67 + ClientWidth = 215 TabOrder = 0 + object Panel2: TPanel + Height = 67 + Width = 162 + Align = alClient + BevelOuter = bvNone + ClientHeight = 67 + ClientWidth = 162 + ParentFont = True + TabOrder = 0 + object rbRaise: TRadioButton + Height = 21 + Width = 162 + Align = alTop + Caption = 'Raise' + Checked = True + State = cbChecked + TabOrder = 2 + end + object rbLower: TRadioButton + Height = 21 + Top = 21 + Width = 162 + Align = alTop + Caption = 'Lower' + ParentFont = True + TabOrder = 0 + end + object rbSet: TRadioButton + Height = 21 + Top = 42 + Width = 162 + Align = alTop + Caption = 'Set' + ParentFont = True + TabOrder = 1 + end + end + object Panel3: TPanel + Left = 162 + Height = 67 + Width = 53 + Align = alRight + BevelOuter = bvNone + ClientHeight = 67 + ClientWidth = 53 + TabOrder = 1 + object seZ: TSpinEdit + Left = 7 + Height = 23 + Top = 20 + Width = 47 + MaxValue = 127 + MinValue = -128 + ParentFont = True + TabOrder = 0 + Value = 1 + end + end end - object rbLower: TRadioButton + object Panel4: TPanel Left = 8 - Height = 21 - Top = 24 - Width = 59 - Caption = 'Lower' - ParentFont = True - TabOrder = 1 - end - object seZ: TSpinEdit - Left = 72 Height = 23 - Top = 22 - Width = 50 - MaxValue = 127 - MinValue = -128 - ParentFont = True - TabOrder = 3 - Value = 1 - end - object rbSet: TRadioButton - Left = 8 - Height = 21 - Top = 40 - Width = 43 - Caption = 'Set' - ParentFont = True - TabOrder = 2 + Top = 83 + Width = 215 + Align = alTop + BorderSpacing.Around = 8 + BevelOuter = bvNone + ClientHeight = 23 + ClientWidth = 215 + TabOrder = 1 + object cbRandomHeight: TCheckBox + Height = 23 + Width = 168 + Align = alClient + Caption = 'Add Random Altitude' + ParentFont = True + TabOrder = 0 + end + object seRandomHeight: TSpinEdit + Left = 168 + Height = 23 + Width = 47 + Align = alRight + OnChange = seRandomHeightChange + ParentFont = True + TabOrder = 1 + end end end diff --git a/Client/Tools/UfrmElevateSettings.pas b/Client/Tools/UfrmElevateSettings.pas index fdd5267..2d37047 100644 --- a/Client/Tools/UfrmElevateSettings.pas +++ b/Client/Tools/UfrmElevateSettings.pas @@ -1,81 +1,93 @@ -(* - * CDDL HEADER START - * - * The contents of this file are subject to the terms of the - * Common Development and Distribution License, Version 1.0 only - * (the "License"). You may not use this file except in compliance - * with the License. - * - * You can obtain a copy of the license at - * http://www.opensource.org/licenses/cddl1.php. - * See the License for the specific language governing permissions - * and limitations under the License. - * - * When distributing Covered Code, include this CDDL HEADER in each - * file and include the License file at - * http://www.opensource.org/licenses/cddl1.php. If applicable, - * add the following below this CDDL HEADER, with the fields enclosed - * by brackets "[]" replaced with your own identifying * information: - * Portions Copyright [yyyy] [name of copyright owner] - * - * CDDL HEADER END - * - * - * Portions Copyright 2007 Andreas Schneider - *) -unit UfrmElevateSettings; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, LMessages, - LCLIntf, StdCtrls, Spin; - -type - - { TfrmElevateSettings } - - TfrmElevateSettings = class(TForm) - rbSet: TRadioButton; - rbRaise: TRadioButton; - rbLower: TRadioButton; - seZ: TSpinEdit; - procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); - procedure FormDeactivate(Sender: TObject); - protected - procedure MouseLeave(var msg: TLMessage); message CM_MouseLeave; - public - { public declarations } - end; - -var - frmElevateSettings: TfrmElevateSettings; - -implementation - -{ TfrmElevateSettings } - -procedure TfrmElevateSettings.FormClose(Sender: TObject; - var CloseAction: TCloseAction); -begin - CloseAction := caHide; -end; - -procedure TfrmElevateSettings.FormDeactivate(Sender: TObject); -begin - Close; -end; - -procedure TfrmElevateSettings.MouseLeave(var msg: TLMessage); -begin - if not PtInRect(ClientRect, ScreenToClient(Mouse.CursorPos)) then - Close; -end; - -initialization - {$I UfrmElevateSettings.lrs} - -end. - +(* + * CDDL HEADER START + * + * The contents of this file are subject to the terms of the + * Common Development and Distribution License, Version 1.0 only + * (the "License"). You may not use this file except in compliance + * with the License. + * + * You can obtain a copy of the license at + * http://www.opensource.org/licenses/cddl1.php. + * See the License for the specific language governing permissions + * and limitations under the License. + * + * When distributing Covered Code, include this CDDL HEADER in each + * file and include the License file at + * http://www.opensource.org/licenses/cddl1.php. If applicable, + * add the following below this CDDL HEADER, with the fields enclosed + * by brackets "[]" replaced with your own identifying * information: + * Portions Copyright [yyyy] [name of copyright owner] + * + * CDDL HEADER END + * + * + * Portions Copyright 2008 Andreas Schneider + *) +unit UfrmElevateSettings; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, LMessages, + LCLIntf, StdCtrls, Spin, ExtCtrls; + +type + + { TfrmElevateSettings } + + TfrmElevateSettings = class(TForm) + cbRandomHeight: TCheckBox; + Panel1: TPanel; + Panel2: TPanel; + Panel3: TPanel; + Panel4: TPanel; + rbRaise: TRadioButton; + rbLower: TRadioButton; + rbSet: TRadioButton; + seRandomHeight: TSpinEdit; + seZ: TSpinEdit; + procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); + procedure FormDeactivate(Sender: TObject); + procedure seRandomHeightChange(Sender: TObject); + protected + procedure MouseLeave(var msg: TLMessage); message CM_MouseLeave; + public + { public declarations } + end; + +var + frmElevateSettings: TfrmElevateSettings; + +implementation + +{ TfrmElevateSettings } + +procedure TfrmElevateSettings.FormClose(Sender: TObject; + var CloseAction: TCloseAction); +begin + CloseAction := caHide; +end; + +procedure TfrmElevateSettings.FormDeactivate(Sender: TObject); +begin + Close; +end; + +procedure TfrmElevateSettings.seRandomHeightChange(Sender: TObject); +begin + cbRandomHeight.Checked := True; +end; + +procedure TfrmElevateSettings.MouseLeave(var msg: TLMessage); +begin + if not PtInRect(ClientRect, ScreenToClient(Mouse.CursorPos)) then + Close; +end; + +initialization + {$I UfrmElevateSettings.lrs} + +end. + diff --git a/Client/ULandscape.pas b/Client/ULandscape.pas index 9082bcf..66165da 100644 --- a/Client/ULandscape.pas +++ b/Client/ULandscape.pas @@ -1,1163 +1,1163 @@ -(* - * CDDL HEADER START - * - * The contents of this file are subject to the terms of the - * Common Development and Distribution License, Version 1.0 only - * (the "License"). You may not use this file except in compliance - * with the License. - * - * You can obtain a copy of the license at - * http://www.opensource.org/licenses/cddl1.php. - * See the License for the specific language governing permissions - * and limitations under the License. - * - * When distributing Covered Code, include this CDDL HEADER in each - * file and include the License file at - * http://www.opensource.org/licenses/cddl1.php. If applicable, - * add the following below this CDDL HEADER, with the fields enclosed - * by brackets "[]" replaced with your own identifying * information: - * Portions Copyright [yyyy] [name of copyright owner] - * - * CDDL HEADER END - * - * - * Portions Copyright 2007 Andreas Schneider - *) -unit ULandscape; - -{$mode objfpc}{$H+} - -interface - -uses - SysUtils, Classes, math, contnrs, LCLIntf, GL, GLU, ImagingOpenGL, - Imaging, ImagingClasses, ImagingTypes, ImagingUtility, - UGenericIndex, UMap, UStatics, UArt, UTexture, UTiledata, UHue, UWorldItem, - UMulBlock, - UListSort, UVector, UEnhancedMemoryStream, - UCacheManager, ULinkedList; - -type - TNormals = array[0..3] of TVector; - PRadarBlock = ^TRadarBlock; - TRadarBlock = array[0..7, 0..7] of Word; - - { TMaterial } - - TMaterial = class(TObject) - constructor Create(AWidth, AHeight: Integer; AGraphic: TSingleImage); - destructor Destroy; override; - protected - FWidth: Integer; - FHeight: Integer; - FRealWidth: Integer; - FRealHeight: Integer; - FTexture: GLuint; - FGraphic: TSingleImage; - public - property Width: Integer read FWidth; - property Height: Integer read FHeight; - property RealWidth: Integer read FRealWidth; - property RealHeight: Integer read FRealHeight; - property Texture: GLuint read FTexture; - property Graphic: TSingleImage read FGraphic; - - function HitTest(AX, AY: Integer): Boolean; - procedure UpdateTexture; - end; - - { TLandTextureManager } - - TLandTextureManager = class(TObject) - constructor Create; - destructor Destroy; override; - function GetArtMaterial(ATileID: Word): TMaterial; overload; - function GetArtMaterial(ATileID: Word; AHue: THue; APartialHue: Boolean): TMaterial; overload; - function GetFlatLandMaterial(ATileID: Word): TMaterial; - function GetTexMaterial(ATileID: Word): TMaterial; - protected - FArtCache: TCacheManager; - FFlatLandArtCache: TCacheManager; - FTexCache: TCacheManager; - end; - - { TBlock } - - TBlock = class(TObject) - constructor Create(AMap: TMapBlock; AStatics: TStaticBlock); - destructor Destroy; override; - protected - FMapBlock: TMapBlock; - FStaticBlock: TStaticBlock; - public - property Map: TMapBlock read FMapBlock; - property Static: TStaticBlock read FStaticBlock; - end; - - TLandscapeChangeEvent = procedure of object; - TStaticFilter = function(AStatic: TStaticItem): Boolean of object; - - { TLandscape } - - TLandscape = class(TObject) - constructor Create(AWidth, AHeight: Word); - destructor Destroy; override; - protected - FWidth: Word; - FHeight: Word; - FCellWidth: Word; - FCellHeight: Word; - FBlockCache: TCacheManager; - FOnChange: TLandscapeChangeEvent; - FOpenRequests: array of Boolean; - function Compare(left, right: TObject): Integer; - function GetNormals(AX, AY: Word): TNormals; - function GetMapCell(AX, AY: Word): TMapCell; - function GetStaticList(AX, AY: Word): TList; - function GetMapBlock(AX, AY: Word): TMapBlock; - function GetStaticBlock(AX, AY: Word): TSeperatedStaticBlock; - procedure UpdateStaticsPriority(AStaticItem: TStaticItem; - APrioritySolver: Integer); - procedure OnBlockChanged(ABlock: TMulBlock); - procedure OnRemoveCachedObject(AObject: TObject); - - procedure OnBlocksPacket(ABuffer: TEnhancedMemoryStream); - procedure OnDrawMapPacket(ABuffer: TEnhancedMemoryStream); - procedure OnInsertStaticPacket(ABuffer: TEnhancedMemoryStream); - procedure OnDeleteStaticPacket(ABuffer: TEnhancedMemoryStream); - procedure OnElevateStaticPacket(ABuffer: TEnhancedMemoryStream); - procedure OnMoveStaticPacket(ABuffer: TEnhancedMemoryStream); - procedure OnHueStaticPacket(ABuffer: TEnhancedMemoryStream); - public - property Width: Word read FWidth; - property Height: Word read FHeight; - property CellWidth: Word read FCellWidth; - property CellHeight: Word read FCellHeight; - property MapCell[X, Y: Word]: TMapCell read GetMapCell; - property StaticList[X, Y: Word]: TList read GetStaticList; - property Normals[X, Y: Word]: TNormals read GetNormals; - property OnChange: TLandscapeChangeEvent read FOnChange write FOnChange; - - function GetDrawList(AX, AY: Word; AMinZ, AMaxZ: ShortInt; - AGhostTile: TWorldItem; AVirtualLayer: TStaticItem; AMap, - AStatics: Boolean; ANoDraw:Boolean; AStaticsFilter: TStaticFilter): TList; - function GetEffectiveAltitude(ATile: TMapCell): ShortInt; - function GetLandAlt(AX, AY: Word; ADefault: ShortInt): ShortInt; - - procedure MoveStatic(AStatic: TStaticItem; AX, AY: Word); - procedure PrepareBlocks(AX1, AY1, AX2, AY2: Word); - end; - PBlockInfo = ^TBlockInfo; - TBlockInfo = record - ScreenRect: TRect; - Item: TWorldItem; - Material: TMaterial; - Next: PBlockInfo; - end; - - { TTileList } - - TTileList = class(TObject) - constructor Create; virtual; - destructor Destroy; override; - protected - FFirst: PBlockInfo; - FLastBlock: PBlockInfo; - public - procedure Clear; virtual; - function Iterate(var ABlockInfo: PBlockInfo): Boolean; virtual; - procedure Add(AItem: TWorldItem); virtual; - procedure Delete(AItem: TWorldItem); virtual; - property LastBlock: PBlockInfo read FLastBlock; - end; - - { TScreenBuffer } - - TScreenBuffer = class(TTileList) - public - procedure OnTileRemoved(ATile: TMulBlock); - procedure Clear; override; - function Find(AScreenPosition: TPoint): PBlockInfo; - procedure Store(AScreenRect: TRect; AItem: TWorldItem; AMaterial: TMaterial); - end; - - TStaticInfo = packed record - X: Word; - Y: Word; - Z: ShortInt; - TileID: Word; - Hue: Word; - end; - //operator=(AStaticItem: TStaticItem; AStaticInfo: TStaticInfo): Boolean; - -implementation - -uses - UGameResources, UdmNetwork, UPackets, UPacketHandlers; - -const - mMap = 0; - mStatics = 1; - -function GetID(AX, AY: Word): Integer; -begin - Result := ((AX and $7FFF) shl 15) or (AY and $7FFF); -end; - -{operator=(AStaticItem: TStaticItem; AStaticInfo: TStaticInfo): Boolean; -begin - Result := (AStaticItem.X = AStaticInfo.X) and - (AStaticItem.Y = AStaticInfo.Y) and - (AStaticItem.Z = AStaticInfo.Z) and - (AStaticItem.TileID = AStaticInfo.TileID) and - (AStaticItem.Hue = AStaticInfo.Hue); -end;} - -{ TLandTextureManager } - -constructor TLandTextureManager.Create; -begin - inherited Create; - FArtCache := TCacheManager.Create(1024); - FFlatLandArtCache := TCacheManager.Create(128); - FTexCache := TCacheManager.Create(128); -end; - -destructor TLandTextureManager.Destroy; -begin - if FArtCache <> nil then FreeAndNil(FArtCache); - if FFlatLandArtCache <> nil then FreeAndNil(FFlatLandArtCache); - if FTexCache <> nil then FreeAndNil(FTexCache); - inherited Destroy; -end; - -function TLandTextureManager.GetArtMaterial(ATileID: Word): TMaterial; -var - artEntry: TArt; -begin - if not FArtCache.QueryID(ATileID, TObject(Result)) then - begin - artEntry := TArt(ResMan.Art.Block[ATileID]); - - Result := TMaterial.Create(artEntry.Graphic.Width, artEntry.Graphic.Height, - artEntry.Graphic); - FArtCache.StoreID(ATileID, Result); - - artEntry.Free; - end; -end; - -function TLandTextureManager.GetArtMaterial(ATileID: Word; AHue: THue; APartialHue: Boolean): TMaterial; -var - artEntry: TArt; - id: Integer; -begin - if AHue = nil then - begin - Result := GetArtMaterial(ATileID); - end else - begin - id := ATileID or ((AHue.ID and $3FFF) shl 15) or (Byte(APartialHue) shl 29); - if not FArtCache.QueryID(id, TObject(Result)) then - begin - artEntry := ResMan.Art.GetArt(ATileID, 0, AHue, APartialHue); - - Result := TMaterial.Create(artEntry.Graphic.Width, artEntry.Graphic.Height, - artEntry.Graphic); - FArtCache.StoreID(id, Result); - - artEntry.Free; - end; - end; -end; - -function TLandTextureManager.GetFlatLandMaterial(ATileID: Word): TMaterial; -var - artEntry: TArt; -begin - if not FFlatLandArtCache.QueryID(ATileID, TObject(Result)) then - begin - artEntry := ResMan.Art.GetFlatLand(ATileID); - - Result := TMaterial.Create(artEntry.Graphic.Width, artEntry.Graphic.Height, - artEntry.Graphic); - FFlatLandArtCache.StoreID(ATileID, Result); - - artEntry.Free; - end; -end; - -function TLandTextureManager.GetTexMaterial(ATileID: Word): TMaterial; -var - texEntry: TTexture; - texID: Integer; -begin - if not FTexCache.QueryID(ATileID, TObject(Result)) then - begin - texID := ResMan.Tiledata.LandTiles[ATileID].TextureID; - if texID > 0 then - begin - texEntry := TTexture(ResMan.Texmaps.Block[texID]); - - Result := TMaterial.Create(texEntry.Graphic.Width, texEntry.Graphic.Height, - texEntry.Graphic); - FTexCache.StoreID(ATileID, Result); - - texEntry.Free; - end else - Result := nil; - end; -end; - -{ TBlock } - -constructor TBlock.Create(AMap: TMapBlock; AStatics: TStaticBlock); -begin - inherited Create; - FMapBlock := AMap; - FStaticBlock := AStatics; -end; - -destructor TBlock.Destroy; -begin - if FMapBlock <> nil then FreeAndNil(FMapBlock); - if FStaticBlock <> nil then FreeAndNil(FStaticBlock); - inherited Destroy; -end; - -{ TLandscape } - -constructor TLandscape.Create(AWidth, AHeight: Word); -var - blockID: Integer; -begin - inherited Create; - FWidth := AWidth; - FHeight := AHeight; - FCellWidth := FWidth * 8; - FCellHeight := FHeight * 8; - FBlockCache := TCacheManager.Create(256); - FBlockCache.OnRemoveObject := @OnRemoveCachedObject; - - SetLength(FOpenRequests, FWidth * FHeight); - for blockID := 0 to Length(FOpenRequests) - 1 do - FOpenRequests[blockID] := False; - - RegisterPacketHandler($04, TPacketHandler.Create(0, @OnBlocksPacket)); - RegisterPacketHandler($06, TPacketHandler.Create(8, @OnDrawMapPacket)); - RegisterPacketHandler($07, TPacketHandler.Create(10, @OnInsertStaticPacket)); - RegisterPacketHandler($08, TPacketHandler.Create(10, @OnDeleteStaticPacket)); - RegisterPacketHandler($09, TPacketHandler.Create(11, @OnElevateStaticPacket)); - RegisterPacketHandler($0A, TPacketHandler.Create(14, @OnMoveStaticPacket)); - RegisterPacketHandler($0B, TPacketHandler.Create(12, @OnHueStaticPacket)); -end; - -destructor TLandscape.Destroy; -var - i: Integer; -begin - if FBlockCache <> nil then - begin - FBlockCache.OnRemoveObject := nil; - FreeAndNil(FBlockCache); - end; - - RegisterPacketHandler($04, nil); - RegisterPacketHandler($06, nil); - RegisterPacketHandler($07, nil); - RegisterPacketHandler($08, nil); - RegisterPacketHandler($09, nil); - RegisterPacketHandler($0A, nil); - RegisterPacketHandler($0B, nil); - - inherited Destroy; -end; - -function TLandscape.GetMapCell(AX, AY: Word): TMapCell; -var - block: TMapBlock; -begin - Result := nil; - if (AX >= 0) and (AX <= FCellWidth) and (AY >= 0) and (AY <= FCellHeight) then - begin - block := GetMapBlock(AX div 8, AY div 8); - if block <> nil then - Result := block.Cells[(AY mod 8) * 8 + AX mod 8]; - end; -end; - -function TLandscape.GetLandAlt(AX, AY: Word; ADefault: ShortInt): ShortInt; -var - cell: TMapCell; -begin - cell := MapCell[AX, AY]; - if cell <> nil then - Result := cell.Altitude - else - Result := ADefault; -end; - -function TLandscape.GetStaticList(AX, AY: Word): TList; -var - block: TSeperatedStaticBlock; -begin - Result := nil; - if (AX >= 0) and (AX <= FCellWidth) and (AY >= 0) and (AY <= FCellHeight) then - begin - block := GetStaticBlock(AX div 8, AY div 8); - if block <> nil then - Result := block.Cells[(AY mod 8) * 8 + AX mod 8]; - end; -end; - -function TLandscape.Compare(left, right: TObject): Integer; -begin - Result := TWorldItem(right).Priority - TWorldItem(left).Priority; - if Result = 0 then - begin - if (left is TMapCell) and (right is TStaticItem) then - Result := 1 - else if (left is TStaticItem) and (right is TMapCell) then - Result := -1; - end; - - if Result = 0 then - Result := TWorldItem(right).PriorityBonus - TWorldItem(left).PriorityBonus; - - if Result = 0 then - Result := TWorldItem(right).PrioritySolver - TWorldItem(left).PrioritySolver; -end; - -function TLandscape.GetDrawList(AX, AY: Word; AMinZ, AMaxZ: ShortInt; - AGhostTile: TWorldItem; AVirtualLayer: TStaticItem; AMap, - AStatics: Boolean; ANoDraw:Boolean; AStaticsFilter: TStaticFilter): TList; -var - landAlt: ShortInt; - drawMapCell: TMapCell; - drawStatics: TList; - i: Integer; -begin - Result := TList.Create; - if AMap then - begin - landAlt := GetLandAlt(AX, AY, 0); - if (landAlt >= AMinZ) and (landAlt <= AMaxZ) then - begin - drawMapCell := GetMapCell(AX, AY); - if (drawMapCell <> nil) and (ANoDraw or (drawMapCell.TileID > 2)) then - begin - drawMapCell.Priority := GetEffectiveAltitude(drawMapCell); - drawMapCell.PriorityBonus := 0; - drawMapCell.PrioritySolver := 0; - Result.Add(drawMapCell); - end; - - if AGhostTile is TMapCell then - begin - AGhostTile.X := AX; - AGhostTile.Y := AY; - AGhostTile.Priority := GetEffectiveAltitude(TMapCell(AGhostTile)); - AGhostTile.PriorityBonus := 0; - AGhostTile.PrioritySolver := 0; - Result.Add(AGhostTile); - end; - end; - end; - - if AStatics then - begin - drawStatics := GetStaticList(AX, AY); - if drawStatics <> nil then - for i := 0 to drawStatics.Count - 1 do - if (TStaticItem(drawStatics[i]).Z >= AMinZ) and - (TStaticItem(drawStatics[i]).Z <= AMaxZ) and - ((AStaticsFilter = nil) or AStaticsFilter(TStaticItem(drawStatics[i]))) then - begin - UpdateStaticsPriority(TStaticItem(drawStatics[i]), i + 1); - Result.Add(Pointer(drawStatics[i])); - end; - - - if AGhostTile is TStaticItem then - begin - UpdateStaticsPriority(TStaticItem(AGhostTile), MaxInt); - Result.Add(AGhostTile); - end; - end; - - if AVirtualLayer <> nil then - begin - UpdateStaticsPriority(AVirtualLayer, MaxInt-1); - Result.Add(AVirtualLayer); - end; - - ListSort(Result, @Compare); -end; - -function TLandscape.GetEffectiveAltitude(ATile: TMapCell): ShortInt; -var - north, west, south, east: ShortInt; -begin - north := ATile.Altitude; - west := GetLandAlt(ATile.X, ATile.Y + 1, north); - south := GetLandAlt(ATile.X + 1, ATile.Y + 1, north); - east := GetLandAlt(ATile.X + 1, ATile.Y, north); - - if Abs(north - south) > Abs(west - east) then - Result := (north + south) div 2 - else - Result := (west + east) div 2; -end; - -function TLandscape.GetNormals(AX, AY: Word): TNormals; -var - cells: array[0..2, 0..2] of TNormals; - north, west, south, east: TVector; - i, j: Integer; - - function GetPlainNormals(X, Y: SmallInt): TNormals; - var - cell: TMapCell; - north, west, south, east: ShortInt; - u, v: TVector; - begin - cell := GetMapCell(X, Y); - if Assigned(cell) then - begin - north := cell.Altitude; - west := GetLandAlt(cell.X, cell.Y + 1, north); - south := GetLandAlt(cell.X + 1, cell.Y + 1, north); - east := GetLandAlt(cell.X + 1, cell.Y, north); - end else - begin - north := 0; - west := 0; - east := 0; - south := 0; - end; - - if (north = west) and (west = east) and (north = south) then - begin - Result[0] := Vector(0, 0, 1); - Result[1] := Vector(0, 0, 1); - Result[2] := Vector(0, 0, 1); - Result[3] := Vector(0, 0, 1); - end else - begin - u := Vector(-22, 22, (north - east) * 4); - v := Vector(-22, -22, (west - north) * 4); - Result[0] := VectorNorm(VectorCross(u, v)); - - u := Vector(22, 22, (east - south) * 4); - v := Vector(-22, 22, (north - east) * 4); - Result[1] := VectorNorm(VectorCross(u, v)); - - u := Vector(22, -22, (south - west) * 4); - v := Vector(22, 22, (east - south) * 4); - Result[2] := VectorNorm(VectorCross(u, v)); - - u := Vector(-22, -22, (west - north) * 4); - v := Vector(22, -22, (south - west) * 4); - Result[3] := VectorNorm(VectorCross(u, v)); - end; - end; -begin - for i := 0 to 2 do - for j := 0 to 2 do - cells[i, j] := GetPlainNormals(AX - 1 + i, AY - 1 + j); - - north := cells[0, 0][2]; - west := cells[0, 1][1]; - east := cells[1, 0][3]; - south := cells[1, 1][0]; - Result[0] := VectorNorm(VectorAdd(VectorAdd(VectorAdd(north, west), east), south)); - - north := cells[1, 0][2]; - west := cells[1, 1][1]; - east := cells[2, 0][3]; - south := cells[2, 1][0]; - Result[1] := VectorNorm(VectorAdd(VectorAdd(VectorAdd(north, west), east), south)); - - north := cells[1, 1][2]; - west := cells[1, 2][1]; - east := cells[2, 1][3]; - south := cells[2, 2][0]; - Result[2] := VectorNorm(VectorAdd(VectorAdd(VectorAdd(north, west), east), south)); - - north := cells[0, 1][2]; - west := cells[0, 2][1]; - east := cells[1, 1][3]; - south := cells[1, 2][0]; - Result[3] := VectorNorm(VectorAdd(VectorAdd(VectorAdd(north, west), east), south)); -end; - -procedure TLandscape.OnBlockChanged(ABlock: TMulBlock); -var - block, old: TWorldBlock; - mode: Byte; - id, blockID: Integer; -begin - {block := ABlock as TWorldBlock; - if block <> nil then - begin - if block is TSeperatedStaticBlock then - mode := mStatics - else - mode := mMap; - id := GetID(block.X, block.Y, mode); - blockID := (block.X * FHeight) + block.Y; - if block.Changed or (block.RefCount > 0) then - begin - if FPersistentBlocks[blockID][mode] = nil then - begin - FPersistentBlocks[blockID][mode] := block; - FBlockCache.DiscardID(id); - end; - end else - begin - FPersistentBlocks[blockID][mode] := nil; - if not FBlockCache.QueryID(id, TObject(old)) then - FBlockCache.StoreID(id, block); - end; - end;} -end; - -procedure TLandscape.MoveStatic(AStatic: TStaticItem; AX, AY: Word); -var - sourceBlock, targetBlock: TSeperatedStaticBlock; - targetStaticList: TList; - i: Integer; -begin - if (AX >= 0) and (AX <= FCellWidth) and (AY >= 0) and (AY <= FCellHeight) then - begin - sourceBlock := AStatic.Owner as TSeperatedStaticBlock; - targetBlock := GetStaticBlock(AX div 8, AY div 8); - if (sourceBlock <> nil) and (targetBlock <> nil) then - begin - sourceBlock.Cells[(AStatic.Y mod 8) * 8 + AStatic.X mod 8].Remove(AStatic); - targetStaticList := targetBlock.Cells[(AY mod 8) * 8 + AX mod 8]; - targetStaticList.Add(AStatic); - for i := 0 to targetStaticList.Count - 1 do - UpdateStaticsPriority(TStaticItem(targetStaticList.Items[i]), i); - ListSort(targetStaticList, @Compare); - AStatic.UpdatePos(AX, AY, AStatic.Z); - AStatic.Owner := targetBlock; - end; - end; -end; - -procedure TLandscape.PrepareBlocks(AX1, AY1, AX2, AY2: Word); -var - x, y, i, mapID, staticID: Integer; - coords: TBlockCoordsArray; - obj: TObject; -begin - AX1 := EnsureRange(AX1, 0, FWidth - 1); - AY1 := EnsureRange(AY1, 0, FHeight - 1); - AX2 := EnsureRange(AX2, 0, FWidth - 1); - AY2 := EnsureRange(AY2, 0, FHeight - 1); - - SetLength(coords, 0); - for x := AX1 to AX2 do - begin - for y := AY1 to AY2 do - begin - if (not FOpenRequests[y * FWidth + x]) and - (not FBlockCache.QueryID(GetID(x, y), obj)) then - begin - SetLength(coords, Length(coords) + 1); - i := High(coords); - coords[i].X := x; - coords[i].Y := y; - FOpenRequests[y * FWidth + x] := True; - end; - end; - end; - if Length(coords) > 0 then - dmNetwork.Send(TRequestBlocksPacket.Create(coords)); -end; - -function TLandscape.GetMapBlock(AX, AY: Word): TMapBlock; -var - block: TBlock; -begin - Result := nil; - if (AX >= 0) and (AX < FWidth) and (AY >= 0) and (AY < FHeight) then - begin - if FBlockCache.QueryID(GetID(AX, AY), TObject(block)) then - Result := block.Map; - end; -end; - -function TLandscape.GetStaticBlock(AX, AY: Word): TSeperatedStaticBlock; -var - block: TBlock; -begin - Result := nil; - if (AX >= 0) and (AX < FWidth) and (AY >= 0) and (AY < FHeight) then - begin - if FBlockCache.QueryID(GetID(AX, AY), TObject(block)) then - Result := TSeperatedStaticBlock(block.Static); - end; -end; - -procedure TLandscape.UpdateStaticsPriority(AStaticItem: TStaticItem; - APrioritySolver: Integer); -var - staticTileData: TStaticTileData; -begin - staticTileData := ResMan.Tiledata.StaticTiles[AStaticItem.TileID]; - AStaticItem.PriorityBonus := 0; - if not ((staticTileData.Flags and tdfBackground) = tdfBackground) then - AStaticItem.PriorityBonus := AStaticItem.PriorityBonus + 1; - if staticTileData.Height > 0 then - AStaticItem.PriorityBonus := AStaticItem.PriorityBonus + 1; - AStaticItem.Priority := AStaticItem.Z + AStaticItem.PriorityBonus; - AStaticItem.PrioritySolver := APrioritySolver; -end; - -procedure TLandscape.OnBlocksPacket(ABuffer: TEnhancedMemoryStream); -var - index: TGenericIndex; - map: TMapBlock; - statics: TStaticBlock; - coords: TBlockCoords; - count: Word; - id: Integer; -begin - index := TGenericIndex.Create(nil); - while ABuffer.Position < ABuffer.Size do - begin - ABuffer.Read(coords, SizeOf(TBlockCoords)); - id := GetID(coords.X, coords.Y); - - map := TMapBlock.Create(ABuffer, coords.X, coords.Y); - count := ABuffer.ReadWord; - if count > 0 then - index.Lookup := ABuffer.Position - else - index.Lookup := $FFFFFFFF; - index.Size := count * 7; - statics := TSeperatedStaticBlock.Create(ABuffer, index, coords.X, coords.Y); - - FBlockCache.RemoveID(id); - FBlockCache.StoreID(id, TBlock.Create(map, statics)); - - FOpenRequests[coords.Y * FWidth + coords.X] := False; - end; - index.Free; - if Assigned(FOnChange) then FOnChange; -end; - -procedure TLandscape.OnDrawMapPacket(ABuffer: TEnhancedMemoryStream); -var - x, y: Word; - cell: TMapCell; -begin - x := ABuffer.ReadWord; - y := ABuffer.ReadWord; - cell := GetMapCell(x, y); - if cell <> nil then - begin - cell.Altitude := ABuffer.ReadShortInt; - cell.TileID := ABuffer.ReadWord; - if Assigned(FOnChange) then FOnChange; - end; -end; - -procedure TLandscape.OnInsertStaticPacket(ABuffer: TEnhancedMemoryStream); -var - x, y: Word; - block: TSeperatedStaticBlock; - staticItem: TStaticItem; - targetStaticList: TList; - i: Integer; -begin - x := ABuffer.ReadWord; - y := ABuffer.ReadWord; - block := GetStaticBlock(x div 8, y div 8); - if block <> nil then - begin - staticItem := TStaticItem.Create(nil, nil, 0, 0); - staticItem.X := x; - staticItem.Y := y; - staticItem.Z := ABuffer.ReadShortInt; - staticItem.TileID := ABuffer.ReadWord; - staticItem.Hue := ABuffer.ReadWord; - targetStaticList := block.Cells[(y mod 8) * 8 + x mod 8]; - targetStaticList.Add(staticItem); - for i := 0 to targetStaticList.Count - 1 do - UpdateStaticsPriority(TStaticItem(targetStaticList.Items[i]), i); - ListSort(targetStaticList, @Compare); - staticItem.Owner := block; - if Assigned(FOnChange) then FOnChange; - end; -end; - -procedure TLandscape.OnDeleteStaticPacket(ABuffer: TEnhancedMemoryStream); -var - block: TSeperatedStaticBlock; - i: Integer; - statics: TList; - staticInfo: TStaticInfo; - staticItem: TStaticItem; -begin - ABuffer.Read(staticInfo, SizeOf(TStaticInfo)); - block := GetStaticBlock(staticInfo.X div 8, staticInfo.Y div 8); - if block <> nil then - begin - statics := block.Cells[(staticInfo.Y mod 8) * 8 + staticInfo.X mod 8]; - for i := 0 to statics.Count - 1 do - begin - staticItem := TStaticItem(statics.Items[i]); - if (staticItem.Z = staticInfo.Z) and - (staticItem.TileID = staticInfo.TileID) and - (staticItem.Hue = staticInfo.Hue) then - begin - statics.Delete(i); - staticItem.Delete; - if Assigned(FOnChange) then FOnChange; - Break; - end; - end; - end; -end; - -procedure TLandscape.OnElevateStaticPacket(ABuffer: TEnhancedMemoryStream); -var - block: TSeperatedStaticBlock; - i,j : Integer; - statics: TList; - staticInfo: TStaticInfo; - staticItem: TStaticItem; -begin - ABuffer.Read(staticInfo, SizeOf(TStaticInfo)); - block := GetStaticBlock(staticInfo.X div 8, staticInfo.Y div 8); - if block <> nil then - begin - statics := block.Cells[(staticInfo.Y mod 8) * 8 + staticInfo.X mod 8]; - for i := 0 to statics.Count - 1 do - begin - staticItem := TStaticItem(statics.Items[i]); - if (staticItem.Z = staticInfo.Z) and - (staticItem.TileID = staticInfo.TileID) and - (staticItem.Hue = staticInfo.Hue) then - begin - staticItem.Z := ABuffer.ReadShortInt; - for j := 0 to statics.Count - 1 do - UpdateStaticsPriority(TStaticItem(statics.Items[j]), j); - ListSort(statics, @Compare); - if Assigned(FOnChange) then FOnChange; - Break; - end; - end; - end; -end; - -procedure TLandscape.OnMoveStaticPacket(ABuffer: TEnhancedMemoryStream); -var - sourceBlock, targetBlock: TSeperatedStaticBlock; - i: Integer; - statics: TList; - staticInfo: TStaticInfo; - staticItem: TStaticItem; - newX, newY: Word; - item: PLinkedItem; -begin - staticItem := nil; - ABuffer.Read(staticInfo, SizeOf(TStaticInfo)); - newX := EnsureRange(ABuffer.ReadWord, 0, FCellWidth - 1); - newY := EnsureRange(ABuffer.ReadWord, 0, FCellHeight - 1); - - sourceBlock := GetStaticBlock(staticInfo.X div 8, staticInfo.Y div 8); - targetBlock := GetStaticBlock(newX div 8, newY div 8); - if sourceBlock <> nil then - begin - statics := sourceBlock.Cells[(staticInfo.Y mod 8) * 8 + staticInfo.X mod 8]; - i := 0; - while (i < statics.Count) and (staticItem = nil) do - begin - staticItem := TStaticItem(statics.Items[i]); - if (staticItem.Z <> staticInfo.Z) or - (staticItem.TileID <> staticInfo.TileID) or - (staticItem.Hue <> staticInfo.Hue) then - begin - staticItem := nil; - end; - Inc(i); - end; - - if staticItem <> nil then - begin - statics.Remove(staticItem); - staticItem.Delete; - end; - end; - - if targetBlock <> nil then - begin - staticItem := TStaticItem.Create(nil, nil, 0, 0); - staticItem.X := newX; - staticItem.Y := newY; - staticItem.Z := staticInfo.Z; - staticItem.TileID := staticInfo.TileID; - staticItem.Hue := staticInfo.Hue; - statics := targetBlock.Cells[(newY mod 8) * 8 + newX mod 8]; - statics.Add(staticItem); - for i := 0 to statics.Count - 1 do - UpdateStaticsPriority(TStaticItem(statics.Items[i]), i); - ListSort(statics, @Compare); - staticItem.Owner := targetBlock; - end; - - if Assigned(FOnChange) then FOnChange; -end; - -procedure TLandscape.OnHueStaticPacket(ABuffer: TEnhancedMemoryStream); -var - block: TSeperatedStaticBlock; - i,j : Integer; - statics: TList; - staticInfo: TStaticInfo; - staticItem: TStaticItem; -begin - ABuffer.Read(staticInfo, SizeOf(TStaticInfo)); - block := GetStaticBlock(staticInfo.X div 8, staticInfo.Y div 8); - if block <> nil then - begin - statics := block.Cells[(staticInfo.Y mod 8) * 8 + staticInfo.X mod 8]; - for i := 0 to statics.Count - 1 do - begin - staticItem := TStaticItem(statics.Items[i]); - if (staticItem.Z = staticInfo.Z) and - (staticItem.TileID = staticInfo.TileID) and - (staticItem.Hue = staticInfo.Hue) then - begin - staticItem.Hue := ABuffer.ReadWord; - if Assigned(FOnChange) then FOnChange; - Break; - end; - end; - end; -end; - -procedure TLandscape.OnRemoveCachedObject(AObject: TObject); -var - block: TBlock; -begin - block := AObject as TBlock; - if block <> nil then - dmNetwork.Send(TFreeBlockPacket.Create(block.Map.X, block.Map.Y)); -end; - -{ TMaterial } - -constructor TMaterial.Create(AWidth, AHeight: Integer; - AGraphic: TSingleImage); -var - caps: TGLTextureCaps; -begin - inherited Create; - FRealWidth := AWidth; - FRealHeight := AHeight; - GetGLTextureCaps(caps); - if caps.PowerOfTwo then - begin - if IsPow2(AWidth) then FWidth := AWidth else FWidth := NextPow2(AWidth); - if IsPow2(AHeight) then FHeight := AHeight else FHeight := NextPow2(AHeight); - end else - begin - FWidth := AWidth; - FHeight := AHeight; - end; - FGraphic := TSingleImage.CreateFromParams(FWidth, FHeight, ifA8R8G8B8); - AGraphic.CopyTo(0, 0, AWidth, AHeight, FGraphic, 0, 0); - UpdateTexture; -end; - -destructor TMaterial.Destroy; -begin - if FGraphic <> nil then FreeAndNil(FGraphic); - if FTexture <> 0 then glDeleteTextures(1, @FTexture); - inherited Destroy; -end; - -function TMaterial.HitTest(AX, AY: Integer): Boolean; -var - pixel: TColor32Rec; -begin - Result := False; - //writeln(FGraphic.Width, ',', FGraphic.Height, ',', AX, ',', AY); - if InRange(AX, 0, FGraphic.Width - 1) and - InRange(AY, 0, FGraphic.Height - 1) then - begin - pixel := GetPixel32(FGraphic.ImageDataPointer^, AX, AY); - if pixel.A > 0 then - Result := True; - end; -end; - -procedure TMaterial.UpdateTexture; -begin - if FTexture <> 0 then glDeleteTextures(1, @FTexture); - - FTexture := CreateGLTextureFromImage(FGraphic.ImageDataPointer^, 0, 0, False, ifUnknown, @FWidth, @FHeight); - glBindTexture(GL_TEXTURE_2D, FTexture); - {glGetTexLevelParameteriv(GL_TEXTURE_2D, 0, GL_TEXTURE_WIDTH, @FWidth); - glGetTexLevelParameteriv(GL_TEXTURE_2D, 0, GL_TEXTURE_HEIGHT, @FHeight);} - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST); - glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP); - glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP); -end; - -{ TTileList } - -constructor TTileList.Create; -begin - inherited Create; - FFirst := nil; - FLastBlock := nil; -end; - -destructor TTileList.Destroy; -begin - Clear; - inherited Destroy; -end; - -procedure TTileList.Clear; -var - current, next: PBlockInfo; -begin - current := FFirst; - while current <> nil do - begin - next := current^.Next; - Dispose(current); - current := next; - end; - FFirst := nil; - FLastBlock := nil; -end; - -function TTileList.Iterate(var ABlockInfo: PBlockInfo): Boolean; -begin - if ABlockInfo = nil then - ABlockInfo := FFirst - else - ABlockInfo := ABlockInfo^.Next; - Result := ABlockInfo <> nil; -end; - -procedure TTileList.Add(AItem: TWorldItem); -var - current: PBlockInfo; -begin - New(current); - current^.Item := AItem; - current^.Next := nil; - if FFirst = nil then FFirst := current; - if FLastBlock <> nil then FLastBlock^.Next := current; - FLastBlock := current; -end; - -procedure TTileList.Delete(AItem: TWorldItem); -var - current, last, next: PBlockInfo; -begin - last := nil; - current := FFirst; - while current <> nil do - begin - if current^.Item = AItem then - begin - if FFirst = current then FFirst := current^.Next; - if FLastBlock = current then FLastBlock := last; - if last <> nil then last^.Next := current^.Next; - Dispose(current); - next := nil; - end else - next := current^.Next; - last := current; - current := next; - end; -end; - -{ TScreenBuffer } - -procedure TScreenBuffer.OnTileRemoved(ATile: TMulBlock); -var - currentItem, lastItem, nextItem: PBlockInfo; -begin - lastItem := nil; - currentItem := FFirst; - while currentItem <> nil do - begin - if currentItem^.Item = ATile then - begin - if FFirst = currentItem then FFirst := currentItem^.Next; - if FLastBlock = currentItem then FLastBlock := lastItem; - if lastItem <> nil then lastItem^.Next := currentItem^.Next; - Dispose(currentItem); - nextItem := nil; - end else - nextItem := currentItem^.Next; - lastItem := currentItem; - currentItem := nextItem; - end; -end; - -procedure TScreenBuffer.Clear; -var - current, next: PBlockInfo; -begin - current := FFirst; - while current <> nil do - begin - next := current^.Next; - current^.Item.Locked := False; - current^.Item.OnDestroy.UnregisterEvent(@OnTileRemoved); - Dispose(current); - current := next; - end; - FFirst := nil; - FLastBlock := nil; -end; - -function TScreenBuffer.Find(AScreenPosition: TPoint): PBlockInfo; -var - current: PBlockInfo; -begin - Result := nil; - current := FFirst; - while (current <> nil) and (Result = nil) do - begin - if PtInRect(current^.ScreenRect, AScreenPosition) and - current^.Material.HitTest(AScreenPosition.x - current^.ScreenRect.Left, - AScreenPosition.y - current^.ScreenRect.Top) then - begin - Result := current; - end; - current := current^.Next; - end; -end; - -procedure TScreenBuffer.Store(AScreenRect: TRect; AItem: TWorldItem; - AMaterial: TMaterial); -var - current: PBlockInfo; -begin - New(current); - AItem.Locked := True; - AItem.OnDestroy.RegisterEvent(@OnTileRemoved); - current^.ScreenRect := AScreenRect; - current^.Item := AItem; - current^.Material := AMaterial; - current^.Next := FFirst; - FFirst := current; - if FLastBlock = nil then FLastBlock := current; -end; - -end. - +(* + * CDDL HEADER START + * + * The contents of this file are subject to the terms of the + * Common Development and Distribution License, Version 1.0 only + * (the "License"). You may not use this file except in compliance + * with the License. + * + * You can obtain a copy of the license at + * http://www.opensource.org/licenses/cddl1.php. + * See the License for the specific language governing permissions + * and limitations under the License. + * + * When distributing Covered Code, include this CDDL HEADER in each + * file and include the License file at + * http://www.opensource.org/licenses/cddl1.php. If applicable, + * add the following below this CDDL HEADER, with the fields enclosed + * by brackets "[]" replaced with your own identifying * information: + * Portions Copyright [yyyy] [name of copyright owner] + * + * CDDL HEADER END + * + * + * Portions Copyright 2007 Andreas Schneider + *) +unit ULandscape; + +{$mode objfpc}{$H+} + +interface + +uses + SysUtils, Classes, math, contnrs, LCLIntf, GL, GLU, ImagingOpenGL, + Imaging, ImagingClasses, ImagingTypes, ImagingUtility, + UGenericIndex, UMap, UStatics, UArt, UTexture, UTiledata, UHue, UWorldItem, + UMulBlock, + UListSort, UVector, UEnhancedMemoryStream, + UCacheManager, ULinkedList; + +type + TNormals = array[0..3] of TVector; + PRadarBlock = ^TRadarBlock; + TRadarBlock = array[0..7, 0..7] of Word; + + { TMaterial } + + TMaterial = class(TObject) + constructor Create(AWidth, AHeight: Integer; AGraphic: TSingleImage); + destructor Destroy; override; + protected + FWidth: Integer; + FHeight: Integer; + FRealWidth: Integer; + FRealHeight: Integer; + FTexture: GLuint; + FGraphic: TSingleImage; + public + property Width: Integer read FWidth; + property Height: Integer read FHeight; + property RealWidth: Integer read FRealWidth; + property RealHeight: Integer read FRealHeight; + property Texture: GLuint read FTexture; + property Graphic: TSingleImage read FGraphic; + + function HitTest(AX, AY: Integer): Boolean; + procedure UpdateTexture; + end; + + { TLandTextureManager } + + TLandTextureManager = class(TObject) + constructor Create; + destructor Destroy; override; + function GetArtMaterial(ATileID: Word): TMaterial; overload; + function GetArtMaterial(ATileID: Word; AHue: THue; APartialHue: Boolean): TMaterial; overload; + function GetFlatLandMaterial(ATileID: Word): TMaterial; + function GetTexMaterial(ATileID: Word): TMaterial; + protected + FArtCache: TCacheManager; + FFlatLandArtCache: TCacheManager; + FTexCache: TCacheManager; + end; + + { TBlock } + + TBlock = class(TObject) + constructor Create(AMap: TMapBlock; AStatics: TStaticBlock); + destructor Destroy; override; + protected + FMapBlock: TMapBlock; + FStaticBlock: TStaticBlock; + public + property Map: TMapBlock read FMapBlock; + property Static: TStaticBlock read FStaticBlock; + end; + + TLandscapeChangeEvent = procedure of object; + TStaticFilter = function(AStatic: TStaticItem): Boolean of object; + + { TLandscape } + + TLandscape = class(TObject) + constructor Create(AWidth, AHeight: Word); + destructor Destroy; override; + protected + FWidth: Word; + FHeight: Word; + FCellWidth: Word; + FCellHeight: Word; + FBlockCache: TCacheManager; + FOnChange: TLandscapeChangeEvent; + FOpenRequests: array of Boolean; + function Compare(left, right: TObject): Integer; + function GetNormals(AX, AY: Word): TNormals; + function GetMapCell(AX, AY: Word): TMapCell; + function GetStaticList(AX, AY: Word): TList; + function GetMapBlock(AX, AY: Word): TMapBlock; + function GetStaticBlock(AX, AY: Word): TSeperatedStaticBlock; + procedure UpdateStaticsPriority(AStaticItem: TStaticItem; + APrioritySolver: Integer); + procedure OnBlockChanged(ABlock: TMulBlock); + procedure OnRemoveCachedObject(AObject: TObject); + + procedure OnBlocksPacket(ABuffer: TEnhancedMemoryStream); + procedure OnDrawMapPacket(ABuffer: TEnhancedMemoryStream); + procedure OnInsertStaticPacket(ABuffer: TEnhancedMemoryStream); + procedure OnDeleteStaticPacket(ABuffer: TEnhancedMemoryStream); + procedure OnElevateStaticPacket(ABuffer: TEnhancedMemoryStream); + procedure OnMoveStaticPacket(ABuffer: TEnhancedMemoryStream); + procedure OnHueStaticPacket(ABuffer: TEnhancedMemoryStream); + public + property Width: Word read FWidth; + property Height: Word read FHeight; + property CellWidth: Word read FCellWidth; + property CellHeight: Word read FCellHeight; + property MapCell[X, Y: Word]: TMapCell read GetMapCell; + property StaticList[X, Y: Word]: TList read GetStaticList; + property Normals[X, Y: Word]: TNormals read GetNormals; + property OnChange: TLandscapeChangeEvent read FOnChange write FOnChange; + + function GetDrawList(AX, AY: Word; AMinZ, AMaxZ: ShortInt; + AGhostTile: TWorldItem; AVirtualLayer: TStaticItem; AMap, + AStatics: Boolean; ANoDraw:Boolean; AStaticsFilter: TStaticFilter): TList; + function GetEffectiveAltitude(ATile: TMapCell): ShortInt; + function GetLandAlt(AX, AY: Word; ADefault: ShortInt): ShortInt; + + procedure MoveStatic(AStatic: TStaticItem; AX, AY: Word); + procedure PrepareBlocks(AX1, AY1, AX2, AY2: Word); + end; + PBlockInfo = ^TBlockInfo; + TBlockInfo = record + ScreenRect: TRect; + Item: TWorldItem; + Material: TMaterial; + Next: PBlockInfo; + end; + + { TTileList } + + TTileList = class(TObject) + constructor Create; virtual; + destructor Destroy; override; + protected + FFirst: PBlockInfo; + FLastBlock: PBlockInfo; + public + procedure Clear; virtual; + function Iterate(var ABlockInfo: PBlockInfo): Boolean; virtual; + procedure Add(AItem: TWorldItem); virtual; + procedure Delete(AItem: TWorldItem); virtual; + property LastBlock: PBlockInfo read FLastBlock; + end; + + { TScreenBuffer } + + TScreenBuffer = class(TTileList) + public + procedure OnTileRemoved(ATile: TMulBlock); + procedure Clear; override; + function Find(AScreenPosition: TPoint): PBlockInfo; + procedure Store(AScreenRect: TRect; AItem: TWorldItem; AMaterial: TMaterial); + end; + + TStaticInfo = packed record + X: Word; + Y: Word; + Z: ShortInt; + TileID: Word; + Hue: Word; + end; + //operator=(AStaticItem: TStaticItem; AStaticInfo: TStaticInfo): Boolean; + +implementation + +uses + UGameResources, UdmNetwork, UPackets, UPacketHandlers; + +const + mMap = 0; + mStatics = 1; + +function GetID(AX, AY: Word): Integer; +begin + Result := ((AX and $7FFF) shl 15) or (AY and $7FFF); +end; + +{operator=(AStaticItem: TStaticItem; AStaticInfo: TStaticInfo): Boolean; +begin + Result := (AStaticItem.X = AStaticInfo.X) and + (AStaticItem.Y = AStaticInfo.Y) and + (AStaticItem.Z = AStaticInfo.Z) and + (AStaticItem.TileID = AStaticInfo.TileID) and + (AStaticItem.Hue = AStaticInfo.Hue); +end;} + +{ TLandTextureManager } + +constructor TLandTextureManager.Create; +begin + inherited Create; + FArtCache := TCacheManager.Create(1024); + FFlatLandArtCache := TCacheManager.Create(128); + FTexCache := TCacheManager.Create(128); +end; + +destructor TLandTextureManager.Destroy; +begin + if FArtCache <> nil then FreeAndNil(FArtCache); + if FFlatLandArtCache <> nil then FreeAndNil(FFlatLandArtCache); + if FTexCache <> nil then FreeAndNil(FTexCache); + inherited Destroy; +end; + +function TLandTextureManager.GetArtMaterial(ATileID: Word): TMaterial; +var + artEntry: TArt; +begin + if not FArtCache.QueryID(ATileID, TObject(Result)) then + begin + artEntry := TArt(ResMan.Art.Block[ATileID]); + + Result := TMaterial.Create(artEntry.Graphic.Width, artEntry.Graphic.Height, + artEntry.Graphic); + FArtCache.StoreID(ATileID, Result); + + artEntry.Free; + end; +end; + +function TLandTextureManager.GetArtMaterial(ATileID: Word; AHue: THue; APartialHue: Boolean): TMaterial; +var + artEntry: TArt; + id: Integer; +begin + if AHue = nil then + begin + Result := GetArtMaterial(ATileID); + end else + begin + id := ATileID or ((AHue.ID and $3FFF) shl 15) or (Byte(APartialHue) shl 29); + if not FArtCache.QueryID(id, TObject(Result)) then + begin + artEntry := ResMan.Art.GetArt(ATileID, 0, AHue, APartialHue); + + Result := TMaterial.Create(artEntry.Graphic.Width, artEntry.Graphic.Height, + artEntry.Graphic); + FArtCache.StoreID(id, Result); + + artEntry.Free; + end; + end; +end; + +function TLandTextureManager.GetFlatLandMaterial(ATileID: Word): TMaterial; +var + artEntry: TArt; +begin + if not FFlatLandArtCache.QueryID(ATileID, TObject(Result)) then + begin + artEntry := ResMan.Art.GetFlatLand(ATileID); + + Result := TMaterial.Create(artEntry.Graphic.Width, artEntry.Graphic.Height, + artEntry.Graphic); + FFlatLandArtCache.StoreID(ATileID, Result); + + artEntry.Free; + end; +end; + +function TLandTextureManager.GetTexMaterial(ATileID: Word): TMaterial; +var + texEntry: TTexture; + texID: Integer; +begin + if not FTexCache.QueryID(ATileID, TObject(Result)) then + begin + texID := ResMan.Tiledata.LandTiles[ATileID].TextureID; + if texID > 0 then + begin + texEntry := TTexture(ResMan.Texmaps.Block[texID]); + + Result := TMaterial.Create(texEntry.Graphic.Width, texEntry.Graphic.Height, + texEntry.Graphic); + FTexCache.StoreID(ATileID, Result); + + texEntry.Free; + end else + Result := nil; + end; +end; + +{ TBlock } + +constructor TBlock.Create(AMap: TMapBlock; AStatics: TStaticBlock); +begin + inherited Create; + FMapBlock := AMap; + FStaticBlock := AStatics; +end; + +destructor TBlock.Destroy; +begin + if FMapBlock <> nil then FreeAndNil(FMapBlock); + if FStaticBlock <> nil then FreeAndNil(FStaticBlock); + inherited Destroy; +end; + +{ TLandscape } + +constructor TLandscape.Create(AWidth, AHeight: Word); +var + blockID: Integer; +begin + inherited Create; + FWidth := AWidth; + FHeight := AHeight; + FCellWidth := FWidth * 8; + FCellHeight := FHeight * 8; + FBlockCache := TCacheManager.Create(256); + FBlockCache.OnRemoveObject := @OnRemoveCachedObject; + + SetLength(FOpenRequests, FWidth * FHeight); + for blockID := 0 to Length(FOpenRequests) - 1 do + FOpenRequests[blockID] := False; + + RegisterPacketHandler($04, TPacketHandler.Create(0, @OnBlocksPacket)); + RegisterPacketHandler($06, TPacketHandler.Create(8, @OnDrawMapPacket)); + RegisterPacketHandler($07, TPacketHandler.Create(10, @OnInsertStaticPacket)); + RegisterPacketHandler($08, TPacketHandler.Create(10, @OnDeleteStaticPacket)); + RegisterPacketHandler($09, TPacketHandler.Create(11, @OnElevateStaticPacket)); + RegisterPacketHandler($0A, TPacketHandler.Create(14, @OnMoveStaticPacket)); + RegisterPacketHandler($0B, TPacketHandler.Create(12, @OnHueStaticPacket)); +end; + +destructor TLandscape.Destroy; +var + i: Integer; +begin + if FBlockCache <> nil then + begin + FBlockCache.OnRemoveObject := nil; + FreeAndNil(FBlockCache); + end; + + RegisterPacketHandler($04, nil); + RegisterPacketHandler($06, nil); + RegisterPacketHandler($07, nil); + RegisterPacketHandler($08, nil); + RegisterPacketHandler($09, nil); + RegisterPacketHandler($0A, nil); + RegisterPacketHandler($0B, nil); + + inherited Destroy; +end; + +function TLandscape.GetMapCell(AX, AY: Word): TMapCell; +var + block: TMapBlock; +begin + Result := nil; + if (AX >= 0) and (AX <= FCellWidth) and (AY >= 0) and (AY <= FCellHeight) then + begin + block := GetMapBlock(AX div 8, AY div 8); + if block <> nil then + Result := block.Cells[(AY mod 8) * 8 + AX mod 8]; + end; +end; + +function TLandscape.GetLandAlt(AX, AY: Word; ADefault: ShortInt): ShortInt; +var + cell: TMapCell; +begin + cell := MapCell[AX, AY]; + if cell <> nil then + Result := cell.Altitude + else + Result := ADefault; +end; + +function TLandscape.GetStaticList(AX, AY: Word): TList; +var + block: TSeperatedStaticBlock; +begin + Result := nil; + if (AX >= 0) and (AX <= FCellWidth) and (AY >= 0) and (AY <= FCellHeight) then + begin + block := GetStaticBlock(AX div 8, AY div 8); + if block <> nil then + Result := block.Cells[(AY mod 8) * 8 + AX mod 8]; + end; +end; + +function TLandscape.Compare(left, right: TObject): Integer; +begin + Result := TWorldItem(right).Priority - TWorldItem(left).Priority; + if Result = 0 then + begin + if (left is TMapCell) and (right is TStaticItem) then + Result := 1 + else if (left is TStaticItem) and (right is TMapCell) then + Result := -1; + end; + + if Result = 0 then + Result := TWorldItem(right).PriorityBonus - TWorldItem(left).PriorityBonus; + + if Result = 0 then + Result := TWorldItem(right).PrioritySolver - TWorldItem(left).PrioritySolver; +end; + +function TLandscape.GetDrawList(AX, AY: Word; AMinZ, AMaxZ: ShortInt; + AGhostTile: TWorldItem; AVirtualLayer: TStaticItem; AMap, + AStatics: Boolean; ANoDraw:Boolean; AStaticsFilter: TStaticFilter): TList; +var + landAlt: ShortInt; + drawMapCell: TMapCell; + drawStatics: TList; + i: Integer; +begin + Result := TList.Create; + if AMap then + begin + landAlt := GetLandAlt(AX, AY, 0); + if (landAlt >= AMinZ) and (landAlt <= AMaxZ) then + begin + drawMapCell := GetMapCell(AX, AY); + if (drawMapCell <> nil) and (ANoDraw or (drawMapCell.TileID > 2)) then + begin + drawMapCell.Priority := GetEffectiveAltitude(drawMapCell); + drawMapCell.PriorityBonus := 0; + drawMapCell.PrioritySolver := 0; + Result.Add(drawMapCell); + end; + + if AGhostTile is TMapCell then + begin + AGhostTile.X := AX; + AGhostTile.Y := AY; + AGhostTile.Priority := GetEffectiveAltitude(TMapCell(AGhostTile)); + AGhostTile.PriorityBonus := 0; + AGhostTile.PrioritySolver := 0; + Result.Add(AGhostTile); + end; + end; + end; + + if AStatics then + begin + drawStatics := GetStaticList(AX, AY); + if drawStatics <> nil then + for i := 0 to drawStatics.Count - 1 do + if (TStaticItem(drawStatics[i]).Z >= AMinZ) and + (TStaticItem(drawStatics[i]).Z <= AMaxZ) and + ((AStaticsFilter = nil) or AStaticsFilter(TStaticItem(drawStatics[i]))) then + begin + UpdateStaticsPriority(TStaticItem(drawStatics[i]), i + 1); + Result.Add(Pointer(drawStatics[i])); + end; + + + if AGhostTile is TStaticItem then + begin + UpdateStaticsPriority(TStaticItem(AGhostTile), MaxInt); + Result.Add(AGhostTile); + end; + end; + + if AVirtualLayer <> nil then + begin + UpdateStaticsPriority(AVirtualLayer, MaxInt-1); + Result.Add(AVirtualLayer); + end; + + ListSort(Result, @Compare); +end; + +function TLandscape.GetEffectiveAltitude(ATile: TMapCell): ShortInt; +var + north, west, south, east: ShortInt; +begin + north := ATile.Altitude; + west := GetLandAlt(ATile.X, ATile.Y + 1, north); + south := GetLandAlt(ATile.X + 1, ATile.Y + 1, north); + east := GetLandAlt(ATile.X + 1, ATile.Y, north); + + if Abs(north - south) > Abs(west - east) then + Result := (north + south) div 2 + else + Result := (west + east) div 2; +end; + +function TLandscape.GetNormals(AX, AY: Word): TNormals; +var + cells: array[0..2, 0..2] of TNormals; + north, west, south, east: TVector; + i, j: Integer; + + function GetPlainNormals(X, Y: SmallInt): TNormals; + var + cell: TMapCell; + north, west, south, east: ShortInt; + u, v: TVector; + begin + cell := GetMapCell(X, Y); + if Assigned(cell) then + begin + north := cell.Altitude; + west := GetLandAlt(cell.X, cell.Y + 1, north); + south := GetLandAlt(cell.X + 1, cell.Y + 1, north); + east := GetLandAlt(cell.X + 1, cell.Y, north); + end else + begin + north := 0; + west := 0; + east := 0; + south := 0; + end; + + if (north = west) and (west = east) and (north = south) then + begin + Result[0] := Vector(0, 0, 1); + Result[1] := Vector(0, 0, 1); + Result[2] := Vector(0, 0, 1); + Result[3] := Vector(0, 0, 1); + end else + begin + u := Vector(-22, 22, (north - east) * 4); + v := Vector(-22, -22, (west - north) * 4); + Result[0] := VectorNorm(VectorCross(u, v)); + + u := Vector(22, 22, (east - south) * 4); + v := Vector(-22, 22, (north - east) * 4); + Result[1] := VectorNorm(VectorCross(u, v)); + + u := Vector(22, -22, (south - west) * 4); + v := Vector(22, 22, (east - south) * 4); + Result[2] := VectorNorm(VectorCross(u, v)); + + u := Vector(-22, -22, (west - north) * 4); + v := Vector(22, -22, (south - west) * 4); + Result[3] := VectorNorm(VectorCross(u, v)); + end; + end; +begin + for i := 0 to 2 do + for j := 0 to 2 do + cells[i, j] := GetPlainNormals(AX - 1 + i, AY - 1 + j); + + north := cells[0, 0][2]; + west := cells[0, 1][1]; + east := cells[1, 0][3]; + south := cells[1, 1][0]; + Result[0] := VectorNorm(VectorAdd(VectorAdd(VectorAdd(north, west), east), south)); + + north := cells[1, 0][2]; + west := cells[1, 1][1]; + east := cells[2, 0][3]; + south := cells[2, 1][0]; + Result[1] := VectorNorm(VectorAdd(VectorAdd(VectorAdd(north, west), east), south)); + + north := cells[1, 1][2]; + west := cells[1, 2][1]; + east := cells[2, 1][3]; + south := cells[2, 2][0]; + Result[2] := VectorNorm(VectorAdd(VectorAdd(VectorAdd(north, west), east), south)); + + north := cells[0, 1][2]; + west := cells[0, 2][1]; + east := cells[1, 1][3]; + south := cells[1, 2][0]; + Result[3] := VectorNorm(VectorAdd(VectorAdd(VectorAdd(north, west), east), south)); +end; + +procedure TLandscape.OnBlockChanged(ABlock: TMulBlock); +var + block, old: TWorldBlock; + mode: Byte; + id, blockID: Integer; +begin + {block := ABlock as TWorldBlock; + if block <> nil then + begin + if block is TSeperatedStaticBlock then + mode := mStatics + else + mode := mMap; + id := GetID(block.X, block.Y, mode); + blockID := (block.X * FHeight) + block.Y; + if block.Changed or (block.RefCount > 0) then + begin + if FPersistentBlocks[blockID][mode] = nil then + begin + FPersistentBlocks[blockID][mode] := block; + FBlockCache.DiscardID(id); + end; + end else + begin + FPersistentBlocks[blockID][mode] := nil; + if not FBlockCache.QueryID(id, TObject(old)) then + FBlockCache.StoreID(id, block); + end; + end;} +end; + +procedure TLandscape.MoveStatic(AStatic: TStaticItem; AX, AY: Word); +var + sourceBlock, targetBlock: TSeperatedStaticBlock; + targetStaticList: TList; + i: Integer; +begin + if (AX >= 0) and (AX <= FCellWidth) and (AY >= 0) and (AY <= FCellHeight) then + begin + sourceBlock := AStatic.Owner as TSeperatedStaticBlock; + targetBlock := GetStaticBlock(AX div 8, AY div 8); + if (sourceBlock <> nil) and (targetBlock <> nil) then + begin + sourceBlock.Cells[(AStatic.Y mod 8) * 8 + AStatic.X mod 8].Remove(AStatic); + targetStaticList := targetBlock.Cells[(AY mod 8) * 8 + AX mod 8]; + targetStaticList.Add(AStatic); + for i := 0 to targetStaticList.Count - 1 do + UpdateStaticsPriority(TStaticItem(targetStaticList.Items[i]), i); + ListSort(targetStaticList, @Compare); + AStatic.UpdatePos(AX, AY, AStatic.Z); + AStatic.Owner := targetBlock; + end; + end; +end; + +procedure TLandscape.PrepareBlocks(AX1, AY1, AX2, AY2: Word); +var + x, y, i, mapID, staticID: Integer; + coords: TBlockCoordsArray; + obj: TObject; +begin + AX1 := EnsureRange(AX1, 0, FWidth - 1); + AY1 := EnsureRange(AY1, 0, FHeight - 1); + AX2 := EnsureRange(AX2, 0, FWidth - 1); + AY2 := EnsureRange(AY2, 0, FHeight - 1); + + SetLength(coords, 0); + for x := AX1 to AX2 do + begin + for y := AY1 to AY2 do + begin + if (not FOpenRequests[y * FWidth + x]) and + (not FBlockCache.QueryID(GetID(x, y), obj)) then + begin + SetLength(coords, Length(coords) + 1); + i := High(coords); + coords[i].X := x; + coords[i].Y := y; + FOpenRequests[y * FWidth + x] := True; + end; + end; + end; + if Length(coords) > 0 then + dmNetwork.Send(TRequestBlocksPacket.Create(coords)); +end; + +function TLandscape.GetMapBlock(AX, AY: Word): TMapBlock; +var + block: TBlock; +begin + Result := nil; + if (AX >= 0) and (AX < FWidth) and (AY >= 0) and (AY < FHeight) then + begin + if FBlockCache.QueryID(GetID(AX, AY), TObject(block)) then + Result := block.Map; + end; +end; + +function TLandscape.GetStaticBlock(AX, AY: Word): TSeperatedStaticBlock; +var + block: TBlock; +begin + Result := nil; + if (AX >= 0) and (AX < FWidth) and (AY >= 0) and (AY < FHeight) then + begin + if FBlockCache.QueryID(GetID(AX, AY), TObject(block)) then + Result := TSeperatedStaticBlock(block.Static); + end; +end; + +procedure TLandscape.UpdateStaticsPriority(AStaticItem: TStaticItem; + APrioritySolver: Integer); +var + staticTileData: TStaticTileData; +begin + staticTileData := ResMan.Tiledata.StaticTiles[AStaticItem.TileID]; + AStaticItem.PriorityBonus := 0; + if not ((staticTileData.Flags and tdfBackground) = tdfBackground) then + AStaticItem.PriorityBonus := AStaticItem.PriorityBonus + 1; + if staticTileData.Height > 0 then + AStaticItem.PriorityBonus := AStaticItem.PriorityBonus + 1; + AStaticItem.Priority := AStaticItem.Z + AStaticItem.PriorityBonus; + AStaticItem.PrioritySolver := APrioritySolver; +end; + +procedure TLandscape.OnBlocksPacket(ABuffer: TEnhancedMemoryStream); +var + index: TGenericIndex; + map: TMapBlock; + statics: TStaticBlock; + coords: TBlockCoords; + count: Word; + id: Integer; +begin + index := TGenericIndex.Create(nil); + while ABuffer.Position < ABuffer.Size do + begin + ABuffer.Read(coords, SizeOf(TBlockCoords)); + id := GetID(coords.X, coords.Y); + + map := TMapBlock.Create(ABuffer, coords.X, coords.Y); + count := ABuffer.ReadWord; + if count > 0 then + index.Lookup := ABuffer.Position + else + index.Lookup := $FFFFFFFF; + index.Size := count * 7; + statics := TSeperatedStaticBlock.Create(ABuffer, index, coords.X, coords.Y); + + FBlockCache.RemoveID(id); + FBlockCache.StoreID(id, TBlock.Create(map, statics)); + + FOpenRequests[coords.Y * FWidth + coords.X] := False; + end; + index.Free; + if Assigned(FOnChange) then FOnChange; +end; + +procedure TLandscape.OnDrawMapPacket(ABuffer: TEnhancedMemoryStream); +var + x, y: Word; + cell: TMapCell; +begin + x := ABuffer.ReadWord; + y := ABuffer.ReadWord; + cell := GetMapCell(x, y); + if cell <> nil then + begin + cell.Altitude := ABuffer.ReadShortInt; + cell.TileID := ABuffer.ReadWord; + if Assigned(FOnChange) then FOnChange; + end; +end; + +procedure TLandscape.OnInsertStaticPacket(ABuffer: TEnhancedMemoryStream); +var + x, y: Word; + block: TSeperatedStaticBlock; + staticItem: TStaticItem; + targetStaticList: TList; + i: Integer; +begin + x := ABuffer.ReadWord; + y := ABuffer.ReadWord; + block := GetStaticBlock(x div 8, y div 8); + if block <> nil then + begin + staticItem := TStaticItem.Create(nil, nil, 0, 0); + staticItem.X := x; + staticItem.Y := y; + staticItem.Z := ABuffer.ReadShortInt; + staticItem.TileID := ABuffer.ReadWord; + staticItem.Hue := ABuffer.ReadWord; + targetStaticList := block.Cells[(y mod 8) * 8 + x mod 8]; + targetStaticList.Add(staticItem); + for i := 0 to targetStaticList.Count - 1 do + UpdateStaticsPriority(TStaticItem(targetStaticList.Items[i]), i); + ListSort(targetStaticList, @Compare); + staticItem.Owner := block; + if Assigned(FOnChange) then FOnChange; + end; +end; + +procedure TLandscape.OnDeleteStaticPacket(ABuffer: TEnhancedMemoryStream); +var + block: TSeperatedStaticBlock; + i: Integer; + statics: TList; + staticInfo: TStaticInfo; + staticItem: TStaticItem; +begin + ABuffer.Read(staticInfo, SizeOf(TStaticInfo)); + block := GetStaticBlock(staticInfo.X div 8, staticInfo.Y div 8); + if block <> nil then + begin + statics := block.Cells[(staticInfo.Y mod 8) * 8 + staticInfo.X mod 8]; + for i := 0 to statics.Count - 1 do + begin + staticItem := TStaticItem(statics.Items[i]); + if (staticItem.Z = staticInfo.Z) and + (staticItem.TileID = staticInfo.TileID) and + (staticItem.Hue = staticInfo.Hue) then + begin + statics.Delete(i); + staticItem.Delete; + if Assigned(FOnChange) then FOnChange; + Break; + end; + end; + end; +end; + +procedure TLandscape.OnElevateStaticPacket(ABuffer: TEnhancedMemoryStream); +var + block: TSeperatedStaticBlock; + i,j : Integer; + statics: TList; + staticInfo: TStaticInfo; + staticItem: TStaticItem; +begin + ABuffer.Read(staticInfo, SizeOf(TStaticInfo)); + block := GetStaticBlock(staticInfo.X div 8, staticInfo.Y div 8); + if block <> nil then + begin + statics := block.Cells[(staticInfo.Y mod 8) * 8 + staticInfo.X mod 8]; + for i := 0 to statics.Count - 1 do + begin + staticItem := TStaticItem(statics.Items[i]); + if (staticItem.Z = staticInfo.Z) and + (staticItem.TileID = staticInfo.TileID) and + (staticItem.Hue = staticInfo.Hue) then + begin + staticItem.Z := ABuffer.ReadShortInt; + for j := 0 to statics.Count - 1 do + UpdateStaticsPriority(TStaticItem(statics.Items[j]), j); + ListSort(statics, @Compare); + if Assigned(FOnChange) then FOnChange; + Break; + end; + end; + end; +end; + +procedure TLandscape.OnMoveStaticPacket(ABuffer: TEnhancedMemoryStream); +var + sourceBlock, targetBlock: TSeperatedStaticBlock; + i: Integer; + statics: TList; + staticInfo: TStaticInfo; + staticItem: TStaticItem; + newX, newY: Word; + item: PLinkedItem; +begin + staticItem := nil; + ABuffer.Read(staticInfo, SizeOf(TStaticInfo)); + newX := EnsureRange(ABuffer.ReadWord, 0, FCellWidth - 1); + newY := EnsureRange(ABuffer.ReadWord, 0, FCellHeight - 1); + + sourceBlock := GetStaticBlock(staticInfo.X div 8, staticInfo.Y div 8); + targetBlock := GetStaticBlock(newX div 8, newY div 8); + if sourceBlock <> nil then + begin + statics := sourceBlock.Cells[(staticInfo.Y mod 8) * 8 + staticInfo.X mod 8]; + i := 0; + while (i < statics.Count) and (staticItem = nil) do + begin + staticItem := TStaticItem(statics.Items[i]); + if (staticItem.Z <> staticInfo.Z) or + (staticItem.TileID <> staticInfo.TileID) or + (staticItem.Hue <> staticInfo.Hue) then + begin + staticItem := nil; + end; + Inc(i); + end; + + if staticItem <> nil then + begin + statics.Remove(staticItem); + staticItem.Delete; + end; + end; + + if targetBlock <> nil then + begin + staticItem := TStaticItem.Create(nil, nil, 0, 0); + staticItem.X := newX; + staticItem.Y := newY; + staticItem.Z := staticInfo.Z; + staticItem.TileID := staticInfo.TileID; + staticItem.Hue := staticInfo.Hue; + statics := targetBlock.Cells[(newY mod 8) * 8 + newX mod 8]; + statics.Add(staticItem); + for i := 0 to statics.Count - 1 do + UpdateStaticsPriority(TStaticItem(statics.Items[i]), i); + ListSort(statics, @Compare); + staticItem.Owner := targetBlock; + end; + + if Assigned(FOnChange) then FOnChange; +end; + +procedure TLandscape.OnHueStaticPacket(ABuffer: TEnhancedMemoryStream); +var + block: TSeperatedStaticBlock; + i,j : Integer; + statics: TList; + staticInfo: TStaticInfo; + staticItem: TStaticItem; +begin + ABuffer.Read(staticInfo, SizeOf(TStaticInfo)); + block := GetStaticBlock(staticInfo.X div 8, staticInfo.Y div 8); + if block <> nil then + begin + statics := block.Cells[(staticInfo.Y mod 8) * 8 + staticInfo.X mod 8]; + for i := 0 to statics.Count - 1 do + begin + staticItem := TStaticItem(statics.Items[i]); + if (staticItem.Z = staticInfo.Z) and + (staticItem.TileID = staticInfo.TileID) and + (staticItem.Hue = staticInfo.Hue) then + begin + staticItem.Hue := ABuffer.ReadWord; + if Assigned(FOnChange) then FOnChange; + Break; + end; + end; + end; +end; + +procedure TLandscape.OnRemoveCachedObject(AObject: TObject); +var + block: TBlock; +begin + block := AObject as TBlock; + if block <> nil then + dmNetwork.Send(TFreeBlockPacket.Create(block.Map.X, block.Map.Y)); +end; + +{ TMaterial } + +constructor TMaterial.Create(AWidth, AHeight: Integer; + AGraphic: TSingleImage); +var + caps: TGLTextureCaps; +begin + inherited Create; + FRealWidth := AWidth; + FRealHeight := AHeight; + GetGLTextureCaps(caps); + if caps.NonPowerOfTwo then + begin + FWidth := AWidth; + FHeight := AHeight; + end else + begin + if IsPow2(AWidth) then FWidth := AWidth else FWidth := NextPow2(AWidth); + if IsPow2(AHeight) then FHeight := AHeight else FHeight := NextPow2(AHeight); + end; + FGraphic := TSingleImage.CreateFromParams(FWidth, FHeight, ifA8R8G8B8); + AGraphic.CopyTo(0, 0, AWidth, AHeight, FGraphic, 0, 0); + UpdateTexture; +end; + +destructor TMaterial.Destroy; +begin + if FGraphic <> nil then FreeAndNil(FGraphic); + if FTexture <> 0 then glDeleteTextures(1, @FTexture); + inherited Destroy; +end; + +function TMaterial.HitTest(AX, AY: Integer): Boolean; +var + pixel: TColor32Rec; +begin + Result := False; + //writeln(FGraphic.Width, ',', FGraphic.Height, ',', AX, ',', AY); + if InRange(AX, 0, FGraphic.Width - 1) and + InRange(AY, 0, FGraphic.Height - 1) then + begin + pixel := GetPixel32(FGraphic.ImageDataPointer^, AX, AY); + if pixel.A > 0 then + Result := True; + end; +end; + +procedure TMaterial.UpdateTexture; +begin + if FTexture <> 0 then glDeleteTextures(1, @FTexture); + + FTexture := CreateGLTextureFromImage(FGraphic.ImageDataPointer^, 0, 0, False, ifUnknown, @FWidth, @FHeight); + glBindTexture(GL_TEXTURE_2D, FTexture); + {glGetTexLevelParameteriv(GL_TEXTURE_2D, 0, GL_TEXTURE_WIDTH, @FWidth); + glGetTexLevelParameteriv(GL_TEXTURE_2D, 0, GL_TEXTURE_HEIGHT, @FHeight);} + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST); + glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP); + glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP); +end; + +{ TTileList } + +constructor TTileList.Create; +begin + inherited Create; + FFirst := nil; + FLastBlock := nil; +end; + +destructor TTileList.Destroy; +begin + Clear; + inherited Destroy; +end; + +procedure TTileList.Clear; +var + current, next: PBlockInfo; +begin + current := FFirst; + while current <> nil do + begin + next := current^.Next; + Dispose(current); + current := next; + end; + FFirst := nil; + FLastBlock := nil; +end; + +function TTileList.Iterate(var ABlockInfo: PBlockInfo): Boolean; +begin + if ABlockInfo = nil then + ABlockInfo := FFirst + else + ABlockInfo := ABlockInfo^.Next; + Result := ABlockInfo <> nil; +end; + +procedure TTileList.Add(AItem: TWorldItem); +var + current: PBlockInfo; +begin + New(current); + current^.Item := AItem; + current^.Next := nil; + if FFirst = nil then FFirst := current; + if FLastBlock <> nil then FLastBlock^.Next := current; + FLastBlock := current; +end; + +procedure TTileList.Delete(AItem: TWorldItem); +var + current, last, next: PBlockInfo; +begin + last := nil; + current := FFirst; + while current <> nil do + begin + if current^.Item = AItem then + begin + if FFirst = current then FFirst := current^.Next; + if FLastBlock = current then FLastBlock := last; + if last <> nil then last^.Next := current^.Next; + Dispose(current); + next := nil; + end else + next := current^.Next; + last := current; + current := next; + end; +end; + +{ TScreenBuffer } + +procedure TScreenBuffer.OnTileRemoved(ATile: TMulBlock); +var + currentItem, lastItem, nextItem: PBlockInfo; +begin + lastItem := nil; + currentItem := FFirst; + while currentItem <> nil do + begin + if currentItem^.Item = ATile then + begin + if FFirst = currentItem then FFirst := currentItem^.Next; + if FLastBlock = currentItem then FLastBlock := lastItem; + if lastItem <> nil then lastItem^.Next := currentItem^.Next; + Dispose(currentItem); + nextItem := nil; + end else + nextItem := currentItem^.Next; + lastItem := currentItem; + currentItem := nextItem; + end; +end; + +procedure TScreenBuffer.Clear; +var + current, next: PBlockInfo; +begin + current := FFirst; + while current <> nil do + begin + next := current^.Next; + current^.Item.Locked := False; + current^.Item.OnDestroy.UnregisterEvent(@OnTileRemoved); + Dispose(current); + current := next; + end; + FFirst := nil; + FLastBlock := nil; +end; + +function TScreenBuffer.Find(AScreenPosition: TPoint): PBlockInfo; +var + current: PBlockInfo; +begin + Result := nil; + current := FFirst; + while (current <> nil) and (Result = nil) do + begin + if PtInRect(current^.ScreenRect, AScreenPosition) and + current^.Material.HitTest(AScreenPosition.x - current^.ScreenRect.Left, + AScreenPosition.y - current^.ScreenRect.Top) then + begin + Result := current; + end; + current := current^.Next; + end; +end; + +procedure TScreenBuffer.Store(AScreenRect: TRect; AItem: TWorldItem; + AMaterial: TMaterial); +var + current: PBlockInfo; +begin + New(current); + AItem.Locked := True; + AItem.OnDestroy.RegisterEvent(@OnTileRemoved); + current^.ScreenRect := AScreenRect; + current^.Item := AItem; + current^.Material := AMaterial; + current^.Next := FFirst; + FFirst := current; + if FLastBlock = nil then FLastBlock := current; +end; + +end. + diff --git a/Client/UOverlayUI.pas b/Client/UOverlayUI.pas index 8a78321..48f0006 100644 --- a/Client/UOverlayUI.pas +++ b/Client/UOverlayUI.pas @@ -1,246 +1,246 @@ -(* - * CDDL HEADER START - * - * The contents of this file are subject to the terms of the - * Common Development and Distribution License, Version 1.0 only - * (the "License"). You may not use this file except in compliance - * with the License. - * - * You can obtain a copy of the license at - * http://www.opensource.org/licenses/cddl1.php. - * See the License for the specific language governing permissions - * and limitations under the License. - * - * When distributing Covered Code, include this CDDL HEADER in each - * file and include the License file at - * http://www.opensource.org/licenses/cddl1.php. If applicable, - * add the following below this CDDL HEADER, with the fields enclosed - * by brackets "[]" replaced with your own identifying * information: - * Portions Copyright [yyyy] [name of copyright owner] - * - * CDDL HEADER END - * - * - * Portions Copyright 2007 Andreas Schneider - *) -unit UOverlayUI; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, SysUtils, Gl, GLU, ImagingTypes, ImagingClasses, ImagingOpenGL, - OpenGLContext, ImagingUtility; - -type - - { TGLArrow } - - TGLArrow = class(TObject) - constructor Create(AGraphic: TSingleImage); - destructor Destroy; override; - protected - FGraphic: TSingleImage; - FTexture: GLuint; - FRealWidth: Integer; - FRealHeight: Integer; - FWidth: Integer; - FHeight: Integer; - FCurrentX: Integer; - FCurrentY: Integer; - procedure UpdateTexture; - public - property Width: Integer read FWidth; - property Height: Integer read FHeight; - property CurrentX: Integer read FCurrentX; - property CurrentY: Integer read FCurrentY; - - function HitTest(AX, AY: Integer): Boolean; - procedure DrawGL(AX, AY: Integer; AActive: Boolean = False); - end; - - { TOverlayUI } - - TOverlayUI = class(TObject) - constructor Create; - destructor Destroy; override; - protected - FArrows: array[0..7] of TGLArrow; - FActiveArrow: Integer; - FVisible: Boolean; - public - property ActiveArrow: Integer read FActiveArrow write FActiveArrow; - property Visible: Boolean read FVisible write FVisible; - function HitTest(AX, AY: Integer): Integer; - procedure Draw(AContext: TOpenGLControl); - end; - -implementation - -uses - UResourceManager; - -{ TGLArrow } - -constructor TGLArrow.Create(AGraphic: TSingleImage); -var - caps: TGLTextureCaps; -begin - inherited Create; - FRealWidth := AGraphic.Width; - FRealHeight := AGraphic.Height; - GetGLTextureCaps(caps); - if caps.PowerOfTwo then - begin - if IsPow2(FRealWidth) then FWidth := FRealWidth else FWidth := NextPow2(FRealWidth); - if IsPow2(FRealHeight) then FHeight := FRealHeight else FHeight := NextPow2(FRealHeight); - end else - begin - FWidth := FRealHeight; - FHeight := FRealHeight; - end; - FGraphic := TSingleImage.CreateFromParams(FWidth, FHeight, ifA8R8G8B8); - AGraphic.CopyTo(0, 0, FRealWidth, FRealHeight, FGraphic, 0, 0); - FTexture := 0; -end; - -destructor TGLArrow.Destroy; -begin - if FGraphic <> nil then FreeAndNil(FGraphic); - if FTexture <> 0 then glDeleteTextures(1, @FTexture); - inherited Destroy; -end; - -procedure TGLArrow.UpdateTexture; -begin - if (FGraphic <> nil) and (FRealWidth > 0) and (FRealWidth > 0) then - begin - FTexture := CreateGLTextureFromImage(FGraphic.ImageDataPointer^, 0, 0, False); - - glBindTexture(GL_TEXTURE_2D, FTexture); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST); - glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP); - glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP); - end; -end; - -function TGLArrow.HitTest(AX, AY: Integer): Boolean; -begin - if (AX > -1) and (AX < FRealWidth) and (AY > -1) and (AY < FRealHeight) then - begin - Result := (FGraphic <> nil) and (Cardinal(PIntegerArray(FGraphic.Bits)^[AY * FWidth + AX] and $FF000000) > 0); - end else - Result := False; -end; - -procedure TGLArrow.DrawGL(AX, AY: Integer; AActive: Boolean = False); -begin - FCurrentX := AX; - FCurrentY := AY; - - if FTexture = 0 then UpdateTexture; - - if FTexture <> 0 then - begin - if AActive then - begin - glEnable(GL_COLOR_LOGIC_OP); - glLogicOp(GL_COPY_INVERTED); - end; - - glBindTexture(GL_TEXTURE_2D, FTexture); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2d(AX, AY); - glTexCoord2f(1, 0); glVertex2d(AX + FWidth, AY); - glTexCoord2f(1, 1); glVertex2d(AX + FWidth, AY + FHeight); - glTexCoord2f(0, 1); glVertex2d(AX, AY + FHeight); - glEnd; - - if AActive then - glDisable(GL_COLOR_LOGIC_OP); - end; -end; - -{ TOverlayUI } - -constructor TOverlayUI.Create; -var - i: Integer; - arrow: TSingleImage; -begin - inherited Create; - FActiveArrow := -1; - FVisible := False; - - arrow := TSingleImage.CreateFromStream(ResourceManager.GetResource(0)); - for i := 0 to 3 do - begin - FArrows[2*i] := TGLArrow.Create(arrow); - arrow.Rotate(-90); - end; - arrow.Free; - arrow := TSingleImage.CreateFromStream(ResourceManager.GetResource(1)); - for i := 0 to 3 do - begin - FArrows[2*i+1] := TGLArrow.Create(arrow); - arrow.Rotate(-90); - end; - arrow.Free; -end; - -destructor TOverlayUI.Destroy; -var - i: Integer; -begin - for i := 0 to 7 do - if FArrows[i] <> nil then FreeAndNil(FArrows[i]); - - inherited Destroy; -end; - -function TOverlayUI.HitTest(AX, AY: Integer): Integer; -var - i: Integer; -begin - Result := -1; - i := 0; - while (i <= 7) and (Result = -1) do - begin - if FArrows[i].HitTest(AX - FArrows[i].CurrentX, AY - FArrows[i].CurrentY) then - Result := i; - Inc(i); - end; -end; - -procedure TOverlayUI.Draw(AContext: TOpenGLControl); -begin - if FVisible then - begin - FArrows[0].DrawGL(10, 10, FActiveArrow = 0); - FArrows[1].DrawGL(AContext.Width div 2 - FArrows[1].Width div 2, 10, - FActiveArrow = 1); - FArrows[2].DrawGL(AContext.Width - 10 - FArrows[2].Width, 10, - FActiveArrow = 2); - - FArrows[3].DrawGL(AContext.Width - 10 - FArrows[3].Width, - AContext.Height div 2 - FArrows[3].Height div 2, - FActiveArrow = 3); - - FArrows[4].DrawGL(AContext.Width - 10 - FArrows[4].Width, - AContext.Height - 10 - FArrows[4].Height, - FActiveArrow = 4); - FArrows[5].DrawGL(AContext.Width div 2 - FArrows[5].Width div 2, - AContext.Height - 10 - FArrows[5].Height, - FActiveArrow = 5); - FArrows[6].DrawGL(10, AContext.Height - 10 - FArrows[6].Height, - FActiveArrow = 6); - - FArrows[7].DrawGL(10, AContext.Height div 2 - FArrows[7].Height div 2, - FActiveArrow = 7); - end; -end; - -end. - +(* + * CDDL HEADER START + * + * The contents of this file are subject to the terms of the + * Common Development and Distribution License, Version 1.0 only + * (the "License"). You may not use this file except in compliance + * with the License. + * + * You can obtain a copy of the license at + * http://www.opensource.org/licenses/cddl1.php. + * See the License for the specific language governing permissions + * and limitations under the License. + * + * When distributing Covered Code, include this CDDL HEADER in each + * file and include the License file at + * http://www.opensource.org/licenses/cddl1.php. If applicable, + * add the following below this CDDL HEADER, with the fields enclosed + * by brackets "[]" replaced with your own identifying * information: + * Portions Copyright [yyyy] [name of copyright owner] + * + * CDDL HEADER END + * + * + * Portions Copyright 2007 Andreas Schneider + *) +unit UOverlayUI; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Gl, GLU, ImagingTypes, ImagingClasses, ImagingOpenGL, + OpenGLContext, ImagingUtility; + +type + + { TGLArrow } + + TGLArrow = class(TObject) + constructor Create(AGraphic: TSingleImage); + destructor Destroy; override; + protected + FGraphic: TSingleImage; + FTexture: GLuint; + FRealWidth: Integer; + FRealHeight: Integer; + FWidth: Integer; + FHeight: Integer; + FCurrentX: Integer; + FCurrentY: Integer; + procedure UpdateTexture; + public + property Width: Integer read FWidth; + property Height: Integer read FHeight; + property CurrentX: Integer read FCurrentX; + property CurrentY: Integer read FCurrentY; + + function HitTest(AX, AY: Integer): Boolean; + procedure DrawGL(AX, AY: Integer; AActive: Boolean = False); + end; + + { TOverlayUI } + + TOverlayUI = class(TObject) + constructor Create; + destructor Destroy; override; + protected + FArrows: array[0..7] of TGLArrow; + FActiveArrow: Integer; + FVisible: Boolean; + public + property ActiveArrow: Integer read FActiveArrow write FActiveArrow; + property Visible: Boolean read FVisible write FVisible; + function HitTest(AX, AY: Integer): Integer; + procedure Draw(AContext: TOpenGLControl); + end; + +implementation + +uses + UResourceManager; + +{ TGLArrow } + +constructor TGLArrow.Create(AGraphic: TSingleImage); +var + caps: TGLTextureCaps; +begin + inherited Create; + FRealWidth := AGraphic.Width; + FRealHeight := AGraphic.Height; + GetGLTextureCaps(caps); + if caps.NonPowerOfTwo then + begin + FWidth := FRealHeight; + FHeight := FRealHeight; + end else + begin + if IsPow2(FRealWidth) then FWidth := FRealWidth else FWidth := NextPow2(FRealWidth); + if IsPow2(FRealHeight) then FHeight := FRealHeight else FHeight := NextPow2(FRealHeight); + end; + FGraphic := TSingleImage.CreateFromParams(FWidth, FHeight, ifA8R8G8B8); + AGraphic.CopyTo(0, 0, FRealWidth, FRealHeight, FGraphic, 0, 0); + FTexture := 0; +end; + +destructor TGLArrow.Destroy; +begin + if FGraphic <> nil then FreeAndNil(FGraphic); + if FTexture <> 0 then glDeleteTextures(1, @FTexture); + inherited Destroy; +end; + +procedure TGLArrow.UpdateTexture; +begin + if (FGraphic <> nil) and (FRealWidth > 0) and (FRealWidth > 0) then + begin + FTexture := CreateGLTextureFromImage(FGraphic.ImageDataPointer^, 0, 0, False); + + glBindTexture(GL_TEXTURE_2D, FTexture); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST); + glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP); + glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP); + end; +end; + +function TGLArrow.HitTest(AX, AY: Integer): Boolean; +begin + if (AX > -1) and (AX < FRealWidth) and (AY > -1) and (AY < FRealHeight) then + begin + Result := (FGraphic <> nil) and (Cardinal(PIntegerArray(FGraphic.Bits)^[AY * FWidth + AX] and $FF000000) > 0); + end else + Result := False; +end; + +procedure TGLArrow.DrawGL(AX, AY: Integer; AActive: Boolean = False); +begin + FCurrentX := AX; + FCurrentY := AY; + + if FTexture = 0 then UpdateTexture; + + if FTexture <> 0 then + begin + if AActive then + begin + glEnable(GL_COLOR_LOGIC_OP); + glLogicOp(GL_COPY_INVERTED); + end; + + glBindTexture(GL_TEXTURE_2D, FTexture); + glBegin(GL_QUADS); + glTexCoord2f(0, 0); glVertex2d(AX, AY); + glTexCoord2f(1, 0); glVertex2d(AX + FWidth, AY); + glTexCoord2f(1, 1); glVertex2d(AX + FWidth, AY + FHeight); + glTexCoord2f(0, 1); glVertex2d(AX, AY + FHeight); + glEnd; + + if AActive then + glDisable(GL_COLOR_LOGIC_OP); + end; +end; + +{ TOverlayUI } + +constructor TOverlayUI.Create; +var + i: Integer; + arrow: TSingleImage; +begin + inherited Create; + FActiveArrow := -1; + FVisible := False; + + arrow := TSingleImage.CreateFromStream(ResourceManager.GetResource(0)); + for i := 0 to 3 do + begin + FArrows[2*i] := TGLArrow.Create(arrow); + arrow.Rotate(-90); + end; + arrow.Free; + arrow := TSingleImage.CreateFromStream(ResourceManager.GetResource(1)); + for i := 0 to 3 do + begin + FArrows[2*i+1] := TGLArrow.Create(arrow); + arrow.Rotate(-90); + end; + arrow.Free; +end; + +destructor TOverlayUI.Destroy; +var + i: Integer; +begin + for i := 0 to 7 do + if FArrows[i] <> nil then FreeAndNil(FArrows[i]); + + inherited Destroy; +end; + +function TOverlayUI.HitTest(AX, AY: Integer): Integer; +var + i: Integer; +begin + Result := -1; + i := 0; + while (i <= 7) and (Result = -1) do + begin + if FArrows[i].HitTest(AX - FArrows[i].CurrentX, AY - FArrows[i].CurrentY) then + Result := i; + Inc(i); + end; +end; + +procedure TOverlayUI.Draw(AContext: TOpenGLControl); +begin + if FVisible then + begin + FArrows[0].DrawGL(10, 10, FActiveArrow = 0); + FArrows[1].DrawGL(AContext.Width div 2 - FArrows[1].Width div 2, 10, + FActiveArrow = 1); + FArrows[2].DrawGL(AContext.Width - 10 - FArrows[2].Width, 10, + FActiveArrow = 2); + + FArrows[3].DrawGL(AContext.Width - 10 - FArrows[3].Width, + AContext.Height div 2 - FArrows[3].Height div 2, + FActiveArrow = 3); + + FArrows[4].DrawGL(AContext.Width - 10 - FArrows[4].Width, + AContext.Height - 10 - FArrows[4].Height, + FActiveArrow = 4); + FArrows[5].DrawGL(AContext.Width div 2 - FArrows[5].Width div 2, + AContext.Height - 10 - FArrows[5].Height, + FActiveArrow = 5); + FArrows[6].DrawGL(10, AContext.Height - 10 - FArrows[6].Height, + FActiveArrow = 6); + + FArrows[7].DrawGL(10, AContext.Height div 2 - FArrows[7].Height div 2, + FActiveArrow = 7); + end; +end; + +end. + diff --git a/Client/UfrmLogin.lfm b/Client/UfrmLogin.lfm index a693161..c84ee9e 100644 --- a/Client/UfrmLogin.lfm +++ b/Client/UfrmLogin.lfm @@ -16,8 +16,8 @@ object frmLogin: TfrmLogin ShowInTaskBar = stAlways LCLVersion = '0.9.25' object lblCopyright: TLabel - Height = 25 - Top = 240 + Height = 26 + Top = 239 Width = 489 Align = alBottom Alignment = taCenter @@ -151,6 +151,7 @@ object frmLogin: TfrmLogin 233023312332233323342335517451745174222C0A2251745174517451745174 51745174517451745174517451745174517451745174227D3B0A } + Transparent = True end object imgUsername: TImage Left = 6 @@ -242,6 +243,7 @@ object frmLogin: TfrmLogin 233123322333233423355174517451745174222C0A2251745174517451745174 51745174517451745174517451745174517451745174227D3B0A } + Transparent = True end object imgPassword: TImage Left = 6 @@ -323,6 +325,7 @@ object frmLogin: TfrmLogin 5174222C0A2251742349234A236E234B51745174517451745174517451745174 517451745174227D3B0A } + Transparent = True end object edHost: TEdit Left = 101 @@ -432,11 +435,11 @@ object frmLogin: TfrmLogin end object GroupBox1: TGroupBox Left = 336 - Height = 84 + Height = 88 Top = 112 Width = 145 Caption = 'Profiles' - ClientHeight = 69 + ClientHeight = 73 ClientWidth = 141 ParentFont = True TabOrder = 3 diff --git a/Client/UfrmMain.pas b/Client/UfrmMain.pas index 404db5e..0e35819 100644 --- a/Client/UfrmMain.pas +++ b/Client/UfrmMain.pas @@ -619,6 +619,8 @@ begin if tile is TMapCell then begin + if frmElevateSettings.cbRandomHeight.Checked then + Inc(z, Random(frmElevateSettings.seRandomHeight.Value)); dmNetwork.Send(TDrawMapPacket.Create(tile.X, tile.Y, z, tile.TileID)); end else diff --git a/Client/UfrmRegionControl.lfm b/Client/UfrmRegionControl.lfm index 5eb4cfa..e9eba31 100644 --- a/Client/UfrmRegionControl.lfm +++ b/Client/UfrmRegionControl.lfm @@ -12,6 +12,7 @@ object frmRegionControl: TfrmRegionControl OnDestroy = FormDestroy OnShow = FormShow Position = poOwnerFormCenter + ShowInTaskBar = stAlways LCLVersion = '0.9.25' object Panel1: TPanel Height = 359 diff --git a/Client/UfrmRegionControl.pas b/Client/UfrmRegionControl.pas index b725bb4..fba9c98 100644 --- a/Client/UfrmRegionControl.pas +++ b/Client/UfrmRegionControl.pas @@ -345,6 +345,8 @@ var areaInfo: PRect; p: TPoint; begin + if vstRegions.GetFirstSelected = nil then Exit; + FAreaMove := []; p := Point(X * 8, Y * 8); match := nil; diff --git a/Imaging/Imaging.pas b/Imaging/Imaging.pas index 29977e0..7a2bfe4 100644 --- a/Imaging/Imaging.pas +++ b/Imaging/Imaging.pas @@ -1,5 +1,5 @@ { - $Id: Imaging.pas 99 2007-06-26 04:12:01Z galfar $ + $Id: Imaging.pas 124 2008-04-21 09:47:07Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -1573,6 +1573,8 @@ function GenerateMipMaps(const Image: TImageData; Levels: LongInt; var MipMaps: TDynImageDataArray): Boolean; var Width, Height, I, Count: LongInt; + Info: TImageFormatInfo; + CompatibleCopy: TImageData; begin Result := False; if TestImage(Image) then @@ -1585,6 +1587,20 @@ begin if (Levels <= 0) or (Levels > Count) then Levels := Count; + // If we have special format image we create copy to allow pixel access. + // This is also done in FillMipMapLevel which is called for each level + // but then the main big image would be converted to compatible + // for every level. + GetImageFormatInfo(Image.Format, Info); + if Info.IsSpecial then + begin + InitImage(CompatibleCopy); + CloneImage(Image, CompatibleCopy); + ConvertImage(CompatibleCopy, ifDefault); + end + else + CompatibleCopy := Image; + FreeImagesInArray(MipMaps); SetLength(MipMaps, Levels); CloneImage(Image, MipMaps[0]); @@ -1595,8 +1611,17 @@ begin Height := Height shr 1; if Width < 1 then Width := 1; if Height < 1 then Height := 1; - FillMipMapLevel(MipMaps[I - 1], Width, Height, MipMaps[I]); + FillMipMapLevel(CompatibleCopy, Width, Height, MipMaps[I]); end; + + if CompatibleCopy.Format <> MipMaps[0].Format then + begin + // Must convert smaller levels to proper format + for I := 1 to High(MipMaps) do + ConvertImage(MipMaps[I], MipMaps[0].Format); + FreeImage(CompatibleCopy); + end; + Result := True; except RaiseImaging(SErrorGenerateMipMaps, [Levels, ImageToStr(Image)]); @@ -3262,15 +3287,13 @@ finalization File Notes: -- TODOS ---------------------------------------------------- - - make searching for the closest color in palette much faster - MapImageToPal - - investigate CopyPixel and ComparePixels inline problems - line 550 - - add to low level interface function - CreateImageFromRawData(W, H, Bpp, Data, Align, Flipped, Endian, ...) - and CreateRawDataFromImage() - use these in BMP loading (align) - and PNG loading (endian) - - add loading of multi images from file sequence - - do not load all frames when only one is required, possible? - (LoadImageFromFile on MNG/DDS) + - nothing now + + -- 0.24.3 Changes/Bug Fixes --------------------------------- + - GenerateMipMaps now generates all smaller levels from + original big image (better results when using more advanced filters). + Also conversion to compatible image format is now done here not + in FillMipMapLevel (that is called for every mipmap level). -- 0.23 Changes/Bug Fixes ----------------------------------- - MakePaletteForImages now works correctly for indexed and special format images diff --git a/Imaging/ImagingBitmap.pas b/Imaging/ImagingBitmap.pas index e359518..37166e6 100644 --- a/Imaging/ImagingBitmap.pas +++ b/Imaging/ImagingBitmap.pas @@ -1,5 +1,5 @@ { - $Id: ImagingBitmap.pas 94 2007-06-21 19:29:49Z galfar $ + $Id: ImagingBitmap.pas 129 2008-08-06 20:01:30Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -484,7 +484,7 @@ begin FPalSize := 1 shl BI.BitCount; Read(Handle, Palette, FPalSize * SizeOf(TColor32Rec)); end; - for I := 0 to FPalSize - 1 do + for I := 0 to Info.PaletteEntries - 1 do Palette[I].A := $FF; end; @@ -802,6 +802,10 @@ initialization - nothing now - Add option to choose to save V3 or V4 headers. + -- 0.25.0 Changes/Bug Fixes --------------------------------- + - Fixed problem with indexed BMP loading - some pal entries + could end up with alpha=0. + -- 0.23 Changes/Bug Fixes ----------------------------------- - Now saves bitmaps as bottom-up for better compatibility (mainly Lazarus' TImage!). diff --git a/Imaging/ImagingCanvases.pas b/Imaging/ImagingCanvases.pas index 5784d0d..65ed33d 100644 --- a/Imaging/ImagingCanvases.pas +++ b/Imaging/ImagingCanvases.pas @@ -1,5 +1,5 @@ { - $Id: ImagingCanvases.pas 103 2007-09-15 01:11:14Z galfar $ + $Id: ImagingCanvases.pas 131 2008-08-14 15:14:24Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -62,8 +62,10 @@ const pcDkGray = $FF808080; MaxPenWidth = 256; + type EImagingCanvasError = class(EImagingError); + EImagingCanvasBlendingError = class(EImagingError); { Fill mode used when drawing filled objects on canvas.} TFillMode = ( @@ -77,6 +79,26 @@ type pmClear // No drawing done ); + { Source and destination blending factors for drawing functions with blending. + Blending formula: SrcColor * SrcFactor + DestColor * DestFactor } + TBlendingFactor = ( + bfIgnore, // Don't care + bfZero, // For Src and Dest, Factor = (0, 0, 0, 0) + bfOne, // For Src and Dest, Factor = (1, 1, 1, 1) + bfSrcAlpha, // For Src and Dest, Factor = (Src.A, Src.A, Src.A, Src.A) + bfOneMinusSrcAlpha, // For Src and Dest, Factor = (1 - Src.A, 1 - Src.A, 1 - Src.A, 1 - Src.A) + bfDstAlpha, // For Src and Dest, Factor = (Dest.A, Dest.A, Dest.A, Dest.A) + bfOneMinusDstAlpha, // For Src and Dest, Factor = (1 - Dest.A, 1 - Dest.A, 1 - Dest.A, 1 - Dest.A) + bfSrcColor, // For Dest, Factor = (Src.R, Src.R, Src.B, Src.A) + bfOneMinusSrcColor, // For Dest, Factor = (1 - Src.R, 1 - Src.G, 1 - Src.B, 1 - Src.A) + bfDstColor, // For Src, Factor = (Dest.R, Dest.G, Dest.B, Dest.A) + bfOneMinusDstColor // For Src, Factor = (1 - Dest.R, 1 - Dest.G, 1 - Dest.B, 1 - Dest.A) + ); + + { Procedure for custom pixel write modes with blending.} + TPixelWriteProc = procedure(const SrcPix: TColorFPRec; DestPtr: PByte; + DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor); + { Represents 3x3 convolution filter kernel.} TConvolutionFilter3x3 = record Kernel: array[0..2, 0..2] of LongInt; @@ -91,6 +113,13 @@ type Bias: Single; end; + TPointTransformFunction = function(const Pixel: TColorFPRec; + Param1, Param2, Param3: Single): TColorFPRec; + + TDynFPPixelArray = array of TColorFPRec; + + TSelectPixelFunction = function(var Pixels: TDynFPPixelArray): TColorFPRec; + { Base canvas class for drawing objects, applying effects, and other. Constructor takes TBaseImage (or pointer to TImageData). Source image bits are not copied but referenced so all canvas functions affect @@ -104,11 +133,6 @@ type can use one of fast canvas clases. These descendants of TImagingCanvas work only for few select formats (or only one) but they are optimized thus much faster. - - -- - Canvas in this Imaging version (0.20) is very basic and its purpose is to - act like sort of a preview of things to come. - Update 0.22: Some new stuff added but not much yet. } TImagingCanvas = class(TObject) private @@ -125,6 +149,7 @@ type procedure SetFillColor32(const Value: TColor32); {$IFDEF USE_INLINE}inline;{$ENDIF} procedure SetFillColorFP(const Value: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF} procedure SetClipRect(const Value: TRect); + procedure CheckBeforeBlending(SrcFactor, DestFactor: TBlendingFactor; DestCanvas: TImagingCanvas); protected FPData: PImageData; FClipRect: TRect; @@ -151,6 +176,11 @@ type like ellipses and circles.} procedure HorzLineInternal(X1, X2, Y: LongInt; Color: Pointer; Bpp: LongInt); virtual; procedure CopyPixelInternal(X, Y: LongInt; Pixel: Pointer; Bpp: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF} + procedure DrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas; + DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc); + procedure StretchDrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas; + const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor; + Filter: TResizeFilter; PixelWriteProc: TPixelWriteProc); public constructor CreateForData(ImageDataPointer: PImageData); constructor CreateForImage(Image: TBaseImage); @@ -177,6 +207,8 @@ type procedure FrameRect(const Rect: TRect); { Fills given rectangle with current fill settings.} procedure FillRect(const Rect: TRect); virtual; + { Fills given rectangle with current fill settings and pixel blending.} + procedure FillRectBlend(const Rect: TRect; SrcFactor, DestFactor: TBlendingFactor); { Draws rectangle which is outlined by using the current pen settings and filled by using the current fill settings.} procedure Rectangle(const Rect: TRect); @@ -185,6 +217,34 @@ type of ellipse to be drawn.} procedure Ellipse(const Rect: TRect); + { Draws contents of this canvas onto another canvas with pixel blending. + Blending factors are chosen using TBlendingFactor parameters. + Resulting destination pixel color is: + SrcColor * SrcFactor + DstColor * DstFactor} + procedure DrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas; + DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor); + { Draws contents of this canvas onto another one with typical alpha + blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)} + procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); + { Draws contents of this canvas onto another one using additive blending + (source and dest factors are bfOne).} + procedure DrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); + { Draws stretched and filtered contents of this canvas onto another canvas + with pixel blending. Blending factors are chosen using TBlendingFactor parameters. + Resulting destination pixel color is: + SrcColor * SrcFactor + DstColor * DstFactor} + procedure StretchDrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas; + const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor; + Filter: TResizeFilter = rfBilinear); + { Draws contents of this canvas onto another one with typical alpha + blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)} + procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; + const DestRect: TRect; Filter: TResizeFilter = rfBilinear); + { Draws contents of this canvas onto another one using additive blending + (source and dest factors are bfOne).} + procedure StretchDrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas; + const DestRect: TRect; Filter: TResizeFilter = rfBilinear); + { Convolves canvas' image with given 3x3 filter kernel. You can use predefined filter kernels or define your own.} procedure ApplyConvolution3x3(const Filter: TConvolutionFilter3x3); @@ -201,6 +261,36 @@ type procedure ApplyConvolution(Kernel: PLongInt; KernelSize, Divisor: LongInt; Bias: Single = 0.0; ClampChannels: Boolean = True); virtual; + { Applies custom non-linear filter. Filter size is diameter of pixel + neighborhood. Typical values are 3, 5, or 7. } + procedure ApplyNonLinearFilter(FilterSize: Integer; SelectFunc: TSelectPixelFunction); + { Applies median non-linear filter with user defined pixel neighborhood. + Selects median pixel from the neighborhood as new pixel + (current implementation is quite slow).} + procedure ApplyMedianFilter(FilterSize: Integer); + { Applies min non-linear filter with user defined pixel neighborhood. + Selects min pixel from the neighborhood as new pixel.} + procedure ApplyMinFilter(FilterSize: Integer); + { Applies max non-linear filter with user defined pixel neighborhood. + Selects max pixel from the neighborhood as new pixel.} + procedure ApplyMaxFilter(FilterSize: Integer); + + { Transforms pixels one by one by given function. Pixel neighbors are + not taken into account. Param 1-3 are optional parameters + for transform function.} + procedure PointTransform(Transform: TPointTransformFunction; + Param1, Param2, Param3: Single); + { Modifies image contrast and brightness. Parameters should be + in range <-100; 100>.} + procedure ModifyContrastBrightness(Contrast, Brightness: Single); + { Gamma correction of individual color channels. Range is (0, +inf), + 1.0 means no change.} + procedure GammaCorection(Red, Green, Blue: Single); + { Inverts colors of all image pixels, makes negative image.} + procedure InvertColors; + { Simple single level thresholding with threshold level for each color channel.} + procedure Threshold(Red, Green, Blue: Single); + { Color used when drawing lines, frames, and outlines of objects.} property PenColor32: TColor32 read FPenColor32 write SetPenColor32; { Color used when drawing lines, frames, and outlines of objects.} @@ -384,6 +474,7 @@ const (-1, -2, -1)); Divisor: 4); + { Kernel for 3x3 contour enhancement filter.} FilterTraceControur3x3: TConvolutionFilter3x3 = ( Kernel: ((-6, -6, -2), (-1, 32, -1), @@ -466,7 +557,173 @@ begin Result := FindBestCanvasForImage(Image.Format); end; -{ TImagingCanvas } +{ Canvas helper functions } + +procedure PixelBlendProc(const SrcPix: TColorFPRec; DestPtr: PByte; + DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor); +var + DestPix, FSrc, FDst: TColorFPRec; +begin + // Get set pixel color + DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil); + // Determine current blending factors + case SrcFactor of + bfZero: FSrc := ColorFP(0, 0, 0, 0); + bfOne: FSrc := ColorFP(1, 1, 1, 1); + bfSrcAlpha: FSrc := ColorFP(SrcPix.A, SrcPix.A, SrcPix.A, SrcPix.A); + bfOneMinusSrcAlpha: FSrc := ColorFP(1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A); + bfDstAlpha: FSrc := ColorFP(DestPix.A, DestPix.A, DestPix.A, DestPix.A); + bfOneMinusDstAlpha: FSrc := ColorFP(1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A); + bfDstColor: FSrc := ColorFP(DestPix.A, DestPix.R, DestPix.G, DestPix.B); + bfOneMinusDstColor: FSrc := ColorFP(1 - DestPix.A, 1 - DestPix.R, 1 - DestPix.G, 1 - DestPix.B); + end; + case DestFactor of + bfZero: FDst := ColorFP(0, 0, 0, 0); + bfOne: FDst := ColorFP(1, 1, 1, 1); + bfSrcAlpha: FDst := ColorFP(SrcPix.A, SrcPix.A, SrcPix.A, SrcPix.A); + bfOneMinusSrcAlpha: FDst := ColorFP(1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A); + bfDstAlpha: FDst := ColorFP(DestPix.A, DestPix.A, DestPix.A, DestPix.A); + bfOneMinusDstAlpha: FDst := ColorFP(1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A); + bfSrcColor: FDst := ColorFP(SrcPix.A, SrcPix.R, SrcPix.G, SrcPix.B); + bfOneMinusSrcColor: FDst := ColorFP(1 - SrcPix.A, 1 - SrcPix.R, 1 - SrcPix.G, 1 - SrcPix.B); + end; + // Compute blending formula + DestPix.R := SrcPix.R * FSrc.R + DestPix.R * FDst.R; + DestPix.G := SrcPix.G * FSrc.G + DestPix.G * FDst.G; + DestPix.B := SrcPix.B * FSrc.B + DestPix.B * FDst.B; + DestPix.A := SrcPix.A * FSrc.A + DestPix.A * FDst.A; + // Write blended pixel + DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix); +end; + +procedure PixelAlphaProc(const SrcPix: TColorFPRec; DestPtr: PByte; + DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor); +var + DestPix: TColorFPRec; +begin + DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil); + // Blend the two pixels (Src 'over' Dest alpha composition operation) + DestPix.R := SrcPix.R * SrcPix.A + DestPix.R * DestPix.A * (1.0 - SrcPix.A); + DestPix.G := SrcPix.G * SrcPix.A + DestPix.G * DestPix.A * (1.0 - SrcPix.A); + DestPix.B := SrcPix.B * SrcPix.A + DestPix.B * DestPix.A * (1.0 - SrcPix.A); + DestPix.A := SrcPix.A + DestPix.A * (1.0 - SrcPix.A); + // Write blended pixel + DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix); +end; + +procedure PixelAddProc(const SrcPix: TColorFPRec; DestPtr: PByte; + DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor); +var + DestPix: TColorFPRec; +begin + // Just add Src and Dest + DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil); + DestPix.R := SrcPix.R + DestPix.R; + DestPix.G := SrcPix.G + DestPix.G; + DestPix.B := SrcPix.B + DestPix.B; + DestPix.A := SrcPix.A + DestPix.A; + DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix); +end; + +function CompareColors(const C1, C2: TColorFPRec): Single; {$IFDEF USE_INLINE}inline;{$ENDIF} +begin + Result := (C1.R * GrayConv.R + C1.G * GrayConv.G + C1.B * GrayConv.B) - + (C2.R * GrayConv.R + C2.G * GrayConv.G + C2.B * GrayConv.B); +end; + +function MedianSelect(var Pixels: TDynFPPixelArray): TColorFPRec; + + procedure QuickSort(L, R: Integer); + var + I, J: Integer; + P, Temp: TColorFPRec; + begin + repeat + I := L; + J := R; + P := Pixels[(L + R) shr 1]; + repeat + while CompareColors(Pixels[I], P) < 0 do Inc(I); + while CompareColors(Pixels[J], P) > 0 do Dec(J); + if I <= J then + begin + Temp := Pixels[I]; + Pixels[I] := Pixels[J]; + Pixels[J] := Temp; + Inc(I); + Dec(J); + end; + until I > J; + if L < J then + QuickSort(L, J); + L := I; + until I >= R; + end; + +begin + // First sort pixels + QuickSort(0, High(Pixels)); + // Select middle pixel + Result := Pixels[Length(Pixels) div 2]; +end; + +function MinSelect(var Pixels: TDynFPPixelArray): TColorFPRec; +var + I: Integer; +begin + Result := Pixels[0]; + for I := 1 to High(Pixels) do + begin + if CompareColors(Pixels[I], Result) < 0 then + Result := Pixels[I]; + end; +end; + +function MaxSelect(var Pixels: TDynFPPixelArray): TColorFPRec; +var + I: Integer; +begin + Result := Pixels[0]; + for I := 1 to High(Pixels) do + begin + if CompareColors(Pixels[I], Result) > 0 then + Result := Pixels[I]; + end; +end; + +function TransformContrastBrightness(const Pixel: TColorFPRec; C, B, Ignore: Single): TColorFPRec; +begin + Result.A := Pixel.A; + Result.R := Pixel.R * C + B; + Result.G := Pixel.G * C + B; + Result.B := Pixel.B * C + B; +end; + +function TransformGamma(const Pixel: TColorFPRec; R, G, B: Single): TColorFPRec; +begin + Result.A := Pixel.A; + Result.R := Power(Pixel.R, 1.0 / R); + Result.G := Power(Pixel.G, 1.0 / G); + Result.B := Power(Pixel.B, 1.0 / B); +end; + +function TransformInvert(const Pixel: TColorFPRec; A, B, C: Single): TColorFPRec; +begin + Result.A := Pixel.A; + Result.R := 1.0 - Pixel.R; + Result.G := 1.0 - Pixel.G; + Result.B := 1.0 - Pixel.B; +end; + +function TransformThreshold(const Pixel: TColorFPRec; R, G, B: Single): TColorFPRec; +begin + Result.A := Pixel.A; + Result.R := IffFloat(Pixel.R >= R, 1.0, 0.0); + Result.G := IffFloat(Pixel.G >= G, 1.0, 0.0); + Result.B := IffFloat(Pixel.B >= B, 1.0, 0.0); +end; + +{ TImagingCanvas class implementation } constructor TImagingCanvas.CreateForData(ImageDataPointer: PImageData); begin @@ -568,6 +825,17 @@ begin IntersectRect(FClipRect, FClipRect, Rect(0, 0, FPData.Width, FPData.Height)); end; +procedure TImagingCanvas.CheckBeforeBlending(SrcFactor, + DestFactor: TBlendingFactor; DestCanvas: TImagingCanvas); +begin + if SrcFactor in [bfSrcColor, bfOneMinusSrcColor] then + raise EImagingCanvasBlendingError.Create('Invalid source blending factor. Check the documentation for TBlendingFactor.'); + if DestFactor in [bfDstColor, bfOneMinusDstColor] then + raise EImagingCanvasBlendingError.Create('Invalid destination blending factor. Check the documentation for TBlendingFactor.'); + if DestCanvas.FormatInfo.IsIndexed then + raise EImagingCanvasBlendingError.Create('Blending destination canvas cannot be in indexed mode.'); +end; + function TImagingCanvas.GetPixelPointer(X, Y: LongInt): Pointer; begin Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * FFormatInfo.BytesPerPixel] @@ -810,6 +1078,28 @@ begin end; end; +procedure TImagingCanvas.FillRectBlend(const Rect: TRect; SrcFactor, + DestFactor: TBlendingFactor); +var + DstRect: TRect; + X, Y: Integer; + Line: PByte; +begin + if (FFillMode <> fmClear) and IntersectRect(DstRect, Rect, FClipRect) then + begin + CheckBeforeBlending(SrcFactor, DestFactor, Self); + for Y := DstRect.Top to DstRect.Bottom - 1 do + begin + Line := @PByteArray(FPData.Bits)[(Y * FPData.Width + DstRect.Left) * FFormatInfo.BytesPerPixel]; + for X := DstRect.Left to DstRect.Right - 1 do + begin + PixelBlendProc(FFillColorFP, Line, @FFormatInfo, SrcFactor, DestFactor); + Inc(Line, FFormatInfo.BytesPerPixel); + end; + end; + end; +end; + procedure TImagingCanvas.Rectangle(const Rect: TRect); begin FillRect(Rect); @@ -885,6 +1175,186 @@ begin end; end; +procedure TImagingCanvas.DrawInternal(const SrcRect: TRect; + DestCanvas: TImagingCanvas; DestX, DestY: Integer; SrcFactor, + DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc); +var + X, Y, SrcX, SrcY, Width, Height, SrcBpp, DestBpp: Integer; + PSrc: TColorFPRec; + SrcPointer, DestPointer: PByte; +begin + CheckBeforeBlending(SrcFactor, DestFactor, DestCanvas); + SrcX := SrcRect.Left; + SrcY := SrcRect.Top; + Width := SrcRect.Right - SrcRect.Left; + Height := SrcRect.Bottom - SrcRect.Top; + SrcBpp := FFormatInfo.BytesPerPixel; + DestBpp := DestCanvas.FFormatInfo.BytesPerPixel; + // Clip src and dst rects + ClipCopyBounds(SrcX, SrcY, Width, Height, DestX, DestY, + FPData.Width, FPData.Height, DestCanvas.ClipRect); + + for Y := 0 to Height - 1 do + begin + // Get src and dst scanlines + SrcPointer := @PByteArray(FPData.Bits)[((SrcY + Y) * FPData.Width + SrcX) * SrcBpp]; + DestPointer := @PByteArray(DestCanvas.FPData.Bits)[((DestY + Y) * DestCanvas.FPData.Width + DestX) * DestBpp]; + + for X := 0 to Width - 1 do + begin + PSrc := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, FPData.Palette); + // Call pixel writer procedure - combine source and dest pixels + PixelWriteProc(PSrc, DestPointer, @DestCanvas.FFormatInfo, SrcFactor, DestFactor); + // Increment pixel pointers + Inc(SrcPointer, SrcBpp); + Inc(DestPointer, DestBpp); + end; + end; +end; + +procedure TImagingCanvas.DrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas; + DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor); +begin + DrawInternal(SrcRect, DestCanvas, DestX, DestY, SrcFactor, DestFactor, PixelBlendProc); +end; + +procedure TImagingCanvas.DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; + DestX, DestY: Integer); +begin + DrawInternal(SrcRect, DestCanvas, DestX, DestY, bfIgnore, bfIgnore, PixelAlphaProc); +end; + +procedure TImagingCanvas.DrawAdd(const SrcRect: TRect; + DestCanvas: TImagingCanvas; DestX, DestY: Integer); +begin + DrawInternal(SrcRect, DestCanvas, DestX, DestY, bfIgnore, bfIgnore, PixelAddProc); +end; + +procedure TImagingCanvas.StretchDrawInternal(const SrcRect: TRect; + DestCanvas: TImagingCanvas; const DestRect: TRect; + SrcFactor, DestFactor: TBlendingFactor; Filter: TResizeFilter; + PixelWriteProc: TPixelWriteProc); +const + FilterMapping: array[TResizeFilter] of TSamplingFilter = + (sfNearest, sfLinear, DefaultCubicFilter); +var + X, Y, I, J, SrcX, SrcY, SrcWidth, SrcHeight: Integer; + DestX, DestY, DestWidth, DestHeight, SrcBpp, DestBpp: Integer; + SrcPix, PDest: TColorFPRec; + MapX, MapY: TMappingTable; + XMinimum, XMaximum: Integer; + LineBuffer: array of TColorFPRec; + ClusterX, ClusterY: TCluster; + Weight, AccumA, AccumR, AccumG, AccumB: Single; + DestLine: PByte; + FilterFunction: TFilterFunction; + Radius: Single; +begin + CheckBeforeBlending(SrcFactor, DestFactor, DestCanvas); + SrcX := SrcRect.Left; + SrcY := SrcRect.Top; + SrcWidth := SrcRect.Right - SrcRect.Left; + SrcHeight := SrcRect.Bottom - SrcRect.Top; + DestX := DestRect.Left; + DestY := DestRect.Top; + DestWidth := DestRect.Right - DestRect.Left; + DestHeight := DestRect.Bottom - DestRect.Top; + SrcBpp := FFormatInfo.BytesPerPixel; + DestBpp := DestCanvas.FFormatInfo.BytesPerPixel; + // Get actual resampling filter and radius + FilterFunction := SamplingFilterFunctions[FilterMapping[Filter]]; + Radius := SamplingFilterRadii[FilterMapping[Filter]]; + // Clip src and dst rects + ClipStretchBounds(SrcX, SrcY, SrcWidth, SrcHeight, DestX, DestY, DestWidth, DestHeight, + FPData.Width, FPData.Height, DestCanvas.ClipRect); + // Generate mapping tables + MapX := BuildMappingTable(DestX, DestX + DestWidth, SrcX, SrcX + SrcWidth, + FPData.Width, FilterFunction, Radius, False); + MapY := BuildMappingTable(DestY, DestY + DestHeight, SrcY, SrcY + SrcHeight, + FPData.Height, FilterFunction, Radius, False); + FindExtremes(MapX, XMinimum, XMaximum); + SetLength(LineBuffer, XMaximum - XMinimum + 1); + + for J := 0 to DestHeight - 1 do + begin + ClusterY := MapY[J]; + for X := XMinimum to XMaximum do + begin + AccumA := 0.0; + AccumR := 0.0; + AccumG := 0.0; + AccumB := 0.0; + for Y := 0 to Length(ClusterY) - 1 do + begin + Weight := ClusterY[Y].Weight; + SrcPix := FFormatInfo.GetPixelFP(@PByteArray(FPData.Bits)[(ClusterY[Y].Pos * FPData.Width + X) * SrcBpp], + @FFormatInfo, FPData.Palette); + AccumB := AccumB + SrcPix.B * Weight; + AccumG := AccumG + SrcPix.G * Weight; + AccumR := AccumR + SrcPix.R * Weight; + AccumA := AccumA + SrcPix.A * Weight; + end; + with LineBuffer[X - XMinimum] do + begin + A := AccumA; + R := AccumR; + G := AccumG; + B := AccumB; + end; + end; + + DestLine := @PByteArray(DestCanvas.FPData.Bits)[((J + DestY) * DestCanvas.FPData.Width + DestX) * DestBpp]; + + for I := 0 to DestWidth - 1 do + begin + ClusterX := MapX[I]; + AccumA := 0.0; + AccumR := 0.0; + AccumG := 0.0; + AccumB := 0.0; + for X := 0 to Length(ClusterX) - 1 do + begin + Weight := ClusterX[X].Weight; + with LineBuffer[ClusterX[X].Pos - XMinimum] do + begin + AccumB := AccumB + B * Weight; + AccumG := AccumG + G * Weight; + AccumR := AccumR + R * Weight; + AccumA := AccumA + A * Weight; + end; + end; + + SrcPix.A := AccumA; + SrcPix.R := AccumR; + SrcPix.G := AccumG; + SrcPix.B := AccumB; + + // Write resulting blended pixel + PixelWriteProc(SrcPix, DestLine, @DestCanvas.FFormatInfo, SrcFactor, DestFactor); + Inc(DestLine, DestBpp); + end; + end; +end; + +procedure TImagingCanvas.StretchDrawBlend(const SrcRect: TRect; + DestCanvas: TImagingCanvas; const DestRect: TRect; + SrcFactor, DestFactor: TBlendingFactor; Filter: TResizeFilter); +begin + StretchDrawInternal(SrcRect, DestCanvas, DestRect, SrcFactor, DestFactor, Filter, PixelBlendProc); +end; + +procedure TImagingCanvas.StretchDrawAlpha(const SrcRect: TRect; + DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter); +begin + StretchDrawInternal(SrcRect, DestCanvas, DestRect, bfIgnore, bfIgnore, Filter, PixelAlphaProc); +end; + +procedure TImagingCanvas.StretchDrawAdd(const SrcRect: TRect; + DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter); +begin + StretchDrawInternal(SrcRect, DestCanvas, DestRect, bfIgnore, bfIgnore, Filter, PixelAddProc); +end; + procedure TImagingCanvas.ApplyConvolution(Kernel: PLongInt; KernelSize, Divisor: LongInt; Bias: Single; ClampChannels: Boolean); var @@ -917,11 +1387,11 @@ begin for J := 0 to KernelSize - 1 do begin - PosY := ClampInt(Y + J - SizeDiv2, FClipRect.Top, FClipRect.Bottom); + PosY := ClampInt(Y + J - SizeDiv2, FClipRect.Top, FClipRect.Bottom - 1); for I := 0 to KernelSize - 1 do begin - PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right); + PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1); SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp]; // Get pixels from neighbourhood of current pixel and add their @@ -966,12 +1436,126 @@ begin ApplyConvolution(@Filter.Kernel, 5, Filter.Divisor, Filter.Bias, True); end; +procedure TImagingCanvas.ApplyNonLinearFilter(FilterSize: Integer; SelectFunc: TSelectPixelFunction); +var + X, Y, I, J, PosY, PosX, SizeDiv2, WidthBytes, Bpp: LongInt; + Pixel: TColorFPRec; + TempImage: TImageData; + DstPointer, SrcPointer: PByte; + NeighPixels: TDynFPPixelArray; +begin + SizeDiv2 := FilterSize div 2; + Bpp := FFormatInfo.BytesPerPixel; + WidthBytes := FPData.Width * Bpp; + SetLength(NeighPixels, FilterSize * FilterSize); + + InitImage(TempImage); + CloneImage(FPData^, TempImage); + + try + // For every pixel in clip rect + for Y := FClipRect.Top to FClipRect.Bottom - 1 do + begin + DstPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp]; + + for X := FClipRect.Left to FClipRect.Right - 1 do + begin + for J := 0 to FilterSize - 1 do + begin + PosY := ClampInt(Y + J - SizeDiv2, FClipRect.Top, FClipRect.Bottom - 1); + + for I := 0 to FilterSize - 1 do + begin + PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1); + SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp]; + + // Get pixels from neighbourhood of current pixel and store them + Pixel := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, TempImage.Palette); + NeighPixels[J * FilterSize + I] := Pixel; + end; + end; + + // Choose pixel using custom function + Pixel := SelectFunc(NeighPixels); + // Set resulting pixel color + FFormatInfo.SetPixelFP(DstPointer, @FFormatInfo, FPData.Palette, Pixel); + + Inc(DstPointer, Bpp); + end; + end; + + finally + FreeImage(TempImage); + end; +end; + +procedure TImagingCanvas.ApplyMedianFilter(FilterSize: Integer); +begin + ApplyNonLinearFilter(FilterSize, MedianSelect); +end; + +procedure TImagingCanvas.ApplyMinFilter(FilterSize: Integer); +begin + ApplyNonLinearFilter(FilterSize, MinSelect); +end; + +procedure TImagingCanvas.ApplyMaxFilter(FilterSize: Integer); +begin + ApplyNonLinearFilter(FilterSize, MaxSelect); +end; + +procedure TImagingCanvas.PointTransform(Transform: TPointTransformFunction; + Param1, Param2, Param3: Single); +var + X, Y, Bpp, WidthBytes: Integer; + PixPointer: PByte; + Pixel: TColorFPRec; +begin + Bpp := FFormatInfo.BytesPerPixel; + WidthBytes := FPData.Width * Bpp; + + // For every pixel in clip rect + for Y := FClipRect.Top to FClipRect.Bottom - 1 do + begin + PixPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp]; + for X := FClipRect.Left to FClipRect.Right - 1 do + begin + Pixel := FFormatInfo.GetPixelFP(PixPointer, @FFormatInfo, FPData.Palette); + + FFormatInfo.SetPixelFP(PixPointer, @FFormatInfo, FPData.Palette, + Transform(Pixel, Param1, Param2, Param3)); + + Inc(PixPointer, Bpp); + end; + end; +end; + +procedure TImagingCanvas.ModifyContrastBrightness(Contrast, Brightness: Single); +begin + PointTransform(TransformContrastBrightness, 1.0 + Contrast / 100, + Brightness / 100, 0.0); +end; + +procedure TImagingCanvas.GammaCorection(Red, Green, Blue: Single); +begin + PointTransform(TransformGamma, Red, Green, Blue); +end; + +procedure TImagingCanvas.InvertColors; +begin + PointTransform(TransformInvert, 0, 0, 0); +end; + +procedure TImagingCanvas.Threshold(Red, Green, Blue: Single); +begin + PointTransform(TransformThreshold, Red, Green, Blue); +end; + class function TImagingCanvas.GetSupportedFormats: TImageFormats; begin Result := [ifIndex8..Pred(ifDXT1)]; end; - { TFastARGB32Canvas } destructor TFastARGB32Canvas.Destroy; @@ -1027,12 +1611,18 @@ finalization File Notes: -- TODOS ---------------------------------------------------- - - more more more ... + - more more more ... - implement pen width everywhere - - add blending (image and object drawing) - - add image drawing + - add blending (*image and object drawing) - more objects (arc, polygon) - - add channel write/read masks (like apply conv only on Red channel,...) + + -- 0.25.0 Changes/Bug Fixes --------------------------------- + - Fixed error that could cause AV in linear and nonlinear filters. + - Added blended rect filling function FillRectBlend. + - Added drawing function with blending (DrawAlpha, StretchDrawAlpha, + StretchDrawAdd, DrawBlend, StretchDrawBlend, ...) + - Added non-linear filters (min, max, median). + - Added point transforms (invert, contrast, gamma, brightness). -- 0.21 Changes/Bug Fixes ----------------------------------- - Added some new filter kernels for convolution. diff --git a/Imaging/ImagingClasses.pas b/Imaging/ImagingClasses.pas index 67846f1..08c9b00 100644 --- a/Imaging/ImagingClasses.pas +++ b/Imaging/ImagingClasses.pas @@ -1,5 +1,5 @@ { - $Id: ImagingClasses.pas 94 2007-06-21 19:29:49Z galfar $ + $Id: ImagingClasses.pas 124 2008-04-21 09:47:07Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -231,6 +231,8 @@ type procedure ExchangeImages(Index1, Index2: LongInt); { Deletes image at the given position in the image array.} procedure DeleteImage(Index: LongInt); + { Rearranges images so that the first image will become last and vice versa.} + procedure ReverseImages; { Converts all images to another image data format.} procedure ConvertImages(Format: TImageFormat); @@ -886,6 +888,14 @@ begin Imaging.ResizeImage(FDataArray[I], NewWidth, NewHeight, Filter); end; +procedure TMultiImage.ReverseImages; +var + I: Integer; +begin + for I := 0 to GetImageCount div 2 do + ExchangeImages(I, GetImageCount - 1 - I); +end; + procedure TMultiImage.LoadFromFile(const FileName: string); begin if GetImageCount = 0 then @@ -931,6 +941,9 @@ end; - put all low level stuff here like ReplaceColor etc, change CopyTo to Copy, and add overload Copy(SrcRect, DstX, DstY) ... + -- 0.24.3 Changes/Bug Fixes --------------------------------- + - Added TMultiImage.ReverseImages method. + -- 0.23 Changes/Bug Fixes ----------------------------------- - Added SwapChannels method to TBaseImage. - Added ReplaceColor method to TBaseImage. diff --git a/Imaging/ImagingComponents.pas b/Imaging/ImagingComponents.pas index e55b2d6..7e370e3 100644 --- a/Imaging/ImagingComponents.pas +++ b/Imaging/ImagingComponents.pas @@ -1,5 +1,5 @@ { - $Id: ImagingComponents.pas 110 2007-11-18 21:23:59Z galfar $ + $Id: ImagingComponents.pas 132 2008-08-27 20:37:38Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -114,7 +114,8 @@ type { Returns file extensions of this graphic class.} class function GetFileExtensions: string; override; { Returns default MIME type of this graphic class.} - function GetMimeType: string; override; + function GetMimeType: string; override; // uncomment for Laz 0.9.25 if you get error here + //function GetDefaultMimeType: string; override; {$ENDIF} { Default (the most common) file extension of this graphic class.} property DefaultFileExt: string read FDefaultFileExt; @@ -150,6 +151,7 @@ type procedure SaveToStream(Stream: TStream); override; class function GetFileFormat: TImageFileFormat; override; {$IFDEF COMPONENT_SET_LCL} + //function GetMimeType: string; override; // uncomment for Laz 0.9.25 if you get error here function GetDefaultMimeType: string; override; {$ENDIF} { See ImagingJpegQuality option for details.} @@ -231,6 +233,7 @@ type procedure SaveToStream(Stream: TStream); override; class function GetFileFormat: TImageFileFormat; override; {$IFDEF COMPONENT_SET_LCL} + //function GetMimeType: string; override; // uncomment for Laz 0.9.25 if you get error here function GetDefaultMimeType: string; override; {$ENDIF} { See ImagingMNGLossyCompression option for details.} @@ -637,7 +640,6 @@ var {$IFDEF COMPONENT_SET_LCL} RawImage: TRawImage; LineLazBytes: LongInt; - rect: TRect; {$ENDIF} begin {$IFDEF COMPONENT_SET_LCL} @@ -725,9 +727,8 @@ begin {$ENDIF} {$IFDEF COMPONENT_SET_LCL} // Get raw image from bitmap (mask handle must be 0 or expect violations) - { If you get complitation error here upgrade to Lazarus 0.9.24+ } - rect := Classes.Rect(0, 0, Data.Width, Data.Height); - if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, @rect) then + if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, nil) then // uncommnet for Laz 0.9.25 if you get error here + //if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, Classes.Rect(0, 0, Data.Width, Data.Height)) then begin LineLazBytes := GetBytesPerLine(Data.Width, RawImage.Description.BitsPerPixel, RawImage.Description.LineEnd); @@ -826,10 +827,15 @@ end; var P: TPoint; begin + // If you get compilation errors here with new Lazarus (rev 14368+) + // uncomment commented code and comment the active code below: + P := TGtkDeviceContext(Dest).Offset; + //P := GetDCOffset(TDeviceContext(Dest)); Inc(DstX, P.X); Inc(DstY, P.Y); gdk_draw_rgb_32_image(TGtkDeviceContext(Dest).Drawable, TGtkDeviceContext(Dest).GC, + //gdk_draw_rgb_32_image(TDeviceContext(Dest).Drawable, TDeviceContext(Dest).GC, DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE, @PLongWordArray(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 4); end; @@ -1014,7 +1020,8 @@ begin Result := StringReplace(GetFileFormat.Extensions.CommaText, ',', ';', [rfReplaceAll]); end; -function TImagingGraphicForSave.GetMimeType: string; +function TImagingGraphicForSave.GetMimeType: string; // uncomment for Laz 0.9.25 if you get error here +//function TImagingGraphicForSave.GetDefaultMimeType: string; begin Result := 'image/' + FDefaultFileExt; end; @@ -1061,6 +1068,7 @@ begin end; {$IFDEF COMPONENT_SET_LCL} +//function TImagingJpeg.GetMimeType: string; // uncomment for Laz 0.9.25 if you get error here function TImagingJpeg.GetDefaultMimeType: string; begin Result := 'image/jpeg'; @@ -1193,6 +1201,7 @@ begin end; {$IFDEF COMPONENT_SET_LCL} +//function TImagingMNG.GetMimeType: string; // uncomment for Laz 0.9.25 if you get error here function TImagingMNG.GetDefaultMimeType: string; begin Result := 'video/mng'; diff --git a/Imaging/ImagingDds.pas b/Imaging/ImagingDds.pas index 48d66e5..0b439a9 100644 --- a/Imaging/ImagingDds.pas +++ b/Imaging/ImagingDds.pas @@ -1,5 +1,5 @@ { - $Id: ImagingDds.pas 100 2007-06-28 21:09:52Z galfar $ + $Id: ImagingDds.pas 129 2008-08-06 20:01:30Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -102,7 +102,7 @@ const DDSSupportedFormats: TImageFormats = [ifR8G8B8, ifA8R8G8B8, ifX8R8G8B8, ifA1R5G5B5, ifA4R4G4B4, ifX1R5G5B5, ifX4R4G4B4, ifR5G6B5, ifA16B16G16R16, ifR32F, ifA32B32G32R32F, ifR16F, ifA16B16G16R16F, ifR3G3B2, ifGray8, ifA8Gray8, - ifGray16, ifDXT1, ifDXT3, ifDXT5]; + ifGray16, ifDXT1, ifDXT3, ifDXT5, ifATI1N, ifATI2N]; const { Four character codes.} @@ -114,6 +114,10 @@ const (Byte('3') shl 24)); FOURCC_DXT5 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or (Byte('5') shl 24)); + FOURCC_ATI1 = LongWord(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or + (Byte('1') shl 24)); + FOURCC_ATI2 = LongWord(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or + (Byte('2') shl 24)); { Some D3DFORMAT values used in DDS files as FourCC value.} D3DFMT_A16B16G16R16 = 36; @@ -350,6 +354,8 @@ begin FOURCC_DXT1: SrcFormat := ifDXT1; FOURCC_DXT3: SrcFormat := ifDXT3; FOURCC_DXT5: SrcFormat := ifDXT5; + FOURCC_ATI1: SrcFormat := ifATI1N; + FOURCC_ATI2: SrcFormat := ifATI2N; end; end else if (Flags and DDPF_RGB) = DDPF_RGB then @@ -663,6 +669,8 @@ begin ifDXT1: Desc.PixelFormat.FourCC := FOURCC_DXT1; ifDXT3: Desc.PixelFormat.FourCC := FOURCC_DXT3; ifDXT5: Desc.PixelFormat.FourCC := FOURCC_DXT5; + ifATI1N: Desc.PixelFormat.FourCC := FOURCC_ATI1; + ifATI2N: Desc.PixelFormat.FourCC := FOURCC_ATI2; end; end else if FmtInfo.HasGrayChannel then @@ -815,6 +823,9 @@ initialization -- TODOS ---------------------------------------------------- - nothing now + -- 0.25.0 Changes/Bug Fixes --------------------------------- + - Added support for 3Dc ATI1/2 formats. + -- 0.23 Changes/Bug Fixes ----------------------------------- - Saved DDS with mipmaps now correctly defineds COMPLEX flag. - Fixed loading of RGB DDS files that use pitch and have mipmaps - diff --git a/Imaging/ImagingFormats.pas b/Imaging/ImagingFormats.pas index fedc6fe..6c972fe 100644 --- a/Imaging/ImagingFormats.pas +++ b/Imaging/ImagingFormats.pas @@ -1,5 +1,5 @@ { - $Id: ImagingFormats.pas 94 2007-06-21 19:29:49Z galfar $ + $Id: ImagingFormats.pas 129 2008-08-06 20:01:30Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -76,6 +76,15 @@ type sfGaussian, sfSpline, sfLanczos, sfMitchell, sfCatmullRom); { Type of custom sampling function} TFilterFunction = function(Value: Single): Single; +const + { Default resampling filter used for bicubic resizing.} + DefaultCubicFilter = sfCatmullRom; +var + { Built-in filter functions.} + SamplingFilterFunctions: array[TSamplingFilter] of TFilterFunction; + { Default radii of built-in filter functions.} + SamplingFilterRadii: array[TSamplingFilter] of Single; + { Stretches rectangle in source image to rectangle in destination image with resampling. One of built-in resampling filters defined by Filter is used. Set WrapEdges to True for seamlessly tileable images. @@ -103,7 +112,7 @@ procedure FillMipMapLevel(const BiggerLevel: TImageData; Width, Height: LongInt; var SmallerLevel: TImageData); -{ Various helper format support functions } +{ Various helper & support functions } { Copies Src pixel to Dest pixel. It is faster than System.Move procedure.} procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF} @@ -163,6 +172,23 @@ function ColorHalfToFloat(ColorHF: TColorHFRec): TColorFPRec; {$IFDEF USE_INLINE { Converts single-precision floating point color to half float color.} function ColorFloatToHalf(ColorFP: TColorFPRec): TColorHFRec; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Makes image PalEntries x 1 big where each pixel has color of one pal entry.} +procedure VisualizePalette(Pal: PPalette32; Entries: Integer; out PalImage: TImageData); + +type + TPointRec = record + Pos: LongInt; + Weight: Single; + end; + TCluster = array of TPointRec; + TMappingTable = array of TCluster; + +{ Helper function for resampling.} +function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt; + Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable; +{ Helper function for resampling.} +procedure FindExtremes(const Map: TMappingTable; var MinPos, MaxPos: LongInt); + { Pixel readers/writers for different image formats } @@ -171,7 +197,7 @@ procedure ChannelGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; var Pix: TColor64Rec); { Sets pixel of image in any ARGB format. Channel values must be scaled to 16 bits.} procedure ChannelSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo; - const Pix: TColor64Rec); + const Pix: TColor64Rec); { Returns pixel of image in any grayscale format. Gray value is scaled to 64 bits and alpha to 16 bits.} @@ -275,6 +301,22 @@ procedure IndexToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, DstInfo: PImageFormatInfo; SrcPal: PPalette32); +{ Color constructor functions } + +{ Constructs TColor24Rec color.} +function Color24(R, G, B: Byte): TColor24Rec; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Constructs TColor32Rec color.} +function Color32(A, R, G, B: Byte): TColor32Rec; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Constructs TColor48Rec color.} +function Color48(R, G, B: Word): TColor48Rec; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Constructs TColor64Rec color.} +function Color64(A, R, G, B: Word): TColor64Rec; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Constructs TColorFPRec color.} +function ColorFP(A, R, G, B: Single): TColorFPRec; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Constructs TColorHFRec color.} +function ColorHF(A, R, G, B: THalfFloat): TColorHFRec; {$IFDEF USE_INLINE}inline;{$ENDIF} + + { Special formats conversion functions } { Converts image to/from/between special image formats (dxtc, ...).} @@ -285,6 +327,14 @@ procedure ConvertSpecial(var Image: TImageData; SrcInfo, { Inits all image format information. Called internally on startup.} procedure InitImageFormats(var Infos: TImageFormatInfoArray); +const + // Grayscale conversion channel weights + GrayConv: TColorFPRec = (B: 0.114; G: 0.587; R: 0.299; A: 0.0); + + // Contants for converting integer colors to floating point + OneDiv8Bit: Single = 1.0 / 255.0; + OneDiv16Bit: Single = 1.0 / 65535.0; + implementation { TImageFormatInfo member functions } @@ -317,14 +367,6 @@ procedure SetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward; procedure SetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward; - -const - // grayscale conversion channel weights - GrayConv: TColorFPRec = (B: 0.114; G: 0.587; R: 0.299; A: 0.0); - // contants for converting integer colors to floating point - OneDiv8Bit: Single = 1.0 / 255.0; - OneDiv16Bit: Single = 1.0 / 65535.0; - var PFR3G3B2: TPixelFormatInfo; PFX5R1G1B1: TPixelFormatInfo; @@ -759,6 +801,26 @@ var CheckDimensions: CheckDXTDimensions; SpecialNearestFormat: ifGray8); + ATI1NInfo: TImageFormatInfo = ( + Format: ifATI1N; + Name: 'ATI1N'; + ChannelCount: 1; + HasAlphaChannel: False; + IsSpecial: True; + GetPixelsSize: GetDXTPixelsSize; + CheckDimensions: CheckDXTDimensions; + SpecialNearestFormat: ifGray8); + + ATI2NInfo: TImageFormatInfo = ( + Format: ifATI2N; + Name: 'ATI2N'; + ChannelCount: 2; + HasAlphaChannel: False; + IsSpecial: True; + GetPixelsSize: GetDXTPixelsSize; + CheckDimensions: CheckDXTDimensions; + SpecialNearestFormat: ifA8R8G8B8); + {$WARNINGS ON} function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo; forward; @@ -804,6 +866,8 @@ begin Infos[ifDXT3] := @DXT3Info; Infos[ifDXT5] := @DXT5Info; Infos[ifBTC] := @BTCInfo; + Infos[ifATI1N] := @ATI1NInfo; + Infos[ifATI2N] := @ATI2NInfo; PFR3G3B2 := PixelFormat(0, 3, 3, 2); PFX5R1G1B1 := PixelFormat(0, 1, 1, 1); @@ -906,6 +970,57 @@ begin end; end; + +{ Color constructor functions } + + +function Color24(R, G, B: Byte): TColor24Rec; +begin + Result.R := R; + Result.G := G; + Result.B := B; +end; + +function Color32(A, R, G, B: Byte): TColor32Rec; +begin + Result.A := A; + Result.R := R; + Result.G := G; + Result.B := B; +end; + +function Color48(R, G, B: Word): TColor48Rec; +begin + Result.R := R; + Result.G := G; + Result.B := B; +end; + +function Color64(A, R, G, B: Word): TColor64Rec; +begin + Result.A := A; + Result.R := R; + Result.G := G; + Result.B := B; +end; + +function ColorFP(A, R, G, B: Single): TColorFPRec; +begin + Result.A := A; + Result.R := R; + Result.G := G; + Result.B := B; +end; + +function ColorHF(A, R, G, B: THalfFloat): TColorHFRec; +begin + Result.A := A; + Result.R := R; + Result.G := G; + Result.B := B; +end; + + { Additional image manipulation functions (usually used internally by Imaging unit) } const @@ -1184,13 +1299,18 @@ procedure ReduceColorsMedianCut(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, begin FillChar(DstPal^, SizeOf(TColor32Rec) * MaxColors, $FF); for I := 0 to MaxColors - 1 do + begin + if I < Boxes then with Box[I].Represented do - begin - DstPal[I].A := A; - DstPal[I].R := R; - DstPal[I].G := G; - DstPal[I].B := B; - end; + begin + DstPal[I].A := A; + DstPal[I].R := R; + DstPal[I].G := G; + DstPal[I].B := B; + end + else + DstPal[I].Color := $FF000000; + end; end; function MapColor(const Col: TColor32Rec) : LongInt; @@ -1439,37 +1559,21 @@ begin Result := 0.0; end; -const - // Some built-in filter functions adn their default radii - FilterFunctions: array[TSamplingFilter] of TFilterFunction = ( - FilterNearest, FilterLinear, FilterCosine, FilterHermite, FilterQuadratic, - FilterGaussian, FilterSpline, FilterLanczos, FilterMitchell, FilterCatmullRom); - FilterRadii: array[TSamplingFilter] of Single = ( - 1.0, 1.0, 1.0, 1.0, 1.5, - 1.25, 2.0, 3.0, 2.0, 2.0); - procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, DstHeight: LongInt; Filter: TSamplingFilter; WrapEdges: Boolean); begin // Calls the other function with filter function and radius defined by Filter StretchResample(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight, DstImage, DstX, DstY, - DstWidth, DstHeight, FilterFunctions[Filter], FilterRadii[Filter]); + DstWidth, DstHeight, SamplingFilterFunctions[Filter], SamplingFilterRadii[Filter], + WrapEdges); end; -{ The following resampling code is modified and extended code from Graphics32 - library by Alex A. Denisov.} -type - TPointRec = record - Pos: LongInt; - Weight: Single; - end; - TCluster = array of TPointRec; - TMappingTable = array of TCluster; - var FullEdge: Boolean = True; +{ The following resampling code is modified and extended code from Graphics32 + library by Alex A. Denisov.} function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt; Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable; var @@ -1595,6 +1699,25 @@ begin end; end; +procedure FindExtremes(const Map: TMappingTable; var MinPos, MaxPos: LongInt); +var + I, J: LongInt; +begin + if Length(Map) > 0 then + begin + MinPos := Map[0][0].Pos; + MaxPos := MinPos; + for I := 0 to Length(Map) - 1 do + for J := 0 to Length(Map[I]) - 1 do + begin + if MinPos > Map[I][J].Pos then + MinPos := Map[I][J].Pos; + if MaxPos < Map[I][J].Pos then + MaxPos := Map[I][J].Pos; + end; + end; +end; + procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, DstHeight: LongInt; Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean); @@ -1614,26 +1737,6 @@ var BytesPerChannel: LongInt; ChannelValueMax, InvChannelValueMax: Single; UseOptimizedVersion: Boolean; - - procedure FindExtremes(const Map: TMappingTable; var MinPos, MaxPos: LongInt); - var - I, J: LongInt; - begin - if Length(Map) > 0 then - begin - MinPos := Map[0][0].Pos; - MaxPos := MinPos; - for I := 0 to Length(Map) - 1 do - for J := 0 to Length(Map[I]) - 1 do - begin - if MinPos > Map[I][J].Pos then - MinPos := Map[I][J].Pos; - if MaxPos < Map[I][J].Pos then - MaxPos := Map[I][J].Pos; - end; - end; - end; - begin GetImageFormatInfo(SrcImage.Format, Info); Assert(SrcImage.Format = DstImage.Format); @@ -2237,6 +2340,21 @@ begin Result.B := FloatToHalf(ColorFP.B); end; +procedure VisualizePalette(Pal: PPalette32; Entries: Integer; out PalImage: TImageData); +var + I: Integer; + Pix: PColor32; +begin + InitImage(PalImage); + NewImage(Entries, 1, ifA8R8G8B8, PalImage); + Pix := PalImage.Bits; + for I := 0 to Entries - 1 do + begin + Pix^ := Pal[I].Color; + Inc(Pix); + end; +end; + { Pixel readers/writers for different image formats } @@ -3234,6 +3352,31 @@ begin end; end; +procedure GetInterpolatedAlphas(var AlphaBlock: TDXTAlphaBlockInt); +begin + with AlphaBlock do + if Alphas[0] > Alphas[1] then + begin + // Interpolation of six alphas + Alphas[2] := (6 * Alphas[0] + 1 * Alphas[1] + 3) div 7; + Alphas[3] := (5 * Alphas[0] + 2 * Alphas[1] + 3) div 7; + Alphas[4] := (4 * Alphas[0] + 3 * Alphas[1] + 3) div 7; + Alphas[5] := (3 * Alphas[0] + 4 * Alphas[1] + 3) div 7; + Alphas[6] := (2 * Alphas[0] + 5 * Alphas[1] + 3) div 7; + Alphas[7] := (1 * Alphas[0] + 6 * Alphas[1] + 3) div 7; + end + else + begin + // Interpolation of four alphas, two alphas are set directly + Alphas[2] := (4 * Alphas[0] + 1 * Alphas[1] + 2) div 5; + Alphas[3] := (3 * Alphas[0] + 2 * Alphas[1] + 2) div 5; + Alphas[4] := (2 * Alphas[0] + 3 * Alphas[1] + 2) div 5; + Alphas[5] := (1 * Alphas[0] + 4 * Alphas[1] + 2) div 5; + Alphas[6] := 0; + Alphas[7] := $FF; + end; +end; + procedure DecodeDXT5(SrcBits, DestBits: PByte; Width, Height: LongInt); var Sel, X, Y, I, J, K: LongInt; @@ -3264,27 +3407,7 @@ begin AMask[0] := PLongWord(@AlphaBlock.Alphas[2])^ and $00FFFFFF; AMask[1] := PLongWord(@AlphaBlock.Alphas[5])^ and $00FFFFFF; // alpha interpolation between two endpoint alphas - with AlphaBlock do - if Alphas[0] > Alphas[1] then - begin - // interpolation of six alphas - Alphas[2] := (6 * Alphas[0] + 1 * Alphas[1] + 3) div 7; - Alphas[3] := (5 * Alphas[0] + 2 * Alphas[1] + 3) div 7; - Alphas[4] := (4 * Alphas[0] + 3 * Alphas[1] + 3) div 7; - Alphas[5] := (3 * Alphas[0] + 4 * Alphas[1] + 3) div 7; - Alphas[6] := (2 * Alphas[0] + 5 * Alphas[1] + 3) div 7; - Alphas[7] := (1 * Alphas[0] + 6 * Alphas[1] + 3) div 7; - end - else - begin - // interpolation of four alphas, two alphas are set directly - Alphas[2] := (4 * Alphas[0] + 1 * Alphas[1] + 2) div 5; - Alphas[3] := (3 * Alphas[0] + 2 * Alphas[1] + 2) div 5; - Alphas[4] := (2 * Alphas[0] + 3 * Alphas[1] + 2) div 5; - Alphas[5] := (1 * Alphas[0] + 4 * Alphas[1] + 2) div 5; - Alphas[6] := 0; - Alphas[7] := $FF; - end; + GetInterpolatedAlphas(AlphaBlock); // we distribute the dxt block colors and alphas // across the 4x4 block of the destination image @@ -3307,7 +3430,7 @@ begin end; procedure GetBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos, - Width, Height: LongInt); + Width, Height: LongInt); var X, Y, I: LongInt; Src: PColor32Rec; @@ -3637,7 +3760,71 @@ begin end; end; -procedure DecodeBTC(SrcBits, DestBits: PByte; Width, Height: LongInt); +procedure GetOneChannelBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos, + Width, Height, BytesPP, ChannelIdx: Integer); +var + X, Y, I: Integer; + Src: PByte; +begin + I := 0; + // 4x4 pixel block is filled with information about every pixel in the block, + // but only one channel value is stored in Alpha field + for Y := 0 to 3 do + for X := 0 to 3 do + begin + Src := @PByteArray(SrcBits)[(YPos * 4 + Y) * Width * BytesPP + + (XPos * 4 + X) * BytesPP + ChannelIdx]; + Block[I].Alpha := Src^; + Inc(I); + end; +end; + +procedure EncodeATI1N(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer); +var + X, Y: Integer; + AlphaBlock: TDXTAlphaBlockInt; + Pixels: TPixelBlock; +begin + for Y := 0 to Height div 4 - 1 do + for X := 0 to Width div 4 - 1 do + begin + // Encode one channel + GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 1, 0); + GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]); + GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels, + PByteArray(@AlphaBlock.Alphas[2])); + PDXTAlphaBlockInt(DestBits)^ := AlphaBlock; + Inc(DestBits, SizeOf(AlphaBlock)); + end; +end; + +procedure EncodeATI2N(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer); +var + X, Y: Integer; + AlphaBlock: TDXTAlphaBlockInt; + Pixels: TPixelBlock; +begin + for Y := 0 to Height div 4 - 1 do + for X := 0 to Width div 4 - 1 do + begin + // Encode Red/X channel + GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 4, ChannelRed); + GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]); + GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels, + PByteArray(@AlphaBlock.Alphas[2])); + PDXTAlphaBlockInt(DestBits)^ := AlphaBlock; + Inc(DestBits, SizeOf(AlphaBlock)); + // Encode Green/Y channel + GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 4, ChannelGreen); + GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]); + GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels, + PByteArray(@AlphaBlock.Alphas[2])); + PDXTAlphaBlockInt(DestBits)^ := AlphaBlock; + Inc(DestBits, SizeOf(AlphaBlock)); + end; +end; + +procedure DecodeBTC(SrcBits, DestBits: PByte; Width, Height: Integer); var X, Y, I, J, K: Integer; Block: TBTCBlock; @@ -3665,25 +3852,101 @@ begin end; end; -procedure SpecialToUnSpecial(const SrcImage: TImageData; DestBits: Pointer; - SrcInfo, DstInfo: PImageFormatInfo); +procedure DecodeATI1N(SrcBits, DestBits: PByte; Width, Height: Integer); +var + X, Y, I, J: Integer; + AlphaBlock: TDXTAlphaBlockInt; + AMask: array[0..1] of LongWord; begin - case SrcInfo.Format of + for Y := 0 to Height div 4 - 1 do + for X := 0 to Width div 4 - 1 do + begin + AlphaBlock := PDXTAlphaBlockInt(SrcBits)^; + Inc(SrcBits, SizeOf(AlphaBlock)); + // 6 bit alpha mask is copied into two long words for + // easier usage + AMask[0] := PLongWord(@AlphaBlock.Alphas[2])^ and $00FFFFFF; + AMask[1] := PLongWord(@AlphaBlock.Alphas[5])^ and $00FFFFFF; + // alpha interpolation between two endpoint alphas + GetInterpolatedAlphas(AlphaBlock); + + // we distribute the dxt block alphas + // across the 4x4 block of the destination image + for J := 0 to 3 do + for I := 0 to 3 do + begin + PByteArray(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] := + AlphaBlock.Alphas[AMask[J shr 1] and 7]; + AMask[J shr 1] := AMask[J shr 1] shr 3; + end; + end; +end; + +procedure DecodeATI2N(SrcBits, DestBits: PByte; Width, Height: Integer); +var + X, Y, I, J: Integer; + Color: TColor32Rec; + AlphaBlock1, AlphaBlock2: TDXTAlphaBlockInt; + AMask1: array[0..1] of LongWord; + AMask2: array[0..1] of LongWord; +begin + for Y := 0 to Height div 4 - 1 do + for X := 0 to Width div 4 - 1 do + begin + // Read the first alpha block and get masks + AlphaBlock1 := PDXTAlphaBlockInt(SrcBits)^; + Inc(SrcBits, SizeOf(AlphaBlock1)); + AMask1[0] := PLongWord(@AlphaBlock1.Alphas[2])^ and $00FFFFFF; + AMask1[1] := PLongWord(@AlphaBlock1.Alphas[5])^ and $00FFFFFF; + // Read the secind alpha block and get masks + AlphaBlock2 := PDXTAlphaBlockInt(SrcBits)^; + Inc(SrcBits, SizeOf(AlphaBlock2)); + AMask2[0] := PLongWord(@AlphaBlock2.Alphas[2])^ and $00FFFFFF; + AMask2[1] := PLongWord(@AlphaBlock2.Alphas[5])^ and $00FFFFFF; + // alpha interpolation between two endpoint alphas + GetInterpolatedAlphas(AlphaBlock1); + GetInterpolatedAlphas(AlphaBlock2); + + Color.A := $FF; + Color.B := 0; + + // Distribute alpha block values across 4x4 pixel block, + // first alpha block represents Red channel, second is Green. + for J := 0 to 3 do + for I := 0 to 3 do + begin + Color.R := AlphaBlock1.Alphas[AMask1[J shr 1] and 7]; + Color.G := AlphaBlock2.Alphas[AMask2[J shr 1] and 7]; + PColor32RecArray(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] := Color; + AMask1[J shr 1] := AMask1[J shr 1] shr 3; + AMask2[J shr 1] := AMask2[J shr 1] shr 3; + end; + end; +end; + +procedure SpecialToUnSpecial(const SrcImage: TImageData; DestBits: Pointer; + SpecialFormat: TImageFormat); +begin + case SpecialFormat of ifDXT1: DecodeDXT1(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); ifDXT3: DecodeDXT3(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); ifDXT5: DecodeDXT5(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); ifBTC: DecodeBTC (SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); + ifATI1N: DecodeATI1N(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); + ifATI2N: DecodeATI2N(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); end; end; -procedure UnSpecialToSpecial(const DestImage: TImageData; SrcBits: Pointer; - SrcInfo, DstInfo: PImageFormatInfo); +procedure UnSpecialToSpecial(SrcBits: Pointer; const DestImage: TImageData; + SpecialFormat: TImageFormat); begin - case DstInfo.Format of + case SpecialFormat of ifDXT1: EncodeDXT1(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); ifDXT3: EncodeDXT3(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); ifDXT5: EncodeDXT5(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); ifBTC: EncodeBTC (SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); + ifATI1N: EncodeATI1N(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); + ifATI2N: EncodeATI2N(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); end; end; @@ -3691,35 +3954,58 @@ procedure ConvertSpecial(var Image: TImageData; SrcInfo, DstInfo: PImageFormatInfo); var WorkImage: TImageData; - Width, Height: LongInt; -begin - // first convert image to default non-special format - if SrcInfo.IsSpecial then + + procedure CheckSize(var Img: TImageData; Info: PImageFormatInfo); + var + Width, Height: Integer; begin + Width := Img.Width; + Height := Img.Height; + DstInfo.CheckDimensions(Info.Format, Width, Height); + ResizeImage(Img, Width, Height, rfNearest); + end; + +begin + if SrcInfo.IsSpecial and DstInfo.IsSpecial then + begin + // Convert source to nearest 'normal' format InitImage(WorkImage); NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage); - SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo, DstInfo); + SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo.Format); FreeImage(Image); - Image := WorkImage; + // Make sure output of SpecialToUnSpecial is the same as input of + // UnSpecialToSpecial + if SrcInfo.SpecialNearestFormat <> DstInfo.SpecialNearestFormat then + ConvertImage(WorkImage, DstInfo.SpecialNearestFormat); + // Convert work image to dest special format + CheckSize(WorkImage, DstInfo); + NewImage(WorkImage.Width, WorkImage.Height, DstInfo.Format, Image); + UnSpecialToSpecial(WorkImage.Bits, Image, DstInfo.Format); + FreeImage(WorkImage); end - else - ConvertImage(Image, DstInfo.SpecialNearestFormat); - // we have now image in default non-special format and - // if dest format is special we will convert to this special format - if DstInfo.IsSpecial then + else if SrcInfo.IsSpecial and not DstInfo.IsSpecial then begin - Width := Image.Width; - Height := Image.Height; - DstInfo.CheckDimensions(DstInfo.Format, Width, Height); + // Convert source to nearest 'normal' format InitImage(WorkImage); - NewImage(Width, Height, DstInfo.Format, WorkImage); - ResizeImage(Image, Width, Height, rfNearest); - UnSpecialToSpecial(WorkImage, Image.Bits, SrcInfo, DstInfo); + NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage); + SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo.Format); FreeImage(Image); + // Now convert to dest format + ConvertImage(WorkImage, DstInfo.Format); Image := WorkImage; end - else - ConvertImage(Image, DstInfo.Format); + else if not SrcInfo.IsSpecial and DstInfo.IsSpecial then + begin + // Convert source to nearest format + WorkImage := Image; + ConvertImage(WorkImage, DstInfo.SpecialNearestFormat); + // Now convert from nearest to dest + CheckSize(WorkImage, DstInfo); + InitImage(Image); + NewImage(WorkImage.Width, WorkImage.Height, DstInfo.Format, Image); + UnSpecialToSpecial(WorkImage.Bits, Image, DstInfo.Format); + FreeImage(WorkImage); + end; end; function GetStdPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; @@ -3740,7 +4026,7 @@ begin // multiples of four CheckDXTDimensions(Format, Width, Height); Result := Width * Height; - if Format = ifDXT1 then + if Format in [ifDXT1, ifATI1N] then Result := Result div 2; end; @@ -3908,6 +4194,29 @@ begin end; end; +initialization + // Initialize default sampling filter function pointers and radii + SamplingFilterFunctions[sfNearest] := FilterNearest; + SamplingFilterFunctions[sfLinear] := FilterLinear; + SamplingFilterFunctions[sfCosine] := FilterCosine; + SamplingFilterFunctions[sfHermite] := FilterHermite; + SamplingFilterFunctions[sfQuadratic] := FilterQuadratic; + SamplingFilterFunctions[sfGaussian] := FilterGaussian; + SamplingFilterFunctions[sfSpline] := FilterSpline; + SamplingFilterFunctions[sfLanczos] := FilterLanczos; + SamplingFilterFunctions[sfMitchell] := FilterMitchell; + SamplingFilterFunctions[sfCatmullRom] := FilterCatmullRom; + SamplingFilterRadii[sfNearest] := 1.0; + SamplingFilterRadii[sfLinear] := 1.0; + SamplingFilterRadii[sfCosine] := 1.0; + SamplingFilterRadii[sfHermite] := 1.0; + SamplingFilterRadii[sfQuadratic] := 1.5; + SamplingFilterRadii[sfGaussian] := 1.25; + SamplingFilterRadii[sfSpline] := 2.0; + SamplingFilterRadii[sfLanczos] := 3.0; + SamplingFilterRadii[sfMitchell] := 2.0; + SamplingFilterRadii[sfCatmullRom] := 2.0; + { File Notes: @@ -3915,6 +4224,17 @@ end; - nothing now - rewrite StretchRect for 8bit channels to use integer math? + -- 0.25.0 Changes/Bug Fixes ----------------------------------- + - Made some resampling stuff public so that it can be used in canvas class. + - Added some color constructors. + - Added VisualizePalette helper function. + - Fixed ConvertSpecial, not very readable before and error when + converting special->special. + + -- 0.24.3 Changes/Bug Fixes ----------------------------------- + - Some refactorings a changes to DXT based formats. + - Added ifATI1N and ifATI2N image data formats support structures and functions. + -- 0.23 Changes/Bug Fixes ----------------------------------- - Added ifBTC image format support structures and functions. diff --git a/Imaging/ImagingGif.pas b/Imaging/ImagingGif.pas index dfa8276..013fd67 100644 --- a/Imaging/ImagingGif.pas +++ b/Imaging/ImagingGif.pas @@ -1,5 +1,5 @@ { - $Id: ImagingGif.pas 111 2007-12-02 23:25:44Z galfar $ + $Id: ImagingGif.pas 132 2008-08-27 20:37:38Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -34,7 +34,7 @@ unit ImagingGif; interface uses - SysUtils, Classes, Imaging, ImagingTypes, ImagingUtility; + SysUtils, Classes, Imaging, ImagingTypes, ImagingIO, ImagingUtility; type { GIF (Graphics Interchange Format) loader/saver class. GIF was @@ -48,7 +48,7 @@ type TGIFFileFormat = class(TImageFileFormat) private function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer; - procedure LZWDecompress(const IO: TIOFunctions; Handle: TImagingHandle; + procedure LZWDecompress(Stream: TStream; Handle: TImagingHandle; Width, Height: Integer; Interlaced: Boolean; Data: Pointer); procedure LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle; Width, Height, BitCount: Integer; Interlaced: Boolean; Data: Pointer); @@ -246,7 +246,7 @@ begin end; { GIF LZW decompresion code is from JVCL JvGIF.pas unit.} -procedure TGIFFileFormat.LZWDecompress(const IO: TIOFunctions; Handle: TImagingHandle; Width, Height: Integer; +procedure TGIFFileFormat.LZWDecompress(Stream: TStream; Handle: TImagingHandle; Width, Height: Integer; Interlaced: Boolean; Data: Pointer); var MinCodeSize: Byte; @@ -266,7 +266,8 @@ var Bytes: Byte; BytesToLose: Integer; begin - while Context.Inx + Context.CodeSize > Context.Size do + while (Context.Inx + Context.CodeSize > Context.Size) and + (Stream.Position < Stream.Size) do begin // Not enough bits in buffer - refill it - Not very efficient, but infrequently called BytesToLose := Context.Inx shr 3; @@ -274,16 +275,16 @@ var Move(Context.Buf[Word(BytesToLose)], Context.Buf[0], 3); Context.Inx := Context.Inx and 7; Context.Size := Context.Size - (BytesToLose shl 3); - IO.Read(Handle, @Bytes, 1); + Stream.Read(Bytes, 1); if Bytes > 0 then - IO.Read(Handle, @Context.Buf[Word(Context.Size shr 3)], Bytes); + Stream.Read(Context.Buf[Word(Context.Size shr 3)], Bytes); Context.Size := Context.Size + (Bytes shl 3); end; ByteIndex := Context.Inx shr 3; RawCode := Context.Buf[Word(ByteIndex)] + (Word(Context.Buf[Word(ByteIndex + 1)]) shl 8); if Context.CodeSize > 8 then - RawCode := RawCode + (Longint(Context.Buf[ByteIndex + 2]) shl 16); + RawCode := RawCode + (LongInt(Context.Buf[ByteIndex + 2]) shl 16); RawCode := RawCode shr (Context.Inx and 7); Context.Inx := Context.Inx + Byte(Context.CodeSize); Result := RawCode and Context.ReadMask; @@ -345,7 +346,7 @@ begin GetMem(Suffix, SizeOf(TIntCodeTable)); GetMem(OutCode, SizeOf(TIntCodeTable) + SizeOf(Word)); try - IO.Read(Handle, @MinCodeSize, 1); + Stream.Read(MinCodeSize, 1); if (MinCodeSize < 2) or (MinCodeSize > 9) then RaiseImaging(SGIFDecodingError, []); // Initial read context @@ -690,20 +691,26 @@ var end; end; - procedure CopyFrameTransparent(const Image, Frame: TImageData; Left, Top, TransIndex: Integer); + procedure CopyFrameTransparent(const Image, Frame: TImageData; Left, Top, + TransIndex: Integer; Disposal: TDisposalMethod); var X, Y: Integer; Src, Dst: PByte; begin Src := Frame.Bits; - // Copy all pixels from frame to log screen but ignore the transparent ones + // Copy all pixels from frame to log screen but ignore the transparent ones for Y := 0 to Frame.Height - 1 do begin Dst := @PByteArray(Image.Bits)[(Top + Y) * Image.Width + Left]; for X := 0 to Frame.Width - 1 do begin - if Src^ <> TransIndex then + // If disposal methos is undefined copy all pixels regardless of + // transparency (transparency of whole image will be determined by TranspIndex + // in image palette) - same effect as filling the image with trasp color + // instead of backround color beforehand. + // For other methods don't copy transparent pixels from frame to image. + if (Src^ <> TransIndex) or (Disposal = dmUndefined) then Dst^ := Src^; Inc(Src); Inc(Dst); @@ -711,6 +718,28 @@ var end; end; + procedure CopyLZWData(Dest: TStream); + var + CodeSize, BlockSize: Byte; + InputSize: Integer; + Buff: array[Byte] of Byte; + begin + InputSize := ImagingIO.GetInputSize(GetIO, Handle); + // Copy codesize to stream + GetIO.Read(Handle, @CodeSize, 1); + Dest.Write(CodeSize, 1); + repeat + // Read and write data blocks, last is block term value of 0 + GetIO.Read(Handle, @BlockSize, 1); + Dest.Write(BlockSize, 1); + if BlockSize > 0 then + begin + GetIO.Read(Handle, @Buff[0], BlockSize); + Dest.Write(Buff[0], BlockSize); + end; + until (BlockSize = 0) or (GetIO.Tell(Handle) >= InputSize); + end; + procedure ReadFrame; var ImageDesc: TImageDescriptor; @@ -719,6 +748,7 @@ var LocalPal: TPalette32Size256; BlockTerm: Byte; Frame: TImageData; + LZWStream: TMemoryStream; begin Idx := Length(Images); SetLength(Images, Idx + 1); @@ -806,15 +836,20 @@ var @Header.BackgroundColorIndex); end; + LZWStream := TMemoryStream.Create; try + // Copy LZW data to temp stream, needed for correct decompression + CopyLZWData(LZWStream); + LZWStream.Position := 0; // Data decompression finally - LZWDecompress(GetIO, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Frame.Bits); - Read(Handle, @BlockTerm, SizeOf(BlockTerm)); + LZWDecompress(LZWStream, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Frame.Bits); // Now copy frame to logical screen with skipping of transparent pixels (if enabled) TransIndex := Iff(HasTransparency, GraphicExt.TransparentColorIndex, MaxInt); - CopyFrameTransparent(Images[Idx], Frame, ImageDesc.Left, ImageDesc.Top, TransIndex); + CopyFrameTransparent(Images[Idx], Frame, ImageDesc.Left, ImageDesc.Top, + TransIndex, Disposals[Idx]); finally FreeImage(Frame); + LZWStream.Free; end; end; end; @@ -840,7 +875,6 @@ begin Read(Handle, @GlobalPal[I].G, SizeOf(GlobalPal[I].G)); Read(Handle, @GlobalPal[I].B, SizeOf(GlobalPal[I].B)); end; - GlobalPal[Header.BackgroundColorIndex].A := 0; end; // Read ID of the first block @@ -973,6 +1007,14 @@ initialization -- TODOS ---------------------------------------------------- - nothing now + -- 0.25.0 Changes/Bug Fixes --------------------------------- + - Fixed loading of some rare GIFs, problems with LZW + decompression. + + -- 0.24.3 Changes/Bug Fixes --------------------------------- + - Better solution to transparency for some GIFs. Background not + transparent by default. + -- 0.24.1 Changes/Bug Fixes --------------------------------- - Made backround color transparent by default (alpha = 0). diff --git a/Imaging/ImagingJpeg.pas b/Imaging/ImagingJpeg.pas index 9d6d4b2..cd83743 100644 --- a/Imaging/ImagingJpeg.pas +++ b/Imaging/ImagingJpeg.pas @@ -1,5 +1,5 @@ { - $Id: ImagingJpeg.pas 103 2007-09-15 01:11:14Z galfar $ + $Id: ImagingJpeg.pas 128 2008-07-23 11:57:36Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -46,7 +46,7 @@ unit ImagingJpeg; { Automatically use FPC's PasJpeg when compiling with Lazarus.} {$IFDEF LCL} - { $UNDEF IMJPEGLIB} + {$UNDEF IMJPEGLIB} {$DEFINE PASJPEG} {$ENDIF} @@ -65,7 +65,7 @@ uses {$IF Defined(FPC) and Defined(PASJPEG)} { When using FPC's pasjpeg in FPC the channel order is BGR instead of RGB} - { $DEFINE RGBSWAPPED} // not needed now apparently + {$DEFINE RGBSWAPPED} {$IFEND} type @@ -375,10 +375,8 @@ var Dest: PByte; jc: TJpegContext; Info: TImageFormatInfo; - Format: TImageFormat; Col32: PColor32Rec; {$IFDEF RGBSWAPPED} - I: LongInt; Pix: PColor24Rec; {$ENDIF} begin @@ -556,6 +554,9 @@ initialization -- TODOS ---------------------------------------------------- - nothing now + -- 0.25.0 Changes/Bug Fixes --------------------------------- + -- FPC's PasJpeg wasn't really used in last version, fixed. + -- 0.24.1 Changes/Bug Fixes --------------------------------- - Fixed loading of CMYK jpeg images. Could cause heap corruption and loaded image looked wrong. diff --git a/Imaging/ImagingNetworkGraphics.pas b/Imaging/ImagingNetworkGraphics.pas index 3b2dbb2..a83dcd9 100644 --- a/Imaging/ImagingNetworkGraphics.pas +++ b/Imaging/ImagingNetworkGraphics.pas @@ -1,5 +1,5 @@ { - $Id: ImagingNetworkGraphics.pas 90 2007-06-18 22:09:16Z galfar $ + $Id: ImagingNetworkGraphics.pas 122 2008-03-14 14:05:42Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -299,6 +299,7 @@ type GlobalPaletteEntries: LongInt; GlobalTransparency: Pointer; GlobalTransparencySize: LongInt; + destructor Destroy; override; procedure Clear; function GetLastFrame: TFrameInfo; function AddFrameInfo: TFrameInfo; @@ -340,10 +341,6 @@ type end; {$ENDIF} -var - NGFileLoader: TNGFileLoader = nil; - NGFileSaver: TNGFileSaver = nil; - { Helper routines } function PaethPredictor(A, B, C: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} @@ -455,6 +452,12 @@ end; { TNGFileHandler class implementation} +destructor TNGFileHandler.Destroy; +begin + Clear; + inherited Destroy; +end; + procedure TNGFileHandler.Clear; var I: LongInt; @@ -1865,8 +1868,11 @@ end; function TPNGFileFormat.LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; +var + NGFileLoader: TNGFileLoader; begin Result := False; + NGFileLoader := TNGFileLoader.Create; try // Use NG file parser to load file if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then @@ -1881,7 +1887,7 @@ begin Result := True; end; finally - NGFileLoader.Clear; + NGFileLoader.Free; end; end; @@ -1890,21 +1896,25 @@ function TPNGFileFormat.SaveData(Handle: TImagingHandle; var ImageToSave: TImageData; MustBeFreed: Boolean; + NGFileSaver: TNGFileSaver; begin // Make image PNG compatible, store it in saver, and save it to file Result := MakeCompatible(Images[Index], ImageToSave, MustBeFreed); if Result then - with NGFileSaver do - try - FileType := ngPNG; - SetFileOptions(Self); - AddFrame(ImageToSave, False); - SaveFile(Handle); - finally - // Clear NG saver and compatible image - Clear; - if MustBeFreed then - FreeImage(ImageToSave); + begin + NGFileSaver := TNGFileSaver.Create; + with NGFileSaver do + try + FileType := ngPNG; + SetFileOptions(Self); + AddFrame(ImageToSave, False); + SaveFile(Handle); + finally + // Free NG saver and compatible image + NGFileSaver.Free; + if MustBeFreed then + FreeImage(ImageToSave); + end; end; end; @@ -1932,9 +1942,11 @@ end; function TMNGFileFormat.LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; var + NGFileLoader: TNGFileLoader; I, Len: LongInt; begin Result := False; + NGFileLoader := TNGFileLoader.Create; try // Use NG file parser to load file if NGFileLoader.LoadFile(Handle) then @@ -1965,13 +1977,14 @@ begin Result := True; end; finally - NGFileLoader.Clear; + NGFileLoader.Free; end; end; function TMNGFileFormat.SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; Index: LongInt): Boolean; var + NGFileSaver: TNGFileSaver; I, LargestWidth, LargestHeight: LongInt; ImageToSave: TImageData; MustBeFreed: Boolean; @@ -1980,6 +1993,7 @@ begin LargestWidth := 0; LargestHeight := 0; + NGFileSaver := TNGFileSaver.Create; NGFileSaver.FileType := ngMNG; NGFileSaver.SetFileOptions(Self); @@ -2016,7 +2030,7 @@ begin SaveFile(Handle); Result := True; finally - Clear; + NGFileSaver.Free; end; end; @@ -2044,8 +2058,11 @@ end; function TJNGFileFormat.LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; +var + NGFileLoader: TNGFileLoader; begin Result := False; + NGFileLoader := TNGFileLoader.Create; try // Use NG file parser to load file if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then @@ -2060,48 +2077,48 @@ begin Result := True; end; finally - NGFileLoader.Clear; + NGFileLoader.Free; end; end; function TJNGFileFormat.SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; Index: LongInt): Boolean; var + NGFileSaver: TNGFileSaver; ImageToSave: TImageData; MustBeFreed: Boolean; begin // Make image JNG compatible, store it in saver, and save it to file Result := MakeCompatible(Images[Index], ImageToSave, MustBeFreed); if Result then - with NGFileSaver do - try - FileType := ngJNG; - SetFileOptions(Self); - AddFrame(ImageToSave, True); - SaveFile(Handle); - finally - // Clear NG saver and compatible image - Clear; - if MustBeFreed then - FreeImage(ImageToSave); + begin + NGFileSaver := TNGFileSaver.Create; + with NGFileSaver do + try + FileType := ngJNG; + SetFileOptions(Self); + AddFrame(ImageToSave, True); + SaveFile(Handle); + finally + // Free NG saver and compatible image + NGFileSaver.Free; + if MustBeFreed then + FreeImage(ImageToSave); + end; end; end; {$ENDIF} initialization - NGFileLoader := TNGFileLoader.Create; - NGFileSaver := TNGFileSaver.Create; RegisterImageFileFormat(TPNGFileFormat); {$IFDEF LINK_MNG} RegisterImageFileFormat(TMNGFileFormat); {$ENDIF} {$IFDEF LINK_JNG} RegisterImageFileFormat(TJNGFileFormat); -{$ENDIF} +{$ENDIF} finalization - FreeAndNil(NGFileLoader); - FreeAndNil(NGFileSaver); { File Notes: @@ -2109,6 +2126,9 @@ finalization -- TODOS ---------------------------------------------------- - nothing now + -- 0.24.3 Changes/Bug Fixes --------------------------------- + - Changes for better thread safety. + -- 0.23 Changes/Bug Fixes ----------------------------------- - Added loading of global palettes and transparencies in MNG files (and by doing so fixed crash when loading images with global PLTE or tRNS). diff --git a/Imaging/ImagingOpenGL.pas b/Imaging/ImagingOpenGL.pas index c49bde4..ac2af20 100644 --- a/Imaging/ImagingOpenGL.pas +++ b/Imaging/ImagingOpenGL.pas @@ -1,5 +1,5 @@ { - $Id: ImagingOpenGL.pas 106 2007-10-23 23:03:35Z galfar $ + $Id: ImagingOpenGL.pas 128 2008-07-23 11:57:36Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -33,7 +33,7 @@ unit ImagingOpenGL; {$I ImagingOptions.inc} { Define this symbol if you want to use dglOpenGL header.} -{ $DEFINE USE_DGL_HEADERS} +{.$DEFINE USE_DGL_HEADERS} interface @@ -49,12 +49,17 @@ uses type { Various texture capabilities of installed OpenGL driver.} TGLTextureCaps = record - MaxTextureSize: LongInt; - PowerOfTwo: Boolean; - DXTCompression: Boolean; - FloatTextures: Boolean; - MaxAnisotropy: LongInt; - MaxSimultaneousTextures: LongInt; + MaxTextureSize: LongInt; // Max size of texture in pixels supported by HW + NonPowerOfTwo: Boolean; // HW has full support for NPOT textures + DXTCompression: Boolean; // HW supports S3TC/DXTC compressed textures + ATI3DcCompression: Boolean; // HW supports ATI 3Dc compressed textures (ATI2N) + LATCCompression: Boolean; // HW supports LATC/RGTC compressed textures (ATI1N+ATI2N) + FloatTextures: Boolean; // HW supports floating point textures + MaxAnisotropy: LongInt; // Max anisotropy for aniso texture filtering + MaxSimultaneousTextures: LongInt; // Number of texture units + ClampToEdge: Boolean; // GL_EXT_texture_edge_clamp + TextureLOD: Boolean; // GL_SGIS_texture_lod + VertexTextureUnits: Integer; // Texture units accessible in vertex programs end; { Returns texture capabilities of installed OpenGL driver.} @@ -71,7 +76,7 @@ function IsGLExtensionSupported(const Extension: string): Boolean; supported by hardware using GetGLTextureCaps, ImageFormatToGL does not check this.} function ImageFormatToGL(Format: TImageFormat; var GLFormat: GLenum; - var GLType: GLenum; var GLInternal: GLint): Boolean; + var GLType: GLenum; var GLInternal: GLint; const Caps: TGLTextureCaps): Boolean; { All GL textures created by Imaging functions have default parameters set - that means that no glTexParameter calls are made so default filtering, @@ -164,6 +169,14 @@ var image->texture process (usually only pow2/nonpow2 stuff and when you set custom Width & Height in CreateGLTextureFrom(Multi)Image).} PasteNonPow2ImagesIntoPow2: Boolean = False; + { Standard behaviur if GL_ARB_texture_non_power_of_two extension is not supported + is to rescale image to power of 2 dimensions. NPOT extension is exposed only + when HW has full support for NPOT textures but some cards + (ATI Radeons, some other maybe) have partial NPOT support. Namely Radeons + can use NPOT textures but not mipmapped. If you know what you are doing + you can disable NPOT support check so the image won't be rescaled to POT + by seting DisableNPOTSupportCheck to True.} + DisableNPOTSupportCheck: Boolean = False; implementation @@ -239,6 +252,11 @@ const GL_COMPRESSED_RGBA_S3TC_DXT1_EXT = $83F1; GL_COMPRESSED_RGBA_S3TC_DXT3_EXT = $83F2; GL_COMPRESSED_RGBA_S3TC_DXT5_EXT = $83F3; + GL_COMPRESSED_LUMINANCE_ALPHA_3DC_ATI = $8837; + GL_COMPRESSED_LUMINANCE_LATC1_EXT = $8C70; + GL_COMPRESSED_SIGNED_LUMINANCE_LATC1_EXT = $8C71; + GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT = $8C72; + GL_COMPRESSED_SIGNED_LUMINANCE_ALPHA_LATC2_EXT = $8C73; // various GL extension constants GL_MAX_TEXTURE_UNITS = $84E2; @@ -311,36 +329,49 @@ end; function GetGLTextureCaps(var Caps: TGLTextureCaps): Boolean; begin - // check DXTC support and load extension functions if necesary + // Check DXTC support and load extension functions if necesary Caps.DXTCompression := IsGLExtensionSupported('GL_ARB_texture_compression') and IsGLExtensionSupported('GL_EXT_texture_compression_s3tc'); if Caps.DXTCompression then glCompressedTexImage2D := GetGLProcAddress('glCompressedTexImage2D'); Caps.DXTCompression := Caps.DXTCompression and (@glCompressedTexImage2D <> nil); - // check non power of 2 textures - Caps.PowerOfTwo := not IsGLExtensionSupported('GL_ARB_texture_non_power_of_two'); - // check for floating point textures support + Caps.ATI3DcCompression := Caps.DXTCompression and + IsGLExtensionSupported('GL_ATI_texture_compression_3dc'); + Caps.LATCCompression := Caps.DXTCompression and + IsGLExtensionSupported('GL_EXT_texture_compression_latc'); + // Check non power of 2 textures + Caps.NonPowerOfTwo := IsGLExtensionSupported('GL_ARB_texture_non_power_of_two'); + // Check for floating point textures support Caps.FloatTextures := IsGLExtensionSupported('GL_ARB_texture_float'); - // get max texture size + // Get max texture size glGetIntegerv(GL_MAX_TEXTURE_SIZE, @Caps.MaxTextureSize); - // get max anisotropy + // Get max anisotropy if IsGLExtensionSupported('GL_EXT_texture_filter_anisotropic') then glGetIntegerv(GL_MAX_TEXTURE_MAX_ANISOTROPY_EXT, @Caps.MaxAnisotropy) else Caps.MaxAnisotropy := 0; - // get number of texture units + // Get number of texture units if IsGLExtensionSupported('GL_ARB_multitexture') then glGetIntegerv(GL_MAX_TEXTURE_UNITS, @Caps.MaxSimultaneousTextures) else Caps.MaxSimultaneousTextures := 1; - // get max texture size + // Get number of vertex texture units + if IsGLExtensionSupported('GL_ARB_vertex_shader') then + glGetIntegerv(GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS, @Caps.VertexTextureUnits) + else + Caps.VertexTextureUnits := 1; + // Get max texture size glGetIntegerv(GL_MAX_TEXTURE_SIZE, @Caps.MaxTextureSize); + // Clamp texture to edge? + Caps.ClampToEdge := IsGLExtensionSupported('GL_EXT_texture_edge_clamp'); + // Texture LOD extension? + Caps.TextureLOD := IsGLExtensionSupported('GL_SGIS_texture_lod'); Result := True; end; function ImageFormatToGL(Format: TImageFormat; var GLFormat: GLenum; - var GLType: GLenum; var GLInternal: GLint): Boolean; + var GLType: GLenum; var GLInternal: GLint; const Caps: TGLTextureCaps): Boolean; begin GLFormat := 0; GLType := 0; @@ -437,6 +468,13 @@ begin ifDXT1: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT1_EXT; ifDXT3: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT3_EXT; ifDXT5: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT5_EXT; + ifATI1N: GLInternal := GL_COMPRESSED_LUMINANCE_LATC1_EXT; + ifATI2N: + begin + GLInternal := GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT; + if not Caps.LATCCompression and Caps.ATI3DcCompression then + GLInternal := GL_COMPRESSED_LUMINANCE_ALPHA_3DC_ATI; + end; end; Result := GLInternal <> 0; end; @@ -500,7 +538,7 @@ function CreateGLTextureFromMultiImage(const Images: TDynImageDataArray; Width, Height: LongInt; MipMaps: Boolean; MainLevelIndex: LongInt; OverrideFormat: TImageFormat; CreatedWidth, CreatedHeight: PLongInt): GLuint; const - CompressedFormats: TImageFormats = [ifDXT1, ifDXT3, ifDXT5]; + BlockCompressedFormats: TImageFormats = [ifDXT1, ifDXT3, ifDXT5, ifATI1N, ifATI2N]; var I, MipLevels, PossibleLevels, ExistingLevels, CurrentWidth, CurrentHeight: LongInt; Caps: TGLTextureCaps; @@ -537,7 +575,7 @@ begin // First check desired size and modify it if necessary if Width <= 0 then Width := Images[MainLevelIndex].Width; if Height <= 0 then Height := Images[MainLevelIndex].Height; - if Caps.PowerOfTwo then + if not Caps.NonPowerOfTwo and not DisableNPOTSupportCheck then begin // If device supports only power of 2 texture sizes Width := NextPow2(Width); @@ -564,23 +602,27 @@ begin else Desired := OverrideFormat; - // Check if the hardware supports floating point and compressed textures + // Check if the hardware supports floating point and compressed textures GetImageFormatInfo(Desired, Info); if Info.IsFloatingPoint and not Caps.FloatTextures then Desired := ifA8R8G8B8; if (Desired in [ifDXT1, ifDXT3, ifDXT5]) and not Caps.DXTCompression then Desired := ifA8R8G8B8; + if (Desired = ifATI1N) and not Caps.LATCCompression then + Desired := ifGray8; + if (Desired = ifATI2N) and not (Caps.ATI3DcCompression or Caps.LATCCompression) then + Desired := ifA8Gray8; // Try to find GL format equivalent to image format and if it is not // found use one of default formats - if not ImageFormatToGL(Desired, GLFormat, GLType, GLInternal) then + if not ImageFormatToGL(Desired, GLFormat, GLType, GLInternal, Caps) then begin GetImageFormatInfo(Desired, Info); if Info.HasGrayChannel then ConvTo := ifGray8 else ConvTo := ifA8R8G8B8; - if not ImageFormatToGL(ConvTo, GLFormat, GLType, GLInternal) then + if not ImageFormatToGL(ConvTo, GLFormat, GLType, GLInternal, Caps) then Exit; end else @@ -618,7 +660,7 @@ begin // Check if input image for this mipmap level has the right // size and format NeedsConvert := not (Images[I].Format = ConvTo); - if ConvTo in CompressedFormats then + if ConvTo in BlockCompressedFormats then begin // Input images in DXTC will have min dimensions of 4, but we need // current Width and Height to be lesser (for glCompressedTexImage2D) @@ -659,7 +701,7 @@ begin FillMipMapLevel(LevelsArray[I - 1], CurrentWidth, CurrentHeight, LevelsArray[I]); end; - if ConvTo in CompressedFormats then + if ConvTo in BlockCompressedFormats then begin // Note: GL DXTC texture snaller than 4x4 must have width and height // as expected for non-DXTC texture (like 1x1 - we cannot @@ -838,6 +880,14 @@ initialization not only A8R8G8B8 - support for cube and 3D maps + -- 0.25.0 Changes/Bug Fixes --------------------------------- + - Added 3Dc compressed texture formats support. + - Added detection of 3Dc formats to texture caps. + + -- 0.24.3 Changes/Bug Fixes --------------------------------- + - Added DisableNPOTSupportCheck option and related functionality. + - Added some new texture caps detection. + -- 0.24.1 Changes/Bug Fixes --------------------------------- - Added PasteNonPow2ImagesIntoPow2 option and related functionality. - Better NeedsResize determination for small DXTC textures - diff --git a/Imaging/ImagingOptions.inc b/Imaging/ImagingOptions.inc index e2ab253..2c18fc8 100644 --- a/Imaging/ImagingOptions.inc +++ b/Imaging/ImagingOptions.inc @@ -1,4 +1,4 @@ -{ $Id: ImagingOptions.inc 100 2007-06-28 21:09:52Z galfar $ } +{ $Id: ImagingOptions.inc 132 2008-08-27 20:37:38Z galfar $ } { User Options @@ -212,11 +212,6 @@ {$PACKENUM 4} // Min enum size: 4 B {$CALLING REGISTER} // default calling convention is register {$IFDEF CPU86} - {$IFNDEF DYN_LIBRARY} - {$SMARTLINK ON} // smartlinking on, but not for dll/so - - // nothing gets exported from library when it is on - // in FPC 1.9.8 - {$ENDIF} {$ASMMODE INTEL} // intel assembler mode {$ENDIF} {$ENDIF} diff --git a/Imaging/ImagingPortableMaps.pas b/Imaging/ImagingPortableMaps.pas index 9566d4b..871e2c4 100644 --- a/Imaging/ImagingPortableMaps.pas +++ b/Imaging/ImagingPortableMaps.pas @@ -1,5 +1,5 @@ { - $Id: ImagingPortableMaps.pas 107 2007-11-06 23:37:48Z galfar $ + $Id: ImagingPortableMaps.pas 127 2008-05-31 01:57:13Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -65,11 +65,10 @@ type protected FIdNumbers: TChar2; FSaveBinary: LongBool; - FMapInfo: TPortableMapInfo; function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; override; - function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; - Index: LongInt): Boolean; override; + function SaveDataInternal(Handle: TImagingHandle; const Images: TDynImageDataArray; + Index: LongInt; var MapInfo: TPortableMapInfo): Boolean; public constructor Create; override; function TestFormat(Handle: TImagingHandle): Boolean; override; @@ -203,6 +202,8 @@ var PixelFP: TColorFPRec; LineBuffer: array[0..LineBufferCapacity - 1] of Char; LineEnd, LinePos: LongInt; + MapInfo: TPortableMapInfo; + LineBreak: string; procedure CheckBuffer; begin @@ -262,7 +263,7 @@ var C := LineBuffer[LinePos]; Inc(LinePos); until not (C in WhiteSpaces) or (LineEnd = 0); - // Dec pos, current is the beggining of the the string + // Dec pos, current is the begining of the the string Dec(LinePos); Result := S; @@ -273,6 +274,22 @@ var Result := StrToInt(ReadString); end; + procedure FindLineBreak; + var + C: Char; + begin + LineBreak := #10; + repeat + CheckBuffer; + C := LineBuffer[LinePos]; + Inc(LinePos); + + if C = #13 then + LineBreak := #13#10; + + until C = #10; + end; + function ParseHeader: Boolean; var Id: TChar2; @@ -284,34 +301,37 @@ var Result := False; with GetIO do begin - FillChar(FMapInfo, SizeOf(FMapInfo), 0); + FillChar(MapInfo, SizeOf(MapInfo), 0); Read(Handle, @Id, SizeOf(Id)); + FindLineBreak; + if Id[1] in ['1'..'6'] then begin // Read header for PBM, PGM, and PPM files - FMapInfo.Width := ReadIntValue; - FMapInfo.Height := ReadIntValue; + MapInfo.Width := ReadIntValue; + MapInfo.Height := ReadIntValue; + if Id[1] in ['1', '4'] then begin - FMapInfo.MaxVal := 1; - FMapInfo.BitCount := 1 + MapInfo.MaxVal := 1; + MapInfo.BitCount := 1 end else begin // Read channel max value, <=255 for 8bit images, >255 for 16bit images // but some programs think its max colors so put <=256 here - FMapInfo.MaxVal := ReadIntValue; - FMapInfo.BitCount := Iff(FMapInfo.MaxVal <= 256, 8, 16); + MapInfo.MaxVal := ReadIntValue; + MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16); end; - FMapInfo.Depth := 1; + MapInfo.Depth := 1; case Id[1] of - '1', '4': FMapInfo.TupleType := ttBlackAndWhite; - '2', '5': FMapInfo.TupleType := ttGrayScale; + '1', '4': MapInfo.TupleType := ttBlackAndWhite; + '2', '5': MapInfo.TupleType := ttGrayScale; '3', '6': begin - FMapInfo.TupleType := ttRGB; - FMapInfo.Depth := 3; + MapInfo.TupleType := ttRGB; + MapInfo.Depth := 3; end; end; end @@ -320,24 +340,24 @@ var // Read values from PAM header // WIDTH if (ReadString <> SPAMWidth) then Exit; - FMapInfo.Width := ReadIntValue; + MapInfo.Width := ReadIntValue; // HEIGHT if (ReadString <> SPAMheight) then Exit; - FMapInfo.Height := ReadIntValue; + MapInfo.Height := ReadIntValue; // DEPTH if (ReadString <> SPAMDepth) then Exit; - FMapInfo.Depth := ReadIntValue; + MapInfo.Depth := ReadIntValue; // MAXVAL if (ReadString <> SPAMMaxVal) then Exit; - FMapInfo.MaxVal := ReadIntValue; - FMapInfo.BitCount := Iff(FMapInfo.MaxVal <= 256, 8, 16); + MapInfo.MaxVal := ReadIntValue; + MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16); // TUPLETYPE if (ReadString <> SPAMTupleType) then Exit; TupleTypeName := ReadString; for I := Low(TTupleType) to High(TTupleType) do if SameText(TupleTypeName, TupleTypeNames[I]) then begin - FMapInfo.TupleType := I; + MapInfo.TupleType := I; Break; end; // ENDHDR @@ -346,33 +366,42 @@ var else if Id[1] in ['F', 'f'] then begin // Read header of PFM file - FMapInfo.Width := ReadIntValue; - FMapInfo.Height := ReadIntValue; + MapInfo.Width := ReadIntValue; + MapInfo.Height := ReadIntValue; OldSeparator := DecimalSeparator; DecimalSeparator := '.'; Scale := StrToFloatDef(ReadString, 0); DecimalSeparator := OldSeparator; - FMapInfo.IsBigEndian := Scale > 0.0; + MapInfo.IsBigEndian := Scale > 0.0; if Id[1] = 'F' then - FMapInfo.TupleType := ttRGBFP + MapInfo.TupleType := ttRGBFP else - FMapInfo.TupleType := ttGrayScaleFP; - FMapInfo.Depth := Iff(FMapInfo.TupleType = ttRGBFP, 3, 1); - FMapInfo.BitCount := Iff(FMapInfo.TupleType = ttRGBFP, 96, 32); + MapInfo.TupleType := ttGrayScaleFP; + MapInfo.Depth := Iff(MapInfo.TupleType = ttRGBFP, 3, 1); + MapInfo.BitCount := Iff(MapInfo.TupleType = ttRGBFP, 96, 32); end; FixInputPos; - FMapInfo.Binary := (Id[1] in ['4', '5', '6', '7', 'F', 'f']); + MapInfo.Binary := (Id[1] in ['4', '5', '6', '7', 'F', 'f']); + + if MapInfo.Binary and not (Id[1] in ['F', 'f']) then + begin + // Mimic the behaviour of Photoshop and other editors/viewers: + // If linenreaks in file are DOS CR/LF 16bit binary values are + // little endian, Unix LF only linebreak indicates big endian. + MapInfo.IsBigEndian := LineBreak = #10; + end; + // Check if values found in header are valid - Result := (FMapInfo.Width > 0) and (FMapInfo.Height > 0) and - (FMapInfo.BitCount in [1, 8, 16, 32, 96]) and (FMapInfo.TupleType <> ttInvalid); + Result := (MapInfo.Width > 0) and (MapInfo.Height > 0) and + (MapInfo.BitCount in [1, 8, 16, 32, 96]) and (MapInfo.TupleType <> ttInvalid); // Now check if image has proper number of channels (PAM) if Result then - case FMapInfo.TupleType of - ttBlackAndWhite, ttGrayScale: Result := FMapInfo.Depth = 1; - ttBlackAndWhiteAlpha, ttGrayScaleAlpha: Result := FMapInfo.Depth = 2; - ttRGB: Result := FMapInfo.Depth = 3; - ttRGBAlpha: Result := FMapInfo.Depth = 4; + case MapInfo.TupleType of + ttBlackAndWhite, ttGrayScale: Result := MapInfo.Depth = 1; + ttBlackAndWhiteAlpha, ttGrayScaleAlpha: Result := MapInfo.Depth = 2; + ttRGB: Result := MapInfo.Depth = 3; + ttRGBAlpha: Result := MapInfo.Depth = 4; end; end; end; @@ -388,24 +417,24 @@ begin // Try to parse file header if not ParseHeader then Exit; // Select appropriate data format based on values read from file header - case FMapInfo.TupleType of + case MapInfo.TupleType of ttBlackAndWhite: Format := ifGray8; ttBlackAndWhiteAlpha: Format := ifA8Gray8; - ttGrayScale: Format := IffFormat(FMapInfo.BitCount = 8, ifGray8, ifGray16); - ttGrayScaleAlpha: Format := IffFormat(FMapInfo.BitCount = 8, ifA8Gray8, ifA16Gray16); - ttRGB: Format := IffFormat(FMapInfo.BitCount = 8, ifR8G8B8, ifR16G16B16); - ttRGBAlpha: Format := IffFormat(FMapInfo.BitCount = 8, ifA8R8G8B8, ifA16R16G16B16); + ttGrayScale: Format := IffFormat(MapInfo.BitCount = 8, ifGray8, ifGray16); + ttGrayScaleAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8Gray8, ifA16Gray16); + ttRGB: Format := IffFormat(MapInfo.BitCount = 8, ifR8G8B8, ifR16G16B16); + ttRGBAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8R8G8B8, ifA16R16G16B16); ttGrayScaleFP: Format := ifR32F; ttRGBFP: Format := ifA32B32G32R32F; end; // Exit if no matching data format was found if Format = ifUnknown then Exit; - NewImage(FMapInfo.Width, FMapInfo.Height, Format, Images[0]); + NewImage(MapInfo.Width, MapInfo.Height, Format, Images[0]); Info := GetFormatInfo(Format); // Now read pixels from file to dest image - if not FMapInfo.Binary then + if not MapInfo.Binary then begin Dest := Bits; for I := 0 to Width * Height - 1 do @@ -414,7 +443,7 @@ begin ifGray8: begin Dest^ := ReadIntValue; - if FMapInfo.BitCount = 1 then + if MapInfo.BitCount = 1 then // If source is 1bit mono image (where 0=white, 1=black) // we must scale it to 8bits Dest^ := 255 - Dest^ * 255; @@ -440,9 +469,9 @@ begin end else begin - if FMapInfo.BitCount > 1 then + if MapInfo.BitCount > 1 then begin - if not (FMapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then + if not (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then begin // Just copy bytes from binary Portable Maps (non 1bit, non FP) Read(Handle, Bits, Size); @@ -455,48 +484,43 @@ begin // I will stick with Photoshops behaviour here for I := 0 to Width * Height - 1 do begin - Read(Handle, @PixelFP, FMapInfo.BitCount shr 3); - if FMapInfo.TupleType = ttRGBFP then + Read(Handle, @PixelFP, MapInfo.BitCount div 8); + if MapInfo.TupleType = ttRGBFP then with PColorFPRec(Dest)^ do begin A := 1.0; R := PixelFP.R; G := PixelFP.G; B := PixelFP.B; - if FMapInfo.IsBigEndian then + if MapInfo.IsBigEndian then SwapEndianLongWord(PLongWord(Dest), 3); end else begin PSingle(Dest)^ := PixelFP.B; - if FMapInfo.IsBigEndian then + if MapInfo.IsBigEndian then SwapEndianLongWord(PLongWord(Dest), 1); end; Inc(Dest, Info.BytesPerPixel); end; end; - if FMapInfo.TupleType in [ttBlackAndWhite, ttBlackAndWhiteAlpha] then + if MapInfo.TupleType in [ttBlackAndWhite, ttBlackAndWhiteAlpha] then begin // Black and white PAM files must be scaled to 8bits. Note that // in PAM files 1=white, 0=black (reverse of PBM) - for I := 0 to Width * Height * Iff(FMapInfo.TupleType = ttBlackAndWhiteAlpha, 2, 1) - 1 do + for I := 0 to Width * Height * Iff(MapInfo.TupleType = ttBlackAndWhiteAlpha, 2, 1) - 1 do PByteArray(Bits)[I] := PByteArray(Bits)[I] * 255; - end; - if FMapInfo.TupleType in [ttRGB, ttRGBAlpha] then + end + else if MapInfo.TupleType in [ttRGB, ttRGBAlpha] then begin // Swap channels of RGB/ARGB images. Binary RGB image files use BGR order. SwapChannels(Images[0], ChannelBlue, ChannelRed); end; - if FMapInfo.BitCount = 16 then - begin - Dest := Bits; - for I := 0 to Width * Height * Info.BytesPerPixel div SizeOf(Word) - 1 do - begin - PWord(Dest)^ := SwapEndianWord(PWord(Dest)^); - Inc(Dest, SizeOf(Word)); - end; - end; + + // Swap byte order if needed + if (MapInfo.BitCount = 16) and MapInfo.IsBigEndian then + SwapEndianWord(Bits, Width * Height * Info.BytesPerPixel div SizeOf(Word)); end else begin @@ -520,19 +544,19 @@ begin FixInputPos; - if (FMapInfo.MaxVal <> Pow2Int(FMapInfo.BitCount) - 1) and - (FMapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha, ttRGB, ttRGBAlpha]) then + if (MapInfo.MaxVal <> Pow2Int(MapInfo.BitCount) - 1) and + (MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha, ttRGB, ttRGBAlpha]) then begin Dest := Bits; // Scale color values according to MaxVal we got from header // if necessary. - for I := 0 to Width * Height * Info.BytesPerPixel div (FMapInfo.BitCount shr 3) - 1 do + for I := 0 to Width * Height * Info.BytesPerPixel div (MapInfo.BitCount shr 3) - 1 do begin - if FMapInfo.BitCount = 8 then - Dest^ := Dest^ * 255 div FMapInfo.MaxVal + if MapInfo.BitCount = 8 then + Dest^ := Dest^ * 255 div MapInfo.MaxVal else - PWord(Dest)^ := PWord(Dest)^ * 65535 div FMapInfo.MaxVal; - Inc(Dest, FMapInfo.BitCount shr 3); + PWord(Dest)^ := PWord(Dest)^ * 65535 div MapInfo.MaxVal; + Inc(Dest, MapInfo.BitCount shr 3); end; end; @@ -540,9 +564,12 @@ begin end; end; -function TPortableMapFileFormat.SaveData(Handle: TImagingHandle; - const Images: TDynImageDataArray; Index: Integer): Boolean; +function TPortableMapFileFormat.SaveDataInternal(Handle: TImagingHandle; + const Images: TDynImageDataArray; Index: Integer; var MapInfo: TPortableMapInfo): Boolean; const + // Use Unix linebreak, for many viewers/editors it means that + // 16bit samples are stored as big endian - so we need to swap byte order + // before saving LineDelimiter = #10; PixelDelimiter = #32; var @@ -567,14 +594,14 @@ var var OldSeparator: Char; begin - WriteString('P' + FMapInfo.FormatId); - if not FMapInfo.HasPAMHeader then + WriteString('P' + MapInfo.FormatId); + if not MapInfo.HasPAMHeader then begin // Write header of PGM, PPM, and PFM files WriteString(IntToStr(ImageToSave.Width)); WriteString(IntToStr(ImageToSave.Height)); - case FMapInfo.TupleType of - ttGrayScale, ttRGB: WriteString(IntToStr(Pow2Int(FMapInfo.BitCount) - 1)); + case MapInfo.TupleType of + ttGrayScale, ttRGB: WriteString(IntToStr(Pow2Int(MapInfo.BitCount) - 1)); ttGrayScaleFP, ttRGBFP: begin OldSeparator := DecimalSeparator; @@ -590,9 +617,9 @@ var // Write PAM file header WriteString(Format('%s %d', [SPAMWidth, ImageToSave.Width])); WriteString(Format('%s %d', [SPAMHeight, ImageToSave.Height])); - WriteString(Format('%s %d', [SPAMDepth, FMapInfo.Depth])); - WriteString(Format('%s %d', [SPAMMaxVal, Pow2Int(FMapInfo.BitCount) - 1])); - WriteString(Format('%s %s', [SPAMTupleType, TupleTypeNames[FMapInfo.TupleType]])); + WriteString(Format('%s %d', [SPAMDepth, MapInfo.Depth])); + WriteString(Format('%s %d', [SPAMMaxVal, Pow2Int(MapInfo.BitCount) - 1])); + WriteString(Format('%s %s', [SPAMTupleType, TupleTypeNames[MapInfo.TupleType]])); WriteString(SPAMEndHdr); end; end; @@ -605,29 +632,29 @@ begin Info := GetFormatInfo(Format); // Fill values of MapInfo record that were not filled by // descendants in their SaveData methods - FMapInfo.BitCount := (Info.BytesPerPixel div Info.ChannelCount) * 8; - FMapInfo.Depth := Info.ChannelCount; - if FMapInfo.TupleType = ttInvalid then + MapInfo.BitCount := (Info.BytesPerPixel div Info.ChannelCount) * 8; + MapInfo.Depth := Info.ChannelCount; + if MapInfo.TupleType = ttInvalid then begin if Info.HasGrayChannel then begin if Info.HasAlphaChannel then - FMapInfo.TupleType := ttGrayScaleAlpha + MapInfo.TupleType := ttGrayScaleAlpha else - FMapInfo.TupleType := ttGrayScale; + MapInfo.TupleType := ttGrayScale; end else begin if Info.HasAlphaChannel then - FMapInfo.TupleType := ttRGBAlpha + MapInfo.TupleType := ttRGBAlpha else - FMapInfo.TupleType := ttRGB; + MapInfo.TupleType := ttRGB; end; end; // Write file header WriteHeader; - if not FMapInfo.Binary then + if not MapInfo.Binary then begin Src := Bits; LineLength := 0; @@ -644,7 +671,7 @@ begin with PColor48Rec(Src)^ do WriteString(SysUtils.Format('%d %d %d', [R, G, B]), PixelDelimiter); end; - // Lines in text PNM images should have length <70 + // Lines in text PNM images should have length <70 if LineLength > 65 then begin LineLength := 0; @@ -656,12 +683,12 @@ begin else begin // Write binary images - if not (FMapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then + if not (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then begin // Save integer binary images - if FMapInfo.BitCount = 8 then + if MapInfo.BitCount = 8 then begin - if FMapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then + if MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then begin // 8bit grayscale images can be written in one Write call Write(Handle, Bits, Size); @@ -674,7 +701,7 @@ begin for I := 0 to Width * Height - 1 do with PColor32Rec(Src)^ do begin - if FMapInfo.TupleType = ttRGBAlpha then + if MapInfo.TupleType = ttRGBAlpha then Pixel32.A := A; Pixel32.R := B; Pixel32.G := G; @@ -688,7 +715,7 @@ begin begin // Images with 16bit channels: make sure that channel values are saved in big endian Src := Bits; - if FMapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then + if MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then begin // 16bit grayscale image for I := 0 to Width * Height * Info.BytesPerPixel div SizeOf(Word) - 1 do @@ -704,7 +731,7 @@ begin for I := 0 to Width * Height - 1 do with PColor64Rec(Src)^ do begin - if FMapInfo.TupleType = ttRGBAlpha then + if MapInfo.TupleType = ttRGBAlpha then Pixel64.A := SwapEndianWord(A); Pixel64.R := SwapEndianWord(B); Pixel64.G := SwapEndianWord(G); @@ -713,13 +740,13 @@ begin Inc(Src, Info.BytesPerPixel); end; end; - end; + end; end else begin // Floating point images (no need to swap endian here - little // endian is specified in file header) - if FMapInfo.TupleType = ttGrayScaleFP then + if MapInfo.TupleType = ttGrayScaleFP then begin // Grayscale images can be written in one Write call Write(Handle, Bits, Size); @@ -787,11 +814,13 @@ end; function TPGMFileFormat.SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; Index: Integer): Boolean; +var + MapInfo: TPortableMapInfo; begin - FillChar(FMapInfo, SizeOf(FMapInfo), 0); - FMapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], FIdNumbers[0]); - FMapInfo.Binary := FSaveBinary; - Result := inherited SaveData(Handle, Images, Index); + FillChar(MapInfo, SizeOf(MapInfo), 0); + MapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], FIdNumbers[0]); + MapInfo.Binary := FSaveBinary; + Result := SaveDataInternal(Handle, Images, Index, MapInfo); end; procedure TPGMFileFormat.ConvertToSupported(var Image: TImageData; @@ -831,11 +860,13 @@ end; function TPPMFileFormat.SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; Index: Integer): Boolean; +var + MapInfo: TPortableMapInfo; begin - FillChar(FMapInfo, SizeOf(FMapInfo), 0); - FMapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], FIdNumbers[0]); - FMapInfo.Binary := FSaveBinary; - Result := inherited SaveData(Handle, Images, Index); + FillChar(MapInfo, SizeOf(MapInfo), 0); + MapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], FIdNumbers[0]); + MapInfo.Binary := FSaveBinary; + Result := SaveDataInternal(Handle, Images, Index, MapInfo); end; procedure TPPMFileFormat.ConvertToSupported(var Image: TImageData; @@ -873,12 +904,14 @@ end; function TPAMFileFormat.SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; Index: Integer): Boolean; +var + MapInfo: TPortableMapInfo; begin - FillChar(FMapInfo, SizeOf(FMapInfo), 0); - FMapInfo.FormatId := FIdNumbers[0]; - FMapInfo.Binary := True; - FMapInfo.HasPAMHeader := True; - Result := inherited SaveData(Handle, Images, Index); + FillChar(MapInfo, SizeOf(MapInfo), 0); + MapInfo.FormatId := FIdNumbers[0]; + MapInfo.Binary := True; + MapInfo.HasPAMHeader := True; + Result := SaveDataInternal(Handle, Images, Index, MapInfo); end; procedure TPAMFileFormat.ConvertToSupported(var Image: TImageData; @@ -915,16 +948,17 @@ function TPFMFileFormat.SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; Index: Integer): Boolean; var Info: TImageFormatInfo; + MapInfo: TPortableMapInfo; begin - FillChar(FMapInfo, SizeOf(FMapInfo), 0); + FillChar(MapInfo, SizeOf(MapInfo), 0); Info := GetFormatInfo(Images[Index].Format); if (Info.ChannelCount > 1) or Info.IsIndexed then - FMapInfo.TupleType := ttRGBFP + MapInfo.TupleType := ttRGBFP else - FMapInfo.TupleType := ttGrayScaleFP; - FMapInfo.FormatId := Iff(FMapInfo.TupleType = ttGrayScaleFP, FIdNumbers[1], FIdNumbers[0]); - FMapInfo.Binary := True; - Result := inherited SaveData(Handle, Images, Index); + MapInfo.TupleType := ttGrayScaleFP; + MapInfo.FormatId := Iff(MapInfo.TupleType = ttGrayScaleFP, FIdNumbers[1], FIdNumbers[0]); + MapInfo.Binary := True; + Result := SaveDataInternal(Handle, Images, Index, MapInfo); end; procedure TPFMFileFormat.ConvertToSupported(var Image: TImageData; @@ -949,6 +983,10 @@ initialization -- TODOS ---------------------------------------------------- - nothing now + -- 0.24.3 Changes/Bug Fixes ----------------------------------- + - Improved compatibility of 16bit/component image loading. + - Changes for better thread safety. + -- 0.21 Changes/Bug Fixes ----------------------------------- - Made modifications to ASCII PNM loading to be more "stream-safe". - Fixed bug: indexed images saved as grayscale in PFM. diff --git a/Imaging/ImagingTypes.pas b/Imaging/ImagingTypes.pas index 36c2541..31f6c07 100644 --- a/Imaging/ImagingTypes.pas +++ b/Imaging/ImagingTypes.pas @@ -1,5 +1,5 @@ { - $Id: ImagingTypes.pas 112 2007-12-11 19:43:15Z galfar $ + $Id: ImagingTypes.pas 132 2008-08-27 20:37:38Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -37,9 +37,9 @@ const { Current Major version of Imaging.} ImagingVersionMajor = 0; { Current Minor version of Imaging.} - ImagingVersionMinor = 24; + ImagingVersionMinor = 26; { Current patch of Imaging.} - ImagingVersionPatch = 2; + ImagingVersionPatch = 0; { Imaging Option Ids whose values can be set/get by SetOption/ GetOption functions.} @@ -137,6 +137,11 @@ const Allowed values are 0 (store as text - very! large files) and 1 (save binary). Default value is 1.} ImagingPPMSaveBinary = 51; + { Boolean option that specifies whether GIF images with more frames + are animated by Imaging (according to frame disposal methods) or just + raw frames are loaded and sent to user (if you want to animate GIF yourself). + Default value is 1.} + ImagingGIFLoadAnimated = 56; { This option is used when reducing number of colors used in @@ -225,7 +230,9 @@ type ifDXT1 = 220, ifDXT3 = 221, ifDXT5 = 222, - ifBTC = 223); + ifBTC = 223, + ifATI1N = 224, + ifATI2N = 225); { Color value for 32 bit images.} TColor32 = LongWord; @@ -439,11 +446,9 @@ implementation -- TODOS ---------------------------------------------------- - add lookup tables to pixel formats for fast conversions - - change TImageFormatInfo - add new fields that shoudl replace old chaos - like not knowing whether it is RGB without checking all other fields for False - (add something like FormatType = (ftIndexed, ftRGB, ftIntensity, ftCompressed, - ftFloatingPoint, ftRGBBitFields) and additional infos like HasAlphaChannel, - ChannelSize, ChannelCount, ...) + + -- 0.24.3 Changes/Bug Fixes --------------------------------- + - Added ifATI1N and ifATI2N image data formats. -- 0.23 Changes/Bug Fixes ----------------------------------- - Added ifBTC image format and SpecialNearestFormat field diff --git a/Imaging/ImagingUtility.pas b/Imaging/ImagingUtility.pas index ca3a186..ace59c6 100644 --- a/Imaging/ImagingUtility.pas +++ b/Imaging/ImagingUtility.pas @@ -1,5 +1,5 @@ { - $Id: ImagingUtility.pas 86 2007-06-12 22:39:08Z galfar $ + $Id: ImagingUtility.pas 128 2008-07-23 11:57:36Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -56,6 +56,9 @@ type TBooleanArray = array[0..MaxInt - 1] of Boolean; PBooleanArray = ^TBooleanArray; + TDynIntegerArray = array of Integer; + TDynBooleanArray = array of Boolean; + TWordRec = packed record case Integer of 0: (WordValue: Word); @@ -119,8 +122,10 @@ procedure FreeMemNil(var P); {$IFDEF USE_INLINE}inline;{$ENDIF} procedure FreeMem(P: Pointer); {$IFDEF USE_INLINE}inline;{$ENDIF} { Returns current exception object. Do not call outside exception handler.} function GetExceptObject: Exception; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Returns time value with microsecond resolution. Use for some time counters.} +{ Returns time value with microsecond resolution.} function GetTimeMicroseconds: Int64; +{ Returns time value with milisecond resolution.} +function GetTimeMilliseconds: Int64; { Returns file extension (without "." dot)} function GetFileExt(const FileName: string): string; @@ -128,7 +133,7 @@ function GetFileExt(const FileName: string): string; function GetAppExe: string; { Returns directory where application's exceutable is located without path delimiter at the end.} -function GetAppDir:string; +function GetAppDir: string; { Returns True if FileName matches given Mask with optional case sensitivity. Mask can contain ? and * special characters: ? matches one character, * matches zero or more characters.} @@ -151,6 +156,10 @@ function PosNoCase(const SubStr, S: string; Offset: LongInt = 1): LongInt; {$IFD function StrToken(var S: string; Sep: Char): string; { Same as StrToken but searches from the end of S string.} function StrTokenEnd(var S: string; Sep: Char): string; +{ Returns string representation of integer number (with digit grouping).} +function IntToStrFmt(const I: Int64): string; +{ Returns string representation of float number (with digit grouping).} +function FloatToStrFmt(const F: Double; Precision: Integer = 2): string; { Clamps integer value to range } function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} @@ -235,6 +244,7 @@ procedure SwapEndianWord(P: PWordArray; Count: LongInt); overload; function SwapEndianLongWord(Value: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} { Swaps byte order of multiple LongWord values.} procedure SwapEndianLongWord(P: PLongWord; Count: LongInt); overload; + { Calculates CRC32 for the given data.} procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt); { Fills given memory with given Byte value. Size is size of buffer in bytes.} @@ -385,6 +395,11 @@ asm end; {$ENDIF} +function GetTimeMilliseconds: Int64; +begin + Result := GetTimeMicroseconds div 1000; +end; + function GetFileExt(const FileName: string): string; begin Result := ExtractFileExt(FileName); @@ -418,7 +433,7 @@ begin {$ENDIF} end; -function GetAppDir:string; +function GetAppDir: string; begin Result := ExtractFileDir(GetAppExe); end; @@ -760,6 +775,16 @@ begin end; end; +function IntToStrFmt(const I: Int64): string; +begin + Result := Format('%.0n', [I * 1.0]); +end; + +function FloatToStrFmt(const F: Double; Precision: Integer): string; +begin + Result := Format('%.' + IntToStr(Precision) + 'n', [F]); +end; + function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; begin Result := Number; @@ -1371,8 +1396,7 @@ procedure ClipCopyBounds(var SrcX, SrcY, Width, Height, DstX, DstY: LongInt; Src begin Diff := DstClipMin - DstPos; Size := Size - Diff; - if DstPos < SrcPos then - SrcPos := SrcPos + Diff; + SrcPos := SrcPos + Diff; DstPos := DstClipMin; end; if SrcPos < 0 then @@ -1528,6 +1552,13 @@ initialization -- TODOS ---------------------------------------------------- - nothing now + -- 0.25.0 Changes/Bug Fixes ----------------------------------- + - Fixed error in ClipCopyBounds which was causing ... bad clipping! + + -- 0.24.3 Changes/Bug Fixes ----------------------------------- + - Added GetTimeMilliseconds function. + - Added IntToStrFmt and FloatToStrFmt helper functions. + -- 0.23 Changes/Bug Fixes ----------------------------------- - Added RectInRect and RectIntersects functions - Added some string utils: StrToken, StrTokenEnd, PosEx, PosNoCase. diff --git a/Tools/cedserver_config_2_3/cedserver_config_2_3.lpi b/Tools/cedserver_config_2_3/cedserver_config_2_3.lpi new file mode 100644 index 0000000..17eb7be --- /dev/null +++ b/Tools/cedserver_config_2_3/cedserver_config_2_3.lpi @@ -0,0 +1,76 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +