Context Navigation

source: tags/1.3.6/LocalPlayer/Tribes.pas

Last change on this file was 532, checked in by chronos, 19 months ago
Modified: Code cleanup.
File size: 16.5 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: