source: branches/delphi/LocalPlayer/Tribes.pas

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