aksdb
/
CentrED
1
0
Fork 0
Code Issues 2 Pull Requests Releases Wiki Activity

- Removed custom tile info window 

- Updated VirtualTreeView
- Added tile info as owner drawn hint to vdtTiles (fixes #55)
This commit is contained in:
Andreas Schneider 2009-12-19 19:01:48 +01:00
parent 9ab8e5901b
commit 158403e41a
10 changed files with 3267 additions and 3460 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

97
Client/CentrED.lpi
View File

@ -55,7 +55,7 @@
<MinVersion Major="4" Minor="5" Release="1" Valid="True"/> <MinVersion Major="4" Minor="5" Release="1" Valid="True"/>
</Item5> </Item5>
</RequiredPackages> </RequiredPackages>
<Units Count="43"> <Units Count="42">
<Unit0> <Unit0>
<Filename Value="CentrED.lpr"/> <Filename Value="CentrED.lpr"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
@ -191,126 +191,119 @@
<UnitName Value="UfrmFilter"/> <UnitName Value="UfrmFilter"/>
</Unit19> </Unit19>
<Unit20> <Unit20>
<Filename Value="UfrmTileInfo.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="frmTileInfo"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="UfrmTileInfo"/>
</Unit20>
<Unit21>
<Filename Value="UGUIPlatformUtils.pas"/> <Filename Value="UGUIPlatformUtils.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="UGUIPlatformUtils"/> <UnitName Value="UGUIPlatformUtils"/>
</Unit21> </Unit20>
<Unit22> <Unit21>
<Filename Value="UPlatformTypes.pas"/> <Filename Value="UPlatformTypes.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="UPlatformTypes"/> <UnitName Value="UPlatformTypes"/>
</Unit22> </Unit21>
<Unit23> <Unit22>
<Filename Value="UfrmRegionControl.pas"/> <Filename Value="UfrmRegionControl.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<ComponentName Value="frmRegionControl"/> <ComponentName Value="frmRegionControl"/>
<HasResources Value="True"/> <HasResources Value="True"/>
<ResourceBaseClass Value="Form"/> <ResourceBaseClass Value="Form"/>
<UnitName Value="UfrmRegionControl"/> <UnitName Value="UfrmRegionControl"/>
</Unit23> </Unit22>
<Unit24> <Unit23>
<Filename Value="UPacketHandlers.pas"/> <Filename Value="UPacketHandlers.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="UPacketHandlers"/> <UnitName Value="UPacketHandlers"/>
</Unit24> </Unit23>
<Unit25> <Unit24>
<Filename Value="UPackets.pas"/> <Filename Value="UPackets.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="UPackets"/> <UnitName Value="UPackets"/>
</Unit25> </Unit24>
<Unit26> <Unit25>
<Filename Value="ULandscape.pas"/> <Filename Value="ULandscape.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="ULandscape"/> <UnitName Value="ULandscape"/>
</Unit26> </Unit25>
<Unit27> <Unit26>
<Filename Value="UGameResources.pas"/> <Filename Value="UGameResources.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="UGameResources"/> <UnitName Value="UGameResources"/>
</Unit27> </Unit26>
<Unit28> <Unit27>
<Filename Value="UAdminHandling.pas"/> <Filename Value="UAdminHandling.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="UAdminHandling"/> <UnitName Value="UAdminHandling"/>
</Unit28> </Unit27>
<Unit29> <Unit28>
<Filename Value="Tools/UfrmToolWindow.pas"/> <Filename Value="Tools/UfrmToolWindow.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<ComponentName Value="frmToolWindow"/> <ComponentName Value="frmToolWindow"/>
<ResourceBaseClass Value="Form"/> <ResourceBaseClass Value="Form"/>
<UnitName Value="UfrmToolWindow"/> <UnitName Value="UfrmToolWindow"/>
</Unit29> </Unit28>
<Unit30> <Unit29>
<Filename Value="../Logging.pas"/> <Filename Value="../Logging.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="Logging"/> <UnitName Value="Logging"/>
</Unit30> </Unit29>
<Unit31> <Unit30>
<Filename Value="../UOLib/UStatics.pas"/> <Filename Value="../UOLib/UStatics.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="UStatics"/> <UnitName Value="UStatics"/>
</Unit31> </Unit30>
<Unit32> <Unit31>
<Filename Value="../UOLib/UWorldItem.pas"/> <Filename Value="../UOLib/UWorldItem.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="UWorldItem"/> <UnitName Value="UWorldItem"/>
</Unit32> </Unit31>
<Unit33> <Unit32>
<Filename Value="../UOLib/UMap.pas"/> <Filename Value="../UOLib/UMap.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="UMap"/> <UnitName Value="UMap"/>
</Unit33> </Unit32>
<Unit34> <Unit33>
<Filename Value="../UOLib/UTiledata.pas"/> <Filename Value="../UOLib/UTiledata.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="UTiledata"/> <UnitName Value="UTiledata"/>
</Unit34> </Unit33>
<Unit35> <Unit34>
<Filename Value="UGLFont.pas"/> <Filename Value="UGLFont.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="UGLFont"/> <UnitName Value="UGLFont"/>
</Unit35> </Unit34>
<Unit36> <Unit35>
<Filename Value="../UOLib/UAnimData.pas"/> <Filename Value="../UOLib/UAnimData.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="UAnimData"/> <UnitName Value="UAnimData"/>
</Unit36> </Unit35>
<Unit37> <Unit36>
<Filename Value="../MulProvider/UTileDataProvider.pas"/> <Filename Value="../MulProvider/UTileDataProvider.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="UTileDataProvider"/> <UnitName Value="UTileDataProvider"/>
</Unit37> </Unit36>
<Unit38> <Unit37>
<Filename Value="../MulProvider/UAnimDataProvider.pas"/> <Filename Value="../MulProvider/UAnimDataProvider.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="UAnimDataProvider"/> <UnitName Value="UAnimDataProvider"/>
</Unit38> </Unit37>
<Unit39> <Unit38>
<Filename Value="../MulProvider/UMulManager.pas"/> <Filename Value="../MulProvider/UMulManager.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="UMulManager"/> <UnitName Value="UMulManager"/>
</Unit39> </Unit38>
<Unit40> <Unit39>
<Filename Value="../MulProvider/UArtProvider.pas"/> <Filename Value="../MulProvider/UArtProvider.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="UArtProvider"/> <UnitName Value="UArtProvider"/>
</Unit40> </Unit39>
<Unit41> <Unit40>
<Filename Value="../MulProvider/UTexmapProvider.pas"/> <Filename Value="../MulProvider/UTexmapProvider.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="UTexmapProvider"/> <UnitName Value="UTexmapProvider"/>
</Unit41> </Unit40>
<Unit42> <Unit41>
<Filename Value="../version.inc"/> <Filename Value="../version.inc"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
</Unit42> </Unit41>
</Units> </Units>
</ProjectOptions> </ProjectOptions>
<CompilerOptions> <CompilerOptions>
@ -353,7 +346,7 @@
<IgnoredMessages idx4079="True" idx4080="True" idx4081="True" idx5024="True" idx5028="True"/> <IgnoredMessages idx4079="True" idx4080="True" idx4081="True" idx5024="True" idx5028="True"/>
</CompilerMessages> </CompilerMessages>
<CustomOptions Value="-FE../bin/ <CustomOptions Value="-FE../bin/
-dNoLogging"/> #-dNoLogging"/>
<CompilerPath Value="$(CompPath)"/> <CompilerPath Value="$(CompPath)"/>
</Other> </Other>
</CompilerOptions> </CompilerOptions>

122
Client/CentrED.lpr
View File

@ -1,61 +1,61 @@
(* (*
* CDDL HEADER START * CDDL HEADER START
* *
* The contents of this file are subject to the terms of the * The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only * Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance * (the "License"). You may not use this file except in compliance
* with the License. * with the License.
* *
* You can obtain a copy of the license at * You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php. * http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions * See the License for the specific language governing permissions
* and limitations under the License. * and limitations under the License.
* *
* When distributing Covered Code, include this CDDL HEADER in each * When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at * file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable, * http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed * add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information: * by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner] * Portions Copyright [yyyy] [name of copyright owner]
* *
* CDDL HEADER END * CDDL HEADER END
* *
* *
* Portions Copyright 2009 Andreas Schneider * Portions Copyright 2009 Andreas Schneider
*) *)
program CentrED; program CentrED;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
uses uses
{$IFDEF UNIX}{$IFDEF UseCThreads} {$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads, cthreads,
{$ENDIF}{$ENDIF} {$ENDIF}{$ENDIF}
SysUtils, SysUtils,
Interfaces, // this includes the LCL widgetset Interfaces, // this includes the LCL widgetset
Forms, LResources, lnetvisual, LazOpenGLContext, UdmNetwork, UfrmMain, Forms, LResources, lnetvisual, LazOpenGLContext, UdmNetwork, UfrmMain,
UfrmLogin, UfrmInitialize, UfrmAccountControl, virtualtreeview_package, UfrmLogin, UfrmInitialize, UfrmAccountControl, virtualtreeview_package,
multiloglaz, UfrmEditAccount, UfrmDrawSettings, UfrmBoundaries, multiloglaz, UfrmEditAccount, UfrmDrawSettings, UfrmBoundaries,
UfrmElevateSettings, UOverlayUI, UResourceManager, UfrmConfirmation, UfrmElevateSettings, UOverlayUI, UResourceManager, UfrmConfirmation,
UfrmMoveSettings, UfrmAbout, UfrmHueSettings, UfrmRadar, UfrmMoveSettings, UfrmAbout, UfrmHueSettings, UfrmRadar,
UfrmLargeScaleCommand, UfrmVirtualLayer, UfrmFilter, UfrmTileInfo, UfrmLargeScaleCommand, UfrmVirtualLayer, UfrmFilter,
UGUIPlatformUtils, UPlatformTypes, UfrmRegionControl, UPackets, UGUIPlatformUtils, UPlatformTypes, UfrmRegionControl, UPackets,
UPacketHandlers, UAdminHandling, UGameResources, ULandscape, UfrmToolWindow, UPacketHandlers, UAdminHandling, UGameResources, ULandscape, UfrmToolWindow,
Logging, UTileDataProvider, UMap, UWorldItem, UStatics, UTiledata, UAnimData, Logging, UTileDataProvider, UMap, UWorldItem, UStatics, UTiledata, UAnimData,
UGLFont, UAnimDataProvider, UMulManager, UArtProvider, UTexmapProvider; UGLFont, UAnimDataProvider, UMulManager, UArtProvider, UTexmapProvider;
{$IFDEF WINDOWS}{$R CentrED.rc}{$ENDIF} {$IFDEF WINDOWS}{$R CentrED.rc}{$ENDIF}
function GetApplicationName: String; function GetApplicationName: String;
begin begin
Result := 'CentrED'; Result := 'CentrED';
end; end;
begin begin
{$I CentrED.lrs} {$I CentrED.lrs}
OnGetApplicationName := @GetApplicationName; OnGetApplicationName := @GetApplicationName;
Application.Initialize; Application.Initialize;
Application.CreateForm(TdmNetwork, dmNetwork); Application.CreateForm(TdmNetwork, dmNetwork);
Application.Run; Application.Run;
end. end.

46
Client/Tools/UfrmFilter.lfm
View File

@ -31,8 +31,8 @@ object frmFilter: TfrmFilter
ChildSizing.ShrinkVertical = crsScaleChilds ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 2 ChildSizing.ControlsPerLine = 2
ClientHeight = 22 ClientHeight = 26
ClientWidth = 220 ClientWidth = 222
Columns = 2 Columns = 2
ItemIndex = 0 ItemIndex = 0
Items.Strings = ( Items.Strings = (
@ -50,8 +50,8 @@ object frmFilter: TfrmFilter
Align = alClient Align = alClient
BorderSpacing.Around = 4 BorderSpacing.Around = 4
Caption = 'Tile filter' Caption = 'Tile filter'
ClientHeight = 241 ClientHeight = 245
ClientWidth = 220 ClientWidth = 222
TabOrder = 1 TabOrder = 1
object Label1: TLabel object Label1: TLabel
AnchorSideLeft.Control = GroupBox1 AnchorSideLeft.Control = GroupBox1
@ -60,9 +60,9 @@ object frmFilter: TfrmFilter
AnchorSideRight.Control = GroupBox1 AnchorSideRight.Control = GroupBox1
AnchorSideRight.Side = asrBottom AnchorSideRight.Side = asrBottom
Left = 4 Left = 4
Height = 27 Height = 30
Top = 27 Top = 30
Width = 212 Width = 214
Anchors = [akTop, akLeft, akRight] Anchors = [akTop, akLeft, akRight]
BorderSpacing.Around = 4 BorderSpacing.Around = 4
Caption = 'Drag and Drop static tiles from the tile list on this list to add them to the filter.' Caption = 'Drag and Drop static tiles from the tile list on this list to add them to the filter.'
@ -79,7 +79,7 @@ object frmFilter: TfrmFilter
Left = 30 Left = 30
Height = 22 Height = 22
Hint = 'Clear' Hint = 'Clear'
Top = 215 Top = 219
Width = 22 Width = 22
Anchors = [akLeft, akBottom] Anchors = [akLeft, akBottom]
Color = clBtnFace Color = clBtnFace
@ -131,7 +131,7 @@ object frmFilter: TfrmFilter
Left = 4 Left = 4
Height = 22 Height = 22
Hint = 'Delete' Hint = 'Delete'
Top = 215 Top = 219
Width = 22 Width = 22
Anchors = [akLeft, akBottom] Anchors = [akLeft, akBottom]
BorderSpacing.Around = 4 BorderSpacing.Around = 4
@ -187,12 +187,11 @@ object frmFilter: TfrmFilter
AnchorSideBottom.Control = btnDelete AnchorSideBottom.Control = btnDelete
Cursor = 63 Cursor = 63
Left = 4 Left = 4
Height = 153 Height = 151
Top = 58 Top = 64
Width = 212 Width = 214
Anchors = [akTop, akLeft, akRight, akBottom] Anchors = [akTop, akLeft, akRight, akBottom]
BorderSpacing.Around = 4 BorderSpacing.Around = 4
BorderStyle = bsSingle
DefaultNodeHeight = 44 DefaultNodeHeight = 44
DragType = dtVCL DragType = dtVCL
Header.AutoSizeIndex = 0 Header.AutoSizeIndex = 0
@ -226,9 +225,9 @@ object frmFilter: TfrmFilter
AnchorSideLeft.Control = GroupBox1 AnchorSideLeft.Control = GroupBox1
AnchorSideTop.Control = GroupBox1 AnchorSideTop.Control = GroupBox1
Left = 4 Left = 4
Height = 19 Height = 22
Top = 4 Top = 4
Width = 78 Width = 85
BorderSpacing.Around = 4 BorderSpacing.Around = 4
Caption = 'Filter active' Caption = 'Filter active'
OnChange = cbTileFilterChange OnChange = cbTileFilterChange
@ -243,14 +242,14 @@ object frmFilter: TfrmFilter
Align = alBottom Align = alBottom
BorderSpacing.Around = 4 BorderSpacing.Around = 4
Caption = 'Hue filter' Caption = 'Hue filter'
ClientHeight = 150 ClientHeight = 154
ClientWidth = 220 ClientWidth = 222
TabOrder = 2 TabOrder = 2
object cbHueFilter: TCheckBox object cbHueFilter: TCheckBox
Left = 4 Left = 4
Height = 19 Height = 22
Top = 4 Top = 4
Width = 212 Width = 214
Align = alTop Align = alTop
BorderSpacing.Around = 4 BorderSpacing.Around = 4
Caption = 'Filter active' Caption = 'Filter active'
@ -260,12 +259,11 @@ object frmFilter: TfrmFilter
object vdtHues: TVirtualDrawTree object vdtHues: TVirtualDrawTree
Cursor = 63 Cursor = 63
Left = 4 Left = 4
Height = 119 Height = 120
Top = 27 Top = 30
Width = 212 Width = 214
Align = alClient Align = alClient
BorderSpacing.Around = 4 BorderSpacing.Around = 4
BorderStyle = bsSingle
Header.AutoSizeIndex = 2 Header.AutoSizeIndex = 2
Header.Columns = < Header.Columns = <
item item
@ -280,7 +278,7 @@ object frmFilter: TfrmFilter
item item
Position = 2 Position = 2
Text = 'Name' Text = 'Name'
Width = 150 Width = 154
end> end>
Header.DefaultHeight = 17 Header.DefaultHeight = 17
Header.Options = [hoAutoResize, hoColumnResize, hoDrag, hoVisible] Header.Options = [hoAutoResize, hoColumnResize, hoDrag, hoVisible]

740
Client/UdmNetwork.pas
View File

@ -1,371 +1,369 @@
(* (*
* CDDL HEADER START * CDDL HEADER START
* *
* The contents of this file are subject to the terms of the * The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only * Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance * (the "License"). You may not use this file except in compliance
* with the License. * with the License.
* *
* You can obtain a copy of the license at * You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php. * http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions * See the License for the specific language governing permissions
* and limitations under the License. * and limitations under the License.
* *
* When distributing Covered Code, include this CDDL HEADER in each * When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at * file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable, * http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed * add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information: * by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner] * Portions Copyright [yyyy] [name of copyright owner]
* *
* CDDL HEADER END * CDDL HEADER END
* *
* *
* Portions Copyright 2009 Andreas Schneider * Portions Copyright 2009 Andreas Schneider
*) *)
unit UdmNetwork; unit UdmNetwork;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
interface interface
uses uses
Classes, SysUtils, LResources, Forms, Controls, Dialogs, lNetComponents, lNet, Classes, SysUtils, LResources, Forms, Controls, Dialogs, lNetComponents, lNet,
UEnhancedMemoryStream, UPacket, UEnums, ExtCtrls, dateutils; UEnhancedMemoryStream, UPacket, UEnums, ExtCtrls, dateutils;
type type
{ TdmNetwork } { TdmNetwork }
TdmNetwork = class(TDataModule) TdmNetwork = class(TDataModule)
TCPClient: TLTCPComponent; TCPClient: TLTCPComponent;
tmNoOp: TTimer; tmNoOp: TTimer;
procedure DataModuleCreate(Sender: TObject); procedure DataModuleCreate(Sender: TObject);
procedure DataModuleDestroy(Sender: TObject); procedure DataModuleDestroy(Sender: TObject);
procedure TCPClientConnect(aSocket: TLSocket); procedure TCPClientConnect(aSocket: TLSocket);
procedure TCPClientDisconnect(aSocket: TLSocket); procedure TCPClientDisconnect(aSocket: TLSocket);
procedure TCPClientError(const msg: string; aSocket: TLSocket); procedure TCPClientError(const msg: string; aSocket: TLSocket);
procedure TCPClientReceive(aSocket: TLSocket); procedure TCPClientReceive(aSocket: TLSocket);
procedure tmNoOpStartTimer(Sender: TObject); procedure tmNoOpStartTimer(Sender: TObject);
procedure tmNoOpTimer(Sender: TObject); procedure tmNoOpTimer(Sender: TObject);
protected protected
FSendQueue: TEnhancedMemoryStream; FSendQueue: TEnhancedMemoryStream;
FReceiveQueue: TEnhancedMemoryStream; FReceiveQueue: TEnhancedMemoryStream;
FUsername: string; FUsername: string;
FPassword: string; FPassword: string;
FAccessLevel: TAccessLevel; FAccessLevel: TAccessLevel;
FDataDir: string; FDataDir: string;
FLastPacket: TDateTime; FLastPacket: TDateTime;
procedure OnCanSend(ASocket: TLSocket); procedure OnCanSend(ASocket: TLSocket);
procedure OnConnectionHandlingPacket(ABuffer: TEnhancedMemoryStream); procedure OnConnectionHandlingPacket(ABuffer: TEnhancedMemoryStream);
procedure ProcessQueue; procedure ProcessQueue;
procedure DoLogin; procedure DoLogin;
public public
property Username: string read FUsername; property Username: string read FUsername;
property AccessLevel: TAccessLevel read FAccessLevel write FAccessLevel; property AccessLevel: TAccessLevel read FAccessLevel write FAccessLevel;
procedure Send(APacket: TPacket); procedure Send(APacket: TPacket);
procedure Disconnect; procedure Disconnect;
procedure CheckClose(ASender: TForm); procedure CheckClose(ASender: TForm);
end; end;
var var
dmNetwork: TdmNetwork; dmNetwork: TdmNetwork;
implementation implementation
uses uses
UPacketHandlers, UPackets, UfrmMain, UfrmLogin, UfrmInitialize, UPacketHandlers, UPackets, UfrmMain, UfrmLogin, UfrmInitialize,
UGameResources, UfrmAccountControl, UfrmEditAccount, UfrmDrawSettings, UGameResources, UfrmAccountControl, UfrmEditAccount, UfrmDrawSettings,
UfrmBoundaries, UfrmElevateSettings, UfrmConfirmation, UfrmMoveSettings, UfrmBoundaries, UfrmElevateSettings, UfrmConfirmation, UfrmMoveSettings,
UfrmAbout, UfrmHueSettings, UfrmRadar, UfrmLargeScaleCommand, UfrmAbout, UfrmHueSettings, UfrmRadar, UfrmLargeScaleCommand,
UfrmVirtualLayer, UfrmFilter, UfrmTileInfo, UfrmRegionControl; UfrmVirtualLayer, UfrmFilter, UfrmRegionControl;
{$I version.inc} {$I version.inc}
{ TdmNetwork } { TdmNetwork }
procedure TdmNetwork.DataModuleCreate(Sender: TObject); procedure TdmNetwork.DataModuleCreate(Sender: TObject);
begin begin
FSendQueue := TEnhancedMemoryStream.Create; FSendQueue := TEnhancedMemoryStream.Create;
FReceiveQueue := TEnhancedMemoryStream.Create; FReceiveQueue := TEnhancedMemoryStream.Create;
TCPClient.OnCanSend := @OnCanSend; TCPClient.OnCanSend := @OnCanSend;
PacketHandlers[$02] := TPacketHandler.Create(0, @OnConnectionHandlingPacket); PacketHandlers[$02] := TPacketHandler.Create(0, @OnConnectionHandlingPacket);
DoLogin; DoLogin;
end; end;
procedure TdmNetwork.DataModuleDestroy(Sender: TObject); procedure TdmNetwork.DataModuleDestroy(Sender: TObject);
begin begin
FreeAndNil(FSendQueue); FreeAndNil(FSendQueue);
FreeAndNil(FReceiveQueue); FreeAndNil(FReceiveQueue);
FreeAndNil(PacketHandlers[$02]); FreeAndNil(PacketHandlers[$02]);
end; end;
procedure TdmNetwork.TCPClientConnect(aSocket: TLSocket); procedure TdmNetwork.TCPClientConnect(aSocket: TLSocket);
begin begin
FSendQueue.Clear; FSendQueue.Clear;
FReceiveQueue.Clear; FReceiveQueue.Clear;
end; end;
procedure TdmNetwork.TCPClientDisconnect(aSocket: TLSocket); procedure TdmNetwork.TCPClientDisconnect(aSocket: TLSocket);
begin begin
FSendQueue.Clear; FSendQueue.Clear;
FReceiveQueue.Clear; FReceiveQueue.Clear;
DoLogin; DoLogin;
end; end;
procedure TdmNetwork.TCPClientError(const msg: string; aSocket: TLSocket); procedure TdmNetwork.TCPClientError(const msg: string; aSocket: TLSocket);
begin begin
MessageDlg('Connection error', msg, mtError, [mbOK], 0); MessageDlg('Connection error', msg, mtError, [mbOK], 0);
if not TCPClient.Connected then if not TCPClient.Connected then
TCPClientDisconnect(aSocket); TCPClientDisconnect(aSocket);
end; end;
procedure TdmNetwork.TCPClientReceive(aSocket: TLSocket); procedure TdmNetwork.TCPClientReceive(aSocket: TLSocket);
var var
buffer: array[0..4095] of byte; buffer: array[0..4095] of byte;
size: Integer; size: Integer;
begin begin
repeat repeat
size := TCPClient.Get(buffer, 4096); size := TCPClient.Get(buffer, 4096);
if size > 0 then if size > 0 then
FReceiveQueue.Enqueue(buffer, size); FReceiveQueue.Enqueue(buffer, size);
until size <= 0; until size <= 0;
ProcessQueue; ProcessQueue;
end; end;
procedure TdmNetwork.tmNoOpStartTimer(Sender: TObject); procedure TdmNetwork.tmNoOpStartTimer(Sender: TObject);
begin begin
FLastPacket := Now; FLastPacket := Now;
end; end;
procedure TdmNetwork.tmNoOpTimer(Sender: TObject); procedure TdmNetwork.tmNoOpTimer(Sender: TObject);
begin begin
if SecondsBetween(FLastPacket, Now) > 25 then if SecondsBetween(FLastPacket, Now) > 25 then
Send(TNoOpPacket.Create); Send(TNoOpPacket.Create);
end; end;
procedure TdmNetwork.OnCanSend(ASocket: TLSocket); procedure TdmNetwork.OnCanSend(ASocket: TLSocket);
var var
size: Integer; size: Integer;
begin begin
while FSendQueue.Size > 0 do while FSendQueue.Size > 0 do
begin begin
FLastPacket := Now; FLastPacket := Now;
size := TCPClient.Send(FSendQueue.Memory^, FSendQueue.Size); size := TCPClient.Send(FSendQueue.Memory^, FSendQueue.Size);
if size > 0 then if size > 0 then
FSendQueue.Dequeue(size) FSendQueue.Dequeue(size)
else else
Break; Break;
end; end;
end; end;
procedure TdmNetwork.OnConnectionHandlingPacket(ABuffer: TEnhancedMemoryStream); procedure TdmNetwork.OnConnectionHandlingPacket(ABuffer: TEnhancedMemoryStream);
var var
subID: Byte; subID: Byte;
loginState: TLoginState; loginState: TLoginState;
width, height: Word; width, height: Word;
serverState: TServerState; serverState: TServerState;
begin begin
subID := ABuffer.ReadByte; subID := ABuffer.ReadByte;
case subID of case subID of
$01: $01:
begin begin
if ABuffer.ReadCardinal = ProtocolVersion then if ABuffer.ReadCardinal = ProtocolVersion then
begin begin
frmInitialize.lblStatus.Caption := 'Authenticating'; frmInitialize.lblStatus.Caption := 'Authenticating';
Send(TLoginRequestPacket.Create(FUsername, FPassword)); Send(TLoginRequestPacket.Create(FUsername, FPassword));
end else end else
begin begin
MessageDlg('Error', 'Invalid protocol version. Maybe your client is outdated.', mtError, [mbOK], 0); MessageDlg('Error', 'Invalid protocol version. Maybe your client is outdated.', mtError, [mbOK], 0);
Disconnect; Disconnect;
end; end;
end; end;
$03: $03:
begin begin
loginState := TLoginState(ABuffer.ReadByte); loginState := TLoginState(ABuffer.ReadByte);
if loginState = lsOK then if loginState = lsOK then
begin begin
frmInitialize.lblStatus.Caption := 'Initializing'; frmInitialize.lblStatus.Caption := 'Initializing';
frmInitialize.Repaint; frmInitialize.Repaint;
frmInitialize.lblStatus.Repaint; frmInitialize.lblStatus.Repaint;
Application.ProcessMessages; Application.ProcessMessages;
FAccessLevel := TAccessLevel(ABuffer.ReadByte); FAccessLevel := TAccessLevel(ABuffer.ReadByte);
InitGameResourceManager(FDataDir); InitGameResourceManager(FDataDir);
width := ABuffer.ReadWord; width := ABuffer.ReadWord;
height := ABuffer.ReadWord; height := ABuffer.ReadWord;
ResMan.InitLandscape(width, height); ResMan.InitLandscape(width, height);
ResMan.Landscape.UpdateWriteMap(ABuffer); ResMan.Landscape.UpdateWriteMap(ABuffer);
frmMain := TfrmMain.Create(dmNetwork); frmMain := TfrmMain.Create(dmNetwork);
frmRadarMap := TfrmRadarMap.Create(frmMain); frmRadarMap := TfrmRadarMap.Create(frmMain);
frmLargeScaleCommand := TfrmLargeScaleCommand.Create(frmMain); frmLargeScaleCommand := TfrmLargeScaleCommand.Create(frmMain);
frmRegionControl := TfrmRegionControl.Create(frmMain); frmRegionControl := TfrmRegionControl.Create(frmMain);
frmAccountControl := TfrmAccountControl.Create(frmMain); frmAccountControl := TfrmAccountControl.Create(frmMain);
frmEditAccount := TfrmEditAccount.Create(frmAccountControl); frmEditAccount := TfrmEditAccount.Create(frmAccountControl);
frmConfirmation := TfrmConfirmation.Create(frmMain); frmConfirmation := TfrmConfirmation.Create(frmMain);
frmDrawSettings := TfrmDrawSettings.Create(frmMain); frmDrawSettings := TfrmDrawSettings.Create(frmMain);
frmMoveSettings := TfrmMoveSettings.Create(frmMain); frmMoveSettings := TfrmMoveSettings.Create(frmMain);
frmElevateSettings := TfrmElevateSettings.Create(frmMain); frmElevateSettings := TfrmElevateSettings.Create(frmMain);
frmHueSettings := TfrmHueSettings.Create(frmMain); frmHueSettings := TfrmHueSettings.Create(frmMain);
frmBoundaries := TfrmBoundaries.Create(frmMain); frmBoundaries := TfrmBoundaries.Create(frmMain);
frmFilter := TfrmFilter.Create(frmMain); frmFilter := TfrmFilter.Create(frmMain);
frmVirtualLayer := TfrmVirtualLayer.Create(frmMain); frmVirtualLayer := TfrmVirtualLayer.Create(frmMain);
frmAbout := TfrmAbout.Create(frmMain); frmAbout := TfrmAbout.Create(frmMain);
frmTileInfo := TfrmTileInfo.Create(frmMain); frmMain.Show;
frmMain.Show; frmInitialize.Hide;
frmInitialize.Hide; tmNoOp.Enabled := True;
tmNoOp.Enabled := True; end else
end else begin
begin if loginState = lsInvalidUser then
if loginState = lsInvalidUser then MessageDlg('Error', 'The username you specified is incorrect.', mtWarning, [mbOK], 0)
MessageDlg('Error', 'The username you specified is incorrect.', mtWarning, [mbOK], 0) else if loginState = lsInvalidPassword then
else if loginState = lsInvalidPassword then MessageDlg('Error', 'The password you specified is incorrect.', mtWarning, [mbOK], 0)
MessageDlg('Error', 'The password you specified is incorrect.', mtWarning, [mbOK], 0) else if loginState = lsAlreadyLoggedIn then
else if loginState = lsAlreadyLoggedIn then MessageDlg('Error', 'There is already a client logged in using that account.', mtWarning, [mbOK], 0)
MessageDlg('Error', 'There is already a client logged in using that account.', mtWarning, [mbOK], 0) else if loginState = lsNoAccess then
else if loginState = lsNoAccess then MessageDlg('Error', 'This account has no access.', mtWarning, [mbOK], 0);
MessageDlg('Error', 'This account has no access.', mtWarning, [mbOK], 0); end;
end; end;
end; $04: //Server state
$04: //Server state begin
begin serverState := TServerState(ABuffer.ReadByte);
serverState := TServerState(ABuffer.ReadByte); if serverState = ssRunning then
if serverState = ssRunning then begin
begin frmInitialize.UnsetModal;
frmInitialize.UnsetModal; frmInitialize.Hide;
frmInitialize.Hide; tmNoOp.Enabled := True;
tmNoOp.Enabled := True; end else
end else begin
begin case serverState of
case serverState of ssFrozen: frmInitialize.lblStatus.Caption := 'The server is currently paused.';
ssFrozen: frmInitialize.lblStatus.Caption := 'The server is currently paused.'; ssOther: frmInitialize.lblStatus.Caption := ABuffer.ReadStringNull
ssOther: frmInitialize.lblStatus.Caption := ABuffer.ReadStringNull end;
end; tmNoOp.Enabled := False;
tmNoOp.Enabled := False; frmInitialize.Show;
frmInitialize.Show; frmInitialize.SetModal;
frmInitialize.SetModal; end;
end; end;
end; end;
end; end;
end;
procedure TdmNetwork.ProcessQueue;
procedure TdmNetwork.ProcessQueue; var
var packetHandler: TPacketHandler;
packetHandler: TPacketHandler; size: Cardinal;
size: Cardinal; begin
begin FReceiveQueue.Position := 0;
FReceiveQueue.Position := 0; while FReceiveQueue.Size >= 1 do
while FReceiveQueue.Size >= 1 do begin
begin packetHandler := PacketHandlers[FReceiveQueue.ReadByte];
packetHandler := PacketHandlers[FReceiveQueue.ReadByte]; if packetHandler <> nil then
if packetHandler <> nil then begin
begin size := packetHandler.PacketLength;
size := packetHandler.PacketLength; if size = 0 then
if size = 0 then begin
begin if FReceiveQueue.Size > 5 then
if FReceiveQueue.Size > 5 then size := FReceiveQueue.ReadCardinal
size := FReceiveQueue.ReadCardinal else
else Break; //wait for more data
Break; //wait for more data end;
end;
if FReceiveQueue.Size >= size then
if FReceiveQueue.Size >= size then begin
begin FReceiveQueue.Lock(FReceiveQueue.Position, size - FReceiveQueue.Position); //prevent handler from reading too much
FReceiveQueue.Lock(FReceiveQueue.Position, size - FReceiveQueue.Position); //prevent handler from reading too much packetHandler.Process(FReceiveQueue);
packetHandler.Process(FReceiveQueue); FReceiveQueue.Unlock;
FReceiveQueue.Unlock; FReceiveQueue.Dequeue(size);
FReceiveQueue.Dequeue(size); end else
end else Break; //wait for more data
Break; //wait for more data end else
end else begin
begin {Writeln('Dropping client due to unknown packet: ', ANetState.Socket.PeerAddress);}
{Writeln('Dropping client due to unknown packet: ', ANetState.Socket.PeerAddress);} Disconnect;
Disconnect; FReceiveQueue.Clear;
FReceiveQueue.Clear; end;
end; end;
end; end;
end;
procedure TdmNetwork.DoLogin;
procedure TdmNetwork.DoLogin; begin
begin tmNoOp.Enabled := False;
tmNoOp.Enabled := False; frmLogin := TfrmLogin.Create(dmNetwork);
frmLogin := TfrmLogin.Create(dmNetwork); if frmInitialize = nil then
if frmInitialize = nil then frmInitialize := TfrmInitialize.Create(dmNetwork);
frmInitialize := TfrmInitialize.Create(dmNetwork);
FreeAndNil(frmEditAccount);
FreeAndNil(frmTileInfo); FreeAndNil(frmAccountControl);
FreeAndNil(frmEditAccount); FreeAndNil(frmConfirmation);
FreeAndNil(frmAccountControl); FreeAndNil(frmDrawSettings);
FreeAndNil(frmConfirmation); FreeAndNil(frmMoveSettings);
FreeAndNil(frmDrawSettings); FreeAndNil(frmElevateSettings);
FreeAndNil(frmMoveSettings); FreeAndNil(frmHueSettings);
FreeAndNil(frmElevateSettings); FreeAndNil(frmBoundaries);
FreeAndNil(frmHueSettings); FreeAndNil(frmFilter);
FreeAndNil(frmBoundaries); FreeAndNil(frmVirtualLayer);
FreeAndNil(frmFilter); FreeAndNil(frmAbout);
FreeAndNil(frmVirtualLayer); FreeAndNil(frmRegionControl);
FreeAndNil(frmAbout); FreeAndNil(frmLargeScaleCommand);
FreeAndNil(frmRegionControl); FreeAndNil(frmRadarMap);
FreeAndNil(frmLargeScaleCommand);
FreeAndNil(frmRadarMap); if frmMain <> nil then
begin
if frmMain <> nil then frmMain.ApplicationProperties1.OnIdle := nil;
begin FreeAndNil(frmMain);
frmMain.ApplicationProperties1.OnIdle := nil; end;
FreeAndNil(frmMain);
end; FreeAndNil(GameResourceManager);
FreeAndNil(GameResourceManager); frmInitialize.Hide;
while frmLogin.ShowModal = mrOK do
frmInitialize.Hide; begin
while frmLogin.ShowModal = mrOK do if TCPClient.Connect(frmLogin.edHost.Text, frmLogin.edPort.Value) then
begin begin
if TCPClient.Connect(frmLogin.edHost.Text, frmLogin.edPort.Value) then FUsername := frmLogin.edUsername.Text;
begin FPassword := frmLogin.edPassword.Text;
FUsername := frmLogin.edUsername.Text; FDataDir := frmLogin.edData.Text;
FPassword := frmLogin.edPassword.Text; frmInitialize.lblStatus.Caption := 'Connecting';
FDataDir := frmLogin.edData.Text; frmInitialize.Show;
frmInitialize.lblStatus.Caption := 'Connecting'; Break;
frmInitialize.Show; end else
Break; MessageDlg('Error', 'Cannot connect to the specified server.', mtError, [mbOK], 0);
end else end;
MessageDlg('Error', 'Cannot connect to the specified server.', mtError, [mbOK], 0); frmLogin.Close;
end; FreeAndNil(frmLogin);
frmLogin.Close; end;
FreeAndNil(frmLogin);
end; procedure TdmNetwork.Send(APacket: TPacket);
var
procedure TdmNetwork.Send(APacket: TPacket); source: TEnhancedMemoryStream;
var begin
source: TEnhancedMemoryStream; if TCPClient.Connected then
begin begin
if TCPClient.Connected then FSendQueue.Seek(0, soFromEnd);
begin source := APacket.Stream;
FSendQueue.Seek(0, soFromEnd); FSendQueue.CopyFrom(source, 0);
source := APacket.Stream; OnCanSend(nil);
FSendQueue.CopyFrom(source, 0); end;
OnCanSend(nil); APacket.Free;
end; end;
APacket.Free;
end; procedure TdmNetwork.Disconnect;
begin
procedure TdmNetwork.Disconnect; Send(TQuitPacket.Create);
begin end;
Send(TQuitPacket.Create);
end; procedure TdmNetwork.CheckClose(ASender: TForm);
begin
procedure TdmNetwork.CheckClose(ASender: TForm); if ((frmLogin = nil) or (ASender = frmLogin)) and
begin ((frmMain = nil) or (ASender = frmMain)) and
if ((frmLogin = nil) or (ASender = frmLogin)) and ((frmInitialize = nil) or (not frmInitialize.Visible)) then
((frmMain = nil) or (ASender = frmMain)) and begin
((frmInitialize = nil) or (not frmInitialize.Visible)) then Application.Terminate;
begin end;
Application.Terminate; end;
end;
end; initialization
{$I UdmNetwork.lrs}
initialization
{$I UdmNetwork.lrs} end.
end.

3
Client/UfrmLargeScaleCommand.lfm
View File

@ -1089,7 +1089,6 @@ object frmLargeScaleCommand: TfrmLargeScaleCommand
Width = 144 Width = 144
Anchors = [akTop, akLeft, akRight, akBottom] Anchors = [akTop, akLeft, akRight, akBottom]
BorderSpacing.Bottom = 4 BorderSpacing.Bottom = 4
BorderStyle = bsSingle
DefaultText = 'Node' DefaultText = 'Node'
Header.AutoSizeIndex = 0 Header.AutoSizeIndex = 0
Header.Columns = <> Header.Columns = <>
@ -1132,7 +1131,7 @@ object frmLargeScaleCommand: TfrmLargeScaleCommand
item item
Position = 0 Position = 0
Text = 'Actions' Text = 'Actions'
Width = 152 Width = 148
end> end>
Header.DefaultHeight = 17 Header.DefaultHeight = 17
Header.Options = [hoAutoResize, hoVisible] Header.Options = [hoAutoResize, hoVisible]

5303
Client/UfrmMain.lfm
View File

File diff suppressed because it is too large Load Diff

174
Client/UfrmMain.pas
View File

@ -35,7 +35,7 @@ uses
StdCtrls, Spin, UEnums, VirtualTrees, Buttons, UMulBlock, UWorldItem, math, StdCtrls, Spin, UEnums, VirtualTrees, Buttons, UMulBlock, UWorldItem, math,
LCLIntf, UOverlayUI, UStatics, UEnhancedMemoryStream, ActnList, LCLIntf, UOverlayUI, UStatics, UEnhancedMemoryStream, ActnList,
XMLPropStorage, fgl, ImagingClasses, dateutils, UPlatformTypes, UMap, UPacket, XMLPropStorage, fgl, ImagingClasses, dateutils, UPlatformTypes, UMap, UPacket,
UGLFont, DOM, XMLRead, XMLWrite; UGLFont, DOM, XMLRead, XMLWrite, strutils;
type type
TAccessChangedListener = procedure(AAccessLevel: TAccessLevel) of object; TAccessChangedListener = procedure(AAccessLevel: TAccessLevel) of object;
@ -48,6 +48,13 @@ type
TAccessChangedListeners = specialize TFPGList<TAccessChangedListener>; TAccessChangedListeners = specialize TFPGList<TAccessChangedListener>;
TSelectionListeners = specialize TFPGList<TSelectionListener>; TSelectionListeners = specialize TFPGList<TSelectionListener>;
TTileHintInfo = record
Name: String;
Flags: String;
NameRect: TRect;
FlagsRect: TRect;
end;
{ TfrmMain } { TfrmMain }
TfrmMain = class(TForm) TfrmMain = class(TForm)
@ -138,7 +145,6 @@ type
tbFilter: TToolButton; tbFilter: TToolButton;
tbFlat: TToolButton; tbFlat: TToolButton;
tbNoDraw: TToolButton; tbNoDraw: TToolButton;
tmTileHint: TTimer;
tbSeparator2: TToolButton; tbSeparator2: TToolButton;
tbUndo: TToolButton; tbUndo: TToolButton;
tsLocations: TTabSheet; tsLocations: TTabSheet;
@ -181,6 +187,8 @@ type
procedure acUndoExecute(Sender: TObject); procedure acUndoExecute(Sender: TObject);
procedure acVirtualLayerExecute(Sender: TObject); procedure acVirtualLayerExecute(Sender: TObject);
procedure ApplicationProperties1Idle(Sender: TObject; var Done: Boolean); procedure ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
procedure ApplicationProperties1ShowHint(var HintStr: string;
var CanShow: Boolean; var HintInfo: THintInfo);
procedure btnAddLocationClick(Sender: TObject); procedure btnAddLocationClick(Sender: TObject);
procedure btnAddRandomClick(Sender: TObject); procedure btnAddRandomClick(Sender: TObject);
procedure btnClearLocationsClick(Sender: TObject); procedure btnClearLocationsClick(Sender: TObject);
@ -240,7 +248,6 @@ type
procedure tbTerrainClick(Sender: TObject); procedure tbTerrainClick(Sender: TObject);
procedure tmGrabTileInfoTimer(Sender: TObject); procedure tmGrabTileInfoTimer(Sender: TObject);
procedure tmMovementTimer(Sender: TObject); procedure tmMovementTimer(Sender: TObject);
procedure tmTileHintTimer(Sender: TObject);
procedure vdtRandomClick(Sender: TObject); procedure vdtRandomClick(Sender: TObject);
procedure vdtRandomDragDrop(Sender: TBaseVirtualTree; Source: TObject; procedure vdtRandomDragDrop(Sender: TBaseVirtualTree; Source: TObject;
DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState; DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState;
@ -254,15 +261,14 @@ type
Stream: TStream); Stream: TStream);
procedure vdtRandomUpdating(Sender: TBaseVirtualTree; State: TVTUpdateState); procedure vdtRandomUpdating(Sender: TBaseVirtualTree; State: TVTUpdateState);
procedure vdtTilesClick(Sender: TObject); procedure vdtTilesClick(Sender: TObject);
procedure vdtTilesDrawHint(Sender: TBaseVirtualTree; HintCanvas: TCanvas;
Node: PVirtualNode; const R: TRect; Column: TColumnIndex);
procedure vdtTilesDrawNode(Sender: TBaseVirtualTree; procedure vdtTilesDrawNode(Sender: TBaseVirtualTree;
const PaintInfo: TVTPaintInfo); const PaintInfo: TVTPaintInfo);
procedure vdtTilesEnter(Sender: TObject); procedure vdtTilesEnter(Sender: TObject);
procedure vdtTilesExit(Sender: TObject); procedure vdtTilesGetHintSize(Sender: TBaseVirtualTree; Node: PVirtualNode;
procedure vdtTilesHotChange(Sender: TBaseVirtualTree; OldNode, Column: TColumnIndex; var R: TRect);
NewNode: PVirtualNode);
procedure vdtTilesKeyPress(Sender: TObject; var Key: char); procedure vdtTilesKeyPress(Sender: TObject; var Key: char);
procedure vdtTilesMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure vdtTilesScroll(Sender: TBaseVirtualTree; DeltaX, DeltaY: Integer); procedure vdtTilesScroll(Sender: TBaseVirtualTree; DeltaX, DeltaY: Integer);
procedure vstChatClick(Sender: TObject); procedure vstChatClick(Sender: TObject);
procedure vstChatFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure vstChatFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
@ -316,6 +322,7 @@ type
FUndoList: TPacketList; FUndoList: TPacketList;
FGLFont: TGLFont; FGLFont: TGLFont;
FSelectionListeners: TSelectionListeners; FSelectionListeners: TSelectionListeners;
FTileHint: TTileHintInfo;
{ Methods } { Methods }
procedure BuildTileList; procedure BuildTileList;
function ConfirmAction: Boolean; function ConfirmAction: Boolean;
@ -387,8 +394,8 @@ uses
UfrmAccountControl, UGraphicHelper, ImagingComponents, UfrmDrawSettings, UfrmAccountControl, UGraphicHelper, ImagingComponents, UfrmDrawSettings,
UfrmBoundaries, UfrmElevateSettings, UfrmConfirmation, UfrmMoveSettings, UfrmBoundaries, UfrmElevateSettings, UfrmConfirmation, UfrmMoveSettings,
UfrmAbout, UPacketHandlers, UfrmHueSettings, UfrmRadar, UfrmLargeScaleCommand, UfrmAbout, UPacketHandlers, UfrmHueSettings, UfrmRadar, UfrmLargeScaleCommand,
UfrmLogin, UResourceManager, UfrmVirtualLayer, UfrmFilter, UfrmTileInfo, UfrmLogin, UResourceManager, UfrmVirtualLayer, UfrmFilter, UfrmRegionControl,
UfrmRegionControl, Logging, LConvEncoding, LCLType; Logging, LConvEncoding, LCLType;
type type
TGLArrayf4 = array[0..3] of GLfloat; TGLArrayf4 = array[0..3] of GLfloat;
@ -1053,6 +1060,17 @@ begin
Done := False; Done := False;
end; end;
procedure TfrmMain.ApplicationProperties1ShowHint(var HintStr: string;
var CanShow: Boolean; var HintInfo: THintInfo);
begin
//that check is a bit dirty, but serves its purpose
//(i.e. to set the timeout for the tile info hints)
if HintStr = '-' then
HintInfo.HideTimeout := Application.HintHidePause +
Application.HintHidePausePerChar * (Length(FTileHint.Name) +
Length(FTileHint.Flags));
end;
procedure TfrmMain.btnAddLocationClick(Sender: TObject); procedure TfrmMain.btnAddLocationClick(Sender: TObject);
var var
locationName: string; locationName: string;
@ -1446,12 +1464,6 @@ begin
end; end;
end; end;
procedure TfrmMain.tmTileHintTimer(Sender: TObject);
begin
frmTileInfo.Show;
tmTileHint.Enabled := False;
end;
procedure TfrmMain.vdtRandomClick(Sender: TObject); procedure TfrmMain.vdtRandomClick(Sender: TObject);
var var
node: PVirtualNode; node: PVirtualNode;
@ -1538,6 +1550,18 @@ begin
ProcessToolState; ProcessToolState;
end; end;
procedure TfrmMain.vdtTilesDrawHint(Sender: TBaseVirtualTree;
HintCanvas: TCanvas; Node: PVirtualNode; const R: TRect; Column: TColumnIndex
);
begin
HintCanvas.Font.Style := [fsBold];
DrawText(HintCanvas.Handle, PChar(FTileHint.Name), Length(FTileHint.Name),
FTileHint.NameRect, 0);
HintCanvas.Font.Style := [fsItalic];
DrawText(HintCanvas.Handle, PChar(FTileHint.Flags), Length(FTileHint.Flags),
FTileHint.FlagsRect, DT_WORDBREAK);
end;
procedure TfrmMain.vdtTilesDrawNode(Sender: TBaseVirtualTree; procedure TfrmMain.vdtTilesDrawNode(Sender: TBaseVirtualTree;
const PaintInfo: TVTPaintInfo); const PaintInfo: TVTPaintInfo);
var var
@ -1594,34 +1618,88 @@ begin
end; end;
end; end;
procedure TfrmMain.vdtTilesExit(Sender: TObject); procedure TfrmMain.vdtTilesGetHintSize(Sender: TBaseVirtualTree;
begin Node: PVirtualNode; Column: TColumnIndex; var R: TRect);
{TODO : Fix mouse over on !Windows platforms}
{$IFDEF Windows}
tmTileHint.Enabled := False;
{$ENDIF Windows}
end;
procedure TfrmMain.vdtTilesHotChange(Sender: TBaseVirtualTree; OldNode,
NewNode: PVirtualNode);
{$IFDEF Windows}
var var
tileInfo: PTileInfo; tileInfo: PTileInfo;
{$ENDIF Windows} tileData: TTiledata;
begin prefix, flags: string;
{TODO : Fix mouse over on !Windows platforms}
{$IFDEF Windows} procedure UpdateFlags(AFlag: TTileDataFlag; AName: string);
if NewNode <> nil then
begin begin
tileInfo := vdtTiles.GetNodeData(NewNode); if AFlag in tileData.Flags then
frmTileInfo.Update(tileInfo^.ID); begin
tmTileHint.Enabled := True; if flags <> '' then
end else flags := flags + ', ' + AName
begin else
frmTileInfo.Hide; flags := AName;
tmTileHint.Enabled := False; end;
end; end;
{$ENDIF Windows}
begin
tileInfo := Sender.GetNodeData(Node);
flags := '';
tileData := ResMan.Tiledata.TileData[tileInfo^.ID];
if tileInfo^.ID < $4000 then
begin
if TLandTiledata(tileData).TextureID > 0 then
flags := 'Stretchable';
end;
if tdfArticleA in tileData.Flags then
prefix := 'a '
else if tdfArticleAn in tileData.Flags then
prefix := 'an '
else
prefix := '';
FTileHint.Name := AnsiProperCase(Format('%s%s',
[prefix, tileData.TileName]), [' ']);
FTileHint.NameRect.Left := 5;
FTileHint.NameRect.Top := 5;
Sender.Canvas.Font.Style := [fsBold];
DrawText(Sender.Canvas.Handle, PChar(FTileHint.Name), Length(FTileHint.Name),
FTileHint.NameRect, DT_CALCRECT);
UpdateFlags(tdfBackground, 'Background');
UpdateFlags(tdfWeapon, 'Weapon');
UpdateFlags(tdfTransparent, 'Transparent');
UpdateFlags(tdfTranslucent, 'Translucent');
UpdateFlags(tdfWall, 'Wall');
UpdateFlags(tdfDamaging, 'Damaging');
UpdateFlags(tdfImpassable, 'Impassable');
UpdateFlags(tdfWet, 'Wet');
UpdateFlags(tdfSurface, 'Surface');
UpdateFlags(tdfBridge, 'Bridge');
UpdateFlags(tdfGeneric, 'Generic');
UpdateFlags(tdfWindow, 'Window');
UpdateFlags(tdfNoShoot, 'NoShoot');
UpdateFlags(tdfInternal, 'Internal');
UpdateFlags(tdfFoliage, 'Foliage');
UpdateFlags(tdfPartialHue, 'PartialHue');
UpdateFlags(tdfMap, 'Map');
UpdateFlags(tdfContainer, 'Container');
UpdateFlags(tdfWearable, 'Wearable');
UpdateFlags(tdfLightSource, 'Lightsource');
UpdateFlags(tdfAnimation, 'Animation');
UpdateFlags(tdfNoDiagonal, 'NoDiagonal');
UpdateFlags(tdfArmor, 'Armor');
UpdateFlags(tdfRoof, 'Roof');
UpdateFlags(tdfDoor, 'Door');
UpdateFlags(tdfStairBack, 'StairBack');
UpdateFlags(tdfStairRight, 'StairRight');
FTileHint.Flags := Format('Flags = [%s]', [flags]);
FTileHint.FlagsRect.Left := 5;
FTileHint.FlagsRect.Top := FTileHint.NameRect.Bottom + 5;
FTileHint.FlagsRect.Right := 145;
Sender.Canvas.Font.Style := [fsItalic];
DrawText(Sender.Canvas.Handle, PChar(FTileHint.Flags), Length(FTileHint.Flags),
FTileHint.FlagsRect, DT_CALCRECT or DT_WORDBREAK);
R := Rect(0, 0, Max(FTileHint.NameRect.Right, FTileHint.FlagsRect.Right) + 5,
FTileHint.FlagsRect.Bottom + 5);
end; end;
procedure TfrmMain.vdtTilesKeyPress(Sender: TObject; var Key: char); procedure TfrmMain.vdtTilesKeyPress(Sender: TObject; var Key: char);
@ -1636,22 +1714,6 @@ begin
end; end;
end; end;
procedure TfrmMain.vdtTilesMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if tmTileHint.Enabled then
begin
tmTileHint.Enabled := False;
tmTileHint.Enabled := True; //Restart timer
end;
if frmTileInfo.Visible then
begin
frmTileInfo.Hide;
tmTileHint.Enabled := True;
end;
end;
procedure TfrmMain.vdtTilesScroll(Sender: TBaseVirtualTree; DeltaX, procedure TfrmMain.vdtTilesScroll(Sender: TBaseVirtualTree; DeltaX,
DeltaY: Integer); DeltaY: Integer);
begin begin

3
Client/UfrmRegionControl.lfm
View File

@ -85,7 +85,7 @@ object frmRegionControl: TfrmRegionControl
item item
Position = 0 Position = 0
Text = 'Regions' Text = 'Regions'
Width = 160 Width = 156
end> end>
Header.DefaultHeight = 17 Header.DefaultHeight = 17
Header.Options = [hoAutoResize, hoVisible] Header.Options = [hoAutoResize, hoVisible]
@ -222,7 +222,6 @@ object frmRegionControl: TfrmRegionControl
BorderSpacing.Left = 4 BorderSpacing.Left = 4
BorderSpacing.Right = 4 BorderSpacing.Right = 4
BorderSpacing.Bottom = 4 BorderSpacing.Bottom = 4
BorderStyle = bsSingle
DefaultText = 'Node' DefaultText = 'Node'
Header.AutoSizeIndex = 0 Header.AutoSizeIndex = 0
Header.Columns = <> Header.Columns = <>

69
Client/UfrmTileInfo.lfm
View File

@ -1,69 +0,0 @@
object frmTileInfo: TfrmTileInfo
Left = 290
Height = 59
Top = 171
Width = 250
HorzScrollBar.Page = 249
VertScrollBar.Page = 106
AutoSize = True
BorderIcons = []
BorderStyle = bsNone
Caption = 'Tile info'
ClientHeight = 59
ClientWidth = 250
Color = clInfoBk
Constraints.MinWidth = 250
Font.Color = clInfoText
FormStyle = fsStayOnTop
OnShow = FormShow
ShowInTaskBar = stNever
LCLVersion = '0.9.29'
object lblTileID: TLabel
Left = 8
Height = 16
Top = 26
Width = 234
Align = alTop
BorderSpacing.Left = 8
BorderSpacing.Top = 2
BorderSpacing.Right = 8
BorderSpacing.Bottom = 8
Font.Color = clInfoText
Font.Style = [fsItalic]
ParentColor = False
ParentFont = False
end
object lblFlags: TLabel
Left = 8
Height = 1
Top = 50
Width = 234
Align = alTop
BorderSpacing.Around = 8
Font.Color = clInfoText
ParentColor = False
ParentFont = False
WordWrap = True
end
object lblName: TLabel
Left = 8
Height = 16
Top = 8
Width = 234
Align = alTop
BorderSpacing.Left = 8
BorderSpacing.Top = 8
BorderSpacing.Right = 8
BorderSpacing.Bottom = 2
Font.Style = [fsBold]
ParentColor = False
ParentFont = False
end
object tmHide: TTimer
Enabled = False
Interval = 5000
OnTimer = tmHideTimer
left = 216
top = 8
end
end

170
Client/UfrmTileInfo.pas
View File

@ -1,170 +0,0 @@
(*
* 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 UfrmTileInfo;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
ExtCtrls, LCLIntf, LCLType, strutils;
type
{ TfrmTileInfo }
TfrmTileInfo = class(TForm)
lblName: TLabel;
lblFlags: TLabel;
lblTileID: TLabel;
tmHide: TTimer;
procedure FormShow(Sender: TObject);
procedure tmHideTimer(Sender: TObject);
private
{ private declarations }
public
procedure Update(ATileID: Word);
procedure Show(ATileID: Word); overload;
end;
var
frmTileInfo: TfrmTileInfo;
implementation
uses
UGameResources, UTiledata;
{ TfrmTileInfo }
procedure TfrmTileInfo.tmHideTimer(Sender: TObject);
begin
tmHide.Enabled := False;
Hide;
end;
procedure TfrmTileInfo.FormShow(Sender: TObject);
begin
tmHide.Enabled := True;
Left := Mouse.CursorPos.x + 8;
Top := Mouse.CursorPos.y + 8;
end;
procedure TfrmTileInfo.Update(ATileID: Word);
var
tileData: TTiledata;
prefix, flags: string;
procedure UpdateFlags(AFlag: TTileDataFlag; AName: string);
begin
if AFlag in tileData.Flags then
begin
if flags <> '' then
flags := flags + ', ' + AName
else
flags := AName;
end;
end;
begin
if Visible then
begin
Left := Mouse.CursorPos.x + 8;
Top := Mouse.CursorPos.y + 8;
end;
flags := '';
if ATileID < $4000 then
begin
tileData := ResMan.Tiledata.LandTiles[ATileID];
if TLandTiledata(tileData).TextureID > 0 then
flags := 'Stretchable';
end else
begin
Dec(ATileID, $4000);
tileData := ResMan.Tiledata.StaticTiles[ATileID];
end;
if tdfArticleA in tileData.Flags then
prefix := 'a '
else if tdfArticleAn in tileData.Flags then
prefix := 'an '
else
prefix := '';
lblName.Caption := AnsiProperCase(Format('%s%s', [prefix, tileData.TileName]), [' ']);
lblTileID.Caption := Format('Tile ID: $%x (%0:d)', [ATileID]);
UpdateFlags(tdfBackground, 'Background');
UpdateFlags(tdfWeapon, 'Weapon');
UpdateFlags(tdfTransparent, 'Transparent');
UpdateFlags(tdfTranslucent, 'Translucent');
UpdateFlags(tdfWall, 'Wall');
UpdateFlags(tdfDamaging, 'Damaging');
UpdateFlags(tdfImpassable, 'Impassable');
UpdateFlags(tdfWet, 'Wet');
UpdateFlags(tdfSurface, 'Surface');
UpdateFlags(tdfBridge, 'Bridge');
UpdateFlags(tdfGeneric, 'Generic');
UpdateFlags(tdfWindow, 'Window');
UpdateFlags(tdfNoShoot, 'NoShoot');
UpdateFlags(tdfInternal, 'Internal');
UpdateFlags(tdfFoliage, 'Foliage');
UpdateFlags(tdfPartialHue, 'PartialHue');
UpdateFlags(tdfMap, 'Map');
UpdateFlags(tdfContainer, 'Container');
UpdateFlags(tdfWearable, 'Wearable');
UpdateFlags(tdfLightSource, 'Lightsource');
UpdateFlags(tdfAnimation, 'Animation');
UpdateFlags(tdfNoDiagonal, 'NoDiagonal');
UpdateFlags(tdfArmor, 'Armor');
UpdateFlags(tdfRoof, 'Roof');
UpdateFlags(tdfDoor, 'Door');
UpdateFlags(tdfStairBack, 'StairBack');
UpdateFlags(tdfStairRight, 'StairRight');
lblFlags.Caption := Format('Flags = [%s]', [flags]);
if tmHide.Enabled then
begin
tmHide.Enabled := False;
tmHide.Enabled := True; //Refresh timer
end;
end;
procedure TfrmTileInfo.Show(ATileID: Word);
begin
Update(ATileID);
Show;
end;
initialization
{$I UfrmTileInfo.lrs}
end.