Services & ResourcesWolfram ForumsMathGroup Archive

[Date Index] [Thread Index] [Author Index]

Re: Two programming challenges

• To: mathgroup at smc.vnet.net
• Subject: [mg14455] Re: [mg14374] Two programming challenges
• From: Jurgen Tischer <jtischer at col2.telecom.com.co>
• Date: Wed, 21 Oct 1998 03:32:52 -0400
• Organization: Universidad del Valle
• References: <199810150429.AAA18352@smc.vnet.net.>
• Sender: owner-wri-mathgroup at wolfram.com

Ok Will,
here is a hopefully working answer to your second challenge. That was
quite hard, you know. the main problem was to get the algorithm to not
build up traps, that is bays that can not be filled. If you run the
notebook as is, it should produce an example. There is a parameter 0 <=
param <= 1  which to a certain extent controls the overall shape of the
monster, close to 0 will give something more compact. It is well
possible that the algorithm runs into a trap, in that case it will
Abort after printing "kaputt".

Jurgen


Notebook[{
Cell[BoxData[
    RowBox[{"<<", 
      StyleBox[
        RowBox[{"DiscreteMath", 
          StyleBox["`",
            "MB"], "ComputationalGeometry", 
          StyleBox["`",
            "MB"]}]]}]], "Input"],

Cell[BoxData[
    \(Off[Precision::"\<mnprec\>"]\)], "Input"],

Cell[BoxData[
    \(ang[a_, b_] := ArcTan[Sequence@@\((b - a)\)]\)], "Input"],

Cell[BoxData[
    \(ang[{b_, a_, c_}] := Mod[ang[a, c] - ang[a, b], 2  \[Pi]]\)],
"Input"],

Cell[BoxData[
    \(angN[{b_, a_, c_}] := Round[\(5\ ang[{b, a, c}]\)\/\[Pi]]\)],
"Input"],

Cell[BoxData[
    \(generateTile[{a_, b_}, n_] := 
      Module[{\[Alpha] = N[ang[a, b] + n\ \[Pi]\/5], x}, 
        x = a + {Cos[\[Alpha]], Sin[\[Alpha]]}; {b + x - a, x}]\)],
"Input"],

Cell[BoxData[
    \(posMod[n_, l_] := Mod[n - 1, l] + 1\)], "Input"],

Cell[BoxData[
    \(randomElement[li_] := li[\([Random[Integer, {1,
Length[li]}]]\)]\)], 
  "Input"],

Cell[BoxData[
    \(randomElement1[li_] := randomElement[li]\)], "Input"],

Cell[BoxData[
    \(minPositions[li_] := Position[li, Min[li]]\)], "Input"],

Cell[BoxData[
    \(maxPositions[li_] := Position[li, Max[li]]\)], "Input"],

Cell[BoxData[
    \(randomMinPosition[li_] :=
First[randomElement[minPositions[li]]]\)], 
  "Input"],

Cell[BoxData[
    \(randomMaxPosition[li_] :=
First[randomElement[maxPositions[li]]]\)], 
  "Input"],

Cell[BoxData[
    \(steepness[{a_, b__, c_}] := Min[\(ang[{a, #, c}]&\)/@{b}]\)],
"Input"],

Cell[BoxData[
    \(\(steepness[{a_, b_}] = \[Pi]; \)\)], "Input"],

Cell[BoxData[
    \(\(minAng[{a_, b_}] = 100; \)\)], "Input"],

Cell[BoxData[
    \(minAng[li_] := Min[angN/@Partition[li, 3, 1]]\)], "Input"],

Cell[BoxData[
    \(take1[li_, {n1_, n2_}] := 
      If[n1 > n2, Join[Take[li, {n1, \(-1\)}], Take[li, {1, n2}]], 
        Take[li, {n1, n2}]]\)], "Input"],

Cell[BoxData[
    \(posToUse[li_, angs_, ch_, param_] := 
      Random[Integer, {2, Length[li] - 1}] /; Length[li] ==
Length[ch]\)], 
  "Input"],

Cell[BoxData[
    \(\(posToUse[li_, angs_, ch_, param_] := 
      Module[{liParts, angsParts, pos}, \n\t\t
        liParts = 
          \(take1[li, #]&\)/@Partition[Append[ch, ch[\([1]\)]], 2, 1];
\t\t\n
        \t\tIf[Random[] < param, \n\t\t\t\t\t\t\t
          pos = randomMinPosition[steepness/@liParts], \n\t\t\t\t\t\t\t
          pos = randomMaxPosition[Length/@liParts]]; \n\t\t
        angsParts = 
          \(take1[angs, #]&\)/@Partition[Append[ch, ch[\([1]\)]], 2, 1];
\n
        \t\ posMod[\ 
          ch[\([pos]\)] + randomMinPosition[angsParts[\([pos]\)]] - 1, 
          Length[li]]]\t\t\t\t\)\)], "Input"],

Cell[BoxData[
    \(nicheCheck[angs_] := 
      Module[{li = Apply[Plus, Partition[angs, 2, 1], 1], m, pos},
\n\t\t
        m = Min[li]; \n\t\tpos = randomMinPosition[li]; \n\t\t
        Which[\n\t\t\tm < 5, Print["\<kaputt\>"]; Abort[], \n\t\t\t
          m == 5, {1, pos}, \n\t\t\tm == 6, {2, pos}, \n\t\t\ \ 
          m > 6, {3, pos}]]\)], "Input"],

Cell[BoxData[
    \(angToUse[{n1_, n2_}] := 
      With[{nList = Range[Max[5 - n2, 1], Min[n1, 4]]}, \n\t\t
        randomElement1[nList]]\)], "Input"],

Cell[BoxData[
    \(addTile1[{boundary_, angs_}, pos_] := \n\t
      Module[{angs1 = Drop[angs, {pos, pos + 1}], l = Length[angs]},
\n\t\t\t
        angs1[\([pos - 1]\)] -= angs[\([pos + 1]\)]; \n\t\t\t
        angs1[\([posMod[pos, l - 2]]\)] -= angs[\([pos]\)]; \n
        \t\t{{Drop[boundary, {pos, pos + 1}], angs1}, 
          boundary[\([\(posMod[#, l]&\)/@\((pos + {\(-1\), 0, 1,
2})\)]\)]}]
        \)], "Input"],

Cell[BoxData[
    \(addTile2[{boundary_, angs_}, pos_] := 
      Module[{pos1 = pos, boundary1 = boundary, angs1 = angs, 
          l = Length[angs]}, \n\t\t
        Switch[pos1, \n\t\t\t\t1, \(pos1++\), \n\t\t\t\tl, \(pos1--\),
\n
          \ \ \ \ \ \ \ \ \ 2 | \((l - 1)\), pos1, \n\t\t\t\ \ _, 
          If[Random[] <  .5, \(pos1++\)]]; \n\t
        boundary1[\([pos1]\)] = 
          boundary[\([pos1 - 1]\)] + boundary[\([pos1 + 1]\)] - 
            boundary[\([pos1]\)]; \n\ \ \ \ \ 
        angs1[\([pos1 - 1]\)] -= 5 - angs[\([pos1]\)]; \n\t\ \ \ 
        angs1[\([pos1 + 1]\)] -= 5 - angs[\([pos1]\)]; \n\t\ \ \ 
        angs1[\([pos1]\)] = 10 - angs[\([pos1]\)]; 
        \n{{boundary1, angs1}, 
          Append[boundary1[\([pos1 + {\(-1\), 0, 1}]\)], 
            boundary[\([pos1]\)]]}]\)], "Input"],

Cell[BoxData[
    \(addTile[{boundary_, angs_}, param_:  .5] := \n\t
      Module[{ch = ConvexHull[boundary], boundary1, angs1, pos, a, b,
fi, 
          l = Length[boundary], tile}, \n\t
        boundary1 = RotateLeft[boundary, First[ch] - 1]; \n\t\t
        angs1 = RotateLeft[angs, First[ch] - 1]; \n\t\t
        ch = ConvexHull[boundary1]; \n\t\t{n, pos} = nicheCheck[angs1];
\n\t
        Switch[n, \n\t\t\t1, Return[addTile1[{boundary1, angs1}, pos]],
\n
          \ \ \ \ \ \ \ 2, Return[addTile2[{boundary1, angs1}, pos]]];
\t\t\t
        \n\tpos = posToUse[boundary1, angs1, ch, param]; \n\t
        While[pos == 1 || pos == l, \n\t\ \ \ \ \ 
          boundary1 = RotateLeft[boundary1, ch[\([2]\)] - 1]; \n\t\t\t
          angs1 = RotateLeft[angs1, ch[\([2]\)] - 1]; \n\t\ \ \ \ \ 
          ch = ConvexHull[boundary1]; \n\t\ \ \ \ \ 
          pos = posToUse[boundary1, angs1, ch, param]]; \n\t\t
        fi = angToUse[angs1[\([pos + {0, \(-1\)}]\)]]; \n
        \t\t{a, b} = generateTile[boundary1[\([pos + {0, \(-1\)}]\)],
fi]; \n
        \ttile = Join[{a, b}, boundary1[\([pos + {0, \(-1\)}]\)]]; \n\t
        Which[\n\t\t\tfi == angs1[\([pos]\)], \n\t\t\t\t\t
          boundary1[\([pos]\)] = a; \n\t\t\t\t\t
          angs1[\([pos + {\(-1\), 1}]\)] -= {5 - fi, 5 - fi};
\n\t\t\t\t\t
          angs1[\([pos]\)] = 10 - fi, \n\t\t\tangs1[\([pos - 1]\)] == 5
- fi, 
          \n\t\t\t\t\tboundary1[\([pos - 1]\)] = b; \n\t\t\t\t\t
          angs1[\([pos + {0, \(-2\)}]\)] -= {fi, fi}; \n\t\t\t\t\t
          angs1[\([pos - 1]\)] = 5 + fi, \n\t\t\tTrue, \n\t\t\t\t\t
          boundary1 = Release[Insert[boundary1, Hold[Sequence[a, b]],
pos]]; 
          \n\t\t\t\t\tangs1[\([pos + {0, \(-1\)}]\)] -= {fi, 5 - fi}; \n
          \t\t\t\t\t
          angs1 = Release[
              Insert[angs1, Hold[Sequence[10 - fi, 5 + fi]], pos]]];
\n\t\t
        Chop[{{boundary1, angs1}, tile}]]\)], "Input"],

Cell[BoxData[
    \(sh[{a_, b_}] := 
      Show[Graphics[{a, {Thickness[ .01], Line[Append[b,
b[\([1]\)]]]}}], 
        AspectRatio -> Automatic]\)], "Input"],

Cell[BoxData[
    \(shl[li_] := Show[Graphics[Line[li]], AspectRatio -> Automatic]\)],

  "Input"],

Cell["\<\
This is to have a look at the result. There is a parameter param which
can \
have values between 0 and 1 and sets a random switch between two
strategies: \
fill the next into the longest bay or fill it into the deepest bay.\
\>", "Text"],

Cell[BoxData[
    \(li = {{0, 0}, {1, 0}, {1 + 1\/4\ \((1 + \ at 5)\), 
            1\/2\ \ at \(1\/2\ \((5 - \ at 5)\)\)}, {1\/4\ \((1 + \ at 5)\), 
            1\/2\ \ at \(1\/2\ \((5 - \ at 5)\)\)}} // N; \n
    angs1 = angN/@
        Partition[li[\([Flatten[{\(-1\), Range[Length[li]], 1}]]\)], 3,
1]; \n
    sol = {li, {Hue[0], Polygon[li]}}; \n$n = 1; \nparam = 0.25; 
    \n{a, b} = addTile[{li, angs1}, param]; \n
    sol = {Append[sol[\([2]\)], {Hue[Sin[$n]], Polygon[b]}],
a[\([1]\)]}; \n
    Do[With[{c = addTile[a, param]}, a = c[\([1]\)]; 
        sol = {Append[
              sol[\([1]\)], {Hue[Sin[\($n++\)]], Polygon[c[\([2]\)]]}], 
            c[\([1, 1]\)]}], {100}]; sh[sol]\)], "Input"] },
FrontEndVersion->"Microsoft Windows 3.0", ScreenRectangle->{{0, 1024},
{0, 740}}, WindowToolbars->"EditBar",
WindowSize->{470, 598},
WindowMargins->{{2, Automatic}, {Automatic, 5}} ]



(***************************************************************)

Will Self wrote:
> 
> Mathematica Programming Challenge 1
> 
> Given several points in the plane, connect these points by line
> segments, resulting in a connected polygonal line that passes through
> all the points and does not intersect itself.  Arrange it so that the
> line seems to spiral inwards.
> 
> Mathematica Programming Challenge 2
> 
> There are two rhombi, named after Penrose, which you can use to tile the
> plane.  They both have the same edge length; the narrower rhombus has a
> tip angle of Pi/5, and the wider rhombus has a tip angle of 2Pi/5.
> Write a program that produces random (whatever that means) tesselations
> of (part of) the plane, using these two shapes.
> 
> Will Self

• References:
  • Two programming challenges
    • From: wself@viking.emcmt.edu (Will Self)