Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

I'm designing a small demonstration that helps to visualize the reason behind shaping an electrode that is used to probe a surface:

tip[rg_] := {EdgeForm[Thin], FaceForm[White],Polygon[{{0, 4}, {0, 0.2}, 
  {0.5 - rg, 0}, {0.5 + rg, 0}, {1, 0.2}, {1, 4}}], 
  FaceForm[Black], Rectangle[{0.4, 0}, {0.6, 1}]};
box = {EdgeForm[Thin], FaceForm[Blue], Rectangle[{-3, -1}, {3, 3}]};
surface = {FaceForm[Green],
   Polygon@Partition[Flatten@{{-3, -1}, {3, -1},
       Table[
        BezierFunction[{{-3, 0}, {0, 1}, {2, -1}, {3, 0}}][x], {x, 1, 
         0, -0.05}]}, 2]};
Manipulate[Graphics[{box, surface, GeometricTransformation[
    GeometricTransformation[tip[rg], TranslationTransform[{a, b}]],
    RotationTransform[t Degree, 0.5 + {a, b}]]}, 
  PlotRange -> {{-3, 3.1}, {-1.1, 3}}],
 {{a, 0, "Left/Right"}, -3, 2}, {{b, 2, "Up/Down"}, -0.5, 
  2}, {{t, 0, "UME tilt"}, -15, 
  15}, {{rg, 0.4, "UME sharpness"}, 0.11, 0.5}]

Mathematica graphics

I would like the demonstration to show some type of visualization (perhaps just a big red "CRASH warning" text) whenever the tip graphic is positioned below the surface graphic, but I do not know how to construct a conditional statement that compares the multiple points in each graphic object.

I'm happy to alter the structure of either the surface or tip objects if that makes the problem easier to solve.

share|improve this question
1  
Have you already tried the methods shown in (9405) and (11146)? Where did you have trouble with them? –  Mr.Wizard Aug 17 '13 at 17:04
    
@Mr.Wizard Ahh these didn't come up in my research - will check them out and report back if there's a problem. –  bobthechemist Aug 17 '13 at 17:13

3 Answers 3

up vote 7 down vote accepted

Here is a method based on image manipulations, which means I pre-suppose a certain pixel resolution with which the crash is detected:

tip[rg_] := {EdgeForm[Thin], FaceForm[White], 
   Polygon[{{0, 4}, {0, 0.2}, {0.5 - rg, 0}, {0.5 + rg, 0}, {1, 
      0.2}, {1, 4}}], FaceForm[Black], 
   Rectangle[{0.4, 0}, {0.6, 1}]};
box = {EdgeForm[Thin], FaceForm[Blue], Rectangle[{-3, -1}, {3, 3}]};
surface = {FaceForm[Green], 
   Polygon@Partition[
     Flatten@{{-3, -1}, {3, -1}, 
       Table[BezierFunction[{{-3, 0}, {0, 1}, {2, -1}, {3, 0}}][
         x], {x, 1, 0, -0.05}]}, 2]};
