author  nemo 
Sat, 23 May 2009 18:26:16 +0000  
changeset 2096  356468481e74 
parent 1906  644f93d8f148 
child 2152  a2811690da1b 
permissions  rwrr 
4  1 
(* 
1066  2 
* Hedgewars, a free turn based strategy game 
883  3 
* Copyright (c) 20052008 Andrey Korotaev <unC0Rr@gmail.com> 
4  4 
* 
183  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 

4  8 
* 
183  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. 

4  13 
* 
183  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 

4  17 
*) 
18 

19 
unit uLand; 

20 
interface 

1906  21 
uses SDLh, uLandTemplates, uFloat, 
22 
{$IFDEF IPHONE} 

23 
gles11, 

24 
{$ELSE} 

25 
GL, 

26 
{$ENDIF} 

27 
uConsts; 

4  28 
{$include options.inc} 
1760  29 
type TLandArray = packed array[0 .. LAND_HEIGHT  1, 0 .. LAND_WIDTH  1] of LongWord; 
30 
TPreview = packed array[0..127, 0..31] of byte; 

31 
TDirtyTag = packed array[0 .. LAND_HEIGHT div 32  1, 0 .. LAND_WIDTH div 32  1] of byte; 

4  32 

33 
var Land: TLandArray; 

768  34 
LandPixels: TLandArray; 
1738
00e8dadce69a
Add nemo's depixeling patch. Still needs some polishing for the case when we delete pixel on which hedgehog stays
unc0rr
parents:
1537
diff
changeset

35 
LandDirty: TDirtyTag; 
1776  36 
hasBorder: boolean; // I'm putting this here for now. I'd like it to be toggleable by user (so user can set a border on a noncave map)  will turn off air attacks 
37 
hasGirders: boolean; // I think should be on template by template basis. some caverns might have open water and large spaces. Some islands don't need? It might be better to tweak the girder code based upon space above. dunno. 

1792  38 
playHeight, playWidth, leftX, rightX, topY, MaxHedgehogs: Longword; // idea is that a template can specify height/width. Or, a map, a height/width by the dimensions of the image. If the map has pixels near top of image, it triggers border. Maybe not a good idea, but, for now? Could also be used to prevent placing a girder outside play area on maps with hasBorder = true 
1776  39 

40 
// in your coding style, it appears to be "isXXXX" for a verb, and "FooBar" for everything else  should be PlayHeight ? 

4  41 

37  42 
procedure GenMap; 
766  43 
function GenPreview: TPreview; 
367  44 
procedure CheckLandDigest(s: shortstring); 
4  45 

46 
implementation 

1806  47 
uses uConsole, uStore, uMisc, uRandom, uTeams, uLandObjects, uSHA, uIO, uAmmos, uLandTexture; 
4  48 

49 
type TPixAr = record 

50 
Count: Longword; 

22  51 
ar: array[0..Pred(cMaxEdgePoints)] of TPoint; 
4  52 
end; 
53 

37  54 
procedure LogLandDigest; 
316  55 
var ctx: TSHA1Context; 
56 
dig: TSHA1Digest; 

57 
s: shortstring; 

37  58 
begin 
316  59 
SHA1Init(ctx); 
60 
SHA1Update(ctx, @Land, sizeof(Land)); 

61 
dig:= SHA1Final(ctx); 

367  62 
s:='M{'+inttostr(dig[0])+':' 
316  63 
+inttostr(dig[1])+':' 
64 
+inttostr(dig[2])+':' 

65 
+inttostr(dig[3])+':' 

66 
+inttostr(dig[4])+'}'; 

699  67 
CheckLandDigest(s); 
367  68 
SendIPCRaw(@s[0], Length(s) + 1) 
69 
end; 

70 

71 
procedure CheckLandDigest(s: shortstring); 

72 
const digest: shortstring = ''; 

73 
begin 

368  74 
{$IFDEF DEBUGFILE} 
75 
AddFileLog('CheckLandDigest: ' + s); 

76 
{$ENDIF} 

367  77 
if digest = '' then 
78 
digest:= s 

79 
else 

700  80 
TryDo(s = digest, 'Different maps generated, sorry', true) 
37  81 
end; 
82 

371  83 
procedure DrawLine(X1, Y1, X2, Y2: LongInt; Color: Longword); 
358  84 
var 
371  85 
eX, eY, dX, dY: LongInt; 
86 
i, sX, sY, x, y, d: LongInt; 

358  87 
begin 
88 
eX:= 0; 

89 
eY:= 0; 

90 
dX:= X2  X1; 

91 
dY:= Y2  Y1; 

92 

93 
if (dX > 0) then sX:= 1 

94 
else 

95 
if (dX < 0) then 

96 
begin 

97 
sX:= 1; 

98 
dX:= dX 

99 
end else sX:= dX; 

100 

101 
if (dY > 0) then sY:= 1 

102 
else 

103 
if (dY < 0) then 

104 
begin 

105 
sY:= 1; 

106 
dY:= dY 

107 
end else sY:= dY; 

108 

109 
if (dX > dY) then d:= dX 

