Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- // Original algorithms by slacky, optimized by Janilabo
- const
- FLOODFILL_8WAY = True; // Fills TPA bounds (polygon outlines)
- FLOODFILL_COLOR = 65535; // ..with this color.
- type
- TFloodFill = (ff4Way, ff8Way);
- procedure __TPAFloodFillEx(var store: array of TBoolArray; skip: array of TBoolArray; X, Y, W, H: Integer; method: TFloodFill; area: TBox);
- begin
- if ((X > -1) and (Y > -1) and (X < W) and (Y < H) and (X >= area.X1) and (Y >= area.Y1) and (X <= area.X2) and (Y <= area.Y2)) then
- if not skip[X][Y] then
- if not store[X][Y] then
- begin
- store[X][Y] := True;
- __TPAFloodFillEx(store, skip, (X - 1), Y, W, H, method, area);
- __TPAFloodFillEx(store, skip, (X + 1), Y, W, H, method, area);
- __TPAFloodFillEx(store, skip, X, (Y - 1), W, H, method, area);
- __TPAFloodFillEx(store, skip, X, (Y + 1), W, H, method, area);
- if (method = ff8Way) then
- begin
- __TPAFloodFillEx(store, skip, (X - 1), (Y - 1), W, H, method, area);
- __TPAFloodFillEx(store, skip, (X + 1), (Y + 1), W, H, method, area);
- __TPAFloodFillEx(store, skip, (X + 1), (Y - 1), W, H, method, area);
- __TPAFloodFillEx(store, skip, (X - 1), (Y + 1), W, H, method, area);
- end;
- end;
- end;
- {==============================================================================]
- Explanation: !
- [==============================================================================}
- function TPAFloodFillEx(TPA: TPointArray; start: TPoint; method: TFloodFill; area: TBox): TPointArray;
- var
- i, l, r, X, Y, W, H: Integer;
- b: TBox;
- store, skip: array of TBoolArray;
- o: Boolean;
- begin
- l := Length(TPA);
- if (l > 0) then
- begin
- b := IntToBox(TPA[0].X, TPA[0].Y, TPA[0].X, TPA[0].Y);
- o := ((start.X = TPA[0].X) and (start.Y = TPA[0].Y));
- if (l > 1) then
- for i := 1 to (l - 1) do
- begin
- if not o then
- o := ((start.X = TPA[i].X) and (start.Y = TPA[i].Y));
- if (TPA[i].X < b.X1) then
- b.X1 := TPA[i].X
- else
- if (TPA[i].X > b.X2) then
- b.X2 := TPA[i].X;
- if (TPA[i].Y < b.Y1) then
- b.Y1 := TPA[i].Y
- else
- if (TPA[i].Y > b.Y2) then
- b.Y2 := TPA[i].Y;
- end;
- if (b.X2 < area.X2) then
- b.X2 := area.X2;
- if (b.Y2 < area.Y2) then
- b.Y2 := area.Y2;
- if ((start.X >= area.X1) and (start.Y >= area.Y1) and (start.X <= area.X2) and (start.Y <= area.Y2)) then
- begin
- W := ((b.X2 - b.X1) + 1);
- H := ((b.Y2 - b.Y1) + 1);
- SetLength(store, W);
- SetLength(skip, W);
- for i := 0 to (W - 1) do
- begin
- SetLength(skip[i], H);
- SetLength(store[i], H);
- end;
- if o then
- begin
- for X := 0 to (W - 1) do
- for Y := 0 to (H - 1) do
- skip[X][Y] := True;
- for i := 0 to (l - 1) do
- skip[(TPA[i].X - b.X1)][(TPA[i].Y - b.Y1)] := False;
- end else
- for i := 0 to (l - 1) do
- skip[(TPA[i].X - b.X1)][(TPA[i].Y - b.Y1)] := True;
- __TPAFloodFillEx(store, skip, (start.X - b.X1), (start.Y - b.Y1), W, H, method, area);
- SetLength(skip, 0);
- SetLength(Result, (W * H));
- for Y := 0 to (H - 1) do
- for X := 0 to (W - 1) do
- if store[X][Y] then
- begin
- Result[r] := Point((X + b.X1), (Y + b.Y1));
- Inc(r);
- end;
- end;
- end;
- SetLength(Result, r);
- end;
- //******* DIRTY EXAMPLE BELLOW: *******//
- procedure SetPixels(bmp: Integer; TPA: TPointArray; color: Integer);
- var
- a, z, w, h: Integer;
- begin
- z := High(TPA);
- if (z > -1) then
- begin
- GetBitmapSize(bmp, w, h);
- for a := 0 to z do
- if ((TPA[a].X >= 0) and (TPA[a].Y >= 0) and (TPA[a].X < w) and (TPA[a].Y < h)) then
- FastSetPixel(bmp, TPA[a].X, TPA[a].Y, color);
- end;
- end;
- 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 Setup;
- var
- shape, TPA: TPointArray;
- bmp, w, h, t: Integer;
- pt: TPoint;
- begin
- bmp := BitmapFromString(490, 361, 'meJzt21mSKzkOBdHc/6ajPmSm' +
- '0ouRwQG4APz8dlcKBD1ZyjbrbQMAAAAAAAAAAAAAAAAAAAAAAAAAA' +
- 'AAAAAAAAAAAAAAAqPsD1qNq5GNcNZHDC1UjH7Oqrzp3HAAVGGdG1T' +
- 'Dgnpn7AKiA1xv5uGfmPgAq4PVGPu6ZuQ+ACni9kY97Zu4DoAJeb+T' +
- 'jnpn7AKiA1xv5uGfmPgAq4PVGPu6ZuQ+ACni9kY97Zu4DoAJeb+Tj' +
- 'npn7AKiA1xv5uGfmPgAq4PVGPu6ZuQ+ACni9kY97Zu4DoAJeb+Tjn' +
- 'pn7AKiA1xv5uGfmPgAq4PVGPu6ZuQ+ACni9kY97Zu4DoAJeb+Tjnp' +
- 'n7AKiA1xv5uGfmPgAq4PVGPu6ZuQ+ACni9kY97Zu4DoAJeb+Tjnpn' +
- '7AKiA1xv5uGfmPgAq4PVGPu6ZuQ+ACni9kY97Zu4DoAJeb+Tjnpn7' +
- 'AKiA1xv5uGfmPgAq4PVGPu6ZuQ+ACni9kY97Zu4DoAJeb+Tjnpn7A' +
- 'KiA1xv5uGfmPgAq4PVGPu6ZuQ+ACni9kY97Zu4DpPRnxfugrXi9E6' +
- 'DqHfdp3QeIzizpdt4rOWE8mOweovCL95L3Sk64D+Y+QDjr4lz3k90' +
- 'ZT6Jz8CjWtbfuJ7tzn8R9AH3KaSnPdpwz68dFpFyO8mzHOV0+WmQA' +
- 'TfrlXNGcPPfHRaHZRgvNyd0X5T6AFKk2ZlE4VLVfKykKAUyncCj31' +
- 'bkP4E4hAzNehzVeY7Jb60DV+aoWHMBRkbavWB7feKVFbvAUVWetWn' +
- 'AAe5XbvrJ6J7zeq1H1UbKqBQewRN6PFq2I13sdqn6Uo2rBAQyQd4e' +
- '5S+P1no6qO4SuWnCApSh80KwF8npPRNWDglYtOMAi5D3X4D55vaeg' +
- '6rliVS04wHQUvk73bnm9B1H1OlGqFhxgIgq30bFnXu9uVG1Dv2rBA' +
- 'WahcGOvFs7r3YeqjSlXLTjAOAp31Lh8Xu+3qNqRZtWCA4ygcBGPF8' +
- 'Hr3Y6qRahVfeQ+QDcKV3NzI7zejahajU7VR+4DdODLiayrq+H1fkT' +
- 'VskSqvhrMcYC3KFzf8Y54ve9RtT73qq9GchzgFSKP4vh1hdf7ClVH' +
- '4Vv11TyOA7QT2Rja8Xo/oupweL1f0VkX3nK5uxCdUHVcInenX47Cl' +
- 'jDI+BL1a6HqBNwvUbwf9/1gFsurFA+GqtPwvUrlhIg8GbMLVW6Gqp' +
- 'NxvFDZiog8JZtrlc2GqlPyulbNkIg8MYPL1SyHqhNzuVzBlog8vdV' +
- 'XLBgPVadnf8VqORF5EUsvWq0fqi7C+KKliiLyUtZdt1RCVF2K5XVL' +
- 'RUXk1ZR6vb0HgZGCrzeR17Ti3nVCouqabO5dJC3+uixrxdWLhETVZ' +
- 'dlcvUJaRF7c9AAUWqLq4gwCUKiLyJH49fYdA47Sv958RcE2OwP3nK' +
- 'gaW4H/XwOR4yPl6+04AxQkfr2JHL9m9UDV0LGuB8fM+OsSO7OSoGr' +
- 'oWJeEQucunw5NaV5vl0+HJl5vVMDrjXySvd5EjivjbVA11Kxog86h' +
- 'htcb+aR5vf9+GH809I3nQdVQsyIP386NPxdRhH69jT8XUfB6owJeb' +
- '+TD640KeL2RT4LXm8ivsJZfI51QtQ7W8mtuJ3Qu4u+H9ywSeL0ToO' +
- 'odXu9k/g68J5LA6x0aVZ/i9c7kGDmb+eD1jouqr/B6p7Frm8384vU' +
- 'Oiqpv8HoncPq1hM384vUOh6of8XpHdxr5xmb+xesdC1W34PUO7bTw' +
- '3X/kMpgaXu9AqLrRitfbxZT5A3k8ftnNnBrZhlHBZ6bvQdzj8ctu5' +
- 'tT0bRhlfTBr/hBazl5zM1cGt2EU8cHcJYhrOXvNzVyJvo3o83do/O' +
- '0uuJkbsbYRa9opqLpD9G1En/+VV1/MSm3mUaxtxJp2EFV3i76N6PO' +
- '3exX5VmkzLWJtI9a0I6h6RPRtRJ+/0avCd//I0sGiiLWNWNN2o+pB' +
- '0bcRff5Hb7+cHP/BdbMFEmsbsabtQNVTRN9G9Pnv9RW++2dXDBZOr' +
- 'G3EmvYtqp4lwTYSHOGo+8vJ8SdMny2ciKuIOPMjqp4oxypynOLXeO' +
- 'RbxrV0i7iKiDPfo+q5cqwixym+xgv//TmzpgotYiERZ75B1dPZF7L' +
- 'i42aF4W7Kl5PdT5syWGgGeVD1DapewT6Pv4PpP3nWD7S3IvLQC5nF' +
- '5umm6lNUvYj9Ko6dzxog+rVO/92PvpCJ7F9vqv6g6nUcX+/tovlZP' +
- 'zyQ6b/yux876wcGZbAHqj6i6qW89nD80FnBR7zZRZFvMbexgs0eqP' +
- 'oXVa/m+3qffu5g8IuCWWfpwLFWsYhZElT9RdWrOSbR8rndwUe53O7' +
- 'f5Y6PWPHDozBbAlVvVG3Fdwkd3bZXoX+/BpFvEfawmvEGqJqqDbhv' +
- 'oGOA9uANEhphNp7yEgzYZ0DVVL2aQgYjA7QE737AUy2/pCs+bvUHa' +
- 'bI/PlVT9Woixx+c4bT27w+0zKmR/UhqG7DkFQBVm32izcdJ0Qlg1h' +
- 'hXwQue1HgYkePbc7x6qjb7XLNPFKFz9duCW9Ds3HESheO7cDw4VZt' +
- '9tOWHKlA7+KJhdGoX+XT7j3bkfmqqtvl0+492JHjq1SM5Bu/+K7ZJ' +
- '3vhq7jvfqNpqBpdPd+G+81NmIxkHrxD5Vq9zhZ1vVL2Y+wDGFHZ+x' +
- 'XKqq9rnDqCzbZExbOisfaPqlUTGsKGz9lMusy0Kft3vzuA83oMsJ7' +
- 'X2japX0plkNam1n/Idb2LwapFv3rs1o7b2zXvzVJ2A2tqvKEw4GLz' +
- 'mqgVHmk5z8xtVLyM40nSamz8lNefb4Dt+KcxoTjWR7OY3seVTdSCy' +
- 'mz8lOOpN7b9zKke+SS52IuXNb5LLp2p9ypu/IjvtffDiexYfr1uI5' +
- 'W9UvYb4eN1CLP+U/szhIt8ibLVDiM1/6M9J1SJCbP5KoMmjRL6F2m' +
- 'qLQJv/iDiq/sAhhmwXaPM3Qg+vKXoSv4JGHmvaEMI1cCNo1UcJjqA' +
- 'mx0r/DrwneiHizOJyrDR01Uc5TiElwUqjFx53clkJVhq96lOZzqIg' +
- 'dB5pvpyEHl5Q6B7SVH2U70S+gu4zWeE5TqEj6D6TVX2U9Vxewu0zZ' +
- 'eGZzqIg3D5TVn0q9+mMBarlWHiIsRslO46vQHnkrvqowhnNhFhmhc' +
- 'KznstFiGVWqPqozkkNiC+zTuG5T2dMfJl1qj5V7bzraMZzmrfakNN' +
- 'VOKMNzWBqVn1U9uDTqW2ycuGlDruU2iYrV31U/PgTiWySvDeZu0hA' +
- 'ZJNUfYU9TOFb1FXeZW+28tknompxLGQK+zXetM1tsocpqFocm5nCZ' +
- 'o33bXOPX2xjCqrWx37GrcuMtvuwmXFUrY91jZu4w5awua9HbGkcVe' +
- 'tjb+P6dtieNHf0FhsbR9UhsMNBHcUS9moscBBVh8BWBxG2IFY6iKp' +
- 'DYMmDSFoQex5E1VGw+RFsTxP3MoLtRcG/OkewOk1UPYLVRUHnI1id' +
- 'JqoeweoC4bK6sTpZXE03VhcIX1S6sTdZVN2NvQVC593Ymyyq7sbeY' +
- 'uG++vBEKONq+lB1LNxXN1Yni6vpxuoC4bJG/P3wngX/41JGUHUgXN' +
- 'MgUhfEjQyi6hC4pnF8XVHDdYyjan1c0CxsUgd3MQubFMftzELqOri' +
- 'IWahaGbczEX9viuAWJqJqWdzLdKzUHVcwHSvVxKVMx9cVdyx/OqoW' +
- 'xI0swmIdsfxFWKwUrmMdduuFza/DbqVwF+vw96YXdr4OVevgIlZjw' +
- '/bY+WpsWAG3YICvK8bYtgGqVsD+bZC6JVZtg6odsXxLbNsGe7bEtl' +
- '2wdnv8vbka67VH1cbYtiOWvwiLdcTyzbBnX3xdWYF9+qJqA6xXBKl' +
- 'PxCZFUPU67FYK1zEFa5TCdazAVgXx9+YgtieIqqdjmbJIvRt7k0XV' +
- 's7BGcXxd6cC6xFH1OBYYBTfVjl1FwU11Y3WxcF8t2FIs3FcflhYOf' +
- '28+YjnhUPVb7CouUr/CWuKi6kYsKjq+rhyxkOio+hH7SYOr/GIVaX' +
- 'CVN9hMJqT+wRIyoepT7CQf/t6sfPasqHqHbSRW9nLLHrwCLveDPaR' +
- 'X8OtKtfMWVLDqo9DHDz28sVKphz5p6OGNlap6J/TB+ZfvW0XWFfqM' +
- 'VP1WzXVFP/Xfv7zHiSH9xqKfjqo7VNtYgsP+HXhPFEbWjSU4F1V3q' +
- '7OxBMc8dh79RJZSLi3Bcah6RIWl5Tjd7zVVuLUVMi0tx0Goelzipa' +
- 'U52vEg1N4i5Ve7NGeh6j4pq97JdLTTs+S+vhHHvNNsKf1Zkt3XRIm' +
- 'rPsp0tKubSn+Jr1TIO9OJqLpFhap3kh3w5sqKXOiVq7ZTbiPZuaj6' +
- 'Sqmqd5Kd9PHuSl3uR8G2k52Rqo8KVr2T78gtJypy12XzzndSqv4qW' +
- '/VRvoM33mbieyfvfOelaqreSXn89mvN1MBV2wmO9lbKU1N18ap3su' +
- '7h1bmi90DbO1k3QNVBz7JC4oW8PVrEPMj7VOI9UDW+Eq+l49KjpEL' +
- 'e9xJvg6rxkXs5fbcvmw1tN8q9FqrGlvqvy4/uA0pVRN6vpN8PVaPC' +
- 'ukbO6F4UeXeosCWqRoWlDbZhX9dV2+lvapYKu6Lq4oqsbjwSm9Joe' +
- '4oiS6PqyoqsceIxF7VH3hMV2R5VV1ZnmXNPOrFDl7xzXzpVD/40qg' +
- '6hznmn9zPS5FXbS+/C/rfJS+Kj7VB1nap36px0W/N9rCMYy9hufps' +
- 'SX33iox1RdZGqd0oddlt23lfZGGT22HbuzhMf7RRVV6h6p85Jv9Yd' +
- 'ubEcmwEeq07cedZz3aDqV9PmUOSYv5Zebks8cwd41fa6MaRkPdcNq' +
- 'l4xhrIix9xZfb+PqQ9+emPY9x/R+F+LKOWhHlF1y5BpFDnmkcHB7y' +
- 'vq+PTxsK9+4Ksx9GU91yOq3srcfpFjnrI5+1V+7Z8+ve3H2aJLeah' +
- 'GVJ216qMKZ7xidsWnOd1/9Lq2Tz9l8OeoSXmoRlSdteqdCme8MrGW' +
- 'vo87zd6g7dOpJv5Md/lO1I6qt6RV71Q44w3747eXvC7s03kW/XwXK' +
- 'Q/VjqorBNC9c3EdG1i35JsPnXiQ8WEMPsvGzJKUdGxg3ZJvPnTiQc' +
- 'aHMfgsLzPbEvN2A0v3fPO53ZNPH8Pyc5dalZSAtxtYuuebz+2efPo' +
- 'Ylp9rb1E/jkJ0vmk05j7AIlRN1SGuFTuv7q7yRSv8oqERVTei6uja' +
- 'r6/yRVc+e0RU3aLy2dOg83t8RYmIqu9RdRotl1j2rssePDqqvlH24' +
- 'Pm0XGXZ6y578Oio+kbZg6dE56dqnjoNqj5V89S53V9ozRuveepMqP' +
- 'qo5qlzu7nTmtdd89TJUPVOzVNXcHWzNW+85qnzoepfNU9dBJ1//P3' +
- 'wngWjqPqDqnM7vdyCN17wyIlR9UfBI1dzvOJql85XlHyomqqLoPNS' +
- '5y2Cqkudt7Lfiy5173xFSYyqi5y3uN+7LnXvpQ5bDVV7DwIjfwfeE' +
- '1koddiCqBrpETnyoWrkVrPwj4JHLoKqSx25JiKvduoKqLraqaupXP' +
- 'hH2YMnRtVlD14EhW98RUmHqjeqTo3Cv9hAGlT9xQayIvIvlpAGVX+' +
- 'xhJQofIc9JEDVO+whGQo/xTZCo+pTbCMTCj/FQkKj6lMsJA2+nNxg' +
- 'J0FR9Q12kgCF32MzEVH1PTYTHYW3YDmxUHULlhMakbdgP7FQdQv2E' +
- 'xeFt2NFUVB1O1YUEYW/wqJCoOpXWFQ4FN6BXYmj6g7sKhYi78O6lF' +
- 'F1H9YVBYV3Y2myqLobSwuBwsexOjVUPY7ViaPwKdihFKqegh3K4sv' +
- 'JXKxRAVXPxRrVUPgi7NMRVS/CPkVQ+FIs1gVVL8ViFRC5AXZrjKoN' +
- 'sFsFpL4au7VH1auxWxHH1LmRudiqPapeja3qOK2dq5mCfXqh6nXYp' +
- 'xpqX4RlOqLqRVimJmqfjjW6o+rpWKMsap+IHYqg6onYobjT2rmsDq' +
- 'xOB1XPwur0Ufs49qaGqsext0CofQQb00TVI9hYLHxp6cauZFF1N3Y' +
- 'VDrV3YFHiqLoDi4qL2l9hRSFQ9SusKDRqb8R+AqHqRuwngdPaudAd' +
- '1hILVbdgLTlQ+z12EhFV32MnyVD7FRYSF1VfYSH58KXlFHsIjapPs' +
- 'YeUqH2HJSRA1TssITdq/yp+/Eyo+qv48Ssg9Y0vKulQ9UbVZZB65b' +
- 'NnRdWVz14NqZc9e2JUXfbs1VS+6+K/5olVvlaqrqP4RRc/flbFr7X' +
- '48esoftF8UUmp+J1SdRHcMhvIhztlAxXwr2k2kA93ygaK4JZJPR8u' +
- 'lKor4Io3lpAOF7qxhAK44o0vKulwmxtVF8D9frCHTLjND/aQm++/o' +
- 'P8u+E5i/+mYS6clnUnsPx0GvO73KvJ7BvOs+wiYoerdPOs+Ao5idb' +
- '60f1JPg6qPI035aZDicrn3H+rV//RfHHih6tPPnXFKCLG/2e5PnNj' +
- '/1afTeQ5UPWU2iHu8+hAfN/dXgNSjo2qqLsLsZu0rovOyqJqqK7C5' +
- 'WamE6Dw9qqbqCgxuNlA/IYbEI6r+FWJIdLDsfN1HAL+oGhWs/gpB5' +
- 'LBH1ShiXYqB/rpEMlSNChalSORwRNWoYEWNRA5fVI0KpgdJ5HBH1a' +
- 'hgbpNEDgVUjSImlknkEEHVqGBWnEQOHVSNCqb0yV+XkELVqGC8TyK' +
- 'HGqpGBYOJEjkEUTWK6A6VyCGLqlHBeOcrpgJGUDUq6MuVyKGMqlFB' +
- 'R7FEDnFUjQreRsv/MAh9VI0i2rslckRB1aigMV0iRyBUjQpa6iVyx' +
- 'ELVqOBV52ZTASOoGhU8NkzkCIeqUcRNyfx1iaCoGhVclUzkiIuqUc' +
- 'FpzESO0KgaFRx7JnJER9WoYJc0kSMBqkYRv2ETOXKgalTwd+A9ETC' +
- 'KqlEBnSMfqkYFRI58qBoVEDnyoWoUQeTIh6oBAAAAAAAAAAAAAB3+' +
- 'A9qZhKc=');
- GetBitmapSize(bmp, w, h);
- TPA := GetBitmapColorTPA(bmp, 0);
- pt := MiddleTPA(TPA);
- t := GetSystemTime;
- if FLOODFILL_8WAY then
- shape := TPAFloodFillEx(TPA, pt, ff8Way, IntToBox(0, 0, (w - 1), (h - 1)))
- else
- shape := TPAFloodFillEx(TPA, pt, ff4Way, IntToBox(0, 0, (w - 1), (h - 1)));
- WriteLn('TPAFloodFill() finished in ' + IntToStr(GetSystemTime - t) + ' ms.');
- SetPixels(bmp, shape, FLOODFILL_COLOR);
- DisplayDebugImgWindow(w, h);
- DrawBitmapDebugImg(bmp);
- FreeBitmap(bmp);
- SetLength(TPA, 0);
- end;
- begin
- Setup;
- end.
Advertisement
Add Comment
Please, Sign In to add comment