(* * 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, 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; // Количество элементов в списке отмены type TAccessChangedListener = procedure(AAccessLevel: TAccessLevel) of object; TSelectionListener = procedure(AWorldItem: TWorldItem) of object; TScreenBufferState = (sbsValid, sbsIndexed, sbsFiltered); TScreenBufferStates = set of TScreenBufferState; TBlockInfoList = specialize TFPGList; TGhostTile = class(TStaticItem) public CenterX, CenterY: Word; // Точки привязки к курсору (центральный тайл для объектов размером больше 1 тайла) end; TPacketList = specialize TFPGObjectList; PPacketList = ^TPacketList; TAccessChangedListeners = specialize TFPGList; TSelectionListeners = specialize TFPGList; TTileHintInfo = record Column: Byte; Obj: String; Name: String; Flags: String; ObjRect: TRect; NameRect: TRect; FlagsRect: TRect; end; 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; // Число тайлов перехода (в ) EdgeId: ^PWord; // �ндификаторы кистей переходов (ссылка на кисть в ) 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; { 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; acTerrain: TAction; acStatics: TAction; acSelection: TAction; acSurfElevate: TAction; acSurfStretch: TAction; acSurfSmooth: TAction; acFill: TAction; acRedo: TAction; acWalkable: TAction; 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; edX: TSpinEdit; edY: TSpinEdit; gbRandom: TGroupBox; gbGoTo: TGroupBox; ImageList1: TImageList; lblTileInfoOLabel: TLabel; lblTileInfoIDLabel: TLabel; lblTileInfoHLabel: TLabel; lblTileInfoIDValue: TLabel; lblTileInfoCLabel: TLabel; lblTileInfoWLabel: TLabel; lblTileInfoYLabel: TLabel; lblTileInfoXValue: TLabel; lblTileInfoXLabel: TLabel; lblTileInfoZValue: TLabel; lblTileInfoHueValue: TLabel; lblTileInfoHueLabel: TLabel; lblChatHeaderCaption: TLabel; lblFilter: TLabel; lblTileInfoZLabel: TLabel; lblTileInfoYValue: TLabel; lblTileInfoHValue: TLabel; lblTileInfoWValue: TLabel; lblX: TLabel; lblY: TLabel; MainMenu1: TMainMenu; 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; mnuWhiteBackground: TMenuItem; 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; pbRadar: TPaintBox; pcLeft: TPageControl; pmZoomSettings: TPopupMenu; pmViewTerrainSettings: TPopupMenu; pmGrabTileInfo: TPopupMenu; pmNoDrawSettings: TPopupMenu; pmViewStaticSettings: TPopupMenu; pmTileList: TPopupMenu; pmTools: TPopupMenu; pmClients: TPopupMenu; pnlChat: TPanel; pnlChatHeader: TPanel; pmFlatViewSettings: TPopupMenu; spChat: TSplitter; spGroupList1: TSplitter; spTileList: TSplitter; spGroupList: TSplitter; tbFill: TToolButton; tbSurfSmooth: TToolButton; tbSurfStretch: TToolButton; tbSurfElevate: TToolButton; tbSelection: TToolButton; tbFilter: TToolButton; tbFlat: TToolButton; tbSeparator6: TToolButton; tbSeparator7: TToolButton; tbSeparator8: TToolButton; tbSeparator9: TToolButton; tbRedo: TToolButton; tbZoom: TToolButton; tbNoDraw: TToolButton; tbSeparator2: TToolButton; tbUndo: TToolButton; tbLightlevel: TToolButton; tbWalkable: TToolButton; tmSelectNode: TTimer; tmSettingsClose: TTimer; tsNavigation: TTabSheet; tbSetHue: TToolButton; tmGrabTileInfo: TTimer; tmMovement: TTimer; tbSeparator5: TToolButton; tbRadarMap: TToolButton; tbVirtualLayer: TToolButton; tsObjects: TTabSheet; 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; tvGroups: TVirtualStringTree; vdtTiles: TVirtualList; vdtRandom: TVirtualDrawTree; vdlRandom: TVirtualList; vstChat: TVirtualStringTree; vstLocations: TVirtualStringTree; vstClients: TVirtualStringTree; XMLPropStorage1: TXMLPropStorage; procedure acBoundariesExecute(Sender: TObject); procedure acDeleteExecute(Sender: TObject); procedure acDrawExecute(Sender: TObject); procedure acElevateExecute(Sender: TObject); procedure acFillExecute(Sender: TObject); 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); procedure acSelectionExecute(Sender: TObject); procedure acStaticsExecute(Sender: TObject); procedure acSurfElevateExecute(Sender: TObject); procedure acSurfSmoothExecute(Sender: TObject); procedure acSurfStretchExecute(Sender: TObject); procedure acTerrainExecute(Sender: TObject); procedure acUndoExecute(Sender: TObject); procedure acVirtualLayerExecute(Sender: TObject); procedure acWalkableExecute(Sender: TObject); procedure acGridExecute(Sender: TObject); procedure ApplicationProperties1Idle(Sender: TObject; var Done: Boolean); procedure ApplicationProperties1ShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo); 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); procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure FormShow(Sender: TObject); procedure FormWindowStateChange(Sender: TObject); procedure lblChatHeaderCaptionClick(Sender: TObject); procedure lblChatHeaderCaptionMouseEnter(Sender: TObject); procedure lblChatHeaderCaptionMouseLeave(Sender: TObject); procedure mnuAboutClick(Sender: TObject); procedure mnuAccountControlClick(Sender: TObject); procedure mnuAutoHideGroupListClick(Sender: TObject); procedure mnuAutoHideRandomListClick(Sender: TObject); procedure mnuAutoShowFilterWindowClick(Sender: TObject); procedure mnuCompactHueSettingsClick(Sender: TObject); procedure mnuDisconnectClick(Sender: TObject); procedure mnuDocsClick(Sender: TObject); procedure mnuEng2ComClick(Sender: TObject); procedure mnuEngComClick(Sender: TObject); procedure mnuExitClick(Sender: TObject); procedure mnuFlatShowHeightClick(Sender: TObject); procedure mnuFlushClick(Sender: TObject); procedure mnuGoToClientClick(Sender: TObject); procedure GrabBoundaries(Sender: TObject); procedure mnuGrabFilterHueClick(Sender: TObject); procedure mnuGrabFilterTileIDClick(Sender: TObject); procedure mnuGrabHueClick(Sender: TObject); procedure mnuGrabTileIDClick(Sender: TObject); procedure mnuGrabVirtualLayerZClick(Sender: TObject); procedure mnuLargeScaleCommandsClick(Sender: TObject); procedure mnuMakeScreenShotClick(Sender: TObject); procedure mnuRegionControlClick(Sender: TObject); procedure mnuReloadGroupsClick(Sender: TObject); procedure mnuRusComClick(Sender: TObject); procedure mnuSetLanguageClick(Sender: TObject); procedure mnuShowAnimationsClick(Sender: TObject); procedure mnuShowBlocksClick(Sender: TObject); procedure mnuShowBridgesClick(Sender: TObject); procedure mnuShowGridClick(Sender: TObject); procedure mnuShowLightSourceClick(Sender: TObject); procedure mnuShowNoDrawTilesClick(Sender: TObject); procedure mnuShowStaticsOptionClick(Sender: TObject); procedure mnuShutdownClick(Sender: TObject); procedure mnuTileListDrawClick(Sender: TObject); procedure mnuTileListViewClick(Sender: TObject); procedure mnuWhiteBackgroundClick(Sender: TObject); procedure mnuWindowedModeClick(Sender: TObject); procedure mnuZoomClick(Sender: TObject); procedure oglGameWindowClick(Sender: TObject); procedure oglGameWindowDblClick(Sender: TObject); procedure oglGameWindowKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); 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); procedure pbRadarMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure pbRadarPaint(Sender: TObject); procedure pcLeftChange(Sender: TObject); procedure pcLeftResize(Sender: TObject); procedure pmGrabTileInfoPopup(Sender: TObject); procedure DropedownMenusClose(Sender: TObject); 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); procedure tbRadarMapClick(Sender: TObject); procedure tmGrabTileInfoTimer(Sender: TObject); procedure tmMovementTimer(Sender: TObject); procedure tmSelectNodeTimer(Sender: TObject); procedure tmSettingsCloseTimer(Sender: TObject); procedure tsNavigationContextPopup(Sender: TObject; MousePos: TPoint; var Handled: Boolean); procedure tvGroupFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure tvGroupsChange(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure tvGroupsDrawText(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; 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); 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); procedure vdtTilesChange(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure vdtTilesClick(Sender: TObject); procedure vdtTilesDragAllowed(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); 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); 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); 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); procedure XMLPropStorage1SavingProperties(Sender: TObject); protected { Members } FAppDir: String; // .\ FLocalDir: String; // .\..\LocalData\ FConfigDir: String; // {$User}\AppData\Local\CentrED-plus\ - зависит от реестра FProfileDir: String; // {$User}\AppData\Local\CentrED-plus\Profiles\{$Profile}\ - зависит от реестра 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; FVLightSrcImage: array[1..FVLightSrcImageCount] of TSingleImage; FVLightSrcMaterial: ^TMaterial; FOverlayUI: TOverlayUI; FLocationsFile: string; FRandomPresetsFile: string; FRandomPresetsDoc: TXMLDocument; FLastDraw: TDateTime; FAccessChangedListeners: TAccessChangedListeners; FRepaintNeeded: Boolean; FSelection: TRect; 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; FGLFont: TGLFont; FSelectionListeners: TSelectionListeners; FTileHint: TTileHintInfo; FLightManager: TLightManager; FVisibleTiles: TBits; FLightSourceTiles: PLightTile; { Methods } 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; procedure BuildTileList; procedure FreeGroupLists; function ConfirmAction: Boolean; function FindRandomPreset(AName: String): TDOMElement; procedure ForceUpdateCurrentTile; procedure GetDrawOffset(AX, AY: Integer; out DrawX, DrawY: Integer); inline; function GetInternalTileID(ATile: TWorldItem): LongWord; 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; property AppDir: string read FAppDir; property LocalDir: string read FLocalDir; property ConfigDir: string read FConfigDir; property ProfileDir: string read FProfileDir; { 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); 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; end; var frmMain: TfrmMain; implementation uses UdmNetwork, UArt, UTexture, UHue, UTiledata, UAdminHandling, UPackets, UfrmAccountControl, UGraphicHelper, ImagingComponents, UfrmDrawSettings, UfrmBoundaries, UfrmElevateSettings, UfrmConfirmation, UfrmMoveSettings, UfrmAbout, UPacketHandlers, UfrmHueSettings, UfrmRadar, UfrmLargeScaleCommand, UfrmLogin, UResourceManager, UfrmVirtualLayer, UfrmFilter, UfrmRegionControl, Logging, LConvEncoding, LCLType, UfrmLightlevel, vinfo, Imaging, Language, UfrmEditAccount, UfrmFillSettings, UfrmSelectionSettings, UfrmInitialize, UfrmSurfElevateSettings, UfrmSurfStretchSettings, UfrmSurfSmoothSettings, Crc32Hash; {$I version.inc} type TGLArrayf4 = array[0..3] of GLfloat; PTileInfo = ^TTileInfo; TTileInfo = record ID: LongWord; ptr: Pointer; end; PChatInfo = ^TChatInfo; TChatInfo = record Time: TDateTime; Sender: string; Msg: string; end; PLocationInfo = ^TLocationInfo; TLocationInfo = record X: Word; Y: Word; Name: string; end; PClientInfo = ^TClientInfo; TClientInfo = record Name: string; AccessLevel: TAccessLevel; LogonDateTime : TDateTime; //Time: string; //Map: Byte; //X: Word; //Y: Word; end; 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 tbFlat.Down := acFlat.Checked; RebuildScreenBuffer; end; procedure TfrmMain.mnuShowNoDrawTilesClick(Sender: TObject); begin tbNoDraw.Down := acNoDraw.Checked; RebuildScreenBuffer; FRepaintNeeded := True; end; procedure TfrmMain.mnuShowLightSourceClick(Sender: TObject); begin tbNoDraw.Down := acNoDraw.Checked; RebuildScreenBuffer; FRepaintNeeded := True; end; procedure TfrmMain.mnuShowGridClick(Sender: TObject); begin 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 begin clientInfo := vstClients.GetNodeData(node); dmNetwork.Send(TGotoClientPosPacket.Create(clientInfo^.Name)); end; end; procedure TfrmMain.mnuGrabTileIDClick(Sender: TObject); var internalTileID: LongWord; item: PVirtualItem; tileInfo: PTileInfo; 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; begin Logger.Send([lcClient, lcDebug], 'TfrmMain.mnuGrabTileIDClick', TRUE); if CurrentTile <> nil then begin internalTileID := GetInternalTileID(CurrentTile); // Выбираем группы 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 begin tileInfo := vdtTiles.GetNodeData(item); if tileInfo^.ID = internalTileID then begin vdtTiles.ClearSelection; vdtTiles.Selected[item] := True; vdtTiles.FocusedNode := item; Break; end; item := vdtTiles.GetNext(item); end; end; 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; 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; procedure TfrmMain.mnuShowBridgesClick(Sender: TObject); begin end; procedure TfrmMain.mnuShutdownClick(Sender: TObject); begin dmNetwork.Send(TQuitServerPacket.Create('')); end; procedure TfrmMain.mnuWhiteBackgroundClick(Sender: TObject); begin FRepaintNeeded := True; end; 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; 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); var step, zoomfactor: Integer; begin 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; case Key of 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; 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); if Button = mbMiddle then tmGrabTileInfoTimer(Sender); 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; if (frmFilter.Visible and mnuAutoShowFilterWindow.Checked) then 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; targetBlocks: TBlockInfoList; //а в чем разница с targetTiles: TWorldItemList; ? 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; FUndoList := GetNextUndoList; if (SelectedTile = targetTile) or ConfirmAction then begin if acDraw.Checked then //***** Drawing Mode *****// begin for tileX := FSelection.Left-1 to FSelection.Right do for tileY := FSelection.Top-1 to FSelection.Bottom do begin map := FLandscape.MapCell[tileX, tileY]; if map.IsGhost then begin FUndoList^.Add(TDrawMapPacket.Create(tileX, tileY, map.RawZ, map.RawTileID)); dmNetwork.Send(TDrawMapPacket.Create(tileX, tileY, map.Z, map.TileID)); 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 dmNetwork.Send(TInsertStaticPacket.Create(tile.X, tile.Y, tile.Z, tile.TileID, TGhostTile(tile).Hue)); FUndoList^.Add(TDeleteStaticPacket.Create(TGhostTile(tile))); 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 targetBlocks := TBlockInfoList.Create; if SelectedTile = targetTile then begin blockInfo := nil; while FScreenBuffer.Iterate(blockInfo) do begin if blockInfo^.Item = targetTile then begin targetBlocks.Add(blockInfo); Break; end; end; 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 targetBlocks.Add(blockInfo); end; end; end; if acMove.Checked then //***** Move tile *****// begin offsetX := frmMoveSettings.GetOffsetX; offsetY := frmMoveSettings.GetOffsetY; 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 begin if frmMoveSettings.cbLand.Checked and (((offsetY > 0) or (offsetX > 0)) and not ((offsetY > 0) and (offsetX < 0))) then tileY := abs(i - targetBlocks.Count + 1) else tileY := i; tile := targetBlocks.Items[tileY]^.Item; if (frmMoveSettings.cbItem.Checked) and (tile is TStaticItem) then begin newX := EnsureRange(tile.X + offsetX, 0, FLandscape.CellWidth - 1); newY := EnsureRange(tile.Y + offsetY, 0, FLandscape.CellHeight - 1); FUndoList^.Add(TMoveStaticPacket.Create(newX, newY, tile.Z, tile.TileID, TStaticItem(tile).Hue, tile.X, tile.Y)); dmNetwork.Send(TMoveStaticPacket.Create(TStaticItem(tile), newX, newY)); 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)); end; end; end else if acElevate.Checked then //***** Elevate tile *****// begin for i := 0 to targetBlocks.Count - 1 do begin tile := targetBlocks.Items[i]^.Item; 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)); FUndoList^.Add(TDrawMapPacket.Create(tile.X, tile.Y, tile.Z, tile.TileID)); dmNetwork.Send(TDrawMapPacket.Create(tile.X, tile.Y, z, tile.TileID)); end else begin FUndoList^.Add(TElevateStaticPacket.Create(tile.X, tile.Y, z, tile.TileID, TStaticItem(tile).Hue, tile.Z)); dmNetwork.Send(TElevateStaticPacket.Create(TStaticItem(tile), z)); end; end; end else if acDelete.Checked then //***** Delete tile *****// begin Logger.Send([lcClient, lcDebug], 'targetBlocks.Count', targetBlocks.Count); for i := 0 to targetBlocks.Count - 1 do begin tile := targetBlocks.Items[i]^.Item; if tile is TStaticItem then begin FUndoList^.Add(TInsertStaticPacket.Create(tile.X, tile.Y, tile.Z, tile.TileID, TStaticItem(tile).Hue)); dmNetwork.Send(TDeleteStaticPacket.Create(TStaticItem(tile))); end; end; end else if acHue.Checked then //***** Hue tile *****// begin for i := 0 to targetBlocks.Count - 1 do begin blockInfo := targetBlocks.Items[i]; tile := blockInfo^.Item; if blockInfo^.HueOverride and (tile is TStaticItem) then begin 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)); dmNetwork.Send(THueStaticPacket.Create(TStaticItem(tile), blockInfo^.Hue)); end; end; end; blockInfo := nil; end; targetBlocks.Free; end; end; end; end; acUndo.Enabled := FUndoList^.Count > 0; 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; 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; 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 FUndoList := GetNextUndoList; newZ := EnsureRange(CurrentTile.Z + WheelDelta, -128, 127); if CurrentTile is TStaticItem then begin FUndoList^.Add(TElevateStaticPacket.Create(CurrentTile.X, CurrentTile.Y, 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 FUndoList^.Add(TDrawMapPacket.Create(CurrentTile.X, CurrentTile.Y, CurrentTile.Z, CurrentTile.TileID)); dmNetwork.Send(TDrawMapPacket.Create(CurrentTile.X, CurrentTile.Y, newZ, CurrentTile.TileID)); Handled := True; end; acUndo.Enabled := FUndoList^.Count > 0; 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); var i : Integer; ARegistry: TRegistry; begin 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); FAppDir := IncludeTrailingPathDelimiter(ExtractFilePath(Application.ExeName)); 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 := ''; ForceDirectories(FConfigDir); if (FProfileDir <> '') then XMLPropStorage1.FileName := FProfileDir + 'Config.xml' else XMLPropStorage1.FileName := FConfigDir + 'Config.xml'; 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; 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; 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; 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); vdtTiles.NodeDataSize := SizeOf(TTileInfo); vdlRandom.NodeDataSize := SizeOf(TTileInfo); //mnuTileListViewClick(nil); LoadEntryTilesList; LoadBrushTilesList; LoadSurfsTilesList; BuildGroupList; BuildTileList; Randomize; vstChat.NodeDataSize := SizeOf(TChatInfo); pnlChatHeader.AnchorSide[akBottom].Control := pcLeft; pnlChatHeader.AnchorSide[akBottom].Side := asrBottom; if FProfileDir <> '' then FLocationsFile := FProfileDir + 'Locations.xml' else FLocationsFile := FConfigDir + 'Locations.xml'; vstLocations.NodeDataSize := SizeOf(TLocationInfo); LoadLocations; vstClients.NodeDataSize := SizeOf(TClientInfo); Logger.Send([lcClient, lcInfo], 'RegisterPacketHandler()...'); RegisterPacketHandler($0C, TPacketHandler.Create(0, @OnClientHandlingPacket)); 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')); FGLFont := TGLFont.Create; FGLFont.LoadImage(ResourceManager.GetResource('GLFont/DejaVu.png')); FGLFont.LoadFontInfo(ResourceManager.GetResource('GLFont/DejaVu.fnt')); Logger.Send([lcClient, lcInfo], 'TWorldItemList.Create(True)...'); FVirtualTiles := TWorldItemList.Create(True); 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'; LoadRandomPresets; Logger.Send([lcClient, lcInfo], 'Завершение загрузки...'); DoubleBuffered := True; //pnlBottom.DoubleBuffered := True; FAccessChangedListeners := TAccessChangedListeners.Create; FSelectionListeners := TSelectionListeners.Create; FLastDraw := Now; Logger.ExitMethod([lcLandscape, lcDebug], 'TfrmMain.FormCreate(Sender: TObject)'); 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; tileNode: PVirtualItem; tileInfo: PTileInfo; begin presetName := cbRandomPreset.Text; if InputQuery(lbDlgSaveRandPrsCaption, lbDlgSaveRandPrs, presetName) then begin preset := FindRandomPreset(presetName); if preset = nil then begin preset := FRandomPresetsDoc.CreateElement('Preset'); preset.AttribStrings['Name'] := UTF8ToCP1251(presetName); 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; tileNode := vdlRandom.GetFirst; while tileNode <> nil do begin tileInfo := vdlRandom.GetNodeData(tileNode); tile := FRandomPresetsDoc.CreateElement('Tile'); tile.AttribStrings['ID'] := IntToStr(tileInfo^.ID); preset.AppendChild(tile); tileNode := vdlRandom.GetNext(tileNode); end; cbRandomPreset.ItemIndex := cbRandomPreset.Items.IndexOfObject(preset); SaveRandomPresets; end; end; procedure TfrmMain.cbRandomPresetChange(Sender: TObject); var preset, tile: TDOMElement; tiles: TDOMNodeList; tileNode: PVirtualItem; tileInfo: PTileInfo; i, id: Integer; begin if cbRandomPreset.ItemIndex > -1 then begin vdlRandom.Clear; 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 tileNode := vdlRandom.AddItem(nil); tileInfo := vdlRandom.GetNodeData(tileNode); tileInfo^.ID := id; end; end; end; end; procedure TfrmMain.btnAddRandomClick(Sender: TObject); var selected: PVirtualItem; node: PVirtualItem; sourceTileInfo, targetTileInfo: PTileInfo; begin vdlRandom.BeginUpdate; selected := vdtTiles.GetFirstSelected; while selected <> nil do begin sourceTileInfo := vdtTiles.GetNodeData(selected); node := vdlRandom.AddItem(nil); targetTileInfo := vdlRandom.GetNodeData(node); targetTileInfo^.ID := sourceTileInfo^.ID; targetTileInfo^.ptr := sourceTileInfo^.ptr; selected := vdtTiles.GetNextSelected(selected); end; vdlRandom.EndUpdate; end; procedure TfrmMain.btnClearLocationsClick(Sender: TObject); begin if MessageDlg(lbDlgDelConfCaption, lbDlgDelConf, 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) + Length(FTileHint.Obj) + Length(FTileHint.Flags)); end; procedure TfrmMain.btnAddLocationClick(Sender: TObject); var locationName: string; locationInfo: PLocationInfo; begin locationName := ''; if InputQuery(lbDlgNewQuerryCaption, lbDlgNewQuerry, 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; 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; procedure TfrmMain.acUndoExecute(Sender: TObject); var i: Integer; begin for i := FUndoList^.Count - 1 downto 0 do begin dmNetwork.Send(FUndoList^[i]); FUndoList^[i] := nil; end; 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; end; procedure TfrmMain.acVirtualLayerExecute(Sender: TObject); begin frmVirtualLayer.Show; end; 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; procedure TfrmMain.acWalkableExecute(Sender: TObject); begin InvalidateFilter; FRepaintNeeded := True; end; procedure TfrmMain.acGridExecute(Sender: TObject); begin end; procedure TfrmMain.acDrawExecute(Sender: TObject); begin acDraw.Checked := True; tbDrawTile.Down := True; mnuDraw.Checked := True; frmDrawSettings.Show; ProcessToolState; end; procedure TfrmMain.acFillExecute(Sender: TObject); begin acFill.Checked := True; tbFill.Down := True; mnuFill.Checked := True; frmFillSettings.Show; ProcessToolState; end; procedure TfrmMain.acDeleteExecute(Sender: TObject); begin acDelete.Checked := True; 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; 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; procedure TfrmMain.acFilterExecute(Sender: TObject); begin if acFilter.Checked then begin frmFilter.Show; frmFilter.Locked := False; if (tbFilter.Down) then begin frmFilter.tFormClose.Interval := 1500; frmFilter.tFormClose.Tag := PtrInt(True); frmFilter.tFormClose.Enabled := True; end; 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 vdlRandom.BeginUpdate; vdlRandom.Clear; vdlRandom.EndUpdate; end; procedure TfrmMain.btnDeleteLocationClick(Sender: TObject); begin vstLocations.DeleteSelectedNodes; end; procedure TfrmMain.btnDeleteRandomClick(Sender: TObject); begin vdlRandom.BeginUpdate; vdlRandom.DeleteSelectedNodes; vdlRandom.EndUpdate; end; procedure TfrmMain.cbStaticsChange(Sender: TObject); begin //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; end; procedure TfrmMain.cbTerrainChange(Sender: TObject); 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); begin if (not cbTerrain.Checked) and (not cbStatics.Checked) then 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); 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); 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; BuildTileList; end; procedure TfrmMain.FormActivate(Sender: TObject); begin Logger.EnterMethod([lcLandscape, lcDebug], 'TfrmMain.FormActivate(Sender: TObject)'); if oglGameWindow.MouseEntered then oglGameWindowMouseEnter(Sender); Logger.ExitMethod([lcLandscape, lcDebug], 'TfrmMain.FormActivate(Sender: TObject)'); end; procedure TfrmMain.FormClose(Sender: TObject; var CloseAction: TCloseAction); begin frmDrawSettings.rbTileList.Checked := True; frmDrawSettings.rbRandom.Checked := False; dmNetwork.CheckClose(Self); end; procedure TfrmMain.FormDestroy(Sender: TObject); var i: Integer; begin CurrentTile := nil; SelectedTile := nil; SaveLocations; SaveRandomPresets; FreeAndNil(FTextureManager); FreeAndNil(FScreenBuffer); FreeAndNil(FOverlayUI); FreeAndNil(FLightManager); FreeAndNil(FVLayerImage); FreeAndNil(FVLayerMaterial); 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; FreeAndNil(FVirtualTiles); for i:=1 to FUndoListLength do FreeAndNil(FUndoListArray[i]); FreeAndNil(FGLFont); FreeAndNil(FRandomPresetsDoc); FreeAndNil(FAccessChangedListeners); FreeAndNil(FSelectionListeners); FreeAndNil(FTilesSelectionUndoRedoManager); FreeAndNil(FGroupsSelectionUndoRedoManager); FreeAndNil(FTilesSelectionUndoRedoCommandGroup); FreeAndNil(FGroupsSelectionUndoRedoCommandGroup); 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; item: PVirtualItem; 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 MessageDlg(lbDlgSearchIdErrCaption, lbDlgSearchIdErr, mtError, [mbOK], 0); vdtTiles.SetFocus; Exit; end; if tileType = 'S' then Inc(tileID, $4000); item := vdtTiles.GetFirst; while item <> nil do begin tileInfo := vdtTiles.GetNodeData(item); if tileInfo^.ID = tileID then begin vdtTiles.ClearSelection; vdtTiles.Selected[item] := True; vdtTiles.FocusedNode := item; Break; end; item := vdtTiles.GetNext(item); end; if item = nil then begin MessageDlg(lbDlgNotFoundErrCaption, lbDlgNotFoundErr, mtError, [mbOK], 0); vdtTiles.SetFocus; Exit; end; edSearchID.Visible := False; end else if Key = #27 then begin edSearchID.Visible := False; Key := #0; 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 // �диотизм тот еще, но иначе приложение не коректно сворачивается // 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;} end; procedure TfrmMain.lblChatHeaderCaptionClick(Sender: TObject); begin if pnlChat.Visible then begin pnlChat.Visible := False; spChat.Visible := False; pnlChatHeader.AnchorSide[akBottom].Control := pcLeft; pnlChatHeader.AnchorSide[akBottom].Side := asrBottom; end else begin spChat.Visible := True; pnlChat.Visible := True; spChat.Top := pnlChat.Top - spChat.Height; pnlChatHeader.AnchorSide[akBottom].Control := spChat; pnlChatHeader.AnchorSide[akBottom].Side := asrTop; 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; 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); end; procedure TfrmMain.mnuDisconnectClick(Sender: TObject); begin dmNetwork.Disconnect; end; 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; procedure TfrmMain.oglGameWindowPaint(Sender: TObject); begin if mnuWhiteBackground.Checked then glClearColor(1, 1, 1, 1) else glClearColor(0, 0, 0, 1); glClear(GL_COLOR_BUFFER_BIT); InitRender; InitSize; glDisable(GL_DEPTH_TEST); Render; oglGameWindow.SwapBuffers; end; procedure TfrmMain.oglGameWindowResize(Sender: TObject); begin InvalidateScreenBuffer; end; procedure TfrmMain.pbRadarMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var posx, posy: Integer; begin 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); end; procedure TfrmMain.pbRadarPaint(Sender: TObject); var posX, posY, scrW, scrH: Integer; zoom: Single; image: TSingleImage; begin 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); end; procedure TfrmMain.pcLeftChange(Sender: TObject); begin end; procedure TfrmMain.pmGrabTileInfoPopup(Sender: TObject); var isStatic: Boolean; begin isStatic := CurrentTile is TStaticItem; mnuGrabHue.Enabled := isStatic; mnuGrabFilterTileID.Enabled := isStatic; mnuGrabFilterHue.Enabled := isStatic; end; procedure TfrmMain.tbRadarMapClick(Sender: TObject); begin frmRadarMap.Show; frmRadarMap.BringToFront; 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 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); end; end; procedure TfrmMain.tmSettingsCloseTimer(Sender: TObject); begin tmSettingsClose.Enabled := False; tbTerrain.Down := acTerrain.Checked; tbStatics.Down := acStatics.Checked; tbNoDraw.Down := acNoDraw.Checked; tbFlat.Down := acFlat.Checked; end; procedure TfrmMain.tsNavigationContextPopup(Sender: TObject; MousePos: TPoint; var Handled: Boolean); begin end; procedure TfrmMain.FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer); begin if Sender is TWinControl then if not (TWinControl(Sender)).Focused then (TWinControl(Sender)).SetFocus; end; procedure TfrmMain.tvGroupsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: String); var nodeData : PGroupNode; begin nodeData := tvGroups.GetNodeData(Node); CellText := nodeData^.Name; end; procedure TfrmMain.tvGroupsDrawText(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const CellText: String; const CellRect: TRect; var DefaultDraw: Boolean); var nodeData : PGroupNode; TextWidth: Integer; begin nodeData := tvGroups.GetNodeData(Node); 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; end; 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); begin if acDraw.Checked then ProcessToolState; end; procedure TfrmMain.vdtTilesDragAllowed(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); begin //vdtTiles.auto Allowed := True; end; procedure TfrmMain.vdtTilesDrawHint(Sender: TBaseVirtualTree; HintCanvas: TCanvas; Node: PVirtualNode; const R: TRect; Column: TColumnIndex ); var m_name : string; begin vdtTiles.UpdateHintCanvas(HintCanvas); HintCanvas.Font.Assign(Sender.Font); HintCanvas.Font.Style := [fsBold]; 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); HintCanvas.Font.Style := [fsItalic]; DrawText(HintCanvas.Handle, PChar(FTileHint.Flags), Length(FTileHint.Flags), FTileHint.FlagsRect, DT_WORDBREAK); end; procedure TfrmMain.vdtTilesDrawNode(Sender: TBaseVirtualTree; const PaintInfo: TVTPaintInfo); var tileInfo: PTileInfo; textStyle: TTextStyle; artEntry: TArt; tileData: TTileData; 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; begin 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; textStyle := PaintInfo.Canvas.TextStyle; textStyle.Alignment := taCenter; textStyle.Layout := tlCenter; textStyle.Wordbreak := True; 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]); case PaintInfo.Column of 0: begin id := tileInfo^.ID; 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; end; 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 begin 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 // Тайлы begin artEntry := ResMan.Art.GetArt(tileInfo^.ID, RGB2ARGB(PaintInfo.Canvas.Pixels[CellRect.Left, CellRect.Top]), nil, False); DisplayNodeImage((Sender = vdtTiles), PaintInfo.Canvas, CellRect, artEntry.Graphic); artEntry.Free; 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; end; end; end; end; procedure TfrmMain.vdtTilesEnter(Sender: TObject); begin if acFilter.Checked and mnuAutoShowFilterWindow.Checked and (not frmFilter.Visible) and (not frmFilter.Locked) then 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; id: LongWord; cmHint: TCMHintShow; 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 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]; flags := ''; // 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 begin 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; 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; FTileHint.NameRect.Left := 5; FTileHint.NameRect.Top := 5; Sender.Canvas.Font.Style := [fsBold]; DrawText(Sender.Canvas.Handle, PChar(CP1251ToUTF8(FTileHint.Name)), Length(CP1251ToUTF8(FTileHint.Name)), FTileHint.NameRect, DT_CALCRECT); 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); FTileHint.Flags := Format('Flags = [%s]', [flags]); FTileHint.FlagsRect.Left := 5; FTileHint.FlagsRect.Top := FTileHint.ObjRect.Bottom + 2; FTileHint.FlagsRect.Right := 145; Sender.Canvas.Font.Style := [fsItalic]; DrawText(Sender.Canvas.Handle, PChar(FTileHint.Flags), Length(FTileHint.Flags), FTileHint.FlagsRect, DT_CALCRECT or DT_WORDBREAK); R := Rect(0, 0, Max(Max(FTileHint.NameRect.Right, FTileHint.ObjRect.Right), FTileHint.FlagsRect.Right) + 5, 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; 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; 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); var ws: Integer; begin 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);'); 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; pbRadar.Repaint; 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); var sRect: TRect; w, h: Integer; 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 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; end else begin FCurrentTile.OnDestroy.RegisterEvent(@OnTileRemoved); 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; end; UpdateSelection; //Logger.Send([lcClient, lcDebug], 'CurrentTile: %.5x (%.6d)', [CurrentTile.TileID, CurrentTile.TileID]); //Logger.ExitMethod([lcClient, lcDebug], 'SetCurrentTile'); end; procedure TfrmMain.SetSelectedTile(const AValue: TWorldItem); begin //Logger.EnterMethod([lcClient, lcDebug], 'SetSelectedTile'); if AValue = FSelectedTile then begin Logger.ExitMethod([lcClient, lcDebug], 'SetSelectedTile'); 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); locationInfo^.Name := CP1251ToUTF8(location.AttribStrings['Name']); 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 cbRandomPreset.Items.AddObject( CP1251ToUTF8(TDOMElement(presets[i]).AttribStrings['Name']), presets[i]); 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 current, north, east, west, tile1, tile4, tile3, tile6: PBlockInfo; 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; 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 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 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; end; end; if north <> nil then PrepareScreenBlock(north); if east <> nil then PrepareScreenBlock(east); if west <> nil then PrepareScreenBlock(west); if tile1 <> nil then PrepareScreenBlock(tile1); if tile3 <> nil then PrepareScreenBlock(tile3); if tile4 <> nil then PrepareScreenBlock(tile4); if tile6 <> nil then PrepareScreenBlock(tile6); 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; z, west, south, east, tileNorth, tileWest, tileLeft, tileRight: SmallInt; rawZ, rawWest, rawSouth, rawEast, rawTileNorth, rawTileWest, rawTileLeft, rawTileRight: SmallInt; staticItem: TStaticItem; zoom: Single; 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; // Подготовка сетки рельефа для текстур 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; 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; // Подготовка сетки рельефа для лендов 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; end; end else // Виртуальный пол 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; // Подготовка сетки блоков на виртуальном полу 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; end else begin staticItem := TStaticItem(item); // Тайл виртуального источника света 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; 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; 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; 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; end; end; procedure TfrmMain.Render; var highlight: Boolean; intensity, red, green, blue: GLfloat; blockInfo: PBlockInfo; item: TWorldItem; i : byte; zoom: Single; begin if tbZoom.Down then zoom := tbZoom.Tag / 1000.0 else zoom:=1.0; 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; 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; if blockInfo^.Translucent then glColor4f(intensity * red, intensity * green, intensity * blue, 0.8) else glColor4f(intensity * red, intensity * green, intensity * blue, 1.0); highlight := blockInfo^.Highlighted and item.CanBeEdited; if highlight then begin glEnable(GL_COLOR_LOGIC_OP); glLogicOp(GL_COPY_INVERTED); end; 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], '', [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], ' ', [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], ''); 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 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], '', [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], ' ', [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], ' ', [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], ' ', [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], ' ', [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], ' ', [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], ' ', [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], ' ', [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], ' ', [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], ' '); end; Logger.Send([lcInfo], ''); 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 begin ProcessNode(cNode, TreeNode); cNode := cNode.NextSibling; end; // сохраняем данные узла 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; procedure BuildLinks(Node: PVirtualNode); var i : Integer; item : PVirtualNode; group: PGroupNode; begin group := tvGroups.GetNodeData(Node); for i := 0 to group^.Links - 1 do begin //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; 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; FreeMem(group^.lids); group^.lids := nil; end; begin tvGroups.BeginUpdate; tvGroups.Clear; 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 begin iNode := XMLDoc.DocumentElement.FirstChild; while iNode <> nil do begin if LowerCase(iNode.NodeName) = 'group' then ProcessNode(iNode, nil); // Рекурсия iNode := iNode.NextSibling; end; // Построение Указателей 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; end; XMLDoc.Free; tvGroups.EndUpdate; end; procedure TfrmMain.FreeGroupLists; var i, j, k : Integer; begin 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; for i:=0 to $3FFF do begin FBrushList.Tiles[i].ID := 0; FBrushList.Tiles[i].Brush1:=nil; FBrushList.Tiles[i].Brush2:=nil; end; end; procedure TfrmMain.BuildTileList; var minID, maxID, i, k, lastID: Integer; item : PVirtualItem; groupNode : PVirtualNode; tileInfo: PTileInfo; filter : string; nodeData: PGroupNode; procedure AddNodeTiles(Node: PVirtualNode; Count: Integer); var item: PVirtualItem; groupNode: PVirtualNode; nodeData: PGroupNode; tileInfo: PTileInfo; lastID: LongWord; i, j: Integer; //b,t,e: Integer; begin 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], '', [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], ' ', [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], ''); end; 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], '', [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], ' ', [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], ' ', [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], ' ', [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], ' ', [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], ' ', [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], ' ', [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], ' ', [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], ' ', [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], ' '); end; Logger.Send([lcInfo], ''); end; Logger.ExitMethod([lcInfo, lcDebug], 'TfrmMain.AddNodeTiles-Brushes'); } for i := 0 to nodeData^.Count - 1 do begin 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; end; end; begin filter := AnsiLowerCase(UTF8ToCP1251(edFilter.Text)); Logger.Send([lcInfo], 'TfrmMain.BuildTileList: %s', ['Start']); // Сортировка по группам if (not cbStatics.Checked) and (not cbTerrain.Checked) then begin 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; end else // Старое построение - список всех land и\или item тайлов begin 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 begin tileInfo := vdtTiles.GetNodeData(item); lastID := tileInfo^.ID; end else lastID := -1; 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; vdtTiles.EndUpdate; item := vdtTiles.GetFirstSelected; if item <> nil then vdtTiles.FocusedNode := item; end; Logger.Send([lcInfo], 'TfrmMain.BuildTileList: %s', ['End']); end; procedure TfrmMain.ProcessToolState; var blockInfo: PBlockInfo; begin if acSelect.Checked then begin //lblTip.Caption := 'Нажатие правой кнопки мышки покажет меню со всеми инструментами.'; //lblTip.Caption := 'Нажмите и удерживайте левую кнопку мышки, чтобы просмотреть список действий.'; //'Press and hold the left mouse button to show a list with actions (eg. grab hue).'; oglGameWindow.Cursor := +01;//crDefault; //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 //lblTip.Caption := 'Нажмите и удерживайте левую кнопку мышки, чтобы выбрать область.'; //'Press and hold the left mouse button to target an area.'; oglGameWindow.Cursor := +03;//crHandPoint; end; FRepaintNeeded := True; end; procedure TfrmMain.ProcessAccessLevel; begin 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); acDraw.Enabled := (dmNetwork.AccessLevel >= alNormal); acMove.Enabled := (dmNetwork.AccessLevel >= alNormal); acElevate.Enabled := (dmNetwork.AccessLevel >= alNormal); acSurfElevate.Enabled := (dmNetwork.AccessLevel >= alNormal); acSurfStretch.Enabled := (dmNetwork.AccessLevel >= alNormal); acSurfSmooth.Enabled := (dmNetwork.AccessLevel >= alNormal); acDelete.Enabled := (dmNetwork.AccessLevel >= alNormal); acHue.Enabled := (dmNetwork.AccessLevel >= alNormal); 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]); end; procedure TfrmMain.RebuildScreenBuffer; var blockInfo: PBlockInfo; i, tileX, tileY: Integer; virtualTile: TVirtualTile; zoom: Single; begin //Logger.EnterMethod([lcClient], 'RebuildScreenBuffer'); if tbZoom.Down then zoom:= tbZoom.Tag / 1000.0 else zoom:= 1.0; FDrawDistance := Trunc(Sqrt(oglGameWindow.Width * oglGameWindow.Width + oglGamewindow.Height * oglGamewindow.Height) / (44 * zoom)); //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; 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; //Logger.Send([lcClient, lcDebug], 'VirtualTiles', FVirtualTiles.Count); FLandscape.FillDrawList(FScreenBuffer, FX + FLowOffsetX, FY + FLowOffsetY, FRangeX, FRangeY, acTerrain.Checked, acStatics.Checked, mnuShowWalls.Checked, mnuShowBridges.Checked, mnuShowRoofs.Checked, mnuShowSurfaces.Checked, mnuShowFoliage.Checked, mnuShowWater.Checked, acNoDraw.Checked and mnuShowNoDrawTiles.Checked, FVirtualTiles); //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; zoom: Single; 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; if tbZoom.Down then zoom := tbZoom.Tag / 1000.0 else zoom := 1.0; blockInfo := FScreenBuffer.Find(Point(AX, AY), zoom); if blockInfo <> nil then CurrentTile := blockInfo^.Item else CurrentTile := nil; //Logger.ExitMethod([lcClient, lcDebug], 'UpdateCurrentTile'); end; procedure TfrmMain.UpdateFilter; var blockInfo: PBlockInfo; tileData: TTiledata; staticTileData: TStaticTileData; lastSurface: PBlockInfo; surfaceTop: Integer; zoom: Single; begin blockInfo := nil; lastSurface := nil; while FScreenBuffer.Iterate(blockInfo) do begin if blockInfo^.State in [ssNormal, ssFiltered] then begin blockInfo^.State := ssNormal; 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 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; 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 end; end; Include(FScreenBufferState, sbsFiltered); if tbZoom.Down then zoom := tbZoom.Tag / 1000.0 else zoom := 1.0; if (FLightManager.LightLevel > 0) and not acFlat.Checked then FLightManager.UpdateLightMap(FX + FLowOffsetX, FRangeX + 1, FY + FLowOffsetY, FRangeY + 1, FScreenBuffer, zoom); 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 begin ABlockInfo^.Hue := frmHueSettings.GetHue; ABlockInfo^.LowRes := FTextureManager.GetStaticMaterial( TStaticItem(ABlockInfo^.Item), ABlockInfo^.Hue); end else begin ABlockInfo^.LowRes := FTextureManager.GetStaticMaterial( TStaticItem(ABlockInfo^.Item)); end; end; end else begin ABlockInfo^.Highlighted := AHighlighted; end; end; 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; var blockInfo: PBlockInfo; tileInfo: PTileInfo; item: PVirtualItem; node: PVirtualItem; cell: TMapCell; ghostTile: TGhostTile; i, randalt: Integer; begin if frmDrawSettings.cbProbability.Checked and frmDrawSettings.cbProbability.Enabled and (frmDrawSettings.seProbability.Value < 100 * Random) then exit; tileInfo := nil; if frmDrawSettings.rbTileList.Checked then begin item := vdtTiles.GetFirstSelected; if item <> nil then tileInfo := vdtTiles.GetNodeData(item); end else if frmDrawSettings.rbRandom.Checked then begin node := vdlRandom.GetFirst; for i := 1 to Random(vdlRandom.TilesCount) do node := vdlRandom.GetNext(node); if node <> nil then tileInfo := vdlRandom.GetNodeData(node); end; if tileInfo <> nil then begin 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], ' ', [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 // **** Текстуры **** 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 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; ghostTile := TGhostTile.Create(nil, nil, 0, 0); ghostTile.TileID := tileInfo^.ID - $4000; 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 begin if frmDrawSettings.cbUseSurfaceAltitude.Checked then begin blockInfo := FScreenBuffer.Find(AX, AY); if blockInfo <> nil then ABaseTile := blockInfo^.Item; end; //ghostTile.Z := ABaseTile.Z; 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; 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; brushMod: Boolean; // Актевирован Режим работы с кистями 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 brushMod := (vdtTiles.GetFirstSelected <> nil) and (PTileInfo(vdtTiles.GetNodeData(vdtTiles.GetFirstSelected))^.ID >= $2F000000); 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]; if (item is TGhostTile) and not IsInRect((item as TGhostTile).CenterX, (item as TGhostTile).CenterY, selectedRect) then begin FScreenBuffer.Delete(item); FVirtualTiles.Delete(i); end; end; //Logger.Send([lcClient, lcDebug], 'FSelection', FSelection); 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 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; if brushMod then begin // Для кистей inc(selectedRect.Left, +1); inc(selectedRect.Top, +1); end; 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);} //Logger.Send([lcClient, lcDebug], 'SelectedTile: %.5x (%.6d)', [SelectedTile.TileID, SelectedTile.TileID]); //set new ghost tiles if acDraw.Checked then begin for tileX := selectedRect.Left to selectedRect.Right do for tileY := selectedRect.Top to selectedRect.Bottom do if not IsInRect(tileX, tileY, FSelection) then 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; 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'); //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); while FScreenBuffer.Iterate(blockInfo) do if blockInfo^.State = ssNormal then SetHighlight(blockInfo, (blockInfo^.Item = CurrentTile) and not acDraw.Checked); 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; clientNode: PVirtualNode; clientInfo: PClientInfo; begin case ABuffer.ReadByte of $01: //client connected begin sender := ABuffer.ReadStringNull; vstClients.BeginUpdate; clientNode := vstClients.AddChild(nil); clientInfo := vstClients.GetNodeData(clientNode); clientInfo^.Name := sender; clientInfo^.AccessLevel := TAccessLevel(ABuffer.ReadByte); clientInfo^.LogonDateTime := Now; vstClients.EndUpdate; if sender <> dmNetwork.Username then WriteChatMessage('System', Format(lbUserLoginedMsg, [sender])); end; $02: begin sender := ABuffer.ReadStringNull; 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; if sender <> dmNetwork.Username then WriteChatMessage('System', Format(lbUserLogoutedMsg, [sender])); end; $03: //Client list begin vstClients.Clear; while ABuffer.Position < ABuffer.Size do 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; 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 MessageDlg(lbDlgBlockedAccessCaption, lbDlgBlockedAccess, mtWarning, [mbOK], 0); mnuDisconnectClick(nil); end else begin ProcessAccessLevel; MessageDlg(lbDlgCnangedAccessCaption, Format(lbDlgCnangedAccess, [GetAccessLevel(accessLevel)]), mtWarning, [mbOK], 0); end; end; for i := FAccessChangedListeners.Count - 1 downto 0 do FAccessChangedListeners[i](accessLevel); end; end; end; function TfrmMain.GetInternalTileID(ATile: TWorldItem): LongWord; 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; var zoom: Single; begin if tbZoom.Down then zoom := tbZoom.Tag / 1000.0 else zoom := 1.0; Dec(AX, FX); Dec(AY, FY); DrawX := (oglGameWindow.Width div 2) + Trunc((AX - AY) * 22 * zoom); DrawY := (oglGamewindow.Height div 2) + Trunc((AX + AY) * 22 * zoom); end; initialization {$I UfrmMain.lrs} end.