close Warning: Can't synchronize with repository "(default)" (No changeset 184 in the repository). Look in the Trac log for more information.

source: tags/1.2.0/Forms/UFormMain.pas

Last change on this file was 158, checked in by chronos, 7 years ago
  • Fixed: Show error message if not all players were placed to the map.
File size: 12.8 KB
Line 
1unit UFormMain;
2
3{$mode delphi}{$H+}
4
5interface
6
7uses
8 Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
9 UGame, LCLType, Menus, ActnList, ComCtrls, types, dateutils, XMLConf, DOM;
10
11const
12 ZoomFactor = 1.5;
13 MouseMinDiff = 0.1;
14
15type
16
17 { TFormMain }
18
19 TFormMain = class(TForm)
20 AStatusBarVisible: TAction;
21 AToolBarVisible: TAction;
22 AToolBarBigIcons: TAction;
23 AZoomIn: TAction;
24 AZoomAll: TAction;
25 AZoomOut: TAction;
26 ActionList1: TActionList;
27 MainMenu1: TMainMenu;
28 MenuItem1: TMenuItem;
29 MenuItem10: TMenuItem;
30 MenuItem11: TMenuItem;
31 MenuItem12: TMenuItem;
32 MenuItem13: TMenuItem;
33 MenuItem14: TMenuItem;
34 MenuItem15: TMenuItem;
35 MenuItem16: TMenuItem;
36 MenuItem17: TMenuItem;
37 MenuItem18: TMenuItem;
38 MenuItem19: TMenuItem;
39 MenuItem2: TMenuItem;
40 MenuItem20: TMenuItem;
41 MenuItem21: TMenuItem;
42 MenuItem22: TMenuItem;
43 MenuItem23: TMenuItem;
44 MenuItem24: TMenuItem;
45 MenuItem25: TMenuItem;
46 MenuItemLoadRecent: TMenuItem;
47 MenuItem3: TMenuItem;
48 MenuItem4: TMenuItem;
49 MenuItem5: TMenuItem;
50 MenuItem6: TMenuItem;
51 MenuItem7: TMenuItem;
52 MenuItem8: TMenuItem;
53 MenuItem9: TMenuItem;
54 PaintBox1: TPaintBox;
55 PopupMenuToolbar: TPopupMenu;
56 StatusBar1: TStatusBar;
57 Timer1: TTimer;
58 ToolBar1: TToolBar;
59 ToolButton1: TToolButton;
60 ToolButton10: TToolButton;
61 ToolButton11: TToolButton;
62 ToolButton12: TToolButton;
63 ToolButton13: TToolButton;
64 ToolButton2: TToolButton;
65 ToolButton3: TToolButton;
66 ToolButton4: TToolButton;
67 ToolButton5: TToolButton;
68 ToolButton6: TToolButton;
69 ToolButton7: TToolButton;
70 ToolButton8: TToolButton;
71 ToolButton9: TToolButton;
72 procedure AStatusBarVisibleExecute(Sender: TObject);
73 procedure AToolBarBigIconsExecute(Sender: TObject);
74 procedure AToolBarVisibleExecute(Sender: TObject);
75 procedure AZoomAllExecute(Sender: TObject);
76 procedure AZoomInExecute(Sender: TObject);
77 procedure AZoomOutExecute(Sender: TObject);
78 procedure FormShow(Sender: TObject);
79 procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
80 procedure FormCreate(Sender: TObject);
81 procedure FormDestroy(Sender: TObject);
82 procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
83 procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
84 Shift: TShiftState; X, Y: Integer);
85 procedure PaintBox1MouseLeave(Sender: TObject);
86 procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
87 Y: Integer);
88 procedure PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
89 Shift: TShiftState; X, Y: Integer);
90 procedure PaintBox1MouseWheelDown(Sender: TObject; Shift: TShiftState;
91 MousePos: TPoint; var Handled: Boolean);
92 procedure PaintBox1MouseWheelUp(Sender: TObject; Shift: TShiftState;
93 MousePos: TPoint; var Handled: Boolean);
94 procedure PaintBox1Paint(Sender: TObject);
95 procedure EraseBackground(DC: HDC); override;
96 procedure PaintBox1Resize(Sender: TObject);
97 procedure Timer1Timer(Sender: TObject);
98 private
99 TempBitmap: TBitmap;
100 StartMousePoint: TPoint;
101 StartViewPoint: TPoint;
102 MoveActive: Boolean;
103 RedrawPending: Boolean;
104 Drawing: Boolean;
105 DrawDuration: TDateTime;
106 LastTimerTime: TDateTime;
107 TimerPeriod: TDateTime;
108 public
109 procedure LoadConfig(Config: TXmlConfig; Path: string);
110 procedure SaveConfig(Config: TXmlConfig; Path: string);
111 procedure ReloadView;
112 procedure Redraw;
113 end;
114
115var
116 FormMain: TFormMain;
117
118implementation
119
120uses
121 UCore;
122
123resourcestring
124 STurn = 'turn';
125
126{$R *.lfm}
127
128{ TFormMain }
129
130procedure TFormMain.PaintBox1Paint(Sender: TObject);
131var
132 DrawStart: TDateTime;
133const
134 BackgroundColor = $404040;
135begin
136 DrawStart := Now;
137 if Assigned(Core.CurrentClient) then
138 with Core.CurrentClient do begin
139 View.DestRect := Bounds(0, 0, PaintBox1.Width, PaintBox1.Height);
140 if csOpaque in PaintBox1.ControlStyle then begin
141 TempBitmap.SetSize(PaintBox1.Width, PaintBox1.Height);
142 TempBitmap.Canvas.Brush.Color := BackGroundColor; //clBackground; //PaintBox1.GetColorResolvingParent;
143 TempBitmap.Canvas.FillRect(0, 0, PaintBox1.Width, PaintBox1.Height);
144 if Assigned(ControlPlayer) then ControlPlayer.Paint(TempBitmap.Canvas, View)
145 else Core.Game.Map.Paint(TempBitmap.Canvas, View);
146 PaintBox1.Canvas.Draw(0, 0, TempBitmap);
147 end else begin
148 {$ifdef WINDOWS}
149 PaintBox1.Canvas.Brush.Color := BackgroundColor; //clBackground; //PaintBox1.GetColorResolvingParent;
150 PaintBox1.Canvas.FillRect(0, 0, PaintBox1.Width, PaintBox1.Height);
151 {$endif}
152 if Assigned(ControlPlayer) then ControlPlayer.Paint(PaintBox1.Canvas, View)
153 else Core.Game.Map.Paint(PaintBox1.Canvas, View);
154 end;
155 end;
156 DrawDuration := (9 * DrawDuration + (Now - DrawStart)) / 10;
157end;
158
159procedure TFormMain.EraseBackground(DC: HDC);
160begin
161 // Do nothing, all background space covered by controls
162end;
163
164procedure TFormMain.PaintBox1Resize(Sender: TObject);
165begin
166 if Assigned(Core.CurrentClient) then
167 with Core.CurrentClient do
168 View.DestRect := Bounds(0, 0, PaintBox1.Width, PaintBox1.Height);
169 Redraw;
170end;
171
172procedure TFormMain.Timer1Timer(Sender: TObject);
173var
174 NewCaption: string;
175begin
176 if RedrawPending and not Drawing then begin
177 Drawing := True;
178 if not Core.DevelMode then RedrawPending := False;
179 TimerPeriod := (9 * TimerPeriod + (Now - LastTimerTime)) / 10;
180 LastTimerTime := Now;
181 PaintBox1.Repaint;
182 StatusBar1.Panels[1].Text := IntToStr(Trunc(DrawDuration / OneMillisecond)) + ' / ' +
183 IntToStr(Trunc(TimerPeriod / OneMillisecond)) + ' ms' +
184 ' ' + IntToStr(Core.Game.Map.CellLinks.Count);
185 NewCaption := 'xTactics';
186 if Assigned(Core.Game.CurrentPlayer) then
187 NewCaption := Core.Game.CurrentPlayer.Name + ' - ' + STurn + ' ' + IntToStr(Core.Game.TurnCounter) + ' - ' + NewCaption;
188 Caption := NewCaption;
189 Drawing := False;
190 end;
191end;
192
193procedure TFormMain.LoadConfig(Config: TXmlConfig; Path: string);
194begin
195 with Config do begin
196 AToolBarBigIcons.Checked := GetValue(DOMString(Path + '/LargeIcons'), False);
197 AToolBarVisible.Checked := GetValue(DOMString(Path + '/ToolBarVisible'), True);
198 AStatusBarVisible.Checked := GetValue(DOMString(Path + '/StatusBarVisible'), False);
199 end;
200end;
201
202procedure TFormMain.SaveConfig(Config: TXmlConfig; Path: string);
203begin
204 with Config do begin
205 SetValue(DOMString(Path + '/LargeIcons'), AToolBarBigIcons.Checked);
206 SetValue(DOMString(Path + '/ToolBarVisible'), AToolBarVisible.Checked);
207 SetValue(DOMString(Path + '/StatusBarVisible'), AStatusBarVisible.Checked);
208 end;
209end;
210
211procedure TFormMain.ReloadView;
212begin
213 if AToolBarBigIcons.Checked then begin
214 ToolBar1.Images := Core.ImageListLarge;
215 ToolBar1.ButtonWidth := Core.ImageListLarge.Width + 7;
216 ToolBar1.ButtonHeight := Core.ImageListLarge.Height + 6;
217 ToolBar1.Width := Core.ImageListLarge.Width + 10;
218 ToolBar1.Height := Core.ImageListLarge.Height + 10;
219 end else begin
220 ToolBar1.Images := Core.ImageListSmall;
221 ToolBar1.ButtonWidth := Core.ImageListSmall.Width + 7;
222 ToolBar1.ButtonHeight := Core.ImageListSmall.Height + 6;
223 ToolBar1.Width := Core.ImageListSmall.Width + 10;
224 ToolBar1.Height := Core.ImageListSmall.Height + 10;
225 end;
226 ToolBar1.Visible := AToolBarVisible.Checked;
227 StatusBar1.Visible := AStatusBarVisible.Checked;
228end;
229
230procedure TFormMain.Redraw;
231begin
232 RedrawPending := True;
233end;
234
235procedure TFormMain.FormCreate(Sender: TObject);
236begin
237 {$IFDEF Linux}
238 //PaintBox1.ControlStyle := PaintBox1.ControlStyle + [csOpaque];
239 {$ENDIF}
240 //DoubleBuffered := True;
241 TempBitmap := TBitmap.Create;
242 TimerPeriod := 0;
243 LastTimerTime := Now;
244end;
245
246procedure TFormMain.AZoomAllExecute(Sender: TObject);
247var
248 Factor: TFloatPoint;
249 MapRect: TRect;
250 NewZoom: Single;
251begin
252 with Core, Game, CurrentClient, View do begin
253 MapRect := Map.CalculatePixelRect;
254 Factor := FloatPoint((DestRect.Right - DestRect.Left) / (MapRect.Right - MapRect.Left),
255 (DestRect.Bottom - DestRect.Top) / (MapRect.Bottom - MapRect.Top));
256 if Factor.X < Factor.Y then NewZoom := Factor.X
257 else NewZoom := Factor.Y;
258 if NewZoom = 0 then NewZoom := 1;
259 Zoom := NewZoom;
260 CenterMap;
261 end;
262 Redraw;
263end;
264
265procedure TFormMain.AToolBarBigIconsExecute(Sender: TObject);
266begin
267 AToolBarBigIcons.Checked := not AToolBarBigIcons.Checked;
268 ReloadView;
269end;
270
271procedure TFormMain.AStatusBarVisibleExecute(Sender: TObject);
272begin
273 AStatusBarVisible.Checked := not AStatusBarVisible.Checked;
274 ReloadView;
275end;
276
277procedure TFormMain.AToolBarVisibleExecute(Sender: TObject);
278begin
279 AToolBarVisible.Checked := not AToolBarVisible.Checked;
280 ReloadView;
281end;
282
283procedure TFormMain.AZoomInExecute(Sender: TObject);
284begin
285 with Core.CurrentClient do begin
286 View.Zoom := View.Zoom * ZoomFactor;
287 end;
288 Redraw;
289end;
290
291procedure TFormMain.AZoomOutExecute(Sender: TObject);
292//var
293// D: TPoint;
294begin
295 with Core.CurrentClient do begin
296 //D := Point(Trunc(MousePos.X - View.Left / ViewZoom),
297 // Trunc(MousePos.Y - View.Top / ViewZoom));
298 View.Zoom := View.Zoom / ZoomFactor;
299 //View := Bounds(Trunc((D.X - MousePos.X) * ViewZoom),
300 // Trunc((D.Y - MousePos.Y) * ViewZoom),
301 // View.Right - View.Left,
302 // View.Bottom - View.Top);
303 end;
304 Redraw;
305end;
306
307procedure TFormMain.FormClose(Sender: TObject; var CloseAction: TCloseAction);
308begin
309 Core.Game.Running := False;
310 Core.PersistentForm.Save(Self);
311 SaveConfig(Core.XMLConfig1, 'FormMain');
312 Core.XMLConfig1.Flush;
313end;
314
315procedure TFormMain.FormDestroy(Sender: TObject);
316begin
317 TempBitmap.Free;
318end;
319
320procedure TFormMain.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState
321 );
322begin
323 if (Key = 27) or (Key = 17) then
324 if Assigned(Core.Game.CurrentPlayer) then begin
325 Core.CurrentClient.View.SelectedCell := nil;
326 Redraw;
327 end;
328end;
329
330procedure TFormMain.FormShow(Sender: TObject);
331begin
332 Core.Init;
333 LoadConfig(Core.XMLConfig1, 'FormMain');
334 Core.PersistentForm.Load(Self, wsMaximized);
335 ReloadView;
336 Redraw;
337end;
338
339procedure TFormMain.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
340 Shift: TShiftState; X, Y: Integer);
341begin
342 if Button = mbLeft then begin
343 if Assigned(Core.CurrentClient) then begin
344 StartMousePoint := Point(X, Y);
345 StartViewPoint := Core.CurrentClient.View.SourceRect.TopLeft;
346 MoveActive := True;
347 end;
348 end;
349end;
350
351procedure TFormMain.PaintBox1MouseLeave(Sender: TObject);
352begin
353 MoveActive := False;
354end;
355
356procedure TFormMain.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
357 Y: Integer);
358var
359 Cell: TCell;
360 OldCell: TCell;
361 CellPos: TPoint;
362begin
363 if Assigned(Core.CurrentClient) then begin
364 if MoveActive then
365 if (Abs(StartMousePoint.X - X) > Trunc(Screen.PixelsPerInch * MouseMinDiff)) or
366 (Abs(StartMousePoint.Y - Y) > Trunc(Screen.PixelsPerInch * MouseMinDiff)) then
367 with Core.Game.CurrentPlayer, Core.CurrentClient do begin
368 View.SourceRect := Bounds(Trunc(StartViewPoint.X + (StartMousePoint.X - X) / View.Zoom),
369 Trunc(StartViewPoint.Y + (StartMousePoint.Y - Y) / View.Zoom),
370 View.SourceRect.Right - View.SourceRect.Left,
371 View.SourceRect.Bottom - View.SourceRect.Top);
372 Redraw;
373 end;
374 Cell := nil;
375 OldCell := Core.CurrentClient.View.FocusedCell;
376 with Core.Game do
377 Cell := Map.PosToCell(Core.CurrentClient.View.CanvasToCellPos(Point(X, Y)), Core.CurrentClient.View );
378 if Assigned(Cell) then begin
379 Core.CurrentClient.View.FocusedCell := Cell;
380 StatusBar1.Panels[0].Text := '[' + IntToStr(Cell.PosPx.X) + ', ' + IntToStr(Cell.PosPx.Y) +
381 '] (' + IntToStr(Cell.MovesFrom.Count) + ', ' + IntToStr(Cell.MovesTo.Count) + ')';
382 end else begin
383 Core.CurrentClient.View.FocusedCell := nil;
384 StatusBar1.Panels[0].Text := '';
385 end;
386 CellPos := Core.CurrentClient.View.CanvasToCellPos(Point(X, Y));
387 StatusBar1.Panels[2].Text := 'CellPos: ' + IntToStr(CellPos.X) + ', ' + IntToStr(CellPos.Y);
388 if Cell <> OldCell then Redraw;
389 end else StatusBar1.Panels[0].Text := '';
390end;
391
392procedure TFormMain.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
393 Shift: TShiftState; X, Y: Integer);
394begin
395 if (Abs(StartMousePoint.X - X) < Trunc(Screen.PixelsPerInch * MouseMinDiff)) and
396 (Abs(StartMousePoint.Y - Y) < Trunc(Screen.PixelsPerInch * MouseMinDiff)) then begin
397 if Core.Game.Running and (Core.Game.CurrentPlayer.Mode = pmHuman) then begin
398 Core.CurrentClient.View.SelectCell(Point(X, Y), Core.Game.CurrentPlayer, Shift);
399 Redraw;
400 end;
401 end;
402 MoveActive := False;
403end;
404
405procedure TFormMain.PaintBox1MouseWheelDown(Sender: TObject;
406 Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
407begin
408 AZoomOut.Execute;
409end;
410
411procedure TFormMain.PaintBox1MouseWheelUp(Sender: TObject; Shift: TShiftState;
412 MousePos: TPoint; var Handled: Boolean);
413begin
414 AZoomIn.Execute;
415end;
416
417end.
418
Note: See TracBrowser for help on using the repository browser.