Manipulate[Column[{
     #,
     If[Max@MorphologicalComponents[Image[#, ImageSize -> 200], .2] > 
       1, "OK", Style["CRASH", Red]]} &@
   Graphics[{box, surface, 
     GeometricTransformation[
      GeometricTransformation[tip[rg], TranslationTransform[{a, b}]], 
      RotationTransform[t Degree, 0.5 + {a, b}]]},
    PlotRange -> {{-3, 3.1}, {-1.1, 3}}
    ]
  ],
 {{a, 0, "Left/Right"}, -3, 2}, {{b, 2, "Up/Down"}, -0.5, 
  2}, {{t, 0, "UME tilt"}, -15, 15}, {{rg, 0.4, "UME sharpness"}, 
  0.11, 0.5}]

crash

The idea is to form a small image of the instantaneous Graphics and count how many connected regions it contains (with a threshold set so that the blue background is a separate region). When that number changes, I detect the crash. The crucial line that does this is this:

Max@MorphologicalComponents[Image[#, ImageSize -> 200], .2]

To make sure that the sides of the plot region don't cause crashes, I would limit the horizontal movement of the tip a little more, but that's something you'll be able to adjust yourself.

share|improve this answer

This works by making an interpolation function in initialization, which represents the surface. Each time the prob is moved, it finds the Euclidean distance between the current tip position and the surface at the x-coordinates at the time.

It checks that this distance is not smaller than some crash tolerance constant value set in the initialization. (This tolerance can also be added as control variable if needed).

This also prevents the crash to occur, by forcing the slider that controls the tip y-position to go back above the surface. Hence it is no possible to hit the surface. It also makes a Beep[] (just in case :).

Manipulate[
 Module[{d, ys},
 ys = surfaceFun[x];
 d = EuclideanDistance[{x, y}, {x, ys}];
 If[y <= ys, y = ys + crashTol]; (*reset slider to stay above surface*)      
  Graphics[
   {
    box,
    surface,
    GeometricTransformation[
     GeometricTransformation[tip[rg], TranslationTransform[{x, y}]],
     RotationTransform[t Degree, 0.5 + {x, y}]],
    Text[If[d <= crashTol, Beep[]; Style["WARNING !!", Red, 18], ""], {x, y}, {0, 1}]
    }, PlotRange -> {{-3, 3.1}, {-1.1, 3}}]
  ],

 {{x, 0, "Left/Right"}, -3, 2, Appearance -> "Labeled"},
 {{y, 2, "Up/Down"}, -0.5, 2, 2 crashTol, Appearance -> "Labeled"},
 {{t, 0, "UME tilt"}, -15, 15, Appearance -> "Labeled"},
 {{rg, 0.4, "UME sharpness"}, 0.11, 0.5, Appearance -> "Labeled"},
 ControlPlacement -> Above,
 ContinuousAction -> True,
 Alignment -> Center,
 ImageMargins -> 5,
 FrameMargins -> 5,
 Paneled -> True,
 Frame -> False,
 AutorunSequencing -> {1},
 Initialization :>
  (
   crashTol = 0.01; (*change as needed*)
   surfaceData = Table[BezierFunction[{{-3, 0}, {0, 1}, {2, -1}, {3, 0}}][x], {x, 
      1, 0, -0.05}];

   surfaceFun = Interpolation[surfaceData];
   tip[rg_] := {
     EdgeForm[Thin], FaceForm[White],
     Polygon[{{0, 4}, {0, 0.2}, {0.5 - rg, 0}, {0.5 + rg, 0}, {1, 
        0.2}, {1, 4}}], FaceForm[Black], Rectangle[{0.4, 0}, {0.6, 1}]
     };

   box = {EdgeForm[Thin], FaceForm[Blue], Rectangle[{-3, -1}, {3, 3}]};

   surface = {FaceForm[Green],
     Polygon@Partition[Flatten@{{-3, -1}, {3, -1}, surfaceData}, 2]}
   )     
 ]

enter image description here

share|improve this answer
    
I think the tip sharpness should affect the collision detection, but it doesn't do that here. –  Jens Aug 17 '13 at 18:44
    
@Jens sure. You are right ofcourse. May be in practice the actual tip will always be the point closest to the surface, regardless of orientation? It depends on the shape of the head of the prob if the bottom is flat or not. if it flat, then yes, the above is not very accurate unless one makes crash tolerance large or the prob head more pointed than shown. Either way, this is meant as an idea to consider. Your image based method is much more precise ofcourse. –  Nasser Aug 17 '13 at 18:52
    
Nice implementation. @Jens is correct, though. One of the key points I'm trying to make with the demonstration is the importance of the tip shape on the ability to avoid a crash. I particularly like the restrictions on the y-axis movement (and wish the actual instrument had such a feature so my students wouldn't be trashing $100 tips so frequently). –  bobthechemist Aug 17 '13 at 21:29

Testing overlapping polygons

One can use the testpoint function from this answer to 9405, which I will call inPolygonQ:

inPolygonQ[poly_?MatrixQ, pt_?VectorQ] := 
  Round[(Total @ Mod[(# - RotateRight[#]) &@ (ArcTan @@ (pt - #) & /@ poly),
   2 Pi, -Pi]/2/Pi)] != 0;

In V8/V9, there is the undocumented function Graphics`Mesh`InPolygonQ which may be used instead (same arguments); it is faster, but there is no guarantee that it will always be around or have the same name.

We can test whether two polygons overlap by running through all vertices until one finds a vertex of one of the polygons that lies in the other polygon. An easy way to write it is

overlapQ[poly1_?MatrixQ, poly2_?MatrixQ] := Or @@ (inPolygonQ[poly1, #] & /@ poly2) || 
   Or @@ (inPolygonQ[poly2, #] & /@ poly1);

This is a little wasteful in that all vertices are tested individually before figuring out whether one of them is inside the other. This is fast enough for this application. Here is another way that tests one point at a time, returning True as soon it finds a vertex inside a polygon.

overlapQ[poly1_?MatrixQ, poly2_?MatrixQ] := If[
  Catch@Fold[(If[inPolygonQ[poly1, #2], Throw[True]]; False) &, , poly2],
  True,
  Catch@Fold[(If[inPolygonQ[poly2, #2], Throw[True]]; False) &, , poly1]]

The speed depends on the order of the vertices and whether the polygons overlap; in this case it's over 5X faster when they overlap (with poly2 == tip) and about the same speed when they don't.

Getting the tip polygon

This is a problem, if you wish to stick to using GeometricTransformation, which can be quite an efficient way to draw graphics. However this application has relatively few computations per update, so speed does not need to be an overriding concern. The problem with GeometricTransformation is that the coordinates of the image seem to be computed in the Front End at the time of rendering. So I don't know how to access those coordinates and use them to determine a "crash" of the tip into the surface.

To solve this problem, I rewrote how the tip was drawn. You do not have to give up the use of RotationTransform and the like, since you can apply TransformationFunctions to a list of points, as well as compose them with Composition (see tipPoly0[translate_, tilt_, rg_] below).

We need the points in the tip in two places, to draw the tip and to check overlap, so computing them once seemed a good idea (see tipPoly = tipPoly0[{a, b}, t, rg]).

Example demonstration

tipPoly0[translate_, tilt_, rg_] := (* translate = {a,b}; tilt = t *)
  Composition[RotationTransform[tilt Degree, 0.5 + translate], 
    TranslationTransform[translate]] @ {
    (* polygon={1,2,..,6} *)
    {0, 0.2}, {0.5 - rg, 0}, {0.5 + rg, 0}, {1, 0.2}, {1, 4}, {0, 4},
    (* rect={7,8,9,10} *)
    {0.4, 0}, {0.6, 0}, {0.6, 1}, {0.4, 1}};
tip[pts_] := GraphicsComplex[pts,
    {EdgeForm[Thin], FaceForm[White], Polygon @ Range[6], 
    FaceForm[Black], Polygon[{7, 8, 9, 10}]}];

inPolygonQ[poly_, pt_] := 
  Round[(Total @  Mod[(# - RotateRight[#]) &@ (ArcTan @@ (pt - #) & /@ poly), 
         2 Pi, -Pi]/2/Pi)] != 0;
overlapQ[poly1_?MatrixQ, poly2_?MatrixQ] := If[
   Catch @ Fold[(If[inPolygonQ[poly1, #2], Throw[True]]; False) &, {}, poly2],
   True,
   Catch @ Fold[(If[inPolygonQ[poly2, #2], Throw[True]]; False) &, {}, poly1]];

box = {EdgeForm[Thin], FaceForm[Blue], Rectangle[{-3, -1}, {3, 3}]};
polypoints = Join[{{-3, -1}, {3, -1}}, 
   Table[BezierFunction[{{-3, 0}, {0, 1}, {2, -1}, {3, 0}}][x], {x, 1, 0, -0.05}]];
surface = {FaceForm[Green], Polygon @ polypoints};

Manipulate[
 With[{tipPoly = tipPoly0[{a, b}, t, rg]},
  Graphics[{box, surface, tip[tipPoly], 
    If[overlapQ[polypoints, tipPoly[[1 ;; 4]]], 
     Text[Style["CRASH warning", Large, Red], 
      Scaled[{0.5, 0.5}], {0, 0}, {3, 1}], {}]}, 
   PlotRange -> {{-3, 3.1}, {-1.1, 3}}]
  ],
 {{a, 0, "Left/Right"}, -3, 2},
 {{b, 0.16, "Up/Down"}, -0.5, 2},
 {{t, 0, "UME tilt"}, -15, 15},
 {{rg, 0.4, "UME sharpness"}, 0.11, 0.5}]

Manipulate animation

share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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