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

* Fixed compilation with FPC 3.1.1 and Lazarus 1.5

This commit is contained in:
Andreas Schneider 2015-05-01 12:48:35 +02:00
parent fe6b65844f
commit 58b24b35ec
6 changed files with 408 additions and 452 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Client/CentrED.lpr
View File

@ -36,7 +36,7 @@ uses
Forms, Dialogs, Windows, UdmNetwork, UResourceManager;
{$R CentrED.res}
{$R CentrED.manifest.rc}
//{$R CentrED.manifest.rc}
function GetApplicationName: String;
begin

444
Client/GUI/AeroGlass.pas
View File

@ -1,222 +1,222 @@
unit AeroGlass;
{$mode delphi}
//{$mode objfpc}{$H+}
interface
uses
//Windows, Forms, Graphics;
// os
Windows, UxTheme, ShellAPI, Win32Proc, Win32Extra,
// rtl
Classes, SysUtils,
// lcl
Forms, Controls, Graphics, Themes;//, LCLProc, LCLType;
type
_MARGINS = packed record
cxLeftWidth : Integer;
cxRightWidth : Integer;
cyTopHeight : Integer;
cyBottomHeight : Integer;
end;
PMargins = ^_MARGINS;
TMargins = _MARGINS;
DwmIsCompositionEnabledFunc = function(pfEnabled: PBoolean): HRESULT; stdcall;
DwmExtendFrameIntoClientAreaFunc = function(destWnd: HWND; const pMarInset: PMargins): HRESULT; stdcall;
SetLayeredWindowAttributesFunc = function(destWnd: HWND; cKey: TColor; bAlpha: Byte; dwFlags: DWord): BOOL; stdcall;
const
WS_EX_LAYERED = $80000;
LWA_COLORKEY = 1;
procedure GlassFormEx(frm: TForm; tmpMargins: TMargins; cBlurColorKey: TColor = clFuchsia);
procedure GlassForm(frm: TForm; cBlurColorKey: TColor = clFuchsia);
function WindowsAeroGlassCompatible: Boolean;
function CreateBitmap32(DC: HDC; W, H: Integer; var BitmapBits: Pointer): HBITMAP;
procedure DrawAlphaText(wnd: hwnd; DC: HDC; x,y: integer; txt: WideString);
implementation
// =============================================================================
// == Преобразование формы в AeroGlass
// =============================================================================
function WindowsAeroGlassCompatible: Boolean;
var
osVinfo: TOSVERSIONINFO;
begin
ZeroMemory(@osVinfo, SizeOf(osVinfo));
OsVinfo.dwOSVersionInfoSize := SizeOf(TOSVERSIONINFO);
if (
(GetVersionEx(osVInfo) = True) and
(osVinfo.dwPlatformId = VER_PLATFORM_WIN32_NT) and
(osVinfo.dwMajorVersion >= 6)
)
then Result:=True
else Result:=False;
end;
procedure GlassFormEx(frm: TForm; tmpMargins: TMargins; cBlurColorKey: TColor = clFuchsia);
var
hDwmDLL: Cardinal;
fDwmIsCompositionEnabled: DwmIsCompositionEnabledFunc;
fDwmExtendFrameIntoClientArea: DwmExtendFrameIntoClientAreaFunc;
fSetLayeredWindowAttributesFunc: SetLayeredWindowAttributesFunc;
bCmpEnable: Boolean;
mgn: TMargins;
begin
{ Continue if Windows version is compatible }
if WindowsAeroGlassCompatible then begin
{ Continue if 'dwmapi' library is loaded }
hDwmDLL := LoadLibrary('dwmapi.dll');
if hDwmDLL <> 0 then begin
{ Get values }
@fDwmIsCompositionEnabled := GetProcAddress(hDwmDLL, 'DwmIsCompositionEnabled');
@fDwmExtendFrameIntoClientArea := GetProcAddress(hDwmDLL, 'DwmExtendFrameIntoClientArea');
@fSetLayeredWindowAttributesFunc := GetProcAddress(GetModulehandle(user32), 'SetLayeredWindowAttributes');
{ Continue if values are <> nil }
if (
(@fDwmIsCompositionEnabled <> nil) and
(@fDwmExtendFrameIntoClientArea <> nil) and
(@fSetLayeredWindowAttributesFunc <> nil)
)
then begin
{ Continue if composition is enabled }
fDwmIsCompositionEnabled(@bCmpEnable);
if bCmpEnable = True then begin
{ Set Form Color same as cBlurColorKey }
frm.Color := cBlurColorKey;
{ ... }
SetWindowLong(frm.Handle, GWL_EXSTYLE, GetWindowLong(frm.Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
{ ... }
fSetLayeredWindowAttributesFunc(frm.Handle, cBlurColorKey, 0, LWA_COLORKEY);
{ Set margins }
ZeroMemory(@mgn, SizeOf(mgn));
mgn.cxLeftWidth := tmpMargins.cxLeftWidth;
mgn.cxRightWidth := tmpMargins.cxRightWidth;
mgn.cyTopHeight := tmpMargins.cyTopHeight;
mgn.cyBottomHeight := tmpMargins.cyBottomHeight;
{ Extend Form }
fDwmExtendFrameIntoClientArea(frm.Handle,@mgn);
end;
end;
{ Free loaded 'dwmapi' library }
FreeLibrary(hDWMDLL);
end;
end;
end;
procedure GlassForm(frm: TForm; cBlurColorKey: TColor = clFuchsia);
var
tmpMargins: TMargins;
begin
{ If all margins are -1 the whole form will be aero glass}
tmpMargins.cxLeftWidth := 8;
tmpMargins.cxRightWidth := 8;
tmpMargins.cyBottomHeight := 25;
tmpMargins.cyTopHeight := 4;
{ FormName ; Margins ; TransparentColor }
GlassFormEx(frm, tmpMargins, cBlurColorKey);
end;
// =============================================================================
// == Вывод текста и изображений на форме AeroGlass
// =============================================================================
function CreateBitmap32(DC: HDC; W, H: Integer; var BitmapBits: Pointer): HBITMAP;
var
bi: BITMAPINFO;
begin
ZeroMemory(@bi, sizeof(BITMAPINFO));
with bi.bmiHeader do
begin
biSize := sizeof(BITMAPINFOHEADER);
biWidth := W;
biHeight := -H;
biCompression := BI_RGB;
biBitCount := 32;
biPlanes := 1;
biXPelsPerMeter := 0;
biYPelsPerMeter := 0;
biClrUsed := 0;
biClrImportant := 0;
end;
Result := CreateDIBSection(DC, bi, DIB_RGB_COLORS, BitmapBits, 0, 0);
end;
type
TDTTOpts = record
dwSize: Longword;
dwFlags: Longword;
crText: Longword;
crBorder: Longword;
crShadow: Longword;
eTextShadowType: Integer;
ptShadowOffset: TPoint;
iBorderSize: Integer;
iFontPropId: Integer;
iColorPropId: Integer;
iStateId: Integer;
fApplyOverlay: Integer;
iGlowSize: Integer;
pfnDrawTextCallback: Pointer;
lParam: Integer;
end;
var
hTheme: THandle;
procedure DrawAlphaText(wnd: hwnd; DC: HDC; x,y: integer; txt: WideString);
var
tr: trect;
txtOptions: TDTTOPTS;
hBmp: HBITMAP;
hBmpDC: HDC;
hFnt: HFont;
p: pointer;
ts: SIZE;
begin
hTheme := OpenThemeData(wnd, 'window');
hBmpDC := CreateCompatibleDC(0);
hFnt := CreateFont(-MulDiv(10, GetDeviceCaps(hBmpDC, LOGPIXELSY), 72), 0, 0, 0, FW_BOLD {FW_NORMAL}, 0, 0, 0,
DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH, 'arial');
SelectObject(hBmpDC, hFnt);
GetTextExtentPointW(hBmpDC, PWideChar(txt), length(txt), ts);
SetRect(tr, 0, 0, ts.cx + 5, ts.cy + 5);
hBmp := CreateBitmap32(hBmpDC, tr.Right, tr.Bottom, p);
SelectObject(hBmpDC, hBmp);
ZeroMemory(@txtOptions, sizeof(TDTTOPTS));
txtOptions.dwSize := sizeof(TDTTOPTS);
txtOptions.dwFlags := DTT_COMPOSITED or DTT_GLOWSIZE or DTT_TEXTCOLOR;
txtOptions.iGlowSize := 5;
txtOptions.crText := $00FF0000;
DrawThemeTextEx(hTheme, hBmpDC, 0, 0, PWideChar(txt), length(txt), DT_SINGLELINE or DT_vCENTER, @tr, @txtOptions);
BitBlt(dc, x, y, tr.Right, tr.Bottom, hBmpDC, 0, 0, SRCCOPY);
DeleteObject(hBmpDC);
DeleteObject(hBmp);
DeleteObject(hFnt);
CloseThemeData(hTheme);
end;
end.
unit AeroGlass;
{$mode delphi}
//{$mode objfpc}{$H+}
interface
uses
//Windows, Forms, Graphics;
// os
Windows, UxTheme, ShellAPI, Win32Proc, Win32Extra,
// rtl
Classes, SysUtils,
// lcl
Forms, Controls, Graphics, Themes;//, LCLProc, LCLType;
type
_MARGINS = packed record
cxLeftWidth : Integer;
cxRightWidth : Integer;
cyTopHeight : Integer;
cyBottomHeight : Integer;
end;
PMargins = ^_MARGINS;
TMargins = _MARGINS;
DwmIsCompositionEnabledFunc = function(pfEnabled: PBoolean): HRESULT; stdcall;
DwmExtendFrameIntoClientAreaFunc = function(destWnd: HWND; const pMarInset: PMargins): HRESULT; stdcall;
SetLayeredWindowAttributesFunc = function(destWnd: HWND; cKey: TColor; bAlpha: Byte; dwFlags: DWord): BOOL; stdcall;
const
WS_EX_LAYERED = $80000;
LWA_COLORKEY = 1;
procedure GlassFormEx(frm: TForm; tmpMargins: TMargins; cBlurColorKey: TColor = clFuchsia);
procedure GlassForm(frm: TForm; cBlurColorKey: TColor = clFuchsia);
function WindowsAeroGlassCompatible: Boolean;
function CreateBitmap32(DC: HDC; W, H: Integer; var BitmapBits: Pointer): HBITMAP;
procedure DrawAlphaText(wnd: hwnd; DC: HDC; x,y: integer; txt: WideString);
implementation
// =============================================================================
// == Преобразование формы в AeroGlass
// =============================================================================
function WindowsAeroGlassCompatible: Boolean;
var
osVinfo: TOSVERSIONINFO;
begin
ZeroMemory(@osVinfo, SizeOf(osVinfo));
OsVinfo.dwOSVersionInfoSize := SizeOf(TOSVERSIONINFO);
if (
(GetVersionEx(osVInfo) = True) and
(osVinfo.dwPlatformId = VER_PLATFORM_WIN32_NT) and
(osVinfo.dwMajorVersion >= 6)
)
then Result:=True
else Result:=False;
end;
procedure GlassFormEx(frm: TForm; tmpMargins: TMargins; cBlurColorKey: TColor = clFuchsia);
var
hDwmDLL: Cardinal;
fDwmIsCompositionEnabled: DwmIsCompositionEnabledFunc;
fDwmExtendFrameIntoClientArea: DwmExtendFrameIntoClientAreaFunc;
fSetLayeredWindowAttributesFunc: SetLayeredWindowAttributesFunc;
bCmpEnable: Boolean;
mgn: TMargins;
begin
{ Continue if Windows version is compatible }
if WindowsAeroGlassCompatible then begin
{ Continue if 'dwmapi' library is loaded }
hDwmDLL := LoadLibrary('dwmapi.dll');
if hDwmDLL <> 0 then begin
{ Get values }
@fDwmIsCompositionEnabled := GetProcAddress(hDwmDLL, 'DwmIsCompositionEnabled');
@fDwmExtendFrameIntoClientArea := GetProcAddress(hDwmDLL, 'DwmExtendFrameIntoClientArea');
@fSetLayeredWindowAttributesFunc := GetProcAddress(GetModulehandle(user32), 'SetLayeredWindowAttributes');
{ Continue if values are <> nil }
if (
(@fDwmIsCompositionEnabled <> nil) and
(@fDwmExtendFrameIntoClientArea <> nil) and
(@fSetLayeredWindowAttributesFunc <> nil)
)
then begin
{ Continue if composition is enabled }
fDwmIsCompositionEnabled(@bCmpEnable);
if bCmpEnable = True then begin
{ Set Form Color same as cBlurColorKey }
frm.Color := cBlurColorKey;
{ ... }
SetWindowLong(frm.Handle, GWL_EXSTYLE, GetWindowLong(frm.Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
{ ... }
fSetLayeredWindowAttributesFunc(frm.Handle, cBlurColorKey, 0, LWA_COLORKEY);
{ Set margins }
ZeroMemory(@mgn, SizeOf(mgn));
mgn.cxLeftWidth := tmpMargins.cxLeftWidth;
mgn.cxRightWidth := tmpMargins.cxRightWidth;
mgn.cyTopHeight := tmpMargins.cyTopHeight;
mgn.cyBottomHeight := tmpMargins.cyBottomHeight;
{ Extend Form }
fDwmExtendFrameIntoClientArea(frm.Handle,@mgn);
end;
end;
{ Free loaded 'dwmapi' library }
FreeLibrary(hDWMDLL);
end;
end;
end;
procedure GlassForm(frm: TForm; cBlurColorKey: TColor = clFuchsia);
var
tmpMargins: TMargins;
begin
{ If all margins are -1 the whole form will be aero glass}
tmpMargins.cxLeftWidth := 8;
tmpMargins.cxRightWidth := 8;
tmpMargins.cyBottomHeight := 25;
tmpMargins.cyTopHeight := 4;
{ FormName ; Margins ; TransparentColor }
GlassFormEx(frm, tmpMargins, cBlurColorKey);
end;
// =============================================================================
// == Вывод текста и изображений на форме AeroGlass
// =============================================================================
function CreateBitmap32(DC: HDC; W, H: Integer; var BitmapBits: Pointer): HBITMAP;
var
bi: BITMAPINFO;
begin
ZeroMemory(@bi, sizeof(BITMAPINFO));
with bi.bmiHeader do
begin
biSize := sizeof(BITMAPINFOHEADER);
biWidth := W;
biHeight := -H;
biCompression := BI_RGB;
biBitCount := 32;
biPlanes := 1;
biXPelsPerMeter := 0;
biYPelsPerMeter := 0;
biClrUsed := 0;
biClrImportant := 0;
end;
Result := CreateDIBSection(DC, bi, DIB_RGB_COLORS, BitmapBits, 0, 0);
end;
type
TDTTOpts = record
dwSize: Longword;
dwFlags: Longword;
crText: Longword;
crBorder: Longword;
crShadow: Longword;
eTextShadowType: Integer;
ptShadowOffset: TPoint;
iBorderSize: Integer;
iFontPropId: Integer;
iColorPropId: Integer;
iStateId: Integer;
fApplyOverlay: Integer;
iGlowSize: Integer;
pfnDrawTextCallback: Pointer;
lParam: Integer;
end;
var
hTheme: THandle;
procedure DrawAlphaText(wnd: hwnd; DC: HDC; x,y: integer; txt: WideString);
var
tr: trect;
txtOptions: TDTTOPTS;
hBmp: HBITMAP;
hBmpDC: HDC;
hFnt: HFont;
p: pointer;
ts: SIZE;
begin
hTheme := OpenThemeData(wnd, 'window');
hBmpDC := CreateCompatibleDC(0);
hFnt := CreateFont(-MulDiv(10, GetDeviceCaps(hBmpDC, LOGPIXELSY), 72), 0, 0, 0, FW_BOLD {FW_NORMAL}, 0, 0, 0,
DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH, 'arial');
SelectObject(hBmpDC, hFnt);
GetTextExtentPointW(hBmpDC, PWideChar(txt), length(txt), ts);
SetRect(tr, 0, 0, ts.cx + 5, ts.cy + 5);
hBmp := CreateBitmap32(hBmpDC, tr.Right, tr.Bottom, p);
SelectObject(hBmpDC, hBmp);
ZeroMemory(@txtOptions, sizeof(TDTTOPTS));
txtOptions.dwSize := sizeof(TDTTOPTS);
txtOptions.dwFlags := DTT_COMPOSITED or DTT_GLOWSIZE or DTT_TEXTCOLOR;
txtOptions.iGlowSize := 5;
txtOptions.crText := $00FF0000;
DrawThemeTextEx(hTheme, hBmpDC, 0, 0, PWideChar(txt), length(txt), DT_SINGLELINE or DT_vCENTER, @tr, @txtOptions);
BitBlt(dc, x, y, tr.Right, tr.Bottom, hBmpDC, 0, 0, SRCCOPY);
DeleteObject(hBmpDC);
DeleteObject(hBmp);
DeleteObject(hFnt);
CloseThemeData(hTheme);
end;
end.

8
Client/GUI/VirtualList.pas
View File

@ -28,6 +28,8 @@ type
Selected: Boolean;
end;
{ TVirtualList }
TVirtualList = class(TVirtualDrawTree)
private
@ -75,7 +77,7 @@ type
procedure HandleMouseDblClick(var Message: TLMMouse; const HitInfo: THitInfo); override;
procedure HandleMouseDown(var Message: TLMMouse; var HitInfo: THitInfo); override;
procedure HandleMouseUp(var Message: TLMMouse; const HitInfo: THitInfo); override;
procedure HandleMouseUp(Keys: PtrUInt; const HitInfo: THitInfo); override;
property SelectedCount: Dword read FSelectionCount;
property TilesCount: Dword read FTilesCount;
@ -690,10 +692,10 @@ begin
end;
procedure TVirtualList.HandleMouseUp(var Message: TLMMouse; const HitInfo: THitInfo);
procedure TVirtualList.HandleMouseUp(Keys: PtrUInt; const HitInfo: THitInfo);
begin
//Logger.Send([lcClient, lcDebug], 'TVirtualTree.HandleMouseUp %s', ['Start']);
inherited HandleMouseUp(Message, HitInfo);
inherited HandleMouseUp(Keys, HitInfo);
end;
//----------------------------------------------------------------------------------------------------------------------

132
Client/UfrmMain.lfm
View File

@ -1,10 +1,10 @@
object frmMain: TfrmMain
Left = 294
Left = 290
Height = 680
Top = 123
Width = 982
Caption = 'UO CentrED+'
ClientHeight = 660
ClientHeight = 659
ClientWidth = 982
Constraints.MinHeight = 680
Constraints.MinWidth = 980
@ -18,24 +18,23 @@ object frmMain: TfrmMain
OnShow = FormShow
OnWindowStateChange = FormWindowStateChange
SessionProperties = 'acFlat.Checked;acLightlevel.Tag;acNoDraw.Checked;acStatics.Checked;acTerrain.Checked;acWalkable.Checked;cbStatics.Checked;cbTerrain.Checked;Height;Left;mnuAutoHideGroupList.Checked;mnuAutoHideGroupList.Tag;mnuAutoHideRandomList.Checked;mnuAutoHideRandomList.Tag;mnuAutoShowFilterWindow.Checked;mnuCompactHueSettings.Checked;mnuFlatShowHeight.Checked;mnuMiscTileListCentre.Checked;mnuMiscTileListClip.Checked;mnuMiscTileListDrawInfo.Checked;mnuMiscTileListLarge.Checked;mnuMiscTileListMidle.Checked;mnuMiscTileListSmall.Checked;mnuMiscTileListStretch.Checked;mnuMiscTileListTable.Checked;mnuSecurityQuestion.Checked;mnuShowAnimations.Checked;mnuShowBlocks.Checked;mnuShowBridges.Checked;mnuShowFoliage.Checked;mnuShowGrid.Checked;mnuShowLightSource.Checked;mnuShowNoDrawTiles.Checked;mnuShowRoofs.Checked;mnuShowSurfaces.Checked;mnuShowWalls.Checked;mnuShowWater.Checked;mnuTileListCentre.Checked;mnuTileListClip.Checked;mnuTileListDrawInfo.Checked;mnuTileListLarge.Checked;mnuTileListMidle.Checked;mnuTileListSmall.Checked;mnuTileListStretch.Checked;mnuTileListTable.Checked;mnuWhiteBackground.Checked;mnuWindowedMode.Checked;mnuWindowedMode.Tag;pcLeft.TabIndex;spGroupList.Top;spTileList.Top;Tag;Top;Width;WindowState;mnuMiscTileListDrawInfo.Enabled;mnuTileListDrawInfo.Enabled'
LCLVersion = '0.9.30.2'
LCLVersion = '1.5'
WindowState = wsMaximized
object pcLeft: TPageControl
Cursor = crArrow
Left = 0
Height = 660
Height = 659
Top = 0
Width = 224
ActivePage = tsTiles
Align = alLeft
TabIndex = 0
TabOrder = 0
OnChange = pcLeftChange
OnResize = pcLeftResize
object tsTiles: TTabSheet
Caption = ' Тайлы '
ClientHeight = 634
ClientWidth = 216
ClientHeight = 632
ClientWidth = 220
object vdtTiles: TVirtualDrawTree
Tag = -1
AnchorSideLeft.Control = tsTiles
@ -47,8 +46,8 @@ object frmMain: TfrmMain
Left = 0
Height = 64
Hint = '-'
Top = 295
Width = 213
Top = 293
Width = 217
Anchors = [akTop, akLeft, akRight, akBottom]
BorderSpacing.Top = 1
BorderSpacing.Right = 3
@ -193,7 +192,7 @@ object frmMain: TfrmMain
Left = 0
Height = 5
Top = 290
Width = 216
Width = 220
Align = alNone
Anchors = [akTop, akLeft, akRight]
OnMoved = spTileListMoved
@ -204,10 +203,10 @@ object frmMain: TfrmMain
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = tsTiles
Cursor = crArrow
Left = 79
Height = 14
Left = 92
Height = 13
Top = 0
Width = 85
Width = 97
BorderSpacing.Left = 16
Caption = 'Фильтр / Поиск:'
ParentColor = False
@ -220,15 +219,15 @@ object frmMain: TfrmMain
AnchorSideBottom.Control = tsTiles
Cursor = crArrow
Left = 0
Height = 339
Height = 337
Top = 295
Width = 216
Width = 220
Align = alBottom
Anchors = [akTop, akLeft, akRight, akBottom]
BidiMode = bdRightToLeft
Caption = 'Набор случайных тайлов'
ClientHeight = 321
ClientWidth = 212
ClientHeight = 323
ClientWidth = 218
Constraints.MinHeight = 1
ParentBidiMode = False
ParentColor = False
@ -279,7 +278,6 @@ object frmMain: TfrmMain
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00
}
NumGlyphs = 0
OnClick = btnAddRandomClick
ShowCaption = False
ShowHint = True
@ -333,7 +331,6 @@ object frmMain: TfrmMain
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00
}
NumGlyphs = 0
OnClick = btnDeleteRandomClick
ShowCaption = False
ShowHint = True
@ -388,7 +385,6 @@ object frmMain: TfrmMain
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00
}
NumGlyphs = 0
OnClick = btnClearRandomClick
ShowCaption = False
ShowHint = True
@ -399,10 +395,10 @@ object frmMain: TfrmMain
AnchorSideTop.Control = cbRandomPreset
AnchorSideRight.Control = btnRandomPresetDelete
Cursor = crArrow
Left = 162
Left = 168
Height = 22
Hint = 'Сохранить набор'
Top = 296
Top = 294
Width = 22
Anchors = [akTop, akRight]
BorderSpacing.Right = 4
@ -442,7 +438,6 @@ object frmMain: TfrmMain
4DFFC88C4FFFC88C4FFFC88C4FFFC88D4FFFC98C4FFFC78B4FFFC5894BFFC476
3BFF000000000000000000000000000000000000000000000000
}
NumGlyphs = 0
OnClick = btnRandomPresetSaveClick
ShowCaption = False
ShowHint = True
@ -454,10 +449,10 @@ object frmMain: TfrmMain
AnchorSideRight.Control = vdtRandom
AnchorSideRight.Side = asrBottom
Cursor = crArrow
Left = 188
Left = 194
Height = 22
Hint = 'Удалить набор'
Top = 296
Top = 294
Width = 22
Anchors = [akTop, akRight]
Glyph.Data = {
@ -496,7 +491,6 @@ object frmMain: TfrmMain
0000C88B4DFFC88C4FFFC88C4FFFC88C4FFFC88C4FFFC88D4FFFC98C4FFFC78B
4FFFC5894BFFC4763BFF00000000000000000000000000000000
}
NumGlyphs = 0
OnClick = btnRandomPresetDeleteClick
ShowCaption = False
ShowHint = True
@ -513,9 +507,9 @@ object frmMain: TfrmMain
AnchorSideBottom.Control = cbRandomPreset
Cursor = 63
Left = 2
Height = 272
Height = 270
Top = 20
Width = 208
Width = 214
Anchors = [akTop, akLeft, akRight, akBottom]
BorderSpacing.Left = 2
BorderSpacing.Top = 2
@ -628,7 +622,7 @@ object frmMain: TfrmMain
ScrollBarOptions.ScrollBars = ssVertical
TabOrder = 0
TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScroll, toAutoScrollOnExpand, toAutoTristateTracking, toAutoDeleteMovedNodes]
TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning]
TreeOptions.MiscOptions = [toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning]
TreeOptions.PaintOptions = [toHideFocusRect, toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages, toStaticBackground]
TreeOptions.SelectionOptions = [toFullRowSelect]
OnClick = vdtRandomClick
@ -647,13 +641,13 @@ object frmMain: TfrmMain
AnchorSideBottom.Side = asrBottom
Cursor = crArrow
Left = 2
Height = 21
Top = 296
Width = 156
Height = 25
Top = 294
Width = 162
Anchors = [akLeft, akRight, akBottom]
BorderSpacing.Right = 4
BorderSpacing.Bottom = 4
ItemHeight = 13
ItemHeight = 0
OnChange = cbRandomPresetChange
ParentBidiMode = False
Sorted = True
@ -666,9 +660,9 @@ object frmMain: TfrmMain
AnchorSideTop.Control = cbTerrain
Cursor = crArrow
Left = 4
Height = 19
Height = 24
Top = 18
Width = 62
Width = 76
BorderSpacing.Top = 16
Caption = 'Статика'
OnChange = cbStaticsChange
@ -679,9 +673,9 @@ object frmMain: TfrmMain
AnchorSideTop.Control = tsTiles
Cursor = crArrow
Left = 4
Height = 19
Height = 24
Top = 2
Width = 59
Width = 72
BorderSpacing.Left = 4
BorderSpacing.Top = 2
Caption = 'Рельеф'
@ -695,10 +689,10 @@ object frmMain: TfrmMain
AnchorSideRight.Control = tsTiles
AnchorSideRight.Side = asrBottom
Cursor = crIBeam
Left = 79
Height = 21
Top = 14
Width = 121
Left = 92
Height = 19
Top = 13
Width = 112
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Right = 16
OnEditingDone = edFilterEditingDone
@ -711,8 +705,8 @@ object frmMain: TfrmMain
Cursor = crVSplit
Left = 0
Height = 5
Top = 289
Width = 216
Top = 287
Width = 220
Align = alNone
Anchors = [akLeft, akRight, akBottom]
OnMoved = spGroupListMoved
@ -723,8 +717,8 @@ object frmMain: TfrmMain
AnchorSideRight.Side = asrBottom
AnchorSideBottom.Control = vdtTiles
AnchorSideBottom.Side = asrBottom
Left = 97
Height = 21
Left = 101
Height = 19
Hint = 'Append S or T to restrict the search to Statics or Terrain.'
Top = 330
Width = 96
@ -748,9 +742,9 @@ object frmMain: TfrmMain
AnchorSideBottom.Control = spGroupList
Cursor = crArrow
Left = 0
Height = 251
Top = 38
Width = 213
Height = 244
Top = 43
Width = 217
Anchors = [akTop, akLeft, akRight, akBottom]
BorderSpacing.Top = 1
BorderSpacing.Right = 3
@ -777,7 +771,7 @@ object frmMain: TfrmMain
SelectionCurveRadius = 8
TabOrder = 8
TextMargin = 0
TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toToggleOnDblClick, toWheelPanning]
TreeOptions.MiscOptions = [toFullRepaintOnResize, toToggleOnDblClick, toWheelPanning]
TreeOptions.PaintOptions = [toHideFocusRect, toShowButtons, toShowRoot, toShowTreeLines]
TreeOptions.SelectionOptions = [toFullRowSelect, toMultiSelect]
TreeOptions.StringOptions = []
@ -796,9 +790,8 @@ object frmMain: TfrmMain
end
object tsNavigation: TTabSheet
Caption = 'Навигация'
ClientHeight = 634
ClientWidth = 216
OnContextPopup = tsNavigationContextPopup
ClientHeight = 632
ClientWidth = 220
object gbGoTo: TGroupBox
AnchorSideLeft.Control = tsNavigation
AnchorSideTop.Control = btnDeleteLocation
@ -816,8 +809,8 @@ object frmMain: TfrmMain
BidiMode = bdRightToLeft
BorderSpacing.Bottom = 4
Caption = 'Быстрый переход'
ClientHeight = 34
ClientWidth = 212
ClientHeight = 38
ClientWidth = 214
ParentBidiMode = False
ParentColor = False
TabOrder = 1
@ -946,7 +939,6 @@ object frmMain: TfrmMain
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00
}
NumGlyphs = 0
OnClick = btnAddLocationClick
ShowCaption = False
ShowHint = True
@ -1000,7 +992,6 @@ object frmMain: TfrmMain
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00
}
NumGlyphs = 0
OnClick = btnDeleteLocationClick
ShowCaption = False
ShowHint = True
@ -1054,7 +1045,6 @@ object frmMain: TfrmMain
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00
}
NumGlyphs = 0
OnClick = btnClearLocationsClick
ShowCaption = False
ShowHint = True
@ -1239,6 +1229,7 @@ object frmMain: TfrmMain
object tbSeparator1: TToolButton
Cursor = crArrow
Left = 24
Height = 22
Top = 2
Width = 4
Style = tbsDivider
@ -1373,6 +1364,7 @@ object frmMain: TfrmMain
object tbSeparator3: TToolButton
Cursor = crArrow
Left = 124
Height = 22
Top = 2
Width = 4
Caption = 'tbSeparator3'
@ -1391,6 +1383,7 @@ object frmMain: TfrmMain
object tbSeparator4: TToolButton
Cursor = crArrow
Left = 583
Height = 22
Top = 2
Width = 4
Caption = 'tbSeparator4'
@ -1415,6 +1408,7 @@ object frmMain: TfrmMain
object tbSeparator5: TToolButton
Cursor = crArrow
Left = 645
Height = 22
Top = 2
Width = 4
Caption = 'tbSeparator5'
@ -1472,6 +1466,7 @@ object frmMain: TfrmMain
object tbSeparator2: TToolButton
Cursor = crArrow
Left = 293
Height = 22
Top = 2
Width = 4
Caption = 'tbSeparator2'
@ -1524,6 +1519,7 @@ object frmMain: TfrmMain
object tbSeparator6: TToolButton
Cursor = crArrow
Left = 197
Height = 22
Top = 2
Width = 4
Caption = 'tbSeparator2'
@ -1533,6 +1529,7 @@ object frmMain: TfrmMain
object tbSeparator7: TToolButton
Cursor = crArrow
Left = 51
Height = 22
Top = 2
Width = 4
Caption = 'tbSeparator2'
@ -1541,6 +1538,7 @@ object frmMain: TfrmMain
object tbSeparator8: TToolButton
Cursor = crArrow
Left = 521
Height = 22
Top = 2
Width = 4
Caption = 'tbSeparator2'
@ -1549,6 +1547,7 @@ object frmMain: TfrmMain
object tbSeparator9: TToolButton
Cursor = crArrow
Left = 343
Height = 22
Top = 2
Width = 4
Caption = 'tbSeparator2'
@ -1564,7 +1563,7 @@ object frmMain: TfrmMain
Cursor = crArrow
Left = 224
Height = 20
Top = 495
Top = 494
Width = 758
Anchors = [akLeft, akRight, akBottom]
BevelInner = bvRaised
@ -1577,7 +1576,7 @@ object frmMain: TfrmMain
Left = 10
Height = 16
Top = 2
Width = 95
Width = 106
Align = alLeft
BorderSpacing.Left = 8
Caption = 'Чат и Сообщения'
@ -1907,7 +1906,7 @@ object frmMain: TfrmMain
AnchorSideBottom.Side = asrBottom
Left = 224
Height = 140
Top = 520
Top = 519
Width = 758
Anchors = [akTop, akLeft, akRight, akBottom]
BevelOuter = bvNone
@ -1918,7 +1917,7 @@ object frmMain: TfrmMain
object vstChat: TVirtualStringTree
Cursor = 63
Left = 0
Height = 119
Height = 121
Top = 0
Width = 758
Align = alClient
@ -1948,7 +1947,7 @@ object frmMain: TfrmMain
item
Position = 2
Text = 'Сообщение'
Width = 604
Width = 606
end>
Header.DefaultHeight = 17
Header.MainColumn = 2
@ -1967,8 +1966,8 @@ object frmMain: TfrmMain
object edChat: TEdit
Cursor = crIBeam
Left = 0
Height = 21
Top = 119
Height = 19
Top = 121
Width = 758
Align = alBottom
Anchors = [akLeft, akRight]
@ -1982,7 +1981,7 @@ object frmMain: TfrmMain
Cursor = crVSplit
Left = 222
Height = 5
Top = 515
Top = 514
Width = 760
Align = alCustom
Anchors = [akLeft, akRight, akBottom]
@ -2001,11 +2000,10 @@ object frmMain: TfrmMain
AnchorSideRight.Side = asrBottom
AnchorSideBottom.Control = pnlChatHeader
Left = 224
Height = 471
Height = 470
Top = 24
Width = 758
Anchors = [akTop, akLeft, akRight, akBottom]
OnClick = oglGameWindowClick
OnDblClick = oglGameWindowDblClick
OnKeyDown = oglGameWindowKeyDown
OnMouseDown = oglGameWindowMouseDown