110 
else d:= dY; 

111 

112 
x:= X1; 

113 
y:= Y1; 

114 

115 
for i:= 0 to d do 

116 
begin 

117 
inc(eX, dX); 

118 
inc(eY, dY); 

119 
if (eX > d) then 

120 
begin 

121 
dec(eX, d); 

122 
inc(x, sX); 

123 
end; 

124 
if (eY > d) then 

125 
begin 

126 
dec(eY, d); 

127 
inc(y, sY); 

128 
end; 

364  129 

1753  130 
if ((x and LAND_WIDTH_MASK) = 0) and ((y and LAND_HEIGHT_MASK) = 0) then 
358  131 
Land[y, x]:= Color; 
132 
end 

133 
end; 

134 

365  135 
procedure DrawEdge(var pa: TPixAr; Color: Longword); 
371  136 
var i: LongInt; 
4  137 
begin 
365  138 
i:= 0; 
4  139 
with pa do 
371  140 
while i < LongInt(Count)  1 do 
365  141 
if (ar[i + 1].X = NTPX) then inc(i, 2) 
142 
else begin 

143 
DrawLine(ar[i].x, ar[i].y, ar[i + 1].x, ar[i + 1].y, Color); 

144 
inc(i) 

145 
end 

22  146 
end; 
147 

365  148 
procedure Vector(p1, p2, p3: TPoint; var Vx, Vy: hwFloat); 
149 
var d1, d2, d: hwFloat; 

364  150 
begin 
498  151 
Vx:= int2hwFloat(p1.X  p3.X); 
152 
Vy:= int2hwFloat(p1.Y  p3.Y); 

153 
d:= DistanceI(p2.X  p1.X, p2.Y  p1.Y); 

154 
d1:= DistanceI(p2.X  p3.X, p2.Y  p3.Y); 

365  155 
d2:= Distance(Vx, Vy); 
156 
if d1 < d then d:= d1; 

157 
if d2 < d then d:= d2; 

158 
d:= d * _1div3; 

159 
if d2.QWordValue = 0 then 

160 
begin 

498  161 
Vx:= _0; 
162 
Vy:= _0 

365  163 
end else 
164 
begin 

498  165 
d2:= _1 / d2; 
365  166 
Vx:= Vx * d2; 
167 
Vy:= Vy * d2; 

168 

169 
Vx:= Vx * d; 

170 
Vy:= Vy * d 

171 
end 

172 
end; 

173 

371  174 
procedure AddLoopPoints(var pa, opa: TPixAr; StartI, EndI: LongInt; Delta: hwFloat); 
175 
var i, pi, ni: LongInt; 

365  176 
NVx, NVy, PVx, PVy: hwFloat; 
498  177 
x1, x2, y1, y2: LongInt; 
178 
tsq, tcb, t, r1, r2, r3, cx1, cx2, cy1, cy2: hwFloat; 

371  179 
X, Y: LongInt; 
365  180 
begin 
181 
pi:= EndI; 

182 
i:= StartI; 

183 
ni:= Succ(StartI); 

184 
Vector(opa.ar[pi], opa.ar[i], opa.ar[ni], NVx, NVy); 

185 
repeat 

186 
inc(pi); 

187 
if pi > EndI then pi:= StartI; 

188 
inc(i); 

189 
if i > EndI then i:= StartI; 

190 
inc(ni); 

191 
if ni > EndI then ni:= StartI; 

192 
PVx:= NVx; 

193 
PVy:= NVy; 

194 
Vector(opa.ar[pi], opa.ar[i], opa.ar[ni], NVx, NVy); 

195 

196 
x1:= opa.ar[pi].x; 

197 
y1:= opa.ar[pi].y; 

198 
x2:= opa.ar[i].x; 

199 
y2:= opa.ar[i].y; 

498  200 
cx1:= int2hwFloat(x1)  PVx; 
201 
cy1:= int2hwFloat(y1)  PVy; 

202 
cx2:= int2hwFloat(x2) + NVx; 

203 
cy2:= int2hwFloat(y2) + NVy; 

204 
t:= _0; 

364  205 
while t.Round = 0 do 
206 
begin 

207 
tsq:= t * t; 

208 
tcb:= tsq * t; 

498  209 
r1:= (_1  t*3 + tsq*3  tcb); 
210 
r2:= ( t*3  tsq*6 + tcb*3); 

211 
r3:= ( tsq*3  tcb*3); 

430  212 
X:= hwRound(r1 * x1 + r2 * cx1 + r3 * cx2 + tcb * x2); 
213 
Y:= hwRound(r1 * y1 + r2 * cy1 + r3 * cy2 + tcb * y2); 

364  214 
t:= t + Delta; 
215 
pa.ar[pa.Count].x:= X; 

216 
pa.ar[pa.Count].y:= Y; 

217 
inc(pa.Count); 

218 
TryDo(pa.Count <= cMaxEdgePoints, 'Edge points overflow', true) 

219 
end; 

365  220 
until i = StartI; 
221 
pa.ar[pa.Count].x:= opa.ar[StartI].X; 

