Pleasure in the Small Things

May 14, 2015 Leave a comment


profile for ubpdqn on Stack Exchange, a network of free, community-driven Q&A sites

Today I reached 20k on Mathematica Stackexchange. This is a small thing, even undeserved and an over-rating and of only interest to me, it brought my pleasure to be part of this creative and vibrant community. Peace to all.

Categories: Uncategorized

Down the Rabbit Hole

May 10, 2015 Leave a comment

Inspired by the Fibonacci clock  I extended the idea:

fc2a

The left is year (not Fibonacci related), the middle the month and day, the right the original Fibonacci clock with edges black for am and orange for pm.

The translation:

fc2

Categories: Uncategorized

Rabbits and Clocks

May 10, 2015 1 comment

This post is inspired by a tweet from Clifford Pickover regarding Fibonacci clock.

I sought to simulate this clock. Note the pattern for a given times is not unique for the most part but this adds interest to changing patterns.

Here is the code of my attempt:

sc = Rectangle @@@ {{{2, 3}, {3, 4}}, {{2, 4}, {3, 5}}, {{0, 3}, {2,
5}}, {{0, 0}, {3, 3}}, {{3, 0}, {8, 5}}};
h[n_] := Module[{tu},
tu = Tuples[{0, 1}, 5];
Pick[tu, {1, 1, 2, 3, 5}.# == n & /@ tu]];
m[n_] := Module[{tu},
tu = Tuples[{0, 5}, 5];
Pick[tu, {1, 1, 2, 3, 5}.# == n & /@ tu]];
m[0] := {{0, 0, 0, 0, 0}};
h[0] := {{0, 0, 0, 0, 0}};
rh = # -> h[#] & /@ Range[0, 12];
rm = # -> m[#] & /@ Range[0, 55, 5];
col = {0 -> White, 1 -> Red, 5 -> Green, 6 -> Blue};
clck[hr_, mn_] := Module[{ch, cm, cl},
ch = RandomChoice[hr /. rh];
cm = RandomChoice[mn /. rm];
cl = (ch + cm) /. col;
Graphics[Prepend[Riffle[cl, sc], EdgeForm[Black]]]
]
tm = Rest@Tuples[{Range[0, 12], Range[0, 55, 5]}];
clcanim =
Column /@
Thread[{clck @@@ tm,
Row[{#1, ":", IntegerString[#2, 10, 2]}] & @@@ tm}];

The animation was made from clcanim
fc

Categories: Uncategorized

Wrap Around

April 25, 2015 Leave a comment


I came across this puzzle in a tweet from Clifford Pickover.

I enjoyed tried trying to visualize approach:

cp

Categories: Uncategorized

The Princess Revisited

March 30, 2015 Leave a comment

I enjoyed the Princess puzzle but lost the code I wrote. As an exercise, I approached it again…feeling in a code sharing mood,


sa = SparseArray[{{1, 2} -> 1, {17, 16} -> 1, Band[{2, 1}] -> 1/2,
Band[{2, 3}, {16, 17}] -> 1/2}, {17, 17}];
dm[p_] :=
DiscreteMarkovProcess[ReplacePart[ConstantArray[0, 17], p -> 1], sa]
sol = Thread[{Range[0, 29], Join[Range[2, 16], Reverse@Range[2, 16]]}];
func[n_] := Module[{rp = RandomFunction[dm[n], {0, 29}], pt},
pt = Intersection[rp["Paths"][[1]], sol];
ListPlot[{rp, sol}, PlotStyle -> {Black, Red}, Joined -> True,
Frame -> True,
FrameTicks -> {Table[{j, j + 1}, {j, 0, 29, 2}], Automatic},
PlotLabel ->
Row[Style[#, Bold] & /@ {"Princess starts in room: ", n}],
FrameLabel -> {"Day", "Room"}, Background -> LightOrange,
Epilog -> {Yellow, EdgeForm[Black], Disk[#, 0.5] & /@ pt}]]

and for simulation:

sim[num_] := Transpose[Table[func[#], {num}] & /@ Range[17]]

100 simulations:

princess

Of course better code welcome.

Categories: Mathematica

Rock, Paper, Scissors

March 30, 2015 Leave a comment

I have been reading “Magical Mathematics”. I admit that I am ignorant of magic and cannot juggle (but would like to learn). I am enjoying getting insights into magic.

This post relates to a rock paper scissors trick on page 185 of the book. In the trick, there is a deck of 27 card with all the triples of choosing (with replacement)  from the {rock, paper, scissors} with object arrange vertically. The trick involves shuffling the cards, putting aside the top card, then taking pairs of the remaining 26 cards and playing rock, paper scissors looking at first, second, the third rows then predicting the removed card. The process is much better explained in the book.

I decided I’d like to implement in Mathematica:
The rock, paper, scissors game:

rps[{"rock", "paper"}] := {"paper", "rock"};
rps[{"paper", "scissors"}] := {"scissors", "paper"}
rps[{"scissors", "rock"}] := {"rock", "scissors"}
rps[{x_, y_}] := rps[{y, x}]
rps[{x_, x_}] := Sequence[];

The round process:

rsub[m_, n_] := Module[{dat, lab = {"rock", "paper", "scissors"}, tl},
dat = rps /@ ((Transpose[#])[[n]] & /@ m);
tl = {#, Count[dat[[All, 2]], #]} & /@ lab;
rps[Select[GatherBy[tl, Mod[#[[2]], 2] &], Length@# == 2 &][[1, All,
1]]][[1]]
]
trick[m_] := {rsub[Partition[Rest@m, 2], #] & /@ Range[3], First@m}

Generating the “cards”:

tup = Tuples[{"rock", "paper", "scissors"}, 3];

Generating 1000 random samples and using thumbnails:

rck = Thumbnail@
Import["http://fc02.deviantart.net/fs71/i/2013/012/f/f/rock_02_png_\
__by_alzstock-d5r85eg.png"];
ppr = Thumbnail@
Import["http://cdn.dickblick.com/items/102/40/10240-1009-1-3ww-l.\
jpg"];
scs = Thumbnail@
Import["http://www.acco.com.au/products/img/Zoom/z9752326%20Marbig%\
20Orange%20Handle%20Scissors%20DEI.jpg"];
rule = Thread[{"rock", "paper", "scissors"} -> {rck, ppr, scs}];
tab = Table[Table[trick[RandomSample[tup, 27]], {10}], {100}];
anim = Grid[
Prepend[{Row[#1 /. rule],
Row[#2 /. rule]} & @@@ #, {"Prediction", "First Card"}],
Frame -> All] & /@ tab;

Exported as animated gif:

rps

Categories: Uncategorized

Here’s Looking at Euclid

March 13, 2015 Leave a comment

I enjoyed this book.  It was an enjoyable journey through multiple areas of mathematics.  Numbers, euclidean  geometry, recreational mathematics, probability and statistics and finally non-euclidean geometry are presented with motivating current everyday examples being enriched by the historical developments that underpinned them. I particularly enjoyed the chapters on mathematical devices, e.g. Curta, recreational mathematics, the chapters on chance and statistics.  The mathematical discussions are interspersed with interesting personalities and personal anecdotes such as weighing baguettes ‘in search of’ the normal distribution, only to be thwarted by the heat…in the footsteps of Poincare.

Categories: books, Mathematics
Follow

Get every new post delivered to your Inbox.

Join 37 other followers