author  unc0rr 
Wed, 18 Mar 2009 15:48:43 +0000  
changeset 1899  5763f46d7486 
parent 1869  490005509a7b 
child 1906  644f93d8f148 
permissions  rwrr 
184  1 
(* 
1066  2 
* Hedgewars, a free turn based strategy game 
883  3 
* Copyright (c) 20052008 Andrey Korotaev <unC0Rr@gmail.com> 
184  4 
* 
5 
* This program is free software; you can redistribute it and/or modify 

6 
* it under the terms of the GNU General Public License as published by 

7 
* the Free Software Foundation; version 2 of the License 

8 
* 

9 
* This program is distributed in the hope that it will be useful, 

10 
* but WITHOUT ANY WARRANTY; without even the implied warranty of 

11 
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 

12 
* GNU General Public License for more details. 

13 
* 

14 
* You should have received a copy of the GNU General Public License 

15 
* along with this program; if not, write to the Free Software 

16 
* Foundation, Inc., 59 Temple Place  Suite 330, Boston, MA 021111307, USA 

17 
*) 

18 

19 
unit uLandObjects; 

20 
interface 

21 
uses SDLh; 

22 
{$include options.inc} 

23 

1180
e56317fdf78d
Start implementing support for 32bit sprites concerned in map generation process.
unc0rr
parents:
1156
diff
changeset

24 
procedure AddObjects(); 
1085
0b82870073b5
Load flakes information from theme.cfg when playing painted map
unc0rr
parents:
1066
diff
changeset

25 
procedure LoadThemeConfig; 
1183
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

26 
procedure BlitImageAndGenerateCollisionInfo(cpX, cpY, Width: Longword; Image: PSDL_Surface); 
1190
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

27 
procedure AddOnLandObjects(Surface: PSDL_Surface); 
184  28 

29 
implementation 

1256  30 
uses uLand, uStore, uConsts, uMisc, uConsole, uRandom, uVisualGears, uFloat, GL, uSound, uWorld; 
1190
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

31 
const MaxRects = 512; 
184  32 
MAXOBJECTRECTS = 16; 
33 
MAXTHEMEOBJECTS = 32; 

34 

35 
type PRectArray = ^TRectsArray; 

36 
TRectsArray = array[0..MaxRects] of TSDL_Rect; 

37 
TThemeObject = record 

38 
Surf: PSDL_Surface; 

39 
inland: TSDL_Rect; 

40 
outland: array[0..Pred(MAXOBJECTRECTS)] of TSDL_Rect; 

41 
rectcnt: Longword; 

42 
Width, Height: Longword; 

43 
Maxcnt: Longword; 

44 
end; 

45 
TThemeObjects = record 

371  46 
Count: LongInt; 
184  47 
objs: array[0..Pred(MAXTHEMEOBJECTS)] of TThemeObject; 
48 
end; 

49 
TSprayObject = record 

50 
Surf: PSDL_Surface; 

51 
Width, Height: Longword; 

52 
Maxcnt: Longword; 

53 
end; 

54 
TSprayObjects = record 

371  55 
Count: LongInt; 
184  56 
objs: array[0..Pred(MAXTHEMEOBJECTS)] of TSprayObject 
57 
end; 

58 

59 
var Rects: PRectArray; 

60 
RectCount: Longword; 

1085
0b82870073b5
Load flakes information from theme.cfg when playing painted map
unc0rr
parents:
1066
diff
changeset

61 
ThemeObjects: TThemeObjects; 
0b82870073b5
Load flakes information from theme.cfg when playing painted map
unc0rr
parents:
1066
diff
changeset

62 
SprayObjects: TSprayObjects; 
0b82870073b5
Load flakes information from theme.cfg when playing painted map
unc0rr
parents:
1066
diff
changeset

63 

184  64 

1183
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

65 
procedure BlitImageAndGenerateCollisionInfo(cpX, cpY, Width: Longword; Image: PSDL_Surface); 
1182
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