222 
pa.ar[pa.Count].y:= opa.ar[StartI].Y; 

364  223 
inc(pa.Count) 
224 
end; 

225 

365  226 
procedure BezierizeEdge(var pa: TPixAr; Delta: hwFloat); 
495  227 
var i, StartLoop: LongInt; 
365  228 
opa: TPixAr; 
229 
begin 

230 
opa:= pa; 

231 
pa.Count:= 0; 

232 
i:= 0; 

233 
StartLoop:= 0; 

371  234 
while i < LongInt(opa.Count) do 
365  235 
if (opa.ar[i + 1].X = NTPX) then 
236 
begin 

237 
AddLoopPoints(pa, opa, StartLoop, i, Delta); 

238 
inc(i, 2); 

239 
StartLoop:= i; 

240 
pa.ar[pa.Count].X:= NTPX; 

241 
inc(pa.Count); 

242 
end else inc(i) 

243 
end; 

244 

371  245 
procedure FillLand(x, y: LongInt); 
4  246 
var Stack: record 
247 
Count: Longword; 

248 
points: array[0..8192] of record 

371  249 
xl, xr, y, dir: LongInt; 
4  250 
end 
251 
end; 

252 

371  253 
procedure Push(_xl, _xr, _y, _dir: LongInt); 
4  254 
begin 
75  255 
TryDo(Stack.Count <= 8192, 'FillLand: stack overflow', true); 
4  256 
_y:= _y + _dir; 
1760  257 
if (_y < 0) or (_y >= LAND_HEIGHT) then exit; 
4  258 
with Stack.points[Stack.Count] do 
259 
begin 

260 
xl:= _xl; 

261 
xr:= _xr; 

262 
y:= _y; 

263 
dir:= _dir 

264 
end; 

75  265 
inc(Stack.Count) 
4  266 
end; 
267 

371  268 
procedure Pop(var _xl, _xr, _y, _dir: LongInt); 
4  269 
begin 
270 
dec(Stack.Count); 

271 
with Stack.points[Stack.Count] do 

272 
begin 

273 
_xl:= xl; 

274 
_xr:= xr; 

275 
_y:= y; 

276 
_dir:= dir 

277 
end 

278 
end; 

279 

371  280 
var xl, xr, dir: LongInt; 
351  281 
begin 
4  282 
Stack.Count:= 0; 
283 
xl:= x  1; 

284 
xr:= x; 

23  285 
Push(xl, xr, y, 1); 
286 
Push(xl, xr, y, 1); 

4  287 
while Stack.Count > 0 do 
288 
begin 

289 
Pop(xl, xr, y, dir); 

51  290 
while (xl > 0) and (Land[y, xl] <> 0) do dec(xl); 
1760  291 
while (xr < LAND_WIDTH  1) and (Land[y, xr] <> 0) do inc(xr); 
4  292 
while (xl < xr) do 
293 
begin 

51  294 
while (xl <= xr) and (Land[y, xl] = 0) do inc(xl); 
4  295 
x:= xl; 
51  296 
while (xl <= xr) and (Land[y, xl] <> 0) do 
4  297 
begin 
51  298 
Land[y, xl]:= 0; 
4  299 
inc(xl) 
300 
end; 

22  301 
if x < xl then 
302 
begin 

303 
Push(x, Pred(xl), y, dir); 

304 
Push(x, Pred(xl), y,dir); 

305 
end; 

4  306 
end; 
307 
end; 

308 
end; 

309 

310 
procedure ColorizeLand(Surface: PSDL_Surface); 

311 
var tmpsurf: PSDL_Surface; 

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

312 
r, rr: TSDL_Rect; 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

313 
x, yd, yu: LongInt; 
4  314 
begin 
567  315 
tmpsurf:= LoadImage(Pathz[ptCurrTheme] + '/LandTex', false, true, false); 
4  316 
r.y:= 0; 
1760  317 
while r.y < LAND_HEIGHT do 
1182
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

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

319 
r.x:= 0; 
1760  320 
while r.x < LAND_WIDTH do 
1182
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

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

322 
SDL_UpperBlit(tmpsurf, nil, Surface, @r); 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

323 
inc(r.x, tmpsurf^.w) 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

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

325 
inc(r.y, tmpsurf^.h) 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

326 
end; 
4  327 
SDL_FreeSurface(tmpsurf); 
328 

351  329 
tmpsurf:= LoadImage(Pathz[ptCurrTheme] + '/Border', false, true, true); 
1760  330 
for x:= 0 to LAND_WIDTH  1 do 
1182
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

331 
begin 
1760  332 
yd:= LAND_HEIGHT  1; 
1182
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

333 
repeat 
1760  334 
while (yd > 0) and (Land[yd, x] = 0) do dec(yd); 
1182
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

335 

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

336 
if (yd < 0) then yd:= 0; 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

337 

1760  338 
while (yd < LAND_HEIGHT) and (Land[yd, x] <> 0) do inc(yd); 
1182
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

339 
dec(yd); 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

340 
yu:= yd; 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

341 

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

342 
while (yu > 0 ) and (Land[yu, x] <> 0) do dec(yu); 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

