source: trunk/LocalPlayer/TechTree.pas

Last change on this file was 684, checked in by chronos, 3 months ago
  • Modified: Improved forms painting if resized to bigger dimensions.
File size: 9.2 KB
Line 
1{$INCLUDE Switches.inc}
2unit TechTree;
3
4interface
5
6uses
7 ScreenTools, LCLIntf, LCLType, SysUtils, Classes, ButtonB, DrawDlg,
8 {$IFDEF DPI}Dpi.Graphics, Dpi.Controls, Dpi.Forms, Dpi.ExtCtrls{$ELSE}
9 Graphics, Controls, Forms, ExtCtrls{$ENDIF};
10
11type
12
13 { TTechTreeDlg }
14
15 TTechTreeDlg = class(TDrawDlg)
16 CloseBtn: TButtonB;
17 TimerKeyPressed: TTimer;
18 procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
19 procedure FormCreate(Sender: TObject);
20 procedure FormDestroy(Sender: TObject);
21 procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
22 procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
23 procedure FormPaint(Sender: TObject);
24 procedure FormShow(Sender: TObject);
25 procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
26 Shift: TShiftState; X, Y: Integer);
27 procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
28 Shift: TShiftState; X, Y: Integer);
29 procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
30 procedure CloseBtnClick(Sender: TObject);
31 procedure TimerKeyPressedTimer(Sender: TObject);
32 protected
33 procedure DoOnResize; override;
34 private
35 Offset: TPoint;
36 Down: TPoint;
37 Image: TBitmap;
38 Dragging: Boolean;
39 LeftPressed: Boolean;
40 RightPressed: Boolean;
41 UpPressed: Boolean;
42 DownPressed: Boolean;
43 procedure Move(Diff: TPoint);
44 end;
45
46
47implementation
48
49uses
50 Directories;
51
52{$R *.lfm}
53
54const
55 BlackBorder = 4;
56 LeftBorder = 72;
57 RightBorder = 45;
58 TopBorder = 16;
59 BottomBorder = 48;
60 xStart = 0;
61 yStart = 40;
62 xPitch = 160;
63 yPitch = 90;
64 xLegend = 44;
65 yLegend = 79;
66 yLegendPitch = 32;
67
68function Min(A, B: Integer): Integer;
69begin
70 if A < B then Result := A
71 else Result := B;
72end;
73
74function Max(A, B: Integer): Integer;
75begin
76 if A > B then Result := A
77 else Result := B;
78end;
79
80procedure TTechTreeDlg.FormCreate(Sender: TObject);
81begin
82 InitButtons;
83 Image := nil;
84end;
85
86procedure TTechTreeDlg.FormClose(Sender: TObject; var CloseAction: TCloseAction
87 );
88begin
89 TimerKeyPressed.Enabled := False;
90 RightPressed := False;
91 DownPressed := False;
92 LeftPressed := False;
93 UpPressed := False;
94end;
95
96procedure TTechTreeDlg.FormDestroy(Sender: TObject);
97begin
98 FreeAndNil(Image);
99end;
100
101procedure TTechTreeDlg.FormKeyDown(Sender: TObject; var Key: Word;
102 Shift: TShiftState);
103begin
104 case Key of
105 37: RightPressed := True;
106 38: DownPressed := True;
107 39: LeftPressed := True;
108 40: UpPressed := True;
109 end;
110 TimerKeyPressedTimer(nil);
111 TimerKeyPressed.Enabled := RightPressed or DownPressed or LeftPressed or UpPressed;
112end;
113
114procedure TTechTreeDlg.FormKeyUp(Sender: TObject; var Key: Word;
115 Shift: TShiftState);
116begin
117 case Key of
118 37: RightPressed := False;
119 38: DownPressed := False;
120 39: LeftPressed := False;
121 40: UpPressed := False;
122 end;
123 TimerKeyPressed.Enabled := RightPressed or DownPressed or LeftPressed or UpPressed;
124end;
125
126procedure TTechTreeDlg.FormPaint(Sender: TObject);
127var
128 X, W: Integer;
129begin
130 with Canvas do begin
131 // black border
132 Brush.Color := $000000;
133 FillRect(rect(0, 0, BlackBorder, ClientHeight));
134 FillRect(rect(BlackBorder, 0, ClientWidth - BlackBorder, BlackBorder));
135 FillRect(rect(ClientWidth - BlackBorder, 0, ClientWidth, ClientHeight));
136 FillRect(rect(BlackBorder, ClientHeight - BlackBorder,
137 ClientWidth - BlackBorder, ClientHeight));
138
139 // texturize empty space
140 Brush.Color := $FFFFFF;
141 if Offset.X > 0 then
142 FillRectSeamless(Canvas, BlackBorder, BlackBorder, BlackBorder + Offset.X,
143 ClientHeight - BlackBorder, -BlackBorder - Offset.X,
144 -BlackBorder - Offset.Y, Paper);
145 if Offset.X + Image.Width < ClientWidth - 2 * BlackBorder then
146 FillRectSeamless(Canvas, BlackBorder + Offset.X + Image.Width, BlackBorder,
147 ClientWidth - BlackBorder, ClientHeight - BlackBorder,
148 -BlackBorder - Offset.X, -BlackBorder - Offset.Y, Paper);
149 X := Max(BlackBorder, BlackBorder + Offset.X);
150 W := Min(BlackBorder + Offset.X + Image.Width, ClientWidth - BlackBorder);
151 if Offset.Y > 0 then
152 FillRectSeamless(Canvas, X, BlackBorder, W, BlackBorder + Offset.Y,
153 -BlackBorder - Offset.X, -BlackBorder - Offset.Y, Paper);
154 if Offset.Y + Image.Height < ClientHeight - 2 * BlackBorder then
155 FillRectSeamless(Canvas, X, BlackBorder + Offset.Y + Image.Height, W,
156 ClientHeight - BlackBorder, -BlackBorder - Offset.X,
157 -BlackBorder - Offset.Y, Paper);
158 end;
159 BitBltCanvas(Canvas, Max(BlackBorder, BlackBorder + Offset.X),
160 Max(BlackBorder, BlackBorder + Offset.Y),
161 Min(Image.Width, Min(Image.Width + Offset.X,
162 Min(ClientWidth - 2 * BlackBorder, ClientWidth - 2 * BlackBorder - Offset.X))
163 ), Min(Image.Height, Min(Image.Height + Offset.Y,
164 Min(ClientHeight - 2 * BlackBorder, ClientHeight - 2 * BlackBorder -
165 Offset.Y))), Image.Canvas, Max(0, -Offset.X),
166 Max(0, -Offset.Y));
167end;
168
169procedure TTechTreeDlg.FormShow(Sender: TObject);
170var
171 X, Y, ad: Integer;
172 S: string;
173 NewWidth: Integer;
174 NewHeight: Integer;
175begin
176 Caption := Phrases2.Lookup('MENU_ADVTREE');
177 if Image = nil then begin
178 Image := TBitmap.Create;
179 Image.PixelFormat := TPixelFormat.pf24bit;
180 LoadGraphicFile(Image, GetAppSharePath('Help' + DirectorySeparator + 'AdvTree.png'),
181 [gfNoGamma]);
182
183 with Image.Canvas do begin
184 // Write advance names
185 Font.Assign(UniFont[ftSmall]);
186 Font.Color := clBlack;
187 Brush.Style := TBrushStyle.bsClear;
188 for X := 0 to (Image.Width - xStart) div xPitch do
189 for Y := 0 to (Image.Height - yStart) div yPitch do
190 begin
191 ad := Pixels[xStart + X * xPitch + 10, yStart + Y * yPitch - 1];
192 if ad and $FFFF00 = 0 then
193 begin
194 S := Phrases.Lookup('ADVANCES', ad);
195 while TextWidth(S) > 112 do
196 Delete(S, Length(S), 1);
197 TextOut(xStart + X * xPitch + 2, yStart + Y * yPitch, S);
198 Pixels[xStart + X * xPitch + 10, yStart + Y * yPitch - 1]
199 := TransparentColor2;
200 end;
201 end;
202
203 // Write legend
204 TextOut(xLegend, yLegend, Phrases2.Lookup('ADVTREE_UP0'));
205 TextOut(xLegend, yLegend + yLegendPitch, Phrases2.Lookup('ADVTREE_UP1'));
206 TextOut(xLegend, yLegend + 2 * yLegendPitch,
207 Phrases2.Lookup('ADVTREE_UP2'));
208 TextOut(xLegend, yLegend + 3 * yLegendPitch,
209 Phrases2.Lookup('ADVTREE_GOV'));
210 TextOut(xLegend, yLegend + 4 * yLegendPitch,
211 Phrases2.Lookup('ADVTREE_OTHER'));
212 end;
213
214 Texturize(Image, Paper, TransparentColor2);
215 end;
216
217 // Fit window to image, center image in window, center window to screen
218 NewWidth := Min(Screen.PrimaryMonitor.Width - 40, Image.Width + LeftBorder + RightBorder +
219 2 * BlackBorder);
220 NewHeight := Min(Screen.PrimaryMonitor.Height - 40, Image.Height + TopBorder + BottomBorder +
221 2 * BlackBorder);
222 BoundsRect := Bounds(Screen.PrimaryMonitor.Left + (Screen.PrimaryMonitor.Width - NewWidth) div 2,
223 Screen.PrimaryMonitor.Top + (Screen.PrimaryMonitor.Height - NewHeight) div 2, NewWidth, NewHeight);
224 CloseBtn.Left := Width - CloseBtn.Width - BlackBorder - 8;
225 CloseBtn.Top := BlackBorder + 8;
226 Offset.X := (ClientWidth - Image.Width + LeftBorder - RightBorder) div 2 -
227 BlackBorder;
228 Offset.Y := ClientHeight - 2 * BlackBorder - Image.Height - BottomBorder;
229end;
230
231procedure TTechTreeDlg.FormMouseDown(Sender: TObject; Button: TMouseButton;
232 Shift: TShiftState; X, Y: Integer);
233begin
234 if Button = TMouseButton.mbLeft then
235 begin
236 Dragging := True;
237 Down := Point(X, Y);
238 end;
239end;
240
241procedure TTechTreeDlg.FormMouseUp(Sender: TObject; Button: TMouseButton;
242 Shift: TShiftState; X, Y: Integer);
243begin
244 Dragging := False;
245end;
246
247procedure TTechTreeDlg.FormMouseMove(Sender: TObject; Shift: TShiftState;
248 X, Y: Integer);
249begin
250 if Dragging then
251 begin
252 Move(Point(X - Down.X, Y - Down.Y));
253 Down := Point(X, Y);
254 end;
255end;
256
257procedure TTechTreeDlg.CloseBtnClick(Sender: TObject);
258begin
259 Close;
260end;
261
262procedure TTechTreeDlg.TimerKeyPressedTimer(Sender: TObject);
263const
264 Diff = 50;
265var
266 Change: TPoint;
267begin
268 Change := Point(0, 0);
269 if RightPressed then Change.X := Change.X + Diff;
270 if LeftPressed then Change.X := Change.X - Diff;
271 if DownPressed then Change.Y := Change.Y + Diff;
272 if UpPressed then Change.Y := Change.Y - Diff;
273
274 if (Change.X <> 0) or (Change.Y <> 0) then Move(Change);
275end;
276
277procedure TTechTreeDlg.DoOnResize;
278begin
279 inherited;
280 CloseBtn.Left := Width - 43;
281end;
282
283procedure TTechTreeDlg.Move(Diff: TPoint);
284begin
285 Offset := Offset + Diff;
286
287 if Offset.X > LeftBorder then
288 Offset.X := LeftBorder;
289 if Offset.X < ClientWidth - 2 * BlackBorder - Image.Width - RightBorder then
290 Offset.X := ClientWidth - 2 * BlackBorder - Image.Width - RightBorder;
291 if Offset.Y > TopBorder then
292 Offset.Y := TopBorder;
293 if Offset.Y < ClientHeight - 2 * BlackBorder - Image.Height - BottomBorder then
294 Offset.Y := ClientHeight - 2 * BlackBorder - Image.Height - BottomBorder;
295
296 SmartInvalidate;
297end;
298
299end.
Note: See TracBrowser for help on using the repository browser.