66 
var p: PLongwordArray; 
184  67 
x, y: Longword; 
371  68 
bpp: LongInt; 
184  69 
begin 
70 
WriteToConsole('Generating collision info... '); 

71 

72 
if SDL_MustLock(Image) then 

73 
SDLTry(SDL_LockSurface(Image) >= 0, true); 

74 

351  75 
bpp:= Image^.format^.BytesPerPixel; 
1180
e56317fdf78d
Start implementing support for 32bit sprites concerned in map generation process.
unc0rr
parents:
1156
diff
changeset

76 
TryDo(bpp = 4, 'Land object should be 32bit', true); 
1182
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

77 

1183
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

78 
if Width = 0 then Width:= Image^.w; 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

79 

351  80 
p:= Image^.pixels; 
1180
e56317fdf78d
Start implementing support for 32bit sprites concerned in map generation process.
unc0rr
parents:
1156
diff
changeset

81 
for y:= 0 to Pred(Image^.h) do 
e56317fdf78d
Start implementing support for 32bit sprites concerned in map generation process.
unc0rr
parents:
1156
diff
changeset

82 
begin 
1183
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

83 
for x:= 0 to Pred(Width) do 
1181  84 
if LandPixels[cpY + y, cpX + x] = 0 then 
1180
e56317fdf78d
Start implementing support for 32bit sprites concerned in map generation process.
unc0rr
parents:
1156
diff
changeset

85 
begin 
1182
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

86 
LandPixels[cpY + y, cpX + x]:= p^[x]; 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

87 
if (p^[x] and $FF000000) <> 0 then Land[cpY + y, cpX + x]:= COLOR_LAND; 
1180
e56317fdf78d
Start implementing support for 32bit sprites concerned in map generation process.
unc0rr
parents:
1156
diff
changeset

88 
end; 
1182
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

89 
p:= @(p^[Image^.pitch div 4]); 
1180
e56317fdf78d
Start implementing support for 32bit sprites concerned in map generation process.
unc0rr
parents:
1156
diff
changeset

90 
end; 
e56317fdf78d
Start implementing support for 32bit sprites concerned in map generation process.
unc0rr
parents:
1156
diff
changeset

91 

184  92 
if SDL_MustLock(Image) then 
93 
SDL_UnlockSurface(Image); 

94 
WriteLnToConsole(msgOK) 

95 
end; 

96 

371  97 
procedure AddRect(x1, y1, w1, h1: LongInt); 
184  98 
begin 
351  99 
with Rects^[RectCount] do 
184  100 
begin 
101 
x:= x1; 

102 
y:= y1; 

103 
w:= w1; 

104 
h:= h1 

105 
end; 

106 
inc(RectCount); 

107 
TryDo(RectCount < MaxRects, 'AddRect: overflow', true) 

108 
end; 

109 

110 
procedure InitRects; 

111 
begin 

112 
RectCount:= 0; 

113 
New(Rects) 

114 
end; 

115 

116 
procedure FreeRects; 

117 
begin 

118 
Dispose(rects) 

119 
end; 

120 

371  121 
function CheckIntersect(x1, y1, w1, h1: LongInt): boolean; 
184  122 
var i: Longword; 
351  123 
Result: boolean; 
184  124 
begin 
125 
Result:= false; 

126 
i:= 0; 

127 
if RectCount > 0 then 

128 
repeat 

351  129 
with Rects^[i] do 
184  130 
Result:= (x < x1 + w1) and (x1 < x + w) and 
131 
(y < y1 + h1) and (y1 < y + h); 

132 
inc(i) 

351  133 
until (i = RectCount) or (Result); 
134 
CheckIntersect:= Result 

184  135 
end; 
136 

1183
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

137 
function AddGirder(gX: LongInt): boolean; 
184  138 
var tmpsurf: PSDL_Surface; 
371  139 
x1, x2, y, k, i: LongInt; 
1183
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