343 
while (yu < yd ) and (Land[yu, x] = 0) do inc(yu); 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

344 

1760  345 
if (yd < LAND_HEIGHT  1) and ((yd  yu) >= 16) then 
1182
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

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

347 
rr.x:= x; 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

348 
rr.y:= yd  15; 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

349 
r.x:= x mod tmpsurf^.w; 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

350 
r.y:= 16; 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

351 
r.w:= 1; 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

352 
r.h:= 16; 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

353 
SDL_UpperBlit(tmpsurf, @r, Surface, @rr); 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

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

355 
if (yu > 0) then 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

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

357 
rr.x:= x; 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

358 
rr.y:= yu; 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

359 
r.x:= x mod tmpsurf^.w; 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

360 
r.y:= 0; 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

361 
r.w:= 1; 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

362 
r.h:= min(16, yd  yu + 1); 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

363 
SDL_UpperBlit(tmpsurf, @r, Surface, @rr); 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

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

365 
yd:= yu  1; 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

366 
until yd < 0; 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

367 
end; 
4  368 
end; 
369 

358  370 
procedure SetPoints(var Template: TEdgeTemplate; var pa: TPixAr); 
371  371 
var i: LongInt; 
22  372 
begin 
23  373 
with Template do 
374 
begin 

358  375 
pa.Count:= BasePointsCount; 
376 
for i:= 0 to pred(pa.Count) do 

23  377 
begin 
371  378 
pa.ar[i].x:= BasePoints^[i].x + LongInt(GetRandom(BasePoints^[i].w)); 
1792  379 
if pa.ar[i].x <> NTPX then 
380 
pa.ar[i].x:= pa.ar[i].x + ((LAND_WIDTH  Template.TemplateWidth) div 2); 

1776  381 
pa.ar[i].y:= BasePoints^[i].y + LongInt(GetRandom(BasePoints^[i].h)) + LAND_HEIGHT  Template.TemplateHeight 
23  382 
end; 
1183
540cea859395
Step 4: repair girder rendering (girder is 32bit now)
unc0rr
parents:
1182
diff
changeset

383 

358  384 
if canMirror then 
360  385 
if getrandom(2) = 0 then 
358  386 
begin 
387 
for i:= 0 to pred(BasePointsCount) do 

365  388 
if pa.ar[i].x <> NTPX then 
1760  389 
pa.ar[i].x:= LAND_WIDTH  1  pa.ar[i].x; 
358  390 
for i:= 0 to pred(FillPointsCount) do 
1760  391 
FillPoints^[i].x:= LAND_WIDTH  1  FillPoints^[i].x; 
358  392 
end; 
22  393 

358  394 
if canFlip then 
360  395 
if getrandom(2) = 0 then 
358  396 
begin 
397 
for i:= 0 to pred(BasePointsCount) do 

1760  398 
pa.ar[i].y:= LAND_HEIGHT  1  pa.ar[i].y; 
358  399 
for i:= 0 to pred(FillPointsCount) do 
1760  400 
FillPoints^[i].y:= LAND_HEIGHT  1  FillPoints^[i].y; 
358  401 
end; 
402 
end 

4  403 
end; 
67  404 

561  405 
function CheckIntersect(V1, V2, V3, V4: TPoint): boolean; 
406 
var c1, c2, dm: LongInt; 

407 
begin 

408 
dm:= (V4.y  V3.y) * (V2.x  V1.x)  (V4.x  V3.x) * (V2.y  V1.y); 

409 
c1:= (V4.x  V3.x) * (V1.y  V3.y)  (V4.y  V3.y) * (V1.x  V3.x); 

410 
if dm = 0 then exit(false); 

411 

412 
c2:= (V2.x  V3.x) * (V1.y  V3.y)  (V2.y  V3.y) * (V1.x  V3.x); 

413 
if dm > 0 then 

414 
begin 

415 
if (c1 < 0) or (c1 > dm) then exit(false); 

416 
if (c2 < 0) or (c2 > dm) then exit(false) 

417 
end else 

418 
begin 

419 
if (c1 > 0) or (c1 < dm) then exit(false); 

420 
if (c2 > 0) or (c2 < dm) then exit(false) 

421 
end; 

422 

423 
//AddFileLog('1 (' + inttostr(V1.x) + ',' + inttostr(V1.y) + ')x(' + inttostr(V2.x) + ',' + inttostr(V2.y) + ')'); 

424 
//AddFileLog('2 (' + inttostr(V3.x) + ',' + inttostr(V3.y) + ')x(' + inttostr(V4.x) + ',' + inttostr(V4.y) + ')'); 

425 
CheckIntersect:= true 

426 
end; 

427 

428 
function CheckSelfIntersect(var pa: TPixAr; ind: Longword): boolean; 

429 
var i: Longword; 

430 
begin 

431 
if (ind <= 0) or (ind >= Pred(pa.Count)) then exit(false); 

432 
for i:= 1 to pa.Count  3 do 

433 
if (i <= ind  1) or (i >= ind + 2) then 

434 
begin 