270
Client/UfrmMain.pas
View File

@ -469,7 +469,6 @@ type
procedure acUndoExecute(Sender: TObject);
procedure acVirtualLayerExecute(Sender: TObject);
procedure acWalkableExecute(Sender: TObject);
procedure acGridExecute(Sender: TObject);
procedure ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
procedure ApplicationProperties1ShowHint(var HintStr: string;
var CanShow: Boolean; var HintInfo: THintInfo);
@ -504,8 +503,6 @@ type
procedure mnuAccountControlClick(Sender: TObject);
procedure mnuAutoHideGroupListClick(Sender: TObject);
procedure mnuAutoHideRandomListClick(Sender: TObject);
procedure mnuAutoShowFilterWindowClick(Sender: TObject);
procedure mnuCompactHueSettingsClick(Sender: TObject);
procedure mnuDisconnectClick(Sender: TObject);
procedure mnuDocsClick(Sender: TObject);
procedure mnuEng2ComClick(Sender: TObject);
@ -528,7 +525,6 @@ type
procedure mnuSetLanguageClick(Sender: TObject);
procedure mnuShowAnimationsClick(Sender: TObject);
procedure mnuShowBlocksClick(Sender: TObject);
procedure mnuShowBridgesClick(Sender: TObject);
procedure mnuShowGridClick(Sender: TObject);
procedure mnuShowLightSourceClick(Sender: TObject);
procedure mnuShowNoDrawTilesClick(Sender: TObject);
@ -539,7 +535,6 @@ type
procedure mnuWhiteBackgroundClick(Sender: TObject);
procedure mnuWindowedModeClick(Sender: TObject);
procedure mnuZoomClick(Sender: TObject);
procedure oglGameWindowClick(Sender: TObject);
procedure oglGameWindowDblClick(Sender: TObject);
procedure oglGameWindowKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
@ -558,7 +553,6 @@ type
procedure pbRadarMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure pbRadarPaint(Sender: TObject);
procedure pcLeftChange(Sender: TObject);
procedure pcLeftResize(Sender: TObject);
procedure pmGrabTileInfoPopup(Sender: TObject);
procedure DropedownMenusClose(Sender: TObject);
@ -573,8 +567,6 @@ type
procedure tmMovementTimer(Sender: TObject);
procedure tmSelectNodeTimer(Sender: TObject);
procedure tmSettingsCloseTimer(Sender: TObject);
procedure tsNavigationContextPopup(Sender: TObject; MousePos: TPoint;
var Handled: Boolean);
procedure tvGroupFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
procedure tvGroupsChange(Sender: TBaseVirtualTree; Node: PVirtualNode);
procedure tvGroupsDrawText(Sender: TBaseVirtualTree; TargetCanvas: TCanvas;
@ -1073,11 +1065,6 @@ begin
RebuildScreenBuffer;
end;
procedure TfrmMain.mnuShowBridgesClick(Sender: TObject);
begin
end;
procedure TfrmMain.mnuShutdownClick(Sender: TObject);
begin
dmNetwork.Send(TQuitServerPacket.Create(''));
@ -1164,11 +1151,6 @@ begin
RebuildScreenBuffer;
end;
procedure TfrmMain.oglGameWindowClick(Sender: TObject);
begin
end;
procedure TfrmMain.oglGameWindowDblClick(Sender: TObject);
begin
if (acSelect.Checked) and (CurrentTile <> nil) then
@ -1299,7 +1281,7 @@ var
blockInfo: PBlockInfo;
targetRect: TRect;
offsetX, offsetY: Integer;
tile: TWorldItem;
item: TWorldItem;
tileX, tileY, newX, newY: Word;
targetBlocks: TBlockInfoList; //а в чем разница с targetTiles: TWorldItemList; ?
targetTile: TWorldItem;
@ -1357,11 +1339,11 @@ begin
Logger.Send([lcClient, lcDebug], 'Virtual tiles', FVirtualTiles.Count);
for i := 0 to FVirtualTiles.Count - 1 do
begin
tile := FVirtualTiles[i];
if tile is TGhostTile then
item := FVirtualTiles[i];
if item is TGhostTile then
begin
dmNetwork.Send(TInsertStaticPacket.Create(tile.X, tile.Y, tile.Z, tile.TileID, TGhostTile(tile).Hue));
FUndoList^.Add(TDeleteStaticPacket.Create(TGhostTile(tile)));
dmNetwork.Send(TInsertStaticPacket.Create(item.X, item.Y, item.Z, item.TileID, TGhostTile(item).Hue));
FUndoList^.Add(TDeleteStaticPacket.Create(TGhostTile(item)));
end;
end;
end else if (SelectedTile <> targetTile) or targetTile.CanBeEdited then
@ -1395,7 +1377,7 @@ begin
end;
end;
if acMove.Checked then //***** Move tile *****//
if acMove.Checked then //***** Move item *****//
begin
offsetX := frmMoveSettings.GetOffsetX;
offsetY := frmMoveSettings.GetOffsetY;
@ -1423,81 +1405,81 @@ begin
begin
if frmMoveSettings.cbLand.Checked and (((offsetY > 0) or (offsetX > 0)) and not ((offsetY > 0) and (offsetX < 0)))
then tileY := abs(i - targetBlocks.Count + 1) else tileY := i;
tile := targetBlocks.Items[tileY]^.Item;
item := targetBlocks.Items[tileY]^.Item;
if (frmMoveSettings.cbItem.Checked) and (tile is TStaticItem) then begin
newX := EnsureRange(tile.X + offsetX, 0, FLandscape.CellWidth - 1);
newY := EnsureRange(tile.Y + offsetY, 0, FLandscape.CellHeight - 1);
FUndoList^.Add(TMoveStaticPacket.Create(newX, newY, tile.Z, tile.TileID, TStaticItem(tile).Hue, tile.X, tile.Y));
dmNetwork.Send(TMoveStaticPacket.Create(TStaticItem(tile), newX, newY));
if (frmMoveSettings.cbItem.Checked) and (item is TStaticItem) then begin
newX := EnsureRange(item.X + offsetX, 0, FLandscape.CellWidth - 1);
newY := EnsureRange(item.Y + offsetY, 0, FLandscape.CellHeight - 1);
FUndoList^.Add(TMoveStaticPacket.Create(newX, newY, item.Z, item.TileID, TStaticItem(item).Hue, item.X, item.Y));
dmNetwork.Send(TMoveStaticPacket.Create(TStaticItem(item), newX, newY));
end;
if (frmMoveSettings.cbLand.Checked) and (tile is TMapCell) then begin
newX := EnsureRange(tile.X + offsetX, 0, FLandscape.CellWidth - 1);
newY := EnsureRange(tile.Y + offsetY, 0, FLandscape.CellHeight - 1);
if (frmMoveSettings.cbLand.Checked) and (item is TMapCell) then begin
newX := EnsureRange(item.X + offsetX, 0, FLandscape.CellWidth - 1);
newY := EnsureRange(item.Y + offsetY, 0, FLandscape.CellHeight - 1);
map := FLandscape.MapCell[newX, newY];
// Это не очень хорошо, для оптимизации следует ввести специальный пакет TMoveMapPacket
FUndoList^.Add(TDrawMapPacket.Create(tile.X, tile.Y, tile.Z, tile.TileID));
FUndoList^.Add(TDrawMapPacket.Create(item.X, item.Y, item.Z, item.TileID));
FUndoList^.Add(TDrawMapPacket.Create(newX, newY, map.RawZ, map.TileID));
dmNetwork.Send(TDrawMapPacket.Create(tile.X, tile.Y, z, $0001));
dmNetwork.Send(TDrawMapPacket.Create(newX, newY, tile.Z, tile.TileID));
dmNetwork.Send(TDrawMapPacket.Create(item.X, item.Y, z, $0001));
dmNetwork.Send(TDrawMapPacket.Create(newX, newY, item.Z, item.TileID));
end;
end;
end else if acElevate.Checked then //***** Elevate tile *****//
end else if acElevate.Checked then //***** Elevate item *****//
begin
for i := 0 to targetBlocks.Count - 1 do
begin
tile := targetBlocks.Items[i]^.Item;
item := targetBlocks.Items[i]^.Item;
z := frmElevateSettings.seZ.Value;
if frmElevateSettings.rbRaise.Checked then
z := EnsureRange(tile.Z + z, -128, 127)
z := EnsureRange(item.Z + z, -128, 127)
else if frmElevateSettings.rbLower.Checked then
z := EnsureRange(tile.Z - z, -128, 127);
z := EnsureRange(item.Z - z, -128, 127);
if tile is TMapCell then
if item is TMapCell then
begin
if frmElevateSettings.cbRandomHeight.Checked then
Inc(z, Random(frmElevateSettings.seRandomHeight.Value));
FUndoList^.Add(TDrawMapPacket.Create(tile.X, tile.Y, tile.Z,
tile.TileID));
dmNetwork.Send(TDrawMapPacket.Create(tile.X, tile.Y, z,
tile.TileID));
FUndoList^.Add(TDrawMapPacket.Create(item.X, item.Y, item.Z,
item.TileID));
dmNetwork.Send(TDrawMapPacket.Create(item.X, item.Y, z,
item.TileID));
end else
begin
FUndoList^.Add(TElevateStaticPacket.Create(tile.X, tile.Y,
z, tile.TileID, TStaticItem(tile).Hue, tile.Z));
dmNetwork.Send(TElevateStaticPacket.Create(TStaticItem(tile), z));
FUndoList^.Add(TElevateStaticPacket.Create(item.X, item.Y,
z, item.TileID, TStaticItem(item).Hue, item.Z));
dmNetwork.Send(TElevateStaticPacket.Create(TStaticItem(item), z));
end;
end;
end else if acDelete.Checked then //***** Delete tile *****//
end else if acDelete.Checked then //***** Delete item *****//
begin
Logger.Send([lcClient, lcDebug], 'targetBlocks.Count', targetBlocks.Count);
for i := 0 to targetBlocks.Count - 1 do
begin
tile := targetBlocks.Items[i]^.Item;
if tile is TStaticItem then
item := targetBlocks.Items[i]^.Item;
if item is TStaticItem then
begin
FUndoList^.Add(TInsertStaticPacket.Create(tile.X, tile.Y,
tile.Z, tile.TileID, TStaticItem(tile).Hue));
dmNetwork.Send(TDeleteStaticPacket.Create(TStaticItem(tile)));
FUndoList^.Add(TInsertStaticPacket.Create(item.X, item.Y,
item.Z, item.TileID, TStaticItem(item).Hue));
dmNetwork.Send(TDeleteStaticPacket.Create(TStaticItem(item)));
end;
end;
end else if acHue.Checked then //***** Hue tile *****//
end else if acHue.Checked then //***** Hue item *****//
begin
for i := 0 to targetBlocks.Count - 1 do
begin
blockInfo := targetBlocks.Items[i];
tile := blockInfo^.Item;
item := blockInfo^.Item;
if blockInfo^.HueOverride and (tile is TStaticItem) then
if blockInfo^.HueOverride and (item is TStaticItem) then
begin
if TStaticItem(tile).Hue <> blockInfo^.Hue then
if TStaticItem(item).Hue <> blockInfo^.Hue then
begin
FUndoList^.Add(THueStaticPacket.Create(tile.X, tile.Y, tile.Z,
tile.TileID, blockInfo^.Hue, TStaticItem(tile).Hue));
dmNetwork.Send(THueStaticPacket.Create(TStaticItem(tile),
FUndoList^.Add(THueStaticPacket.Create(item.X, item.Y, item.Z,
item.TileID, blockInfo^.Hue, TStaticItem(item).Hue));
dmNetwork.Send(THueStaticPacket.Create(TStaticItem(item),
blockInfo^.Hue));
end;
end;
@ -1823,7 +1805,7 @@ procedure TfrmMain.btnRandomPresetSaveClick(Sender: TObject);
var
presetName: string;
i: Integer;
preset, tile: TDOMElement;
presetElement, tileElement: TDOMElement;
children: TDOMNodeList;
tileNode: PVirtualItem;
tileInfo: PTileInfo;
@ -1831,31 +1813,31 @@ begin
presetName := cbRandomPreset.Text;
if InputQuery(lbDlgSaveRandPrsCaption, lbDlgSaveRandPrs, presetName) then
begin
preset := FindRandomPreset(presetName);
if preset = nil then
presetElement := FindRandomPreset(presetName);
if presetElement = nil then
begin
preset := FRandomPresetsDoc.CreateElement('Preset');
preset.AttribStrings['Name'] := UTF8ToCP1251(presetName);
FRandomPresetsDoc.DocumentElement.AppendChild(preset);
cbRandomPreset.Items.AddObject(presetName, preset);
presetElement := FRandomPresetsDoc.CreateElement('PresetElement');
presetElement.AttribStrings['Name'] := UTF8ToCP1251(presetName);
FRandomPresetsDoc.DocumentElement.AppendChild(presetElement);
cbRandomPreset.Items.AddObject(presetName, presetElement);
end else
begin
children := preset.ChildNodes;
children := presetElement.ChildNodes;
for i := children.Count - 1 downto 0 do
preset.RemoveChild(children[i]);
presetElement.RemoveChild(children[i]);
end;
tileNode := vdlRandom.GetFirst;
while tileNode <> nil do
begin
tileInfo := vdlRandom.GetNodeData(tileNode);
tile := FRandomPresetsDoc.CreateElement('Tile');
tile.AttribStrings['ID'] := IntToStr(tileInfo^.ID);
preset.AppendChild(tile);
tileElement := FRandomPresetsDoc.CreateElement('TileElement');
tileElement.AttribStrings['ID'] := IntToStr(tileInfo^.ID);
presetElement.AppendChild(tileElement);
tileNode := vdlRandom.GetNext(tileNode);
end;
cbRandomPreset.ItemIndex := cbRandomPreset.Items.IndexOfObject(preset);
cbRandomPreset.ItemIndex := cbRandomPreset.Items.IndexOfObject(presetElement);
SaveRandomPresets;
end;
@ -1863,7 +1845,7 @@ end;
procedure TfrmMain.cbRandomPresetChange(Sender: TObject);
var
preset, tile: TDOMElement;
presetElement, tileElement: TDOMElement;
tiles: TDOMNodeList;
tileNode: PVirtualItem;
tileInfo: PTileInfo;
@ -1872,13 +1854,13 @@ begin
if cbRandomPreset.ItemIndex > -1 then
begin
vdlRandom.Clear;
preset := TDOMElement(cbRandomPreset.Items.Objects[cbRandomPreset.ItemIndex]);
tiles := preset.ChildNodes;
presetElement := TDOMElement(cbRandomPreset.Items.Objects[cbRandomPreset.ItemIndex]);
tiles := presetElement.ChildNodes;
for i := 0 to tiles.Count - 1 do
begin
tile := TDOMElement(tiles[i]);
if (tile.NodeName = 'Tile') and
TryStrToInt(tile.AttribStrings['ID'], id) and
tileElement := TDOMElement(tiles[i]);
if (tileElement.NodeName = 'TileElement') and
TryStrToInt(tileElement.AttribStrings['ID'], id) and
(id < FLandscape.MaxStaticID + $4000) then
begin
tileNode := vdlRandom.AddItem(nil);
@ -2054,11 +2036,6 @@ begin
FRepaintNeeded := True;
end;
procedure TfrmMain.acGridExecute(Sender: TObject);
begin
end;
procedure TfrmMain.acDrawExecute(Sender: TObject);
begin
acDraw.Checked := True;
@ -2852,16 +2829,6 @@ begin
spTileListMoved(Sender);
end;
procedure TfrmMain.mnuAutoShowFilterWindowClick(Sender: TObject);
begin
end;
procedure TfrmMain.mnuCompactHueSettingsClick(Sender: TObject);
begin
end;
procedure TfrmMain.spGroupListMoved(Sender: TObject);
var
anchor: integer;
@ -3032,11 +2999,6 @@ begin
pbRadar.Canvas.Line(posX-scrW-1, posY+scrH+1, posX-scrW-1, posY-scrH-1);
end;
procedure TfrmMain.pcLeftChange(Sender: TObject);
begin
end;
procedure TfrmMain.pmGrabTileInfoPopup(Sender: TObject);
var
isStatic: Boolean;
@ -3085,12 +3047,6 @@ begin
tbFlat.Down := acFlat.Checked;
end;
procedure TfrmMain.tsNavigationContextPopup(Sender: TObject; MousePos: TPoint;
var Handled: Boolean);
begin
end;
procedure TfrmMain.FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
begin
if Sender is TWinControl then
@ -5613,7 +5569,7 @@ var
z, b, t, a, e, value: Integer;
uu, ur, ll, ul, dl, dr : Word;
valueF : Single;
tile: TBrushTile;
brushTile: TBrushTile;
// Создание миниатюр
id : Integer;
destColor, hue : Word;
@ -5681,7 +5637,7 @@ begin
FBrushList.Brush[b]^.ECount := 0;
while tNode <> nil do begin
s := LowerCase(tNode.NodeName);
if (s = 'tile') or (s = 'land') then
if (s = 'brushTile') or (s = 'land') then
inc(FBrushList.Brush[b]^.Count)
else if (s = 'edge') then
inc(FBrushList.Brush[b]^.ECount);
@ -5703,37 +5659,37 @@ begin
while tNode <> nil do
begin
s := LowerCase(tNode.NodeName);
if (s = 'tile') or (s = 'land') then begin
if (s = 'brushTile') or (s = 'land') then begin
//Logger.Send([lcInfo], 'Brush: %d - Land: %d / %d', [b+1, t+1, FBrushList.Brush[b]^.Count]);
tile.ID := $FFFF;
tile.Chance := 1.0;
brushTile.ID := $FFFF;
brushTile.Chance := 1.0;
for a := tNode.Attributes.Length - 1 downto 0 do begin
attribute := LowerCase(tNode.Attributes[a].NodeName);
if attribute = 'id' then begin
if TryStrToInt(tNode.Attributes[a].NodeValue, value)
then tile.ID := value;
then brushTile.ID := value;
end else if attribute = 'chance' then begin
if TryStrToFloat(tNode.Attributes[a].NodeValue, valueF)
then tile.Chance := valueF;
then brushTile.Chance := valueF;
end;
end;
tile.Mask := $0F;
tile.Brush1 := FBrushList.Brush[b];
tile.Brush2 := FBrushList.Brush[b];
brushTile.Mask := $0F;
brushTile.Brush1 := FBrushList.Brush[b];
brushTile.Brush2 := FBrushList.Brush[b];
// Тестирование...
if LoadListError(tile.ID = $FFFF,
if LoadListError(brushTile.ID = $FFFF,
fPath, Format(GetParseErText('blTagTileAttrID'), [FBrushList.Brush[b]^.ID]))
then begin LoadBrushTilesList; Exit; end;
if LoadListError(tile.ID > $3FFF,
fPath, Format(GetParseErText('blTagTileAttrIDOutOfRange'), [tile.ID, tile.ID, FBrushList.Brush[b]^.ID]))
if LoadListError(brushTile.ID > $3FFF,
fPath, Format(GetParseErText('blTagTileAttrIDOutOfRange'), [brushTile.ID, brushTile.ID, FBrushList.Brush[b]^.ID]))
then begin LoadBrushTilesList; Exit; end;
if LoadListError(FBrushList.Tiles[tile.ID].ID = tile.ID,
fPath, Format(GetParseErText('blTagTileRedeclaration'), [tile.ID, tile.ID, FBrushList.Brush[b]^.ID]))
if LoadListError(FBrushList.Tiles[brushTile.ID].ID = brushTile.ID,
fPath, Format(GetParseErText('blTagTileRedeclaration'), [brushTile.ID, brushTile.ID, FBrushList.Brush[b]^.ID]))
then begin LoadBrushTilesList; Exit; end;
FBrushList.Tiles[tile.ID] := tile;
FBrushList.Brush[b]^.BTile[t] := @FBrushList.Tiles[tile.ID];
FBrushList.Tiles[brushTile.ID] := brushTile;
FBrushList.Brush[b]^.BTile[t] := @FBrushList.Tiles[brushTile.ID];
inc(t);
end else if (s = 'edge') then begin
//Logger.Send([lcInfo], 'Brush: %d - Edge: %d / %d', [b+1, e+1, FBrushList.Brush[b]^.ECount]);
@ -5762,7 +5718,7 @@ begin
FBrushList.Brush[b]^.BEdges[e]^.CountDR := 0;
while eNode <> nil do begin
s := LowerCase(eNode.NodeName);
if (s = 'tile') or (s = 'land') then begin
if (s = 'brushTile') or (s = 'land') then begin
attribute := '';
for a := eNode.Attributes.Length - 1 downto 0 do begin
attribute := LowerCase(eNode.Attributes[a].NodeName);
@ -5779,7 +5735,7 @@ begin
end;
if LoadListError((attribute<>'type') or ((s<>'uu')and(s<>'ur')and(s<>'ll')and(s<>'ul')and(s<>'dl')and(s<>'dr')),
fPath, Format(GetParseErText('blTagTile2AttrType'), [tile.ID, tile.ID, FBrushList.Brush[b]^.BEdges[e]^.ID, FBrushList.Brush[b]^.ID]))
fPath, Format(GetParseErText('blTagTile2AttrType'), [brushTile.ID, brushTile.ID, FBrushList.Brush[b]^.BEdges[e]^.ID, FBrushList.Brush[b]^.ID]))
then begin LoadBrushTilesList; Exit; end;
end;
eNode := eNode.NextSibling;
@ -5795,57 +5751,57 @@ begin
eNode := tNode.FirstChild;
while eNode <> nil do begin
s := LowerCase(eNode.NodeName);
if (s = 'tile') or (s = 'land') then begin
if (s = 'brushTile') or (s = 'land') then begin
//Logger.Send([lcInfo], 'Brush: %d - Edge: %d - Land: %d / %d', [b+1, e+1, uu+ur+ll+ul+dl+dr+1, FBrushList.Brush[b]^.BEdges[e]^.CountUU+FBrushList.Brush[b]^.BEdges[e]^.CountUR+FBrushList.Brush[b]^.BEdges[e]^.CountLL+FBrushList.Brush[b]^.BEdges[e]^.CountUL+FBrushList.Brush[b]^.BEdges[e]^.CountDL+FBrushList.Brush[b]^.BEdges[e]^.CountDR]);
tile.ID := $FFFF;
tile.Chance := 1.0;
brushTile.ID := $FFFF;
brushTile.Chance := 1.0;
for a := eNode.Attributes.Length - 1 downto 0 do begin
attribute := LowerCase(eNode.Attributes[a].NodeName);
if attribute = 'type' then begin
s := LowerCase(CP1251ToUTF8(eNode.Attributes[a].NodeValue));
if s = 'uu' then tile.Mask := $03
else if s = 'ur' then tile.Mask := $07
else if s = 'll' then tile.Mask := $09
else if s = 'ul' then tile.Mask := $0B
else if s = 'dl' then tile.Mask := $0D
else if s = 'dr' then tile.Mask := $0E;
if s = 'uu' then brushTile.Mask := $03
else if s = 'ur' then brushTile.Mask := $07
else if s = 'll' then brushTile.Mask := $09
else if s = 'ul' then brushTile.Mask := $0B
else if s = 'dl' then brushTile.Mask := $0D
else if s = 'dr' then brushTile.Mask := $0E;
end else if attribute = 'id' then begin
if TryStrToInt(eNode.Attributes[a].NodeValue, value)
then tile.ID := value;
then brushTile.ID := value;
end else if attribute = 'chance' then begin
if TryStrToFloat(eNode.Attributes[a].NodeValue, valueF)
then tile.Chance := valueF;
then brushTile.Chance := valueF;
end;
end;
// Тестирование...
if LoadListError(tile.ID = $FFFF,
if LoadListError(brushTile.ID = $FFFF,
fPath, Format(GetParseErText('blTagTile2AttrID'), [FBrushList.Brush[b]^.ID]))
then begin LoadBrushTilesList; Exit; end;
if LoadListError(tile.ID > $3FFF,
fPath, Format(GetParseErText('blTagTile2AttrIDOutOfRange'), [tile.ID, tile.ID, FBrushList.Brush[b]^.ID]))
if LoadListError(brushTile.ID > $3FFF,
fPath, Format(GetParseErText('blTagTile2AttrIDOutOfRange'), [brushTile.ID, brushTile.ID, FBrushList.Brush[b]^.ID]))
then begin LoadBrushTilesList; Exit; end;
if LoadListError(FBrushList.Tiles[tile.ID].ID = tile.ID,
fPath, Format(GetParseErText('blTagTile2Redeclaration'), [tile.ID, tile.ID, FBrushList.Brush[b]^.ID]))
if LoadListError(FBrushList.Tiles[brushTile.ID].ID = brushTile.ID,
fPath, Format(GetParseErText('blTagTile2Redeclaration'), [brushTile.ID, brushTile.ID, FBrushList.Brush[b]^.ID]))
then begin LoadBrushTilesList; Exit; end;
tile.Brush1 := FBrushList.Brush[b];
tile.Brush2 := nil;
FBrushList.Tiles[tile.ID] := tile;
if tile.Mask = $03 then begin
FBrushList.Brush[b]^.BEdges[e]^.BTileUU[uu] := @FBrushList.Tiles[tile.ID]; inc(uu);
end else if tile.Mask = $07 then begin
FBrushList.Brush[b]^.BEdges[e]^.BTileUR[ur] := @FBrushList.Tiles[tile.ID]; inc(ur);
end else if tile.Mask = $09 then begin
FBrushList.Brush[b]^.BEdges[e]^.BTileLL[ll] := @FBrushList.Tiles[tile.ID]; inc(ll);
end else if tile.Mask = $0B then begin
FBrushList.Brush[b]^.BEdges[e]^.BTileUL[ul] := @FBrushList.Tiles[tile.ID]; inc(ul);
end else if tile.Mask = $0D then begin
FBrushList.Brush[b]^.BEdges[e]^.BTileDL[dl] := @FBrushList.Tiles[tile.ID]; inc(dl);
end else if tile.Mask = $0E then begin
FBrushList.Brush[b]^.BEdges[e]^.BTileDR[dr] := @FBrushList.Tiles[tile.ID]; inc(dr);
brushTile.Brush1 := FBrushList.Brush[b];
brushTile.Brush2 := nil;
FBrushList.Tiles[brushTile.ID] := brushTile;
if brushTile.Mask = $03 then begin
FBrushList.Brush[b]^.BEdges[e]^.BTileUU[uu] := @FBrushList.Tiles[brushTile.ID]; inc(uu);
end else if brushTile.Mask = $07 then begin
FBrushList.Brush[b]^.BEdges[e]^.BTileUR[ur] := @FBrushList.Tiles[brushTile.ID]; inc(ur);
end else if brushTile.Mask = $09 then begin
FBrushList.Brush[b]^.BEdges[e]^.BTileLL[ll] := @FBrushList.Tiles[brushTile.ID]; inc(ll);
end else if brushTile.Mask = $0B then begin
FBrushList.Brush[b]^.BEdges[e]^.BTileUL[ul] := @FBrushList.Tiles[brushTile.ID]; inc(ul);
end else if brushTile.Mask = $0D then begin
FBrushList.Brush[b]^.BEdges[e]^.BTileDL[dl] := @FBrushList.Tiles[brushTile.ID]; inc(dl);
end else if brushTile.Mask = $0E then begin
FBrushList.Brush[b]^.BEdges[e]^.BTileDR[dr] := @FBrushList.Tiles[brushTile.ID]; inc(dr);
end;
FBrushList.Tiles[tile.ID].ID := FBrushList.Brush[b]^.BEdges[e]^.ID; // Временно запоминаем ID перехода (позже востанавливаем ID тайла)
FBrushList.Tiles[brushTile.ID].ID := FBrushList.Brush[b]^.BEdges[e]^.ID; // Временно запоминаем ID перехода (позже востанавливаем ID тайла)
end;
eNode := eNode.NextSibling;
end;

4
UCacheManager.pas
View File

@ -43,7 +43,7 @@ type
{ TCacheManager }
generic TCacheManager<T> = class
type public
public type
{ Types }
TRemoveObjectEvent = procedure(AObject: T) of object;
@ -53,7 +53,7 @@ type
Obj: T;
Next: PCacheEntry;
end;
var protected
protected
{ Members }
FSize: Integer;
FFirst: PCacheEntry;