innercore.pas

类似文明的游戏源代码。

  end;
end;

{
                          Location Navigation
 ____________________________________________________________________
}
function dLoc(Loc,dx,dy: integer): integer;
{relative location, dx in hor and dy in ver direction from Loc}
var
y0: integer;
begin
assert((Loc>=0) and (Loc<MapSize) and (dx+lx>=0));
y0:=Loc div lx;
result:=(Loc+(dx+y0 and 1+lx+lx) shr 1) mod lx +lx*(y0+dy);
if (result<0) or (result>=MapSize) then result:=-1;
end;

procedure dxdy(Loc0,Loc1: integer; var dx,dy: integer);
begin
dx:=((Loc1 mod lx *2 +Loc1 div lx and 1)
  -(Loc0 mod lx *2 +Loc0 div lx and 1)+3*lx) mod (2*lx) -lx;
dy:=Loc1 div lx-Loc0 div lx;
end;

function Distance(Loc0,Loc1: integer): integer;
var
dx,dy: integer;
begin
dxdy(Loc0,Loc1,dx,dy);
dx:=abs(dx);
dy:=abs(dy);
result:=dx+dy+abs(dx-dy) shr 1;
end;

{
                             Map Creation
 ____________________________________________________________________
}
var
primitive: integer;
StartLoc, StartLoc2: array[0..nPl-1] of integer; {starting coordinates}
Elevation: array[0..lxmax*lymax-1] of Byte; {map elevation}
ElCount: array[Byte] of integer; {count of elevation occurance}

procedure CalculatePrimitive;
var
i,j: integer;
begin
primitive:=1;
i:=2;
while i*i<=MapSize+1 do // test whether prime
  begin if (MapSize+1) mod i=0 then primitive:=0; inc(i) end;

if primitive>0 then
  repeat
    inc(primitive);
    i:=1;
    j:=0;
    repeat inc(j); i:=i*primitive mod (MapSize+1) until (i=1) or (j=MapSize+1);
  until j=MapSize;
end;

function MapGeneratorAvailable: boolean;
begin
result:=(primitive>0) and (lx>=20) and (ly>=40)
end;

procedure CreateElevation;
const
d=64;
Smooth=0.049;{causes low amplitude of short waves}
Detail=0.095;{causes short period of short waves}
Merge=5;{elevation merging range at the connection line of the
  round world,in relation to lx}

var
sa,ca,f1,f2:array[1..d] of single;
imerge,x,y:integer;
v,maxv:single;

  function Value(x,y:integer):single;{elevation formula}
  var
  i:integer;
  begin
  result:=0;
  for i:=1 to d do result:=result+sin(f1[i]*((x*2+y and 1)*sa[i]+y*1.5*ca[i]))
    *f2[i];
   {x values effectively multiplied with 2 to get 2 horizantal periods
   of the prime waves}
  end;

begin
for x:=1 to d do {prepare formula parameters}
  begin
  if x=1 then v:=pi/2 else v:=Random*2*pi;{first wave goes horizontal}
  sa[x]:=sin(v)/lx;
  ca[x]:=cos(v)/ly;
  f1[x]:=2*pi*Exp(Detail*(x-1));
  f2[x]:=Exp(-x*Smooth)
  end;

imerge:=2*lx div Merge;
FillChar(ElCount,SizeOf(ElCount),0);
maxv:=0;
for x:=0 to lx-1 do for y:=0 to ly-1 do
  begin
  v:=Value(x,y);
  if x*2<imerge then v:=(x*2*v+(imerge-x*2)*Value(x+lx,y))/imerge;
  v:=v-sqr(sqr(2*y/ly-1));{soft cut at poles}
  if v>maxv then maxv:=v;

  if v<-4 then Elevation[x+lx*y]:=0
  else if v>8.75 then Elevation[x+lx*y]:=255
  else Elevation[x+lx*y]:=Round((v+4)*20);
  inc(ElCount[Elevation[x+lx*y]])
  end;
end;

procedure FindContinents;

  procedure ReplaceCont(a,b,Stop:integer);
  {replace continent name a by b}
  // make sure always continent[loc]<=loc
  var
  i: integer;
  begin
  if a<b then begin i:=a; a:=b; b:=i end;
  if a>b then
    for i:=a to Stop do if Continent[i]=a then Continent[i]:=b
  end;