435 
if (i <> ind  1) and 

436 
CheckIntersect(pa.ar[ind], pa.ar[ind  1], pa.ar[i], pa.ar[i  1]) then exit(true); 

437 
if (i <> ind + 2) and 

438 
CheckIntersect(pa.ar[ind], pa.ar[ind + 1], pa.ar[i], pa.ar[i  1]) then exit(true); 

439 
end; 

440 
CheckSelfIntersect:= false 

441 
end; 

442 

429  443 
procedure RandomizePoints(var pa: TPixAr); 
364  444 
const cEdge = 55; 
561  445 
cMinDist = 8; 
371  446 
var radz: array[0..Pred(cMaxEdgePoints)] of LongInt; 
561  447 
i, k, dist, px, py: LongInt; 
364  448 
begin 
449 
radz[0]:= 0; 

450 
for i:= 0 to Pred(pa.Count) do 

451 
with pa.ar[i] do 

365  452 
if x <> NTPX then 
453 
begin 

1760  454 
radz[i]:= Min(Max(x  cEdge, 0), Max(LAND_WIDTH  cEdge  x, 0)); 
455 
radz[i]:= Min(radz[i], Min(Max(y  cEdge, 0), Max(LAND_HEIGHT  cEdge  y, 0))); 

365  456 
if radz[i] > 0 then 
457 
for k:= 0 to Pred(i) do 

364  458 
begin 
429  459 
dist:= Max(abs(x  pa.ar[k].x), abs(y  pa.ar[k].y)); 
365  460 
radz[k]:= Max(0, Min((dist  cMinDist) div 2, radz[k])); 
461 
radz[i]:= Max(0, Min(dist  radz[k]  cMinDist, radz[i])) 

462 
end 

463 
end; 

364  464 

465 
for i:= 0 to Pred(pa.Count) do 

466 
with pa.ar[i] do 

1753  467 
if ((x and LAND_WIDTH_MASK) = 0) and ((y and LAND_HEIGHT_MASK) = 0) then 
364  468 
begin 
561  469 
px:= x; 
470 
py:= y; 

371  471 
x:= x + LongInt(GetRandom(7)  3) * (radz[i] * 5 div 7) div 3; 
561  472 
y:= y + LongInt(GetRandom(7)  3) * (radz[i] * 5 div 7) div 3; 
473 
if CheckSelfIntersect(pa, i) then 

474 
begin 

475 
x:= px; 

476 
y:= py 

477 
end; 

364  478 
end 
67  479 
end; 
480 

364  481 

23  482 
procedure GenBlank(var Template: TEdgeTemplate); 
4  483 
var pa: TPixAr; 
23  484 
i: Longword; 
155
401f4ea24715
Engine can generate land preview and send it via IPC
unc0rr
parents:
109
diff
changeset

485 
y, x: Longword; 
4  486 
begin 
1760  487 
for y:= 0 to LAND_HEIGHT  1 do 
488 
for x:= 0 to LAND_WIDTH  1 do 

155
401f4ea24715
Engine can generate land preview and send it via IPC
unc0rr
parents:
109
diff
changeset

489 
Land[y, x]:= COLOR_LAND; 
401f4ea24715
Engine can generate land preview and send it via IPC
unc0rr
parents:
109
diff
changeset

490 

358  491 
SetPoints(Template, pa); 
429  492 
for i:= 1 to Template.BezierizeCount do 
493 
begin 

431  494 
BezierizeEdge(pa, _0_5); 
561  495 
RandomizePoints(pa); 
429  496 
RandomizePoints(pa) 
497 
end; 

498 
for i:= 1 to Template.RandPassesCount do RandomizePoints(pa); 

365  499 
BezierizeEdge(pa, _0_1); 
27  500 

365  501 
DrawEdge(pa, 0); 
27  502 

358  503 
with Template do 
23  504 
for i:= 0 to pred(FillPointsCount) do 
505 
with FillPoints^[i] do 

89  506 
FillLand(x, y); 
507 

1773  508 
DrawEdge(pa, COLOR_LAND); 
509 

1792  510 
MaxHedgehogs:= Template.MaxHedgehogs; 
1776  511 
hasGirders:= Template.hasGirders; 
512 
playHeight:= Template.TemplateHeight; 

513 
playWidth:= Template.TemplateWidth; 

514 
leftX:= ((LAND_WIDTH  playWidth) div 2); 

515 
rightX:= (playWidth + ((LAND_WIDTH  playWidth) div 2))  1; 

516 
topY:= LAND_HEIGHT  playHeight; 

517 

1797  518 
// force to only cavern even if a cavern map is invertable if cTemplateFilter = 4 ? 
1773  519 
if (Template.canInvert and (getrandom(2) = 0)) or 
520 
(not Template.canInvert and Template.isNegative) then 

1776  521 
begin 
522 
hasBorder:= true; 

1773  523 
for y:= 0 to LAND_HEIGHT  1 do 
524 
for x:= 0 to LAND_WIDTH  1 do 

1776  525 
if (y < topY) or (x < leftX) or (x > rightX) then 
526 
Land[y, x]:= 0 

