Janilabo

nearby

Sep 15th, 2013
63
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Pascal 9.80 KB | None | 0 0
  1. {$loadlib pumbaa.dll}
  2.  
  3. // TPADistribute contains these 2 commands:
  4. // procedure TPADistribute(TPA: TPointArray; dist: Extended; var output: T2DPointArray);
  5. // procedure TPADistributeEx(TPA: TPointArray; minDist, maxDist: Extended; var output: T2DPointArray);
  6.  
  7. const
  8.   DIST = 5.25;
  9.   DRAW = 25;
  10.  
  11. {==============================================================================]
  12.   Explanation: Returns all the color points from bitmap as TPointArray.
  13.                Result is based on Row-by-Row.
  14. [==============================================================================}
  15. function GetBitmapColorTPA(bmp: Integer; color: Integer): TPointArray;
  16. var
  17.   w, h, x, y, r: Integer;
  18. begin
  19.   try
  20.     GetBitmapSize(bmp, w, h);
  21.   except
  22.   end;
  23.   if ((w > 0) and (h > 0)) then
  24.   begin
  25.     SetLength(Result, (w * h));
  26.     for y := 0 to (h - 1) do
  27.       for x := 0 to (w - 1) do
  28.         if (FastGetPixel(bmp, x, y) = color) then
  29.         begin
  30.           Result[r] := Point(x, y);
  31.           Inc(r);
  32.         end;
  33.   end;
  34.   SetLength(Result, r);
  35. end;
  36.  
  37. procedure Test;
  38. var
  39.   TPA: TPointArray;
  40.   bmp, t, w, h, i: Integer;
  41. begin
  42.   ClearDebug;
  43.   //bmp := BitmapFromString(297, 166, 'meJztnVt3m8wOhlmxOWN8ilM3X7ObNKvtRf//7/OWmZQSYPAAc0J+n+Wb1vEgydK8jAzD5aKTYv+idTwAwG3Kx/fN4TXfofoAsMfm+LY5vAVBUOz/59oWnUDHgc+Uxx/BZ1xbpAceOo7ZQwsOw9hbUFl5Tjdfiv13ZqV3FXEWOs5j9nCOwzBuT796Cyrf/hf0Yd9CjXRFfKFO8Zg9nOM2jLLc601RgqTQvpGKDBSRTMSXWHpcVwGWcR5GcdBW1W9PP+Wl92TZQkVk8i2Qibi3qdtrFddVgDn8DCOVG71axy12L7TqlKlDVXpfkvxozUh1hqM3UHeBf1J+V6sAc3gbxnz3rXXcZiUOkBQna0aqI2wT80nrrQER/1t6fkm5LBPk9vs1dXiCt2HMyuf6oMXh9dIpxqWUXku+g7aCD4l4HXOvpPzjS1n+KsAtfoaRkk2lyqRG+lR93RnjoqzgNZ7MJ8xWAa7wNoxp8USvUZnZTtT8mOSP3ZGpCoxa3ktLvkcp+D+P/Cg9ZqsAV3gbRvWEHCDODrKRjRrfhKapmfLdxAcpZ7MKcIuHYSTN3RxeR6ak1Mhs+9wcfHN8E28ZMr6F0O6Z8v3Jo0rKe9X8YkXQOa0CHOJnGKlYdJVe0BE+MXK+/c+E5V10edHyqFfNL+YFndkqwBXehnGOSX1G/tMIMowktX5rjpE30ajdbY+KU1fNL1YEXYv9PqwC3OJnGDWem9XQmL0uG9U+vdrdpRt5o4LOaRXgEG/DSDWS5CcthjURv0JSrrb/vzD4E4l2L1q01Lwl6IHuNOa0CnCIt2G8nkrlR12G1aSbc7rpEVPZimkmevsqQ35J1FygN5P1Wu5qFeAcP8NYrRz1111l4XXY3nLIyvaKaSZCuE1odxeZmn+8q0/T2awC3OJtGEnytBumQrH/rjG8QrgNzSEtZGou0KXpnFYBDvE5jCSd2g1TQeMdiNaKTjCg5gItms5jFeAcb8OYZPYythdd4XXrRZeZms5jFeAcn8PoSvIEYurQEWGXXvQyU9N5rAKc43MYZb0CGfSRh1W4Wsf06r67DrN1lI8aNkp3c8PrWrgHmO7U8lcBPuBtGKNkO2pAcoR0qv54q/rWYfp32FJxwDjbayg9/yRPIDR9gqw7n0xmfiOe4HMY1Wukpll6gkoBk+aBwpHDzozwWOFuHXdAxAVNKR97LJpYJswtPFYBzvE2jGFchPFm7IBZ+TXJhy7epmFVxqFDk+bOjC2NMFa4a4SCD4h4UOn4BCmvEZo+ofQYrAJ8wNswXksvUiqTFsO/XKiU8/78R0tsqRwmVMQ/Rz6XXk1Xxy/jpbzJSKc4rAKc43MY11E2yrbGmEO3ySteKXe9+nHe5RNCtScIdw0p+E0Rr481auQ5ms5jFeAcb8M41qomA0m1e/p9c5ehm7YpIlR7mnA3Ubn8YFSBz9F0BqsAH/A5jCSgQXX6OtY8QXfAYvdSHt8nDJWVZ9mYw0xW7RbDIi4Ye9H7ZE1nsArwgUWEkWpQqOpAi68Jnb4Gn8uEcmzsLkNdsu11uwzZ9gtdZh6uyc15foKU1yi68+/rWPgqwBMWFEZRgOKDN2uQzqLrDw5vmT4BdYMD0XSaKtw3Dyp0fJqU15Cmq8v6nAN5sgrwgeWG8WEVUfVVffWPxF6FyfWfUdb8M1Hac9z87HIps+cmTeFW1O6Pg1ad/26ItOh4i1rWB5SdwSrAB3iHsThMPAHrJdaxs+jfAlTV7pqWiGvX8S7KvixsFeAbLMOoURTCGXo3gNDurnz3KvhFt4h3mSDri1sF+AmPMOqyYR3lXv1oq1fEu8yX9cWtAvxkoWGsb02Ks/0cM8RrpjF60b6yqyFNNyTrXTxcBSwRr8IYZ0dxGqwFXSGaiS53urjSdP9XAYvAwzBer9tP9yRYk6/d0mKGFpo3F88R8Sa1oFvWdC3GB/6tAiyzlDBSGSpeI1ddZlmYs2QUJN96FbyFfY8YrwJsstAwyu6hENfRWTNjFLWCzxHxJi5cYLgKsA+DMJL915ZC4/pSb+uui7qIN73zQc05rQIcgjB6wvC9kN6q+UJXAb6BMDrnQ8c/S3mwEDVf4irAQxBGMI1FrwL8AWEEAAAAAAAAAAAAAAAAYIhi/+LaBAD6YZyc5eP75vCa79g6CJYL4+TcHN82h7eA3ROyAAMYJ2d5/NG6ysi1RQB8wCA5e23OynO6+dLdm9G+eeCeYZyc29OvXptlO+fYtxDcLbyTU2Zzr2vB9YE1X+wbCe4T3skpbG6tUrenn3LvODySFSwCrslJHtGrJdbF7qXYvwxsv08TS3KvO+kBa/BOzta+cJfKX5lTTZLi9uMyAZgD7+TMyufa4OLwelHepHER3oFFwzg5SZpVHJGReu8gWC6MkzMtnprb5E6Azqh7Hy5DU5N9dwAneCfnHL9q4uwgG9m+R4ANXJOz2L2MfXK6DDqpzrbPzcE3xze33oFFwzs5yR5d3gWduUWMzON55cA+vJNTl1+C5hOc6USaZq36LVcOguXCODlnrl57oTF74wbtA6NgnJxkRpKf9HtXXTXX3ce49hqAm/BOTlp4JvnRgHfndNMzX/W2mADohXFyVr906HctqH5DCapppPtWVj7ftgzcPbyTk2YVE67dpNh/t+MgWC68kzPJHx15x23HDKAdxsmZZEbUXB3TDoLlwjs5Xc0qArHUNeogWC68k3P4MbJd6CMPq3C1junVfXcdZusoHzVslO7MeQcWDePkjJLtKNdoFqKpoP54y8F1mP4dVvXh7HG2R+mBXngnp7oZNU3vah9X6yRonBiHI4c15B1YNIyTUzwUe6x3Wfk1yYduNmw9fl0GHZqmNRN+AQbwTs6rd5GSJS2Gr7RRidj+/MecX4ABvJNzHWUTXAuu58BD2zop3tmR777hImogg3FyTvNLMKDFu6ffA7ux9WLIQbBceCfnOkyDqt06zcHugMXupTy+TxgqK8+GfAQLxbfkNJSf5KboAvX+FNIlSnctS0iaFbdiG8CEa2DpeJKc2fa692DvZkq6fBQHuulmlJRN12b6JTDhFOCB8+S0lqUPq4gcJH+vv/5Xor8Kk+s/o6z5Z2IpuhSnAA+cJGeznJ1THMYtV4eJl7ATPlgKvJNz/vlzTejTlAIYwDI5dXm0jnJcugn0wjg561vp42w/2S86bRYv194AVnBNzjg7iratFlx7A1hxD8kZZ4c43dOcMOG6Vp/9Agy4n+QkTxXv6aBQhHHh2l5wR9xPcsru+RX3fbi2Dtw195CcdL4dXuW+aHjHxDWwdJCcAAAAAAAAAAAAADwo9i+uTQDg7igf3zeH13yH6gPAHpvj2+bwFuDhPgBYpDz+aP2U79oiAPjQW1BZeU43X7oboNk3DwCWbE+/egtKtj2FfQuBz6D/NhlZQcku2CYptG8k8BP03+YgCqrVQtmefspLD0+TBFfQf5sMRYxerTPJYvdCpxADe1yT6iWe7bME7IP+2xxamy9dqmKUVVyTpBh6FhJgQ29Bof82n6x8ruNWHF4vyjuhofTuAfTfDEETl0qVyUhRfdyRFZQ0JdB/UyAtnuoN0KZBy73eJziQbtp3B5hAfNHov+llTtHVxNlBNrJ9j4BG0H8zAQVQ8eGYN6EVX7Z9bg6+Ob6h9BiA/psJqFh0lV7QET4xMh61vHTQfzOBrqL7CHX+WK/46NshSa3fcusmmAz6byaY2VqRhPpjcd36f2jfEkH/zQQU0iQ/zYlqL6Kl3N0stC5JsCC0pAT6by3oPJxmJC2xbZJuzummZ57sjT/wFvTfDFGdBuivu6A6wQgqjeu+Rat1134DVdB/MwRNRLqiOopi/92160AJvd87+m81FAe9sVUEt5MsAvTfDJFkRk411XEdADAE+m/mcCV5H6Gu+jCuYwCkoP9mDtljwmTQRx5W4Wod06v77jrM1lE+aljfHuwOatB/M0eUbEdG7JHmq/rjrepbh+nfYZWevBlUj4ZH6XkL+m/mUK+RmmbpCSoFTILGqi0cOaxdp4Eq6L8ZQjx5dmxYsvIrrbuHh1UZhw5NmmvNWTAW9N/McS29SKlMWgy3oVTKeX/+Y81NMA3038yxjrJpYYmzoXseFS97yHff7upHnMWB/pshRkW1HRP5ieLu6ffArcq92PQaKIL+mzkoGlVMJgpfd8Bi91Ie3ycMlZVn2ZjAFei/WYBqUISo9zyhC81FrZjQeaPifcoDZNvrvc+9N3MBy6D/ZhNRgML3mzVIU2L9Qdm+i5NxGAQgQP/NFQ+riKqPivG6NK7OSFdhcv1nlDX/TPRJJnxBvTTLGbgF/TefKQ7jeik3vjJsE+cNc75H9N8sMH9xVxNC73wC/Tc/mfZ1dFlHOdfWMRvQf/OH+jrzONtPjiSt6cTLtTdACfTf3ELLZzGnIYb3DPpvroizQ5zuKRQTfvRB0d0J6L+ZhspQ8YIHqtMwLlzbCyyB/ptNZBfEiosiXFsHbKCr3NB/mwBFLLyei/67CgJ1dyeg/waAZdB/A8Ah6L8B4Bz03wBwDvpvADgE/TcAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAArvwfp05eIw==');
  44.   bmp := BitmapFromString(493, 288, 'meJzt3QuS4zYMBcDc/9KTSjaxXWNbosQPCLL7BCLw8DJVm539+QEAAAAAAAAAAAAAABjtr/9FfwgAl/31SfRHAVDqY43rc4AQx51cI/plAOvr1+HKHGCAATWuzwH6GVnj+hyguZAa1+QArUTVuCYHaEKNw54c4zJ0+GAmQAgnubCeVS0wT+bAYK5yH9WVLCcnTIwBnOfO6rcvHh+ZHl21CpiYraFtHjbPhhnSQ/NciRbi8ZFboxVZojch+cjpcZvkMJ60vGt+ica7KlGBabnNGcw5PcGARFxroDkHKAmQlMsdbNox2j5k507HmLYSlTYsw+X2M3lJTvhJAPPw4y5AXqcdrskBplXY4ZocYE6XalyTA0zlaoercYCpqHGA7HQ4wAIUOHnJKvyocXKSWHhQ46QjtPDKRZDLaWLllt04BxIp7HDRZStugUTUOLxzCyRyqcall324AlK42uECzDDyBiXUOBOSOiinxpmN4MElapypyB5cpcYLbf78McQP7lHjp0xgAAmklQ1zosNPGUJvl0JoBRzYMyfO55g5dHW1wG2BAzuHxNV8Yxpd3eluW+C7zRPiXj4ykH7ud7dF8ImE/KisNwqknzt9bRF8JyGvNn/+K+3Ryf2+tgv+JTCUEIZO6g/QLlpJOkOBoZAw9NDqAO2iXt55SgslhKG5VqdnI63kHamccEoemmt1dzbSUOqpSgjHRKKt+ou7J/rdCeQdrHhwQCraqj+3GtGvzyfRYAWDbwSjoZpDayV6BolNPlip4KOaYMjGu8p5NhE9gxVMO1iR4JeKqpCQz5qMtFL0DNYx22ylgnc1qRCPb5pM1TomMdWEBYNfaiIhIccaztYiYs0zZPHgXX0qxONAw/HaQqxJ5iwhvKtPhXgcazhhKwg0w6jlhG8EY4AmQ7aCWOEDFxWI1eoGXWWU8LELDIRrdYZOMsQMkxcYCFd/hk4yypzDlxAYT4cnNe38JQTG0+EZzbwCCYHxdHg6M29BSCCKAs9l5nVM+2GwPB2eyOQbmfOrYAc6PAtLAb7R4SnYC3BAh8/PdoBjWmJ+FgScUhEz859agOw0OUBq/ggDIDtNzi+SAOl8bHInvCFJgLzc7+a+BUAYIBGXu6eSAhcJyMLNbuVqgQsGZOFUl1dT4PocIErD9lbmACP1K3BlDtDVmAJX5gA9jO9wTQ7QkBoHSE2NA6SmxgFSU+MAqalxgNTUOEBqahwgNTUOkJoaZ3nfIieNrCGoxR0OI3wLnkCykv6F/Vn0u5/yfjnHbJZ3S677atRbiX73P1J/PMdsll8W3vjtKqsU/e7ah0d/PieslVdrL/1e2utFv1uNL85aeVh+7/fSXm+BV8c+gQPWyqvll14T+BoLvDr2CRywVl4tv/SawNdY4NWxT+CAtR7Y56UPyy+9JvA1Fnh17BM4YK0fbfXYVzssvSbz90S/WI0vzlrf7fbeV/ssvSb55aJf+Z+V3sI7a32156t/2ertNflPlJP1XsQra33Y9uHvdnt1zRWkGNSq7+IPa/3xf85/sc9LH1Y9h5p3pXggm+9UsPllvRjUhDzRM3e2805lm29W2n59zhM9dk/b7rRJttcYBd+ssXQ5X962O22S7TVGwbHs65bzHey50CbZXmYaLEzOd7DtQmWbHdTnXNTnt+1CZZsd1Odc1FPYc5uyzQ7qcy7qKWy7TcFmBzU5l/ZE9lylYLODmpyLeiJ7blO22YScb2LPbco2m5DzTWy4TTXOPoR5Bxu2lhpnK5K8gw0rS4ezFUnexG5b1uEAAAAAAAAAAAAAAAAAMAN/oQ8gL381GyA1NQ6Ql9+VBJCX33oHkJoaB8jr6DdQa3KA6alxgLxOO1yTA8xMjQPkVdjhmhxgQpc6XJMDzEaNE+5GCDuJngRcJu3MoGEPV4qeBFwm7cygYQ9Xip4E64vOeEfRoyVSdPqeoifB4qIDPkL0jIkRnbun6Emwsuh0DxI9ZmJE5+4pehKsLDrdg0SPmRjRuXuKngSLiw54d9EDJkx09J6iJ8E/ll/TgCSPFz1UgkUH8Cl6Epvac2tNEjuD6EEyhegYPkVP4pqM3/xq8/X90XwII0UPj4lEh/EpehIXJP3sPyzxXdeZtBU9KmYUncqn6ElckPTLrfLYsPncEz0e5hWdzafoSZRK+uW2WW7wrI5FD4MEokP6FD2JUhm/fPw2U4zlWMjQVhogw0RH9Sl6EqXSffn4VWaZTCFzY3LjI/pN9CRK5fry8XtMNJxCJnbPei+a1uCIHoiexLmM3z9md+nGcomJ3bDko6Y1OKIHoidxIuMTeq+sUPQYqpjYVUs+anIjw3ksehInMj6h98oKRY+hioldsuSj5jcsmaeiJ3Ei4xN6r6xQ9BjuM7RySz4qi95pLBc9iXPpvn/M4k5Fj+E+Qyu05KMS6RrFS6IncS7d949Z3KnoMdwUPbY0c1vyUbl0SuAN0ZMoku7jR24w12RORU8uzeiWfFQunRJ4Q/QkiqT7+JEbzDWZYw2fvPz0lnxULjUZayt6EkUyfvzIJSYay7Hm7117huu9KJfb6WouehJFkn78yD0mGss3XZ+56gzXe1EiV0PVT/QkiuT9+JGrzDKTj4a9cclJLvacLC6FtqvoSZxb+/sbin5olcEPXG+e671ofiUzHyN6Eueyf//PkHVHP7FW1NOWGekmOZnKhfvsLHoSRVJ//MPOGzwV+7QFBrtVWiZx82I7iJ5EqdevzfXlD3surtwMT5vhG+7ZOTlRWt5znehJ7MWy6EeKBqs854aiJ7EXi6ArJz9Sow5uIHoSe7ECenPyw7Qu4/uiJ7Edk6c3Jz9G526+IHoSQGOufowB/VwoehJAY3Ne/YSfBDCt2Zrcj5QAV01Vm2oc4IZ5alONA9w2Q3OqcYAa4c2pxgEqxZanGgeoF1KeJQWuyQHKjWzOSx2uzAEKzdzhmhxgEmocIDsdDpCaGgfITocDZKfDAbLT4QDZ6XCA7HQ4QHY6HGABChwAAAAAAAAAAAAAAAAAAAAAAAAAAAAAgDX4DfwAefn3sADy8q/TQisuiPG+/SPjcghXuSDGO+hwOYSrXBCDnXa4HMIljoiGCiu6iei3wiycCa0MK3ARhVfOhFbGVLd8vjIHfvxhE+107mzh/M0o+MOx0FCfthbLDwyEBydDW02rWiC/MhMe3A7NNapqOTxiLDy4IHpo0dYSeMRkeHBH9FDd1uJ3wmR4cEr0UFfVsnfCcHjlmmjudqhkr5DJ8Mo10VZNomSvkLHwykHRUH2cBK+EmfDKQdFKkywJXgkD4ZWDopVWWZK6A8bCOzfV1WMsO4yuYZYKRb94KMPhGzdVzwwfGo5i+VmVMyWOtbqpPQPTcHqbTNIQrhInStTnZM+oNJnbhvPc/PmXiBP00+q+9jy9bR9+lSxBc63Oyunt+eobBAnaqr8p1/ew4ZPvkSJopeaaHOA3Wz22hvxAvdY97RK5TGygRu/SdowUkhm4TY0zA5mB23Q4MxAbqKHDCSc5UEl7E0uEoJIOJ5wIQQ2lTTihgtvKK1qB049oQQ0/ZhNO9qCS8yGWGgfITocDZKfDAQAAAAAAAAAAAAAAAAAAAAAAAAAAAIBV/Q25PS+O');
  45.   GetBitmapSize(bmp, w, h);
  46.   DisplayDebugImgWindow(w, h);
  47.   DrawBitmapDebugImg(bmp);
  48.   TPA := GetBitmapColorTPA(bmp, 0);
  49.   t := GetSystemTime;
  50.   pp_TPASortByNearbyPoints(TPA, DIST, dm_SquaredEuclidean); // Adding 0.5 to adapt the behaviour from SplitTPA distance check..
  51.   WriteLn('TPASortByNearbyPoints() finished in ' + IntToStr(GetSystemTime - t) + ' ms.');
  52.   h := High(TPA);
  53.   for i := 0 to h do
  54.   begin
  55.     FastSetPixel(bmp, TPA[i].X, TPA[i].Y, 255);
  56.     if ((i mod DRAW) = 0) then
  57.       DrawBitmapDebugImg(bmp);
  58.   end;
  59.   SetLength(TPA, 0);
  60.   FreeBitmap(bmp);
  61. end;
  62.  
  63. begin
  64.   Test;
  65. end.
Advertisement
Add Comment
Please, Sign In to add comment