This week only. Pastebin PRO Accounts Christmas Special! Don't miss out!Want more features on Pastebin? Sign Up, it's FREE!
Guest

Untitled

By: a guest on Dec 17th, 2013  |  syntax: Delphi  |  size: 5.33 KB  |  views: 36  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. {Quick Corner Detection: algoryth & code by SKy Scripter, translated to Pascal by beginner5
  2. http://villavu.com/forum/showthread.php?t=80290                                         }
  3. library corn_det;
  4.  
  5. {$mode objfpc}{$H+}
  6.  
  7. {$macro on}
  8. {$define callconv:=
  9.     {$IFDEF WINDOWS}{$IFDEF CPU32}cdecl;{$ELSE}{$ENDIF}{$ENDIF}
  10.     {$IFDEF LINUX}{$IFDEF CPU32}cdecl;{$ELSE}{$ENDIF}{$ENDIF}
  11. }
  12.  
  13. uses
  14.   classes, sysutils, math
  15.   { you can add units after this };
  16.  
  17. var
  18.   OldMemoryManager: TMemoryManager;
  19.   memisset: Boolean = False;
  20.  const
  21.   clWhite = 16777215;
  22.   clBlack = 0;
  23.   clRed   = 255;
  24.   clGreen = 32768;
  25.   clBlue  = 16711680;
  26.   clPurple = 8388736;
  27.   clYellow = 65535;
  28.  
  29.  
  30. type TPointArray = array of TPoint;
  31. type TIntegerArray = array of integer;
  32. type T2dIntegerArray = array of TIntegerArray;
  33. type TBooleanArray = array of boolean;
  34. type T2sBooleanArray = array of TBooleanArray;
  35. type TStaticIntegerArray = array [0..7] of integer;
  36.  
  37.  const
  38.     cx:TStaticIntegerArray = ( 1, 0, -1, 0, 1, 1, -1, -1 );
  39.     cy:TStaticIntegerArray = ( 0, 1, 0, -1, -1, 1, 1, -1 );
  40. var
  41.  w,h,sx,sy : integer;
  42.  cn ,bc :T2sBooleanArray;
  43.  adist, filldist, maxd : double;
  44.  es,ee : TPoint;
  45.  
  46.  
  47.  
  48. procedure ffillc(x,y : integer;var C :t2dIntegerArray);
  49. var
  50.   i ,a,b: integer;
  51.   sqrX ,sqrY : double;
  52. begin
  53.   bc[y][x] := True;
  54.   for i:=0 to 7 do
  55.   begin
  56.     if (not bc[y+cy[i]][x+cx[i]] )and cn[y+cy[i]][x+cx[i]] then
  57.     begin
  58.       a := x + cx[i];
  59.       b := y + cy[i];
  60.       sqrX := Sqr(a - sx);
  61.       sqrY := Sqr(b - sy);
  62.       adist := (sqrX + sqrY);
  63.       if adist < filldist then
  64.         ffillc(a,b,c)
  65.       else
  66.       begin
  67.         if (es.x =0) and (es.y = 0) then
  68.           es := Point(a,b);
  69.         sqrX := Sqr(es.x - a);
  70.         sqrY := Sqr(es.y - b);
  71.         adist := (sqrX + sqrY);
  72.         if maxd < adist then
  73.         begin
  74.           maxd := adist;
  75.           ee := Point(a,b);
  76.         end;
  77.       end;
  78.     end;
  79.   end;
  80. end;
  81.  
  82. procedure edgefill(x,y :integer; var C :t2dIntegerArray);
  83. var i,j,a,b,xx,yy:integer;
  84. begin
  85.  
  86.   c[y][x] := clBlue;
  87.   cn[y][x] := True;
  88.   for i:=0 to 7 do
  89.   begin
  90.     xx := x + cx[i];
  91.     yy := y + cy[i];
  92.     if ((a<w)and(b<h)) and (c[yy][xx] < clwhite) and (not cn[yy][xx]) then
  93.       for j:=0 to 7 do
  94.         if (c[yy+cy[j]][xx+cx[j]] = clwhite) then
  95.            edgefill(a, b, c);
  96.   end;
  97. end;
  98.  
  99. procedure Init(var TPA :TPointArray; var C :t2dIntegerArray);
  100. var
  101.   x,y,i,j,TPAcounter,tw,th: integer;
  102.   angle1 ,angle2 ,realangle : double;
  103.   p :TPoint;
  104. begin
  105.   TPAcounter := 0;
  106.  
  107.   for y:= 1 to h-1 do
  108.     for x:= 1 to w-1 do
  109.       if (c[y][x] < clwhite) then
  110.       begin
  111.         edgefill(x,y, c);
  112.         break;
  113.       end;
  114.  
  115.   filldist := Sqr(15); // distance to scan
  116.   tw := Length(cn[0]);
  117.   th := Length(cn);
  118.   for y:= 1 to h-2 do
  119.     for x:= 1 to w-2 do
  120.       if cn[y][x] then
  121.       begin
  122.         SetLength(bc,0,0);
  123.         SetLength(bc,th,tw);
  124.  
  125.         sx := x;
  126.         sy := y;
  127.         es := Point(0,0);
  128.         ee := Point(0,0);
  129.         maxd := 0;
  130.         ffillc(x,y ,c);
  131.  
  132.         angle1 := RadToDeg( ArcTan2(y-ee.y , x - ee.x));
  133.         angle2 := RadToDeg( ArcTan2(y-es.y , x - es.x));
  134.         realangle := Abs(angle2 - angle1);
  135.         realangle := Abs(realangle - 180);
  136.         if realangle > 42 then
  137.         begin
  138.           c[y][x] := clred;
  139.           inc(TPAcounter);
  140.           SetLength(TPA,TPAcounter);
  141.           p.x := x;
  142.           p.y := y;
  143.           TPA[TPAcounter-1] := p;
  144.         end;
  145.       end;
  146. end;
  147.  
  148.  
  149.  
  150. procedure SetupCD( c : T2dIntegerArray; var resTPA : TPointArray); callconv
  151. var i,j : integer;
  152. begin
  153.   w := Length(c[0]);
  154.   h := Length(c);
  155.   //writeln(Length(resTPA));
  156.   SetLength(cn,h,w);
  157.   //for i:= 0 to h-1 do //cleaning cn on start
  158.   //  for j:= 0 to w-1 do
  159.   //    cn[i][j] := FALSE;
  160.  
  161.   SetLength(bc,h,w);
  162.   Init(resTPA,c);
  163. end;
  164.  
  165.  
  166.  
  167.  
  168.  
  169.  
  170.  
  171.  
  172. function GetPluginABIVersion: Integer; callconv export;
  173. begin
  174.   Result := 2;
  175. end;
  176.  
  177. procedure SetPluginMemManager(MemMgr : TMemoryManager); callconv export;
  178. begin
  179.   if memisset then
  180.     exit;
  181.   GetMemoryManager(OldMemoryManager);
  182.   SetMemoryManager(MemMgr);
  183.   memisset := true;
  184. end;
  185.  
  186. procedure OnDetach; callconv export;
  187. begin
  188.   SetMemoryManager(OldMemoryManager);
  189.   writeln('Quick Corner Detection: Detach');
  190. end;
  191.  
  192. procedure OnAttach; callconv export;
  193. begin
  194.   writeln('Quick Corner Detection: algoryth & code by SKy Scripter, translation to Pascal and plugin by beginner5');
  195.   writeln('http://villavu.com/forum/showthread.php?t=80290');
  196. end;
  197.  
  198. function GetTypeCount(): Integer; callconv export;
  199. begin
  200.   Result := 0;
  201. end;
  202.  
  203. function GetTypeInfo(x: Integer; var sType, sTypeDef: PChar): integer; callconv export;
  204. begin
  205.  
  206.   result := -1;
  207. end;
  208.  
  209. function GetFunctionCount(): Integer; callconv export;
  210. begin
  211.   Result :=1;
  212. end;
  213.  
  214. function GetFunctionInfo(x: Integer; var ProcAddr: Pointer; var ProcDef: PChar): Integer; callconv export;
  215. begin
  216.   case x of
  217.     0: begin
  218.         ProcAddr := @SetupCD;
  219.         StrPCopy(ProcDef, 'procedure CornerDetection(BitmapAreaColors : T2dIntegerArray;var resTPA :TPointArray);');
  220.        end;
  221.     else
  222.       x := -1;
  223.   end;
  224.  
  225.   Result := x;
  226. end;
  227.  
  228. exports GetPluginABIVersion;
  229. exports SetPluginMemManager;
  230. exports GetTypeCount;
  231. exports GetTypeInfo;
  232. exports GetFunctionCount;
  233. exports GetFunctionInfo;
  234. exports OnDetach;
  235. exports OnAttach;
  236.  
  237. begin
  238. end.
clone this paste RAW Paste Data