527 
else 

528 
begin 

529 
if Land[y, x] = 0 then 

530 
Land[y, x]:= COLOR_LAND 

531 
else if Land[y, x] = COLOR_LAND then 

532 
Land[y, x]:= 0; 

533 
end; 

534 
end; 

23  535 
end; 
536 

371  537 
function SelectTemplate: LongInt; 
161  538 
begin 
1797  539 
case cTemplateFilter of 
540 
0: begin 

541 
SelectTemplate:= getrandom(Succ(High(EdgeTemplates))); 

542 
end; 

543 
1: begin 

544 
SelectTemplate:= SmallTemplates[getrandom(Succ(High(SmallTemplates)))]; 

545 
end; 

546 
2: begin 

547 
SelectTemplate:= MediumTemplates[getrandom(Succ(High(MediumTemplates)))]; 

548 
end; 

549 
3: begin 

550 
SelectTemplate:= LargeTemplates[getrandom(Succ(High(LargeTemplates)))]; 

551 
end; 

552 
4: begin 

553 
SelectTemplate:= CavernTemplates[getrandom(Succ(High(CavernTemplates)))]; 

554 
end; 

555 
5: begin 

556 
SelectTemplate:= WackyTemplates[getrandom(Succ(High(WackyTemplates)))]; 

557 
end; 

558 
end; 

559 
WriteLnToConsole('Selected template #'+inttostr(SelectTemplate)+' using filter #'+inttostr(cTemplateFilter)); 

161  560 
end; 
561 

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

562 
procedure LandSurface2LandPixels(Surface: PSDL_Surface); 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

563 
var x, y: LongInt; 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

564 
p: PLongwordArray; 
1180
e56317fdf78d
Start implementing support for 32bit sprites concerned in map generation process.
unc0rr
parents:
1085
diff
changeset

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

566 
TryDo(Surface <> nil, 'Assert (LandSurface <> nil) failed', true); 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

567 

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

568 
if SDL_MustLock(Surface) then 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

569 
SDLTry(SDL_LockSurface(Surface) >= 0, true); 
1180
e56317fdf78d
Start implementing support for 32bit sprites concerned in map generation process.
unc0rr
parents:
1085
diff
changeset

570 

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

571 
p:= Surface^.pixels; 
1760  572 
for y:= 0 to LAND_HEIGHT  1 do 
1182
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

573 
begin 
1760  574 
for x:= 0 to LAND_WIDTH  1 do 
1182
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

575 
if Land[y, x] <> 0 then LandPixels[y, x]:= p^[x] or $FF000000; 
1760  576 

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

577 
p:= @(p^[Surface^.pitch div 4]); 
e2e13aa055c1
Step 3: Maps are rendered correctly, but without objects yet
unc0rr
parents:
1181
diff
changeset

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

579 

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

580 
if SDL_MustLock(Surface) then 
1753  581 
SDL_UnlockSurface(Surface); 
1754  582 
end; 
583 

584 
procedure GenLandSurface; 

585 
var tmpsurf: PSDL_Surface; 

586 
begin 

587 
WriteLnToConsole('Generating land...'); 

588 

589 
GenBlank(EdgeTemplates[SelectTemplate]); 

590 

591 
AddProgress; 

592 

1760  593 
tmpsurf:= SDL_CreateRGBSurface(SDL_SWSURFACE, LAND_WIDTH, LAND_HEIGHT, 32, RMask, GMask, BMask, 0); 
1754  594 

595 
TryDo(tmpsurf <> nil, 'Error creating preland surface', true); 

596 
ColorizeLand(tmpsurf); 

597 
AddOnLandObjects(tmpsurf); 

598 

599 
LandSurface2LandPixels(tmpsurf); 

600 
SDL_FreeSurface(tmpsurf); 

601 

602 
AddProgress; 

603 

604 
AddProgress 

605 
end; 

606 

607 
procedure MakeFortsMap; 

608 
var tmpsurf: PSDL_Surface; 

609 
begin 

1784  610 
// For now, defining a fort's playable area as 3072x1200  there are no tall forts. The extra height is to avoid triggering border with current code, also if user turns on a border, it'll give a bit more maneuvering room. 
611 
playHeight:= 1200; 

2096  612 
playWidth:= 2560; 
1776  613 
leftX:= (LAND_WIDTH  playWidth) div 2; 
614 
rightX:= ((playWidth + (LAND_WIDTH  playWidth) div 2)  1); 

615 
topY:= LAND_HEIGHT  playHeight; 

616 

1754  617 
WriteLnToConsole('Generating forts land...'); 
618 

619 
tmpsurf:= LoadImage(Pathz[ptForts] + '/' + ClansArray[0]^.Teams[0]^.FortName + 'L', true, true, true); 

1784  620 
BlitImageAndGenerateCollisionInfo(leftX+150, LAND_HEIGHT  tmpsurf^.h, tmpsurf^.w, tmpsurf); 
1754  621 
SDL_FreeSurface(tmpsurf); 
622 

