Engine:
* Forgot to remove one line in last commit.
(*
* Hedgewars, a free turn based strategy game
* Copyright (c) 2005-2008 Andrey Korotaev <unC0Rr@gmail.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; version 2 of the License
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA
*)
{$INCLUDE "options.inc"}
unit uLandObjects;
interface
uses SDLh;
procedure AddObjects();
procedure LoadThemeConfig;
procedure BlitImageAndGenerateCollisionInfo(cpX, cpY, Width: Longword; Image: PSDL_Surface);
procedure AddOnLandObjects(Surface: PSDL_Surface);
implementation
uses uLand, uStore, uConsts, uMisc, uConsole, uRandom, uVisualGears, uFloat, uSound, uWorld,
{$IFDEF GLES11}
gles11;
{$ELSE}
GL;
{$ENDIF}
const MaxRects = 512;
MAXOBJECTRECTS = 16;
MAXTHEMEOBJECTS = 32;
type PRectArray = ^TRectsArray;
TRectsArray = array[0..MaxRects] of TSDL_Rect;
TThemeObject = record
Surf: PSDL_Surface;
inland: TSDL_Rect;
outland: array[0..Pred(MAXOBJECTRECTS)] of TSDL_Rect;
rectcnt: Longword;
Width, Height: Longword;
Maxcnt: Longword;
end;
TThemeObjects = record
Count: LongInt;
objs: array[0..Pred(MAXTHEMEOBJECTS)] of TThemeObject;
end;
TSprayObject = record
Surf: PSDL_Surface;
Width, Height: Longword;
Maxcnt: Longword;
end;
TSprayObjects = record
Count: LongInt;
objs: array[0..Pred(MAXTHEMEOBJECTS)] of TSprayObject
end;
var Rects: PRectArray;
RectCount: Longword;
ThemeObjects: TThemeObjects;
SprayObjects: TSprayObjects;
procedure BlitImageAndGenerateCollisionInfo(cpX, cpY, Width: Longword; Image: PSDL_Surface);
var p: PLongwordArray;
x, y: Longword;
bpp: LongInt;
begin
WriteToConsole('Generating collision info... ');
if SDL_MustLock(Image) then
SDLTry(SDL_LockSurface(Image) >= 0, true);
bpp:= Image^.format^.BytesPerPixel;
TryDo(bpp = 4, 'Land object should be 32bit', true);
if Width = 0 then Width:= Image^.w;
p:= Image^.pixels;
for y:= 0 to Pred(Image^.h) do
begin
for x:= 0 to Pred(Width) do
if LandPixels[cpY + y, cpX + x] = 0 then
begin
LandPixels[cpY + y, cpX + x]:= p^[x];
if (p^[x] and AMask) <> 0 then Land[cpY + y, cpX + x]:= COLOR_OBJECT;
end;
p:= @(p^[Image^.pitch shr 2]);
end;
if SDL_MustLock(Image) then
SDL_UnlockSurface(Image);
WriteLnToConsole(msgOK)
end;
procedure AddRect(x1, y1, w1, h1: LongInt);
begin
with Rects^[RectCount] do
begin
x:= x1;
y:= y1;
w:= w1;
h:= h1
end;
inc(RectCount);
TryDo(RectCount < MaxRects, 'AddRect: overflow', true)
end;
procedure InitRects;
begin
RectCount:= 0;
New(Rects)
end;
procedure FreeRects;
begin
Dispose(rects)
end;
function CheckIntersect(x1, y1, w1, h1: LongInt): boolean;
var i: Longword;
res: boolean = false;
begin
i:= 0;
if RectCount > 0 then
repeat
with Rects^[i] do
res:= (x < x1 + w1) and (x1 < x + w) and
(y < y1 + h1) and (y1 < y + h);
inc(i)
until (i = RectCount) or (res);
CheckIntersect:= res;
end;
function AddGirder(gX: LongInt): boolean;
var tmpsurf: PSDL_Surface;
x1, x2, y, k, i: LongInt;
rr: TSDL_Rect;
bRes: boolean;
function CountNonZeroz(x, y: LongInt): Longword;
var i: LongInt;
lRes: Longword;
begin
lRes:= 0;
for i:= y to y + 15 do
if Land[i, x] <> 0 then inc(lRes);
CountNonZeroz:= lRes;
end;
begin
y:= topY+150;
repeat
inc(y, 24);
x1:= gX;
x2:= gX;
while (x1 > Longint(leftX)+150) and (CountNonZeroz(x1, y) = 0) do dec(x1, 2);
i:= x1 - 12;
repeat
dec(x1, 2);
k:= CountNonZeroz(x1, y)
until (x1 < Longint(leftX)+150) or (k = 0) or (k = 16) or (x1 < i);
inc(x1, 2);
if k = 16 then
begin
while (x2 < (rightX-150)) and (CountNonZeroz(x2, y) = 0) do inc(x2, 2);
i:= x2 + 12;
repeat
inc(x2, 2);
k:= CountNonZeroz(x2, y)
until (x2 >= (rightX-150)) or (k = 0) or (k = 16) or (x2 > i) or (x2 - x1 >= 768);
if (x2 < (rightX - 150)) and (k = 16) and (x2 - x1 > 250) and (x2 - x1 < 768)
and not CheckIntersect(x1 - 32, y - 64, x2 - x1 + 64, 144) then break;
end;
x1:= 0;
until y > (LAND_HEIGHT-125);
if x1 > 0 then
begin
bRes:= true;
tmpsurf:= LoadImage(Pathz[ptCurrTheme] + '/Girder', ifTransparent or ifIgnoreCaps);
if tmpsurf = nil then tmpsurf:= LoadImage(Pathz[ptGraphics] + '/Girder', ifCritical or ifTransparent or ifIgnoreCaps);
rr.x:= x1;
while rr.x < x2 do
begin
BlitImageAndGenerateCollisionInfo(rr.x, y, min(x2 - rr.x, tmpsurf^.w), tmpsurf);
inc(rr.x, tmpsurf^.w);
end;
SDL_FreeSurface(tmpsurf);
AddRect(x1 - 8, y - 32, x2 - x1 + 16, 80);
end
else bRes:= false;
AddGirder:= bRes;
end;
function CheckLand(rect: TSDL_Rect; dX, dY, Color: Longword): boolean;
var i: Longword;
bRes: boolean = true;
begin
inc(rect.x, dX);
inc(rect.y, dY);
i:= 0;
{$WARNINGS OFF}
while (i <= rect.w) and bRes do
begin
bRes:= (Land[rect.y, rect.x + i] = Color) and (Land[rect.y + rect.h, rect.x + i] = Color);
inc(i)
end;
i:= 0;
while (i <= rect.h) and bRes do
begin
bRes:= (Land[rect.y + i, rect.x] = Color) and (Land[rect.y + i, rect.x + rect.w] = Color);
inc(i)
end;
{$WARNINGS ON}
CheckLand:= bRes;
end;
function CheckCanPlace(x, y: Longword; var Obj: TThemeObject): boolean;
var i: Longword;
bRes: boolean;
begin
with Obj do
if CheckLand(inland, x, y, COLOR_LAND) then
begin
bRes:= true;
i:= 1;
while bRes and (i <= rectcnt) do
begin
bRes:= CheckLand(outland[i], x, y, 0);
inc(i)
end;
if bRes then
bRes:= not CheckIntersect(x, y, Width, Height)
end else
bRes:= false;
CheckCanPlace:= bRes;
end;
function TryPut(var Obj: TThemeObject): boolean; overload;
const MaxPointsIndex = 2047;
var x, y: Longword;
ar: array[0..MaxPointsIndex] of TPoint;
cnt, i: Longword;
bRes: boolean;
begin
cnt:= 0;
with Obj do
begin
if Maxcnt = 0 then
exit(false);
x:= 0;
repeat
y:= topY+32; // leave room for a hedgie to teleport in
repeat
if CheckCanPlace(x, y, Obj) then
begin
ar[cnt].x:= x;
ar[cnt].y:= y;
inc(cnt);
if cnt > MaxPointsIndex then // buffer is full, do not check the rest land
begin
y:= 5000;
x:= 5000;
end
end;
inc(y, 3);
until y > LAND_HEIGHT - 1 - Height;
inc(x, getrandom(6) + 3)
until x > LAND_WIDTH - 1 - Width;
bRes:= cnt <> 0;
if bRes then
begin
i:= getrandom(cnt);
BlitImageAndGenerateCollisionInfo(ar[i].x, ar[i].y, 0, Obj.Surf);
AddRect(ar[i].x, ar[i].y, Width, Height);
dec(Maxcnt)
end else Maxcnt:= 0
end;
TryPut:= bRes;
end;
function TryPut(var Obj: TSprayObject; Surface: PSDL_Surface): boolean; overload;
const MaxPointsIndex = 8095;
var x, y: Longword;
ar: array[0..MaxPointsIndex] of TPoint;
cnt, i: Longword;
r: TSDL_Rect;
bRes: boolean;
begin
cnt:= 0;
with Obj do
begin
if Maxcnt = 0 then
exit(false);
x:= 0;
r.x:= 0;
r.y:= 0;
r.w:= Width;
r.h:= Height + 16;
repeat
y:= 8;
repeat
if CheckLand(r, x, y - 8, COLOR_LAND)
and not CheckIntersect(x, y, Width, Height) then
begin
ar[cnt].x:= x;
ar[cnt].y:= y;
inc(cnt);
if cnt > MaxPointsIndex then // buffer is full, do not check the rest land
begin
y:= 5000;
x:= 5000;
end
end;
inc(y, 12);
until y > LAND_HEIGHT - 1 - Height - 8;
inc(x, getrandom(12) + 12)
until x > LAND_WIDTH - 1 - Width;
bRes:= cnt <> 0;
if bRes then
begin
i:= getrandom(cnt);
r.x:= ar[i].X;
r.y:= ar[i].Y;
r.w:= Width;
r.h:= Height;
SDL_UpperBlit(Obj.Surf, nil, Surface, @r);
AddRect(ar[i].x - 32, ar[i].y - 32, Width + 64, Height + 64);
dec(Maxcnt)
end else Maxcnt:= 0
end;
TryPut:= bRes;
end;
procedure ReadThemeInfo(var ThemeObjects: TThemeObjects; var SprayObjects: TSprayObjects);
var s: shortstring;
f: textfile;
i, ii: LongInt;
vobcount: Longword;
c1, c2: TSDL_Color;
procedure CheckRect(Width, Height, x, y, w, h: LongWord);
begin
if (x + w > Width) then OutError('Object''s rectangle exceeds image: x + w (' + inttostr(x) + ' + ' + inttostr(w) + ') > Width (' + inttostr(Width) + ')', true);
if (y + h > Height) then OutError('Object''s rectangle exceeds image: y + h (' + inttostr(y) + ' + ' + inttostr(h) + ') > Height (' + inttostr(Height) + ')', true);
end;
begin
AddProgress;
s:= Pathz[ptCurrTheme] + '/' + cThemeCFGFilename;
WriteLnToConsole('Reading objects info...');
Assign(f, s);
{$I-}
filemode:= 0; // readonly
Reset(f);
// read sky and explosion border colors
Readln(f, c1.r, c1.g, c1. b);
Readln(f, c2.r, c2.g, c2. b);
// read water gradient colors
Readln(f, WaterColorArray[0].r, WaterColorArray[0].g, WaterColorArray[0].b);
Readln(f, WaterColorArray[2].r, WaterColorArray[2].g, WaterColorArray[2].b, cWaterOpacity);
WaterColorArray[0].a := 255;
WaterColorArray[2].a := 255;
WaterColorArray[1]:= WaterColorArray[0];
WaterColorArray[3]:= WaterColorArray[2];
glClearColor(c1.r / 255, c1.g / 255, c1.b / 255, 0.99); // sky color
cExplosionBorderColor:= c2.value or AMask;
ReadLn(f, s);
if MusicFN = '' then MusicFN:= s;
ReadLn(f, cCloudsNumber);
// TODO - adjust all the theme cloud numbers. This should not be a permanent fix
cCloudsNumber:= cCloudsNumber * (LAND_WIDTH div 2048);
Readln(f, ThemeObjects.Count);
for i:= 0 to Pred(ThemeObjects.Count) do
begin
Readln(f, s); // filename
with ThemeObjects.objs[i] do
begin
Surf:= LoadImage(Pathz[ptCurrTheme] + '/' + s, ifCritical or ifTransparent or ifIgnoreCaps);
Width:= Surf^.w;
Height:= Surf^.h;
Read(f, Maxcnt);
if (Maxcnt < 1) or (Maxcnt > MAXTHEMEOBJECTS) then OutError('Object''s max count should be between 1 and '+ inttostr(MAXTHEMEOBJECTS) +' (it was '+ inttostr(Maxcnt) +').', true);
with inland do
begin
Read(f, x, y, w, h);
CheckRect(Width, Height, x, y, w, h)
end;
Read(f, rectcnt);
for ii:= 1 to rectcnt do
with outland[ii] do
begin
Read(f, x, y, w, h);
CheckRect(Width, Height, x, y, w, h)
end;
ReadLn(f)
end;
end;
// sprays
Readln(f, SprayObjects.Count);
for i:= 0 to Pred(SprayObjects.Count) do
begin
Readln(f, s); // filename
with SprayObjects.objs[i] do
begin
Surf:= LoadImage(Pathz[ptCurrTheme] + '/' + s, ifCritical or ifTransparent or ifIgnoreCaps);
Width:= Surf^.w;
Height:= Surf^.h;
ReadLn(f, Maxcnt)
end;
end;
// snowflakes
Readln(f, vobCount);
if vobCount > 0 then
Readln(f, vobFramesCount, vobFrameTicks, vobVelocity, vobFallSpeed);
for i:= 0 to Pred(vobCount) do
AddVisualGear( -cScreenWidth + random(cScreenWidth * 2 + LAND_WIDTH), random(1024+200) - 100 + LAND_HEIGHT, vgtFlake);
Close(f);
{$I+}
TryDo(IOResult = 0, 'Bad data or cannot access file ' + cThemeCFGFilename, true);
AddProgress;
end;
procedure AddThemeObjects(var ThemeObjects: TThemeObjects);
var i, ii, t: LongInt;
b: boolean;
begin
if ThemeObjects.Count = 0 then exit;
WriteLnToConsole('Adding theme objects...');
for i:=0 to ThemeObjects.Count do
ThemeObjects.objs[i].Maxcnt := max(1, (ThemeObjects.objs[i].Maxcnt * MaxHedgehogs) div 18); // Maxcnt is proportional to map size, but allow objects to span even if we're on a tiny map
repeat
t := getrandom(ThemeObjects.Count);
b := false;
for i:=0 to ThemeObjects.Count do
begin
ii := (i+t) mod ThemeObjects.Count;
if ThemeObjects.objs[ii].Maxcnt <> 0 then
b := b or TryPut(ThemeObjects.objs[ii])
end;
until not b;
end;
procedure AddSprayObjects(Surface: PSDL_Surface; var SprayObjects: TSprayObjects);
var i, ii, t: LongInt;
b: boolean;
begin
if SprayObjects.Count = 0 then exit;
WriteLnToConsole('Adding spray objects...');
for i:=0 to SprayObjects.Count do
SprayObjects.objs[i].Maxcnt := max(1, (SprayObjects.objs[i].Maxcnt * MaxHedgehogs) div 18); // Maxcnt is proportional to map size, but allow objects to span even if we're on a tiny map
repeat
t := getrandom(SprayObjects.Count);
b := false;
for i:=0 to SprayObjects.Count do
begin
ii := (i+t) mod SprayObjects.Count;
if SprayObjects.objs[ii].Maxcnt <> 0 then
b := b or TryPut(SprayObjects.objs[ii], Surface)
end;
until not b;
end;
procedure AddObjects();
var i, int: Longword;
begin
InitRects;
if hasGirders then
begin
int:= max(playWidth div 8, 256);
i:=leftX+int;
repeat
AddGirder(i);
i:=i+int;
until (i>rightX-int);
end;
AddThemeObjects(ThemeObjects);
AddProgress();
FreeRects();
end;
procedure AddOnLandObjects(Surface: PSDL_Surface);
begin
InitRects;
//AddSprayObjects(Surface, SprayObjects, 12);
AddSprayObjects(Surface, SprayObjects);
FreeRects
end;
procedure LoadThemeConfig;
begin
ReadThemeInfo(ThemeObjects, SprayObjects)
end;
end.