var
x,y,Loc,Wrong:integer;
begin
for y:=1 to ly-2 do for x:=0 to lx-1 do
  begin
  Loc:=x+lx*y;
  Continent[Loc]:=-1;
  if RealMap[Loc] and fTerrain>=fGrass then
    begin
    if (y-2>=1) and (RealMap[Loc-2*lx] and fTerrain>=fGrass) then
      Continent[Loc]:=Continent[Loc-2*lx];
    if (x-1+y and 1>=0) and (y-1>=1)
      and (RealMap[Loc-1+y and 1-lx] and fTerrain>=fGrass) then
      Continent[Loc]:=Continent[Loc-1+y and 1-lx];
    if (x+y and 1<lx) and (y-1>=1)
      and (RealMap[Loc+y and 1-lx] and fTerrain>=fGrass) then
      Continent[Loc]:=Continent[Loc+y and 1-lx];
    if (x-1>=0) and (RealMap[Loc-1] and fTerrain>=fGrass) then
      if Continent[Loc]=-1 then Continent[Loc]:=Continent[Loc-1]
      else ReplaceCont(Continent[Loc-1],Continent[Loc],Loc);
    if Continent[Loc]=-1 then Continent[Loc]:=Loc
    end
  end;

{connect continents due to round earth}
for y:=1 to ly-2 do if RealMap[lx*y] and fTerrain>=fGrass then
  begin
  Wrong:=-1;
  if RealMap[lx-1+lx*y] and fTerrain>=fGrass then Wrong:=Continent[lx-1+lx*y];
  if (y and 1=0) and (y-1>=1) and (RealMap[lx-1+lx*(y-1)] and fTerrain>=fGrass) then
    Wrong:=Continent[lx-1+lx*(y-1)];
  if (y and 1=0) and (y+1<ly-1)
    and (RealMap[lx-1+lx*(y+1)] and fTerrain>=fGrass) then
    Wrong:=Continent[lx-1+lx*(y+1)];
  if Wrong>=0 then ReplaceCont(Wrong,Continent[lx*y],MapSize-1)
  end;
end;

procedure RarePositions;
// distribute rare resources
// must be done after FindContinents
var
i,j,Cnt,x,y,dx,dy,Loc0,Loc1,xworst,yworst,totalrare,RareMaxWater,RareType,
  iBest,jbest,MinDist,xBlock,yBlock: integer;
AreaCount, RareByArea, RareAdjacent: array[0..7,0..4] of integer;
RareLoc: array[0..11] of integer;
Dist: array[0..11,0..11] of integer;
begin
RareMaxWater:=0;
repeat
  FillChar(AreaCount, SizeOf(AreaCount), 0);
  for y:=1 to ly-2 do
    begin
    yBlock:=y*5 div ly;
    if yBlock=(y+1)*5 div ly then for x:=0 to lx-1 do
      begin
      xBlock:=x*8 div lx;
      if xBlock=(x+1)*8 div lx then
        begin
        Loc0:=x+lx*y;
        if (RealMap[Loc0] and fTerrain>=fGrass) and (RealMap[Loc0] and fSpecial=0) then
          begin
          Cnt:=0;
          for dy:=-2 to 2 do for dx:=-2 to 2 do
            if abs(dx)+abs(dy)=2 then
              begin
              Loc1:=dLoc(Loc0,dx,dy);
              if (Loc1>=0) and (RealMap[Loc1] and fTerrain<fGrass) then
                inc(Cnt); // count adjacent water
              end;
          if Cnt<=RareMaxWater then // inner land
            begin
            inc(AreaCount[xBlock,yBlock]);
            if Random(AreaCount[xBlock,yBlock])=0 then
              RareByArea[xBlock,yBlock]:=Loc0
            end
          end;
        end;
      end
    end;
  totalrare:=0;
  for x:=0 to 7 do for y:=0 to 4 do if AreaCount[x,y]>0 then
    inc(totalrare);
  inc(RareMaxWater);
until totalrare>=12;