623 
tmpsurf:= LoadImage(Pathz[ptForts] + '/' + ClansArray[1]^.Teams[0]^.FortName + 'R', true, true, true); 

1784  624 
BlitImageAndGenerateCollisionInfo(rightX  150  tmpsurf^.w, LAND_HEIGHT  tmpsurf^.h, tmpsurf^.w, tmpsurf); 
1754  625 
SDL_FreeSurface(tmpsurf); 
626 
end; 

627 

1792  628 
// Hi unC0Rr. 
629 
// This is a function that Tiy assures me would not be good for gameplay. 

630 
// It allows the setting of arbitrary portions of landscape as indestructible, or regular, or even blank. 

631 
// He said I could add it here only when I swore it wouldn't impact gameplay. Which, as far as I can tell, is true. 

632 
// I'd just like to play with it with my friends if you don't mind. 

633 
// Can allow for amusing maps. 

634 
procedure LoadMask; 

635 
var tmpsurf: PSDL_Surface; 

636 
p: PLongwordArray; 

637 
x, y, cpX, cpY: Longword; 

638 
begin 

639 
tmpsurf:= LoadImage(Pathz[ptMapCurrent] + '/mask', true, false, true); 

640 
if (tmpsurf <> nil) and (tmpsurf^.w <= LAND_WIDTH) and (tmpsurf^.h <= LAND_HEIGHT) and (tmpsurf^.format^.BytesPerPixel = 4) then 

641 
begin 

642 
cpX:= (LAND_WIDTH  tmpsurf^.w) div 2; 

643 
cpY:= LAND_HEIGHT  tmpsurf^.h; 

644 
if SDL_MustLock(tmpsurf) then 

645 
SDLTry(SDL_LockSurface(tmpsurf) >= 0, true); 

646 

647 
p:= tmpsurf^.pixels; 

648 
for y:= 0 to Pred(tmpsurf^.h) do 

649 
begin 

650 
for x:= 0 to Pred(tmpsurf^.w) do 

1849  651 
begin 
652 
if (($FF000000 and p^[x]) = 0) then // Tiy was having trouble generating transparent black 

653 
Land[cpY + y, cpX + x]:= 0 

654 
else 

655 
Land[cpY + y, cpX + x]:= p^[x]; 

656 
end; 

1792  657 
p:= @(p^[tmpsurf^.pitch div 4]); 
658 
end; 

659 

660 
if SDL_MustLock(tmpsurf) then 

661 
SDL_UnlockSurface(tmpsurf); 

662 
SDL_FreeSurface(tmpsurf); 

663 
end; 

664 
end; 

665 

1754  666 
procedure LoadMap; 
667 
var tmpsurf: PSDL_Surface; 

1795  668 
s: string; 
669 
f: textfile; 

1754  670 
begin 
671 
WriteLnToConsole('Loading land from file...'); 

672 
AddProgress; 

673 
tmpsurf:= LoadImage(Pathz[ptMapCurrent] + '/map', true, true, true); 

1760  674 
TryDo((tmpsurf^.w <= LAND_WIDTH) and (tmpsurf^.h <= LAND_HEIGHT), 'Map dimensions too big!', true); 
1754  675 

1792  676 
// unC0Rr  should this be passed from the GUI? I'm not sure which layer does what 
677 
s:= Pathz[ptMapCurrent] + '/map.cfg'; 

678 
WriteLnToConsole('Fetching map HH limit'); 

679 
Assign(f, s); 

680 
Reset(f); 

1795  681 
Readln(f); 
682 
if not eof(f) then Readln(f, MaxHedgehogs); 

683 

1792  684 
if(MaxHedgehogs = 0) then MaxHedgehogs:= 18; 
685 

1776  686 
playHeight:= tmpsurf^.h; 
687 
playWidth:= tmpsurf^.w; 

688 
leftX:= (LAND_WIDTH  playWidth) div 2; 

689 
rightX:= (playWidth + ((LAND_WIDTH  playWidth) div 2))  1; 

690 
topY:= LAND_HEIGHT  playHeight; 

691 

1754  692 
TryDo(tmpsurf^.format^.BytesPerPixel = 4, 'Map should be 32bit', true); 
693 

1772  694 
BlitImageAndGenerateCollisionInfo( 
695 
(LAND_WIDTH  tmpsurf^.w) div 2, 

696 
LAND_HEIGHT  tmpsurf^.h, 

697 
tmpsurf^.w, 

698 
tmpsurf); 

1754  699 
SDL_FreeSurface(tmpsurf); 
1792  700 

701 
LoadMask; 

1754  702 
end; 
703 

704 
procedure GenMap; 

1784  705 
var x, y, w, c: Longword; 
1754  706 
begin 
1776  707 
hasBorder:= false; 
708 
hasGirders:= true; 

1754  709 
LoadThemeConfig; 
710 

711 
if (GameFlags and gfForts) = 0 then 

712 
if Pathz[ptMapCurrent] <> '' then LoadMap 

713 
else GenLandSurface 

714 
else MakeFortsMap; 

715 
AddProgress; 

1760  716 

1754  717 
{$IFDEF DEBUGFILE}LogLandDigest;{$ENDIF} 
1753  718 

