TPASkeleton [DEV]

{$loadlib pumbaa.dll}

const
  DELAY = 1500; // For drawing skeleton.

procedure TPASkeletonEx(var TPA: TPointArray; straighten: Boolean);
var
  b: TBox;
  f, k, q, o, c, w, h, i, l, g, t, x, y: Integer;
  m: T2DBoolArray;
  n, v: TPointArray;
  p: TBoolArray;
  s, u: TIntegerArray;
  d, e, r: Boolean;
  z, j: TPoint;
begin
  l := Length(TPA);
  if (l > 1) then
  begin
    b := pp_TPABounds(TPA);
    w := ((b.X2 - b.X1) + 1);
    h := ((b.Y2 - b.Y1) + 1);
    if ((w > 1) and (h > 1)) then
    begin
      pp_BoxExpand(b);
      w := (w + 2);
      h := (h + 2);
      pp_Create(False, w, h, m);
      w := (w - 1);
      h := (h - 1);
      l := (l - 1);
      for i := 0 to l do
        m[(TPA[i].X - b.X1)][(TPA[i].Y - b.Y1)] := True;
      l := 0;
      for y := 0 to h do
        for x := 0 to w do
          if m[x][y] then
          begin
            TPA[l].X := (x + b.X1);
            TPA[l].Y := (y + b.Y1);
            l := (l + 1);
          end;
      SetLength(TPA, l);
      if (l > 1) then
      begin
        SetLength(s, l);
        l := (l - 1);
        SetLength(n, 8);
        n[0] := Point(0, -1); // UP
        n[1] := Point(1, 0); // RIGHT
        n[2] := Point(0, 1); // DOWN
        n[3] := Point(-1, 0); // LEFT
        n[4] := Point(-1, -1); // TOP-LEFT
        n[5] := Point(1, -1); // TOP-RIGHT
        n[6] := Point(1, 1); // BOTTOM-RIGHT
        n[7] := Point(-1, 1); // BOTTOM-LEFT
        SetLength(v, 12);
        v[0] := Point(5, 2); // TOP-RIGHT and DOWN
        v[1] := Point(4, 2); // TOP-LEFT and DOWN
        v[2] := Point(0, 7); // UP and BOTTOM-LEFT
        v[3] := Point(0, 6); // UP and BOTTOM-RIGHT
        v[4] := Point(5, 7); // TOP-RIGHT and BOTTOM-LEFT
        v[5] := Point(4, 6); // TOP-LEFT and BOTTOM-RIGHT
        v[6] := Point(0, 2); // UP and DOWN
        v[7] := Point(3, 1); // LEFT and RIGHT
        v[8] := Point(3, 6); // LEFT and BOTTOM-RIGHT
        v[9] := Point(5, 3); // TOP-RIGHT And LEFT
        v[10] := Point(1, 7); // RIGHT and BOTTOM-LEFT
        v[11] := Point(4, 1); // TOP-LEFT and RIGHT
        SetLength(p, 4);
        SetLength(u, 8);
        repeat
          d := False;
          c := 0;
          for i := 0 to l do
          begin
            e := False;
            z.X := (TPA[i].X - b.X1);
            z.Y := (TPA[i].Y - b.Y1);
            p[0] := m[(z.X + n[0].X)][(z.Y + n[0].Y)];
            p[1] := m[(z.X + n[1].X)][(z.Y + n[1].Y)];
            p[2] := m[(z.X + n[2].X)][(z.Y + n[2].Y)];
            p[3] := m[(z.X + n[3].X)][(z.Y + n[3].Y)];
            t := 0;
            for g := 0 to 3 do
              if p[g] then
                t := (t + 1);
            if ((t > 0) and (t < 4)) then
            begin
              if not (p[0] and p[2]) then
                e := (p[0] or p[2]);
              if not e then
                if not (p[1] and p[3]) then
                  e := (p[1] or p[3]);
            end;
            if e then
            begin
              s[c] := i;
              c := (c + 1);
            end;
          end;
          if (c > 0) then
          begin
            c := (c - 1);
            q := 0;
            for i := 0 to c do
            begin
              z.X := (TPA[(s[i] - q)].X - b.X1);
              z.Y := (TPA[(s[i] - q)].Y - b.Y1);
              if not ((m[(z.X + n[1].X)][(z.Y + n[1].Y)] and m[(z.X + n[3].X)][(z.Y + n[3].Y)]) and (m[(z.X + n[0].X)][(z.Y + n[0].Y)] and m[(z.X + n[2].X)][(z.Y + n[2].Y)])) then
              begin
                r := True;
                if (not m[(z.X + n[1].X)][(z.Y + n[1].Y)] and not m[(z.X + n[3].X)][(z.Y + n[3].Y)]) then
                for o := 0 to 6 do
                begin
                  r := not (m[(z.X + n[v[o].X].X)][(z.Y + n[v[o].X].Y)] and m[(z.X + n[v[o].Y].X)][(z.Y + n[v[o].Y].Y)]);
                  if not r then
                    Break;
                end;
                if r then
                  if (not m[(z.X + n[0].X)][(z.Y + n[0].Y)] and not m[(z.X + n[2].X)][(z.Y + n[2].Y)]) then
                  for o := 7 to 11 do
                  begin
                    r := not (m[(z.X + n[v[o].X].X)][(z.Y + n[v[o].X].Y)] and m[(z.X + n[v[o].Y].X)][(z.Y + n[v[o].Y].Y)]);
                    if not r then
                      Break;
                  end;
                if r then
                begin
                  k := 0;
                  for f := 0 to 7 do
                    if m[(z.X + n[f].X)][(z.Y + n[f].Y)] then
                    begin
                      u[k] := f;
                      k := (k + 1);
                    end;
                  if (k > 0) then
                  begin
                    if (k = 1) then
                    begin
                      k := 0;
                      j := TPA[u[0]];
                      for f := 0 to 7 do
                        if m[(j.X + n[f].X)][(j.Y + n[f].Y)] then
                          k := (k + 1);
                      r := (k < 3);
                    end else
                    begin
                      for f := 4 to 7 do
                      begin
                        if m[(z.X + n[f].X)][(z.Y + n[f].Y)] then
                        case f of
                          4: r := (m[((z.X + n[f].X) + 1)][(z.Y + n[f].Y)] or m[(z.X + n[f].X)][((z.Y + n[f].Y) + 1)]);
                          5: r := (m[((z.X + n[f].X) - 1)][(z.Y + n[f].Y)] or m[(z.X + n[f].X)][((z.Y + n[f].Y) + 1)]);
                          6: r := (m[((z.X + n[f].X) - 1)][(z.Y + n[f].Y)] or m[(z.X + n[f].X)][((z.Y + n[f].Y) - 1)]);
                          7: r := (m[((z.X + n[f].X) + 1)][(z.Y + n[f].Y)] or m[(z.X + n[f].X)][((z.Y + n[f].Y) - 1)]);
                        end;
                        if not r then
                          Break;
                      end;
                    end;
                    if r then
                    begin
                      m[(TPA[(s[i] - q)].X - b.X1)][(TPA[(s[i] - q)].Y - b.Y1)] := False;
                      pp_Delete(TPA, (s[i] - q));
                      q := (q + 1);
                      d := True;
                      l := (l - 1);
                    end;
                  end;
                end;
              end;
            end;
          end;
        until not d;
        if straighten then
          if (l > 1) then
          begin
            SetLength(p, 8);
            for i := 0 to l do
            begin
              d := False;
              z.X := (TPA[i].X - b.X1);
              z.Y := (TPA[i].Y - b.Y1);
              for c := 0 to 7 do
                p[c] := m[(z.X + n[c].X)][(z.Y + n[c].Y)];
              if not (p[0] or p[1] or p[2] or p[3]) then
              for k := 0 to 3 do
              begin
                case k of
                  0:
                  if ((p[5] and p[7]) and not (p[4] or p[6])) then
                  begin
                    TPA[i].X := (TPA[i].X + 1);
                    m[(z.X + 1)][z.Y] := True;
                    m[z.X][z.Y] := False;
                  end;
                  1:
                  if ((p[6] and p[7]) and not (p[4] or p[5])) then
                  begin
                    TPA[i].Y := (TPA[i].Y + 1);
                    m[z.X][(z.Y + 1)] := True;
                    m[z.X][z.Y] := False;
                  end;
                  2:
                  if ((p[4] and p[6]) and not (p[5] or p[7])) then
                  begin
                    TPA[i].X := (TPA[i].X - 1);
                    m[(z.X - 1)][z.Y] := True;
                    m[z.X][z.Y] := False;
                  end;
                  3:
                  if ((p[4] and p[5]) and not (p[6] or p[7])) then
                  begin
                    TPA[i].Y := (TPA[i].Y - 1);
                    m[z.X][(z.Y - 1)] := True;
                    m[z.X][z.Y] := False;
                  end;
                end;
                if not m[z.X][z.Y] then
                  Break;
              end;
            end;
          end;
      end;
    end else
      SetLength(TPA, 1);
  end;
