the onScreenwidgets are multitouch now, frequently (alternating) tapping left and right still causes it to bug though, but you have to try hard to duplicate it, works ok for now
unit uLandOutline;
interface
uses uConsts, SDLh, uFloat;
type TPixAr = record
Count: Longword;
ar: array[0..Pred(cMaxEdgePoints)] of TPoint;
end;
procedure DrawEdge(var pa: TPixAr; Color: Longword);
procedure FillLand(x, y: LongInt);
procedure BezierizeEdge(var pa: TPixAr; Delta: hwFloat);
procedure RandomizePoints(var pa: TPixAr);
implementation
uses uLandGraphics, uDebug, uVariables, uLandTemplates, uRandom, uUtils;
var Stack: record
Count: Longword;
points: array[0..8192] of record
xl, xr, y, dir: LongInt;
end
end;
procedure Push(_xl, _xr, _y, _dir: LongInt);
begin
TryDo(Stack.Count <= 8192, 'FillLand: stack overflow', true);
_y:= _y + _dir;
if (_y < 0) or (_y >= LAND_HEIGHT) then
exit;
with Stack.points[Stack.Count] do
begin
xl:= _xl;
xr:= _xr;
y:= _y;
dir:= _dir
end;
inc(Stack.Count)
end;
procedure Pop(var _xl, _xr, _y, _dir: LongInt);
begin
dec(Stack.Count);
with Stack.points[Stack.Count] do
begin
_xl:= xl;
_xr:= xr;
_y:= y;
_dir:= dir
end
end;
procedure FillLand(x, y: LongInt);
var xl, xr, dir: LongInt;
begin
Stack.Count:= 0;
xl:= x - 1;
xr:= x;
Push(xl, xr, y, -1);
Push(xl, xr, y, 1);
dir:= 0;
while Stack.Count > 0 do
begin
Pop(xl, xr, y, dir);
while (xl > 0) and (Land[y, xl] <> 0) do
dec(xl);
while (xr < LAND_WIDTH - 1) and (Land[y, xr] <> 0) do
inc(xr);
while (xl < xr) do
begin
while (xl <= xr) and (Land[y, xl] = 0) do
inc(xl);
x:= xl;
while (xl <= xr) and (Land[y, xl] <> 0) do
begin
Land[y, xl]:= 0;
inc(xl)
end;
if x < xl then
begin
Push(x, Pred(xl), y, dir);
Push(x, Pred(xl), y,-dir);
end;
end;
end;
end;
procedure DrawEdge(var pa: TPixAr; Color: Longword);
var i: LongInt;
begin
i:= 0;
with pa do
while i < LongInt(Count) - 1 do
if (ar[i + 1].X = NTPX) then
inc(i, 2)
else
begin
DrawLine(ar[i].x, ar[i].y, ar[i + 1].x, ar[i + 1].y, Color);
inc(i)
end
end;
procedure Vector(p1, p2, p3: TPoint; var Vx, Vy: hwFloat);
var d1, d2, d: hwFloat;
begin
Vx:= int2hwFloat(p1.X - p3.X);
Vy:= int2hwFloat(p1.Y - p3.Y);
d:= DistanceI(p2.X - p1.X, p2.Y - p1.Y);
d1:= DistanceI(p2.X - p3.X, p2.Y - p3.Y);
d2:= Distance(Vx, Vy);
if d1 < d then
d:= d1;
if d2 < d then
d:= d2;
d:= d * _1div3;
if d2.QWordValue = 0 then
begin
Vx:= _0;
Vy:= _0
end
else
begin
d2:= _1 / d2;
Vx:= Vx * d2;
Vy:= Vy * d2;
Vx:= Vx * d;
Vy:= Vy * d
end
end;
procedure AddLoopPoints(var pa, opa: TPixAr; StartI, EndI: LongInt; Delta: hwFloat);
var i, pi, ni: LongInt;
NVx, NVy, PVx, PVy: hwFloat;
x1, x2, y1, y2: LongInt;
tsq, tcb, t, r1, r2, r3, cx1, cx2, cy1, cy2: hwFloat;
X, Y: LongInt;
begin
pi:= EndI;
i:= StartI;
ni:= Succ(StartI);
{$HINTS OFF}
Vector(opa.ar[pi], opa.ar[i], opa.ar[ni], NVx, NVy);
{$HINTS ON}
repeat
inc(pi);
if pi > EndI then
pi:= StartI;
inc(i);
if i > EndI then
i:= StartI;
inc(ni);
if ni > EndI then
ni:= StartI;
PVx:= NVx;
PVy:= NVy;
Vector(opa.ar[pi], opa.ar[i], opa.ar[ni], NVx, NVy);
x1:= opa.ar[pi].x;
y1:= opa.ar[pi].y;
x2:= opa.ar[i].x;
y2:= opa.ar[i].y;
cx1:= int2hwFloat(x1) - PVx;
cy1:= int2hwFloat(y1) - PVy;
cx2:= int2hwFloat(x2) + NVx;
cy2:= int2hwFloat(y2) + NVy;
t:= _0;
while t.Round = 0 do
begin
tsq:= t * t;
tcb:= tsq * t;
r1:= (_1 - t*3 + tsq*3 - tcb);
r2:= ( t*3 - tsq*6 + tcb*3);
r3:= ( tsq*3 - tcb*3);
X:= hwRound(r1 * x1 + r2 * cx1 + r3 * cx2 + tcb * x2);
Y:= hwRound(r1 * y1 + r2 * cy1 + r3 * cy2 + tcb * y2);
t:= t + Delta;
pa.ar[pa.Count].x:= X;
pa.ar[pa.Count].y:= Y;
inc(pa.Count);
TryDo(pa.Count <= cMaxEdgePoints, 'Edge points overflow', true)
end;
until i = StartI;
pa.ar[pa.Count].x:= opa.ar[StartI].X;
pa.ar[pa.Count].y:= opa.ar[StartI].Y;
inc(pa.Count)
end;
procedure BezierizeEdge(var pa: TPixAr; Delta: hwFloat);
var i, StartLoop: LongInt;
opa: TPixAr;
begin
opa:= pa;
pa.Count:= 0;
i:= 0;
StartLoop:= 0;
while i < LongInt(opa.Count) do
if (opa.ar[i + 1].X = NTPX) then
begin
AddLoopPoints(pa, opa, StartLoop, i, Delta);
inc(i, 2);
StartLoop:= i;
pa.ar[pa.Count].X:= NTPX;
pa.ar[pa.Count].Y:= 0;
inc(pa.Count);
end else inc(i)
end;
function CheckIntersect(V1, V2, V3, V4: TPoint): boolean;
var c1, c2, dm: LongInt;
begin
dm:= (V4.y - V3.y) * (V2.x - V1.x) - (V4.x - V3.x) * (V2.y - V1.y);
c1:= (V4.x - V3.x) * (V1.y - V3.y) - (V4.y - V3.y) * (V1.x - V3.x);
if dm = 0 then
exit(false);
c2:= (V2.x - V3.x) * (V1.y - V3.y) - (V2.y - V3.y) * (V1.x - V3.x);
if dm > 0 then
begin
if (c1 < 0) or (c1 > dm) then
exit(false);
if (c2 < 0) or (c2 > dm) then
exit(false)
end
else
begin
if (c1 > 0) or (c1 < dm) then
exit(false);
if (c2 > 0) or (c2 < dm) then
exit(false)
end;
//AddFileLog('1 (' + inttostr(V1.x) + ',' + inttostr(V1.y) + ')x(' + inttostr(V2.x) + ',' + inttostr(V2.y) + ')');
//AddFileLog('2 (' + inttostr(V3.x) + ',' + inttostr(V3.y) + ')x(' + inttostr(V4.x) + ',' + inttostr(V4.y) + ')');
CheckIntersect:= true
end;
function CheckSelfIntersect(var pa: TPixAr; ind: Longword): boolean;
var i: Longword;
begin
if (ind <= 0) or (ind >= Pred(pa.Count)) then
exit(false);
for i:= 1 to pa.Count - 3 do
if (i <= ind - 1) or (i >= ind + 2) then
begin
if (i <> ind - 1) and
CheckIntersect(pa.ar[ind], pa.ar[ind - 1], pa.ar[i], pa.ar[i - 1]) then
exit(true);
if (i <> ind + 2) and
CheckIntersect(pa.ar[ind], pa.ar[ind + 1], pa.ar[i], pa.ar[i - 1]) then
exit(true);
end;
CheckSelfIntersect:= false
end;
procedure RandomizePoints(var pa: TPixAr);
const cEdge = 55;
cMinDist = 8;
var radz: array[0..Pred(cMaxEdgePoints)] of LongInt;
i, k, dist, px, py: LongInt;
begin
for i:= 0 to Pred(pa.Count) do
begin
radz[i]:= 0;
with pa.ar[i] do
if x <> NTPX then
begin
radz[i]:= Min(Max(x - cEdge, 0), Max(LAND_WIDTH - cEdge - x, 0));
radz[i]:= Min(radz[i], Min(Max(y - cEdge, 0), Max(LAND_HEIGHT - cEdge - y, 0)));
if radz[i] > 0 then
for k:= 0 to Pred(i) do
begin
dist:= Max(abs(x - pa.ar[k].x), abs(y - pa.ar[k].y));
radz[k]:= Max(0, Min((dist - cMinDist) div 2, radz[k]));
radz[i]:= Max(0, Min(dist - radz[k] - cMinDist, radz[i]))
end
end;
end;
for i:= 0 to Pred(pa.Count) do
with pa.ar[i] do
if ((x and LAND_WIDTH_MASK) = 0) and ((y and LAND_HEIGHT_MASK) = 0) then
begin
px:= x;
py:= y;
x:= x + LongInt(GetRandom(7) - 3) * (radz[i] * 5 div 7) div 3;
y:= y + LongInt(GetRandom(7) - 3) * (radz[i] * 5 div 7) div 3;
if CheckSelfIntersect(pa, i) then
begin
x:= px;
y:= py
end;
end
end;
end.