1768  719 
// check for land near top 
1784  720 
c:= 0; 
721 
if (GameFlags and gfBorder) <> 0 then 

722 
hasBorder:= true 

723 
else 

724 
for y:= topY to topY + 5 do 

725 
for x:= leftX to rightX do 

726 
if Land[y, x] <> 0 then 

727 
begin 

728 
inc(c); 

729 
if c > 200 then // avoid accidental triggering 

730 
begin 

731 
hasBorder:= true; 

732 
break; 

733 
end; 

734 
end; 

1768  735 

1776  736 
if hasBorder then 
1768  737 
begin 
1784  738 
for y:= 0 to LAND_HEIGHT  1 do 
739 
for x:= 0 to LAND_WIDTH  1 do 

740 
if (y < topY) or (x < leftX) or (x > rightX) then 

741 
Land[y, x]:= COLOR_INDESTRUCTIBLE; 

1768  742 
// experiment hardcoding cave 
1784  743 
// also try basing cave dimensions on map/template dimensions, if they exist 
744 
for w:= 0 to 5 do // width of 3 allowed worms to be knocked through with grenade 

745 
begin 

746 
for y:= topY to LAND_HEIGHT  1 do 

747 
begin 

748 
Land[y, leftX + w]:= COLOR_INDESTRUCTIBLE; 

749 
Land[y, rightX  w]:= COLOR_INDESTRUCTIBLE; 

750 
if (y + w) mod 32 < 16 then 

751 
c:= $FF000000 

752 
else 

753 
c:= $FF00FFFF; 

754 
LandPixels[y, leftX + w]:= c; 

755 
LandPixels[y, rightX  w]:= c; 

756 
end; 

1768  757 

1784  758 
for x:= leftX to rightX do 
759 
begin 

760 
Land[topY + w, x]:= COLOR_INDESTRUCTIBLE; 

761 
if (x + w) mod 32 < 16 then 

762 
c:= $FF000000 

763 
else 

764 
c:= $FF00FFFF; 

765 
LandPixels[topY + w, x]:= c; 

766 
end; 

767 
end; 

1768  768 
end; 
769 

1776  770 
if ((GameFlags and gfForts) = 0) and (Pathz[ptMapCurrent] = '') then AddObjects; 
771 

1807  772 
UpdateLandTexture(0, LAND_WIDTH, 0, LAND_HEIGHT); 
37  773 
end; 
774 

566  775 
function GenPreview: TPreview; 
371  776 
var x, y, xx, yy, t, bit: LongInt; 
566  777 
Preview: TPreview; 
155
401f4ea24715
Engine can generate land preview and send it via IPC
unc0rr
parents:
109
diff
changeset

778 
begin 
160  779 
WriteLnToConsole('Generating preview...'); 
161  780 
GenBlank(EdgeTemplates[SelectTemplate]); 
155
401f4ea24715
Engine can generate land preview and send it via IPC
unc0rr
parents:
109
diff
changeset

781 

401f4ea24715
Engine can generate land preview and send it via IPC
unc0rr
parents:
109
diff
changeset

782 
for y:= 0 to 127 do 
401f4ea24715
Engine can generate land preview and send it via IPC
unc0rr
parents:
109
diff
changeset

783 
for x:= 0 to 31 do 
401f4ea24715
Engine can generate land preview and send it via IPC
unc0rr
parents:
109
diff
changeset

784 
begin 
401f4ea24715
Engine can generate land preview and send it via IPC
unc0rr
parents:
109
diff
changeset

785 
Preview[y, x]:= 0; 
401f4ea24715
Engine can generate land preview and send it via IPC
unc0rr
parents:
109
diff
changeset

786 
for bit:= 0 to 7 do 
401f4ea24715
Engine can generate land preview and send it via IPC
unc0rr
parents:
109
diff
changeset

787 
begin 
401f4ea24715
Engine can generate land preview and send it via IPC
unc0rr
parents:
109
diff
changeset

788 
t:= 0; 
1760  789 
for yy:= y * (LAND_HEIGHT div 128) to y * (LAND_HEIGHT div 128) + 7 do 
790 
for xx:= x * (LAND_WIDTH div 32) + bit * 8 to x * (LAND_WIDTH div 32) + bit * 8 + 7 do 

155
401f4ea24715
Engine can generate land preview and send it via IPC
unc0rr
parents:
109
diff
changeset

791 
if Land[yy, xx] <> 0 then inc(t); 
351  792 
if t > 8 then Preview[y, x]:= Preview[y, x] or ($80 shr bit) 
155
401f4ea24715
Engine can generate land preview and send it via IPC
unc0rr
parents:
109
diff
changeset

793 
end 
566  794 
end; 
1768  795 
GenPreview:= Preview 
155
401f4ea24715
Engine can generate land preview and send it via IPC
unc0rr
parents:
109
diff
changeset

796 
end; 
401f4ea24715
Engine can generate land preview and send it via IPC
unc0rr
parents:
109
diff
changeset

797 

51  798 
initialization 
799 

4  800 
end. 