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

Jigsaw Puzzles with Mathematica (Delete Small edges)

By: ThalesFernandes on Jun 30th, 2012  |  syntax: None  |  size: 0.97 KB  |  views: 83  |  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. height = 1;
  2. width  = 1;
  3. DeleteSmallLine[exp_, minLength_] := Module[{lines = exp, len, min, pos, p1, p2, rlz, sides, result},
  4.         lines = lines /. Line[a_List] :> Line@Sort@a // Union;
  5.         len = lines /. Line[{a_, b_}] :> Norm[b-a];
  6.         min = Min@len; pos = Position[len, min];
  7.         If[min > minLength,
  8.                 exp
  9.         ,
  10.                 {p1, p2} = First@First@Extract[lines, pos];
  11.                 sides = N@{{0,0}, {0, height}, {width, 0}, {width, height}};
  12.                 rlz = Which[
  13.                         MemberQ[sides, p1], {p2 -> p1},
  14.                         MemberQ[sides, p2], {p1 -> p2},
  15.                         p1[[1]] == 0 \[Or] p1[[1]] == width \[Or] p1[[2]] == 0 \[Or] p1[[2]] == height , {p2 -> p1},
  16.                         p2[[1]] == 0 \[Or] p2[[1]] == width \[Or] p2[[2]] == 0 \[Or] p2[[2]] == height, {p1 -> p2},
  17.                         True, {p1 -> Mean[{p1, p2}], p2 -> Mean[{p1, p2}]}
  18.                 ];
  19.                 result = exp /. rlz /. Line[a_List] :> Line@Sort@a // Union;
  20.                 result = DeleteCases[result, Line[{a_, a_}]]
  21.         ]
  22. ]
  23. DeleteSmallLines[exp_, minLength_] := FixedPoint[DeleteSmallLine[#, minLength] &, exp, SameTest -> (#1 == #2 &)]
clone this paste RAW Paste Data