Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2005
*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 2005

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

Search the Archive

Re: Hexagonal Spiral

  • To: mathgroup at smc.vnet.net
  • Subject: [mg56929] Re: [mg56872] Hexagonal Spiral
  • From: DrBob <drbob at bigfoot.com>
  • Date: Tue, 10 May 2005 03:42:44 -0400 (EDT)
  • References: <200505090545.BAA13761@smc.vnet.net>
  • Reply-to: drbob at bigfoot.com
  • Sender: owner-wri-mathgroup at wolfram.com

This needs more work to appear properly hexagonal, but it shows primes in Red and other integers in Blue:

Clear[tier, last]
last[tier_] = Rationalize@Fit[Transpose@{Range@
   6, {1, 7, 19, 37, 61, 91}}, {1, tier, tier^2}, tier];
Clear[n, tier]
tier[n_Integer?Positive] = Ceiling[tier /. Last@Solve[n == last@tier, tier]];
Clear@direction
direction[1] = 0;
direction[n_Integer?Positive] := Module[{t = tier@n},
     Pi(1 - 2*((last[t] - n)/(last[t] - last[t - 1])))
     ]
Clear@point
Attributes@point = {Listable};
point[1] := {Red, Text[1, {0, 0}]}
point[n_Integer?
Positive] := Text[n, tier@n{Re@#, Im@#} &[E^(I*direction[n])]]
max = 91; p = PrimePi@max;
Show[Graphics@{Blue, point@
       Range@max, Red, point@Prime@Range@p}, AspectRatio -> Automatic];

Bobby

On Mon, 9 May 2005 01:45:54 -0400 (EDT), zak <chocolatez at gmail.com> wrote:

> Hi
> the purpose of this message is to draw a hexagonal spiral and then
> divide every edge to the suitable numbers of points, then map the
> prime numbers to the all points of the spiral.
> this is motivated by the figure:
> http://www.cut-the-knot.org/ctk/HexMosaic.gif
> in an article in:
> http://www.cut-the-knot.org/ctk/FromLCarrollToArchimedes.shtml
> this project consist of three parts: first: draw a hexagonal spiral by
> using the hexagon function from mathworld HexagonalGrid.nb notebook by
> making multiple hexagons every one bigger than  the previous by one
> unit, the fifth edge of every hexagon is extended by one unit to allow
> the beginning of a new bigger hexagon in a spiral way.
> second: we need to divide the edges of every hexagon to pieces
> according to its position from the center, except the fifth edge, this
> dividing will use the straigth Line equation to determine the
> coordinates of every point inside the edge.
> third: map the prime numbers over the points wich constitute the
> hexagonal spiral.
> you can download the notebook from:
> http://sr2.mytempdir.com/25353
>
> the program may seem messy and convoluted but it may be usefull for
> studying the straight line equation, or other fun something.
> welcome to any critic, suggestions, ideas, improvements.
>
> (* The hexagon generator function is from mathworld in the notebook
> HexagonalGrid.nb with a small variation*)
> x = 0; dsp = 1;(*dsp is for drawing consecutive bigger hexagons*)
> Table[p[i] = x + # & /@ (dsp*(Through[{Cos, Sin}[Pi#/3]] &) /@ Range[0, 5]);
>   dsp++;
>   (* The fifth edge of every hexagon we want to extend it horizontaly by 1 \
> unit so we will be able to begin the new bigger hexagon in a spiral form *)
>   p[i] = ReplacePart[p[i], Last[p[i]] + {1, 0}, Length[p[i]]];, {i,(*
>       number of hexagons possible *)100}]; (* End of Table function *)
> i = 1; ww = {}; While[i <= 20 (* number of hexagons desired *),
>   ww = Join[ww, p[i]]; i++] (*
>   The coordinates of the vertices of consecutive Hexagons will be in ww \
> variable*)
> (* the Hexagonal spiral *)
> m1 = Graphics[{Line[ww], {Red, PointSize[0.02], Point[{0, 0}]}},
>       AspectRatio -> Automatic];
> Show[m1]
>
> (* The straigth Line Equation function *)
> f[{x1_, y1_}, {x2_, y2_}] :=
>   y = x*((y2 - y1)/(x2 - x1)) + y1 - x1*((y2 - y1)/(x2 - x1))
> w = Partition[ww, 6];
> w2 = {}; i = 1; While[i <= Length[w] - 1,
> w2 = Join[w2, {Append[w[[i]], First[w[[i + 1]]]]}]; i++;]
> (* the following will divide every edge into equal units according to its \
> distance from the center of the hexagon with the exception of the horizontal \
> fifth edge wich is taller than the others by one unit *)
>
> n = 1; polylist = {}; polynum = 19 (* number of hexagons *); lst = {}; s = 1;
>   i = 1; j = 1;
>   While[
>     s <= polynum,
>     j = 1;
>     While[j <= 6, lst = {};
>       x1 = w2[[s]][[j]][[1]];
>       y1 = w2[[s]][[j]][[2]];
>       x2 = w2[[s]][[j + 1]][[1]];
>       y2 = w2[[s]][[j + 1]][[2]];
>       If[j == 5, ss = s + 1, ss = s];
>       i = 1; n = 1;
>       While[i <= s,
>         x = x1 + n*(x2 - x1)/ss;
> (*call the straight line equation function : *)
> y = f[{x1, y1}, {x2, y2}];
>           lst = Join[lst, {{x, y}}];
>           n++; i++];
>       If[j == 1, lst = Prepend[lst, {x1, y1}]];
>       If[j == 5, lst = Append[lst, {x2, y2}]];
>       polylist = Join[polylist, lst];
>       j++];
>   s++]
> (* To delete one of every consecutive similar points which represent the \
> beginning point of every hexagon points *)
> i = 1; While[i <= Length[polylist] - 2,
>   If[polylist[[i]] == polylist[[i + 1]], polylist = Delete[polylist, i]]; i++]
> v = {}; i = 1;
> While[i <= Length[polylist],
>   If[PrimeQ[i] == True, v = Join[v, {polylist[[i]]}]]; i++]
> Show[Graphics[{Line[Take[ww, 50]], {PointSize[.02], Point[{0, 0}], Red,
>         Point /@ Take[polylist, 234]}}], AspectRatio -> Automatic]
> hexx = Graphics[{PointSize[.02], Point[{0, 0}], Green, Point /@ polylist}];
> prm = Graphics[{PointSize[.02], Red, Point /@ v}];
> lin = Graphics[{Line[ww], {PointSize[.03], Point[{0, 0}]}}];
> (* show prime numbers in Red : *)
> Show[hexx, prm, AspectRatio -> Automatic]
> Show[lin, hexx, prm, AspectRatio -> Automatic]
>
>
>
>



-- 
DrBob at bigfoot.com


  • Prev by Date: Re: FilledPlot: Curves->Back option and Epilog not working?
  • Next by Date: Re: Re: Re: How to quickly find number of non-zero elements in sparse matrix rows?
  • Previous by thread: Hexagonal Spiral
  • Next by thread: Re: Hexagonal Spiral