source: branches/AlphaChannel/LocalPlayer/Tribes.pas

Last change on this file was 98, checked in by chronos, 9 years ago
  • Fixed: Tribe special unit names were not loaded correctly.
File size: 17.8 KB
Line 
1{$INCLUDE Switches.inc}
2unit Tribes;
3
4interface
5
6uses
7 Protocol, ScreenTools, LazFileUtils,
8 Classes, Graphics, SysUtils;
9
10type
11 TCityPicture = record
12 xShield, yShield: integer;
13 end;
14
15 TModelPicture = record
16 HGr, pix, xShield, yShield: integer;
17 end;
18
19 TModelPictureInfo = record
20 trix, mix, pix, Hash: integer;
21 GrName: ShortString;
22 end;
23
24 TTribe = class
25 symHGr, sympix, faceHGr, facepix, cHGr, cpix,
26 // symbol and city graphics
27 cAge, mixSlaves: integer;
28 Color: TColor;
29 NumberName: integer;
30 CityPicture: array [0 .. 3] of TCityPicture;
31 ModelPicture: array [-1 .. 256] of TModelPicture; // -1 is building site
32 ModelName: array [-1 .. 256] of string;
33 constructor Create(FileName: string);
34 destructor Destroy; override;
35 function GetCityName(i: integer): string;
36{$IFNDEF SCR} procedure SetCityName(i: integer; NewName: string); {$ENDIF}
37{$IFNDEF SCR} function TString(Template: string): string;
38 function TPhrase(Item: string): string; {$ENDIF}
39 procedure SetModelPicture(const Info: TModelPictureInfo; IsNew: boolean);
40 function ChooseModelPicture(var Picture: TModelPictureInfo;
41 code, Turn: integer; ForceNew: boolean): boolean;
42 procedure InitAge(Age: integer);
43 protected
44 CityLine0, nCityLines: integer;
45 Name: array ['a' .. 'z'] of string;
46 Script: tstringlist;
47 end;
48
49var
50 Tribe: array [0 .. nPl - 1] of TTribe;
51 HGrStdUnits: integer;
52
53procedure Init;
54procedure Done;
55function CityName(Founder: integer): string;
56function ModelCode(const ModelInfo: TModelInfo): integer;
57procedure FindStdModelPicture(code: integer; var pix: integer;
58 var Name: string);
59function GetTribeInfo(FileName: string; var Name: string;
60 var Color: TColor): boolean;
61procedure FindPosition(HGr, x, y, xmax, ymax: integer; Mark: TColor;
62 var xp, yp: integer);
63
64implementation
65
66uses
67 Directories;
68
69type
70 TChosenModelPictureInfo = record
71 Hash, HGr, pix: integer;
72 ModelName: ShortString end;
73
74 TPictureList = array [0 .. 99999] of TChosenModelPictureInfo;
75
76 var
77 StdUnitScript: tstringlist;
78 PictureList: ^TPictureList;
79 nPictureList: integer;
80
81 procedure Init;
82 begin
83 StdUnitScript := tstringlist.Create;
84 StdUnitScript.LoadFromFile(LocalizedFilePath('Tribes' + DirectorySeparator + 'StdUnits.txt'));
85 nPictureList := 0;
86 PictureList := nil;
87 end;
88
89 procedure Done;
90 begin
91 ReallocMem(PictureList, 0);
92 StdUnitScript.Free;
93 end;
94
95 function CityName(Founder: integer): string;
96 begin
97 if not GenerateNames then
98 result := Format('%d.%d', [Founder shr 12, Founder and $FFF])
99 else
100 result := Tribe[Founder shr 12].GetCityName(Founder and $FFF);
101 end;
102
103 function ModelCode(const ModelInfo: TModelInfo): integer;
104 begin
105 with ModelInfo do
106 begin
107 case Kind of
108 mkSelfDeveloped, mkEnemyDeveloped:
109 case Domain of { age determination }
110 dGround:
111 if (Attack >= Defense * 4) or (Attack > 0) and (MaxUpgrade < 10)
112 and (Cap and (1 shl (mcArtillery - mcFirstNonCap)) <> 0) then
113 begin
114 result := 170;
115 if MaxUpgrade >= 12 then
116 inc(result, 3)
117 else if (MaxUpgrade >= 10) or (Weight > 7) then
118 inc(result, 2)
119 else if MaxUpgrade >= 4 then
120 inc(result, 1)
121 end
122 else
123 begin
124 result := 100;
125 if MaxUpgrade >= 12 then
126 inc(result, 6)
127 else if (MaxUpgrade >= 10) or (Weight > 7) then
128 inc(result, 5)
129 else if MaxUpgrade >= 6 then
130 inc(result, 4)
131 else if MaxUpgrade >= 4 then
132 inc(result, 3)
133 else if MaxUpgrade >= 2 then
134 inc(result, 2)
135 else if MaxUpgrade >= 1 then
136 inc(result, 1);
137 if Speed >= 250 then
138 if (result >= 105) and (Attack <= Defense) then
139 result := 110
140 else
141 inc(result, 30)
142 end;
143 dSea:
144 begin
145 result := 200;
146 if MaxUpgrade >= 8 then
147 inc(result, 3)
148 else if MaxUpgrade >= 6 then
149 inc(result, 2)
150 else if MaxUpgrade >= 3 then
151 inc(result, 1);
152 if Cap and (1 shl (mcSub - mcFirstNonCap)) <> 0 then
153 result := 240
154 else if ATrans_Fuel > 0 then
155 result := 220
156 else if (result >= 202) and (Attack = 0) and (TTrans > 0) then
157 result := 210;
158 end;
159 dAir:
160 begin
161 result := 300;
162 if (Bombs > 0) or (TTrans > 0) then
163 inc(result, 10);
164 if Speed > 850 then
165 inc(result, 1)
166 end;
167 end;
168 mkSpecial_TownGuard:
169 result := 41;
170 mkSpecial_Boat:
171 result := 64;
172 mkSpecial_SubCabin:
173 result := 71;
174 mkSpecial_Glider:
175 result := 73;
176 mkSlaves:
177 result := 74;
178 mkSettler:
179 if Speed > 150 then
180 result := 11
181 else
182 result := 10;
183 mkDiplomat:
184 result := 21;
185 mkCaravan:
186 result := 30;
187 end;
188 end;
189 end;
190
191 var
192 Input: string;
193
194 function Get: string;
195
196 var
197 p: integer;
198 begin
199 while (Input <> '') and ((Input[1] = ' ') or (Input[1] = #9)) do
200 Delete(Input, 1, 1);
201 p := pos(',', Input);
202 if p = 0 then
203 p := Length(Input) + 1;
204 result := Copy(Input, 1, p - 1);
205 Delete(Input, 1, p)
206 end;
207
208 function GetNum: integer;
209
210 var
211 i: integer;
212 begin
213 val(Get, result, i);
214 if i <> 0 then
215 result := 0
216 end;
217
218 procedure FindStdModelPicture(code: integer; var pix: integer;
219 var Name: string);
220
221 var
222 i: integer;
223 begin
224 for i := 0 to StdUnitScript.Count - 1 do
225 begin // look through StdUnits
226 Input := StdUnitScript[i];
227 pix := GetNum;
228 if code = GetNum then
229 begin
230 Name := Get;
231 exit;
232 end
233 end;
234 pix := -1
235 end;
236
237 function GetTribeInfo(FileName: string; var Name: string;
238 var Color: TColor): boolean;
239
240 var
241 found: integer;
242 TribeScript: TextFile;
243 begin
244 Name := '';
245 Color := $FFFFFF;
246 found := 0;
247 AssignFile(TribeScript, LocalizedFilePath('Tribes' + DirectorySeparator + FileName +
248 '.tribe.txt'));
249 Reset(TribeScript);
250 while not EOF(TribeScript) do
251 begin
252 ReadLn(TribeScript, Input);
253 if Copy(Input, 1, 7) = '#CHOOSE' then
254 begin
255 Name := Copy(Input, 9, 255);
256 found := found or 1;
257 if found = 3 then
258 break
259 end
260 else if Copy(Input, 1, 6) = '#COLOR' then
261 begin
262 Color := HexStringToColor(Copy(Input, 7, 255));
263 found := found or 2;
264 if found = 3 then
265 break
266 end
267 end;
268 CloseFile(TribeScript);
269 result := found = 3;
270 end;
271
272 constructor TTribe.Create(FileName: string);
273
274 var
275 line: integer;
276 variant: char;
277 Item: string;
278 begin
279 inherited Create;
280 for variant := 'a' to 'z' do
281 Name[variant] := '';
282 Script := tstringlist.Create;
283 Script.LoadFromFile(LocalizedFilePath('Tribes' + DirectorySeparator + FileName + '.tribe.txt'));
284 CityLine0 := 0;
285 nCityLines := 0;
286 for line := 0 to Script.Count - 1 do
287 begin
288 Input := Script[line];
289 if (CityLine0 > 0) and (nCityLines = 0) and
290 ((Input = '') or (Input[1] = '#')) then
291 nCityLines := line - CityLine0;
292 if (Length(Input) >= 3) and (Input[1] = '#') and (Input[2] in ['a' .. 'z']
293 ) and (Input[3] = ' ') then
294 Name[Input[2]] := Copy(Input, 4, 255)
295 else if Copy(Input, 1, 6) = '#COLOR' then
296 Color := HexStringToColor(Copy(Input, 7, 255))
297 else if Copy(Input, 1, 7) = '#CITIES' then
298 CityLine0 := line + 1
299 else if Copy(Input, 1, 8) = '#SYMBOLS' then
300 begin
301 Delete(Input, 1, 9);
302 Item := Get;
303 sympix := GetNum;
304 symHGr := LoadGraphicSet(Item + '.png');
305 end
306 end;
307 FillChar(ModelPicture, SizeOf(ModelPicture), 0);
308 NumberName := -1;
309 cAge := -1;
310 mixSlaves := -1;
311 end;
312
313 destructor TTribe.Destroy;
314 begin
315 Script.Free;
316 inherited Destroy;
317 end;
318
319 procedure FindPosition(HGr, x, y, xmax, ymax: integer; Mark: TColor;
320 var xp, yp: integer);
321 begin
322 xp := 0;
323 while (xp < xmax) and (GrExt[HGr].Data.Canvas.Pixels[x + 1 + xp, y]
324 <> Mark) do
325 inc(xp);
326 yp := 0;
327 while (yp < ymax) and (GrExt[HGr].Data.Canvas.Pixels[x, y + 1 + yp]
328 <> Mark) do
329 inc(yp);
330 end;
331
332 function TTribe.GetCityName(i: integer): string;
333 begin
334 result := '';
335 if nCityLines > i then
336 begin
337 result := Script[CityLine0 + i];
338 while (result <> '') and ((result[1] = ' ') or (result[1] = #9)) do
339 Delete(result, 1, 1);
340 end
341{$IFNDEF SCR} else
342 result := Format(TPhrase('GENCITY'), [i + 1]){$ENDIF}
343 end;
344
345{$IFNDEF SCR}
346 procedure TTribe.SetCityName(i: integer; NewName: string);
347 begin
348 while nCityLines <= i do
349 begin
350 Script.Insert(CityLine0 + nCityLines, Format(TPhrase('GENCITY'),
351 [nCityLines + 1]));
352 inc(nCityLines);
353 end;
354 Script[CityLine0 + i] := NewName;
355 end;
356
357 function TTribe.TString(Template: string): string;
358
359 var
360 p: integer;
361 variant: char;
362 CaseUp: boolean;
363 begin
364 repeat
365 p := pos('#', Template);
366 if (p = 0) or (p = Length(Template)) then
367 break;
368 variant := Template[p + 1];
369 CaseUp := variant in ['A' .. 'Z'];
370 if CaseUp then
371 inc(variant, 32);
372 Delete(Template, p, 2);
373 if variant in ['a' .. 'z'] then
374 begin
375 if NumberName < 0 then
376 Insert(Name[variant], Template, p)
377 else
378 Insert(Format('P%d', [NumberName]), Template, p);
379 if CaseUp and (Length(Template) >= p) and
380 (Template[p] in ['a' .. 'z', #$E0 .. #$FF]) then
381 dec(Template[p], 32);
382 end
383 until false;
384 result := Template;
385 end;
386
387 function TTribe.TPhrase(Item: string): string;
388 begin
389 result := TString(Phrases.Lookup(Item));
390 end;
391{$ENDIF}
392
393 procedure TTribe.InitAge(Age: integer);
394 type
395 TLine = array [0 .. 649, 0 .. 2] of Byte;
396 var
397 i, x, gray: integer;
398 Item: string;
399 begin
400 if Age = cAge then
401 exit;
402 cAge := Age;
403 with Script do
404 begin
405 i := 0;
406 while (i < Count) and
407 (Copy(Strings[i], 1, 6) <> '#AGE' + char(48 + Age) + ' ') do
408 inc(i);
409 if i < Count then
410 begin
411 Input := Strings[i];
412 system.Delete(Input, 1, 6);
413 Item := Get;
414 cpix := GetNum;
415 // init city graphics
416 if Age < 2 then
417 begin
418 if CompareText(Item, 'stdcities') = 0 then
419 case cpix of
420 3:
421 cpix := 0;
422 6:
423 begin
424 cpix := 0;
425 Item := 'Nation2';
426 end
427 end;
428 cHGr := LoadGraphicSet(Item + '.png');
429 for x := 0 to 3 do
430 with CityPicture[x] do
431 begin
432 FindPosition(cHGr, x * 65, cpix * 49, 63, 47, $00FFFF,
433 xShield, yShield);
434 // FindPosition(cHGr,x*65,cpix*49,$FFFFFF,xf,yf);
435 end
436 end
437 else
438 cHGr := -1;
439
440{$IFNDEF SCR}
441 Get;
442 GetNum;
443 Item := Get;
444 if Item = '' then
445 faceHGr := -1
446 else
447 begin
448 faceHGr := LoadGraphicSet(Item + '.png');
449 facepix := GetNum;
450 if GrExt[faceHGr].Data.Canvas.Pixels[facepix mod 10 * 65,
451 facepix div 10 * 49 + 48] = $00FFFF then
452 begin // generate shield picture
453 GrExt[faceHGr].Data.Canvas.Pixels[facepix mod 10 * 65,
454 facepix div 10 * 49 + 48] := $000000;
455 gray := $B8B8B8;
456 ImageOp_BCC(GrExt[faceHGr].Data, Templates,
457 facepix mod 10 * 65 + 1, facepix div 10 * 49 + 1, 1, 25, 64, 48,
458 gray, Color);
459 end
460 end;
461{$ENDIF}
462 end
463 end
464 end;
465
466 procedure TTribe.SetModelPicture(const Info: TModelPictureInfo;
467 IsNew: boolean);
468 var
469 i: integer;
470 ok: boolean;
471 begin
472 with Info do
473 begin
474 if not IsNew then
475 begin
476 i := nPictureList - 1;
477 while (i >= 0) and (PictureList[i].Hash <> Info.Hash) do
478 dec(i);
479 assert(i >= 0);
480 assert(PictureList[i].HGr = LoadGraphicSet(GrName));
481 assert(PictureList[i].pix = pix);
482 ModelPicture[mix].HGr := PictureList[i].HGr;
483 ModelPicture[mix].pix := PictureList[i].pix;
484 ModelName[mix] := PictureList[i].ModelName;
485 end
486 else
487 begin
488 with ModelPicture[mix] do
489 begin
490 HGr := LoadGraphicSet(GrName);
491 pix := Info.pix;
492 inc(GrExt[HGr].pixUsed[pix]);
493 end;
494 ModelName[mix] := '';
495
496 // read model name from tribe script
497 ok := false;
498 for i := 0 to Script.Count - 1 do
499 begin
500 Input := Script[i];
501 if Input = '#UNITS ' + ExtractFileNameOnly(GrName) then
502 ok := true
503 else if (Input <> '') and (Input[1] = '#') then
504 ok := false
505 else if ok and (GetNum = pix) then
506 begin
507 Get;
508 ModelName[mix] := Get
509 end
510 end;
511
512 if ModelName[mix] = '' then
513 begin // read model name from StdUnits.txt
514 for i := 0 to StdUnitScript.Count - 1 do
515 begin
516 Input := StdUnitScript[i];
517 if GetNum = pix then
518 begin
519 Get;
520 ModelName[mix] := Get
521 end
522 end
523 end;
524
525 if Hash <> 0 then
526 begin
527 if nPictureList = 0 then
528 ReallocMem(PictureList, 64 * SizeOf(TChosenModelPictureInfo))
529 else if (nPictureList >= 64) and
530 (nPictureList and (nPictureList - 1) = 0) then
531 ReallocMem(PictureList,
532 nPictureList * (2 * SizeOf(TChosenModelPictureInfo)));
533 PictureList[nPictureList].Hash := Info.Hash;
534 PictureList[nPictureList].HGr := ModelPicture[mix].HGr;
535 PictureList[nPictureList].pix := Info.pix;
536 PictureList[nPictureList].ModelName := ModelName[mix];
537 inc(nPictureList);
538 end
539 end;
540
541 with ModelPicture[mix] do
542 FindPosition(HGr, pix mod 10 * 65, pix div 10 * 49, 63, 47, $FFFFFF,
543 xShield, yShield);
544 end;
545 end;
546
547 function TTribe.ChooseModelPicture(var Picture: TModelPictureInfo;
548 code, Turn: integer; ForceNew: boolean): boolean;
549 var
550 i, Cnt, HGr, used, LeastUsed: integer;
551 TestPic: TModelPictureInfo;
552 ok: boolean;
553
554 procedure check;
555 begin
556 TestPic.pix := GetNum;
557 if code = GetNum then
558 begin
559 if ForceNew or (HGr < 0) then
560 used := 0
561 else
562 begin
563 used := 4 * GrExt[HGr].pixUsed[TestPic.pix];
564 if HGr = HGrStdUnits then
565 inc(used, 2); // prefer units not from StdUnits
566 end;
567 if used < LeastUsed then
568 begin
569 Cnt := 0;
570 LeastUsed := used
571 end;
572 if used = LeastUsed then
573 begin
574 inc(Cnt);
575 if Turn mod Cnt = 0 then
576 Picture := TestPic
577 end;
578 end
579 end;
580
581 begin
582 // look for identical model to assign same picture again
583 if not ForceNew and (Picture.Hash > 0) then
584 begin
585 for i := 0 to nPictureList - 1 do
586 if PictureList[i].Hash = Picture.Hash then
587 begin
588 Picture.GrName := GrExt[PictureList[i].HGr].Name;
589 Picture.pix := PictureList[i].pix;
590 result := false;
591 exit;
592 end
593 end;
594
595 Picture.pix := 0;
596 TestPic := Picture;
597 LeastUsed := MaxInt;
598
599 TestPic.GrName := 'StdUnits.png';
600 HGr := HGrStdUnits;
601 for i := 0 to StdUnitScript.Count - 1 do
602 begin // look through StdUnits
603 Input := StdUnitScript[i];
604 check;
605 end;
606
607 ok := false;
608 for i := 0 to Script.Count - 1 do
609 begin // look through units defined in tribe script
610 Input := Script[i];
611 if Copy(Input, 1, 6) = '#UNITS' then
612 begin
613 ok := true;
614 TestPic.GrName := Copy(Input, 8, 255) + '.png';
615 HGr := nGrExt - 1;
616 while (HGr >= 0) and (GrExt[HGr].Name <> TestPic.GrName) do
617 dec(HGr);
618 end
619 else if (Input <> '') and (Input[1] = '#') then
620 ok := false
621 else if ok then
622 check;
623 end;
624 result := true;
625 end;
626
627end.
Note: See TracBrowser for help on using the repository browser.