140 
rr: TSDL_Rect; 
351  141 
Result: boolean; 
184  142 

1183
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

143 
function CountNonZeroz(x, y: LongInt): Longword; 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

144 
var i: LongInt; 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

145 
Result: Longword; 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

146 
begin 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

147 
Result:= 0; 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

148 
for i:= y to y + 15 do 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

149 
if Land[i, x] <> 0 then inc(Result); 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

150 
CountNonZeroz:= Result 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

151 
end; 
184  152 

153 
begin 

1792  154 
y:= topY+150; 
184  155 
repeat 
1183
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

156 
inc(y, 24); 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

157 
x1:= gX; 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

158 
x2:= gX; 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

159 

1792  160 
while (x1 > Longint(leftX)+150) and (CountNonZeroz(x1, y) = 0) do dec(x1, 2); 
1183
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

161 

540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

162 
i:= x1  12; 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

163 
repeat 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

164 
dec(x1, 2); 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

165 
k:= CountNonZeroz(x1, y) 
1792  166 
until (x1 < Longint(leftX)+150) or (k = 0) or (k = 16) or (x1 < i); 
1183
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

167 

540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

168 
inc(x1, 2); 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

169 
if k = 16 then 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

170 
begin 
1792  171 
while (x2 < (rightX150)) and (CountNonZeroz(x2, y) = 0) do inc(x2, 2); 
1183
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

172 
i:= x2 + 12; 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

173 
repeat 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

174 
inc(x2, 2); 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

175 
k:= CountNonZeroz(x2, y) 
1792  176 
until (x2 > (rightX150)) or (k = 0) or (k = 16) or (x2 > i); 
177 
if (x2 < (rightX150)) and (k = 16) and (x2  x1 > 250) 

1183
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

178 
and not CheckIntersect(x1  32, y  64, x2  x1 + 64, 144) then break; 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

179 
end; 
184  180 
x1:= 0; 
1753  181 
until y > (LAND_HEIGHT125); 
1183
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

182 

184  183 
if x1 > 0 then 
1183
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

184 
begin 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

185 
Result:= true; 
1184  186 
tmpsurf:= LoadImage(Pathz[ptCurrTheme] + '/Girder', false, false, true); 
1185  187 
if tmpsurf = nil then tmpsurf:= LoadImage(Pathz[ptGraphics] + '/Girder', false, true, true); 
1184  188 

1183
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

189 
rr.x:= x1; 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

190 
while rr.x < x2 do 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

191 
begin 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

192 
BlitImageAndGenerateCollisionInfo(rr.x, y, min(x2  rr.x, tmpsurf^.w), tmpsurf); 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

193 
inc(rr.x, tmpsurf^.w); 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

194 
end; 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

195 
SDL_FreeSurface(tmpsurf); 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

196 

540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

197 
AddRect(x1  8, y  32, x2  x1 + 16, 80); 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

198 
end else Result:= false; 
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

199 

351  200 
AddGirder:= Result 
184  201 
end; 
202 

203 
function CheckLand(rect: TSDL_Rect; dX, dY, Color: Longword): boolean; 

204 
var i: Longword; 

351  205 
Result: boolean; 
184  206 
begin 
207 
Result:= true; 

208 
inc(rect.x, dX); 

209 
inc(rect.y, dY); 

210 
i:= 0; 

211 
{$WARNINGS OFF} 

212 
while (i <= rect.w) and Result do 

213 
begin 

214 
Result:= (Land[rect.y, rect.x + i] = Color) and (Land[rect.y + rect.h, rect.x + i] = Color); 

215 
inc(i) 

216 
end; 

217 
i:= 0; 

218 
while (i <= rect.h) and Result do 

219 
begin 

220 
Result:= (Land[rect.y + i, rect.x] = Color) and (Land[rect.y + i, rect.x + rect.w] = Color); 

221 
inc(i) 

222 
end; 

