Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
1998
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 1998

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

Search the Archive

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



  • Prev by Date: Re: Adding equations
  • Next by Date: RE: fractals
  • Previous by thread: Re: Two programming challenges
  • Next by thread: Re: Two programming challenges