Ignore:
Timestamp:
Jan 7, 2017, 11:32:14 AM (7 years ago)
Author:
chronos
Message:
  • Modified: Formated all project source files using Delphi formatter as original indentation and other formatting was really bad.
File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/LocalPlayer/Tribes.pas

    r2 r6  
    11{$INCLUDE switches}
    2 
    32unit Tribes;
    43
    … …  
    65
    76uses
    8   Protocol,ScreenTools,
    9 
    10   Classes,Graphics,SysUtils;
     7  Protocol, ScreenTools,
     8
     9  Classes, Graphics, SysUtils;
    1110
    1211type
    13 TCityPicture=record
    14   xShield,yShield:integer;
    15   end;
    16 TModelPicture=record
    17   HGr,pix,xShield,yShield:integer;
    18   end;
    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, //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;
     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;
    4646  end;
    4747
    4848var
    49 Tribe: array[0..nPl-1] of TTribe;
    50 HGrStdUnits: integer;
     49  Tribe: array [0 .. nPl - 1] of TTribe;
     50  HGrStdUnits: integer;
    5151
    5252procedure Init;
    … …  
    5656procedure FindStdModelPicture(code: integer; var pix: integer;
    5757  var Name: string);
    58 function GetTribeInfo(FileName: string; var Name: string; var Color: TColor): boolean;
    59 procedure FindPosition(HGr,x,y,xmax,ymax: integer; Mark: TColor; var xp,yp: integer);
    60 
     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);
    6162
    6263implementation
    6364
    6465uses
    65 Directories;
    66 
     66  Directories;
    6767
    6868type
    69 TChosenModelPictureInfo=record
    70   Hash,HGr,pix: integer;
    71   ModelName: ShortString
    72   end;
    73 
    74 TPictureList=array[0..99999] of TChosenModelPictureInfo;
    75 
    76 var
    77 StdUnitScript: tstringlist;
    78 PictureList: ^TPictureList;
    79 nPictureList: integer;
    80 
    81 
    82 procedure Init;
    83 begin
    84 StdUnitScript:=tstringlist.Create;
    85 StdUnitScript.LoadFromFile(LocalizedFilePath('Tribes\StdUnits.txt'));
    86 nPictureList:=0;
    87 PictureList:=nil;
    88 end;
    89 
    90 procedure Done;
    91 begin
    92 ReallocMem(PictureList,0);
    93 StdUnitScript.Free;
    94 end;
    95 
    96 function CityName(Founder: integer): string;
    97 begin
    98 if not GenerateNames then
    99   result:=Format('%d.%d',[Founder shr 12, Founder and $FFF])
    100 else 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)
    112             or (Attack>0) and (MaxUpgrade<10)
    113               and (Cap and (1 shl (mcArtillery-mcFirstNonCap))<>0) then
    114             begin
    115             result:=170;
    116             if MaxUpgrade>=12 then inc(result,3)
    117             else if (MaxUpgrade>=10) or (Weight>7) then inc(result,2)
    118             else if MaxUpgrade>=4 then inc(result,1)
     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);
    119458            end
    120           else
    121             begin
    122             result:=100;
    123             if MaxUpgrade>=12 then inc(result,6)
    124             else if (MaxUpgrade>=10) or (Weight>7) then inc(result,5)
    125             else if MaxUpgrade>=6 then inc(result,4)
    126             else if MaxUpgrade>=4 then inc(result,3)
    127             else if MaxUpgrade>=2 then inc(result,2)
    128             else if MaxUpgrade>=1 then inc(result,1);
    129             if Speed>=250 then
    130               if (result>=105) and (Attack<=Defense) then result:=110
    131               else inc(result,30)
    132             end;
    133         dSea:
    134           begin
    135           result:=200;
    136           if MaxUpgrade>=8 then inc(result,3)
    137           else if MaxUpgrade>=6 then inc(result,2)
    138           else if MaxUpgrade>=3 then inc(result,1);
    139           if Cap and (1 shl (mcSub-mcFirstNonCap))<>0 then result:=240
    140           else if ATrans_Fuel>0 then result:=220
    141           else if (result>=202) and (Attack=0) and (TTrans>0) then result:=210;
    142459          end;
    143         dAir:
    144           begin
    145           result:=300;
    146           if (Bombs>0) or (TTrans>0) then inc(result,10);
    147           if Speed>850 then inc(result,1)
    148           end;
    149         end;
    150     mkSpecial_TownGuard: result:=41;
    151     mkSpecial_Boat: result:=64;
    152     mkSpecial_SubCabin: result:=71;
    153     mkSpecial_Glider: result:=73;
    154     mkSlaves: result:=74;
    155     mkSettler: if Speed>150 then result:=11 else result:=10;
    156     mkDiplomat: result:=21;
    157     mkCaravan: result:=30;
    158     end;
    159   end;
    160 end;
    161 
    162 var
    163 Input: string;
    164 
    165 function Get: string;
    166 var
    167 p:integer;
    168 begin
    169 while (Input<>'') and ((Input[1]=' ') or (Input[1]=#9)) do Delete(Input,1,1);
    170 p:=pos(',',Input);if p=0 then p:=Length(Input)+1;
    171 result:=Copy(Input,1,p-1);
    172 Delete(Input,1,p)
    173 end;
    174 
    175 function GetNum: integer;
    176 var
    177 i:integer;
    178 begin
    179 val(Get,result,i);
    180 if i<>0 then result:=0
    181 end;
    182 
    183 procedure FindStdModelPicture(code: integer; var pix: integer;
    184   var Name: string);
    185 var
    186 i: integer;
    187 begin
    188 for i:=0 to StdUnitScript.Count-1 do
    189   begin // look through StdUnits
    190   Input:=StdUnitScript[i];
    191   pix:=GetNum;
    192   if code=GetNum then begin Name:=Get; exit; end
    193   end;
    194 pix:=-1
    195 end;
    196 
    197 function GetTribeInfo(FileName: string; var Name: string; var Color: TColor): boolean;
    198 var
    199 found: integer;
    200 TribeScript: TextFile;
    201 begin
    202 Name:='';
    203 Color:=$FFFFFF;
    204 found:=0;
    205 AssignFile(TribeScript,LocalizedFilePath('Tribes\'+FileName+'.tribe.txt'));
    206 Reset(TribeScript);
    207 while not EOF(TribeScript) do
    208   begin
    209   ReadLn(TribeScript,Input);
    210   if Copy(Input,1,7)='#CHOOSE' then
    211     begin
    212     Name:=Copy(Input,9,255);
    213     found:=found or 1;
    214     if found=3 then break
    215     end
    216   else if Copy(Input,1,6)='#COLOR' then
    217     begin
    218     Color:=HexStringToColor(Copy(Input,7,255));
    219     found:=found or 2;
    220     if found=3 then break
    221     end
    222   end;
    223 CloseFile(TribeScript);
    224 result:= found=3;
    225 end;
    226 
    227 constructor TTribe.Create(FileName: string);
    228 var
    229 line:integer;
    230 variant: char;
    231 Item:string;
    232 begin
    233 inherited Create;
    234 for variant:='a' to 'z' do Name[variant]:='';
    235 Script:=tstringlist.Create;
    236 Script.LoadFromFile(LocalizedFilePath('Tribes\'+FileName+'.tribe.txt'));
    237 CityLine0:=0;
    238 nCityLines:=0;
    239 for line:=0 to Script.Count-1 do
    240   begin
    241   Input:=Script[line];
    242   if (CityLine0>0) and (nCityLines=0) and ((Input='') or (Input[1]='#')) then
    243     nCityLines:=line-CityLine0;
    244   if (Length(Input)>=3) and (Input[1]='#') and (Input[2] in ['a'..'z'])
    245     and (Input[3]=' ') then
    246     Name[Input[2]]:=Copy(Input,4,255)
    247   else if Copy(Input,1,6)='#COLOR' then
    248     Color:=HexStringToColor(Copy(Input,7,255))
    249   else if Copy(Input,1,7)='#CITIES' then CityLine0:=line+1
    250   else if Copy(Input,1,8)='#SYMBOLS' then
    251     begin
    252     Delete(Input,1,9);
    253     Item:=Get;
    254     sympix:=GetNum;
    255     symHGr:=LoadGraphicSet(Item);
    256     end
    257   end;
    258 FillChar(ModelPicture,SizeOf(ModelPicture),0);
    259 NumberName:=-1;
    260 cAge:=-1;
    261 mixSlaves:=-1;
    262 end;
    263 
    264 destructor TTribe.Destroy;
    265 begin
    266 Script.Free;
    267 inherited Destroy;
    268 end;
    269 
    270 procedure FindPosition(HGr,x,y,xmax,ymax: integer; Mark: TColor;
    271   var xp,yp: integer);
    272 begin
    273 xp:=0;
    274 while (xp<xmax) and (GrExt[HGr].Data.Canvas.Pixels[x+1+xp,y]<>Mark) do
    275   inc(xp);
    276 yp:=0;
    277 while (yp<ymax) and (GrExt[HGr].Data.Canvas.Pixels[x,y+1+yp]<>Mark) do
    278   inc(yp);
    279 end;
    280 
    281 function TTribe.GetCityName(i: integer): string;
    282 begin
    283 result:='';
    284 if nCityLines>i then
    285   begin
    286   result:=Script[CityLine0+i];
    287   while (result<>'') and ((result[1]=' ') or (result[1]=#9)) do
    288     Delete(result,1,1);
    289   end
    290 {$IFNDEF SCR}else result:=Format(TPhrase('GENCITY'),[i+1]){$ENDIF}
    291 end;
    292 
    293 {$IFNDEF SCR}
    294 procedure TTribe.SetCityName(i: integer; NewName: string);
    295 begin
    296 while nCityLines<=i do
    297   begin
    298   Script.Insert(CityLine0+nCityLines, Format(TPhrase('GENCITY'),
    299     [nCityLines+1]));
    300   inc(nCityLines);
    301   end;
    302 Script[CityLine0+i]:=NewName;
    303 end;
    304 
    305 function TTribe.TString(Template: string): string;
    306 var
    307 p: integer;
    308 variant: char;
    309 CaseUp: boolean;
    310 begin
    311 repeat
    312   p:=pos('#',Template);
    313   if (p=0) or (p=Length(Template)) then Break;
    314   variant:=Template[p+1];
    315   CaseUp:= variant in ['A'..'Z'];
    316   if CaseUp then inc(variant,32);
    317   Delete(Template,p,2);
    318   if variant in ['a'..'z'] then
    319     begin
    320     if NumberName<0 then Insert(Name[variant],Template,p)
    321     else Insert(Format('P%d',[NumberName]),Template,p);
    322     if CaseUp and (Length(Template)>=p) and (Template[p] in ['a'..'z',#$E0..#$FF]) then
    323       dec(Template[p],32);
    324     end
    325 until false;
    326 result:=Template;
    327 end;
    328 
    329 function TTribe.TPhrase(Item: string): string;
    330 begin
    331 result:=TString(Phrases.Lookup(Item));
    332 end;
    333460{$ENDIF}
    334 
    335 procedure TTribe.InitAge(Age: integer);
    336 type
    337 TLine=array[0..649,0..2] of Byte;
    338 var
    339 i,x,gray: integer;
    340 Item: string;
    341 begin
    342 if Age=cAge then exit;
    343 cAge:=Age;
    344 with Script do
    345   begin
    346   i:=0;
    347   while (i<Count) and (Copy(Strings[i],1,6)<>'#AGE'+char(48+Age)+' ') do
    348     inc(i);
    349   if i<Count then
    350     begin
    351     Input:=Strings[i];
    352     system.Delete(Input,1,6);
    353     Item:=Get;
    354     cpix:=GetNum;
    355     // init city graphics
    356     if age<2 then
    357       begin
    358       if CompareText(Item,'stdcities')=0 then
    359         case cpix of
    360           3: cpix:=0;
    361           6: begin cpix:=0; Item:='Nation2'; end
    362           end;
    363       cHGr:=LoadGraphicSet(Item);
    364       for x:=0 to 3 do with CityPicture[x] do
    365         begin
    366         FindPosition(cHGr,x*65,cpix*49,63,47,$00FFFF,xShield,yShield);
    367         //FindPosition(cHGr,x*65,cpix*49,$FFFFFF,xf,yf);
    368461        end
    369462      end
    370     else cHGr:=-1;
    371 
    372     {$IFNDEF SCR}
    373     Get;
    374     GetNum;
    375     Item:=Get;
    376     if Item='' then faceHGr:=-1
    377     else
    378       begin
    379       faceHGr:=LoadGraphicSet(Item);
    380       facepix:=GetNum;
    381       if GrExt[faceHGr].Data.Canvas.Pixels[facepix mod 10*65,facepix div 10*49+48]=$00FFFF then
    382         begin // generate shield picture
    383         GrExt[faceHGr].Data.Canvas.Pixels[facepix mod 10*65,facepix div 10*49+48]:=$000000;
    384         gray:=$B8B8B8;
    385         ImageOp_BCC(GrExt[faceHGr].Data,Templates,facepix mod 10*65+1,
    386           facepix div 10*49+1,1,25,64,48,gray,Color);
     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;
    387577        end
    388578      end;
    389     {$ENDIF} 
    390     end
    391   end
    392 end;
    393 
    394 procedure TTribe.SetModelPicture(const Info: TModelPictureInfo; IsNew: boolean);
    395 var
    396 i: integer;
    397 ok: boolean;
    398 begin
    399 with Info do
    400   begin
    401   if not IsNew then
    402     begin
    403     i:=nPictureList-1;
    404     while (i>=0) and (PictureList[i].Hash<>Info.Hash) do dec(i);
    405     assert(i>=0);
    406     assert(PictureList[i].HGr = LoadGraphicSet(GrName));
    407     assert(PictureList[i].pix = pix);
    408     ModelPicture[mix].HGr:=PictureList[i].HGr;
    409     ModelPicture[mix].pix:=PictureList[i].pix;
    410     ModelName[mix]:=PictureList[i].ModelName;
    411     end
    412   else
    413     begin
    414     with ModelPicture[mix] do
    415       begin
    416       HGr:=LoadGraphicSet(GrName);
    417       pix:=Info.pix;
    418       inc(GrExt[HGr].pixUsed[pix]);
     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
    419592      end;
    420     ModelName[mix]:='';
    421 
    422     // read model name from tribe script
    423     ok:=false;
    424     for i:=0 to Script.Count-1 do
    425       begin
    426       Input:=Script[i];
    427       if Input='#UNITS '+GrName then ok:=true
    428       else if (Input<>'') and (Input[1]='#') then ok:=false
    429       else if ok and (GetNum=pix) then
    430         begin Get; ModelName[mix]:=Get 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;
    431604      end;
    432605
    433     if ModelName[mix]='' then
    434       begin // read model name from StdUnits.txt
    435       for i:=0 to StdUnitScript.Count-1 do
     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
    436611        begin
    437         Input:=StdUnitScript[i];
    438         if GetNum=pix then
    439           begin Get; ModelName[mix]:=Get end
     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);
    440617        end
     618        else if (Input <> '') and (Input[1] = '#') then
     619          ok := false
     620        else if ok then
     621          check;
    441622      end;
    442 
    443     if Hash<>0 then
    444       begin
    445       if nPictureList=0 then
    446         ReallocMem(PictureList, 64*sizeof(TChosenModelPictureInfo))
    447       else if (nPictureList>=64) and (nPictureList and (nPictureList-1)=0) then
    448         ReallocMem(PictureList, nPictureList*(2*sizeof(TChosenModelPictureInfo)));
    449       PictureList[nPictureList].Hash:=Info.Hash;
    450       PictureList[nPictureList].HGr:=ModelPicture[mix].HGr;
    451       PictureList[nPictureList].pix:=Info.pix;
    452       PictureList[nPictureList].ModelName:=ModelName[mix];
    453       inc(nPictureList);
    454       end
    455     end;
    456 
    457   with ModelPicture[mix] do
    458     FindPosition(HGr,pix mod 10 *65,pix div 10 *49,63,47,$FFFFFF,xShield,yShield);
    459   end;
    460 end;
    461 
    462 function TTribe.ChooseModelPicture(var Picture: TModelPictureInfo;
    463   code,Turn: integer; ForceNew: boolean): boolean;
    464 var
    465 i,Cnt,HGr,used,LeastUsed: integer;
    466 TestPic: TModelPictureInfo;
    467 ok: boolean;
    468 
    469   procedure check;
    470   begin
    471   TestPic.pix:=GetNum;
    472   if code=GetNum then
    473     begin
    474     if ForceNew or (HGr<0) then used:=0
    475     else
    476       begin
    477       used:=4*GrExt[HGr].pixUsed[TestPic.pix];
    478       if HGr=HGrStdUnits then inc(used,2); // prefer units not from StdUnits
    479       end;
    480     if used<LeastUsed then begin Cnt:=0; LeastUsed:=used end;
    481     if used=LeastUsed then
    482       begin
    483       inc(Cnt);
    484       if Turn mod Cnt=0 then Picture:=TestPic
    485       end;
    486     end
    487   end;
    488 
    489 begin
    490 // look for identical model to assign same picture again
    491 if not ForceNew and (Picture.Hash>0) then
    492   begin
    493   for i:=0 to nPictureList-1 do
    494     if PictureList[i].Hash=Picture.Hash then
    495       begin
    496       Picture.GrName:=GrExt[PictureList[i].HGr].Name;
    497       Picture.pix:=PictureList[i].pix;
    498       result:=false;
    499       exit;
    500       end
    501   end;
    502 
    503 Picture.pix:=0;
    504 TestPic:=Picture;
    505 LeastUsed:=MaxInt;
    506 
    507 TestPic.GrName:='StdUnits';
    508 HGr:=HGrStdUnits;
    509 for i:=0 to StdUnitScript.Count-1 do
    510   begin // look through StdUnits
    511   Input:=StdUnitScript[i];
    512   check;
    513   end;
    514 
    515 ok:=false;
    516 for i:=0 to Script.Count-1 do
    517   begin // look through units defined in tribe script
    518   Input:=Script[i];
    519   if Copy(Input,1,6)='#UNITS' then
    520     begin
    521     ok:=true;
    522     TestPic.GrName:=Copy(Input,8,255);
    523     HGr:=nGrExt-1;
    524     while (HGr>=0) and (GrExt[HGr].Name<>TestPic.GrName) do dec(HGr);
    525     end
    526   else if (Input<>'') and (Input[1]='#') then ok:=false
    527   else if ok then check;
    528   end;
    529 result:=true;
    530 end;
     623      result := true;
     624    end;
    531625
    532626end.
    533 
Note: See TracChangeset for help on using the changeset viewer.