1
$\begingroup$

I have a square area with a background hexagonal tiling. When I click on a certain point of the area I want the hexagon placed there to show/hide.

enter image description here

I've implemented it as follows:

  1. Calculate hexagon-center points (vert1, vert2, centerPoints)
  2. Calculate vertices of each hexagon (vertices)
  3. Create hexagons using the vertices (polygons)
  4. ClickPane&Graphics. On click:
    i.$\ $ Check in what polygon is the clicked point (using Element)
    ii. Add or remove it from a list with visible hexagons (activeHexagons)

Manipulate[
 (*Center Points*)
 vert1 = Table[
   r*{3 x, Sqrt[3] y}, {x, 0, Ceiling[a/(3 r)]}, {y, 0, 
    Ceiling[b/(Sqrt[3]*r)]}];
 vert2 = Map[# + {3/2, Sqrt[3]/2}*r &, vert1, {2}];
 centerPoints = Flatten[Join[vert1, vert2], 1];
 vertices = 
  ConstantArray[#, 7] + 
     r*Table[{Cos[θ], Sin[θ]}, {θ, 0, 
        2 π, π/3}] & /@ centerPoints;
 polygons = Polygon /@ vertices[[All, 1 ;; 6]];
 DynamicModule[{activeHexagons = {},
   clickedHexagon,
   pt},
  ClickPane[Framed @ Show[
     Graphics[Dynamic@(Line /@ vertices[[activeHexagons]]), 
      PlotRange -> {{0, a}, {0, b}}, AspectRatio -> Automatic],
     Graphics[Dynamic@(Point /@ centerPoints[[activeHexagons]])]
     ],
   (pt = #;
     clickedHexagon = 
      Flatten[Position[Element[pt, #] & /@ polygons, True]][[1]];
     activeHexagons = If[
       MemberQ[activeHexagons, clickedHexagon],
       DeleteCases[activeHexagons, clickedHexagon],
       AppendTo[activeHexagons, clickedHexagon]]) &]],
 {{a, 7, "Honeycomb width"}, 2, 8},
 {{b, 7, "Honeycomb height"}, 2, 8},
 {{r, 0.2, "Hexagon radius"}, 0.1, 3}]

For areas with many hexagons my code is really slow (with default manipulate parameters >2s delay between mouse-click and displaying the hexagon). How can I make it faster?

(For now resizing the area/hexagon size with Manipulate changes the relative position of the hexagons. Keeping the relative position would be nicer but isn't really important)

$\endgroup$
2
$\begingroup$

Bottleneck here is the part clickedHexagon = Flatten[Position[Element[pt, #] & /@ polygons, True]]. You could use Nearest function for this.

Manipulate[(*Center Points*)
 centerPoints = 
  Flatten[Table[{#, # + {3/2, Sqrt[3]/2}*r} &[r*{3 x, Sqrt[3] y}], {x,
      0, Ceiling[a/(3 r)]}, {y, 0, Ceiling[b/(Sqrt[3]*r)]}], 2];
 nearPoint = Nearest[centerPoints];
 DynamicModule[{activeHexagons = {}, clickedHexagon, pt},
  Row@{DynamicWrapper[Spacer[0], 
     activeHexagons = 
      DeleteDuplicates[(nearPoint /@ activeHexagons)[[All, 1]]]], 
    ClickPane[
     Framed@
      Show[Graphics[{EdgeForm[Black], FaceForm[None], 
         Dynamic@{RegularPolygon[#, r, 6] & /@ activeHexagons, 
           Point[activeHexagons]}}, PlotRange -> {{0, a}, {0, b}}, 
        AspectRatio -> Automatic], ImageSize -> 300], (pt = #;
       clickedHexagon = First[nearPoint[pt]];
       activeHexagons = 
        If[MemberQ[activeHexagons, clickedHexagon], 
         DeleteCases[activeHexagons, clickedHexagon], 
         AppendTo[activeHexagons, clickedHexagon]
         ]) &]}], {{a, 7, "Honeycomb width"}, 2, 
  8}, {{b, 7, "Honeycomb height"}, 2, 8}, {{r, 0.2, "Hexagon radius"},
   0.1, 3}]
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.