# Untitled

unknown
pascal
2 years ago
11 kB
4
Indexable
Never
```{\$rangechecks off}
procedure RotatingAdjecent(var Adj:TPointArray;const Curr:TPoint; const Prev:TPoint);
var
i: Integer;
dx,dy,x,y:Single;
begin
x := Prev.x; y := Prev.y;
adj[7] := Prev;
for i:=0 to 6 do
begin
dx := x - Curr.x;
dy := y - Curr.y;
x := ((dy * 0.7070) + (dx * 0.7070)) + Curr.x;
y := ((dy * 0.7070) - (dx * 0.7070)) + Curr.y;
adj[i] := Point(Round(x),Round(y));
end;
end;

function TPABorder(const TPA:TPointArray): TPointArray;
var
i,j,h,x,y,hit:Integer;
Matrix: TIntegerMatrix;
adj: TPointArray;
start,prev,endpt:TPoint;
Area: TBox;
isset:Boolean;
begin
H := High(TPA);
Area := GetTPABounds(TPA);
Area.X2 := (Area.X2 - Area.X1) + 3;  //Width
Area.Y2 := (Area.Y2 - Area.Y1) + 3;  //Height
Area.X1 := Area.X1 - 1;
Area.Y1 := Area.Y1 - 1;

Matrix.SetSize(Area.X2+1, Area.Y2+1);
//Matrix := NewMatrix(Area.X2+1, Area.Y2+1);

start := Point(Area.X2, Area.Y2);
for i:=0 to H do
Matrix[(TPA[i].y-Area.Y1)][(TPA[i].x-Area.X1)] := 1;

//find FIRST starting y coord.
Isset := False;
Start := Point(Area.X2, Area.Y2);
for y:=0 to Area.Y2-1 do begin
for x:=0 to Area.X2-1 do
if Matrix[y][x] <> 0 then
begin
Start := Point(x,y);
Isset := True;
Break;
end;
if Isset then Break;
end;

H := H*4;
endpt := Start;
prev := Point(start.x, start.y-1);
hit := 0;

SetLength(adj, 8);
for i:=0 to H do
begin
if ((endpt = start) and (i>1)) then begin
if hit = 1 then Break;
Inc(hit);
end;
RotatingAdjecent(adj, start, prev);
for j:=0 to 7 do begin
x := adj[j].x;
y := adj[j].y;
if (x >= 0) and (x < Area.X2) and
(y >= 0) and (y < Area.Y2) then
if Matrix[y][x] <= 0 then begin
if Matrix[y][x] = 0 then
begin
Result += Point((adj[j].x+Area.x1), (adj[j].y+Area.y1));
Dec(Matrix[y][x]);
end;
end else if Matrix[y][x] >= 1 then
begin
prev := start;
start := adj[j];
Break;
end;
end;
end;
end;
{\$rangechecks on}

var TPA: TPointArray;
var bmp: TMufasaBitmap;
begin
SetTargetBitmap(BitmapFromString(572, 547, 'meJzt27FtHNnadlEBdNqmQ4ABMIS26bTJpGgzCFoMQIEwCybABO7fgH4IElp98d5vMDq7imtZMjeeOnVKwvT85z8AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAwOa9vb09/e75+Xl1VJStABY6X8KPj4/ffvfw8PDy8vL5+bm6rsVWAGud/6Xw7U/u7+8/Pj5W17XYCmCta/fw3d3d+/v7B784nU6+WQALXftm3dzcnD9b9/zicDj4ZgEsdO2bdXt7+/r6+p1fHI9H3yyAhfyuYM5WAMv9+P326XQ6HA7nf0r4/fZ/YSuAgo+Pj/v7++/fv68O2QBbAazlHp6zFcBa7uE5WwGs5R6esxXAWu7hOVsBrOUenrMVwFru4TlbAazlHp6zFcBa7uE5WwGs5R6esxXAWu7hOVsBrOUenrMVwFru4TlbAazlHp6zFcBa7uE5WwGs5R6esxXAWu7hOVsBrOUenrMVwFru4TlbAazlHp6zFcBa7uE5WwGs5R6esxXAWu7hOVsBrOUenrMVwFru4TlbAazlHp6zFcBa7uE5WwGs5R6esxXAWu7hOVsBrOUenrMVwFru4TlbAazlHp6zFcBa7uE5WwGs5R6esxXAWu7hOVsBrOUenrMVwFru4TlbAazlHp6zFcBa7uE5WwGs5R6esxXAWu7hOVsBrOUenrMVwFru4bnaVm9vb0+/e35+Xh0VZas5W1FWu4fLUludL5bHx8dvv3t4eHh5efn8/Fxd12KrOVsRl7qH41Jbnf/2++1PzoXnztV1LbaasxVxqXs4LrXVtbvl7u7u/f39g1+cTidbDV3byjeLiI/SPRyX2uraN+vm5uZ8Fd/zi8PhYKuha1vd+2bRkLqH41JbXftm3d7evr6+fucXx+PRVkPXtvLNIiJ1D8eltvLfyudsNWcr4lL3cFxtqx+/ST6dTofD4fzXY79J/i9sNWcrymr3cFlzq2ZVk63mbEWTkznX3KpZ1WSrOVvR5GTONbdqVjXZas5WNDmZc82tmlVNtpqzFU1O5lxzq2ZVk63mbEWTkznX3KpZ1WSrOVvR5GTONbdqVjXZas5WNDmZc82tmlVNtpqzFU1O5lxzq2ZVk63mbEWTkznX3KpZ1WSrOVvR5GTONbdqVjXZas5WNDmZc82tmlVNtpqzFU1O5lxzq2ZVk63mbEWTkznX3KpZ1WSrOVvR5GTONbdqVjXZas5WNDmZc82tmlVNtpqzFU1O5lxzq2ZVk63mbEWTkznX3KpZ1WSrOVvR5GTONbdqVjXZas5WNDmZc82tmlVNtpqzFU1O5lxzq2ZVk63mbEWTkznX3KpZ1WSrOVvR5GTONbdqVjXZas5WNDmZc82tmlVNtpqzFU1O5lxzq2ZVk63mbEWTkznX3KpZ1WSrOVvR5GTONbdqVjXZas5WNDmZc82tmlVNtpqzFU1O5lxzq2ZVk63mbEWTkznX3KpZ1WSrOVvR5GTONbdqVjXZas5WNDmZc82tmlVNtpqzFU1O5lxzq2ZVk63mbEWTkznX3KpZ1WSrOVvR5GTONbdqVjXZas5WNDmZc82tmlVNtpqzFU1O5lxzq2ZVk63mbEWTkznX3KpZ1WSrOVvR5GTONbdqVjXZas5WNDmZc82tmlVNtpqzFU1O5lxzq2ZVk63mbEWTkznX3KpZ1WSrOVt9ZW9vb0+/e35+Xh31/6tOp9PhcDgej6kqW229yhPcOt+sL+v8sjw+Pn773cPDw8vLy+fnpypVqr5mVZxv1pd1/hvdtz85n4fzqVClStXXrIrzzfqyrr0vd3d37+/vH4ucTidV/7CqeQ83t2pW+Wb9Fx++WV/Vtbvl5ubm/CLfL3I4HFT9w6r75DeruVWz6t436zrfrC/r2t1ye3v7+vr6fZHj8ajqH1atvfGcq39e5Zv1X/hmfVnN//6rSpUqv8H4L3yzvrLm72xV/a9Vfr+t6uvwzaJ5BlRtXXMrVVtnK5pnQNXWNbdStXW2onkGVG1dcytVW2crmmdA1dY1t1K1dbaieQZUbV1zK1VbZyuaZ0DV1jW3UrV1tqJ5BlRtXXMrVVtnK5pnQNXWNbdStXW2onkGVG1dcytVW2crmmdA1dY1t1K1dbaieQZUbV1zK1VbZyuaZ0DV1jW3UrV1tqJ5BlRtXXMrVVtnK5pnQNXWNbdStXW2onkGVG1dcytVW2crmmdA1dY1t1K1dbaieQZUbV1zK1VbZyuaZ0DV1jW3UrV1tqJ5BlRtXXMrVVtnK5pnQNXWNbdStXW2onkGVG1dcytVW2crmmdA1dY1t1K1dbaieQZUbV1zK1VbZyuaZ0DV1jW3UrV1tqJ5BlRtXXMrVVtnK5pnQNXWNbdStXW2onkGVG1dcytVW2crmmdA1dY1t1K1dbaieQZUbV1zK1VbZyuaZ0DV1jW3UrV1tqJ5BlRtXXMrVVtnK5pnQNXWNbdStXW2onkGVG1dcytVW2crmmdA1dY1t1K1dbaieQZUbV1zK1VbZyuaZ0DV1jW3UrV1tqJ5BlRtXXMrVVtnK5pnQNXWNbdStXW2onkGVG1dcytVW2crmmdA1dY1t1K1dbaieQZUbV1zK1VbZyuaZ0DV1jW3UrV1tvrK3t7enp6eTqfT4XA4Ho/nPz8/P6+Oilb94H2Za26lauts9WWdPw2Pj4/ffvfw8PDy8vL5+anqj7wvc82tVG2drb6s879fvv3J+TycT4WqP/K+zDW3UrV1tvqyrn0d7u7u3t/fPxY5nU6+WfvQ3ErV1tnqy7r2zbq5uTl/tu4XORwOvln70NxK1dbZ6su69s26vb19fX39vsjxePTN2ofmVqq2zlZfVvPXDs2qn7wvc82tVG2drb6yH78q/1XhV+V+674Pza1UbZ2taGqezGZVU3MrVVtnK5qaJ7NZ1dTcStXW2Yqm5slsVjU1t1K1dbaiqXkym1VNza1UbZ2taGqezGZVU3MrVVtnK5qaJ7NZ1dTcStXW2Yqm5slsVjU1t1K1dbaiqXkym1VNza1UbZ2taGqezGZVU3MrVVtnK5qaJ7NZ1dTcStXW2Yqm5slsVjU1t1K1dbaiqXkym1VNza1UbZ2taGqezGZVU3MrVVtnK5qaJ7NZ1dTcStXW2Yqm5slsVjU1t1K1dbaiqXkym1VNza1UbZ2taGqezGZVU3MrVVtnK5qaJ7NZ1dTcStXW2Yqm5slsVjU1t1K1dbaiqXkym1VNza1UbZ2taGqezGZVU3MrVVtnK5qaJ7NZ1dTcStXW2Yqm5slsVjU1t1K1dbaiqXkym1VNza1UbZ2taGqezGZVU3MrVVtnK5qaJ7NZ1dTcStXW2Yqm5slsVjU1t1K1dbaiqXkym1VNza1UbZ2taGqezGZVU3MrVVtnK5qaJ7NZ1dTcStXW2Yqm5slsVjU1t1K1dbaiqXkym1VNza1UbZ2taGqezGZVU3MrVVtnK5qaJ7NZ1dTcStXW2Yqm5slsVjU1t1K1dbaiqXkym1VNza1UbZ2taGqezGZVU3MrVVtnK5qaJ7NZ1dTcStXW2Yqm5slsVjU1t1K1dbaiqXkym1VNza1UbZ2taGqezGZVU3MrVVtnK5qaJ7NZ1dTcStXW2erveHt7e/rd8/Pz6qh01el0OhwOx+MxUvWD92WuuVWtqnna3Qxf3Hnqx8fHb797eHh4eXn5/PxU1a/6qXbjlTW3SlU1T7sqzn8f+PYn53fn/Aap6lf9lLrx4ppbpaqap10V19a+u7t7f3//WOT8T+wNVUVO5kfpxotrbpWqcjP886rIzbAz107mzc3N+RjcL3I4HDZUdd84mR+lGy+uuVWqys3wz6vuGzfDzlw7mbe3t6+vr98XOR6PG6qKnMzUjRfX3CpV5Wb451WRm2Fnmv/1UNX/QerGi2tulapqnnZV/Kf6K01V/6vUjRfX3KpW5VflW6/at9r78oOquWZVU3OrZlVTc6tm1V4111Y116xqam7VrGpqbtWs2qvm2qrmmlVNza2aVU3NrZpVe9VcW9Vcs6qpuVWzqqm5VbNqr5prq5prVjU1t2pWNTW3albtVXNtVXPNqqbmVs2qpuZWzaq9aq6taq5Z1dTcqlnV1NyqWbVXzbVVzTWrmppbNauamls1q/aqubaquWZVU3OrZlVTc6tm1V4111Y116xqam7VrGpqbtWs2qvm2qrmmlVNza2aVU3NrZpVe9VcW9Vcs6qpuVWzqqm5VbNqr5prq5prVjU1t2pWNTW3albtVXNtVXPNqqbmVs2qpuZWzaq9aq6taq5Z1dTcqlnV1NyqWbVXzbVVzTWrmppbNauamls1q/aqubaquWZVU3OrZlVTc6tm1V4111Y116xqam7VrGpqbtWs2qvm2qrmmlVNza2aVU3NrZpVe9VcW9Vcs6qpuVWzqqm5VbNqr5prq5prVjU1t2pWNTW3albtVXNtVXPNqqbmVs2qpuZWzaq9aq6taq5Z1dTcqlnV1NyqWbVXzbVVzTWrmppbNauamls1q/aqubaquWZVU3OrZlVTc6tm1V4111Y116xqam7VrGpqbtWs2qvm2qrmmlVNza2aVU3NrZpVe9VcW9Vcs6qpuVWzqqm5VbNqr5prq5prVjU1t2pWNTW3albtVXNtVXPNqqbmVs2qpuZWzaq9aq6taq5Z1dTcqlnV1NyqWbVXzbVVzTWrmppbNauamls1q/aqubaquWZVU3OrZlVTc6tm1V4111Y116xqam7VrGpqbtWs2qvm2qrmmlVNza2aVU3NrZpVe9VcW9Vcs6qpuVWzqqm5VbNqr5prq5prVjU1t2pWNTW3albtVXNtVXPNqqbmVs2qpuZWzaq9aq6taq5Z1dTcqlnV1NyqWbVXzbVVzTWrmppbNauamls1q/aqubaquWZVU3OrZlVTc6tm1V4111Y116xqam7VrGpqbtWs2qva2m9vb09PT6fT6XA4HI/H85+fn59XR6navOZWzaqy2n31Q7Nqr1Jrn1/hx8fHb797eHh4eXn5/PxU1a9qam7VrIpL3Vc/Nav2KrX2+e+Z3/7kXHjuVNWvampu1ayKS91XPzWr9iq19rW3+O7u7v39/WOR0+kUvFuaWzVde4LO1eZ8lO6rn5pVe5Va+9o9fHNzc75e7hc5HA7Bu6W5VdO1J+hcbU7qvvqpWbVXqbWv3cO3t7evr6/fFzkej8G7pblV07Un6FxtTuq++qlZtVeptZv/VVrV1jW3albFpe6rn5pVe1Vbu/nrX1Vb92OrXxW28gT/V7X76odm1V4111Y116xizhOca27VrNqr5tqq5ppVzHmCc82tmlV71Vxb1VyzijlPcK65VbNqr5prq5prVjHnCc41t2pW7VVzbVVzzSrmPMG55lbNqr1qrq1qrlnFnCc419yqWbVXzbVVzTWrmPME55pbNav2qrm2qrlmFXOe4Fxzq2bVXjXXVjXXrGLOE5xrbtWs2qvm2qrmmlXMeYJzza2aVXvVXFvVXLOKOU9wrrlVs2qvmmurmmtWMecJzjW3albtVXNtVXPNKuY8wbnmVs2qvWqurWquWcWcJzjX3KpZtVfNtVXNNauY8wTnmls1q/aqubaquWYVc57gXHOrZtVeNddWNdesYs4TnGtu1azaq+baquaaVcx5gnPNrZpVe9VcW9Vcs4o5T3CuuVWzaq+aa6uaa1Yx5wnONbdqVu1Vc21Vc80q5jzBueZWzaq9aq6taq5ZxZwnONfcqlm1V821Vc01q5jzBOeaWzWr9qq5tqq5ZhVznuBcc6tm1V4111Y116xizhOca27VrNqr5tqq5ppVzHmCc82tmlV71Vxb1VyzijlPcK65VbNqr5prq5prVjHnCc41t2pW7VVzbVVzzSrmPMG55lbNqr1qrq1qrlnFnCc419yqWbVXzbVVzTWrmPME55pbNav2qrm2qrlmFXOe4Fxzq2bVXjXXVjXXrGLOE5xrbtWs2qvm2qrmmlXMeYJzza2aVXvVXFvVXLOKOU9wrrlVs2qvmmurmmtWMecJzjW3albtVXNtVXPNKuY8wbnmVs2qvWqurWquWcWcJzjX3KpZtVfNtVXNNauY8wTnmls1q/aqubaquWYVc57gXHOrZtVeNddWNdesYs4TnGtu1azaq+baquaaVcx5gnPNrZpV+/P29vb09HQ6nQ6Hw/F4PP/5+fl5dZSqzVcx5wnOlbfyzfoLzgfg8fHx2+8eHh5eXl4+Pz9VqeLf5gnOxbfyzfoLzn9L+fYn5+XP+6tSxb/NE5yLb+Wb9RdcOwN3d3fv7+8fi5z/4R88mdvaam0Vc57gXPNm+OnDN+vfd+0evrm5Ob8y94scDofgydzWVmurmPME55o3w0++WX/BtXv49vb29fX1+yLH4zF4Mre11doq5jzBuebN8JNv1l/Q/G+aqrZexZwnOBffyjfr72j+dlTV/1r1q0IVc57gXPMd/ME3629qrq0KuNR8B5tVe9VcWxVwqfkONqv2qrm2KuBS8x1sVu1Vc21VwKXmO9is2qvm2qqAS813sFm1V821VQGXmu9gs2qvmmurAi4138Fm1V4111YFXGq+g82qvWqurQq41HwHm1V71VxbFXCp+Q42q/aqubYq4FLzHWxW7VVzbVXApeY72Kzaq+baqoBLzXewWbVXzbVVAZea72Czaq+aa6sCLjXfwWbVXjXXVgVcar6Dzaq9aq6tCrjUfAebVXvVXFsVcKn5Djar9qq5tirgUvMdbFbtVXNtVcCl5jvYrNqr5tqqgEvNd7BZtVfNtVUBl5rvYLNqr5prqwIuNd/BZtVeNddWBVxqvoPNqr1qrq0KuNR8B5tVe9VcWxVwqfkONqv2qrm2KuBS8x1sVu1Vc21VwKXmO9is2qvm2qqAS813sFm1V821VQGXmu9gs2qvmmurAi4138Fm1V4111YFXGq+g82qvWqurQq41HwHm1V71VxbFXCp+Q42q/aqubYq4FLzHWxW7VVzbVXApeY72Kzaq+baqoBLzXewWbVXzbVVAZea72Czaq+aa6sCLjXfwWbVXjXXVgVcar6Dzaq9aq6tCrjUfAebVXvVXFsVcKn5Djar9qq5dq3q7e3t6enpdDodDofj8Xj+8/Pz8+oo+EKa72Czat9qX4cfUlXnY/n4+Pjtdw8PDy8vL5+fn6vrYP+a72CzavdSX4efUlXnvzt9+5Nz4blzdR3sX/MdbFbtXurr8FOq6trJvLu7e39//wD+ZafTKfgOXqvyzfpXfZS+Dj+lqq59s25ubs6vzD3wLzscDsF38FrVvW/Wvyn1dfgpVXXtm3V7e/v6+vod+Jcdj8fgO3ityjfrX5X6OvyUqvJfWmGt5jvYrNq91Nfhp1rVj1+0/sovWuFvar6Dzap9q30dfmhWAbBW8+vQrAJgrebXoVkFwFrNr0OzCoC1ml+HZhUAazW/Ds0qANZqfh2aVQCs1fw6NKsAWKv5dWhWAbBW8+vQrAJgrebXoVkFwFrNr0OzCoC1ml+HZhUAazW/Ds0qANZqfh2aVQCs1fw6NKsAWKv5dWhWAbBW8+vQrAJgrebXoVkFwFrNr0OzCoC1ml+HZhUAazW/Ds0qANZqfh2aVQCs1fw6NKsAWKv5dWhWAbBW8+vQrAJgrebXoVkFwFrNr0OzCoC1ml+HZhUAazW/Ds0qANZqfh2aVQCs1fw6NKsAWKv5dWhWAbBW8+vQrAJgrebXoVkFwFrNr0OzCoC1ml+HZhUAazW/Ds0qANZqfh2aVQCs1fw6NKsAWKv5dWhWAbBW8+vQrAJglbe3t6enp9PpdDgcjsfj+c/Pz8+ro9JVvypUAXwR50v48fHx2+8eHh5eXl4+Pz9V9asAvo7zvxS+/cn9/f3Hx4eqfhXA13HtHr67u3t/f/9Y5HQ6bajKNwvg77j2zbq5uTl/IO4XORwOG6q6980C+CuufbNub29fX1+/L3I8HjdU5ZsF8Hc0f1egCoA/8qvy/7WqthXAV/Ph/94dsxXAWu7hOVsBrOUenrMVwFru4TlbAazlHp6zFcBa7uE5WwGs5R6esxXAWu7hOVsBrOUenrMVwFru4TlbAazlHp6zFcBa7uE5WwGs5R6esxXAWu7hOVsBrOUenrMVwFru4TlbAazlHp6zFcBa7uE5WwGs5R6esxXAWu7hOVsBrOUenrMVwFru4TlbAazlHp6zFcBa7uE5WwGs5R6esxXAWu7hOVsBrOUenrMVwFru4TlbAazlHp6zFcBa7uE5WwGs5R6esxXAWu7hOVsBrOUenrMVwFru4TlbAazlHp6zFcBa7uE5WwGs5R6esxXAWu7hOVsBrOUenrMVwFru4TlbAazlHp6zFcBa7uE5WwGs8vb29vT0dDqdDofD8Xg8//n5+Xl1VJStABY6X8KPj4/ffvfw8PDy8vL5+bm6rsVWAGud/6Xw7U/u7+8/Pj5W17XYCmCta/fw3d3d+/v7B784nU6+WQALXftm3dzcnD9b9/zicDj4ZgEsdO2bdXt7+/r6+p1fHI9H3yyAhfyuYM5WAMv9+P32r/x++xpbAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAsGP/D6kdkZM='));

FindColorsTolerance(TPA, 0, 0, 0, 572-1, 547-1, 50);

bmp.init();
bmp.SetSize(1000,1000);
bmp.DrawTPA(TPABorder(TPA), 255);

ShowBitmap(bmp);
end.```