223 
{$WARNINGS ON} 

351  224 
CheckLand:= Result 
184  225 
end; 
226 

227 
function CheckCanPlace(x, y: Longword; var Obj: TThemeObject): boolean; 

228 
var i: Longword; 

351  229 
Result: boolean; 
184  230 
begin 
231 
with Obj do 

1776  232 
if CheckLand(inland, x, y, COLOR_LAND) then 
184  233 
begin 
234 
Result:= true; 

235 
i:= 1; 

236 
while Result and (i <= rectcnt) do 

237 
begin 

238 
Result:= CheckLand(outland[i], x, y, 0); 

239 
inc(i) 

240 
end; 

241 
if Result then 

242 
Result:= not CheckIntersect(x, y, Width, Height) 

243 
end else 

351  244 
Result:= false; 
245 
CheckCanPlace:= Result 

184  246 
end; 
247 

1180
e56317fdf78d
Start implementing support for 32bit sprites concerned in map generation process.
unc0rr
parents:
1156
diff
changeset

248 
function TryPut(var Obj: TThemeObject): boolean; overload; 
184  249 
const MaxPointsIndex = 2047; 
250 
var x, y: Longword; 

251 
ar: array[0..MaxPointsIndex] of TPoint; 

252 
cnt, i: Longword; 

351  253 
Result: boolean; 
184  254 
begin 
255 
cnt:= 0; 

256 
with Obj do 

257 
begin 

258 
if Maxcnt = 0 then 

351  259 
exit(false); 
184  260 
x:= 0; 
261 
repeat 

1792  262 
y:= topY+32; // leave room for a hedgie to teleport in 
184  263 
repeat 
264 
if CheckCanPlace(x, y, Obj) then 

265 
begin 

266 
ar[cnt].x:= x; 

267 
ar[cnt].y:= y; 

268 
inc(cnt); 

269 
if cnt > MaxPointsIndex then // buffer is full, do not check the rest land 

270 
begin 

271 
y:= 5000; 

272 
x:= 5000; 

273 
end 

274 
end; 

275 
inc(y, 3); 

1773  276 
until y > LAND_HEIGHT  1  Height; 
184  277 
inc(x, getrandom(6) + 3) 
1773  278 
until x > LAND_WIDTH  1  Width; 
184  279 
Result:= cnt <> 0; 
280 
if Result then 

281 
begin 

282 
i:= getrandom(cnt); 

1183
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

283 
BlitImageAndGenerateCollisionInfo(ar[i].x, ar[i].y, 0, Obj.Surf); 
184  284 
AddRect(ar[i].x, ar[i].y, Width, Height); 
285 
dec(Maxcnt) 

286 
end else Maxcnt:= 0 

351  287 
end; 
288 
TryPut:= Result 

184  289 
end; 
290 

291 
function TryPut(var Obj: TSprayObject; Surface: PSDL_Surface): boolean; overload; 

292 
const MaxPointsIndex = 8095; 

293 
var x, y: Longword; 

294 
ar: array[0..MaxPointsIndex] of TPoint; 

295 
cnt, i: Longword; 

296 
r: TSDL_Rect; 

351  297 
Result: boolean; 
184  298 
begin 
299 
cnt:= 0; 

300 
with Obj do 

1190
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

301 
begin 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

302 
if Maxcnt = 0 then 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

303 
exit(false); 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

304 
x:= 0; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

305 
r.x:= 0; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

306 
r.y:= 0; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

307 
r.w:= Width; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

308 
r.h:= Height + 16; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

309 
repeat 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

310 
y:= 8; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

311 
repeat 
1776  312 
if CheckLand(r, x, y  8, COLOR_LAND) 
1190
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

313 
and not CheckIntersect(x, y, Width, Height) then 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

314 
begin 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

315 
ar[cnt].x:= x; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

316 
ar[cnt].y:= y; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

317 
inc(cnt); 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

