Thursday, November 29, 2007

Enigmatic comments

This is a placeholder for comments on postings at Enigmatics.

Please remember to identify which Enigma problem you are commenting on.

Enigmatic movements

I have decided that my Mathematica solutions to the New Scientist Enigma problems are cluttering up this blog, so I will move them to a separate blog called Enigmatics which I will generate using the incredibly useful WorkLife FrameWork; believe me, using WLFW is like having a 24/7 personal assistant organising all of your Mathematica notebooks. This allows me to present my solutions in a form that is much closer to the original Mathematica, but it does not allow for comments on blog entries.

I have looked into the possibility of managing the comments myself, but the effort needed to counter the inevitable spam is too great. I will instead provide a link in each Enigmatics blog entry back to this blog, which will allow comments to be made using the Blogger commenting system.

Wednesday, November 28, 2007

NanoArt 2007

Nanoart is defined here as:

NanoArt is a new art discipline related to micro/nanosculptures created by artists/scientists through chemical/physical processes and/or natural micro/nanostructures that are visualized with powerful research tools like Scanning Electron Microscope and Atomic Force Microscope.

The process of creating nanoart is described here as:

I bring the small world in front of my audience through high resolution electron microscope scans of natural micro or nanostructures and sculptures I create at micro or nano scale by physical or/and chemical processing. I take further steps by mixing the realistic images of this structures with abstract colors, digitally painting and manipulating the monochromatic electron scans, and finally printing them with long-lasting inks on canvas or fine art paper (giclee prints). This way, the scientific images become artworks and could be showcased for a large audience to educate the public with creative images that are appealing and acceptable.

In a nutshell, the electron microscope provides the raw image, and the artist colours it in to produce an enhanced (i.e. artistic) result. This could range from a trivial colour tinting of the raw image, through to an artistic rendition that is based only very loosely on the raw image. Of course, I favour the more artistic style of nanoart, and I have some ideas on new ways of creating such artwork, but there isn't room in this tiny blog posting to tell you all about it!

Anyway, back to the title of this posting: NanoArt 2007. This is an online competition to create nanoart, and the submission deadline is 31 December 2007. For people without ready access to an electron microscope to create their own raw images there are 3 high resolution monochromatic electron scans provided here (nano-flower), here (micro & nano), and here (nano-crystals). I think it would be fun to enter this competition.

Saturday, November 24, 2007

Dresden art gallery

Here is a nice photo of a very small part of the world famous Dresden Art Gallery:



Here is a snapshot that I took of the same scene (with some more context) in Second Life:


The exact location of this duplicate of the Dresden Art Gallery in Second Life is http://slurl.com/secondlife/Dresden%20Gallery/77/121/26. Visitors to SL do not need to pay anything just to explore.

I won't show you inside the Second Life duplicate of the art gallery, so you will have to visit it yourself to enjoy it. You can have a look at the WIRED report here if you want more details. Set aside a spare half-day for this adventure in SL. You won't be disappointed.

Wednesday, November 21, 2007

Sand painting

I found this video of sand painting here at Backreaction:


I think it is a wonderful art form, and it has given me some ideas ...

Friday, November 16, 2007

Enigma 1469

Here is how Mathematica can be used to solve New Scientist Enigma number 1469 in the 17 November 2007 issue.

WARNING: See the comments for details. There is an error in the solution given below that I need to fix. In working on a fix I discovered a bug in the HamiltonianCycle function in Mathematica's Combinatorica package (this bug has been acknowledged by the author of the Combinatorica package) which destroyed any chance of my fix working fully correctly, although the correct solution to Enigma 1469 could be seen lurking in amongst the erroneous clutter. I will abandon my solution to Enigma 1469 because it has absorbed too much of my time already, and the discovery of the HamiltonianCycle bug can stand as a testimonial to the cleverness of Enigma 1469. I suppose that I ought to leave the rest of this posting intact otherwise the comments would be orphaned, and also there are some useful techniques illustrated in my erroneous solution.

Load the Combinatorica package.
Needs["Combinatorica`"];

Derive the formula for triangular numbers.
triangularformula=Sum[i,{i,n}]
1/2 n (1 + n)

Compute a list of all triangular numbers less than 1000.
triangularnumbers = Table[triangularformula, {n,44}]
{1, 3, 6, 10, 15, 21, 28, 36, 45, 55, 66, 78, 91, 105, 120, 136, 153, 171, 190, 210, 231, 253, 276, 300, 325, 351, 378, 406, 435, 465, 496, 528, 561, 595, 630, 666, 703, 741, 780, 820, 861, 903, 946, 990}

