author | unc0rr |
Wed, 03 Dec 2014 00:07:33 +0300 | |
branch | qmlfrontend |
changeset 10606 | 8e95911cb86b |
parent 10456 | 6fd99bb73524 |
child 10612 | eb3c1a289a23 |
permissions | -rw-r--r-- |
10406 | 1 |
unit uFLGameConfig; |
2 |
interface |
|
10428
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
3 |
uses uFLTypes; |
10406 | 4 |
|
10430 | 5 |
procedure resetGameConfig; cdecl; |
6 |
procedure runQuickGame; cdecl; |
|
10448 | 7 |
procedure runLocalGame; cdecl; |
10430 | 8 |
procedure getPreview; cdecl; |
10406 | 9 |
|
10430 | 10 |
procedure registerGUIMessagesCallback(p: pointer; f: TGUICallback); cdecl; |
11 |
||
12 |
procedure setSeed(seed: PChar); cdecl; |
|
13 |
function getSeed: PChar; cdecl; |
|
10456 | 14 |
procedure setTheme(themeName: PChar); cdecl; |
10428
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
15 |
|
10452
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
16 |
procedure tryAddTeam(teamName: PChar); cdecl; |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
17 |
procedure tryRemoveTeam(teamName: PChar); cdecl; |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
18 |
procedure changeTeamColor(teamName: PChar; dir: LongInt); cdecl; |
10444
47a6231f1fc1
Teams widget now allows to add and remove teams (basic implementation, no checks performed, no colors, no hedgehogs)
unc0rr
parents:
10432
diff
changeset
|
19 |
|
10406 | 20 |
implementation |
10448 | 21 |
uses uFLIPC, hwengine, uFLUtils, uFLTeams, uFLData; |
10428
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
22 |
|
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
23 |
var guiCallbackPointer: pointer; |
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
24 |
guiCallbackFunction: TGUICallback; |
10406 | 25 |
|
10426 | 26 |
const |
27 |
MAXCONFIGS = 5; |
|
28 |
MAXARGS = 32; |
|
29 |
||
30 |
type |
|
31 |
TGameConfig = record |
|
32 |
seed: shortstring; |
|
33 |
theme: shortstring; |
|
34 |
script: shortstring; |
|
10432 | 35 |
mapgen: Longint; |
10426 | 36 |
gameType: TGameType; |
37 |
teams: array[0..7] of TTeam; |
|
38 |
arguments: array[0..Pred(MAXARGS)] of shortstring; |
|
39 |
argv: array[0..Pred(MAXARGS)] of PChar; |
|
40 |
argumentsNumber: Longword; |
|
41 |
end; |
|
42 |
PGameConfig = ^TGameConfig; |
|
43 |
||
10432 | 44 |
var |
45 |
currentConfig: TGameConfig; |
|
46 |
||
10430 | 47 |
|
10432 | 48 |
procedure sendConfig(config: PGameConfig); |
49 |
var i: Longword; |
|
50 |
begin |
|
51 |
with config^ do |
|
10430 | 52 |
begin |
10432 | 53 |
case gameType of |
54 |
gtPreview: begin |
|
55 |
ipcToEngine('eseed ' + seed); |
|
56 |
ipcToEngine('e$mapgen ' + intToStr(mapgen)); |
|
57 |
end; |
|
58 |
gtLocal: begin |
|
59 |
ipcToEngine('eseed ' + seed); |
|
60 |
ipcToEngine('e$mapgen ' + intToStr(mapgen)); |
|
10456 | 61 |
ipcToEngine('e$theme ' + theme); |
10432 | 62 |
i:= 0; |
63 |
while (i < 8) and (teams[i].hogsNumber > 0) do |
|
64 |
begin |
|
65 |
ipcToEngine('eammloadt 93919294221991210322351110012000000002111001010111110001'); |
|
66 |
ipcToEngine('eammprob 04050405416006555465544647765766666661555101011154111111'); |
|
67 |
ipcToEngine('eammdelay 00000000000002055000000400070040000000002200000006000200'); |
|
68 |
ipcToEngine('eammreinf 13111103121111111231141111111111111112111111011111111111'); |
|
69 |
ipcToEngine('eammstore'); |
|
70 |
sendTeamConfig(teams[i]); |
|
71 |
inc(i) |
|
72 |
end; |
|
73 |
end; |
|
74 |
end; |
|
75 |
||
76 |
ipcToEngine('!'); |
|
77 |
end; |
|
78 |
end; |
|
10426 | 79 |
|
80 |
procedure queueExecution; |
|
81 |
var pConfig: PGameConfig; |
|
82 |
i: Longword; |
|
83 |
begin |
|
84 |
new(pConfig); |
|
85 |
pConfig^:= currentConfig; |
|
86 |
||
87 |
with pConfig^ do |
|
88 |
for i:= 0 to Pred(MAXARGS) do |
|
89 |
begin |
|
90 |
if arguments[i][0] = #255 then |
|
10428
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
91 |
arguments[i][255]:= #0 |
10426 | 92 |
else |
10428
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
93 |
arguments[i][byte(arguments[i][0]) + 1]:= #0; |
10426 | 94 |
argv[i]:= @arguments[i][1] |
95 |
end; |
|
96 |
||
97 |
RunEngine(pConfig^.argumentsNumber, @pConfig^.argv); |
|
10432 | 98 |
|
99 |
sendConfig(pConfig) |
|
10426 | 100 |
end; |
101 |
||
102 |
procedure resetGameConfig; cdecl; |
|
10450 | 103 |
var i: Longword; |
10406 | 104 |
begin |
10450 | 105 |
with currentConfig do |
106 |
begin |
|
107 |
for i:= 0 to 7 do |
|
108 |
teams[i].hogsNumber:= 0 |
|
109 |
end |
|
10406 | 110 |
end; |
111 |
||
10430 | 112 |
procedure setSeed(seed: PChar); cdecl; |
113 |
begin |
|
114 |
currentConfig.seed:= seed |
|
115 |
end; |
|
116 |
||
10448 | 117 |
|
10430 | 118 |
function getSeed: PChar; cdecl; |
119 |
begin |
|
120 |
getSeed:= str2PChar(currentConfig.seed) |
|
121 |
end; |
|
122 |
||
10450 | 123 |
function getUnusedColor: Longword; |
10448 | 124 |
var i, c: Longword; |
125 |
fColorMatched: boolean; |
|
126 |
begin |
|
127 |
c:= 0; |
|
128 |
i:= 0; |
|
129 |
repeat |
|
130 |
repeat |
|
10450 | 131 |
fColorMatched:= (currentConfig.teams[i].hogsNumber > 0) and (currentConfig.teams[i].color = c); |
10448 | 132 |
inc(i) |
133 |
until (i >= 8) or (currentConfig.teams[i].hogsNumber = 0) or fColorMatched; |
|
134 |
||
135 |
if fColorMatched then |
|
136 |
begin |
|
137 |
i:= 0; |
|
138 |
inc(c) |
|
139 |
end; |
|
140 |
until not fColorMatched; |
|
141 |
||
10450 | 142 |
getUnusedColor:= c |
10448 | 143 |
end; |
144 |
||
10430 | 145 |
procedure runQuickGame; cdecl; |
10426 | 146 |
begin |
10432 | 147 |
with currentConfig do |
148 |
begin |
|
149 |
gameType:= gtLocal; |
|
150 |
arguments[0]:= ''; |
|
151 |
arguments[1]:= '--internal'; |
|
10448 | 152 |
arguments[2]:= '--nomusic'; |
10432 | 153 |
argumentsNumber:= 3; |
10426 | 154 |
|
10432 | 155 |
teams[0]:= createRandomTeam; |
10450 | 156 |
teams[0].color:= 0; |
10432 | 157 |
teams[1]:= createRandomTeam; |
10450 | 158 |
teams[1].color:= 1; |
10432 | 159 |
teams[1].botLevel:= 1; |
160 |
||
161 |
queueExecution; |
|
162 |
end; |
|
10426 | 163 |
end; |
164 |
||
10448 | 165 |
|
10430 | 166 |
procedure getPreview; cdecl; |
10426 | 167 |
begin |
168 |
with currentConfig do |
|
169 |
begin |
|
170 |
gameType:= gtPreview; |
|
171 |
arguments[0]:= ''; |
|
172 |
arguments[1]:= '--internal'; |
|
173 |
arguments[2]:= '--landpreview'; |
|
174 |
argumentsNumber:= 3; |
|
10428
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
175 |
|
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
176 |
queueExecution; |
10426 | 177 |
end; |
10428
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
178 |
end; |
10426 | 179 |
|
10448 | 180 |
procedure runLocalGame; cdecl; |
181 |
begin |
|
182 |
with currentConfig do |
|
183 |
begin |
|
184 |
gameType:= gtLocal; |
|
185 |
arguments[0]:= ''; |
|
186 |
arguments[1]:= '--internal'; |
|
187 |
arguments[2]:= '--nomusic'; |
|
188 |
argumentsNumber:= 3; |
|
189 |
||
190 |
queueExecution; |
|
191 |
end; |
|
192 |
end; |
|
193 |
||
194 |
||
10428
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
195 |
procedure engineMessageCallback(p: pointer; msg: PChar; len: Longword); |
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
196 |
begin |
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
197 |
if len = 128 * 256 then guiCallbackFunction(guiCallbackPointer, mtPreview, msg, len) |
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
198 |
end; |
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
199 |
|
10430 | 200 |
procedure registerGUIMessagesCallback(p: pointer; f: TGUICallback); cdecl; |
10428
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
201 |
begin |
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
202 |
guiCallbackPointer:= p; |
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
203 |
guiCallbackFunction:= f; |
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
204 |
|
7c25297720f1
More refactoring: move PoC preview getting code into flib
unc0rr
parents:
10426
diff
changeset
|
205 |
registerIPCCallback(nil, @engineMessageCallback) |
10426 | 206 |
end; |
207 |
||
10444
47a6231f1fc1
Teams widget now allows to add and remove teams (basic implementation, no checks performed, no colors, no hedgehogs)
unc0rr
parents:
10432
diff
changeset
|
208 |
|
10452
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
209 |
procedure tryAddTeam(teamName: PChar); cdecl; |
10444
47a6231f1fc1
Teams widget now allows to add and remove teams (basic implementation, no checks performed, no colors, no hedgehogs)
unc0rr
parents:
10432
diff
changeset
|
210 |
var msg: ansistring; |
10446 | 211 |
i, hn, hedgehogsNumber: Longword; |
212 |
team: PTeam; |
|
10450 | 213 |
c: Longword; |
10444
47a6231f1fc1
Teams widget now allows to add and remove teams (basic implementation, no checks performed, no colors, no hedgehogs)
unc0rr
parents:
10432
diff
changeset
|
214 |
begin |
10446 | 215 |
with currentConfig do |
216 |
begin |
|
217 |
hedgehogsNumber:= 0; |
|
218 |
i:= 0; |
|
219 |
||
220 |
while (i < 8) and (teams[i].hogsNumber > 0) do |
|
221 |
begin |
|
222 |
inc(i); |
|
223 |
inc(hedgehogsNumber, teams[i].hogsNumber) |
|
224 |
end; |
|
225 |
||
226 |
// no free space for a team or reached hogs number maximum |
|
227 |
if (i > 7) or (hedgehogsNumber >= 48) then exit; |
|
228 |
||
229 |
team:= teamByName(teamName); |
|
230 |
if team = nil then exit; |
|
231 |
||
10448 | 232 |
c:= getUnusedColor; |
233 |
||
10446 | 234 |
teams[i]:= team^; |
235 |
||
236 |
if i = 0 then hn:= 4 else hn:= teams[i - 1].hogsNumber; |
|
237 |
if hn > 48 - hedgehogsNumber then hn:= 48 - hedgehogsNumber; |
|
238 |
teams[i].hogsNumber:= hn; |
|
10448 | 239 |
|
240 |
teams[i].color:= c; |
|
10446 | 241 |
|
10452
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
242 |
msg:= '0' + #10 + teamName; |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
243 |
guiCallbackFunction(guiCallbackPointer, mtAddPlayingTeam, @msg[1], length(msg)); |
10444
47a6231f1fc1
Teams widget now allows to add and remove teams (basic implementation, no checks performed, no colors, no hedgehogs)
unc0rr
parents:
10432
diff
changeset
|
244 |
|
10452
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
245 |
msg:= teamName + #10 + colorsSet[teams[i].color]; |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
246 |
guiCallbackFunction(guiCallbackPointer, mtTeamColor, @msg[1], length(msg)); |
10444
47a6231f1fc1
Teams widget now allows to add and remove teams (basic implementation, no checks performed, no colors, no hedgehogs)
unc0rr
parents:
10432
diff
changeset
|
247 |
|
10452
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
248 |
msg:= teamName; |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
249 |
guiCallbackFunction(guiCallbackPointer, mtRemoveTeam, @msg[1], length(msg)) |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
250 |
end |
10444
47a6231f1fc1
Teams widget now allows to add and remove teams (basic implementation, no checks performed, no colors, no hedgehogs)
unc0rr
parents:
10432
diff
changeset
|
251 |
end; |
47a6231f1fc1
Teams widget now allows to add and remove teams (basic implementation, no checks performed, no colors, no hedgehogs)
unc0rr
parents:
10432
diff
changeset
|
252 |
|
10448 | 253 |
|
10452
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
254 |
procedure tryRemoveTeam(teamName: PChar); cdecl; |
10444
47a6231f1fc1
Teams widget now allows to add and remove teams (basic implementation, no checks performed, no colors, no hedgehogs)
unc0rr
parents:
10432
diff
changeset
|
255 |
var msg: ansistring; |
10448 | 256 |
i: Longword; |
257 |
tn: shortstring; |
|
10444
47a6231f1fc1
Teams widget now allows to add and remove teams (basic implementation, no checks performed, no colors, no hedgehogs)
unc0rr
parents:
10432
diff
changeset
|
258 |
begin |
10448 | 259 |
with currentConfig do |
260 |
begin |
|
261 |
i:= 0; |
|
262 |
tn:= teamName; |
|
263 |
while (i < 8) and (teams[i].teamName <> tn) do |
|
264 |
inc(i); |
|
265 |
||
266 |
// team not found??? |
|
267 |
if (i > 7) then exit; |
|
268 |
||
269 |
while (i < 7) and (teams[i + 1].hogsNumber > 0) do |
|
270 |
begin |
|
271 |
teams[i]:= teams[i + 1]; |
|
272 |
inc(i) |
|
273 |
end; |
|
274 |
||
275 |
teams[i].hogsNumber:= 0 |
|
276 |
end; |
|
277 |
||
10444
47a6231f1fc1
Teams widget now allows to add and remove teams (basic implementation, no checks performed, no colors, no hedgehogs)
unc0rr
parents:
10432
diff
changeset
|
278 |
msg:= teamName; |
47a6231f1fc1
Teams widget now allows to add and remove teams (basic implementation, no checks performed, no colors, no hedgehogs)
unc0rr
parents:
10432
diff
changeset
|
279 |
|
47a6231f1fc1
Teams widget now allows to add and remove teams (basic implementation, no checks performed, no colors, no hedgehogs)
unc0rr
parents:
10432
diff
changeset
|
280 |
guiCallbackFunction(guiCallbackPointer, mtRemovePlayingTeam, @msg[1], length(msg)); |
47a6231f1fc1
Teams widget now allows to add and remove teams (basic implementation, no checks performed, no colors, no hedgehogs)
unc0rr
parents:
10432
diff
changeset
|
281 |
guiCallbackFunction(guiCallbackPointer, mtAddTeam, @msg[1], length(msg)) |
47a6231f1fc1
Teams widget now allows to add and remove teams (basic implementation, no checks performed, no colors, no hedgehogs)
unc0rr
parents:
10432
diff
changeset
|
282 |
end; |
47a6231f1fc1
Teams widget now allows to add and remove teams (basic implementation, no checks performed, no colors, no hedgehogs)
unc0rr
parents:
10432
diff
changeset
|
283 |
|
10452
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
284 |
|
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
285 |
procedure changeTeamColor(teamName: PChar; dir: LongInt); cdecl; |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
286 |
var i, dc: Longword; |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
287 |
tn: shortstring; |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
288 |
msg: ansistring; |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
289 |
begin |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
290 |
with currentConfig do |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
291 |
begin |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
292 |
i:= 0; |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
293 |
tn:= teamName; |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
294 |
while (i < 8) and (teams[i].teamName <> tn) do |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
295 |
inc(i); |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
296 |
// team not found??? |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
297 |
if (i > 7) then exit; |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
298 |
|
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
299 |
if dir >= 0 then dc:= 1 else dc:= 8; |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
300 |
teams[i].color:= (teams[i].color + dc) mod 9; |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
301 |
|
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
302 |
msg:= tn + #10 + colorsSet[teams[i].color]; |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
303 |
guiCallbackFunction(guiCallbackPointer, mtTeamColor, @msg[1], length(msg)) |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
304 |
end |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
305 |
end; |
03519fd9f98d
Show team color in teams list widget, also allow to change it on mouse click
unc0rr
parents:
10450
diff
changeset
|
306 |
|
10456 | 307 |
procedure setTheme(themeName: PChar); cdecl; |
308 |
begin |
|
309 |
currentConfig.theme:= themeName |
|
310 |
end; |
|
311 |
||
10406 | 312 |
end. |