Untitled

{$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.