318 
if cnt > MaxPointsIndex then // buffer is full, do not check the rest land 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

319 
begin 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

320 
y:= 5000; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

321 
x:= 5000; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

322 
end 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

323 
end; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

324 
inc(y, 12); 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

325 
until y > 1023  Height  8; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

326 
inc(x, getrandom(12) + 12) 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

327 
until x > 2047  Width; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

328 
Result:= cnt <> 0; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

329 
if Result then 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

330 
begin 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

331 
i:= getrandom(cnt); 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

332 
r.x:= ar[i].X; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

333 
r.y:= ar[i].Y; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

334 
r.w:= Width; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

335 
r.h:= Height; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

336 
SDL_UpperBlit(Obj.Surf, nil, Surface, @r); 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

337 
AddRect(ar[i].x  32, ar[i].y  32, Width + 64, Height + 64); 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

338 
dec(Maxcnt) 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

339 
end else Maxcnt:= 0 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

340 
end; 
351  341 
TryPut:= Result 
184  342 
end; 
343 

344 
procedure ReadThemeInfo(var ThemeObjects: TThemeObjects; var SprayObjects: TSprayObjects); 

345 
var s: string; 

346 
f: textfile; 

371  347 
i, ii: LongInt; 
805  348 
vobcount: Longword; 
1085
0b82870073b5
Load flakes information from theme.cfg when playing painted map
unc0rr
parents:
1066
diff
changeset

349 
c1, c2: TSDL_Color; 
1277  350 

351 
procedure CheckRect(Width, Height, x, y, w, h: LongWord); 

352 
begin 

353 
if (x + w > Width) then OutError('Object''s rectangle exceeds image: x + w (' + inttostr(x) + ' + ' + inttostr(w) + ') > Width (' + inttostr(Width) + ')', true); 

354 
if (y + h > Height) then OutError('Object''s rectangle exceeds image: y + h (' + inttostr(y) + ' + ' + inttostr(h) + ') > Height (' + inttostr(Height) + ')', true); 

355 
end; 

356 

184  357 
begin 
358 
s:= Pathz[ptCurrTheme] + '/' + cThemeCFGFilename; 

359 
WriteLnToConsole('Reading objects info...'); 

351  360 
Assign(f, s); 
184  361 
{$I} 
362 
Reset(f); 

1085
0b82870073b5
Load flakes information from theme.cfg when playing painted map
unc0rr
parents:
1066
diff
changeset

363 

0b82870073b5
Load flakes information from theme.cfg when playing painted map
unc0rr
parents:
1066
diff
changeset

364 
// read sky and explosion border colors 
0b82870073b5
Load flakes information from theme.cfg when playing painted map
unc0rr
parents:
1066
diff
changeset

365 
Readln(f, c1.r, c1.g, c1. b); 
0b82870073b5
Load flakes information from theme.cfg when playing painted map
unc0rr
parents:
1066
diff
changeset

366 
Readln(f, c2.r, c2.g, c2. b); 
1256  367 
// read water gradient colors 
368 
Readln(f, WaterColor.r, WaterColor.g, WaterColor. b); 

369 
Readln(f, DeepWaterColor.r, DeepWaterColor.g, DeepWaterColor. b); 

1085
0b82870073b5
Load flakes information from theme.cfg when playing painted map
unc0rr
parents:
1066
diff
changeset

370 

0b82870073b5
Load flakes information from theme.cfg when playing painted map
unc0rr
parents:
1066
diff
changeset

371 
glClearColor(c1.r / 255, c1.g / 255, c1.b / 255, 0.99); // sky color 
0b82870073b5
Load flakes information from theme.cfg when playing painted map
unc0rr
parents:
1066
diff
changeset

372 
cExplosionBorderColor:= c2.value or $FF000000; 
0b82870073b5
Load flakes information from theme.cfg when playing painted map
unc0rr
parents:
1066
diff
changeset

373 

