Forced sprites placing mode, exposed to scripts (not tested at all)
(* * Hedgewars, a free turn based strategy game * Copyright (c) 2004-2014 Andrey Korotaev <unC0Rr@gmail.com> * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; version 2 of the License * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *){$INCLUDE "options.inc"}unit uLandGraphics;interfaceuses uFloat, uConsts, uTypes;type fillType = (nullPixel, backgroundPixel, ebcPixel, icePixel, setNotCurrentMask, changePixelSetNotCurrent, setCurrentHog, changePixelNotSetNotCurrent);type TRangeArray = array[0..31] of record Left, Right: LongInt; end; PRangeArray = ^TRangeArray;TLandCircleProcedure = procedure (landX, landY, pixelX, pixelY: Longint);function addBgColor(OldColor, NewColor: LongWord): LongWord;function SweepDirty: boolean;function Despeckle(X, Y: LongInt): Boolean;procedure Smooth(X, Y: LongInt);function CheckLandValue(X, Y: LongInt; LandFlag: Word): boolean;function DrawExplosion(X, Y, Radius: LongInt): Longword;procedure DrawHLinesExplosions(ar: PRangeArray; Radius: LongInt; y, dY: LongInt; Count: Byte);procedure DrawTunnel(X, Y, dX, dY: hwFloat; ticks, HalfWidth: LongInt);function FillRoundInLand(X, Y, Radius: LongInt; Value: Longword): Longword;function FillRoundInLandFT(X, Y, Radius: LongInt; fill: fillType): Longword;procedure ChangeRoundInLand(X, Y, Radius: LongInt; doSet, isCurrent: boolean);function LandBackPixel(x, y: LongInt): LongWord;procedure DrawLine(X1, Y1, X2, Y2: LongInt; Color: Longword);function DrawThickLine(X1, Y1, X2, Y2, radius: LongInt; color: Longword): Longword;procedure DumpLandToLog(x, y, r: LongInt);procedure DrawIceBreak(x, y, iceRadius, iceHeight: Longint);function TryPlaceOnLandSimple(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; doPlace, indestructible: boolean): boolean; inline;function TryPlaceOnLand(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; doPlace: boolean; LandFlags: Word): boolean; inline;function ForcePlaceOnLand(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; LandFlags: Word): boolean; inline;function TryPlaceOnLand(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; doPlace, outOfMap, force: boolean; LandFlags: Word): boolean;function GetPlaceCollisionTex(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt): PTexture;implementationuses SDLh, uLandTexture, uTextures, uVariables, uUtils, uDebug;procedure calculatePixelsCoordinates(landX, landY: Longint; var pixelX, pixelY: Longint); inline;beginif (cReducedQuality and rqBlurryLand) = 0 then begin pixelX := landX; pixelY := landY; endelse begin pixelX := LandX div 2; pixelY := LandY div 2; end;end;function drawPixelBG(landX, landY, pixelX, pixelY: Longint): Longword; inline;begindrawPixelBG := 0;if (Land[LandY, landX] and lfIndestructible) = 0 then begin if ((Land[landY, landX] and lfBasic) <> 0) and (((LandPixels[pixelY, pixelX] and AMask) shr AShift) = 255) and (not disableLandBack) then begin LandPixels[pixelY, pixelX]:= LandBackPixel(landX, landY); inc(drawPixelBG); end else if ((Land[landY, landX] and lfObject) <> 0) or (((LandPixels[pixelY, pixelX] and AMask) shr AShift) < 255) then LandPixels[pixelY, pixelX]:= LandPixels[pixelY, pixelX] and (not AMASK) end;end;procedure drawPixelEBC(landX, landY, pixelX, pixelY: Longint); inline;beginif ((Land[landY, landX] and lfBasic) <> 0) or ((Land[landY, landX] and lfObject) <> 0) then begin LandPixels[pixelY, pixelX]:= ExplosionBorderColor; Land[landY, landX]:= (Land[landY, landX] or lfDamaged) and (not lfIce); LandDirty[landY div 32, landX div 32]:= 1; end;end;function isLandscapeEdge(weight:Longint):boolean; inline;beginisLandscapeEdge := (weight < 8) and (weight >= 2);end;function getPixelWeight(x, y:Longint): Longint;var i, j, r: Longint;beginr := 0;for i := x - 1 to x + 1 do for j := y - 1 to y + 1 do begin if (i < 0) or (i > LAND_WIDTH - 1) or (j < 0) or (j > LAND_HEIGHT -1) then exit(9); if Land[j, i] and lfLandMask and (not lfIce) = 0 then inc(r) end; getPixelWeight:= rend;procedure fillPixelFromIceSprite(pixelX, pixelY:Longint); inline;var iceSurface: PSDL_Surface; icePixels: PLongwordArray; w: LongWord;begin if cOnlyStats then exit; // So. 3 parameters here. Ice colour, Ice opacity, and a bias on the greyscaled pixel towards lightness iceSurface:= SpritesData[sprIceTexture].Surface; icePixels := iceSurface^.pixels; w:= LandPixels[pixelY, pixelX]; if w > 0 then begin w:= round(((w shr RShift and $FF) * RGB_LUMINANCE_RED + (w shr BShift and $FF) * RGB_LUMINANCE_GREEN + (w shr GShift and $FF) * RGB_LUMINANCE_BLUE)); if w < 128 then w:= w+128; if w > 255 then w:= 255; w:= (w shl RShift) or (w shl BShift) or (w shl GShift) or (LandPixels[pixelY, pixelX] and AMask); LandPixels[pixelY, pixelX]:= addBgColor(w, IceColor); LandPixels[pixelY, pixelX]:= addBgColor(LandPixels[pixelY, pixelX], icePixels^[iceSurface^.w * (pixelY mod iceSurface^.h) + (pixelX mod iceSurface^.w)]) end else begin LandPixels[pixelY, pixelX]:= IceColor and (not AMask) or $E8 shl AShift; LandPixels[pixelY, pixelX]:= addBgColor(LandPixels[pixelY, pixelX], icePixels^[iceSurface^.w * (pixelY mod iceSurface^.h) + (pixelX mod iceSurface^.w)]); // silly workaround to avoid having to make background erasure a tadb it smarter about sea ice if LandPixels[pixelY, pixelX] and AMask shr AShift = 255 then LandPixels[pixelY, pixelX]:= LandPixels[pixelY, pixelX] and (not AMask) or 254 shl AShift; end;end;procedure DrawPixelIce(landX, landY, pixelX, pixelY: Longint); inline;beginif ((Land[landY, landX] and lfIce) <> 0) then exit;if isLandscapeEdge(getPixelWeight(landX, landY)) then begin if (LandPixels[pixelY, pixelX] and AMask < 255) and (LandPixels[pixelY, pixelX] and AMask > 0) then LandPixels[pixelY, pixelX] := (IceEdgeColor and (not AMask)) or (LandPixels[pixelY, pixelX] and AMask) else if (LandPixels[pixelY, pixelX] and AMask < 255) or (Land[landY, landX] > 255) then LandPixels[pixelY, pixelX] := IceEdgeColor endelse if Land[landY, landX] > 255 then begin fillPixelFromIceSprite(pixelX, pixelY); end;if Land[landY, landX] > 255 then Land[landY, landX] := Land[landY, landX] or lfIce and (not lfDamaged);end;function FillLandCircleLineFT(y, fromPix, toPix: LongInt; fill : fillType): Longword;var px, py, i: LongInt;begin//get rid of compiler warning px := 0; py := 0; FillLandCircleLineFT := 0; case fill of backgroundPixel: for i:= fromPix to toPix do begin calculatePixelsCoordinates(i, y, px, py); inc(FillLandCircleLineFT, drawPixelBG(i, y, px, py)); end; ebcPixel: for i:= fromPix to toPix do begin calculatePixelsCoordinates(i, y, px, py); drawPixelEBC(i, y, px, py); end; nullPixel: for i:= fromPix to toPix do begin calculatePixelsCoordinates(i, y, px, py); if ((Land[y, i] and lfIndestructible) = 0) and (not disableLandBack or (Land[y, i] > 255)) then LandPixels[py, px]:= LandPixels[py, px] and (not AMASK); end; icePixel: for i:= fromPix to toPix do begin calculatePixelsCoordinates(i, y, px, py); DrawPixelIce(i, y, px, py); end; setNotCurrentMask: for i:= fromPix to toPix do begin Land[y, i]:= Land[y, i] and lfNotCurrentMask; end; changePixelSetNotCurrent: for i:= fromPix to toPix do begin if Land[y, i] and lfObjMask > 0 then Land[y, i]:= Land[y, i] - 1; end; setCurrentHog: for i:= fromPix to toPix do begin Land[y, i]:= Land[y, i] or lfCurrentHog end; changePixelNotSetNotCurrent: for i:= fromPix to toPix do begin if Land[y, i] and lfObjMask < lfObjMask then Land[y, i]:= Land[y, i] + 1 end; end;end;function FillLandCircleSegmentFT(x, y, dx, dy: LongInt; fill : fillType): Longword; inline;begin FillLandCircleSegmentFT := 0;if ((y + dy) and LAND_HEIGHT_MASK) = 0 then inc(FillLandCircleSegmentFT, FillLandCircleLineFT(y + dy, Max(x - dx, 0), Min(x + dx, LAND_WIDTH - 1), fill));if ((y - dy) and LAND_HEIGHT_MASK) = 0 then inc(FillLandCircleSegmentFT, FillLandCircleLineFT(y - dy, Max(x - dx, 0), Min(x + dx, LAND_WIDTH - 1), fill));if ((y + dx) and LAND_HEIGHT_MASK) = 0 then inc(FillLandCircleSegmentFT, FillLandCircleLineFT(y + dx, Max(x - dy, 0), Min(x + dy, LAND_WIDTH - 1), fill));if ((y - dx) and LAND_HEIGHT_MASK) = 0 then inc(FillLandCircleSegmentFT, FillLandCircleLineFT(y - dx, Max(x - dy, 0), Min(x + dy, LAND_WIDTH - 1), fill));end;function FillRoundInLandFT(X, Y, Radius: LongInt; fill: fillType): Longword; inline;var dx, dy, d: LongInt;begindx:= 0;dy:= Radius;d:= 3 - 2 * Radius;FillRoundInLandFT := 0;while (dx < dy) do begin inc(FillRoundInLandFT, FillLandCircleSegmentFT(x, y, dx, dy, fill)); if (d < 0) then d:= d + 4 * dx + 6 else begin d:= d + 4 * (dx - dy) + 10; dec(dy) end; inc(dx) end;if (dx = dy) then inc (FillRoundInLandFT, FillLandCircleSegmentFT(x, y, dx, dy, fill));end;function addBgColor(OldColor, NewColor: LongWord): LongWord;// Factor ranges from 0 to 100% NewColorvar oRed, oBlue, oGreen, oAlpha, nRed, nBlue, nGreen, nAlpha: byte;begin oAlpha := (OldColor shr AShift); nAlpha := (NewColor shr AShift); // shortcircuit if (oAlpha = 0) or (nAlpha = $FF) then begin addBgColor:= NewColor; exit end; // Get colors oRed := (OldColor shr RShift); oGreen := (OldColor shr GShift); oBlue := (OldColor shr BShift); nRed := (NewColor shr RShift); nGreen := (NewColor shr GShift); nBlue := (NewColor shr BShift); // Mix colors nRed := min(255,((nRed*nAlpha) div 255) + ((oRed*oAlpha*byte(255-nAlpha)) div 65025)); nGreen := min(255,((nGreen*nAlpha) div 255) + ((oGreen*oAlpha*byte(255-nAlpha)) div 65025)); nBlue := min(255,((nBlue*nAlpha) div 255) + ((oBlue*oAlpha*byte(255-nAlpha)) div 65025)); nAlpha := min(255, oAlpha + nAlpha); addBgColor := (nAlpha shl AShift) or (nRed shl RShift) or (nGreen shl GShift) or (nBlue shl BShift);end;function FillCircleLines(x, y, dx, dy: LongInt; Value: Longword): Longword;var i: LongInt;begin FillCircleLines:= 0; if ((y + dy) and LAND_HEIGHT_MASK) = 0 then for i:= Max(x - dx, 0) to Min(x + dx, LAND_WIDTH - 1) do if (Land[y + dy, i] and lfIndestructible) = 0 then begin if Land[y + dy, i] <> Value then inc(FillCircleLines); Land[y + dy, i]:= Value; end; if ((y - dy) and LAND_HEIGHT_MASK) = 0 then for i:= Max(x - dx, 0) to Min(x + dx, LAND_WIDTH - 1) do if (Land[y - dy, i] and lfIndestructible) = 0 then begin if Land[y - dy, i] <> Value then inc(FillCircleLines); Land[y - dy, i]:= Value; end; if ((y + dx) and LAND_HEIGHT_MASK) = 0 then for i:= Max(x - dy, 0) to Min(x + dy, LAND_WIDTH - 1) do if (Land[y + dx, i] and lfIndestructible) = 0 then begin if Land[y + dx, i] <> Value then inc(FillCircleLines); Land[y + dx, i]:= Value; end; if ((y - dx) and LAND_HEIGHT_MASK) = 0 then for i:= Max(x - dy, 0) to Min(x + dy, LAND_WIDTH - 1) do if (Land[y - dx, i] and lfIndestructible) = 0 then begin if Land[y - dx, i] <> Value then inc(FillCircleLines); Land[y - dx, i]:= Value; end;end;function FillRoundInLand(X, Y, Radius: LongInt; Value: Longword): Longword;var dx, dy, d: LongInt;beginFillRoundInLand:= 0;dx:= 0;dy:= Radius;d:= 3 - 2 * Radius;while (dx < dy) do begin inc(FillRoundInLand, FillCircleLines(x, y, dx, dy, Value)); if (d < 0) then d:= d + 4 * dx + 6 else begin d:= d + 4 * (dx - dy) + 10; dec(dy) end; inc(dx) end;if (dx = dy) then inc(FillRoundInLand, FillCircleLines(x, y, dx, dy, Value));end;procedure ChangeRoundInLand(X, Y, Radius: LongInt; doSet, isCurrent: boolean);beginif not doSet and isCurrent then FillRoundInLandFT(X, Y, Radius, setNotCurrentMask)else if not doSet and (not IsCurrent) then FillRoundInLandFT(X, Y, Radius, changePixelSetNotCurrent)else if doSet and IsCurrent then FillRoundInLandFT(X, Y, Radius, setCurrentHog)else if doSet and (not IsCurrent) then FillRoundInLandFT(X, Y, Radius, changePixelNotSetNotCurrent);end;procedure DrawIceBreak(x, y, iceRadius, iceHeight: Longint);var i, j: integer; landRect: TSDL_Rect;beginfor i := min(max(x - iceRadius, 0), LAND_WIDTH - 1) to min(max(x + iceRadius, 0), LAND_WIDTH - 1) do begin for j := min(max(y, 0), LAND_HEIGHT - 1) to min(max(y + iceHeight, 0), LAND_HEIGHT - 1) do begin if Land[j, i] = 0 then begin Land[j, i] := lfIce; if (cReducedQuality and rqBlurryLand) = 0 then fillPixelFromIceSprite(i, j) else fillPixelFromIceSprite(i div 2, j div 2); end; end; end;landRect.x := min(max(x - iceRadius, 0), LAND_WIDTH - 1);landRect.y := min(max(y, 0), LAND_HEIGHT - 1);landRect.w := min(2*iceRadius, LAND_WIDTH - landRect.x - 1);landRect.h := min(iceHeight, LAND_HEIGHT - landRect.y - 1);UpdateLandTexture(landRect.x, landRect.w, landRect.y, landRect.h, true);end;function DrawExplosion(X, Y, Radius: LongInt): Longword;var tx, ty, dx, dy: Longint;begin DrawExplosion := FillRoundInLandFT(x, y, Radius, backgroundPixel); if Radius > 20 then FillRoundInLandFT(x, y, Radius - 15, nullPixel); FillRoundInLand(X, Y, Radius, 0); FillRoundInLandFT(x, y, Radius + 4, ebcPixel); tx:= Max(X - Radius - 5, 0); dx:= Min(X + Radius + 5, LAND_WIDTH) - tx; ty:= Max(Y - Radius - 5, 0); dy:= Min(Y + Radius + 5, LAND_HEIGHT) - ty; UpdateLandTexture(tx, dx, ty, dy, false);end;procedure DrawHLinesExplosions(ar: PRangeArray; Radius: LongInt; y, dY: LongInt; Count: Byte);var tx, ty, by, bx, i: LongInt;beginfor i:= 0 to Pred(Count) do begin for ty:= Max(y - Radius, 0) to Min(y + Radius, LAND_HEIGHT) do for tx:= Max(0, ar^[i].Left - Radius) to Min(LAND_WIDTH, ar^[i].Right + Radius) do begin if (Land[ty, tx] and lfIndestructible) = 0 then begin if (cReducedQuality and rqBlurryLand) = 0 then begin by:= ty; bx:= tx; end else begin by:= ty div 2; bx:= tx div 2; end; if ((Land[ty, tx] and lfBasic) <> 0) and (((LandPixels[by,bx] and AMask) shr AShift) = 255) and (not disableLandBack) then LandPixels[by, bx]:= LandBackPixel(tx, ty) else if ((Land[ty, tx] and lfObject) <> 0) or (((LandPixels[by,bx] and AMask) shr AShift) < 255) then LandPixels[by, bx]:= LandPixels[by, bx] and (not AMASK) end end; inc(y, dY) end;inc(Radius, 4);dec(y, Count * dY);for i:= 0 to Pred(Count) do begin for ty:= Max(y - Radius, 0) to Min(y + Radius, LAND_HEIGHT) do for tx:= Max(0, ar^[i].Left - Radius) to Min(LAND_WIDTH, ar^[i].Right + Radius) do if ((Land[ty, tx] and lfBasic) <> 0) or ((Land[ty, tx] and lfObject) <> 0) then begin if (cReducedQuality and rqBlurryLand) = 0 then LandPixels[ty, tx]:= ExplosionBorderColor else LandPixels[ty div 2, tx div 2]:= ExplosionBorderColor; Land[ty, tx]:= (Land[ty, tx] or lfDamaged) and (not lfIce); LandDirty[ty div 32, tx div 32]:= 1; end; inc(y, dY) end;UpdateLandTexture(0, LAND_WIDTH, 0, LAND_HEIGHT, false)end;procedure DrawExplosionBorder(X, Y, dx, dy:hwFloat; despeckle : Boolean);var t, tx, ty :Longint;beginfor t:= 0 to 7 do begin X:= X + dX; Y:= Y + dY; tx:= hwRound(X); ty:= hwRound(Y); if ((ty and LAND_HEIGHT_MASK) = 0) and ((tx and LAND_WIDTH_MASK) = 0) and (((Land[ty, tx] and lfBasic) <> 0) or ((Land[ty, tx] and lfObject) <> 0)) then begin Land[ty, tx]:= (Land[ty, tx] or lfDamaged) and (not lfIce); if despeckle then LandDirty[ty div 32, tx div 32]:= 1; if (cReducedQuality and rqBlurryLand) = 0 then LandPixels[ty, tx]:= ExplosionBorderColor else LandPixels[ty div 2, tx div 2]:= ExplosionBorderColor end end;end;//// - (dX, dY) - direction, vector of length = 0.5//procedure DrawTunnel(X, Y, dX, dY: hwFloat; ticks, HalfWidth: LongInt);var nx, ny, dX8, dY8: hwFloat; i, t, tx, ty, by, bx, stX, stY, ddy, ddx: Longint; despeckle : Boolean;begin // (-dY, dX) is (dX, dY) rotated by PI/2stY:= hwRound(Y);stX:= hwRound(X);despeckle:= HalfWidth > 1;nx:= X + dY * (HalfWidth + 8);ny:= Y - dX * (HalfWidth + 8);dX8:= dX * 8;dY8:= dY * 8;for i:= 0 to 7 do begin X:= nx - dX8; Y:= ny - dY8; for t:= -8 to ticks + 8 do begin X:= X + dX; Y:= Y + dY; tx:= hwRound(X); ty:= hwRound(Y); if ((ty and LAND_HEIGHT_MASK) = 0) and ((tx and LAND_WIDTH_MASK) = 0) and (((Land[ty, tx] and lfBasic) <> 0) or ((Land[ty, tx] and lfObject) <> 0)) then begin Land[ty, tx]:= Land[ty, tx] and (not lfIce); if despeckle then begin Land[ty, tx]:= Land[ty, tx] or lfDamaged; LandDirty[ty div 32, tx div 32]:= 1 end; if (cReducedQuality and rqBlurryLand) = 0 then LandPixels[ty, tx]:= ExplosionBorderColor else LandPixels[ty div 2, tx div 2]:= ExplosionBorderColor end end; nx:= nx - dY; ny:= ny + dX; end;for i:= -HalfWidth to HalfWidth do begin X:= nx - dX8; Y:= ny - dY8; DrawExplosionBorder(X, Y, dx, dy, despeckle); X:= nx; Y:= ny; for t:= 0 to ticks do begin X:= X + dX; Y:= Y + dY; tx:= hwRound(X); ty:= hwRound(Y); if ((ty and LAND_HEIGHT_MASK) = 0) and ((tx and LAND_WIDTH_MASK) = 0) and ((Land[ty, tx] and lfIndestructible) = 0) then begin if (cReducedQuality and rqBlurryLand) = 0 then begin by:= ty; bx:= tx; end else begin by:= ty div 2; bx:= tx div 2; end; if ((Land[ty, tx] and lfBasic) <> 0) and (((LandPixels[by,bx] and AMask) shr AShift) = 255) and (not disableLandBack) then LandPixels[by, bx]:= LandBackPixel(tx, ty) else if ((Land[ty, tx] and lfObject) <> 0) or (((LandPixels[by,bx] and AMask) shr AShift) < 255) then LandPixels[by, bx]:= LandPixels[by, bx] and (not AMASK); Land[ty, tx]:= 0; end end; DrawExplosionBorder(X, Y, dx, dy, despeckle); nx:= nx - dY; ny:= ny + dX; end;for i:= 0 to 7 do begin X:= nx - dX8; Y:= ny - dY8; for t:= -8 to ticks + 8 do begin X:= X + dX; Y:= Y + dY; tx:= hwRound(X); ty:= hwRound(Y); if ((ty and LAND_HEIGHT_MASK) = 0) and ((tx and LAND_WIDTH_MASK) = 0) and (((Land[ty, tx] and lfBasic) <> 0) or ((Land[ty, tx] and lfObject) <> 0)) then begin Land[ty, tx]:= (Land[ty, tx] or lfDamaged) and (not lfIce); if despeckle then LandDirty[ty div 32, tx div 32]:= 1; if (cReducedQuality and rqBlurryLand) = 0 then LandPixels[ty, tx]:= ExplosionBorderColor else LandPixels[ty div 2, tx div 2]:= ExplosionBorderColor end end; nx:= nx - dY; ny:= ny + dX; end;tx:= Max(stX - HalfWidth * 2 - 4 - abs(hwRound(dX * ticks)), 0);ty:= Max(stY - HalfWidth * 2 - 4 - abs(hwRound(dY * ticks)), 0);ddx:= Min(stX + HalfWidth * 2 + 4 + abs(hwRound(dX * ticks)), LAND_WIDTH) - tx;ddy:= Min(stY + HalfWidth * 2 + 4 + abs(hwRound(dY * ticks)), LAND_HEIGHT) - ty;UpdateLandTexture(tx, ddx, ty, ddy, false)end;function TryPlaceOnLandSimple(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; doPlace, indestructible: boolean): boolean; inline;var lf: Word;beginif indestructible then lf:= lfIndestructibleelse lf:= 0;TryPlaceOnLandSimple:= TryPlaceOnLand(cpX, cpY, Obj, Frame, doPlace, false, false, lf);end;function TryPlaceOnLand(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; doPlace: boolean; LandFlags: Word): boolean; inline;beginTryPlaceOnLand:= TryPlaceOnLand(cpX, cpY, Obj, Frame, doPlace, false, false, LandFlags);end;function ForcePlaceOnLand(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; LandFlags: Word): boolean; inline;begin ForcePlaceOnLand:= TryPlaceOnLand(cpX, cpY, Obj, Frame, true, true, true, LandFlags)end;function TryPlaceOnLand(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; doPlace, outOfMap, force: boolean; LandFlags: Word): boolean;var X, Y, bpp, h, w, row, col, gx, gy, numFramesFirstCol: LongInt; p: PByteArray; Image: PSDL_Surface; indestructible: boolean;beginTryPlaceOnLand:= false;numFramesFirstCol:= SpritesData[Obj].imageHeight div SpritesData[Obj].Height;// make land indestructible if lfIndestructible is passedindestructible:= (LandFlags and lfIndestructible <> 0);if outOfMap then doPlace:= false; // just using for a checkTryDo(SpritesData[Obj].Surface <> nil, 'Assert SpritesData[Obj].Surface failed', true);Image:= SpritesData[Obj].Surface;w:= SpritesData[Obj].Width;h:= SpritesData[Obj].Height;row:= Frame mod numFramesFirstCol;col:= Frame div numFramesFirstCol;if SDL_MustLock(Image) then SDLTry(SDL_LockSurface(Image) >= 0, true);bpp:= Image^.format^.BytesPerPixel;TryDo(bpp = 4, 'It should be 32 bpp sprite', true);// Check that sprite fits free spacep:= PByteArray(@(PByteArray(Image^.pixels)^[ Image^.pitch * row * h + col * w * 4 ]));case bpp of 4: for y:= 0 to Pred(h) do begin for x:= 0 to Pred(w) do if ((PLongword(@(p^[x * 4]))^) and AMask) <> 0 then if (outOfMap and ((cpY + y) < LAND_HEIGHT) and ((cpY + y) >= 0) and ((cpX + x) < LAND_WIDTH) and ((cpX + x) >= 0) and ((not force) or (Land[cpY + y, cpX + x] <> 0))) or (not outOfMap and (((cpY + y) <= Longint(topY)) or ((cpY + y) >= LAND_HEIGHT) or ((cpX + x) <= Longint(leftX)) or ((cpX + x) >= Longint(rightX)) or ((not force) or (Land[cpY + y, cpX + x] <> 0)))) then begin if SDL_MustLock(Image) then SDL_UnlockSurface(Image); exit end; p:= PByteArray(@(p^[Image^.pitch])); end; end;TryPlaceOnLand:= true;if not doPlace then begin if SDL_MustLock(Image) then SDL_UnlockSurface(Image); exit end;// Checked, now placep:= PByteArray(@(PByteArray(Image^.pixels)^[ Image^.pitch * row * h + col * w * 4 ]));case bpp of 4: for y:= 0 to Pred(h) do begin for x:= 0 to Pred(w) do if ((PLongword(@(p^[x * 4]))^) and AMask) <> 0 then begin if (cReducedQuality and rqBlurryLand) = 0 then begin gX:= cpX + x; gY:= cpY + y; end else begin gX:= (cpX + x) div 2; gY:= (cpY + y) div 2; end; if indestructible then Land[cpY + y, cpX + x]:= {lfIndestructible or }LandFlags else if (LandPixels[gY, gX] and AMask) shr AShift = 255 then // This test assumes lfBasic and lfObject differ only graphically Land[cpY + y, cpX + x]:= lfBasic or LandFlags else Land[cpY + y, cpX + x]:= lfObject or LandFlags; LandPixels[gY, gX]:= PLongword(@(p^[x * 4]))^ end; p:= PByteArray(@(p^[Image^.pitch])); end; end;if SDL_MustLock(Image) then SDL_UnlockSurface(Image);x:= Max(cpX, leftX);w:= Min(cpX + Image^.w, LAND_WIDTH) - x;y:= Max(cpY, topY);h:= Min(cpY + Image^.h, LAND_HEIGHT) - y;UpdateLandTexture(x, w, y, h, true)end;function GetPlaceCollisionTex(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt): PTexture;var X, Y, bpp, h, w, row, col, numFramesFirstCol: LongInt; p, pt: PByteArray; Image, finalSurface: PSDL_Surface;beginGetPlaceCollisionTex:= nil;numFramesFirstCol:= SpritesData[Obj].imageHeight div SpritesData[Obj].Height;TryDo(SpritesData[Obj].Surface <> nil, 'Assert SpritesData[Obj].Surface failed', true);Image:= SpritesData[Obj].Surface;w:= SpritesData[Obj].Width;h:= SpritesData[Obj].Height;row:= Frame mod numFramesFirstCol;col:= Frame div numFramesFirstCol;if SDL_MustLock(Image) then SDLTry(SDL_LockSurface(Image) >= 0, true);bpp:= Image^.format^.BytesPerPixel;TryDo(bpp = 4, 'It should be 32 bpp sprite', true);finalSurface:= SDL_CreateRGBSurface(SDL_SWSURFACE, w, h, 32, RMask, GMask, BMask, AMask);TryDo(finalSurface <> nil, 'GetPlaceCollisionTex: fail to create surface', true);if SDL_MustLock(finalSurface) then SDLTry(SDL_LockSurface(finalSurface) >= 0, true);// draw on surface based on collisionsp:= PByteArray(@(PByteArray(Image^.pixels)^[ Image^.pitch * row * h + col * w * 4 ]));pt:= PByteArray(@(PByteArray(finalSurface^.pixels)^));case bpp of 4: for y:= 0 to Pred(h) do begin for x:= 0 to Pred(w) do if (((PLongword(@(p^[x * 4]))^) and AMask) <> 0) and (((cpY + y) <= Longint(topY)) or ((cpY + y) >= LAND_HEIGHT) or ((cpX + x) <= Longint(leftX)) or ((cpX + x) >= Longint(rightX)) or (Land[cpY + y, cpX + x] <> 0)) then (PLongword(@(pt^[x * 4]))^):= cWhiteColor else (PLongword(@(pt^[x * 4]))^):= 0; p:= PByteArray(@(p^[Image^.pitch])); pt:= PByteArray(@(pt^[finalSurface^.pitch])); end; end;if SDL_MustLock(Image) then SDL_UnlockSurface(Image);if SDL_MustLock(finalSurface) then SDL_UnlockSurface(finalSurface);GetPlaceCollisionTex:= Surface2Tex(finalSurface, true);SDL_FreeSurface(finalSurface);end;function Despeckle(X, Y: LongInt): boolean;var nx, ny, i, j, c, xx, yy: LongInt; pixelsweep: boolean;begin Despeckle:= true; if (cReducedQuality and rqBlurryLand) = 0 then begin xx:= X; yy:= Y; end else begin xx:= X div 2; yy:= Y div 2; end; pixelsweep:= (Land[Y, X] <= lfAllObjMask) and (LandPixels[yy, xx] <> 0); if (((Land[Y, X] and lfDamaged) <> 0) and ((Land[Y, X] and lfIndestructible) = 0)) or pixelsweep then begin c:= 0; for i:= -1 to 1 do for j:= -1 to 1 do if (i <> 0) or (j <> 0) then begin ny:= Y + i; nx:= X + j; if ((ny and LAND_HEIGHT_MASK) = 0) and ((nx and LAND_WIDTH_MASK) = 0) then begin if pixelsweep then begin if ((cReducedQuality and rqBlurryLand) <> 0) then begin ny:= Y div 2 + i; nx:= X div 2 + j; if ((ny and (LAND_HEIGHT_MASK div 2)) = 0) and ((nx and (LAND_WIDTH_MASK div 2)) = 0) then if LandPixels[ny, nx] <> 0 then inc(c); end else if LandPixels[ny, nx] <> 0 then inc(c); end else if Land[ny, nx] > 255 then inc(c); end end; if c < 4 then // 0-3 neighbours begin if ((Land[Y, X] and lfBasic) <> 0) and (not disableLandBack) then LandPixels[yy, xx]:= LandBackPixel(X, Y) else LandPixels[yy, xx]:= LandPixels[yy, xx] and (not AMASK); if not pixelsweep then begin Land[Y, X]:= 0; exit end end; end; Despeckle:= falseend;procedure Smooth(X, Y: LongInt);begin// a bit of AA for explosionsif (Land[Y, X] = 0) and (Y > LongInt(topY) + 1) and (Y < LAND_HEIGHT-2) and (X > LongInt(leftX) + 1) and (X < LongInt(rightX) - 1) then begin if ((((Land[y, x-1] and lfDamaged) <> 0) and (((Land[y+1,x] and lfDamaged) <> 0)) or ((Land[y-1,x] and lfDamaged) <> 0)) 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 begin if (cReducedQuality and rqBlurryLand) = 0 then begin if ((LandPixels[y,x] and AMask) shr AShift) < 10 then LandPixels[y,x]:= (ExplosionBorderColor and (not AMask)) or (128 shl AShift) else LandPixels[y,x]:= (((((LandPixels[y,x] and RMask shr RShift) div 2)+((ExplosionBorderColor and RMask) shr RShift) div 2) and $FF) shl RShift) or (((((LandPixels[y,x] and GMask shr GShift) div 2)+((ExplosionBorderColor and GMask) shr GShift) div 2) and $FF) shl GShift) or (((((LandPixels[y,x] and BMask shr BShift) div 2)+((ExplosionBorderColor and BMask) shr BShift) div 2) and $FF) shl BShift) or ($FF shl AShift) end; if (Land[y, x-1] = lfObject) then Land[y,x]:= lfObject else if (Land[y, x+1] = lfObject) then Land[y,x]:= lfObject else Land[y,x]:= lfBasic; end 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)) 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)) 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)) 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)) 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)) 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)) 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)) 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 begin if (cReducedQuality and rqBlurryLand) = 0 then begin if ((LandPixels[y,x] and AMask) shr AShift) < 10 then LandPixels[y,x]:= (ExplosionBorderColor and (not AMask)) or (64 shl AShift) else LandPixels[y,x]:= (((((LandPixels[y,x] and RMask shr RShift) * 3 div 4)+((ExplosionBorderColor and RMask) shr RShift) div 4) and $FF) shl RShift) or (((((LandPixels[y,x] and GMask shr GShift) * 3 div 4)+((ExplosionBorderColor and GMask) shr GShift) div 4) and $FF) shl GShift) or (((((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) end; if (Land[y, x-1] = lfObject) then Land[y, x]:= lfObject else if (Land[y, x+1] = lfObject) then Land[y, x]:= lfObject else if (Land[y+1, x] = lfObject) then Land[y, x]:= lfObject else if (Land[y-1, x] = lfObject) then Land[y, x]:= lfObject else Land[y,x]:= lfBasic end endelse if ((cReducedQuality and rqBlurryLand) = 0) and (LandPixels[Y, X] and AMask = 255)and (Land[Y, X] and (lfDamaged or lfBasic) = lfBasic)and (Y > LongInt(topY) + 1) and (Y < LAND_HEIGHT-2) and (X > LongInt(leftX) + 1) and (X < LongInt(rightX) - 1) then begin if ((((Land[y, x-1] and lfDamaged) <> 0) and (((Land[y+1,x] and lfDamaged) <> 0)) or ((Land[y-1,x] and lfDamaged) <> 0)) 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 begin LandPixels[y,x]:= (((((LandPixels[y,x] and RMask shr RShift) div 2)+((ExplosionBorderColor and RMask) shr RShift) div 2) and $FF) shl RShift) or (((((LandPixels[y,x] and GMask shr GShift) div 2)+((ExplosionBorderColor and GMask) shr GShift) div 2) and $FF) shl GShift) or (((((LandPixels[y,x] and BMask shr BShift) div 2)+((ExplosionBorderColor and BMask) shr BShift) div 2) and $FF) shl BShift) or ($FF shl AShift) end 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)) 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)) 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)) 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)) 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)) 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)) 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)) 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 begin LandPixels[y,x]:= (((((LandPixels[y,x] and RMask shr RShift) * 3 div 4)+((ExplosionBorderColor and RMask) shr RShift) div 4) and $FF) shl RShift) or (((((LandPixels[y,x] and GMask shr GShift) * 3 div 4)+((ExplosionBorderColor and GMask) shr GShift) div 4) and $FF) shl GShift) or (((((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) end endend;function SweepDirty: boolean;var x, y, xx, yy, ty, tx: LongInt; bRes, updateBlock, resweep, recheck: boolean;beginbRes:= false;reCheck:= true;while recheck do begin recheck:= false; for y:= 0 to LAND_HEIGHT div 32 - 1 do begin for x:= 0 to LAND_WIDTH div 32 - 1 do begin if LandDirty[y, x] = 1 then begin updateBlock:= false; resweep:= true; ty:= y * 32; tx:= x * 32; while(resweep) do begin resweep:= false; for yy:= ty to ty + 31 do for xx:= tx to tx + 31 do if Despeckle(xx, yy) then begin bRes:= true; updateBlock:= true; resweep:= true; if (yy = ty) and (y > 0) then begin LandDirty[y-1, x]:= 1; recheck:= true; end else if (yy = ty+31) and (y < LAND_HEIGHT div 32 - 1) then begin LandDirty[y+1, x]:= 1; recheck:= true; end; if (xx = tx) and (x > 0) then begin LandDirty[y, x-1]:= 1; recheck:= true; end else if (xx = tx+31) and (x < LAND_WIDTH div 32 - 1) then begin LandDirty[y, x+1]:= 1; recheck:= true; end end; end; if updateBlock then UpdateLandTexture(tx, 32, ty, 32, false); LandDirty[y, x]:= 2; end; end; end; end;for y:= 0 to LAND_HEIGHT div 32 - 1 do for x:= 0 to LAND_WIDTH div 32 - 1 do if LandDirty[y, x] <> 0 then begin LandDirty[y, x]:= 0; ty:= y * 32; tx:= x * 32; for yy:= ty to ty + 31 do for xx:= tx to tx + 31 do Smooth(xx,yy) end;SweepDirty:= bRes;end;// 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.incfunction CheckLandValue(X, Y: LongInt; LandFlag: Word): boolean; inline;begin CheckLandValue:= ((X and LAND_WIDTH_MASK <> 0) or (Y and LAND_HEIGHT_MASK <> 0)) or ((Land[Y, X] and LandFlag) = 0)end;function LandBackPixel(x, y: LongInt): LongWord; inline;var p: PLongWordArray;begin if LandBackSurface = nil then LandBackPixel:= 0 else begin p:= LandBackSurface^.pixels; LandBackPixel:= p^[LandBackSurface^.w * (y mod LandBackSurface^.h) + (x mod LandBackSurface^.w)];// or $FF000000; endend;procedure DrawLine(X1, Y1, X2, Y2: LongInt; Color: Longword);var eX, eY, dX, dY: LongInt; i, sX, sY, x, y, d: LongInt;begineX:= 0;eY:= 0;dX:= X2 - X1;dY:= Y2 - Y1;if (dX > 0) then sX:= 1else if (dX < 0) then begin sX:= -1; dX:= -dX end else sX:= dX;if (dY > 0) then sY:= 1else if (dY < 0) then begin sY:= -1; dY:= -dY end else sY:= dY;if (dX > dY) then d:= dXelse d:= dY;x:= X1;y:= Y1;for i:= 0 to d do begin inc(eX, dX); inc(eY, dY); if (eX > d) then begin dec(eX, d); inc(x, sX); end; if (eY > d) then begin dec(eY, d); inc(y, sY); end; if ((x and LAND_WIDTH_MASK) = 0) and ((y and LAND_HEIGHT_MASK) = 0) then Land[y, x]:= Color; endend;function DrawDots(x, y, xx, yy: Longint; Color: Longword): Longword; inline;begin DrawDots:= 0; if (((x + xx) and LAND_WIDTH_MASK) = 0) and (((y + yy) and LAND_HEIGHT_MASK) = 0) and (Land[y + yy, x + xx] <> Color) then begin inc(DrawDots); Land[y + yy, x + xx]:= Color; end; if (((x + xx) and LAND_WIDTH_MASK) = 0) and (((y - yy) and LAND_HEIGHT_MASK) = 0) and (Land[y - yy, x + xx] <> Color) then begin inc(DrawDots); Land[y - yy, x + xx]:= Color; end; if (((x - xx) and LAND_WIDTH_MASK) = 0) and (((y + yy) and LAND_HEIGHT_MASK) = 0) and (Land[y + yy, x - xx] <> Color) then begin inc(DrawDots); Land[y + yy, x - xx]:= Color; end; if (((x - xx) and LAND_WIDTH_MASK) = 0) and (((y - yy) and LAND_HEIGHT_MASK) = 0) and (Land[y - yy, x - xx] <> Color) then begin inc(DrawDots); Land[y - yy, x - xx]:= Color; end; if (((x + yy) and LAND_WIDTH_MASK) = 0) and (((y + xx) and LAND_HEIGHT_MASK) = 0) and (Land[y + xx, x + yy] <> Color) then begin inc(DrawDots); Land[y + xx, x + yy]:= Color; end; if (((x + yy) and LAND_WIDTH_MASK) = 0) and (((y - xx) and LAND_HEIGHT_MASK) = 0) and (Land[y - xx, x + yy] <> Color) then begin inc(DrawDots); Land[y - xx, x + yy]:= Color; end; if (((x - yy) and LAND_WIDTH_MASK) = 0) and (((y + xx) and LAND_HEIGHT_MASK) = 0) and (Land[y + xx, x - yy] <> Color) then begin inc(DrawDots); Land[y + xx, x - yy]:= Color; end; if (((x - yy) and LAND_WIDTH_MASK) = 0) and (((y - xx) and LAND_HEIGHT_MASK) = 0) and (Land[y - xx, x - yy] <> Color) then begin inc(DrawDots); Land[y - xx, x - yy]:= Color; end;end;function DrawLines(X1, Y1, X2, Y2, XX, YY: LongInt; color: Longword): Longword;var eX, eY, dX, dY: LongInt; i, sX, sY, x, y, d: LongInt; f: boolean;begin eX:= 0; eY:= 0; dX:= X2 - X1; dY:= Y2 - Y1; DrawLines:= 0; if (dX > 0) then sX:= 1 else if (dX < 0) then begin sX:= -1; dX:= -dX end else sX:= dX; if (dY > 0) then sY:= 1 else if (dY < 0) then begin sY:= -1; dY:= -dY end else sY:= dY; if (dX > dY) then d:= dX else d:= dY; x:= X1; y:= Y1; for i:= 0 to d do begin inc(eX, dX); inc(eY, dY); f:= eX > d; if f then begin dec(eX, d); inc(x, sX); inc(DrawLines, DrawDots(x, y, xx, yy, color)) end; if (eY > d) then begin dec(eY, d); inc(y, sY); f:= true; inc(DrawLines, DrawDots(x, y, xx, yy, color)) end; if not f then inc(DrawLines, DrawDots(x, y, xx, yy, color)) endend;function DrawThickLine(X1, Y1, X2, Y2, radius: LongInt; color: Longword): Longword;var dx, dy, d: LongInt;begin DrawThickLine:= 0; dx:= 0; dy:= Radius; d:= 3 - 2 * Radius; while (dx < dy) do begin inc(DrawThickLine, DrawLines(x1, y1, x2, y2, dx, dy, color)); if (d < 0) then d:= d + 4 * dx + 6 else begin d:= d + 4 * (dx - dy) + 10; dec(dy) end; inc(dx) end; if (dx = dy) then inc(DrawThickLine, DrawLines(x1, y1, x2, y2, dx, dy, color));end;procedure DumpLandToLog(x, y, r: LongInt);var xx, yy, dx: LongInt; s: shortstring;begin s[0]:= char(r * 2 + 1); for yy:= y - r to y + r do begin for dx:= 0 to r*2 do begin xx:= dx - r + x; if (xx = x) and (yy = y) then s[dx + 1]:= 'X' else if Land[yy, xx] > 255 then s[dx + 1]:= 'O' else if Land[yy, xx] > 0 then s[dx + 1]:= '*' else s[dx + 1]:= '.' end; AddFileLog('Land dump: ' + s); end;end;end.