while totalrare>12 do
  begin // remove rarebyarea resources too close to each other
  FillChar(RareAdjacent,SizeOf(RareAdjacent),0);
  for x:=0 to 7 do for y:=0 to 4 do if AreaCount[x,y]>0 then
    begin
    if (AreaCount[(x+1) mod 8,y]>0)
      and (Continent[RareByArea[x,y]]=Continent[RareByArea[(x+1) mod 8,y]]) then
      begin
      inc(RareAdjacent[x,y]);
      inc(RareAdjacent[(x+1) mod 8,y]);
      end;
    if y<4 then
      begin
      if (AreaCount[x,y+1]>0)
        and (Continent[RareByArea[x,y]]=Continent[RareByArea[x,y+1]]) then
        begin
        inc(RareAdjacent[x,y]);
        inc(RareAdjacent[x,y+1]);
        end;
      if (AreaCount[(x+1) mod 8,y+1]>0)
        and (Continent[RareByArea[x,y]]=Continent[RareByArea[(x+1) mod 8,y+1]]) then
        begin
        inc(RareAdjacent[x,y]);
        inc(RareAdjacent[(x+1) mod 8,y+1]);
        end;
      if (AreaCount[(x+7) mod 8,y+1]>0)
        and (Continent[RareByArea[x,y]]=Continent[RareByArea[(x+7) mod 8,y+1]]) then
        begin
        inc(RareAdjacent[x,y]);
        inc(RareAdjacent[(x+7) mod 8,y+1]);
        end;
      end
    end;
  xworst:=0; yworst:=0;
  Cnt:=0;
  for x:=0 to 7 do for y:=0 to 4 do if AreaCount[x,y]>0 then
    begin
    if (Cnt=0) or (RareAdjacent[x,y]>RareAdjacent[xworst,yworst]) then
      begin xworst:=x; yworst:=y; Cnt:=1 end
    else if (RareAdjacent[x,y]=RareAdjacent[xworst,yworst]) then
      begin
      inc(Cnt);
      if Random(Cnt)=0 then begin xworst:=x; yworst:=y; end
      end;
    end;
  AreaCount[xworst,yworst]:=0;
  dec(totalrare)
  end;

Cnt:=0;
for x:=0 to 7 do for y:=0 to 4 do if AreaCount[x,y]>0 then
  begin RareLoc[Cnt]:=RareByArea[x,y]; inc(Cnt) end;
for i:=0 to 11 do
  begin
  RealMap[RareLoc[i]]:=RealMap[RareLoc[i]] or fRare;
  for dy:=-1 to 1 do for dx:=-1 to 1 do if (dx+dy) and 1=0 then
    begin
    Loc1:=dLoc(RareLoc[i],dx,dy);
    if (Loc1>=0) and (RealMap[Loc1] and fTerrain=fMountains) then
      RealMap[Loc1]:=RealMap[Loc1] and not fTerrain or fHills;
    end
  end;
for i:=0 to 11 do for j:=0 to 11 do
  Dist[i,j]:=Distance(RareLoc[i],RareLoc[j]);

MinDist:=Distance(0,MapSize-lx shr 1) shr 1;
for RareType:=1 to 3 do
  begin
  Cnt:=0;
  for i:=0 to 11 do if RareLoc[i]>=0 then
    for j:=0 to 11 do if RareLoc[j]>=0 then
      if (Cnt>0) and (Dist[iBest,jbest]>=MinDist) then
        begin
        if Dist[i,j]>=MinDist then
          begin
          inc(Cnt);
          if Random(Cnt)=0 then
            begin iBest:=i; jbest:=j end
          end
        end
      else if (Cnt=0) or (Dist[i,j]>Dist[iBest,jbest]) then
        begin iBest:=i; jbest:=j; Cnt:=1; end;
  RealMap[RareLoc[iBest]]:=RealMap[RareLoc[iBest]] or Cardinal(RareType) shl 25;
  RealMap[RareLoc[jbest]]:=RealMap[RareLoc[jbest]] or Cardinal(RareType) shl 25;
  RareLoc[iBest]:=-1;
  RareLoc[jbest]:=-1;
  end;
end; // RarePositions

function CheckShore(Loc: integer): boolean;
var
dx,dy,Loc1,OldTile: integer;
begin
result:=false;
OldTile:=RealMap[Loc];
if OldTile and fTerrain<fGrass then
  begin
  RealMap[Loc]:=RealMap[Loc] and not fTerrain or fOcean;
  for dy:=-3 to 3 do for dx:=-3 to 3 do
    if ((dx+dy) and 1=0) and ((dx<>3) and (dx<>-3) or (dy<>3) and (dy<>-3)) then
    begin
    Loc1:=dLoc(Loc,dx,dy);
    if (Loc1>=0) and (RealMap[Loc1] and fTerrain>=fGrass)
      and (RealMap[Loc1] and fTerrain<>fArctic) then
      RealMap[Loc]:=RealMap[Loc] and not fTerrain or fShore;
    end;
  if (RealMap[Loc] xor Cardinal(OldTile)) and fTerrain<>0 then
    result:=true
  end;