1097  374 
ReadLn(f, s); 
375 
if MusicFN = '' then MusicFN:= s; 

376 

1131
c5b8f2bfa487
 Add ability to choose clouds number in theme config file
unc0rr
parents:
1097
diff
changeset

377 
ReadLn(f, cCloudsNumber); 
c5b8f2bfa487
 Add ability to choose clouds number in theme config file
unc0rr
parents:
1097
diff
changeset

378 

1801  379 
// TODO  adjust all the theme cloud numbers. This should not be a permanent fix 
380 
cCloudsNumber:= cCloudsNumber * (LAND_WIDTH div 2048); 

381 

184  382 
Readln(f, ThemeObjects.Count); 
383 
for i:= 0 to Pred(ThemeObjects.Count) do 

1276
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

384 
begin 
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

385 
Readln(f, s); // filename 
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

386 
with ThemeObjects.objs[i] do 
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

387 
begin 
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

388 
Surf:= LoadImage(Pathz[ptCurrTheme] + '/' + s, false, true, true); 
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

389 
Width:= Surf^.w; 
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

390 
Height:= Surf^.h; 
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

391 
with inland do 
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

392 
begin 
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

393 
Read(f, x, y, w, h); 
1277  394 
CheckRect(Width, Height, x, y, w, h) 
1276
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

395 
end; 
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

396 
Read(f, rectcnt); 
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

397 
for ii:= 1 to rectcnt do 
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

398 
with outland[ii] do 
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

399 
begin 
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

400 
Read(f, x, y, w, h); 
1277  401 
CheckRect(Width, Height, x, y, w, h) 
1276
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

402 
end; 
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

403 
Maxcnt:= 3; 
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

404 
ReadLn(f) 
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

405 
end; 
281f6aa9afba
Fix bug #61 http://fireforge.net/tracker/index.php?func=detail&aid=61&group_id=11&atid=125
unc0rr
parents:
1256
diff
changeset

406 
end; 
184  407 

802
ed5450a89b96
Start implementing 'visual gears'  gears, that don't need to be synchronized (clouds and flakes)
unc0rr
parents:
780
diff
changeset

408 
// sprays 
184  409 
Readln(f, SprayObjects.Count); 
410 
for i:= 0 to Pred(SprayObjects.Count) do 

411 
begin 

412 
Readln(f, s); // filename 

413 
with SprayObjects.objs[i] do 

414 
begin 

351  415 
Surf:= LoadImage(Pathz[ptCurrTheme] + '/' + s, false, true, true); 
416 
Width:= Surf^.w; 

417 
Height:= Surf^.h; 

184  418 
ReadLn(f, Maxcnt) 
419 
end; 

420 
end; 

802
ed5450a89b96
Start implementing 'visual gears'  gears, that don't need to be synchronized (clouds and flakes)
unc0rr
parents:
780
diff
changeset

421 

ed5450a89b96
Start implementing 'visual gears'  gears, that don't need to be synchronized (clouds and flakes)
unc0rr
parents:
780
diff
changeset

422 
// snowflakes 
805  423 
Readln(f, vobCount); 
424 
if vobCount > 0 then 

425 
Readln(f, vobFramesCount, vobFrameTicks, vobVelocity, vobFallSpeed); 

426 

427 
for i:= 0 to Pred(vobCount) do 

1869  428 
AddVisualGear( cScreenWidth + random(cScreenWidth * 2 + LAND_WIDTH), random(1024+200)  100 + LAND_HEIGHT, vgtFlake); 
805  429 

351  430 
Close(f); 
184  431 
{$I+} 
432 
TryDo(IOResult = 0, 'Bad data or cannot access file ' + cThemeCFGFilename, true) 

433 
end; 

434 

1186
bf5af791d234
Step 5: Finally... we have theme objects with alphachannel!
unc0rr
parents:
1185
diff
changeset

