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.0.0/Forms/UFormMain.pas

Last change on this file was 111, checked in by chronos, 7 years ago
  • Modified: Changed debian packages configuration files to support build on Launchpad.
  • Fixed: Wrong zoom calculation in some case.
  • Fixed: Set configuration file name explicitly.
File size: 12.5 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;
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 MenuItem3: TMenuItem;
45 MenuItem4: TMenuItem;
46 MenuItem5: TMenuItem;
47 MenuItem6: TMenuItem;
48 MenuItem7: TMenuItem;
49 MenuItem8: TMenuItem;
50 MenuItem9: TMenuItem;
51 PaintBox1: TPaintBox;
52 PopupMenuToolbar: TPopupMenu;
53 StatusBar1: TStatusBar;
54 Timer1: TTimer;
55 ToolBar1: TToolBar;
56 ToolButton1: TToolButton;
57 ToolButton10: TToolButton;
58 ToolButton11: TToolButton;
59 ToolButton12: TToolButton;
60 ToolButton13: TToolButton;
61 ToolButton2: TToolButton;
62 ToolButton3: TToolButton;
63 ToolButton4: TToolButton;
64 ToolButton5: TToolButton;
65 ToolButton6: TToolButton;
66 ToolButton7: TToolButton;
67 ToolButton8: TToolButton;
68 ToolButton9: TToolButton;
69 procedure AStatusBarVisibleExecute(Sender: TObject);
70 procedure AToolBarBigIconsExecute(Sender: TObject);
71 procedure AToolBarVisibleExecute(Sender: TObject);
72 procedure AZoomAllExecute(Sender: TObject);
73 procedure AZoomInExecute(Sender: TObject);
74 procedure AZoomOutExecute(Sender: TObject);
75 procedure FormActivate(Sender: TObject);
76 procedure FormShow(Sender: TObject);
77 procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
78 procedure FormCreate(Sender: TObject);
79 procedure FormDestroy(Sender: TObject);
80 procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
81 procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
82 Shift: TShiftState; X, Y: Integer);
83 procedure PaintBox1MouseLeave(Sender: TObject);
84 procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
85 Y: Integer);
86 procedure PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
87 Shift: TShiftState; X, Y: Integer);
88 procedure PaintBox1MouseWheelDown(Sender: TObject; Shift: TShiftState;
89 MousePos: TPoint; var Handled: Boolean);
90 procedure PaintBox1MouseWheelUp(Sender: TObject; Shift: TShiftState;
91 MousePos: TPoint; var Handled: Boolean);
92 procedure PaintBox1Paint(Sender: TObject);
93 procedure EraseBackground(DC: HDC); override;
94 procedure PaintBox1Resize(Sender: TObject);
95 procedure Timer1Timer(Sender: TObject);
96 private
97 TempBitmap: TBitmap;
98 StartMousePoint: TPoint;
99 StartViewPoint: TPoint;
100 MoveActive: Boolean;
101 RedrawPending: Boolean;
102 Drawing: Boolean;
103 DrawDuration: TDateTime;
104 LastTimerTime: TDateTime;
105 TimerPeriod: TDateTime;
106 public
107 procedure LoadConfig(Config: TXmlConfig; Path: string);
108 procedure SaveConfig(Config: TXmlConfig; Path: string);
109 procedure ReloadView;
110 procedure Redraw;
111 end;
112
113var
114 FormMain: TFormMain;
115
116implementation
117
118uses
119 UCore;
120
121resourcestring
122 STurn = 'turn';
123
124{$R *.lfm}
125
126{ TFormMain }
127
128procedure TFormMain.PaintBox1Paint(Sender: TObject);
129var
130 DrawStart: TDateTime;
131begin
132 DrawStart := Now;
133 if Assigned(Core.Player) then
134 with Core.Player do begin
135 View.DestRect := Bounds(0, 0, PaintBox1.Width, PaintBox1.Height);
136 if csOpaque in PaintBox1.ControlStyle then begin
137 TempBitmap.SetSize(PaintBox1.Width, PaintBox1.Height);
138 TempBitmap.Canvas.Brush.Color := clBackground; //PaintBox1.GetColorResolvingParent;
139 TempBitmap.Canvas.FillRect(0, 0, PaintBox1.Width, PaintBox1.Height);
140 Paint(TempBitmap.Canvas);
141 PaintBox1.Canvas.Draw(0, 0, TempBitmap);
142 end else begin
143 {$ifdef WINDOWS}
144 PaintBox1.Canvas.Brush.Color := clBackground; //PaintBox1.GetColorResolvingParent;
145 PaintBox1.Canvas.FillRect(0, 0, PaintBox1.Width, PaintBox1.Height);
146 {$endif}
147 Paint(PaintBox1.Canvas);
148 end;
149 end;
150 DrawDuration := (9 * DrawDuration + (Now - DrawStart)) / 10;
151end;
152
153procedure TFormMain.EraseBackground(DC: HDC);
154begin
155 // Do nothing, all background space covered by controls
156end;
157
158procedure TFormMain.PaintBox1Resize(Sender: TObject);
159begin
160 if Assigned(Core.Player) then
161 with Core.Player do
162 View.DestRect := Bounds(0, 0, PaintBox1.Width, PaintBox1.Height);
163 Redraw;
164end;
165
166procedure TFormMain.Timer1Timer(Sender: TObject);
167var
168 NewCaption: string;
169begin
170 if RedrawPending and not Drawing then begin
171 Drawing := True;
172 if not Core.DevelMode then RedrawPending := False;
173 TimerPeriod := (9 * TimerPeriod + (Now - LastTimerTime)) / 10;
174 LastTimerTime := Now;
175 PaintBox1.Repaint;
176 StatusBar1.Panels[1].Text := IntToStr(Trunc(DrawDuration / OneMillisecond)) + ' / ' +
177 IntToStr(Trunc(TimerPeriod / OneMillisecond)) + ' ms' +
178 ' ' + IntToStr(Core.Game.Map.CellLinks.Count);
179 NewCaption := 'xTactics';
180 if Assigned(Core.Game.CurrentPlayer) then
181 NewCaption := Core.Game.CurrentPlayer.Name + ' - ' + STurn + ' ' + IntToStr(Core.Game.TurnCounter) + ' - ' + NewCaption;
182 Caption := NewCaption;
183 Drawing := False;
184 end;
185end;
186
187procedure TFormMain.LoadConfig(Config: TXmlConfig; Path: string);
188begin
189 with Config do begin
190 AToolBarBigIcons.Checked := GetValue(Path + '/LargeIcons', False);
191 AToolBarVisible.Checked := GetValue(Path + '/ToolBarVisible', True);
192 AStatusBarVisible.Checked := GetValue(Path + '/StatusBarVisible', False);
193 end;
194end;
195
196procedure TFormMain.SaveConfig(Config: TXmlConfig; Path: string);
197begin
198 with Config do begin
199 SetValue(Path + '/LargeIcons', AToolBarBigIcons.Checked);
200 SetValue(Path + '/ToolBarVisible', AToolBarVisible.Checked);
201 SetValue(Path + '/StatusBarVisible', AStatusBarVisible.Checked);
202 end;
203end;
204
205procedure TFormMain.ReloadView;
206begin
207 if AToolBarBigIcons.Checked then begin
208 ToolBar1.Images := Core.ImageListLarge;
209 ToolBar1.ButtonWidth := Core.ImageListLarge.Width + 7;
210 ToolBar1.ButtonHeight := Core.ImageListLarge.Height + 6;
211 ToolBar1.Width := Core.ImageListLarge.Width + 10;
212 ToolBar1.Height := Core.ImageListLarge.Height + 10;
213 end else begin
214 ToolBar1.Images := Core.ImageListSmall;
215 ToolBar1.ButtonWidth := Core.ImageListSmall.Width + 7;
216 ToolBar1.ButtonHeight := Core.ImageListSmall.Height + 6;
217 ToolBar1.Width := Core.ImageListSmall.Width + 10;
218 ToolBar1.Height := Core.ImageListSmall.Height + 10;
219 end;
220 ToolBar1.Visible := AToolBarVisible.Checked;
221 StatusBar1.Visible := AStatusBarVisible.Checked;
222end;
223
224procedure TFormMain.Redraw;
225begin
226 RedrawPending := True;
227end;
228
229procedure TFormMain.FormCreate(Sender: TObject);
230begin
231 {$IFDEF Linux}
232 //PaintBox1.ControlStyle := PaintBox1.ControlStyle + [csOpaque];
233 {$ENDIF}
234 //DoubleBuffered := True;
235 TempBitmap := TBitmap.Create;
236 TimerPeriod := 0;
237 LastTimerTime := Now;
238end;
239
240procedure TFormMain.FormActivate(Sender: TObject);
241begin
242 if not Core.Initialized then begin
243 Core.Init;
244 end;
245end;
246
247procedure TFormMain.AZoomAllExecute(Sender: TObject);
248var
249 Factor: TFloatPoint;
250 MapRect: TRect;
251 NewZoom: Single;
252begin
253 with Core, Game, Player, View do begin
254 MapRect := Map.GetPixelRect;
255 Factor := FloatPoint((DestRect.Right - DestRect.Left) / (MapRect.Right - MapRect.Left),
256 (DestRect.Bottom - DestRect.Top) / (MapRect.Bottom - MapRect.Top));
257 if Factor.X < Factor.Y then NewZoom := Factor.X
258 else NewZoom := Factor.Y;
259 if NewZoom = 0 then NewZoom := 1;
260 Zoom := NewZoom;
261 CenterMap;
262 end;
263 Redraw;
264end;
265
266procedure TFormMain.AToolBarBigIconsExecute(Sender: TObject);
267begin
268 AToolBarBigIcons.Checked := not AToolBarBigIcons.Checked;
269 ReloadView;
270end;
271
272procedure TFormMain.AStatusBarVisibleExecute(Sender: TObject);
273begin
274 AStatusBarVisible.Checked := not AStatusBarVisible.Checked;
275 ReloadView;
276end;
277
278procedure TFormMain.AToolBarVisibleExecute(Sender: TObject);
279begin
280 AToolBarVisible.Checked := not AToolBarVisible.Checked;
281 ReloadView;
282end;
283
284procedure TFormMain.AZoomInExecute(Sender: TObject);
285begin
286 with Core.Player do begin
287 View.Zoom := View.Zoom * ZoomFactor;
288 end;
289 Redraw;
290end;
291
292procedure TFormMain.AZoomOutExecute(Sender: TObject);
293var
294 D: TPoint;
295begin
296 with Core.Player do begin
297 //D := Point(Trunc(MousePos.X - View.Left / ViewZoom),
298 // Trunc(MousePos.Y - View.Top / ViewZoom));
299 View.Zoom := View.Zoom / ZoomFactor;
300 //View := Bounds(Trunc((D.X - MousePos.X) * ViewZoom),
301 // Trunc((D.Y - MousePos.Y) * ViewZoom),
302 // View.Right - View.Left,
303 // View.Bottom - View.Top);
304 end;
305 Redraw;
306end;
307
308procedure TFormMain.FormClose(Sender: TObject; var CloseAction: TCloseAction);
309begin
310 Core.Game.Running := False;
311 SaveConfig(Core.XMLConfig1, 'FormMain');
312 Core.PersistentForm.Save(Self);
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.Game.CurrentPlayer.View.SelectedCell := nil;
326 Redraw;
327 end;
328end;
329
330procedure TFormMain.FormShow(Sender: TObject);
331begin
332 Core.XMLConfig1.Filename := 'Config.xml';
333 LoadConfig(Core.XMLConfig1, 'FormMain');
334 Core.PersistentForm.Load(Self, True);
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 Core.Game.CurrentPlayer.Mode = pmHuman then begin
344 StartMousePoint := Point(X, Y);
345 StartViewPoint := Core.Game.CurrentPlayer.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.Game.CurrentPlayer) 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 do begin
368 if Mode = pmHuman then begin
369 View.SourceRect := Bounds(Trunc(StartViewPoint.X + (StartMousePoint.X - X) / View.Zoom),
370 Trunc(StartViewPoint.Y + (StartMousePoint.Y - Y) / View.Zoom),
371 View.SourceRect.Right - View.SourceRect.Left,
372 View.SourceRect.Bottom - View.SourceRect.Top);
373 Redraw;
374 end;
375 end;
376 Cell := nil;
377 OldCell := Core.Game.CurrentPlayer.View.FocusedCell;
378 with Core.Game do
379 Cell := Map.PosToCell(CurrentPlayer.View.CanvasToCellPos(Point(X, Y)), CurrentPlayer.View );
380 if Assigned(Cell) then begin
381 Core.Game.CurrentPlayer.View.FocusedCell := Cell;
382 StatusBar1.Panels[0].Text := '[' + IntToStr(Cell.PosPx.X) + ', ' + IntToStr(Cell.PosPx.Y) +
383 '] (' + IntToStr(Cell.MovesFrom.Count) + ', ' + IntToStr(Cell.MovesTo.Count) + ')';
384 end else begin
385 Core.Game.CurrentPlayer.View.FocusedCell := nil;
386 StatusBar1.Panels[0].Text := '';
387 end;
388 CellPos := Core.Game.CurrentPlayer.View.CanvasToCellPos(Point(X, Y));
389 StatusBar1.Panels[2].Text := 'CellPos: ' + IntToStr(CellPos.X) + ', ' + IntToStr(CellPos.Y);
390 if Cell <> OldCell then Redraw;
391 end else StatusBar1.Panels[0].Text := '';
392end;
393
394procedure TFormMain.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
395 Shift: TShiftState; X, Y: Integer);
396begin
397 if (Abs(StartMousePoint.X - X) < Trunc(Screen.PixelsPerInch * MouseMinDiff)) and
398 (Abs(StartMousePoint.Y - Y) < Trunc(Screen.PixelsPerInch * MouseMinDiff)) then begin
399 if Core.Game.Running and (Core.Game.CurrentPlayer.Mode = pmHuman) then begin
400 Core.Game.CurrentPlayer.View.SelectCell(Point(X, Y), Core.Game.CurrentPlayer, Shift);
401 Redraw;
402 end;
403 end;
404 MoveActive := False;
405end;
406
407procedure TFormMain.PaintBox1MouseWheelDown(Sender: TObject;
408 Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
409begin
410 AZoomOut.Execute;
411end;
412
413procedure TFormMain.PaintBox1MouseWheelUp(Sender: TObject; Shift: TShiftState;
414 MousePos: TPoint; var Handled: Boolean);
415begin
416 AZoomIn.Execute;
417end;
418
419end.
420
Note: See TracBrowser for help on using the repository browser.