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