435 
procedure AddThemeObjects(var ThemeObjects: TThemeObjects; MaxCount: LongInt); 
371  436 
var i, ii, t: LongInt; 
184  437 
b: boolean; 
438 
begin 

439 
if ThemeObjects.Count = 0 then exit; 

440 
WriteLnToConsole('Adding theme objects...'); 

441 
i:= 1; 

442 
repeat 

443 
t:= getrandom(ThemeObjects.Count); 

444 
ii:= t; 

445 
repeat 

446 
inc(ii); 

447 
if ii = ThemeObjects.Count then ii:= 0; 

1180
e56317fdf78d
Start implementing support for 32bit sprites concerned in map generation process.
unc0rr
parents:
1156
diff
changeset

448 
b:= TryPut(ThemeObjects.objs[ii]) 
184  449 
until b or (ii = t); 
450 
inc(i) 

451 
until (i > MaxCount) or not b; 

452 
end; 

453 

454 
procedure AddSprayObjects(Surface: PSDL_Surface; var SprayObjects: TSprayObjects; MaxCount: Longword); 

455 
var i: Longword; 

371  456 
ii, t: LongInt; 
184  457 
b: boolean; 
458 
begin 

459 
if SprayObjects.Count = 0 then exit; 

460 
WriteLnToConsole('Adding spray objects...'); 

461 
i:= 1; 

462 
repeat 

463 
t:= getrandom(SprayObjects.Count); 

464 
ii:= t; 

465 
repeat 

466 
inc(ii); 

467 
if ii = SprayObjects.Count then ii:= 0; 

468 
b:= TryPut(SprayObjects.objs[ii], Surface) 

469 
until b or (ii = t); 

470 
inc(i) 

471 
until (i > MaxCount) or not b; 

472 
end; 

473 

1180
e56317fdf78d
Start implementing support for 32bit sprites concerned in map generation process.
unc0rr
parents:
1156
diff
changeset

474 
procedure AddObjects(); 
1792  475 
var i, int: Longword; 
184  476 
begin 
1183
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

477 
InitRects; 
1776  478 
if hasGirders then 
479 
begin 

1792  480 
int:= max(playWidth div 8, 256); 
481 
i:=leftX+int; 

482 
repeat 

483 
AddGirder(i); 

484 
i:=i+int; 

485 
until (i>rightXint); 

1776  486 
end; 
1792  487 
AddThemeObjects(ThemeObjects, MaxHedgehogs div 2); // MaxHedgehogs should roughly correspond to available surface area. Was also thinking maybe using playHeight * playWidth div constant :) 
184  488 
AddProgress; 
1190
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

489 
FreeRects 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

490 
end; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

491 

73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

492 
procedure AddOnLandObjects(Surface: PSDL_Surface); 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

493 
begin 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

494 
InitRects; 
73ec31d8bb6f
Enable back rendering objects that are put on top of land texture
unc0rr
parents:
1186
diff
changeset

495 
AddSprayObjects(Surface, SprayObjects, 12); 
1186
bf5af791d234
Step 5: Finally... we have theme objects with alphachannel!
unc0rr
parents:
1185
diff
changeset

496 
FreeRects 
184  497 
end; 
498 

1085
0b82870073b5
Load flakes information from theme.cfg when playing painted map
unc0rr
parents:
1066
diff
changeset

499 
procedure LoadThemeConfig; 
0b82870073b5
Load flakes information from theme.cfg when playing painted map
unc0rr
parents:
1066
diff
changeset

500 
begin 
0b82870073b5
Load flakes information from theme.cfg when playing painted map
unc0rr
parents:
1066
diff
changeset

501 
ReadThemeInfo(ThemeObjects, SprayObjects) 
0b82870073b5
Load flakes information from theme.cfg when playing painted map
unc0rr
parents:
1066
diff
changeset

502 
end; 
0b82870073b5
Load flakes information from theme.cfg when playing painted map
unc0rr
parents:
1066
diff
changeset

503 

184  504 
end. 