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

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