source: tags/1.3.6/LocalPlayer/TechTree.pas

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