aksdb
/
CentrED
1
0
Fork 0
Code Issues 2 Pull Requests Releases Wiki Activity
CentrED/Client/ULandscape.pas

1870 lines
51 KiB
Plaintext
Raw Permalink Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

(*
* 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 2009 Andreas Schneider
*)
unit ULandscape;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes, math, matrix, LCLIntf, GL, GLu, ImagingOpenGL, Imaging,
ImagingClasses, ImagingTypes, ImagingUtility, DOM, XMLRead,
UGenericIndex, UMap, UStatics, UArt, UTexture, UTiledata, UHue, UWorldItem,
UMulBlock, UAnimData, UfrmInitialize,
UEnhancedMemoryStream, UGLFont,
UCacheManager;
type
TGlVector3f = array[0..2] of GLfloat;
PNormals = ^TNormals;
TNormals = array[0..3] of TGlVector3f;
PRadarBlock = ^TRadarBlock;
TRadarBlock = array[0..7, 0..7] of Word;
{ TMaterial }
TMaterial = class(ICacheable)
constructor Create;
destructor Destroy; override;
protected
FRefCount: Integer;
FWidth: Integer;
FHeight: Integer;
FRealWidth: Integer;
FRealHeight: Integer;
FGraphic: TMultiImage;
class procedure CalculateTextureDimensions(ACaps: TGLTextureCaps; ARealWidth,
ARealHeight: Integer; out AWidth, AHeight: Integer);
function GenerateTexture(AImage: TBaseImage): TGLuint;
function GetTexture: GLuint; virtual; abstract;
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 GetTexture;
procedure AddRef;
procedure DelRef;
function HitTest(AX, AY: Integer): Boolean;
function HitTest(AX, AY: Integer; Zoom: Single): Boolean;
{ICacheable}
function CanBeRemoved: Boolean;
procedure RemoveFromCache;
end;
{ TSimpleMaterial }
TSimpleMaterial = class(TMaterial)
constructor Create(AGraphic: TBaseImage);
destructor Destroy; override;
protected
FTexture: TGLuint;
function GetTexture: GLuint; override;
end;
{ TAnimMaterial }
TAnimMaterial = class(TMaterial)
constructor Create(ABaseID: LongWord; AAnimData: TAnimData; AHue: THue = nil;
APartialHue: Boolean = False);
destructor Destroy; override;
protected
FActiveFrame: Byte;
FNextChange: DWord;
FAnimData: TAnimData;
FTextures: array of TGLuint;
function GetTexture: GLuint; override;
end;
TMaterialCache = specialize TCacheManager<TMaterial>;
{ TLandTextureManager }
TLandTextureManager = class
constructor Create;
destructor Destroy; override;
protected
FArtCache: TMaterialCache;
FTexCache: TMaterialCache;
FAnimCache: TMaterialCache;
FUseAnims: Boolean;
public
property UseAnims: Boolean read FUseAnims write FUseAnims;
function GetArtMaterial(ATileID: LongWord): TMaterial; overload;
function GetArtMaterial(ATileID: LongWord; AHue: THue;
APartialHue: Boolean): TMaterial; overload;
function GetStaticMaterial(AStaticItem: TStaticItem;
AOverrideHue: Integer = -1): TMaterial;
function GetTexMaterial(ATileID: LongWord): TMaterial;
end;
{ TSeperatedStaticBlock }
TSeperatedStaticBlock = class(TStaticBlock)
constructor Create(AData: TStream; AIndex: TGenericIndex; AX, AY: Word); overload;
constructor Create(AData: TStream; AIndex: TGenericIndex); overload;
destructor Destroy; override;
public
Cells: array[0..63] of TStaticItemList;
{ Methods }
function Clone: TSeperatedStaticBlock; override;
function GetSize: Integer; override;
procedure RebuildList;
end;
TLandscape = class;
{ TBlock }
TBlock = class
constructor Create(AMap: TMapBlock; AStatics: TStaticBlock);
destructor Destroy; override;
protected
{ Fields }
FMapBlock: TMapBlock;
FStaticBlock: TStaticBlock;
public
{ Fields }
property Map: TMapBlock read FMapBlock;
property Static: TStaticBlock read FStaticBlock;
{ Methods }
procedure UpdateBlockAcess(ALandscape: TLandscape);
end;
TLandscapeChangeEvent = procedure of object;
TMapChangedEvent = procedure(AMapCell: TMapCell) of object;
TNewBlockEvent = procedure(ABlock: TBlock) of object;
TStaticChangedEvent = procedure(AStaticItem: TStaticItem) of object;
TScreenBuffer = class;
TBlockCache = specialize TCacheManager<TBlock>;
{ TLandscape }
TLandscape = class
constructor Create(AWidth, AHeight: Word);
destructor Destroy; override;
protected
{ Members }
FWidth: Word;
FHeight: Word;
FCellWidth: Word;
FCellHeight: Word;
FBlockCache: TBlockCache;
FBlockCacheBak: TBlockCache;
FOnChange: TLandscapeChangeEvent;
FOnMapChanged: TMapChangedEvent;
FOnNewBlock: TNewBlockEvent;
FOnStaticInserted: TStaticChangedEvent;
FOnStaticDeleted: TStaticChangedEvent;
FOnStaticElevated: TStaticChangedEvent;
FOnStaticHued: TStaticChangedEvent;
FOpenRequests: TBits;
FWriteMap: TBits;
FDrawMap: TBits;
FMaxStaticID: Cardinal;
BlockCacheSize: Integer;
{ Methods }
function GetMapBlock(AX, AY: Word): TMapBlock;
function GetMapCell(AX, AY: Integer): TMapCell;
function GetNormals(AX, AY: Integer): TNormals;
function GetStaticBlock(AX, AY: Word): TSeperatedStaticBlock;
function GetStaticList(AX, AY: Word): TStaticItemList;
{ Events }
procedure OnRemoveCachedObject(ABlock: TBlock);
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
{ Fields }
property Width: Word read FWidth;
property Height: Word read FHeight;
property CellWidth: Word read FCellWidth;
property CellHeight: Word read FCellHeight;
property MapCell[X, Y: Integer]: TMapCell read GetMapCell;
property StaticList[X, Y: Word]: TStaticItemList read GetStaticList;
property Normals[X, Y: Integer]: TNormals read GetNormals;
property MaxStaticID: Cardinal read FMaxStaticID;
property OnChange: TLandscapeChangeEvent read FOnChange write FOnChange;
property OnMapChanged: TMapChangedEvent read FOnMapChanged write FOnMapChanged;
property OnNewBlock: TNewBlockEvent read FOnNewBlock write FOnNewBlock;
property OnStaticInserted: TStaticChangedEvent read FOnStaticInserted
write FOnStaticInserted;
property OnStaticDeleted: TStaticChangedEvent read FOnStaticDeleted
write FOnStaticDeleted;
property OnStaticElevated: TStaticChangedEvent read FOnStaticElevated
write FOnStaticElevated;
property OnStaticHued: TStaticChangedEvent read FOnStaticHued
write FOnStaticHued;
{ Methods }
function CanWrite(AX, AY: Word): Boolean;
procedure FillDrawList(ADrawList: TScreenBuffer; AX, AY, AWidth, AHeight: Word;
AMap, AStatics, ATDWalls, ATDBridges, ATDRoofs, ATDSurfaces, ATDFoliage, ATDWet: Boolean;
ANoDraw: Boolean; AAdditionalTiles: TWorldItemList = nil);
function GetEffectiveAltitude(ATile: TMapCell): ShortInt;
function GetLandAlt(AX, AY: Word; ADefault: ShortInt): ShortInt;
procedure GetNormals(AX, AY: Word; var ANormals: TNormals);
procedure LoadNoDrawMap(AFileName: String);
procedure MoveStatic(AStatic: TStaticItem; AX, AY: Word);
procedure PrepareBlocks(AX1, AY1, AX2, AY2: Word);
procedure UpdateBlockAccess;
procedure UpdateWriteMap(AStream: TEnhancedMemoryStream);
procedure ResizeBlockCache(Count: Integer);
end;
{ TGLText }
TGLText = class
constructor Create(AFont: TGLFont; AText: String);
protected
FFont: TGLFont;
FText: String;
FWidth: Integer;
FHeight: Integer;
public
procedure Render(AScreenRect: TRect);
end;
TScreenState = (ssNormal, ssFiltered, ssGhost);
TWalkRestriction = (wrNone, wrCanWalk, wrCannotWalk);
PBlockInfo = ^TBlockInfo;
TBlockInfo = record
ScreenRect: TRect;
DrawQuad: array[0..3,0..1] of TGLint;
RealQuad: array[0..3,0..1] of TGLint;
LineWidth: array[0..2] of GLfloat;
LineDraw: array[0..2,0..1,0..1] of TGLint;
Item: TWorldItem;
HighRes: TMaterial;
LowRes: TMaterial;
Normals: PNormals;
State: TScreenState;
Highlighted: Boolean;
HueOverride: Boolean;
Hue: Word;
CheckRealQuad: Boolean;
Translucent: Boolean;
WalkRestriction: TWalkRestriction;
Text: TGLText;
Next: PBlockInfo;
end;
{ TScreenBuffer }
TScreenBuffer = class
constructor Create; virtual;
destructor Destroy; override;
protected
{ Members }
FCount: Cardinal;
FShortCuts: array[-1..10] of PBlockInfo; //-1 = last, 0 = first, 1..10 = other shortcuts
FShortCutsValid: Boolean;
FSerial: Cardinal;
public
{ Methods }
function Add(AItem: TWorldItem): PBlockInfo;
procedure Clear;
procedure Delete(AItem: TWorldItem);
function Find(AScreenPosition: TPoint; Zoom: Single): PBlockInfo;
function Find(AX, AY: Word): PBlockInfo;
function GetSerial: Cardinal;
function Insert(AItem: TWorldItem): PBlockInfo;
function Iterate(var ABlockInfo: PBlockInfo): Boolean;
procedure UpdateShortcuts;
function UpdateSortOrder(AItem: TWorldItem): PBlockInfo;
{ Events }
procedure OnTileRemoved(ATile: TMulBlock);
end;
TStaticInfo = packed record
X: Word;
Y: Word;
Z: ShortInt;
TileID: Word;
Hue: Word;
end;
implementation
uses
UGameResources, UdmNetwork, UPackets, UPacketHandlers, Logging;
function GetID(AX, AY: Word): Integer; inline;
begin
Result := (AX shl 16) or AY;
end;
operator := (AVector: Tvector3_single) GLVector: TGlVector3f;
begin
GLVector[0] := AVector.data[0];
GLVector[1] := AVector.data[1];
GLVector[2] := AVector.data[2];
end;
{ TLandTextureManager }
constructor TLandTextureManager.Create;
begin
inherited Create;
FArtCache := TMaterialCache.Create(1024);
FTexCache := TMaterialCache.Create(128);
FAnimCache := TMaterialCache.Create(128);
FUseAnims := True;
end;
destructor TLandTextureManager.Destroy;
begin
FreeAndNil(FArtCache);
FreeAndNil(FTexCache);
FreeAndNil(FAnimCache);
inherited Destroy;
end;
function TLandTextureManager.GetArtMaterial(ATileID: LongWord): TMaterial;
var
artEntry: TArt;
animData: TAnimData;
begin
Result := nil;
if FUseAnims and (ATileID >= $4000) and (tdfAnimation in
ResMan.Tiledata.StaticTiles[ATileID - $4000].Flags) then
begin
animData := ResMan.Animdata.AnimData[ATileID - $4000];
if (animData.FrameCount > 0) and not FAnimCache.QueryID(ATileID, Result) then
begin
Result := TAnimMaterial.Create(ATileID, animData);
FAnimCache.StoreID(ATileID, Result);
end;
end;
if (Result = nil) and not FArtCache.QueryID(ATileID, Result) then
begin
artEntry := TArt(ResMan.Art.Block[ATileID]);
Result := TSimpleMaterial.Create(artEntry.Graphic);
FArtCache.StoreID(ATileID, Result);
artEntry.Free;
end;
Result.AddRef;
end;
function TLandTextureManager.GetArtMaterial(ATileID: LongWord; AHue: THue;
APartialHue: Boolean): TMaterial;
var
artEntry: TArt;
animData: TAnimData;
id: Integer;
begin
if AHue = nil then
begin
Result := GetArtMaterial(ATileID);
end else
begin
Result := nil;
id := ATileID or (((AHue.ID + 1) and $3FFF) shl 16) or (Byte(APartialHue) shl 30);
if FUseAnims and (ATileID >= $4000) and (tdfAnimation in
ResMan.Tiledata.StaticTiles[ATileID - $4000].Flags) then
begin
animData := ResMan.Animdata.AnimData[ATileID - $4000];
if (animData.FrameCount > 0) and not FAnimCache.QueryID(id, Result) then
begin
Result := TAnimMaterial.Create(ATileID, animData, AHue, APartialHue);
FAnimCache.StoreID(id, Result);
end;
end;
if (Result = nil) and not FArtCache.QueryID(id, Result) then
begin
artEntry := ResMan.Art.GetArt(ATileID, 0, AHue, APartialHue);
Result := TSimpleMaterial.Create(artEntry.Graphic);
FArtCache.StoreID(id, Result);
artEntry.Free;
end;
Result.AddRef;
end;
end;
function TLandTextureManager.GetStaticMaterial(AStaticItem: TStaticItem;
AOverrideHue: Integer = -1): TMaterial;
var
staticTiledata: TStaticTiledata;
hue: THue;
begin
staticTiledata := ResMan.Tiledata.StaticTiles[AStaticItem.TileID];
if AOverrideHue < 0 then
AOverrideHue := AStaticItem.Hue;
if AOverrideHue > 0 then
hue := ResMan.Hue.Hues[AOverrideHue - 1]
else
hue := nil;
Result := GetArtMaterial($4000 + AStaticItem.TileID, hue,
tdfPartialHue in staticTiledata.Flags);
end;
function TLandTextureManager.GetTexMaterial(ATileID: LongWord): TMaterial;
var
texEntry: TTexture;
texID: Integer;
begin
if not FTexCache.QueryID(ATileID, Result) then
begin
texID := ResMan.Tiledata.LandTiles[ATileID].TextureID;
if texID > 0 then
begin
texEntry := TTexture(ResMan.Texmaps.Block[texID]);
Result := TSimpleMaterial.Create(texEntry.Graphic);
FTexCache.StoreID(ATileID, Result);
texEntry.Free;
end else
Result := nil;
end;
if Result <> nil then
Result.AddRef;
end;
{ TSeperatedStaticBlock }
constructor TSeperatedStaticBlock.Create(AData: TStream; AIndex: TGenericIndex;
AX, AY: Word);
var
i, ts: Integer;
item: TStaticItem;
block: TMemoryStream;
begin
inherited Create;
FItems := TStaticItemList.Create(False);
FX := AX;
FY := AY;
for i := 0 to 63 do
Cells[i] := TStaticItemList.Create;
if not UseStaticsOldFormat
then ts := 7
else ts := 11;
if (AData <> nil) and (AIndex.Lookup > 0) and (AIndex.Size > 0) then
begin
AData.Position := AIndex.Lookup;
block := TMemoryStream.Create;
block.CopyFrom(AData, AIndex.Size);
block.Position := 0;
for i := 1 to (AIndex.Size div ts) do
begin
item := TStaticItem.Create(Self, block, AX, AY);
Cells[(item.Y mod 8) * 8 + (item.X mod 8)].Add(item);
end;
block.Free;
end;
end;
constructor TSeperatedStaticBlock.Create(AData: TStream; AIndex: TGenericIndex);
begin
Create(AData, AIndex, 0, 0);
end;
destructor TSeperatedStaticBlock.Destroy;
var
i: Integer;
begin
FreeAndNil(FItems);
for i := 0 to 63 do
begin
if Cells[i] <> nil then
FreeAndNil(Cells[i]);
end;
inherited Destroy;
end;
function TSeperatedStaticBlock.Clone: TSeperatedStaticBlock;
begin
raise Exception.Create('TSeperatedStaticBlock.Clone is not implemented (yet).');
Result := nil;
end;
function TSeperatedStaticBlock.GetSize: Integer;
begin
RebuildList;
Result := inherited GetSize;
end;
procedure TSeperatedStaticBlock.RebuildList;
var
i, j, solver: Integer;
begin
FItems.Clear;
solver := 0;
for i := 0 to 63 do
begin
if Cells[i] <> nil then
begin
for j := 0 to Cells[i].Count - 1 do
begin
FItems.Add(Cells[i].Items[j]);
TStaticItem(Cells[i].Items[j]).UpdatePriorities(
ResMan.Tiledata.StaticTiles[TStaticItem(Cells[i].Items[j]).TileID],
solver);
Inc(solver);
end;
end;
end;
Sort;
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;
procedure TBlock.UpdateBlockAcess(ALandscape: TLandscape);
var
staticItem: TStaticItem;
i: Integer;
begin
for i := Low(FMapBlock.Cells) to High(FMapBlock.Cells) do
begin
FMapBlock.Cells[i].CanBeEdited := ALandscape.CanWrite(FMapBlock.Cells[i].X,
FMapBlock.Cells[i].Y);
end;
if FStaticBlock is TSeperatedStaticBlock then
TSeperatedStaticBlock(FStaticBlock).RebuildList; //fill items
for i := 0 to FStaticBlock.Items.Count - 1 do
begin
staticItem := FStaticBlock.Items[i];
staticItem.CanBeEdited := ALandscape.CanWrite(staticItem.X,
staticItem.Y);
end;
end;
{ TLandscape }
constructor TLandscape.Create(AWidth, AHeight: Word);
var
i: Integer;
begin
inherited Create;
FWidth := AWidth;
FHeight := AHeight;
FCellWidth := FWidth * 8;
FCellHeight := FHeight * 8;
BlockCacheSize := 256;
FBlockCache := TBlockCache.Create(BlockCacheSize); //856
FBlockCache.OnRemoveObject := @OnRemoveCachedObject;
FOnChange := nil;
FOnNewBlock := nil;
FOnStaticDeleted := nil;
FOnStaticElevated := nil;
FOnStaticHued := nil;
FOnStaticInserted := nil;
FOpenRequests := TBits.Create(FWidth * FHeight);
FOpenRequests.Clearall; //set all to 0
FWriteMap := TBits.Create(FCellWidth * FCellHeight);
for i := 0 to FWriteMap.Size - 1 do
FWriteMap[i] := True;
//FMaxStaticID := $1FFDC;
FMaxStaticID := Min(Min(ResMan.Animdata.AnimCount, ResMan.Tiledata.StaticCount),
ResMan.Art.EntryCount - $4000);
Logger.Send([lcClient, lcInfo], 'Landscape recognizes $%x StaticTile IDs.',
[FMaxStaticId]);
FDrawMap := TBits.Create($4000 + FMaxStaticID);
for i := 0 to FDrawMap.Size - 1 do
FDrawMap[i] := True;
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;
begin
if (FBlockCacheBak <> nil) then
begin
FBlockCacheBak.OnRemoveObject := nil;
FreeAndNil(FBlockCacheBak);
end;
if FBlockCache <> nil then
begin
FBlockCache.OnRemoveObject := nil;
FreeAndNil(FBlockCache);
end;
FreeAndNil(FOpenRequests);
FreeAndNil(FWriteMap);
FreeAndNil(FDrawMap);
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.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), block) then
Result := block.Map;
end;
end;
function TLandscape.GetMapCell(AX, AY: Integer): 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.GetNormals(AX, AY: Integer): TNormals;
begin
GetNormals(AX, AY, Result);
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), block) then
Result := TSeperatedStaticBlock(block.Static);
end;
end;
function TLandscape.GetStaticList(AX, AY: Word): TStaticItemList;
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;
procedure TLandscape.OnRemoveCachedObject(ABlock: TBlock);
begin
if ABlock <> nil then
dmNetwork.Send(TFreeBlockPacket.Create(ABlock.Map.X, ABlock.Map.Y));
end;
procedure TLandscape.OnBlocksPacket(ABuffer: TEnhancedMemoryStream);
var
index: TGenericIndex;
map: TMapBlock;
statics: TStaticBlock;
coords: TBlockCoords;
count: Word;
id: Integer;
block: TBlock;
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 := -1;
if not UseStaticsOldFormat
then index.Size := count * 7
else index.Size := count * 11;
statics := TSeperatedStaticBlock.Create(ABuffer, index, coords.X, coords.Y);
FBlockCache.RemoveID(id);
block := TBlock.Create(map, statics);
block.UpdateBlockAcess(Self);
FBlockCache.StoreID(id, block);
FOpenRequests[coords.Y * FWidth + coords.X] := False;
if Assigned(FOnNewBlock) then FOnNewBlock(block);
end;
index.Free;
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(FOnMapChanged) then FOnMapChanged(cell);
end;
end;
procedure TLandscape.OnInsertStaticPacket(ABuffer: TEnhancedMemoryStream);
var
x, y: Word;
block: TSeperatedStaticBlock;
staticItem: TStaticItem;
targetStaticList: TStaticItemList;
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
targetStaticList.Items[i].UpdatePriorities(
ResMan.Tiledata.StaticTiles[targetStaticList.Items[i].TileID],
i);
targetStaticList.Sort(@CompareStaticItems);
staticItem.Owner := block;
staticItem.CanBeEdited := CanWrite(x, y);
if Assigned(FOnStaticInserted) then FOnStaticInserted(staticItem);
end;
end;
procedure TLandscape.OnDeleteStaticPacket(ABuffer: TEnhancedMemoryStream);
var
block: TSeperatedStaticBlock;
i: Integer;
statics: TStaticItemList;
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 := statics.Items[i];
if (staticItem.Z = staticInfo.Z) and
(staticItem.TileID = staticInfo.TileID) and
(staticItem.Hue = staticInfo.Hue) then
begin
if Assigned(FOnStaticDeleted) then FOnStaticDeleted(staticItem);
staticItem.Delete;
statics.Delete(i);
Break;
end;
end;
end;
end;
procedure TLandscape.OnElevateStaticPacket(ABuffer: TEnhancedMemoryStream);
var
block: TSeperatedStaticBlock;
i,j : Integer;
statics: TStaticItemList;
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 := 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
statics.Items[j].UpdatePriorities(
ResMan.Tiledata.StaticTiles[statics.Items[j].TileID],
j);
statics.Sort(@CompareStaticItems);
if Assigned(FOnStaticElevated) then FOnStaticElevated(staticItem);
Break;
end;
end;
end;
end;
procedure TLandscape.OnMoveStaticPacket(ABuffer: TEnhancedMemoryStream);
var
sourceBlock, targetBlock: TSeperatedStaticBlock;
i: Integer;
statics: TStaticItemList;
staticInfo: TStaticInfo;
staticItem: TStaticItem;
newX, newY: Word;
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 := 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
if Assigned(FOnStaticDeleted) then FOnStaticDeleted(staticItem);
staticItem.Delete;
statics.Remove(staticItem);
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
TStaticItem(statics.Items[i]).UpdatePriorities(
ResMan.Tiledata.StaticTiles[TStaticItem(statics.Items[i]).TileID],
i);
statics.Sort(@CompareStaticItems);
staticItem.Owner := targetBlock;
staticItem.CanBeEdited := CanWrite(newX, newY);
if Assigned(FOnStaticInserted) then FOnStaticInserted(staticItem);
end;
end;
procedure TLandscape.OnHueStaticPacket(ABuffer: TEnhancedMemoryStream);
var
block: TSeperatedStaticBlock;
i : Integer;
statics: TStaticItemList;
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 := 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(FOnStaticHued) then FOnStaticHued(staticItem);
Break;
end;
end;
end;
end;
function TLandscape.CanWrite(AX, AY: Word): Boolean;
begin
Result := FWriteMap[AX * FCellHeight + AY];
end;
procedure TLandscape.FillDrawList(ADrawList: TScreenBuffer; AX, AY, AWidth,
AHeight: Word; AMap, AStatics, ATDWalls, ATDBridges, ATDRoofs, ATDSurfaces, ATDFoliage, ATDWet: Boolean;
ANoDraw: Boolean; AAdditionalTiles: TWorldItemList = nil);
var
drawMapCell: TMapCell;
drawStatics: TStaticItemList;
i, x, y: Integer;
tempDrawList: TWorldItemList;
staticTileData: TStaticTiledata;
begin
ADrawList.Clear;
tempDrawList := TWorldItemList.Create(False);
for x := AX to AX + AWidth do
begin
for y := AY to AY + AWidth do
begin
if AMap then
begin
drawMapCell := GetMapCell(x, y);
if (drawMapCell <> nil) and (ANoDraw or FDrawMap[drawMapCell.TileID]) then
begin
drawMapCell.Priority := GetEffectiveAltitude(drawMapCell);
drawMapCell.PriorityBonus := 0;
drawMapCell.PrioritySolver := 0;
tempDrawList.Add(drawMapCell);
end;
end;
if AStatics then
begin
drawStatics := GetStaticList(x, y);
if drawStatics <> nil then
for i := 0 to drawStatics.Count - 1 do
begin
staticTileData := ResMan.Tiledata.StaticTiles[drawStatics[i].TileID];
if ANoDraw or FDrawMap[drawStatics[i].TileID + $4000] then
begin
if not ATDWalls and ((tdfWall in staticTileData.Flags) or (tdfWindow in staticTileData.Flags)) then continue;
if not ATDBridges and ((tdfBridge in staticTileData.Flags) or (tdfStairBack in staticTileData.Flags) or (tdfStairRight in staticTileData.Flags)) then continue;
if not ATDRoofs and (tdfRoof in staticTileData.Flags) then continue;
if not ATDSurfaces and (tdfSurface in staticTileData.Flags) then continue;
if not ATDFoliage and (tdfFoliage in staticTileData.Flags) then continue;
if not ATDWet and (tdfWet in staticTileData.Flags) then continue;
drawStatics[i].UpdatePriorities(staticTileData, ADrawList.GetSerial);
tempDrawList.Add(drawStatics[i]);
end;
end;
end;
end;
end;
for i := 0 to AAdditionalTiles.Count - 1 do
tempDrawList.Add(AAdditionalTiles[i]);
tempDrawList.Sort(@CompareWorldItems);
for i := 0 to tempDrawList.Count - 1 do
ADrawList.Add(TWorldItem(tempDrawList[i]));
tempDrawList.Free;
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 := Min(north, south) + Abs(west - east) div 2
else
Result := Min(north, south) + Abs(north - south) div 2;
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;
procedure TLandscape.GetNormals(AX, AY: Word; var ANormals: TNormals);
type
_Normals = array[0..3] of Tvector3_single;
var
cells: array[0..2, 0..2] of _Normals;
north, west, south, east: Tvector3_single;
i, j: Integer;
function Normalize(const AVector: Tvector3_single): Tvector3_single; inline;
begin
Result := AVector / AVector.length;
end;
function GetPlainNormals(X, Y: SmallInt): _Normals;
var
cell: TMapCell;
north, west, south, east: ShortInt;
u, v: Tvector3_single;
begin
cell := GetMapCell(X, Y);
if cell <> nil 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].init(0, 0, 1);
Result[1].init(0, 0, 1);
Result[2].init(0, 0, 1);
Result[3].init(0, 0, 1);
end else
begin
u.init(-22, 22, (north - east) * 4);
v.init(-22, -22, (west - north) * 4);
Result[0] := Normalize(u >< v);
u.init(22, 22, (east - south) * 4);
v.init(-22, 22, (north - east) * 4);
Result[1] := Normalize(u >< v);
u.init(22, -22, (south - west) * 4);
v.init(22, 22, (east - south) * 4);
Result[2] := Normalize(u >< v);
u.init(-22, -22, (west - north) * 4);
v.init(22, -22, (south - west) * 4);
Result[3] := Normalize(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];
ANormals[0] := Normalize(north + west + east + south);
north := cells[1, 0][2];
west := cells[1, 1][1];
east := cells[2, 0][3];
south := cells[2, 1][0];
ANormals[1] := Normalize(north + west + east + south);
north := cells[1, 1][2];
west := cells[1, 2][1];
east := cells[2, 1][3];
south := cells[2, 2][0];
ANormals[2] := Normalize(north + west + east + south);
north := cells[0, 1][2];
west := cells[0, 2][1];
east := cells[1, 1][3];
south := cells[1, 2][0];
ANormals[3] := Normalize(north + west + east + south);
end;
procedure TLandscape.LoadNoDrawMap(AFileName: String);
var
XMLDoc: TXMLDocument;
iNode, node: TDOMNode;
s: string;
i, id: Integer;
begin
frmInitialize.SetStatusLabel(Format(frmInitialize.SplashLoading, ['VirtualTiles.xml']));
// Читаем xml файл с жесткого диска
ReadXMLFile(XMLDoc, AFileName);
if LowerCase(XMLDoc.DocumentElement.NodeName) = 'virtualtiles' then
begin
iNode := XMLDoc.DocumentElement.FirstChild;
while iNode <> nil do
begin
if LowerCase(iNode.NodeName) = 'nodraw' then
begin
node := iNode.FirstChild;
while node <> nil do
begin
s := LowerCase(node.NodeName);
if (s = 'tile') or (s = 'land') or (s = 'item') then
for i := node.Attributes.Length - 1 downto 0 do
if LowerCase(node.Attributes[i].NodeName) = 'id' then
if TryStrToInt(node.Attributes[i].NodeValue, id) then
begin
if s = 'item'
then Inc(id, $4000);
if (id >= 0) and (id < FDrawMap.Size)
then FDrawMap[id] := False;
end;
node := node.NextSibling;
end;
end;
iNode := iNode.NextSibling;
end;
end;
end;
procedure TLandscape.MoveStatic(AStatic: TStaticItem; AX, AY: Word);
var
sourceBlock, targetBlock: TSeperatedStaticBlock;
targetStaticList: TStaticItemList;
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
targetStaticList.Items[i].UpdatePriorities(
ResMan.Tiledata.StaticTiles[targetStaticList.Items[i].TileID],
i);
targetStaticList.Sort(@CompareStaticItems);
AStatic.UpdatePos(AX, AY, AStatic.Z);
AStatic.Owner := targetBlock;
end;
end;
end;
procedure TLandscape.PrepareBlocks(AX1, AY1, AX2, AY2: Word);
var
x, y, i: Integer;
coords: TBlockCoordsArray;
block: TBlock;
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), block)) 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;
procedure TLandscape.UpdateBlockAccess;
var
cacheEntry: TBlockCache.PCacheEntry;
begin
cacheEntry := nil;
while FBlockCache.Iterate(cacheEntry) do
if cacheEntry^.Obj <> nil then
cacheEntry^.Obj.UpdateBlockAcess(Self);
end;
procedure TLandscape.UpdateWriteMap(AStream: TEnhancedMemoryStream);
var
x1, y1, x2, y2: Word;
i, areaCount, cellX, cellY: Integer;
begin
Logger.EnterMethod([lcLandscape, lcDebug], 'TLandscape.UpdateWriteMap');
areaCount := AStream.ReadWord;
Logger.Send([lcLandscape, lcDebug], 'AreaCount', areaCount);
if areaCount > 0 then
begin
FWriteMap.Clearall;
for i := 0 to areaCount - 1 do
begin
x1 := AStream.ReadWord;
y1 := AStream.ReadWord;
x2 := AStream.ReadWord;
y2 := AStream.ReadWord;
for cellX := x1 to x2 do
for cellY := y1 to y2 do
FWriteMap[cellX * FCellHeight + cellY] := True;
end;
end else
for i := 0 to FWriteMap.Size - 1 do
FWriteMap[i] := True;
Logger.Send([lcLandscape, lcDebug], 'WriteMap @ 0,0', FWriteMap[0]);
UpdateBlockAccess;
Logger.ExitMethod([lcLandscape, lcDebug], 'TLandscape.UpdateWriteMap');
end;
procedure TLandscape.ResizeBlockCache(Count: Integer);
begin
if Count < 0 then Count:= 256;
if FBlockCache <> nil then
begin
if BlockCacheSize = Count then exit;
FBlockCache.OnRemoveObject := nil;
if (FBlockCacheBak <> nil) then begin
FBlockCacheBak.Clear;
FreeAndNil(FBlockCacheBak);
FBlockCacheBak := nil;
end;
if Count = 0 then exit;
FBlockCacheBak := FBlockCache;
BlockCacheSize:= Count;
FBlockCache := TBlockCache.Create(BlockCacheSize); //256
FBlockCache.OnRemoveObject := @OnRemoveCachedObject;
end;
end;
{ TMaterial }
constructor TMaterial.Create;
begin
FRefCount := 1;
end;
destructor TMaterial.Destroy;
begin
FreeAndNil(FGraphic);
inherited Destroy;
end;
class procedure TMaterial.CalculateTextureDimensions(ACaps: TGLTextureCaps;
ARealWidth, ARealHeight: Integer; out AWidth, AHeight: Integer);
begin
if ACaps.NonPowerOfTwo then
begin
AWidth := ARealWidth;
AHeight := ARealHeight;
end else
begin
if IsPow2(ARealWidth) then
AWidth := ARealWidth
else
AWidth := NextPow2(ARealWidth);
if IsPow2(ARealHeight) then
AHeight := ARealHeight
else
AHeight := NextPow2(ARealHeight);
end;
end;
function TMaterial.GenerateTexture(AImage: TBaseImage): TGLuint;
begin
Result := CreateGLTextureFromImage(AImage.ImageDataPointer^);
glBindTexture(GL_TEXTURE_2D, Result);
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;
procedure TMaterial.AddRef;
begin
Inc(FRefCount);
end;
procedure TMaterial.DelRef;
begin
Dec(FRefCount);
if FRefCount < 1 then
Free;
end;
function TMaterial.HitTest(AX, AY: Integer; Zoom: Single): Boolean;
begin
AX := Trunc(AX / Zoom);
AY := Trunc(AY / Zoom);
Result := HitTest(AX, AY);
end;
function TMaterial.HitTest(AX, AY: Integer): Boolean;
var
pixel: TColor32Rec;
begin
Result := False;
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;
function TMaterial.CanBeRemoved: Boolean;
begin
Result := FRefCount <= 1;
end;
procedure TMaterial.RemoveFromCache;
begin
DelRef;
end;
{ TScreenBuffer }
constructor TScreenBuffer.Create;
begin
inherited Create;
FCount := 0;
FSerial := 0;
UpdateShortcuts;
end;
destructor TScreenBuffer.Destroy;
begin
Clear;
inherited Destroy;
end;
function TScreenBuffer.Add(AItem: TWorldItem): PBlockInfo;
begin
New(Result);
AItem.Locked := True;
AItem.OnDestroy.RegisterEvent(@OnTileRemoved);
Result^.Item := AItem;
Result^.HighRes := nil;
Result^.LowRes := nil;
Result^.Normals := nil;
Result^.State := ssNormal;
Result^.Highlighted := False;
Result^.Translucent := False;
Result^.Text := nil;
Result^.Next := nil;
if FShortCuts[0] = nil then //First element
begin
FShortCuts[0] := Result;
FShortCuts[-1] := Result; //Last element
end else
begin
FShortCuts[-1]^.Next := Result;
FShortCuts[-1] := Result;
end;
Inc(FCount);
end;
procedure TScreenBuffer.Clear;
var
current, next: PBlockInfo;
begin
current := FShortCuts[0];
while current <> nil do
begin
next := current^.Next;
current^.Item.Locked := False;
current^.Item.OnDestroy.UnregisterEvent(@OnTileRemoved);
if current^.Normals <> nil then Dispose(current^.Normals);
if current^.HighRes <> nil then current^.HighRes.DelRef;
if current^.LowRes <> nil then current^.LowRes.DelRef;
current^.Text.Free;
Dispose(current);
current := next;
end;
FShortCuts[0] := nil;
FShortCuts[-1] := nil;
FCount := 0;
FSerial := 0;
UpdateShortcuts;
end;
procedure TScreenBuffer.Delete(AItem: TWorldItem);
var
current, last, next: PBlockInfo;
begin
last := nil;
current := FShortCuts[0];
while current <> nil do
begin
if current^.Item = AItem then
begin
if FShortCuts[-1] = current then FShortCuts[-1] := last;
if FShortCuts[0] = current then FShortCuts[0] := current^.Next;
if last <> nil then last^.Next := current^.Next;
if current^.Normals <> nil then Dispose(current^.Normals);
if current^.HighRes <> nil then current^.HighRes.DelRef;
if current^.LowRes <> nil then current^.LowRes.DelRef;
current^.Text.Free;
Dispose(current);
Dec(FCount);
FShortCutsValid := False;
next := nil;
end else
next := current^.Next;
last := current;
current := next;
end;
end;
function TScreenBuffer.Find(AScreenPosition: TPoint; Zoom: Single): PBlockInfo;
var
current: PBlockInfo;
buff: array[0..3] of GLuint;
begin
Result := nil;
current := FShortCuts[0];
while current <> nil do //search the last matching tile
begin
if (current^.State = ssNormal) and
PtInRect(current^.ScreenRect, AScreenPosition)then
begin
if current^.CheckRealQuad then
begin
//OpenGL hit test
//We use the "real quad" here to prevent the draw-preview from
//intercepting with our actual tiles (which are "hidden" then).
glSelectBuffer(4, @buff[0]);
glViewport(current^.ScreenRect.Left, current^.ScreenRect.Top,
current^.ScreenRect.Right, current^.ScreenRect.Bottom);
glRenderMode(GL_SELECT);
glInitNames;
glPushName(0);
glPushMatrix;
glMatrixMode(GL_PROJECTION);
glLoadIdentity;
gluOrtho2D(AScreenPosition.x, AScreenPosition.x + 1,
AScreenPosition.y + 1, AScreenPosition.y);
glMatrixMode(GL_MODELVIEW);
glLoadIdentity;
glBegin(GL_QUADS);
glVertex2iv(@current^.RealQuad[0]);
glVertex2iv(@current^.RealQuad[3]);
glVertex2iv(@current^.RealQuad[2]);
glVertex2iv(@current^.RealQuad[1]);
glEnd;
glPopMatrix;
glFlush;
if glRenderMode(GL_RENDER) > 0 then //glRenderMode now returns the number of hits
Result := current;
end else
if current^.LowRes.HitTest(AScreenPosition.x - current^.ScreenRect.Left,
AScreenPosition.y - current^.ScreenRect.Top, Zoom) then
Result := current;
end;
current := current^.Next;
end;
end;
function TScreenBuffer.Find(AX, AY: Word): PBlockInfo;
var
current: PBlockInfo;
tile: TWorldItem;
staticTileData: TStaticTiledata;
tileZ: Integer;
begin
Result := nil;
current := FShortCuts[0];
while current <> nil do //search the last matching tile
begin
if current^.State = ssNormal then begin
tile := current^.Item;
if (tile.X = AX) and (tile.Y = AY) then begin
tileZ := $FFFF;
if tile is TStaticItem then begin
staticTileData := ResMan.Tiledata.StaticTiles[tile.TileID];
if tdfSurface in staticTileData.Flags then
tileZ := tile.Z + staticTileData.Height;
end else if tile is TMapCell then begin
tileZ := ResMan.Landscape.GetEffectiveAltitude(tile as TMapCell)
end else if tile is TVirtualTile then
tileZ := tile.Z;
if (tileZ <> $FFFF) and ((Result = nil) or (tile.Z > Result^.Item.Z)) then
Result := current;
end;
end;
current := current^.Next;
end;
end;
function TScreenBuffer.GetSerial: Cardinal;
begin
Result := FSerial;
Inc(FSerial);
end;
function TScreenBuffer.Insert(AItem: TWorldItem): PBlockInfo;
var
current: PBlockInfo;
shortcut: Integer;
begin
if not FShortCutsValid then
UpdateShortcuts;
New(Result);
AItem.Locked := True;
AItem.OnDestroy.RegisterEvent(@OnTileRemoved);
Result^.Item := AItem;
Result^.HighRes := nil;
Result^.LowRes := nil;
Result^.Normals := nil;
Result^.State := ssNormal;
Result^.Highlighted := False;
Result^.Translucent := False;
Result^.Text := nil;
if (FShortCuts[0] = nil) or (CompareWorldItems(AItem, FShortCuts[0]^.Item) < 0) then
begin
if FShortCuts[0] = nil then
FShortCuts[-1] := Result; //Update last item
Result^.Next := FShortCuts[0];
FShortCuts[0] := Result;
end else
begin
//find best entry point
shortcut := 0;
while (shortcut <= 10) and (FShortCuts[shortcut] <> nil) and
(CompareWorldItems(AItem, FShortCuts[shortcut]^.Item) >= 0) do
begin
current := FShortCuts[shortcut];
Inc(shortcut);
end;
//now find the real match
while (current^.Next <> nil) and
(CompareWorldItems(AItem, current^.Next^.Item) > 0) do
begin
current := current^.Next;
end;
if FShortCuts[-1] = current^.Next then
FShortCuts[-1] := Result; //Update last item
Result^.Next := current^.Next;
current^.Next := Result;
end;
Inc(FCount);
end;
function TScreenBuffer.Iterate(var ABlockInfo: PBlockInfo): Boolean;
begin
if ABlockInfo = nil then
ABlockInfo := FShortCuts[0]
else
ABlockInfo := ABlockInfo^.Next;
Result := ABlockInfo <> nil;
end;
procedure TScreenBuffer.UpdateShortcuts;
var
shortcut, step, nextStep, stepSize: Integer;
blockInfo: PBlockInfo;
begin
if FCount < 10 then
begin
for shortcut := 1 to 10 do
FShortCuts[shortcut] := nil;
end
else if FShortCuts[0] <> nil then
begin
stepSize := FCount div 10;
nextStep := stepSize;
step := 0;
shortcut := 1;
blockInfo := FShortCuts[0];
repeat
if (step = nextStep) and (shortcut <= 10) then
begin
FShortCuts[shortcut] := blockInfo;
Inc(shortcut);
Inc(nextStep, stepSize);
end;
Inc(step);
FShortCuts[-1] := blockInfo; //update last known item
blockInfo := blockInfo^.Next;
until (blockInfo = nil);
end;
FShortCutsValid := True;
end;
function TScreenBuffer.UpdateSortOrder(AItem: TWorldItem): PBlockInfo;
var
newNodePosition, oldNode, oldNodePrev, current: PBlockInfo;
begin
newNodePosition := nil;
oldNode := nil;
oldNodePrev := nil;
current := FShortCuts[0];
while (current <> nil) and ((oldNode = nil) or (newNodePosition = nil)) do
begin
if current^.Item = AItem then
oldNode := current
else if oldNode = nil then
oldNodePrev := current;
if newNodePosition = nil then
begin
if (current^.Next = nil) or (CompareWorldItems(AItem, current^.Next^.Item) < 0) then
newNodePosition := current;
end;
current := current^.Next;
end;
//oldNode = nil, if the change happend out-of-screen
if (oldNode <> nil ) and (oldNode <> newNodePosition) then
begin
if oldNodePrev <> oldNode then
begin
if oldNodePrev = nil then
FShortCuts[0] := oldNode^.Next
else
oldNodePrev^.Next := oldNode^.Next;
end;
if (newNodePosition = FShortCuts[0]) and (CompareWorldItems(AItem, FShortCuts[0]^.Item) < 0) then
begin
oldNode^.Next := FShortCuts[0];
FShortCuts[0] := oldNode;
end else
begin
oldNode^.Next := newNodePosition^.Next;
newNodePosition^.Next := oldNode;
end;
end;
Result := oldNode;
end;
procedure TScreenBuffer.OnTileRemoved(ATile: TMulBlock);
begin
Delete(TWorldItem(ATile));
end;
{ TGLText }
constructor TGLText.Create(AFont: TGLFont; AText: String);
begin
FFont := AFont;
FText := AText;
FWidth := FFont.GetTextWidth(AText);
FHeight := FFont.GetTextHeight('A');
end;
procedure TGLText.Render(AScreenRect: TRect);
var
x, y: Integer;
begin
y := AScreenRect.Top + (AScreenRect.Bottom - AScreenRect.Top - FHeight) div 2;
x := AScreenRect.Left + (AScreenRect.Right - AScreenRect.Left - FWidth) div 2;
FFont.DrawText(x, y, FText);
end;
{ TSimpleMaterial }
constructor TSimpleMaterial.Create(AGraphic: TBaseImage);
var
caps: TGLTextureCaps;
begin
inherited Create;
FRealWidth := AGraphic.Width;
FRealHeight := AGraphic.Height;
GetGLTextureCaps(caps);
CalculateTextureDimensions(caps, FRealWidth, FRealHeight, FWidth, FHeight);
FGraphic := TMultiImage.CreateFromParams(FWidth, FHeight, ifA8R8G8B8, 1);
AGraphic.CopyTo(0, 0, FRealWidth, FRealHeight, FGraphic, 0, 0);
FTexture := GenerateTexture(FGraphic);
end;
destructor TSimpleMaterial.Destroy;
begin
if FTexture <> 0 then glDeleteTextures(1, @FTexture);
inherited Destroy;
end;
function TSimpleMaterial.GetTexture: GLuint;
begin
Result := FTexture;
end;
{ TAnimMaterial }
constructor TAnimMaterial.Create(ABaseID: LongWord; AAnimData: TAnimData;
AHue: THue = nil; APartialHue: Boolean = False);
var
i: Integer;
art: array of TArt;
caps: TGLTextureCaps;
begin
inherited Create;
FAnimData := AAnimData;
FRealWidth := 0;
FRealHeight := 0;
SetLength(FTextures, AAnimData.FrameCount);
SetLength(art, AAnimData.FrameCount);
for i := 0 to AAnimData.FrameCount - 1 do
begin
art[i] := ResMan.Art.GetArt(ABaseID + AAnimData.FrameData[i], 0, AHue,
APartialHue);
if art[i].Graphic.Width > FRealWidth then
FRealWidth := art[i].Graphic.Width;
if art[i].Graphic.Height > FRealHeight then
FRealHeight := art[i].Graphic.Height;
end;
GetGLTextureCaps(caps);
CalculateTextureDimensions(caps, FRealWidth, FRealHeight, FWidth, FHeight);
FGraphic := TMultiImage.CreateFromParams(FWidth, FHeight, ifA8R8G8B8,
AAnimData.FrameCount);
for i := 0 to AAnimData.FrameCount - 1 do
begin
FGraphic.ActiveImage := i;
art[i].Graphic.CopyTo(0, 0, art[i].Graphic.Width, art[i].Graphic.Height,
FGraphic, 0, 0);
FTextures[i] := GenerateTexture(FGraphic);
art[i].Free;
end;
FGraphic.ActiveImage := 0;
FActiveFrame := 0;
FNextChange := GetTickCount + AAnimData.FrameStart * 100;
end;
destructor TAnimMaterial.Destroy;
begin
glDeleteTextures(Length(FTextures), @FTextures[0]);
inherited Destroy;
end;
function TAnimMaterial.GetTexture: GLuint;
begin
if FNextChange <= GetTickCount then
begin
FActiveFrame := (FActiveFrame + 1) mod FAnimData.FrameCount;
FGraphic.ActiveImage := FActiveFrame;
if FActiveFrame = 0 then
FNextChange := GetTickCount + FAnimData.FrameStart * 100
else
FNextChange:= GetTickCount + FAnimData.FrameInterval * 100;
end;
Result := FTextures[FActiveFrame];
end;
end.
Reference in New Issue View Git Blame Copy Permalink