Convert this to the corresponding list of lists of digits.
triangulardigits = IntegerDigits[triangularnumbers]
{{1}, {3}, {6}, {1, 0}, {1, 5}, {2, 1}, {2, 8}, {3, 6}, {4, 5}, {5, 5}, {6, 6}, {7, 8}, {9, 1}, {1, 0, 5}, {1, 2, 0}, {1, 3, 6}, {1, 5, 3}, {1, 7, 1}, {1, 9, 0}, {2, 1, 0}, {2, 3, 1}, {2, 5, 3}, {2, 7, 6}, {3, 0, 0}, {3, 2, 5}, {3, 5, 1}, {3, 7, 8}, {4, 0, 6}, {4, 3, 5}, {4, 6, 5}, {4, 9, 6}, {5, 2, 8}, {5, 6, 1}, {5, 9, 5}, {6, 3, 0}, {6, 6, 6}, {7, 0, 3}, {7, 4, 1}, {7, 8, 0}, {8, 2, 0}, {8, 6, 1}, {9, 0, 3}, {9, 4, 6}, {9, 9, 0}}

Construct the adjacency matrix of allowed adjacencies between triangular numbers.
adjacencies = Outer[(If[Last[#1]==First[#2], 1, 0])&, triangulardigits, triangulardigits, 1];

Convert the adjacency matrix to a set of rules that allow me to add a "tooltip" to each node of the corresponding the graph so that it can be explored by hovering the mouse over the graph: (1) extract the sparse array form of the adjacency matrix, (2) convert the sparse array into a list of rules for which graph nodes are linked by edges, (3) add a tooltip to each graph node.
adjacencies2 = SparseArray[adjacencies];
adjacencies3 = ((adjacencies2//ArrayRules//Most) /. HoldPattern[{i_,j_}->1] :> i->j);
adjacencies4 = adjacencies3 /. x_?IntegerQ :> Tooltip[x, triangularnumbers[[x]]];

Display the graph with tooltips.
GraphPlot[adjacencies4, DirectedEdges->True]
[Output omitted]

Convert the adjacency matrix to a graph. I need this representation in order to use graph manipulation algorithms.
g = FromAdjacencyMatrix[adjacencies, Type->Directed];

Extract the longest cycle in the graph, and extract the edges within this cycle.
longestcyclenodes = ExtractCycles[g]//Sort//Last//Most;
longestcycleedges = Partition[longestcyclenodes,2,1,{1,1}];

Display the graph with the longest cycle highlighted.
GraphPlot[adjacencies4, EdgeRenderingFunction -> (If[MemberQ[longestcycleedges,#2], {Red,Arrow[#1]}, {Opacity[0.3],LightGray,Arrow[#1]}]&)]

Convert the longest cycle to the corresponding a list of triangular numbers, and thence the sequence of digits encountered when going around the cycle.
longestcyclenumbers = triangularnumbers[[longestcyclenodes]];
longestcycledigits = longestcyclenumbers//IntegerDigits//Flatten

[Output omitted]

Compute the number of digits encountered when going around the longest cycle.
longestcycledigits//Length
[Solution omitted]

Wednesday, November 14, 2007

The Goldstone theorem

There is an interesting posting on Tommaso Dorigo's blog A Quantum Diaries Survivor entitled The Goldstone Theorem for Real Dummies. Quoting from his posting the Goldstone theorem is: "The spontaneous breaking of a continuous symmetry of the lagrangian generates massless scalars". Despite its claim to be for real dummies his derivation of the Goldstone theorem assumes familiarity with a lot of theory, which ensures that the "dumb" reader will not develop an intuitive feel for the masslessness of the particles (the Goldstone bosons, that is).

I am personally at ease with the level of theory that he uses, but I am in a very small minority in this respect. Wouldn't it be nice to write an intuitive description that does not assume that the reader has prior knowledge of much theory, but where the writer ensures that the intuitive description faithfully conforms to the underlying theory that is known to him. The Goldstone theorem can be understood intuitively without having to follow the detailed algebraic steps of its proof.

Here I will attempt to "prove" the Goldstone theorem using only words (i.e. no pictures, and no maths). Pictures would greatly improve the presentation, and maths would very succinctly summarise and generalise what is going on, but it is interesting to see what you can do with words alone.

Mass is defined as the propensity of the vector-valued field value alone (i.e. not including any field derivatives, or equivalently the field values at neighbouring points) to contribute to a restoring force that pushes the field towards an equilibrium value of the field. If within a local neighbourhood of field space there are direction(s) that have zero restoring force then each of these directions corresponds to a zero mass excitation.

It suffices to visualise a potential in field space whose (negative) gradient defines the field restoring force, and to ask ourselves what sort of shapes this potential could have in field space. We need to find places in field space where this potential has zero gradient, and then enquire whether the gradient of the potential is actually zero over the whole of a local neighbourhood rather than just at a single point, so that displacement of the field value within such a neighbourhood would encounter zero restoring force, and would thus correspond to a zero mass excitation.

The visualisation problem reduces to the classification of the stationarities of a scalar potential function in field space, which is something that is very easy to visualise (e.g. minima, maxima, saddle points, etc). The particular case that is relevant to the Goldstone theorem is when the potential function is constrained to be symmetric, e.g. under the continuous group of rotations about the origin of the vector-valued field. What sort of stationarities are allowed under such symmetry constraints? For a rotation symmetry the potential must be constant on each origin-centred spherical shell in field space, but different spherical shells have independent values of the potential. The potential is therefore fully described by its variation as a function of distance from the origin in field space (i.e. a 1-dimensional potential).

To find an equilibrium point you need to find a stationary point of the 1-dimensional version of the potential, then constancy of the full version of the potential over each spherical shell gives us zero gradient of the potential over the entire spherical shell that intersects this stationary point, which thus gives as many zero-mass degrees of freedom of the vector-valued field as there are directions within the spherical shell (i.e. one less than the dimensionality of the field). This is the Goldstone theorem.

Rereading what I have written above I am now uncertain whether it is of much use to anyone other than me. It is just the internal chatter (minus the pictures) that goes on inside my head when I think "Goldstone theorem", so it isn't guaranteed to be as intuitive for other people as it is for me.

Tuesday, November 13, 2007

Enigma 1468

I have had to skip a couple of Enigmas because there hasn't been time to do them. I may come back to them later, but don't hold your breath.

Here is how Mathematica can be used to solve New Scientist Enigma number 1468 in the 10 November 2007 issue. This solution draws heavily on the graph manipulation facilities in the Combinatorica package. Most of the work involves setting up an appropriate graph to represent the problem, after which the solution to the problem drops out by simply calling the HamiltonianCycle function.

Load the Combinatorica package for doing operations on graphs.

Needs["Combinatorica`"];

Define a function for computing 2D indexing from 1D indexing on a 6 by 6 array.

indices[i_] := {Quotient[i+5,6], Mod[i,6,1]};

Define a function for computing if a pair of nodes is adjacent in a Manhattan metric. You could use GridGraph[6,6] instead, but I want to show how to use an explicit adjacency function here.

manhattan[{i1_,j1_}, {i2_,j2_}] := Abs[i1-i2]==1&&j1==j2 || Abs[j1-j2]==1&&i1==i2;

Define a function for testing if adjacency between a pair of nodes is excluded.

exception[{i1_,j1_}, {i2_,j2_}] := Apply[Or, Map[{i1,j1}==#[[1]] && {i2,j2}!=#[[2]]&, {{{2,3},{1,3}}, {{3,4},{4,4}}, {{5,3},{6,3}}, {{5,6},{5,5}}}]];

Use these adjacency functions to define an adjacency matrix.

adjacency = SparseArray[{{_, _}?((manhattan[#1,#2] && Not[exception[#1,#2]])&[indices[#[[1]]], indices[#[[2]]]]&)->1}, {36,36}];

Use this adjacency matrix to define an adjacency function.

edge[from_, to_] := adjacency[[from, to]]==1;

Define the layout (i.e. embedding) of the graph.

coordinates = Table[index->{{0,1},{-1,0}}.indices[index], {index,36}];

Display the graph.

GraphPlot[g=MakeGraph[Range[36],edge], DirectedEdges->True, VertexLabeling->True, VertexCoordinateRules->coordinates]

[Output omitted]

Compute all of the Hamiltonian cycles in the graph. There is only one, as expected.

cycles = HamiltonianCycle[g,All]

[Output omitted]

Extract the edges in the Hamiltonian cycle.

cycleedges = Partition[cycles[[1]],2,1];

Define a function for drawing only the edges that lie on the Hamiltonian cycle.

cycleedge[coords_, vertices_, label_] := If[MemberQ[cycleedges,vertices], {Red,Thickness[0.01],Arrow[coords]}, {}];

Display the Hamiltonian cycle.

GraphPlot[MakeGraph[Range[36],edge], VertexLabeling->True, VertexCoordinateRules->coordinates, EdgeRenderingFunction->cycleedge]

[Output omitted]

Rotate the Hamiltonian cycle so that it starts at the correct node.

cycles2 = RotateLeft[#, Position[#,11][[1,1]]-1]&[Most[cycles[[1]]]]

[Output omitted]

Compute which positions in the Hamiltonian cycle fall on the nodes labelled "ENIGMA".

Map[Position[cycles2,#][[1,1]]&, Range[19,24]]

[Solution omitted]