end;

function SpecialTile(Loc: integer): Cardinal;
begin
result:=HypoSpecialTile(Loc mod lx, Loc div lx, RealMap[Loc] and fTerrain);
end;

procedure CreateMap(preview: boolean);
const
ShHiHills=6; {of land}
ShMountains=6; {of land}
ShRandHills=12; {of land}
ShTestRiver=40;
ShSwamp=25; {of grassland}
MinRivLen=3;
unification=70;
hotunification=50; // min. 25

Zone:array[0..3,2..9] of single= {terrain distribution}
 ((0.25,0,   0,   0.4 ,0,0,0,0.35),
  (0.55,0,   0.1 ,0,   0,0,0,0.35),
  (0.4, 0,   0.35,0,   0,0,0,0.25),
  (0,   0.7, 0,   0,   0,0,0,0.3));
  {Grs  Dst  Pra  Tun  - - - For}

  function RndLow(y:integer):Cardinal;
  {random lowland appropriate to climate}
  var
  z0,i:integer;
  p,p0,ZPlus:single;
  begin
  if ly-1-y>y then begin z0:=6*y div ly;ZPlus:=6*y/ly -z0 end
  else begin z0:=6*(ly-1-y) div ly;ZPlus:=6*(ly-1-y)/ly -z0 end;
  p0:=1;
  for i:=2 to 9 do
    begin
    p:=Zone[z0,i]*(1-ZPlus)+Zone[z0+1,i]*ZPlus;
    {weight between zones z0 and z0+1}
    if Random*p0<p then begin RndLow:=i;Break end;
    p0:=p0-p
    end;
  end;

  function RunRiver(Loc0: integer): integer;
  {runs river from start point Loc0; return value: length}
  var
  Dir,T,Loc,Loc1,Cost: integer;
  Q: TIPQ;
  From: array[0..lxmax*lymax-1] of integer;
  Time: array[0..lxmax*lymax-1] of integer;
  OneTileLake: boolean;
  begin
  FillChar(Time,SizeOf(Time),255); {-1}
  Q:=TIPQ.Create(MapSize);
  Q.Put(Loc0,0);
  while Q.Get(Loc,T) and (RealMap[Loc] and fRiver=0) do
    begin
    if (RealMap[Loc] and fTerrain<fGrass) then
      begin
      OneTileLake:=true;
      for Dir:=0 to 3 do
        begin
        Loc1:=dLoc(Loc,Dir and 1 *2 -1,Dir shr 1 *2 -1);
        if (Loc1>=0) and (RealMap[Loc1] and fTerrain<fGrass) then
          OneTileLake:=false;
        end;
      if not OneTileLake then Break;
      end;
    Time[Loc]:=T;
    for Dir:=0 to 3 do
      begin
      Loc1:=dLoc(Loc,Dir and 1 *2 -1,Dir shr 1 *2 -1);
      if (Loc1>=lx) and (Loc1<lx*(ly-1)) and (Time[Loc1]<0) then
        begin
        if RealMap[Loc1] and fRiver=0 then
          begin
          Cost:=Elevation[Loc1]-Elevation[Loc];
          if Cost<0 then Cost:=0;
          end
        else Cost:=0;
        if Q.Put(Loc1,T+Cost shl 8+1) then From[Loc1]:=Loc
        end
      end
    end;
  Loc1:=Loc;
  result:=0;
  while Loc<>Loc0 do begin Loc:=From[Loc]; inc(result); end;
  if (result>1) and ((result>=MinRivLen) or (RealMap[Loc1] and fTerrain>=fGrass)) then
    begin
    Loc:=Loc1;
    while Loc<>Loc0 do
      begin
      Loc:=From[Loc];
      if RealMap[Loc] and fTerrain in [fHills,fMountains] then
        RealMap[Loc]:=fGrass or fRiver
      else if RealMap[Loc] and fTerrain>=fGrass then