end;

procedure TPASkeleton(var TPA: TPointArray);
begin
  TPASkeletonEx(TPA, True);
end;

{==============================================================================]
  Explanation: Returns all the color points from bitmap as TPointArray.
               Result is based on Row-by-Row.
[==============================================================================}
function GetBitmapColorTPA(bmp: Integer; color: Integer): TPointArray;
var
  w, h, x, y, r: Integer;
begin
  try
    GetBitmapSize(bmp, w, h);
  except
  end;
  if ((w > 0) and (h > 0)) then
  begin
    SetLength(Result, (w * h));
    for y := 0 to (h - 1) do
      for x := 0 to (w - 1) do
        if (FastGetPixel(bmp, x, y) = color) then
        begin
          Result[r] := Point(x, y);
          Inc(r);
        end;
  end;
  SetLength(Result, r);
end;

procedure DebugBitmap(bmp: Integer);
var
  w, h: Integer;
begin
  GetBitmapSize(bmp, w, h);
  DisplayDebugImgWindow(w, h);
  DrawBitmapDebugImg(bmp);
end;

var
  bmp: Integer;
  TPA: TPointArray;

begin
  ClearDebug;
  bmp := BitmapFromString(300, 149, 'meJztnety6joMhXn/xyy03NpyLZRS4Pg0MwybJI6WLMl24u9np9ZlGSdxYsu3W6HQH67X66iJyWTy/f0dO7qB8vr6WvXCbDaLHUtBncYB+EgZiZasVqu2jogdWkGLzjFYfgBmnM/nzo44Ho+xwywIQxyDDneJjh2sOk8pb7dbS++bzaZcEgfIfepRej961rvdrnTEAHHTPWgM9rX3KYm72+L1etWL4efnp3RERFzn/v5x+cPSNToG+zcloUzE7nx8fOhFgvaF6jVhUHhE/vr60vaOPo6OencFRm9AegpAV4POSIbQdyLE7XQohh73I6qAnghSYXQ2NLi8Z4Hne1Aj7mFVIwypfs8X94SJiqCnQ3gY9LZDeN3tB1Xb8fn5GT0M8QBSgNEXu90uhUiempf3bCioXA43fxEMYLvdli6rYPRFCmE8NT8ej4kkkgsMuWQVK/1153K5RJcivDsYWSjlkgun0ymuXKjrfs/lF4tFrI6oQLuj0YibsKB2lNLJhclkgmrlmkh5F+mm2Ww26ss6/3A12CyXS5HucLy/v6OmHOfzWTajjGDIJeI35INU276nO+v1OtM+Ne4Fhl9KAAxr4/FYNqO8EBSfDvpC5t5wv9/bR2tGlLx+f38hSUdd8wLUmnhG2eH0tNcK8nhfGQW1Eo/ZgCgZTadTVE//WjXUmmM+nwtmlCOQXPYeD4cD9P96YWtDzEVwVk53SheTYdB4rXKCuKsQXS43fw/3yOimcMLD1oaYiOw3enEZUYMUm0PAWDFGN4UTHrY29omgGlK+EKE2BdPJGkg09+TQuPFzs9lQfDG+iYigrWE49oloaKhhcyCg0jVCebAXccRAaZmlIMREjN3dIc5DIZtSufQDtEcaoey0FXHEwEDDQCwTYSwtI351pRucTqciufQGtEca6dzlJOKFh42MIVgmsl6vlQSkGyz78R9Bu4PdTVKOxANLActc9AQkGtTYDZcpaF+0QSl40rnMTJb39/fT6WSgoRTEvCx9oU7FDfYSNxDcgz1vB3egnoxtnrIBJI5ZsnryDqq/6ByPR8Z6JA0xGXWcRPzmAiXx8J3UjAWisin0tfsYRboCeXt7Q4OE7I/H4+VyuV6vD4fDQCbvFFlsvDwCVROiGOzryjRU2ED0gpSVJS8M9FEtqEg0HphCmrhbEipsILw4lcz2Bj3l76CzEuP4n/7ZPQUF5GqK3rsOnpKNaNjsGUrKoy7YvgIN+tum/wQLaRuOeITiguQIqvzn5+d8PndPQR8fH5QTG9G6suLxN7ZCv1glW7oEOj0nHEaE4gb7B115npJAB+NHsHUOpUaDUEjENCPCTsdAAb+1TMu/iENUvvN/GlcmkPr1X0cQnTWCAuOpo1T+PQRGoSQ2aGyy1vqKXh+hK7QZxzx1FkW54eWAOhGTXo7AHO92ZHP3fxT2t22cwiwWi7wWoRHh91wTjxUP0JKDjOChagxSyGkvCWNiWK8s19nEjQJ6SJ7Xtv6GlOAPhwOsUaoAfUaDZzmR4FWjNYAS/MvLS0hzejBtRaRly3MB6qQKmjJRE3YlSTpodT5BRHtAmMDIBXNvbN74Ll3k7W6OO0PZVeL9VMZ5rYhohK0XrT31h0A3LyC29c8goLoQ9eb1N1qSvfKHSP03bVQ3c+33+5talTPxtys8lPsnPlK5e9qiX41RRPUQ4HQ6CW4e8eC83AJelT/GfLlctLuJR6Q+NEUw/aqVmzXY96aGMgwsU77vb4ryrlIb6H1g7niWwUN2LDuoDrHiohKMo055uHlHfUWljWsl3GzCzVncrdzlNZDNa43UJyyet6lPROm4RlQlesJs0I26ig2ahSFFgutecuF4PPJOnTPDRgezdCi7p+33dDOYTqdl3IUQuwMBeiMF/Xwis5B4qHZHv4nddRxUBWFU6QyB+Doi4hdzIqqd0g/2+z16QnqaaM/ljdMhjkHjqBiodkq+KC3ViIjBzmvjjNIZgy8vL9/f327WyTuhVbNPMoNR5i4plsvl7o/D4fD0k7BhPB5b5ksZgxQ7s9mMF0CgX4qdvnI+n7fbLVv56MTWzwd73cv99Sb9sb9zDNL1pP8nEaJB1GzuQLIkTmwtfbibL7Gs1tfXV/2LM10E/xg8nU50JYke6SLQs4DMZgqkhhmr1Wq/37vfiXsArmZq0IrlXI4IqUcudfPqNEWxgDoNSZxo1s0j3GzCXZ3CS4inAKSDNuIBa6sXBUgBzxik3Igff+TimkOJ+JuwxYyO8alGddydDo0Zsq8hWnQgBTxjsLNttZMC9auUCOX/2ZJGxHIMVg+W7qky8D0k6ldKq0R4eXmB0m8bgwzpxAWHEiHydN3IAg0d6kQMWNB1CqDpN45BytJQtmu9XIgwjhaKjpIUj7jpc6xopfymAGNZdWNxAJ5o4oKjudBh6hsVgzXzlDAo/6/hNxcmkwlPfDcROBwO5/OZ8jGizbu44LxcxMNIDXp2Upq4GSJljrPZbKqJpJTfHEFzZxDuPf1E0qexwHK9JqeIJhJic/xmirZW/hMEiEY8Fsx2K0sLny4hsiiJ3+k3X7SF6vzeTbTz2MQN6ijFnTT7IS1QWdxjp/HuuVFfukP7vEjKByNI8Ih7apS7Ii1iiQwRWyQZUhCKaMfyIKE7i8WisURV77GXmkFskQSw+VV3hmEQA0SyJ3taErsTSMQWSYDlcmkgVP0cnycMYqBwPB5tZM+C2L1BIrZIAiSilVkYjNgGC7p2MZDqlEm0VWyRBNAQsxH/q1GzMBoxUzsvptOptvL1L1aohSjKCKKhahv+U28sI6ljJnhe6M1TPE4FTaWPu/VryMuTi27hcrm4WVtbyQ7398/PT7QwkZXkmSH1Dch1ym638y/SuIMa1xZBlXBtBU/zDLcQkl2wlv0k5PxNtlMzR9E5HA5seR+Bdol64gm3wDOImh0U6KmO9ONEPUAes+47NFOPAvThHB6PUoKhavYUqEC6lFOo47LuOzTTTgUC5ULdySZYNamWOz7u4ZrP5+55++fnZ4CLZG7gw5KUU6jjBP0ag6ZJUYByvmd4SEo5Ev+/c6VBzzgej5CGIkAdJ+jXEsG9Bk8HDobIRfRITzMsMx85lrPgUcagEmiOHuq/Rs9Hge/v7/CooqTZCPFNe9ZAG2o6rXmebN0P6XQ6Vf+GdoSyBvLIHkPWuLC5TWp/YESP9EzlshQIJlOIldIpahCNMIox2kghCJqgn7bahk8VhCjnlYsLLptpeDw5AlWCajOiJ77fb7LIpi9Y8F9K8MvlUh13JZspO56sQe+DTnw3GdntdgYLTR/9ZoR4+oxK5oGxtTWPdUSsVPppEmXHNEpskQA00ndXPOPwDJKi0/vXMmUMCoIueCD+536/l4oQEpx9xqIU7llLKvGUyeJM3tgiUaFn5C59jfUnGzGucF4d90DPRQOpfLOgjEEp6Kvfq8s7fQwKVn6guHOJWO63cr56cwohj/IsKgUxl/tLTvrVz//ZXTzIm+gin7rxwhNm98HNZnN3irblpXa9Xt0dZLFYuIer8R+z2cyF4S47gWe31WHkQr/63dc22MSJZkSE8vlymNCfiHhUBWSeQI0w8qKY3W63wfr9D33/12Mr+hgUfE6jByn+7a/UUmtDfAyu1+vD4eC/0aA2oYzczU7PeEg6T63sxyBxXSIvu04E7+Y9I+RZlP3OHHVEySJwiaZ7RuVtXmOnQF+hJPWBjB1quM2R6N28Z6D3QRElIY+j9l+FVKUIiq9GiEdvNLalr5YvY7DfSBUqgaB7bPOLWgh0F5JIW1v6GHR3eY7KrGih9Ok2R2UMtgPdB6Wc0j1WuNuNe9S0KRdfIZWFpzn9Jl7GYL/JYgxGoVouEpKFf4JJ/6YvVWWF6E7D5qiMwXbsn0Xp7qLjWSTW2bZTB/oxjv24D/Z+6XUIdBlRy26AO+XdxEfj5YkNPMUo4tDXg0mtKAhJOdDmqNwH25G9D+73e+NDZLRpzNHfhPgxmv4dc8hj8GnvBsNCFtBlDGyeI2i+9C/R9J1BIvNB+pIAyCzR5ggfg55rnXuM71klUrqMN/1D1VMD0gpajsWOgQd9Czxklp4FceU5uomAJUZyQCkPiqfFrv5/Rqu+0MMw7mUls50XKPRomzuNa5Lzgpd473mqrOt/hcIoN0GPxLiXlcw2rpD//f2FKtxKhZ0U2vsmsqNt2uJpwls3Sw8prId13dHNjv7mcePxGGqCIqKVNuw7fka4vpYVzeOLXXiQno52CiHu6GbNEJFLg9jCyDCfz90zoXvws9wI44nncWOyoNkntLMIcUc3a4mIYoFcr1f3kNmbT3URlfRsiQq8Dlimr7QiMdlCKILVP4i4KQzlSKx8MdbzkbaQwmudWaYvUk39prNZTAORk2opxE60g8lk4uZKjW+kUVM2ejaiF49l+uzTtaReWhojWJm8Dn2hryVoFpBxs2saMVQ9y1Ly1nEXQ0jz3JFaH/729hY7lVaevp2hQL5ExJQKVc+yqgLaXwSSIvDHeSd2Hs+4TpSqQoZmJ+U0NSwVAHs7S9pOiMtUNNlcArPTDiYKxgpA7hLHZmWa2bFuj1hu74ICM4vKEmMFIHexeH19XS6X6/X6eDyKF2FOVjTBwyX1sosSoTbGCkDuZKnKa1elAK5/hKdjhrgaGjXeeUBhxw5WBWMFIHchSL0PSQd6EfU2xuNx7CQagFKIHaw86BHG4R4hd3Te39+HUD2bNzcUPDVSAyiX2MHKg/ZmoDtokUwd17x6gkrkISoiHpXctSivrf3QAa+xg5UHHQV5ues9/dAKehiLHaw8xoPC2F0hC9w8YrA/CcbkItCjsbtCFkDLF2MHKwyjcEGgR2N3hSzYbDaD/Ukw9twFejR2V8gC6JtL7GCFYRz4GOjR2F0hC6CtoLGDlcd4UKAbb0VyLCQOVCg4drDygEPQ+ht9uLtC+pxOpyH/JMAhWMZgQZ6Bj8Fb2utFw90V0gd6Nxg7WBUmk0kZg4WIlDF4I4+Lt7e3cF/0D7JpLvIviEP/Tt15IHW+EBfshRdRvCEXveVyGe6ukD70MTifz2MHqwXxQ6GUO6LgIZXDCxlBH4M9ONbKQ4JjEDpCsZAv9HXLjDPF8sJsDFJ8jYIL+BcygjgGRWZDiWMzAP2O7lSFXwpDgDgG7Q/vsMdzSrW4r07BxT0WkoU4BqWKlifOarWyGQ6dFQw0nBbSpIzBOj8/P27+q1q2xT8T1/NbSBDiGCx1hDQoA7BwI4/B2GH2liede//+uVCnjMHo3BfqWB5zUEgHYjmL2GEWCn2mcwCWdVOFgirlJlgoxKWMwUIhOmUAFgpxKWOwUIhOGYCFQnQeFy2vVqvY4fzDf9uFdCM=');
  TPA := GetBitmapColorTPA(bmp, 0);
  DrawTPABitmap(bmp, TPA, 0);
  DebugBitmap(bmp);
  TPASkeleton(TPA);
  Wait(DELAY);
  DrawTPABitmap(bmp, TPA, 255);
  DebugBitmap(bmp);
end.