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

7532 lines
270 KiB
Plaintext
Raw Normal View History

- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
(*
* 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 UfrmMain;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Menus,
ComCtrls, OpenGLContext, GL, GLu, UGameResources, ULandscape, ExtCtrls,
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
StdCtrls, Spin, UEnums, VirtualTrees, VirtualList, Buttons, math, UMulBlock,
UWorldItem, LCLIntf, UOverlayUI, UStatics, UEnhancedMemoryStream, ActnList,
XMLPropStorage, LazHelpHTML, fgl, ImagingClasses, dateutils, UPlatformTypes,
UMap, UPacket, UGLFont, DOM, XMLRead, XMLWrite, strutils, ULightManager,
UndoRedoCmd, ShellAPI, ImagingTypes, ImagingCanvases, types, Registry,
IniFiles, LMessages;
const
FVLightSrcImageCount = 15; // Количество иконок виртуальных источников
FUndoListLength = 64; // Количество элементов в списке отмены
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
type
TAccessChangedListener = procedure(AAccessLevel: TAccessLevel) of object;
TSelectionListener = procedure(AWorldItem: TWorldItem) of object;
TScreenBufferState = (sbsValid, sbsIndexed, sbsFiltered);
TScreenBufferStates = set of TScreenBufferState;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
TBlockInfoList = specialize TFPGList<PBlockInfo>;
TGhostTile = class(TStaticItem)
public
CenterX, CenterY: Word; // Точки привязки к курсору (центральный тайл для объектов размером больше 1 тайла)
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
TPacketList = specialize TFPGObjectList<TPacket>;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
PPacketList = ^TPacketList;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
TAccessChangedListeners = specialize TFPGList<TAccessChangedListener>;
TSelectionListeners = specialize TFPGList<TSelectionListener>;
TTileHintInfo = record
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
Column: Byte;
Obj: String;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
Name: String;
Flags: String;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
ObjRect: TRect;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
NameRect: TRect;
FlagsRect: TRect;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
TGroupTile = record
ID: LongWord;
end;
TEntryTile = record
ID: LongWord;
Hue: Word;
X,Y: Smallint;
Z: ShortInt;
end;
TBrushTile = record
ID: Word;
Chance: Float;
Mask: Byte;
Brush1: ^TGroupBrush;
Brush2: ^TGroupBrush;
end;
PBrushTile = ^TBrushTile;
TGroupEntry = record
ID: Word;
Name: string;
Image: TSingleImage;
Count: Word; // Число тайлов в объекте
ETile: ^TEntryTile;
end;
PGroupEntry = ^TGroupEntry;
TGroupBrushEdge = record
ID: Word;
CountDR: Word;
BTileDR: ^PBrushTile;
CountDL: Word;
BTileDL: ^PBrushTile;
CountUR: Word;
BTileUR: ^PBrushTile;
CountUL: Word;
BTileUL: ^PBrushTile;
CountLL: Word;
BTileLL: ^PBrushTile;
CountUU: Word;
BTileUU: ^PBrushTile;
end;
PGroupBrushEdge = ^TGroupBrushEdge;
TGroupBrush = record
ID: Word;
Name: string;
Image: TSingleImage;
Count: Word; // Число тайлов в объекте
BTile: ^PBrushTile;
ECount: Word; // Число тайлов перехода (в <Edge />)
EdgeId: ^PWord; // <20>ндификаторы кистей переходов (ссылка на кисть в <Edge />)
BEdges: ^PGroupBrushEdge; // Тайлы переходов
end;
PGroupBrush = ^TGroupBrush;
TEntryList = record
Entry: ^PGroupEntry;
Count: Word;
end;
TBrushList = record
Brush: ^PGroupBrush;
Count: Word;
Tiles: array[0..$3FFF] of TBrushTile;
end;
TGroupNode = record
Name : string;
Color: TColor;
Bold : Boolean;
Ital : Boolean;
Items: LongWord; // число элементов (тайлы, объекты, кисти и тд) в группе (включая подгруппы)
Nodes: Word;
ID : LongWord;
Links: Word; // число элементов в GLink
lids : ^LongWord;
GLink: ^PVirtualNode; // сылки на группы
Count: LongWord; // число элементов в GTile
GTile: ^TGroupTile;
Entries: LongWord; // число элементов в Entry
Entry: ^PGroupEntry; // сылки на объекты из TilesEntry.xml
Brushes: LongWord; // число элементов в Brush
Brush: ^PGroupBrush; // сылки на объекты из TilesBrush.xml
end;
PGroupNode = ^TGroupNode;
// SurfaceInf.xml types start
TSurfTile = record
Tile: ^LongWord; // ID тайлов лендов и итемов
Hash: ^LongWord; // Surface's тэги для них
Count: Word;
end;
PSurfTile = ^TSurfTile;
TSurfGrad = record
Grad: ^TSurfTile; // списки тайлов в Surface'ах, рассортированные по Category+Type
Hash: ^LongWord; // SurfaceCategory + ItemType
Count: Word;
end;
PSurfGrad = ^TSurfGrad;
TSurfInfo = record
Name : string;
TileID: LongWord;
TileHash: LongWord; // Кеш Имени (Name)
GradHash: ^LongWord; // Кэши типов тайлов в объекте
GradCount: Word; // Чмсло GradHash
end;
PSurfInfo = ^TSurfInfo;
TSurfGroup = record
Name : string; // Имя категории
Info : ^TSurfInfo; // Список поверхностей в категории
Count: Word; // Длинна списка поверхностей
end;
PSurfGroup = ^TSurfGroup;
TSurfsList = record
Group: ^TSurfGroup;
GroupCount: Word;
Grads: ^TSurfGrad; // Контейнер для хранения памяти
GradsCount: Word;
Tiles: ^PSurfGrad;
TilesCount: Word;
end;
// SurfaceInf.xml types end
TLightTile = record
image: Byte;
color: Byte;
end;
PLightTile = ^TLightTile;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
{ TfrmMain }
TfrmMain = class(TForm)
acSelect: TAction;
acDraw: TAction;
acMove: TAction;
acElevate: TAction;
acDelete: TAction;
acHue: TAction;
acBoundaries: TAction;
acFilter: TAction;
acFlat: TAction;
acNoDraw: TAction;
acLightlevel: TAction;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
acTerrain: TAction;
acStatics: TAction;
acSelection: TAction;
acSurfElevate: TAction;
acSurfStretch: TAction;
acSurfSmooth: TAction;
acFill: TAction;
acRedo: TAction;
- Added optional highlight for (un)walkable tiles - Fixed lightmanager to draw in the correct color - Fixed TMapBlock and TStaticBlock to correctly initialize itself as "unchanged" - Cleanup in the server project
2009-12-24 15:49:15 +01:00
acWalkable: TAction;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
acUndo: TAction;
acVirtualLayer: TAction;
ActionList1: TActionList;
ApplicationProperties1: TApplicationProperties;
btnAddLocation: TSpeedButton;
btnAddRandom: TSpeedButton;
btnClearLocations: TSpeedButton;
btnClearRandom: TSpeedButton;
btnDeleteLocation: TSpeedButton;
btnDeleteRandom: TSpeedButton;
btnGoTo: TButton;
btnRandomPresetDelete: TSpeedButton;
btnRandomPresetSave: TSpeedButton;
cbRandomPreset: TComboBox;
cbStatics: TCheckBox;
cbTerrain: TCheckBox;
edChat: TEdit;
edFilter: TEdit;
edSearchID: TEdit;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
edX: TSpinEdit;
edY: TSpinEdit;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
gbRandom: TGroupBox;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
gbGoTo: TGroupBox;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
ImageList1: TImageList;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
lblTileInfoOLabel: TLabel;
lblTileInfoIDLabel: TLabel;
lblTileInfoHLabel: TLabel;
lblTileInfoIDValue: TLabel;
lblTileInfoCLabel: TLabel;
lblTileInfoWLabel: TLabel;
lblTileInfoYLabel: TLabel;
lblTileInfoXValue: TLabel;
lblTileInfoXLabel: TLabel;
lblTileInfoZValue: TLabel;
lblTileInfoHueValue: TLabel;
lblTileInfoHueLabel: TLabel;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
lblChatHeaderCaption: TLabel;
lblFilter: TLabel;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
lblTileInfoZLabel: TLabel;
lblTileInfoYValue: TLabel;
lblTileInfoHValue: TLabel;
lblTileInfoWValue: TLabel;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
lblX: TLabel;
lblY: TLabel;
MainMenu1: TMainMenu;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
MenuItem1: TMenuItem;
mnuMiscTileListLarge: TMenuItem;
mnuSeparator9: TMenuItem;
mnuSeparator8: TMenuItem;
mnuTileListDrawInfo: TMenuItem;
mnuMiscTileListTable: TMenuItem;
mnuMiscTileListSmall: TMenuItem;
mnuSeparator10: TMenuItem;
mnuMiscTileListCentre: TMenuItem;
mnuMiscTileListDrawInfo: TMenuItem;
mnuMiscTileListMidle: TMenuItem;
mnuMiscTileListClip: TMenuItem;
mnuMiscTileListStretch: TMenuItem;
mnuMiscTileList: TMenuItem;
mnuEng2Com: TMenuItem;
mnuTileListMidle: TMenuItem;
mnuTileListTable: TMenuItem;
mnuTileListSmall: TMenuItem;
mnuTileListLarge: TMenuItem;
mnuTileListStretch: TMenuItem;
mnuTileListClip: TMenuItem;
mnuTileListCentre: TMenuItem;
mnuSeparator7: TMenuItem;
mnuTileList: TMenuItem;
mnuSeparator6: TMenuItem;
mnuSetLanguage: TMenuItem;
mnuAutoShowFilterWindow: TMenuItem;
mnuSelection: TMenuItem;
mnuSurfElevate: TMenuItem;
mnuSurfStretch: TMenuItem;
mnuSurfSmooth: TMenuItem;
mnuFill: TMenuItem;
mnuShowNoDrawTiles: TMenuItem;
mnuEngCom: TMenuItem;
mnuRusCom: TMenuItem;
mnuSupport: TMenuItem;
mnuSeparator5: TMenuItem;
mnuDocs: TMenuItem;
mnuShowBlocks: TMenuItem;
mnuGrabBoundaries: TMenuItem;
mnuGrabBoundMinZ: TMenuItem;
mnuGrabBoundMaxZ: TMenuItem;
mnuGrabBoundMinX: TMenuItem;
mnuGrabBoundMaxX: TMenuItem;
mnuGrabBoundMinY: TMenuItem;
mnuGrabBoundMaxY: TMenuItem;
mnuZoom300: TMenuItem;
mnuZoom400: TMenuItem;
mnuZoom033: TMenuItem;
mnuZoom025: TMenuItem;
mnuZoom150: TMenuItem;
mnuZoom200: TMenuItem;
mnuZoom075: TMenuItem;
mnuZoom050: TMenuItem;
mnuZoom100: TMenuItem;
mnuShowBridges: TMenuItem;
mnuWindowedMode: TMenuItem;
mnuMakeScreenShot: TMenuItem;
mnuShowWater: TMenuItem;
mnuShowSurfaces: TMenuItem;
mnuShowRoofs: TMenuItem;
mnuShowFoliage: TMenuItem;
mnuAutoHideRandomList: TMenuItem;
mnuAutoHideGroupList: TMenuItem;
mnuSeparator4: TMenuItem;
mnuReloadGroups: TMenuItem;
mnuGrabFilterTileID: TMenuItem;
mnuGrabFilterHue: TMenuItem;
mnuGrabVirtualLayerZ: TMenuItem;
mnuShowGrid: TMenuItem;
mnuShowWalls: TMenuItem;
mnuShowLightSource: TMenuItem;
- Added option to set the render background to white (fixes #59)
2009-12-23 20:54:56 +01:00
mnuWhiteBackground: TMenuItem;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
mnuSecurityQuestion: TMenuItem;
mnuShowAnimations: TMenuItem;
mnuSettings: TMenuItem;
mnuFlatShowHeight: TMenuItem;
mnuGrabHue: TMenuItem;
mnuGrabTileID: TMenuItem;
mnuRegionControl: TMenuItem;
mnuVirtualLayer: TMenuItem;
mnuLargeScaleCommands: TMenuItem;
mnuSetHue: TMenuItem;
mnuGoToClient: TMenuItem;
mnuAbout: TMenuItem;
mnuHelp: TMenuItem;
mnuSeparator3: TMenuItem;
mnuBoundaries: TMenuItem;
mnuSelect: TMenuItem;
mnuDraw: TMenuItem;
mnuMove: TMenuItem;
mnuElevate: TMenuItem;
mnuDelete: TMenuItem;
mnuAddToRandom: TMenuItem;
mnuFlush: TMenuItem;
mnuShutdown: TMenuItem;
mnuSeparator2: TMenuItem;
mnuAccountControl: TMenuItem;
mnuAdministration: TMenuItem;
mnuSeparator1: TMenuItem;
mnuExit: TMenuItem;
mnuDisconnect: TMenuItem;
mnuCentrED: TMenuItem;
oglGameWindow: TOpenGLControl;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
pbRadar: TPaintBox;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
pcLeft: TPageControl;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
pmZoomSettings: TPopupMenu;
pmViewTerrainSettings: TPopupMenu;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
pmGrabTileInfo: TPopupMenu;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
pmNoDrawSettings: TPopupMenu;
pmViewStaticSettings: TPopupMenu;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
pmTileList: TPopupMenu;
pmTools: TPopupMenu;
pmClients: TPopupMenu;
pnlChat: TPanel;
pnlChatHeader: TPanel;
pmFlatViewSettings: TPopupMenu;
spChat: TSplitter;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
spGroupList1: TSplitter;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
spTileList: TSplitter;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
spGroupList: TSplitter;
tbFill: TToolButton;
tbSurfSmooth: TToolButton;
tbSurfStretch: TToolButton;
tbSurfElevate: TToolButton;
tbSelection: TToolButton;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
tbFilter: TToolButton;
tbFlat: TToolButton;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tbSeparator6: TToolButton;
tbSeparator7: TToolButton;
tbSeparator8: TToolButton;
tbSeparator9: TToolButton;
tbRedo: TToolButton;
tbZoom: TToolButton;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
tbNoDraw: TToolButton;
tbSeparator2: TToolButton;
tbUndo: TToolButton;
- Added optional highlight for (un)walkable tiles - Fixed lightmanager to draw in the correct color - Fixed TMapBlock and TStaticBlock to correctly initialize itself as "unchanged" - Cleanup in the server project
2009-12-24 15:49:15 +01:00
tbLightlevel: TToolButton;
tbWalkable: TToolButton;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tmSelectNode: TTimer;
tmSettingsClose: TTimer;
tsNavigation: TTabSheet;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
tbSetHue: TToolButton;
tmGrabTileInfo: TTimer;
tmMovement: TTimer;
tbSeparator5: TToolButton;
tbRadarMap: TToolButton;
tbVirtualLayer: TToolButton;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tsObjects: TTabSheet;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
tbMain: TToolBar;
tbDisconnect: TToolButton;
tbSeparator1: TToolButton;
tbSelect: TToolButton;
tbDrawTile: TToolButton;
tbMoveTile: TToolButton;
tbElevateTile: TToolButton;
tbDeleteTile: TToolButton;
tbSeparator3: TToolButton;
tbBoundaries: TToolButton;
tbSeparator4: TToolButton;
tbTerrain: TToolButton;
tbStatics: TToolButton;
tsTiles: TTabSheet;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tvGroups: TVirtualStringTree;
vdtTiles: TVirtualList;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
vdtRandom: TVirtualDrawTree;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
vdlRandom: TVirtualList;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
vstChat: TVirtualStringTree;
vstLocations: TVirtualStringTree;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
vstClients: TVirtualStringTree;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
XMLPropStorage1: TXMLPropStorage;
procedure acBoundariesExecute(Sender: TObject);
procedure acDeleteExecute(Sender: TObject);
procedure acDrawExecute(Sender: TObject);
procedure acElevateExecute(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure acFillExecute(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure acFilterExecute(Sender: TObject);
procedure acFlatExecute(Sender: TObject);
procedure acHueExecute(Sender: TObject);
procedure acLightlevelExecute(Sender: TObject);
procedure acMoveExecute(Sender: TObject);
procedure acNoDrawExecute(Sender: TObject);
procedure acSelectExecute(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure acSelectionExecute(Sender: TObject);
procedure acStaticsExecute(Sender: TObject);
procedure acSurfElevateExecute(Sender: TObject);
procedure acSurfSmoothExecute(Sender: TObject);
procedure acSurfStretchExecute(Sender: TObject);
procedure acTerrainExecute(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure acUndoExecute(Sender: TObject);
procedure acVirtualLayerExecute(Sender: TObject);
- Added optional highlight for (un)walkable tiles - Fixed lightmanager to draw in the correct color - Fixed TMapBlock and TStaticBlock to correctly initialize itself as "unchanged" - Cleanup in the server project
2009-12-24 15:49:15 +01:00
procedure acWalkableExecute(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure acGridExecute(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
procedure ApplicationProperties1ShowHint(var HintStr: string;
var CanShow: Boolean; var HintInfo: THintInfo);
procedure btnAddLocationClick(Sender: TObject);
procedure btnAddRandomClick(Sender: TObject);
procedure btnClearLocationsClick(Sender: TObject);
procedure btnClearRandomClick(Sender: TObject);
procedure btnDeleteLocationClick(Sender: TObject);
procedure btnDeleteRandomClick(Sender: TObject);
procedure btnGoToClick(Sender: TObject);
procedure btnRandomPresetDeleteClick(Sender: TObject);
procedure btnRandomPresetSaveClick(Sender: TObject);
procedure cbRandomPresetChange(Sender: TObject);
procedure cbStaticsChange(Sender: TObject);
procedure cbTerrainChange(Sender: TObject);
procedure edChatKeyPress(Sender: TObject; var Key: char);
procedure edFilterEditingDone(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure edSearchIDExit(Sender: TObject);
procedure edSearchIDKeyPress(Sender: TObject; var Key: char);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormShow(Sender: TObject);
procedure FormWindowStateChange(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure lblChatHeaderCaptionClick(Sender: TObject);
procedure lblChatHeaderCaptionMouseEnter(Sender: TObject);
procedure lblChatHeaderCaptionMouseLeave(Sender: TObject);
procedure mnuAboutClick(Sender: TObject);
procedure mnuAccountControlClick(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure mnuAutoHideGroupListClick(Sender: TObject);
procedure mnuAutoHideRandomListClick(Sender: TObject);
procedure mnuAutoShowFilterWindowClick(Sender: TObject);
procedure mnuCompactHueSettingsClick(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure mnuDisconnectClick(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure mnuDocsClick(Sender: TObject);
procedure mnuEng2ComClick(Sender: TObject);
procedure mnuEngComClick(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure mnuExitClick(Sender: TObject);
procedure mnuFlatShowHeightClick(Sender: TObject);
procedure mnuFlushClick(Sender: TObject);
procedure mnuGoToClientClick(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure GrabBoundaries(Sender: TObject);
procedure mnuGrabFilterHueClick(Sender: TObject);
procedure mnuGrabFilterTileIDClick(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure mnuGrabHueClick(Sender: TObject);
procedure mnuGrabTileIDClick(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure mnuGrabVirtualLayerZClick(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure mnuLargeScaleCommandsClick(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure mnuMakeScreenShotClick(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure mnuRegionControlClick(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure mnuReloadGroupsClick(Sender: TObject);
procedure mnuRusComClick(Sender: TObject);
procedure mnuSetLanguageClick(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure mnuShowAnimationsClick(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure mnuShowBlocksClick(Sender: TObject);
procedure mnuShowBridgesClick(Sender: TObject);
procedure mnuShowGridClick(Sender: TObject);
procedure mnuShowLightSourceClick(Sender: TObject);
procedure mnuShowNoDrawTilesClick(Sender: TObject);
procedure mnuShowStaticsOptionClick(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure mnuShutdownClick(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure mnuTileListDrawClick(Sender: TObject);
procedure mnuTileListViewClick(Sender: TObject);
- Added option to set the render background to white (fixes #59)
2009-12-23 20:54:56 +01:00
procedure mnuWhiteBackgroundClick(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure mnuWindowedModeClick(Sender: TObject);
procedure mnuZoomClick(Sender: TObject);
procedure oglGameWindowClick(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure oglGameWindowDblClick(Sender: TObject);
procedure oglGameWindowKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure oglGameWindowMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure oglGameWindowMouseEnter(Sender: TObject);
procedure oglGameWindowMouseLeave(Sender: TObject);
procedure oglGameWindowMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure oglGameWindowMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure oglGameWindowMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
procedure oglGameWindowPaint(Sender: TObject);
procedure oglGameWindowResize(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure pbRadarMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure pbRadarPaint(Sender: TObject);
procedure pcLeftChange(Sender: TObject);
procedure pcLeftResize(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure pmGrabTileInfoPopup(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure DropedownMenusClose(Sender: TObject);
procedure spGroupListMoved(Sender: TObject);
procedure spTileListMoved(Sender: TObject);
procedure tbFilterMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure tbFilterMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure tbRadarMapClick(Sender: TObject);
procedure tmGrabTileInfoTimer(Sender: TObject);
procedure tmMovementTimer(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
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;
Node: PVirtualNode; Column: TColumnIndex; const CellText: String;
const CellRect: TRect; var DefaultDraw: Boolean);
procedure tvGroupsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType; var CellText: String);
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState
);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure tvSelectGroupsChanged(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure vdtRandomClick(Sender: TObject);
procedure vdtRandomDragDrop(Sender: TBaseVirtualTree; Source: TObject;
DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState;
Pt: TPoint; var Effect: Integer; Mode: TDropMode);
procedure vdtRandomDragOver(Sender: TBaseVirtualTree; Source: TObject;
Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode;
var Effect: Integer; var Accept: Boolean);
procedure vdtRandomLoadNode(Sender: TBaseVirtualTree; Node: PVirtualNode;
Stream: TStream);
procedure vdtRandomSaveNode(Sender: TBaseVirtualTree; Node: PVirtualNode;
Stream: TStream);
procedure vdtRandomUpdating(Sender: TBaseVirtualTree; State: TVTUpdateState);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure vdtTilesChange(Sender: TBaseVirtualTree; Node: PVirtualNode);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure vdtTilesClick(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure vdtTilesDragAllowed(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; var Allowed: Boolean);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure vdtTilesDrawHint(Sender: TBaseVirtualTree; HintCanvas: TCanvas;
Node: PVirtualNode; const R: TRect; Column: TColumnIndex);
procedure vdtTilesDrawNode(Sender: TBaseVirtualTree;
const PaintInfo: TVTPaintInfo);
procedure vdtTilesEnter(Sender: TObject);
procedure vdtTilesGetHintSize(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; var R: TRect);
procedure vdtTilesKeyPress(Sender: TObject; var Key: char);
procedure vdtTilesScroll(Sender: TBaseVirtualTree; DeltaX, DeltaY: Integer);
procedure vstChatClick(Sender: TObject);
procedure vstChatFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
procedure vstChatGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType; var CellText: String);
procedure vstChatPaintText(Sender: TBaseVirtualTree;
const TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;
TextType: TVSTTextType);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure vstClientsGetImageIndex(Sender: TBaseVirtualTree;
Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
var Ghosted: Boolean; var ImageIndex: Integer);
procedure vstClientsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType; var CellText: String);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure vstLocationsDblClick(Sender: TObject);
procedure vstLocationsFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode
);
procedure vstLocationsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType; var CellText: String);
procedure vstLocationsLoadNode(Sender: TBaseVirtualTree;
Node: PVirtualNode; Stream: TStream);
procedure vstLocationsNewText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; const NewText: String);
procedure vstLocationsSaveNode(Sender: TBaseVirtualTree;
Node: PVirtualNode; Stream: TStream);
procedure XMLPropStorage1RestoreProperties(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure XMLPropStorage1SavingProperties(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
protected
{ Members }
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FAppDir: String; // .\
FLocalDir: String; // .\..\LocalData\
FConfigDir: String; // {$User}\AppData\Local\CentrED-plus\ - зависит от реестра
FProfileDir: String; // {$User}\AppData\Local\CentrED-plus\Profiles\{$Profile}\ - зависит от реестра
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
FX: Integer;
FY: Integer;
FDrawDistance: Integer;
FLowOffsetX: Integer;
FLowOffsetY: Integer;
FHighOffsetX: Integer;
FHighOffsetY: Integer;
FRangeX: Integer;
FRangeY: Integer;
FLandscape: TLandscape;
FTextureManager: TLandTextureManager;
FScreenBuffer: TScreenBuffer;
FScreenBufferState: TScreenBufferStates;
FCurrentTile: TWorldItem;
FSelectedTile: TWorldItem;
FVirtualTiles: TWorldItemList;
FVLayerImage: TSingleImage;
FVLayerMaterial: TMaterial;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FVLightSrcImage: array[1..FVLightSrcImageCount] of TSingleImage;
FVLightSrcMaterial: ^TMaterial;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
FOverlayUI: TOverlayUI;
FLocationsFile: string;
FRandomPresetsFile: string;
FRandomPresetsDoc: TXMLDocument;
FLastDraw: TDateTime;
FAccessChangedListeners: TAccessChangedListeners;
FRepaintNeeded: Boolean;
FSelection: TRect;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FUndoList: PPacketList;
FUndoListArray: array[1..FUndoListLength] of TPacketList;
FUndoListFirstIndex: Word;
FundoListLastIndex: Word;
FEntryList: TEntryList;
FBrushList: TBrushList;
FSurfsList: TSurfsList;
FGroupsSelectionUndoRedoCommandGroup: TUndoRedoCommandGroup;
FGroupsSelectionUndoRedoManager: TUndoRedoManager;
FTilesSelectionUndoRedoCommandGroup: TUndoRedoCommandGroup;
FTilesSelectionUndoRedoManager: TUndoRedoManager;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
FGLFont: TGLFont;
FSelectionListeners: TSelectionListeners;
FTileHint: TTileHintInfo;
FLightManager: TLightManager;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FVisibleTiles: TBits;
FLightSourceTiles: PLightTile;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
{ Methods }
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
function GetNextUndoList: PPacketList;
function LoadListError(condition: Boolean; filename, message : string): Boolean;
procedure LoadVisibleTiles(AFileName: String);
procedure LoadLightSourceTiles(AFileName: String);
procedure LoadEntryTilesList;
procedure LoadBrushTilesList;
procedure LoadSurfsTilesList;
procedure BuildGroupList;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure BuildTileList;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure FreeGroupLists;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
function ConfirmAction: Boolean;
function FindRandomPreset(AName: String): TDOMElement;
procedure ForceUpdateCurrentTile;
procedure GetDrawOffset(AX, AY: Integer; out DrawX, DrawY: Integer); inline;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
function GetInternalTileID(ATile: TWorldItem): LongWord;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
function GetSelectedRect: TRect;
procedure InitRender;
procedure InitSize;
procedure LoadLocations;
procedure LoadRandomPresets;
procedure MoveBy(AOffsetX, AOffsetY: Integer); inline;
procedure PrepareMapCell(AMapCell: TMapCell);
procedure PrepareScreenBlock(ABlockInfo: PBlockInfo);
procedure ProcessToolState;
procedure ProcessAccessLevel;
procedure RebuildScreenBuffer;
procedure Render;
procedure SaveLocations;
procedure SaveRandomPresets;
procedure SetCurrentTile(const AValue: TWorldItem);
procedure SetDarkLights; inline;
procedure SetNormalLights; inline;
procedure SetSelectedTile(const AValue: TWorldItem);
procedure SetX(const AValue: Integer);
procedure SetY(const AValue: Integer);
procedure UpdateCurrentTile;
procedure UpdateCurrentTile(AX, AY: Integer);
procedure UpdateFilter;
procedure UpdateSelection;
procedure WriteChatMessage(ASender, AMessage: string);
{ Events }
procedure OnClientHandlingPacket(ABuffer: TEnhancedMemoryStream);
procedure OnLandscapeChanged;
procedure OnMapChanged(AMapCell: TMapCell);
procedure OnNewBlock(ABlock: TBlock);
procedure OnStaticDeleted(AStaticItem: TStaticItem);
procedure OnStaticElevated(AStaticItem: TStaticItem);
procedure OnStaticHued(AStaticItem: TStaticItem);
procedure OnStaticInserted(AStaticItem: TStaticItem);
procedure OnTileRemoved(ATile: TMulBlock);
public
{ Fields }
property X: Integer read FX write SetX;
property Y: Integer read FY write SetY;
property Landscape: TLandscape read FLandscape;
property CurrentTile: TWorldItem read FCurrentTile write SetCurrentTile;
property SelectedTile: TWorldItem read FSelectedTile write SetSelectedTile;
property LightManager: TLightManager read FLightManager;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
property AppDir: string read FAppDir;
property LocalDir: string read FLocalDir;
property ConfigDir: string read FConfigDir;
property ProfileDir: string read FProfileDir;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
{ Methods }
procedure InvalidateFilter;
procedure InvalidateScreenBuffer;
procedure RegisterAccessChangedListener(AListener: TAccessChangedListener);
procedure RegisterSelectionListener(AListener: TSelectionListener);
procedure SetPos(AX, AY: Word);
procedure SwitchToSelection;
procedure UnregisterAccessChangedListener(AListener: TAccessChangedListener);
procedure UnregisterSelectionListener(AListener: TSelectionListener);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
public
{Localization}
lbFormTitleAccount: string;
lbFormTitleProfile: string;
lbBottomCursorVLayer1: string;
lbBottomCursorVLayer2: string;
lbBottomCursorItemID: string;
lbBottomCursorLandID: string;
lbBottomCursorPosX: string;
lbBottomCursorPosY: string;
lbBottomCursorPosZ: string;
lbBottomCursorItemHue: string;
lbToolbarUndo: string;
lbDlgWindowedModeSwitchCaption: string;
lbDlgWindowedModeSwitch: string;
lbScreenShotMsg: string;
lbUserLoginedMsg: string;
lbUserLogoutedMsg: string;
lbDlgGetDcErrCaption: string;
lbDlgGetDcErr: string;
lbDlgFreeDcErrCaption: string;
lbDlgFreeDcErr: string;
lbDlgCnangedAccessCaption: string;
lbDlgCnangedAccess: string;
lbDlgBlockedAccessCaption: string;
lbDlgBlockedAccess: string;
lbDlgSaveRandPrsCaption: string;
lbDlgSaveRandPrs: string;
lbDlgSearchIdErrCaption: string;
lbDlgSearchIdErr: string;
lbDlgNotFoundErrCaption: string;
lbDlgNotFoundErr: string;
lbDlgDelConfCaption: string;
lbDlgDelConf: string;
lbDlgNewQuerryCaption: string;
lbDlgNewQuerry: string;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
var
frmMain: TfrmMain;
implementation
uses
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
UdmNetwork, UArt, UTexture, UHue, UTiledata, UAdminHandling, UPackets,
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
UfrmAccountControl, UGraphicHelper, ImagingComponents, UfrmDrawSettings,
UfrmBoundaries, UfrmElevateSettings, UfrmConfirmation, UfrmMoveSettings,
UfrmAbout, UPacketHandlers, UfrmHueSettings, UfrmRadar, UfrmLargeScaleCommand,
UfrmLogin, UResourceManager, UfrmVirtualLayer, UfrmFilter, UfrmRegionControl,
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
Logging, LConvEncoding, LCLType, UfrmLightlevel, vinfo, Imaging, Language,
UfrmEditAccount, UfrmFillSettings, UfrmSelectionSettings, UfrmInitialize,
UfrmSurfElevateSettings, UfrmSurfStretchSettings, UfrmSurfSmoothSettings, Crc32Hash;
{$I version.inc}
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
type
TGLArrayf4 = array[0..3] of GLfloat;
PTileInfo = ^TTileInfo;
TTileInfo = record
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
ID: LongWord;
ptr: Pointer;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
PChatInfo = ^TChatInfo;
TChatInfo = record
Time: TDateTime;
Sender: string;
Msg: string;
end;
PLocationInfo = ^TLocationInfo;
TLocationInfo = record
X: Word;
Y: Word;
Name: string;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
PClientInfo = ^TClientInfo;
TClientInfo = record
Name: string;
AccessLevel: TAccessLevel;
LogonDateTime : TDateTime;
//Time: string;
//Map: Byte;
//X: Word;
//Y: Word;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
const
CScreenBufferValid = [sbsValid, sbsIndexed, sbsFiltered];
function IsInRect(const AX, AY: Integer; const ARect: TRect): Boolean; inline;
begin
Result := (AX >= ARect.Left) and
(AX <= ARect.Right) and
(AY >= ARect.Top) and
(AY <= ARect.Bottom);
end;
{ TfrmMain }
procedure TfrmMain.mnuExitClick(Sender: TObject);
begin
Close;
end;
procedure TfrmMain.mnuFlatShowHeightClick(Sender: TObject);
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tbFlat.Down := acFlat.Checked;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
RebuildScreenBuffer;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.mnuShowNoDrawTilesClick(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tbNoDraw.Down := acNoDraw.Checked;
RebuildScreenBuffer;
FRepaintNeeded := True;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.mnuShowLightSourceClick(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tbNoDraw.Down := acNoDraw.Checked;
RebuildScreenBuffer;
FRepaintNeeded := True;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.mnuShowGridClick(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tbTerrain.Down := acTerrain.Checked;
mnuShowBlocks.Checked := False;
RebuildScreenBuffer;
FRepaintNeeded := True;
end;
procedure TfrmMain.mnuShowBlocksClick(Sender: TObject);
begin
tbTerrain.Down := acTerrain.Checked;
mnuShowGrid.Checked := False;
RebuildScreenBuffer;
FRepaintNeeded := True;
end;
procedure TfrmMain.mnuShowStaticsOptionClick(Sender: TObject);
begin
tbStatics.Down := acStatics.Checked;
RebuildScreenBuffer;
end;
procedure TfrmMain.mnuFlushClick(Sender: TObject);
begin
dmNetwork.Send(TFlushServerPacket.Create);
end;
procedure TfrmMain.mnuGoToClientClick(Sender: TObject);
var
mpos: TPoint;
node: PVirtualNode;
clientInfo: PClientInfo;
begin
mpos := vstClients.ScreenToClient(Mouse.CursorPos);
node := vstClients.GetNodeAt(mpos.X, mpos.Y);// .GetFirstSelected;
if node <> nil then
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
clientInfo := vstClients.GetNodeData(node);
dmNetwork.Send(TGotoClientPosPacket.Create(clientInfo^.Name));
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.mnuGrabTileIDClick(Sender: TObject);
var
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
internalTileID: LongWord;
item: PVirtualItem;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
tileInfo: PTileInfo;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
treeNode: PVirtualNode;
function TileInNode(Node: PVirtualNode; TileID: LongWord) : Boolean;
var
nodeData: ^TGroupNode;
i: Integer;
begin
Result := False;
nodeData := tvGroups.GetNodeData(Node);
for i := 0 to nodeData^.Count - 1 do
begin
if nodeData^.GTile[i].ID = TileID then
begin
Result := True;
break;
end;
end;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
Logger.Send([lcClient, lcDebug], 'TfrmMain.mnuGrabTileIDClick', TRUE);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if CurrentTile <> nil then
begin
internalTileID := GetInternalTileID(CurrentTile);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
// Выбираем группы
if (not cbStatics.Checked) and (not cbTerrain.Checked) then
begin
treeNode := tvGroups.GetFirst();
while treeNode <> nil do
begin
if TileInNode(treeNode, internalTileID) then
begin
tvGroups.Selected[treeNode] := True;
tvGroups.FocusedNode := treeNode;
if toMultiSelect in tvGroups.TreeOptions.SelectionOptions
then break;
end;
treeNode := tvGroups.GetNext(treeNode);
end;
end;
Logger.Send([lcClient, lcDebug], 'TfrmMain.mnuGrabTileIDClick', internalTileID);
// Выбираем тайл
item := vdtTiles.GetFirst;
while item <> nil do
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tileInfo := vdtTiles.GetNodeData(item);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if tileInfo^.ID = internalTileID then
begin
vdtTiles.ClearSelection;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
vdtTiles.Selected[item] := True;
vdtTiles.FocusedNode := item;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
Break;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
item := vdtTiles.GetNext(item);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
Logger.Send([lcClient, lcDebug], 'TfrmMain.mnuGrabTileIDClick', FALSE);
end;
procedure TfrmMain.mnuGrabHueClick(Sender: TObject);
begin
if CurrentTile is TStaticItem then
begin
frmHueSettings.lbHue.ItemIndex := TStaticItem(CurrentTile).Hue;
frmFilter.JumpToHue(TStaticItem(CurrentTile).Hue);
end;
end;
procedure TfrmMain.mnuGrabFilterTileIDClick(Sender: TObject);
begin
if CurrentTile is TStaticItem then
begin
frmFilter.AddTile(GetInternalTileID(CurrentTile));
frmFilter.cbTileFilter.Checked := True;
frmMain.InvalidateFilter;
end;
end;
procedure TfrmMain.mnuGrabFilterHueClick(Sender: TObject);
begin
if CurrentTile is TStaticItem then
begin
frmFilter.AddHue(TStaticItem(CurrentTile).Hue);
frmFilter.cbHueFilter.Checked := True;
frmMain.InvalidateFilter;
end;
end;
procedure TfrmMain.mnuGrabVirtualLayerZClick(Sender: TObject);
begin
frmVirtualLayer.seZ.Value := CurrentTile.Z;
frmVirtualLayer.seZChange(frmVirtualLayer.seZ);
if not frmVirtualLayer.cbShowLayer.Checked then
begin
frmVirtualLayer.cbShowLayer.Checked := True;
frmMain.InvalidateScreenBuffer;
end;
//cursorNeedsUpdate := True;
//Handled := True;
end;
procedure TfrmMain.GrabBoundaries(Sender: TObject);
begin
if Sender = mnuGrabBoundMinZ then begin
frmBoundaries.seMinZ.Value := CurrentTile.Z; frmBoundaries.seMinZChange(nil); end
else if Sender = mnuGrabBoundMaxZ then begin
frmBoundaries.seMaxZ.Value := CurrentTile.Z; frmBoundaries.seMaxZChange(nil); end
else if Sender = mnuGrabBoundMinX then begin
frmBoundaries.seMinX.Value := CurrentTile.X; frmBoundaries.seMinXChange(nil); end
else if Sender = mnuGrabBoundMaxX then begin
frmBoundaries.seMaxX.Value := CurrentTile.X; frmBoundaries.seMaxXChange(nil); end
else if Sender = mnuGrabBoundMinY then begin
frmBoundaries.seMinY.Value := CurrentTile.Y; frmBoundaries.seMinYChange(nil); end
else if Sender = mnuGrabBoundMaxY then begin
frmBoundaries.seMaxY.Value := CurrentTile.Y; frmBoundaries.seMaxYChange(nil); end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.mnuLargeScaleCommandsClick(Sender: TObject);
begin
frmLargeScaleCommand.Show;
end;
procedure TfrmMain.mnuRegionControlClick(Sender: TObject);
begin
frmRegionControl.Show;
end;
procedure TfrmMain.mnuShowAnimationsClick(Sender: TObject);
begin
FTextureManager.UseAnims := mnuShowAnimations.Checked;
RebuildScreenBuffer;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.mnuShowBridgesClick(Sender: TObject);
begin
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure TfrmMain.mnuShutdownClick(Sender: TObject);
begin
dmNetwork.Send(TQuitServerPacket.Create(''));
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
- Added option to set the render background to white (fixes #59)
2009-12-23 20:54:56 +01:00
procedure TfrmMain.mnuWhiteBackgroundClick(Sender: TObject);
begin
FRepaintNeeded := True;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.mnuWindowedModeClick(Sender: TObject);
var btn: Integer;
begin
btn := MessageDlg(lbDlgWindowedModeSwitchCaption, lbDlgWindowedModeSwitch,
mtConfirmation, mbYesNoCancel, 0);
// btn=2=mbCancel; btn=6=mbYes; btn=7=mbNo;
// Почему так хз, по идее btn=ord(mbCancel) или TMsgDlgBtn(btn)=mbCancel,
// но этой чертовой среде ничего нравитсо ("Pascale must die")
if btn = 2 then mnuWindowedMode.Checked := not mnuWindowedMode.Checked else begin
XMLPropStorage1.Save;
if btn = 6 then begin
XMLPropStorage1.Restore;
dmNetwork.Disconnect;
end;
end;
end;
procedure TfrmMain.mnuZoomClick(Sender: TObject);
var
zoom : Single;
cache: Integer;
begin
if Sender = tbZoom then begin
if tbZoom.Down then mnuZoomClick(mnuZoom100)
else case tbZoom.Tag of
250: mnuZoomClick(mnuZoom025);
333: mnuZoomClick(mnuZoom033);
500: mnuZoomClick(mnuZoom050);
750: mnuZoomClick(mnuZoom075);
1000: mnuZoomClick(mnuZoom100);
1500: mnuZoomClick(mnuZoom150);
2000: mnuZoomClick(mnuZoom200);
3000: mnuZoomClick(mnuZoom300);
4000: mnuZoomClick(mnuZoom400);
end;
exit;
end;
if (Sender as TMenuItem).Checked then begin
if mnuZoom100 <> Sender then
mnuZoomClick(mnuZoom100);
exit;
end;
(Sender as TMenuItem).Checked := True;
if mnuZoom025 <> Sender then mnuZoom025.Checked:= False else begin zoom:=0.250; cache:=4096; end;
if mnuZoom033 <> Sender then mnuZoom033.Checked:= False else begin zoom:=0.333; cache:=2048; end;
if mnuZoom050 <> Sender then mnuZoom050.Checked:= False else begin zoom:=0.500; cache:=1024; end;
if mnuZoom075 <> Sender then mnuZoom075.Checked:= False else begin zoom:=0.750; cache:= 512; end;
if mnuZoom100 <> Sender then mnuZoom100.Checked:= False else begin zoom:=1.000; cache:= 256; end;
if mnuZoom150 <> Sender then mnuZoom150.Checked:= False else begin zoom:=1.500; cache:= 128; end;
if mnuZoom200 <> Sender then mnuZoom200.Checked:= False else begin zoom:=2.000; cache:= 64; end;
if mnuZoom300 <> Sender then mnuZoom300.Checked:= False else begin zoom:=3.000; cache:= 32; end;
if mnuZoom400 <> Sender then mnuZoom400.Checked:= False else begin zoom:=4.000; cache:= 16; end;
cache := 2 * Trunc(Sqrt(oglGameWindow.Width * oglGameWindow.Width +
oglGamewindow.Height * oglGamewindow.Height) / (44 * zoom));
cache := cache*cache;
//cache := 4096;
FLandscape.ResizeBlockCache(cache);
if zoom < 1.0 then tbZoom.ImageIndex:= 37 else
if zoom > 1.0 then tbZoom.ImageIndex:= 36 else
tbZoom.ImageIndex:= 35;
tbZoom.Down := zoom <> 1.0;
if zoom <> 1.0 then
tbZoom.Tag := Trunc(zoom * 1000.0);
FRepaintNeeded := True;
RebuildScreenBuffer;
end;
procedure TfrmMain.oglGameWindowClick(Sender: TObject);
begin
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure TfrmMain.oglGameWindowDblClick(Sender: TObject);
begin
if (acSelect.Checked) and (CurrentTile <> nil) then
btnAddRandomClick(Sender);
end;
procedure TfrmMain.oglGameWindowKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
var step, zoomfactor: Integer;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if tbZoom.Down then zoomfactor := tbZoom.Tag else zoomfactor := 1000;
if Shift = [ssShift]
then step := 1
else if Shift = []
then step := 8000 div zoomfactor
else exit;
- Added optional highlight for (un)walkable tiles - Fixed lightmanager to draw in the correct color - Fixed TMapBlock and TStaticBlock to correctly initialize itself as "unchanged" - Cleanup in the server project
2009-12-24 15:49:15 +01:00
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
case Key of
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
VK_W, VK_NUMPAD8, VK_UP: MoveBy(-step, -step);
VK_S, VK_NUMPAD2, VK_DOWN: MoveBy(+step, +step);
VK_A, VK_NUMPAD4, VK_LEFT: MoveBy(-step, +step);
VK_D, VK_NUMPAD6, VK_RIGHT: MoveBy(+step, -step);
VK_Q, VK_NUMPAD7: MoveBy(-step, 0);
VK_E, VK_NUMPAD9: MoveBy(0, -step);
VK_Y, VK_NUMPAD1: MoveBy(0, +step);
VK_G, VK_NUMPAD3: MoveBy(+step, 0);
VK_SPACE: if frmFilter.Visible then begin
frmFilter.Locked := True;
frmFilter.Hide;
frmFilter.Locked := False;
end else frmFilter.Show;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
procedure TfrmMain.oglGameWindowMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Logger.EnterMethod([lcClient, lcDebug], 'MouseDown');
try
if Button = mbRight then
pmTools.PopUp(Mouse.CursorPos.X, Mouse.CursorPos.Y);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if Button = mbMiddle then
tmGrabTileInfoTimer(Sender);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if Button <> mbLeft then
Exit;
UpdateCurrentTile(X, Y);
if FOverlayUI.ActiveArrow > -1 then
tmMovement.Enabled := True;
SelectedTile := CurrentTile;
if CurrentTile = nil then Exit;
if acSelect.Checked then //***** Selection Mode *****//
tmGrabTileInfo.Enabled := True;
FRepaintNeeded := True;
finally
Logger.ExitMethod([lcClient, lcDebug], 'MouseDown');
end;
end;
procedure TfrmMain.oglGameWindowMouseEnter(Sender: TObject);
begin
if Active then
oglGameWindow.SetFocus;
FOverlayUI.Visible := True;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if (frmFilter.Visible and mnuAutoShowFilterWindow.Checked) then
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
frmFilter.Locked := True;
frmFilter.Hide;
frmFilter.Locked := False;
end;
FRepaintNeeded := True;
end;
procedure TfrmMain.oglGameWindowMouseLeave(Sender: TObject);
begin
if not (frmConfirmation.Visible or
(frmMoveSettings.Visible and (fsModal in frmMoveSettings.FormState))
) then //during confirmation the mouse would leave ...
begin
CurrentTile := nil;
FOverlayUI.Visible := False;
end;
FRepaintNeeded := True;
end;
procedure TfrmMain.oglGameWindowMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
var
lastTile: TWorldItem;
offsetX, offsetY: Integer;
begin
//Logger.EnterMethod([lcClient, lcDebug], 'MouseMove');
lastTile := CurrentTile;
if ssMiddle in Shift then
begin
UpdateCurrentTile(X, Y);
if (lastTile <> nil) and (CurrentTile <> nil) and (lastTile <> CurrentTile) then
begin
offsetX := lastTile.X - CurrentTile.X;
offsetY := lastTile.Y - CurrentTile.Y;
if InRange(offsetX, -8, 8) and InRange(offsetY, -8, 8) then
SetPos(FX - offsetX, FY - offsetY);
end;
end;
UpdateCurrentTile(X, Y);
FRepaintNeeded := True;
//Logger.ExitMethod([lcClient, lcDebug], 'MouseMove');
end;
procedure TfrmMain.oglGameWindowMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
map: TMapCell;
i: Integer;
z: ShortInt;
blockInfo: PBlockInfo;
targetRect: TRect;
offsetX, offsetY: Integer;
tile: TWorldItem;
tileX, tileY, newX, newY: Word;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
targetBlocks: TBlockInfoList; //а в чем разница с targetTiles: TWorldItemList; ?
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
targetTile: TWorldItem;
begin
Logger.EnterMethod([lcClient, lcDebug], 'MouseUp');
if Button <> mbLeft then
begin
Logger.ExitMethod([lcClient, lcDebug], 'MouseUp');
Exit;
end;
UpdateCurrentTile(X, Y);
tmMovement.Enabled := False;
if CurrentTile = nil then
begin
SelectedTile := nil;
Logger.ExitMethod([lcClient, lcDebug], 'MouseUp');
Exit;
end;
targetTile := CurrentTile;
if acSelect.Checked then
begin
if tmGrabTileInfo.Enabled then
begin
tmGrabTileInfo.Enabled := False;
mnuGrabTileIDClick(nil);
end;
for i := FSelectionListeners.Count - 1 downto 0 do
FSelectionListeners[i](CurrentTile);
end;
if (not acSelect.Checked) and (targetTile <> nil) and (SelectedTile <> nil) then
begin
targetRect := GetSelectedRect;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FUndoList := GetNextUndoList;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if (SelectedTile = targetTile) or ConfirmAction then
begin
if acDraw.Checked then //***** Drawing Mode *****//
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
for tileX := FSelection.Left-1 to FSelection.Right do
for tileY := FSelection.Top-1 to FSelection.Bottom do
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
map := FLandscape.MapCell[tileX, tileY];
if map.IsGhost then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FUndoList^.Add(TDrawMapPacket.Create(tileX, tileY, map.RawZ, map.RawTileID));
dmNetwork.Send(TDrawMapPacket.Create(tileX, tileY, map.Z, map.TileID));
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
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
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
dmNetwork.Send(TInsertStaticPacket.Create(tile.X, tile.Y, tile.Z, tile.TileID, TGhostTile(tile).Hue));
FUndoList^.Add(TDeleteStaticPacket.Create(TGhostTile(tile)));
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
end else if (SelectedTile <> targetTile) or targetTile.CanBeEdited then
begin
if (not acMove.Checked) or (SelectedTile <> targetTile) or
(not frmMoveSettings.cbAsk.Checked) or ConfirmAction then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
targetBlocks := TBlockInfoList.Create;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if SelectedTile = targetTile then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
blockInfo := nil;
while FScreenBuffer.Iterate(blockInfo) do
begin
if blockInfo^.Item = targetTile then
begin
targetBlocks.Add(blockInfo);
Break;
end;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end else
begin
blockInfo := nil;
while FScreenBuffer.Iterate(blockInfo) do
begin
if (blockInfo^.State = ssNormal) and
blockInfo^.Item.CanBeEdited and
IsInRect(blockInfo^.Item.X, blockInfo^.Item.Y, targetRect) then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
targetBlocks.Add(blockInfo);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
end;
if acMove.Checked then //***** Move tile *****//
begin
offsetX := frmMoveSettings.GetOffsetX;
offsetY := frmMoveSettings.GetOffsetY;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if (frmMoveSettings.cbLand.Checked) then begin
if offsetX >= 0 then newX := $7FFF else newX := 0;
if offsetY >= 0 then newY := $7FFF else newY := 0;
for i := 0 to targetBlocks.Count - 1 do if (targetBlocks.Items[i]^.Item is TMapCell) then begin
if offsetX >= 0 then newX := min(newX, targetBlocks.Items[i]^.Item.X) else newX := max(newX, targetBlocks.Items[i]^.Item.X - 1);
if offsetY >= 0 then newY := min(newY, targetBlocks.Items[i]^.Item.Y) else newY := max(newY, targetBlocks.Items[i]^.Item.Y - 1);
end;
tileX := 0;
if offsetY > 0 then for i := newY to newY + offsetY do inc(tileX, FLandscape.MapCell[newX,i].RawZ+128) else
if offsetY < 0 then for i := newY + offsetY to newY do inc(tileX, FLandscape.MapCell[newX,i].RawZ+128);
if offsetX > 0 then for i := newX to newX + offsetX do inc(tileX, FLandscape.MapCell[i,newY].RawZ+128) else
if offsetX < 0 then for i := newX + offsetX to newX do inc(tileX, FLandscape.MapCell[i,newY].RawZ+128);
if (offsetX <> 0) and (offsetY <> 0)
then tileY := tileX div (abs(offsetX) + abs(offsetY) + 2)
else tileY := tileX div (abs(offsetX) + abs(offsetY) + 1);
z := max(-128, min(tileY - 128, +127));
end;
for i := 0 to targetBlocks.Count - 1 do
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
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;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if (frmMoveSettings.cbItem.Checked) and (tile is TStaticItem) then begin
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
newX := EnsureRange(tile.X + offsetX, 0, FLandscape.CellWidth - 1);
newY := EnsureRange(tile.Y + offsetY, 0, FLandscape.CellHeight - 1);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
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));
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);
map := FLandscape.MapCell[newX, newY];
// Это не очень хорошо, для оптимизации следует ввести специальный пакет TMoveMapPacket
FUndoList^.Add(TDrawMapPacket.Create(tile.X, tile.Y, tile.Z, tile.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));
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
end else if acElevate.Checked then //***** Elevate tile *****//
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
for i := 0 to targetBlocks.Count - 1 do
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tile := targetBlocks.Items[i]^.Item;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
z := frmElevateSettings.seZ.Value;
if frmElevateSettings.rbRaise.Checked then
z := EnsureRange(tile.Z + z, -128, 127)
else if frmElevateSettings.rbLower.Checked then
z := EnsureRange(tile.Z - z, -128, 127);
if tile is TMapCell then
begin
if frmElevateSettings.cbRandomHeight.Checked then
Inc(z, Random(frmElevateSettings.seRandomHeight.Value));
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FUndoList^.Add(TDrawMapPacket.Create(tile.X, tile.Y, tile.Z,
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
tile.TileID));
dmNetwork.Send(TDrawMapPacket.Create(tile.X, tile.Y, z,
tile.TileID));
end else
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FUndoList^.Add(TElevateStaticPacket.Create(tile.X, tile.Y,
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
z, tile.TileID, TStaticItem(tile).Hue, tile.Z));
dmNetwork.Send(TElevateStaticPacket.Create(TStaticItem(tile), z));
end;
end;
end else if acDelete.Checked then //***** Delete tile *****//
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
Logger.Send([lcClient, lcDebug], 'targetBlocks.Count', targetBlocks.Count);
for i := 0 to targetBlocks.Count - 1 do
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tile := targetBlocks.Items[i]^.Item;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if tile is TStaticItem then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FUndoList^.Add(TInsertStaticPacket.Create(tile.X, tile.Y,
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
tile.Z, tile.TileID, TStaticItem(tile).Hue));
dmNetwork.Send(TDeleteStaticPacket.Create(TStaticItem(tile)));
end;
end;
end else if acHue.Checked then //***** Hue tile *****//
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
for i := 0 to targetBlocks.Count - 1 do
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
blockInfo := targetBlocks.Items[i];
tile := blockInfo^.Item;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if blockInfo^.HueOverride and (tile is TStaticItem) then
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if TStaticItem(tile).Hue <> blockInfo^.Hue then
begin
FUndoList^.Add(THueStaticPacket.Create(tile.X, tile.Y, tile.Z,
tile.TileID, blockInfo^.Hue, TStaticItem(tile).Hue));
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
dmNetwork.Send(THueStaticPacket.Create(TStaticItem(tile),
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
blockInfo^.Hue));
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
blockInfo := nil;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
targetBlocks.Free;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
end;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
acUndo.Enabled := FUndoList^.Count > 0;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
SelectedTile := nil;
FRepaintNeeded := True;
Logger.ExitMethod([lcClient, lcDebug], 'MouseUp');
end;
procedure TfrmMain.oglGameWindowMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
var
cursorNeedsUpdate: Boolean;
newZ: ShortInt;
begin
//We want single steps ...
WheelDelta := WheelDelta div WHEEL_DELTA;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if ((Word(GetKeyState(VK_X)) and $8000)<>0) then begin
if (Shift = [ssCtrl]) then begin
frmBoundaries.seMinX.Value := frmBoundaries.seMinX.Value + min(max(WheelDelta,
frmBoundaries.seMinX.MinValue-frmBoundaries.seMinX.Value),
frmBoundaries.seMinX.MaxValue-frmBoundaries.seMinX.Value);
frmBoundaries.seMinXChange(nil); exit; end
else if (Shift = [ssShift]) then begin
frmBoundaries.seMaxX.Value := frmBoundaries.seMaxX.Value + min(max(WheelDelta,
frmBoundaries.seMaxX.MinValue-frmBoundaries.seMaxX.Value),
frmBoundaries.seMaxX.MaxValue-frmBoundaries.seMaxX.Value);
frmBoundaries.seMaxXChange(nil); exit; end;
end else if ((Word(GetKeyState(VK_C)) and $8000)<>0) then begin
if (Shift = [ssCtrl]) then begin
frmBoundaries.seMinY.Value := frmBoundaries.seMinY.Value + min(max(WheelDelta,
frmBoundaries.seMinY.MinValue-frmBoundaries.seMinY.Value),
frmBoundaries.seMinY.MaxValue-frmBoundaries.seMinY.Value);
frmBoundaries.seMinYChange(nil); exit; end
else if (Shift = [ssShift]) then begin
frmBoundaries.seMaxY.Value := frmBoundaries.seMaxY.Value + min(max(WheelDelta,
frmBoundaries.seMaxY.MinValue-frmBoundaries.seMaxY.Value),
frmBoundaries.seMaxY.MaxValue-frmBoundaries.seMaxY.Value);
frmBoundaries.seMaxYChange(nil); exit; end;
end else begin
if (Shift = [ssCtrl]) then begin
frmBoundaries.seMinZ.Value := frmBoundaries.seMinZ.Value + min(max(WheelDelta,
frmBoundaries.seMinZ.MinValue-frmBoundaries.seMinZ.Value),
frmBoundaries.seMinZ.MaxValue-frmBoundaries.seMinZ.Value);
frmBoundaries.seMinZChange(nil); exit; end
else if (Shift = [ssShift]) then begin
frmBoundaries.seMaxZ.Value := frmBoundaries.seMaxZ.Value + min(max(WheelDelta,
frmBoundaries.seMaxZ.MinValue-frmBoundaries.seMaxZ.Value),
frmBoundaries.seMaxZ.MaxValue-frmBoundaries.seMaxZ.Value);
frmBoundaries.seMaxZChange(nil); exit; end;
end;
if CurrentTile = nil then
Exit;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
cursorNeedsUpdate := False;
if (CurrentTile is TVirtualTile) or ((ssCtrl in Shift) and
(frmVirtualLayer.cbShowLayer.Checked)) then
begin
frmVirtualLayer.seZ.Value := EnsureRange(frmVirtualLayer.seZ.Value +
WheelDelta, -128, 127);
frmVirtualLayer.seZChange(frmVirtualLayer.seZ);
cursorNeedsUpdate := True;
Handled := True;
end else if not (ssCtrl in Shift) then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FUndoList := GetNextUndoList;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
newZ := EnsureRange(CurrentTile.Z + WheelDelta, -128, 127);
if CurrentTile is TStaticItem then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FUndoList^.Add(TElevateStaticPacket.Create(CurrentTile.X, CurrentTile.Y,
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
newZ, CurrentTile.TileID, TStaticItem(CurrentTile).Hue,
CurrentTile.Z));
dmNetwork.Send(TElevateStaticPacket.Create(TStaticItem(CurrentTile),
newZ));
cursorNeedsUpdate := True;
Handled := True;
end else if CurrentTile is TMapCell then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FUndoList^.Add(TDrawMapPacket.Create(CurrentTile.X, CurrentTile.Y,
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
CurrentTile.Z, CurrentTile.TileID));
dmNetwork.Send(TDrawMapPacket.Create(CurrentTile.X, CurrentTile.Y,
newZ, CurrentTile.TileID));
Handled := True;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
acUndo.Enabled := FUndoList^.Count > 0;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
if cursorNeedsUpdate then
begin
SetCursorPos(Mouse.CursorPos.X, Mouse.CursorPos.Y - 4 * WheelDelta);
UpdateCurrentTile(MousePos.X, MousePos.Y - 4 * WheelDelta);
end;
FRepaintNeeded := True;
end;
procedure TfrmMain.FormCreate(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
var
i : Integer;
ARegistry: TRegistry;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
Logger.EnterMethod([lcLandscape, lcDebug], 'TfrmMain.FormCreate(Sender: TObject)');
// Подменяем TVirtualDrawTree на его перегруженный аналог TVirtualList
vdtTiles := TVirtualList.Create(vdtTiles);
vdtRandom := TVirtualList.Create(vdtRandom);
vdlRandom := TVirtualList(vdtRandom); // Лазареусу пчмуто не нравиться если поменять тип у vdtRandom
oglGameWindow.Cursor := +01;
pcLeft.ActivePageIndex := tsNavigation.PageIndex;
LanguageTranslate(Self);
Application.TaskBarBehavior := tbSingleButton;
{
BorderStyle := bsNone;
FormStyle := fsStayOnTop;
WindowState := wsMaximized;
Left:=0; Top:=0;
Width:=1920;
Height:=1200; }
//oglGameWindow.Visible:= false;
//oglGameWindowResize(Sender);
ARegistry := TRegistry.Create();
ARegistry.RootKey := HKEY_LOCAL_MACHINE;
ARegistry.OpenKey('\SOFTWARE\Quintessence\UO CentrED+', False);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
FAppDir := IncludeTrailingPathDelimiter(ExtractFilePath(Application.ExeName));
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FLocalDir := FAppDir + '..' + PathDelim + 'LocalData' + PathDelim;
if ARegistry.ReadBool('UseConfigDir')
then FConfigDir := GetAppConfigDir(False)
else FConfigDir := FLocalDir + 'UsersData' + PathDelim;
ARegistry.Free;
if (sprofile <> '')
then FProfileDir := FConfigDir + 'Profiles' + PathDelim + UTF8ToCP1251(sprofile) + PathDelim
else FProfileDir := '';
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
ForceDirectories(FConfigDir);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if (FProfileDir <> '')
then XMLPropStorage1.FileName := FProfileDir + 'Config.xml'
else XMLPropStorage1.FileName := FConfigDir + 'Config.xml';
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
XMLPropStorage1.Active := True;
FLandscape := ResMan.Landscape;
FLandscape.OnChange := @OnLandscapeChanged;
FLandscape.OnMapChanged := @OnMapChanged;
FLandscape.OnNewBlock := @OnNewBlock;
FLandscape.OnStaticDeleted := @OnStaticDeleted;
FLandscape.OnStaticElevated := @OnStaticElevated;
FLandscape.OnStaticHued := @OnStaticHued;
FLandscape.OnStaticInserted := @OnStaticInserted;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
Logger.Send([lcClient, lcInfo], 'LoadNoDrawMap()...');
if FileExists(FProfileDir + 'VirtualTiles.xml') then
FLandscape.LoadNoDrawMap(FProfileDir + 'VirtualTiles.xml')
else begin
if FileExists(FLocalDir + 'VirtualTiles.xml') then
FLandscape.LoadNoDrawMap(FLocalDir + 'VirtualTiles.xml');
if FileExists(FConfigDir + 'VirtualTiles.xml') then
FLandscape.LoadNoDrawMap(FConfigDir + 'VirtualTiles.xml');
if FileExists(ResMan.GetFile('VirtualTiles.xml')) then
FLandscape.LoadNoDrawMap(ResMan.GetFile('VirtualTiles.xml'));
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
FTextureManager := TLandTextureManager.Create;
FScreenBuffer := TScreenBuffer.Create;
FScreenBufferState := [];
X := 0;
Y := 0;
edX.MaxValue := FLandscape.CellWidth;
edY.MaxValue := FLandscape.CellHeight;
FOverlayUI := TOverlayUI.Create;
FLightManager := TLightManager.Create(@GetDrawOffset);
ProcessAccessLevel;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
Logger.Send([lcClient, lcInfo], 'LoadLightSourceTiles()...');
if FileExists(FProfileDir + 'VirtualTiles.xml') then
LoadLightSourceTiles (FProfileDir + 'VirtualTiles.xml')
else begin
if FileExists(FLocalDir + 'VirtualTiles.xml') then
LoadLightSourceTiles (FLocalDir + 'VirtualTiles.xml');
if FileExists(FConfigDir + 'VirtualTiles.xml') then
LoadLightSourceTiles (FConfigDir + 'VirtualTiles.xml');
if FileExists(ResMan.GetFile('VirtualTiles.xml')) then
LoadLightSourceTiles (ResMan.GetFile('VirtualTiles.xml'));
end;
Logger.Send([lcClient, lcInfo], 'LoadVisibleTiles()...');
if FileExists(FProfileDir + 'VirtualTiles.xml') then
LoadVisibleTiles(FProfileDir + 'VirtualTiles.xml')
else begin
if FileExists(FLocalDir + 'VirtualTiles.xml') then
LoadVisibleTiles(FLocalDir + 'VirtualTiles.xml');
if FileExists(FConfigDir + 'VirtualTiles.xml') then
LoadVisibleTiles(FConfigDir + 'VirtualTiles.xml');
if FileExists(ResMan.GetFile('VirtualTiles.xml')) then
LoadVisibleTiles(ResMan.GetFile('VirtualTiles.xml'));
end;
Logger.Send([lcClient, lcInfo], 'LoadColorLight()...');
if FileExists(FProfileDir + 'ColorLight.xml') then
FLightManager.LoadConfig(FProfileDir + 'ColorLight.xml')
else begin
if FileExists(FLocalDir + 'ColorLight.xml') then
FLightManager.LoadConfig(FLocalDir + 'ColorLight.xml');
if FileExists(FConfigDir + 'ColorLight.xml') then
FLightManager.LoadConfig(FConfigDir + 'ColorLight.xml');
if FileExists(ResMan.GetFile('ColorLight.xml')) then
FLightManager.LoadConfig(ResMan.GetFile('ColorLight.xml'));
end;
FTilesSelectionUndoRedoCommandGroup := TUndoRedoCommandGroup.Create;
FGroupsSelectionUndoRedoCommandGroup := TUndoRedoCommandGroup.Create;
FTilesSelectionUndoRedoManager := TUndoRedoManager.Create;
FGroupsSelectionUndoRedoManager := TUndoRedoManager.Create;
tvGroups.NodeDataSize := SizeOf(TGroupNode);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
vdtTiles.NodeDataSize := SizeOf(TTileInfo);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
vdlRandom.NodeDataSize := SizeOf(TTileInfo);
//mnuTileListViewClick(nil);
LoadEntryTilesList;
LoadBrushTilesList;
LoadSurfsTilesList;
BuildGroupList;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
BuildTileList;
Randomize;
vstChat.NodeDataSize := SizeOf(TChatInfo);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
pnlChatHeader.AnchorSide[akBottom].Control := pcLeft;
pnlChatHeader.AnchorSide[akBottom].Side := asrBottom;
if FProfileDir <> ''
then FLocationsFile := FProfileDir + 'Locations.xml'
else FLocationsFile := FConfigDir + 'Locations.xml';
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
vstLocations.NodeDataSize := SizeOf(TLocationInfo);
LoadLocations;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
vstClients.NodeDataSize := SizeOf(TClientInfo);
Logger.Send([lcClient, lcInfo], 'RegisterPacketHandler()...');
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
RegisterPacketHandler($0C, TPacketHandler.Create(0, @OnClientHandlingPacket));
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FVLayerImage := TSingleImage.CreateFromStream(ResourceManager.GetResource('Overlay/VirtualLayer.tga'));
FVLightSrcImage[ 1] := TSingleImage.CreateFromStream(ResourceManager.GetResource('Overlay/LightBulb_24nn.tga'));
FVLightSrcImage[ 2] := TSingleImage.CreateFromStream(ResourceManager.GetResource('Overlay/LightBulb_24bw.tga'));
FVLightSrcImage[ 3] := TSingleImage.CreateFromStream(ResourceManager.GetResource('Overlay/LightBulb_24tw.tga'));
FVLightSrcImage[ 4] := TSingleImage.CreateFromStream(ResourceManager.GetResource('Overlay/LightBulb_24bo.tga'));
FVLightSrcImage[ 5] := TSingleImage.CreateFromStream(ResourceManager.GetResource('Overlay/LightBulb_24to.tga'));
FVLightSrcImage[ 6] := TSingleImage.CreateFromStream(ResourceManager.GetResource('Overlay/LightBulb_24by.tga'));
FVLightSrcImage[ 7] := TSingleImage.CreateFromStream(ResourceManager.GetResource('Overlay/LightBulb_24ty.tga'));
FVLightSrcImage[ 8] := TSingleImage.CreateFromStream(ResourceManager.GetResource('Overlay/LightBulb_24ny.tga'));
FVLightSrcImage[ 9] := TSingleImage.CreateFromStream(ResourceManager.GetResource('Overlay/LightBulb_24bl.tga'));
FVLightSrcImage[10] := TSingleImage.CreateFromStream(ResourceManager.GetResource('Overlay/LightBulb_24bb.tga'));
FVLightSrcImage[11] := TSingleImage.CreateFromStream(ResourceManager.GetResource('Overlay/LightBulb_24tb.tga'));
FVLightSrcImage[12] := TSingleImage.CreateFromStream(ResourceManager.GetResource('Overlay/LightBulb_24bg.tga'));
FVLightSrcImage[13] := TSingleImage.CreateFromStream(ResourceManager.GetResource('Overlay/LightBulb_24tg.tga'));
FVLightSrcImage[14] := TSingleImage.CreateFromStream(ResourceManager.GetResource('Overlay/LightBulb_24br.tga'));
FVLightSrcImage[15] := TSingleImage.CreateFromStream(ResourceManager.GetResource('Overlay/LightBulb_24bp.tga'));
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
FGLFont := TGLFont.Create;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FGLFont.LoadImage(ResourceManager.GetResource('GLFont/DejaVu.png'));
FGLFont.LoadFontInfo(ResourceManager.GetResource('GLFont/DejaVu.fnt'));
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
Logger.Send([lcClient, lcInfo], 'TWorldItemList.Create(True)...');
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
FVirtualTiles := TWorldItemList.Create(True);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
for i:=1 to FUndoListLength do
FUndoListArray[i] := TPacketList.Create(True);
FUndoList := @FUndoListArray[1];
FUndoListFirstIndex := 0;
FundoListLastIndex := 0;
if FProfileDir <> ''
then FRandomPresetsFile := FProfileDir + 'RandomPresets.xml'
else FRandomPresetsFile := FConfigDir + 'RandomPresets.xml';
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
LoadRandomPresets;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
Logger.Send([lcClient, lcInfo], 'Завершение загрузки...');
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
DoubleBuffered := True;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
//pnlBottom.DoubleBuffered := True;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
FAccessChangedListeners := TAccessChangedListeners.Create;
FSelectionListeners := TSelectionListeners.Create;
FLastDraw := Now;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
Logger.ExitMethod([lcLandscape, lcDebug], 'TfrmMain.FormCreate(Sender: TObject)');
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.btnGoToClick(Sender: TObject);
begin
SetPos(edX.Value, edY.Value);
end;
procedure TfrmMain.btnRandomPresetDeleteClick(Sender: TObject);
var
preset: TDOMElement;
begin
if cbRandomPreset.ItemIndex > -1 then
begin
preset := TDOMElement(cbRandomPreset.Items.Objects[cbRandomPreset.ItemIndex]);
FRandomPresetsDoc.DocumentElement.RemoveChild(preset);
cbRandomPreset.Items.Delete(cbRandomPreset.ItemIndex);
cbRandomPreset.ItemIndex := -1;
end;
end;
procedure TfrmMain.btnRandomPresetSaveClick(Sender: TObject);
var
presetName: string;
i: Integer;
preset, tile: TDOMElement;
children: TDOMNodeList;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tileNode: PVirtualItem;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
tileInfo: PTileInfo;
begin
presetName := cbRandomPreset.Text;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if InputQuery(lbDlgSaveRandPrsCaption, lbDlgSaveRandPrs, presetName) then
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
preset := FindRandomPreset(presetName);
if preset = nil then
begin
preset := FRandomPresetsDoc.CreateElement('Preset');
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
preset.AttribStrings['Name'] := UTF8ToCP1251(presetName);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
FRandomPresetsDoc.DocumentElement.AppendChild(preset);
cbRandomPreset.Items.AddObject(presetName, preset);
end else
begin
children := preset.ChildNodes;
for i := children.Count - 1 downto 0 do
preset.RemoveChild(children[i]);
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tileNode := vdlRandom.GetFirst;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
while tileNode <> nil do
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tileInfo := vdlRandom.GetNodeData(tileNode);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
tile := FRandomPresetsDoc.CreateElement('Tile');
tile.AttribStrings['ID'] := IntToStr(tileInfo^.ID);
preset.AppendChild(tile);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tileNode := vdlRandom.GetNext(tileNode);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
cbRandomPreset.ItemIndex := cbRandomPreset.Items.IndexOfObject(preset);
SaveRandomPresets;
end;
end;
procedure TfrmMain.cbRandomPresetChange(Sender: TObject);
var
preset, tile: TDOMElement;
tiles: TDOMNodeList;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tileNode: PVirtualItem;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
tileInfo: PTileInfo;
i, id: Integer;
begin
if cbRandomPreset.ItemIndex > -1 then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
vdlRandom.Clear;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
preset := TDOMElement(cbRandomPreset.Items.Objects[cbRandomPreset.ItemIndex]);
tiles := preset.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
(id < FLandscape.MaxStaticID + $4000) then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tileNode := vdlRandom.AddItem(nil);
tileInfo := vdlRandom.GetNodeData(tileNode);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
tileInfo^.ID := id;
end;
end;
end;
end;
procedure TfrmMain.btnAddRandomClick(Sender: TObject);
var
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
selected: PVirtualItem;
node: PVirtualItem;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
sourceTileInfo, targetTileInfo: PTileInfo;
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
vdlRandom.BeginUpdate;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
selected := vdtTiles.GetFirstSelected;
while selected <> nil do
begin
sourceTileInfo := vdtTiles.GetNodeData(selected);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
node := vdlRandom.AddItem(nil);
targetTileInfo := vdlRandom.GetNodeData(node);
targetTileInfo^.ID := sourceTileInfo^.ID;
targetTileInfo^.ptr := sourceTileInfo^.ptr;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
selected := vdtTiles.GetNextSelected(selected);
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
vdlRandom.EndUpdate;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.btnClearLocationsClick(Sender: TObject);
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if MessageDlg(lbDlgDelConfCaption, lbDlgDelConf,
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
mtConfirmation, [mbYes, mbNo], 0) = mrYes then
begin
vstLocations.Clear;
end;
end;
procedure TfrmMain.ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
begin
if (FScreenBufferState <> CScreenBufferValid) or
((FRepaintNeeded or mnuShowAnimations.Checked) and
(MilliSecondsBetween(Now, FLastDraw) > 50)) then
begin
//Logger.Send([lcClient, lcDebug], 'Repainting Game Window');
oglGameWindow.Repaint;
FLastDraw := Now;
FRepaintNeeded := False;
end;
Sleep(1);
Done := False;
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) +
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
Length(FTileHint.Obj) + Length(FTileHint.Flags));
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.btnAddLocationClick(Sender: TObject);
var
locationName: string;
locationInfo: PLocationInfo;
begin
locationName := '';
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if InputQuery(lbDlgNewQuerryCaption, lbDlgNewQuerry,
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
locationName) then
begin
locationInfo := vstLocations.GetNodeData(vstLocations.AddChild(nil));
locationInfo^.X := X;
locationInfo^.Y := Y;
locationInfo^.Name := locationName;
end;
end;
procedure TfrmMain.acSelectExecute(Sender: TObject);
begin
acSelect.Checked := True;
tbSelect.Down := True;
mnuSelect.Checked := True;
ProcessToolState;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.acSelectionExecute(Sender: TObject);
begin
acSelection.Checked := True;
tbSelection.Down := True;
mnuSelection.Checked := True;
frmSelectionSettings.Show;
ProcessToolState;
end;
function TfrmMain.GetNextUndoList: PPacketList;
var
i: Integer;
begin
Inc(FUndoListLastIndex, 1);
if FUndoListLastIndex > FUndoListLength
then FUndoListLastIndex := 1;
if (FUndoListFirstIndex = FUndoListLastIndex) or (FUndoListFirstIndex = 0)
then Inc(FUndoListFirstIndex, 1);
if FUndoListFirstIndex > FUndoListLength
then FUndoListFirstIndex := 1;
if FUndoListFirstIndex <= FUndoListLastIndex
then i := FUndoListLastIndex - FUndoListFirstIndex + 1
else i := FUndoListLastIndex + FUndoListLength - FUndoListFirstIndex + 1;
tbUndo.Hint := lbToolbarUndo + ' (' + IntToStr(i) + ').';
FUndoListArray[FundoListLastIndex].Clear;
GetNextUndoList := @FUndoListArray[FundoListLastIndex];
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure TfrmMain.acUndoExecute(Sender: TObject);
var
i: Integer;
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
for i := FUndoList^.Count - 1 downto 0 do
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
dmNetwork.Send(FUndoList^[i]);
FUndoList^[i] := nil;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FUndoList^.Clear;
if FUndoListLastIndex = FUndoListFirstIndex then
begin
FUndoListFirstIndex:= 0;
FUndoListLastIndex := 0;
tbUndo.Hint := lbToolbarUndo + ' (0).';
acUndo.Enabled := False;
end
else
begin
Inc(FUndoListLastIndex, -1);
if FUndoListLastIndex = 0
then FUndoListLastIndex := FUndoListLength;
FUndoList := @FUndoListArray[FundoListLastIndex];
if FUndoListFirstIndex <= FUndoListLastIndex
then i := FUndoListLastIndex - FUndoListFirstIndex + 1
else i := FUndoListLastIndex + FUndoListLength - FUndoListFirstIndex + 1;
tbUndo.Hint := lbToolbarUndo + ' (' + IntToStr(i) + ').';
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.acVirtualLayerExecute(Sender: TObject);
begin
frmVirtualLayer.Show;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.acTerrainExecute(Sender: TObject);
begin
acTerrain.Checked := not acTerrain.Checked;
//tbTerrain.Down := acTerrain.Checked;
RebuildScreenBuffer;
end;
procedure TfrmMain.acStaticsExecute(Sender: TObject);
begin
acStatics.Checked := not acStatics.Checked;
RebuildScreenBuffer;
end;
- Added optional highlight for (un)walkable tiles - Fixed lightmanager to draw in the correct color - Fixed TMapBlock and TStaticBlock to correctly initialize itself as "unchanged" - Cleanup in the server project
2009-12-24 15:49:15 +01:00
procedure TfrmMain.acWalkableExecute(Sender: TObject);
begin
InvalidateFilter;
FRepaintNeeded := True;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.acGridExecute(Sender: TObject);
begin
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure TfrmMain.acDrawExecute(Sender: TObject);
begin
acDraw.Checked := True;
tbDrawTile.Down := True;
mnuDraw.Checked := True;
frmDrawSettings.Show;
ProcessToolState;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.acFillExecute(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
acFill.Checked := True;
tbFill.Down := True;
mnuFill.Checked := True;
frmFillSettings.Show;
ProcessToolState;
end;
procedure TfrmMain.acDeleteExecute(Sender: TObject);
begin
acDelete.Checked := True;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
tbDeleteTile.Down := True;
mnuDelete.Checked := True;
ProcessToolState;
end;
procedure TfrmMain.acBoundariesExecute(Sender: TObject);
begin
frmBoundaries.Show;
end;
procedure TfrmMain.acElevateExecute(Sender: TObject);
begin
acElevate.Checked := True;
tbElevateTile.Down := True;
mnuElevate.Checked := True;
ProcessToolState;
frmElevateSettings.Show;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.acSurfElevateExecute(Sender: TObject);
begin
acSurfElevate.Checked := True;
tbSurfElevate.Down := True;
mnuSurfElevate.Checked := True;
frmSurfElevateSettings.Show;
ProcessToolState;
end;
procedure TfrmMain.acSurfStretchExecute(Sender: TObject);
begin
acSurfStretch.Checked := True;
tbSurfStretch.Down := True;
mnuSurfStretch.Checked := True;
frmSurfStretchSettings.Show;
ProcessToolState;
end;
procedure TfrmMain.acSurfSmoothExecute(Sender: TObject);
begin
acSurfSmooth.Checked := True;
tbSurfSmooth.Down := True;
mnuSurfSmooth.Checked := True;
frmSurfSmoothSettings.Show;
ProcessToolState;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure TfrmMain.acFilterExecute(Sender: TObject);
begin
if acFilter.Checked then
begin
frmFilter.Show;
frmFilter.Locked := False;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if (tbFilter.Down) then begin
frmFilter.tFormClose.Interval := 1500;
frmFilter.tFormClose.Tag := PtrInt(True);
frmFilter.tFormClose.Enabled := True;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end else
frmFilter.Hide;
InvalidateFilter;
end;
procedure TfrmMain.acFlatExecute(Sender: TObject);
begin
acFlat.Checked := not acFlat.Checked;
RebuildScreenBuffer;
end;
procedure TfrmMain.acHueExecute(Sender: TObject);
begin
acHue.Checked := True;
tbSetHue.Down := True;
mnuSetHue.Checked := True;
ProcessToolState;
frmHueSettings.Show;
end;
procedure TfrmMain.acLightlevelExecute(Sender: TObject);
begin
frmLightlevel.Show;
end;
procedure TfrmMain.acMoveExecute(Sender: TObject);
begin
acMove.Checked := True;
tbMoveTile.Down := True;
mnuMove.Checked := True;
ProcessToolState;
frmMoveSettings.Show;
end;
procedure TfrmMain.acNoDrawExecute(Sender: TObject);
begin
acNoDraw.Checked := not acNoDraw.Checked;
RebuildScreenBuffer;
end;
procedure TfrmMain.btnClearRandomClick(Sender: TObject);
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
vdlRandom.BeginUpdate;
vdlRandom.Clear;
vdlRandom.EndUpdate;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.btnDeleteLocationClick(Sender: TObject);
begin
vstLocations.DeleteSelectedNodes;
end;
procedure TfrmMain.btnDeleteRandomClick(Sender: TObject);
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
vdlRandom.BeginUpdate;
vdlRandom.DeleteSelectedNodes;
vdlRandom.EndUpdate;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.cbStaticsChange(Sender: TObject);
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
//tvGroups.Enabled := not (cbStatics.Checked or cbTerrain.Checked);
if mnuAutoHideGroupList.Checked then begin
if (((cbStatics.Checked) or (cbTerrain.Checked)) = spGroupList.Enabled)
then mnuAutoHideGroupListClick(Sender);
end else if (cbStatics.Checked or cbTerrain.Checked)
then tvGroups.ClearSelection;
//if (not cbStatics.Checked) and (not cbTerrain.Checked) then
// cbTerrain.Checked := True;
//if tvGroups.Selected <> nil then
// tvGroups.Selected := nil
//else
BuildTileList;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.cbTerrainChange(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
begin
if mnuAutoHideGroupList.Checked then
if (((cbStatics.Checked) or (cbTerrain.Checked)) = spGroupList.Enabled)
then mnuAutoHideGroupListClick(Sender);
//if (not cbTerrain.Checked) and (not cbStatics.Checked) then
// cbStatics.Checked := True;
//if tvGroups.Selected <> nil then
// tvGroups.Selected := nil
//else
BuildTileList;
end;
procedure TfrmMain.tvSelectGroupsChanged(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
if (not cbTerrain.Checked) and (not cbStatics.Checked) then
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
BuildTileList;
// if Sender = cbStatics then
// MessageDlg('Ошибка', 'Тайл с указанным ID не был найден.' +
// LineEnding + 'Проверте конфликты настроек фильтров.', mtError, [mbOK], 0);
if cbTerrain.Checked then cbTerrain.Checked := False;
if cbStatics.Checked then cbStatics.Checked := False;
end;
procedure TfrmMain.mnuReloadGroupsClick(Sender: TObject);
var
fPath : string;
begin
FreeGroupLists;
LoadEntryTilesList;
LoadBrushTilesList;
LoadSurfsTilesList;
BuildGroupList;
if FileExists(FProfileDir + 'ColorLight.xml')
then fPath := (FProfileDir + 'ColorLight.xml')
else if FileExists(FLocalDir + 'ColorLight.xml')
then fPath := (FLocalDir + 'ColorLight.xml')
else if FileExists(FConfigDir + 'ColorLight.xml')
then fPath := (FConfigDir + 'ColorLight.xml')
else if FileExists(ResMan.GetFile('ColorLight.xml'))
then fPath := (ResMan.GetFile('ColorLight.xml'))
else Exit;
FLightManager.LoadConfig(fPath);
if FileExists(FProfileDir + 'VirtualTiles.xml')
then fPath := (FProfileDir + 'VirtualTiles.xml')
else if FileExists(FLocalDir + 'VirtualTiles.xml')
then fPath := (FLocalDir + 'VirtualTiles.xml')
else if FileExists(FConfigDir + 'VirtualTiles.xml')
then fPath := (FConfigDir + 'VirtualTiles.xml')
else if FileExists(ResMan.GetFile('VirtualTiles.xml'))
then fPath := (ResMan.GetFile('VirtualTiles.xml'))
else Exit;
LoadLightSourceTiles(fPath);
LoadVisibleTiles(fPath);
end;
procedure TfrmMain.mnuSetLanguageClick(Sender: TObject);
var
settings: TIniFile;
begin
LanguageSet(Integer(TMenuItem(Sender).Tag));
ReloadLanguageTranslation();
frmMain.Menu := nil; // Перерисовываем главное меню
frmMain.Menu := MainMenu1;
ProcessAccessLevel; // Обновляем заголовок формы
// Запоминаем выбранный язык
settings := TIniFile.Create(FConfigDir + 'LoginSettings.ini');
settings.WriteString('Profile', 'Lang', TMenuItem(Sender).Caption);
settings.Free;
end;
//procedure ssrSaveHandle(handle: HWND; filepath: PChar); external 'SSRender';
//function GetDesktopWindow(): HWND; external 'SSRender';
function GetDesktopWindow:HWND; external 'user32' name 'GetDesktopWindow';
procedure TfrmMain.mnuMakeScreenShotClick(Sender: TObject);
var
Bitmap: TBitmap;
Image: TJPEGImage;
ScreenWND: HWND;
ScreenDC: HDC;
DateTime: TDateTime;
FolderPath: string;
Refocus: Boolean;
srcRect, destRect: TRect;
oglPoint: TPoint;
begin
Bitmap:= TBitmap.Create;
Image := TJPEGImage.Create;
// Снимаем фокус с окна (чтобы убрать стрелочки)
Refocus := oglGameWindow.Focused;
if Refocus then begin
oglGameWindowMouseLeave(Sender);
oglGameWindow.Paint;
end;
// Получение контекстного устройства
oglGameWindow.HandleNeeded;
ScreenWND := GetDesktopWindow();// oglGameWindow.Handle; //Handle;//0;//
ScreenDC := GetDC(ScreenWND); //GetDeviceContext(ScreenWND);
if ScreenDC<>0 then try
// Получаем "буффер" экрана
Bitmap.LoadFromDevice(ScreenDC);
// Размеры сохраняемого изображения
destRect.Left :=0;
destRect.Top :=0;
destRect.Right :=oglGameWindow.Width;
destRect.Bottom:=oglGameWindow.Height;
Image.SetSize(destRect.Right, destRect.Bottom);
// Сохраняемая область на экране
oglPoint.x := 0; oglPoint.y := 0;
oglPoint := oglGameWindow.ClientToScreen(oglPoint);
srcRect.Left := oglPoint.x;
srcRect.Top := oglPoint.y;
srcRect.Right := srcRect.Left + destRect.Right;
srcRect.Bottom := srcRect.Top + destRect.Bottom;
// Копируем область с экрана на сохраняемое изображение
Image.Canvas.CopyRect(destRect, Bitmap.Canvas, srcRect);
// Сохраняем файл
DateTime := Now;
FolderPath := FAppDir + '../ScreenShots/' + FormatDateTime('YYYY-MM-DD', DateTime) + '/';
ForceDirectories(FolderPath);
Image.SaveToFile(FolderPath + FormatDateTime('HHNN-SSZZZ', DateTime) + '.jpg');
WriteChatMessage('System', Format('%s "./../ScreenShots/%s/%s.jpg"',
[lbScreenShotMsg, FormatDateTime('YYYY-MM-DD', DateTime), FormatDateTime('HHNN-SSZZZ', DateTime)]));
finally
if ReleaseDC(ScreenWND, ScreenDC)<>1 then
MessageDlg(lbDlgFreeDcErrCaption, lbDlgFreeDcErr, mtError, [mbOK], 0);
Bitmap.Free;
Image.Free;
end else
MessageDlg(lbDlgGetDcErrCaption, lbDlgGetDcErr, mtError, [mbOK], 0);
// Возвращаем обратно фокус окна (если надо)
if Refocus then begin
oglGameWindowMouseEnter(Sender);
oglGameWindow.Paint;
end;
//DateTime := Now;
//FolderPath := FAppDir + 'ScreenShots/' + FormatDateTime('YYYY-MM-DD', DateTime) + '/';
//ForceDirectories(FolderPath);
//MessageDlg('Ошибка', Format('Handle: %d File: "%s"', [ScreenWND, FolderPath + FormatDateTime('HHNN-SSZZZ', DateTime) + '.bmp']), mtError, [mbOK], 0);
//ssrSaveHandle(ScreenWND, PChar(FolderPath + FormatDateTime('HHNN-SSZZZ', DateTime) + '.bmp'));
//oglGameWindowResize(Sender);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.edChatKeyPress(Sender: TObject; var Key: char);
begin
if Key = #13 then
begin
Key := #0;
if edChat.Text <> '' then
begin
dmNetwork.Send(TChatMessagePacket.Create(edChat.Text));
edChat.Text := '';
end;
end;
end;
procedure TfrmMain.edFilterEditingDone(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
var
chrtemp: char;
strtemp: string;
inttemp: Integer;
begin
strtemp := edFilter.Text;
if (Length(strtemp) > 2) and (strtemp[1] = '0') and ((strtemp[2] = 'x') or (strtemp[2] = 'X'))
then begin Delete(strtemp, 1, 1); strtemp[1] := '$'; end;
if (TryStrToInt(strtemp, inttemp)) then begin
edSearchID.Text := strtemp;
chrtemp := #13;
Self.edSearchIDKeyPress(nil, chrtemp);
edSearchID.Text := '';
edFilter.Text := '';
Exit;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
BuildTileList;
end;
procedure TfrmMain.FormActivate(Sender: TObject);
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
Logger.EnterMethod([lcLandscape, lcDebug], 'TfrmMain.FormActivate(Sender: TObject)');
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if oglGameWindow.MouseEntered then
oglGameWindowMouseEnter(Sender);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
Logger.ExitMethod([lcLandscape, lcDebug], 'TfrmMain.FormActivate(Sender: TObject)');
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
frmDrawSettings.rbTileList.Checked := True;
frmDrawSettings.rbRandom.Checked := False;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
dmNetwork.CheckClose(Self);
end;
procedure TfrmMain.FormDestroy(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
var
i: Integer;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
CurrentTile := nil;
SelectedTile := nil;
SaveLocations;
SaveRandomPresets;
FreeAndNil(FTextureManager);
FreeAndNil(FScreenBuffer);
FreeAndNil(FOverlayUI);
FreeAndNil(FLightManager);
FreeAndNil(FVLayerImage);
FreeAndNil(FVLayerMaterial);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
for i:=1 to FVLightSrcImageCount do
FreeAndNil(FVLightSrcImage[i]);
if FVLightSrcMaterial <> nil then begin
for i := 0 to FVLightSrcImageCount - 1 do
FreeAndNil(FVLightSrcMaterial[i]);
freemem(FVLightSrcMaterial);
FVLightSrcMaterial := nil;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
FreeAndNil(FVirtualTiles);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
for i:=1 to FUndoListLength do
FreeAndNil(FUndoListArray[i]);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
FreeAndNil(FGLFont);
FreeAndNil(FRandomPresetsDoc);
FreeAndNil(FAccessChangedListeners);
FreeAndNil(FSelectionListeners);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FreeAndNil(FTilesSelectionUndoRedoManager);
FreeAndNil(FGroupsSelectionUndoRedoManager);
FreeAndNil(FTilesSelectionUndoRedoCommandGroup);
FreeAndNil(FGroupsSelectionUndoRedoCommandGroup);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
RegisterPacketHandler($0C, nil);
end;
procedure TfrmMain.edSearchIDExit(Sender: TObject);
begin
edSearchID.Visible := False;
edSearchID.Text := '';
end;
procedure TfrmMain.edSearchIDKeyPress(Sender: TObject; var Key: char);
var
enteredText: String;
tileID: Integer;
tileType: Char;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
item: PVirtualItem;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
tileInfo: PTileInfo;
begin
if Key = #13 then
begin
Key := #0;
enteredText := edSearchID.Text;
tileType := #0;
if Length(enteredText) > 1 then
tileType := enteredText[Length(enteredText)];
if not (tileType in ['S', 'T']) then
begin
if cbTerrain.Checked then
tileType := 'T'
else
tileType := 'S';
end else
Delete(enteredText, Length(enteredText), 1);
tileID := 0;
if not TryStrToInt(enteredText, tileID) then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
MessageDlg(lbDlgSearchIdErrCaption, lbDlgSearchIdErr, mtError, [mbOK], 0);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
vdtTiles.SetFocus;
Exit;
end;
if tileType = 'S' then
Inc(tileID, $4000);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
item := vdtTiles.GetFirst;
while item <> nil do
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tileInfo := vdtTiles.GetNodeData(item);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if tileInfo^.ID = tileID then
begin
vdtTiles.ClearSelection;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
vdtTiles.Selected[item] := True;
vdtTiles.FocusedNode := item;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
Break;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
item := vdtTiles.GetNext(item);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if item = nil then
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
MessageDlg(lbDlgNotFoundErrCaption, lbDlgNotFoundErr, mtError, [mbOK], 0);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
vdtTiles.SetFocus;
Exit;
end;
edSearchID.Visible := False;
end else if Key = #27 then
begin
edSearchID.Visible := False;
Key := #0;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
end else if not (Key in ['$', '0'..'9', 'a'..'f', 'A'..'F', 's', 'S', 't', 'T', #8])
then Key := #0;
end;
procedure TfrmMain.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var UndoRedoManager: TUndoRedoManager;
begin
if Sender=tvGroups then UndoRedoManager:=FGroupsSelectionUndoRedoManager
else if Sender=vdtTiles then UndoRedoManager:=FTilesSelectionUndoRedoManager;
if Button = mbExtra1 then UndoRedoManager.Undo;
if Button = mbExtra2 then UndoRedoManager.Redo;
end;
procedure TfrmMain.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
var UndoRedoManager: TUndoRedoManager;
begin
if Sender=tvGroups then UndoRedoManager:=FGroupsSelectionUndoRedoManager
else if Sender=vdtTiles then UndoRedoManager:=FTilesSelectionUndoRedoManager;
if Key = VK_OEM_PLUS then UndoRedoManager.Redo;
if Key = VK_OEM_MINUS then UndoRedoManager.Undo;
if Key = VK_SPACE then if frmFilter.Visible then begin
frmFilter.Locked := True;
frmFilter.Hide;
frmFilter.Locked := False;
end else frmFilter.Show;
end;
procedure TfrmMain.FormShow(Sender: TObject);
begin
//XMLPropStorage1.Restore;
XMLPropStorage1RestoreProperties(nil);
mnuAutoHideGroupListClick(nil);
mnuAutoHideRandomListClick(nil);
end;
procedure TfrmMain.FormWindowStateChange(Sender: TObject);
//var
// ws: TWindowState;
// h: HWND;
begin
// <20>диотизм тот еще, но иначе приложение не коректно сворачивается
// Logger.Send([lcClient, lcDebug], 'Main Window State Chancged');
if frmMain.WindowState = wsMinimized then begin
if frmRadarMap.Visible then frmRadarMap.WindowState := wsMinimized;
//if frmRegionControl.Visible then frmRegionControl.WindowState := wsMinimized;
//if frmLargeScaleCommand.Visible then frmLargeScaleCommand.WindowState := wsMinimized;
//if frmAccountControl.Visible then frmAccountControl.WindowState := wsMinimized;
//if frmAbout.Visible then frmAbout.WindowState := wsMinimized;
Application.Minimize;
end; // else Application.Restore;
{h:=frmMain.Handle;
if frmMain.WindowState = wsMinimized then begin
ShowWindow(h,SW_HIDE);
SetWindowLong(h, GWL_EXSTYLE, GetWindowLong(h, GWL_EXSTYLE) and not WS_EX_OVERLAPPEDWINDOW or WS_EX_STATICEDGE);
ShowWindow(h,SW_SHOWMINIMIZED);
end else begin
//ShowInTaskBar := stDefault;
ShowWindow(h,SW_HIDE);
SetWindowLong(h, GWL_EXSTYLE, GetWindowLong(h, GWL_EXSTYLE) and not WS_EX_STATICEDGE or WS_EX_OVERLAPPEDWINDOW);
//ShowInTaskBar := stDefault;
ShowWindow(h,SW_RESTORE);
end;}
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.lblChatHeaderCaptionClick(Sender: TObject);
begin
if pnlChat.Visible then
begin
pnlChat.Visible := False;
spChat.Visible := False;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
pnlChatHeader.AnchorSide[akBottom].Control := pcLeft;
pnlChatHeader.AnchorSide[akBottom].Side := asrBottom;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end else
begin
spChat.Visible := True;
pnlChat.Visible := True;
spChat.Top := pnlChat.Top - spChat.Height;
pnlChatHeader.AnchorSide[akBottom].Control := spChat;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
pnlChatHeader.AnchorSide[akBottom].Side := asrTop;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
lblChatHeaderCaption.Font.Bold := False;
lblChatHeaderCaption.Font.Italic := False;
lblChatHeaderCaption.Font.Color := clWindowText;
edChat.SetFocus;
end;
end;
procedure TfrmMain.lblChatHeaderCaptionMouseEnter(Sender: TObject);
begin
lblChatHeaderCaption.Font.Underline := True;
end;
procedure TfrmMain.lblChatHeaderCaptionMouseLeave(Sender: TObject);
begin
lblChatHeaderCaption.Font.Underline := False;
end;
procedure TfrmMain.mnuAboutClick(Sender: TObject);
begin
frmAbout.ShowModal;
end;
procedure TfrmMain.mnuAccountControlClick(Sender: TObject);
begin
frmAccountControl.Show;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
frmAccountControl.BringToFront;
end;
procedure TfrmMain.mnuTileListViewClick(Sender: TObject);
var
ViewMode: Word;
MainTile: Boolean;
AddHeight: Boolean;
function UpdateProps(VTList: TVirtualList; ViewMode: Word; AddHeight: Boolean; Update: Boolean): Boolean;
var
ColumIdx: Word;
begin
Result := False;
if ((not Update) and (Word(VTList.Tag) = ViewMode))
then Exit;
for ColumIdx := 0 to 11 do begin
VTList.Header.Columns[ColumIdx].Tag := PtrInt(-1);
VTList.Header.Columns[ColumIdx].Options := VTList.Header.Columns[ColumIdx].Options - [coVisible];
end;
case ViewMode of
4: ColumIdx := 44;
3: ColumIdx := 80;
2: ColumIdx := 96;
1: ColumIdx := 44;
end;
if (AddHeight)
then inc(ColumIdx, 14);
VTList.DefaultNodeHeight := ColumIdx;
VTList.Tag := PtrInt(ViewMode);
if (ViewMode = 1) then begin
VTList.Header.Options := VTList.Header.Options + [hoVisible];
VTList.TreeOptions.SelectionOptions := VTList.TreeOptions.SelectionOptions + [toFullRowSelect];
VTList.TreeOptions.MiscOptions := VTList.TreeOptions.MiscOptions + [toFullRowDrag];
VTList.Header.Columns[3].Options := VTList.Header.Columns[3].Options - [coVisible];
VTList.Header.Columns[13].Options := VTList.Header.Columns[13].Options - [coVisible];
end else begin
VTList.Header.Options := VTList.Header.Options - [hoVisible];
VTList.TreeOptions.SelectionOptions := VTList.TreeOptions.SelectionOptions - [toFullRowSelect];
VTList.TreeOptions.MiscOptions := VTList.TreeOptions.MiscOptions - [toFullRowDrag];
VTList.Header.Columns[3].Options := VTList.Header.Columns[3].Options + [coVisible];
VTList.Header.Columns[13].Options := VTList.Header.Columns[13].Options + [coVisible];
end;
case ViewMode of
4: begin ColumIdx := 4; ViewMode := 7; end;
3: begin ColumIdx := 8; ViewMode := 10; end;
2: begin ColumIdx := 11; ViewMode := 12; end;
1: begin ColumIdx := 0; ViewMode := 2; end;
end;
for ColumIdx := ColumIdx to ViewMode do begin
if (ViewMode <> 2)
then VTList.Header.Columns[ColumIdx].Tag := PtrInt(Word(VTList.Tag) + ColumIdx - ViewMode - 1)
else VTList.Header.Columns[ColumIdx].Tag := PtrInt(0);
VTList.Header.Columns[ColumIdx].Options := VTList.Header.Columns[ColumIdx].Options + [coVisible];
end;
VTList.BeginUpdate;
VTList.UpdateTileColumn(Word(VTList.Tag), Update);
VTList.EndUpdate;
Result := True;
end;
begin
if (Sender <> nil) then begin
mnuTileListDrawInfo.Enabled := (Sender <> mnuTileListTable);
mnuMiscTileListDrawInfo.Enabled := (Sender <> mnuMiscTileListTable);
end;
MainTile := (Sender = mnuTileListTable) or (Sender = mnuTileListSmall)
or (Sender = mnuTileListMidle) or (Sender = mnuTileListLarge);
if ((Sender = mnuTileListTable) or (Sender = mnuMiscTileListTable)) then ViewMode := 1 else
if ((Sender = mnuTileListSmall) or (Sender = mnuMiscTileListSmall)) then ViewMode := 4 else
if ((Sender = mnuTileListMidle) or (Sender = mnuMiscTileListMidle)) then ViewMode := 3 else
if ((Sender = mnuTileListLarge) or (Sender = mnuMiscTileListLarge)) then ViewMode := 2;
if ((MainTile) or (Sender = nil)) then begin
if ((Sender = nil) and (mnuTileListTable.Checked)) then ViewMode := 1 else
if ((Sender = nil) and (mnuTileListSmall.Checked)) then ViewMode := 4 else
if ((Sender = nil) and (mnuTileListMidle.Checked)) then ViewMode := 3 else
if ((Sender = nil) and (mnuTileListLarge.Checked)) then ViewMode := 2;
AddHeight := mnuTileListDrawInfo.Enabled and mnuTileListDrawInfo.Checked;
UpdateProps(vdtTiles, ViewMode, AddHeight, Sender = nil);
end;
if ((not MainTile) or (Sender = nil)) then begin
if ((Sender = nil) and (mnuMiscTileListTable.Checked)) then ViewMode := 1 else
if ((Sender = nil) and (mnuMiscTileListSmall.Checked)) then ViewMode := 4 else
if ((Sender = nil) and (mnuMiscTileListMidle.Checked)) then ViewMode := 3 else
if ((Sender = nil) and (mnuMiscTileListLarge.Checked)) then ViewMode := 2;
AddHeight := mnuMiscTileListDrawInfo.Enabled and mnuMiscTileListDrawInfo.Checked;
UpdateProps(vdlRandom, ViewMode, AddHeight, Sender = nil);
UpdateProps(frmFilter.vdtFilter, ViewMode, AddHeight, Sender = nil);
UpdateProps(frmLargeScaleCommand.vdlTerrainTiles, ViewMode, AddHeight, Sender = nil);
UpdateProps(frmLargeScaleCommand.vdlInsertStaticsTiles, ViewMode, AddHeight, Sender = nil);
UpdateProps(frmLargeScaleCommand.vdlDeleteStaticsTiles, ViewMode, AddHeight, Sender = nil);
end;
// vdtTiles.Clear;
// BuildTileList;
end;
procedure TfrmMain.mnuTileListDrawClick(Sender: TObject);
var
dheight: Integer;
procedure UpdateHeight(TVList: TVirtualList; height: integer);
var
TVTree: TVirtualDrawTree;
node: PVirtualNode;
begin
TVTree := TVirtualDrawTree(TVList);
TVList.BeginUpdate;
TVList.DefaultNodeHeight := TVList.DefaultNodeHeight + height;
node := TVTree.GetFirst();
while (node <> nil) do begin
node^.NodeHeight := node^.NodeHeight + height;
node := TVTree.GetNext(node);
end;
TVList.EndUpdate;
end;
begin
if (Sender = mnuTileListDrawInfo) then begin
if (mnuTileListDrawInfo.Checked)
then UpdateHeight(vdtTiles, +14)
else UpdateHeight(vdtTiles, -14);
end else if (Sender = mnuMiscTileListDrawInfo) then begin
if (mnuMiscTileListDrawInfo.Checked)
then dheight := +14
else dheight := -14;
UpdateHeight(vdlRandom, dheight);
UpdateHeight(frmFilter.vdtFilter, dheight);
UpdateHeight(frmLargeScaleCommand.vdlTerrainTiles, dheight);
UpdateHeight(frmLargeScaleCommand.vdlInsertStaticsTiles, dheight);
UpdateHeight(frmLargeScaleCommand.vdlDeleteStaticsTiles, dheight);
end;
// Код является частью отрисовки OnDrawNode => ее надо принудительно вызвать
vdtTiles.Repaint;
vdlRandom.Repaint;
frmFilter.vdtFilter.Repaint;
end;
procedure TfrmMain.mnuAutoHideGroupListClick(Sender: TObject);
begin
if mnuAutoHideGroupList.Checked then
begin
spGroupList.Enabled := (not cbTerrain.Checked) and (not cbStatics.Checked);
tvGroups.Visible := spGroupList.Enabled;
if not spGroupList.Enabled
then mnuAutoHideGroupList.Tag := spGroupList.Top;
//else mnuAutoHideGroupList.Tag := 0;
end else
begin
if mnuAutoHideGroupList.Tag > 0
then spGroupList.Top := mnuAutoHideGroupList.Tag;
mnuAutoHideGroupList.Tag := 0;
spGroupList.Enabled := True;
tvGroups.Visible := True;
end;
if spGroupList.Enabled then
begin
spGroupList.Cursor := crVSplit;
//if spGroupList.Tag > 0 then
// spGroupList.Height := spGroupList.Tag;
spGroupList.Height := 5;
end else
begin
spGroupList.Cursor := crDefault;
//spGroupList.Tag := spGroupList.Height;
spGroupList.Height := 1;
end;
spGroupListMoved(Sender);
end;
procedure TfrmMain.mnuAutoHideRandomListClick(Sender: TObject);
begin
if mnuAutoHideRandomList.Checked then
begin
if (not frmDrawSettings.rbRandom.Checked) and (Sender <> nil)
then mnuAutoHideRandomList.Tag := spTileList.Top;
//else mnuAutoHideRandomList.Tag := 0;
spTileList.Enabled := frmDrawSettings.rbRandom.Checked;
//gbRandom.Visible := frmDrawSettings.rbRandom.Checked;
cbRandomPreset.Visible := frmDrawSettings.rbRandom.Checked;
btnRandomPresetSave.Visible := frmDrawSettings.rbRandom.Checked;
btnRandomPresetDelete.Visible := frmDrawSettings.rbRandom.Checked;
vdlRandom.Visible := frmDrawSettings.rbRandom.Checked;
end else
begin
if mnuAutoHideRandomList.Tag > 0
then spTileList.Top := mnuAutoHideRandomList.Tag;
mnuAutoHideRandomList.Tag := 0;
spTileList.Enabled := True;
//gbRandom.Visible := True;
cbRandomPreset.Visible := True;
btnRandomPresetSave.Visible := True;
btnRandomPresetDelete.Visible := True;
vdlRandom.Visible := True;
end;
if spTileList.Enabled then
begin
spTileList.Cursor := crVSplit;
//if spTileList.Tag > 0 then
// spTileList.Height := spTileList.Tag;
spTileList.Height := 5;
end else
begin
spTileList.Cursor := crDefault;
//spTileList.Tag := spTileList.Height;
spTileList.Height := 1;
end;
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;
begin
if mnuAutoHideGroupList.Checked then
if (spGroupList.Enabled) and (mnuAutoHideGroupList.Tag > 0) then
begin
spGroupList.Top := mnuAutoHideGroupList.Tag;
mnuAutoHideGroupList.Tag := 0;
end
else if not spGroupList.Enabled then
begin
spGroupList.Top := tvGroups.Top + 4;
Exit;
end;
if spGroupList.Enabled then
if spGroupList.Top <= tvGroups.Top then
spGroupList.Top := tvGroups.Top
else begin
anchor := spTileList.Top - spGroupList.Height - vdtTiles.Constraints.MinHeight;
if spGroupList.Top > anchor then spGroupList.Top := (anchor - 1);
end;
end;
procedure TfrmMain.spTileListMoved(Sender: TObject);
var
anchor: integer;
begin
if mnuAutoHideRandomList.Checked then
if (spTileList.Enabled) and (mnuAutoHideRandomList.Tag > 0) then
begin
spTileList.Top := mnuAutoHideRandomList.Tag;
mnuAutoHideRandomList.Tag := 0;
end
else if not spTileList.Enabled then
begin
spTileList.Top := gbRandom.Top + gbRandom.Height - spTileList.Tag + 3;
Exit;
end;
if spTileList.Enabled then
if spTileList.Top + spTileList.Height >= gbRandom.Top + gbRandom.Height then
spTileList.Top := gbRandom.Top + gbRandom.Height - spTileList.Height
else begin
anchor := spGroupList.Top + spGroupList.Height + vdtTiles.Constraints.MinHeight;
if spTileList.Top < anchor then spTileList.Top := (anchor + 1);
end;
end;
procedure TfrmMain.tbFilterMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
If Button = mbRight then
tbFilter.Tag := PtrInt(GetTickCount);
end;
procedure TfrmMain.tbFilterMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if acFilter.Checked and (not frmFilter.Visible) and ((GetTickCount - DWORD(tbFilter.Tag)) < 1000) then begin
tbFilter.Tag := PtrInt(False);
frmFilter.Show;
end;
end;
procedure TfrmMain.pcLeftResize(Sender: TObject);
begin
spGroupListMoved(Sender);
spTileListMoved(Sender);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.mnuDisconnectClick(Sender: TObject);
begin
dmNetwork.Disconnect;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.mnuDocsClick(Sender: TObject);
begin
ShellExecute(Handle, 'open', PChar('http://dev.uoquint.ru/projects/centred/wiki'), nil, nil, 1 {SW_SHOWNORMAL});
end;
procedure TfrmMain.mnuRusComClick(Sender: TObject);
begin
ShellExecute(Handle, 'open', PChar('http://forum.uokit.com/index.php?showforum=207'), nil, nil, 1 {SW_SHOWNORMAL});
end;
procedure TfrmMain.mnuEng2ComClick(Sender: TObject);
begin
ShellExecute(Handle, 'open', PChar('http://craftuo.com/threads/centred.888'), nil, nil, 1 {SW_SHOWNORMAL});
end;
procedure TfrmMain.mnuEngComClick(Sender: TObject);
begin
ShellExecute(Handle, 'open', PChar('http://board.uoquint.ru/'), nil, nil, 1 {SW_SHOWNORMAL});
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure TfrmMain.oglGameWindowPaint(Sender: TObject);
begin
- Added option to set the render background to white (fixes #59)
2009-12-23 20:54:56 +01:00
if mnuWhiteBackground.Checked then
glClearColor(1, 1, 1, 1)
else
glClearColor(0, 0, 0, 1);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
glClear(GL_COLOR_BUFFER_BIT);
InitRender;
InitSize;
glDisable(GL_DEPTH_TEST);
Render;
oglGameWindow.SwapBuffers;
end;
procedure TfrmMain.oglGameWindowResize(Sender: TObject);
begin
InvalidateScreenBuffer;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.pbRadarMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var posx, posy: Integer;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
posx := self.X+4 * Trunc((Y+X - (pbRadar.Height+pbRadar.Width)div 2)*cos(45));
posy := self.Y+4 * Trunc((Y-X - (pbRadar.Height-pbRadar.Width)div 2)*cos(45));
//if (posx < 0) then posx := 0 else if (posx >= 8*Landscape.Width) then posx := 8*Landscape.Width-1;
//if (posy < 0) then posy := 0 else if (posy >= 8*Landscape.Height) then posy := 8*Landscape.Height-1;
if (posx>=0)and(posy>=0)and(posx<8*Landscape.Width)and(posy<8*Landscape.Height)
then SetPos(posx, posy);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.pbRadarPaint(Sender: TObject);
var
posX, posY, scrW, scrH: Integer;
zoom: Single;
image: TSingleImage;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
posX := (X div 8) - (pbRadar.Width div 4);
posY := (Y div 8) - (pbRadar.Height div 4);
// NOTE: Не очень-то хорошо каждый раз создавать Image...
image := TSingleImage.CreateFromParams(pbRadar.Width+84, pbRadar.Height+84, ifA8R8G8B8);
StretchRect(frmRadarMap.Radar.ImageDataPointer^, posX, posY, pbRadar.Width div 2, pbRadar.Height div 2,
image.ImageDataPointer^, 0, 0, image.Width, image.Height, rfBicubic);
RotateImage(image.ImageDataPointer^, -45.0);
DisplayImage(pbRadar.Canvas, (pbRadar.Width-image.Width) div 2, (pbRadar.Height-image.Height) div 2, image);
image.Free;
posX := pbRadar.Width div 2;
posY := pbRadar.Width div 2;
if tbZoom.Down then zoom := tbZoom.Tag / 1000.0 else zoom := 1.0;
scrW := Trunc(0.25 * oglGameWindow.Width / 44.0 / zoom);
scrH := Trunc(0.25 * oglGameWindow.Height/ 44.0 / zoom);
pbRadar.Canvas.Pen.Color := clBlack;
pbRadar.Canvas.Pen.Style := psSolid;
pbRadar.Canvas.Line(posX-scrW, posY-scrH, posX+scrW, posY-scrH);
pbRadar.Canvas.Line(posX+scrW, posY-scrH, posX+scrW, posY+scrH);
pbRadar.Canvas.Line(posX+scrW, posY+scrH, posX-scrW, posY+scrH);
pbRadar.Canvas.Line(posX-scrW, posY+scrH, posX-scrW, posY-scrH);
pbRadar.Canvas.Pen.Color := clSilver;
pbRadar.Canvas.Pen.Style := psSolid;
pbRadar.Canvas.Line(posX-scrW-1, posY-scrH-1, posX+scrW+1, posY-scrH-1);
pbRadar.Canvas.Line(posX+scrW+1, posY-scrH-1, posX+scrW+1, posY+scrH+1);
pbRadar.Canvas.Line(posX+scrW+1, posY+scrH+1, posX-scrW-1, posY+scrH+1);
pbRadar.Canvas.Line(posX-scrW-1, posY+scrH+1, posX-scrW-1, posY-scrH-1);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.pcLeftChange(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.pmGrabTileInfoPopup(Sender: TObject);
var
isStatic: Boolean;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
isStatic := CurrentTile is TStaticItem;
mnuGrabHue.Enabled := isStatic;
mnuGrabFilterTileID.Enabled := isStatic;
mnuGrabFilterHue.Enabled := isStatic;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.tbRadarMapClick(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
frmRadarMap.Show;
frmRadarMap.BringToFront;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.tmGrabTileInfoTimer(Sender: TObject);
begin
tmGrabTileInfo.Enabled := False;
if CurrentTile <> nil then
pmGrabTileInfo.PopUp(Mouse.CursorPos.X, Mouse.CursorPos.Y);
SelectedTile := nil;
end;
procedure TfrmMain.tmMovementTimer(Sender: TObject);
begin
case FOverlayUI.ActiveArrow of
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
0: MoveBy(-1, 0);
1: MoveBy(-1, -1);
2: MoveBy( 0, -1);
3: MoveBy(+1, -1);
4: MoveBy(+1, 0);
5: MoveBy(+1, +1);
6: MoveBy( 0, +1);
7: MoveBy(-1, +1);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.tmSettingsCloseTimer(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tmSettingsClose.Enabled := False;
tbTerrain.Down := acTerrain.Checked;
tbStatics.Down := acStatics.Checked;
tbNoDraw.Down := acNoDraw.Checked;
tbFlat.Down := acFlat.Checked;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.tsNavigationContextPopup(Sender: TObject; MousePos: TPoint;
var Handled: Boolean);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if Sender is TWinControl then
if not (TWinControl(Sender)).Focused
then (TWinControl(Sender)).SetFocus;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.tvGroupsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType; var CellText: String);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
var
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
nodeData : PGroupNode;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
nodeData := tvGroups.GetNodeData(Node);
CellText := nodeData^.Name;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.tvGroupsDrawText(Sender: TBaseVirtualTree;
TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;
const CellText: String; const CellRect: TRect; var DefaultDraw: Boolean);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
var
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
nodeData : PGroupNode;
TextWidth: Integer;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
nodeData := tvGroups.GetNodeData(Node);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
TargetCanvas.Font.Color := nodeData^.Color;
TargetCanvas.Font.Bold := nodeData^.Bold;
TargetCanvas.Font.Italic:= nodeData^.Ital;
TargetCanvas.TextOut(CellRect.Left, CellRect.Top+2, CellText);
TextWidth := TargetCanvas.TextWidth(CellText);
TargetCanvas.Font.Color := TColor($00BBBBBB);
TargetCanvas.Font.Bold := False;
TargetCanvas.Font.Italic:= False;
TargetCanvas.TextOut(CellRect.Left + TextWidth + 6, CellRect.Top + 2,
Format('(%u)', [nodeData^.Items]));
DefaultDraw := False;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.tmSelectNodeTimer(Sender: TObject);
begin
tmSelectNode.Enabled := False;
if (FGroupsSelectionUndoRedoCommandGroup.UndoRedoCommands.Count > 0) then begin
if not FGroupsSelectionUndoRedoManager.Enabled then begin
tmSelectNode.Enabled := True;
Exit;
end;
FGroupsSelectionUndoRedoManager.ExecCommand(FGroupsSelectionUndoRedoCommandGroup);
FGroupsSelectionUndoRedoCommandGroup := TUndoRedoCommandGroup.Create;
end;
//if (FTilesSelectionUndoRedoCommandGroup.UndoRedoCommands.Count > 0) then
begin
if not FTilesSelectionUndoRedoManager.Enabled then begin
tmSelectNode.Enabled := True;
Exit;
end;
FTilesSelectionUndoRedoManager.ExecCommand(FTilesSelectionUndoRedoCommandGroup);
FTilesSelectionUndoRedoCommandGroup := TUndoRedoCommandGroup.Create;
end;
end;
procedure TfrmMain.vdtTilesChange(Sender: TBaseVirtualTree; Node: PVirtualNode);
begin
if (Node <> nil) and (FTilesSelectionUndoRedoManager.Enabled) then begin
FTilesSelectionUndoRedoCommandGroup.Add(
TUndoRedoSelectVirtualNodeCommand.Create(
FTilesSelectionUndoRedoManager, Sender, Node)
);
if not FTilesSelectionUndoRedoManager.Enabled
then vdtTiles.FocusedNode := PVirtualItem(Node);
if not tmSelectNode.Enabled
then tmSelectNode.Enabled := True
else tmSelectNode.Interval:= 250;
end;
end;
procedure TfrmMain.tvGroupsChange(Sender: TBaseVirtualTree; Node: PVirtualNode);
var
item: PVirtualNode;
begin
if (Node <> nil) and (FGroupsSelectionUndoRedoManager.Enabled) then begin
FGroupsSelectionUndoRedoCommandGroup.Add(
TUndoRedoSelectVirtualNodeCommand.Create(
FGroupsSelectionUndoRedoManager, Sender, Node)
);
if not tmSelectNode.Enabled
then tmSelectNode.Enabled := True
else tmSelectNode.Interval:= 250;
if ((cbStatics.Checked or cbTerrain.Checked) and Sender.Selected[Node]) then begin
cbStatics.Checked := False;
cbTerrain.Checked := False;
Exit;
end;
end;
BuildTileList;
end;
procedure TfrmMain.tvGroupFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
var
groupData: PGroupNode;
begin
groupData := Sender.GetNodeData(Node);
groupData^.Name := EmptyStr;
FreeMem(groupData^.GLink);
FreeMem(groupData^.GTile);
FreeMem(groupData^.Brush);
FreeMem(groupData^.Entry);
end;
procedure TfrmMain.DropedownMenusClose(Sender: TObject);
begin
tmSettingsClose.Enabled := True;
end;
procedure TfrmMain.vdtRandomClick(Sender: TObject);
var
item: PVirtualItem;
node: PVirtualItem;
treeNode: PVirtualNode;
tileInfo: PTileInfo;
selectedID: Integer;
function TileInNode(Node: PVirtualNode; TileID: LongWord) : Boolean;
var
nodeData: ^TGroupNode;
i: Integer;
begin
Result := False;
nodeData := tvGroups.GetNodeData(Node);
for i := 0 to nodeData^.Count - 1 do
begin
if nodeData^.GTile[i].ID = TileID then
begin
Result := True;
break;
end;
end;
end;
begin
if vdlRandom.SelectedCount = 1 then
begin
node := vdlRandom.GetFirstSelected;
if node <> nil then
begin
tileInfo := vdlRandom.GetNodeData(node);
selectedID := tileInfo^.ID;
// Выбираем группы
if (not cbStatics.Checked) and (not cbTerrain.Checked) then
begin
treeNode := tvGroups.GetFirst();
while treeNode <> nil do
begin
if TileInNode(treeNode, selectedID) then
begin
tvGroups.Selected[treeNode] := True;
tvGroups.FocusedNode := treeNode;
if toMultiSelect in tvGroups.TreeOptions.SelectionOptions
then Break;
end;
treeNode := tvGroups.GetNext(treeNode);
end;
end;
// Выбираем тайл
item := vdtTiles.GetFirst;
while item <> nil do
begin
tileInfo := vdtTiles.GetNodeData(item);
if tileInfo^.ID = selectedID then
begin
vdtTiles.ClearSelection;
vdtTiles.Selected[item] := True;
vdtTiles.FocusedNode := item;
item := nil;
end else
item := vdtTiles.GetNext(item);
end;
end;
end;
end;
procedure TfrmMain.vdtRandomDragDrop(Sender: TBaseVirtualTree; Source: TObject;
DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState;
Pt: TPoint; var Effect: Integer; Mode: TDropMode);
begin
if Source = vdtTiles then
btnAddRandomClick(Sender);
end;
procedure TfrmMain.vdtRandomDragOver(Sender: TBaseVirtualTree; Source: TObject;
Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode;
var Effect: Integer; var Accept: Boolean);
begin
if source = vdtTiles then Accept := True;
end;
procedure TfrmMain.vdtRandomLoadNode(Sender: TBaseVirtualTree;
Node: PVirtualNode; Stream: TStream);
var
tileInfo: PTileInfo;
begin
tileInfo := Sender.GetNodeData(Node);
Stream.Read(tileInfo^.ID, SizeOf(tileInfo^.ID));
end;
procedure TfrmMain.vdtRandomSaveNode(Sender: TBaseVirtualTree;
Node: PVirtualNode; Stream: TStream);
var
tileInfo: PTileInfo;
begin
tileInfo := Sender.GetNodeData(Node);
Stream.Write(tileInfo^.ID, SizeOf(tileInfo^.ID));
end;
procedure TfrmMain.vdtRandomUpdating(Sender: TBaseVirtualTree;
State: TVTUpdateState);
begin
if acDraw.Checked then
ProcessToolState;
end;
procedure TfrmMain.vdtTilesClick(Sender: TObject);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
if acDraw.Checked then
ProcessToolState;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.vdtTilesDragAllowed(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean);
begin
//vdtTiles.auto
Allowed := True;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure TfrmMain.vdtTilesDrawHint(Sender: TBaseVirtualTree;
HintCanvas: TCanvas; Node: PVirtualNode; const R: TRect; Column: TColumnIndex
);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
var
m_name : string;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
vdtTiles.UpdateHintCanvas(HintCanvas);
- Changed TWorldItem and TWorldBlock Change-tracking - Reverted TStaticItem.UpdatePriorities - Fixed vdtTiles' HintCanvas to use the desired font when drawing - Fixed UpdateFilter to no longer call ForceUpdateCurrentTile - Several code cleanups
2009-12-23 16:39:24 +01:00
HintCanvas.Font.Assign(Sender.Font);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
HintCanvas.Font.Style := [fsBold];
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
m_name := CP1251ToUTF8(FTileHint.Name);
DrawText(HintCanvas.Handle, PChar(m_name), Length(m_name), FTileHint.NameRect, 0);
HintCanvas.Font.Style := [];
DrawText(HintCanvas.Handle, PChar(FTileHint.Obj), Length(FTileHint.Obj), FTileHint.ObjRect, 0);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
HintCanvas.Font.Style := [fsItalic];
DrawText(HintCanvas.Handle, PChar(FTileHint.Flags), Length(FTileHint.Flags),
FTileHint.FlagsRect, DT_WORDBREAK);
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.vdtTilesDrawNode(Sender: TBaseVirtualTree; const PaintInfo: TVTPaintInfo);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
var
tileInfo: PTileInfo;
textStyle: TTextStyle;
artEntry: TArt;
tileData: TTileData;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
id: LongWord;
rect, CellRect:TRect;
image: TSingleImage;
colorOld, colorNew: Word;
DrawInfo: Boolean;
oldcolor: DWORD;
newcolor: DWORD;
srcCanvas, dstCanvas: TFastARGB32Canvas;
tmpImage : TSingleImage;
bit: Integer;
procedure DisplayNodeImage(main: Boolean; const Canvas: TCanvas; const CellRect: TRect; Image: TBaseImage; ForceStretch: Boolean = False);
var
Resised: Float;
DstSize: TSize;
DstRect: TRect;
//SrcRect: TRect;
begin
if (main and mnuTileListStretch.Checked) or (not main and mnuMiscTileListStretch.Checked) or (ForceStretch) then begin
if ForceStretch or (DstSize.cy <> 44) then begin
DstSize.cx := CellRect.Right - CellRect.Left;
DstSize.cy := CellRect.Bottom - CellRect.Top;
if ForceStretch then begin
if (DstSize.cx <= 44) then id := 2
else if (DstSize.cx <= 80) then id := 3
else id := 4;
DstSize.cx := DstSize.cx - id;
DstSize.cy := DstSize.cy - id;
end;
Resised := Min(Min(Float(DstSize.cx)/Float(Image.Width), Float(DstSize.cy)/Float(Image.Height)), 1.0);
DstSize.cx := Trunc(Resised * Float(Image.Width));
DstSize.cy := Trunc(Resised * Float(Image.Height));
DstRect.Left := Trunc((CellRect.Left + CellRect.Right - DstSize.cx) / 2);
DstRect.Right := DstRect.Left + DstSize.cx;
if not ForceStretch
then DstRect.Bottom := CellRect.Bottom
else DstRect.Bottom := (CellRect.Bottom - CellRect.Top + DstSize.cy) div 2;
DstRect.Top := DstRect.Bottom - DstSize.cy
end else begin
DstRect := CellRect;
end;
DisplayImage(Canvas, DstRect, Image);
end else
if (main and mnuTileListClip.Checked) or (not main and mnuMiscTileListClip.Checked) then begin
//DstSize.cx := CellRect.Right - CellRect.Left;
//DstSize.cy := CellRect.Bottom - CellRect.Top;
//DstRect := CellRect;
//SrcRect.Top := 0;
//if (DstSize.cy <= Image.Height) then begin
// SrcRect.Bottom := DstSize.cy;
//end else begin
// SrcRect.Bottom := Image.Height;
// DstRect.Bottom := DstRect.Top + Image.Height;
//end;
//if (DstSize.cx <= Image.Width) then begin
// SrcRect.Left := (Image.Width - DstSize.cx) div 2;
// SrcRect.Right:= SrcRect.Left + DstSize.cx;
//end else begin
// SrcRect.Left := 0;
// SrcRect.Right:= Image.Width;
// DstRect.Left := DstRect.Left + (DstSize.cx - Image.Width) div 2;
// DstRect.Right:= DstRect.Left + Image.Width;
//end;
//Logger.Send([lcClient, lcDebug], 'TfrmMain.vdtTilesDrawNode [%d,%d,%d,%d](%d,%d) - [%d,%d,%d,%d](%d,%d) I(%d,%d) C[%d,%d,%d,%d](%d,%d)',
//[SrcRect.Top, SrcRect.Left, SrcRect.Bottom, SrcRect.Right, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top,
// DstRect.Top, DstRect.Left, DstRect.Bottom, DstRect.Right, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top,
// Image.Width, Image.Height,
// CellRect.Top, CellRect.Left, CellRect.Bottom, CellRect.Right, CellRect.Right - CellRect.Left, CellRect.Bottom - CellRect.Top]);
//DisplayImage(Canvas, DstRect, Image, SrcRect);
DisplayImage(Canvas, Trunc((CellRect.Left + CellRect.Right - Image.Width) / 2), CellRect.Top, Image);
Canvas.FillRect(CellRect.Left, CellRect.Bottom, CellRect.Right, CellRect.Bottom + 14);
end else
if (main and mnuTileListCentre.Checked) or (not main and mnuMiscTileListCentre.Checked) then begin
// TODO: ....
end;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if (not (Sender is TVirtualList))
then tileInfo := Sender.GetNodeData(PaintInfo.Node)
else tileInfo := vdtTiles.GetNodeData(PVirtualItem(PaintInfo.Node));
//if (sender <> vdtTiles) then begin
//Logger.Send([lcClient, lcDebug], 'TfrmMain.vdtTilesDrawNode %.8x at cell [%d,%d]', [tileInfo^.ID, PaintInfo.Column, PaintInfo.Node^.Index]);
//Exit;
//end;
// Logger.Send([lcClient, lcDebug], 'TfrmMain.vdtTilesDrawNode %d', [tileInfo^.ID]);
if (tileInfo^.ID = $FFFFFFFF) then exit;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
textStyle := PaintInfo.Canvas.TextStyle;
textStyle.Alignment := taCenter;
textStyle.Layout := tlCenter;
textStyle.Wordbreak := True;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
PaintInfo.Canvas.Font.Color := Sender.Font.Color;
if (Sender = vdtTiles) then
PaintInfo.Canvas.Font.Color := TColor($808080);
//Logger.Send([lcClient, lcDebug], 'vdtTilesDrawNode %.4x', [tileInfo^.ID]);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
case PaintInfo.Column of
0:
begin
id := tileInfo^.ID;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if id > $2F000000 then
PaintInfo.Canvas.TextRect(PaintInfo.CellRect, 0, 0, Format('BL%.3d', [id - $2F000000]), textStyle)
else if id > $1F000000 then
PaintInfo.Canvas.TextRect(PaintInfo.CellRect, 0, 0, Format('ET%.3d', [id - $1F000000]), textStyle)
else begin
if id > $00003FFF then Dec(id, $00004000);
//PaintInfo.Canvas.TextRect(PaintInfo.CellRect, 0, 0, '4x', textStyle);
PaintInfo.Canvas.TextRect(PaintInfo.CellRect, 0, 0, Format('$%.4x', [id]), textStyle);
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
2:
begin
textStyle.Alignment := taLeftJustify;
if (tileInfo^.ID > $2F000000) then begin // Кисти
PaintInfo.Canvas.TextRect(PaintInfo.CellRect, PaintInfo.CellRect.Left + 4,
PaintInfo.CellRect.Top, PGroupBrush(tileInfo^.ptr)^.Name, textStyle);
end else if (tileInfo^.ID > $1F000000) then begin // Объекты
PaintInfo.Canvas.TextRect(PaintInfo.CellRect, PaintInfo.CellRect.Left + 4,
PaintInfo.CellRect.Top, PGroupEntry(tileInfo^.ptr)^.Name, textStyle);
end else begin // Тайлы
tileData := TTileData(ResMan.Tiledata.Block[tileInfo^.ID]);
PaintInfo.Canvas.TextRect(PaintInfo.CellRect, PaintInfo.CellRect.Left + 4,
PaintInfo.CellRect.Top, CP1251ToUTF8(Trim(tileData.TileName)),
textStyle);
tileData.Free;
end;
end;
3: begin Exit; end;
13: begin Exit; end;
// 1: - 3: 4: 5: 6: - 7: 8: 9: - 10: 11:
else
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
CellRect := PaintInfo.CellRect;
if (PaintInfo.Column = 1)
then DrawInfo := False
else if (sender = vdtTiles)
then DrawInfo := mnuTileListDrawInfo.Enabled and mnuTileListDrawInfo.Checked
else DrawInfo := mnuMiscTileListDrawInfo.Enabled and mnuMiscTileListDrawInfo.Checked;
if DrawInfo then begin
CellRect.Bottom := CellRect.Bottom - 14;
end;
if (tileInfo^.ID > $2F000000) then begin // Кисти
//image := TSingleImage.CreateFromImage(PGroupBrush(tileInfo^.ptr)^.Image);
colorOld := $0000; colorNew := RGB2ARGB(PaintInfo.Canvas.Pixels[CellRect.Left,CellRect.Top]);
PGroupBrush(tileInfo^.ptr)^.Image.ReplaceColor(0,0,PGroupBrush(tileInfo^.ptr)^.Image.Width,PGroupBrush(tileInfo^.ptr)^.Image.Height,
@colorOld, @colorNew);
image := TSingleImage.CreateFromImage(PGroupBrush(tileInfo^.ptr)^.Image);
image.Format := ifDefault;
DisplayNodeImage((Sender = vdtTiles), PaintInfo.Canvas, CellRect, image, True);
//DisplayImage(PaintInfo.Canvas, CellRect, image);
image.Free;
end else if (tileInfo^.ID > $1F000000) then begin// Объекты
//colorOld := $0000; colorNew := RGB2ARGB($00FFFFFF);
//PGroupEntry(tileInfo^.ptr)^.Image.ReplaceColor(0,0,PGroupEntry(tileInfo^.ptr)^.Image.Width,PGroupEntry(tileInfo^.ptr)^.Image.Height,
//@colorOld, @colorNew);
image := TSingleImage.CreateFromImage(PGroupEntry(tileInfo^.ptr)^.Image);
//oldcolor := PDWORD(Image.Bits)^;
//newcolor := $00FF0000;//PDWORD(Image.)^;
//image.ReplaceColor(0,0,Image.Width,Image.Height,@oldcolor,@newcolor);
//image.Format := ifDefault;
DisplayNodeImage((Sender = vdtTiles), PaintInfo.Canvas, CellRect, image, True);
image.Free;
end else if ResMan.Art.Exists(tileInfo^.ID) then // Тайлы
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
artEntry := ResMan.Art.GetArt(tileInfo^.ID,
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
RGB2ARGB(PaintInfo.Canvas.Pixels[CellRect.Left, CellRect.Top]), nil, False);
DisplayNodeImage((Sender = vdtTiles), PaintInfo.Canvas, CellRect, artEntry.Graphic);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
artEntry.Free;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if tileInfo^.ID > $3FFF then
if (FLightSourceTiles[tileInfo^.ID - $4000].image > 0) then // Источники света
begin
bit := FLightSourceTiles[tileInfo^.ID - $4000].image;
//rect.Right:=CellRect.Right;
//rect.Bottom:=CellRect.Bottom;
//rect.Left:=CellRect.Right - 24;
//rect.Top:=CellRect.Bottom - 24;
//DisplayImage(PaintInfo.Canvas, rect, FVLightSrcImage);
//DisplayNodeImage((Sender = vdtTiles), PaintInfo.Canvas, CellRect, FVLightSrcImage, True);
rect.Left := 0;
rect.Top := 0;
rect.Right:= FVLightSrcImage[bit].Width;
rect.Bottom:=FVLightSrcImage[bit].Height;
tmpImage := TSingleImage.CreateFromParams(rect.Right, rect.Bottom, ifA8R8G8B8);
srcCanvas := TFastARGB32Canvas.CreateForImage(FVLightSrcImage[bit]);
dstCanvas := TFastARGB32Canvas.CreateForImage(tmpImage);
dstCanvas.FillColor32 := PaintInfo.Canvas.Pixels[CellRect.Left+4,CellRect.Top+4];
dstCanvas.FillRect(rect);
srcCanvas.DrawAlpha(rect, dstCanvas, 0,0);
srcCanvas.Free;
dstCanvas.Free;
DisplayNodeImage((Sender = vdtTiles), PaintInfo.Canvas, CellRect, tmpImage, True);
tmpImage.Free;
end;
end;
if DrawInfo then begin // Подписи тайлов
CellRect.Bottom := PaintInfo.CellRect.Bottom;
rect := PaintInfo.CellRect;
rect.Top := rect.Bottom - 14;;
id := tileInfo^.ID;
if id > $2F000000 then
PaintInfo.Canvas.TextRect(rect, 0, 0, Format('BL%.3d', [id - $2F000000]), textStyle)
else if id > $1F000000 then
PaintInfo.Canvas.TextRect(rect, 0, 0, Format('ET%.3d', [id - $1F000000]), textStyle)
else begin
if id > $00003FFF then Dec(id, $00004000);
//PaintInfo.Canvas.TextRect(rect, 0, 0, '4x', textStyle);
PaintInfo.Canvas.TextRect(rect, 0, 0, Format('0x%.4x', [id]), textStyle);
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
procedure TfrmMain.vdtTilesEnter(Sender: TObject);
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if acFilter.Checked and mnuAutoShowFilterWindow.Checked and (not frmFilter.Visible) and (not frmFilter.Locked) then
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
frmFilter.Locked := True;
frmFilter.Show;
frmMain.SetFocus;
frmFilter.Locked := False;
end;
end;
procedure TfrmMain.vdtTilesGetHintSize(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex; var R: TRect);
var
tileInfo: PTileInfo;
tileData: TTiledata;
prefix, flags: string;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
id: LongWord;
cmHint: TCMHintShow;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
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
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
case Word(Sender.Tag) of
1: id := 0;
2: id := min(max(0, Column - 10), 2);
3: id := min(max(0, Column - 7), 3);
4: id := min(max(0, Column - 3), 4);
end;
//Logger.Send([lcClient, lcDebug], 'vdtTilesGetHintSize', Column);
tileInfo := (TVirtualList(Sender)).GetNodeData(vdtTiles.GetItemAt(Node, Column));// @PTileInfo(Sender.GetNodeData(Node))[id];
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
flags := '';
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
// if (FTileHint.Column = id) then Exit;
// FTileHint.Column := id;
if (tileInfo^.ID > $2F000000) then begin
FTileHint.Name := UTF8ToCP1251(PGroupBrush(tileInfo^.ptr)^.Name);
FTileHint.Obj := Format('Brush ID: 0x%.4x (%.5d)', [tileInfo^.ID-$2F000000, tileInfo^.ID-$2F000000]);
//flags := 'Brush';
end else if (tileInfo^.ID > $1F000000) then begin
FTileHint.Name := UTF8ToCP1251(PGroupEntry(tileInfo^.ptr)^.Name);
FTileHint.Obj := Format('Entry ID: 0x%.4x (%.5d)', [tileInfo^.ID-$1F000000, tileInfo^.ID-$1F000000]);
//flags := 'Entry';
end else
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tileData := ResMan.Tiledata.TileData[tileInfo^.ID];
if tileInfo^.ID < $4000 then begin
if TLandTiledata(tileData).TextureID > 0 then
flags := 'Stretchable';
FTileHint.Obj := Format('LandT ID: 0x%.4x (%.5d)', [tileInfo^.ID, tileInfo^.ID]);
end else begin
FTileHint.Obj := Format('ItemT ID: 0x%.4x (%.5d)', [tileInfo^.ID-$4000, tileInfo^.ID-$4000]);
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
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]), [' ']);
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'); //HoverOver
UpdateFlags(tdfArmor, 'Armor');
UpdateFlags(tdfRoof, 'Roof');
UpdateFlags(tdfDoor, 'Door');
UpdateFlags(tdfStairBack, 'StairBack');
UpdateFlags(tdfStairRight, 'StairRight');
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
FTileHint.NameRect.Left := 5;
FTileHint.NameRect.Top := 5;
Sender.Canvas.Font.Style := [fsBold];
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
DrawText(Sender.Canvas.Handle, PChar(CP1251ToUTF8(FTileHint.Name)), Length(CP1251ToUTF8(FTileHint.Name)),
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
FTileHint.NameRect, DT_CALCRECT);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FTileHint.ObjRect.Left := 5;
FTileHint.ObjRect.Top := FTileHint.NameRect.Bottom + 6;
Sender.Canvas.Font.Style := [];
DrawText(Sender.Canvas.Handle, PChar(FTileHint.Obj), Length(FTileHint.Obj), FTileHint.ObjRect, DT_CALCRECT);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
FTileHint.Flags := Format('Flags = [%s]', [flags]);
FTileHint.FlagsRect.Left := 5;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FTileHint.FlagsRect.Top := FTileHint.ObjRect.Bottom + 2;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
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);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
R := Rect(0, 0, Max(Max(FTileHint.NameRect.Right, FTileHint.ObjRect.Right), FTileHint.FlagsRect.Right) + 5,
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
FTileHint.FlagsRect.Bottom + 5);
end;
procedure TfrmMain.vdtTilesKeyPress(Sender: TObject; var Key: char);
begin
if Key in ['$', '0'..'9'] then
begin
edSearchID.Text := Key;
edSearchID.Visible := True;
edSearchID.SetFocus;
edSearchID.SelStart := 1;
Key := #0;
end;
end;
procedure TfrmMain.vdtTilesScroll(Sender: TBaseVirtualTree; DeltaX,
DeltaY: Integer);
begin
if Sender.CanFocus and Sender.MouseEntered then
Sender.SetFocus;
end;
procedure TfrmMain.vstChatClick(Sender: TObject);
begin
edChat.SetFocus;
end;
procedure TfrmMain.vstChatFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
var
chatInfo: PChatInfo;
begin
chatInfo := Sender.GetNodeData(Node);
chatInfo^.Sender := '';
chatInfo^.Msg := '';
end;
procedure TfrmMain.vstChatGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType; var CellText: String);
var
chatInfo: PChatInfo;
begin
chatInfo := Sender.GetNodeData(Node);
case Column of
0: CellText := TimeToStr(chatInfo^.Time);
1: CellText := chatInfo^.Sender;
2: CellText := chatInfo^.Msg;
end;
end;
procedure TfrmMain.vstChatPaintText(Sender: TBaseVirtualTree;
const TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;
TextType: TVSTTextType);
var
chatInfo: PChatInfo;
begin
chatInfo := Sender.GetNodeData(Node);
if chatInfo^.Sender = 'System' then
begin
if Column = 1 then
TargetCanvas.Font.Style := TargetCanvas.Font.Style + [fsItalic, fsBold]
else
TargetCanvas.Font.Style := TargetCanvas.Font.Style + [fsItalic];
end;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.vstClientsGetText(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
var CellText: String);
var
clientInfo: PClientInfo;
begin
clientInfo := Sender.GetNodeData(Node);
case Column of
1: CellText := clientInfo^.Name;//Format('%d, %d', [locationInfo^.X, locationInfo^.Y]);
2: CellText := FormatDateTime('mm\dd - hh:mm:ss', clientInfo^.LogonDateTime);
end;
end;
procedure TfrmMain.vstClientsGetImageIndex(Sender: TBaseVirtualTree;
Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
var Ghosted: Boolean; var ImageIndex: Integer);
var
clientInfo: PClientInfo;
begin
clientInfo := Sender.GetNodeData(Node);
case Column of
0: frmAccountControl.GetAccountImageIndex(clientInfo^.AccessLevel, ImageIndex);
end;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
procedure TfrmMain.vstLocationsDblClick(Sender: TObject);
var
node: PVirtualNode;
locationInfo: PLocationInfo;
begin
node := vstLocations.GetFirstSelected;
if node <> nil then
begin
locationInfo := vstLocations.GetNodeData(node);
SetPos(locationInfo^.X, locationInfo^.Y);
end;
end;
procedure TfrmMain.vstLocationsFreeNode(Sender: TBaseVirtualTree;
Node: PVirtualNode);
var
locationInfo: PLocationInfo;
begin
locationInfo := Sender.GetNodeData(Node);
locationInfo^.Name := EmptyStr;
end;
procedure TfrmMain.vstLocationsGetText(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
var CellText: String);
var
locationInfo: PLocationInfo;
begin
locationInfo := Sender.GetNodeData(Node);
case Column of
0: CellText := Format('%d, %d', [locationInfo^.X, locationInfo^.Y]);
1: CellText := locationInfo^.Name;
end;
end;
procedure TfrmMain.vstLocationsLoadNode(Sender: TBaseVirtualTree;
Node: PVirtualNode; Stream: TStream);
var
locationInfo: PLocationInfo;
stringLength: Integer;
s: string;
begin
locationInfo := Sender.GetNodeData(Node);
Stream.Read(locationInfo^.X, SizeOf(Word));
Stream.Read(locationInfo^.Y, SizeOf(Word));
stringLength := 0;
Stream.Read(stringLength, SizeOf(Integer));
SetLength(s, stringLength);
Stream.Read(s[1], stringLength);
locationInfo^.Name := s;
end;
procedure TfrmMain.vstLocationsNewText(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex; const NewText: String);
var
locationInfo: PLocationInfo;
begin
if Column = 1 then
begin
locationInfo := Sender.GetNodeData(Node);
locationInfo^.Name := NewText;
end;
end;
procedure TfrmMain.vstLocationsSaveNode(Sender: TBaseVirtualTree;
Node: PVirtualNode; Stream: TStream);
var
locationInfo: PLocationInfo;
stringLength: Integer;
begin
locationInfo := Sender.GetNodeData(Node);
Stream.Write(locationInfo^.X, SizeOf(Word));
Stream.Write(locationInfo^.Y, SizeOf(Word));
stringLength := Length(locationInfo^.Name);
Stream.Write(stringLength, SizeOf(Integer));
Stream.Write(locationInfo^.Name[1], stringLength);
end;
procedure TfrmMain.XMLPropStorage1RestoreProperties(Sender: TObject);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
var ws: Integer;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
Logger.EnterMethod([lcLandscape, lcDebug], 'TfrmMain.XMLPropStorage1RestoreProperties(Sender: TObject);');
if Sender = nil then begin
FTextureManager.UseAnims := mnuShowAnimations.Checked;
tbTerrain.Down := acTerrain.Checked;
frmLightLevel.tbLightlevel.Position:=acLightLevel.Tag;
end;
if mnuWindowedMode.Checked then begin
BorderStyle := bsSizeable;
FormStyle := fsNormal;
{if ((Tag<>0) and (mnuWindowedMode.Tag<>0)) then begin
ws := (Tag and $3);
if ws = 1 then WindowState := wsNormal else
if ws = 2 then WindowState := wsMinimized else
if ws = 3 then WindowState := wsMaximized;
Left := ((mnuWindowedMode.Tag shr 15) and $7FFF);
Top := (mnuWindowedMode.Tag and $7FFF);
Width := ((Tag shr 16) and $3FFF);
Height:= ((Tag shr 2) and $3FFF);
Tag := 0; mnuWindowedMode.Tag := 0;
end; }
end else begin
{if ((Tag = 0) and (mnuWindowedMode.Tag = 0)) then begin
if WindowState = wsNormal then ws := 1 else
if WindowState = wsMinimized then ws := 2 else
if WindowState = wsMaximized then ws := 3 else ws := 0;
Tag := ((Width and $3FFF) shl 16) or ((Height and $3FFF) shl 2) or (ws and $3);
mnuWindowedMode.Tag := ((Left and $7FFF) shl 15) or ((Top and $7FFF) shl 0);
end; }
BorderStyle := bsNone;
FormStyle := fsStayOnTop;
WindowState := wsMaximized;
end;
//mnuTileListViewClick(nil);
//mnuAutoHideGroupListClick(nil);
//mnuAutoHideRandomListClick(nil);
Logger.ExitMethod([lcLandscape, lcDebug], 'TfrmMain.XMLPropStorage1RestoreProperties(Sender: TObject);');
end;
procedure TfrmMain.XMLPropStorage1SavingProperties(Sender: TObject);
var ws: Integer;
begin
Logger.EnterMethod([lcLandscape, lcDebug], 'TfrmMain.XMLPropStorage1SavingProperties(Sender: TObject);');
//Hide;
if mnuWindowedMode.Checked then begin
if ((Tag<>0) and (mnuWindowedMode.Tag<>0)) then begin
ws := (Tag and $3);
if ws = 1 then WindowState := wsNormal else
if ws = 2 then WindowState := wsMinimized else
if ws = 3 then WindowState := wsMaximized;
Left := ((mnuWindowedMode.Tag shr 15) and $7FFF);
Top := (mnuWindowedMode.Tag and $7FFF);
Width := ((Tag shr 16) and $3FFF);
Height:= ((Tag shr 2) and $3FFF);
Tag := 0; mnuWindowedMode.Tag := 0;
end;
end else begin
if ((Tag = 0) and (mnuWindowedMode.Tag = 0)) then begin
if WindowState = wsNormal then ws := 1 else
if WindowState = wsMinimized then ws := 2 else
if WindowState = wsMaximized then ws := 3 else ws := 0;
Tag := ((Width and $3FFF) shl 16) or ((Height and $3FFF) shl 2) or (ws and $3);
mnuWindowedMode.Tag := ((Left and $7FFF) shl 15) or ((Top and $7FFF) shl 0);
end;
end;
//Show;
if spTileList.Top > spTileList.Parent.Height then
spTileList.Top := spTileList.Parent.Height - 200;
Logger.ExitMethod([lcLandscape, lcDebug], 'TfrmMain.XMLPropStorage1SavingProperties(Sender: TObject);');
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.SetX(const AValue: Integer);
begin
SetPos(AValue, FY);
end;
procedure TfrmMain.SetY(const AValue: Integer);
begin
SetPos(FX, AValue);
end;
procedure TfrmMain.SetPos(AX, AY: Word);
begin
if InRange(AX, 0, FLandscape.CellWidth - 1) and InRange(AY, 0,
FLandscape.CellHeight - 1) then
begin
FX := AX;
edX.Value := FX;
FY := AY;
edY.Value := FY;
dmNetwork.Send(TUpdateClientPosPacket.Create(AX, AY));
InvalidateScreenBuffer;
if frmRadarMap <> nil then frmRadarMap.Repaint;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
pbRadar.Repaint;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
procedure TfrmMain.SwitchToSelection;
begin
acSelect.Checked := True;
BringToFront;
end;
procedure TfrmMain.RegisterAccessChangedListener(
AListener: TAccessChangedListener);
begin
if FAccessChangedListeners.IndexOf(AListener) < 0 then
FAccessChangedListeners.Add(AListener);
end;
procedure TfrmMain.RegisterSelectionListener(AListener: TSelectionListener);
begin
if FSelectionListeners.IndexOf(AListener) < 0 then
FSelectionListeners.Add(AListener);
end;
procedure TfrmMain.UnregisterAccessChangedListener(
AListener: TAccessChangedListener);
begin
FAccessChangedListeners.Remove(AListener);
end;
procedure TfrmMain.UnregisterSelectionListener(AListener: TSelectionListener);
begin
FSelectionListeners.Remove(AListener);
end;
procedure TfrmMain.SetCurrentTile(const AValue: TWorldItem);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
var
sRect: TRect;
w, h: Integer;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
//Logger.EnterMethod([lcClient, lcDebug], 'SetCurrentTile');
if AValue = FCurrentTile then
begin
//Logger.ExitMethod([lcClient, lcDebug], 'SetCurrentTile');
Exit;
end;
//Logger.Send([lcClient, lcDebug], 'Value', AValue);
if FCurrentTile <> nil then
FCurrentTile.OnDestroy.UnregisterEvent(@OnTileRemoved);
FCurrentTile := AValue;
if FCurrentTile = nil then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
lblTileInfoIDLabel.Caption:= '';
lblTileInfoIDValue.Caption:= '';
lblTileInfoXLabel.Caption := '';
lblTileInfoXValue.Caption := '';
lblTileInfoYLabel.Caption := '';
lblTileInfoYValue.Caption := '';
lblTileInfoZLabel.Caption := '';
lblTileInfoZValue.Caption := '';
lblTileInfoHueLabel.Caption := '';
lblTileInfoHueValue.Caption := '';
lblTileInfoOLabel.Visible := False;
lblTileInfoWLabel.Visible := False;
lblTileInfoWValue.Visible := False;
lblTileInfoHLabel.Visible := False;
lblTileInfoHValue.Visible := False;
lblTileInfoCLabel.Visible := False;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end else
begin
FCurrentTile.OnDestroy.RegisterEvent(@OnTileRemoved);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
lblTileInfoIDValue.Caption := Format('0x%.4x', [FCurrentTile.TileID]);
lblTileInfoIDValue.Font.Bold := True;
lblTileInfoXLabel.Caption := lbBottomCursorPosX;
lblTileInfoYLabel.Caption := lbBottomCursorPosY;
lblTileInfoZLabel.Caption := lbBottomCursorPosZ;
lblTileInfoXValue.Caption := Format('%d', [FCurrentTile.X]);
lblTileInfoYValue.Caption := Format('%d', [FCurrentTile.Y]);
lblTileInfoZValue.Caption := Format('%d', [FCurrentTile.Z]);
if FCurrentTile is TVirtualTile then begin
lblTileInfoIDLabel.Caption := lbBottomCursorVLayer1;
lblTileInfoIDValue.Font.Bold := False;
lblTileInfoIDValue.Caption := lbBottomCursorVLayer2;
lblTileInfoHueLabel.Caption:= '';
lblTileInfoHueValue.Caption:= '';
end
else if FCurrentTile is TMapCell then begin
lblTileInfoIDLabel.Caption := lbBottomCursorLandID;
lblTileInfoHueLabel.Caption:= '';
lblTileInfoHueValue.Caption:= '';
end
else if FCurrentTile is TStaticItem then begin
lblTileInfoIDLabel.Caption := lbBottomCursorItemID;
lblTileInfoHueLabel.Caption:= lbBottomCursorItemHue;
lblTileInfoHueValue.Caption:= Format('%.3x', [TStaticItem(FCurrentTile).Hue]);
end;
sRect := GetSelectedRect;
w := sRect.Right - sRect.Left + 1;
h := sRect.Bottom - sRect.Top + 1;
if ((w > 1) or (h > 1)) then begin
lblTileInfoOLabel.Visible := True;
lblTileInfoWLabel.Visible := True;
lblTileInfoWValue.Visible := True;
lblTileInfoHLabel.Visible := True;
lblTileInfoHValue.Visible := True;
lblTileInfoCLabel.Visible := True;
lblTileInfoWValue.Caption := Format('%d', [w]);
lblTileInfoHValue.Caption := Format('%d', [h]);
end else begin
lblTileInfoOLabel.Visible := False;
lblTileInfoWLabel.Visible := False;
lblTileInfoWValue.Visible := False;
lblTileInfoHLabel.Visible := False;
lblTileInfoHValue.Visible := False;
lblTileInfoCLabel.Visible := False;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
UpdateSelection;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
//Logger.Send([lcClient, lcDebug], 'CurrentTile: %.5x (%.6d)', [CurrentTile.TileID, CurrentTile.TileID]);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
//Logger.ExitMethod([lcClient, lcDebug], 'SetCurrentTile');
end;
procedure TfrmMain.SetSelectedTile(const AValue: TWorldItem);
begin
//Logger.EnterMethod([lcClient, lcDebug], 'SetSelectedTile');
if AValue = FSelectedTile then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
Logger.ExitMethod([lcClient, lcDebug], 'SetSelectedTile');
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
Exit;
end;
//Logger.Send([lcClient, lcDebug], 'Value', AValue);
if FSelectedTile <> nil then
FSelectedTile.OnDestroy.UnregisterEvent(@OnTileRemoved);
FSelectedTile := AValue;
if FSelectedTile <> nil then
FSelectedTile.OnDestroy.RegisterEvent(@OnTileRemoved);
UpdateSelection;
//Logger.ExitMethod([lcClient, lcDebug], 'SetSelectedTile');
end;
procedure TfrmMain.SetNormalLights;
const
specular: TGLArrayf4 = (2, 2, 2, 1);
ambient: TGLArrayf4 = (1, 1, 1, 1);
begin
glLightfv(GL_LIGHT0, GL_AMBIENT, @specular);
glLightModelfv(GL_LIGHT_MODEL_AMBIENT, @ambient);
end;
procedure TfrmMain.SetDarkLights;
const
specularDark: TGLArrayf4 = (0.5, 0.5, 0.5, 1);
ambientDark: TGLArrayf4 = (0.25, 0.25, 0.25, 1);
begin
glLightfv(GL_LIGHT0, GL_AMBIENT, @specularDark);
glLightModelfv(GL_LIGHT_MODEL_AMBIENT, @ambientDark);
end;
procedure TfrmMain.InitRender;
const
lightPosition: TGLArrayf4 = (-1, -1, 0.5, 0);
begin
glEnable(GL_ALPHA_TEST);
glAlphaFunc(GL_GREATER, 0.1);
glEnable(GL_TEXTURE_2D);
glDisable(GL_DITHER);
glEnable(GL_BLEND); // Enable alpha blending of textures
glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
glShadeModel(GL_SMOOTH);
glEnable(GL_NORMALIZE);
glEnable(GL_LIGHT0);
glLightfv(GL_LIGHT0, GL_POSITION, @lightPosition);
glLightModeli(GL_LIGHT_MODEL_TWO_SIDE, GL_FALSE);
end;
procedure TfrmMain.InitSize;
begin
glViewport(0, 0, oglGameWindow.Width, oglGameWindow.Height);
glMatrixMode(GL_PROJECTION);
glLoadIdentity;
gluOrtho2D(0, oglGameWindow.Width, oglGameWindow.Height, 0);
glMatrixMode(GL_MODELVIEW);
glLoadIdentity;
end;
procedure TfrmMain.LoadLocations;
var
xmlDoc: TXMLDocument;
location: TDOMElement;
locationNode: PVirtualNode;
locationInfo: PLocationInfo;
locations: TDOMNodeList;
i, j: Integer;
begin
vstLocations.Clear;
if FileExists(FLocationsFile) then
begin
ReadXMLFile(xmlDoc, FLocationsFile);
if xmlDoc.DocumentElement.NodeName = 'Locations' then
begin
locations := xmlDoc.DocumentElement.ChildNodes;
for i := 0 to locations.Count - 1 do
begin
location := TDOMElement(locations[i]);
if location.NodeName = 'Location' then
begin
locationNode := vstLocations.AddChild(nil);
locationInfo := vstLocations.GetNodeData(locationNode);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
locationInfo^.Name := CP1251ToUTF8(location.AttribStrings['Name']);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if TryStrToInt(location.AttribStrings['X'], j) then
locationInfo^.X := j
else
locationInfo^.X := 0;
if TryStrToInt(location.AttribStrings['Y'], j) then
locationInfo^.Y := j
else
locationInfo^.Y := 0;
end;
end;
end;
xmlDoc.Free;
end;
end;
procedure TfrmMain.LoadRandomPresets;
var
presets: TDOMNodeList;
i: Integer;
begin
cbRandomPreset.Clear;
FreeAndNil(FRandomPresetsDoc);
if FileExists(FRandomPresetsFile) then
begin
ReadXMLFile(FRandomPresetsDoc, FRandomPresetsFile);
presets := FRandomPresetsDoc.DocumentElement.ChildNodes;
for i := 0 to presets.Count - 1 do
begin
if presets[i].NodeName = 'Preset' then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
cbRandomPreset.Items.AddObject(
CP1251ToUTF8(TDOMElement(presets[i]).AttribStrings['Name']), presets[i]);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
end else
begin
FRandomPresetsDoc := TXMLDocument.Create;
FRandomPresetsDoc.AppendChild(FRandomPresetsDoc.CreateElement('RandomPresets'));
end;
end;
procedure TfrmMain.MoveBy(AOffsetX, AOffsetY: Integer); inline;
begin
SetPos(EnsureRange(FX + AOffsetX, 0, FLandscape.CellWidth - 1),
EnsureRange(FY + AOffsetY, 0, FLandscape.CellHeight - 1));
UpdateCurrentTile;
end;
procedure TfrmMain.PrepareMapCell(AMapCell: TMapCell);
var
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
current, north, east, west, tile1, tile4, tile3, tile6: PBlockInfo;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
cell: TMapCell;
begin
current := FScreenBuffer.UpdateSortOrder(AMapCell);
if current = nil then
Exit; //off-screen update
PrepareScreenBlock(current);
Exclude(FScreenBufferState, sbsIndexed);
//Find surrounding cells
current := nil;
north := nil;
east := nil;
west := nil;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tile1 := nil;
tile4 := nil;
tile3 := nil;
tile6 := nil;
while ((north = nil) or (east = nil) or (west = nil) or
(tile1 = nil) or (tile3 = nil) or (tile4 = nil) or (tile6 = nil)) and
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
FScreenBuffer.Iterate(current) do
begin
if current^.Item is TMapCell then
begin
cell := TMapCell(current^.Item);
if (cell.X = AMapCell.X - 1) and (cell.Y = AMapCell.Y - 1) then
north := current
else if (cell.X = AMapCell.X) and (cell.Y = AMapCell.Y - 1) then
east := current
else if (cell.X = AMapCell.X - 1) and (cell.Y = AMapCell.Y) then
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
west := current
else if (cell.X = AMapCell.X) and (cell.Y = AMapCell.Y + 1) then
tile1 := current
else if (cell.X = AMapCell.X + 1) and (cell.Y = AMapCell.Y) then
tile3 := current
else if (cell.X = AMapCell.X - 1) and (cell.Y = AMapCell.Y + 1) then
tile4 := current
else if (cell.X = AMapCell.X + 1) and (cell.Y = AMapCell.Y - 1) then
tile6 := current;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
if north <> nil then PrepareScreenBlock(north);
if east <> nil then PrepareScreenBlock(east);
if west <> nil then PrepareScreenBlock(west);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if tile1 <> nil then PrepareScreenBlock(tile1);
if tile3 <> nil then PrepareScreenBlock(tile3);
if tile4 <> nil then PrepareScreenBlock(tile4);
if tile6 <> nil then PrepareScreenBlock(tile6);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.InvalidateFilter;
begin
Exclude(FScreenBufferState, sbsFiltered);
end;
procedure TfrmMain.InvalidateScreenBuffer;
begin
Exclude(FScreenBufferState, sbsValid);
end;
procedure TfrmMain.PrepareScreenBlock(ABlockInfo: PBlockInfo);
procedure GetLandAlt(const AX, AY: Integer; const ADefaultZ,
ADefaultRaw: SmallInt; out Z, RawZ: SmallInt);
var
cell: TMapCell;
begin
cell := FLandscape.MapCell[AX, AY];
if cell <> nil then
begin
Z := cell.Z;
RawZ := cell.RawZ;
end else
begin
Z := ADefaultZ;
RawZ := ADefaultRaw;
end;
end;
var
item: TWorldItem;
drawX, drawY: Integer;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
z, west, south, east, tileNorth, tileWest, tileLeft, tileRight: SmallInt;
rawZ, rawWest, rawSouth, rawEast, rawTileNorth, rawTileWest, rawTileLeft, rawTileRight: SmallInt;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
staticItem: TStaticItem;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
zoom: Single;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
//add normals to map tiles and materials where possible
item := ABlockInfo^.Item;
GetDrawOffset(item.X , item.Y, drawX, drawY);
if acFlat.Checked then
begin
z := 0;
rawZ := 0;
end else
begin
z := item.Z;
rawZ := item.RawZ;
end;
if ABlockInfo^.HighRes <> nil then ABlockInfo^.HighRes.DelRef;
if ABlockInfo^.LowRes <> nil then ABlockInfo^.LowRes.DelRef;
ABlockInfo^.HighRes := nil;
ABlockInfo^.CheckRealQuad := False;
ABlockInfo^.Text.Free;
if item is TMapCell then
begin
if not acFlat.Checked then
begin
GetLandAlt(item.X, item.Y + 1, z, rawZ, west, rawWest);
GetLandAlt(item.X + 1, item.Y + 1, z, rawZ, south, rawSouth);
GetLandAlt(item.X + 1, item.Y, z, rawZ, east, rawEast);
if (west <> z) or (south <> z) or (east <> z) then
ABlockInfo^.HighRes := FTextureManager.GetTexMaterial(item.TileID);
if (rawWest <> rawZ) or (rawSouth <> rawZ) or (rawEast <> rawZ) then
begin
ABlockInfo^.RealQuad[0][0] := drawX;
ABlockInfo^.RealQuad[0][1] := drawY - rawZ * 4;
ABlockInfo^.RealQuad[1][0] := drawX + 22;
ABlockInfo^.RealQuad[1][1] := drawY + 22 - rawEast * 4;
ABlockInfo^.RealQuad[2][0] := drawX;
ABlockInfo^.RealQuad[2][1] := drawY + 44 - rawSouth * 4;
ABlockInfo^.RealQuad[3][0] := drawX - 22;
ABlockInfo^.RealQuad[3][1] := drawY + 22 - rawWest * 4;
with ABlockInfo^ do
begin
with ScreenRect do
begin
Left := drawX - 22;
Right := drawX + 22;
Top := RealQuad[0][1];
Bottom := RealQuad[0][1];
if RealQuad[1][1] < Top then Top := RealQuad[1][1];
if RealQuad[1][1] > Bottom then Bottom := RealQuad[1][1];
if RealQuad[2][1] < Top then Top := RealQuad[2][1];
if RealQuad[2][1] > Bottom then Bottom := RealQuad[2][1];
if RealQuad[3][1] < Top then Top := RealQuad[3][1];
if RealQuad[3][1] > Bottom then Bottom := RealQuad[3][1];
end;
CheckRealQuad := True;
end;
end;
end else
begin
if mnuFlatShowHeight.Checked then
ABlockInfo^.Text := TGLText.Create(FGLFont, IntToStr(item.Z));
end;
if not ABlockInfo^.CheckRealQuad then
ABlockInfo^.ScreenRect := Bounds(Trunc(drawX - 22),
Trunc(drawY - rawZ * 4), 44, 44);
ABlockInfo^.LowRes := FTextureManager.GetArtMaterial(item.TileID);
if ABlockInfo^.HighRes <> nil then
begin
if ABlockInfo^.Normals = nil then
New(ABlockInfo^.Normals);
FLandscape.GetNormals(item.X, item.Y, ABlockInfo^.Normals^);
ABlockInfo^.DrawQuad[0][0] := drawX;
ABlockInfo^.DrawQuad[0][1] := drawY - z * 4;
ABlockInfo^.DrawQuad[1][0] := drawX + 22;
ABlockInfo^.DrawQuad[1][1] := drawY + 22 - east * 4;
ABlockInfo^.DrawQuad[2][0] := drawX;
ABlockInfo^.DrawQuad[2][1] := drawY + 44 - south * 4;
ABlockInfo^.DrawQuad[3][0] := drawX - 22;
ABlockInfo^.DrawQuad[3][1] := drawY + 22 - west * 4;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
// Подготовка сетки рельефа для текстур
if mnuShowGrid.Checked or mnuShowBlocks.Checked then
begin
ABlockInfo^.LineWidth[0] := 0.9;
ABlockInfo^.LineDraw[0][0] := ABlockInfo^.DrawQuad[0];
ABlockInfo^.LineDraw[0][1] := ABlockInfo^.DrawQuad[1];
ABlockInfo^.LineWidth[1] := 0.9;
ABlockInfo^.LineDraw[1][0] := ABlockInfo^.DrawQuad[0];
ABlockInfo^.LineDraw[1][1] := ABlockInfo^.DrawQuad[3];
ABlockInfo^.LineWidth[2] := 0.8;
//ABlockInfo^.LineDraw[2][0] := ABlockInfo^.DrawQuad[0];
//ABlockInfo^.LineDraw[2][1] := ABlockInfo^.DrawQuad[2];
ABlockInfo^.LineDraw[2][0] := ABlockInfo^.DrawQuad[1];
ABlockInfo^.LineDraw[2][1] := ABlockInfo^.DrawQuad[3];
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end else
begin
ABlockInfo^.DrawQuad[0][0] := drawX - 22;
ABlockInfo^.DrawQuad[0][1] := drawY - z * 4;
ABlockInfo^.DrawQuad[1][0] := drawX - 22 + ABlockInfo^.LowRes.Width;
ABlockInfo^.DrawQuad[1][1] := drawY - z * 4;
ABlockInfo^.DrawQuad[2][0] := drawX - 22 + ABlockInfo^.LowRes.Width;
ABlockInfo^.DrawQuad[2][1] := drawY + ABlockInfo^.LowRes.Height - z * 4;
ABlockInfo^.DrawQuad[3][0] := drawX - 22;
ABlockInfo^.DrawQuad[3][1] := drawY + ABlockInfo^.LowRes.Height - z * 4;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
// Подготовка сетки рельефа для лендов
if mnuShowGrid.Checked or mnuShowBlocks.Checked then
begin
GetLandAlt(item.X, item.Y - 1, z, rawZ, tileNorth, rawTileNorth);
GetLandAlt(item.X - 1, item.Y, z, rawZ, tileWest, rawTileWest);
GetLandAlt(item.X - 1, item.Y + 1, z, rawZ, tileLeft, rawTileLeft);
GetLandAlt(item.X + 1, item.Y - 1, z, rawZ, tileRight, rawTileRight);
if (tileNorth <> z) or (tileRight <> z)
then ABlockInfo^.LineWidth[0] := 0.9
else ABlockInfo^.LineWidth[0] := 0.8;
ABlockInfo^.LineDraw[0][0][0] := drawX;
ABlockInfo^.LineDraw[0][0][1] := ABlockInfo^.DrawQuad[0][1];
ABlockInfo^.LineDraw[0][1][0] := ABlockInfo^.DrawQuad[1][0];
ABlockInfo^.LineDraw[0][1][1] := ABlockInfo^.DrawQuad[1][1] + 22;
if (tileWest <> z) or (tileLeft <> z)
then ABlockInfo^.LineWidth[1] := 0.9
else ABlockInfo^.LineWidth[1] := 0.8;
ABlockInfo^.LineDraw[1][0][0] := drawX;
ABlockInfo^.LineDraw[1][0][1] := ABlockInfo^.DrawQuad[0][1];
ABlockInfo^.LineDraw[1][1][0] := ABlockInfo^.DrawQuad[3][0];
ABlockInfo^.LineDraw[1][1][1] := ABlockInfo^.DrawQuad[3][1] - 22;
ABlockInfo^.LineWidth[2] := 0.0;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end else
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
// Виртуальный пол
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if item is TVirtualTile then
begin
ABlockInfo^.LowRes := FVLayerMaterial;
ABlockInfo^.LowRes.AddRef;
ABlockInfo^.ScreenRect := Bounds(Trunc(drawX - 22), Trunc(drawY - z * 4),
44, 44);
ABlockInfo^.DrawQuad[0][0] := drawX - 22;
ABlockInfo^.DrawQuad[0][1] := drawY - z * 4;
ABlockInfo^.DrawQuad[1][0] := drawX - 22 + ABlockInfo^.LowRes.Width;
ABlockInfo^.DrawQuad[1][1] := drawY - z * 4;
ABlockInfo^.DrawQuad[2][0] := drawX - 22 + ABlockInfo^.LowRes.Width;
ABlockInfo^.DrawQuad[2][1] := drawY + ABlockInfo^.LowRes.Height - z * 4;
ABlockInfo^.DrawQuad[3][0] := drawX - 22;
ABlockInfo^.DrawQuad[3][1] := drawY + ABlockInfo^.LowRes.Height - z * 4;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
// Подготовка сетки блоков на виртуальном полу
if (frmVirtualLayer.cbShowBlocks.Checked) then
begin
if (item.Y mod 8) <> 0 then
ABlockInfo^.LineWidth[0] := 0
else begin
ABlockInfo^.LineWidth[0] := 1.6;
ABlockInfo^.LineDraw[0][0][0] := drawX;
ABlockInfo^.LineDraw[0][0][1] := ABlockInfo^.DrawQuad[0][1];
ABlockInfo^.LineDraw[0][1][0] := ABlockInfo^.DrawQuad[1][0];
ABlockInfo^.LineDraw[0][1][1] := ABlockInfo^.DrawQuad[1][1] + 22;
end;
if (item.X mod 8) <> 0 then
ABlockInfo^.LineWidth[1] := 0
else begin
ABlockInfo^.LineWidth[1] := 1.6;
ABlockInfo^.LineDraw[1][0][0] := drawX;
ABlockInfo^.LineDraw[1][0][1] := ABlockInfo^.DrawQuad[0][1];
ABlockInfo^.LineDraw[1][1][0] := ABlockInfo^.DrawQuad[3][0];
ABlockInfo^.LineDraw[1][1][1] := ABlockInfo^.DrawQuad[3][1] - 22;
end;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end else
begin
staticItem := TStaticItem(item);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
// Тайл виртуального источника света
if acNoDraw.Checked and mnuShowLightSource.Checked and (staticItem.TileID <= FLandscape.MaxStaticID)
and (FLightSourceTiles[staticItem.TileID].image > 0) then
begin
ABlockInfo^.LowRes := FVLightSrcMaterial[FLightSourceTiles[staticItem.TileID].image - 1];
ABlockInfo^.LowRes.AddRef;
ABlockInfo^.ScreenRect := Bounds(Trunc(drawX - 12), Trunc(drawY - z * 4), 24, 24);
ABlockInfo^.DrawQuad[0][0] := drawX - 12;
ABlockInfo^.DrawQuad[0][1] := drawY + 12 - z * 4;
ABlockInfo^.DrawQuad[1][0] := drawX - 12 + ABlockInfo^.LowRes.Width;
ABlockInfo^.DrawQuad[1][1] := drawY + 12 - z * 4;
ABlockInfo^.DrawQuad[2][0] := drawX - 12 + ABlockInfo^.LowRes.Width;
ABlockInfo^.DrawQuad[2][1] := drawY + 12 + ABlockInfo^.LowRes.Height - z * 4;
ABlockInfo^.DrawQuad[3][0] := drawX - 12;
ABlockInfo^.DrawQuad[3][1] := drawY + 12 + ABlockInfo^.LowRes.Height - z * 4;
end else
// Тайлы обычной статики
begin
ABlockInfo^.LowRes := FTextureManager.GetStaticMaterial(staticItem);
ABlockInfo^.HueOverride := False;
ABlockInfo^.ScreenRect := Bounds(Trunc(drawX - ABlockInfo^.LowRes.RealWidth / 2),
Trunc(drawY + 44 - ABlockInfo^.LowRes.RealHeight - z * 4),
ABlockInfo^.LowRes.RealWidth,
ABlockInfo^.LowRes.RealHeight);
ABlockInfo^.Translucent := tdfTranslucent in
ResMan.Tiledata.StaticTiles[staticItem.TileID].Flags;
south := ABlockInfo^.LowRes.RealHeight;
east := ABlockInfo^.LowRes.RealWidth div 2;
ABlockInfo^.DrawQuad[0][0] := drawX - east;
ABlockInfo^.DrawQuad[0][1] := drawY + 44 - south - z * 4;
ABlockInfo^.DrawQuad[1][0] := drawX - east + ABlockInfo^.LowRes.Width;
ABlockInfo^.DrawQuad[1][1] := drawY + 44 - south - z * 4;
ABlockInfo^.DrawQuad[2][0] := drawX - east + ABlockInfo^.LowRes.Width;
ABlockInfo^.DrawQuad[2][1] := drawY + 44 - south + ABlockInfo^.LowRes.Height - z * 4;
ABlockInfo^.DrawQuad[3][0] := drawX - east;
ABlockInfo^.DrawQuad[3][1] := drawY + 44 - south + ABlockInfo^.LowRes.Height - z * 4;
end;
end;
if tbZoom.Down then begin
zoom := tbZoom.Tag / 1000.0;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
ABlockInfo^.ScreenRect.Left := Trunc(zoom * (ABlockInfo^.ScreenRect.Left -drawX)+drawX);
ABlockInfo^.ScreenRect.Top := Trunc(zoom * (ABlockInfo^.ScreenRect.Top -drawY)+drawY);;
ABlockInfo^.ScreenRect.Right := Trunc(zoom * (ABlockInfo^.ScreenRect.Right -drawX)+drawX);
ABlockInfo^.ScreenRect.Bottom := Trunc(zoom * (ABlockInfo^.ScreenRect.Bottom -drawY)+drawY);
//south:= Trunc(zoom*(ABlockInfo^.DrawQuad[2][1] - ABlockInfo^.DrawQuad[0][1]));
//east := Trunc(zoom*(ABlockInfo^.DrawQuad[2][0] - ABlockInfo^.DrawQuad[0][0]));
for z:=0 to 3 do begin
ABlockInfo^.DrawQuad[z][0] := Trunc(zoom * (ABlockInfo^.DrawQuad[z][0] -drawX)+drawX);
ABlockInfo^.DrawQuad[z][1] := Trunc(zoom * (ABlockInfo^.DrawQuad[z][1] -drawY)+drawY);
end;
if item is TMapCell then begin
inc(ABlockInfo^.DrawQuad[0][1], -1);
inc(ABlockInfo^.DrawQuad[1][0], +1);
inc(ABlockInfo^.DrawQuad[2][1], +1);
inc(ABlockInfo^.DrawQuad[3][0], -1);
end else if zoom < 1.0 then begin
inc(ABlockInfo^.DrawQuad[0][0], -1);
inc(ABlockInfo^.DrawQuad[0][1], -1);
//inc(ABlockInfo^.DrawQuad[1][0], +1);
inc(ABlockInfo^.DrawQuad[1][1], -1);
//inc(ABlockInfo^.DrawQuad[2][0], +1);
//inc(ABlockInfo^.DrawQuad[2][1], +1);
inc(ABlockInfo^.DrawQuad[3][0], -1);
//inc(ABlockInfo^.DrawQuad[3][1], +1);
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if not acFlat.Checked and (item is TMapCell) and
((rawWest <> rawZ) or (rawSouth <> rawZ) or (rawEast <> rawZ)) then
for z:=0 to 3 do begin
ABlockInfo^.RealQuad[z][0] := Trunc(zoom * (ABlockInfo^.RealQuad[z][0] -drawX)+drawX);
ABlockInfo^.RealQuad[z][1] := Trunc(zoom * (ABlockInfo^.RealQuad[z][1] -drawY)+drawY);
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
rawZ := -1;
if ((mnuShowGrid.Checked or mnuShowBlocks.Checked) and (item is TMapCell))
then if (ABlockInfo^.HighRes <> nil) then rawZ:=2 else rawZ:= 1
else if (frmVirtualLayer.cbShowBlocks.Checked and (item is TVirtualTile))
then if ((item.Y mod 8 = 0) or (item.X mod 8 = 0)) then rawZ := 1;
for z:=0 to rawZ do begin
//ABlockInfo^.LineWidth[z] := zoom * ABlockInfo^.LineWidth[z];
ABlockInfo^.LineDraw[z][0][0] := TGLint(Trunc(zoom *(ABlockInfo^.LineDraw[z][0][0] -drawX)+drawX));
ABlockInfo^.LineDraw[z][0][1] := TGLint(Trunc(zoom *(ABlockInfo^.LineDraw[z][0][1] -drawY)+drawY));
ABlockInfo^.LineDraw[z][1][0] := TGLint(Trunc(zoom *(ABlockInfo^.LineDraw[z][1][0] -drawX)+drawX));
ABlockInfo^.LineDraw[z][1][1] := TGLint(Trunc(zoom *(ABlockInfo^.LineDraw[z][1][1] -drawY)+drawY));
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
procedure TfrmMain.Render;
var
highlight: Boolean;
- Added optional highlight for (un)walkable tiles - Fixed lightmanager to draw in the correct color - Fixed TMapBlock and TStaticBlock to correctly initialize itself as "unchanged" - Cleanup in the server project
2009-12-24 15:49:15 +01:00
intensity, red, green, blue: GLfloat;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
blockInfo: PBlockInfo;
item: TWorldItem;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
i : byte;
zoom: Single;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if tbZoom.Down then zoom := tbZoom.Tag / 1000.0 else zoom:=1.0;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if not (sbsValid in FScreenBufferState) then
RebuildScreenBuffer;
if not (sbsIndexed in FScreenBufferState) then
begin
FScreenBuffer.UpdateShortcuts;
Include(FScreenBufferState, sbsIndexed);
end;
if not (sbsFiltered in FScreenBufferState) then
UpdateFilter;
blockInfo := nil;
while FScreenBuffer.Iterate(blockInfo) do
begin
if blockInfo^.State = ssFiltered then
Continue;
item := blockInfo^.Item;
if acSelect.Checked or item.CanBeEdited or (item is TVirtualTile) then
begin
intensity := 1.0;
SetNormalLights;
end else
begin
intensity := 0.5;
SetDarkLights;
end;
- Added optional highlight for (un)walkable tiles - Fixed lightmanager to draw in the correct color - Fixed TMapBlock and TStaticBlock to correctly initialize itself as "unchanged" - Cleanup in the server project
2009-12-24 15:49:15 +01:00
case blockInfo^.WalkRestriction of
wrNone:
begin
red := 1;
green := 1;
blue := 1;
end;
wrCanWalk:
begin
red := 0.5;
green := 1;
blue := 0.5;
end;
wrCannotWalk:
begin
red := 1;
green := 0.5;
blue := 0.5;
end;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if blockInfo^.Translucent then
- Added optional highlight for (un)walkable tiles - Fixed lightmanager to draw in the correct color - Fixed TMapBlock and TStaticBlock to correctly initialize itself as "unchanged" - Cleanup in the server project
2009-12-24 15:49:15 +01:00
glColor4f(intensity * red, intensity * green, intensity * blue, 0.8)
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
else
- Added optional highlight for (un)walkable tiles - Fixed lightmanager to draw in the correct color - Fixed TMapBlock and TStaticBlock to correctly initialize itself as "unchanged" - Cleanup in the server project
2009-12-24 15:49:15 +01:00
glColor4f(intensity * red, intensity * green, intensity * blue, 1.0);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
highlight := blockInfo^.Highlighted and item.CanBeEdited;
if highlight then
begin
glEnable(GL_COLOR_LOGIC_OP);
glLogicOp(GL_COPY_INVERTED);
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if blockInfo^.HighRes <> nil then
begin
glBindTexture(GL_TEXTURE_2D, blockInfo^.HighRes.Texture);
if not highlight and (blockInfo^.WalkRestriction = wrNone) then
glEnable(GL_LIGHTING);
glBegin(GL_QUADS);
glNormal3fv(@blockInfo^.Normals^[0]);
glTexCoord2i(0, 0); glVertex2iv(@blockInfo^.DrawQuad[0]);
glNormal3fv(@blockInfo^.Normals^[3]);
glTexCoord2i(0, 1); glVertex2iv(@blockInfo^.DrawQuad[3]);
glNormal3fv(@blockInfo^.Normals^[2]);
glTexCoord2i(1, 1); glVertex2iv(@blockInfo^.DrawQuad[2]);
glNormal3fv(@blockInfo^.Normals^[1]);
glTexCoord2i(1, 0); glVertex2iv(@blockInfo^.DrawQuad[1]);
glEnd;
if not highlight and (blockInfo^.WalkRestriction = wrNone) then
glDisable(GL_LIGHTING);
end else
begin
glBindTexture(GL_TEXTURE_2D, blockInfo^.LowRes.Texture);
glBegin(GL_QUADS);
glTexCoord2i(0, 0); glVertex2iv(@blockInfo^.DrawQuad[0]);
glTexCoord2i(1, 0); glVertex2iv(@blockInfo^.DrawQuad[1]);
glTexCoord2i(1, 1); glVertex2iv(@blockInfo^.DrawQuad[2]);
glTexCoord2i(0, 1); glVertex2iv(@blockInfo^.DrawQuad[3]);
glEnd;
end;
if highlight then
glDisable(GL_COLOR_LOGIC_OP);
if (blockInfo^.Text <> nil) then
blockInfo^.Text.Render(blockInfo^.ScreenRect);
/////////////////
// Рендинг сетки рельефа
if (mnuShowGrid.Checked) and (blockInfo^.Item is TMapCell) then
begin
glDisable(GL_TEXTURE_2D); // не использовать цвет текстуры
glEnable(GL_LINE_SMOOTH); // сглаживание линий
//glDisable(GL_LINE_SMOOTH);
if (tbFlat.Down) then
begin
glColor4f(0.8, 0.8, 0.8, 0.9); // цвет линий
glLineWidth(0.1); // ширина линий
glBegin(GL_LINES);
glVertex2iv(@blockInfo^.LineDraw[0][0]);
glVertex2iv(@blockInfo^.LineDraw[0][1]);
glVertex2iv(@blockInfo^.LineDraw[1][0]);
glVertex2iv(@blockInfo^.LineDraw[1][1]);
glEnd;
end else
begin
if blockInfo^.LineWidth[0] < 0.85
then glColor4f(1.0, 1.0, 0.0, 0.5) // цвет линий
else glColor4f(1.0, 1.0, 1.0, 1.0); // цвет линий
glLineWidth(blockInfo^.LineWidth[0]); // ширина линий
glBegin(GL_LINES);
glVertex2iv(@blockInfo^.LineDraw[0][0]);
glVertex2iv(@blockInfo^.LineDraw[0][1]);
glEnd;
if blockInfo^.LineWidth[1] < 0.85
then glColor4f(1.0, 1.0, 0.0, 0.5) // цвет линий
else glColor4f(1.0, 1.0, 1.0, 1.0); // цвет линий
glLineWidth(blockInfo^.LineWidth[1]); // ширина линий
glBegin(GL_LINES);
glVertex2iv(@blockInfo^.LineDraw[1][0]);
glVertex2iv(@blockInfo^.LineDraw[1][1]);
glEnd;
if blockInfo^.LineWidth[2] > 0 then
begin
glColor4f(1.3281, 0.2510, 1.0, 0.8); // цвет линий
glLineWidth(blockInfo^.LineWidth[2]);// ширина линий
glBegin(GL_LINES);
glVertex2iv(@blockInfo^.LineDraw[2][0]);
glVertex2iv(@blockInfo^.LineDraw[2][1]);
glEnd;
end;
end;
glDisable(GL_LINE_SMOOTH);
glEnable(GL_TEXTURE_2D);
end else if (mnuShowBlocks.Checked) and (blockInfo^.Item is TMapCell) then
begin // Рендинг сетки блоков
glDisable(GL_TEXTURE_2D); // не использовать цвет текстуры
glEnable(GL_LINE_SMOOTH); // сглаживание линий
if (blockInfo^.Item.X mod 8 = 0) then begin
glLineWidth(2.0);
glColor4f(1.0, 1.0, 0.0, 0.5);
end else begin
glColor4f(0.8, 0.8, 0.8, 0.9);
glLineWidth(0.1);
end;
glBegin(GL_LINES);
glVertex2iv(@blockInfo^.LineDraw[1][0]);
glVertex2iv(@blockInfo^.LineDraw[1][1]);
glEnd;
if (blockInfo^.Item.Y mod 8 = 0) then begin
glLineWidth(2.0);
glColor4f(1.0, 1.0, 0.0, 0.5);
end else begin
glColor4f(0.8, 0.8, 0.8, 0.9);
glLineWidth(0.1);
end;
glBegin(GL_LINES);
glVertex2iv(@blockInfo^.LineDraw[0][0]);
glVertex2iv(@blockInfo^.LineDraw[0][1]);
glEnd;
glDisable(GL_LINE_SMOOTH);
glEnable(GL_TEXTURE_2D);
end else if (frmVirtualLayer.cbShowBlocks.Checked) and (blockInfo^.Item is TVirtualTile) then
begin
glDisable(GL_TEXTURE_2D); // не использовать цвет текстуры
glEnable(GL_LINE_SMOOTH); // сглаживание линий
for i := 0 to 1 do if blockInfo^.LineWidth[i] > 0 then begin
glColor4f(0.0, 0.65, 0.68, 0.50); // цвет линий
glLineWidth(blockInfo^.LineWidth[i]); // ширина линий
glBegin(GL_LINES);
glVertex2iv(@blockInfo^.LineDraw[i][0]);
glVertex2iv(@blockInfo^.LineDraw[i][1]);
glEnd;
end;
glDisable(GL_LINE_SMOOTH);
glEnable(GL_TEXTURE_2D);
end;
////////////////
end;
if (FLightManager.LightLevel > 0) and not acFlat.Checked then
FLightManager.Draw(oglGameWindow.ClientRect, zoom);
FOverlayUI.Draw(oglGameWindow);
FLandscape.ResizeBlockCache(0);
end;
procedure TfrmMain.SaveLocations;
var
xmlDoc: TXMLDocument;
location: TDOMElement;
locationNode: PVirtualNode;
locationInfo: PLocationInfo;
begin
xmlDoc := TXMLDocument.Create;
xmlDoc.AppendChild(xmlDoc.CreateElement('Locations'));
locationNode := vstLocations.GetFirst;
while locationNode <> nil do
begin
locationInfo := vstLocations.GetNodeData(locationNode);
location := xmlDoc.CreateElement('Location');
location.AttribStrings['Name'] := UTF8ToCP1251(locationInfo^.Name);
location.AttribStrings['X'] := IntToStr(locationInfo^.X);
location.AttribStrings['Y'] := IntToStr(locationInfo^.Y);
xmlDoc.DocumentElement.AppendChild(location);
locationNode := vstLocations.GetNext(locationNode);
end;
WriteXMLFile(xmlDoc, FLocationsFile);
xmlDoc.Free;
end;
procedure TfrmMain.SaveRandomPresets;
begin
WriteXMLFile(FRandomPresetsDoc, FRandomPresetsFile);
end;
procedure TfrmMain.OnLandscapeChanged;
begin
InvalidateScreenBuffer;
oglGameWindow.Repaint;
UpdateCurrentTile;
end;
procedure TfrmMain.OnMapChanged(AMapCell: TMapCell);
begin
PrepareMapCell(AMapCell);
ForceUpdateCurrentTile;
InvalidateFilter
end;
procedure TfrmMain.OnNewBlock(ABlock: TBlock);
begin
InvalidateScreenBuffer;
end;
procedure TfrmMain.OnStaticDeleted(AStaticItem: TStaticItem);
begin
FScreenBuffer.Delete(AStaticItem);
FRepaintNeeded := True;
ForceUpdateCurrentTile;
InvalidateFilter
end;
procedure TfrmMain.OnStaticElevated(AStaticItem: TStaticItem);
var
blockInfo: PBlockInfo;
begin
AStaticItem.PrioritySolver := FScreenBuffer.GetSerial;
blockInfo := FScreenBuffer.UpdateSortOrder(AStaticItem);
if blockInfo <> nil then
begin
PrepareScreenBlock(blockInfo);
Exclude(FScreenBufferState, sbsIndexed);
ForceUpdateCurrentTile;
InvalidateFilter
end;
end;
procedure TfrmMain.OnStaticHued(AStaticItem: TStaticItem);
var
blockInfo: PBlockInfo;
begin
blockInfo := nil;
while FScreenBuffer.Iterate(blockInfo) do
begin
if blockInfo^.Item = AStaticItem then
begin
PrepareScreenBlock(blockInfo);
FRepaintNeeded := True;
ForceUpdateCurrentTile;
Break;
end;
end;
end;
procedure TfrmMain.OnStaticInserted(AStaticItem: TStaticItem);
begin
if (AStaticItem.X >= FX + FLowOffsetX) and
(AStaticItem.X <= FX + FHighOffsetX) and
(AStaticItem.Y >= FY + FLowOffsetY) and
(AStaticItem.Y <= FY + FHighOffsetY) then
begin
AStaticItem.PrioritySolver := FScreenBuffer.GetSerial;
PrepareScreenBlock(FScreenBuffer.Insert(AStaticItem));
FRepaintNeeded := True;
ForceUpdateCurrentTile;
InvalidateFilter
end;
end;
function TfrmMain.LoadListError(condition: Boolean; filename, message : string): Boolean; inline;
var
answer: Word;
l, c: Word;
begin
result := False;
if not condition
then Exit;
l := Length(filename);
for c := l downto 1 do
if (filename[c] = '\') or (filename[c] = '/')
then break;
if c > 1 then inc(c);
answer := MessageDlg(Format(GetParseErText('MessageDlgCaption'), [Copy(filename, c, l-c+1)]),
Format(GetParseErText('MessageDlgTxtLine1')+sLineBreak+
GetParseErText('MessageDlgTxtLine2')+sLineBreak+sLineBreak+
GetParseErText('MessageDlgTxtLine3'),
[message, filename]), mtError, [mbAbort, mbRetry, mbIgnore], 0);
if answer = mrAbort
then begin
Application.Terminate;
Halt;
end;
result := (answer = mrRetry);
end;
procedure TfrmMain.LoadVisibleTiles(AFileName: String);
var
XMLDoc: TXMLDocument;
iNode, node: TDOMNode;
s: string;
i, id: Integer;
begin
frmInitialize.SetStatusLabel(Format(frmInitialize.SplashLoading, ['VirtualTiles.xml']));
FVisibleTiles := TBits.Create($4000 + FLandscape.MaxStaticID);
for i := 0 to FVisibleTiles.Size - 1 do
FVisibleTiles[i] := True;
// Читаем xml файл с жесткого диска
ReadXMLFile(XMLDoc, AFileName);
if LowerCase(XMLDoc.DocumentElement.NodeName) = 'virtualtiles' then
begin
iNode := XMLDoc.DocumentElement.FirstChild;
while iNode <> nil do
begin
if LowerCase(iNode.NodeName) = 'unused' then
begin
node := iNode.FirstChild;
while node <> nil do
begin
s := LowerCase(node.NodeName);
if (s = 'tile') or (s = 'land') or (s = 'item') then
for i := node.Attributes.Length - 1 downto 0 do
if LowerCase(node.Attributes[i].NodeName) = 'id' then
if TryStrToInt(node.Attributes[i].NodeValue, id) then
begin
if s = 'item'
then Inc(id, $4000);
if (id >= 0) and (id < FVisibleTiles.Size)
then FVisibleTiles[id] := False;
end;
node := node.NextSibling;
end;
end;
iNode := iNode.NextSibling;
end;
end;
end;
procedure TfrmMain.LoadLightSourceTiles(AFileName: String);
var
XMLDoc: TXMLDocument;
iNode, node: TDOMNode;
s: string;
i, id, bit: Integer;
begin
frmInitialize.SetStatusLabel(Format(frmInitialize.SplashLoading, ['VirtualTiles.xml']));
if (FLightSourceTiles = nil) then begin
getmem(FLightSourceTiles, (FLandscape.MaxStaticID + 1) * SizeOf(TLightTile));
for i := 0 to FLandscape.MaxStaticID - 1 do
FillByte(FLightSourceTiles[i], SizeOf(TLightTile), 0);
end;
// Читаем xml файл с жесткого диска
ReadXMLFile(XMLDoc, AFileName);
if LowerCase(XMLDoc.DocumentElement.NodeName) = 'virtualtiles' then
begin
iNode := XMLDoc.DocumentElement.FirstChild;
while iNode <> nil do
begin
if LowerCase(iNode.NodeName) = 'lightsource' then
begin
node := iNode.FirstChild;
while node <> nil do
begin
s := LowerCase(node.NodeName);
if (s = 'tile') or (s = 'item') then begin
id :=-1;
bit := 1;
for i := node.Attributes.Length - 1 downto 0 do
begin
if LowerCase(node.Attributes[i].NodeName) = 'id' then
if TryStrToInt(node.Attributes[i].NodeValue, id) then
begin
if s = 'tile'
then Inc(id, -$4000);
//if (id >= 0) and (id < FLightSourceTiles.Size)
// then FLightSourceTiles[id] := True;
end;
if LowerCase(node.Attributes[i].NodeName) = 'icon' then
if TryStrToInt(node.Attributes[i].NodeValue, bit) then
if (bit < 1) or (bit > FVLightSrcImageCount) then
bit := 1;
end;
if (id >= 0) and (id <= FLandscape.MaxStaticID) then
begin
FLightSourceTiles[id].image := bit;
end;
end;
node := node.NextSibling;
end;
end;
iNode := iNode.NextSibling;
end;
end;
end;
procedure TfrmMain.LoadSurfsTilesList;
begin
frmInitialize.SetStatusLabel(Format(frmInitialize.SplashLoading, ['SurfaceInf.xml']));
end;
{
procedure TfrmMain.LoadSurfsTilesList;
var
fPath, str, attribute : string;
XMLDoc: TXMLDocument;
cNode, sNode, eNode : TDOMNode;
c, s, e, a : Integer;
tCount: Integer;
tHash1: ^DWORD;
tHash2: ^DWORD;
tIndex: ^LongWord;
value : Integer;
//e, t, a, value : Integer;
// cCount : Word;
sCount : ^Word;
eCount : ^PWord;
begin
if FileExists(FProfileDir + 'SurfaceInf.xml')
then fPath := (FProfileDir + 'SurfaceInf.xml')
else if FileExists(FLocalDir + 'SurfaceInf.xml')
then fPath := (FLocalDir + 'SurfaceInf.xml')
else if FileExists(FConfigDir + 'SurfaceInf.xml')
then fPath := (FConfigDir + 'SurfaceInf.xml')
else if FileExists(ResMan.GetFile('SurfaceInf.xml'))
then fPath := (ResMan.GetFile('SurfaceInf.xml'))
else Exit;
// Читаем xml файл с жесткого диска
ReadXMLFile(XMLDoc, fPath);
if LowerCase(XMLDoc.DocumentElement.NodeName) = 'surfaceinf' then
begin
// Подсчет категорий
FSurfsList.GroupCount := 0;
cNode := XMLDoc.DocumentElement.FirstChild;
while cNode <> nil do
begin
if LowerCase(cNode.NodeName) = 'category' then
inc(FSurfsList.GroupCount);
cNode := cNode.NextSibling;
end;
getmem(sCount, FSurfsList.GroupCount * SizeOf( Word));
getmem(eCount, FSurfsList.GroupCount * SizeOf(PWord));
// Подсчет объектов
cNode := XMLDoc.DocumentElement.FirstChild;
while cNode <> nil do
begin
if LowerCase(cNode.NodeName) = 'category' then
begin
sNode := cNode.FirstChild;
while sNode <> nil do
begin
sNode := sNode.NextSibling;
end;
end;
cNode := cNode.NextSibling;
end;
////////////////////////////////////////////////////////////////////////////
// Создание списка
FSurfsList.TilesCount := $4000 + FLandscape.MaxStaticID;
getmem(FSurfsList.Tiles, FSurfsList.TilesCount * SizeOf(PSurfGrad));
getmem(FSurfsList.Grads, FSurfsList.GradsCount * SizeOf(TSurfGrad));
getmem(FSurfsList.Group, FSurfsList.GroupCount * SizeOf(TSurfGroup));
tCount := 0;
c := 0; // -------------- 1
cNode := XMLDoc.DocumentElement.FirstChild;
while cNode <> nil do
begin
if LowerCase(cNode.NodeName) = 'category' then begin
FSurfsList.Group[c].Name := 'NoName';
for a := cNode.Attributes.Length - 1 downto 0 do begin
if LowerCase(cNode.Attributes[a].NodeName) = 'name' then
FSurfsList.Group[c].Name := CP1251ToUTF8(cNode.Attributes[a].NodeValue);
end;
// ?????? FSurfsList.Group[c].Count
getmem(FSurfsList.Group[c].Info, FSurfsList.Group[c].Count * SizeOf(TSurfGroup));
s := 0; // -------------- 2
sNode := cNode.FirstChild;
while sNode <> nil do
begin
if LowerCase(sNode.NodeName) = 'surafece' then begin
FSurfsList.Group[c].Info[s].Name := 'NoName';
FSurfsList.Group[c].Info[s].TileID := $4001;
for a := sNode.Attributes.Length - 1 downto 0 do begin
if LowerCase(sNode.Attributes[a].NodeName) = 'name' then
FSurfsList.Group[c].Info[s].Name := CP1251ToUTF8(sNode.Attributes[a].NodeValue);
if LowerCase(sNode.Attributes[a].NodeName) = 'tileid' then
if TryStrToInt(sNode.Attributes[a].NodeValue, value) then
FSurfsList.Group[c].Info[s].TileID := value;
end;
CalcStringCRC32(LowerCase(FSurfsList.Group[c].Info[s].Name),
FSurfsList.Group[c].Info[s].TileHash);
// ?????? FSurfsList.Group[c].Info[s].GradCount
getmem(FSurfsList.Group[c].Info[s].GradHash, FSurfsList.Group[c].Info[s].GradCount * SizeOf(LongWord));
e := 0; // -------------- 3
eNode := sNode.FirstChild;
while eNode <> nil do
begin
str := LowerCase(eNode.NodeName);
if (str = 'item') or (str = 'land') or (str = 'tile') then begin
str := 'NoType';
for a := eNode.Attributes.Length - 1 downto 0 do begin
if LowerCase(sNode.Attributes[a].NodeName) = 'type' then
str := CP1251ToUTF8(eNode.Attributes[a].NodeValue);
end;
CalcStringCRC32(LowerCase(FSurfsList.Group[c].Name + '|' + str),
FSurfsList.Group[c].Info[s].GradHash[e]);
inc(tCount);
end else if str = 'brush' then begin
// TODO
end;
inc(e);
eNode := eNode.NextSibling;
end; // -------------- 3
end;
inc(s);
sNode := sNode.NextSibling;
end; // -------------- 2
end;
inc(c);
cNode := cNode.NextSibling;
end; // -------------- 1
////////////////////////////////////////////////////////////////////////////
// Построение списка TSurfGrad
getmem(tHash, tCount * SizeOf(DWORD));
tCount := 0;
for c := 0 to FSurfsList.GroupCount do
for s := 0 to FSurfsList.Group[c].Count do
for e := 0 to FSurfsList.Group[c].Info[s].GradCount do
begin
for a := tCount-1 downto -1 do
if a < 0 then begin
tHash[tCount] = FSurfsList.Group[c].Info[s].GradHash[e];
inc(tCount);
end else if tHash[a] = FSurfsList.Group[c].Info[s].GradHash[e]
then break;
end;
FSurfsList.GradsCount := tCount;
getmem(FSurfsList.Grads, FSurfsList.GradsCount * SizeOf(TSurfGrad));
freemem(gHash);
getmem(sCount, FSurfsList.GroupCount * SizeOf( Word));
getmem(eCount, FSurfsList.GroupCount * SizeOf(PWord));
// Подсчет объектов
cNode := XMLDoc.DocumentElement.FirstChild;
while cNode <> nil do
begin
if LowerCase(cNode.NodeName) = 'category' then
begin
sNode := cNode.FirstChild;
while sNode <> nil do
begin
sNode := sNode.NextSibling;
end;
end;
cNode := cNode.NextSibling;
end;
end;
end;
}
procedure TfrmMain.LoadEntryTilesList;
var
fPath, s, attribute : string;
XMLDoc: TXMLDocument;
eNode, tNode : TDOMNode;
e, t, a, value : Integer;
// Создание миниатюр
id : Integer;
hue : Word;
alt : integer;
artHue : THue;
artEntry : TArt;
dSize: TSize;
entHash: QWORD;
Resised: Float;
tCRC32, CacheLen: DWORD;
cacheHash, cachePost: PDWORD;
imageData: TImageData;
imageCache: TFileStream;
imageTemp: TSingleImage;
dX, dY, dZ, dW, dH : Integer;
entStack, entFirst, entLast, entPrev, entNext: PByte;
dstCanvas: TFastARGB32Canvas;
srcCanvas: TFastARGB32Canvas;
begin
frmInitialize.SetStatusLabel(Format(frmInitialize.SplashLoading, ['TilesEntry.xml']));
if FileExists(FProfileDir + 'TilesEntry.xml')
then fPath := (FProfileDir + 'TilesEntry.xml')
else if FileExists(FLocalDir + 'TilesEntry.xml')
then fPath := (FLocalDir + 'TilesEntry.xml')
else if FileExists(FConfigDir + 'TilesEntry.xml')
then fPath := (FConfigDir + 'TilesEntry.xml')
else if FileExists(ResMan.GetFile('TilesEntry.xml'))
then fPath := (ResMan.GetFile('TilesEntry.xml'))
else Exit;
FEntryList.Count := 0;
// Читаем xml файл с жесткого диска
ReadXMLFile(XMLDoc, fPath);
if LowerCase(XMLDoc.DocumentElement.NodeName) = 'tilesentry' then
begin
// Подсчет объектов
eNode := XMLDoc.DocumentElement.FirstChild;
while eNode <> nil do
begin
if LowerCase(eNode.NodeName) = 'entry' then
inc(FEntryList.Count);
eNode := eNode.NextSibling;
end;
getmem(FEntryList.Entry, FEntryList.Count * SizeOf(PGroupEntry));
// Построение списка
eNode := XMLDoc.DocumentElement.FirstChild;
for e := 0 to FEntryList.Count - 1 do begin
//Logger.Send([lcInfo], 'Entry: %d / %d - Start...', [e, FEntryList.Count]);
new (FEntryList.Entry[e]);
FEntryList.Entry[e]^.Name := 'NoName';
for a := eNode.Attributes.Length - 1 downto 0 do begin
if LowerCase(eNode.Attributes[a].NodeName) = 'id' then
if TryStrToInt(eNode.Attributes[a].NodeValue, value) then
FEntryList.Entry[e]^.ID := value;
if LowerCase(eNode.Attributes[a].NodeName) = 'name' then
FEntryList.Entry[e]^.Name := CP1251ToUTF8(eNode.Attributes[a].NodeValue);
end;
// Подсчет тайлов
tNode := eNode.FirstChild;
FEntryList.Entry[e]^.Count := 0;
while tNode <> nil do begin
s := LowerCase(tNode.NodeName);
if (s = 'tile') or (s = 'item') or (s = 'land') then
inc(FEntryList.Entry[e]^.Count);
tNode := tNode.NextSibling;
end;
getmem(FEntryList.Entry[e]^.ETile, FEntryList.Entry[e]^.Count * SizeOf(TEntryTile));
// Чтение списка тайлов
tNode := eNode.FirstChild;
for t := 0 to FEntryList.Entry[e]^.Count - 1 do
begin
//Logger.Send([lcInfo], 'Entry: %d - Item: %d / %d', [e, t, FEntryList.Entry[e]^.Count]);
FEntryList.Entry[e]^.ETile[t].ID := 0;
FEntryList.Entry[e]^.ETile[t].Hue := 0;
FEntryList.Entry[e]^.ETile[t].X := 0;
FEntryList.Entry[e]^.ETile[t].Y := 0;
FEntryList.Entry[e]^.ETile[t].Z := 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 begin
if s = 'item' then Inc(value, $4000);
FEntryList.Entry[e]^.ETile[t].ID := value;
end;
end else if attribute = 'hue' then begin
if TryStrToInt(tNode.Attributes[a].NodeValue, value)
then FEntryList.Entry[e]^.ETile[t].Hue := value;
end else if attribute = 'x' then begin
if TryStrToInt(tNode.Attributes[a].NodeValue, value)
then FEntryList.Entry[e]^.ETile[t].X := value;
end else if attribute = 'y' then begin
if TryStrToInt(tNode.Attributes[a].NodeValue, value)
then FEntryList.Entry[e]^.ETile[t].Y := value;
end else if attribute = 'z' then begin
if TryStrToInt(tNode.Attributes[a].NodeValue, value)
then FEntryList.Entry[e]^.ETile[t].Z := value;
end;
end;
while (tNode <> nil) do begin
tNode := tNode.NextSibling;
if tNode <> nil then begin
s := LowerCase(tNode.NodeName);
if (s = 'tile') or (s = 'item') or (s = 'land')
then break;
end;
end;
end;
while (eNode <> nil) do begin
eNode := eNode.NextSibling;
if (eNode <> nil) and (LowerCase(eNode.NodeName) = 'entry')
then break;
end;
end;
end;
XMLDoc.Free;
Logger.Send([lcInfo], 'TfrmMain.LoadEntryTilesList SizeOf(TImageFormat)', SizeOf(TImageFormat));
// Создание миниатюр
if (FProfileDir <> '')
then fPath := FProfileDir
else fPath := FConfigDir;
fPath := fPath + 'TilesEntry.cache';
if not FileExists(fPath)
then FileClose(FileCreate(fPath));
imageCache := TFileStream.Create(fPath, fmOpenReadWrite);
if (imageCache.Size < 4) then begin
value := 0;
cacheHash := nil;
cachePost := nil;
imageCache.WriteDWord(value);
end else begin
value := imageCache.ReadDWord;
getmem(cacheHash, 4 * value);
getmem(cachePost, 4 * value);
end;
t := 0;
CacheLen := value;
while (t < value) do begin
cacheHash[t] := imageCache.ReadDWord;
cachePost[t] := imageCache.Position;
imageCache.Position := imageCache.Position + 12;
e := imageCache.ReadDWord;
imageCache.Position := imageCache.Position + e;
inc(t);
end;
for e := 0 to FEntryList.Count - 1 do begin
s := Format('e:%d|n:%s|', [FEntryList.Entry[e]^.ID, FEntryList.Entry[e]^.Name]);
for t := 0 to FEntryList.Entry[e]^.Count - 1 do
s := s + Format('i:%d|h:%d|x:%d|y:%d|z:%d|', [FEntryList.Entry[e]^.ETile[t].ID, FEntryList.Entry[e]^.ETile[t].Hue,
FEntryList.Entry[e]^.ETile[t].X, FEntryList.Entry[e]^.ETile[t].Y, FEntryList.Entry[e]^.ETile[t].Z]);
CalcStringCRC32(s, tCRC32);
FEntryList.Entry[e]^.Image := nil;
// Чтение изображения из кэша
for t := 0 to value - 1 do
if (cacheHash[t] = tCRC32) then begin
imageCache.Position := cachePost[t];
imageCache.Read(imageData, 16);
getmem(imageData.Bits, imageData.Size);
imageCache.Read(PByte(imageData.Bits)^, imageData.Size);
imageData.Palette := nil;
FEntryList.Entry[e]^.Image := TSingleImage.CreateFromData(imageData);
freemem(imageData.Bits);
//Logger.Send([lcInfo], 'TfrmMain.LoadEntryTilesList entry %d Loaded from Cache', [FEntryList.Entry[e]^.ID]);
//FEntryList.Entry[e]^.Image.Format := ifA1R5G5B5;
Break;
end;
if (FEntryList.Entry[e]^.Image <> nil)
then Continue;
// Сортировка тайлов для отрисовки
dW := 0;
dH := 0;
alt:= 0;
getmem(entStack, FEntryList.Entry[e]^.Count * 12);
FillByte(entStack^, FEntryList.Entry[e]^.Count * 12, 0);
entFirst := entStack;
entLast := entStack;
for t := 0 to FEntryList.Entry[e]^.Count - 1 do begin
dSize := ResMan.Art.GetArtSize(FEntryList.Entry[e]^.ETile[t].ID);
dX := 44 * (FEntryList.Entry[e]^.ETile[t].X - FEntryList.Entry[e]^.ETile[t].Y);
dY := -22 * (FEntryList.Entry[e]^.ETile[t].X + FEntryList.Entry[e]^.ETile[t].Y) + 4 * FEntryList.Entry[e]^.ETile[t].Z;
if (dY >= 0) then begin
dH := max(dH, alt + dY + dSize.cy);
end else begin
a := alt;
alt:= max(alt, Abs(dY));
dH := alt + max(dH - a, max(0, dSize.cy + dY));
end;
dW := max(dW, Abs(dX) + dSize.cx);
dX := min(max(0, FEntryList.Entry[e]^.ETile[t].X + 1023), 2047);
dY := min(max(0, FEntryList.Entry[e]^.ETile[t].Y + 1023), 2047);
dZ := min(max(0, FEntryList.Entry[e]^.ETile[t].Z + 255), 513);
entHash := DWORD(dX) * 1064440 + DWORD(dY) * 520 + DWORD(dZ + 7);
if (tdfFoliage in ResMan.Tiledata.TileData[FEntryList.Entry[e]^.ETile[t].ID].Flags)
then Inc(entHash, +1);
PDWord(entLast)^ := entHash;
PDWord(entLast + 4)^ := DWord(t);
if (entLast = entStack) then begin
inc(entLast, 12);
end else begin
entNext := entFirst;
entPrev := nil;
while True do begin
if (entNext = nil) then begin
PDWord(entPrev + 8)^ := PtrInt(entLast);
inc(entLast, 12);
Break;
end else if (PDWord(entNext)^ >= entHash) then begin
if (entPrev <> nil) then begin
PDWord(entPrev + 8)^ := PtrInt(entLast);
end else begin
entFirst := entLast;
end;
PDWord(entLast + 8)^ := PtrInt(entNext);
inc(entLast, 12);
Break;
end;
entPrev := entNext;
entNext := PByte(PDWord(entNext + 8)^);
end;
end;
end;
// Отрисовка изображения миниатюры
//Logger.Send([lcInfo], 'TfrmMain.LoadEntryTilesList %d dW: %d dH: %d', [FEntryList.Entry[e]^.ID, dW, dH]);
FEntryList.Entry[e]^.Image := TSingleImage.CreateFromParams(dW, dH, ifA8R8G8B8);
dstCanvas := TFastARGB32Canvas.CreateForImage(FEntryList.Entry[e]^.Image);
dstCanvas.FillColor32 := $00404040;
dstCanvas.FillRect(Rect(0,0,FEntryList.Entry[e]^.Image.Width,FEntryList.Entry[e]^.Image.Height));
entNext := entFirst;
while (entNext <> nil) do begin
//if ((FEntryList.Entry[e]^.ID < 9120) and (FEntryList.Entry[e]^.ID > 9025))
//then break;
t := PDWord(entNext + 4)^;
//Logger.Send([lcInfo], 'TfrmMain.LoadEntryTilesList t: %d [%d/%d]', [t, alt, FEntryList.Entry[e]^.Image.Height]);
entNext := PByte(PDWord(entNext + 8)^);
id := FEntryList.Entry[e]^.ETile[t].ID;
hue := FEntryList.Entry[e]^.ETile[t].Hue;
if ResMan.Art.Exists(id) then begin
if hue > 0
then artHue := ResMan.Hue.Hues[hue - 1]
else artHue := nil;
artEntry := ResMan.Art.GetArt(id, EncodeUOColor($0FF0F000), artHue, tdfPartialHue in TTileData(ResMan.Tiledata.Block[id]).Flags);
srcCanvas := TFastARGB32Canvas.CreateForImage(artEntry.Graphic);
dX := (FEntryList.Entry[e]^.Image.Width - artEntry.Graphic.Width) div 2 + 22 * (FEntryList.Entry[e]^.ETile[t].X - FEntryList.Entry[e]^.ETile[t].Y);
dY := FEntryList.Entry[e]^.Image.Height - artEntry.Graphic.Height - alt +
22 * (FEntryList.Entry[e]^.ETile[t].X + FEntryList.Entry[e]^.ETile[t].Y) - 4 * FEntryList.Entry[e]^.ETile[t].Z;
srcCanvas.DrawAlpha(Rect(0,0,artEntry.Graphic.Width,artEntry.Graphic.Height), dstCanvas, dX,dY);
srcCanvas.Free;
artEntry.Free;
end;
end;
// Уменьшение изоображения
dW := 93;
dH := 96;
dSize.cx := FEntryList.Entry[e]^.Image.Width;
dSize.cy := FEntryList.Entry[e]^.Image.Height;
Resised := Min(Min(Float(dW)/Float(dSize.cx), Float(dH)/Float(dSize.cy)), 1.0);
dSize.cx := Trunc(Resised * Float(dSize.cx));
dSize.cy := Trunc(Resised * Float(dSize.cy));
imageTemp := TSingleImage.CreateFromParams(dSize.cx, dSize.cy, ifA8R8G8B8);
srcCanvas := TFastARGB32Canvas.CreateForImage(imageTemp);
dstCanvas.StretchDrawAdd(Rect(0,0,FEntryList.Entry[e]^.Image.Width,FEntryList.Entry[e]^.Image.Height),
srcCanvas, Rect(0,0,dSize.cx,dSize.cy), rfNearest);//rfBilinear);
srcCanvas.Free;
dstCanvas.Free;
freemem(entStack);
FEntryList.Entry[e]^.Image.Free;
FEntryList.Entry[e]^.Image := imageTemp;
// Сохранение изоображение в кэше
imageCache.Position := imageCache.Size;
imageCache.WriteDWord(tCRC32);
imageData := FEntryList.Entry[e]^.Image.ImageDataPointer^;
imageCache.Write(imageData, 16);
imageCache.Write(imageData.Bits^, imageData.Size);
inc(CacheLen, +1);
//Logger.Send([lcInfo], 'TfrmMain.LoadEntryTilesList imageData.Palette <> nil', imageData.Palette <> nil);
//
Application.ProcessMessages;
end;
if (value > 0) then begin
freemem(cacheHash);
freemem(cachePost);
end;
imageCache.Position := 0;
imageCache.WriteDWord(CacheLen);
imageCache.Free;
{ // Отладка - проверка считанного файла
Logger.EnterMethod([lcInfo, lcDebug], 'TfrmMain.LoadEntryTilesList');
Logger.Send([lcInfo], 'Entries Number: %x', [FEntryList.Count]);
for e := 0 to FEntryList.Count - 1 do begin
Logger.Send([lcInfo], '<Entry Id="%.4d" Name="%s" Tiles="%x">',
[FEntryList.Entry[e]^.ID, FEntryList.Entry[e]^.Name, FEntryList.Entry[e]^.Count]);
for t := 0 to FEntryList.Entry[e]^.Count - 1 do
Logger.Send([lcInfo], ' <Tile Id="0x%.5x" Hue="0x%.3x" X="%d" Y="%d" Z="%d">',
[FEntryList.Entry[e]^.ETile[t].ID, FEntryList.Entry[e]^.ETile[t].Hue,
FEntryList.Entry[e]^.ETile[t].X, FEntryList.Entry[e]^.ETile[t].Y, FEntryList.Entry[e]^.ETile[t].Z]);
Logger.Send([lcInfo], '</Entry>');
end;
Logger.ExitMethod([lcInfo, lcDebug], 'TfrmMain.LoadEntryTilesList');
}
end;
procedure TfrmMain.LoadBrushTilesList;
var
fPath, s, attribute : string;
XMLDoc: TXMLDocument;
bNode, tNode, eNode : TDOMNode;
z, b, t, a, e, value: Integer;
uu, ur, ll, ul, dl, dr : Word;
valueF : Single;
tile: TBrushTile;
// Создание миниатюр
id : Integer;
destColor, hue : Word;
destRect: TRect;
texmEntry : TTexture;
dX, dY, dW, dH : Integer;
begin
frmInitialize.SetStatusLabel(Format(frmInitialize.SplashLoading, ['TilesBrush.xml']));
if FileExists(FProfileDir + 'TilesBrush.xml')
then fPath := (FProfileDir + 'TilesBrush.xml')
else if FileExists(FLocalDir + 'TilesBrush.xml')
then fPath := (FLocalDir + 'TilesBrush.xml')
else if FileExists(FConfigDir + 'TilesBrush.xml')
then fPath := (FConfigDir + 'TilesBrush.xml')
else if FileExists(ResMan.GetFile('TilesBrush.xml'))
then fPath := (ResMan.GetFile('TilesBrush.xml'))
else Exit;
FBrushList.Count := 0;
// Читаем xml файл с жесткого диска
ReadXMLFile(XMLDoc, fPath);
if LowerCase(XMLDoc.DocumentElement.NodeName) = 'tilesbrush' then
begin
// Подсчет объектов
bNode := XMLDoc.DocumentElement.FirstChild;
while bNode <> nil do
begin
if LowerCase(bNode.NodeName) = 'brush' then
inc(FBrushList.Count);
bNode := bNode.NextSibling;
end;
getmem(FBrushList.Brush, FBrushList.Count * SizeOf(PGroupBrush));
// Построение списка
bNode := XMLDoc.DocumentElement.FirstChild;
for b := 0 to FBrushList.Count - 1 do begin
//Logger.Send([lcInfo], 'Brush: %d / %d - Start...', [b+1, FBrushList.Count]);
new (FBrushList.Brush[b]);
FBrushList.Brush[b]^.ID := 0;
FBrushList.Brush[b]^.Name := 'NoName';
for a := bNode.Attributes.Length - 1 downto 0 do begin
if LowerCase(bNode.Attributes[a].NodeName) = 'id' then
if TryStrToInt(bNode.Attributes[a].NodeValue, value) then
FBrushList.Brush[b]^.ID := value;
if LowerCase(bNode.Attributes[a].NodeName) = 'name' then
FBrushList.Brush[b]^.Name := CP1251ToUTF8(bNode.Attributes[a].NodeValue);
end;
// Тестирование...
if LoadListError((FBrushList.Brush[b]^.ID = 0) or (FBrushList.Brush[b]^.ID > 9999),
fPath, Format(GetParseErText('blTagBrushAttrID'), [FBrushList.Brush[b]^.ID, FBrushList.Brush[b]^.Name]))
//'Missmatch or wrong <ID> attribute in BrushID: %.4d ("%s"). Brush ID must be larger 0 and less than 9999', [FBrushList.Brush[b]^.ID, FBrushList.Brush[b]^.Name]))
then begin LoadBrushTilesList; Exit; end;
if b > 0 then for z := b-1 downto 0 do begin
if LoadListError(FBrushList.Brush[z]^.ID = FBrushList.Brush[b]^.ID,
fPath, Format(GetParseErText('blTagBrushDuplicate'), [FBrushList.Brush[b]^.ID]))
then begin LoadBrushTilesList; Exit; end;
end;
// Подсчет тайлов и переходов
tNode := bNode.FirstChild;
FBrushList.Brush[b]^.Count := 0;
FBrushList.Brush[b]^.ECount := 0;
while tNode <> nil do begin
s := LowerCase(tNode.NodeName);
if (s = 'tile') or (s = 'land') then
inc(FBrushList.Brush[b]^.Count)
else if (s = 'edge') then
inc(FBrushList.Brush[b]^.ECount);
tNode := tNode.NextSibling;
end;
getmem(FBrushList.Brush[b]^.BTile, FBrushList.Brush[b]^.Count * SizeOf(PBrushTile));
getmem(FBrushList.Brush[b]^.EdgeId, FBrushList.Brush[b]^.ECount * SizeOf(PWord));
getmem(FBrushList.Brush[b]^.BEdges, FBrushList.Brush[b]^.ECount * SizeOf(PGroupBrushEdge));
// Тестирование...
if LoadListError(FBrushList.Brush[b]^.Count = 0,
fPath, Format(GetParseErText('blTagBrushEmpty'), [FBrushList.Brush[b]^.ID]))
then begin LoadBrushTilesList; Exit; end;
// Чтение списка тайлов
tNode := bNode.FirstChild;
t := 0; e := 0;
while tNode <> nil do
begin
s := LowerCase(tNode.NodeName);
if (s = 'tile') 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;
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;
end else if attribute = 'chance' then begin
if TryStrToFloat(tNode.Attributes[a].NodeValue, valueF)
then tile.Chance := valueF;
end;
end;
tile.Mask := $0F;
tile.Brush1 := FBrushList.Brush[b];
tile.Brush2 := FBrushList.Brush[b];
// Тестирование...
if LoadListError(tile.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]))
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]))
then begin LoadBrushTilesList; Exit; end;
FBrushList.Tiles[tile.ID] := tile;
FBrushList.Brush[b]^.BTile[t] := @FBrushList.Tiles[tile.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]);
//new (FBrushList.Brush[b]^.EdgeId[e]);
new (FBrushList.Brush[b]^.BEdges[e]);
FBrushList.Brush[b]^.BEdges[e]^.ID := 0;
for a := tNode.Attributes.Length - 1 downto 0 do begin
attribute := LowerCase(tNode.Attributes[a].NodeName);
if attribute = 'to' then begin
if TryStrToInt(tNode.Attributes[a].NodeValue, value)
then FBrushList.Brush[b]^.BEdges[e]^.ID := value;
end;
end;
// Тестирование...
if LoadListError((FBrushList.Brush[b]^.BEdges[e]^.ID = 0) or (FBrushList.Brush[b]^.BEdges[e]^.ID > 9999),
fPath, Format(GetParseErText('blTagEdgeAttrTo'), [FBrushList.Brush[b]^.ID]))
then begin LoadBrushTilesList; Exit; end;
// Подсчет тайлов в переходе
eNode := tNode.FirstChild;
FBrushList.Brush[b]^.BEdges[e]^.CountUU := 0;
FBrushList.Brush[b]^.BEdges[e]^.CountUR := 0;
FBrushList.Brush[b]^.BEdges[e]^.CountLL := 0;
FBrushList.Brush[b]^.BEdges[e]^.CountUL := 0;
FBrushList.Brush[b]^.BEdges[e]^.CountDL := 0;
FBrushList.Brush[b]^.BEdges[e]^.CountDR := 0;
while eNode <> nil do begin
s := LowerCase(eNode.NodeName);
if (s = 'tile') or (s = 'land') then begin
attribute := '';
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 inc(FBrushList.Brush[b]^.BEdges[e]^.CountUU)
else if s = 'ur' then inc(FBrushList.Brush[b]^.BEdges[e]^.CountUR)
else if s = 'll' then inc(FBrushList.Brush[b]^.BEdges[e]^.CountLL)
else if s = 'ul' then inc(FBrushList.Brush[b]^.BEdges[e]^.CountUL)
else if s = 'dl' then inc(FBrushList.Brush[b]^.BEdges[e]^.CountDL)
else if s = 'dr' then inc(FBrushList.Brush[b]^.BEdges[e]^.CountDR);
break;
end;
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]))
then begin LoadBrushTilesList; Exit; end;
end;
eNode := eNode.NextSibling;
end;
getmem(FBrushList.Brush[b]^.BEdges[e]^.BTileUU, FBrushList.Brush[b]^.BEdges[e]^.CountUU * SizeOf(PBrushTile));
getmem(FBrushList.Brush[b]^.BEdges[e]^.BTileUR, FBrushList.Brush[b]^.BEdges[e]^.CountUR * SizeOf(PBrushTile));
getmem(FBrushList.Brush[b]^.BEdges[e]^.BTileLL, FBrushList.Brush[b]^.BEdges[e]^.CountLL * SizeOf(PBrushTile));
getmem(FBrushList.Brush[b]^.BEdges[e]^.BTileUL, FBrushList.Brush[b]^.BEdges[e]^.CountUL * SizeOf(PBrushTile));
getmem(FBrushList.Brush[b]^.BEdges[e]^.BTileDL, FBrushList.Brush[b]^.BEdges[e]^.CountDL * SizeOf(PBrushTile));
getmem(FBrushList.Brush[b]^.BEdges[e]^.BTileDR, FBrushList.Brush[b]^.BEdges[e]^.CountDR * SizeOf(PBrushTile));
// Чтение списка тайлов в переходе
uu := 0; ur := 0; ll := 0; ul := 0; dl := 0; dr := 0;
eNode := tNode.FirstChild;
while eNode <> nil do begin
s := LowerCase(eNode.NodeName);
if (s = 'tile') 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;
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;
end else if attribute = 'id' then begin
if TryStrToInt(eNode.Attributes[a].NodeValue, value)
then tile.ID := value;
end else if attribute = 'chance' then begin
if TryStrToFloat(eNode.Attributes[a].NodeValue, valueF)
then tile.Chance := valueF;
end;
end;
// Тестирование...
if LoadListError(tile.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]))
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]))
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);
end;
FBrushList.Tiles[tile.ID].ID := FBrushList.Brush[b]^.BEdges[e]^.ID; // Временно запоминаем ID перехода (позже востанавливаем ID тайла)
end;
eNode := eNode.NextSibling;
end;
FBrushList.Brush[b]^.EdgeId[e] := @(FBrushList.Brush[b]^.BEdges[e]^.ID);
inc(e);
end;
tNode := tNode.NextSibling;
end;
bNode := bNode.NextSibling;
end;
end;
XMLDoc.Free;
// Задание вторичных кистей
for t := 0 to $3FFF do begin
if (FBrushList.Tiles[t].Brush1 <> nil) and (FBrushList.Tiles[t].Brush2 = nil)
then begin
for b := 0 to FBrushList.Count - 1 do
if FBrushList.Brush[b]^.ID = FBrushList.Tiles[t].ID then begin
FBrushList.Tiles[t].Brush2 := FBrushList.Brush[b];
break;
end;
// Тестирование...
if LoadListError((FBrushList.Tiles[t].Brush2 = nil),
fPath, Format(GetParseErText('blTagEdgeUnknown'), [FBrushList.Tiles[t].Brush1^.ID, FBrushList.Tiles[t].ID]))
then begin LoadBrushTilesList; Exit; end;
FBrushList.Tiles[t].ID := t;
end else if (FBrushList.Tiles[t].Brush1 = nil) and (FBrushList.Tiles[t].Brush2 = nil)
then begin // Пустые тайлы
FBrushList.Tiles[t].ID:= $FFFF;
FBrushList.Tiles[t].Mask:= $00;
end;
end;
// Тестирование...
// for t := 0 to $3FFF do
// if LoadListError((FBrushList.Tiles[t].Brush1 <> nil) and (FBrushList.Tiles[t].Brush2 = nil),
// fPath, Format(GetParseErText('blTagTile2Redeclaration'), [FBrushList.Brush[b]^.ID]))
// then begin LoadBrushTilesList; Exit; end;
// Создание миниатюр
for b := 0 to FBrushList.Count - 1 do begin
//FBrushList.Brush[b]^.Image := TTexture(ResMan.Texmaps.Block[t]).Graphic;
FBrushList.Brush[b]^.Image := TSingleImage.CreateFromParams(96, 96, ifA1R5G5B5);
//FBrushList.Brush[b]^.Image.Bits .Canvas.Brush.Color := $00FF9000;//DecodeUOColor(destColor);
//FBrushList.Brush[b]^.Image.Canvas.Clear;
//if FBrushList.Brush[b]^.Image.FormatInfo.BytesPerPixel = 2
// then FillWord(FBrushList.Brush[b]^.Image.Bits^,
// FBrushList.Brush[b]^.Image.Width * FBrushList.Brush[b]^.Image.Height,
// $0000)
// else FillDWord(FBrushList.Brush[b]^.Image.Bits^,
// FBrushList.Brush[b]^.Image.Width * FBrushList.Brush[b]^.Image.Height,
// $00000000);
t := ResMan.Tiledata.LandTiles[FBrushList.Brush[b]^.BTile[0]^.ID].TextureID;
texmEntry := TTexture(ResMan.Texmaps.Block[t]);
//texmEntry.Graphic.CopyTo(0, 0, texmEntry.Graphic.Width, texmEntry.Graphic.Height,
// FBrushList.Brush[b]^.Image, 0, 0);
texmEntry.Graphic.StretchTo(0, 0, texmEntry.Graphic.Width, texmEntry.Graphic.Height,
FBrushList.Brush[b]^.Image, 2, 2,
FBrushList.Brush[b]^.Image.Width-4, FBrushList.Brush[b]^.Image.Height-4,
rfNearest);
texmEntry.Free;
end;
{ // Отладка - проверка считанного файла
Logger.EnterMethod([lcInfo, lcDebug], 'TfrmMain.LoadBrushTilesList');
Logger.Send([lcInfo], 'Brushes Number: %x', [FBrushList.Count]);
for b := 0 to FBrushList.Count - 1 do begin
Logger.Send([lcInfo], '<Brush Id="%.4d" Name="%s" Tiles="%d" Edges="%d">',
[FBrushList.Brush[b]^.ID, FBrushList.Brush[b]^.Name, FBrushList.Brush[b]^.Count, FBrushList.Brush[b]^.ECount]);
for t := 0 to FBrushList.Brush[b]^.Count - 1 do
Logger.Send([lcInfo], ' <Land Id="0x%.4x" Chance="%.2f" Mask="0x%.2x">',
[FBrushList.Brush[b]^.BTile[t]^.ID, FBrushList.Brush[b]^.BTile[t]^.Chance, FBrushList.Brush[b]^.BTile[t]^.Mask]);
for e := 0 to FBrushList.Brush[b]^.ECount - 1 do begin
Logger.Send([lcInfo], ' <Edge To="%d" Tiles="%d">',
[FBrushList.Brush[b]^.EdgeId[e]^, 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]);
for t := 0 to FBrushList.Brush[b]^.BEdges[e]^.CountUU - 1 do
Logger.Send([lcInfo], ' <Land Id="0x%.4x" Chance="%.2f" Mask="0x%.2x">',
[FBrushList.Brush[b]^.BEdges[e]^.BTileUU[t]^.ID, FBrushList.Brush[b]^.BEdges[e]^.BTileUU[t]^.Chance, FBrushList.Brush[b]^.BEdges[e]^.BTileUU[t]^.Mask]);
for t := 0 to FBrushList.Brush[b]^.BEdges[e]^.CountUR - 1 do
Logger.Send([lcInfo], ' <Land Id="0x%.4x" Chance="%.2f" Mask="0x%.2x">',
[FBrushList.Brush[b]^.BEdges[e]^.BTileUR[t]^.ID, FBrushList.Brush[b]^.BEdges[e]^.BTileUR[t]^.Chance, FBrushList.Brush[b]^.BEdges[e]^.BTileUR[t]^.Mask]);
for t := 0 to FBrushList.Brush[b]^.BEdges[e]^.CountLL - 1 do
Logger.Send([lcInfo], ' <Land Id="0x%.4x" Chance="%.2f" Mask="0x%.2x">',
[FBrushList.Brush[b]^.BEdges[e]^.BTileLL[t]^.ID, FBrushList.Brush[b]^.BEdges[e]^.BTileLL[t]^.Chance, FBrushList.Brush[b]^.BEdges[e]^.BTileLL[t]^.Mask]);
for t := 0 to FBrushList.Brush[b]^.BEdges[e]^.CountUL - 1 do
Logger.Send([lcInfo], ' <Land Id="0x%.4x" Chance="%.2f" Mask="0x%.2x">',
[FBrushList.Brush[b]^.BEdges[e]^.BTileUL[t]^.ID, FBrushList.Brush[b]^.BEdges[e]^.BTileUL[t]^.Chance, FBrushList.Brush[b]^.BEdges[e]^.BTileUL[t]^.Mask]);
for t := 0 to FBrushList.Brush[b]^.BEdges[e]^.CountDL - 1 do
Logger.Send([lcInfo], ' <Land Id="0x%.4x" Chance="%.2f" Mask="0x%.2x">',
[FBrushList.Brush[b]^.BEdges[e]^.BTileDL[t]^.ID, FBrushList.Brush[b]^.BEdges[e]^.BTileDL[t]^.Chance, FBrushList.Brush[b]^.BEdges[e]^.BTileDL[t]^.Mask]);
for t := 0 to FBrushList.Brush[b]^.BEdges[e]^.CountDR - 1 do
Logger.Send([lcInfo], ' <Land Id="0x%.4x" Chance="%.2f" Mask="0x%.2x">',
[FBrushList.Brush[b]^.BEdges[e]^.BTileDR[t]^.ID, FBrushList.Brush[b]^.BEdges[e]^.BTileDR[t]^.Chance, FBrushList.Brush[b]^.BEdges[e]^.BTileDR[t]^.Mask]);
Logger.Send([lcInfo], ' </Edge>');
end;
Logger.Send([lcInfo], '</Brush>');
end;
Logger.ExitMethod([lcInfo, lcDebug], 'TfrmMain.LoadBrushTilesList');
}
end;
procedure TfrmMain.BuildGroupList;
var
XMLDoc: TXMLDocument;
iNode : TDOMNode;
fPath : string;
vNode : PVirtualNode;
bTemp : array[0..$E000] of Word;
gTemp : array[0..$FFFF] of Boolean;
procedure SumItems(Node: PVirtualNode; Count: Integer; var Items: LongWord);
var
i : Integer;
item : PVirtualNode;
group: PGroupNode;
begin
group := tvGroups.GetNodeData(Node);
Items += group^.Count;
Items += group^.Entries;
Items += group^.Brushes;
for i := 0 to group^.Links - 1 do
if group^.GLink[i] <> nil then
SumItems(group^.GLink[i], 0, Items);
if (Count > 0) then
begin
item := tvGroups.GetFirstChild(Node);
while item <> nil do
begin
SumItems(item, Count - 1, Items);
item := tvGroups.GetNextSibling(item);
end;
end;
end;
procedure ProcessNode(Node: TDOMNode; TreeNode: PVirtualNode);
var
element: TDOMElement;
cNode: TDOMNode;
s: string;
i, j, k, e, b, d, q, id: Integer;
group: PGroupNode;
begin
if Node = nil then Exit; // выходим, если достигнут конец документа
if LowerCase(Node.NodeName) <> 'group' then Exit;
// добавляем узел в дерево
TreeNode := tvGroups.AddChild(TreeNode);
group := tvGroups.GetNodeData(TreeNode);
// сохраняем данные узла
e := 0; b := 0; d := 0;
group^.Count := 0;
cNode := Node.FirstChild;
while cNode <> nil do
begin
s := LowerCase(cNode.NodeName);
if (s = 'tile') or (s = 'land') or (s = 'item')
then Inc(group^.Count, 1)
else if (s = 'entry') then Inc(e, 1)
else if (s = 'brush') then Inc(b, 1)
else if (s = 'link') then // Inc(d, 1);
for i := 0 to cNode.Attributes.Length - 1 do
if LowerCase(cNode.Attributes[i].NodeName) = 'groupid' then Inc(d, 1)
else if LowerCase(cNode.Attributes[i].NodeName) = 'brushid' then
if TryStrToInt(cNode.Attributes[i].NodeValue, id) then begin
for j := 0 to Length(FBrushList.Tiles) - 1 do
if (FBrushList.Tiles[j].ID <> $FFFF) and
((id = FBrushList.Tiles[j].Brush1^.ID) or (id = FBrushList.Tiles[j].Brush2^.ID))
then Inc(group^.Count, 1);
end;
cNode := cNode.NextSibling;
end;
group^.Entries := e; group^.Brushes := b; group^.Links := d;
k := 0; e := 0; b := 0; d := 0;
getmem(group^.lids, group^.Links * SizeOf(LongWord));
getmem(group^.GLink, group^.Links * SizeOf(PVirtualnode));
getmem(group^.GTile, group^.Count * SizeOf(TGroupTile));
getmem(group^.Entry, group^.Entries * SizeOf(PGroupEntry));
getmem(group^.Brush, group^.Brushes * SizeOf(PGroupBrush));
cNode := Node.FirstChild;
while cNode <> nil do
begin
s := LowerCase(cNode.NodeName);
if (s = 'tile') or (s = 'land') or (s = 'item') then
begin
for i := cNode.Attributes.Length - 1 downto 0 do
begin
if LowerCase(cNode.Attributes[i].NodeName) = 'id' then
if TryStrToInt(cNode.Attributes[i].NodeValue, id) then
begin
if s = 'item' then
Inc(id, $4000);
group^.GTile[k].ID := id;
Inc(k, 1);
end;
end;
end
else if (s = 'entry') then
begin
for i := cNode.Attributes.Length - 1 downto 0 do
begin
if LowerCase(cNode.Attributes[i].NodeName) = 'id' then
if TryStrToInt(cNode.Attributes[i].NodeValue, id) then
begin
group^.Entry[e] := nil;
for j := 0 to FEntryList.Count - 1 do
if FEntryList.Entry[j]^.ID = id then begin
group^.Entry[e] := FEntryList.Entry[j];
break;
end;
Inc(e, 1);
end;
end;
end
else if (s = 'brush') then
begin
for i := cNode.Attributes.Length - 1 downto 0 do
begin
if LowerCase(cNode.Attributes[i].NodeName) = 'id' then
if TryStrToInt(cNode.Attributes[i].NodeValue, id) then
begin
group^.Brush[b] := nil;
for j := 0 to FBrushList.Count - 1 do
if FBrushList.Brush[j]^.ID = id then begin
group^.Brush[b] := FBrushList.Brush[j];
break;
end;
Inc(b, 1);
end;
end;
end
else if (s = 'link') then
begin
for i := 0 to cNode.Attributes.Length - 1 do
begin
if LowerCase(cNode.Attributes[i].NodeName) = 'groupid' then
if TryStrToInt(cNode.Attributes[i].NodeValue, id) then
begin
group^.lids[d] := id;
Inc(d, 1);
end;
if LowerCase(cNode.Attributes[i].NodeName) = 'brushid' then //
if TryStrToInt(cNode.Attributes[i].NodeValue, id) then
begin
bTemp[$0000]:=$0000; bTemp[$D000]:=$D000;
bTemp[$1000]:=$1000; bTemp[$2000]:=$2000; bTemp[$3000]:=$3000; bTemp[$4000]:=$4000;
bTemp[$5000]:=$5000; bTemp[$6000]:=$6000; bTemp[$7000]:=$7000; bTemp[$8000]:=$8000;
bTemp[$9000]:=$9000; bTemp[$A000]:=$A000; bTemp[$B000]:=$B000; bTemp[$C000]:=$C000;
for j := 0 to Length(gTemp)-1 do gTemp[j] := False;
for j := 0 to Length(FBrushList.Tiles) - 1 do begin
if (FBrushList.Tiles[j].ID = $FFFF) then Continue;
if (id = FBrushList.Tiles[j].Brush1^.ID) and (id = FBrushList.Tiles[j].Brush2^.ID) then begin
inc(bTemp[$0000], 1); bTemp[bTemp[$0000]] := j; Continue;
end;
if (FBrushList.Tiles[j].Mask = $0B) and (id = FBrushList.Tiles[j].Brush2^.ID) then begin
inc(bTemp[$1000],1); bTemp[bTemp[$1000]]:=j;
gTemp[FBrushList.Tiles[j].Brush1^.ID]:=True;
bTemp[bTemp[$1000]+$0800]:=FBrushList.Tiles[j].Brush1^.ID;
Continue;
end;
if (FBrushList.Tiles[j].Mask = $0D) and (id = FBrushList.Tiles[j].Brush2^.ID) then begin
inc(bTemp[$2000],1); bTemp[bTemp[$2000]]:=j;
gTemp[FBrushList.Tiles[j].Brush1^.ID]:=True;
bTemp[bTemp[$2000]+$0800]:=FBrushList.Tiles[j].Brush1^.ID;
Continue;
end;
if (FBrushList.Tiles[j].Mask = $07) and (id = FBrushList.Tiles[j].Brush2^.ID) then begin
inc(bTemp[$3000],1); bTemp[bTemp[$3000]]:=j;
gTemp[FBrushList.Tiles[j].Brush1^.ID]:=True;
bTemp[bTemp[$3000]+$0800]:=FBrushList.Tiles[j].Brush1^.ID;
Continue;
end;
if (FBrushList.Tiles[j].Mask = $0E) and (id = FBrushList.Tiles[j].Brush2^.ID) then begin
inc(bTemp[$4000],1); bTemp[bTemp[$4000]]:=j;
gTemp[FBrushList.Tiles[j].Brush1^.ID]:=True;
bTemp[bTemp[$4000]+$0800]:=FBrushList.Tiles[j].Brush1^.ID;
Continue;
end;
if (FBrushList.Tiles[j].Mask = $09) and (id = FBrushList.Tiles[j].Brush2^.ID) then begin
inc(bTemp[$5000],1); bTemp[bTemp[$5000]]:=j;
gTemp[FBrushList.Tiles[j].Brush1^.ID]:=True;
bTemp[bTemp[$5000]+$0800]:=FBrushList.Tiles[j].Brush1^.ID;
Continue;
end;
if (FBrushList.Tiles[j].Mask = $03) and (id = FBrushList.Tiles[j].Brush2^.ID) then begin
inc(bTemp[$6000],1); bTemp[bTemp[$6000]]:=j;
gTemp[FBrushList.Tiles[j].Brush1^.ID]:=True;
bTemp[bTemp[$6000]+$0800]:=FBrushList.Tiles[j].Brush1^.ID;
Continue;
end;
if (FBrushList.Tiles[j].Mask = $03) and (id = FBrushList.Tiles[j].Brush1^.ID) then begin
inc(bTemp[$7000],1); bTemp[bTemp[$7000]]:=j;
gTemp[FBrushList.Tiles[j].Brush2^.ID]:=True;
bTemp[bTemp[$7000]+$0800]:=FBrushList.Tiles[j].Brush2^.ID;
Continue;
end;
if (FBrushList.Tiles[j].Mask = $09) and (id = FBrushList.Tiles[j].Brush1^.ID) then begin
inc(bTemp[$8000],1); bTemp[bTemp[$8000]]:=j;
gTemp[FBrushList.Tiles[j].Brush2^.ID]:=True;
bTemp[bTemp[$8000]+$0800]:=FBrushList.Tiles[j].Brush2^.ID;
Continue;
end;
if (FBrushList.Tiles[j].Mask = $0E) and (id = FBrushList.Tiles[j].Brush1^.ID) then begin
inc(bTemp[$9000],1); bTemp[bTemp[$9000]]:=j;
gTemp[FBrushList.Tiles[j].Brush2^.ID]:=True;
bTemp[bTemp[$9000]+$0800]:=FBrushList.Tiles[j].Brush2^.ID;
Continue;
end;
if (FBrushList.Tiles[j].Mask = $0D) and (id = FBrushList.Tiles[j].Brush1^.ID) then begin
inc(bTemp[$A000],1); bTemp[bTemp[$A000]]:=j;
gTemp[FBrushList.Tiles[j].Brush2^.ID]:=True;
bTemp[bTemp[$A000]+$0800]:=FBrushList.Tiles[j].Brush2^.ID;
Continue;
end;
if (FBrushList.Tiles[j].Mask = $07) and (id = FBrushList.Tiles[j].Brush1^.ID) then begin
inc(bTemp[$B000],1); bTemp[bTemp[$B000]]:=j;
gTemp[FBrushList.Tiles[j].Brush2^.ID]:=True;
bTemp[bTemp[$B000]+$0800]:=FBrushList.Tiles[j].Brush2^.ID;
Continue;
end;
if (FBrushList.Tiles[j].Mask = $0B) and (id = FBrushList.Tiles[j].Brush1^.ID) then begin
inc(bTemp[$C000],1); bTemp[bTemp[$C000]]:=j;
gTemp[FBrushList.Tiles[j].Brush2^.ID]:=True;
bTemp[bTemp[$C000]+$0800]:=FBrushList.Tiles[j].Brush2^.ID;
Continue;
end;
if (id = FBrushList.Tiles[j].Brush1^.ID) or (id = FBrushList.Tiles[j].Brush2^.ID) then begin
inc(bTemp[$D000],1); // то что не удалось расортировать (вообще мы никогда не должны сюда попадать)
bTemp[bTemp[$D000]] := j;
end;
end;
for j := $0001 to bTemp[$0000] do begin
group^.GTile[k].ID := bTemp[j]; Inc(k, 1);
end;
for q := 0 to Length(gTemp)-1 do
if gTemp[q] then begin
for j := $1001 to bTemp[$1000] do if (bTemp[j+$0800]=q) then begin
group^.GTile[k].ID := bTemp[j]; Inc(k, 1);
end;
for j := $2001 to bTemp[$2000] do if (bTemp[j+$0800]=q) then begin
group^.GTile[k].ID := bTemp[j]; Inc(k, 1);
end;
for j := $3001 to bTemp[$3000] do if (bTemp[j+$0800]=q) then begin
group^.GTile[k].ID := bTemp[j]; Inc(k, 1);
end;
for j := $4001 to bTemp[$4000] do if (bTemp[j+$0800]=q) then begin
group^.GTile[k].ID := bTemp[j]; Inc(k, 1);
end;
for j := $5001 to bTemp[$5000] do if (bTemp[j+$0800]=q) then begin
group^.GTile[k].ID := bTemp[j]; Inc(k, 1);
end;
for j := $6001 to bTemp[$6000] do if (bTemp[j+$0800]=q) then begin
group^.GTile[k].ID := bTemp[j]; Inc(k, 1);
end;
for j := $7001 to bTemp[$7000] do if (bTemp[j+$0800]=q) then begin
group^.GTile[k].ID := bTemp[j]; Inc(k, 1);
end;
for j := $8001 to bTemp[$8000] do if (bTemp[j+$0800]=q) then begin
group^.GTile[k].ID := bTemp[j]; Inc(k, 1);
end;
for j := $9001 to bTemp[$9000] do if (bTemp[j+$0800]=q) then begin
group^.GTile[k].ID := bTemp[j]; Inc(k, 1);
end;
for j := $A001 to bTemp[$A000] do if (bTemp[j+$0800]=q) then begin
group^.GTile[k].ID := bTemp[j]; Inc(k, 1);
end;
for j := $B001 to bTemp[$B000] do if (bTemp[j+$0800]=q) then begin
group^.GTile[k].ID := bTemp[j]; Inc(k, 1);
end;
for j := $C001 to bTemp[$C000] do if (bTemp[j+$0800]=q) then begin
group^.GTile[k].ID := bTemp[j]; Inc(k, 1);
end;
end;
for j := $D001 to bTemp[$D000] do begin
group^.GTile[k].ID := bTemp[j]; Inc(k, 1);
end;
end;
end;
end;
cNode := cNode.NextSibling;
end;
// переходим к дочернему узлу
cNode := Node.FirstChild;
// проходим по всем дочерним узлам
while cNode <> nil do
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
ProcessNode(cNode, TreeNode);
cNode := cNode.NextSibling;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
// сохраняем данные узла
k:= 0;
group^.ID := 0;
group^.Nodes:= 0;
group^.Name := 'NoName';
group^.Color:= TColor($00000000);
if tvGroups.ChildCount[TreeNode] = 0
then group^.Ital := True
else group^.Ital := False;
if tvGroups.ChildCount[TreeNode] > 4
then group^.Bold := True
else group^.Bold := False;
if Node.HasAttributes and (Node.Attributes.Length>0) then
for i := 0 to Node.Attributes.Length - 1 do
if LowerCase(Node.Attributes[i].NodeName) = 'name' then begin
group^.Name := CP1251ToUTF8(Node.Attributes[i].NodeValue)
end else if LowerCase(Node.Attributes[i].NodeName) = 'color' then begin
if TryStrToInt(Node.Attributes[i].NodeValue, k) then
group^.Color:=TColor(((k and$0000FF)shl 16)or(k and$00FF00)or((k and$FF0000)shr 16));
end else if LowerCase(Node.Attributes[i].NodeName) = 'bold' then begin
TryStrToBool(Node.Attributes[i].NodeValue, group^.Bold);
end else if LowerCase(Node.Attributes[i].NodeName) = 'ital' then begin
TryStrToBool(Node.Attributes[i].NodeValue, group^.Ital);
end else if LowerCase(Node.Attributes[i].NodeName) = 'id' then begin
if TryStrToInt(Node.Attributes[i].NodeValue, d) then group^.ID := d;
end else if LowerCase(Node.Attributes[i].NodeName) = 'nodes' then begin
if TryStrToInt(Node.Attributes[i].NodeValue, k) then
begin if k=-1 then k:=$FFFF; group^.Nodes := Max(0, k); k:=0; end;
end;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure BuildLinks(Node: PVirtualNode);
var
i : Integer;
item : PVirtualNode;
group: PGroupNode;
begin
group := tvGroups.GetNodeData(Node);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
for i := 0 to group^.Links - 1 do
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
//Logger.Send([lcClient, lcDebug], 'BuildLinks: %.4d / %.4d - id: %d', [i+1, group^.Links, group^.lids[i]]);
group^.GLink[i] := nil;
if group^.lids[i] = 0 then continue;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
item := tvGroups.GetFirst();
while item <> nil do
begin
if group^.lids[i] = PGroupNode(tvGroups.GetNodeData(item))^.ID then
begin
//Logger.Send([lcClient, lcDebug], 'BuildLinks: Group id: %d Found', [group^.lids[i]]);
group^.GLink[i] := item;
break;
end;
item := tvGroups.GetNext(item);
end
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FreeMem(group^.lids);
group^.lids := nil;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tvGroups.BeginUpdate;
tvGroups.Clear;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
frmInitialize.SetStatusLabel(Format(frmInitialize.SplashLoading, ['TilesGroup.xml']));
if FileExists(FProfileDir + 'TilesGroup.xml')
then fPath := (FProfileDir + 'TilesGroup.xml')
else if FileExists(FLocalDir + 'TilesGroup.xml')
then fPath := (FLocalDir + 'TilesGroup.xml')
else if FileExists(FConfigDir + 'TilesGroup.xml')
then fPath := (FConfigDir + 'TilesGroup.xml')
else if FileExists(ResMan.GetFile('TilesGroup.xml'))
then fPath := (ResMan.GetFile('TilesGroup.xml'))
else Exit;
// Читаем xml файл с жесткого диска
ReadXMLFile(XMLDoc, fPath);
if LowerCase(XMLDoc.DocumentElement.NodeName) = 'tilesgroup' then
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
iNode := XMLDoc.DocumentElement.FirstChild;
while iNode <> nil do
begin
if LowerCase(iNode.NodeName) = 'group' then
ProcessNode(iNode, nil); // Рекурсия
iNode := iNode.NextSibling;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
// Построение Указателей
vNode := tvGroups.GetFirst();
while vNode <> nil do
begin
BuildLinks(vNode);
vNode := tvGroups.GetNext(vNode);
end;
// Подсчет Items
vNode := tvGroups.GetFirst();
while vNode <> nil do
begin
SumItems(vNode, PGroupNode(tvGroups.GetNodeData(vNode))^.Nodes,
PGroupNode(tvGroups.GetNodeData(vNode))^.Items);
vNode := tvGroups.GetNext(vNode);
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
XMLDoc.Free;
tvGroups.EndUpdate;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.FreeGroupLists;
var i, j, k : Integer;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
for i:=0 to FEntryList.Count-1 do begin
FreeMem(FEntryList.Entry[i]^.ETile);
FEntryList.Entry[i]^.Image.Destroy;
end;
FreeMem(FEntryList.Entry);
FEntryList.Count:=0;
for i:=0 to FBrushList.Count-1 do begin
//for j:=0 to FBrushList.Brush[i]^.Count-1 do begin
// FreeMem(FBrushList.Brush[i]^.BTile[j]);
//end;
FreeMem(FBrushList.Brush[i]^.BEdges);
FreeMem(FBrushList.Brush[i]^.BTile);
FBrushList.Brush[i]^.Image.Destroy;
FBrushList.Count:=0;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
for i:=0 to $3FFF do begin
FBrushList.Tiles[i].ID := 0;
FBrushList.Tiles[i].Brush1:=nil;
FBrushList.Tiles[i].Brush2:=nil;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure TfrmMain.BuildTileList;
var
minID, maxID, i, k, lastID: Integer;
item : PVirtualItem;
groupNode : PVirtualNode;
tileInfo: PTileInfo;
filter : string;
nodeData: PGroupNode;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure AddNodeTiles(Node: PVirtualNode; Count: Integer);
var
item: PVirtualItem;
groupNode: PVirtualNode;
nodeData: PGroupNode;
tileInfo: PTileInfo;
lastID: LongWord;
i, j: Integer;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
//b,t,e: Integer;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
nodeData := tvGroups.GetNodeData(Node);
Logger.Send([lcInfo], 'Brushes: %d - Entries: %d - Tiles: %d', [nodeData^.Brushes, nodeData^.Entries, nodeData^.Count]);
{
Logger.EnterMethod([lcInfo, lcDebug], 'TfrmMain.AddNodeTiles-Entries');
Logger.Send([lcInfo], 'Entries Number: %d', [FEntryList.Count]);
for e := 0 to FEntryList.Count - 1 do begin
Logger.Send([lcInfo], '<Entry Id="%.4d" Name="%s" Tiles="%x">',
[FEntryList.Entry[e]^.ID, FEntryList.Entry[e]^.Name, FEntryList.Entry[e]^.Count]);
for t := 0 to FEntryList.Entry[e]^.Count - 1 do
Logger.Send([lcInfo], ' <Tile Id="0x%.5x" Hue="0x%.3x" X="%d" Y="%d" Z="%d">',
[FEntryList.Entry[e]^.ETile[t].ID, FEntryList.Entry[e]^.ETile[t].Hue,
FEntryList.Entry[e]^.ETile[t].X, FEntryList.Entry[e]^.ETile[t].Y, FEntryList.Entry[e]^.ETile[t].Z]);
Logger.Send([lcInfo], '</Entry>');
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
Logger.ExitMethod([lcInfo, lcDebug], 'TfrmMain.AddNodeTiles-Entries');
Logger.EnterMethod([lcInfo, lcDebug], 'TfrmMain.AddNodeTiles-Brushes');
Logger.Send([lcInfo], 'Brushes Number: %x', [FBrushList.Count]);
for b := 0 to FBrushList.Count - 1 do begin
Logger.Send([lcInfo], '<Brush Id="%.4d" Name="%s" Tiles="%d" Edges="%d">',
[FBrushList.Brush[b]^.ID, FBrushList.Brush[b]^.Name, FBrushList.Brush[b]^.Count, FBrushList.Brush[b]^.ECount]);
for t := 0 to FBrushList.Brush[b]^.Count - 1 do
Logger.Send([lcInfo], ' <Land Id="0x%.4x" Chance="%.2f" Mask="0x%.2x">',
[FBrushList.Brush[b]^.BTile[t]^.ID, FBrushList.Brush[b]^.BTile[t]^.Chance, FBrushList.Brush[b]^.BTile[t]^.Mask]);
for e := 0 to FBrushList.Brush[b]^.ECount - 1 do begin
Logger.Send([lcInfo], ' <Edge To="%d" Tiles="%d">',
[FBrushList.Brush[b]^.EdgeId[e]^, 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]);
for t := 0 to FBrushList.Brush[b]^.BEdges[e]^.CountUU - 1 do
Logger.Send([lcInfo], ' <Land Id="0x%.4x" Chance="%.2f" Mask="0x%.2x">',
[FBrushList.Brush[b]^.BEdges[e]^.BTileUU[t]^.ID, FBrushList.Brush[b]^.BEdges[e]^.BTileUU[t]^.Chance, FBrushList.Brush[b]^.BEdges[e]^.BTileUU[t]^.Mask]);
for t := 0 to FBrushList.Brush[b]^.BEdges[e]^.CountUR - 1 do
Logger.Send([lcInfo], ' <Land Id="0x%.4x" Chance="%.2f" Mask="0x%.2x">',
[FBrushList.Brush[b]^.BEdges[e]^.BTileUR[t]^.ID, FBrushList.Brush[b]^.BEdges[e]^.BTileUR[t]^.Chance, FBrushList.Brush[b]^.BEdges[e]^.BTileUR[t]^.Mask]);
for t := 0 to FBrushList.Brush[b]^.BEdges[e]^.CountLL - 1 do
Logger.Send([lcInfo], ' <Land Id="0x%.4x" Chance="%.2f" Mask="0x%.2x">',
[FBrushList.Brush[b]^.BEdges[e]^.BTileLL[t]^.ID, FBrushList.Brush[b]^.BEdges[e]^.BTileLL[t]^.Chance, FBrushList.Brush[b]^.BEdges[e]^.BTileLL[t]^.Mask]);
for t := 0 to FBrushList.Brush[b]^.BEdges[e]^.CountUL - 1 do
Logger.Send([lcInfo], ' <Land Id="0x%.4x" Chance="%.2f" Mask="0x%.2x">',
[FBrushList.Brush[b]^.BEdges[e]^.BTileUL[t]^.ID, FBrushList.Brush[b]^.BEdges[e]^.BTileUL[t]^.Chance, FBrushList.Brush[b]^.BEdges[e]^.BTileUL[t]^.Mask]);
for t := 0 to FBrushList.Brush[b]^.BEdges[e]^.CountDL - 1 do
Logger.Send([lcInfo], ' <Land Id="0x%.4x" Chance="%.2f" Mask="0x%.2x">',
[FBrushList.Brush[b]^.BEdges[e]^.BTileDL[t]^.ID, FBrushList.Brush[b]^.BEdges[e]^.BTileDL[t]^.Chance, FBrushList.Brush[b]^.BEdges[e]^.BTileDL[t]^.Mask]);
for t := 0 to FBrushList.Brush[b]^.BEdges[e]^.CountDR - 1 do
Logger.Send([lcInfo], ' <Land Id="0x%.4x" Chance="%.2f" Mask="0x%.2x">',
[FBrushList.Brush[b]^.BEdges[e]^.BTileDR[t]^.ID, FBrushList.Brush[b]^.BEdges[e]^.BTileDR[t]^.Chance, FBrushList.Brush[b]^.BEdges[e]^.BTileDR[t]^.Mask]);
Logger.Send([lcInfo], ' </Edge>');
end;
Logger.Send([lcInfo], '</Brush>');
end;
Logger.ExitMethod([lcInfo, lcDebug], 'TfrmMain.AddNodeTiles-Brushes');
}
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
for i := 0 to nodeData^.Count - 1 do
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
lastID := nodeData^.GTile[i].ID;
if FVisibleTiles[lastID] and ResMan.Art.Exists(lastID) then
begin
if (filter <> '') and (Pos(filter, AnsiLowerCase(
ResMan.Tiledata.TileData[lastID].TileName)) = 0) then Continue;
item := vdtTiles.AddItem(nil);
tileInfo := vdtTiles.GetNodeData(item);
tileInfo^.ID := lastID;
end;
end;
for i := 0 to nodeData^.Brushes - 1 do
begin
if nodeData^.Brush[i] = nil then Continue;
lastID := $2F000000 + LongWord(nodeData^.Brush[i]^.ID);
//if FVisibleTiles[lastID] and ResMan.Art.Exists(lastID) then
begin
if (filter <> '') and (Pos(filter, AnsiLowerCase(
nodeData^.Brush[i]^.Name)) = 0) then Continue;
item := vdtTiles.AddItem(nil);
tileInfo := vdtTiles.GetNodeData(item);
tileInfo^.ID := lastID;
tileInfo^.ptr:= nodeData^.Brush[i];
end;
end;
for i := 0 to nodeData^.Entries - 1 do
begin
if nodeData^.Entry[i] = nil then Continue;
lastID := $1F000000 + LongWord(nodeData^.Entry[i]^.ID);
//if FVisibleTiles[lastID] and ResMan.Art.Exists(lastID) then
begin
if (filter <> '') and (Pos(filter, AnsiLowerCase(
nodeData^.Entry[i]^.Name)) = 0) then Continue;
item := vdtTiles.AddItem(nil);
tileInfo := vdtTiles.GetNodeData(item);
tileInfo^.ID := lastID;
tileInfo^.ptr:= nodeData^.Entry[i];
end;
end;
// Добавление сылок групп
for i := 0 to nodeData^.Links - 1 do
if nodeData^.GLink[i] <> nil then
AddNodeTiles(nodeData^.GLink[i], 0);
// Добавление вложенных подгрупп
if (Count > 0) then
begin
groupNode := tvGroups.GetFirstChild(Node);
while groupNode <> nil do
begin
AddNodeTiles(groupNode, Count - 1);
groupNode := tvGroups.GetNextSibling(groupNode);
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
filter := AnsiLowerCase(UTF8ToCP1251(edFilter.Text));
Logger.Send([lcInfo], 'TfrmMain.BuildTileList: %s', ['Start']);
// Сортировка по группам
if (not cbStatics.Checked) and (not cbTerrain.Checked) then
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
vdtTiles.BeginUpdate;
vdtTiles.Clear;
groupNode := tvGroups.GetFirstSelected();
while groupNode <> nil do
begin
nodeData := tvGroups.GetNodeData(groupNode);
AddNodeTiles(groupNode, nodeData^.Nodes);
groupNode := tvGroups.GetNextSelected(groupNode);
end;
vdtTiles.EndUpdate;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end else
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
// Старое построение - список всех land и\или item тайлов
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
Logger.Send([lcInfo], 'TfrmMain.BuildTileList: start');
maxID := $3FFF;
if cbTerrain.Checked then minID := $0 else minID := $4000;
if cbStatics.Checked then maxID := maxID + FLandscape.MaxStaticID;
item := vdtTiles.GetFirstSelected;
if item <> nil then
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tileInfo := vdtTiles.GetNodeData(item);
lastID := tileInfo^.ID;
end else
lastID := -1;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
vdtTiles.BeginUpdate;
vdtTiles.Clear;
Logger.Send([lcInfo], 'TfrmMain.BuildTileList: from %.4x to %.4x', [minID, maxID]);
for i := minID to maxID do
begin
if FVisibleTiles[i] and ResMan.Art.Exists(i) then
begin
if (filter <> '') and (Pos(filter, AnsiLowerCase(
ResMan.Tiledata.TileData[i].TileName)) = 0) then Continue;
item := vdtTiles.AddItem(nil);
tileInfo := vdtTiles.GetNodeData(item);
tileInfo^.ID := i;
//Logger.Send([lcInfo], 'TfrmMain.BuildTileList: tileInfo %.4x == %.4x', [i, PTileInfo(vdtTiles.GetNodeData(vdtTiles.GetFirst()))^.ID]);
if i = lastID then
vdtTiles.Selected[item] := True;
end;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
vdtTiles.EndUpdate;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
item := vdtTiles.GetFirstSelected;
if item <> nil then
vdtTiles.FocusedNode := item;
end;
Logger.Send([lcInfo], 'TfrmMain.BuildTileList: %s', ['End']);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.ProcessToolState;
var
blockInfo: PBlockInfo;
begin
if acSelect.Checked then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
//lblTip.Caption := 'Нажатие правой кнопки мышки покажет меню со всеми инструментами.';
//lblTip.Caption := 'Нажмите и удерживайте левую кнопку мышки, чтобы просмотреть список действий.';
//'Press and hold the left mouse button to show a list with actions (eg. grab hue).';
oglGameWindow.Cursor := +01;//crDefault;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
//no highlighted tiles in "selection" mode
Logger.Send([lcClient, lcDebug], 'Disable highlighting');
blockInfo := nil;
while FScreenBuffer.Iterate(blockInfo) do
if blockInfo^.State = ssNormal then
blockInfo^.Highlighted := False;
end else
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
//lblTip.Caption := 'Нажмите и удерживайте левую кнопку мышки, чтобы выбрать область.';
//'Press and hold the left mouse button to target an area.';
oglGameWindow.Cursor := +03;//crHandPoint;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
FRepaintNeeded := True;
end;
procedure TfrmMain.ProcessAccessLevel;
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
mnuAdministration.Visible := (dmNetwork.AccessLevel >= alDeveloper);
mnuShutdown.Visible := (dmNetwork.AccessLevel >= alAdministrator);
mnuAccountControl.Visible := (dmNetwork.AccessLevel >= alAdministrator);
mnuRegionControl.Visible := (dmNetwork.AccessLevel >= alAdministrator);
acSelection.Enabled := (dmNetwork.AccessLevel >= alNormal);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
acDraw.Enabled := (dmNetwork.AccessLevel >= alNormal);
acMove.Enabled := (dmNetwork.AccessLevel >= alNormal);
acElevate.Enabled := (dmNetwork.AccessLevel >= alNormal);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
acSurfElevate.Enabled := (dmNetwork.AccessLevel >= alNormal);
acSurfStretch.Enabled := (dmNetwork.AccessLevel >= alNormal);
acSurfSmooth.Enabled := (dmNetwork.AccessLevel >= alNormal);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
acDelete.Enabled := (dmNetwork.AccessLevel >= alNormal);
acHue.Enabled := (dmNetwork.AccessLevel >= alNormal);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
acFill.Enabled := (dmNetwork.AccessLevel >= alNormal);
Caption := Format('UO CentrED+ v%s [%s "%s" (%s) | %s "%s"]',
//Caption := Format('UO CentrED+ v%s !!! pre-release (not stable version) !!! [%s "%s" (%s) | %s "%s"]',
[VersionInfo.GetProductVersionString, lbFormTitleAccount, dmNetwork.Username,
GetAccessLevel(dmNetwork.AccessLevel), lbFormTitleProfile, dmNetwork.Profile]);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.RebuildScreenBuffer;
var
blockInfo: PBlockInfo;
i, tileX, tileY: Integer;
virtualTile: TVirtualTile;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
zoom: Single;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
//Logger.EnterMethod([lcClient], 'RebuildScreenBuffer');
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if tbZoom.Down then zoom:= tbZoom.Tag / 1000.0 else zoom:= 1.0;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
FDrawDistance := Trunc(Sqrt(oglGameWindow.Width * oglGameWindow.Width +
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
oglGamewindow.Height * oglGamewindow.Height) / (44 * zoom));
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
//Logger.Send([lcClient], 'DrawDistance', FDrawDistance);
{$HINTS off}{$WARNINGS off}
if FX - FDrawDistance < 0 then FLowOffsetX := -FX else FLowOffsetX := -FDrawDistance;
if FY - FDrawDistance < 0 then FLowOffsetY := -FY else FLowOffsetY := -FDrawDistance;
if FX + FDrawDistance >= FLandscape.Width * 8 then FHighOffsetX := FLandscape.Width * 8 - FX - 1 else FHighOffsetX := FDrawDistance;
if FY + FDrawDistance >= FLandscape.Height * 8 then FHighOffsetY := FLandscape.Height * 8 - FY - 1 else FHighOffsetY := FDrawDistance;
{$HINTS on}{$WARNINGS on}
FRangeX := FHighOffsetX - FLowOffsetX;
FRangeY := FHighOffsetY - FLowOffsetY;
FLandscape.PrepareBlocks((FX + FLowOffsetX) div 8, (FY + FLowOffsetY) div 8,
(FX + FHighOffsetX) div 8 + 1, (FY + FHighOffsetY) div 8 + 1);
if frmVirtualLayer.cbShowLayer.Checked then
begin
//Logger.Send([lcClient, lcDebug], 'Preparing Virtual Layer');
if FVLayerMaterial = nil then
FVLayerMaterial := TSimpleMaterial.Create(FVLayerImage);
i := 0;
for tileX := FX + FLowOffsetX to FX + FHighOffsetX do
begin
for tileY := FY + FLowOffsetY to FY + FHighOffsetY do
begin
while (i < FVirtualTiles.Count) and (not (FVirtualTiles[i] is TVirtualTile)) do
Inc(i);
if i < FVirtualTiles.Count then
begin
virtualTile := TVirtualTile(FVirtualTiles[i]);
end else
begin
virtualTile := TVirtualTile.Create(nil);
FVirtualTiles.Add(virtualTile);
end;
virtualTile.X := tileX;
virtualTile.Y := tileY;
virtualTile.Z := frmVirtualLayer.seZ.Value;
virtualTile.Priority := virtualTile.Z;
virtualTile.PriorityBonus := High(ShortInt);
Inc(i);
end;
end;
while i < FVirtualTiles.Count do
begin
if FVirtualTiles[i] is TVirtualTile then
FVirtualTiles.Delete(i)
else
Inc(i);
end;
end else
begin
for i := FVirtualTiles.Count - 1 downto 0 do
if FVirtualTiles[i] is TVirtualTile then
FVirtualTiles.Delete(i);
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if acNoDraw.Checked and mnuShowLightSource.Checked then
begin
if FVLightSrcMaterial = nil then begin
getmem(FVLightSrcMaterial, FVLightSrcImageCount * SizeOf(TSimpleMaterial));
for i := 1 to FVLightSrcImageCount do
FVLightSrcMaterial[i-1] := TSimpleMaterial.Create(FVLightSrcImage[i]);
end;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
//Logger.Send([lcClient, lcDebug], 'VirtualTiles', FVirtualTiles.Count);
FLandscape.FillDrawList(FScreenBuffer, FX + FLowOffsetX, FY + FLowOffsetY,
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FRangeX, FRangeY, acTerrain.Checked, acStatics.Checked, mnuShowWalls.Checked,
mnuShowBridges.Checked, mnuShowRoofs.Checked, mnuShowSurfaces.Checked, mnuShowFoliage.Checked,
mnuShowWater.Checked, acNoDraw.Checked and mnuShowNoDrawTiles.Checked, FVirtualTiles);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
//Pre-process the buffer
blockInfo := nil;
while FScreenBuffer.Iterate(blockInfo) do
PrepareScreenBlock(blockInfo);
FScreenBuffer.UpdateShortcuts;
FScreenBufferState := [sbsValid, sbsIndexed];
//Logger.ExitMethod([lcClient], 'RebuildScreenBuffer');
end;
procedure TfrmMain.UpdateCurrentTile;
var
localPos: TPoint;
begin
if oglGameWindow.MouseEntered then
begin
localPos := oglGameWindow.ScreenToClient(Mouse.CursorPos);
UpdateCurrentTile(localPos.X, localPos.Y);
end;
end;
procedure TfrmMain.UpdateCurrentTile(AX, AY: Integer);
var
blockInfo: PBlockInfo;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
zoom: Single;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
//Logger.EnterMethod([lcClient, lcDebug], 'UpdateCurrentTile');
FOverlayUI.ActiveArrow := FOverlayUI.HitTest(AX, AY);
if FOverlayUI.ActiveArrow > -1 then
begin
//Logger.Send([lcClient, lcDebug], 'Overlay active');
CurrentTile := nil;
//Logger.ExitMethod([lcClient, lcDebug], 'UpdateCurrentTile');
Exit;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if tbZoom.Down then zoom := tbZoom.Tag / 1000.0 else zoom := 1.0;
blockInfo := FScreenBuffer.Find(Point(AX, AY), zoom);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if blockInfo <> nil then
CurrentTile := blockInfo^.Item
else
CurrentTile := nil;
//Logger.ExitMethod([lcClient, lcDebug], 'UpdateCurrentTile');
end;
procedure TfrmMain.UpdateFilter;
var
blockInfo: PBlockInfo;
- Added optional highlight for (un)walkable tiles - Fixed lightmanager to draw in the correct color - Fixed TMapBlock and TStaticBlock to correctly initialize itself as "unchanged" - Cleanup in the server project
2009-12-24 15:49:15 +01:00
tileData: TTiledata;
staticTileData: TStaticTileData;
lastSurface: PBlockInfo;
surfaceTop: Integer;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
zoom: Single;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
blockInfo := nil;
- Added optional highlight for (un)walkable tiles - Fixed lightmanager to draw in the correct color - Fixed TMapBlock and TStaticBlock to correctly initialize itself as "unchanged" - Cleanup in the server project
2009-12-24 15:49:15 +01:00
lastSurface := nil;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
while FScreenBuffer.Iterate(blockInfo) do
begin
if blockInfo^.State in [ssNormal, ssFiltered] then
begin
blockInfo^.State := ssNormal;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if (blockInfo^.Item.X < frmBoundaries.seMinX.Value) or
(blockInfo^.Item.X > frmBoundaries.seMaxX.Value) or
(blockInfo^.Item.Y < frmBoundaries.seMinY.Value) or
(blockInfo^.Item.Y > frmBoundaries.seMaxY.Value) or
(blockInfo^.Item.Z < frmBoundaries.tbMinZ.Position) or
(blockInfo^.Item.Z > frmBoundaries.tbMaxZ.Position) then
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
blockInfo^.State := ssFiltered;
end else
if tbFilter.Down and (blockInfo^.Item is TStaticItem) and
(not frmFilter.Filter(TStaticItem(blockInfo^.Item))) then
begin
blockInfo^.State := ssFiltered;
end;
- Added optional highlight for (un)walkable tiles - Fixed lightmanager to draw in the correct color - Fixed TMapBlock and TStaticBlock to correctly initialize itself as "unchanged" - Cleanup in the server project
2009-12-24 15:49:15 +01:00
blockInfo^.WalkRestriction := wrNone;
if acWalkable.Checked then
begin
if blockInfo^.Item is TMapCell then
begin
tileData := ResMan.Tiledata.LandTiles[blockInfo^.Item.TileID];
if tdfImpassable in tileData.Flags then
begin
blockInfo^.WalkRestriction := wrCannotWalk;
lastSurface := nil;
end else
begin
blockInfo^.WalkRestriction := wrCanWalk;
lastSurface := blockInfo;
surfaceTop := blockInfo^.Item.Z;
end;
end else
begin
staticTileData := ResMan.Tiledata.StaticTiles[blockInfo^.Item.TileID];
if (lastSurface <> nil) and (lastSurface^.WalkRestriction = wrCanWalk) and
(lastSurface^.Item.X = blockInfo^.Item.X) and
(lastSurface^.Item.Y = blockInfo^.Item.Y) and ([tdfSurface,
tdfImpassable] * staticTileData.Flags <> []) then
begin
if (blockInfo^.Item.Z < surfaceTop + 16) and
((blockInfo^.Item.Z > lastSurface^.Item.Z + 2) or
not (tdfSurface in staticTileData.Flags)) then
lastSurface^.WalkRestriction := wrCannotWalk;
end;
if tdfSurface in staticTileData.Flags then
begin
if tdfImpassable in staticTileData.Flags then
begin
blockInfo^.WalkRestriction := wrCannotWalk;
lastSurface := nil;
end else
begin
blockInfo^.WalkRestriction := wrCanWalk;
lastSurface := blockInfo;
surfaceTop := blockInfo^.Item.Z + staticTileData.Height;
end;
end;
end;
end; //acWalkable.Checked
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
- Added optional highlight for (un)walkable tiles - Fixed lightmanager to draw in the correct color - Fixed TMapBlock and TStaticBlock to correctly initialize itself as "unchanged" - Cleanup in the server project
2009-12-24 15:49:15 +01:00
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
Include(FScreenBufferState, sbsFiltered);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if tbZoom.Down then zoom := tbZoom.Tag / 1000.0 else zoom := 1.0;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if (FLightManager.LightLevel > 0) and not acFlat.Checked then
FLightManager.UpdateLightMap(FX + FLowOffsetX, FRangeX + 1, FY + FLowOffsetY,
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
FRangeY + 1, FScreenBuffer, zoom);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
procedure TfrmMain.UpdateSelection;
procedure SetHighlight(ABlockInfo: PBlockInfo; AHighlighted: Boolean);
begin
if (ABlockInfo^.Item is TStaticItem) and acHue.Checked then
begin
if ABlockInfo^.HueOverride <> AHighlighted then
begin
ABlockInfo^.HueOverride := AHighlighted;
if AHighlighted then
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
begin
ABlockInfo^.Hue := frmHueSettings.GetHue;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
ABlockInfo^.LowRes := FTextureManager.GetStaticMaterial(
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
TStaticItem(ABlockInfo^.Item), ABlockInfo^.Hue);
end else
begin
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
ABlockInfo^.LowRes := FTextureManager.GetStaticMaterial(
TStaticItem(ABlockInfo^.Item));
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end else
begin
ABlockInfo^.Highlighted := AHighlighted;
end;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
procedure AddGhostTile(AX, AY: Word; ABaseTile: TWorldItem; selecetion: TRect);
// Получение ID текстуры для тайлов при использовании кисти
function GetTileId(brush: PGroupBrush; mask: byte; tileId: LongWord) : Integer;
var
i, j : Integer;
tileMask : Byte;
tileBrush, tempBrush: PGroupBrush;
brushEdge: PGroupBrushEdge;
randnf, chance, factor: Float;
brushCount: LongWord;
brushTiles: ^PBrushTile;
begin
GetTileId := tileId;
if FBrushList.Tiles[tileId].ID <> tileId
then exit;
if (FBrushList.Tiles[tileId].Brush1^.ID <> brush^.ID) and (FBrushList.Tiles[tileId].Brush2^.ID <> brush^.ID)
and (FBrushList.Tiles[tileId].Brush1^.ID <> FBrushList.Tiles[tileId].Brush2^.ID)
then begin
i:=0; j:=0;
tileMask := FBrushList.Tiles[tileId].Mask and not(mask);
if (tileMask and $01) <> 0 then inc(i);
if (tileMask and $02) <> 0 then inc(i);
if (tileMask and $04) <> 0 then inc(i);
if (tileMask and $08) <> 0 then inc(i);
tileMask := not(FBrushList.Tiles[tileId].Mask or $F0) and not(mask);
if (tileMask and $01) <> 0 then inc(j);
if (tileMask and $02) <> 0 then inc(j);
if (tileMask and $04) <> 0 then inc(j);
if (tileMask and $08) <> 0 then inc(j);
if i > j
then tileBrush := FBrushList.Tiles[tileId].Brush1
else tileBrush := FBrushList.Tiles[tileId].Brush2;
tileMask := $00;
end else
if (FBrushList.Tiles[tileId].Brush1^.ID = brush^.ID) and (FBrushList.Tiles[tileId].Brush2^.ID = brush^.ID)
then begin
tileBrush := nil;
end else if (FBrushList.Tiles[tileId].Brush1^.ID = FBrushList.Tiles[tileId].Brush2^.ID)
then begin
tileBrush := FBrushList.Tiles[tileId].Brush1;
tileMask := $00;
end else begin
if brush^.ID = FBrushList.Tiles[tileId].Brush1^.ID then begin
tileBrush := FBrushList.Tiles[tileId].Brush2;
tileMask := FBrushList.Tiles[tileId].Mask;
end else
if brush^.ID = FBrushList.Tiles[tileId].Brush2^.ID then begin
tileBrush := FBrushList.Tiles[tileId].Brush1;
tileMask := not(FBrushList.Tiles[tileId].Mask or $F0);
end;
end;
// Сумирование масок
if tileBrush = nil then begin
mask := $0F;
end else begin
//Logger.Send([lcInfo], '1 Brush Id= %d Mask= 0x%.2x TileMask= 0x%.2x tileId= 0x%.4x', [brush^.ID, mask, tileMask, tileId]);
mask := tileMask or mask;
//Logger.Send([lcInfo], '2 Brush Id= %d Mask= 0x%.2x TileMask= 0x%.2x tileId= 0x%.4x', [brush^.ID, mask, tileMask, tileId]);
if (mask = $01) or (mask = $02) or (mask = $04) or (mask = $05) or
(mask = $06) or (mask = $08) or (mask = $0A) or (mask = $0C)
then begin
mask := not(mask or $F0);
tempBrush:= brush;
brush:= tileBrush;
tileBrush:= tempBrush;
end;
end;
// Получение данных кисти
brushCount:= 0; brushEdge:= nil; brushTiles:= nil;
if mask = $0F then begin
brushCount := brush^.Count; brushTiles := brush^.BTile;
end else begin
for i := 0 to brush^.ECount-1 do begin
// Logger.Send([lcInfo], 'i= %d/%d EdgeId= %d BrushId= %d', [i, brush^.ECount-1, mask, brush^.EdgeId[i]^, tileBrush^.ID]);
if brush^.EdgeId[i]^ = tileBrush^.ID then begin
brushEdge := brush^.BEdges[i];
break;
end; end;
if brushEdge <> nil then
case mask of
$0E: begin brushCount := brushEdge^.CountDR; brushTiles := brushEdge^.BTileDR; end;
$0D: begin brushCount := brushEdge^.CountDL; brushTiles := brushEdge^.BTileDL; end;
$0B: begin brushCount := brushEdge^.CountUL; brushTiles := brushEdge^.BTileUL; end;
$07: begin brushCount := brushEdge^.CountUR; brushTiles := brushEdge^.BTileUR; end;
$09: begin brushCount := brushEdge^.CountLL; brushTiles := brushEdge^.BTileLL; end;
$03: begin brushCount := brushEdge^.CountUU; brushTiles := brushEdge^.BTileUU; end;
end;
end;
//Logger.Send([lcInfo], 'Brush Id= %d Mask= 0x%.2x TileMask= 0x%.2x tileId= 0x%.4x', [brush^.ID, mask, tileMask, tileId]);
// Находение ID тайла
chance := 0; factor := 0;
for i := 0 to brushCount - 1 do
chance := chance + brushTiles[i]^.Chance;
if chance > 0 then
factor := 1.0 / chance;
randnf := Random; chance := 0;
for i := 0 to brushCount - 1 do begin
chance := chance + factor * brushTiles[i]^.Chance;
if randnf <= chance then begin
GetTileId := brushTiles[i]^.ID;
break;
end;
end;
//if (FBrushList.Tiles[GetTileId].Mask <> FBrushList.Tiles[tileId].Mask)
//or (FBrushList.Tiles[GetTileId].ID <> GetTileId) or (FBrushList.Tiles[tileId].ID <> tileId)
//or (FBrushList.Tiles[GetTileId].Brush1^.ID <> FBrushList.Tiles[tileId].Brush1^.ID)
//or (FBrushList.Tiles[GetTileId].Brush2^.ID <> FBrushList.Tiles[tileId].Brush2^.ID)
//or (GetTileId < 0) or (GetTileId > $3FFF) then GetTileId:= -1;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
var
blockInfo: PBlockInfo;
tileInfo: PTileInfo;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
item: PVirtualItem;
node: PVirtualItem;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
cell: TMapCell;
ghostTile: TGhostTile;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
i, randalt: Integer;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if frmDrawSettings.cbProbability.Checked and frmDrawSettings.cbProbability.Enabled
and (frmDrawSettings.seProbability.Value < 100 * Random)
then exit;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
tileInfo := nil;
if frmDrawSettings.rbTileList.Checked then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
item := vdtTiles.GetFirstSelected;
if item <> nil then
tileInfo := vdtTiles.GetNodeData(item);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end else if frmDrawSettings.rbRandom.Checked then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
node := vdlRandom.GetFirst;
for i := 1 to Random(vdlRandom.TilesCount) do
node := vdlRandom.GetNext(node);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if node <> nil then
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
tileInfo := vdlRandom.GetNodeData(node);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
if tileInfo <> nil then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if tileInfo^.ID > $2F000000 then
begin // **** Кисти ****
cell := FLandscape.MapCell[AX, AY];
if cell <> nil then
begin
//Logger.Send([lcInfo], '!!! AX= %d AY= %d ', [AX, AY]);
//Logger.Send([lcInfo], 'MapCell GhostId= 0x%.4x TileId= 0x%.4x Id= 0x%.4x', [cell.RawTileID, cell.TileID, cell.ID]);
inc(selecetion.Left, -1); inc(selecetion.Top, -1);
if not IsInRect(AX, AY, selecetion) then exit;
inc(selecetion.Left, +1); inc(selecetion.Top, +1);
if (AX = selecetion.Left) then begin
AddGhostTile(selecetion.Left-1, AY, ABaseTile, selecetion);
end;
if (AY = selecetion.Top) then begin
AddGhostTile(AX, selecetion.Top-1, ABaseTile, selecetion);
end;
if (AX = selecetion.Left) and (AY = selecetion.Top) then begin
AddGhostTile(selecetion.Left-1, selecetion.Top-1, ABaseTile, selecetion);
end;
if (AX = selecetion.Right) and (AY = selecetion.Bottom)
then randalt := GetTileId(PGroupBrush(tileInfo^.ptr), $01, cell.RawTileID)
else if (AX = selecetion.Left-1) and (AY = selecetion.Bottom)
then randalt := GetTileId(PGroupBrush(tileInfo^.ptr), $02, cell.RawTileID)
else if (AX = selecetion.Left-1) and (AY = selecetion.Top-1)
then randalt := GetTileId(PGroupBrush(tileInfo^.ptr), $04, cell.RawTileID)
else if (AX = selecetion.Right) and (AY = selecetion.Top-1)
then randalt := GetTileId(PGroupBrush(tileInfo^.ptr), $08, cell.RawTileID)
else if (AX = selecetion.Right)
then randalt := GetTileId(PGroupBrush(tileInfo^.ptr), $09, cell.RawTileID)
else if (AY = selecetion.Bottom)
then randalt := GetTileId(PGroupBrush(tileInfo^.ptr), $03, cell.RawTileID)
else if (AY = selecetion.Top-1)
then randalt := GetTileId(PGroupBrush(tileInfo^.ptr), $0C, cell.RawTileID)
else if (AX = selecetion.Left-1)
then randalt := GetTileId(PGroupBrush(tileInfo^.ptr), $06, cell.RawTileID)
else randalt := GetTileId(PGroupBrush(tileInfo^.ptr), $0F, cell.RawTileID);
if (randalt > 0) then begin //Добавление текстур
cell.IsGhost := True;
cell.GhostID := randalt;
if frmDrawSettings.cbForceAltitude.Checked then
cell.GhostZ := frmDrawSettings.seForceAltitude.Value
else
cell.GhostZ := cell.RawZ;
if frmDrawSettings.cbRandomHeight.Checked then
cell.GhostZ := cell.GhostZ + Random(frmDrawSettings.seRandomHeight.Value);
PrepareMapCell(cell);
end;
end;
end else if tileInfo^.ID > $1F000000 then
begin // **** Объекты *****
for i := 0 to PGroupEntry(tileInfo^.ptr)^.Count - 1 do begin
if frmDrawSettings.cbUseFreeTilesOnly.Checked then begin
blockInfo := FScreenBuffer.Find(AX + PGroupEntry(tileInfo^.ptr)^.ETile[i].X,
AY + PGroupEntry(tileInfo^.ptr)^.ETile[i].Y);
if (blockInfo <> nil) and (blockInfo^.Next <> nil) and
(blockInfo^.Item.X = blockInfo^.Next^.Item.X) and (blockInfo^.Item.Y = blockInfo^.Next^.Item.Y)
then exit;
end;
end;
if frmDrawSettings.cbRandomHeight.Checked
then randalt := Random(frmDrawSettings.seRandomHeight.Value)
else randalt := 0;
for i := 0 to PGroupEntry(tileInfo^.ptr)^.Count - 1 do begin
ghostTile := TGhostTile.Create(nil, nil, 0, 0);
ghostTile.TileID := PGroupEntry(tileInfo^.ptr)^.ETile[i].ID - $4000;
ghostTile.Hue := PGroupEntry(tileInfo^.ptr)^.ETile[i].Hue;
ghostTile.X := AX + PGroupEntry(tileInfo^.ptr)^.ETile[i].X;
ghostTile.Y := AY + PGroupEntry(tileInfo^.ptr)^.ETile[i].Y;
ghostTile.CenterX := AX;
ghostTile.CenterY := AY;
if ((not frmDrawSettings.cbForceAltitude.Enabled) or (not frmDrawSettings.cbForceAltitude.Checked)) then
begin
if frmDrawSettings.cbUseSurfaceAltitude.Checked then begin
blockInfo := FScreenBuffer.Find(AX, AY);
if blockInfo <> nil then
ABaseTile := blockInfo^.Item;
ghostTile.Z := ABaseTile.Z;
end;
if ABaseTile is TStaticItem then
ghostTile.Z := ABaseTile.Z + ResMan.Tiledata.StaticTiles[ABaseTile.TileID].Height
else if ABaseTile is TMapCell then
ghostTile.Z := ResMan.Landscape.GetEffectiveAltitude(TMapCell(ABaseTile))
else // if ABaseTile is TVirtualTile then
ghostTile.Z := ABaseTile.Z;
end else
ghostTile.Z := frmDrawSettings.seForceAltitude.Value;
ghostTile.Z := ghostTile.Z + randalt + PGroupEntry(tileInfo^.ptr)^.ETile[i].Z;;
{
Logger.Send([lcInfo], ' <Entry Id="%.4d Tile %.2d/%.2d - Id="0x%.4x" Hue="0x%.3x" X="%d" Y="%d" Z="%d">',
[PGroupEntry(tileInfo^.ptr)^.ID, i, PGroupEntry(tileInfo^.ptr)^.Count, ghostTile.TileID,
ghostTile.Hue, ghostTile.X, ghostTile.Y, ghostTile.Z]);
}
ghostTile.UpdatePriorities(ResMan.Tiledata.StaticTiles[ghostTile.TileID], MaxInt);
ghostTile.CanBeEdited := True;
FVirtualTiles.Add(ghostTile);
blockInfo := FScreenBuffer.Insert(ghostTile);
blockInfo^.State := ssGhost;
PrepareScreenBlock(blockInfo);
end;
end else if tileInfo^.ID < $4000 then
begin // **** Текстуры ****
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
cell := FLandscape.MapCell[AX, AY];
if cell <> nil then
begin
cell.IsGhost := True;
cell.GhostID := tileInfo^.ID;
if frmDrawSettings.cbForceAltitude.Checked then
cell.GhostZ := frmDrawSettings.seForceAltitude.Value
else
cell.GhostZ := cell.RawZ;
if frmDrawSettings.cbRandomHeight.Checked then
cell.GhostZ := cell.GhostZ + Random(frmDrawSettings.seRandomHeight.Value);
PrepareMapCell(cell);
end;
end else
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
begin // **** Статика *****
if frmDrawSettings.cbUseFreeTilesOnly.Checked then begin
blockInfo := FScreenBuffer.Find(AX, AY);
if (blockInfo <> nil) and (blockInfo^.Next <> nil) and
(blockInfo^.Item.X = blockInfo^.Next^.Item.X) and (blockInfo^.Item.Y = blockInfo^.Next^.Item.Y)
then exit;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
ghostTile := TGhostTile.Create(nil, nil, 0, 0);
ghostTile.TileID := tileInfo^.ID - $4000;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
ghostTile.Hue := frmHueSettings.GetHue;
ghostTile.X := AX; ghostTile.CenterX := AX;
ghostTile.Y := AY; ghostTile.CenterY := AY;
if ((not frmDrawSettings.cbForceAltitude.Enabled) or (not frmDrawSettings.cbForceAltitude.Checked)) then
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if frmDrawSettings.cbUseSurfaceAltitude.Checked then begin
blockInfo := FScreenBuffer.Find(AX, AY);
if blockInfo <> nil then
ABaseTile := blockInfo^.Item;
end;
//ghostTile.Z := ABaseTile.Z;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if ABaseTile is TStaticItem then
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
ghostTile.Z := ABaseTile.Z + ResMan.Tiledata.StaticTiles[ABaseTile.TileID].Height
else if ABaseTile is TMapCell then
ghostTile.Z := ResMan.Landscape.GetEffectiveAltitude(TMapCell(ABaseTile))
else // if ABaseTile is TVirtualTile then
ghostTile.Z := ABaseTile.Z;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end else
ghostTile.Z := frmDrawSettings.seForceAltitude.Value;
if frmDrawSettings.cbRandomHeight.Checked then
ghostTile.Z := ghostTile.Z +
Random(frmDrawSettings.seRandomHeight.Value);
ghostTile.UpdatePriorities(ResMan.Tiledata.StaticTiles[ghostTile.TileID],
MaxInt);
ghostTile.CanBeEdited := True;
FVirtualTiles.Add(ghostTile);
blockInfo := FScreenBuffer.Insert(ghostTile);
blockInfo^.State := ssGhost;
PrepareScreenBlock(blockInfo);
end;
end;
end;
var
selectedRect: TRect;
blockInfo: PBlockInfo;
item: TWorldItem;
cell: TMapCell;
i, tileX, tileY: Integer;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
brushMod: Boolean; // Актевирован Режим работы с кистями
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
//Logger.EnterMethod([lcClient, lcDebug], 'UpdateSelection');
//If the current tile is nil, but we still have a selected tile, the
//procedure is pointless - the selection should stay intact.
if (CurrentTile <> nil) or (SelectedTile = nil) then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
brushMod := (vdtTiles.GetFirstSelected <> nil) and (PTileInfo(vdtTiles.GetNodeData(vdtTiles.GetFirstSelected))^.ID >= $2F000000);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if CurrentTile = nil then
selectedRect := Rect(-1, -1, -1, -1)
else
selectedRect := GetSelectedRect;
//clean up old ghost tiles
//Logger.Send([lcClient, lcDebug], 'Cleaning ghost tiles');
for i := FVirtualTiles.Count - 1 downto 0 do
begin
item := FVirtualTiles[i];
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if (item is TGhostTile) and not IsInRect((item as TGhostTile).CenterX,
(item as TGhostTile).CenterY, selectedRect) then
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
FScreenBuffer.Delete(item);
FVirtualTiles.Delete(i);
end;
end;
//Logger.Send([lcClient, lcDebug], 'FSelection', FSelection);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if brushMod then begin // Для кистей
i:= -1; inc(selectedRect.Left, -1); inc(selectedRect.Top, -1);
end else i:= 0;
for tileX := FSelection.Left+i to FSelection.Right do
for tileY := FSelection.Top+i to FSelection.Bottom do
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if not IsInRect(tileX, tileY, selectedRect) then
begin
cell := FLandscape.MapCell[tileX, tileY];
if (cell <> nil) and cell.IsGhost then
begin
cell.IsGhost := False;
PrepareMapCell(cell);
end;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if brushMod then begin // Для кистей
inc(selectedRect.Left, +1); inc(selectedRect.Top, +1);
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if (CurrentTile <> nil) and (not acSelect.Checked) then
begin
blockInfo := nil;
if (SelectedTile <> nil) and (CurrentTile <> SelectedTile) then
begin
{Logger.Send([lcClient, lcDebug], 'Multiple Targets');
Logger.Send([lcClient, lcDebug], 'SelectedRect', selectedRect);}
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
//Logger.Send([lcClient, lcDebug], 'SelectedTile: %.5x (%.6d)', [SelectedTile.TileID, SelectedTile.TileID]);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
//set new ghost tiles
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if acDraw.Checked then begin
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
for tileX := selectedRect.Left to selectedRect.Right do
for tileY := selectedRect.Top to selectedRect.Bottom do
if not IsInRect(tileX, tileY, FSelection) then
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
AddGhostTile(tileX, tileY, SelectedTile, selectedRect);
if brushMod then begin // Для кистей
if (selectedRect.Left > FSelection.Left) then
for tileY := selectedRect.Top to selectedRect.Bottom do
AddGhostTile(selectedRect.Left, tileY, SelectedTile, selectedRect);
if (selectedRect.Top > FSelection.Top) then
for tileX := selectedRect.Left to selectedRect.Right do
AddGhostTile(tileX, selectedRect.Top, SelectedTile, selectedRect);
if (selectedRect.Right < FSelection.Right) then
for tileY := selectedRect.Top to selectedRect.Bottom do
AddGhostTile(selectedRect.Right, tileY, SelectedTile, selectedRect);
if (selectedRect.Bottom < FSelection.Bottom) then
for tileX := selectedRect.Left to selectedRect.Right do
AddGhostTile(tileX, selectedRect.Bottom, SelectedTile, selectedRect);
if (selectedRect.Right > FSelection.Right) then
for tileY := FSelection.Top to FSelection.Bottom do
AddGhostTile(FSelection.Right, tileY, SelectedTile, selectedRect);
if (selectedRect.Bottom > FSelection.Bottom) then
for tileX := FSelection.Left to FSelection.Right do
AddGhostTile(tileX, FSelection.Bottom, SelectedTile, selectedRect);
end;
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
while FScreenBuffer.Iterate(blockInfo) do
if (blockInfo^.State = ssNormal) then
SetHighlight(blockInfo, IsInRect(blockInfo^.Item.X, blockInfo^.Item.Y,
selectedRect) and not acDraw.Checked);
end else
begin
//Logger.Send([lcClient, lcDebug], 'Single Target');
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
//Logger.Send([lcClient, lcDebug], 'CurrentTile: %.5x (%.6d)', [CurrentTile.TileID, CurrentTile.TileID]);
if acDraw.Checked and not IsInRect(CurrentTile.X, CurrentTile.Y, FSelection) then
AddGhostTile(CurrentTile.X, CurrentTile.Y, CurrentTile, selectedRect);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
while FScreenBuffer.Iterate(blockInfo) do
if blockInfo^.State = ssNormal then
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
SetHighlight(blockInfo, (blockInfo^.Item = CurrentTile) and not acDraw.Checked);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
FSelection := selectedRect;
end;
{Logger.Send([lcClient, lcDebug], 'Virtual Tiles', FVirtualTiles.Count);
Logger.ExitMethod([lcClient, lcDebug], 'UpdateSelection');}
end;
procedure TfrmMain.OnTileRemoved(ATile: TMulBlock);
begin
if ATile = FCurrentTile then
FCurrentTile := nil
else if ATile = FSelectedTile then
FSelectedTile := nil;
end;
procedure TfrmMain.WriteChatMessage(ASender, AMessage: string);
var
node: PVirtualNode;
chatInfo: PChatInfo;
begin
node := vstChat.AddChild(nil);
chatInfo := vstChat.GetNodeData(node);
chatInfo^.Time := Now;
chatInfo^.Sender := ASender;
chatInfo^.Msg := AMessage;
if vstChat.RootNodeCount > 30 then
vstChat.DeleteNode(vstChat.GetFirst);
vstChat.ScrollIntoView(node, False);
if not pnlChat.Visible then
begin
lblChatHeaderCaption.Font.Bold := True;
lblChatHeaderCaption.Font.Italic := True;
lblChatHeaderCaption.Font.Color := clRed;
end;
end;
procedure TfrmMain.OnClientHandlingPacket(ABuffer: TEnhancedMemoryStream);
var
sender, msg: string;
i: Integer;
accessLevel: TAccessLevel;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
clientNode: PVirtualNode;
clientInfo: PClientInfo;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
case ABuffer.ReadByte of
$01: //client connected
begin
sender := ABuffer.ReadStringNull;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
vstClients.BeginUpdate;
clientNode := vstClients.AddChild(nil);
clientInfo := vstClients.GetNodeData(clientNode);
clientInfo^.Name := sender;
clientInfo^.AccessLevel := TAccessLevel(ABuffer.ReadByte);
clientInfo^.LogonDateTime := Now;
vstClients.EndUpdate;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if sender <> dmNetwork.Username then
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
WriteChatMessage('System', Format(lbUserLoginedMsg, [sender]));
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
$02:
begin
sender := ABuffer.ReadStringNull;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
vstClients.BeginUpdate;
clientNode := vstClients.GetFirst;
while clientNode <> nil do begin
clientInfo := vstClients.GetNodeData(clientNode);
if (clientInfo^.Name = sender)
then begin
vstClients.DeleteNode(clientNode);
break;
end
else clientNode := vstClients.GetNext(clientNode);
end;
vstClients.EndUpdate;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
if sender <> dmNetwork.Username then
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
WriteChatMessage('System', Format(lbUserLogoutedMsg, [sender]));
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
$03: //Client list
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
vstClients.Clear;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
while ABuffer.Position < ABuffer.Size do
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
begin
sender := ABuffer.ReadStringNull;
clientNode := vstClients.AddChild(nil);
clientInfo := vstClients.GetNodeData(clientNode);
clientInfo^.Name := sender;
clientInfo^.AccessLevel := TAccessLevel(ABuffer.ReadByte);
clientInfo^.LogonDateTime := IncSecond(dmNetwork.ServerStart, ABuffer.ReadDWord);
end;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
$04: //Set pos
begin
FX := ABuffer.ReadWord;
FY := ABuffer.ReadWord;
SetPos(FX, FY);
end;
$05: //chat
begin
sender := ABuffer.ReadStringNull;
msg := ABuffer.ReadStringNull;
WriteChatMessage(sender, msg);
end;
$07: //access changed
begin
accessLevel := TAccessLevel(ABuffer.ReadByte);
FLandscape.UpdateWriteMap(ABuffer);
FRepaintNeeded := True;
if accessLevel <> dmNetwork.AccessLevel then
begin
dmNetwork.AccessLevel := accessLevel;
if accessLevel = alNone then
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
MessageDlg(lbDlgBlockedAccessCaption, lbDlgBlockedAccess, mtWarning, [mbOK], 0);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
mnuDisconnectClick(nil);
end else
begin
ProcessAccessLevel;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
MessageDlg(lbDlgCnangedAccessCaption, Format(lbDlgCnangedAccess, [GetAccessLevel(accessLevel)]), mtWarning, [mbOK], 0);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
end;
for i := FAccessChangedListeners.Count - 1 downto 0 do
FAccessChangedListeners[i](accessLevel);
end;
end;
end;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
function TfrmMain.GetInternalTileID(ATile: TWorldItem): LongWord;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
Result := ATile.TileID;
if ATile is TStaticItem then
Inc(Result, $4000);
end;
function TfrmMain.GetSelectedRect: TRect;
begin
if CurrentTile <> nil then
begin
if SelectedTile <> nil then
begin
Result.Left := Min(CurrentTile.X, SelectedTile.X);
Result.Top := Min(CurrentTile.Y, SelectedTile.Y);
Result.Right := Max(CurrentTile.X, SelectedTile.X);
Result.Bottom := Max(CurrentTile.Y, SelectedTile.Y);
end else
begin
Result.Left := CurrentTile.X;
Result.Top := CurrentTile.Y;
Result.Right := CurrentTile.X;
Result.Bottom := CurrentTile.Y;
end;
end;
end;
function TfrmMain.ConfirmAction: Boolean;
begin
if acMove.Checked and frmMoveSettings.cbAsk.Checked then
begin
Result := frmMoveSettings.ShowModal = mrYes;
end else
if not mnuSecurityQuestion.Checked then
begin
Result := True;
end else
begin
frmConfirmation.Left := Mouse.CursorPos.x - frmConfirmation.btnYes.Left - frmConfirmation.btnYes.Width div 2;
frmConfirmation.Top := Mouse.CursorPos.y - frmConfirmation.btnYes.Top - frmConfirmation.btnYes.Height div 2;
Result := frmConfirmation.ShowModal = mrYes;
end;
if not oglGameWindow.MouseEntered then
oglGameWindowMouseLeave(nil);
end;
function TfrmMain.FindRandomPreset(AName: String): TDOMElement;
var
preset: TDOMElement;
presets: TDOMNodeList;
i: Integer;
begin
presets := FRandomPresetsDoc.DocumentElement.ChildNodes;
Result := nil;
i := 0;
while (i < presets.Count) and (Result = nil) do
begin
preset := TDOMElement(presets[i]);
if SameText(preset.AttribStrings['Name'], AName) then
Result := preset
else
Inc(i);
end;
end;
procedure TfrmMain.ForceUpdateCurrentTile;
begin
CurrentTile := nil;
UpdateCurrentTile;
end;
procedure TfrmMain.GetDrawOffset(AX, AY: Integer; out DrawX, DrawY: Integer); inline;
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
var
zoom: Single;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
begin
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
if tbZoom.Down then zoom := tbZoom.Tag / 1000.0 else zoom := 1.0;
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
Dec(AX, FX);
Dec(AY, FY);
* Added CentrED+ code (thanks to StaticZ for his awesome work!)
2015-05-01 12:23:03 +02:00
DrawX := (oglGameWindow.Width div 2) + Trunc((AX - AY) * 22 * zoom);
DrawY := (oglGamewindow.Height div 2) + Trunc((AX + AY) * 22 * zoom);
- Fixed gamewindow not resetting the clear-color
2009-12-22 21:37:16 +01:00
end;
initialization
{$I UfrmMain.lrs}
end.