1 (*
2 * Hedgewars, a free turn based strategy game
3 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>
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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
17 *)
18
19 {$INCLUDE "options.inc"}
20
21 unit uLandGraphics;
22 interface
23 uses uFloat, uConsts, uTypes, Math, uRenderUtils;
24
25 type
26 fillType = (nullPixel, backgroundPixel, ebcPixel, icePixel, addNotHHObj, removeNotHHObj, addHH, removeHH, setCurrentHog, removeCurrentHog);
27
28 type TRangeArray = array[0..31] of record
29 Left, Right: LongInt;
30 end;
31 PRangeArray = ^TRangeArray;
32 TLandCircleProcedure = procedure (landX, landY, pixelX, pixelY: Longint);
33
addBgColornull34 function addBgColor(OldColor, NewColor: LongWord): LongWord;
SweepDirtynull35 function SweepDirty: boolean;
Despecklenull36 function Despeckle(X, Y: LongInt): Boolean;
37 procedure Smooth(X, Y: LongInt);
CheckLandValuenull38 function CheckLandValue(X, Y: LongInt; LandFlag: Word): boolean;
DrawExplosionnull39 function DrawExplosion(X, Y, Radius: LongInt): Longword;
40 procedure DrawHLinesExplosions(ar: PRangeArray; Radius: LongInt; y, dY: LongInt; Count: Byte);
41 procedure DrawTunnel(X, Y, dX, dY: hwFloat; ticks, HalfWidth: LongInt);
FillRoundInLandnull42 function FillRoundInLand(X, Y, Radius: LongInt; Value: Longword): Longword;
FillRoundInLandFTnull43 function FillRoundInLandFT(X, Y, Radius: LongInt; fill: fillType): Longword;
44 procedure ChangeRoundInLand(X, Y, Radius: LongInt; doSet, isCurrent, isHH: boolean);
LandBackPixelnull45 function LandBackPixel(x, y: LongInt): LongWord;
46 procedure DrawLine(X1, Y1, X2, Y2: LongInt; Color: Longword);
DrawThickLinenull47 function DrawThickLine(X1, Y1, X2, Y2, radius: LongInt; color: Longword): Longword;
48 procedure DumpLandToLog(x, y, r: LongInt);
49 procedure DrawIceBreak(x, y, iceRadius, iceHeight: Longint);
TryPlaceOnLandSimplenull50 function TryPlaceOnLandSimple(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; doPlace, indestructible: boolean): boolean; inline;
TryPlaceOnLandnull51 function TryPlaceOnLand(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; doPlace: boolean; LandFlags: Word): boolean; inline;
ForcePlaceOnLandnull52 function ForcePlaceOnLand(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; LandFlags: Word; Tint: LongWord; Behind, flipHoriz, flipVert: boolean): boolean; inline;
TryPlaceOnLandnull53 function TryPlaceOnLand(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; doPlace, outOfMap, force, behind, flipHoriz, flipVert: boolean; LandFlags: Word; Tint: LongWord): boolean;
54 procedure EraseLandRectRaw(X, Y, width, height: LongWord);
55 procedure EraseLand(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; LandFlags: Word; eraseOnLFMatch, onlyEraseLF, flipHoriz, flipVert: boolean);
GetPlaceCollisionTexnull56 function GetPlaceCollisionTex(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt): PTexture;
57
58 implementation
59 uses SDLh, uLandTexture, uTextures, uVariables, uUtils, uDebug, uScript;
60
61
62 procedure calculatePixelsCoordinates(landX, landY: Longint; var pixelX, pixelY: Longint); inline;
63 begin
64 if (cReducedQuality and rqBlurryLand) = 0 then
65 begin
66 pixelX := landX;
67 pixelY := landY;
68 end
69 else
70 begin
71 pixelX := LandX div 2;
72 pixelY := LandY div 2;
73 end;
74 end;
75
drawPixelBGnull76 function drawPixelBG(landX, landY, pixelX, pixelY: Longint): Longword; inline;
77 begin
78 drawPixelBG := 0;
79 if (Land[LandY, landX] and lfIndestructible) = 0 then
80 begin
81 if ((Land[landY, landX] and lfBasic) <> 0) and (((LandPixels[pixelY, pixelX] and AMask) shr AShift) = 255) and (not disableLandBack) then
82 begin
83 LandPixels[pixelY, pixelX]:= LandBackPixel(landX, landY);
84 inc(drawPixelBG);
85 end
86 else if ((Land[landY, landX] and lfObject) <> 0) or (((LandPixels[pixelY, pixelX] and AMask) shr AShift) < 255) then
87 LandPixels[pixelY, pixelX]:= ExplosionBorderColorNoA
88 end;
89 end;
90
91 procedure drawPixelEBC(landX, landY, pixelX, pixelY: Longint); inline;
92 begin
93 if (Land[landY, landX] and lfIndestructible = 0) and
94 (((Land[landY, landX] and lfBasic) <> 0) or ((Land[landY, landX] and lfObject) <> 0)) then
95 begin
96 LandPixels[pixelY, pixelX]:= ExplosionBorderColor;
97 Land[landY, landX]:= (Land[landY, landX] or lfDamaged) and (not lfIce);
98 LandDirty[landY div 32, landX div 32]:= 1;
99 end;
100 end;
101
isLandscapeEdgenull102 function isLandscapeEdge(weight:Longint):boolean; inline;
103 begin
104 isLandscapeEdge := (weight < 8) and (weight >= 2);
105 end;
106
getPixelWeightnull107 function getPixelWeight(x, y:Longint): Longint;
108 var
109 i, j, r: Longint;
110 begin
111 r := 0;
112 for i := x - 1 to x + 1 do
113 for j := y - 1 to y + 1 do
114 begin
115 if (i < 0) or
116 (i > LAND_WIDTH - 1) or
117 (j < 0) or
118 (j > LAND_HEIGHT -1) then
119 exit(9);
120
121 if Land[j, i] and lfLandMask and (not lfIce) = 0 then
122 inc(r)
123 end;
124
125 getPixelWeight:= r
126 end;
127
128
129 procedure fillPixelFromIceSprite(pixelX, pixelY:Longint); inline;
130 var
131 iceSurface: PSDL_Surface;
132 icePixels: PLongwordArray;
133 w: LongWord;
134 begin
135 if cOnlyStats then exit;
136 // So. 3 parameters here. Ice colour, Ice opacity, and a bias on the greyscaled pixel towards lightness
137 iceSurface:= SpritesData[sprIceTexture].Surface;
138 icePixels := iceSurface^.pixels;
139 w:= LandPixels[pixelY, pixelX];
140 if w > 0 then
141 begin
142 w:= round(((w shr RShift and $FF) * RGB_LUMINANCE_RED +
143 (w shr BShift and $FF) * RGB_LUMINANCE_GREEN +
144 (w shr GShift and $FF) * RGB_LUMINANCE_BLUE));
145 if w < 128 then w:= w+128;
146 if w > 255 then w:= 255;
147 w:= (w shl RShift) or (w shl BShift) or (w shl GShift) or (LandPixels[pixelY, pixelX] and AMask);
148 LandPixels[pixelY, pixelX]:= addBgColor(w, IceColor);
149 LandPixels[pixelY, pixelX]:= addBgColor(LandPixels[pixelY, pixelX], icePixels^[iceSurface^.w * (pixelY mod iceSurface^.h) + (pixelX mod iceSurface^.w)])
150 end
151 else
152 begin
153 LandPixels[pixelY, pixelX]:= IceColor and (not AMask) or $E8 shl AShift;
154 LandPixels[pixelY, pixelX]:= addBgColor(LandPixels[pixelY, pixelX], icePixels^[iceSurface^.w * (pixelY mod iceSurface^.h) + (pixelX mod iceSurface^.w)]);
155 // silly workaround to avoid having to make background erasure a tadb it smarter about sea ice
156 if LandPixels[pixelY, pixelX] and AMask shr AShift = 255 then
157 LandPixels[pixelY, pixelX]:= LandPixels[pixelY, pixelX] and (not AMask) or 254 shl AShift;
158 end;
159 end;
160
161
162 procedure DrawPixelIce(landX, landY, pixelX, pixelY: Longint); inline;
163 begin
164 if ((Land[landY, landX] and lfIce) <> 0) then exit;
165 if (pixelX < LeftX) or (pixelX > RightX) or (pixelY < TopY) then exit;
166 if isLandscapeEdge(getPixelWeight(landX, landY)) then
167 begin
168 if (LandPixels[pixelY, pixelX] and AMask < 255) and (LandPixels[pixelY, pixelX] and AMask > 0) then
169 LandPixels[pixelY, pixelX] := (IceEdgeColor and (not AMask)) or (LandPixels[pixelY, pixelX] and AMask)
170 else if (LandPixels[pixelY, pixelX] and AMask < 255) or (Land[landY, landX] > 255) then
171 LandPixels[pixelY, pixelX] := IceEdgeColor
172 end
173 else if Land[landY, landX] > 255 then
174 begin
175 fillPixelFromIceSprite(pixelX, pixelY);
176 end;
177 if Land[landY, landX] > 255 then Land[landY, landX] := Land[landY, landX] or lfIce and (not lfDamaged);
178 end;
179
180
FillLandCircleLineFTnull181 function FillLandCircleLineFT(y, fromPix, toPix: LongInt; fill : fillType): Longword;
182 var px, py, i: LongInt;
183 begin
184 //get rid of compiler warning
185 px := 0;
186 py := 0;
187 FillLandCircleLineFT := 0;
188 case fill of
189 backgroundPixel:
190 for i:= fromPix to toPix do
191 begin
192 calculatePixelsCoordinates(i, y, px, py);
193 inc(FillLandCircleLineFT, drawPixelBG(i, y, px, py));
194 end;
195 ebcPixel:
196 for i:= fromPix to toPix do
197 begin
198 calculatePixelsCoordinates(i, y, px, py);
199 drawPixelEBC(i, y, px, py);
200 end;
201 nullPixel:
202 for i:= fromPix to toPix do
203 begin
204 calculatePixelsCoordinates(i, y, px, py);
205 if ((Land[y, i] and lfIndestructible) = 0) and (not disableLandBack or (Land[y, i] > 255)) then
206 LandPixels[py, px]:= ExplosionBorderColorNoA;
207 end;
208 icePixel:
209 for i:= fromPix to toPix do
210 begin
211 calculatePixelsCoordinates(i, y, px, py);
212 DrawPixelIce(i, y, px, py);
213 end;
214 addNotHHObj:
215 for i:= fromPix to toPix do
216 begin
217 if Land[y, i] and lfNotHHObjMask shr lfNotHHObjShift < lfNotHHObjSize then
218 Land[y, i]:= (Land[y, i] and (not lfNotHHObjMask)) or ((Land[y, i] and lfNotHHObjMask shr lfNotHHObjShift + 1) shl lfNotHHObjShift);
219 end;
220 removeNotHHObj:
221 for i:= fromPix to toPix do
222 begin
223 if Land[y, i] and lfNotHHObjMask <> 0 then
224 Land[y, i]:= (Land[y, i] and (not lfNotHHObjMask)) or ((Land[y, i] and lfNotHHObjMask shr lfNotHHObjShift - 1) shl lfNotHHObjShift);
225 end;
226 addHH:
227 for i:= fromPix to toPix do
228 begin
229 if Land[y, i] and lfHHMask < lfHHMask then
230 Land[y, i]:= Land[y, i] + 1
231 end;
232 removeHH:
233 for i:= fromPix to toPix do
234 begin
235 if Land[y, i] and lfHHMask > 0 then
236 Land[y, i]:= Land[y, i] - 1;
237 end;
238 setCurrentHog:
239 for i:= fromPix to toPix do
240 begin
241 Land[y, i]:= Land[y, i] or lfCurHogCrate
242 end;
243 removeCurrentHog:
244 for i:= fromPix to toPix do
245 begin
246 Land[y, i]:= Land[y, i] and lfNotCurHogCrate;
247 end;
248 end;
249 end;
250
FillLandCircleSegmentFTnull251 function FillLandCircleSegmentFT(x, y, dx, dy: LongInt; fill : fillType): Longword; inline;
252 begin
253 FillLandCircleSegmentFT := 0;
254 if ((y + dy) and LAND_HEIGHT_MASK) = 0 then
255 inc(FillLandCircleSegmentFT, FillLandCircleLineFT(y + dy, Max(x - dx, 0), Min(x + dx, LAND_WIDTH - 1), fill));
256 if ((y - dy) and LAND_HEIGHT_MASK) = 0 then
257 inc(FillLandCircleSegmentFT, FillLandCircleLineFT(y - dy, Max(x - dx, 0), Min(x + dx, LAND_WIDTH - 1), fill));
258 if ((y + dx) and LAND_HEIGHT_MASK) = 0 then
259 inc(FillLandCircleSegmentFT, FillLandCircleLineFT(y + dx, Max(x - dy, 0), Min(x + dy, LAND_WIDTH - 1), fill));
260 if ((y - dx) and LAND_HEIGHT_MASK) = 0 then
261 inc(FillLandCircleSegmentFT, FillLandCircleLineFT(y - dx, Max(x - dy, 0), Min(x + dy, LAND_WIDTH - 1), fill));
262 end;
263
FillRoundInLandFTnull264 function FillRoundInLandFT(X, Y, Radius: LongInt; fill: fillType): Longword; inline;
265 var dx, dy, d: LongInt;
266 begin
267 dx:= 0;
268 dy:= Radius;
269 d:= 3 - 2 * Radius;
270 FillRoundInLandFT := 0;
271 while (dx < dy) do
272 begin
273 inc(FillRoundInLandFT, FillLandCircleSegmentFT(x, y, dx, dy, fill));
274 if (d < 0) then
275 d:= d + 4 * dx + 6
276 else
277 begin
278 d:= d + 4 * (dx - dy) + 10;
279 dec(dy)
280 end;
281 inc(dx)
282 end;
283 if (dx = dy) then
284 inc (FillRoundInLandFT, FillLandCircleSegmentFT(x, y, dx, dy, fill));
285 end;
286
287
addBgColornull288 function addBgColor(OldColor, NewColor: LongWord): LongWord;
289 // Factor ranges from 0 to 100% NewColor
290 var
291 oRed, oBlue, oGreen, oAlpha, nRed, nBlue, nGreen, nAlpha: byte;
292 begin
293 oAlpha := (OldColor shr AShift);
294 nAlpha := (NewColor shr AShift);
295 // shortcircuit
296 if (oAlpha = 0) or (nAlpha = $FF) then
297 begin
298 addBgColor:= NewColor;
299 exit
300 end;
301 // Get colors
302 oRed := (OldColor shr RShift);
303 oGreen := (OldColor shr GShift);
304 oBlue := (OldColor shr BShift);
305
306 nRed := (NewColor shr RShift);
307 nGreen := (NewColor shr GShift);
308 nBlue := (NewColor shr BShift);
309
310 // Mix colors
311 nRed := min(255,((nRed*nAlpha) div 255) + ((oRed*oAlpha*byte(255-nAlpha)) div 65025));
312 nGreen := min(255,((nGreen*nAlpha) div 255) + ((oGreen*oAlpha*byte(255-nAlpha)) div 65025));
313 nBlue := min(255,((nBlue*nAlpha) div 255) + ((oBlue*oAlpha*byte(255-nAlpha)) div 65025));
314 nAlpha := min(255, oAlpha + nAlpha);
315
316 addBgColor := (nAlpha shl AShift) or (nRed shl RShift) or (nGreen shl GShift) or (nBlue shl BShift);
317 end;
318
FillCircleLinesnull319 function FillCircleLines(x, y, dx, dy: LongInt; Value: Longword): Longword;
320 var i: LongInt;
321 begin
322 FillCircleLines:= 0;
323
324 if ((y + dy) and LAND_HEIGHT_MASK) = 0 then
325 for i:= Max(x - dx, 0) to Min(x + dx, LAND_WIDTH - 1) do
326 if (Land[y + dy, i] and lfIndestructible) = 0 then
327 begin
328 if Land[y + dy, i] <> Value then inc(FillCircleLines);
329 Land[y + dy, i]:= Value;
330 end;
331 if ((y - dy) and LAND_HEIGHT_MASK) = 0 then
332 for i:= Max(x - dx, 0) to Min(x + dx, LAND_WIDTH - 1) do
333 if (Land[y - dy, i] and lfIndestructible) = 0 then
334 begin
335 if Land[y - dy, i] <> Value then inc(FillCircleLines);
336 Land[y - dy, i]:= Value;
337 end;
338 if ((y + dx) and LAND_HEIGHT_MASK) = 0 then
339 for i:= Max(x - dy, 0) to Min(x + dy, LAND_WIDTH - 1) do
340 if (Land[y + dx, i] and lfIndestructible) = 0 then
341 begin
342 if Land[y + dx, i] <> Value then inc(FillCircleLines);
343 Land[y + dx, i]:= Value;
344 end;
345 if ((y - dx) and LAND_HEIGHT_MASK) = 0 then
346 for i:= Max(x - dy, 0) to Min(x + dy, LAND_WIDTH - 1) do
347 if (Land[y - dx, i] and lfIndestructible) = 0 then
348 begin
349 if Land[y - dx, i] <> Value then inc(FillCircleLines);
350 Land[y - dx, i]:= Value;
351 end;
352 end;
353
FillRoundInLandnull354 function FillRoundInLand(X, Y, Radius: LongInt; Value: Longword): Longword;
355 var dx, dy, d: LongInt;
356 begin
357 FillRoundInLand:= 0;
358 dx:= 0;
359 dy:= Radius;
360 d:= 3 - 2 * Radius;
361 while (dx < dy) do
362 begin
363 inc(FillRoundInLand, FillCircleLines(x, y, dx, dy, Value));
364 if (d < 0) then
365 d:= d + 4 * dx + 6
366 else
367 begin
368 d:= d + 4 * (dx - dy) + 10;
369 dec(dy)
370 end;
371 inc(dx)
372 end;
373 if (dx = dy) then
374 inc(FillRoundInLand, FillCircleLines(x, y, dx, dy, Value));
375 end;
376
377 procedure ChangeRoundInLand(X, Y, Radius: LongInt; doSet, isCurrent, isHH: boolean);
378 begin
379 if not doSet and isCurrent then
380 FillRoundInLandFT(X, Y, Radius, removeCurrentHog)
381 else if (not doSet) and (not IsCurrent) and isHH then
382 FillRoundInLandFT(X, Y, Radius, removeHH)
383 else if (not doSet) and (not IsCurrent) and (not isHH) then
384 FillRoundInLandFT(X, Y, Radius, removeNotHHObj)
385 else if doSet and IsCurrent then
386 FillRoundInLandFT(X, Y, Radius, setCurrentHog)
387 else if doSet and (not IsCurrent) and isHH then
388 FillRoundInLandFT(X, Y, Radius, addHH)
389 else if doSet and (not IsCurrent) and (not isHH) then
390 FillRoundInLandFT(X, Y, Radius, addNotHHObj);
391 end;
392
393 procedure DrawIceBreak(x, y, iceRadius, iceHeight: Longint);
394 var
395 i, j, iceL, iceR, IceT, iceB: LongInt;
396 landRect: TSDL_Rect;
397 begin
398 // figure out bottom/left/right/top coords of ice to draw
399
400 // determine absolute limits first
401 iceT:= 0;
402 iceB:= min(cWaterLine, LAND_HEIGHT - 1);
403
404 iceL:= 0;
405 iceR:= LAND_WIDTH - 1;
406
407 if WorldEdge <> weNone then
408 begin
409 iceL:= max(leftX, iceL);
410 iceR:= min(rightX, iceR);
411 end;
412
413 // adjust based on location but without violating absolute limits
414 if y >= cWaterLine then
415 begin
416 iceL:= max(x - iceRadius, iceL);
417 iceR:= min(x + iceRadius, iceR);
418 iceT:= max(cWaterLine - iceHeight, iceT);
419 end
420 else {if WorldEdge = weSea then}
421 begin
422 iceT:= max(y - iceRadius, iceT);
423 iceB:= min(y + iceRadius, iceB);
424 if x <= leftX then
425 iceR:= min(leftX + iceHeight, iceR)
426 else {if x >= rightX then}
427 iceL:= max(rightX - iceHeight, iceL);
428 end;
429
430 // don't continue if all ice is outside land array
431 if (iceL > iceR) or (iceT > iceB) then
432 exit();
433
434 for i := iceL to iceR do
435 begin
436 for j := iceT to iceB do
437 begin
438 if Land[j, i] = 0 then
439 begin
440 Land[j, i] := lfIce;
441 if (cReducedQuality and rqBlurryLand) = 0 then
442 fillPixelFromIceSprite(i, j)
443 else
444 fillPixelFromIceSprite(i div 2, j div 2);
445 end;
446 end;
447 end;
448
449 landRect.x := iceL;
450 landRect.y := iceT;
451 landRect.w := iceR - IceL + 1;
452 landRect.h := iceB - iceT + 1;
453
454 UpdateLandTexture(landRect.x, landRect.w, landRect.y, landRect.h, true);
455 end;
456
457 function DrawExplosion(X, Y, Radius: LongInt): Longword;
458 var
459 tx, ty, dx, dy: Longint;
460 begin
461 DrawExplosion := FillRoundInLandFT(x, y, Radius, backgroundPixel);
462 if Radius > 20 then
463 FillRoundInLandFT(x, y, Radius - 15, nullPixel);
464 FillRoundInLand(X, Y, Radius, 0);
465 FillRoundInLandFT(x, y, Radius + 4, ebcPixel);
466 tx:= Max(X - Radius - 5, 0);
467 dx:= Min(X + Radius + 5, LAND_WIDTH) - tx;
468 ty:= Max(Y - Radius - 5, 0);
469 dy:= Min(Y + Radius + 5, LAND_HEIGHT) - ty;
470 UpdateLandTexture(tx, dx, ty, dy, false);
471 end;
472
473 procedure DrawHLinesExplosions(ar: PRangeArray; Radius: LongInt; y, dY: LongInt; Count: Byte);
474 var tx, ty, by, bx, i: LongInt;
475 begin
476 for i:= 0 to Pred(Count) do
477 begin
478 for ty:= Max(y - Radius, 0) to Min(y + Radius, TopY) do
479 for tx:= Max(LeftX, ar^[i].Left - Radius) to Min(RightX, ar^[i].Right + Radius) do
480 begin
481 if (Land[ty, tx] and lfIndestructible) = 0 then
482 begin
483 if (cReducedQuality and rqBlurryLand) = 0 then
484 begin
485 by:= ty; bx:= tx;
486 end
487 else
488 begin
489 by:= ty div 2; bx:= tx div 2;
490 end;
491 if ((Land[ty, tx] and lfBasic) <> 0) and (((LandPixels[by,bx] and AMask) shr AShift) = 255) and (not disableLandBack) then
492 LandPixels[by, bx]:= LandBackPixel(tx, ty)
493 else if ((Land[ty, tx] and lfObject) <> 0) or (((LandPixels[by,bx] and AMask) shr AShift) < 255) then
494 LandPixels[by, bx]:= LandPixels[by, bx] and (not AMASK)
495 end
496 end;
497 inc(y, dY)
498 end;
499
500 inc(Radius, 4);
501 dec(y, Count * dY);
502
503 for i:= 0 to Pred(Count) do
504 begin
505 for ty:= Max(y - Radius, 0) to Min(y + Radius, TopY) do
506 for tx:= Max(LeftX, ar^[i].Left - Radius) to Min(RightX, ar^[i].Right + Radius) do
507 if ((Land[ty, tx] and lfBasic) <> 0) or ((Land[ty, tx] and lfObject) <> 0) then
508 begin
509 if (cReducedQuality and rqBlurryLand) = 0 then
510 LandPixels[ty, tx]:= ExplosionBorderColor
511 else
512 LandPixels[ty div 2, tx div 2]:= ExplosionBorderColor;
513
514 Land[ty, tx]:= (Land[ty, tx] or lfDamaged) and (not lfIce);
515 LandDirty[ty div 32, tx div 32]:= 1;
516 end;
517 inc(y, dY)
518 end;
519
520
521 UpdateLandTexture(0, LAND_WIDTH, 0, LAND_HEIGHT, false)
522 end;
523
524
525
526 procedure DrawExplosionBorder(X, Y, dx, dy:hwFloat; despeckle : Boolean);
527 var
528 t, tx, ty :Longint;
529 begin
530 for t:= 0 to 7 do
531 begin
532 X:= X + dX;
533 Y:= Y + dY;
534 tx:= hwRound(X);
535 ty:= hwRound(Y);
536 if ((ty and LAND_HEIGHT_MASK) = 0) and ((tx and LAND_WIDTH_MASK) = 0) and (((Land[ty, tx] and lfBasic) <> 0)
537 or ((Land[ty, tx] and lfObject) <> 0)) then
538 begin
539 Land[ty, tx]:= (Land[ty, tx] or lfDamaged) and (not lfIce);
540 if despeckle then
541 LandDirty[ty div 32, tx div 32]:= 1;
542 if (cReducedQuality and rqBlurryLand) = 0 then
543 LandPixels[ty, tx]:= ExplosionBorderColor
544 else
545 LandPixels[ty div 2, tx div 2]:= ExplosionBorderColor
546 end
547 end;
548 end;
549
550 type TWrapNeeded = (wnNone, wnLeft, wnRight);
551
552 //
553 // - (dX, dY) - direction, vector of length = 0.5
554 //
555 function DrawTunnel_real(X, Y, dX, dY: hwFloat; ticks, HalfWidth: LongInt): TWrapNeeded;
556 var nx, ny, dX8, dY8: hwFloat;
557 i, t, tx, ty, by, bx, stX, stY, ddy, ddx: Longint;
558 despeckle : Boolean;
559 begin // (-dY, dX) is (dX, dY) rotated by PI/2
560 DrawTunnel_real:= wnNone;
561
562 stY:= hwRound(Y);
563 stX:= hwRound(X);
564
565 despeckle:= HalfWidth > 1;
566
567 nx:= X + dY * (HalfWidth + 8);
568 ny:= Y - dX * (HalfWidth + 8);
569
570 dX8:= dX * 8;
571 dY8:= dY * 8;
572 for i:= 0 to 7 do
573 begin
574 X:= nx - dX8;
575 Y:= ny - dY8;
576 for t:= -8 to ticks + 8 do
577 begin
578 X:= X + dX;
579 Y:= Y + dY;
580 tx:= hwRound(X);
581 ty:= hwRound(Y);
582 if ((ty and LAND_HEIGHT_MASK) = 0)
583 and ((tx and LAND_WIDTH_MASK) = 0)
584 and (((Land[ty, tx] and lfBasic) <> 0) or ((Land[ty, tx] and lfObject) <> 0)) then
585 begin
586 Land[ty, tx]:= Land[ty, tx] and (not lfIce);
587 if despeckle then
588 begin
589 Land[ty, tx]:= Land[ty, tx] or lfDamaged;
590 LandDirty[ty div 32, tx div 32]:= 1
591 end;
592 if (cReducedQuality and rqBlurryLand) = 0 then
593 LandPixels[ty, tx]:= ExplosionBorderColor
594 else
595 LandPixels[ty div 2, tx div 2]:= ExplosionBorderColor
596 end
597 end;
598 nx:= nx - dY;
599 ny:= ny + dX;
600 end;
601
602 for i:= -HalfWidth to HalfWidth do
603 begin
604 X:= nx - dX8;
605 Y:= ny - dY8;
606 DrawExplosionBorder(X, Y, dx, dy, despeckle);
607 X:= nx;
608 Y:= ny;
609 for t:= 0 to ticks do
610 begin
611 X:= X + dX;
612 Y:= Y + dY;
613 tx:= hwRound(X);
614 ty:= hwRound(Y);
615 if ((ty and LAND_HEIGHT_MASK) = 0) and ((tx and LAND_WIDTH_MASK) = 0) and ((Land[ty, tx] and lfIndestructible) = 0) then
616 begin
617 if (cReducedQuality and rqBlurryLand) = 0 then
618 begin
619 by:= ty; bx:= tx;
620 end
621 else
622 begin
623 by:= ty div 2; bx:= tx div 2;
624 end;
625 if ((Land[ty, tx] and lfBasic) <> 0) and (((LandPixels[by,bx] and AMask) shr AShift) = 255) and (not disableLandBack) then
626 LandPixels[by, bx]:= LandBackPixel(tx, ty)
627 else if ((Land[ty, tx] and lfObject) <> 0) or (((LandPixels[by,bx] and AMask) shr AShift) < 255) then
628 LandPixels[by, bx]:= LandPixels[by, bx] and (not AMASK);
629 Land[ty, tx]:= 0;
630 end
631 end;
632 DrawExplosionBorder(X, Y, dx, dy, despeckle);
633 nx:= nx - dY;
634 ny:= ny + dX;
635 end;
636
637 for i:= 0 to 7 do
638 begin
639 X:= nx - dX8;
640 Y:= ny - dY8;
641 for t:= -8 to ticks + 8 do
642 begin
643 X:= X + dX;
644 Y:= Y + dY;
645 tx:= hwRound(X);
646 ty:= hwRound(Y);
647 if ((ty and LAND_HEIGHT_MASK) = 0) and ((tx and LAND_WIDTH_MASK) = 0) and (((Land[ty, tx] and lfBasic) <> 0)
648 or ((Land[ty, tx] and lfObject) <> 0)) then
649 begin
650 Land[ty, tx]:= (Land[ty, tx] or lfDamaged) and (not lfIce);
651 if despeckle then
652 LandDirty[ty div 32, tx div 32]:= 1;
653 if (cReducedQuality and rqBlurryLand) = 0 then
654 LandPixels[ty, tx]:= ExplosionBorderColor
655 else
656 LandPixels[ty div 2, tx div 2]:= ExplosionBorderColor
657 end
658 end;
659 nx:= nx - dY;
660 ny:= ny + dX;
661 end;
662
663 tx:= stX - HalfWidth * 2 - 4 - abs(hwRound(dX * ticks));
664 ddx:= stX + HalfWidth * 2 + 4 + abs(hwRound(dX * ticks));
665
666 if WorldEdge = weWrap then
667 begin
668 if (tx < leftX) or (ddx < leftX) then
669 DrawTunnel_real:= wnLeft
670 else if (tx > rightX) or (ddx > rightX) then
671 DrawTunnel_real:= wnRight;
672 end;
673
674 tx:= Max(tx, 0);
675 ty:= Max(stY - HalfWidth * 2 - 4 - abs(hwRound(dY * ticks)), 0);
676 ddx:= Min(ddx, LAND_WIDTH) - tx;
677 ddy:= Min(stY + HalfWidth * 2 + 4 + abs(hwRound(dY * ticks)), LAND_HEIGHT) - ty;
678
679 UpdateLandTexture(tx, ddx, ty, ddy, false)
680 end;
681
682 procedure DrawTunnel(X, Y, dX, dY: hwFloat; ticks, HalfWidth: LongInt);
683 var wn: TWrapNeeded;
684 begin
685 wn:= DrawTunnel_real(X, Y, dX, dY, ticks, HalfWidth);
686 if wn <> wnNone then
687 begin
688 if wn = wnLeft then
689 DrawTunnel_real(X + int2hwFloat(playWidth), Y, dX, dY, ticks, HalfWidth)
690 else
691 DrawTunnel_real(X - int2hwFloat(playWidth), Y, dX, dY, ticks, HalfWidth);
692 end;
693 end;
694
695 function TryPlaceOnLandSimple(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; doPlace, indestructible: boolean): boolean; inline;
696 var lf: Word;
697 begin
698 if indestructible then
699 lf:= lfIndestructible
700 else
701 lf:= 0;
702 TryPlaceOnLandSimple:= TryPlaceOnLand(cpX, cpY, Obj, Frame, doPlace, false, false, false, false, false, lf, $FFFFFFFF);
703 end;
704
705 function TryPlaceOnLand(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; doPlace: boolean; LandFlags: Word): boolean; inline;
706 begin
707 TryPlaceOnLand:= TryPlaceOnLand(cpX, cpY, Obj, Frame, doPlace, false, false, false, false, false, LandFlags, $FFFFFFFF);
708 end;
709
710 function ForcePlaceOnLand(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; LandFlags: Word; Tint: LongWord; Behind, flipHoriz, flipVert: boolean): boolean; inline;
711 begin
712 ForcePlaceOnLand:= TryPlaceOnLand(cpX, cpY, Obj, Frame, true, false, true, behind, flipHoriz, flipVert, LandFlags, Tint)
713 end;
714 function TryPlaceOnLand(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; doPlace, outOfMap, force, behind, flipHoriz, flipVert: boolean; LandFlags: Word; Tint: LongWord): boolean;
715 var X, Y, bpp, h, w, row, col, gx, gy, numFramesFirstCol: LongInt;
716 p: PByteArray;
717 Image: PSDL_Surface;
718 pixel: LongWord;
719 begin
720 TryPlaceOnLand:= false;
721 numFramesFirstCol:= SpritesData[Obj].imageHeight div SpritesData[Obj].Height;
722
723 if outOfMap then doPlace:= false; // just using for a check
724
725 if checkFails(SpritesData[Obj].Surface <> nil, 'Assert SpritesData[Obj].Surface failed', true) then exit;
726
727 Image:= SpritesData[Obj].Surface;
728 w:= SpritesData[Obj].Width;
729 h:= SpritesData[Obj].Height;
730 if flipVert then flipSurface(Image, true);
731 if flipHoriz then flipSurface(Image, false);
732 row:= Frame mod numFramesFirstCol;
733 col:= Frame div numFramesFirstCol;
734
735 if SDL_MustLock(Image) then
736 if SDLCheck(SDL_LockSurface(Image) >= 0, 'TryPlaceOnLand', true) then exit;
737
738 bpp:= Image^.format^.BytesPerPixel;
739 if checkFails(bpp = 4, 'It should be 32 bpp sprite', true) then
740 begin
741 if SDL_MustLock(Image) then
742 SDL_UnlockSurface(Image);
743 exit
744 end;
745 // Check that sprite fits free space
746 p:= PByteArray(@(PByteArray(Image^.pixels)^[ Image^.pitch * row * h + col * w * 4 ]));
747 case bpp of
748 4: for y:= 0 to Pred(h) do
749 begin
750 for x:= 0 to Pred(w) do
751 if ((PLongword(@(p^[x * 4]))^) and AMask) <> 0 then
752 if (outOfMap and
753 ((cpY + y) < LAND_HEIGHT) and ((cpY + y) >= 0) and
754 ((cpX + x) < LAND_WIDTH) and ((cpX + x) >= 0) and
755 ((not force) and (Land[cpY + y, cpX + x] <> 0))) or
756
757 (not outOfMap and
758 (((cpY + y) <= topY) or ((cpY + y) >= LAND_HEIGHT) or
759 ((cpX + x) <= leftX) or ((cpX + x) >= rightX) or
760 ((not force) and (Land[cpY + y, cpX + x] <> 0)))) then
761 begin
762 if SDL_MustLock(Image) then
763 SDL_UnlockSurface(Image);
764 exit
765 end;
766 p:= PByteArray(@(p^[Image^.pitch]))
767 end
768 end;
769
770 TryPlaceOnLand:= true;
771 if not doPlace then
772 begin
773 if SDL_MustLock(Image) then
774 SDL_UnlockSurface(Image);
775 exit
776 end;
777
778 // Checked, now place
779 p:= PByteArray(@(PByteArray(Image^.pixels)^[ Image^.pitch * row * h + col * w * 4 ]));
780 case bpp of
781 4: for y:= 0 to Pred(h) do
782 begin
783 for x:= 0 to Pred(w) do
784 if ((PLongword(@(p^[x * 4]))^) and AMask) <> 0 then
785 begin
786 if (cReducedQuality and rqBlurryLand) = 0 then
787 begin
788 gX:= cpX + x;
789 gY:= cpY + y;
790 end
791 else
792 begin
793 gX:= (cpX + x) div 2;
794 gY:= (cpY + y) div 2;
795 end;
796 if (not behind) or (Land[cpY + y, cpX + x] and lfLandMask = 0) then
797 begin
798 if (LandFlags and lfBasic <> 0) or
799 ((LandPixels[gY, gX] and AMask shr AShift > 128) and // This test assumes lfBasic and lfObject differ only graphically
800 (LandFlags and (lfObject or lfIce) = 0)) then
801 Land[cpY + y, cpX + x]:= lfBasic or LandFlags
802 else if (LandFlags and lfIce = 0) then
803 Land[cpY + y, cpX + x]:= lfObject or LandFlags
804 else Land[cpY + y, cpX + x]:= LandFlags
805 end;
806 if (not behind) or (LandPixels[gY, gX] = 0) then
807 begin
808 if tint = $FFFFFFFF then
809 LandPixels[gY, gX]:= PLongword(@(p^[x * 4]))^
810 else
811 begin
812 pixel:= PLongword(@(p^[x * 4]))^;
813 LandPixels[gY, gX]:=
814 ceil((pixel shr RShift and $FF) * ((tint shr 24) / 255)) shl RShift or
815 ceil((pixel shr GShift and $FF) * ((tint shr 16 and $ff) / 255)) shl GShift or
816 ceil((pixel shr BShift and $FF) * ((tint shr 8 and $ff) / 255)) shl BShift or
817 ceil((pixel shr AShift and $FF) * ((tint and $ff) / 255)) shl AShift;
818 end
819 end
820 end;
821 p:= PByteArray(@(p^[Image^.pitch]));
822 end;
823 end;
824 if SDL_MustLock(Image) then
825 SDL_UnlockSurface(Image);
826
827 if flipVert then flipSurface(Image, true);
828 if flipHoriz then flipSurface(Image, false);
829
830 x:= Max(cpX, leftX);
831 w:= Min(cpX + Image^.w, LAND_WIDTH) - x;
832 y:= Max(cpY, topY);
833 h:= Min(cpY + Image^.h, LAND_HEIGHT) - y;
834 UpdateLandTexture(x, w, y, h, true);
835
836 ScriptCall('onSpritePlacement', ord(Obj), cpX + w div 2, cpY + h div 2);
837 if Obj = sprAmGirder then
838 ScriptCall('onGirderPlacement', frame, cpX + w div 2, cpY + h div 2)
839 else if Obj = sprAmRubber then
840 ScriptCall('onRubberPlacement', frame, cpX + w div 2, cpY + h div 2);
841
842 end;
843
844 procedure EraseLandRectRaw(X, Y, width, height: LongWord);
845 var tx, ty: LongWord;
846 begin
847 for ty:= 0 to height - 1 do
848 for tx:= 0 to width - 1 do
849 begin
850 LandPixels[ty, tx]:= 0;
851 Land[Y + ty, X + tx]:= 0;
852 end;
853 end;
854
855 procedure EraseLand(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; LandFlags: Word; eraseOnLFMatch, onlyEraseLF, flipHoriz, flipVert: boolean);
856 var X, Y, bpp, h, w, row, col, gx, gy, numFramesFirstCol: LongInt;
857 p: PByteArray;
858 Image: PSDL_Surface;
859 begin
860 numFramesFirstCol:= SpritesData[Obj].imageHeight div SpritesData[Obj].Height;
861
862 if checkFails(SpritesData[Obj].Surface <> nil, 'Assert SpritesData[Obj].Surface failed', true) then exit;
863
864 Image:= SpritesData[Obj].Surface;
865 w:= SpritesData[Obj].Width;
866 h:= SpritesData[Obj].Height;
867 if flipVert then flipSurface(Image, true);
868 if flipHoriz then flipSurface(Image, false);
869 row:= Frame mod numFramesFirstCol;
870 col:= Frame div numFramesFirstCol;
871
872 if SDL_MustLock(Image) then
873 if SDLCheck(SDL_LockSurface(Image) >= 0, 'EraseLand', true) then exit;
874
875 bpp:= Image^.format^.BytesPerPixel;
876 if checkFails(bpp = 4, 'It should be 32 bpp sprite', true) then
877 begin
878 if SDL_MustLock(Image) then
879 SDL_UnlockSurface(Image);
880 exit
881 end;
882 // Check that sprite fits free space
883 p:= PByteArray(@(PByteArray(Image^.pixels)^[ Image^.pitch * row * h + col * w * 4 ]));
884
885 for y:= 0 to Pred(h) do
886 begin
887 for x:= 0 to Pred(w) do
888 if ((PLongword(@(p^[x * 4]))^) and AMask) <> 0 then
889 if ((cpY + y) <= topY) or ((cpY + y) >= LAND_HEIGHT) or
890 ((cpX + x) <= leftX) or ((cpX + x) >= rightX) then
891 begin
892 if SDL_MustLock(Image) then
893 SDL_UnlockSurface(Image);
894 exit
895 end;
896 p:= PByteArray(@(p^[Image^.pitch]))
897 end;
898
899 // Checked, now place
900 p:= PByteArray(@(PByteArray(Image^.pixels)^[ Image^.pitch * row * h + col * w * 4 ]));
901 for y:= 0 to Pred(h) do
902 begin
903 for x:= 0 to Pred(w) do
904 if ((PLongword(@(p^[x * 4]))^) and AMask) <> 0 then
905 begin
906 if (cReducedQuality and rqBlurryLand) = 0 then
907 begin
908 gX:= cpX + x;
909 gY:= cpY + y;
910 end
911 else
912 begin
913 gX:= (cpX + x) div 2;
914 gY:= (cpY + y) div 2;
915 end;
916 if (not eraseOnLFMatch or (Land[cpY + y, cpX + x] and LandFlags <> 0)) and
917 ((PLongword(@(p^[x * 4]))^) and AMask <> 0) then
918 begin
919 if not onlyEraseLF then
920 begin
921 LandPixels[gY, gX]:= 0;
922 Land[cpY + y, cpX + x]:= 0
923 end
924 else Land[cpY + y, cpX + x]:= Land[cpY + y, cpX + x] and (not LandFlags)
925 end
926 end;
927 p:= PByteArray(@(p^[Image^.pitch]));
928 end;
929 if SDL_MustLock(Image) then
930 SDL_UnlockSurface(Image);
931
932 if flipVert then flipSurface(Image, true);
933 if flipHoriz then flipSurface(Image, false);
934
935 x:= Max(cpX, leftX);
936 w:= Min(cpX + Image^.w, LAND_WIDTH) - x;
937 y:= Max(cpY, topY);
938 h:= Min(cpY + Image^.h, LAND_HEIGHT) - y;
939 UpdateLandTexture(x, w, y, h, true)
940 end;
941
942 function GetPlaceCollisionTex(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt): PTexture;
943 var X, Y, bpp, h, w, row, col, numFramesFirstCol: LongInt;
944 p, pt: PLongWordArray;
945 Image, finalSurface: PSDL_Surface;
946 begin
947 GetPlaceCollisionTex:= nil;
948 numFramesFirstCol:= SpritesData[Obj].imageHeight div SpritesData[Obj].Height;
949
950 checkFails(SpritesData[Obj].Surface <> nil, 'Assert SpritesData[Obj].Surface failed', true);
951 Image:= SpritesData[Obj].Surface;
952 w:= SpritesData[Obj].Width;
953 h:= SpritesData[Obj].Height;
954 row:= Frame mod numFramesFirstCol;
955 col:= Frame div numFramesFirstCol;
956
957 if SDL_MustLock(Image) then
958 if SDLCheck(SDL_LockSurface(Image) >= 0, 'SDL_LockSurface', true) then
959 exit;
960
961 bpp:= Image^.format^.BytesPerPixel;
962 checkFails(bpp = 4, 'It should be 32 bpp sprite', true);
963
964
965
966 finalSurface:= SDL_CreateRGBSurface(SDL_SWSURFACE, w, h, 32, RMask, GMask, BMask, AMask);
967
968 checkFails(finalSurface <> nil, 'GetPlaceCollisionTex: fail to create surface', true);
969
970 if SDL_MustLock(finalSurface) then
971 SDLCheck(SDL_LockSurface(finalSurface) >= 0, 'GetPlaceCollisionTex', true);
972
973 if not allOK then
974 begin
975 if SDL_MustLock(Image) then
976 SDL_UnlockSurface(Image);
977
978 if SDL_MustLock(finalSurface) then
979 SDL_UnlockSurface(finalSurface);
980
981 if finalSurface <> nil then
982 SDL_FreeSurface(finalSurface);
983 end;
984
985 p:= PLongWordArray(@(PLongWordArray(Image^.pixels)^[ (Image^.pitch div 4) * row * h + col * w ]));
986 pt:= PLongWordArray(finalSurface^.pixels);
987
988 for y:= 0 to Pred(h) do
989 begin
990 for x:= 0 to Pred(w) do
991 if ((p^[x] and AMask) <> 0)
992 and (((cpY + y) < topY) or ((cpY + y) >= LAND_HEIGHT) or
993 ((cpX + x) < leftX) or ((cpX + x) > rightX) or (Land[cpY + y, cpX + x] <> 0)) then
994 pt^[x]:= cWhiteColor
995 else
996 (pt^[x]):= cWhiteColor and (not AMask);
997 p:= PLongWordArray(@(p^[Image^.pitch div 4]));
998 pt:= PLongWordArray(@(pt^[finalSurface^.pitch div 4]));
999 end;
1000
1001 if SDL_MustLock(Image) then
1002 SDL_UnlockSurface(Image);
1003
1004 if SDL_MustLock(finalSurface) then
1005 SDL_UnlockSurface(finalSurface);
1006
1007 GetPlaceCollisionTex:= Surface2Tex(finalSurface, true);
1008
1009 SDL_FreeSurface(finalSurface);
1010 end;
1011
1012
1013 function Despeckle(X, Y: LongInt): boolean;
1014 var nx, ny, i, j, c, xx, yy: LongInt;
1015 pixelsweep: boolean;
1016
1017 begin
1018 Despeckle:= true;
1019
1020 if (cReducedQuality and rqBlurryLand) = 0 then
1021 begin
1022 xx:= X;
1023 yy:= Y;
1024 end
1025 else
1026 begin
1027 xx:= X div 2;
1028 yy:= Y div 2;
1029 end;
1030
1031 pixelsweep:= (Land[Y, X] <= lfAllObjMask) and ((LandPixels[yy, xx] and AMask) <> 0);
1032 if (((Land[Y, X] and lfDamaged) <> 0) and ((Land[Y, X] and lfIndestructible) = 0)) or pixelsweep then
1033 begin
1034 c:= 0;
1035 for i:= -1 to 1 do
1036 for j:= -1 to 1 do
1037 if (i <> 0) or (j <> 0) then
1038 begin
1039 ny:= Y + i;
1040 nx:= X + j;
1041 if ((ny and LAND_HEIGHT_MASK) = 0) and ((nx and LAND_WIDTH_MASK) = 0) then
1042 begin
1043 if pixelsweep then
1044 begin
1045 if ((cReducedQuality and rqBlurryLand) <> 0) then
1046 begin
1047 ny:= Y div 2 + i;
1048 nx:= X div 2 + j;
1049 if ((ny and (LAND_HEIGHT_MASK div 2)) = 0) and ((nx and (LAND_WIDTH_MASK div 2)) = 0) then
1050 if (LandPixels[ny, nx] and AMASK) <> 0 then
1051 inc(c);
1052 end
1053 else if (LandPixels[ny, nx] and AMASK) <> 0 then
1054 inc(c);
1055 end
1056 else if Land[ny, nx] > 255 then
1057 inc(c);
1058 end
1059 end;
1060
1061 if c < 4 then // 0-3 neighbours
1062 begin
1063 if ((Land[Y, X] and lfBasic) <> 0) and (not disableLandBack) then
1064 LandPixels[yy, xx]:= LandBackPixel(X, Y)
1065 else
1066 LandPixels[yy, xx]:= LandPixels[yy, xx] and (not AMASK);
1067
1068 if not pixelsweep then
1069 begin
1070 Land[Y, X]:= 0;
1071 exit
1072 end
1073 end;
1074 end;
1075 Despeckle:= false
1076 end;
1077
1078 // a bit of AA for explosions
1079 procedure Smooth(X, Y: LongInt);
1080 var c, r, g, b, a, i: integer;
1081 nx, ny: LongInt;
1082 pixel: LongWord;
1083 begin
1084
1085 // only AA inwards
1086 if (Land[Y, X] and lfDamaged) = 0 then
1087 exit;
1088
1089 // check location
1090 if (Y <= topY + 1) or (Y >= LAND_HEIGHT-2)
1091 or (X <= leftX + 1) or (X >= rightX - 1) then
1092 exit;
1093
1094 // counter for neighbor pixels that are not known to be undamaged
1095 c:= 8;
1096
1097 // accumalating rgba value of relevant pixels here
1098 r:= 0;
1099 g:= 0;
1100 b:= 0;
1101 a:= 0;
1102
1103 // iterate over all neighbor pixels (also itself, will be skipped anyway)
1104 for nx:= X-1 to X+1 do
1105 for ny:= Y-1 to Y+1 do
1106 // only consider undamaged neighbors (also leads to skipping itself)
1107 if (Land[ny, nx] and lfDamaged) = 0 then
1108 begin
1109 pixel:= LandPixels[ny, nx];
1110 inc(r, (pixel and RMask) shr RShift);
1111 inc(g, (pixel and GMask) shr GShift);
1112 inc(b, (pixel and BMask) shr BShift);
1113 inc(a, (pixel and AMask) shr AShift);
1114 dec(c);
1115 end;
1116
1117 // nothing do to if all neighbors damaged
1118 if c < 1 then
1119 exit;
1120
1121 // use explosion color for damaged pixels
1122 for i:= 1 to c do
1123 begin
1124 inc(r, ExplosionBorderColorR);
1125 inc(g, ExplosionBorderColorG);
1126 inc(b, ExplosionBorderColorB);
1127 inc(a, 255);
1128 end;
1129
1130 // set resulting color value based on average of all neighbors
1131 r:= r div 8;
1132 g:= g div 8;
1133 b:= b div 8;
1134 a:= a div 8;
1135 LandPixels[y,x]:= (r shl RShift) or (g shl GShift) or (b shl BShift) or (a shl AShift);
1136
1137 end;
1138
1139 procedure Smooth_oldImpl(X, Y: LongInt);
1140 begin
1141 // a bit of AA for explosions
1142 if (Land[Y, X] = 0) and (Y > topY + 1) and
1143 (Y < LAND_HEIGHT-2) and (X > leftX + 1) and (X < rightX - 1) then
1144 begin
1145 if ((((Land[y, x-1] and lfDamaged) <> 0) and (((Land[y+1,x] and lfDamaged) <> 0)) or ((Land[y-1,x] and lfDamaged) <> 0))
1146 or (((Land[y, x+1] and lfDamaged) <> 0) and (((Land[y-1,x] and lfDamaged) <> 0) or ((Land[y+1,x] and lfDamaged) <> 0)))) then
1147 begin
1148 if (cReducedQuality and rqBlurryLand) = 0 then
1149 begin
1150 if ((LandPixels[y,x] and AMask) shr AShift) < 10 then
1151 LandPixels[y,x]:= (ExplosionBorderColor and (not AMask)) or (128 shl AShift)
1152 else
1153 LandPixels[y,x]:=
1154 (((((LandPixels[y,x] and RMask shr RShift) div 2)+((ExplosionBorderColor and RMask) shr RShift) div 2) and $FF) shl RShift) or
1155 (((((LandPixels[y,x] and GMask shr GShift) div 2)+((ExplosionBorderColor and GMask) shr GShift) div 2) and $FF) shl GShift) or
1156 (((((LandPixels[y,x] and BMask shr BShift) div 2)+((ExplosionBorderColor and BMask) shr BShift) div 2) and $FF) shl BShift) or ($FF shl AShift)
1157 end;
1158 {
1159 if (Land[y, x-1] = lfObject) then
1160 Land[y,x]:= lfObject
1161 else if (Land[y, x+1] = lfObject) then
1162 Land[y,x]:= lfObject
1163 else
1164 Land[y,x]:= lfBasic;
1165 }
1166 end
1167 else if ((((Land[y, x-1] and lfDamaged) <> 0) and ((Land[y+1,x-1] and lfDamaged) <> 0) and ((Land[y+2,x] and lfDamaged) <> 0))
1168 or (((Land[y, x-1] and lfDamaged) <> 0) and ((Land[y-1,x-1] and lfDamaged) <> 0) and ((Land[y-2,x] and lfDamaged) <> 0))
1169 or (((Land[y, x+1] and lfDamaged) <> 0) and ((Land[y+1,x+1] and lfDamaged) <> 0) and ((Land[y+2,x] and lfDamaged) <> 0))
1170 or (((Land[y, x+1] and lfDamaged) <> 0) and ((Land[y-1,x+1] and lfDamaged) <> 0) and ((Land[y-2,x] and lfDamaged) <> 0))
1171 or (((Land[y+1, x] and lfDamaged) <> 0) and ((Land[y+1,x+1] and lfDamaged) <> 0) and ((Land[y,x+2] and lfDamaged) <> 0))
1172 or (((Land[y-1, x] and lfDamaged) <> 0) and ((Land[y-1,x+1] and lfDamaged) <> 0) and ((Land[y,x+2] and lfDamaged) <> 0))
1173 or (((Land[y+1, x] and lfDamaged) <> 0) and ((Land[y+1,x-1] and lfDamaged) <> 0) and ((Land[y,x-2] and lfDamaged) <> 0))
1174 or (((Land[y-1, x] and lfDamaged) <> 0) and ((Land[y-1,x-1] and lfDamaged) <> 0) and ((Land[y,x-2] and lfDamaged) <> 0))) then
1175 begin
1176 if (cReducedQuality and rqBlurryLand) = 0 then
1177 begin
1178 if ((LandPixels[y,x] and AMask) shr AShift) < 10 then
1179 LandPixels[y,x]:= (ExplosionBorderColor and (not AMask)) or (64 shl AShift)
1180 else
1181 LandPixels[y,x]:=
1182 (((((LandPixels[y,x] and RMask shr RShift) * 3 div 4)+((ExplosionBorderColor and RMask) shr RShift) div 4) and $FF) shl RShift) or
1183 (((((LandPixels[y,x] and GMask shr GShift) * 3 div 4)+((ExplosionBorderColor and GMask) shr GShift) div 4) and $FF) shl GShift) or
1184 (((((LandPixels[y,x] and BMask shr BShift) * 3 div 4)+((ExplosionBorderColor and BMask) shr BShift) div 4) and $FF) shl BShift) or ($FF shl AShift)
1185 end;
1186 {
1187 if (Land[y, x-1] = lfObject) then
1188 Land[y, x]:= lfObject
1189 else if (Land[y, x+1] = lfObject) then
1190 Land[y, x]:= lfObject
1191 else if (Land[y+1, x] = lfObject) then
1192 Land[y, x]:= lfObject
1193 else if (Land[y-1, x] = lfObject) then
1194 Land[y, x]:= lfObject
1195 else Land[y,x]:= lfBasic
1196 }
1197 end
1198 end
1199 else if ((cReducedQuality and rqBlurryLand) = 0) and ((LandPixels[Y, X] and AMask) = AMask)
1200 and (Land[Y, X] and (lfDamaged or lfBasic) = lfBasic)
1201 and (Y > topY + 1) and (Y < LAND_HEIGHT-2) and (X > leftX + 1) and (X < rightX - 1) then
1202 begin
1203 if ((((Land[y, x-1] and lfDamaged) <> 0) and (((Land[y+1,x] and lfDamaged) <> 0)) or ((Land[y-1,x] and lfDamaged) <> 0))
1204 or (((Land[y, x+1] and lfDamaged) <> 0) and (((Land[y-1,x] and lfDamaged) <> 0) or ((Land[y+1,x] and lfDamaged) <> 0)))) then
1205 begin
1206 LandPixels[y,x]:=
1207 (((((LandPixels[y,x] and RMask shr RShift) div 2)+((ExplosionBorderColor and RMask) shr RShift) div 2) and $FF) shl RShift) or
1208 (((((LandPixels[y,x] and GMask shr GShift) div 2)+((ExplosionBorderColor and GMask) shr GShift) div 2) and $FF) shl GShift) or
1209 (((((LandPixels[y,x] and BMask shr BShift) div 2)+((ExplosionBorderColor and BMask) shr BShift) div 2) and $FF) shl BShift) or ($FF shl AShift)
1210 end
1211 else if ((((Land[y, x-1] and lfDamaged) <> 0) and ((Land[y+1,x-1] and lfDamaged) <> 0) and ((Land[y+2,x] and lfDamaged) <> 0))
1212 or (((Land[y, x-1] and lfDamaged) <> 0) and ((Land[y-1,x-1] and lfDamaged) <> 0) and ((Land[y-2,x] and lfDamaged) <> 0))
1213 or (((Land[y, x+1] and lfDamaged) <> 0) and ((Land[y+1,x+1] and lfDamaged) <> 0) and ((Land[y+2,x] and lfDamaged) <> 0))
1214 or (((Land[y, x+1] and lfDamaged) <> 0) and ((Land[y-1,x+1] and lfDamaged) <> 0) and ((Land[y-2,x] and lfDamaged) <> 0))
1215 or (((Land[y+1, x] and lfDamaged) <> 0) and ((Land[y+1,x+1] and lfDamaged) <> 0) and ((Land[y,x+2] and lfDamaged) <> 0))
1216 or (((Land[y-1, x] and lfDamaged) <> 0) and ((Land[y-1,x+1] and lfDamaged) <> 0) and ((Land[y,x+2] and lfDamaged) <> 0))
1217 or (((Land[y+1, x] and lfDamaged) <> 0) and ((Land[y+1,x-1] and lfDamaged) <> 0) and ((Land[y,x-2] and lfDamaged) <> 0))
1218 or (((Land[y-1, x] and lfDamaged) <> 0) and ((Land[y-1,x-1] and lfDamaged) <> 0) and ((Land[y,x-2] and lfDamaged) <> 0))) then
1219 begin
1220 LandPixels[y,x]:=
1221 (((((LandPixels[y,x] and RMask shr RShift) * 3 div 4)+((ExplosionBorderColor and RMask) shr RShift) div 4) and $FF) shl RShift) or
1222 (((((LandPixels[y,x] and GMask shr GShift) * 3 div 4)+((ExplosionBorderColor and GMask) shr GShift) div 4) and $FF) shl GShift) or
1223 (((((LandPixels[y,x] and BMask shr BShift) * 3 div 4)+((ExplosionBorderColor and BMask) shr BShift) div 4) and $FF) shl BShift) or ($FF shl AShift)
1224 end
1225 end
1226 end;
1227
1228 function SweepDirty: boolean;
1229 var x, y, xx, yy, ty, tx: LongInt;
1230 bRes, resweep, recheck: boolean;
1231 begin
1232 bRes:= false;
1233 reCheck:= true;
1234
1235 while recheck do
1236 begin
1237 recheck:= false;
1238 for y:= 0 to LAND_HEIGHT div 32 - 1 do
1239 begin
1240 for x:= 0 to LAND_WIDTH div 32 - 1 do
1241 begin
1242 if LandDirty[y, x] = 1 then
1243 begin
1244 resweep:= true;
1245 ty:= y * 32;
1246 tx:= x * 32;
1247 while(resweep) do
1248 begin
1249 resweep:= false;
1250 for yy:= ty to ty + 31 do
1251 for xx:= tx to tx + 31 do
1252 if Despeckle(xx, yy) then
1253 begin
1254 bRes:= true;
1255 resweep:= true;
1256 if (yy = ty) and (y > 0) then
1257 begin
1258 LandDirty[y-1, x]:= 1;
1259 recheck:= true;
1260 end
1261 else if (yy = ty+31) and (y < LAND_HEIGHT div 32 - 1) then
1262 begin
1263 LandDirty[y+1, x]:= 1;
1264 recheck:= true;
1265 end;
1266 if (xx = tx) and (x > 0) then
1267 begin
1268 LandDirty[y, x-1]:= 1;
1269 recheck:= true;
1270 end
1271 else if (xx = tx+31) and (x < LAND_WIDTH div 32 - 1) then
1272 begin
1273 LandDirty[y, x+1]:= 1;
1274 recheck:= true;
1275 end
1276 end;
1277 end;
1278 end;
1279 end;
1280 end;
1281 end;
1282
1283 // smooth explosion borders (except if land is blurry)
1284 if (cReducedQuality and rqBlurryLand) = 0 then
1285 for y:= 0 to LAND_HEIGHT div 32 - 1 do
1286 for x:= 0 to LAND_WIDTH div 32 - 1 do
1287 if LandDirty[y, x] <> 0 then
1288 begin
1289 ty:= y * 32;
1290 tx:= x * 32;
1291 for yy:= ty to ty + 31 do
1292 for xx:= tx to tx + 31 do
1293 Smooth(xx,yy)
1294 end;
1295
1296 for y:= 0 to LAND_HEIGHT div 32 - 1 do
1297 for x:= 0 to LAND_WIDTH div 32 - 1 do
1298 if LandDirty[y, x] <> 0 then
1299 begin
1300 LandDirty[y, x]:= 0;
1301 ty:= y * 32;
1302 tx:= x * 32;
1303 UpdateLandTexture(tx, 32, ty, 32, false);
1304 end;
1305
1306 SweepDirty:= bRes;
1307 end;
1308
1309
1310 // Return true if outside of land or not the value tested, used right now for some X/Y movement that does not use normal hedgehog movement in GSHandlers.inc
1311 function CheckLandValue(X, Y: LongInt; LandFlag: Word): boolean; inline;
1312 begin
1313 CheckLandValue:= ((X and LAND_WIDTH_MASK <> 0) or (Y and LAND_HEIGHT_MASK <> 0)) or ((Land[Y, X] and LandFlag) = 0)
1314 end;
1315
1316 function LandBackPixel(x, y: LongInt): LongWord; inline;
1317 var p: PLongWordArray;
1318 begin
1319 if LandBackSurface = nil then
1320 LandBackPixel:= 0
1321 else
1322 begin
1323 p:= LandBackSurface^.pixels;
1324 LandBackPixel:= p^[LandBackSurface^.w * (y mod LandBackSurface^.h) + (x mod LandBackSurface^.w)];// or $FF000000;
1325 end
1326 end;
1327
1328
1329 procedure DrawLine(X1, Y1, X2, Y2: LongInt; Color: Longword);
1330 var
1331 eX, eY, dX, dY: LongInt;
1332 i, sX, sY, x, y, d: LongInt;
1333 begin
1334 eX:= 0;
1335 eY:= 0;
1336 dX:= X2 - X1;
1337 dY:= Y2 - Y1;
1338
1339 if (dX > 0) then
1340 sX:= 1
1341 else
1342 if (dX < 0) then
1343 begin
1344 sX:= -1;
1345 dX:= -dX
1346 end
1347 else
1348 sX:= dX;
1349
1350 if (dY > 0) then
1351 sY:= 1
1352 else
1353 if (dY < 0) then
1354 begin
1355 sY:= -1;
1356 dY:= -dY
1357 end
1358 else
1359 sY:= dY;
1360
1361 if (dX > dY) then
1362 d:= dX
1363 else
1364 d:= dY;
1365
1366 x:= X1;
1367 y:= Y1;
1368
1369 for i:= 0 to d do
1370 begin
1371 inc(eX, dX);
1372 inc(eY, dY);
1373 if (eX > d) then
1374 begin
1375 dec(eX, d);
1376 inc(x, sX);
1377 end;
1378 if (eY > d) then
1379 begin
1380 dec(eY, d);
1381 inc(y, sY);
1382 end;
1383
1384 if ((x and LAND_WIDTH_MASK) = 0) and ((y and LAND_HEIGHT_MASK) = 0) then
1385 Land[y, x]:= Color;
1386 end
1387 end;
1388
1389 function DrawDots(x, y, xx, yy: Longint; Color: Longword): Longword; inline;
1390 begin
1391 DrawDots:= 0;
1392
1393 if (((x + xx) and LAND_WIDTH_MASK) = 0) and (((y + yy) and LAND_HEIGHT_MASK) = 0) and (Land[y + yy, x + xx] <> Color) then
1394 begin inc(DrawDots); Land[y + yy, x + xx]:= Color; end;
1395 if (((x + xx) and LAND_WIDTH_MASK) = 0) and (((y - yy) and LAND_HEIGHT_MASK) = 0) and (Land[y - yy, x + xx] <> Color) then
1396 begin inc(DrawDots); Land[y - yy, x + xx]:= Color; end;
1397 if (((x - xx) and LAND_WIDTH_MASK) = 0) and (((y + yy) and LAND_HEIGHT_MASK) = 0) and (Land[y + yy, x - xx] <> Color) then
1398 begin inc(DrawDots); Land[y + yy, x - xx]:= Color; end;
1399 if (((x - xx) and LAND_WIDTH_MASK) = 0) and (((y - yy) and LAND_HEIGHT_MASK) = 0) and (Land[y - yy, x - xx] <> Color) then
1400 begin inc(DrawDots); Land[y - yy, x - xx]:= Color; end;
1401 if (((x + yy) and LAND_WIDTH_MASK) = 0) and (((y + xx) and LAND_HEIGHT_MASK) = 0) and (Land[y + xx, x + yy] <> Color) then
1402 begin inc(DrawDots); Land[y + xx, x + yy]:= Color; end;
1403 if (((x + yy) and LAND_WIDTH_MASK) = 0) and (((y - xx) and LAND_HEIGHT_MASK) = 0) and (Land[y - xx, x + yy] <> Color) then
1404 begin inc(DrawDots); Land[y - xx, x + yy]:= Color; end;
1405 if (((x - yy) and LAND_WIDTH_MASK) = 0) and (((y + xx) and LAND_HEIGHT_MASK) = 0) and (Land[y + xx, x - yy] <> Color) then
1406 begin inc(DrawDots); Land[y + xx, x - yy]:= Color; end;
1407 if (((x - yy) and LAND_WIDTH_MASK) = 0) and (((y - xx) and LAND_HEIGHT_MASK) = 0) and (Land[y - xx, x - yy] <> Color) then
1408 begin inc(DrawDots); Land[y - xx, x - yy]:= Color; end;
1409 end;
1410
1411 function DrawLines(X1, Y1, X2, Y2, XX, YY: LongInt; color: Longword): Longword;
1412 var
1413 eX, eY, dX, dY: LongInt;
1414 i, sX, sY, x, y, d: LongInt;
1415 f: boolean;
1416 begin
1417 eX:= 0;
1418 eY:= 0;
1419 dX:= X2 - X1;
1420 dY:= Y2 - Y1;
1421 DrawLines:= 0;
1422
1423 if (dX > 0) then
1424 sX:= 1
1425 else
1426 if (dX < 0) then
1427 begin
1428 sX:= -1;
1429 dX:= -dX
1430 end
1431 else
1432 sX:= dX;
1433
1434 if (dY > 0) then
1435 sY:= 1
1436 else
1437 if (dY < 0) then
1438 begin
1439 sY:= -1;
1440 dY:= -dY
1441 end
1442 else
1443 sY:= dY;
1444
1445 if (dX > dY) then
1446 d:= dX
1447 else
1448 d:= dY;
1449
1450 x:= X1;
1451 y:= Y1;
1452
1453 for i:= 0 to d do
1454 begin
1455 inc(eX, dX);
1456 inc(eY, dY);
1457
1458 f:= eX > d;
1459 if f then
1460 begin
1461 dec(eX, d);
1462 inc(x, sX);
1463 inc(DrawLines, DrawDots(x, y, xx, yy, color))
1464 end;
1465 if (eY > d) then
1466 begin
1467 dec(eY, d);
1468 inc(y, sY);
1469 f:= true;
1470 inc(DrawLines, DrawDots(x, y, xx, yy, color))
1471 end;
1472
1473 if not f then
1474 inc(DrawLines, DrawDots(x, y, xx, yy, color))
1475 end
1476 end;
1477
1478 function DrawThickLine(X1, Y1, X2, Y2, radius: LongInt; color: Longword): Longword;
1479 var dx, dy, d: LongInt;
1480 begin
1481 DrawThickLine:= 0;
1482
1483 dx:= 0;
1484 dy:= Radius;
1485 d:= 3 - 2 * Radius;
1486 while (dx < dy) do
1487 begin
1488 inc(DrawThickLine, DrawLines(x1, y1, x2, y2, dx, dy, color));
1489 if (d < 0) then
1490 d:= d + 4 * dx + 6
1491 else
1492 begin
1493 d:= d + 4 * (dx - dy) + 10;
1494 dec(dy)
1495 end;
1496 inc(dx)
1497 end;
1498 if (dx = dy) then
1499 inc(DrawThickLine, DrawLines(x1, y1, x2, y2, dx, dy, color));
1500 end;
1501
1502
1503 procedure DumpLandToLog(x, y, r: LongInt);
1504 var xx, yy, dx: LongInt;
1505 s: shortstring;
1506 begin
1507 s[0]:= char(r * 2 + 1);
1508 for yy:= y - r to y + r do
1509 begin
1510 for dx:= 0 to r*2 do
1511 begin
1512 xx:= dx - r + x;
1513 if (xx = x) and (yy = y) then
1514 s[dx + 1]:= 'X'
1515 else if Land[yy, xx] > 255 then
1516 s[dx + 1]:= 'O'
1517 else if Land[yy, xx] > 0 then
1518 s[dx + 1]:= '*'
1519 else
1520 s[dx + 1]:= '.'
1521 end;
1522 AddFileLog('Land dump: ' + s);
1523 end;
1524 end;
1525
1526 end.
1527