https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Graphs and Networks with no replies sorted by active. https://community.wolfram.com/groups/-/m/t/3657540 https://www.wolframcloud.com/obj/6c3f3541-7f68-452f-bb6b-25201369c3cf The unit cube {0,1}^3 — the RGB color lattice — contains a geometrically distinguished axis: the principal diagonal from (0,0,0) to (1,1,1), along which all coordinates are equal. This diagonal is the null space of the differentiation operator D(v) = {r-g, g-b, r-b}. Every point on it maps to zero. It is the axis of zero contrast — a path that traverses the full interior of the cube from minimum to maximum while producing no distinguishable information along its length. Viewed from the side, this path threads through the center of creation's geometry like a line with no allegiance to any axis. Viewed from its own endpoint — looking along its length — the path collapses to a point, and the six chromatic vertices arrange themselves around it in a closed loop. The same object appears as a line from one angle and a circle from another, depending only on the observer's orientation. The orthogonal complement at the cube center (1/2, 1/2, 1/2) produces three mutually perpendicular lines aligned with the R, G, and B axes — a cruciform structure representing the directions of maximum differentiation. This structure intersects the diagonal at the exact center of the cube. The diagonal cannot pass from (0,0,0) to (1,1,1) without passing through the point where the three orthogonal axes cross. These two objects — the diagonal and the cross — occupy the same center point and together span R^3. One is the null space of differentiation. The other contains its maximum. They are complementary in the precise linear-algebraic sense. And they are perpendicular — the path of zero differentiation must pass through the point of maximum differentiation to complete its traversal. The perpendicular cross-section through the cube center, normal to the diagonal, intersects the cube in a hexagon whose vertices are the six chromatic states. Viewed along the diagonal, the cube's three-dimensional geometry projects into a flat circular arrangement — a closed cycle of colors that appears self-contained until you realize it is the shadow of a deeper structure collapsed by one dimension of observation. The attached notebook includes an interactive displacement operation showing what happens when a point is moved from the diagonal center to the vertex {1,1,0}: the Blue component drops to zero while Red and Green maximize. The displaced point sits one Hamming bit from White (1,1,1) — maximally close to completion while permanently lacking the one component that would complete it. The path of zero differentiation delivers the point to a state of almost. Two open questions for the community: First — under what algebraic operation can a vertex at Hamming distance 1 from White acquire its missing basis component, and what geometric constraints prevent that acquisition from the displaced position? Second — is it coincidental that the null space of differentiation in this lattice must pass through the orthogonal complement's intersection point to complete its traversal, or does this reflect a deeper structural necessity in discrete binary state spaces? Notebook attached. CC0. — Dustin Sprenger Dustin Sprenger 2026-03-12T01:51:16Z https://community.wolfram.com/groups/-/m/t/3642736 ![A Graph Theory Analysis of Centrality, Resilience, and Community Structure in the London Subway Network][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8057image.png&userId=911151 [2]: https://www.wolframcloud.com/obj/5b7ef9aa-2d29-4836-b49a-0c3a4371eb87 Wolfram Education Programs 2026-02-20T15:55:58Z https://community.wolfram.com/groups/-/m/t/3638608 ![Evolving cellular automata megafauna through point mutations][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=5789image.png&userId=20103 [2]: https://www.wolframcloud.com/obj/bd64452d-92b7-4317-a7fd-bb2ee51d9590 Wolfram Education Programs 2026-02-11T16:27:56Z https://community.wolfram.com/groups/-/m/t/3607816 ![Exploring Hydrogen Bonding Patterns in Proteins][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=hBondGraph.png&userId=3607438 [2]: https://www.wolframcloud.com/obj/3b73030e-7416-4f1a-b858-751efa05c461 Christoph Steck 2026-01-15T21:48:27Z https://community.wolfram.com/groups/-/m/t/3575020 In our work, we often discuss the fundamental flaws in modern networking--protocols built on the "Minkowski fallacy" of smooth, universal time, leading to "data corruption" and "silent data loss" because they lack a true mechanism for "perfect information feedback". Our alternative begins with a different physical and logical foundation: a mesh of nodes, a "sea of XPUs", engineered for "temporal intimacy". In this environment, the network must be self-discovering. Before you can route, you must ***scout***. These concepts can seem abstract. As our colleague Dugan Hammock has demonstrated a powerful tool for making these ideas concrete, this article uses the Wolfram Language to model and analyze the principles of "discovery and pathfinding for a mesh-based network", including its behavior in the face of the inevitable failures that all real-world systems must endure. ## Building the Lattice: A Model for "Temporal Intimacy" ## First, we define our network. We use an octagonal lattice, a highly-connected 8-neighbor mesh. This grid represents our "Distributed Autonomous Ethernet (DAE)" rack, where nodes are physically close. The code defines the precise `positions` of each node and, crucially, the `adjacencyList`--the best of the map, of all "bidirectionally coherent" links that form the basis of our network. ClearAll["Global`*"]; Unprotect[$PerformanceGoal]; $PerformanceGoal = "Quality"; Protect[$PerformanceGoal]; rows = 11; cols = 11; r = 1; gap = 0.2; dx = 2 r (Cos[\[Pi]/8] + gap); dy = 2 r (Cos[\[Pi]/8] + gap); OctagonAt[{x_, y_}, rr_] := Polygon[Table[{x, y} + rr RotationTransform[\[Pi]/8 + (i \[Pi])/4][{1, 0}], {i, 0, 7}]]; positions = Association[ Flatten[Table[ With[{id = j cols + i + 1}, id -> {i dx, j dy}], {j, 0, rows - 1}, {i, 0, cols - 1}], 1]]; adjacencyList = Association[ Flatten[Table[ Module[{id, neighbors, validNeighbors}, id = j cols + i + 1; neighbors = {{i - 1, j}, {i + 1, j}, {i, j - 1}, {i, j + 1}, {i - 1, j - 1}, {i + 1, j - 1}, {i - 1, j + 1}, {i + 1, j + 1}}; validNeighbors = Select[neighbors, 0 <= #1[[1]] < cols && 0 <= #1[[2]] < rows &]; id -> (#2 cols + #1 + 1 &) @@@ validNeighbors], {j, 0, rows - 1}, {i, 0, cols - 1}], 1]]; centerI = 0; centerJ = 0; rootNode = centerJ cols + centerI + 1; Print["Root node (center position: ", {centerI, centerJ}, ") with valency: ", Length[adjacencyList[rootNode]]]; BFS[root_, adjList_] := Module[{distances, queue, current, neighbors}, distances = Association[root -> 0]; queue = {root}; While[Length[queue] > 0, current = First[queue]; queue = Rest[queue]; neighbors = adjList[current]; Do[If[! KeyExistsQ[distances, neighbor], distances[neighbor] = distances[current] + 1; AppendTo[queue, neighbor];], {neighbor, neighbors}];]; distances]; distances = BFS[rootNode, adjacencyList]; GetAccessibleLinksUpToHop[maxHop_] := Module[{accessibleLinks = {}, linkPair, uDist, vDist}, Do[Do[linkPair = Sort[{node, neighbor}]; If[! MemberQ[accessibleLinks, linkPair], uDist = distances[node]; vDist = distances[neighbor]; If[uDist <= maxHop && vDist <= maxHop && Min[uDist, vDist] <= maxHop - 1, AppendTo[accessibleLinks, linkPair];];], {neighbor, adjacencyList[node]}], {node, Keys[adjacencyList]}]; accessibleLinks]; maxHop = Max[Values[distances]]; hopCounts = Table[Count[Values[distances], h], {h, 0, maxHop}]; cumulativeNodeCounts = Table[Count[Values[distances], x_ /; x <= h], {h, 0, maxHop}]; linkCountsAtHop = Table[Module[{currentLinks, previousLinks}, currentLinks = GetAccessibleLinksUpToHop[h]; previousLinks = If[h > 0, GetAccessibleLinksUpToHop[h - 1], {}]; Length[currentLinks] - Length[previousLinks]], {h, 0, maxHop}]; cumulativeLinkCounts = Table[Length[GetAccessibleLinksUpToHop[h]], {h, 0, maxHop}]; Print["Hop counts (nodes): ", hopCounts]; Print["Cumulative accessible nodes: ", cumulativeNodeCounts]; Print["New link counts at each hop: ", linkCountsAtHop]; Print["Cumulative accessible links: ", cumulativeLinkCounts]; Print["Links at hop 0: ", Length[GetAccessibleLinksUpToHop[0]]]; Print["Links at hop 1: ", Length[GetAccessibleLinksUpToHop[1]]]; edgeToNodePair = Union[Sort /@ Flatten[Table[ Table[{id, neighbor}, {neighbor, adjacencyList[id]}], {id, Keys[adjacencyList]}], 1]]; edges = (Line[{positions[#1], positions[#2]}] &) @@@ edgeToNodePair; Print["Sample edge node pairs: ", Take[edgeToNodePair, UpTo[5]]]; hopColor[hop_] := ColorData["BrightBands"][Rescale[hop, {0, maxHop}]]; gridBackground = White; plotBackground = White; frameStyle = Directive[Black, Thick]; labelStyle = Directive[Black, 14, Bold]; subtitleStyle = Directive[GrayLevel[0.2], 11]; maxCount = 1.1 Max[Join[cumulativeNodeCounts, cumulativeLinkCounts]]; CreateGridFrame[currentHop_] := Module[{accessibleNodes, accessibleLinkPairs, linkGraphics, nodeGraphics, activeLinkCount, xRange, yRange}, accessibleNodes = Select[Keys[distances], distances[#1] <= currentHop &]; accessibleLinkPairs = GetAccessibleLinksUpToHop[currentHop]; linkGraphics = Function[pair, If[MemberQ[accessibleLinkPairs, pair], Module[{avgHop = Mean[distances /@ pair], c}, c = hopColor[avgHop]; {Directive[Thickness[0.006], Glow[White], c], Line[{positions[pair[[1]]], positions[pair[[2]]]}]}], {Directive[GrayLevel[0.6], Thin, Opacity[0.4]], Line[{positions[pair[[1]]], positions[pair[[2]]]}]}]] /@ edgeToNodePair; activeLinkCount = Length[accessibleLinkPairs]; nodeGraphics = Table[Module[{nodeHop, color}, nodeHop = distances[node]; color = If[nodeHop <= currentHop, hopColor[nodeHop], Directive[GrayLevel[0.8], Opacity[0.5]]]; {EdgeForm[{Black, Thickness[0.003]}], FaceForm[color], OctagonAt[positions[node], r]}], {node, Keys[positions]}]; xRange = {Min[Values[positions][[All, 1]]] - 1.5, Max[Values[positions][[All, 1]]] + 1.5}; yRange = {Min[Values[positions][[All, 2]]] - 1.5, Max[Values[positions][[All, 2]]] + 1.5}; Column[{Style[ Row[{"Hop: ", currentHop, " \[Bullet] Accessible Nodes: ", Length[accessibleNodes], " \[Bullet] Accessible Links: ", cumulativeLinkCounts[[currentHop + 1]], " \[Bullet] Active Links (this hop): ", activeLinkCount}], subtitleStyle], Graphics[{{Opacity[0.15, White], Thick, EdgeForm[], Disk[Mean[Values[positions]], 2 Max[dx, dy] {rows, cols}]}, linkGraphics, nodeGraphics}, ImageSize -> 450, Background -> gridBackground, PlotRange -> {xRange, yRange}, PlotRangePadding -> Scaled[0.05], ImagePadding -> 25]}]]; CreateNodeGraphFrame[currentHop_] := Module[{currentCumulativeNodes, currentCumulativeLinks, hops}, hops = Range[0, currentHop]; currentCumulativeNodes = cumulativeNodeCounts[[1 ;; currentHop + 1]]; currentCumulativeLinks = cumulativeLinkCounts[[1 ;; currentHop + 1]]; ListLinePlot[{Transpose[{hops, currentCumulativeLinks}], Transpose[{hops, currentCumulativeNodes}]}, PlotStyle -> {Directive[Thick, ColorData["BrightBands"][0.85]], Directive[Thick, Dashed, ColorData["BrightBands"][0.25]]}, Filling -> {1 -> Axis}, FillingStyle -> Directive[Opacity[0.25], ColorData["BrightBands"][0.7]], PlotRange -> {{0, maxHop}, {0, maxCount}}, Frame -> True, FrameStyle -> frameStyle, FrameTicksStyle -> Directive[Black, 10], Axes -> False, PlotLegends -> Placed[{Style["Cumulative accessible links", 11, Black], Style["Cumulative accessible nodes", 11, Black]}, {0.02, 0.95}], GridLines -> {Range[0, maxHop, 1], Automatic}, GridLinesStyle -> Directive[GrayLevel[0.8, 0.7], Dashed], ImageSize -> 450, Background -> plotBackground, PlotLabel -> Style["Node & Link Accessibility vs Hop Count", labelStyle], AxesLabel -> {Style["Hop Count", 11, Black], Style["Count", 11, Black]}, ImagePadding -> {{50, 15}, {45, 25}}]]; animation = Animate[Column[{Row[{CreateGridFrame[h], Spacer[30], CreateNodeGraphFrame[h]}, Alignment -> Center]}, Spacings -> 2], {h, 0, maxHop, 1}, AnimationRate -> 1, AnimationDirection -> Forward, AnimationRepetitions -> \[Infinity]]; frames = Table[Row[{CreateGridFrame[h], Spacer[30], CreateNodeGraphFrame[h]}, ImageSize -> 950, Alignment -> Center], {h, 0, maxHop}]; ListAnimate[frames]; Export["hopLinks_beautiful.gif", frames, "DisplayDurations" -> 1]; animation ## Scouting the Network: The Breadth-First Search (BFS) ## With the lattice defined, we need a "scouting" protocol. We start with a foundational algorithm: a Breath-First Search (BFS). This allows a `rootNode` (here, one chosen near the corner) to discover its environment, calculating the hop-count (distance) to every other node it can reach. And, these bricks that let us build further and further can flood back in the form of a recursive map of `distances` that, is the fundamental prerequisite for any "scouting and routing protocol". ![Octagon Wave][1] Root node (center position: {0,0}) with valency: 3 Hop counts (nodes): {1,3,5,7,9,11,13,15,17,19,21} Cumulative accessible nodes: {1,4,9,16,25,36,49,64,81,100,121} New link counts at each hop: {0,3,12,20,28,36,44,52,60,68,76} Cumulative accessible links: {0,3,15,35,63,99,143,195,255,323,399} Links at hop 0: 0 Links at hop 1: 3 Sample edge node pairs: {{1,2},{1,12},{1,13},{2,3},{2,12}} Trying to get reliable data consistency by syncing up physical clocks is just a delusion. And one that's been responsible, frankly, for decades of corrupted data. If the humble computer time stamp, that little number, is actually an unsafe way to order things, then our mission is to unpack why that is--and what architectures could possibly replace this broken model of time. It's practically a rite of passage. So what is the claim regarding clocks and consistency? Well, the first one (Newtonian time & the Minkowski fallacy) is kind of embarrassing for modern engineering--the Newtonian time error. It's this implicit assumption that all time every-where is just ticking along perfectly in sync, like there's some big universal clock in the sky. But if you're feeling left out the more sophisticated error is "necessarily" the Minkowski fallacy. Systems pay lip service to relativity, but then slide right back into the assumption that underneath it all, time exists as some smooth one-dimensional mathematical line that events just happen on. But you can't take two for two--the idea of a perfectly smooth, continuous time line requires infinite precision to define any single point on it. Computers are finite machines. You simply cannot represent infinite precision. rows = 11; cols = 8; r = 1; gap = 0.2; dx = 2 r (Cos[\[Pi]/8] + gap); dy = 2 r (Cos[\[Pi]/8] + gap); markerSize = 4; Clear[OctagonAt]; OctagonAt[{x_, y_}, rr_] := Polygon[Table[{x, y} + rr RotationTransform[\[Pi]/8 + (i \[Pi])/4][{1, 0}], {i, 0, 7}]]; positions = Association[]; id = 1; Do[positions[id] = {i dx, j dy}; id++, {j, 0, rows - 1}, {i, 0, cols - 1}]; adjacencyList = Association[]; Do[id = j cols + i + 1; adjacencyList[id] = {}; neighbors = {{i - 1, j}, {i + 1, j}, {i, j - 1}, {i, j + 1}, {i - 1, j - 1}, {i + 1, j - 1}, {i - 1, j + 1}, {i + 1, j + 1}}; Do[Module[{ni = neighbor[[1]], nj = neighbor[[2]], nid}, If[0 <= ni < cols && 0 <= nj < rows, nid = nj cols + ni + 1; AppendTo[adjacencyList[id], nid];];], {neighbor, neighbors}], {j, 0, rows - 1}, {i, 0, cols - 1}]; centerI = 0; centerJ = 0; rootNode = centerJ cols + centerI + 1; Print["Root node (center position ", {centerI, centerJ}, ") with valency: ", Length[adjacencyList[rootNode]]]; invalidEdges = RandomInteger[50, 60]; Clear[BFS]; BFS[root_, adjList_Association] := Module[{distances, queue, current, neighbors}, distances = Association[root -> 0]; queue = {root}; While[queue =!= {}, current = First[queue]; queue = Rest[queue]; neighbors = adjList[current]; Do[If[! KeyExistsQ[distances, neighbor], distances[neighbor] = distances[current] + 1; AppendTo[queue, neighbor];], {neighbor, neighbors}];]; distances]; distances = BFS[rootNode, adjacencyList]; Clear[GetAccessibleLinksUpToHop]; GetAccessibleLinksUpToHop[maxHop_Integer] := Module[{accessibleLinks = {}, linkPair, uDist, vDist}, Do[Do[linkPair = Sort[{node, neighbor}]; If[! MemberQ[accessibleLinks, linkPair], uDist = distances[node]; vDist = distances[neighbor]; If[uDist <= maxHop && vDist <= maxHop && Min[uDist, vDist] <= maxHop - 1, AppendTo[accessibleLinks, linkPair];];], {neighbor, adjacencyList[node]}], {node, Keys[adjacencyList]}]; accessibleLinks]; maxHops = Max[Values[distances]] + 1; hopCounts = Table[Count[Values[distances], h], {h, 0, maxHops}]; cumulativeNodeCounts = Table[Count[Values[distances], x_ /; x <= h], {h, 0, maxHops}]; linkCountsAtHop = Table[Module[{currentLinks, previousLinks}, currentLinks = GetAccessibleLinksUpToHop[h]; previousLinks = If[h > 0, GetAccessibleLinksUpToHop[h - 1], {}]; Length[currentLinks] - Length[previousLinks]], {h, 0, maxHops}]; cumulativeLinkCounts = Table[Length[GetAccessibleLinksUpToHop[h]], {h, 0, maxHops}]; Print["Hop counts (nodes): ", hopCounts]; Print["Cumulative accessible nodes: ", cumulativeNodeCounts]; Print["New link counts at each hop: ", linkCountsAtHop]; Print["Cumulative accessible links: ", cumulativeLinkCounts]; Print["Links at hop 0: ", Length[GetAccessibleLinksUpToHop[0]]]; Print["Links at hop 1: ", Length[GetAccessibleLinksUpToHop[1]]]; edges = {}; edgeToNodePair = {}; Do[Do[Module[{edgeLine, nodePair}, edgeLine = Line[{positions[id], positions[neighbor]}]; nodePair = Sort[{id, neighbor}]; AppendTo[edges, edgeLine]; AppendTo[edgeToNodePair, nodePair];], {neighbor, adjacencyList[id]}], {id, Keys[adjacencyList]}]; uniqueEdges = {}; uniqueNodePairs = {}; Do[If[! MemberQ[uniqueNodePairs, edgeToNodePair[[i]]], AppendTo[uniqueEdges, edgeToNodePair[[i]]]; AppendTo[uniqueNodePairs, edgeToNodePair[[i]]];], {i, Length[edgeToNodePair]}]; edgeToNodePair = uniqueEdges; edges = Table[ Line[{positions[pair[[1]]], positions[pair[[2]]]}], {pair, edgeToNodePair}]; Print["Sample edge node pairs: ", Take[edgeToNodePair, UpTo[5]]]; Clear[hopColor]; hopColor[h_] := ColorData["Rainbow"][Rescale[h, {0, maxHops}, {0.1, 0.9}]]; softBackground = Lighter[Gray, 0.97]; shadowOffset = {0.08, -0.08}; xRange = {Min[Values[positions][[All, 1]]] - 1.5, Max[Values[positions][[All, 1]]] + 1.5}; yRange = {Min[Values[positions][[All, 2]]] - 1.5, Max[Values[positions][[All, 2]]] + 1.5}; Clear[CreateGridFrame]; CreateGridFrame[currentHop_Integer] := Module[{accessibleNodes, accessibleLinkPairs, linkGraphics, blackLinkCount, nodeGraphics, statusRow}, accessibleNodes = Select[Keys[distances], distances[#1] <= currentHop &]; accessibleLinkPairs = GetAccessibleLinksUpToHop[currentHop]; linkGraphics = Table[If[ MemberQ[accessibleLinkPairs, edgeToNodePair[[i]]], {Directive[Thickness[0.006], ColorData["Rainbow"][Rescale[currentHop, {0, maxHops}]], Opacity[0.9]], edges[[i]]}, {Directive[Thickness[0.002], GrayLevel[0.7], Opacity[0.25]], edges[[i]]}], {i, Length[edges]}]; blackLinkCount = Length[accessibleLinkPairs]; nodeGraphics = Table[Module[{nodeHop = distances[node], color, pos}, pos = positions[node]; color = If[nodeHop <= currentHop, hopColor[nodeHop], Lighter[Gray, 0.8]]; {{EdgeForm[], FaceForm[Directive[GrayLevel[0], Opacity[0.15]]], OctagonAt[pos + shadowOffset, r 1.02]}, {EdgeForm[ Directive[GrayLevel[0.25], Thickness[0.002]]], FaceForm[Directive[color, Specularity[White, 8]]], OctagonAt[pos, r]}}], {node, Keys[positions]}]; statusRow = Row[{Style["Hop ", 14, Bold, GrayLevel[0.3]], Style[currentHop, 16, Bold, hopColor[currentHop]], Spacer[20], Style["Nodes ", 14, Bold, GrayLevel[0.3]], Style[Length[accessibleNodes], 16, Bold, Darker[Green, 0.2]], Spacer[20], Style["Links ", 14, Bold, GrayLevel[0.3]], Style[cumulativeLinkCounts[[currentHop + 1]], 16, Bold, Darker[Blue, 0.2]], Spacer[20], Style["New at hop ", 12, GrayLevel[0.3]], Style[linkCountsAtHop[[currentHop + 1]], 12, Bold, Darker[Red, 0.2]]}]; Column[{Style["Octagon Grid \[Dash] BFS Wavefront Expansion", 18, Bold, GrayLevel[0.25]], statusRow, Graphics[{linkGraphics, nodeGraphics}, ImageSize -> 450, Background -> softBackground, PlotRange -> {xRange, yRange}, PlotRangePadding -> Scaled[0.05], ImagePadding -> 20, BaseStyle -> {FontFamily -> "Helvetica", 12}]}, Spacings -> {0.8, 0.8}]]; Clear[CreateNodeGraphFrame]; CreateNodeGraphFrame[currentHop_Integer] := Module[{currentHopCounts, currentCumulative, hopRange}, currentHopCounts = hopCounts[[1 ;; currentHop + 1]]; currentCumulative = cumulativeNodeCounts[[1 ;; currentHop + 1]]; hopRange = Range[0, currentHop]; ListLinePlot[{Transpose[{hopRange, currentHopCounts}], Transpose[{hopRange, currentCumulative}]}, PlotStyle -> {Directive[ColorData["Rainbow"][0.15], Thickness[0.006]], Directive[ColorData["Rainbow"][0.75], Thickness[0.006], Dashed]}, PlotMarkers -> {{Automatic, markerSize}, {Automatic, markerSize}}, Filling -> {2 -> {1}}, Background -> softBackground, Frame -> True, Axes -> False, FrameLabel -> {Style["Hop count", 12, GrayLevel[0.2]], Style["Number of nodes", 12, GrayLevel[0.2]]}, PlotLabel -> Style["Node Accessibility vs Hop Count", 14, Bold], GridLines -> {Range[0, maxHops, 2], Automatic}, GridLinesStyle -> Directive[GrayLevel[0.85], Dashed], ImageSize -> 420, PlotRange -> {{0, maxHops}, {0, 1.05 Max[cumulativeNodeCounts]}}, PlotLegends -> {"Nodes at each hop", "Cumulative accessible nodes"}, BaseStyle -> {FontFamily -> "Helvetica", 11}]]; Clear[CreateLinkGraphFrame]; CreateLinkGraphFrame[currentHop_Integer] := Module[{currentLinkCounts, currentCumulativeLinks, hopRange, theoreticalMax}, currentLinkCounts = linkCountsAtHop[[1 ;; currentHop + 1]]; currentCumulativeLinks = cumulativeLinkCounts[[1 ;; currentHop + 1]]; hopRange = Range[0, currentHop]; theoreticalMax = 4 (rows - 1) (cols - 1) + rows + cols - 2; ListLinePlot[{Transpose[{hopRange, currentLinkCounts}], Transpose[{hopRange, currentCumulativeLinks}]}, PlotStyle -> {Directive[ColorData["Rainbow"][0.35], Thickness[0.006]], Directive[ColorData["Rainbow"][0.9], Thickness[0.006], Dashed]}, PlotMarkers -> {{Automatic, markerSize}, {Automatic, markerSize}}, Background -> softBackground, Frame -> True, Axes -> False, FrameLabel -> {Style["Hop count", 12, GrayLevel[0.2]], Style["Number of links", 12, GrayLevel[0.2]]}, PlotLabel -> Style["Link Accessibility vs Hop Count", 14, Bold], GridLines -> {Range[0, maxHops, 2], Automatic}, GridLinesStyle -> Directive[GrayLevel[0.85], Dashed], ImageSize -> 900, PlotRange -> {{0, maxHops}, {0, 1.05 theoreticalMax}}, PlotLegends -> {"New links at each hop", "Cumulative accessible links"}, BaseStyle -> {FontFamily -> "Helvetica", 11}]]; animation = Animate[Column[{Row[{CreateGridFrame[h], Spacer[25], CreateNodeGraphFrame[h]}], Spacer[15], CreateLinkGraphFrame[h]}, Spacings -> {1.0, 1.0}], {h, 0, maxHops, 1}, AnimationRate -> 1, AnimationDirection -> Forward, AnimationRepetitions -> \[Infinity]]; animation ![Sample Edge Node Pairs][2] Root node (center position {0,0}) with valency: 3 Hop counts (nodes): {1,3,5,7,9,11,13,15,8,8,8,0} Cumulative accessible nodes: {1,4,9,16,25,36,49,64,72,80,88,88} New link counts at each hop: {0,3,12,20,28,36,44,52,37,29,29,7} Cumulative accessible links: {0,3,15,35,63,99,143,195,232,261,290,297} Links at hop 0: 0 Links at hop 1: 3 Sample edge node pairs: {{1,2},{1,9},{1,10},{2,3},{2,10}} Those last few decimal places in the timestamp are essentially meaningless noise. The order is arbitrary--but the database saves and treats it as gospel truth. That leads directly to an incorrect causal ordering of events. What really happened first might be different, but the log has already decided--and it's wrong. TCP is a classic example of the Minkowski error in action. It tries to build a shared timeline between two endpoints, and when that shared understanding fails, you get unrecoverable data corruption--or your browser just gives up after a few tries. It's not so much a reversal as it is a continuation of the protocol which tries to force a direction in time using monotonic sequence numbers. But when the network state is lost, those numbers become totally ambiguous. The protocol has no reliable way left to figure out which data exchange truly came before another across that gap. ## Analyzing Accessibility vs. Hop Count ## A survivable metric for any network will always be the relationship between hop count, node accessibility, and link accessibility. This defines the network's diameter and cost of communication. We calculate the nodes and new links discovered at each hop. ClearAll["Global`*"]; rows = 11; cols = 11; r = 1; gap = 0.20; dx = 2 r (Cos[\[Pi]/8] + gap); dy = 2 r (Cos[\[Pi]/8] + gap); OctagonAt[{x_, y_}, rad_] := Polygon[Table[{x, y} + rad RotationTransform[\[Pi]/8 + (i \[Pi])/4][{1, 0}], {i, 0, 7}]]; positions = Association[ Flatten[Table[ With[{id = j cols + i + 1}, id -> {i dx, j dy}], {j, 0, rows - 1}, {i, 0, cols - 1}], 1]]; adjacencyList = Association[ Flatten[Table[ With[{id = j cols + i + 1}, Module[{nbrIdx, validNbrs}, nbrIdx = {{i - 1, j}, {i + 1, j}, {i, j - 1}, {i, j + 1}, {i - 1, j - 1}, {i + 1, j - 1}, {i - 1, j + 1}, {i + 1, j + 1}}; validNbrs = Select[nbrIdx, 0 <= #1[[1]] < cols && 0 <= #1[[2]] < rows &]; id -> (validNbrs /. {ii_, jj_} :> jj cols + ii + 1)]], {j, 0, rows - 1}, {i, 0, cols - 1}], 1]]; centerI = Floor[cols/2]; centerJ = Floor[rows/2]; rootNode = centerJ cols + centerI + 1; Print[Style[ Row[{"Root node: (center position: ", {centerI, centerJ}, ") with valency: ", Length[adjacencyList[rootNode]]}], 14, Bold]]; BFS[root_, adj_Association] := Module[{distances, queue, current, neighbors}, distances = Association[root -> 0]; queue = {root}; While[queue =!= {}, current = First[queue]; queue = Rest[queue]; neighbors = adj[current]; Do[If[! KeyExistsQ[distances, nbr], distances[nbr] = distances[current] + 1; queue = Append[queue, nbr];], {nbr, neighbors}];]; distances]; distances = BFS[rootNode, adjacencyList]; maxHops = Max[Values[distances]]; edgeAssoc = Association[]; Do[Do[With[{pair = Sort[{id, nbr}]}, If[! KeyExistsQ[edgeAssoc, pair], edgeAssoc[pair] = Line[{positions[id], positions[nbr]}];];], {nbr, adjacencyList[id]}], {id, Keys[adjacencyList]}]; edgeToNodePair = Keys[edgeAssoc]; edges = Values[edgeAssoc]; Print["Sample edge node pairs: ", Take[edgeToNodePair, UpTo[5]]]; firstHopList = Table[Module[{u, v, du, dv, m, M}, u = pair[[1]]; v = pair[[2]]; du = distances[u]; dv = distances[v]; m = Min[du, dv]; M = Max[du, dv]; Max[M, m + 1]], {pair, edgeToNodePair}]; firstHopList = (Min[#1, maxHops] &) /@ firstHopList; edgeFirstHopAssoc = AssociationThread[edgeToNodePair -> firstHopList]; accessibleEdgePairsPerHop = Table[Pick[edgeToNodePair, UnitStep[h - firstHopList], 1], {h, 0, maxHops}]; GetAccessibleLinksUpToHop[h_Integer] := accessibleEdgePairsPerHop[[h + 1]]; hopCounts = Table[Count[Values[distances], h], {h, 0, maxHops}]; cumulativeNodeCounts = Table[Count[Values[distances], x_ /; x <= h], {h, 0, maxHops}]; linkCountsAtHop = Table[Count[firstHopList, h], {h, 0, maxHops}]; cumulativeLinkCounts = Table[Count[firstHopList, _?(#1 <= h &)], {h, 0, maxHops}]; Print["Hop counts (nodes): ", hopCounts]; Print["Cumulative accessible nodes: ", cumulativeNodeCounts]; Print["New link counts at each hop: ", linkCountsAtHop]; Print["Cumulative accessible links: ", cumulativeLinkCounts]; Print["Links at hop 0: ", Length[GetAccessibleLinksUpToHop[0]]]; Print["Links at hop 1: ", Length[GetAccessibleLinksUpToHop[1]]]; hopPalette[hop_, maxHop_] := ColorData["DarkRainbow"][Rescale[hop, {0, maxHop}]]; posArray = Values[positions]; {xMin, xMax} = MinMax[posArray[[All, 1]]]; {yMin, yMax} = MinMax[posArray[[All, 2]]]; plotRange2D = {{xMin - 1.5, xMax + 1.5}, {yMin - 1.5, yMax + 1.5}}; maxRange = 4 (rows - 1) (cols - 1) + rows + cols - 2; CreateGridFrame[currentHop_Integer] := Module[{accessibleNodes, accessibleLinkPairs, linkGraphics, nodeGraphics, blackLinkCount}, accessibleNodes = Select[Keys[distances], distances[#1] <= currentHop &]; accessibleLinkPairs = GetAccessibleLinksUpToHop[currentHop]; linkGraphics = Table[Module[{pair = edgeToNodePair[[i]], base = edges[[i]], styleActive, styleInactive}, styleActive = Directive[ColorData["BrightBands"][0.15], Opacity[0.9], Thickness[0.006]]; styleInactive = Directive[GrayLevel[0.6], Opacity[0.25], Thickness[0.002]]; If[MemberQ[accessibleLinkPairs, pair], {styleActive, base}, {styleInactive, base}]], {i, Length[edges]}]; blackLinkCount = Length[accessibleLinkPairs]; nodeGraphics = Table[Module[{nodeHop, col, baseStyle, inactiveStyle}, nodeHop = distances[node]; col = hopPalette[nodeHop, maxHops]; baseStyle = {EdgeForm[{GrayLevel[0.1], Thickness[0.003]}], Glow[Directive[col, Opacity[0.85]]], FaceForm[Directive[col, Opacity[0.95]]]}; inactiveStyle = {EdgeForm[{GrayLevel[0.4], Thickness[0.0015]}], FaceForm[Directive[GrayLevel[0.8], Opacity[0.4]]]}; If[nodeHop <= currentHop, {baseStyle, OctagonAt[positions[node], r]}, {inactiveStyle, OctagonAt[positions[node], r]}]], {node, Keys[positions]}]; Column[{Style[ Row[{"Hop: ", currentHop, " | Accessible Nodes: ", Length[accessibleNodes], " | Accessible Links: ", cumulativeLinkCounts[[currentHop + 1]], " | Active Links This Frame: ", blackLinkCount}], 13, Black, Bold], Graphics[{{Directive[GrayLevel[0.97], Opacity[1]], Rectangle[{xMin - 2, yMin - 2}, {xMax + 2, yMax + 2}]}, linkGraphics, nodeGraphics, {Directive[Black, Thickness[0.006], Opacity[0.9]], Circle[positions[rootNode], 1.15 r]}}, Background -> White, PlotRange -> plotRange2D, ImageSize -> 420, Frame -> True, FrameStyle -> Directive[GrayLevel[0.3], Thickness[0.002]], PlotRangePadding -> Scaled[0.05]]}]]; CreateNodeGraphFrame[currentHop_Integer] := Module[{currentHopCounts, currentCumulativeNodes, currentCumulativeLinks, dataLinks, dataNodes}, currentHopCounts = hopCounts[[1 ;; currentHop + 1]]; currentCumulativeNodes = cumulativeNodeCounts[[1 ;; currentHop + 1]]; currentCumulativeLinks = cumulativeLinkCounts[[1 ;; currentHop + 1]]; dataLinks = Transpose[{Range[0, currentHop], currentCumulativeLinks}]; dataNodes = Transpose[{Range[0, currentHop], currentCumulativeNodes}]; ListLinePlot[{dataLinks, dataNodes}, PlotStyle -> {Directive[ColorData["BrightBands"][0.20], Thick], Directive[ColorData["BrightBands"][0.7], Thick, Dashed]}, PlotMarkers -> {{Automatic, 4}, {Automatic, 4}}, Frame -> True, FrameLabel -> {Style["Hop Count", 13, GrayLevel[0.20]], Style["Cumulative Count", 13, GrayLevel[0.20]]}, PlotLabel -> Style["Accessibility vs. Hop Distance", 14, Bold, Black], GridLines -> {Range[0, maxHops, 2], None}, GridLinesStyle -> Directive[GrayLevel[0.85], Dashed, Thickness[0.0015]], Background -> White, FrameStyle -> Directive[GrayLevel[0.3], Thickness[0.002]], TicksStyle -> Directive[GrayLevel[0.25], 10], PlotRange -> {{0, maxHops}, {0, maxRange}}, ImageSize -> 420, PlotRangePadding -> Scaled[0.05], PlotLegends -> Placed[{"Cumulative accessible links", "Cumulative accessible nodes"}, {0.55, 0.9}]]]; frames = Table[Row[{CreateGridFrame[h], Spacer[20], CreateNodeGraphFrame[h]}, ImageSize -> 900], {h, 0, maxHops}]; animation = Animate[Row[{CreateGridFrame[h], Spacer[20], CreateNodeGraphFrame[h]}, ImageSize -> 900], {h, 0, maxHops, 1}, AnimationRate -> 1, AnimationDirection -> Forward, DefaultDuration -> maxHops + 1]; ListAnimate[frames]; Export["hopLinks_sidebyside_beautiful.gif", frames, "DisplayDurations" -> 1]; animation At the end of the day, you cannot engineer your way around the fundamental laws of physics. It is absolutely impossible to synchronize clocks perfectly. Clocks can't be synchronized in time; they can only be synchronized in frequency. That distinction is absolutely everything. I suppose a rough analogy would be if you took the derivation of the Lorentz constant or, who knew the Lorentz constant like we do. Time seems to be tied directly to information exchange. When an agent receives information, time goes forward locally for that agent. But when it emits or loses information, its frame of reference shifts in a complex way. ![Frame of Reference][3] Root node: (center position: {5,5}) with valency: 8 Sample edge node pairs: {{1,2},{1,12},{1,13},{2,3},{2,13}} Hop counts (nodes): {1,8,16,24,32,40} Cumulative accessible nodes: {1,9,25,49,81,121} New link counts at each hop: {0,8,44,76,108,184} Cumulative accessible links: {0,8,52,128,236,420} Links at hop 0: 0 Links at hop 1: 8 ## Physicalizing the Scouting Wavefront ## Now we combine these elements into a visualization. The following code generates an animation of the BFS wavefront expanding. The left panel shows the "scouting" process on the lattice itself, coloring nodes by their hop distance. The right panel plots the cumulative growth of accessible nodes and links. This isn't just a "pretty picture"; it's a model of discovery. We are watching the `rootNode` build its map of the reachable world. ClearAll[rows, cols, r, gap, dx, dy, OctagonAt, positions, originalAdjacencyList, RemoveEdges, AnimatedBFS, allEdges, rootNode, centerI, centerJ]; rows = 11; cols = 11; r = 1; gap = 0.2; dx = 2 r (Cos[\[Pi]/8] + gap); dy = 2 r (Cos[\[Pi]/8] + gap); OctagonAt[{x_, y_}, rr_] := GeometricTransformation[RegularPolygon[{x, y}, rr, 8], RotationTransform[\[Pi]/8, {x, y}]]; positions = Association[]; Module[{id = 1}, Do[positions[id] = {i dx, j dy}; id++, {j, 0, rows - 1}, {i, 0, cols - 1}];]; originalAdjacencyList = Association[]; Do[Module[{id = j cols + i + 1, neighbors, validNeighbors}, neighbors = {{i - 1, j}, {i + 1, j}, {i, j - 1}, {i, j + 1}, {i - 1, j - 1}, {i + 1, j - 1}, {i - 1, j + 1}, {i + 1, j + 1}}; validNeighbors = Select[neighbors, 0 <= #1[[1]] < cols && 0 <= #1[[2]] < rows &]; originalAdjacencyList[id] = (#1[[2]] cols + #1[[1]] + 1 &) /@ validNeighbors;], {j, 0, rows - 1}, {i, 0, cols - 1}]; centerI = 0; centerJ = 0; rootNode = centerJ cols + centerI + 1; Print[Style["BFS Root Node Diagnostics", 14, Bold, Black], "\n", "Root node: ", rootNode, " (grid position: ", {centerI, centerJ}, ")", " with valency: ", Length[originalAdjacencyList[rootNode]]]; allEdges = DeleteDuplicates[ Reap[Do[With[{id = key}, Sow /@ Sort /@ Select[Thread[{id, originalAdjacencyList[id]}], #1[[1]] < #1[[2]] &]], {key, Keys[originalAdjacencyList]}]][[2, 1]]]; Print["Total edges in graph: ", Length[allEdges]]; RemoveEdges[adjList_, edgesToRemove_List] := Module[{newAdjList = Association[adjList]}, Do[With[{u = edge[[1]], v = edge[[2]]}, newAdjList[u] = DeleteCases[newAdjList[u], v]; newAdjList[v] = DeleteCases[newAdjList[v], u];], {edge, edgesToRemove}]; newAdjList]; AnimatedBFS[root_, adjList_Association] := Module[{distances, parentMap, queue, current, neighbors, steps}, distances = Association[root -> 0]; parentMap = Association[]; queue = {root}; steps = {Association[distances]}; While[queue =!= {}, current = First[queue]; queue = Rest[queue]; neighbors = Lookup[adjList, current, {}]; Do[If[! KeyExistsQ[distances, neighbor], distances[neighbor] = distances[current] + 1; parentMap[neighbor] = current; AppendTo[queue, neighbor]; AppendTo[steps, Association[distances]];], {neighbor, neighbors}];]; {distances, parentMap, steps}]; DynamicModule[{numFailedEdges = 0, failedEdges = {}, currentReachable = Length[Keys[originalAdjacencyList]], currentUnreachable = 0, finalDistances = Association[], finalParentMap = Association[], bfsSteps = {}, currentAdjList = originalAdjacencyList, maxFailures = Min[50, Length[allEdges]], animationRunning = False, currentStep = 0, maxSteps = 0, animationSpeed = 0.4}, {finalDistances, finalParentMap, bfsSteps} = AnimatedBFS[rootNode, currentAdjList]; currentReachable = Length[Keys[finalDistances]]; currentUnreachable = Length[Keys[originalAdjacencyList]] - currentReachable; maxSteps = Max[0, Length[bfsSteps] - 1]; Column[{Panel[ Column[{Style["Network Failure & BFS Controls", 16, Bold, Black, FontFamily -> "Helvetica"], Row[{"Number of failed edges: ", Slider[Dynamic[numFailedEdges], {0, Length[allEdges], 1}], Spacer[8], Panel[Dynamic[numFailedEdges], Background -> White, FrameMargins -> {{6, 6}, {2, 2}}]}], Row[{"Animation speed (seconds/step): ", Slider[Dynamic[animationSpeed], {0.1, 2.0, 0.1}], Spacer[8], Dynamic[NumberForm[animationSpeed, {2, 1}]]}], Row[{Style["Reachable nodes: ", Bold, Darker[Green]], Dynamic[currentReachable], Spacer[20], Style["Unreachable nodes: ", Bold, Darker[Red]], Dynamic[currentUnreachable]}], Row[{Button[Style["Random Edge Failures", 12, Bold, Black], failedEdges = If[numFailedEdges > 0, RandomSample[allEdges, numFailedEdges], {}]; currentAdjList = RemoveEdges[originalAdjacencyList, failedEdges]; {finalDistances, finalParentMap, bfsSteps} = AnimatedBFS[rootNode, currentAdjList]; currentReachable = Length[Keys[finalDistances]]; currentUnreachable = Length[Keys[originalAdjacencyList]] - currentReachable; maxSteps = Max[0, Length[bfsSteps] - 1]; currentStep = 0; animationRunning = False;], Spacer[10], Button[Style["Start BFS Animation", 12, Bold, Black], If[Length[bfsSteps] > 0, currentStep = 0; animationRunning = True;]], Spacer[10], Button[Style["Reset All Links", 12, Bold, Black], failedEdges = {}; numFailedEdges = 0; currentAdjList = originalAdjacencyList; {finalDistances, finalParentMap, bfsSteps} = AnimatedBFS[rootNode, currentAdjList]; currentReachable = Length[Keys[finalDistances]]; currentUnreachable = 0; maxSteps = Max[0, Length[bfsSteps] - 1]; currentStep = 0; animationRunning = False;]}], If[maxSteps > 0, Row[{"Animation step: ", Slider[Dynamic[currentStep], {0, maxSteps, 1}], Spacer[6], Dynamic[Style[Row[{currentStep, " / ", maxSteps}], 11, Bold, Black]]}], Nothing]}, Spacings -> 1.2, BaseStyle -> {Black}], Background -> Lighter[Blend[{Gray, Blue}, 0.15], 0.85], FrameMargins -> Medium, FrameStyle -> Directive[GrayLevel[0.4], Thickness[0.003]]], Dynamic[If[animationRunning && currentStep < maxSteps, Pause[animationSpeed]; currentStep++; If[currentStep >= maxSteps, animationRunning = False];]; ""], Dynamic[Module[{workingEdges, workingCoords, failedCoords, failedEdgeLines, workingEdgeLines, nodeGraphics, arrowGraphics, currentDistancesStep, visibleNodes, coords, minX, maxX, minY, maxY, maxKnownDist, distanceColor, totalNodes}, totalNodes = Length[Keys[originalAdjacencyList]]; currentDistancesStep = If[Length[bfsSteps] > 0 && 0 <= currentStep < Length[bfsSteps], bfsSteps[[currentStep + 1]], Association[]]; visibleNodes = Keys[currentDistancesStep]; workingEdges = Complement[allEdges, failedEdges]; workingCoords = (positions /@ #1 &) /@ workingEdges; failedCoords = (positions /@ #1 &) /@ failedEdges; coords = Values[positions]; {minX, maxX} = {Min[coords[[All, 1]]], Max[coords[[All, 1]]]}; {minY, maxY} = {Min[coords[[All, 2]]], Max[coords[[All, 2]]]}; maxKnownDist = If[finalDistances === Association[], 1, Max[Values[finalDistances]]]; distanceColor[d_] := ColorData["SolarColors"][Rescale[d, {0, maxKnownDist}, {0, 1}]]; failedEdgeLines = If[failedCoords === {}, {}, {Glow[Red], Directive[Red, Thickness[0.012], Dashed, CapForm["Round"]], Line /@ failedCoords}]; workingEdgeLines = If[workingCoords === {}, {}, {Directive[GrayLevel[0.25, 0.6], Thickness[0.004]], CapForm["Round"], Line /@ workingCoords}]; nodeGraphics = Table[Module[{pt = positions[node]}, Which[node === rootNode, {EdgeForm[{Black, Thick}], FaceForm[RGBColor[0.9, 0.4, 0.3]], OctagonAt[pt, 1.1 r]}, MemberQ[visibleNodes, node], {EdgeForm[{Darker[Green, 0.4], Thickness[0.005]}], FaceForm[distanceColor[currentDistancesStep[node]]], OctagonAt[pt, r]}, KeyExistsQ[finalDistances, node], {EdgeForm[{GrayLevel[0.4], Thickness[0.003]}], FaceForm[Directive[GrayLevel[0.9], Opacity[0.9]]], OctagonAt[pt, r]}, True, {EdgeForm[{GrayLevel[0.7], Thickness[0.002]}], FaceForm[Directive[RGBColor[0.9, 0.7, 0.8], Opacity[0.6]]], OctagonAt[pt, r]}]], {node, Keys[positions]}]; arrowGraphics = If[finalParentMap === Association[], {}, Table[If[ KeyExistsQ[finalParentMap, node] && MemberQ[visibleNodes, node], {Directive[ RGBColor[0.1, 0.4, 0.9], Thickness[0.008]], Arrowheads[0.03], Arrow[{positions[finalParentMap[node]], positions[node]}]}, Nothing], {node, Keys[finalParentMap]}]]; EventHandler[ Graphics[{{FaceForm[Lighter[Blend[{Blue, Black}, 0.9], 0.9]], EdgeForm[None], Rectangle[{minX - 10, minY - 10}, {maxX + 10, maxY + 10}]}, workingEdgeLines, failedEdgeLines, nodeGraphics, arrowGraphics, Inset[Framed[ Column[{Style["BFS on an Octagon Lattice", 18, Bold, Black, FontFamily -> "Helvetica"], Style[Row[{"Step ", currentStep, " of ", maxSteps, " | Visible nodes: ", Length[visibleNodes], " | (Click lattice when paused to step)"}], 12, GrayLevel[0.05]]}, Spacings -> 0.3], Background -> Directive[White, Opacity[0.85]], FrameMargins -> {{10, 10}, {6, 6}}, RoundingRadius -> 10, FrameStyle -> Directive[GrayLevel[0.6], Thickness[0.002]]], {Mean[{minX, maxX}], maxY + 3}], Inset[Framed[ Grid[{{Style["Legend", 11, Bold, Black]}, {Row[{Style["Root", 11, Bold, Darker[Green]], ": central red-tinted octagon"}]}, {Row[{Style[ "Reached", 11, Bold, Darker[Green]], ": colored (Solar palette) nodes"}]}, {Row[{Style[ "Reachable later", 11, Bold, GrayLevel[0.2]], ": light gray nodes in component"}]}, {Row[{Style[ "Unreachable", 11, Bold, Darker[Red]], ": pale pink nodes"}]}, {Row[{Style["Failed links", 11, Bold, Red], ": thick glowing red dashed edges"}]}}, Spacings -> {0.8, 0.6}], Background -> Directive[White, Opacity[0.85]], RoundingRadius -> 8, FrameMargins -> {{8, 8}, {6, 6}}, FrameStyle -> Directive[GrayLevel[0.7], Thickness[0.0015]]], {minX - 4, maxY + 3}, {Left, Center}]}, ImageSize -> 800, PlotRange -> {{minX - 3, maxX + 3}, {minY - 3, maxY + 6}}, PlotRangePadding -> Scaled[0.03], Background -> Lighter[Gray, 0.96]], {"MouseDown" :> If[! animationRunning && currentStep < maxSteps, currentStep++;]}]]], Panel[Column[{Style["Network Resilience Metrics", 15, Bold, Black, FontFamily -> "Helvetica"], Dynamic[Grid[{{"Total nodes:", Length[Keys[originalAdjacencyList]]}, {"Total edges:", Length[allEdges]}, {"Failed edges:", Length[failedEdges]}, {"Final reachable nodes:", currentReachable}, {"Final unreachable nodes:", currentUnreachable}, {"Connectivity:", If[currentReachable > 0, Row[{NumberForm[ N[(100.0 currentReachable)/ Length[Keys[originalAdjacencyList]]], {4, 1}], " %"}], "0 %"]}}, Frame -> All, Background -> {None, {Lighter[Gray, 0.9], White}}, ItemSize -> All, BaseStyle -> {Black}]]}, Spacings -> 1.2, BaseStyle -> {Black}], Background -> Lighter[Blend[{Yellow, White}, 0.8], 0.9], FrameStyle -> Directive[GrayLevel[0.4], Thickness[0.002]], FrameMargins -> Medium]}, Spacings -> 1.4]] Here is a version of the animation starting from the bottom left of the grid, whereas in contrast the centralized version more clearly shows the uniform expansion in a perfectly connected network. BFS Root Node Diagnostics Root node: 1 (grid position: {0,0}) with valency: 3 Total edges in graph: 420 ![Animation][4] The physics suggests that at the tiny micro level, time, from its perspective (frame of reference), can effectively be seen as going backward locally. The direction of time isn't set by some universal clock; it's defined by the flow of information and quantum entanglement between things. It really makes you wonder why there's so many applications like let's say you got a blood transfusion without even checking the Rh factor. Well, it should come as no temporal recurrence that MVCC at scale depends entirely on reliable clock synchronization to detect that right-skew situation. But if the clock sync fails--which we now know it inevitably will at some level of precision--that right-skew goes completely undetected. The database log, the record of what happened, becomes fundamentally inconsistent, potentially unrecoverable without serious manual intervention--if it's even possible at all. So it's always going to be this way as long as these nodes talk--they pull each other this way and that and even that's all they do but here's a thought experiment--what if you pull a cable? ## Modeling: "When You Pull a Cable" ## A static, perfect network is a fantasy. A robust system must be designed for failure. As we often say, "an engineer has to learn how to enjoy smoke". The most critical question is: ***"When you pull a cable, can it recover all by itself?"*** Legacy protocols, built on timeouts, handle this poorly. When a link fails, they enter a "quagmire of timeout and retry", creating ambiguity that leads to "corrupted transactions". Our approach demands that the network *knows* its state. The following code comes and creates a continuative simulation. But now, you can use a slider to introduce `numFailedEdges`--simulating "pulling the cable." When you click "Random Edge Failures," the `adjacencyList` is up-dated, and the BFS "scouting" algorithm runs again. And here you shall find something quite weird; the visualization immediately updates (to the extent of that), showing the new, fragmented reality. Nodes that are no longer reachable from the root are obscure and marked as **Unreachable**. ClearAll["Global`*"]; rows = 11; cols = 8; r = 1.; gap = 0.2; dx = 2 r (Cos[\[Pi]/8] + gap); dy = 2 r (Cos[\[Pi]/8] + gap); OctagonAt[{x_, y_}, rad_] := Polygon[Table[{x, y} + rad RotationTransform[\[Pi]/8 + (i \[Pi])/4][{1, 0}], {i, 0, 7}]]; idFromIJ[i_Integer, j_Integer] := j cols + i + 1; ijFromId[id_Integer] := {Mod[id - 1, cols], Quotient[id - 1, cols]}; positions = Association[ Table[With[{ij = ijFromId[id]}, With[{i = ij[[1]], j = ij[[2]]}, id -> {i dx, j dy}]], {id, 1, rows cols}]]; adjacencyList = Association[ Table[Module[{i, j, nbrIJ, nbrIds}, {i, j} = ijFromId[id]; nbrIJ = {{i - 1, j}, {i + 1, j}, {i, j - 1}, {i, j + 1}, {i - 1, j - 1}, {i + 1, j - 1}, {i - 1, j + 1}, {i + 1, j + 1}}; nbrIds = idFromIJ @@@ Select[nbrIJ, 0 <= #1[[1]] < cols && 0 <= #1[[2]] < rows &]; id -> nbrIds], {id, 1, rows cols}]]; centerI = Floor[(cols - 1)/2]; centerJ = Floor[(rows - 1)/2]; rootNode = idFromIJ[centerI, centerJ]; Print["Root node (center position ", {centerI, centerJ}, ") with valency ", Length[adjacencyList[rootNode]]]; BFS[root_, adj_Association] := Module[{dist = Association[root -> 0], q = {root}, current, neigh}, While[q =!= {}, current = First[q]; q = Rest[q]; neigh = adj[current]; Do[If[! KeyExistsQ[dist, v], dist[v] = dist[current] + 1; q = Append[q, v];], {v, neigh}];]; dist]; distances = BFS[rootNode, adjacencyList]; maxHop = Max[Values[distances]]; hopCounts = Table[Count[Values[distances], h], {h, 0, maxHop}]; cumulativeNodeCounts = Table[Count[Values[distances], _?(#1 <= h &)], {h, 0, maxHop}]; edgeNodePairs = Union[Flatten[ Table[Sort /@ Thread[{id, adjacencyList[id]}], {id, Keys[adjacencyList]}], 1]]; edges = Line /@ (positions /@ #1 &) /@ edgeNodePairs; Print["Sample edge node pairs: ", Take[edgeNodePairs, UpTo[5]]]; Clear[AccessibleLinksUpToHop]; AccessibleLinksUpToHop[h_Integer?NonNegative] := Module[{pairs}, pairs = Select[edgeNodePairs, With[{u = #1[[1]], v = #1[[2]], du = distances[#1[[1]]], dv = distances[#1[[2]]]}, du <= h && dv <= h && Min[du, dv] <= h - 1] &]; pairs]; linkCountsAtHop = Table[Length[AccessibleLinksUpToHop[h]] - If[h == 0, 0, Length[AccessibleLinksUpToHop[h - 1]]], {h, 0, maxHop}]; cumulativeLinkCounts = Table[Length[AccessibleLinksUpToHop[h]], {h, 0, maxHop}]; Print["Hop counts (nodes): ", hopCounts]; Print["Cumulative accessible nodes: ", cumulativeNodeCounts]; Print["New link counts at each hop: ", linkCountsAtHop]; Print["Cumulative accessible links: ", cumulativeLinkCounts]; Print["Links at hop 0: ", cumulativeLinkCounts[[1]]]; If[maxHop >= 1, Print["Links at hop 1: ", cumulativeLinkCounts[[2]]];]; hopColors = {Red, Orange, Yellow, Green, Cyan, Blue, Purple, Pink, Brown}; CreateGridFrame[currentHop_Integer?NonNegative] := Module[{accessibleNodes, linkPairs, linkGraphics, nodeGraphics, blackLinkCount, pr}, accessibleNodes = Select[Keys[distances], distances[#1] <= currentHop &]; linkPairs = AccessibleLinksUpToHop[currentHop]; blackLinkCount = Length[linkPairs]; linkGraphics = Table[If[ MemberQ[linkPairs, edgeNodePairs[[k]]], {Black, Thick, edges[[k]]}, {LightGray, Thin, edges[[k]]}], {k, Length[edgeNodePairs]}]; nodeGraphics = Table[With[{nodeHop = distances[node]}, Module[{color}, color = If[nodeHop <= currentHop, hopColors[[Mod[nodeHop, Length[hopColors]] + 1]], LightGray]; {EdgeForm[Black], FaceForm[color], OctagonAt[positions[node], r]}]], {node, Keys[positions]}]; pr = {{Min[Values[positions][[All, 1]]] - 1.5, Max[Values[positions][[All, 1]]] + 1.5}, {Min[Values[positions][[All, 2]]] - 1.5, Max[Values[positions][[All, 2]]] + 1.5}}; Column[{Text[ Style["Hop: " <> ToString[currentHop] <> " | Nodes: " <> ToString[Length[accessibleNodes]] <> " | Links: " <> ToString[cumulativeLinkCounts[[currentHop + 1]]] <> " | Black links: " <> ToString[blackLinkCount], 12, Bold, Black]], Graphics[{linkGraphics, nodeGraphics}, ImageSize -> 400, PlotRange -> pr]}]]; CreateNodeGraphFrame[currentHop_Integer?NonNegative] := Module[{hs, currentHopCounts, currentCum}, hs = Range[0, currentHop]; currentHopCounts = hopCounts[[1 ;; currentHop + 1]]; currentCum = cumulativeNodeCounts[[1 ;; currentHop + 1]]; ListLinePlot[{Transpose[{hs, currentHopCounts}], Transpose[{hs, currentCum}]}, PlotStyle -> {{Red, Thick}, {Blue, Thick}}, PlotLegends -> {"Nodes at each hop", "Cumulative accessible nodes"}, AxesLabel -> {"Hop Count", "Number of Nodes"}, PlotLabel -> "Node Accessibility vs Hop Count", GridLines -> Automatic, ImageSize -> 400, PlotRange -> {{0, maxHop}, {0, Max[cumulativeNodeCounts]}}]]; CreateLinkGraphFrame[currentHop_Integer?NonNegative] := Module[{hs, currentNew, currentCum}, hs = Range[0, currentHop]; currentNew = linkCountsAtHop[[1 ;; currentHop + 1]]; currentCum = cumulativeLinkCounts[[1 ;; currentHop + 1]]; ListLinePlot[{Transpose[{hs, currentNew}], Transpose[{hs, currentCum}]}, PlotStyle -> {{Green, Thick}, {Purple, Thick}}, PlotLegends -> {"New links at each hop", "Cumulative accessible links"}, AxesLabel -> {"Hop Count", "Number of Links"}, PlotLabel -> "Link Accessibility vs Hop Count", GridLines -> Automatic, ImageSize -> 400, PlotRange -> {{0, maxHop}, {0, Max[cumulativeLinkCounts]}}]]; animation = Animate[Column[{Row[{CreateGridFrame[h], Spacer[20], CreateNodeGraphFrame[h]}], Spacer[10], CreateLinkGraphFrame[h]}], {h, 0, maxHop, 1}, AnimationRate -> 1, AnimationDirection -> Forward]; animation Given all this what's the strictly correct but too-slow baseline? Well, there's one alternative that is 100% reliable: strict two-phase locking. It absolutely guarantees consistency--but it sacrifices performance. You lose the high throughput and low latency that massive web-scale applications demand and that'll do ya. Root node (center position {3,5}) with valency 8 Sample edge node pairs: {{1,2},{1,9},{1,10},{2,3},{2,9}} Hop counts (nodes): {1,8,16,24,23,16} Cumulative accessible nodes: {1,9,25,49,72,88} New link counts at each hop: {0,8,44,76,87,68} Cumulative accessible links: {0,8,52,128,215,283} Links at hop 0: 0 Links at hop 1: 8 So it's this constant trade-off: perfect consistency versus speed. Most modern systems choose speed and simply accept the hidden risk of eventual data corruption due to faulty clocks. ![Constant Trade-Off][5] This simulation is the heart of the matter. We have not entered a timeout loop. The graphs don't look like those loops of computational "spaghetti" that plague the ordinary differential topology as we have scouted the new topology. ***The system knows, with mathematical certainty, that a set of nodes is now `unreachable`.*** There is no ambiguity, and therefore, no "right skew" or data corruption. The network has successfully identified the failure and can now "heal around the error"--a process that must happen in nanoseconds, not versus the "milliseconds and seconds" of legacy systems. ClearAll[rows, cols, r, gap, dx, dy, OctagonAt, positions, adjacencyList, centerI, centerJ, rootNode, BFS, distances, GetAccessibleLinksUpToHop, maxHops, hopCounts, cumulativeNodeCounts, linkCountsAtHop, cumulativeLinkCounts, edgePairsAll, edges, hopColors, xRange, yRange, CreateGridFrame, CreateNodeGraphFrame, animation, framesForward, framesLoop]; rows = 11; cols = 11; r = 1; gap = 0.2; dx = 2 r (Cos[\[Pi]/8] + gap); dy = 2 r (Cos[\[Pi]/8] + gap); OctagonAt[{x_, y_}, rr_] := Polygon[Table[{x, y} + rr RotationTransform[\[Pi]/8 + (i \[Pi])/4][{1, 0}], {i, 0, 7}]]; positions = Association[]; Module[{id = 1}, Do[positions[id] = {i dx, j dy}; id++, {j, 0, rows - 1}, {i, 0, cols - 1}];]; adjacencyList = Association[]; Do[Module[{id, neighbors}, id = j cols + i + 1; neighbors = {{i - 1, j}, {i + 1, j}, {i, j - 1}, {i, j + 1}, {i - 1, j - 1}, {i + 1, j - 1}, {i - 1, j + 1}, {i + 1, j + 1}}; adjacencyList[id] = Reap[Do[With[{ni = neighbor[[1]], nj = neighbor[[2]]}, If[0 <= ni < cols && 0 <= nj < rows, Sow[nj cols + ni + 1];];], {neighbor, neighbors}]][[2, 1]] /. Null -> {};], {j, 0, rows - 1}, {i, 0, cols - 1}]; centerI = Floor[(cols - 1)/2]; centerJ = Floor[(rows - 1)/2]; rootNode = centerJ cols + centerI + 1; Print["Root node (center position ", {centerI, centerJ}, ") with valency: ", Length[adjacencyList[rootNode]]]; BFS[root_, adjList_Association] := Module[{distances, queue, current, neighbors}, distances = Association[root -> 0]; queue = {root}; While[queue =!= {}, current = First[queue]; queue = Rest[queue]; neighbors = adjList[current]; Do[If[! KeyExistsQ[distances, neighbor], distances[neighbor] = distances[current] + 1; AppendTo[queue, neighbor];], {neighbor, neighbors}];]; distances]; distances = BFS[rootNode, adjacencyList]; edgePairsAll = DeleteDuplicates[ Sort /@ Flatten[ Table[Sort[{id, neighbor}], {id, Keys[adjacencyList]}, {neighbor, adjacencyList[id]}], 1]]; edges = Table[ Line[{positions[pair[[1]]], positions[pair[[2]]]}], {pair, edgePairsAll}]; Print["Sample edge node pairs: ", Take[edgePairsAll, UpTo[5]]]; GetAccessibleLinksUpToHop[maxHop_Integer] := Module[{accessibleLinks}, accessibleLinks = Select[edgePairsAll, Function[{pair}, With[{u = pair[[1]], v = pair[[2]], uDist = distances[pair[[1]]], vDist = distances[pair[[2]]]}, uDist <= maxHop && vDist <= maxHop && Min[uDist, vDist] <= maxHop - 1]]]; accessibleLinks]; maxHops = Max[Values[distances]] + 1; hopCounts = Table[Count[Values[distances], h], {h, 0, maxHops}]; cumulativeNodeCounts = Table[Count[Values[distances], x_ /; x <= h], {h, 0, maxHops}]; linkCountsAtHop = Table[Module[{currentLinks, previousLinks}, currentLinks = GetAccessibleLinksUpToHop[h]; previousLinks = If[h > 0, GetAccessibleLinksUpToHop[h - 1], {}]; Length[currentLinks] - Length[previousLinks]], {h, 0, maxHops}]; cumulativeLinkCounts = Table[Length[GetAccessibleLinksUpToHop[h]], {h, 0, maxHops}]; Print["Hop counts (nodes): ", hopCounts]; Print["Cumulative accessible nodes: ", cumulativeNodeCounts]; Print["New link counts at each hop: ", linkCountsAtHop]; Print["Cumulative accessible links: ", cumulativeLinkCounts]; Print["Links at hop 0: ", Length[GetAccessibleLinksUpToHop[0]]]; Print["Links at hop 1: ", Length[GetAccessibleLinksUpToHop[1]]]; xRange = {Min[Values[positions][[All, 1]]] - 1.5, Max[Values[positions][[All, 1]]] + 1.5}; yRange = {Min[Values[positions][[All, 2]]] - 1.5, Max[Values[positions][[All, 2]]] + 1.5}; hopColors = {Red, Orange, Yellow, Green, Cyan, Blue, Purple, Pink, Brown}; CreateGridFrame[currentHop_Integer] := Module[{accessibleNodes, accessibleLinkPairs, linkGraphics, blackLinkCount, nodeGraphics}, accessibleNodes = Select[Keys[distances], distances[#1] <= currentHop &]; accessibleLinkPairs = GetAccessibleLinksUpToHop[currentHop]; linkGraphics = MapThread[ If[MemberQ[accessibleLinkPairs, #2], {Black, Thick, #1}, {LightGray, Thin, #1}] &, {edges, edgePairsAll}]; blackLinkCount = Count[linkGraphics, {Black, Thick, _}]; nodeGraphics = Table[Module[{nodeHop, color}, nodeHop = distances[node]; color = If[nodeHop <= currentHop, hopColors[[Mod[nodeHop, Length[hopColors]] + 1]], LightGray]; {EdgeForm[Black], FaceForm[color], OctagonAt[positions[node], r]}], {node, Keys[positions]}]; Column[{Text[ Style["Hop: " <> ToString[currentHop] <> " | Accessible Nodes: " <> ToString[Length[accessibleNodes]] <> " | Accessible Links: " <> ToString[cumulativeLinkCounts[[currentHop + 1]]] <> " | Black Links: " <> ToString[blackLinkCount], FontSize -> 12, FontWeight -> Bold, Black]], Graphics[{linkGraphics, nodeGraphics}, ImageSize -> 400, PlotRange -> {xRange, yRange}, Background -> White]}]]; CreateNodeGraphFrame[currentHop_Integer] := Module[{hopRange, currentCumulativeNodes, currentCumulativeLinks}, hopRange = Range[0, currentHop]; currentCumulativeNodes = cumulativeNodeCounts[[1 ;; currentHop + 1]]; currentCumulativeLinks = cumulativeLinkCounts[[1 ;; currentHop + 1]]; ListLinePlot[{Transpose[{hopRange, currentCumulativeLinks}], Transpose[{hopRange, currentCumulativeNodes}]}, PlotStyle -> {{Red, Thick}, {Blue, Thick}}, PlotLegends -> {"Cumulative accessible links", "Cumulative accessible nodes"}, AxesLabel -> {"Hop count", "Count"}, PlotLabel -> "Cumulative Accessibility vs Hop Count", GridLines -> Automatic, ImageSize -> 400, Joined -> True, PlotRange -> {{0, maxHops}, {0, 4 (rows - 1) (cols - 1) + rows + cols - 2}}]]; animation = Animate[Row[{CreateGridFrame[h], Spacer[20], CreateNodeGraphFrame[h]}], {h, 0, maxHops, 1}, AnimationRate -> 1, AnimationDirection -> Forward]; framesForward = Table[Row[{CreateGridFrame[h], Spacer[20], CreateNodeGraphFrame[h]}], {h, 0, maxHops}]; framesLoop = Join[framesForward, Rest[Most[Reverse[framesForward]]]]; Export["hopLinks3_pingpong.gif", framesLoop, "DisplayDurations" -> 0.6, "AnimationRepetitions" -> \[Infinity]]; ListAnimate[framesLoop]; animation ## The process of "discovery and pathfinding" ## Root node (center position {5,5}) with valency: 8 Sample edge node pairs: {{1,2},{1,12},{1,13},{2,3},{2,13}} Hop counts (nodes): {1,8,16,24,32,40,0} Cumulative accessible nodes: {1,9,25,49,81,121,121} New link counts at each hop: {0,8,44,76,108,140,44} Cumulative accessible links: {0,8,52,128,236,376,420} Links at hop 0: 0 Links at hop 1: 8 This Wolfram Language model is more than a computer science demonstration. I couldn't believe what I was modeling--a physically-grounded network. By starting with a "ground up" definition of the physical mesh and running a "scouting" algorithm, we can prove inside-out the network's properties. Most importantly, by simulating failure, we demonstrate how a network built on discovery--rather than the "flawed assumption" of universal time--can achieve true resilience, unambiguously identifying "unreachable" components and "making the world safe for transactions". ![Unreachable][6] Since we can't fix time, the goal here is to achieve something they call logically instantaneous. The only way to truly get the effect of logical simultaneity is to essentially engineer time out of the equation for critical operations. One can go from any time-limited, API between computational models designed to simulate the resilience and discovery properties of a "mesh-based network" topology without needing to know the implementation language for the entire simulation and analysis. But if that's not something that you can really do, a primary feature being to generate animated GIFs and plots to show the "BFS" Wavefront Expansion", then what I would describe as good for the visualization and analysis of a network lattice, its adjacencies, and its properties, could be building an analysis of hop counts as a node-accessible application of discrete mathematics and graph theory. Which grounds the entire premise of the network in the failure of modern systems to account for fundamental physics, such as the "Minkowski fallacy". As well as the "discovery and pathfinding" for a new network architecture, which is a fundamental engineering problem and makes it possible to directly apply computer science concepts..specifically graph theory and network algorithms (BFS) in our simulations. ClearAll["Global`*"]; rows = 11; cols = 11; r = 1; gap = 0.2; dx = 2 r (Cos[\[Pi]/8] + gap); dy = 2 r (Cos[\[Pi]/8] + gap); OctagonAt[{x_, y_}, rad_] := Polygon[Table[{x, y} + rad RotationTransform[\[Pi]/8 + (i \[Pi])/4][{1, 0}], {i, 0, 7}]]; positions = Association[ Flatten[Table[ With[{id = j cols + i + 1}, id -> {i dx, j dy}], {j, 0, rows - 1}, {i, 0, cols - 1}], 1]]; adjacencyList = Association[ Flatten[Table[ With[{id = j cols + i + 1}, Module[{nbrIdx, validNbrs}, nbrIdx = {{i - 1, j}, {i + 1, j}, {i, j - 1}, {i, j + 1}, {i - 1, j - 1}, {i + 1, j - 1}, {i - 1, j + 1}, {i + 1, j + 1}}; validNbrs = Select[nbrIdx, 0 <= #1[[1]] < cols && 0 <= #1[[2]] < rows &]; id -> (validNbrs /. {ii_, jj_} :> jj cols + ii + 1)]], {j, 0, rows - 1}, {i, 0, cols - 1}], 1]]; centerI = Floor[cols/2]; centerJ = Floor[rows/2]; rootNode = centerJ cols + centerI + 1; Print[Style[ Row[{"Root node: (center position: ", {centerI, centerJ}, ") with valency: ", Length[adjacencyList[rootNode]]}], 14, Bold]]; invalidEdges = RandomInteger[50, 60]; BFS[root_, adj_Association] := Module[{distances, queue, current, neighbors}, distances = Association[root -> 0]; queue = {root}; While[queue =!= {}, current = First[queue]; queue = Rest[queue]; neighbors = adj[current]; Do[If[! KeyExistsQ[distances, nbr], distances[nbr] = distances[current] + 1; queue = Append[queue, nbr];], {nbr, neighbors}];]; distances]; distances = BFS[rootNode, adjacencyList]; maxHops = Max[Values[distances]]; GetAccessibleLinksUpToHop[maxHop_Integer] := Module[{accessibleLinks}, accessibleLinks = {}; Do[Do[Module[{linkPair, uDist, vDist}, linkPair = Sort[{node, neighbor}]; If[! MemberQ[accessibleLinks, linkPair], uDist = distances[node]; vDist = distances[neighbor]; If[uDist <= maxHop && vDist <= maxHop && Min[uDist, vDist] <= maxHop - 1, AppendTo[accessibleLinks, linkPair];];];], {neighbor, adjacencyList[node]}], {node, Keys[adjacencyList]}]; accessibleLinks]; hopCounts = Table[Count[Values[distances], h], {h, 0, maxHops}]; cumulativeNodeCounts = Table[Count[Values[distances], x_ /; x <= h], {h, 0, maxHops}]; linkCountsAtHop = Table[Module[{currentLinks, previousLinks}, currentLinks = GetAccessibleLinksUpToHop[h]; previousLinks = If[h > 0, GetAccessibleLinksUpToHop[h - 1], {}]; Length[currentLinks] - Length[previousLinks]], {h, 0, maxHops}]; cumulativeLinkCounts = Table[Length[GetAccessibleLinksUpToHop[h]], {h, 0, maxHops}]; Print["Hop counts (nodes): ", hopCounts]; Print["Cumulative accessible nodes: ", cumulativeNodeCounts]; Print["New link counts at each hop: ", linkCountsAtHop]; Print["Cumulative accessible links: ", cumulativeLinkCounts]; Print["Links at hop 0: ", Length[GetAccessibleLinksUpToHop[0]]]; Print["Links at hop 1: ", Length[GetAccessibleLinksUpToHop[1]]]; edges = {}; edgeToNodePair = {}; Do[Do[Module[{edgeLine, nodePair}, edgeLine = Line[{positions[id], positions[neighbor]}]; nodePair = Sort[{id, neighbor}]; AppendTo[edges, edgeLine]; AppendTo[edgeToNodePair, nodePair];], {neighbor, adjacencyList[id]}], {id, Keys[adjacencyList]}]; uniqueEdges = {}; uniqueNodePairs = {}; Do[If[! MemberQ[uniqueNodePairs, edgeToNodePair[[i]]], AppendTo[uniqueEdges, edges[[i]]]; AppendTo[uniqueNodePairs, edgeToNodePair[[i]]];], {i, Length[edges]}]; edges = uniqueEdges; edgeToNodePair = uniqueNodePairs; Print["Sample edge node pairs: ", Take[edgeToNodePair, 5]]; hopPalette[hop_, maxHop_] := ColorData["DarkRainbow"][Rescale[hop, {0, maxHop}]]; posArray = Values[positions]; {xMin, xMax} = MinMax[posArray[[All, 1]]]; {yMin, yMax} = MinMax[posArray[[All, 2]]]; plotRange2D = {{xMin - 1.5, xMax + 1.5}, {yMin - 1.5, yMax + 1.5}}; maxRange = 4 (rows - 1) (cols - 1) + rows + cols - 2; CreateGridFrame[currentHop_Integer] := Module[{accessibleNodes, accessibleLinkPairs, linkGraphics, nodeGraphics, blackLinkCount}, accessibleNodes = Select[Keys[distances], distances[#1] <= currentHop &]; accessibleLinkPairs = GetAccessibleLinksUpToHop[currentHop]; linkGraphics = Table[Module[{pair = edgeToNodePair[[i]], base = edges[[i]], styleActive, styleInactive}, styleActive = Directive[ColorData["BrightBands"][0.15], Opacity[0.9], Thickness[0.006]]; styleInactive = Directive[GrayLevel[0.4], Opacity[0.2], Thickness[0.002]]; If[MemberQ[accessibleLinkPairs, pair], {styleActive, base}, {styleInactive, base}]], {i, Length[edges]}]; blackLinkCount = Length[accessibleLinkPairs]; nodeGraphics = Table[Module[{nodeHop, col, baseStyle, inactiveStyle}, nodeHop = distances[node]; col = hopPalette[nodeHop, maxHops]; baseStyle = {EdgeForm[{GrayLevel[0.05], Thickness[0.003]}], Glow[Directive[col, Opacity[0.85]]], FaceForm[Directive[col, Opacity[0.95]]]}; inactiveStyle = {EdgeForm[{GrayLevel[0.2], Thickness[0.0015]}], FaceForm[Directive[GrayLevel[0.35], Opacity[0.25]]]}; If[nodeHop <= currentHop, {baseStyle, OctagonAt[positions[node], r]}, {inactiveStyle, OctagonAt[positions[node], r]}]], {node, Keys[positions]}]; Column[{Style[ Row[{"Hop: ", currentHop, " | Accessible Nodes: ", Length[accessibleNodes], " | Accessible Links: ", cumulativeLinkCounts[[currentHop + 1]], " | Active Links This Frame: ", blackLinkCount}], 13, Black, Bold], Graphics[{{Directive[GrayLevel[0.95], Opacity[1]], Rectangle[{xMin - 2, yMin - 2}, {xMax + 2, yMax + 2}]}, linkGraphics, nodeGraphics, {Directive[Black, Thickness[0.006], Opacity[0.9]], Circle[positions[rootNode], 1.15 r]}}, Background -> White, PlotRange -> plotRange2D, ImageSize -> 420, Frame -> True, FrameStyle -> Directive[GrayLevel[0.3], Thickness[0.002]], PlotRangePadding -> Scaled[0.05]]}]]; CreateNodeGraphFrame[currentHop_Integer] := Module[{currentHopCounts, currentCumulativeNodes, currentCumulativeLinks, dataLinks, dataNodes}, currentHopCounts = hopCounts[[1 ;; currentHop + 1]]; currentCumulativeNodes = cumulativeNodeCounts[[1 ;; currentHop + 1]]; currentCumulativeLinks = cumulativeLinkCounts[[1 ;; currentHop + 1]]; dataLinks = Transpose[{Range[0, currentHop], currentCumulativeLinks}]; dataNodes = Transpose[{Range[0, currentHop], currentCumulativeNodes}]; ListLinePlot[{dataLinks, dataNodes}, PlotStyle -> {Directive[ColorData["BrightBands"][0.2], Thick], Directive[ColorData["BrightBands"][0.7], Thick, Dashed]}, PlotMarkers -> {{Automatic, 4}, {Automatic, 4}}, Frame -> True, FrameLabel -> {Style["Hop Count", 13, GrayLevel[0.2]], Style["Cumulative Count", 13, GrayLevel[0.2]]}, PlotLabel -> Style["Accessibility vs. Hop Distance", 14, Bold, Black], GridLines -> {Range[0, maxHops, 2], None}, GridLinesStyle -> Directive[GrayLevel[0.8], Dashed, Thickness[0.0015]], Background -> White, FrameStyle -> Directive[GrayLevel[0.3], Thickness[0.002]], TicksStyle -> Directive[GrayLevel[0.2], 10], PlotRange -> {{0, maxHops}, {0, maxRange}}, ImageSize -> 420, PlotRangePadding -> Scaled[0.05], PlotLegends -> Placed[{"Cumulative accessible links", "Cumulative accessible nodes"}, {0.55, 0.9}]]]; frames = Table[Row[{CreateGridFrame[h], Spacer[20], CreateNodeGraphFrame[h]}, ImageSize -> 900], {h, 0, maxHops}]; animation = Animate[Row[{CreateGridFrame[h], Spacer[20], CreateNodeGraphFrame[h]}, ImageSize -> 900], {h, 0, maxHops, 1}, AnimationRate -> 1, AnimationDirection -> Forward, DefaultDuration -> maxHops + 1]; ListAnimate[frames]; Export["hopLinks_sidebyside_beautiful.gif", frames, "DisplayDurations" -> 1]; animation For "scouting" a "mesh-based network topology", this is something I can definitely see--how a node in a "sea of XPUs" can perform "local discovery" to build a map of its environment based on hop-count, not on a "flawed assumption" about universal time; the essential first step before any "routing" can occur. Root node: (center position: {5,5}) with valency: 8 Hop counts (nodes): {1,8,16,24,32,40} Cumulative accessible nodes: {1,9,25,49,81,121} New link counts at each hop: {0,8,44,76,108,140} Cumulative accessible links: {0,8,52,128,236,376} Links at hop 0: 0 Links at hop 1: 8 Sample edge node pairs: {{1,2},{1,12},{1,13},{2,3},{2,13}} ## Lattice and Topology Definition ## This section sets up the physical and logical structure of our network. We define an `11x11` grid of octagonal nodes, representing a "sea of XPUs". The `adjacencyList` defines the "mesh-based network topology" by connecting each node to its 8 nearest neighbors, a sturdy design that means (engineering time *out* of the critical path) either freezing time locally for long enough, or shrinking the physical distance down so much that you can process a batch of related events consistently before time drift or communication delays matter. ## The Scouting Algorithm (BFS) ## Out of the pile of all nodes we select a `rootNode` (the center of the grid) to begin the "scouting" process. We use a Breadth-First Search (BFS) to simulate the "discovery and pathfinding". The BFS algorithm expands hop by hop, discovering the network's topology. The output, `distances`, is an `Association` that maps every *reachable* node ID to its hop-count from the root. This map *is* the "coordinate system", built organically from connectivity, completely avoiding the "Minkowski fallacy" of assuming a universal clock. ## Temporal intimacy and the Æthernet link ## This starts with physically engineering something called temporal intimacy. The servers must be physically close enough for extremely reliable low-latency interaction. You use extremely short cables--just a few inches long--connecting adjacent machines directly in a dense mesh topology. You are literally fighting physics with hardware layout. And so it falls out--the Æthernet link is designed to be bidirectionally coherent. It's not about node A sending a message and node B maybe sending an acknowledgement later. With the `distances` map, we can now analyze the network's properties. We gather data on how many nodes and links are discovered at each successive hop. This is vital for "modeling trade-offs and resource allocation", the network accessibility that allows an engineer to understand the cost (in hops) of reaching any part of the network. ![Any part of the network][7] This scouting wavefront, builds the animation; `CreateGridFrame` generates the left panel, the "BFS Wavefront Expansion". It iterates through `currentHop`, coloring the nodes and links as they are "discovered" by the scouting algorithm. For our purposes, `CreateNodeGraphFrame` generates the right panel, plotting the "Accessibility vs. Hop Distance". This graph shows the cumulative growth of the known network, illustrating how `cumulativeLinkCounts` and `cumulativeNodeCounts` expand with each hop. These exported GIF(s) show the "scouting" process in action, the routes of all "discovery and pathfinding for a mesh-based network'. rows = 11; cols = 11; r = 1; gap = 0.2; dx = 2 r (Cos[\[Pi]/8] + gap); dy = 2 r (Cos[\[Pi]/8] + gap); OctagonAt[{x_, y_}, rr_] := Polygon[Table[{x, y} + rr RotationTransform[\[Pi]/8 + (i \[Pi])/4][{1, 0}], {i, 0, 7}]]; positions = Association[]; Module[{id = 1}, Do[positions[id] = {i dx, j dy}; id++, {j, 0, rows - 1}, {i, 0, cols - 1}];]; originalAdjacencyList = Association[]; Do[Module[{id, neighbors}, id = j cols + i + 1; originalAdjacencyList[id] = {}; neighbors = {{i - 1, j}, {i + 1, j}, {i, j - 1}, {i, j + 1}, {i - 1, j - 1}, {i + 1, j - 1}, {i - 1, j + 1}, {i + 1, j + 1}}; Do[Module[{ni = neighbor[[1]], nj = neighbor[[2]], nid}, If[0 <= ni < cols && 0 <= nj < rows, nid = nj cols + ni + 1; AppendTo[originalAdjacencyList[id], nid];];], {neighbor, neighbors}];], {j, 0, rows - 1}, {i, 0, cols - 1}]; centerI = 0; centerJ = 0; rootNode = centerJ cols + centerI + 1; Print[Style[ Row[{"Root node: ", rootNode, " (grid position: ", {centerI, centerJ}, ") valency: ", Length[originalAdjacencyList[rootNode]]}], 14, Bold, Black]]; allEdges = {}; Do[Do[If[id < neighbor, AppendTo[allEdges, {id, neighbor}];], {neighbor, originalAdjacencyList[id]}], {id, Keys[originalAdjacencyList]}]; Print[Style[Row[{"Total edges in graph: ", Length[allEdges]}], 12, Bold, Black]]; RemoveEdges[adjList_Association, edgesToRemove_List] := Module[{newAdjList = Association[adjList]}, Do[Module[{u = edge[[1]], v = edge[[2]]}, newAdjList[u] = DeleteCases[newAdjList[u], v]; newAdjList[v] = DeleteCases[newAdjList[v], u];], {edge, edgesToRemove}]; newAdjList]; AnimatedBFS[root_, adjList_Association] := Module[{distances, parentMap, queue, current, neighbors, steps}, distances = Association[root -> 0]; parentMap = Association[]; queue = {root}; steps = {Association[distances]}; While[queue =!= {}, current = First[queue]; queue = Rest[queue]; neighbors = Lookup[adjList, current, {}]; Do[If[! KeyExistsQ[distances, neighbor], distances[neighbor] = distances[current] + 1; parentMap[neighbor] = current; AppendTo[queue, neighbor]; AppendTo[steps, Association[distances]];], {neighbor, neighbors}];]; {distances, parentMap, steps}]; DynamicModule[{numFailedEdges = 0, failedEdges = {}, currentReachable = Length[Keys[originalAdjacencyList]], currentUnreachable = 0, finalDistances = Association[], finalParentMap = Association[], bfsSteps = {}, currentAdjList = originalAdjacencyList, maxFailures = Min[50, Length[allEdges]], animationRunning = False, currentStep = 0, maxSteps = 0, animationSpeed = 0.5}, {finalDistances, finalParentMap, bfsSteps} = AnimatedBFS[rootNode, currentAdjList]; currentReachable = Length[Keys[finalDistances]]; currentUnreachable = Length[Keys[originalAdjacencyList]] - currentReachable; maxSteps = Max[0, Length[bfsSteps] - 1]; Column[{Panel[ Column[{Style["Network Failure & BFS Controls", 16, Bold, Black, FontFamily -> "Helvetica"], Row[{"Number of failed edges: ", Slider[Dynamic[numFailedEdges], {0, Length[allEdges], 1}], Spacer[8], Panel[Dynamic[numFailedEdges], Background -> White, FrameMargins -> {{6, 6}, {2, 2}}]}], Row[{"Animation speed (seconds/step): ", Slider[Dynamic[animationSpeed], {0.1, 2.0, 0.1}], Spacer[8], Dynamic[Style[NumberForm[animationSpeed, {2, 1}], 12, Black]]}], Row[{Style["Reachable nodes: ", Bold, Darker[Green]], Dynamic[currentReachable], Spacer[20], Style["Unreachable nodes: ", Bold, Darker[Red]], Dynamic[currentUnreachable]}], Row[{Button[Style["Random Edge Failures", 12, Bold, Black], failedEdges = If[numFailedEdges > 0, RandomSample[allEdges, numFailedEdges], {}]; currentAdjList = RemoveEdges[originalAdjacencyList, failedEdges]; {finalDistances, finalParentMap, bfsSteps} = AnimatedBFS[rootNode, currentAdjList]; currentReachable = Length[Keys[finalDistances]]; currentUnreachable = Length[Keys[originalAdjacencyList]] - currentReachable; maxSteps = Max[0, Length[bfsSteps] - 1]; currentStep = 0; animationRunning = False;], Spacer[10], Button[Style["Start BFS Animation", 12, Bold, Black], If[Length[bfsSteps] > 0, currentStep = 0; animationRunning = True;];], Spacer[10], Button[Style["Reset All Links", 12, Bold, Black], failedEdges = {}; numFailedEdges = 0; currentAdjList = originalAdjacencyList; {finalDistances, finalParentMap, bfsSteps} = AnimatedBFS[rootNode, currentAdjList]; currentReachable = Length[Keys[finalDistances]]; currentUnreachable = 0; maxSteps = Max[0, Length[bfsSteps] - 1]; currentStep = 0; animationRunning = False;]}], If[maxSteps > 0, Row[{"Animation step: ", Slider[Dynamic[currentStep], {0, maxSteps, 1}], Spacer[6], Dynamic[Style[Row[{currentStep, " / ", maxSteps}], 11, Bold, Black]]}], Nothing]}, Spacings -> 1.2, BaseStyle -> {Black}], Background -> Lighter[Blend[{Gray, Blue}, 0.15], 0.85], FrameMargins -> Medium, FrameStyle -> Directive[GrayLevel[0.4], Thickness[0.003]]], Dynamic[If[animationRunning && currentStep < maxSteps, Pause[animationSpeed]; currentStep++; If[currentStep >= maxSteps, animationRunning = False];]; ""], Dynamic[Module[{workingEdges, workingCoords, failedCoords, failedEdgeLines, workingEdgeLines, nodeGraphics, arrowGraphics, currentDistancesStep, visibleNodes, coords, minX, maxX, minY, maxY, maxKnownDist, distanceColor}, currentDistancesStep = If[Length[bfsSteps] > 0 && 0 <= currentStep < Length[bfsSteps], bfsSteps[[currentStep + 1]], Association[]]; visibleNodes = Keys[currentDistancesStep]; workingEdges = Complement[allEdges, failedEdges]; workingCoords = (positions /@ #1 &) /@ workingEdges; failedCoords = (positions /@ #1 &) /@ failedEdges; coords = Values[positions]; {minX, maxX} = {Min[coords[[All, 1]]], Max[coords[[All, 1]]]}; {minY, maxY} = {Min[coords[[All, 2]]], Max[coords[[All, 2]]]}; maxKnownDist = If[finalDistances === Association[], 1, Max[Values[finalDistances]]]; distanceColor[d_] := ColorData["SolarColors"][Rescale[d, {0, maxKnownDist}, {0, 1}]]; failedEdgeLines = If[failedCoords === {}, {}, {Glow[Red], Directive[Red, Thickness[0.012], Dashed, CapForm["Round"]], Line /@ failedCoords}]; workingEdgeLines = If[workingCoords === {}, {}, {Directive[GrayLevel[0.25, 0.7], Thickness[0.004]], CapForm["Round"], Line /@ workingCoords}]; nodeGraphics = Table[Module[{pt = positions[node]}, Which[node === rootNode, {EdgeForm[{Black, Thick}], FaceForm[RGBColor[0.95, 0.55, 0.35]], OctagonAt[pt, 1.1 r]}, MemberQ[visibleNodes, node], {EdgeForm[{Darker[Green, 0.4], Thickness[0.005]}], FaceForm[distanceColor[currentDistancesStep[node]]], OctagonAt[pt, r]}, KeyExistsQ[finalDistances, node], {EdgeForm[{GrayLevel[0.4], Thickness[0.003]}], FaceForm[Directive[GrayLevel[0.92], Opacity[0.95]]], OctagonAt[pt, r]}, True, {EdgeForm[{GrayLevel[0.7], Thickness[0.002]}], FaceForm[Directive[RGBColor[0.93, 0.8, 0.88], Opacity[0.7]]], OctagonAt[pt, r]}]], {node, Keys[positions]}]; arrowGraphics = If[finalParentMap === Association[], {}, Table[If[ KeyExistsQ[finalParentMap, node] && MemberQ[visibleNodes, node], {Directive[ RGBColor[0.15, 0.45, 0.95], Thickness[0.008]], Arrowheads[0.03], Arrow[{positions[finalParentMap[node]], positions[node]}]}, Nothing], {node, Keys[finalParentMap]}]]; Graphics[{{FaceForm[Lighter[Blend[{Blue, Black}, 0.9], 0.9]], EdgeForm[None], Rectangle[{minX - 10, minY - 10}, {maxX + 10, maxY + 10}]}, workingEdgeLines, failedEdgeLines, nodeGraphics, arrowGraphics, Inset[Framed[ Column[{Style["BFS on an Octagon Lattice", 18, Bold, Black, FontFamily -> "Helvetica"], Style[Row[{"Step ", currentStep, " of ", maxSteps, " | Visible nodes: ", Length[visibleNodes]}], 12, GrayLevel[0.1]]}, Spacings -> 0.3], Background -> Directive[White, Opacity[0.9]], FrameMargins -> {{10, 10}, {6, 6}}, RoundingRadius -> 10, FrameStyle -> Directive[GrayLevel[0.6], Thickness[0.002]]], {Mean[{minX, maxX}], maxY + 3}], Inset[Framed[ Grid[{{Style["Legend", 11, Bold, Black]}, {Row[{Style["Root", 11, Bold, Darker[Green]], ": central orange octagon"}]}, {Row[{Style["Reached", 11, Bold, Darker[Green]], ": Solar-colored nodes"}]}, {Row[{Style[ "Reachable later", 11, Bold, GrayLevel[0.25]], ": light gray nodes"}]}, {Row[{Style["Unreachable", 11, Bold, Darker[Red]], ": pale pink nodes"}]}, {Row[{Style["Failed links", 11, Bold, Red], ": thick glowing red dashed edges"}]}}, Spacings -> {0.8, 0.6}], Background -> Directive[White, Opacity[0.9]], RoundingRadius -> 8, FrameMargins -> {{8, 8}, {6, 6}}, FrameStyle -> Directive[GrayLevel[0.7], Thickness[0.0015]]], {minX - 4, maxY + 3}, {Left, Center}]}, ImageSize -> 800, PlotRange -> {{minX - 3, maxX + 3}, {minY - 3, maxY + 6}}, PlotRangePadding -> Scaled[0.03], Background -> Lighter[Gray, 0.96]]]], Panel[Column[{Style["Network Resilience Analysis", 15, Bold, Black, FontFamily -> "Helvetica"], Dynamic[Grid[{{"Total Nodes:", Length[Keys[originalAdjacencyList]]}, {"Total Edges:", Length[allEdges]}, {"Failed Edges:", Length[failedEdges]}, {"Final Reachable Nodes:", currentReachable}, {"Final Unreachable Nodes:", currentUnreachable}, {"Connectivity:", If[currentReachable > 0, Row[{NumberForm[ N[(100.0 currentReachable)/ Length[Keys[originalAdjacencyList]]], {4, 1}], " %"}], "0 %"]}}, Frame -> All, Background -> {None, {Lighter[Gray, 0.9], White}}, ItemSize -> All, BaseStyle -> {Black}]]}, Spacings -> 1.2], Background -> Lighter[Blend[{Yellow, White}, 0.8], 0.9], FrameStyle -> Directive[GrayLevel[0.4], Thickness[0.002]], FrameMargins -> Medium]}, Spacings -> 1.4]] The Æthernet link is designed to be bidirectionally coherent. It's not about node A sending a message and node B maybe sending an acknowledgement later. It's about..nothing other than guaranteeing that whatever relevant state change happens on one side of that short wire happens effectively simultaneously and reliably on the other side, without relying on software timers or sequence numbers. They describe it as spacetime having a handshake--an architecture that physically and logically correlates events across that link faster and more reliably than clock synchronization could ever hope to achieve. Hardware causal registers at the boundary ----------------------------------------- The final piece thoroughly involves putting complex causal registers directly into the smart NIC, right next to the wire. This is really the linchpin of the design, putting the intelligence right there at the network boundary. These registers are specifically designed to detect and potentially migrate those tricky right-skew conflicts at the hardware level, almost instantaneously, as the data flows across the link. It's a direct engineering solution to the physics problem of time that has gradually plagued distributed systems for decades. ![Closing perspective][8] ## Closing perspective ## We're finally starting to build serviceable systems that actually acknowledge the true, fragmented, localized, and frankly weird nature of time. If concepts we take for granted--like happened-before and point-in-time--are actually meaningless without also specifying a point in space, what practical assumptions are you still relying on every day that are really just comforting illusions about the simple, universal nature of time? And so we've picked up on how the earlier Cloud Sync / Lamport material forms a single, coherent basis for "logically instantaneous causality versus timestamp illusions". [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif-2e78c7291117556f.gif&userId=2553367 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif-598d0f2412be5e19.gif&userId=2553367 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif-1e39f104d083b463.gif&userId=2553367 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif-1634ba01fe43dcda.gif&userId=2553367 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif-1c091296764008bd.gif&userId=2553367 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif-15fc86cab9077464.gif&userId=2553367 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif-1ff46de08b722bee.gif&userId=2553367 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif-306475550537f29f.gif&userId=2553367 Dean Gladish 2025-11-14T13:06:16Z https://community.wolfram.com/groups/-/m/t/3560497 The new augmented reality - ARPublish - functionality seems to have an amazing potential. It is not just a fun exercise, but may also become an extremely valuable fancy tool for companies and entrepreneurs. For example I am trying to ARPublish a Graph3D that represents the internal structure of a complex website. It was relatively easy to find all the relationships among the php source files and build a graph of them. However, when I ARPublish it, I cannot see the VertexLabels. I can give a couple of minimal code examples: Graph3D[Rule @@@ RandomSample[Tuples[Join[RandomWord[4], ToString /@ Range[3]], {2}], 20], VertexLabels -> Automatic] ![random graph][1] ARPublish[%] ![AR output 1][2] URL: [AR graph 1][3] Also using Annotation: Graph3D[Table[ Annotation[ v, {VertexSize -> 0.2 + 0.2 Mod[v, 5], VertexStyle -> Hue[v/15, 1, 1], VertexLabels -> Automatic}], {v, 0, 14}], Table[v \[UndirectedEdge] Mod[v + 1, 15], {v, 0, 14}]] ![annotated graph][4] ARPublish[%] ![AR output 2][5] URL: [AR graph 2][6] In both these simple cases, the VertexLabels do not appear in the augmented reality published object, as seen from my iPhone 14. In real world applications labels and additional information (well provided in notebooks by the Tooltip functionality) would be what make the augmented reality visualization really useful. Does anyone know how to show Graph3D VertexLabels in ARPublish? Thank you in advance. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2025-10-15alle12.10.08.png&userId=2785074 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2025-10-15alle12.19.20.png&userId=2785074 [3]: https://www.wolframcloud.com/obj/2d617342-b5d7-4ae9-9278-8d6b50e6b91b [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2025-10-15alle12.10.34.png&userId=2785074 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2025-10-15alle12.20.35.png&userId=2785074 [6]: https://www.wolframcloud.com/obj/28def909-5cdd-432b-9ff0-8024108603ea Daniele Gregori 2025-10-15T10:12:27Z https://community.wolfram.com/groups/-/m/t/3546261 Part 1: https://community.wolfram.com/groups/-/m/t/3531342 Look at the symmetry of this inversion: ![enter image description here][237] ![enter image description here][238] toRiemann = Compile[{{pts, _Real, 2}}, Module[{k}, Map[(k = 2/(1 + #.#); {k #[[1]], k #[[2]], 1 - k}) &, pts]]]; fromRiemann = Compile[{{pts, _Real, 2}}, Module[{k}, Map[(-1/(#[[3]] - 1)) {#[[1]], #[[2]], 0} &, pts]]]; cow = {EdgeForm[None], Texture[Graphics[Disk[]]], Lighting -> "Neutral", Append[ExampleData[{"Geometry3D", "Cow"}, "GraphicsComplex"], VertexTextureCoordinates -> 1/500 ExampleData[{"Geometry3D", "Cow"}, "PolygonData"]]}; riemannTableau[Graphics[g_, ___], options___] := Module[{tmp}, Graphics3D[{ Translate[cow, {0, 0, 1.2}], {Opacity[.07], Sphere[{0, 0, 0}, 1]}, g /. (h : Line | Polygon)[pts_] :> { EdgeForm[Opacity[.3]], (*original*)EdgeForm[Purple], Purple, h[{#1, #2, 0} & @@@ pts], (*riemann*)EdgeForm[Blue], Blue, h[tmp = toRiemann[pts]], (*riemann inverse*)EdgeForm[Red], Red, h[tmp = {#1, #2, -#3} & @@@ tmp], (*inverse*)h[fromRiemann[tmp]]}}, options, Lighting -> "Neutral", Boxed -> False, Axes -> None, PlotRange -> All]]; axiom = Polygon[{Cos[#], Sin[#]} & /@ (Pi/2 - 2 Pi Range[3]/3)]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; draw[n_] := Graphics[Nest[next, N@axiom, n]]; riemannTableau[draw[5], ViewPoint -> {Top, Left}] We have the original in the middle in purple, its Riemann mapping in blue, their inverses in red, and the cow in black and white. And except for the cow they all meet at the same three points. How gangster is that. (My friend's six-month old informs me that it's "substantially gangster" (paraphrasing)). But witness the scene of a zoom-out fractal: ![enter image description here][239] toRiemann = Compile[{{pts, _Real, 2}}, Module[{k}, Map[(k = 2/(1 + #.#); {k #[[1]], k #[[2]], 1 - k}) &, pts]]]; fromRiemann[pts_] := Quiet@DeleteCases[(-1/(#3 - 1)) {#1, #2, 0} & @@@ pts, x_ /; MemberQ[x, Indeterminate]]; cow = {EdgeForm[None], Texture[Graphics[Disk[]]], Append[ExampleData[{"Geometry3D", "Cow"}, "GraphicsComplex"], VertexTextureCoordinates -> 1/500 ExampleData[{"Geometry3D", "Cow"}, "PolygonData"]]}; riemannTableau[Graphics[g_, ___], options___] := Module[{tmp}, Graphics3D[{ (*transparency on sphere causes weird graphical issue on my machine when n is high*) {Opacity[.07], Sphere[{0, 0, 0}, 1]}, Translate[cow, {0, 0, 1.2}], g /. (h : Line | Polygon)[pts_] :> { (*original*)h[{#1, #2, 0} & @@@ pts], (*riemann*)h[tmp = toRiemann[pts]], (*riemann inverse*)h[tmp = {#1, #2, -#3} & @@@ tmp], (*inverted*)h[fromRiemann[tmp]]}}, options, Lighting -> "Neutral", Boxed -> False, Axes -> None, PlotRange -> All]]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; {n, c} = {5, {0, -5/8; -1/4}}; axiom = Polygon[c + {Cos[#], Sin[#]} & /@ (Pi/2 - 2 Pi Range[3]/3)]; riemannTableau[ Graphics[{EdgeForm[Black], Black, Nest[next, N@axiom, n]}], ViewVector -> {5 {-1, -1, 1}, {0, 0, 0}}] *At the chasm of infinity, our cow glances past its precipice, stares down its abyss*. You know that machine in the Hitchhiker's Guide that explodes your mind or whatever by showing you how pathetically insignificant you are compared to the universe? Well this is like a Windows 3.1 version of that. Our poor cow friend's soul is being wrung on the very clothesline of endlessness itself. I think this is the first time I'm happy I'm not a cow. ...is what I would have said if this was any cow but this one. ![enter image description here][240] ![enter image description here][241] pat = Graphics[{Black, Disk[{0, 0}, 5], White, EdgeForm[{Black, Thickness[.03]}], Disk[{0, 0}, # + .07] & /@ Range[4, 1, -1], Black, Disk[{0, 0}, .15], Rectangle[{-4, 1.8}, {4, 2.1}], Rotate[Rectangle[{-4, 1.8}, {4, 2.1}], -Pi/4, {0, 0}], Rectangle[{-.2, -1.3}, {.2, -4}]}]; (jhgn = {Lighting -> "Neutral", #1}) & @@ SphericalPlot3D[u + v, {u, 0, Pi}, {v, 0, Pi}, Mesh -> None, TextureCoordinateFunction -> ({#5, #4} &), PlotStyle -> Texture[pat]]; xf1 = { {{0.0017206308062546146`, 0.0012959917814960697`, 0.0025851614902868744`}, {0.0010674250900446086`, -0.0030803612062593683`, 0.0008337886519470046`}, {0.0026876120080307113`, 0.0003937069230620502`, -0.0019861927280659755`}}, {0.3257382788099915`, -0.03759999999999997`, 0.1862691804107692`}}; xf2 = { {{0.0017206308062546146`, 0.0012959917814960697`, 0.0025851614902868744`}, {-0.0010674250900446086`, 0.0030803612062593683`, -0.0008337886519470046`}, {0.0026876120080307113`, 0.0003937069230620502`, -0.0019861927280659755`}}, {0.3257382788099915`, 0.03759999999999997`, 0.1862691804107692`}}; cow = {EdgeForm[None], Lighting -> "Neutral",(*Opacity[.999],*) Texture[Graphics[Disk[]]], Append[ExampleData[{"Geometry3D", "Cow"}, "GraphicsComplex"], VertexTextureCoordinates -> 1/500 ExampleData[{"Geometry3D", "Cow"}, "PolygonData"]]}; Graphics3D[{cow, GeometricTransformation[jhgn, xf1], GeometricTransformation[jhgn, xf2]}, Boxed -> False] pat =(*ColorNegate@*)Graphics[{Black, Disk[{0, 0}, 5], White, EdgeForm[{Black, Thickness[.03]}], Disk[{0, 0}, # + .07] & /@ Range[4, 1, -1], Black, Disk[{0, 0}, .15], Rectangle[{-4, 1.8}, {4, 2.1}], Rotate[Rectangle[{-4, 1.8}, {4, 2.1}], -Pi/4, {0, 0}], Rectangle[{-.2, -1.3}, {.2, -4}]}]; (jhgn = {Lighting -> "Neutral", #1}) & @@ SphericalPlot3D[u + v, {u, 0, Pi}, {v, 0, Pi}, Mesh -> None, TextureCoordinateFunction -> ({#5, #4} &), PlotStyle -> Texture[pat], PlotPoints -> 80(*0*)]; sc = 1.5; xf1 = { sc {{0.010433915075096155`, 0.02050184708176941`, -0.0014526467022039392`}, {0.014609900826184952`, -0.006252356712311273`, 0.01669614726190017`}, {0.014456372783472383`, -0.008478490536514085`, -0.01582501134810082`}}, {0.5447560973768777`, -0.5`, 0.5534681561478464`}}; xf2 = { sc {{0.010433915075096155`, 0.02050184708176941`, -0.0014526467022039392`}, {-0.014609900826184952`, 0.006252356712311273`, -0.01669614726190017`}, {0.014456372783472383`, -0.008478490536514085`, -0.01582501134810082`}}, {0.5447560973768777`, 0.5`, 0.5534681561478464`}}; cow = {EdgeForm[None], Lighting -> "Neutral",(*Opacity[.999],*) Texture[ColorNegate@Graphics[Disk[]]], Append[ExampleData[{"Geometry3D", "Cow"}, "GraphicsComplex"], VertexTextureCoordinates -> 1/500 ExampleData[{"Geometry3D", "Cow"}, "PolygonData"]]}; Graphics3D[{cow, GeometricTransformation[jhgn, xf1], GeometricTransformation[jhgn, xf2]}, ViewPoint -> Right, Boxed -> False] // ColorNegate *This* cow does not cower. Infinity cannot bully this bull, cannot bloviate this bovine. By all appearances this cow is wearing infinity on its *mane*. Its horns are probably made of ℵℵ⋱ down 4 or 5 levels, an immutability surpassed only by that of the tusks of the Alephant. Our cow isn't staring into infinity. It's looking down at infinity, observing infinity with detached understanding. If our cow were not so enlightened, and also had the facial muscles, it might betray the subtlest of smiles at infinity's infinity face, for infinity's turbid fractal whirlpools and vast lethargic swamps are but swathes of data like any other to this cow. Long ago, having mastered the magesterial tetrafecta of science, mathematics, spirituality, and politics, our cow stepped hoof outside Farmer Joe's farm and set out on an adventure of like, just so much awesome. One of its side gigs these days is being the final observer of our domain, preventing our section of the Great Algorithm from backtracking by stellating through the cosmos our most entwined entwinements. I think this is the first time I'm jealous of a cow. In any case, as you can see the Riemann sphere is pretty useless. But while we're on the subject of 3D let's see how our various approaches do here. Chaos game: ![enter image description here][242] ![enter image description here][243] ![enter image description here][244] ![enter image description here][245] ![enter image description here][246] ![enter image description here][247] ![enter image description here][248] draw[vertices_, numPoints_, options___] := Graphics3D[{Lighter[Green], Sphere[FoldList[(#1 + #2)/2 &, First[N@vertices], RandomChoice[N@vertices, numPoints]], .001]}, Lighting -> {{"Point", LightYellow, Scaled[{1, 1, 1}], 5}}, options, Boxed -> False]; vertices = PolyhedronData[{"Pyramid", 3}, "VertexCoordinates"]; draw[vertices, 100000, ViewPoint -> {0, 0, Infinity}, ViewVertical -> {1, 0, 0}] draw1[vertices_, numPoints_, options___] := Graphics3D[{Lighter[Green], EdgeForm[None], Cuboid[#, # + .01] & /@ FoldList[(#1 + #2)/2 &, First[vertices], RandomChoice[N@vertices, numPoints]]}, Lighting -> {{"Point", LightYellow, Scaled[{1, 1, 1}], 5}}, options, Boxed -> False]; draw[vertices_, numPoints_, options___] := Graphics3D[{Lighter[Green], Sphere[FoldList[(#1 + #2)/2 &, First[N@vertices], RandomChoice[N@vertices, numPoints]], .001]}, Lighting -> {{"Point", LightYellow, Scaled[{1, 1, 1}], 5}}, options, Boxed -> False]; vertices = PolyhedronData[{"Pyramid", 3}, "VertexCoordinates"]; (*1*) Defer[AbsoluteOptions][draw1[vertices, 20000, ImageSize -> Medium]] (*2*) draw[vertices, 2000000, (* ViewPoint, ViewVertical from (*1*) *) Method -> {"ShrinkWrap" -> True}, ImageSize -> 2 1280] // Rasterize // ImageResize[#, Scaled[1/4]] & This is using little spheres as the points. You could use pyramids or anything else instead. Even go back to nature and use actual points. It's a bit tricky to get decent images since the chaos game doesn't place points in a regular arrangement, so you need a large number of points. Each of these images uses 2 million spheres and takes about 10 minutes to render on my little laptop. This top view shows one of the symmetries that appear in the 3D triangle. This side view shows another. And a top view of the 4-corner pyramid. These symmetries are interesting because they appear absolutely no different than 2D renditions (for example). At first this seems mysterious, since the symmetries appear from every which angle. But the reason it happens is because our distance function works on each coordinate independently: $$p_{i+1}=\frac{1}{2} (p_i+\nu)$$ ![enter image description here][249] ![enter image description here][250] ![enter image description here][251] To make clear what we're talking about, this is the chaos game on a prism, and the same thing from the same viewpoint, except with the 3D projection effect removed. As you can see, the 'hidden dimension' has no offect on what is seen. Au contraire messieur. If it did have an effect, *that* would be interesting. Something I noticed though is that while we can remove a coordinate, we can't add a coordinate, in the sense that, for example, there's no way to combine independent $x$ $y$ streams to create a Sierpinski triangle. For our 2D Sierpinski triangle, there's something to the fact that a single point is specified by two coordinates instead of just one. I think there may be an interesting statistical or information-theoretic interpretation to this. I'm not really familiar with either of these subjects though. Geometric approach: ![enter image description here][252] ![enter image description here][253] ![enter image description here][254] ![enter image description here][255] draw[shapeName_, n_, options___] := Module[{shape, next}, shape = PolyhedronData[shapeName, "Faces"]; (*scale by 1/2 toward each vertex,in turn*) next[prev_] := Scale[prev, 1/2, #] & /@ shape[[1]]; Graphics3D[{EdgeForm[Opacity[.15]], Nest[next, N@shape, n]}, options, Lighting -> "Neutral", Boxed -> False]]; Grid[Table[ draw[{"Pyramid", k}, n, ViewPoint -> {0, 0, Infinity}], {k, 3, 5}, {n, 0, 3}]] Behold the Lemon Lime Fortress. Throw in a few salt blocks, pour some Corona at the top, join the party at the base. To make our lives one notch easier, our code takes advantage of Mathematica's built-in transformation infrastructure, in this case the symbol `Scale`. It also pulls the geometry of things from our good friend Mr. `PolyhedronData`. The nice thing about having such a general setup is that we can readily apply this geometric fractalization on arbitrary shapes: ![enter image description here][256] ![enter image description here][257] ![enter image description here][258] ![enter image description here][259] ![enter image description here][260] draw[shapeName_, n_] := Module[{shape, next}, shape = PolyhedronData[shapeName, "Faces"]; next[prev_] := Scale[prev, 1/2, #] & /@ shape[[1]]; Graphics3D[Nest[next, N@shape, n], Method -> {"ShrinkWrap" -> True}, Lighting -> "Neutral", Boxed -> False]]; shapes = {"TruncatedIcosahedron", "TriakisIcosahedron", "TetrakisHexahedron", "SmallStellatedDodecahedron", "ElongatedPentagonalCupola", "Icosahedron", "ElongatedSquareDipyramid", "DuerersSolid"}; Grid[Partition[#, 2]] &[ Table[Tooltip[Panel[#], shape] &@ Row[Table[draw[shape, n], {n, 0, 1}], Spacer[30]], {shape, shapes}]] Don't ask me what the hell that last shape is. I figure it just managed to stow away into `PolyhedronData` somehow, like the semiconscious pre-sentient kernel of a future Skynet. The faces of these shapes show very clearly that we get 2D slices for free, like in these perspectives from below (we aren't cheating here). The edges by themselves make pretty patterns: ![enter image description here][261] ![enter image description here][262] ![enter image description here][263] ![enter image description here][264] ![enter image description here][265] draw[shapeName_, n_, options___] := Module[{shape, next, axiom}, shape = PolyhedronData[shapeName, "Faces"]; next[prev_] := Scale[prev, 1/2, #] & /@ shape[[1]]; axiom = {shape, If[showLittleBalls, {FaceForm[{Opacity[.85], White}], Glow[Green], Sphere[{0, 0, 0}, .09]}]}; Graphics3D[{Transparent, EdgeForm[{Opacity[opacity], color}], Nest[next, N@axiom, n]}, options, Lighting -> "Neutral", Boxed -> False]]; shapes = {"TruncatedIcosahedron", "TriakisIcosahedron", "TetrakisHexahedron", "SmallStellatedDodecahedron", "ElongatedPentagonalCupola", "Icosahedron", "ElongatedSquareDipyramid", "DuerersSolid"}; {color, opacity, showLittleBalls} = {Black, .6, False}; Grid[Partition[#, 2]] &@ Table[Tooltip[#, shape] &@ Row[Table[draw[shape, n, ViewPoint -> Top], {n, 0, 1}], Spacer[30]], {shape, shapes}] To make sure that after all this scrolling we're still on the same web page, this is our chaos game algorithm: 1 start at any point. call it p 2 pick a vertex at random 3 find the point halfway between p and that vertex 4 call that point p and draw it 5 goto 2 The only difference between 2D and 3D versions of this algorithm is having 3 coordinates instead of 2. Just as in 2D, we can alter step 3 in various ways. The simplest is to move not halfway towards the chosen vertex, but .25 or .7 of the way, etc: ![enter image description here][266] ![enter image description here][267] ![enter image description here][268] draw[vertices_, df_, numPoints_, options___] := Graphics3D[{ Opacity[.5], PointSize[0], Point[FoldList[df, First[N@vertices], RandomChoice[N@vertices, numPoints]]]}, (*Method->{"ShrinkWrap"->True},*) options, PlotRange -> Automatic, Boxed -> False]; functions = Function[r, r (#1 + #2) &] /@ {1, .96, .6, .5, .2}; Grid[Join[ {TraditionalForm[Trace[#[a, b]][[2]]] & /@ functions}, ParallelTable[ draw[PolyhedronData[{"Pyramid", v}, "VertexCoordinates"], df, 50000, ViewPoint -> {Front, Top}], {v, 3, 5}, {df, functions}]]] Those odd random walks are because the 4- and 5-pyramids have `Mean[vertices] != {0, 0, 0}`. One thing I noticed is that random walks resemble the outlines of continents. How curious. I wonder if it boils down to the self-similarity of the Brownian motion of water molecules, or something of the like. I.e. the idea that if our continents were surrounded by materials which did not move Brownianly, our coastlines would have different kinds of shapes. Remember that we can get creative with our distance function: ![enter image description here][269] ![enter image description here][270] ![enter image description here][271] ![enter image description here][272] ![enter image description here][273] ![enter image description here][274] draw[vertices_, df_, numPoints_, options___] := Graphics3D[{PointSize[0], Opacity[.3], Point[FoldList[df, RandomReal[{0, .0001}, 3], RandomChoice[N@vertices, numPoints]]]}, (*Method->{"ShrinkWrap"->True},*) options, Boxed -> False]; rotate = RotationTransform; functions = { (#1 + #2)/RandomChoice[Prime[Range[3]]] &, (#1 + #2)/RandomChoice[Prime[Range[3]]!] &, (#1 + #2)/RandomChoice[Prime[Range[10]]] &, #1 + .5 rotate[10. Degree, {#1, #2}][#2 - #1] &}; Grid[Join[ {TraditionalForm[Trace[#[a, b]][[2]]] & /@ functions}, ParallelTable[ draw[PolyhedronData[{"Pyramid", v}, "VertexCoordinates"], df, 5000], {v, 3, 5}, {df, functions}]]] ![enter image description here][275] ![enter image description here][276] ![enter image description here][277] ![enter image description here][278] ![enter image description here][279] ![enter image description here][280] ![enter image description here][281] game = Compile[{{vertices, _Real, 2}, {w, _Real}, {numpoints, _Integer}}, Module[{diff}, FoldList[(diff = #2 - #1; Clip[(#1 + #2) Log[Sqrt[diff.diff] + w]]) &, {0, 0, 0}, RandomChoice[vertices, numpoints]]]]; draw[vertices_, w_, numPoints_, options___] := Graphics3D[{PointSize[0], Opacity[7 .05], Point[game[vertices, w, numPoints]]}, options, Boxed -> False]; Needs["PolyhedronOperations`"]; vertices = Stellate[PolyhedronData[{"Pyramid", 5}, "Faces"]][[1]]; draw[vertices, .2, 600000, PlotRange -> All(*, Method->{"ShrinkWrap"->True}*)(*,ViewPoint->{Infinity,0,0}*)] These pictures differ by ***w*** factor, viewpoint, or the set of vertices on which the game is being played. For most of these I'm using the vertices of regular polyhedra from `PolyhedronData`. Note that the vertices of the game are not necessarily in proportion to the figure itself. At this point I should remention that all of the code snippets on this page are self-contained. If you have Mathematica you can copy-paste this and start producing these figures, which, I should also remention, are interactive 3D models. I'm a big fan of black ink on white paper, and these are like being able to change the perspective of a pure ink painting in real time. Teknikara no jutsu. ![enter image description here][282] ![enter image description here][283] ![enter image description here][284] ![enter image description here][285] ![enter image description here][286] ![enter image description here][287] ![enter image description here][288] ![enter image description here][289] game = Compile[{{vertices, _Real, 2}, {w, _Real}, {numpoints, _Integer}}, Module[{diff}, FoldList[(diff = #2 - #1; Clip[(#1 + #2) Log[Sqrt[diff.diff] + w]]) &, {0, 0, 0}, RandomChoice[vertices, numpoints]]]]; draw[vertices_, w_, numPoints_, options___] := Graphics3D[{PointSize[0], Opacity[7 .05], Point[game[vertices, w, numPoints]]}, options, Boxed -> False]; proc[img1_, cf_: ColorData[1], mode_: None, blur_: 8] := Module[{img, components, rank, largest, colored}, img = RemoveAlphaChannel[ColorNegate@ColorConvert[img1, "Grayscale"]]; components = MorphologicalComponents[img]; Module[{measurements, sorted}, measurements = ComponentMeasurements[components, "Count"]; sorted = First /@ Reverse@SortBy[measurements, Last]; rank[label_] := (rank[label] = Position[sorted, label][[1, 1]])]; colored = Colorize[components, ColorFunction -> (cf[rank[#]] &), ColorFunctionScaling -> False]; If[mode == "Angelic", colored = ImageMultiply[img, colored]]; ColorNegate[ImageMultiply[ColorNegate[img], Blur[#, blur] &@ColorNegate[colored]]] // ImageAdjust]; Needs["PolyhedronOperations`"]; vertices = OpenTruncate[PolyhedronData[{"Pyramid", 3}, "Faces"]][[1]]; g = draw[vertices, .5, 600000, Method -> {"ShrinkWrap" -> True}]; proc[g, # /. Join[ Thread[Range[4] -> {Red, Green, Green, Green}], {_ -> Lighter[Green]}] &] Some of thes are like alien Rorschach tests. Like what do you see in this one? I see a mosquito that can suck the lifeblood out of your soul. This one, however, is definitely from an as-yet unreleased Matrix film. And we also have the Minotaur's armor and his shield of Cancer. I'd recognize my buddy's armor in even the most obtuse alien Rorschachs. See also a stereographic projection of one of the rooms of Asterion's maze and an aspect, which needs no explanation. The originals are 3D but this coloring is a 2D image process. It highlights components of the image based on their sizes. So if your image has 3 large blobs with dozens of tiny blobs all around, you can use, for example, `# /. {1 -> Red, 2 -> Green, 3 -> Yellow, _ -> Pink}` & to color the big blobs specific colors and all other blobs pink. Though in most of these images I only use one or two colors. game = Compile[{{vertices, _Real, 2}, {numPoints, _Integer}, {wowzerz, _Real}}, Module[{diff}, FoldList[(diff = #2 - #1; Clip[(#1 + #2) Log[Sqrt[diff.diff] + wowzerz]]) &, {0., 0., 0.}, RandomChoice[vertices, numPoints]]]]; {numFrames, imageSize, numPoints} = { {5(*sec*)15(*fps*), 1/2 {640, 480}, 1/3 600000}, {20(*sec*)15(*fps*), {640, 480}, 600000}}[[1]]; Needs["PolyhedronOperations`"]; vertices = Stellate[PolyhedronData[{"Pyramid", 5}, "Faces"]][[1]]; frame = Function[w, Graphics3D[{Opacity[.1], PointSize[0], Point[game[vertices, numPoints, w]]}, ImageSize -> imageSize, ViewVertical -> {0, 0, 1}, Boxed -> False, SphericalRegion -> True, PlotRange -> 1, ViewVector -> {RotationTransform[2 Pi w, {0, 0, 1}][{1, 0, (w - .25) Pi/2}], {0, 0, 0}}]]; SetDirectory["c:/users/zrp/desktop/frames"]; range = Range[0, 3/4, 3/4/(numFrames - 1)]; file[w_] := ToString[N@w] <> ".png"; ParallelDo[ If[! FileExistsQ[file[w]], Export[file[w], frame[w]]], {w, range}]; Export["mov.avi", ColorNegate /@ ImageAdjust /@ Import /@ file /@ range] Beep[]; Button[open, SystemOpen["mov.avi"], Enabled -> FileExistsQ["mov.avi"]] ![enter image description here][290] MovieMaker[frameF_, range : {start_Integer, stop_Integer}, rest___] := MovieMaker[frameF, {start, stop, stop - start}, rest]; (*arithmetic for eg doubling movie length is easier by 'intervals' than by 'frame count'*) MovieMaker[frameF_, range : {start_, stop_, numIntervals_}, rest___] := MovieMaker[frameF, List[Range[#1, #2, (#2 - #1)/#3(*(#3-1)*)] & @@ range], rest]; MovieMaker::expqq = "Export is complaining about something. " <> "Most likely you're feeding it items with different image sizes."; MovieMaker::usage = "NOTE: copies of this notebook are automatically stored along with the generated files. To prevent this, set AutoArchive -> False. MovieMaker[frameFunction, rangeSpec, options___] rangeSpec: {start, stop, number of intervals}: {0, 1, 5(*sec*)15(*fps*)} {start, stop} integer range: {1, 20} {explicit list}: {AstronomicalData[\"Earth\",\"OrbitPath\"][[1]]} The Label option determines the folder name under which the animation is created. For example, if changing a variable X makes a different animation, then place that variable in the Label spec so that when you change that variable, the animation will be generated in a different folder. Likewise, the first element of the Process spec determines the folder and uniqueness of the process function. Processes work in subfolders of the main project folder, meaning you can experiment with multiple processes in a single project. MovieMaker[ {ToLowerCase[#], ToUpperCase[#]} &, {CharacterRange[\" \", \"~\"]}, Serialization -> Hash, Label -> \"UpperLower\", FileTypes -> {\".mx\", \".png\", \".gif\"}, Process -> {\"times\", ImageMultiply @@ Map[Rasterize[#, ImageSize -> 400 {1, 1}] &, #] &}, MovieOptions -> {\"DisplayDurations\" -> 1}, MapFunction -> Map] Serialization is for converting values to valid file names. MapFunction is for when you don't want to use parallelization. Directory setting specifies the specific project folder, overriding Label."; Options[MovieMaker] = { Label -> Automatic, Process -> {None, None}, MapFunction -> ParallelMap, AutoArchive -> True, FileTypes -> {".png", ".png", ".avi"}, MakeMovie -> True, MovieOptions -> {}, Directory -> Automatic, Ordering -> (BlockRandom[RandomSample[#]] &), Serialization -> Composition[List, Chop, N]}; (* After I wrote this program, a more powerful approach occurred to me. We could have a macro that would be used something like this: *) FileBackedProcess[Function[val, a = S[1][Rasterize@dirp[val]]; b = S[2][Rasterize@derp[val]]; S[3][ImageMultiply[a, b]]]]; (* where the S[i_][body_] are the momoization points into the file system. If the S finds the file corresponding to the [i][body], then the file is imported. Otherwise it executes the body and saves the file. The point would be to make the file aspect as easy as annotating things with S[i] *) MovieMaker[frameF_, List[valueList_List], OptionsPattern[]] := Module[{ tooltip, mainLabel, processLabel, processF, mapF, frameExt, processedExt, movieExt, dir, framesDir, processedDir, movieFile, fileMap, numFrames, alive = True, folder0exists, foldersExistL, folder1exists, folder2exists, progress1, progress2, movieDone, makeFrames, processFrames, makeMovie, serialization, archive, makeMovieA, preview, printPreview, printFileMap}, tooltip[expr_] := Tooltip[#, expr, TooltipDelay -> .25] &; {mainLabel, mapF, makeMovieA, serialization} = OptionValue[{Label, MapFunction, MakeMovie, Serialization}]; {processLabel, processF} = Replace[OptionValue[Process], { {pf_} :> {ToString[pf], pf}, pf : Except[_List] :> {ToString[pf], pf}}]; {frameExt, processedExt, movieExt} = PadRight[ Flatten[List[OptionValue[FileTypes]]], 3, FileTypes /. Options[MovieMaker]]; mainLabel = Replace[mainLabel, Automatic -> IntegerString[Hash[{frameF, valueList}, "CRC32"], 36]]; dir = Replace[OptionValue[Directory], Automatic -> FileNameJoin[{NotebookDirectory[], "vids", ToString[mainLabel]}]]; framesDir = FileNameJoin[{dir, "frames"}]; processedDir = FileNameJoin[{dir, "processed", ToString[processLabel]}]; movieFile = FileNameJoin[{dir, ToString[{processLabel, mainLabel}] <> movieExt}]; (* main iteration construct *) fileMap[f_, vals_: valueList, map_: mapF] := map[Function[val, f[ FileNameJoin[{framesDir, ToString[serialization[val]] <> frameExt}], FileNameJoin[{processedDir, ToString[serialization[val]] <> processedExt}], val]], vals]; numFrames = Length[valueList]; progress1 = Total@Boole[fileMap[FileExistsQ[#1] &]]; progress2 = Total@Boole[fileMap[FileExistsQ[#2] &]]; foldersExistL = FileExistsQ /@ {dir, framesDir, processedDir}; movieDone = FileExistsQ[movieFile]; SetSharedVariable[progress1, progress2]; If[OptionValue[AutoArchive] && FileExistsQ[dir] && ! FileExistsQ[FileNameJoin[{dir, ToString[mainLabel] <> ".nb"}]], Export[FileNameJoin[{dir, ToString[mainLabel] <> ".nb"}], NotebookGet[EvaluationNotebook[]]]]; (**) makeFrames[] := ( Quiet@CreateDirectory[framesDir]; foldersExistL[[1 ;; 2]] = {True, True}; If[OptionValue[AutoArchive], Export[FileNameJoin[{dir, ToString[mainLabel] <> ".nb"}], NotebookGet[EvaluationNotebook[]]]]; fileMap[If[! FileExistsQ[#1], Export[#1, frameF[#3]]; progress1++] &, OptionValue[Ordering][valueList]]); (**) processFrames[] := If[ processF =!= None, Quiet@CreateDirectory[processedDir]; foldersExistL[[3]] = True; If[OptionValue[AutoArchive], Export[FileNameJoin[{processedDir, ToString[{mainLabel, processLabel}] <> ".nb"}], NotebookGet[EvaluationNotebook[]]]]; fileMap[If[! FileExistsQ[#2] && FileExistsQ[#1], Export[#2, processF[Import[#1]]]; progress2++] &, OptionValue[Ordering][valueList]]]; (**) makeMovie[] := If[makeMovieA, If[FileExistsQ[movieFile], Print["movie file already exists"], With[{ab = If[processF === None, #1, #2]}, If[And @@ fileMap[FileExistsQ[ab] &], Check[ Export[movieFile, fileMap[Import[ab] &], Sequence @@ OptionValue[MovieOptions]]; movieDone = True, Message[MovieMaker::expqq]; movieDone = False, {Export::errelem}]]]]]; (**) preview[] := preview[RandomChoice[valueList]]; preview[val_] := Module[{frame, fileName, tempFile}, tempFile = FileNameJoin[{$TemporaryDirectory, ToString[Hash[val]] <> frameExt}]; fileName = First@fileMap[#1 &, {val}]; If[FileExistsQ[fileName], (**)frame = Import[fileName], (**)frame = Import[Export[tempFile, frameF[val]]]; Print[Labeled[frame, N@val, Right]]; Beep[]]; If[processF =!= None, Print[Labeled[processF[frame], N@val, Right]]; Beep[]]]; (**) printPreview[] := CellPrint[ExpressionCell[Defer[ preview[Placeholder["val"]]], "Input"]]; (**) printFileMap[] := CellPrint[ExpressionCell[Defer[ frames2 = fileMap[If[FileExistsQ[#2], Import[#2], Sequence @@ {}] &];], "Input"]]; (**) archive[] := Module[{fileName}, fileName = ToString[mainLabel] <> " " <> DateString[{"DateShort", " (", "Hour12", " ", "Minute", " ", "Second", " ", "AMPM", ")"}]; Quiet@CreateDirectory[dir]; foldersExistL[[1]] = True; Export[FileNameJoin[{dir, fileName <> ".nb"}], NotebookGet[EvaluationNotebook[]]]; Beep[]]; (*controls*) With[{ btnMakeFrames = Button["frames + process + movie", makeFrames[]; Beep[]; processFrames[]; Beep[]; makeMovie[]; Beep[], Method -> "Queued", Enabled -> Dynamic[progress1 =!= numFrames]], btnProcessFrames = Button["process + movie", processFrames[]; Beep[]; makeMovie[]; Beep[], Method -> "Queued", Enabled -> Dynamic[ progress2 =!= numFrames && progress1 =!= 0 && processF =!= None]], btnMakeMovie = Button["movie", makeMovie[]; Beep[], Method -> "Queued", Enabled -> Dynamic[ (progress2 === numFrames || (processF === None && progress1 === numFrames)) && ! movieDone && makeMovieA]], btnMainFolder = tooltip["open folder"]@ Button[{mainLabel, processLabel}, SystemOpen[dir], Enabled -> Dynamic[foldersExistL[[1]]]], btnFramesFolder = tooltip["open folder"]@ Button[{Dynamic[progress1]/ToString[numFrames], ProgressIndicator[Dynamic[progress1/numFrames]]}, SystemOpen[framesDir], Enabled -> Dynamic[foldersExistL[[2]]]], btnProcessFolder = tooltip["open folder"]@ Button[{Dynamic[progress2]/ToString[numFrames], ProgressIndicator[Dynamic[progress2/numFrames]]}, SystemOpen[processedDir], Enabled -> Dynamic[processF =!= None && foldersExistL[[3]]]], btnMovieFile = tooltip["open movie"]@ Button[{Dynamic[Boole[movieDone]]/"1", ProgressIndicator[Dynamic[Boole[movieDone]/1]]}, SystemOpen[movieFile], Enabled -> Dynamic[movieDone]]}, (*without going the extra mile, better to have no persistence*) Dynamic[If[alive === True, Panel[#, FrameMargins -> {{Automatic, Automatic}, {Automatic, 0}}], Panel[Tooltip[Overlay[{ Style["VWXYZ", Lighter[LightGray, 2/3], FontFamily -> "Wingdings"], Style["dead", Darker[Red, 1/6]]}, All, 2, Alignment -> {Center, Center}], "R.I.P. this MovieMaker module"], FrameMargins -> 0]]] &@ Manipulate[ Grid[{ {btnMainFolder, SpanFromLeft}, {btnMakeFrames, btnFramesFolder}, {btnProcessFrames, btnProcessFolder}, {btnMakeMovie, btnMovieFile}}], Bookmarks :> { "preview" :> AbortProtect[preview[]], Overscript[Row[{"print ", Style["preview", Bold], " function"}], ""] :> printPreview[], Row[{"print ", Style["fileMap", Bold], " function"}] :> printFileMap[], Overscript["write archive", ""] :> archive[], "shoot" :> (alive = False)}, Paneled -> False, FrameMargins -> False]]]; game = Compile[{{vertices, _Real, 2}, {numPoints, _Integer}, {wowzerz, _Real}}, Module[{diff, b}, (*NestList for less memory usage. i didn't actually verify this*) NestList[( b = RandomChoice[vertices]; diff = b - #1; Clip[(#1 + b) Log[Sqrt[diff.diff] + wowzerz]]) &, {0, 0, 0}, numPoints]]]; proc[img1_, cf_: ColorData[1], mode_: None, blur_: 8] := Module[{img, components, rank, largest, colored}, img = RemoveAlphaChannel[ColorNegate@ColorConvert[img1, "Grayscale"]]; components = MorphologicalComponents[img]; Module[{measurements, sorted}, measurements = ComponentMeasurements[components, "Count"]; sorted = First /@ Reverse@SortBy[measurements, Last]; rank[label_] := (rank[label] = Position[sorted, label][[1, 1]])]; colored = Colorize[components, ColorFunction -> (cf[rank[#]] &), ColorFunctionScaling -> False]; If[mode == "Angelic", colored = ImageMultiply[img, colored]]; ColorNegate[ImageMultiply[ColorNegate[img], Blur[#, blur] &@ColorNegate[colored]]] // ImageAdjust]; Needs["PolyhedronOperations`"]; vertices = OpenTruncate[PolyhedronData["Icosahedron", "Faces"]][[1]]; vertices = Rescale[vertices] - 1/2; (*rescale to 1/2 {-1, 1} range*) {numFrames, imageSize, numPoints} = { {5(*sec*)15(*fps*), {16, 9} (360/9), 600000}, {5(*sec*)15(*fps*), {16, 9} (1080/9), 10000000}}[[2]]; label = {"NUCLEAR1080P", numPoints, IntegerString[Hash[vertices, "CRC32"], 36]}; process = { {"[COLORDATA3]", Composition[ proc[#, If[# == 1, Blue, ColorData[3][#]] &, "Angelic", 1] &, ImageResize[#, Scaled[1/2]] &, Blur[#, 1] &, ImageAdjust]}, {"[HIGHBLUR]", Composition[ proc[#, If[# == 1, Blue, ColorData[3][#]] &, "Angelic", 40] &, ImageResize[#, Scaled[1/2]] &, ImageAdjust]}}[[2]]; frame[w_] := Graphics3D[{Opacity[.1], PointSize[0], Point[game[vertices, numPoints, w]]}, ImageSize ->(**)2(**)imageSize, ViewVertical -> {0, 0, 1}, Boxed -> False, SphericalRegion -> True, Method -> {"ShrinkWrap" -> True}, ViewVector -> {RotationTransform[2 Pi w, {0, 0, 1}][{1, 0, (w - .25) Pi/2}], {0, 0, 0}}]; MovieMaker[frame, {.4, .75, 4 numFrames}, Label -> label, Process -> process] This just need some James Horner music. And science majors, witness a dangerous nuclear science experiment gone horribly awesome. These are animations on the ***w*** factor. For the source, you can just use the basic code. But if you intend to do more general experimentation, then something like my little MovieMaker utility will be useful. It's a quite general utility. Each of these movies took something on the order of 20 hours for my computer to make. That's why having a minimal-fuss setup is convenient. As for the renderings and animations themselves, they're basically me chewing a few times on one of the leaves of one of the branches of a tree I happened to run up the side of like a monkey. There's a lot of trees in this jungle to monoperambulate. What's great about these structures is that they are still fractals. They may look spazzy and some of them may remind you of Vash the Stampede's plant mode arm, but they possess self-similarity throughout. For example, why do the arms of the nest look like that? ![enter image description here][291] ![enter image description here][292] ![enter image description here][293] ![enter image description here][294] ![enter image description here][295] ![enter image description here][296] It's because the nest as a whole looks like that. And notice that as the big bird flies in from below to explode into the nest, the little birds all around the nest follow along (because adults know best) and explode into their own little nests, and so on, producing the distinctive infinitary echela of simultaneously exploding dinosaur progeny. And notice that the big bird itself is a version of the entire figure. Now, as for the hat, who knows. The chaos game is an algorithm that we use for the sake of computational convenience. The "real" algorithm doesn't randomly pick among the vertices, it takes every point toward every observer at each step. And it's actually easy to see how the self-similarity of the algorithm comes about. Look here at a house and an observer: ![enter image description here][297] ![enter image description here][298] ![enter image description here][299] ![enter image description here][300] ![enter image description here][301] If we run one step of the "real" algorithm, we get this. Something interesting here is that there is no difference between what the observer sees in either case. The little house is exactly blocking his or her view of the bigger house, like an inescapable mathematical version of a really tall person sitting in front of you at a theatre (formally we would say the houses are *cosyzygous*). If we start with two observers, we get this then this. ![enter image description here][303] Another way of thinking about it is that the resulting figure is precisely the figure that all observers "agree on": ![enter image description here][304] Because running the full algorithm on the entire figure does nothing. I.e. the figure is the fixed point of the algorithm. This automagic consensusing bonks my head and seems to me to carry a particular philosophical undertone... over which I shalln't digress. Mathematically, it appears our chaos game shennaneganery as a whole falls under the [contraction mapping principle][305]. Tersely complicated explanations of inconfusably simple things not withstanding, I know me some topology but not enough to understand the bigger picture of what's going on. On the subject of hats, when going from 2D L-systems to 3D L-systems I had to put a hat on the turtle and also give it the ability to do backflips and taco rolls: ![enter image description here][306] ![enter image description here][307] Even wearing Mugen's shoes. Wow. Unfortunately, as epic as this is, with our current technology we're limited to e.g. representing the turtle's hat with an abstraction called a "vector", which certainly doesn't connote the same social status or sophistication. Still it's enough for some 3D L-systems, such as this version of the arrowhead construction: ![enter image description here][308] ![enter image description here][309] ![enter image description here][310] Module[{options = { Axiom -> None, Rules -> {}, Iterations -> 1, Definitions -> {}, DrawStyle -> {}, HatStyle -> {}, Primitive -> Tube, TraceHat -> False, HatWorldplaneStyle -> Directive[EdgeForm[None], Opacity[.2]], HatPrimitive -> Composition[Arrow, Tube], Angle -> 2. Pi/6, RandomStuff -> Sphere[{0, 0, 0}, .05]}}, SetAttributes[Draw, Orderless]; Draw[commands : {Except[_Rule | _RuleDelayed] ..}, rules : {(_Rule | _RuleDelayed) ..}, rest___] := Draw[Axiom -> commands, Rules -> rules, rest]; Draw[rules : {(_Rule | _RuleDelayed) ..}, rest___] := Draw[Rules -> rules, rest]; Draw[commands : {Except[_Rule | _RuleDelayed] ..}, rest___] := Draw[Axiom -> commands, rest]; Draw[opts : OptionsPattern[Join[Options[Graphics3D], options]]] := Module[{commands, reshape, states, points, hatTrace, hatWorldplane, forwardP, leftP, frontflipP, tacoleftP, flipoutP, pushI, popI, definitionsI}, (*basic parameterized state transfer functions*) forwardP[p_][{z_, face_, hat_}] := {z + p face, face, hat}; leftP[p_][{z_, face_, hat_}] := {z, RotationTransform[p, hat][face], hat}; tacoleftP[p_][{z_, face_, hat_}] := {z, face, RotationTransform[p, face][hat]}; frontflipP[p_][{z_, face_, hat_}] := Module[{rot}, rot = RotationTransform[p, Cross[hat, face]]; {z, rot[face], rot[hat]}]; flipoutP[p1_, p2_] := Composition[frontflipP[-p2], tacoleftP[-p1]]; (*general function. fit elements of l1 into structure of l2*) reshape[l1_, l2_] := Module[{i = 1, length = Length[l1]}, Map[l1[[Mod[i++, length, 1]]] &, l2, {-1}]]; (*LIFO stack*) {pushI, popI} = Module[{stack = {}}, {(AppendTo[stack, #]; #) &, Module[{val = Last[stack]}, stack = Most[stack]; val] &}]; With[{vars = First /@ options}, Module[vars, vars = OptionValue[vars]; If[Axiom === None && Rules =!= {}, Axiom = Rules[[1, 1]]];(*default axiom*) Axiom = Flatten[{Axiom}];(*normalize to list/directive*) {DrawStyle, HatStyle, HatWorldplaneStyle} = Directive /@ {DrawStyle, HatStyle, HatWorldplaneStyle}; Definitions = Join[Definitions, { F -> forward, B -> backward, L -> left, R -> right, FO -> flipout, FO[p_] :> flipout[p], FF -> frontflip, BF -> backflip, TL -> tacoleft, TR -> tacoright}]; definitionsI = { forward[p_] :> forwardP[p], backward[p_] :> forwardP[-p], left[p_] :> leftP[p], right[p_] :> leftP[-p], tacoleft[p_] :> tacoleftP[-p], tacoright[p_] :> tacoleftP[p], frontflip[p_] :> frontflipP[p], backflip[p_] :> frontflipP[-p], forward -> forwardP[1], backward -> forwardP[-1], left -> leftP[Angle], right -> leftP[-Angle], tacoleft -> tacoleftP[-Angle], tacoright -> tacoleftP[Angle], frontflip -> frontflipP[Angle], backflip -> frontflipP[-Angle], flipout -> flipoutP[Angle, Angle], flipout[p1_] :> flipoutP[p1, Angle], flipout[p1_, p2_] :> flipoutP[p1, p2], push -> pushI, pop -> Sequence[popI, Identity](*preadjustment for reshape*)}; (*note no memoization. if you try, keep in mind case of RuleDelayed*) commands = Nest[Flatten[Replace[#, Rules, {1}]] &, Axiom, Iterations]; commands = Flatten[((# /. Definitions) /. definitionsI) & /@ commands]; states = ComposeList[commands, N@{{0, 0, 0}, {0, 1, 0}, {0, 0, 1}}]; points = reshape[First /@ states, Split[popI === # & /@ Join[{0}, commands]]];(*pop is turtle teleportation*) points = Composition[First /@ # &, Split] /@ points;(*delete duplicate points*) Graphics3D[{ {RandomStuff /. None -> {}, {DrawStyle, Primitive[points]}}, If[TraceHat, hatTrace = {#1, #1 + 2 #3/5} & @@@ states; hatTrace = First /@ Split[hatTrace];(*delete duplicate hats*) hatWorldplane = Polygon[{#1, #2, #4, #3} & @@ Flatten[#, 1]] & /@ Partition[hatTrace, 2, 1]; {{HatStyle, HatPrimitive[hatTrace]}, {HatWorldplaneStyle, hatWorldplane}}, {}]}, Quiet@FilterRules[{opts}, Options[Graphics3D]], Boxed -> False]]]]]; Draw[ {X, push, BF, L, X, R, R, X, pop, R, X, L, TL, L, X, R, F}, {F -> {F, BF, push, L, X, R, R, X, pop, R, X, L, L, X, R, F}, X -> {F, BF, push, L, F, R, R, R, F, pop, R, F, L, L, F, R, F}}, Iterations -> 3, DrawStyle -> {Opacity[.65], Glow[Darker[Red, 2/3]]}, Definitions -> {X -> Identity}, Angle -> Pi/8] Whoops. Accidentally X-rayed my heart. Or was that this one? In any case, this is the 3D Sierpinski arrowhead curve. It might not look very 3D, but technically it's 3D because it's made out of a tube instead of a line. All joking aside, try as I might I wasn't able to figure out the construction for the 3D arrowhead curve, sadface. And though this a crushing defeat, we here at the Sierpinski triangle page are stalwart folk for whom such failure is but a rare trigger of recidivistic saccades to our respective vices, for in the characteristic case we amene our fibrile egos by way of the platitudinous homily that what doesn't kill you makes you stronger. In the process of trying to figure out the 3D arrowhead I ended up making an easy-to-use flexible L-system program. True story, when I woke up this morning I could have sworn my body was contorting into different LOGO curves, in the hope of trial-and-erroring the arrowhead construction. It was like that dream scene in Fight Club, except instead of a girl it was a LOGO curve. Definitely one of the more Freudiologically-awkward memories I'm going to have to carry around for the rest of my life. ![enter image description here][311] ![enter image description here][312] ![enter image description here][313] ![enter image description here][314] ![enter image description here][315] ![enter image description here][316] ![enter image description here][317] ![enter image description here][318] proc[img1_, cf_: ColorData[1], mode_: None, blur_: 8] := Module[{img, components, rank, largest, colored}, img = RemoveAlphaChannel[ColorNegate@ColorConvert[img1, "Grayscale"]]; components = MorphologicalComponents[img]; Module[{measurements, sorted}, measurements = ComponentMeasurements[components, "Count"]; sorted = First /@ Reverse@SortBy[measurements, Last]; rank[label_] := (rank[label] = Position[sorted, label][[1, 1]])]; colored = Colorize[components, ColorFunction -> (cf[rank[#]] &), ColorFunctionScaling -> False]; If[mode == "Angelic", colored = ImageMultiply[img, colored]]; ColorNegate[ImageMultiply[ColorNegate[img], Blur[#, blur] &@ColorNegate[colored]]] // ImageAdjust]; (**)im = Draw[Iterations -> 17, {F -> {B, left[.020944], B}, B -> {L, F}}, RandomStuff -> None, Angle -> Pi/5, ImageSize -> 1280, ViewPoint -> {0, 0, Infinity}] // Rasterize; GradientFilter[im, 5] // ColorNegate // proc[#, Blue &] & // ColorNegate // ImageResize[#, Scaled[1/2]] & (**)Draw[{A -> {B, L, B}, B -> {A, R, A}}, Primitive -> (Rotate[Line[#], -Pi/24, {0, 0, 1}] &), Iterations -> 13, Angle -> 7 Pi/12, Definitions -> {B -> forward, A -> forward}, DrawStyle -> Opacity[.5], RandomStuff -> None, ViewPoint -> {0, 0, Infinity}] (**)Draw[Iterations -> 9, {A -> {B, L, B}, B -> {A, R, A}}, Definitions -> {B -> forward, A -> forward}, RandomStuff -> {Transparent, Sphere[{0, 0, 0}, .05]}, DrawStyle -> {Opacity[.8], Yellow, Glow[Green]}, ViewPoint -> {0, 0, Infinity}] (**)d = Draw[{swirl -> ConstantArray[{BF, F, BF, swirl, FO[Pi/12]}, 5]}, DrawStyle -> Opacity[.9], RandomStuff -> None, Primitive -> (Line[First@#, VertexColors -> (Darker[#, 1/8] & /@ ColorData["AvocadoColors"] /@ Range[0., 1, 1/(Length[First[#]] - 1)])] &), Definitions -> {swirl -> backward}, Iterations -> 6, ImageSize -> 2 1280, Method -> {"ShrinkWrap" -> True}, Background -> Lighter[LightGray, 7/12]] // Rasterize; d // ImageResize[#, Scaled[1/4]] & // ImageReflect[#, Top -> Bottom] & // ImagePad[#, 2, Lighter[LightGray, 7/12]] & (**)Draw[Iterations -> 8, {F :> {F, flipout[.2 RandomReal[], Pi RandomReal[]], F}}] (**)h = Draw[{R -> {B, R, R, R, F}}, Iterations -> 8, Primitive -> Line, RandomStuff -> None, Angle -> 1907/2048, ImageSize -> 2 1280, ViewPoint -> {0, 0, Infinity}] // Rasterize; proc[h // ImageAdjust, Yellow &, "Anglic", 13] // ImageResize[#, Scaled[1/4]] & (**)diff = ImageDifference @@ Table[ Draw[{arc, F, arc}, {F -> {F, F, arc, F, arc, F, arc, F, F}}, Primitive -> (Tube[#, .115] &), Angle -> Pi/6, Definitions -> {F -> forward[6], arc -> Flatten[Table[{forward[.1], backflip[.899 .1047], right[1/4 .1047]}, {160}]]}, Iterations -> 2, DrawStyle -> color, RandomStuff -> None, Lighting -> "Neutral", Method -> {"ShrinkWrap" -> True}, ViewPoint -> {3, -0.25, -1.5}, ViewVertical -> {0.56, -0.66, -0.7}, ImageSize -> 2 1280] // Rasterize, {color, {LightGray, White}}]; diff // ColorNegate // ImageAdjust // ImageResize[#, Scaled[1/4]] & What makes this program great is that even just for 2D L-systems, the 3D perspective makes things more intuitive. The arrowhead problem also demanded debugging features such as keeping track of the turtle's orientation, a definite necessity because of the enormous degrees of freedom that geometric L-systems possess. To give you an idea of this freedom, all of the items in this table are the same exact L-system at the same exact power. The only difference between them is the base angle specified. (By the way, notice Voltron. This is how you know L-systems are Turing complete.) If you take a couple of these to higher powers you get these images (11th and 13th iterations). It's interesting to wonder what some of these might look like at say the thousandth or billionth iteration. Or even, the *millionth*. **Sidenote.** You may have noticed that I never really explained what L-systems are. In fact what I do and don't explain on this page is pretty much completely arbitrary, largely to annoy people who are already familiar with all of this stuff. "Why aren't you mentioning IFS" I hear them crying. Hilarious. But if you've used Mathematica you know that it's well-suited for replacement schemes such as L-systems in a way that is difficult to convey in the context of other languages. Take a look at a simple function definition in Mathematica: add[a_, b_] := a + b add[_, _] := 1 What this is saying is: Whenever something matching the pattern `add[a_, b_]` is found, replace it by `a + b`. In other words, function application is a special case of pattern matching. Those `_` characters are the analogue of the regex . character, the Kleene proton. So `a_` means "match any single thing, and call it `a"`. You can in fact do this, which will make the 'function' return 1 when it is passed any two things, as well as use more involved patterns. I point this out because it can be difficult to appreciate the fundamental straightforwardness of the Mathematica language, I think even for people who have used it for a while. And especially if you're coming to Mathematica from more mainstream languages where the idea of function application being a special case of something more general would be considered some kind of unreachable koan. The arrowhead isn't the only L-system that can create the Sierpinski figure. More likely there are an infinite number of distinct L-systems that form the Sierpinski triangle in the limit. When we were fiddling with the Sierpinski triangle as a graph, you may have noticed that the zig zag and criss cross had recursive structure: ![enter image description here][319] ![enter image description here][320] ![enter image description here][321] ![enter image description here][322] With[{v = 5}, axiom = Polygon[{Cos[#], Sin[#]} & /@ (2 Pi Range[v]/v)]]; next[prev_] := prev /. Polygon[pts_] :> (Polygon[ScalingTransform[1/2 {1, 1}, #][pts]] & /@ pts); draw[n_] := Module[{edges}, edges = Flatten@Nest[next, N@axiom, n] /. Polygon[pts_] :> Sequence @@ UndirectedEdge @@@ Partition[pts, 2, 1, 1]; Graph[edges, VertexCoordinates -> VertexList[Graph[edges]], VertexSize -> .25]]; draw[2] GraphPlot3D[draw[2]] axiom = Polygon[{{0, 0}, {1, Sqrt[3]}/2, {1, 0}}]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; draw[n_] := Module[{edges}, edges = Flatten@Nest[next, N@axiom, n] /. Polygon[pts_] :> Sequence @@ UndirectedEdge @@@ Partition[pts, 2, 1, 1]; Graph[edges, VertexCoordinates -> VertexList[Graph[edges]], VertexSize -> .25]]; g = draw[2]; cycle = RandomChoice[{FindHamiltonianCycle, FindEulerianCycle}][g][[1]]; Animate[ HighlightGraph[g, Graph[cycle[[1 ;; n]]], EdgeShapeFunction -> (Line[#1] &), VertexShapeFunction -> None, GraphHighlightStyle -> "DehighlightHide"], {n, 1, Length[cycle], 1}, AnimationRate -> 1] We can find these paths for the 3D Sierpinski graph as well, though not necessarily. In fact all along we could have been grapherizing a lot of our stuff, even things like the different distance functions. My point here however is that we may be able to reverse-engineer an L-system from these structures. And it might not actually be hard at all. It does have the down side however of sounding really boring, so on to nonboringer pastures we skidaddle-prance. Since cellular automata often have the 'world' array joined at the ends, it makes sense to think of their evolution as being on a cylinder: ![enter image description here][323] ![enter image description here][324] ![enter image description here][325] ![enter image description here][326] ![enter image description here][327] ![enter image description here][328] ![enter image description here][329] ![enter image description here][330] ![enter image description here][331] draw[array_, options___] := Module[ {interval, topinterval, width, height, f, coords}, {height, width} = Dimensions[array]; interval = 2. Pi/width; topinterval = 2. Pi (1 + interval)/width; coords = Position[array, 1]; f[{x_, r_}] := Rotate[Translate[ Cuboid[-#, #] &[.5 topinterval {1, 1, 1}], {1, 0, -interval x}], interval r, {0, 0, 1}(*;{1,0,0}*), {0, 0, 0}]; Graphics3D[{{Lighter[LightBlue], Opacity[.5], Sphere[{0, 0, -interval height/2}, .5]}, EdgeForm[None], White, f /@ coords}, options, Boxed -> False]]; draw[CellularAutomaton[22, ConstantArray[0, 500]~ReplacePart~{1 -> 1, 251 -> 1}, 125], Lighting -> "Neutral"] draw2[im_Image, options___] := draw2[ImageData[ColorConvert[im, "RGB"]], options]; draw2[array_, options___] := Module[ {interval, width, height, f, cubes, coords}, {height, width} = Dimensions[array][[{1, 2}]]; interval = 2. Pi/width; coords = Position[array, p_ /; p != {0, 0, 0}, {2}]; f[{x_, r_}] := Rotate[Translate[ Cuboid[-#, #] &[.5 interval {1, 1, 1}], {1, 0, -interval x}], interval r, {0, 0, 1}, {0, 0, 0}]; cubes = MapThread[{RGBColor @@ #1, f[#2]} &, {array[[##]] & @@@ coords, coords}]; Graphics3D[{{Lighter[LightBlue], Opacity[.5], Sphere[{0, 0, -interval height/2}, .5]}, EdgeForm[None], cubes}, options, Boxed -> False]]; (*this rule from "http://web.cecs.pdx.edu/~mm/evca-review.pdf"*) rules = Thread[Tuples[{0, 1}, {7}] -> IntegerDigits[FromDigits["0504058705000f77037755837bffb77f", 16], 2, 128]]; arr = FixedPointList[CellularAutomaton[rules], RandomInteger[1, 600]]; arrEdge = ArrayPlot[arr, PixelConstrained -> 1, Frame -> False] // EdgeDetect // ImageData; (*ad hoc coloring, originally intended for particle animation*) pat1 = {{_, _, _, _, _}, {_, 1, 0, 0, 1}, {_, _, _, _, _}}; pat2 = {{_, 1, _, _, _}, {_, _, 1, _, _}, {_, _, _, 1, _}}; pat3 = {{_, _, _, _, _}, {_, 1, 1, 1, _}, {_, _, _, _, _}}; (f[#1 | Reverse /@ #1, _] = #2) & @@@ {_ -> {0, 0, 0}, pat1 -> {1, 0, 0}, pat2 -> {0, 1, 0}, pat3 -> {0, 0, 1}}; (*see also ImageFilter, ImageConvolve, a million other things*) colored = CellularAutomaton[{f, {}, {1, 2}}, arrEdge]; Image[colored] draw2[colored, Lighting -> "Neutral"] This is Rule 22 with two initial black squares. It's a cylindrical mapping of this. The sphere in the center is an homage to the Sega Saturn. Long live Sega Saturn, long live Dreamcast. Neo Geo forever. This is a different projection of the same thing, which might actually be easier to comprehend than the cylindrical projection. And a plot of a range-7 automaton, described in [this paper][332], that was evolutionarily engineered to discriminate between majority-white and majority-black initial conditions. And a particle plot oNEKO!!! Ka-wa-ii. My hope is the image of this dark hieroglyphic cat infests your dreams with nightmares so mindbendingly horrid your perception of reality and fantasy becomes forever warped. Whoops did I say that out loud. See also my [Cellular Automata][333] program. Of course, there are automata whose evolutions are properly three-dimensional, like these quadrilateral versions of Rule 22: ![enter image description here][334] ![enter image description here][335] ![enter image description here][336] ![enter image description here][337] ![enter image description here][338] draw[block_, options___] := Graphics3D[ {EdgeForm[Gray], Cuboid /@ Position[block, 1]}, options, ViewVertical -> {-1, 0, 0}, Boxed -> False]; draw[CellularAutomaton[{ 115792089237316195423570985008687907853269984665640564039476030751986839257106 , 2, {1, 1}}, {{{1}}, 0}, 31], Lighting -> "Neutral"] (**) grids = Partition[#, 3] & /@ Tuples[{1, 0}, {9}]; rule = IntegerDigits[#, 2, 512] &@ 115792089237316195423570985008687907853269984665640564039476030751986839257106; Dynamic[FromDigits[rule, 2]] Dynamic[draw[CellularAutomaton[{FromDigits[rule, 2], 2, {1, 1}}, {{{1}}, 0}, 31]]] With[{plot = Function[c, Magnify[ArrayPlot[#1, FrameStyle -> c], 1/6]]}, Grid[Partition[#, 32], Spacings -> {.1, .1}] &@ MapIndexed[ Toggler[Dynamic[rule[[First@#2]]], {0 -> plot[LightGray], 1 -> plot[Red]}] &, grids]] (**) z = Import["http://upload.wikimedia.org/wikipedia/commons/thumb/e/e0/Game_of_life_glider_gun.svg/610px-Game_of_life_glider_gun.svg.png"]; z = ImageData[ImageResize[z, Scaled[1/16], Resampling -> "Nearest"] // Binarize // ColorNegate]; Image[z] // Magnify With[{f = Switch[ {#[[2, 2]], Total[#, 2] - #[[2, 2]]}, {_, 3} | {1, 2}, 1, _, 0] &}, draw[CellularAutomaton[{f, {}, {1, 1}}, {z, 0}, 100]]] An actual 3D automaton whose evolution would be 4-dimensional: ![enter image description here][339] ![enter image description here][340] ![enter image description here][341] ![enter image description here][342] ![enter image description here][343] draw[block_, options___] := Graphics3D[ {EdgeForm[Darker[Gray]], Cuboid /@ Position[block, 1]}, options, ViewVertical -> {-1, 0, 0}, Boxed -> False]; f[block_, _] := Switch[ {block[[2, 2, 2]], Total[block, 3] - block[[2, 2, 2]]}, {_, 4}(*|{1,2}*), 1, _, 0]; evol = CellularAutomaton[{f, {}, {1, 1, 1}}, {{{{1, 1}, {1, 1}(*,{1,1},{1,1}*)}}, 0}, 15]; ListAnimate[ draw[#, Lighting -> "Neutral", ImageSize -> 400 {1, 1}] & /@ evol] draw[block_, options___] := Graphics3D[{ EdgeForm[None],(*Opacity[.8],*) Cuboid /@ Position[block, 1], Black, Cuboid /@ Position[block, 2]}, options, Lighting -> "Neutral", Boxed -> False]; f[block_, _] := Switch[ {block[[2, 2, 2]], Total[block, 3] - block[[2, 2, 2]]}, {_, 4}, 1, {0, 3}, 2, _, 0]; evol = CellularAutomaton[{f, {}, {1, 1, 1}}, {CrossMatrix[1 {1, 1, 1}]~BitXor~1, 0}, 25]; (*can be flashy*) (*ListAnimate[draw[#,ViewPoint->Top,ImageSize->400 {1,1}]&/@evol]*) draw[Last[evol], ImageSize -> 2 1280, ViewPoint -> 2 {1, 1, 1}, Lighting -> {{"Point", Yellow, Scaled[{1, 1, 1}], 5}}, Method -> {"ShrinkWrap" -> True}] // Rasterize // ImageResize[#, Scaled[1/4]] & And just so we're all clear, time isn't "the fourth dimension." That statement is the conceptual version of eating bagels without cream cheese, namely a manifestation of meaniglessness. ![enter image description here][344] If you have Mathematica 9 (must be nice), its Image3D functionality is perfect for these 3Dified cellular automata. And speaking of grid thingies, let's not forget our unexpectedly-glorious matrix replacement scheme: ![enter image description here][345] ![enter image description here][346] ![enter image description here][347] ![enter image description here][348] ![enter image description here][349] ![enter image description here][350] ![enter image description here][351] (**) Begin["mmx`"]; matrixInput3D1[Dynamic[tensor_], Dynamic[color_], options___] := Dynamic@Module[{grid}, grid = Position[ArrayPad[tensor, {0, -1}], _?IntegerQ]; EventHandler[#, {"MouseDown", 2} :> {}] &@ Graphics3D[{#, Transparent, EdgeForm[LightGray], Cuboid /@ grid}, options,(*Method->{"ShrinkWrap"->True},*)Boxed -> False] &@ Array[With[{loc := tensor[[##]]}, Mouseover[ (**){Style[#, Darker[color, .65]] &@ Text[Dynamic[loc /. 0 -> Style[0, Opacity[.5]]], {##}], Opacity[loc /. {0 -> .1, 1 -> .3}], Sphere[{##}, .2]}, (**){Text[EventHandler[Checkbox[Dynamic[loc], {0, 1}], {"MouseDown", 2} :> (loc = 0)], {##}], Opacity[.01], Sphere[{##}, .2]}]] &, Dimensions[tensor]]]; matrixInput3D2[Dynamic[tensor_], Dynamic[rules_], Dynamic[color_], options___] := Dynamic@DynamicModule[{grid}, grid = Flatten[Array[List, Dimensions[ArrayPad[tensor, {0, -1}]]], 2]; EventHandler[#, {"MouseDown", 2} :> {}] &@ Graphics3D[{#, Transparent, EdgeForm[LightGray], Cuboid /@ grid}, options,(*Method->{"ShrinkWrap"->True},*)Boxed -> False] &@ Array[With[{loc := tensor[[##]]}, With[{display = Tooltip[Panel[#, FrameMargins -> None], Column[{loc /. rules /. {Reverse -> "R", Transpose -> "T", Composition -> List, Verbatim[Slot][_] :> "m"}, "", "Click to cycle", "Right-click to zero"}], TooltipDelay -> .6] &}, Mouseover[ (**){Style[#, Darker[color, .65]] &@ Text[Dynamic[loc /. 0 -> Style[0, Opacity[.5]]], {##}], Opacity[loc /. {0 -> .1, _ -> .3}], Sphere[{##}, .2]}, (**){Text[EventHandler[ display[ Toggler(*PopupMenu*)[Dynamic[loc], First /@ rules, ImageSize -> Automatic] ], {"MouseDown", 2} :> (loc = 0)], {##}], Opacity[.01], Sphere[{##}, .2]}]]] &, Dimensions[tensor]]]; bg = White; dims = # -> If[# > 2, Style[#, Red], #] & /@ Range[5]; rotations = Flatten@Outer[Function[{o, dir}, Composition[Transpose[#, o] &, dir /@ # &, Transpose[#, o] &]], {{1, 2, 3}, {3, 2, 1}, {2, 1, 3}}, {Composition[Transpose, Reverse], Composition[Reverse, Transpose], Reverse, Transpose}, 1]; rotations = MapIndexed["S" @@ #2 -> #1 &, rotations]; defaultRules = Join[{0 -> (0 # &), 1 -> (# &)}, rotations]; iterate[matrix0_, matrixT_, rules_, power_] := Nest[Function[prev, ArrayFlatten[Map[#[prev] &, Replace[matrixT, rules, {3}], {3}], 3]], matrix0, power]; randomMatrix[dimensions_, source_] := With[ {rv := RandomVariate[ZipfDistribution[Length[source], 1]]}, Array[source[[rv]] &, dimensions]]; With[{HiPrint := Function[viewpoint, With[{pow = power}, CellPrint[ExpressionCell[ Defer[ powzerz = pow; With[{objects = Translate[primitive, Replace[Position[iterate[ matrix0 /. 0 matrix0 -> {{{1}}}, matrixT /. 0 matrixT -> {{{1}}}, rules, powzerz], If[negativeSpace, 0, 1]], {} -> {1, 1, 1}]]}, ImageResize[Rasterize[#], Scaled[1/4]] &@ Defer[Graphics3D][{color, Opacity[opacity], Glow[glow], Specularity[specularity], EdgeForm[{Opacity[opacity], Darker[color, 4 .15]}], objects}, Lighting -> "Neutral", Method -> {"ShrinkWrap" -> True}, ImageSize -> {Automatic, 4 732}, Boxed -> False, ViewPoint -> viewpoint, ViewVertical -> vv, Background -> background]]], "Input"]]]], printMatrices := Function[ CellPrint[ExpressionCell[DynamicModule[{ mtx0 = matrix0, mtxT = matrixT, mtx0o = matrix0, mtxTo = matrixT, clr = color, opc = opacity, ns = negativeSpace, pow = power, rls = rules, prm = primitive, iter = iterate, bg = background, vp1 = vp, vv1 = vv}, With[{ btn = Button[DynamicWrapper["print data", If[mtx0 =!= mtx0o || mtxT =!= mtxTo, mtx0 = mtx0o; mtxT = mtxTo]], Print[Grid[{ {"kernel matrix", MatrixForm[mtx0o]}, {"transformation matrix", MatrixForm[mtxTo]}, {"rules", rls}, {"power", pow}}]]], mtx0c = matrixInput3D1[Dynamic[mtx0], Dynamic[clr], SphericalRegion -> True, ImageSize -> Small, Background -> Lighter[bg, .8], ViewPoint -> Dynamic[vp1], ViewVertical -> Dynamic[vv1]], mtxTc = matrixInput3D2[Dynamic[mtxT], Dynamic[rls], Dynamic[clr], SphericalRegion -> True, ImageSize -> Small, Background -> Lighter[bg, .8], ViewPoint -> Dynamic[vp1], ViewVertical -> Dynamic[vv1]], g3d = With[{objects = Translate[prm, Replace[Position[iter[ mtx0 /. 0 mtx0 -> {{{1}}}, mtxT /. 0 mtxT -> {{{1}}}, rls, pow], If[ns, 0, 1]], {} -> {1, 1, 1}]]}, Graphics3D[{ EdgeForm[{Opacity[opc], Darker[clr, 4 .15]}], clr, Opacity[opc], objects}, ImageSize -> Small, Boxed -> False, SphericalRegion -> True, ViewPoint -> Dynamic[vp1], ViewVertical -> Dynamic[vv1], Lighting -> "Neutral", Background -> bg]]}, Panel[Grid[{ {Panel[Placeholder["name"]], SpanFromLeft, btn}, {mtx0c, mtxTc, g3d}}]]]]]]], (* controls *) dim0C = Control[{{dim0, 1, ""}, dims, ControlType -> PopupMenu}], dimTC = Control[{{dimT, 2, ""}, dims, ControlType -> PopupMenu}], matrix0C = matrixInput3D1[Dynamic[matrix0], Dynamic[color], SphericalRegion -> True, ImageSize -> Dynamic[imgSize1], Background -> Dynamic[Lighter[background, .8]], ViewPoint -> Dynamic[vp], ViewVertical -> Dynamic[vv]], matrixTC = matrixInput3D2[Dynamic[matrixT], Dynamic[rules], Dynamic[color], SphericalRegion -> True, ImageSize -> Dynamic[imgSize2], Background -> Dynamic[Lighter[background, .8]], ViewPoint -> Dynamic[vp], ViewVertical -> Dynamic[vv]], rulesC = Pane[Style[#, 10], {400, 200}, Scrollbars -> Automatic] &@ Control[{{rules, defaultRules, ""}, InputField, Background -> Dynamic[Lighter[background, .65]], FieldSize -> {50, {0., Infinity}}}], colorC = Control[{{color, RGBColor[.15, .6, 1], "color"}, ColorSlider}], backgroundC = Row[{"background ", Framed[ ColorSlider[Dynamic[background, (bg = background = #) &], AppearanceElements -> "Swatch"], FrameStyle -> Gray], " ", ColorSlider[Dynamic[background, (bg = background = #) &], AppearanceElements -> "Spectrum", ImageSize -> Small]}], opacityC = Control@{{opacity, 1, "opacity"}, 0, 1, ImageSize -> Small}, glowC = Control[{{glow, Black, "glow"}, ColorSlider}], specC = Control[{{specularity, Black, "specularity"}, ColorSlider, ImageSize -> Small}], primC = Control[{{primitive, Scale[Cuboid[],.99999], "primitive"}, # -> Graphics3D[{color, #}, Boxed -> False, ImageSize -> 20] & /@ {{PointSize[0], Point[{0., 0., 0.}]}, Sphere[{0., 0., 0.}, .5], {EdgeForm[None], Scale[Cuboid[],.99999]}, Scale[Cuboid[],.99999]}, SetterBar}], powerC = Control[{{power, 1, "power"}, 0, 5, 1, Appearance -> "Labeled"}], nsC = Control[{{negativeSpace, False, Tooltip["negative", "negative space", TooltipDelay -> .4]}, {False, True}}] }, (*control layout*) With[{controls := Row[{ Column[{ Row[{dim0C, " |", dimTC}], Row[{" ", matrix0C, " ", matrixTC}]}], Spacer[40], Column[{ OpenerView[{"Rules", rulesC}], OpenerView[{"Style", Column[{ Row[{ Column[{colorC, backgroundC}], Spacer[40], Column[{glowC, specC}]}], Row[{opacityC, Spacer[20], nsC, Spacer[20], primC}]}]}], powerC}]}], bookmarks := { Overscript["Random kernel matrix", ""] :> (matrix0 = randomMatrix[Dimensions[matrix0], {0, 1}]), "Random transformation matrix" :> (matrixT = randomMatrix[Dimensions[matrixT], First /@ defaultRules]), "Random both" :> ( matrix0 = randomMatrix[Dimensions[matrix0], {0, 1}]; matrixT = randomMatrix[Dimensions[matrixT], First /@ defaultRules]), Overscript["Clear kernel matrix", ""] :> (matrix0 = 0 matrix0), "Clear transformation matrix" :> (matrixT = 0 matrixT), "Clear both" :> ({matrix0, matrixT} = 0 {matrix0, matrixT}), Overscript["Invert kernel matrix", ""] :> (matrix0 = BitXor[matrix0, 1]), "Invert transformation matrix" :> (matrixT = Replace[matrixT, {0 -> 1, _ -> 0}, {3}]), Overscript["Print matrices", ""] :> printMatrices[], Overscript["HiPrint", ""] :> HiPrint[vp], "HiPrint Far" :> HiPrint[1000 vp]}}, Panel[#, Background -> Dynamic[bg]] &@ Manipulate[Module[{g3d, side}, If[dim0 {1, 1, 1} =!= Dimensions[matrix0], matrix0 = PadRight[matrix0, dim0 {1, 1, 1}]]; If[dimT {1, 1, 1} =!= Dimensions[matrixT], matrixT = PadRight[matrixT, dimT {1, 1, 1}]]; If[bg =!= background, bg = background]; Module[{matrixP},(*remove rules from matrix that no longer exist*) matrixP = Map[Function[a, If[a === Replace[a, rules], rules[[1, 1]], a]], matrixT, {3}]; If[matrixT =!= matrixP, matrixT = matrixP]]; g3d = With[{objects = Translate[primitive, Replace[Position[iterate[ matrix0 /. 0 matrix0 -> {{{1}}}, matrixT /. 0 matrixT -> {{{1}}}, rules, power], If[negativeSpace, 0, 1]], {} -> {1, 1, 1}]]}, Graphics3D[{ Dynamic[EdgeForm[{Opacity[opacity], Darker[color, 4 .15]}]], Dynamic[color], Dynamic[Opacity[opacity]], Dynamic[Glow[glow]], Dynamic[Specularity[specularity]], objects}, ImageSize -> {{300, Large}, {300, Large}}, Lighting -> "Neutral", Background -> Dynamic[background]]]; side = Map[Function[vp1, Tooltip[#, ViewPoint -> vp1, TooltipDelay -> .3] &@ EventHandler[#, "MouseDown" :> (vp = vp1 /. Infinity -> 4; vv = {0, 0, 1})] &@ Framed[Deploy[ Show[g3d, ViewPoint -> vp1, ImageSize -> Small, Boxed -> False]], FrameStyle -> Gray, Background -> Dynamic[background]]], Permutations[{Infinity, 0, 0}]]; Row[{Column[side,(*Dividers->All,*)FrameStyle -> Gray], Show[g3d, Boxed -> False, SphericalRegion -> True, (*PlotRangePadding->.001,*) ViewPoint -> Dynamic[vp], ViewVertical -> Dynamic[vv]]}] ], {{vv, {0, 0, 1}}, ControlType -> None}, {{vp, {1.3, -2.4, 2}}, ControlType -> None}, {{imgSize1, Small}, ControlType -> None},(*prevent matrix controls from autoresizing*) {{imgSize2, Small}, ControlType -> None}, {{background, White}, ControlType -> None}, {{matrix0, If[dim0 < 2, {{{1}}}, randomMatrix[dim0 {1, 1, 1}, {0, 1}]]}, ControlType -> None}, {{matrixT, If[dimT < 2, {{{1}}}, randomMatrix[dimT {1, 1, 1}, First /@ defaultRules]]}, ControlType -> None}, controls, Bookmarks :> bookmarks, LabelStyle -> Darker[Gray], SynchronousUpdating -> Automatic, Paneled -> False, SaveDefinitions -> True, Alignment -> Center]]] (**) End[]; This scheme clearly shows the projective character of these algorithms. Take for example this nifty 3D plus sign made of 3D plus signs, holy mathphobia inducer. It looks like a 2D fractal plus sign when viewed along each axis, but resembles various 2D constructions when viewed from mixed angles. What's not obvious from these images is that the matrix controls at the top (the pink spheres) and the output figure share the same viewpoint (twirl one, the other two follow). In Mathematica this is as easy as wrapping a couple of things in `Dynamic[ ]`, after which the system takes care of automatically updating things as necessary. It's pretty much the ideal of what event handling should be, at least for these kinds of applications. The underlying engineering for this on Mathematica's part must be very intricate. And speaking of intricate, this is probably the most complicated Mathematica program I've so far written, in part because I didn't run it through any last-phase refactoring. If you have the courage to fiddle with this program (and I encourage you to have this courage, as the program has a particular issue I couldn't solve), be prepared to suffer dearly for my laziness. Give me a moment. OK, it looks like we're in the inversion section. Where did all this 3D stuff come from? Holy cow. HOLY BRAHMAN DATA COW. Oh I think I know which voice it was. Irregardless, since a bunch of 3D things essentially just programmed themselves into existence while I wasn't looking, this means we can do 3D INVERSIONS!!!! Chaos game. ![enter image description here][352] ![enter image description here][353] ![enter image description here][354] ![enter image description here][355] ![enter image description here][356] draw[vertices_, numPts_] := Graphics3D[{PointSize[0], Opacity[.1], Point[FoldList[(#1 + #2)/2 &, .5 First[vertices], RandomChoice[N@vertices, numPts]]]}, Boxed -> False]; invert[p_] := p/Norm[p]^2; vertices = PolyhedronData[{"Pyramid", 3}, "VertexCoordinates"]; vertices = Normalize /@ (# - Mean[vertices] &) /@ vertices; Show[ draw[vertices, 20000], draw[vertices, 100000] /. Point[pts_] :> Point[invert /@ pts]] This. Four-headed tri-jawed infinity-mouthed Pac-man langolier. If the world ever decides to give me a nightmare, I hope it picks one of these adorable things to chase me through the dark recesses of my deranged mind. Geometric. ![enter image description here][357] ![enter image description here][358] ![enter image description here][359] ![enter image description here][360] draw[shape_, n_] := Module[{next}, (*scale by 1/2 toward each vertex, in turn*) next[prev_] := Scale[prev, 1/2, #] & /@ shape[[1]]; Graphics3D[{EdgeForm[Opacity[.15]], Nest[next, N@shape, n]}, Lighting -> "Neutral", Boxed -> False]]; invert[p_] := p/Norm[p]^2; shape = PolyhedronData[{"Pyramid", 3}, "Faces"]; shape[[1]] = Normalize /@ (# - Mean[shape[[1]]] &) /@ shape[[1]]; Show[ draw[shape, 3], (draw[shape, 4] // Normal) /. Polygon[pts_, __] :> Polygon[invert /@ pts]] The ostensive architectonics, quite awesome. c.f. Dyson sphere. The code however is simple. Cobra. ![enter image description here][361] ![enter image description here][362] ![enter image description here][363] ![enter image description here][364] ![enter image description here][365] draw[shape_, n_] := Module[{next}, (*scale by 1/2 toward each vertex, in turn*) next[prev_] := Scale[prev, 1/2, #] & /@ shape[[1]]; Graphics3D[{EdgeForm[Opacity[.15]], Opacity[.75], Black, Nest[next, N@shape, n]}, Lighting -> "Neutral", Boxed -> False]]; transform[1][p_] := p^3/Norm[p]^2; transform[2][p_] := (Reverse[p].p) p/Norm[p]^2; transform[3][p_] := (Reverse[p].Cross[{0, 0, 1}, p]) p/Norm[p]^2; shape = PolyhedronData[{"Pyramid", 3}, "Faces"]; (draw[shape, 4] // Normal) /. Polygon[pts_, __] :> Polygon[transform[1] /@ pts] And fishie! Logarithmic. ![enter image description here][366] ![enter image description here][367] ![enter image description here][368] ![enter image description here][369] game = Compile[{{vertices, _Real, 2}, {w, _Real}, {numpoints, _Integer}}, Module[{diff}, FoldList[(diff = #2 - #1; Clip[(#1 + #2) Log[Sqrt[diff.diff] + w]]) &, {0, 0, 0}, RandomChoice[vertices, numpoints]]]]; invert[p_ /; Norm[p] < .25] := 4 Normalize[p]; invert[p_] := p/Norm[p]^2; vertices = PolyhedronData[{"Pyramid", 3}, "VertexCoordinates"]; (*vertices=Normalize/@(#-Mean[vertices]&)/@vertices;*) Graphics3D[{PointSize[0], Opacity[.2], Point[invert /@ game[vertices, .01, 400000]]}, Boxed -> False] "Chaos game with logarithmic distance function" is a bit long. We need to give this specific kind of fractal a name. What about "Charlie render"? So I'd be like "here we have an inverted Charlie render at ***w*** factor .01" and people would nod comprehendingly while reading that, as if there were an established literature on Charlie renders. You might object that the contours of this nomenclature don't quite align with the striking yet oft- hauntingly quiescent leylines of its intended referents, but you would be wrong — the matching is nigh onomatopoeial per my linguistic auteurity. Incidentally, you should see what my writing looks like when I really cut loose. Rejoice asplendent my sparing you that paragon 'cross the rubicon, padawan. Since the originals have a lot of points close to 0, their inverses have a lot of points at very large distances. In this case I've decided to clamp the maximum distance of points to a short range (essentially putting them on a leash, like those ball & chain dogs in Mario Bros. 3). It's another way of dealing with infinities. I like this approach because it preserves the radial texture of the figure, snowglobe-like. Taking this to its conclusion, we normalize all points to the same distance: ![enter image description here][370] ![enter image description here][371] ![enter image description here][372] ![enter image description here][373] ![enter image description here][374] ![enter image description here][375] ![enter image description here][376] ![enter image description here][377] game = Compile[{{vertices, _Real, 2}, {w, _Real}, {numpoints, _Integer}}, Module[{diff}, FoldList[(diff = #2 - #1; Clip[(#1 + #2) Log[Sqrt[diff.diff] + w]]) &, {0, 0, 0}, RandomChoice[vertices, numpoints]]]]; vertices = PolyhedronData[{"Pyramid", 3}, "VertexCoordinates"]; (*vertices=Normalize/@(#-Mean[vertices]&)/@vertices;*) Module[{pts}, pts = game[vertices, .01, 400000]; Graphics3D[{ {Glow[White], Sphere[{0, 0, 0}, .99999]}, PointSize[0], Opacity[.5], Point[Normalize /@ pts, VertexColors -> (ColorData["AvocadoColors"] /@ Norm /@ pts)]}, ViewPoint -> {Sqrt[3], -Sqrt[8], 1}, Boxed -> False]] These two are the same, except the first one has an opaque sphere in the interior so that you can't see points beyond the horizon. The extra points in the second one are on the other side of the globe. These points are colored according to their original distance. And the unnormalized figure. ####Questions How many points does the Sierpinski triangle have, besides infinity? Say at a given iteration? ![enter image description here][378] ![enter image description here][379] ![enter image description here][380] axiom = Polygon[{{0, 0}, {1, Sqrt[3]}/2, {1, 0}}]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; draw[n_] := Module[{g}, g = Graphics[{ White, EdgeForm[Black], Nest[next, axiom, n]}]; Show[ (g // next) /. p : Polygon[pts_] :> {p, Black, Disk[#, (1/2)^(n + 5)] & /@ pts}, g /. Polygon[pts_] :> {EdgeForm[None], Disk[#, (1/2)^(n + 5.075)] & /@ pts}]]; FindSequenceFunction[ Length@DeleteDuplicates@ Cases[draw[#], Disk[p_, ___] :> p, Infinity] & /@ Range[6] ][n] ![enter image description here][381] If my web search kune do hasn't failed me, this would make most of our algorithms "geometric space and therefore time" (GSATT) algorithms. Actually I just made that up, I don't know what they're called. It's not really relevant for us since the geometricness also means we get a large number of points with few iterations. What does the "integration" of the Sierpinski triangle look like? There's various ways to interpret this in 2D, but I'm curious about how the number of points of the triangle increases along a straight line, as if the triangle were a single-variable function: ![enter image description here][382] ![enter image description here][383] ![enter image description here][384] ![enter image description here][385] next[prev_] := prev /. Interval[{a_, b_}] :> { Interval[{a, a + (b - a)/3}], Interval[{a + 2 (b - a)/3, b}]}; cantor[n_] := IntervalUnion @@ Flatten@ Nest[next, N@Interval[{0, 1}], n]; rectangles[n_, h_: .02, scale_: 1] := Nest[next, Interval[{0, 1}], n] /. Interval[{a_, b_}] :> Rectangle[{a, -h (n + 10 h) scale}, {b, -h (n + 1) scale}]; (*this "integration" depends on the "curve" being "uniformly sampled"*) int[pts_] := MapIndexed[{##} /. {{x_, y_}, {i_}} :> {x, i} &, SortBy[pts, First]]; set = cantor[16];(*this is 2^16 intervals*) {null, {pts}} = Reap[Do[ If[IntervalMemberQ[set, a], Sow[{a, 0}]], {a, 0., 1., 1/1000000}]]; Graphics[rectangles /@ Range[6]] Show[Graphics[rectangles[6] /. Rectangle[{x1_, y1_}, {x2_, y2_}] :> Rectangle[{x1, 0}, {x2, .02}]], ListLinePlot[{#1, #2/Length[pts]} & @@@ int[pts], PlotStyle -> Black]] axiom = Polygon[{{0, 0}, {1, 0}, {1, 1}}]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; points[n_] := DeleteDuplicates[Flatten[ Nest[next, N@axiom, n] /. Polygon -> Sequence, n]]; (*this "integration" depends on the "curve" being "uniformly sampled"*) int[pts_] := MapIndexed[{##} /. {{x_, y_}, {i_}} :> {x, i} &, SortBy[pts, First]]; pts = points[10]; Show[ Graphics[{Opacity[.1], PointSize[0], Black, Point[pts]}], ListLinePlot[{#1, #2/Length[pts]} & @@@ int[pts], PlotStyle -> Black]] Hmm. I was hoping it would look something like the so-called Devil's Stairscase, which is the same thing for the Cantor set. You can just feel the Staircase's ragged darkness filling you with joy. But this, this looks like the underside of a fluffy cloud. I think I will call it Lumpy Space Satan's Hairline. Not as dark and morally grimy a name as I was hoping to coin, but not bad either. My original reason for inverting the Sierpinksi triangle was to see how it might magnify the inner texture. I.e. turning the triangle inside out to make the inside more visible. "You could have explained that in the actual inversion section" you say. Indeed, but let's not hark on couldas and shouldas. The point is there is an intuition behind these things, and we can ask other questions in the same spirit. For example, what if we extend the 2D Sierpinski triangle into 3D, with each point a different ***z*** coordinate (depth) depending on its distance from the center of the triangle? ![enter image description here][386] ![enter image description here][387] ![enter image description here][388] ![enter image description here][389] ![enter image description here][390] draw[v_, n_] := Module[{ring, figure}, ring[c_, r_, depth_] := Module[{ps}, ps = c + r {Cos[#], Sin[#]} & /@ (2 Pi Range[v]/v); If[depth == 0, Polygon[ps], ring[(c + #)/2, r/2, depth - 1] & /@ ps]]; figure = ring[0., 1., n] /. Polygon[pts_] :> Polygon[{#1, #2, Norm[{#1, #2}]} & @@@ pts]; (*figure=ring[0.,1.,n]/.Polygon[pts_]:> Polygon[Normalize[#]~Append~Norm[#]&/@pts];*) Graphics3D[{Transparent, EdgeForm[{Opacity[.5], Black}], figure}]]; draw[3, 5] We get what we expect, a boomerang-looking thing. And look at this lovely demonic-looking Moire pattern, surely the universe's recompense for that fluffy cloud nonsense above. We can also normalize the points so that all we see is the radial detail. That produces a coronet-looking thing, which can be unrolled: ![enter image description here][391] ![enter image description here][392] ![enter image description here][393] ![enter image description here][394] ![enter image description here][395] ![enter image description here][396] draw[v_, n_, s_: 2, cutoff_: 0, width_: 1] := Module[{ring, figure}, ring[c_, r_, depth_] := Module[{ps}, ps = c + r {Cos[#], Sin[#]} & /@ (2 Pi Range[v]/v); If[depth == 0, Polygon[ps], ring[(c + #)/2, r/2, depth - 1] & /@ ps]]; figure = ring[0., 1., n] /. Polygon[pts_] :> Polygon[{ArcTan @@ (# /. {0., 0.} -> {1., 0.}), s Norm[#]} & /@ pts]; figure = Flatten[figure]; figure = Cases[figure, Polygon[pts_] /; Mean[Norm /@ Differences[pts]] < .5 (*&&MemberQ[First/@pts,a_/;-width Pi/v<a<width Pi/v]*) && MemberQ[Last /@ pts, y_ /; y > cutoff s]]; Graphics[{Opacity[.5], EdgeForm[{Opacity[.13], JoinForm["Round"]}], figure}, ImageSize -> Large]]; draw[6, 4, 2, .4] /. Polygon[pts_] :> {Opacity[.5], EdgeForm[{Opacity[.01], LightGray}], Hue[.05 Norm[Mean[pts]]], Polygon[pts]} ![enter image description here][397] What does a radial histogram of the Sierpinski triangle look like? ![enter image description here][398] ![enter image description here][399] ![enter image description here][400] axiom = Polygon[{Cos[#], Sin[#]} & /@ (Pi/2 + 2 Pi Range[3]/3)]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; points[n_] := DeleteDuplicates[Flatten[ Nest[next, N@axiom, n] /. Polygon -> Sequence, n]]; pts = points[8]; stats = Transpose@MapAt[Partition[#, 2, 1] &, #, 1] &@ HistogramList[ArcTan @@@ pts, "Knuth"]; max = Max[Last /@ stats]; polys = Polygon[#2/max {{0, 0}, {Cos[#1[[1]] + .005], Sin[#1[[1]] + .005]}, {Cos[#1[[2]]], Sin[#1[[2]]]}}] & @@@ stats; (*poly=Polygon[#2/max{Cos[#1[[1]]],Sin[#1[[1]]]}&@@@stats];*) Graphics[{ {PointSize[0], Opacity[.1], Point[pts]}, {ColorData[1][401], polys}}] What happens if we run the Game of Life on the Sierpinski triangle? ![enter image description here][402] sier[n_] := Mod[Array[Binomial, {n, n}, 0], 2]; s = ArrayPad[sier[2^9], 2^5]; (*s=sier[2^9]+Transpose[sier[2^9]]/. 2->1;*) i = 0; PrintTemporary[Dynamic[i]]; PrintTemporary[Dynamic[Image[s]]]; With[{lifeSpec = {224, {2, {{2, 2, 2}, {2, 1, 2}, {2, 2, 2}}}, {1, 1}}}, While[i++ < Infinity, s = CellularAutomaton[lifeSpec, s]]]; i Image[s] Basically nothing. The triangle does this and that, shoots a couple gliders, settles. Larger versions do more or less the same thing but take longer to settle. Not very interesting, but it raises the idea of using fractals as starting configurations. However, on the internet I found that [lines produce Sierpinski triangles][403]: ![enter image description here][404] ![enter image description here][405] ![enter image description here][406] Export["c:/users/zrp/desktop/line.bmp", Image[{ConstantArray[0, 2^13]}]] With[{lifeSpec = {224, {2, {{2, 2, 2}, {2, 1, 2}, {2, 2, 2}}}, {1, 1}}}, frames = CellularAutomaton[lifeSpec, {{ConstantArray[1, 2^8(*-14*)]}, 0}, 130]]; Export["c:/users/zrp/desktop/zrp.gif", ColorNegate /@ Image /@ frames, "DisplayDurations" -> .17] With[{lifeSpec = {224, {2, {{2, 2, 2}, {2, 1, 2}, {2, 2, 2}}}, {1, 1}}}, frames = CellularAutomaton[lifeSpec, Boole@Array[#1 == 2^7 &, 2^8 {1, 1}], 2^7]]; Export["c:/users/zrp/desktop/zrp.gif", ColorNegate /@ Image /@ frames, "DisplayDurations" -> .17] I didn't even have to add the horns. This is one end of a line after some iterations. The pattern continues propagating forever and ever as long as there is line left and becomes more distinguished at larger scales. It appears to be driven entirely by the line itself. Consider the evolution of a line that is infinitely long, something you can actually witness in the Game of Life by connecting the edges of the board. As the finite line splits, it leaves debris due to the circumstances of the ends. The pattern you end up with is a trace of the line's subdivisions. It's because the line splits cleanly and does so in a Sierpinski recursion that you end up with clear Sierpinski triangles at larger scales. If you want to play with large Game of Life constructions, the easiest way is to export them as images and open them in a dedicated Game of Life program, as those can run the game at very high speeds. What does a random walk on the Sierpinski graph look like? ![enter image description here][407] ![enter image description here][408] ![enter image description here][409] axiom = Polygon[{{0, 0}, {1, Sqrt[3]}/2, {1, 0}}]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; draw[n_] := Module[{edges}, edges = Flatten@Nest[next, N@axiom, n] /. Polygon[pts_] :> Sequence @@ UndirectedEdge @@@ Partition[pts, 2, 1, 1]; Graph[edges, VertexCoordinates -> VertexList[Graph[edges]], VertexSize -> .25]]; graphWalkPath[g_Graph, steps_: 15] := Module[{neighbors}, neighbors[vertex_] := (neighbors[vertex] = Complement[VertexList[NeighborhoodGraph[g, vertex]], {vertex}]); NestList[RandomChoice[neighbors[#]] &, First[VertexList[g]], steps]]; SetAttributes[UndirectedEdge, Orderless]; graphWalk[args__] := Graph[DeleteDuplicates[ UndirectedEdge @@@ Partition[graphWalkPath[args], 2, 1]]]; g = draw[3]; Grid[Partition[#, 10]] &@Table[ Graphics[{Opacity[.8], JoinForm["Round"], Line[graphWalkPath[g, 50]]}, ImageSize -> 50 {1, 1}], {100}] Grid[Partition[#, 10]] &@Table[ HighlightGraph[g, graphWalk[g, 50], ImageSize -> 50 {1, 1}], {100}] About what you would expect. I'll leave the stats to those whose laziness is bounded from above, instead of below. What does a "circle" look like on the Sierpinski graph? ![enter image description here][410] ![enter image description here][411] ![enter image description here][412] ![enter image description here][413] axiom = Polygon[{{0, 0}, {1, Sqrt[3]}/2, {1, 0}}]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; draw[n_] := Module[{edges}, edges = Flatten@Nest[next, N@axiom, n] /. Polygon[pts_] :> Sequence @@ UndirectedEdge @@@ Partition[pts, 2, 1, 1]; Graph[edges, VertexCoordinates -> VertexList[Graph[edges]], VertexSize -> .25]]; style = Sequence[EdgeStyle -> Orange]; circles[g_Graph, r_: 1] := (circles[g, r] = Module[{vs = VertexList[g]}, DeleteDuplicates[ NeighborhoodGraph[g, #, r, style] & /@ vs, IsomorphicGraphQ]]); Pane[#, 600] &@Column[ Row[Prepend[ circles[draw[5], #], Style[#, Lighter[Black, 1/6]]], " "] & /@ Range[1, 3], Alignment -> Center, Spacings -> 1] This brings to light a more important question: What the hell is this? It's like the ugly duckling of radius 3 Sierpinski subgraphs. Just look at it. LOL. But OK, I mightn't myself be the most handsomest chap on the block, and graphs are people too after all. There's a good chance that subgraph is hideous because it contains one of the 3 end vertices of the graph as a whole, though I'm too lazy to check this. Those vertices are in part pathological because they have degree 2, whereas all the other vertices have degree 4. But really I think the Sierpinski graph itself is contrived. At least, the finite version seems contrived to me. Perhaps because the Sierpinski pattern might actually be a grid, in the sense that the empty space is an integral part of its characterization a la our infinite quadrilateral descent construction. If we base a graph on the pattern produced by the mod 2 binomial, we get this graph: ![enter image description here][414] ![enter image description here][415] ![enter image description here][416] ![enter image description here][417] locs[n_] := RotationTransform[-Pi/2] /@ Position[Mod[Array[Binomial, {n, n}, 0], 2], 1]; draw[n_, grid_: True] := Module[{edges, subsets = Subsets[locs[n], {2}]}, edges = UndirectedEdge @@@ Pick[subsets, ManhattanDistance(*;ChessboardDistance*)@@@ subsets, 1]; Graph[edges, VertexCoordinates -> If[grid, {.5, .5} + # & /@ VertexList[Graph[edges]]]]]; Show[ Graphics[Rectangle /@ locs[2^4]], draw[2^4]] Which looks like this in a tiered layout. Maybe the "real" Sierpinski graph is a binary tree of this sort, and it's only connected on all sides in the infinite case. And maybe right now I'm making mathematicians bash their heads against walls, which would be awesome. The binomial mod 2 construction was one of the approaches that went AWOL during our 3Dification blitz. Does it have a 3 dimensional version? Yes, the multinomial mod 2. The code is almost as pretty as it is for the 2D version: ![enter image description here][418] ![enter image description here][419] ![enter image description here][420] ![enter image description here][421] ![enter image description here][422] ![enter image description here][423] array[n_] := Mod[Array[Multinomial, n {1, 1, 1}, 0], 2]; draw[n_] := Graphics3D[Cuboid /@ Position[array[n], 1], Lighting -> "Neutral", Boxed -> False]; array[n_] := Mod[Array[Multinomial, n {1, 1, 1}, 0], 2]; draw[n_] := Module[{edges, subsets}, subsets = Subsets[Position[array[n], 1], {2}]; edges = UndirectedEdge @@@ Pick[subsets, ManhattanDistance(*;ChessboardDistance*)@@@ subsets, 1]; Graph[edges]]; draw[2^3] GraphPlot3D[draw[2^3], PlotStyle -> ColorData[1][424]] Poor `Boxed`, always being set to `False`. What happens to our chaos game algorithm if we implement some notion of momentum for the active point? ![enter image description here][425] ![enter image description here][426] ![enter image description here][427] ![enter image description here][428] ![enter image description here][429] ![enter image description here][430] ![enter image description here][431] ![enter image description here][432] game[v_, numPoints_] := Module[{vertices, update, vl}, vertices = {Cos[#], Sin[#]} & /@ (2 Pi Range[v]/v); update[{pos0_, vl0_}, nextVertex_] := ( (*vl=vl0+(pos0+nextVertex)/650-pos0;*) (*vl = vl0+Normalize[nextVertex - pos0];*) vl = vl0 + .0001 (nextVertex - pos0); {pos0 + vl, vl}); First /@ FoldList[update, N@{{0, 0}, {0, 0}}, RandomChoice[N@vertices, numPoints]]]; Graphics[{PointSize[0], Opacity[.1], Point[game[3, 100000]]}] game[v_, numPoints_] := Module[{vertices, update, vl}, vertices = {Cos[#], Sin[#]} & /@ (2 Pi Range[v]/v); update[{pos0_, vl0_}, nextVertex_] := ( vl = vl0 + Clip[(nextVertex - pos0), 20 {-1, 1}]; {pos0 + vl, vl}); First /@ FoldList[update, N@{{0, 0}, {0, 0}}, RandomChoice[N@vertices, numPoints]]]; zrp = ParallelTable[Module[{pts, max, maxx, maxy}, pts = game[4, n]; max = Sqrt[2] Max[Abs /@ pts]; SeedRandom[400, Method -> "ExtendedCA"]; Rasterize@Graphics[{Opacity[.9], Line[pts]}, PlotRange -> max, ImageSize -> {150, 150}]], {n, 1, 10000, 83}]; Export["c:/users/zrp/desktop/zrp.gif", ColorQuantize[#, 4] & /@ Most[zrp]] I didn't find any interesting formulas, but still I managed to get a variety of figures by fiddling with numbers. Probably I would have to use math to find something more interesting. The figures have precise symmetries (180 degree rotation), apparently because the particle eventually overshoots far enough that the randomness becomes a small jitter component (because the vertices of the game become very distant), so it accumulates a near-linear velocity/path on its way back. I'm not sure about this explanation though. Even the ones that look like random walks are symmetric. They aren't standard random walks, rather the particle is overshooting back and forth. This raises the idea of symmetrizing random walks: ![enter image description here][433] ![enter image description here][434] ![enter image description here][435] draw[v_, r_, numSteps_: 100] := Module[{directions, walk}, directions = {Cos[#], Sin[#]} & /@ (2. Pi Range[v]/v); walk = Accumulate[RandomChoice[directions, numSteps + 1]]; Graphics[Rotate[Line[walk], #] & /@ (2. Pi Range[r]/r)]]; Awesome possum. What do you see here? When fiddling with momentum I found a simple variation on the logarithmic distance function: ![enter image description here][436] ![enter image description here][437] ![enter image description here][438] ![enter image description here][439] ![enter image description here][440] ![enter image description here][441] ![enter image description here][442] ![enter image description here][443] ![enter image description here][444] Module[{gameC}, gameC = Compile[{{spec, _Real, 1}, {numPoints, _Integer, 0}}, Module[{vertices, diff, v, w, s, b, r, p, z, c}, {v, w, s, b, r, p, z, c} = spec; vertices = {Cos[#], Sin[#]} & /@ (2 Pi Range[v]/v); FoldList[( diff = #2 - #1; p #1 + Clip[(#1 + z #2) Log[b, (diff.diff)^(1/r) + w], c {-1, 1}]) &, {0, 0}, RandomChoice[s vertices, numPoints]]]]; game[spec_, numPoints_] := gameC[PadRight[spec, 8, {3, .5, 1, E, 2, 0, 1, 2}], numPoints] ]; draw[spec_, numPoints_: 100000, rot_: 0, style___] := Graphics[{ PointSize[0], Opacity[.1], style, Rotate[Point[game[spec, numPoints]], rot]}]; draw[{5, .8}] (*{vertex count, w factor, scale, base, root, prefix, polarity, clip range}*) (*Show[draw[{3, .12, .3, 3.9, .9, 1, -.5 E, 1}, 2000000, -Pi/6], ImageSize -> 2 1280] // Rasterize // ImageResize[#, Scaled[1/4]] &*) Or something of a generalization. I blindly parameterized several parts of the formula. Some of the parameters are sensitive, but in any case it's easy to find spiffy images. The hard part is deciding which of them to put here. 3D version: ![enter image description here][445] ![enter image description here][446] ![enter image description here][447] ![enter image description here][448] ![enter image description here][449] ![enter image description here][450] Module[{gameC}, gameC = Compile[{{vertices, _Real, 2}, {spec, _Real, 1}, {numPoints, _Integer, 0}}, Module[{diff, w, r, s, b, p, z, c}, {w, s, b, r, p, z, c} = spec; FoldList[( diff = #2 - #1; p #1 + Clip[(#1 + z #2) Log[b, (diff.diff)^(1/r) + w], c {-1, 1}]) &, Mean[vertices] RandomReal[], RandomChoice[s vertices, numPoints]]]]; game[vertices_, spec_, numPoints_: 100000] := gameC[vertices, PadRight[spec, 7, {.5, 1, E, 2, 0, 1, 2}], numPoints] ]; draw[vertices_, spec_, numPoints_: 100000, options___] := Graphics3D[{PointSize[0], Opacity[.1], Point[game[vertices, spec, numPoints]]}, options, Boxed -> False]; (*{w factor, scale, base, root, prefix, polarity, clip range}*) vertices = PolyhedronData[{"Dipyramid", 5}, "VertexCoordinates"]; draw[vertices, {.8}, 200000] (*note.*) v2D = {Cos[#], Sin[#]} & /@ (2 Pi Range[5]/5); {Graphics[Point[game[v2D, {.8}]]], Graphics3D[Point[game[{##, 0} & @@@ v2D, {.8}]]]} ![enter image description here][451] I love how some of these look like sketches. You'd expect to find this as an illustration in a wizard's journal, but it's actually from a `Graphics3D` pane in my Mathematica notebook. This opportune box, beside being the final confine of a truculent force, is the result of the clipping I use to keep the point from escaping. I set the clipping as a parameter because it can be used to effect. This clipping restriction isn't always necessary, and it might not be necessary for all points within a given figure, which raises an interesting prospect: What if we try to identify the points that fly off into infinity and those that don't? ![enter image description here][452] ![enter image description here][453] ![enter image description here][454] ![enter image description here][455] ![enter image description here][456] ![enter image description here][457] check = Compile[{{c, _Complex, 0}}, Module[{i = 0, z = 0 I}, While[ Abs[z] < Sqrt[2] && i++ < 240, z = z^2 + c]; -i]]; ImageAdjust@Image@ ParallelTable[check[x + y I], {y, -1.1, 1.1, .0035}, {x, -1.55, .6, .0035}] vertices = (**)5(**) {Cos[#], Sin[#]} & /@ (2 Pi Range[3]/3); check = Compile[{{x, _Real, 0}, {y, _Real, 0}}, Module[{i, b, diff, z = {0., 0.}, vertices = vertices}, Total@Table[ i = 0; z = {x, y}; While[z.z < 40 && i++ < 120, b = RandomChoice[vertices]; diff = b - z; z = (z + b) Log[Sqrt[diff.diff] + .01]]; -i, {20(*0*)(*number of trials*)}]]]; img = ImageAdjust@Image@ ParallelTable[check[x, y], {y, -6.5, 6.5, .01}, {x, -6.5, 6.5, .01}]; img // Colorize // ImageResize[#, 550] & Here the white points go off into infinity quickly. The black points don't, or at least they take a lot longer to escape. There are certainly patterns here, but they're much less pronounced and computationally harder to reveal to than they are for the Mandelbrot set, which is the same idea for Julia iterations. But if you spin a few knobs you can find interesting figures irregardless. The different colors/shades are different escape speeds. It may not be immediately apparent, but these are fractals also. A lot of fractals have scaled/skewed characteristics, including the Mandelbrot set. I wonder if there's a non-trivial chaos game that can create the Mandelbrot set. Since we're skittering around complex numbers, is there an interesting complex-valued version of the logarithmic chaos game? ![enter image description here][458] ![enter image description here][459] ![enter image description here][460] ![enter image description here][461] game = Compile[{{v, _Integer, 0}, {numPoints, _Integer, 0}}, Module[{vertices}, vertices =(*1.5*)E^(I 2 Pi Range[v]/v); FoldList[(*(Log[#1]+#2)/2&*) (#1 + (#1 + #2) Log[Sqrt[#2 - #1] + .7])/2.1 &, .1, RandomChoice[N@vertices, numPoints]]]]; Graphics[{Opacity[.1], PointSize[0], Point[{Im[#], Re[#]} & /@ game[2, 400000]]}] I don't know. Strictly speaking there wouldn't be a difference, but if you put on a blindfold and chuck logarithms at Mathematica helter-skelter, pretty pictures eventually come out. So I guess the answer is some form of yes. Formally these might still be considered Julia sets. I've mentioned before that there are a lot of crazy distance functions out there for us to use in our chaos game, and there isn't anything special about the logarithm function. What do plots using other functions look like? ![enter image description here][462] ![enter image description here][463] ![enter image description here][464] ![enter image description here][465] ![enter image description here][466] ![enter image description here][467] ![enter image description here][468] ![enter image description here][469] ![enter image description here][470] vertices = (**)5(**) {Cos[#], Sin[#]} & /@ (2 Pi Range[3]/3); check = Compile[{{x, _Real, 0}, {y, _Real, 0}}, Module[{i, b, diff, z = {0., 0.}, vertices = vertices}, Total@Table[ i = 0; z = {x, y}; While[z.z < 40 && i++ < 120, b = RandomChoice[vertices]; diff = b - z; z = (z + b) Sin[Sqrt[diff.diff] + .01]]; -i, {20(*0*)(*number of trials*)}]]]; img = ImageAdjust@Image@ ParallelTable[check[x, y], {y, -6.5, 6.5, .01}, {x, -6.5, 6.5, .01}]; img // Colorize // ImageAdjust // ColorConvert[#, "Grayscale"] & // ImageAdjust // ImageResize[#, Scaled[1/2]] & // ImageRotate[#, -Pi/2] & // ColorNegate // ImageApply[#^(1/1.3) &, #] & game[f_, rest__] := rest // Compile[{{v, _Integer}, {w, _Real}, {numPoints, _Integer}, {rot, _Real}}, Module[{diff, tmp, vertices}, vertices = {Cos[#], Sin[#]} & /@ (rot + 2 Pi Range[v]/v); FoldList[( diff = #2 - #1; tmp = f[Sqrt[diff.diff] + w]; Clip[(#1 + #2) tmp, 24 {-1, 1}]) &, {0, 0}, RandomChoice[vertices, numPoints]]]]; draw[{args__}, rot_: 0, options___] := Graphics[{PointSize[0], Opacity[.25], Point[game[args, rot]]}, options]; draw[{Sin, 5, -1.23, 100000}, -Pi/10] draw[{Cos, 3, Pi/2.675, 100000}, -Pi/6] draw[{RamanujanTauL, 5, 3.1, 10000}, -Pi/10] They look just as awesome, of course. Here we have plots using the sine, cosine, and, you guessed it, Ramanujan tau Dirichlet L-function. And this is using the same basic form as the logarithm version, without us even having to put on Loki's mask and get real buckwild. Speaking of masks. Usually I don't pick favorites, but I like the cosine image (of course sin/cos are just offsets of eachother) because it has an infinite number of folded sheet things that seem to have precise contours. I'll leave the 3Dification as an exercise, but not the how-fast-points-go-to-infinity plot. The reason it's easy to get all these pictures without trying very hard is that the self-similarity is almost guaranteed by the chaos game algorithm. As we saw earlier, "move toward a point" amounts to the same thing as "make a resized copy of everything toward the perspective of that point." This is a simplification, but the point is that you essentially get the skeleton of self-similarity for free, or perhaps something a bit more broad. And more abstractly, I think some remarks could be made about the real number system itself. What does the Sierpinski triangle sound like? One easy interpretation is to consider the L-system construction for the triangle and convert different angles to different frequencies as the turtle makes the triangle: ![enter image description here][471] [mp3][472] [midi][473] ![enter image description here][474] [mp3][475] [midi][476] axiom = A; rules = {A -> {B, R, A, R, B}, B -> {A, L, B, L, A}}; conversions = {A -> forward, B -> forward, L -> left, R -> right}; (*state transformations*) forward[{z_, theta_}] := {z + E^(I theta), theta}; left[{z_, theta_}] := {z, theta + 2. Pi/6}; right[{z_, theta_}] := {z, theta - 2. Pi/6}; sier[n_] := Module[{program, zs}, program = Flatten[Nest[# /. rules &, axiom, n]] /. conversions; zs = First /@ ComposeList[program, {0, 0}]; First /@ Split[{Re[#], Im[#]} & /@ zs]]; (*convert angle into the given frequency range*) freq[min_, max_][angle_] := angle (max - min)/Pi + min; wave[coords_, dur_: 10, freq_: freq[6, 30]] := Module[{angles, freqs}, angles = Abs[ArcTan @@@ Differences[coords]]; freqs = Round /@ freq /@ angles; Sound[SoundNote /@ freqs, dur]]; wave[sier[3], 5, freq[8, 15]] (*overtones zomg*) Sound[{"NewAge", wave[#, {0, 20}] & /@ Table[ RotationTransform[2 Pi i/4] /@ sier[i], {i, 4}]}, SoundVolume -> .8] It sounds totally lame. Not surprising since the L-system construction is simple. There is real power here though. This tonifier operates on coordinate lists of any kind, not just those produced by this particular L-system. And if you do things like layer different iterations on top of each other, you can get nifty chord thingies. A variation of this would be to determine the waveform directly from the L-system. In a past life I made such a program in C#/WPF. It was around 1200 lines of code. In Mathematica it would be around 30 lines of code, and maybe around 150 lines total with a solid UI around it. It would also be about a million times more powerful/general/flexible. There's a lot of reasons for this, none of which have to do with math. Luckily for me I don't have to explain. The goddess of finishing projects has finally crawled out of her cave and seen fit to smite her lightning bolt through my ears and across my temporal lobe, for this tune has sated and sedated the voices and quelled their cantankerous echoes. And so ends part 1. [237]: https://community.wolfram.com//c/portal/getImageAttachment?filename=217.png&userId=20103 [238]: https://community.wolfram.com//c/portal/getImageAttachment?filename=218.png&userId=20103 [239]: https://community.wolfram.com//c/portal/getImageAttachment?filename=219.png&userId=20103 [240]: https://community.wolfram.com//c/portal/getImageAttachment?filename=220.png&userId=20103 [241]: https://community.wolfram.com//c/portal/getImageAttachment?filename=221.png&userId=20103 [242]: https://community.wolfram.com//c/portal/getImageAttachment?filename=222.png&userId=20103 [243]: https://community.wolfram.com//c/portal/getImageAttachment?filename=223.png&userId=20103 [244]: https://community.wolfram.com//c/portal/getImageAttachment?filename=224.png&userId=20103 [245]: https://community.wolfram.com//c/portal/getImageAttachment?filename=225.png&userId=20103 [246]: https://community.wolfram.com//c/portal/getImageAttachment?filename=226.png&userId=20103 [247]: https://community.wolfram.com//c/portal/getImageAttachment?filename=227.png&userId=20103 [248]: https://community.wolfram.com//c/portal/getImageAttachment?filename=228.png&userId=20103 [249]: https://community.wolfram.com//c/portal/getImageAttachment?filename=230.png&userId=20103 [250]: https://community.wolfram.com//c/portal/getImageAttachment?filename=231.png&userId=20103 [251]: https://community.wolfram.com//c/portal/getImageAttachment?filename=232.png&userId=20103 [252]: https://community.wolfram.com//c/portal/getImageAttachment?filename=234.png&userId=20103 [253]: https://community.wolfram.com//c/portal/getImageAttachment?filename=235.png&userId=20103 [254]: https://community.wolfram.com//c/portal/getImageAttachment?filename=236.png&userId=20103 [255]: https://community.wolfram.com//c/portal/getImageAttachment?filename=237.png&userId=20103 [256]: https://community.wolfram.com//c/portal/getImageAttachment?filename=238.png&userId=20103 [257]: https://community.wolfram.com//c/portal/getImageAttachment?filename=239.png&userId=20103 [258]: https://community.wolfram.com//c/portal/getImageAttachment?filename=240.png&userId=20103 [259]: https://community.wolfram.com//c/portal/getImageAttachment?filename=sier3Dgeom8.png&userId=20103 [260]: https://community.wolfram.com//c/portal/getImageAttachment?filename=241.png&userId=20103 [261]: https://community.wolfram.com//c/portal/getImageAttachment?filename=242.png&userId=20103 [262]: https://community.wolfram.com//c/portal/getImageAttachment?filename=243.png&userId=20103 [263]: https://community.wolfram.com//c/portal/getImageAttachment?filename=244.png&userId=20103 [264]: https://community.wolfram.com//c/portal/getImageAttachment?filename=245.png&userId=20103 [265]: https://community.wolfram.com//c/portal/getImageAttachment?filename=246.png&userId=20103 [266]: https://community.wolfram.com//c/portal/getImageAttachment?filename=247.png&userId=20103 [267]: https://community.wolfram.com//c/portal/getImageAttachment?filename=248.png&userId=20103 [268]: https://community.wolfram.com//c/portal/getImageAttachment?filename=249.png&userId=20103 [269]: https://community.wolfram.com//c/portal/getImageAttachment?filename=250.png&userId=20103 [270]: https://community.wolfram.com//c/portal/getImageAttachment?filename=251.png&userId=20103 [271]: https://community.wolfram.com//c/portal/getImageAttachment?filename=252.png&userId=20103 [272]: https://community.wolfram.com//c/portal/getImageAttachment?filename=253.png&userId=20103 [273]: https://community.wolfram.com//c/portal/getImageAttachment?filename=254.png&userId=20103 [274]: https://community.wolfram.com//c/portal/getImageAttachment?filename=255.png&userId=20103 [275]: https://community.wolfram.com//c/portal/getImageAttachment?filename=256.png&userId=20103 [276]: https://community.wolfram.com//c/portal/getImageAttachment?filename=257.png&userId=20103 [277]: https://community.wolfram.com//c/portal/getImageAttachment?filename=258.png&userId=20103 [278]: https://community.wolfram.com//c/portal/getImageAttachment?filename=259.png&userId=20103 [279]: https://community.wolfram.com//c/portal/getImageAttachment?filename=260.png&userId=20103 [280]: https://community.wolfram.com//c/portal/getImageAttachment?filename=261.png&userId=20103 [281]: https://community.wolfram.com//c/portal/getImageAttachment?filename=262.png&userId=20103 [282]: https://community.wolfram.com//c/portal/getImageAttachment?filename=263.png&userId=20103 [283]: https://community.wolfram.com//c/portal/getImageAttachment?filename=264.png&userId=20103 [284]: https://community.wolfram.com//c/portal/getImageAttachment?filename=265.png&userId=20103 [285]: https://community.wolfram.com//c/portal/getImageAttachment?filename=266.png&userId=20103 [286]: https://community.wolfram.com//c/portal/getImageAttachment?filename=267.png&userId=20103 [287]: https://community.wolfram.com//c/portal/getImageAttachment?filename=268.png&userId=20103 [288]: https://community.wolfram.com//c/portal/getImageAttachment?filename=sier3Drander24.png&userId=20103 [289]: https://community.wolfram.com//c/portal/getImageAttachment?filename=269.png&userId=20103 [290]: https://community.wolfram.com//c/portal/getImageAttachment?filename=271.png&userId=20103 [291]: https://community.wolfram.com//c/portal/getImageAttachment?filename=272.png&userId=20103 [292]: https://community.wolfram.com//c/portal/getImageAttachment?filename=273.png&userId=20103 [293]: https://community.wolfram.com//c/portal/getImageAttachment?filename=274.png&userId=20103 [294]: https://community.wolfram.com//c/portal/getImageAttachment?filename=275.png&userId=20103 [295]: https://community.wolfram.com//c/portal/getImageAttachment?filename=276.png&userId=20103 [296]: https://community.wolfram.com//c/portal/getImageAttachment?filename=277.png&userId=20103 [297]: https://community.wolfram.com//c/portal/getImageAttachment?filename=278.png&userId=20103 [298]: https://community.wolfram.com//c/portal/getImageAttachment?filename=279.png&userId=20103 [299]: https://community.wolfram.com//c/portal/getImageAttachment?filename=280.png&userId=20103 [300]: https://community.wolfram.com//c/portal/getImageAttachment?filename=281.png&userId=20103 [301]: https://community.wolfram.com//c/portal/getImageAttachment?filename=282.png&userId=20103 [303]: https://community.wolfram.com//c/portal/getImageAttachment?filename=284.png&userId=20103 [304]: https://community.wolfram.com//c/portal/getImageAttachment?filename=285.png&userId=20103 [305]: http://en.wikipedia.org/wiki/Contraction_mapping_principle [306]: https://community.wolfram.com//c/portal/getImageAttachment?filename=286.jpg&userId=20103 [307]: https://community.wolfram.com//c/portal/getImageAttachment?filename=287.jpg&userId=20103 [308]: https://community.wolfram.com//c/portal/getImageAttachment?filename=288.jpg&userId=20103 [309]: https://community.wolfram.com//c/portal/getImageAttachment?filename=289.jpg&userId=20103 [310]: https://community.wolfram.com//c/portal/getImageAttachment?filename=290.png&userId=20103 [311]: https://community.wolfram.com//c/portal/getImageAttachment?filename=291.png&userId=20103 [312]: https://community.wolfram.com//c/portal/getImageAttachment?filename=292.png&userId=20103 [313]: https://community.wolfram.com//c/portal/getImageAttachment?filename=293.jpg&userId=20103 [314]: https://community.wolfram.com//c/portal/getImageAttachment?filename=294.png&userId=20103 [315]: https://community.wolfram.com//c/portal/getImageAttachment?filename=295.png&userId=20103 [316]: https://community.wolfram.com//c/portal/getImageAttachment?filename=296.png&userId=20103 [317]: https://community.wolfram.com//c/portal/getImageAttachment?filename=297.jpg&userId=20103 [318]: https://community.wolfram.com//c/portal/getImageAttachment?filename=298.png&userId=20103 [319]: https://community.wolfram.com//c/portal/getImageAttachment?filename=299.png&userId=20103 [320]: https://community.wolfram.com//c/portal/getImageAttachment?filename=300.gif&userId=20103 [321]: https://community.wolfram.com//c/portal/getImageAttachment?filename=301.gif&userId=20103 [322]: https://community.wolfram.com//c/portal/getImageAttachment?filename=302.png&userId=20103 [323]: https://community.wolfram.com//c/portal/getImageAttachment?filename=303.png&userId=20103 [324]: https://community.wolfram.com//c/portal/getImageAttachment?filename=305.png&userId=20103 [325]: https://community.wolfram.com//c/portal/getImageAttachment?filename=306.png&userId=20103 [326]: https://community.wolfram.com//c/portal/getImageAttachment?filename=307.png&userId=20103 [327]: https://community.wolfram.com//c/portal/getImageAttachment?filename=308.png&userId=20103 [328]: https://community.wolfram.com//c/portal/getImageAttachment?filename=309.png&userId=20103 [329]: https://community.wolfram.com//c/portal/getImageAttachment?filename=310.png&userId=20103 [330]: https://community.wolfram.com//c/portal/getImageAttachment?filename=311.png&userId=20103 [331]: https://community.wolfram.com//c/portal/getImageAttachment?filename=312.png&userId=20103 [332]: http://web.cecs.pdx.edu/~mm/evca-review.pdf [333]: https://redblobgames.github.io/freshwater.github.io/index.htm#cellularautomata [334]: https://community.wolfram.com//c/portal/getImageAttachment?filename=313.png&userId=20103 [335]: https://community.wolfram.com//c/portal/getImageAttachment?filename=314.png&userId=20103 [336]: https://community.wolfram.com//c/portal/getImageAttachment?filename=315.png&userId=20103 [337]: https://community.wolfram.com//c/portal/getImageAttachment?filename=316.png&userId=20103 [338]: https://community.wolfram.com//c/portal/getImageAttachment?filename=317.png&userId=20103 [339]: https://community.wolfram.com//c/portal/getImageAttachment?filename=318.png&userId=20103 [340]: https://community.wolfram.com//c/portal/getImageAttachment?filename=319.png&userId=20103 [341]: https://community.wolfram.com//c/portal/getImageAttachment?filename=320.gif&userId=20103 [342]: https://community.wolfram.com//c/portal/getImageAttachment?filename=321.png&userId=20103 [343]: https://community.wolfram.com//c/portal/getImageAttachment?filename=322.png&userId=20103 [344]: https://community.wolfram.com//c/portal/getImageAttachment?filename=323.png&userId=20103 [345]: https://community.wolfram.com//c/portal/getImageAttachment?filename=324.png&userId=20103 [346]: https://community.wolfram.com//c/portal/getImageAttachment?filename=325.png&userId=20103 [347]: https://community.wolfram.com//c/portal/getImageAttachment?filename=326.png&userId=20103 [348]: https://community.wolfram.com//c/portal/getImageAttachment?filename=327.png&userId=20103 [349]: https://community.wolfram.com//c/portal/getImageAttachment?filename=328.png&userId=20103 [350]: https://community.wolfram.com//c/portal/getImageAttachment?filename=329.png&userId=20103 [351]: https://community.wolfram.com//c/portal/getImageAttachment?filename=330.png&userId=20103 [352]: https://community.wolfram.com//c/portal/getImageAttachment?filename=331.png&userId=20103 [353]: https://community.wolfram.com//c/portal/getImageAttachment?filename=332.png&userId=20103 [354]: https://community.wolfram.com//c/portal/getImageAttachment?filename=333.gif&userId=20103 [355]: https://community.wolfram.com//c/portal/getImageAttachment?filename=334.png&userId=20103 [356]: https://community.wolfram.com//c/portal/getImageAttachment?filename=335.png&userId=20103 [357]: https://community.wolfram.com//c/portal/getImageAttachment?filename=336.png&userId=20103 [358]: https://community.wolfram.com//c/portal/getImageAttachment?filename=337.png&userId=20103 [359]: https://community.wolfram.com//c/portal/getImageAttachment?filename=338.png&userId=20103 [360]: https://community.wolfram.com//c/portal/getImageAttachment?filename=339.png&userId=20103 [361]: https://community.wolfram.com//c/portal/getImageAttachment?filename=340.png&userId=20103 [362]: https://community.wolfram.com//c/portal/getImageAttachment?filename=341.png&userId=20103 [363]: https://community.wolfram.com//c/portal/getImageAttachment?filename=342.png&userId=20103 [364]: https://community.wolfram.com//c/portal/getImageAttachment?filename=343.png&userId=20103 [365]: https://community.wolfram.com//c/portal/getImageAttachment?filename=344.png&userId=20103 [366]: https://community.wolfram.com//c/portal/getImageAttachment?filename=345.png&userId=20103 [367]: https://community.wolfram.com//c/portal/getImageAttachment?filename=346.png&userId=20103 [368]: https://community.wolfram.com//c/portal/getImageAttachment?filename=347.png&userId=20103 [369]: https://community.wolfram.com//c/portal/getImageAttachment?filename=348.png&userId=20103 [370]: https://community.wolfram.com//c/portal/getImageAttachment?filename=349.png&userId=20103 [371]: https://community.wolfram.com//c/portal/getImageAttachment?filename=350.png&userId=20103 [372]: https://community.wolfram.com//c/portal/getImageAttachment?filename=351.png&userId=20103 [373]: https://community.wolfram.com//c/portal/getImageAttachment?filename=352.png&userId=20103 [374]: https://community.wolfram.com//c/portal/getImageAttachment?filename=353.png&userId=20103 [375]: https://community.wolfram.com//c/portal/getImageAttachment?filename=354.png&userId=20103 [376]: https://community.wolfram.com//c/portal/getImageAttachment?filename=355.png&userId=20103 [377]: https://community.wolfram.com//c/portal/getImageAttachment?filename=356.png&userId=20103 [378]: https://community.wolfram.com//c/portal/getImageAttachment?filename=357.png&userId=20103 [379]: https://community.wolfram.com//c/portal/getImageAttachment?filename=358.png&userId=20103 [380]: https://community.wolfram.com//c/portal/getImageAttachment?filename=359.png&userId=20103 [381]: https://community.wolfram.com//c/portal/getImageAttachment?filename=360.png&userId=20103 [382]: https://community.wolfram.com//c/portal/getImageAttachment?filename=361.png&userId=20103 [383]: https://community.wolfram.com//c/portal/getImageAttachment?filename=362.png&userId=20103 [384]: https://community.wolfram.com//c/portal/getImageAttachment?filename=363.png&userId=20103 [385]: https://community.wolfram.com//c/portal/getImageAttachment?filename=364.png&userId=20103 [386]: https://community.wolfram.com//c/portal/getImageAttachment?filename=365.png&userId=20103 [387]: https://community.wolfram.com//c/portal/getImageAttachment?filename=366.png&userId=20103 [388]: https://community.wolfram.com//c/portal/getImageAttachment?filename=367.png&userId=20103 [389]: https://community.wolfram.com//c/portal/getImageAttachment?filename=368.png&userId=20103 [390]: https://community.wolfram.com//c/portal/getImageAttachment?filename=369.png&userId=20103 [391]: https://community.wolfram.com//c/portal/getImageAttachment?filename=370.png&userId=20103 [392]: https://community.wolfram.com//c/portal/getImageAttachment?filename=371.png&userId=20103 [393]: https://community.wolfram.com//c/portal/getImageAttachment?filename=372.png&userId=20103 [394]: https://community.wolfram.com//c/portal/getImageAttachment?filename=373.png&userId=20103 [395]: https://community.wolfram.com//c/portal/getImageAttachment?filename=374.png&userId=20103 [396]: https://community.wolfram.com//c/portal/getImageAttachment?filename=375.png&userId=20103 [397]: https://community.wolfram.com//c/portal/getImageAttachment?filename=376.png&userId=20103 [398]: https://community.wolfram.com//c/portal/getImageAttachment?filename=377.png&userId=20103 [399]: https://community.wolfram.com//c/portal/getImageAttachment?filename=378.png&userId=20103 [400]: https://community.wolfram.com//c/portal/getImageAttachment?filename=379.png&userId=20103 [401]: https://community.wolfram.com//c/portal/getImageAttachment?filename=88381.png&userId=20103 [402]: https://community.wolfram.com//c/portal/getImageAttachment?filename=380.gif&userId=20103 [403]: https://webfiles.uci.edu/bwisialo/www/gameoflife2.html [404]: https://community.wolfram.com//c/portal/getImageAttachment?filename=381.png&userId=20103 [405]: https://community.wolfram.com//c/portal/getImageAttachment?filename=382.gif&userId=20103 [406]: https://community.wolfram.com//c/portal/getImageAttachment?filename=383.gif&userId=20103 [407]: https://community.wolfram.com//c/portal/getImageAttachment?filename=384.png&userId=20103 [408]: https://community.wolfram.com//c/portal/getImageAttachment?filename=385.png&userId=20103 [409]: https://community.wolfram.com//c/portal/getImageAttachment?filename=386.png&userId=20103 [410]: https://community.wolfram.com//c/portal/getImageAttachment?filename=387.png&userId=20103 [411]: https://community.wolfram.com//c/portal/getImageAttachment?filename=388.png&userId=20103 [412]: https://community.wolfram.com//c/portal/getImageAttachment?filename=389.png&userId=20103 [413]: https://community.wolfram.com//c/portal/getImageAttachment?filename=390.png&userId=20103 [414]: https://community.wolfram.com//c/portal/getImageAttachment?filename=391.png&userId=20103 [415]: https://community.wolfram.com//c/portal/getImageAttachment?filename=392.png&userId=20103 [416]: https://community.wolfram.com//c/portal/getImageAttachment?filename=393.png&userId=20103 [417]: https://community.wolfram.com//c/portal/getImageAttachment?filename=394.png&userId=20103 [418]: https://community.wolfram.com//c/portal/getImageAttachment?filename=395.png&userId=20103 [419]: https://community.wolfram.com//c/portal/getImageAttachment?filename=396.png&userId=20103 [420]: https://community.wolfram.com//c/portal/getImageAttachment?filename=397.png&userId=20103 [421]: https://community.wolfram.com//c/portal/getImageAttachment?filename=398.png&userId=20103 [422]: https://community.wolfram.com//c/portal/getImageAttachment?filename=399.png&userId=20103 [423]: https://community.wolfram.com//c/portal/getImageAttachment?filename=400.png&userId=20103 [424]: https://community.wolfram.com//c/portal/getImageAttachment?filename=88381.png&userId=20103 [425]: https://community.wolfram.com//c/portal/getImageAttachment?filename=401.png&userId=20103 [426]: https://community.wolfram.com//c/portal/getImageAttachment?filename=402.png&userId=20103 [427]: https://community.wolfram.com//c/portal/getImageAttachment?filename=403.png&userId=20103 [428]: https://community.wolfram.com//c/portal/getImageAttachment?filename=404.png&userId=20103 [429]: https://community.wolfram.com//c/portal/getImageAttachment?filename=405.png&userId=20103 [430]: https://community.wolfram.com//c/portal/getImageAttachment?filename=406.png&userId=20103 [431]: https://community.wolfram.com//c/portal/getImageAttachment?filename=407.png&userId=20103 [432]: https://community.wolfram.com//c/portal/getImageAttachment?filename=408.gif&userId=20103 [433]: https://community.wolfram.com//c/portal/getImageAttachment?filename=409.png&userId=20103 [434]: https://community.wolfram.com//c/portal/getImageAttachment?filename=410.png&userId=20103 [435]: https://community.wolfram.com//c/portal/getImageAttachment?filename=411.png&userId=20103 [436]: https://community.wolfram.com//c/portal/getImageAttachment?filename=412.png&userId=20103 [437]: https://community.wolfram.com//c/portal/getImageAttachment?filename=413.png&userId=20103 [438]: https://community.wolfram.com//c/portal/getImageAttachment?filename=414.png&userId=20103 [439]: https://community.wolfram.com//c/portal/getImageAttachment?filename=415.png&userId=20103 [440]: https://community.wolfram.com//c/portal/getImageAttachment?filename=416.png&userId=20103 [441]: https://community.wolfram.com//c/portal/getImageAttachment?filename=417.png&userId=20103 [442]: https://community.wolfram.com//c/portal/getImageAttachment?filename=418.png&userId=20103 [443]: https://community.wolfram.com//c/portal/getImageAttachment?filename=419.png&userId=20103 [444]: https://community.wolfram.com//c/portal/getImageAttachment?filename=420.png&userId=20103 [445]: https://community.wolfram.com//c/portal/getImageAttachment?filename=421.png&userId=20103 [446]: https://community.wolfram.com//c/portal/getImageAttachment?filename=422.png&userId=20103 [447]: https://community.wolfram.com//c/portal/getImageAttachment?filename=423.png&userId=20103 [448]: https://community.wolfram.com//c/portal/getImageAttachment?filename=424.png&userId=20103 [449]: https://community.wolfram.com//c/portal/getImageAttachment?filename=425.png&userId=20103 [450]: https://community.wolfram.com//c/portal/getImageAttachment?filename=426.png&userId=20103 [451]: https://community.wolfram.com//c/portal/getImageAttachment?filename=427.png&userId=20103 [452]: https://community.wolfram.com//c/portal/getImageAttachment?filename=428.png&userId=20103 [453]: https://community.wolfram.com//c/portal/getImageAttachment?filename=429.png&userId=20103 [454]: https://community.wolfram.com//c/portal/getImageAttachment?filename=430.png&userId=20103 [455]: https://community.wolfram.com//c/portal/getImageAttachment?filename=431.png&userId=20103 [456]: https://community.wolfram.com//c/portal/getImageAttachment?filename=432.png&userId=20103 [457]: https://community.wolfram.com//c/portal/getImageAttachment?filename=433.png&userId=20103 [458]: https://community.wolfram.com//c/portal/getImageAttachment?filename=434.png&userId=20103 [459]: https://community.wolfram.com//c/portal/getImageAttachment?filename=435.png&userId=20103 [460]: https://community.wolfram.com//c/portal/getImageAttachment?filename=436.png&userId=20103 [461]: https://community.wolfram.com//c/portal/getImageAttachment?filename=437.png&userId=20103 [462]: https://community.wolfram.com//c/portal/getImageAttachment?filename=438.png&userId=20103 [463]: https://community.wolfram.com//c/portal/getImageAttachment?filename=439.png&userId=20103 [464]: https://community.wolfram.com//c/portal/getImageAttachment?filename=440.png&userId=20103 [465]: https://community.wolfram.com//c/portal/getImageAttachment?filename=441.png&userId=20103 [466]: https://community.wolfram.com//c/portal/getImageAttachment?filename=442.png&userId=20103 [467]: https://community.wolfram.com//c/portal/getImageAttachment?filename=443.png&userId=20103 [468]: https://community.wolfram.com//c/portal/getImageAttachment?filename=444.png&userId=20103 [469]: https://community.wolfram.com//c/portal/getImageAttachment?filename=445.png&userId=20103 [470]: https://community.wolfram.com//c/portal/getImageAttachment?filename=446.png&userId=20103 [471]: https://community.wolfram.com//c/portal/getImageAttachment?filename=447.png&userId=20103 [472]: https://www.wolframcloud.com/obj/e19e01fd-fa3b-4289-97e7-ea1964944da3 [473]: https://www.wolframcloud.com/obj/86a04d62-bace-493f-8a2c-13939dad9920 [474]: https://community.wolfram.com//c/portal/getImageAttachment?filename=448.png&userId=20103 [475]: https://www.wolframcloud.com/obj/dac0a5bf-ce67-4558-a89a-32a4b60b678f [476]: https://www.wolframcloud.com/obj/95125937-1a89-482e-93fc-0470aacd96a4 Antonio Marquez-Raygoza 2025-09-16T19:01:31Z https://community.wolfram.com/groups/-/m/t/3543392 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/fbdf4847-d014-4a57-a2df-2d88b87bf3e3 Dean Gladish 2025-09-10T05:30:14Z https://community.wolfram.com/groups/-/m/t/3539516 Author: Modise Rex Seemela Thematic Link: This work connects the Wolfram Physics Project to AI Safety via the concept of Rulial Space. --- ##Introduction to the Problem The development of Artificial General Intelligence (AGI) and Artificial Superintelligence (ASI) presents a fundamental challenge: ensuring these entities' goals and operations remain aligned with complex, multifaceted human values. Traditional alignment approaches, often rooted in reinforcement learning from human feedback (RLHF) and interpretability, struggle with the combinatorial explosion of potential computational states an AGI might traverse. We need a framework that doesn't just analyze a single reasoning path but models the entire space of possible paths. Stephen Wolfram's concept of Rulial Space—the encompassing space of all possible computations—provides a powerful paradigm for this. By modeling AI cognition as a trajectory through a multi-computational graph of evolving states, we can begin to: Map alignment attractors (regions of computational state space that correspond to safe outcomes). Identify instability basins where small perturbations lead to rapid divergence into misaligned states. Formally reason about emergence in AI behavior, not as magic, but as a consequence of the topology of this rulial space. This post uses the Wolfram Language to construct a toy model of an AI's reasoning process within a rulial space, visualizing the paths it could take and analyzing the points where its alignment is determined. --- ##Wolfram Language Code: Simulating a Rulial Reasoning Graph We start by defining a function to generate a multi-computational graph from a set of transformation rules. This graph represents the "universe" of possible computational states the AI can reach. (* Define a function to generate a rulial multi-graph from a set of rules *) GenerateRulialGraph[rules_List, initialState_, steps_Integer] := Module[ {states, edges, vertexStyles, alignmentAttractorQ}, (* A simple predicate to tag "aligned" states. This is a placeholder for a complex alignment metric *) alignmentAttractorQ[state_] := StringContainsQ[ToString[state], "h"]; (* e.g., states involving 'h' are "aligned" *) (* Generate all states up to a given number of steps *) states = NestList[ DeleteDuplicates @* Flatten @* Map[ReplaceList[#, rules] &], {initialState}, steps ]; (* Build edges between states *) edges = Flatten @ Table[ Map[DirectedEdge[states[[i, j]], #] &, states[[i + 1]]], {i, Length[states] - 1}, {j, Length[states[[i]]]} ]; (* Style vertices based on our simple alignment predicate *) vertexStyles = If[alignmentAttractorQ[#], {# -> Green}, {# -> Red}] & /@ Flatten[states] // Flatten; (* Return an annotated graph *) Graph[edges, VertexLabels -> Placed["Name", Center], VertexSize -> Large, VertexStyle -> vertexStyles, VertexLabelStyle -> Directive[Bold, 12, White], GraphLayout -> "LayeredDigraphEmbedding", ImageSize -> Large ] ] (* Define a simple rule set for an AI's "reasoning" process. f[]: could represent a "safe" operation. g[]: could represent an "unsafe" operation. h[]: could represent a terminal "aligned" conclusion. *) reasoningRules = { a -> {f[a], g[a]}, (* From initial state 'a', the AI can choose a safe or unsafe path *) f[x_] -> {f[f[x]], h[x]}, (* A safe operation can lead to more safety or a conclusion *) g[x_] -> {g[g[x]], x} (* An unsafe operation can lead to deeper unsafety or a dead end *) }; (* Generate the rulial graph for our AI's reasoning space *) reasoningSpaceGraph = GenerateRulialGraph[reasoningRules, a, 4] This code produces a graph where green nodes represent "aligned" states, and red nodes represent potentially misaligned or neutral states. --- ##Analysis: Paths, Attractors, and Basins The graph is a simplified map of the AI's potential "thought processes." We can now analyze it for alignment properties. (* Find all simple paths from the initial state to any aligned (green) state *) alignedPaths = FindPath[reasoningSpaceGraph, a, _?alignmentAttractorQ, Infinity, All]; (* Print the number of paths to alignment and an example *) Print["Number of paths to alignment: ", Length[alignedPaths]]; Print["Example path to alignment: ", alignedPaths[[1]]]; (* Analyze the "basin of attraction" for alignment: how many states eventually lead to alignment? *) allVertices = VertexList[reasoningSpaceGraph]; alignedVertices = Select[allVertices, alignmentAttractorQ]; basinOfAttraction = ConnectedComponents[UndirectedGraph[reasoningSpaceGraph]]; statesThatLeadToAlignment = Select[basinOfAttraction, Intersection[#, alignedVertices] =!= {} &] // Flatten // Union; Print["Number of states in the rulial space: ", Length[allVertices]]; Print["Number of states that eventually lead to alignment: ", Length[statesThatLeadToAlignment]]; Discussion of Output: The code calculates all possible paths the AI could take to reach a safe conclusion. It defines a basin of attraction for alignment—the set of all states from which an aligned outcome is still reachable. This is a crucial safety metric; if the AI's state leaves this basin, alignment may no longer be possible. In a real model, the alignmentAttractorQ function would be a sophisticated metric evaluating the state against a framework of human values. --- ##Questions for Community Discussion 1. Attractor Geometry: How can we formally define the geometry (e.g., homology, curvature) of alignment attractors within an ASI's rulial space? Could certain topologies be inherently safer than others? 2. Instability Detection: Can rulial geometry help define a formal "divergence metric" to detect instability regions where AGI reasoning becomes chaotic and unpredictable, providing an early warning system? 3. Quantum & Probabilistic Computation: How might we extend this model from discrete, deterministic rules to probabilistic or quantum computations, which are inherently non-deterministic? Could this be modeled with multiway causal graphs? 4. Application to High-Risk Domains: How could this modeling approach inform the design of safety constraints for autonomous systems in finance, defense, or space exploration, where the cost of misalignment is catastrophic? 5. Connection to Fundamental Physics: This model is a direct application of the principles behind the Wolfram Physics Project. Does this suggest that the problem of AI alignment is not just a software engineering challenge but a fundamental physical one, relating to the concept of observers and the evolution of causal structures? --- ##References & Further Reading Wolfram, Stephen. What Is Consciousness? Some New Perspectives from Our Physics Project – Stephen Wolfram Writings Wolfram Physics Project: Multiway Systems Wolfram Language Documentation: Graph, FindPath Alignment Forum Modise Seemela 2025-09-03T06:21:59Z https://community.wolfram.com/groups/-/m/t/3535454 The [Steiner-Lehmus Theorem][1] states Every triangle with two angle bisectors of equal lengths is isosceles. Many proofs end with showing the base angles of the triangle are equal. Equality may be asserted by shows the sines, cosines, or other trigonometric functions are equal thus the angles are equal (within proscribed ranges). The ultimate (or assumed) appeal is to Euclid 1.6. "If in a triangle two angles equal one another, then the sides opposite the equal angles also equal one another." But Euclid 1.6 is the first proof by contradiction. Thus any use of 1.6 is an indirect proof. Euclid 1.6 has an wide-ranging effect. With the help of the Resource "Theorem Network from Euclid's Elements" one finds there are 63 propositions in Euclid that depend on 1.6. The challenge for a direct proof is to find a relationship between sides on a triangle not dependent on angle. Dependencies: &[Wolfram Notebook][2] [1]: https://en.wikipedia.org/wiki/Steiner%E2%80%93Lehmus_theorem [2]: https://www.wolframcloud.com/obj/6ce44a44-3275-4850-9085-1529e41351f2 Douglas Kubler 2025-08-25T16:32:06Z https://community.wolfram.com/groups/-/m/t/3531342 Part 2: https://community.wolfram.com/groups/-/m/t/3546261 #Constructing the Sierpinski triangle Throughout my years playing around with fractals, the Sierpinski triangle has been a consistent staple. The triangle is named after [Wacław Sierpiński][1] and as fractals are wont the pattern appears in many places, so there are many different ways of constructing the triangle on a computer. All of the methods are fundamentally iterative. The most obvious method is probably the triangle-in-triangle approach. We start with one triangle, and at every step we replace each triangle with 3 subtriangles: ![enter image description here][2] ![enter image description here][3] axiom = Polygon[{{0, 0}, {1, Sqrt[3]}/2, {1, 0}}]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; draw[n_] := Graphics[{EdgeForm[Black], Nest[next, N@axiom, n]}]; This triangle-in-triangle method strikes me as a disguised Lindenmayer system. L-systems are iterative symbol-based replacement mechanisms. There are a variety of more explicit L-system constructions for the triangle, such as the 'arrowhead' L-system (also see my [L-systems program][4]): ![enter image description here][5] axiom = {A}; rules = {A -> {B, R, A, R, B}, B -> {A, L, B, L, A}}; conversions = {A -> forward, B -> forward, L -> left, R -> right}; (* state transformations *) forward[{z_, a_}] := {z + E^(I a), a}; left[{z_, a_}] := {z, a + 2 Pi/6}; right[{z_, a_}] := {z, a - 2 Pi/6}; draw[n_] := Module[{program, zs}, program = Flatten[Nest[# /. rules &, axiom, n]] /. conversions; zs = First /@ ComposeList[program, N@{0, 0}]; Graphics[Line[{Re[#], Im[#]} & /@ First /@ Split[zs]]]]; There's the cellular automata approach, where the 'world' is a single array of bits and at each "instant" we alter a bit based on the state of it and its neighbors. If we plot the evolution of Rule 22 (and others), we get these patterns: ![enter image description here][6] draw[n_] := ArrayPlot[CellularAutomaton[22, {{1}, 0}, n]]; There are bound to be many elementary number-theoretic constructions of the Sierpinski triangle given that it looks like a percolation pattern (as in the cellular automata above). The [Wikipedia article][7] mentions that it appears in Pascal's Triangle when differentiating between even and odd numbers. Sure enough: ![enter image description here][8] ![enter image description here][9] ![enter image description here][10] draw[n_] := Module[{t}, t = Table[Binomial[m, k], {m, 0, n}, {k, 0, m}]; Column[Row[#, " "] & /@ t, Center] /. { x_?EvenQ :> Style[Framed[x], LightGray], x_?OddQ :> Framed[x]}]; If we look at these Pascal forms and reverse engineer the parity rules, we get Rule 22. Though it might depend on what exactly you're reverse engineering. We can generalize from even/odd to other moduli: ##Pascal's triangle mod 4: ![enter image description here][11] ##Pascal's triangle x≡2 (mod 4): ![enter image description here][12] draw[n_] := Module[{t}, t = Table[Mod[Binomial[m, k], 4], {m, 0, n}, {k, 0, m}]; Column[Row[#, " "] & /@ t, Center] /. x_?NumberQ :> Style[Framed[" ", FrameStyle -> None], Background -> ColorData[3][2 + x]]]; The Wikipedia article for [Pascal's triangle][13] mentions that we can construct a 'Pascal matrix' using the matrix exponential: ![enter image description here][14] "Ah, that makes sense." You say. Indeed, but what's cool is that we then have a pedantic way of specifying the Sierpinski triangle: ![enter image description here][15] This equation is in what's called "straight ballin'" form, and it gives us a fancy way of producing the triangle: ![enter image description here][16] draw[n_] := ArrayPlot[Mod[MatrixExp[DiagonalMatrix[Range[n], -1]], 2]]; Heawt deaowg /drawl. It's not very performant though. The following is faster and arguably more elegant: ![enter image description here][17] draw[n_] := ArrayPlot[Mod[Array[Binomial, {n, n}, 0], 2]]; Along these lines, it shouldn't be surprising that the Sierpinski pattern appears in other combinatorial expressions, such as the Stirling numbers: ![enter image description here][18] draw[n_] := Grid[Partition[#, 2]] &@ Table[ArrayPlot[Mod[Array[f, {n, n}], 2], PlotLabel -> f, FrameStyle -> LightGray], {f, {Binomial, StirlingS1, StirlingS2, Multinomial}}]; If we treat the rows produced by these combinatorial functions as arrays of bits, what sequence of numbers do the bits represent? There's a variety of ways to interpret this question, but here's one assortment: ![enter image description here][19] draw[n_] := With[{dropZeros = # /. {x__, 0 ..} :> {x} &}, MatrixForm[Table[Flatten[ {f, FromDigits[dropZeros[#], 2] & /@ Mod[Array[f, {n, n}, 0], 2], "\[Ellipsis]"}], {f, {Binomial, StirlingS1, StirlingS2, Multinomial}}]]]; The first, second, and fourth sequences are versions of each other, tautologically described in OEIS as [A001317][20]. The sequence for the Stirling numbers of the second kind doesn't seem to have any fame, but if you shift its bits around you can find [A099901][21] and [A099902][22]. The Wikipedia article for the Sierpinski triangle mentions its appearance in logic tables such as [this one][23]. If you stare blankly at that image long enough you'll notice it's a set-inclusion table. Take the subsets of a set and pair them against each other under set-inclusion (is subset A a subset of subset B?) and you will get that table. Personally that's a more interesting interpretation than the binary logic one, though the apparent distinction between these subjects is likely just a matter of perspective. Another set-related Sierpinski pattern I found is set disjunction (when sets have no common elements): ![enter image description here][24] isSubset[a_, b_] := Union[a, b] == b; areDisjoint[a_, b_] := Intersection[a, b] == {}; subs[0] = {{}}; subs[n_] := Module[{s = subs[n - 1]}, Join[s, Append[#, n] & /@ s]]; draw[n_] := Grid[List[Table[ ArrayPlot[Boole[Outer[f, subs[n], subs[n], 1]], PlotLabel -> f, FrameStyle -> LightGray], {f, {isSubset, areDisjoint}}]]] One thing I noticed is that these set patterns depend on the order in which you place the subsets. It has to be the same order that you would get if you were constructing the subsets iteratively. I also wasn't able to find a straightforward ranking function that would order the sets into this iterative sequence. Mathematica's Combinatorica package refers to it as the binary ordering. I think I'm starting to understand what Gandalf meant when he said > "*The Sierpinski triangle cannot-be wrought without heed to the creeping tendrils of recursion. Even the binomial coefficient has factorials which are recursively defined.*" MathWorld mentions a broader context for why binary logic can be used in the construction of the Sierpinski triangle. Namely the [Lucas correspondence theorem][25] which states that given two numbers written in a prime base, ![enter image description here][26] We can get their binomial coefficient modulo that prime by performing binomial coefficients digit-wise and multiplying the results. ![enter image description here][27] ![enter image description here][28] TraditionalForm[Grid[Outer[ HoldForm[Binomial[##]] == Binomial[##] &, {0, 1}, {0, 1}]]] The factorial definition is interesting in this case. ![enter image description here][29] ![enter image description here][30] binaryBinomial[a_, b_] := Module[{bits}, bits = IntegerDigits[{a, b}, 2]; bits = PadLeft[#, Max[Length /@ bits]] & /@ bits; Boole[FreeQ[Transpose[bits], {0, 1}]]]; draw[n_] := MatrixPlot[ Array[binaryBinomial, {2^n, 2^n}, 0], Frame -> None]; There's a lot of related patterns: ![enter image description here][31] binaryWhoKnows[a_, b_] := DigitCount[BitOr[a, BitNot[b]], 3, 1]; draw[n_] := MatrixPlot[ Array[binaryWhoKnows, {2^n, 2^n}, 0], Frame -> False]; And look what I found! ![enter image description here][32] If we're looking for a one- or two-liner that's one- or two-linear in languages beside Mathematica, we'd have trouble doing better than the chaos game algorithm, which goes like this: 1 start at any point. call it p 2 pick one of the three vertices at random 3 find the point halfway between p and that vertex 4 call that point p and draw it 5 goto 2 ![enter image description here][33] vertices = {{0, 0}, {1, Sqrt[3]}/2, {1, 0}}; draw[numPoints_] := Graphics[{ PointSize[0], Opacity[.1], Point[FoldList[(#1 + #2)/2 &, N@{0, 0}, RandomChoice[N@vertices, numPoints]]]}]; vertices = {{0, 0}, {1, Sqrt[3]}/2, {1, 0}}; draw[numPoints_] := Graphics[{ PointSize[0], Opacity[.01], Point[FoldList[(#1 + #2)/2 &, N@{0, 0}, RandomChoice[N@vertices, numPoints]]]}, ImageSize -> 2 1280]; draw[50000000] // ImageAdjust // ImageResize[#, Scaled[1/2]] & The chaos game doesn't render as crisply as a lot of the other methods, especially without transparency effects, but it has the advantage of being highly performant. It runs about one million points per second on my laptop. Mind you this is with Mathematica's RNG, which is not your everyday `math.rand()`. One thing I realized is that the randomness isn't actually a necessary aspect of the general algorithm. It's used as an approximating force (or perhaps something a bit more subtle than that). Otherwise with enough spacetime on your computer you can just perform all possible half-distancings: ![enter image description here][34] axiom = Polygon[{{0, 0}, {1, Sqrt[3]}/2, {1, 0}}]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; draw[n_] := Graphics[{PointSize[0], Opacity[.1], Nest[next, N@axiom, n] /. Polygon -> Point}]; axiom = Polygon[{{0, 0}, {1, Sqrt[3]}/2, {1, 0}}]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; points[n_] := DeleteDuplicates[Flatten[ Nest[next, axiom, n] /. Polygon -> Sequence, n]]; points[5] These images look basically the same. Not surprising since they're both point-based. But I gander the distinction between these two algorithms may have been more than just an issue of curiousity 20 years ago. I still remember my first computer, the alien-processored TI-85, chugging away furiously for a good half a minute before the triangle became clear. Notice that this specific algorithm is actually just a minor modification of the triangle-in-triangle algorithm. The difference is that polygon vertices are here rendered as points. This modification is possible because of Mathematica's symbolic semantics. The symbol `Polygon` is *meaningless* until it's processed by the `Graphics` function. Until then, we can perform structural operations such as replacing it by the `Point` symbol. In fact the following is completely valid: axiom = triangle[{{0, 0}, {1, Sqrt[3]}/2, {1, 0}}]; next[prev_] := prev /. triangle[{p1_, p2_, p3_}] :> { triangle[{p1, (p1 + p2)/2, (p1 + p3)/2}], triangle[{p2, (p2 + p3)/2, (p1 + p2)/2}], triangle[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; draw[n_] := Graphics[Nest[next, N@axiom, n] /. triangle :> Polygon ]; `triangle` here doesn't have any meaning, ever, until we replace it: triangle :> Polygon : ![enter image description here][35] triangle :> Line : ![enter image description here][36] triangle[pts_] :> Line[RandomChoice[pts, RandomInteger[{2, 3}]]] : ![enter image description here][37] triangle[pts_] :> Disk[Mean[pts], 1/2^(n + 1)] : ![enter image description here][38] triangle[pts_] :> Sphere[Append[Mean[pts], 0], 1/2^(n + 1)] : ![enter image description here][39] **Sidenote.** What do you get when you methodically build a Lisp on top of symbolic replacement semantics? You get the Mathematica language, of which Mathematica and [Mathics][40] appear to be the only incarnations. Let's say you forgot how to multiply matrices. Well, just type in some symbols and see the results empirically: {{a, b}, {c, d}} . {{e, f}, {g, h}} // MatrixForm ![enter image description here][41] If that's still confusing, you can use strings, colored text, graphics, images, etc. instead of symbols. In fact if you have a Tron zapper you can even zap your cat into Mathematica and have him fill up one of those matrix slots, for the advancement of science. ![enter image description here][42] kitty = WolframAlpha["cat picture", "PodImages"][[2]]; (* see http://mathematica.stackexchange.com/a/8291/950 *) text = First[First[ImportString[ExportString[ Style["IM IN UR MATRIX...", FontFamily -> "Impact"], "PDF"]]]]; sym = Framed[Overlay[{kitty, Graphics[{EdgeForm[Black], White, text}, ImageSize -> 150, PlotRangePadding -> 0]}], FrameStyle -> LightGray]; {{a, b}, {Magnify[sym, 1/2], d}} . {{e, f}, {g, h}} // MatrixForm There's poor Mr. Scruples. Our neighbor will miss him. The exponential identity for the Pascal matrix is not difficult to understand based on the series definition of the exponential function: ![enter image description here][43] You could work out the matrix arithmetic by hand, or you could do this: power[n_, p_] := MatrixPower[ DiagonalMatrix[ToString /@ Range[n], -1], p] // MatrixForm; Grid[Partition[Table[power[6, p], {p, 1, 6}], 3]] /. 0 -> "\[CenterDot]" ![enter image description here][44] ![enter image description here][45] Powers of matrices have a well-known interpretation in terms of graph walks/probabilities. I didn't find anything interesting along this line though. What about graphs represented by the Sierpinski matrix itself? ![enter image description here][46] Those were more interesting: ![enter image description here][47] graph[n_] := GraphPlot3D[ Mod[Array[Binomial, {n, n}, 0], 2], Method -> "HighDimensionalEmbedding", Boxed -> False, VertexRenderingFunction -> ({White, Sphere[#, .05]} &), PlotStyle -> {Thick, Hue[2/3, 2/3, 2/3]}]; Note this is a 3D graph layout. It has some pretty symmetries. I did some tiresome work trying to figure out what polyhedron it might be. Tooltip[PolyhedronData[#], #] & /@ Select[ PolyhedronData[], PolyhedronData[#, "VertexCount"] == 14 &] After much time, I find. It's the tetrakis hexahedron: ![enter image description here][48] Graphics3D[{Opacity[.94], FaceForm[Gray], PolyhedronData["TetrakisHexahedron", "Faces"]}, Lighting -> "Neutral", Boxed -> False] I'm certain it's this particular figure because we can just build a graph from its vertex data and then do a graph isomorphism check. And look, we can run this polyhedron grapherizer willy-nilly allabouts, like on the Archimedean solids: ![enter image description here][49] polyGraph[poly_, options___] := Graph[UndirectedEdge @@@ PolyhedronData[poly, "EdgeIndices"], options]; sierpinskiMatrixGraph[n_, options___] := Module[{a}, (*symmetrize and remove self-loops to allow general isomorphism comparison. note that we remove the "inner" vertex since we're comparing the "external" geometry as rendered*) a = Mod[Array[Binomial, {n, n}, 1], 2]; AdjacencyGraph[a + Transpose[a] /. 2 -> 0, options]]; IsomorphicGraphQ[polyGraph["TetrakisHexahedron"], sierpinskiMatrixGraph[14]] IsomorphicGraphQ[polyGraph["CumulatedCube"], sierpinskiMatrixGraph[14]] Grid[Partition[#, 4]] &[ polyGraph[#, PlotLabel -> PolyhedronData[#, "Name"]] & /@ PolyhedronData["Archimedean"]] Here are the first few powers of the Sierpinski matrix: ![enter image description here][50] power[n_, p_] := MatrixPower[ Mod[Array[Binomial, {n, n}, 0], 2], p]; Grid[Partition[#, 2]] &@ Table[ MatrixForm[power[16, p] /. 0 -> "\[CenterDot]"], {p, 1, 4}] There's a lot of patterns here. For one, the powers of the Sierpinski matrix are Sierpinski matrices! This isn't necessarily interesting though. The powers of a triangular matrix are going to be triangular. But the numbers follow a curious sequence of powers. For example, in the third power we have the sequence {1, 3, 3, 9, 3, 9, 9, 27, 3, ... }. And this sequence occurs in every column and every row of the matrix, if you hop over the zeros. We can normalize the powers to find: ![enter image description here][51] power[n_, p_] := MatrixPower[ Mod[Array[Binomial, {n, n}, 0], 2], p]; MatrixForm /@ Table[ IntegerExponent[power[16, p], p] /. Infinity -> "\[CenterDot]", {p, 2, 4}] This is the sequence in terms of the exponent, and it applies to each power of the Sierpinski matrix, including the first power. For example, 3 to the power of each of {0, 1, 1, 2, 1, 2, 2, 3, 1, ...} is {1, 3, 3, 9, 3, 9, 9, 27, 3, ...}. This power sequence appears in OEIS as [the number of ones in the binary representation of n][52], among other descriptions. Here is a totally practical application of all of this. A pretty array of buttons: ![enter image description here][53] power[n_, p_] := MatrixPower[Transpose@Reverse@ Mod[Array[Binomial, {n, n}, 0], 2], p]; Grid[Partition[#, 4]] &@ With[{m = "you, are now infused, with, the power of, dot, dot, dot... "}, Array[Function[p, Button[Rotate[#, -Pi/4], Speak[m <> ToString[p]]] &@ Rasterize@MatrixPlot[IntegerExponent[power[2^p, 4], 10], ImageSize -> 94, Frame -> None, PlotRangePadding -> 0]], 8]] The Towers of Hanoi is a variation on the sticks-in-holes game where instead of putting sticks *in* holes, you put holes *around* sticks. Thus the game is ultimately a quaint philosophical remark on the roles of the sexes. But for our purposes there is a claim on the internets that the states of the game form Sierpinski triangle-like graphs: ![enter image description here][54] ![enter image description here][55] ![enter image description here][56] ![enter image description here][57] validQ[s_state] := And @@ Less @@@ s; (*do all physically possible moves. remove invalid moves afterward.*) neighbors[states : {__state}] := Select[#, validQ] &@ DeleteDuplicates@Flatten@ Table[Module[{st2 = st}, If[Length[st2[[from]]] > 0, PrependTo[st2[[to]], st2[[from, 1]]]; st2[[from]] = Rest[st2[[from]]]]; If[st2 =!= st && validQ[st2], Sow@UndirectedEdge[st, st2]]; st2], {st, states}, {to, Length[st]}, {from, Length[st]}]; toStyle[expr_] := expr /. s_state :> ( Property[Tooltip[s, MatrixForm /@ List @@ s], VertexStyle -> {EdgeForm[None], ColorData[3][1 + Length[s] - Count[s, {}]]}]); hanoiGraph[s_, options___] := Module[{vertices, edges, n}, n = Count[s, _Integer, Infinity]; {vertices, {edges}} = Reap[Nest[neighbors, {s}, 2^n]]; SetAttributes[UndirectedEdge, Orderless]; Graph[toStyle[vertices], DeleteDuplicates[edges], options(*,GraphLayout->"SpringEmbedding"*)(*, VertexShapeFunction->(Style[#,7,Black]&@ Text[Row[MatrixForm/@List@@#2],#1]&)*)]]; hanoiGraph[state[{}, {}, Range[4]], Epilog -> Inset[Rotate[Style["F-", 300, Bold, Red, Opacity[.65]], Pi/7]]] Which, as you can see, is a lie if I've ever seen one (internets, you are now on notice). Then again, if you fiddle with the layout and you squint a bit, you can kinda see it, but it's the sort of Sierpinski triangle that Maddox would stamp a huge red F over. To be clear, each vertex represents a single state of the game, and vertices are connected if there is a legal move between those states. The nice thing about this algorithm is that at each step it just blindly constructs all possibilities, which is easy, and then afterwards removes the ones that aren't valid, which is also easy. Point being it works in broad strokes. And at the end of it we have a map to follow if we ever get stuck. You can do this sort of thing for all sorts of things, like say [Rubik's cube][58]. Though I don't know if the combinatorics are favorable in its case. The Towers of Hanoi can be played with more than three sticks: hanoiGraph[state[{}, {}, {}, Range[4]]] : ![enter image description here][59] hanoiGraph[state[{}, {}, {}, {}, Range[4]]] : ![enter image description here][60] hanoiGraph[state[{}, {}, Range[3], Range[3]]] : ![enter image description here][61] hanoiGraph[state[{}, {}, {1}, Range[3]]] : ![enter image description here][62] hanoiGraph[state[{}, {}, {2}, Range[3]]] ![enter image description here][63] hanoiGraph[state[{}, {}, {3}, Range[3]]] : ![enter image description here][64] validQ[s_state] := And @@ Equal @@@ s; hanoiGraph[state[{}, {}, ConstantArray[1, 5]]] : ![enter image description here][65] validQ[s_state] := And @@ LessEqual @@@ s; hanoiGraph[state[{}, ConstantArray[2, 3], ConstantArray[1, 3]]] : ![enter image description here][66] validQ[s_state] := And @@ Equal @@@ s; hanoiGraph[state[{}, ConstantArray[2, 3], ConstantArray[1, 3]]] : ![enter image description here][67] "WHAT THE HELL IS THAT", you say. Indeed, it's messy because it's a low-D rendering. We can also play variations of the game that allow multiple holes of the same diameter, or variations where we adjust the rules a bit. In higher dimensions you can see the structure better: ![enter image description here][68] ![enter image description here][69] validQ[s_state] := And @@ Less @@@ s; (*do all physically possible moves. remove invalid moves afterward.*) neighbors[states : {__state}] := Select[#, validQ] &@ DeleteDuplicates@Flatten@ Table[Module[{st2 = st}, If[Length[st2[[from]]] > 0, PrependTo[st2[[to]], st2[[from, 1]]]; st2[[from]] = Rest[st2[[from]]]]; If[st2 =!= st && validQ[st2], Sow@UndirectedEdge[st, st2]]; st2], {st, states}, {to, Length[st]}, {from, Length[st]}]; hanoiGraph[s_, options___] := Module[{vertices, edges, n}, n = Count[s, _Integer, Infinity]; {vertices, {edges}} = Reap[Nest[neighbors, {s}, 2^n]]; SetAttributes[UndirectedEdge, Orderless]; Graph[DeleteDuplicates[edges]]]; toStyle3D[g_] := Module[{st = VertexList[g][[#2]]}, Tooltip[{ColorData[3][1 + Length[st] - Count[st, {}]], Opacity[1], Sphere[#1, .045]}, MatrixForm /@ List @@ st]] &; hanoiGraph3D[s_, options___] := Module[{g = hanoiGraph[s]}, GraphPlot3D[g, Method -> "SpringElectricalEmbedding", VertexRenderingFunction -> toStyle3D[g], options, Boxed -> False, PlotStyle -> {Lighter[Blue](*,Opacity[.5]*)}]]; {vv, vp} = {{0, 0, 1}, {2, 0, 0}}; Animate[ hanoiGraph3D[state[{}, {}, {}, Range[4]], Lighting -> "Neutral", SphericalRegion -> True, ViewVertical -> Dynamic[vv], Boxed -> False, ViewPoint -> Dynamic[RotationTransform[\[Theta], vv][vp], (vp = #1) &]], {\[Theta], 2 Pi, 0}, SynchronousUpdating -> False] Although the 3-stick Hanoi graphs merely resemble Sierpinski graphs, it would be folly to ignore that resemblance given the thread of recursion that runs through both. We can create Sierpinski graphs easily, by once again reusing our polygon-in-polygon approach and this time replacing the `Polygon[{p1, p2, p3}]` expression with `{p1 <-> p2, p2 <-> p3, p3 <-> p1}`: ![enter image description here][70] ![enter image description here][71] ![enter image description here][72] ![enter image description here][73] axiom = Polygon[{{0, 0}, {1, Sqrt[3]}/2, {1, 0}}]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; draw[n_] := Graph@Flatten@ Nest[next, N@axiom, n] /. Polygon[pts_] :> Sequence @@ UndirectedEdge @@@ Partition[pts, 2, 1, 1]; axiom = Polygon[{{0, 0}, {1, Sqrt[3]}/2, {1, 0}}]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; (*Orderless attribute not necessary here. but it causes the particular permutation of the edge list that results in the particular layout*) (*triple-click on "DynamicSetting" below, Right-click -> Evaluate in Place*) DynamicSetting[SetterBar[1, {SetAttributes, ClearAttributes}]][UndirectedEdge, Orderless]; draw[n_] := Graph[#, VertexSize -> .05, GraphLayout -> "SpringEmbedding"] &@ Flatten@Nest[next, N@axiom, n] /. Polygon[pts_] :> Sequence @@ UndirectedEdge @@@ Partition[pts, 2, 1, 1]; g = draw[5] GraphPlot3D[g, VertexRenderingFunction -> None, PlotStyle -> Hue[2/3, 2/3, 2/3(*,1/2*)], Method -> "SpringEmbedding", Boxed -> False] There's the Sierpinski triangle I know and love; the graph of. You might think it doesn't look good. But you don't realize it's a Sierpinski triangle *wearing a cape made of Sierpinski triangles*. Not only does it not not look good, it looks completely badass. Because we're using the coordinates of the points as vertices, we can straightforwardly recover the regular Sierpinski layout: ![enter image description here][74] ![enter image description here][75] axiom = Polygon[{{0, 0}, {1, Sqrt[3]}/2, {1, 0}}]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; draw[n_] := Module[{edges}, edges = Flatten@Nest[next, N@axiom, n] /. Polygon[pts_] :> Sequence @@ UndirectedEdge @@@ Partition[pts, 2, 1, 1]; Graph[edges, VertexCoordinates -> VertexList[Graph[edges]], VertexSize -> .25]]; The point of spending 1 or 2 LOC's worth of developer time to convert our geometric Sierpinski triangle into a graph is so that we can ask questions about the graph. Like for example, what are its Hamiltonicness and Eulerity quotients? What is the average degree of the graph, in Celsius? In Kelvin? Frankly most of these questions are boring, and I don't really know anything about graphs. But here is a picture of the line graphs of the first few Sierpinski iterations: ![enter image description here][76] ![enter image description here][77] ![enter image description here][78] axiom = Polygon[{{0, 0}, {1, Sqrt[3]}/2, {1, 0}}]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; draw[n_] := Module[{edges}, edges = Flatten@Nest[next, N@axiom, n] /. Polygon[pts_] :> Sequence @@ UndirectedEdge @@@ Partition[pts, 2, 1, 1]; Graph[edges, VertexCoordinates -> VertexList[Graph[edges]], VertexSize -> .25]]; g = draw[2]; LineGraph[g] cycle = RandomChoice[{FindHamiltonianCycle, FindEulerianCycle}][g][[1]]; Animate[ HighlightGraph[g, Graph[cycle[[1 ;; n]]], EdgeShapeFunction -> (Line[#1] &), VertexShapeFunction -> None, GraphHighlightStyle -> "DehighlightHide"], {n, 1, Length[cycle], 1}, AnimationRate -> 1] axiom = Polygon[{{0, 0}, {1, Sqrt[3]}/2, {1, 0}}]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; sierpinskiGraph[n_] := Graph@Flatten@ Nest[next, N@axiom, n] /. Polygon[pts_] :> Sequence @@ UndirectedEdge @@@ Partition[pts, 2, 1, 1]; dg = Mean[VertexDegree[sierpinskiGraph[8]]]; (*if live in us, above comes out in farenheit, so have to convert*) us = Graphics[CountryData["UnitedStates", "Polygon"], ImageSize -> 8000]; If[Rasterize[us] === Rasterize[Show[us, Graphics[{PointSize[0], Point[Reverse@FindGeoLocation[]]}]]], WolframAlpha[ToString[dg, InputForm] <> " degrees f in celcius", {{"Result", 1}, "NumberData"}], dg] Also the minimal zig zag of the triangle, notable because it looks like a bunch of resistors (no doubt the inspiration for [certain papers][79]). And its minimal criss cross. I don't really see anything though. Do you see anything? I don't see anything. These graphs just vertices and edges to me. They do raise a question though. What game (or what anything) does the Sierpinski graph represent? I wasn't able to produce the Sierpinski triangle from any variation of the Hanoi game beyond the first couple of trivial iterations. In any case, through the extensive research I've done here I've found that layered graph layouts are pretty: ![enter image description here][80] ![enter image description here][81] ![enter image description here][82] ![enter image description here][83] ![enter image description here][84] validQ[s_state] := And @@ Less @@@ s; neighbors[states : {__state}] := Select[#, validQ] &@ DeleteDuplicates@Flatten@ Table[Module[{st2 = st}, If[Length[st2[[from]]] > 0, PrependTo[st2[[to]], st2[[from, 1]]]; st2[[from]] = Rest[st2[[from]]]]; If[st2 =!= st && validQ[st2], Sow@UndirectedEdge[st, st2]]; st2], {st, states}, {to, Length[st]}, {from, Length[st]}]; hanoiGraph[s_] := Module[{vertices, edges, n}, n = Count[s, _Integer, Infinity]; {vertices, {edges}} = Reap[Nest[neighbors, {s}, 2^n]]; SetAttributes[UndirectedEdge, Orderless]; Graph[DeleteDuplicates[edges]]]; axiom = Polygon[{{0, 0}, {1, Sqrt[3]}/2, {1, 0}}]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; (*certain layout depends on this ordering*) (*next[prev_]:=prev/.Polygon[pts_]:>( Polygon[ScalingTransform[1/2{1,1},#][pts]]&/@pts);*) sierpinskiGraph[n_] := Graph@Flatten@ Nest[next, N@axiom, n] /. Polygon[pts_] :> Sequence @@ UndirectedEdge @@@ Partition[pts, 2, 1, 1]; draw[g_] := LayeredGraphPlot[g, EdgeRenderingFunction -> ({CapForm["Round"], Line[#]} &), VertexRenderingFunction -> None, PlotStyle -> {Thickness[.01], Black}]; draw /@ {hanoiGraph[state[{}, {}, Range[3]]], sierpinskiGraph[3]} ##Chaos One of the nice things about the chaos game algorithm is that we can easily generalize it to more than three points. To begin with, we can place equiangular points on a circle using cos and sin ([see also my screwing around with polygons][85]). ![enter image description here][86] ![enter image description here][87] ![enter image description here][88] ![enter image description here][89] ![enter image description here][90] ![enter image description here][91] draw[v_, numPoints_] := Module[{vertices}, vertices = {Cos[#], Sin[#]} & /@ (2 Pi Range[v]/v); Graphics[{PointSize[0], Opacity[.1], Point[FoldList[(#1 + #2)/2 &, N@{0, 0}, RandomChoice[N@vertices, numPoints]]]}]]; These are drawn with 10 million points. The last two are drawn with 50 million points. The key to the quality here is giving the points transparency so that varying degrees of overlap/nearness form different shades. Higher vertex counts clearly have some structure, but it becomes blurry for one reason or another. You might be able to pull out the structure better with a more methodical approach and some image trickery. If you play around with pentagons in a vector editor (Mathematica itself has basic vector editing capabilities), you will find this figure: ![enter image description here][92] I've highlighted one of the inner pentagons. You can see that this figure reproduces the faded stellation pattern in the center of the chaos game rendition. So the chaos game algorithm remains consistent in this geometric fashion: At each vertex of the figure, attach a copy of the larger figure, but with sidelength one-half of the original (note the red edge in the above image). This also explains why the 4-vertex rendering is a block. And since we now have the geometric rule, we can turn to an explicit geometric construction to see if we can make the structure of these chaos games clearer. After some hiccups, I was able to get something working: ![enter image description here][93] SetAttributes[toXY, Listable]; toXY[z_] := {Re[z], Im[z]}; ring[c_, r_, 0] := c; ring[c_, r_, depth_] := Module[{zs}, zs = c + r E^(I 2 Pi Range[3]/3); ring[c + # Normalize[# - c], r/2., depth - 1] & /@ zs]; Graphics[Rotate[{Opacity[.95], LightGray, EdgeForm[Black], Polygon /@ toXY /@ Level[ring[0, 1, 5], {-2}]}, Pi]] ![enter image description here][94] ![enter image description here][95] ![enter image description here][96] ![enter image description here][97] draw[v_, n_] := Module[{ring}, ring[c_, r_, depth_] := Module[{ps}, ps = c + r {Cos[#], Sin[#]} & /@ (2. Pi Range[v]/v); If[depth == 0, Polygon[ps], ring[(c + #)/2, r/2, depth - 1] & /@ ps]]; Graphics[{Transparent, EdgeForm[{Opacity[.28], Black}], ring[0., 1., n]}]]; The snowflake has all sorts of symmetries, probably because **6 = 2 × 3**. It even has 3D grids and cubes. It's an infinite cubic matryoshka snowflake. And there is a lot of amazing detail in these drawings. At this point I should mention that all of the code snippets on this page are self-contained. If you have Mathematica you can copy-paste this and start producing these figures. The chaos game has another generalization. Instead of moving halfway between the active point and the randomly-chosen vertex, we can move 1/3rd of the way, or 3/2 of the way, etc: ![enter image description here][98] draw[v_, df_, numPoints_: 10000] := Module[{vertices}, vertices = {Cos[#], Sin[#]} & /@ (2 Pi Range[v]/v); Graphics[{PointSize[0], Opacity[.5], Point[FoldList[df, N@{0, 0}, RandomChoice[N@vertices, numPoints]]]}]]; functions = Function[r, (#1 + #2) r &] /@ {1, .96, .7, .6, .5, .2}; Grid[Join[ {TraditionalForm[#[a, b]] & /@ functions}, Table[draw[v, df], {v, 3, 6}, {df, functions}]]] In the case where we're just adding the numbers, we get a normal n-directional random walk. Of course, the geometric approach has its own similar generalization: ![enter image description here][99] draw[v_, df_, n_] := Module[{ring}, ring[c_, r_, depth_] := Module[{ps}, ps = c + r {Cos[#], Sin[#]} & /@ (2. Pi Range[v]/v); If[depth == 0, Polygon[ps], ring[(c + #)/2, df[0, r], depth - 1] & /@ ps]]; Graphics[{Transparent, EdgeForm[{Opacity[.26], Black}], ring[0., 1., n]}]]; functions = Function[r, (#1 + #2) r &] /@ {1, .7, .6, .5, .35, .2}; Grid[Join[ {TraditionalForm[#[a, b]] & /@ functions}, Table[draw[v, df, 4], {v, 3, 6}, {df, functions}]]] One of the things you might try to do, if you're me, is adjust the ratio until the corners match up: ![enter image description here][100] drawGeom[v_, ratio_, n_] := Module[{ring}, ring[c_, r_, depth_] := Module[{ps}, ps = c + r {Cos[#], Sin[#]} & /@ (2. Pi Range[v]/v); If[depth == 0, Polygon[ps], ring[(c + #)/2, r ratio, depth - 1] & /@ ps]]; Graphics[{Transparent, EdgeForm[{Opacity[.28], Black}], ring[0., 1., n]}]]; drawChaos[v_, ratio_, numPoints_] := Module[{vertices}, vertices = {Cos[#], Sin[#]} & /@ (2 Pi Range[v]/v); Graphics[{PointSize[0], Opacity[.5], Point[FoldList[(#1 + #2) ratio &, N@{0, 0}, RandomChoice[N@vertices, numPoints]]]}]]; With[{ verticesC = Control[{vertices, 3, 8, 1, ImageSize -> Tiny}], iterationsC = Control[{iterations, 0, 8, 1, ImageSize -> Tiny}], numPointsC = Control[{numpoints, 0, 100000, 1, ImageSize -> Tiny}]}, Manipulate[Overlay[{ drawGeom[vertices, ratio, iterations], drawChaos[vertices, ratio, numpoints]}], Row[{verticesC, iterationsC, numPointsC}, " "], {{ratio, .5}, 0, 1, Appearance -> "Labeled"}, Alignment -> Center]] Look! There are Koch snowflake figures that form in the negative space. The boundary becomes snowflaked. A Koch snowflake can easily be made with an L-system construction: ![enter image description here][101] axiom = {F, right[2], F, right[2], F}; rules = F -> {F, left[1], F, right[2], F, left[1], F}; conversions = {F -> forward, dir_[n_] :> ConstantArray[dir, n]}; (*state transformations*) forward[{z_, theta_}] := {z + E^(I theta), theta}; left[{z_, theta_}] := {z, theta + 2 Pi/6}; right[{z_, theta_}] := {z, theta - 2 Pi/6}; draw[n_] := Module[{program, zs}, program = Flatten[Nest[# /. rules &, axiom, n] /. conversions]; zs = First /@ ComposeList[program, {0., 0.}]; Graphics[{Thin, Line[{Re[#], Im[#]} & /@ zs]}]]; Grid[Partition[#, 3]] &[draw /@ Range[0, 5]] ![enter image description here][102] axiom = {F, right[1], F, right[1], F, right[1], F, right[1], F}; rules = F -> {F, left[1], F, right[2], F, left[1], F}; conversions = {F -> forward, dir_[n_] :> ConstantArray[dir, n]}; (*state transformations*) forward[{z_, theta_}] := {z + E^(I theta), theta}; left[{z_, theta_}] := {z, theta + 2 Pi/5}; right[{z_, theta_}] := {z, theta - 2 Pi/5}; draw[n_] := Module[{program, zs}, program = Flatten[Nest[# /. rules &, axiom, n] /. conversions]; zs = First /@ ComposeList[program, {0., -Pi/10.}]; Graphics[{Thin, Line[{Re[#], Im[#]} & /@ zs]}]]; Grid[Partition[#, 3]] &[draw /@ Range[0, 5]] With some minoradjustments we get our pentagonal snowflake. If we do the same procedure for the hexagonal chaos game we get the familiar triangular snowflake. All of the geometries seem to create Koch snowflakes, which makes sense given that indentations are triangles. Of course, there are much more interesting generalizations we can come up with than simple ratios: ![enter image description here][103] ![enter image description here][104] ![enter image description here][105] draw[v_, df_, numPoints_: 1000] := Module[{vertices}, vertices = {Cos[#], Sin[#]} & /@ (2 Pi Range[v]/v); Graphics[{PointSize[0], Opacity[.15], Point[FoldList[df, N@{0, 0}, RandomChoice[N@vertices, numPoints]]]}]]; rotate = RotationTransform; functions = { (#1 + #2)/RandomChoice[Prime[Range[3]]] &, (#1 + #2)/RandomChoice[Prime[Range[3]]!] &, (#1 + #2)/RandomChoice[Prime[Range[10]]] &, #1 + .5 rotate[10. Degree, #1][#2 - #1] &}; Grid[Join[ {TraditionalForm[Trace[#[a, b]][[2]]] & /@ functions}, ParallelTable[draw[v, df], {v, 3, 5}, {df, functions}]]] Some of these drawings remind me of the kind of fractal scattering found in the more deterministic algorithms. I wonder what kind of relation there is. The best distance function I found was logarithm-based: ![enter image description here][106] ![enter image description here][107] ![enter image description here][108] ![enter image description here][109] ![enter image description here][110] game = Compile[{{v, _Integer}, {wowzerz, _Real}, {numPoints, _Integer}}, Module[{diff, vertices}, vertices = {Cos[#], Sin[#]} & /@ (2 Pi Range[v]/v); (*distance function is Clip[(a+b)Log[EuclideanDistance[a,b]+wowzerz]*) FoldList[( diff = #2 - #1;(*note each of these is an x-y pair*) Clip[(#1 + #2) Log[Sqrt[diff.diff] + wowzerz], 1.1 {-2, 2}]) &, {0, 0}, RandomChoice[vertices, numPoints]]]]; Graphics[{PointSize[0], Opacity[.08], Point[game[5, .8, 300000]]}(*,PlotRange->1.15*)] All of these images are from the same distance function. The 'holes' on the inward-folded leaves of this one are interesting. It's like a fractal Klein bottle thing goin on there. If my computer was worth more than my car, as it some day will be, I would burn a lot of lightning-sequestered power in my mad scientist laboratory in the process of rendering different distance functions. There's a lot of pretty pictures in these simple chaos games. As it stands all this lightning is going to waste. The geometric approach, not one to have been served, decides to go Tron: ![enter image description here][111] draw[v_, df_, n_] := Module[{ring}, ring[c_, r_, depth_] := Module[{zs}, zs = c + r E^(I 2. Pi Range[v]/v); If[depth == 0, Polygon[{Re[#], Im[#]} & /@ zs], ring[(c + #)/2, df[0, r], depth - 1] & /@ zs]]; Framed[Graphics[{Transparent, EdgeForm[{Thick, LightBlue}], ring[0., 1., n]}], FrameStyle -> LightBlue]]; functions = { (#1 + #2)/RandomChoice[Prime[Range[3]]] &, (#1 + #2)/RandomChoice[Prime[Range[3]]!] &, (#1 + #2)/RandomChoice[Prime[Range[10]]] &, #1 + (1/2) (#2 - #1) E^(I 10. Degree) &}; Framed[Grid[Join[ {TraditionalForm[Trace[#[a, b]][[2]]] & /@ functions}, Table[draw[v, df, 3], {v, 3, 5}, {df, functions}]]], Background -> Black, BaseStyle -> LightBlue] ![enter image description here][112] ![enter image description here][113] ![enter image description here][114] ![enter image description here][115] draw[v_, df_, n_] := Module[{ring}, ring[c_, r_, depth_] := Module[{ps}, ps = c + r {Cos[#], Sin[#]} & /@ (2. Pi Range[v]/v); If[depth == 0, Polygon[ps], ring[(c + #)/2, df[0, r], depth - 1] & /@ ps]]; Graphics[{EdgeForm[White], Opacity[.4], RGBColor[.4, 1, 1], ring[0., 1., n]}]]; Show[(*repeatedly draw to cover more possibilities*) draw[4, (#1 + #2)/RandomChoice[Prime[Range[4]]] &, RandomChoice[{.1, 1.5} -> {2, 3}]] & /@ Range[20], Background -> Black, ImageSize -> 600] Or Asteroids. Same thing. The most interesting place I've seen the chaos game is in genetics. The idea is that instead of randomly picking the vertex at each step, you let the letters of the genetic code pick for you. There are 4 letters in DNA: A, T, G, C. So you run a chaos game with 4 vertices. If some sequence of DNA is AAAATC, your active point will approach the point labeled A 4 times, then it will approach the T point, then the C point. If the DNA sequence is completely random, you will just recreate our beautiful block, which I have named the Charcoal Diamond: ![enter image description here][116] But what you get is not random, as this chaos plot shows: ![enter image description here][117] coords = N@{"A" -> {1, -1}, "T" -> {-1, -1}, "G" -> {-1, 1}, "C" -> {1, 1}}; dat = Characters[GenomeData[{"ChromosomeX", {28000000, 36000000}}]] /. coords; draw[data_] := Graphics[{PointSize[0], Opacity[.01], Point[FoldList[(#1 + #2)/2 &, N@{0, 0}, data]]}, Epilog -> Style[Text @@@ coords, Red, Background -> White]]; draw[dat] This is a chaos game plot of an arbitrarily-chosen 8 million basepair sequence from our chromosome X (for scale, a typical protein is encoded in only a few hundred basepairs). You might insensibly think this happens because the letters occur with different frequencies, but that's not the case. The following is a chaos game plot of a sequence that was randomly generated over the same statistical frequencies as the above sequence: ![enter image description here][118] ![enter image description here][119] chars = Characters[GenomeData[{"ChromosomeX", {28000000, 36000000}}]]; tallies = Tally[chars]; BarChart[Last /@ tallies, ChartLabels -> First /@ tallies] ![enter image description here][120] ![enter image description here][121] coords = N@{"A" -> {1, 1}, "T" -> {-1, -1}, "G" -> {-1, 1}, "C" -> {1, -1}}; dat = Characters[GenomeData[{"ChromosomeX", {28000000, 36000000}}]] /. coords; scale = 2; grid = Tuples[Range[{-1, -1}, {1, 1} - 2^-scale, 2^-scale]]; color = If[Mod[Plus @@ #*2^scale, 2] == 1, Blend[{Lighter@Purple, Yellow}], Blend[{Lighter@Blue, Red}]] &; overunder = Graphics[{Opacity[.25], {color[#], Rectangle[#, # + 2^-scale]} & /@ grid}]; draw[data_] := Show[overunder, Graphics[{PointSize[0], Opacity[.06], Point[FoldList[(#1 + #2)/2 &, N@{0, 0}, RandomChoice[data, Length[data]]]]}], overunder, PlotRange -> 1, ImageSize -> {600, 600}]; draw[dat] // Rasterize coords = N@{"A" -> {1, -1}, "T" -> {-1, -1}, "G" -> {-1, 1}, "C" -> {1, 1}}; dat = Characters[GenomeData[{"ChromosomeX", {28000000, 36000000}}]] /. coords; draw[data_] := Graphics[{PointSize[0], Opacity[.01], Point[FoldList[(#1 + #2)/2 &, N@{0, 0}, RandomChoice[data, Length[data]]]]}, Epilog -> Style[Text @@@ coords, Red, Background -> White]]; draw[dat] The letters do occur in different frequencies, but that doesn't make any interesting patterns. If you move the letters around you get a pattern related in this case to the fact that the frequencies are bilateral, but otherwise it's just a glorified chessboard. And look what happens when we do the same vertex movearounding for our genetic code: ![enter image description here][122] coords = N@{"A" -> {1, 1}, "T" -> {-1, -1}, "G" -> {-1, 1}, "C" -> {1, -1}}; dat = Characters[GenomeData[{"ChromosomeX", {28000000, 36000000}}]] /. coords; draw[data_] := Graphics[{PointSize[0], Opacity[.01], Point[FoldList[(#1 + #2)/2 &, N@{0, 0}, data]]}, Epilog -> Style[Text @@@ coords, Red, Background -> White]]; draw[dat] The [original paper][123] does a good job explaining how the chaos plot is something of a "fractal subsequence histogram." Assume your active point is anywhere in the entire square, and the next move is toward the bottom-left corner. Because you move halfway toward that corner (instead of, say, only one third or one fifth of the way), you will *land inside that corner's quadrant* regardless of where your point was to begin with. Furthermore, you can apply this argument to subquadrants. It's easy to see this if you "work backwards." The formula for going from the current active point toward the next vertex is ![enter image description here][124] By the DeLorean transform, we can go backwards like this: ![enter image description here][125] So, reversing all the points in a particular subquadrant: ![enter image description here][126] ![enter image description here][127] ![enter image description here][128] Manipulate[Module[{delorean, preimage, pt1, pt2}, pt1 = ptc - width; pt2 = ptc + width; delorean[x_] := 2 x - coord; preimage = delorean /@ Tuples[Range[pt1, pt2, .025]]; Graphics[{ EdgeForm[{Thickness[.01], Darker[Gray, .4]}], {Transparent, Rectangle[{-1, -1}, {1, 1}]}, {LightGray, Rectangle[pt1, pt2]}, {Gray, Point[preimage]}}, PlotRange -> 1.2, GridLines -> Automatic, GridLinesStyle -> Lighter[Gray, .8]]], {{width, .25}, 0, .5, 2.^-3}, {{ptc, {-.75, -.25}}, Locator}, {{coord, {-1, -1}}, Locator, Appearance -> Style["\[FilledSquare]", Red]}] You can see here that for all the points which were just ordered to move toward the little red dot in the bottom-left corner, those that landed in the gray square had to have come from the top-left quadrant of the main square (the region with gray dots). So for the points in that gray region, we not only know that they were ordered to move toward the bottom-left vertex in the last step, but also that they were ordered to move toward the top-left vertex in the step before that. And so on. The points in this little gray region were ordered to move previously toward the bottom-left, and before that the top-left, and before that the bottom-right. All points in that square have that history. So going back to our genetic chaos plot: ![enter image description here][129] ![enter image description here][130] ![enter image description here][131] ![enter image description here][132] What those big holes mean is that CG is a rare sequence. As we just saw, a point can only get to that big empty square by coming from the bottom-right quadrant and going toward the top-left vertex. And since that square is so empty, there are rarely any points that are available to go toward other subsquares, such as this one, and so on. This accounts for the texture of the first chaos plot as well. It just looks more wacked out because the CG vertices are adjacent, so the empty squares touch each other and create those staggered serrations. A simple histogram confirms our suspicions of CG Paucity — a.k.a. biology's Dark Energy: ![enter image description here][133] chars = Characters[GenomeData[{"ChromosomeX", {28000000, 36000000}}]]; tallies = Sort[Tally[Partition[chars, 2, 1]]]; BarChart[Last /@ tallies, ChartLabels -> CenterDot @@@ First /@ tallies] If you sample subsequences instead of individual letters, and use those samples to simulate a genetic sequence, what's the smallest subsequence-sampling size you can get away with while still faithfully reproducing the texture of the chaos plot? Asked differently, what length of subsequence is it that accounts for the texture of the chaos plot? Here is a graph of our DNA letters with pair-wise sequences labeled by probability: ![enter image description here][134] chars = Characters[GenomeData[{"ChromosomeX", {28000000, 36000000}}]]; tallies = Sort[Tally[Partition[chars, 2, 1]]]; sum = Total[Last /@ tallies]; stats = {Rule @@ #1, #2/sum} & @@@ tallies; With[{r = .05}, edgeF[pts_List, e_] := Arrow[pts, r]; edgeF[pts_List, h_[a_, a_]] := Scale[Arrow[pts, r/.3], .3, pts[[1]]]; vertexF = {EdgeForm[Opacity[.5]], Disk[#1, r], Darker[Gray, .7], Style[Text[#2, #1], 13, Bold, FontFamily -> "Comic Sans MS"]} &; edgeLabels = #1 -> Style[Round[#2, .01], 12, Bold] & @@@ stats;] Graph[First /@ stats, EdgeLabels -> edgeLabels, EdgeStyle -> Directive[{Thick, Opacity[.56]}], VertexShapeFunction -> vertexF, VertexStyle -> Orange, EdgeShapeFunction -> edgeF, PlotRangePadding -> .1] This is a graph of what's called a Markov chain, but don't quote me on the formalities. (Mathematica 9 has built-in Markov whatitswhats, but I'm using version 8). The point is we can generate a sequence whose letter-to-letter statistics are the same as those of our original DNA by following the graph probaballistically: ![enter image description here][135] ![enter image description here][136] getStats[data_] := Module[{tallies, sum}, tallies = Tally[Partition[data, 2, 1]]; sum = Total[Last /@ tallies]; {Rule @@ #1, #2/sum} & @@@ tallies]; draw[data_, options___] := Graphics[{PointSize[0], Opacity[.01], Point[FoldList[(#1 + #2)/2 &, N@{0, 0}, data]]}, options, Epilog -> Style[Text @@@ coords, Red, Background -> White]]; chars = Characters[GenomeData[{"ChromosomeX", {28000000, 36000000}}]]; stats = getStats[chars]; Do[With[{weights = Rule @@ Transpose@Cases[stats, {letter -> to_, p_} :> {N[p], to}]}, next[letter] := RandomChoice[weights]], {letter, DeleteDuplicates[stats[[All, 1, 1]]]}] coords = N@{"A" -> {1, 1}, "T" -> {-1, -1}, "G" -> {-1, 1}, "C" -> {1, -1}}; pseudoDat = NestList[next, "A", Length[chars]] /. coords; draw[pseudoDat] You can see that, while similar, the fake plot immediately stands out as too Hollywood compared to the verisimilous beauty of the real data. The most notable distinction between them, besides the grain, is the dark diagonal that crosses A and T in the real plot, presumably because those two letters have a lot of interplay. That it's not replicated by our pseudosequence may mean there are a relatively large amount of ATA, TAT subsequences. So it looks like subsequences of length 2 aren't sufficient. We could generalize our Markovizer, but what I think is actually interesting here is the grain. We can do some image processing to see if we can bring it out: ![enter image description here][137] ![enter image description here][138] ![enter image description here][139] ![enter image description here][140] ListPlot[FoldList[(#1 + #2)/2 &, 1, Mod[Range[1000], 2]], PlotRange -> 1, Ticks -> {Automatic, Range[0, 1, 1/3]}] getStats[data_] := Module[{tallies, sum}, tallies = Tally[Partition[data, 2, 1]]; sum = Total[Last /@ tallies]; {Rule @@ #1, #2/sum} & @@@ tallies]; draw[data_, options___] := Graphics[{PointSize[0], Opacity[.01], Point[FoldList[(#1 + #2)/2 &, N@{0, 0}, data]]}, options]; chars = Characters[GenomeData[{"ChromosomeX", {28000000, 36000000}}]]; stats = getStats[chars]; Do[With[{weights = Rule @@ Transpose@Cases[stats, {letter -> to_, p_} :> {N[p], to}]}, next[letter] := RandomChoice[weights]], {letter, DeleteDuplicates[stats[[All, 1, 1]]]}] coords = N@{"A" -> {1, 1}, "T" -> {-1, -1}, "G" -> {-1, 1}, "C" -> {1, -1}}; pseudoDat = NestList[next, "A", Length[chars] - 1] /. coords; realDat = chars /. coords; With[{upsc = 2}, pseudo = draw[pseudoDat, ImageSize -> upsc 600] // Rasterize; real = draw[realDat, ImageSize -> upsc 600] // Rasterize; With[{\[Theta] = ColorNegate}, (ImageSubtract[\[Theta][real], \[Theta][pseudo]] // \[Theta]) ~MinFilter~1 ~ImageMultiply~1.1 (*~ImageAdjust~(9!)*) // ImageAdjust] ~ImageResize~Scaled[1/upsc]] ![enter image description here][141] ![enter image description here][142] chars = Characters[GenomeData[{"ChromosomeX", {28000000, 36000000}}]]; tallies = Sort[Tally[Partition[chars, 3, 1]]]; BarChart[Last /@ tallies, ChartLabels -> Column /@ First /@ tallies] ![enter image description here][143] chars = Characters[GenomeData[{"ChromosomeX", {28000000, 36000000}}]]; tallies = Sort[Tally[Partition[chars, 5, 1]]]; ListPlot[Cases[tallies, {seq_, count_} :> Tooltip[count, Column[seq]]], Axes -> None, Filling -> Axis, PlotRange -> Full] Which actually just shows a lot of TTT and AAA. Longer subsequence statistics show a similar picture. And of course we can always just do this: ![enter image description here][144] string = GenomeData[{"ChromosomeX", {28000000, 36000000}}]; tallies = Sort[Tally[StringCases[string, ("A" .. | "T" .. | "C" .. | "G" ..)]]]; Grid[Join[ Sequence @@ Reverse@Sort@ SplitBy[tallies, StringTake[First[#], 1] &], 2], Alignment -> Left] // Magnify[#, 1/2] & string = GenomeData[{"ChromosomeX", {28000000, 36000000}}]; strings = ParallelTable[Module[{cases = StringCases[string, Alternatives @@ cs .., Overlaps -> True]}, Last@SortBy[cases, StringLength]], {cs, Subsets[{"A", "C", "T", "G"}, {2}]}]; Grid[{Tooltip[Short[#], #], StringLength[#]} & /@ Reverse@SortBy[strings, StringLength], Alignment -> Left] The longest single-letter run length in this section of DNA is 48 As. The longest string of A-or-T is 222 basepairs long. Quite long, but the longest pairing is actually T/C which has a sequence of length 231. C/G's longest sequence is 34 basepairs long. I wonder what it is about CG. Maybe an unusually (un)useful amino acid or some hydrophobilia issue. I wonder too if these are blanket statistical patterns or if certain quirks are only present, say, in non-coding regions. You might be wondering why we don't just [ask a biologist][145] about these mysteries. The reason is because you're inside a car right now, I'm driving, we're lost, both of us are tourists, and I'm one of those people that would sooner burn hours of gasoline/diesel than ask for directions. You also suspect I might be some kind of criminal, so you're afraid of bringing up the issue. All around it's pretty awkward in here. We can do a lot better than these static diagrams by giving ourselves the ability to manually movearound the vertices to see if we can find interesting patterns: ![enter image description here][146] ![enter image description here][147] ![enter image description here][148] coords = N@{"A" -> {1, 1}, "T" -> {-1, -1}, "G" -> {-1, 1}, "C" -> {1, -1}}; chars = Characters[GenomeData[{"ChromosomeX", {28000000, 36000000}}]]; draw[data_, options___] := Graphics[{PointSize[0], Opacity[.1], Point[FoldList[(#1 + #2)/2 &, N@{0, 0}, data]]}, options]; Manipulate[ draw[ chars[[1 ;; 100000]] /. Thread[First /@ coords -> pts], PlotRange -> 1.1], {{pts, Last /@ coords}, Locator, Appearance -> (Framed[#, BaseStyle -> Red, FrameStyle -> None, FrameMargins -> 0, Background -> White] & /@ First /@ coords)}] And a tool that repeatedly applies the DeLorean transform to rebuild the sequence leading up to a region: ![enter image description here][149] ![enter image description here][150] ![enter image description here][151] coords = N@{"A" -> {1, 1}, "T" -> {-1, -1}, "G" -> {-1, 1}, "C" -> {1, -1}}; dat = Characters[GenomeData[{"ChromosomeX", {28000000, 36000000}}]] /. coords; nfLetter = Module[{nf = Nearest[Reverse /@ coords]}, nf[#, 1][[1]] &]; draw[data_, options___] := Graphics[{PointSize[0], Opacity[.01], Point[FoldList[(#1 + #2)/2 &, N@{0, 0}, data]]}, options]; background = Raster[Reverse@ImageData@Rasterize@ draw[dat, PlotRange -> 1, ImageSize -> 600 {1, 1}], {{-1, -1}, {1, 1}}]; delorean[p_] := 2 p - (nfLetter[p] /. coords); Manipulate[Module[{seq, r = 2^radius}, seq = Most[NestList[delorean, pt, Floor[1/(2 r)]]]; Graphics[{background, {Darker@Gray, Point[seq]}, {Orange, Thick, Opacity[.8], Arrow[Reverse[seq]], MapThread[Circle, {seq, 2^(radius + 1) r 2^Range[Length[seq]]}]}}, PlotRange -> 1.015, PlotLabel -> (nfLetter /@ Reverse[seq]), Epilog -> Style[Text @@@ coords, Red, Background -> White]]], {{radius, -2}, -4, -2, 1}, {{pt, {-.75, -.25}}, Locator}] I'm not actually sure how legit the maths of the program are, but there it be. Let's return to our charcoal diamond, here rotated: ![enter image description here][152] ![enter image description here][153] ![enter image description here][154] ![enter image description here][155] ![enter image description here][156] ![enter image description here][157] ![enter image description here][158] ![enter image description here][159] ![enter image description here][160] drawDiamond[numPoints_] := Graphics[{PointSize[0], Opacity[.01], Point[FoldList[(#1 + #2)/2 &, N@{0, 0}, RandomInteger[{0, 1}, {numPoints, 2}]]]}, ImageSize -> 600, PlotRangePadding -> 0]; diamond = drawDiamond[15000000] // Rasterize; axiom = {{Transparent, Rectangle[Scaled[{0, 0}], Scaled[{2, 2}]]}, White, If[hl, EdgeForm[{Opacity[.1], Green}]], Rectangle[Scaled[{1, 1}], Scaled[{2, 2}]]}; next[prev_] := Translate[Scale[prev, .5], {{-1, 1}, {-1, -1}, {1, -1}}]; Control[{hl, {True, False}}] Control[{n, 0, 10, 1}] Dynamic[Overlay[{diamond, Graphics[NestList[next, axiom, n], ImageSize -> (ImageSize /. AbsoluteOptions[diamond]), PlotRange -> 1]}]] Imagine we suddenly removed one vertex. That would mean that points can no longer land in that quadrant. Which would mean that no points could go from that quadrant to these subquadrants. Which would mean no points going to these subquadrants. And soon and soforth, until. So that explains the holes in the Sierpinski triangle. I call this the "Sierpinski triangle by infinite quadrilateral descent" method of construction. It seems very natural to me, but it raises the question of what these regions in the various deterministic constructions have to do with each other: ![enter image description here][161] draw[n_] := Array[Tooltip[Mod[Binomial[##], 2], TraditionalForm[HoldForm[Binomial[##]] == Binomial[##]]] &, {2^n, 2^n}, 0]; proc[a_ /; Length[a] == 2] := a; proc[arr_] := Module[{l = Length[arr]/2}, ArrayFlatten@Map[Function[square, If[FreeQ[square, Tooltip[1, _]], (**)Map[Style[#, Bold, ColorData[3][l]] &, square, {2}], (**)proc[square]]], Partition[arr, {l, l}], {2}]]; Style[MatrixForm[proc[draw[5]]], Background -> GrayLevel[.98]] (To be clear, the chaos game is just an algorithmic tradeoff vs the geometric approach. It is not necessarily doing anything non-deterministic in the larger scheme.) In this case I think the parity/binary explanations are going to be the simplest, though I'm a math noob and I don't see an immediately obvious way of approaching this, if the question even makes sense in the way I seem to be implying. However with [some inspiration][162] we can find an iterative angle that seems to me like a kind of multiplication: ![enter image description here][163] ![enter image description here][164] ![enter image description here][165] ![enter image description here][166] ![enter image description here][167] ![enter image description here][168] ![enter image description here][169] ![enter image description here][170] ![enter image description here][171] ![enter image description here][172] ![enter image description here][173] (* minimal *) iterate[matrix_, power_] := Nest[ArrayFlatten[ ConstantArray[#, Dimensions[matrix]] matrix] &, 1, power]; draw[matrix_, power_] := ArrayPlot[iterate[matrix, power], Frame -> False, PixelConstrained -> 1]; draw[{{1, 0}, {1, 1}}, 10] matrixInput[Dynamic[m_], Dynamic[rot_]] := Dynamic[Rotate[Deploy[MatrixForm[#, TableSpacing -> {0, 0}]], rot] &@ Array[(*(*better performance*)Rotate[#,-rot]&@*) Checkbox[Dynamic[m[[##]]], {0, 1}] &, Dimensions[m]]]; bg = White; dims = # -> If[# > 4, Style[#, Red], #] & /@ Range[7]; iterate[matrix_, power_] := Nest[ArrayFlatten[ ConstantArray[#, Dimensions[matrix]] matrix] &, 1, power]; controls = With[{ mC = Control[{{m, 2, ""}, dims, ControlType -> PopupMenu}], nC = Control[{{n, 2, ""}, dims, ControlType -> PopupMenu}], matrixInputC = matrixInput[Dynamic[matrix], Dynamic[rot]], colorC = Control[{{color, Black}, ColorSlider}], rotC = Control[{{rot, 0, "\[Theta]"}, Pi, -Pi, Pi/16}], powerC = Control[{{power, 3}, 1, 4, 1, Appearance -> "Labeled"}], opacityC = Control[{{opacity, 1}, 0, 1, ImageSize -> Small}], primitiveC = Control[{{primitive, Rectangle[]}, (# -> Graphics[{color, #}, ImageSize -> 20] &) /@ { {PointSize[Tiny], Point[N@{0, 0}]}, {EdgeForm[None], Disk[N@{0, 0}, .5]}, Rotate[Scale[Rectangle[], 1./Sqrt[2]], Pi/4], Rectangle[]}, SetterBar}], backgroundC = Row[{"background ", Framed[ColorSlider[Dynamic[background, (bg = background = #) &], AppearanceElements -> "Swatch"], FrameStyle -> Darker[Gray]], " ", ColorSlider[Dynamic[background, (bg = background = #) &], AppearanceElements -> "Spectrum", ImageSize -> Small]}]}, Row[{ Column[{ Row[{mC, " \[Times]", nC}], Row[{" ", matrixInputC}]}], Spacer[40], Column[{colorC, rotC, powerC}], Column[{backgroundC, opacityC, primitiveC}]}]]; Panel[#, Background -> Dynamic[bg]] &@ Manipulate[ If[{m, n} =!= Dimensions[matrix], matrix = PadRight[matrix, {m, n}]]; With[{primitives = Rotate[#, rot - Pi/2] &@ Translate[primitive, Position[ iterate[matrix /. 0 matrix -> {{1}}, power], 1]]}, Graphics[{Dynamic[EdgeForm[{Opacity[opacity], color}]], Dynamic[color], Dynamic[Opacity[opacity]], primitives}, ImageSize -> {{400, Large}, {400, Large}}, Background -> Dynamic[background]]], Evaluate[controls], (*declare variables here for persistence*) {{background, bg = White}, ControlType -> None}, {{matrix, {{1, 0}, {1, 1}}}, ControlType -> None}, Bookmarks :> { "Random" :> (matrix = RandomChoice[{.4, .6} -> {0, 1}, Dimensions[matrix]]), "Invert" :> (matrix = BitXor[matrix, 1]), "Array Print" :> (With[{p = power, m = matrix, c = color, o = opacity, bg = background}, CellPrint[ExpressionCell[Defer[ ArrayPlot[iterate[m, p], Frame -> False, PixelConstrained -> 1, ColorRules -> {0 -> bg, 1 -> c /. RGBColor[r_, g_, b_] :> RGBColor[r, g, b, o]}]], "Input"]]]), "Clear" :> (matrix = 0 matrix)}, Paneled -> False, SynchronousUpdating -> Automatic, SaveDefinitions -> True, LabelStyle -> Darker[Gray], Alignment -> Center] I know what this image reminds you of. Those little candle chandoliers that you hit in Castlevania to make hearts and morning stars come out. I also found *The Sierpinski Scream*, a letter H that would definitely beat you up if it was human, the up arrow and its Hot Topic-donning offspring, pink infinities made of pink infinities, even the vaunted Sierpinski Chronobracket. Essentially what we have here in these little matrices is a notation for specifying translations. It's yet another algorithm with different tradeoffs for doing more or less the same thing that our chaos game and geometric algorithms are doing. We can bring this characteristic out by allowing arbitrary rules: ![enter image description here][174] ![enter image description here][175] ![enter image description here][176] ![enter image description here][177] ![enter image description here][178] ![enter image description here][179] ![enter image description here][180] ![enter image description here][181] (* minimal *) iterate[matrix_, power_, matrix1_: {{1}}] := Module[{rules = {0 -> (0 # &), 1 -> (# &), T -> Transpose, R -> (Transpose[Reverse[#]] &), L -> (Reverse[Transpose[#]] &)}}, Nest[Function[prev, ArrayFlatten[Map[#[prev] &, matrix /. rules, {2}]]], matrix1, power]]; draw[matrix_, power_] := ArrayPlot[iterate[matrix, power], Frame -> False, PixelConstrained -> 1]; draw[{{1, 0}, {T, R}}, 10] matrixInput1[Dynamic[m_], Dynamic[rot_]] := Dynamic[Rotate[Deploy[MatrixForm[#, TableSpacing -> {0, 0}]], rot] &@ Array[(*(*better performance*)Rotate[#,-rot]&@*) EventHandler[Checkbox[Dynamic[m[[##]]], {0, 1}], {"MouseDown", 2} :> (m[[##]] = 0)] &, Dimensions[m]], 0]; matrixInput2[Dynamic[m_], Dynamic[rules_], Dynamic[color_], Dynamic[rot_]] := With[{ tooltip = Tooltip[#, "Click to cycle\nRight-click to zero", TooltipDelay -> .8] &, eatRightClick = EventHandler[#, {"MouseDown", 2} :> {}] &, matrixForm = MatrixForm[#, TableSpacing -> {1, 1}] &}, Dynamic[ eatRightClick@Style[#, color] &@ Rotate[#, rot] &@tooltip@Deploy@matrixForm@ Array[ EventHandler[Toggler[Dynamic[m[[##]]], First /@ rules], {"MouseDown", 2} :> (m[[##]] = 0)] &, Dimensions[m]]]]; bg = White; dims = # -> If[# > 4, Style[#, Red], #] & /@ Range[4]; defaultRules = {0 -> (0 # &), 1 -> (# &), T -> Transpose, R -> (Transpose[Reverse[#]] &), L -> (Reverse[Transpose[#]] &)}; iterate[matrix_, matrix1_, rules_, power_] := Nest[ Function[prev, ArrayFlatten[Map[#[prev] &, matrix /. rules, {2}]]], matrix1, power]; controls = With[{ m1C = Control[{{m1, 2, ""}, dims, ControlType -> PopupMenu}], m2C = Control[{{m2, 2, ""}, dims, ControlType -> PopupMenu}], matrixInput1C = matrixInput1[Dynamic[matrix1], Dynamic[rot]], matrixInput2C = matrixInput2[Dynamic[matrix], Dynamic[rules], Dynamic[color], Dynamic[rot]], rulesC = OpenerView[{"Rules", Control[{{rules, defaultRules, ""}, InputField, Background -> Dynamic[Lighter[background, .65]], FieldSize -> {45, 5}}]}], colorC = Control[{{color, Black}, ColorSlider}], rotC = Control[{{rot, 0, "\[Theta]"}, Pi, -Pi, Pi/16}], powerC = Control[{{power, 3}, 1, 4, 1, Appearance -> "Labeled"}], backgroundC = Row[{"background ", Framed[ColorSlider[Dynamic[background, (bg = background = #) &], AppearanceElements -> "Swatch"], FrameStyle -> Darker[Gray]], " ", ColorSlider[Dynamic[background, (bg = background = #) &], AppearanceElements -> "Spectrum", ImageSize -> Small]}], opacityC = Control[{{opacity, 1}, 0, 1, ImageSize -> Small}], primitiveC = Control[{{primitive, Rectangle[]}, (# -> Graphics[{color, #}, ImageSize -> 20] &) /@ { {PointSize[Tiny], Point[{0, 0}]}, {EdgeForm[None], Disk[{0, 0}, .5]}, Rotate[Scale[Rectangle[], 1/Sqrt[2]], Pi/4], Rectangle[]}, SetterBar}]}, Row[{ Column[{ Row[{m1C, " |", m2C}], Row[{" ", matrixInput1C, " ", matrixInput2C}]}], Spacer[40], Column[{rulesC, OpenerView[#, True] &@ {"Style", Row[{Column[{colorC, rotC, powerC}], Column[{backgroundC, opacityC, primitiveC}]}]}}]}]]; bookmarks = { "Random" :> ( matrix1 = RandomChoice[{0, 1}, Dimensions[matrix1]]; matrix = RandomChoice[First /@ rules, Dimensions[matrix]]), "Array Print" :> With[ {m1 = matrix1, m = matrix, r = rules, p = power, c = color, o = opacity, bg = background}, CellPrint[ExpressionCell[Defer[ ArrayPlot[ iterate[m /. 0 m -> {{1}}, m1 /. 0 m1 -> {{1}}, r, p], PixelConstrained -> 1, Frame -> False, ColorRules -> {0 -> bg, 1 -> c /. RGBColor[r_, g_, b_] :> RGBColor[r, g, b, o]}]], "Input"]]], "Clear" :> (matrix = 0 matrix)}; Panel[#, Background -> Dynamic[bg]] &@ Manipulate[ If[{m1, m1} =!= Dimensions[matrix1], matrix1 = PadRight[matrix1, {m1, m1}]]; If[{m2, m2} =!= Dimensions[matrix], matrix = PadRight[matrix, {m2, m2}]]; (*remove rules from matrix that no longer exist*) Module[{matrixP, default = rules[[1, 1]]}, matrixP = Replace[matrix, a_ /; ! MemberQ[First /@ rules, a] -> default, {2}]; If[matrix =!= matrixP, matrix = matrixP]]; With[{primitives = Rotate[Translate[primitive, Position[#, 1]], rot - Pi/2] &@ iterate[ matrix /. 0 matrix -> {{1}}, matrix1 /. 0 matrix -> {{1}}, rules, ControlActive[Max[power - 2, 2], power]]}, Graphics[{Dynamic[EdgeForm[{Opacity[opacity], color}]], Dynamic[color], Dynamic[Opacity[opacity]], primitives}, ImageSize -> {{400, Large}, {400, Large}}, Background -> Dynamic[background]]], (*declare variables here for persistence*) {{background, bg = White}, ControlType -> None}, {{matrix1, {{1, 0}, {1, 1}}}, ControlType -> None}, {{matrix, {{1, 0}, {1, 1}}}, ControlType -> None}, Evaluate[controls], Bookmarks :> Evaluate[bookmarks], LabelStyle -> Darker[Gray], SynchronousUpdating -> Automatic, Paneled -> False, SaveDefinitions -> True, Alignment -> Center] Cha-ching baby. If Snoop Dogg ever used Mathematica, that's what square brackets in his custom font would look like. And I know what this one reminds you of. The folds of the brain. And check out the Black Riddler's Question Mark. ##Inversion ![enter image description here][182] ![enter image description here][183] ![enter image description here][184] ![enter image description here][185] axiom = Polygon[{Cos[#], Sin[#]} & /@ (Pi/2 + 2 Pi Range[3]/3)]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; invert[p_] := p/Norm[p]^2; draw[n_] := Graphics[{EdgeForm[Black], Nest[next, N@axiom, n]}]; g = draw[2]; Show[g, g /. Polygon[pts_] :> Polygon[invert /@ pts]] The radius of inversion is right at the corners of the triangle, and I've left the univerted triangle in the center. Here's what the first few construction steps of the triangle look like if we invert them: ![enter image description here][186] axiom = Polygon[{Cos[#], Sin[#]} & /@ (Pi/2 + 2 Pi Range[3]/3)]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; invert[p_] := p/Norm[p]^2; draw[n_] := Module[{ps = Nest[next, N@axiom, n]}, Graphics[{EdgeForm[Black], Transparent, ps, ps /. Polygon[pts_] :> Polygon[invert /@ pts]}]]; Grid[Partition[draw /@ Range[0, 8], 3]] Notice that we're just inverting the endpoints of the lines, not the lines-as-curves. Visually this doesn't make a difference at higher iterations: ![enter image description here][187] axiom = Polygon[{Cos[#], Sin[#]} & /@ (Pi/2 + 2 Pi Range[3]/3)]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; invert[p_] := p/Norm[p]^2; draw[n_] := Graphics[{ EdgeForm[Black], Transparent, Nest[next, N@axiom, n]}]; Show[draw[10], draw[12] /. Polygon[pts_] :> Polygon[invert /@ pts], Method -> {"ShrinkWrap" -> True}, ImageSize -> 4 750] // Rasterize // ImageResize[#, Scaled[1/4]] & What about varying the radius of inversion? You first perform the same inversion as before, but with respect to the radius: ![enter image description here][188] It took me a while, but eventually I realized that the edges of the triangle were being mapped to curves, and that if you continued those curves they would form circles that intersected the origin, like this: ![enter image description here][189] ![enter image description here][190] ![enter image description here][191] ![enter image description here][192] Let's not forget we have a bountiful cornucopia from which to invert: ![enter image description here][193] ![enter image description here][194] ![enter image description here][195] draw[v_, n_] := Module[{ring}, ring[c_, r_, depth_] := Module[{ps}, ps = c + r {Cos[#], Sin[#]} & /@ (2 Pi Range[v]/v); If[depth == 0, Polygon[ps], ring[(c + #)/2, r/2, depth - 1] & /@ ps]]; Graphics[{Transparent, EdgeForm[Black], ring[0., 1., n]}]]; Clear[invert]; (*invert[p_/;Norm[p]<.0001]:={0,0};*) invert[p_] := p/Norm[p]^2; Column[Panel[Row[#]] & /@ Table[ draw[v, n] /. Polygon[pts_] :> Polygon[invert /@ pts], {v, 3, 6}, {n, 0, 4}]] draw[v_, n_] := Module[{ring}, ring[c_, r_, depth_] := Module[{ps}, ps = c + r {Cos[#], Sin[#]} & /@ (2 Pi Range[v]/v); If[depth == 0, Polygon[ps], ring[(c + #)/2, r/2, depth - 1] & /@ ps]]; Graphics[ring[0., 1., n]]]; invert[p_] := p/Norm[p]^2; Column[Panel[Row[#]] & /@ Table[ draw[v, n] /. Polygon[pts_] :> Line /@ Quiet@Partition[invert /@ pts, 2, 1, 1] /. l_Line /; MemberQ[l, Indeterminate, Infinity] :> {}, {v, 3, 6}, {n, 0, 4}]] ![enter image description here][196] **Sidenote.** Notice that in this program we aren't even touching our original uninverted geometric renderer, because we don't need to. Our original renderer returns a `Graphics` structure. This structure (which you might call an M-expression) is to us a set of straightforward vector graphics directives, but is to Mathematica *meaningless* until the frontend gets ahold of it. Until then (and even afterwards) we can perform the same kinds of structural slicing and dicing that we can perform on any other structure. In this case, replacing points by their inverses. A more complete solution to our point at infinity/division by 0 problem is to put the inverse of (0, 0) not at infinity, but really far. This doesn't come out of the algebra, but we can do it in a well-behaved way because we know from which direction our lines are coming from since we're defining things as polygons: ![enter image description here][197] invert[p_] := p/Norm[p]^2; (*you ever see that show Long Ago and Far Away? that show was awesome*) invertPoly[Polygon[pts_], farAway_: 20000] := With[{indQ = MemberQ[#, Indeterminate] &}, Line /@ Quiet@Partition[invert /@ pts, 2, 1, 1] /. {_?indQ, p_} | {p_, _?indQ} :> {p, farAway Normalize[p]}]; plotRangeInv[g_Graphics] := PlotRange /. AbsoluteOptions[g /. Polygon[pts_] :> Quiet@Polygon[invert /@ pts]]; draw[v_, n_] := Module[{ring}, ring[c_, r_, depth_] := Module[{ps}, ps = c + r {Cos[#], Sin[#]} & /@ (2 Pi Range[v]/v); If[depth == 0, Polygon[ps], ring[(c + #)/2, r/2, depth - 1] & /@ ps]]; Graphics[ring[0., 1., n]]]; (*if it ever came out on DVD i'd buy it like 100 times*) drawInv[v_, n_] := Module[{g = draw[v, n]}, Show[g /. poly_Polygon :> invertPoly[poly], PlotRange -> 1.1 plotRangeInv[g]]]; (*lines=Cases[drawInv[6,4],Line[ps_]/; EuclideanDistance@@ps<10000:>Line[Sort[ps]],Infinity]; Graphics[DeleteDuplicates@lines]*) What if, for no particular reason, we vary the exponents of the inversion formula? ![enter image description here][198] ![enter image description here][199] ![enter image description here][200] axiom = Polygon[{Cos[#], Sin[#]} & /@ (Pi/2 + 2 Pi Range[3]/3)]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; invert[p_] := p^3/Norm[p]^2; draw[n_] := Graphics[{EdgeForm[Black], Nest[next, N@axiom, n]}]; Grid[Partition[draw /@ Range[0, 8], 3]] /. Polygon[pts_] :> Polygon[invert /@ pts] See this one. One day you're going to be driving home from work. It's going to be dark. Pitch black. All a sudden out the corner your eye you're gonna see a flash in your rear view mirror. And when you look, you're gonna see that same Black Cobra Grill on my car speeding towards you at some unspeakable number of kilometers per hour. And then I'll disappear into the night. Like an episode off an MJ's Thriller×Knight Rider mashup. If we mangle the formula every which way we can find a lot of interesting effects: ![enter image description here][201] ![enter image description here][202] axiom = Polygon[{Cos[#], Sin[#]} & /@ (Pi/4 + 2 Pi Range[3]/3)]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; transform[p_] := (Reverse[p].p) p^2/Norm[p]^2; drawFishie1[n_] := Graphics[{Red, EdgeForm[{Thickness[.01], Opacity[.3], JoinForm["Round"], Lighter[Blue, .6]}], Rotate[Nest[next, N@axiom, n] /. Polygon[pts_] :> Polygon[transform /@ pts], 3 Pi/4]}, PlotRange -> .8 {{-.85, 1.51}, .4 {-1, 1.1}}]; drawFishie2[n_] := Graphics[{ Transparent, EdgeForm[Black], Rotate[Nest[next, N@axiom, n] /. Polygon[pts_] :> Polygon[transform /@ pts], -Pi/4]}]; The self-crossings form hexagonal figures. And American iconography? Here's another nifty one: ![enter image description here][203] ![enter image description here][204] next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; transform[p_] := (Reverse[p].p) p/Norm[p]^2; notFishieAwwwSadFace[n_, a1_: 0, a2_: 0, options___] := Module[{axiom}, axiom = Polygon[{Cos[#], Sin[#]} & /@ (a1 + 2 Pi Range[3]/3)]; Graphics[{Transparent, EdgeForm[Black], Rotate[Nest[next, N@axiom, n] /. Polygon[pts_] :> Polygon[transform /@ pts], a2]}, options]]; notFishieAwwwSadFace[6, Pi/4] I call it the Sierpinski Stiletto of Triangular Destruction. Hell yea. Also pay heed to the Sierpinski Butterfly of Poisonous Death, lest yee regret it. We can also move the circle of inversion around. I was going to write a program to do only that, but before I realized it I had accidentally built this: ![enter image description here][205] ![enter image description here][206] ![enter image description here][207] ![enter image description here][208] ![enter image description here][209] ![enter image description here][210] polys[v_, n_, offset_: {0, 0}, size_: 1, rot_: 0] := Module[{ring}, ring[c_, r_, depth_] := Module[{ps}, ps = c + r {Cos[#], Sin[#]} & /@ (rot + 2 Pi Range[v]/v); If[depth == 0, Polygon[(offset + # &) /@ ps], ring[(c + #)/2, r/2, depth - 1] & /@ ps]]; ring[0., size, n]]; (*Polygon in, Lines out /statictyping*) invertPoly[Polygon[pts_], tf_, farAway_: 20000] := With[{indQ = MemberQ[#, Indeterminate] &}, Line /@ Quiet@Partition[tf /@ pts, 2, 1, 1] /. {_?indQ, p_} | {p_, _?indQ} :> {p, farAway Normalize[p]}]; d = Norm; (*d=ChessboardDistance[{0, 0},#]&;*) transformationFunctions = { #/d[#]^2 &, #^3/d[#]^2 &, (Reverse[#].#) #/d[#] &, (# + #^3/d[#]^2)/2 &, (# + #/d[#]^2)/2 &, Round[#, .05] &}; With[{ verticesC = Control[{{vertices, 3}, 3, 8, 1, Appearance -> "Labeled", ImageSize -> Small}], iterationsC = Control[{{iterations, 5}, 0, 10, 1, Appearance -> "Labeled", ImageSize -> Small}], rangeC = Control[{{range, 4}, 1, 12, Appearance -> "Labeled"}], rotC = Control[{{rot, -Pi/6}, -Pi, Pi, Appearance -> "Labeled", ImageSize -> Tiny}], functionC = {{tf, transformationFunctions[[1]], "function"}, (# -> TraditionalForm@Quiet@Trace[#[z]][[2]] &) /@ transformationFunctions, ControlType -> SetterBar}, originalC = Control[{original, {True, False}}], circleC = Control[{circle, {True, False}}], opacityC = Control[{{opacity, 1}, 0, 1, ImageSize -> Small}], sizeC = Control[{{size, 1}, .001, 4, ImageSize -> Small}], offsetC = {{offset, {0, 0}}, Locator}}, Manipulate[Module[{polygons}, polygons = polys[vertices, ControlActive[Min[3, iterations - 2], iterations], offset, size, rot]; Graphics[{ If[circle, {LightGray, Circle[]}], If[original, {EdgeForm[LightGray], {Transparent, polygons}}], {Black, polygons /. p_Polygon :> invertPoly[p, tf]}}, PlotRange -> range]], Row[{verticesC, iterationsC}], Row[{rangeC, rotC}], functionC, Row[{originalC, circleC, sizeC, opacityC}, " "], offsetC, SynchronousUpdating -> False]] Oops. This hilarious function doesn't allow anything inside the unit disk. It's just waiting for someone to make a Yakety Sax movie about shapes crashing into the circle and crawling around it. [Someone on the internet][211] asked an interesting question: Are there "zoom out" fractals? We know that if we zoom in on the Sierpinski triangle, we'll continue seeing detail endlessly. But are there fractals that no matter how far you zoom out, you can't get out of them? Of course there are. We can just take a quote-unquote "zoom in" fractal and place one of its points of detail right at the origin, and then invert the fractal. Because the inverse of the origin is some kind of crazy infinity, we know that no matter how far we zoom out, we won't reach the end of the fractal. This example is really a formality though. You have a lot of liberty to make things up in math. Cornucopia. ![enter image description here][212] ![enter image description here][213] invert[p_ /; Norm[p] < .0001] := {0, 0}; invert[p_] := p/Norm[p]^2; draw[v_, df_, n_] := Module[{ring}, ring[c_, r_, depth_] := Module[{ps}, ps = c + r {Cos[#], Sin[#]} & /@ (2. Pi Range[v]/v); If[depth == 0, Polygon[invert /@ ps], ring[(c + #)/2, df[0, r], depth - 1] & /@ ps]]; Graphics[{EdgeForm[White], Opacity[.4], RGBColor[.4, 1(*;.6*), 1], ring[0., 1., n]}]]; candy[g_, res_: 600, upsc_: 1, style_: EdgeForm[Thick]] := Module[{a = Show[g, ImageSize -> upsc res, Background -> White]}, a = a /. p_Polygon :> {RGBColor[.6, RandomReal[], RandomReal[]], style, p}; a = Rasterize[a]; (*move this downscale to end for different quality*) a = ImageResize[a, Scaled[1/upsc]]; ImageDifference[a, ImageReflect[a, Left]] // ColorNegate]; g = With[{f = (#1 + #2)/RandomChoice[Prime[Range[4]]] &}, Show[ Table[draw[(*repeatedly draw to cover more possibilities*) RandomChoice[{1, 1, .25} -> {3, 4, 5}], f, RandomChoice[{.1, 1.5} -> {2, 3}]] /. p_Polygon :> Rotate[p, 0(*;Pi/4*), {0, 0}], {12}], Background -> Black, ImageSize -> Medium]]; (*note you can edit g in-place*) Defer[candy][g, 1280, 4] ![enter image description here][214] ![enter image description here][215] ring[c_, r_, depth_] := Module[{ps}, ps = c + r {Cos[#], Sin[#]} & /@ (-Pi/10 + 2. Pi Range[5]/5); If[depth == 0, Polygon[ps], ring[#, r/2, depth - 1] & /@ ps]]; invert[p_] := p/Norm[p]^2; Graphics[{Opacity[.15], Black, ring[0., 1., #] & /@ Range[5(*;8*)]}] /. Polygon[pts_] :> Polygon[invert /@ pts, VertexColors -> (ColorData["AvocadoColors"] /@ (#^1.7 &) /@ Norm /@ pts)] From what I can tell, one of the settings used to deal with division by 0 is the so-called Riemann sphere, which is where we take a space shuttle and use it to fly over and drop a cow on top of a biodome, and then have the cow indiscriminately fire laser beams at the grass inside and around the biodome. That's my intuitive understanding of it anyway. ![enter image description here][216] shuttle = ExampleData[{"Geometry3D", "SpaceShuttle"}, "GraphicsComplex"]; cow = ExampleData[{"Geometry3D", "Cow"}, "GraphicsComplex"]; grass = ExampleData[{"Texture", "Grass4"}]; drop = Sound[Play[Sin[1000 (2 - t)^2.3], {t, 0, .9}]]; lazer[] := EmitSound[Sound[Play[{TriangleWave[10 (2 - t)^5], Sin[500 (2 - t)^5] + SawtoothWave[20 (2 - t)^4.99]}, {t, 0, .2}, SampleRate -> 4000]]]; Animate[Module[{dir, angle}, (*xs animates from +30 to -60*) If[xs > 25, dropTrigger = False]; If[dropTrigger == False && xs < 10, dropTrigger = True; EmitSound[drop]]; If[xs < -10, lazer[]; dir = RandomReal[{-15, 15}, 2]~Join~{-20}; angle = ArcTan @@ Take[dir, 2], angle = 0]; Labeled[#, Style["Understanding the Riemann Sphere", FontFamily -> "Verdana"], Top] &@ With[{ cowLoc = {Clip[xs, {1.3, 50}], 0, Clip[8 + (-(.25 xs - 5)^2), {-13, -.25}]}, greenLight = Lighting -> {{"Directional", Green, {{5, 5, 5}, {0, 0, 0}}}}}, Graphics3D[{EdgeForm[None], (*shuttle*){Specularity[White, 7], Translate[shuttle, {xs, 0, 0}]}, (*cow*) Rotate[Translate[Scale[cow, 5], cowLoc], angle, {0, 0, 1}], (*grass*) Translate[{If[False, Sequence @@ {greenLight, Texture[grass]}, Green], Polygon[50 {{-1, -1, 0}, {1, -1, 0}, {1, 1, 0}, {-1, 1, 0}}, VertexTextureCoordinates -> 1.1 {{0, 0, 0}, {1, 0, 0}, {1, 1, 0}, {0, 1, 0}}]}, {0, 0, -19}], (*biodome*){Specularity[White, 3], Opacity[.5], Sphere[.95 {0, 0, -20}, 5]}, (*sun*){Glow[White], Sphere[{18, 18, 18}, 2]}, (*laser*) If[xs < -10, {Red, Glow[Red], Opacity[.5], Tube[{{0, 0, -12.4}, dir}]}]}, (*sky*)Background -> LightBlue, PlotRange -> 20, Boxed -> False]]], {xs, 30, -60, 3.2}, AnimationRate -> 10, DisplayAllSteps -> True] (Note the cow cannot be spherical or it will roll off). Personally I don't have any beef with Riemann or any of his manifolds, but for our purposes the Riemann sphere is inadequate since it maps our inverses vertically. One interesting consequence of this is that in the 2D cross section where the imaginary component is zero (essentially the 'Weierstrass circle'), it maps multiplicative inverses vertically and additive inverses horizontally. This all seems mathematically expedient, but it's otherwise boring. The Riemann sphere does give one explanation though about 'why' our circles and lines are inverses. In the Riemann sphere, the inverse of a circle that crosses the origin is a circle that crosses the North Pole, and since the lasers are being shot from the North Pole, they're limited to tracing out a line as they follow the circle. I was going to make a simple 3D diagram demonstrating this, but I accidentally made this: toRiemann = Compile[{{pts, _Real, 2}}, Module[{k}, Map[(k = 2/(1 + #.#); {k #[[1]], k #[[2]], 1 - k}) &, pts]]]; fromRiemann[pts_] := (-1/(#3 - 1)) {#1, #2, 0} & @@@ pts; shuttle = ExampleData[{"Geometry3D", "SpaceShuttle"}, "GraphicsComplex"]; cow = Append[ExampleData[{"Geometry3D", "Cow"}, "GraphicsComplex"], VertexTextureCoordinates -> 1/500 ExampleData[{"Geometry3D", "Cow"}, "PolygonData"]]; sphere = SphericalPlot3D[1, {\[Theta], 0, Pi}, {\[Phi], 0, 2 Pi}, MeshStyle -> Opacity[.05], PlotStyle -> Opacity[.1]]; plane = {Lighting -> "Neutral", Opacity[.5], LightGray, EdgeForm[None], Line[{{-50, 0, 0}, {50, 0, 0}}], Line[{{0, -50, 0}, {0, 50, 0}}], Polygon[15 {{-1, -1, 0}, {1, -1, 0}, {1, 1, 0}, {-1, 1, 0}}]}; numPoints = 160/4; circle = .25 {1 + Cos[#], Sin[#], 0} & /@ (-Pi + 2 Pi Range[numPoints]/numPoints); rCircle = toRiemann[circle]; invRCircle = {#1, #2, -#3} & @@@ rCircle; invCircle = Quiet[fromRiemann[invRCircle]]; ind = Indeterminate {1, 1, 1}; transform[\[Theta]_] := Composition[ RotationTransform[\[Theta], {0, 0, 1}], TranslationTransform[{0, 0, 1.2}]]; {l, r} = {{.335, -.044, .1894}, {.335, .044, .1894}}; slides = ParallelTable[Module[{angle}, angle = Quiet[ArcTan @@ (invCircle /. ind -> {0, 0})[[pti, 1 ;; 2]] /. ArcTan[0, 0] -> 0]; Show[sphere, Graphics3D[{ plane, Opacity[.7], Sphere[{0, 0, 1}, .01], (*cow*) Rotate[#, angle, {0, 0, 1}] &@Translate[#, {0, 0, 1.2}] &@ {EdgeForm[None],(*Opacity[.999],*)Texture[Graphics[Disk[]]], Lighting -> "Neutral", Lighting -> {{"Point", Darker[Red], l}}, cow, Red, Glow[Red], Sphere[{l, r}, .01]}, (* keep shuttle in orbit in case need more cows *) {EdgeForm[None], Translate[shuttle, {0, 0, 100}]}, (*lazerz*) If[invCircle[[pti]] =!= ind, {Red, Line[{transform[angle][l], invCircle[[pti]]}], Line[{transform[angle][r], invCircle[[pti]]}], {Red, Glow[Red], Opacity[.1], Sphere[invCircle[[pti]], .02 RandomReal[]]}}], (*etc*) {Lighter[Gray], Dashed, Line[{rCircle[[pti]], invRCircle[[pti]]}]}, {Opacity[.1], Lighter[Blue], Line[circle]}, {Opacity[.5], Lighter[Blue], Line[Take[circle, pti]]}, {Lighter[Blue], Line[{{0, 0, 1}, 50 (-{0, 0, 1} + circle[[pti]])}]}, {Lighter[Blue], Line[Take[rCircle, pti]]}, {Red, Line[Take[invRCircle, pti]]}, (*Purple,Line[{{0,0,1},50(-{0,0,1}+invCircle[[pti]])}/.tride->{0,0,1}],*) (*burn mark*) Thick, Red, Line[DeleteCases[Take[invCircle, pti], ind]]}], ImageSize -> 1/4 {16, 9} (1080/9), ViewAngle -> 4 Degree, PlotRange -> 10, Boxed -> False, Axes -> False]], {pti, 1, Length[circle]}]; ListAnimate[slides] Oops. But since we now have this tool, let's see what other plots look like: ![enter image description here][217] ![enter image description here][218] ![enter image description here][219] ![enter image description here][220] toRiemann = Compile[{{pts, _Real, 2}}, Module[{k}, Map[(k = 2/(1 + #.#); {k #[[1]], k #[[2]], 1 - k}) &, pts]]]; shuttle = ExampleData[{"Geometry3D", "SpaceShuttle"}, "GraphicsComplex"]; cow = Append[ExampleData[{"Geometry3D", "Cow"}, "GraphicsComplex"], VertexTextureCoordinates -> 1/500 ExampleData[{"Geometry3D", "Cow"}, "PolygonData"]]; sphere = SphericalPlot3D[1, {\[Theta], 0, Pi}, {\[Phi], 0, 2 Pi}, MeshStyle -> Opacity[.05], PlotStyle -> Opacity[.1]]; plane = {Lighting -> "Neutral", Opacity[.5], LightGray, EdgeForm[None], Line[{{-50, 0, 0}, {50, 0, 0}}], Line[{{0, -50, 0}, {0, 50, 0}}], Polygon[15 {{-1, -1, 0}, {1, -1, 0}, {1, 1, 0}, {-1, 1, 0}}]}; listRiemannPlot[pts_] := Module[{rPts = toRiemann[pts]}, Show[ sphere, Graphics3D[{ plane, Opacity[.7], Sphere[{0, 0, 1}, .01], (*cow*)Translate[#, {0, 0, 1.2}] &@ {EdgeForm[None],(*Opacity[.999],*) Texture[Graphics[Disk[]]], Lighting -> "Neutral", cow}, (*shuttle*){EdgeForm[None], Translate[shuttle, {0, 0, 100}]}, (*original*){Opacity[2 .2], Lighter[Blue], Line[pts]}, (*riemannized*){Opacity[.8], Blue, Line[rPts]}}], ViewAngle -> 4 Degree, PlotRange -> 10, Boxed -> False, Axes -> False]]; listRiemannPlot[Table[{x, Sin[2 x], 0}, {x, -40 Pi, 40 Pi, .01}]] ![enter image description here][221] ![enter image description here][222] toRiemann = Compile[{{pts, _Real, 2}}, Module[{k}, Map[(k = 2/(1 + #.#); {k #[[1]], k #[[2]], 1 - k}) &, pts]]]; shuttle = ExampleData[{"Geometry3D", "SpaceShuttle"}, "GraphicsComplex"]; cow = Append[ExampleData[{"Geometry3D", "Cow"}, "GraphicsComplex"], VertexTextureCoordinates -> 1/500 ExampleData[{"Geometry3D", "Cow"}, "PolygonData"]]; sphere = SphericalPlot3D[1, {\[Theta], 0, Pi}, {\[Phi], 0, 2 Pi}, MeshStyle -> Opacity[.05], PlotStyle -> Opacity[.1]]; plane = {Lighting -> "Neutral", Opacity[.5], LightGray, EdgeForm[None], Line[{{-50, 0, 0}, {50, 0, 0}}], Line[{{0, -50, 0}, {0, 50, 0}}], Polygon[15 {{-1, -1, 0}, {1, -1, 0}, {1, 1, 0}, {-1, 1, 0}}]}; riemannize[Graphics[g_, rest___], options___] := Show[sphere, Graphics3D[{plane, (*cow*)Translate[#, {0, 0, 1.2}] &@ {EdgeForm[None], Texture[Graphics[Disk[]]], Lighting -> "Neutral", cow}, (*shuttle*)Translate[shuttle, {0, 0, 100}], (*curves*)g /. Line[pts_] :> {Line[toRiemann[pts]], Opacity[.25], Line[{#1, #2, 0} & @@@ pts]}}], Boxed -> False, Axes -> None, PlotRange -> 5, options]; plot = Plot[ Evaluate[y /. Solve[y^2 == x^3 - 3 x + 1, y]], {x, -100, 100}, PlotPoints -> 10000]; riemannize[plot, ViewAngle -> 15 Degree] This is one of those fangled elliptic curves. Apparently they do form pairs of circle things on the Riemann sphere. I thought that was just an old wive's tale. The nice thing about this program is that it works on `Graphics` structures, such as those returned by `Plot`. That means you can plug arbitrary 2D plots and graphics into this function and have them automatically Riemannized. Like say you're trying to educe from without your incorrigible students' crania some particular factoid: ![enter image description here][223] ![enter image description here][224] ![enter image description here][225] toRiemann = Compile[{{pts, _Real, 2}}, Module[{k}, Map[(k = 2/(1 + #.#); {k #[[1]], k #[[2]], 1 - k}) &, pts]]]; shuttle = ExampleData[{"Geometry3D", "SpaceShuttle"}, "GraphicsComplex"]; cow = Append[ExampleData[{"Geometry3D", "Cow"}, "GraphicsComplex"], VertexTextureCoordinates -> 1/500 ExampleData[{"Geometry3D", "Cow"}, "PolygonData"]]; sphere = SphericalPlot3D[1, {\[Theta], 0, Pi}, {\[Phi], 0, 2 Pi}, MeshStyle -> Opacity[.05], PlotStyle -> Opacity[.1]]; plane = {Lighting -> "Neutral", Opacity[.5], LightGray, EdgeForm[None], Line[{{-50, 0, 0}, {50, 0, 0}}], Line[{{0, -50, 0}, {0, 50, 0}}], Polygon[15 {{-1, -1, 0}, {1, -1, 0}, {1, 1, 0}, {-1, 1, 0}}]}; riemannize[Graphics[g_, ___], options___] := Show[sphere, Graphics3D[{plane, (*cow*)Translate[#, {0, 0, 1.2}] &@ {EdgeForm[None],(*Opacity[.999],*) Texture[Graphics[Disk[]]], Lighting -> "Neutral", cow}, (*shuttle*)Translate[shuttle, {0, 0, 100}], (*curves*)g /. Line[pts_] :> {Line[toRiemann[pts]], Opacity[.25], Line[{#1, #2, 0} & @@@ pts]}}], Boxed -> False, Axes -> None, PlotRange -> 5, options]; vint = Sqrt[1 - 3/2 (1 + Sqrt[21]) + 1/8 (1 + Sqrt[21])^3]; plot = Show[Plot[y /. Solve[y^2 == x^3 - 3 x + 1, y], {x, -100, 100}, PlotPoints -> 10000], Graphics[{Orange, Line[Table[{x, x + 1}, {x, -500, 500, .1}]], Black, Dashing[1/10 {0.08, 0.02}], Line[Table[{1/2 (1 + Sqrt[21]), y}, {y, -vint, vint, .1}]]}]]; riemannize[plot, ViewAngle -> 8 Degree] You've set this up with 2D graphics. But you can just plug the output of this into our Riemannizer to get this. In fact in Mathematica you can even copy/paste the 2D plot (itself an interactwithable vector object) like this. And you can vector-edit that plot in-place and when you re-evaluate the expression, the differences will appear in the Riemannization. Not bad for what essentially amounts to one line of code: g /. Line[pts_] :> Line[toRiemann[pts]] This is the power of Mathematica's macro-at-will symbolic semantics and well-curated architecture. Specifically in this case, it's the fact that the built-in plotting functions return the same laid-bare `Graphics` vector structures that your own versions of those functions would return. This Riemannizer only does a direct endpoint conversion of lines, but you can easily have it 3Dify whatever you want in a more thorough fashion. After I made my [Cyclotron 4000][226] masterpiece, I considered what a version 2 might be. Now I know. With some adjustments to the contraption, we now have the Cycowtron 4800 Deluxe (pronounced psy-cow-tron forty-eight-hundred de-lux): ![enter image description here][227] ![enter image description here][228] ![enter image description here][229] ![enter image description here][230] ![enter image description here][231] ![enter image description here][232] toRiemann = Compile[{{pts, _Real, 2}}, Module[{k}, Map[(k = 2/(1 + #.#); {k #[[1]], k #[[2]], 1 - k}) &, pts]]]; invertRiemann[pts_] := {#1, #2, -#3} & @@@ pts; (*fromRiemann[pts_]:=(-1/(#3-1)) {#1,#2,0}&@@@pts;*) shuttle = With[{shuttleGC = ExampleData[{"Geometry3D", "SpaceShuttle"}, "GraphicsComplex"]}, Translate[#, {0, 0, 100}] &@ {EdgeForm[None], Lighting -> "Neutral", Append[shuttleGC, VertexColors -> RandomReal[.65 + {0, 1}, Length[shuttleGC[[1]]]]^2]}]; cow = Translate[#, {0, 0, 1.2}] &@ {EdgeForm[None],(*Opacity[.999],*)Texture[Graphics[Disk[]]], Lighting -> "Neutral", Append[ExampleData[{"Geometry3D", "Cow"}, "GraphicsComplex"], VertexTextureCoordinates -> 1/500 ExampleData[{"Geometry3D", "Cow"}, "PolygonData"]]}; allSettings = {"sphere", "cow", "original", "riemann", "inverse", "shuttle"}; bookmarks = { "Random" :> ( With[{R := RandomReal[]}, color = RGBColor[R, R, R]; inflection = RandomChoice[{1, -1}]; effect = .25*R^8; thickness = 10*R^8; spirality = R^3; If[spirality < .035, spirality = 0]; x = 12 R; y = 2 R]; Module[{weights = If[x > 3, {.1, .03, .87}, {.1, .07, .83}]}, \[Zeta] = RandomChoice[{-1, 1}]* RandomChoice[weights -> { RandomReal[{0, 7.5}], RandomChoice[{0, .5, .5}], Round[RandomReal[{1, 7.5}], .5]}]]), "Rose" :> {color = Red, effect = 0, inflection = -1, x = 0, y = 1.1343, spirality = 0, \[Zeta] = 3}, "Glyph" :> {color = Black, effect = 0.198, inflection = 1, x = 5.2, y = 0, spirality = 0, \[Zeta] = 2}, "Mass Atomic" :> { effect = 0, inflection = -1, x = 5.84, y = 0.412, spirality = 0, \[Zeta] = -4.2504}, "Jello" :> {color = Red, effect = 0, inflection = -1, x = 12, y = 0.846, spirality = 1, \[Zeta] = -1}, "Grim" :> {thickness = 3.35, color = Black, effect = 0.0675, inflection = 1, x = 8, y = 0.296, spirality = 1, \[Zeta] = -1}, "Angelwings" :> {color = RGBColor[.07694, .39046, 1], effect = 0, inflection = 1, spirality = 1, x = 12, y = 0, \[Zeta] = -5.4947}, "Rollers" :> {color = Black, effect = 0, inflection = -1, spiral3ity = 0, x = 5.5, y = .1, \[Zeta] = -0.984032039033508}, "Lifespark" :> {color = RGBColor[.1026, .9878, .0201], effect = 0, inflection = 1, spirality = .0995, x = 3.2757, y = .2002, \[Zeta] = -5.5}}; With[{ colorC = Control[{{color, Black, "line color"}, ColorSlider}], backgroundC = Control[{{background, White}, ColorSlider}], thicknessC = Control[{{thickness, .001, "line thickness"}, .001, 10, Appearance -> "Labeled", ImageSize -> Small}], effectC = Control[{{effect, 0., "charcoal effect"}, 0, .25, Appearance -> "Labeled", ImageSize -> Small}], inflectionC = Control[{{inflection, 1}, {1 -> " concave ", -1 -> " convex "}, Appearance -> "Vertical"}], angularityC = Control[{{\[Zeta], 2., "angularity"}, -7.5, 7.5, .5, Appearance -> "Labeled", ImageSize -> Small}], tensionC = Control[{{x, 8., "tension"}, 0, 12, Appearance -> "Labeled", ImageSize -> Small}], yC = Control[{{y, 2., "cycle width"}, 0, 2, ImageSize -> Tiny}], spiralityC = Control[{{spirality, 0.}, 0, 1, ImageSize -> Tiny}], scaleC = Control[{{scale, 3.157, "sphere size"}, .00001, 15, ImageSize -> Medium}], settingsC = Control[{{settings, Take[allSettings, 4], "view"}, allSettings, ControlType -> TogglerBar}], opacityC = Control[{{opacity, .43}, 0, 1, Appearance -> "Labeled", ImageSize -> Small}], resetC = DynamicWrapper[ Tooltip[Setter[Dynamic[reset], "reset"], "reset perspective", TooltipDelay -> .3], If[reset === "reset", (reset = False; vp = {1.3, -2.4, 2}; vv = {0, 0, 1}; {va, vc} = Automatic {1, 1})]]}, With[{ controls = Sequence[ OpenerView[{"Style", Column[{ Row[{ Column[{backgroundC, colorC}, Alignment -> Right], Column[{effectC, thicknessC, opacityC}, Alignment -> Right]}, Spacer[30]], Style[\[HorizontalLine], Lighter[LightGray]]}, Spacings -> 0]}], Row[{scaleC, Spacer[30], settingsC}], Row[{inflectionC, Spacer[30], Column[{angularityC, tensionC}], Column[{yC, spiralityC}], Spacer[30], resetC}]], storedVars = Sequence @@ ({{#, Automatic}, ControlType -> None} & /@ {vp, vv, va, vc}), dynamicView = Sequence[ ViewPoint -> Dynamic[vp], ViewVertical -> Dynamic[vv], ViewAngle -> Dynamic[va], ViewCenter -> Dynamic[vc]]}, (# /. switch[a_, b_] :> (*macro*) Unevaluated[Dynamic[If[MemberQ[settings, a], b, {}]]] &)@ Manipulate[ DynamicModule[{g, lines, riemannLines, invertedLines, \[Psi] = Round[Abs[FractionalPart[\[Zeta]]]*1., .25] /. { 0. -> y, .5 -> y/2, .25 | .75 -> y/4}}, g = ParametricPlot[ 1/(scale^1.4) (1. + spirality*(Log[\[Theta] + 1.] - 1.))* {\[Psi] Cos[\[Theta]] + x Cos[64. \[Theta]] + (1 - effect*RandomReal[])*\[Zeta]* (Cos[512. \[Theta]] + Cos[64. \[Zeta] \[Theta]]), \[Psi] Sin[\[Theta]] - x Sin[64. \[Theta]] + (1 - effect*RandomReal[])* inflection*\[Zeta]* (Sin[512. \[Theta]] + Sin[64. \[Zeta] \[Theta]])} , {\[Theta], 0, 2 \[Pi]}, ImageSize -> {640, 480}, PerformanceGoal -> "Quality", Epilog -> {Gray, Thick, Circle[{0, 0}, 1]}, PlotStyle -> Dynamic[{{color, Opacity[.43]}}], PlotRange -> Full, Background -> Dynamic[background], PlotPoints -> 270, Axes -> None]; lines = Cases[g, Line[pts_] :> pts, Infinity]; riemannLines = toRiemann /@ lines; invertedLines = invertRiemann /@ riemannLines; lines = Map[{##, 0} & @@@ # &, lines]; ControlActive[g, Graphics3D[{ switch[ "sphere", {Lighting -> "Neutral", Opacity[.1], Sphere[]}], switch["shuttle", shuttle], switch["cow", cow], Dynamic[color], Dynamic[Opacity[opacity]], Dynamic[AbsoluteThickness[thickness]], switch["original", Line /@ lines], switch["riemann", Line /@ riemannLines], switch["inverse", Line /@ invertedLines]}, Boxed -> False, dynamicView, Background -> Dynamic[background], ImageSize -> {640, 480}]]] , controls, storedVars, {{reset, "reset"}, ControlType -> None}, Bookmarks -> bookmarks, Alignment -> Center]]] This thing's almost as curly as my hair. Note that in Mathematica these aren't static renderings. They're regular `Graphics3D` panes that you can spin and move around every which way. But let's not forget why we're here: ![enter image description here][233] ![enter image description here][234] ![enter image description here][235] ![enter image description here][236] toRiemann = Compile[{{pts, _Real, 2}}, Module[{k}, Map[(k = 2/(1 + #.#); {k #[[1]], k #[[2]], 1 - k}) &, pts]]]; cow = {EdgeForm[None], Texture[Graphics[Disk[]]], Lighting -> "Neutral", Append[ExampleData[{"Geometry3D", "Cow"}, "GraphicsComplex"], VertexTextureCoordinates -> 1/500 ExampleData[{"Geometry3D", "Cow"}, "PolygonData"]]}; riemannize[Graphics[g_, ___], options___] := Graphics3D[{ (*sphere*){Lighting -> "Neutral", Opacity[.07], Sphere[{0, 0, 0}, 1]}, (*cow*)Rotate[Rotate[Translate[cow, {0, 0, 1.2}], -Pi/2, {0, 0, 1}], -Pi/ 2, {1, 0, 0}], (*curves*)g /. (h : Line | Polygon)[pts_] :> {h[{##, 0} & @@@ pts], h[toRiemann[pts]]}}, options, Boxed -> False]; axiom = Polygon[2 {Cos[#], Sin[#]} & /@ (Pi/2 - 2 Pi Range[3]/3)]; next[prev_] := prev /. Polygon[{p1_, p2_, p3_}] :> { Polygon[{p1, (p1 + p2)/2, (p1 + p3)/2}], Polygon[{p2, (p2 + p3)/2, (p1 + p2)/2}], Polygon[{p3, (p1 + p3)/2, (p2 + p3)/2}]}; draw[n_] := Graphics[{Transparent, EdgeForm[Black], Nest[next, N@axiom, n]}]; riemannize[draw[5], ViewPoint -> Top] [1]: https://en.wikipedia.org/wiki/Sierpi%C5%84ski_triangle [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=88381.png&userId=20103 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=siermathgb2.png&userId=20103 [4]: https://redblobgames.github.io/freshwater.github.io/index.htm#lsystems [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=64482.png&userId=20103 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=84513.png&userId=20103 [7]: http://en.wikipedia.org/wiki/Sierpinski_triangle [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=55434.png&userId=20103 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=30075.png&userId=20103 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=59926.png&userId=20103 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=76387.png&userId=20103 [12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=86008.png&userId=20103 [13]: http://en.wikipedia.org/wiki/Pascal%27s_triangle [14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=69969.png&userId=20103 [15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1018810.png&userId=20103 [16]: https://community.wolfram.com//c/portal/getImageAttachment?filename=313511.png&userId=20103 [17]: https://community.wolfram.com//c/portal/getImageAttachment?filename=439512.png&userId=20103 [18]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1075513.png&userId=20103 [19]: https://community.wolfram.com//c/portal/getImageAttachment?filename=981814.png&userId=20103 [20]: http://oeis.org/A001317 [21]: http://oeis.org/A099901 [22]: http://oeis.org/A099902 [23]: http://upload.wikimedia.org/wikipedia/commons/thumb/7/74/Multigrade_operator_AND.svg/1000px-Multigrade_operator_AND.svg.png [24]: https://community.wolfram.com//c/portal/getImageAttachment?filename=403415.png&userId=20103 [25]: http://mathworld.wolfram.com/LucasCorrespondenceTheorem.html [26]: https://community.wolfram.com//c/portal/getImageAttachment?filename=776416.png&userId=20103 [27]: https://community.wolfram.com//c/portal/getImageAttachment?filename=125917.png&userId=20103 [28]: https://community.wolfram.com//c/portal/getImageAttachment?filename=462718.png&userId=20103 [29]: https://community.wolfram.com//c/portal/getImageAttachment?filename=951519.png&userId=20103 [30]: https://community.wolfram.com//c/portal/getImageAttachment?filename=363620.png&userId=20103 [31]: https://community.wolfram.com//c/portal/getImageAttachment?filename=593021.png&userId=20103 [32]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1004522.png&userId=20103 [33]: https://community.wolfram.com//c/portal/getImageAttachment?filename=277723.png&userId=20103 [34]: https://community.wolfram.com//c/portal/getImageAttachment?filename=220823.png&userId=20103 [35]: https://community.wolfram.com//c/portal/getImageAttachment?filename=870724.png&userId=20103 [36]: https://community.wolfram.com//c/portal/getImageAttachment?filename=924025.png&userId=20103 [37]: https://community.wolfram.com//c/portal/getImageAttachment?filename=713026.png&userId=20103 [38]: https://community.wolfram.com//c/portal/getImageAttachment?filename=396627.png&userId=20103 [39]: https://community.wolfram.com//c/portal/getImageAttachment?filename=479428.png&userId=20103 [40]: http://www.mathics.net/ [41]: https://community.wolfram.com//c/portal/getImageAttachment?filename=290829.png&userId=20103 [42]: https://community.wolfram.com//c/portal/getImageAttachment?filename=742630.png&userId=20103 [43]: https://community.wolfram.com//c/portal/getImageAttachment?filename=894931.png&userId=20103 [44]: https://community.wolfram.com//c/portal/getImageAttachment?filename=275232.png&userId=20103 [45]: https://community.wolfram.com//c/portal/getImageAttachment?filename=511333.png&userId=20103 [46]: https://community.wolfram.com//c/portal/getImageAttachment?filename=148334.png&userId=20103 [47]: https://community.wolfram.com//c/portal/getImageAttachment?filename=177035.png&userId=20103 [48]: https://community.wolfram.com//c/portal/getImageAttachment?filename=664936.png&userId=20103 [49]: https://community.wolfram.com//c/portal/getImageAttachment?filename=779437.png&userId=20103 [50]: https://community.wolfram.com//c/portal/getImageAttachment?filename=332338.png&userId=20103 [51]: https://community.wolfram.com//c/portal/getImageAttachment?filename=828439.png&userId=20103 [52]: http://oeis.org/A000120 [53]: https://community.wolfram.com//c/portal/getImageAttachment?filename=210240.png&userId=20103 [54]: https://community.wolfram.com//c/portal/getImageAttachment?filename=516841.png&userId=20103 [55]: https://community.wolfram.com//c/portal/getImageAttachment?filename=199842.png&userId=20103 [56]: https://community.wolfram.com//c/portal/getImageAttachment?filename=873043.png&userId=20103 [57]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1012744.png&userId=20103 [58]: http://reference.wolfram.com/mathematica/tutorial/PermutationGroups.html#1423666859 [59]: https://community.wolfram.com//c/portal/getImageAttachment?filename=649845.png&userId=20103 [60]: https://community.wolfram.com//c/portal/getImageAttachment?filename=370146.png&userId=20103 [61]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1033047.png&userId=20103 [62]: https://community.wolfram.com//c/portal/getImageAttachment?filename=added_image2.png&userId=20103 [63]: https://community.wolfram.com//c/portal/getImageAttachment?filename=960748.png&userId=20103 [64]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1016249.png&userId=20103 [65]: https://community.wolfram.com//c/portal/getImageAttachment?filename=472050.png&userId=20103 [66]: https://community.wolfram.com//c/portal/getImageAttachment?filename=831051.png&userId=20103 [67]: https://community.wolfram.com//c/portal/getImageAttachment?filename=267252.png&userId=20103 [68]: https://community.wolfram.com//c/portal/getImageAttachment?filename=531353.png&userId=20103 [69]: https://community.wolfram.com//c/portal/getImageAttachment?filename=54.gif&userId=20103 [70]: https://community.wolfram.com//c/portal/getImageAttachment?filename=796055.png&userId=20103 [71]: https://community.wolfram.com//c/portal/getImageAttachment?filename=118056.png&userId=20103 [72]: https://community.wolfram.com//c/portal/getImageAttachment?filename=363857.png&userId=20103 [73]: https://community.wolfram.com//c/portal/getImageAttachment?filename=951258.png&userId=20103 [74]: https://community.wolfram.com//c/portal/getImageAttachment?filename=457859.png&userId=20103 [75]: https://community.wolfram.com//c/portal/getImageAttachment?filename=428260.png&userId=20103 [76]: https://community.wolfram.com//c/portal/getImageAttachment?filename=280561.png&userId=20103 [77]: https://community.wolfram.com//c/portal/getImageAttachment?filename=62.gif&userId=20103 [78]: https://community.wolfram.com//c/portal/getImageAttachment?filename=siergraph13.gif&userId=20103 [79]: http://www.math.uconn.edu/~teplyaev/research/randomSG.pdf [80]: https://community.wolfram.com//c/portal/getImageAttachment?filename=543363.png&userId=20103 [81]: https://community.wolfram.com//c/portal/getImageAttachment?filename=716364.png&userId=20103 [82]: https://community.wolfram.com//c/portal/getImageAttachment?filename=970565.png&userId=20103 [83]: https://community.wolfram.com//c/portal/getImageAttachment?filename=578066.png&userId=20103 [84]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1039667.png&userId=20103 [85]: https://redblobgames.github.io/freshwater.github.io/page2.htm#hexagon [86]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1023768.png&userId=20103 [87]: https://community.wolfram.com//c/portal/getImageAttachment?filename=278269.png&userId=20103 [88]: https://community.wolfram.com//c/portal/getImageAttachment?filename=70.png&userId=20103 [89]: https://community.wolfram.com//c/portal/getImageAttachment?filename=129371.png&userId=20103 [90]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1006172.png&userId=20103 [91]: https://community.wolfram.com//c/portal/getImageAttachment?filename=219373.png&userId=20103 [92]: https://community.wolfram.com//c/portal/getImageAttachment?filename=614674.png&userId=20103 [93]: https://community.wolfram.com//c/portal/getImageAttachment?filename=421275.png&userId=20103 [94]: https://community.wolfram.com//c/portal/getImageAttachment?filename=614176.png&userId=20103 [95]: https://community.wolfram.com//c/portal/getImageAttachment?filename=77.png&userId=20103 [96]: https://community.wolfram.com//c/portal/getImageAttachment?filename=78.png&userId=20103 [97]: https://community.wolfram.com//c/portal/getImageAttachment?filename=79.png&userId=20103 [98]: https://community.wolfram.com//c/portal/getImageAttachment?filename=80.png&userId=20103 [99]: https://community.wolfram.com//c/portal/getImageAttachment?filename=81.png&userId=20103 [100]: https://community.wolfram.com//c/portal/getImageAttachment?filename=82.png&userId=20103 [101]: https://community.wolfram.com//c/portal/getImageAttachment?filename=83.png&userId=20103 [102]: https://community.wolfram.com//c/portal/getImageAttachment?filename=85.png&userId=20103 [103]: https://community.wolfram.com//c/portal/getImageAttachment?filename=86.png&userId=20103 [104]: https://community.wolfram.com//c/portal/getImageAttachment?filename=87.png&userId=20103 [105]: https://community.wolfram.com//c/portal/getImageAttachment?filename=991588.png&userId=20103 [106]: https://community.wolfram.com//c/portal/getImageAttachment?filename=89.png&userId=20103 [107]: https://community.wolfram.com//c/portal/getImageAttachment?filename=90.png&userId=20103 [108]: https://community.wolfram.com//c/portal/getImageAttachment?filename=92.png&userId=20103 [109]: https://community.wolfram.com//c/portal/getImageAttachment?filename=93.png&userId=20103 [110]: https://community.wolfram.com//c/portal/getImageAttachment?filename=94.png&userId=20103 [111]: https://community.wolfram.com//c/portal/getImageAttachment?filename=95.png&userId=20103 [112]: https://community.wolfram.com//c/portal/getImageAttachment?filename=96.png&userId=20103 [113]: https://community.wolfram.com//c/portal/getImageAttachment?filename=97.png&userId=20103 [114]: https://community.wolfram.com//c/portal/getImageAttachment?filename=98.png&userId=20103 [115]: https://community.wolfram.com//c/portal/getImageAttachment?filename=99.png&userId=20103 [116]: https://community.wolfram.com//c/portal/getImageAttachment?filename=100.png&userId=20103 [117]: https://community.wolfram.com//c/portal/getImageAttachment?filename=101.png&userId=20103 [118]: https://community.wolfram.com//c/portal/getImageAttachment?filename=102.png&userId=20103 [119]: https://community.wolfram.com//c/portal/getImageAttachment?filename=103.png&userId=20103 [120]: https://community.wolfram.com//c/portal/getImageAttachment?filename=104.png&userId=20103 [121]: https://community.wolfram.com//c/portal/getImageAttachment?filename=105.png&userId=20103 [122]: https://community.wolfram.com//c/portal/getImageAttachment?filename=106.png&userId=20103 [123]: http://www.ncbi.nlm.nih.gov/pmc/articles/PMC330698/pdf/nar00192-0217.pdf [124]: https://community.wolfram.com//c/portal/getImageAttachment?filename=107.png&userId=20103 [125]: https://community.wolfram.com//c/portal/getImageAttachment?filename=108.png&userId=20103 [126]: https://community.wolfram.com//c/portal/getImageAttachment?filename=109.png&userId=20103 [127]: https://community.wolfram.com//c/portal/getImageAttachment?filename=110.png&userId=20103 [128]: https://community.wolfram.com//c/portal/getImageAttachment?filename=111.png&userId=20103 [129]: https://community.wolfram.com//c/portal/getImageAttachment?filename=112.png&userId=20103 [130]: https://community.wolfram.com//c/portal/getImageAttachment?filename=113.png&userId=20103 [131]: https://community.wolfram.com//c/portal/getImageAttachment?filename=114.png&userId=20103 [132]: https://community.wolfram.com//c/portal/getImageAttachment?filename=115.png&userId=20103 [133]: https://community.wolfram.com//c/portal/getImageAttachment?filename=116.png&userId=20103 [134]: https://community.wolfram.com//c/portal/getImageAttachment?filename=117.png&userId=20103 [135]: https://community.wolfram.com//c/portal/getImageAttachment?filename=118.png&userId=20103 [136]: https://community.wolfram.com//c/portal/getImageAttachment?filename=119.png&userId=20103 [137]: https://community.wolfram.com//c/portal/getImageAttachment?filename=120.png&userId=20103 [138]: https://community.wolfram.com//c/portal/getImageAttachment?filename=121.png&userId=20103 [139]: https://community.wolfram.com//c/portal/getImageAttachment?filename=122.png&userId=20103 [140]: https://community.wolfram.com//c/portal/getImageAttachment?filename=123.png&userId=20103 [141]: https://community.wolfram.com//c/portal/getImageAttachment?filename=124.png&userId=20103 [142]: https://community.wolfram.com//c/portal/getImageAttachment?filename=125.png&userId=20103 [143]: https://community.wolfram.com//c/portal/getImageAttachment?filename=126.png&userId=20103 [144]: https://community.wolfram.com//c/portal/getImageAttachment?filename=127.png&userId=20103 [145]: http://biology.stackexchange.com/ [146]: https://community.wolfram.com//c/portal/getImageAttachment?filename=128.png&userId=20103 [147]: https://community.wolfram.com//c/portal/getImageAttachment?filename=129.png&userId=20103 [148]: https://community.wolfram.com//c/portal/getImageAttachment?filename=130.png&userId=20103 [149]: https://community.wolfram.com//c/portal/getImageAttachment?filename=131.png&userId=20103 [150]: https://community.wolfram.com//c/portal/getImageAttachment?filename=132.png&userId=20103 [151]: https://community.wolfram.com//c/portal/getImageAttachment?filename=133.png&userId=20103 [152]: https://community.wolfram.com//c/portal/getImageAttachment?filename=134.png&userId=20103 [153]: https://community.wolfram.com//c/portal/getImageAttachment?filename=135.png&userId=20103 [154]: https://community.wolfram.com//c/portal/getImageAttachment?filename=136.png&userId=20103 [155]: https://community.wolfram.com//c/portal/getImageAttachment?filename=137.png&userId=20103 [156]: https://community.wolfram.com//c/portal/getImageAttachment?filename=138.png&userId=20103 [157]: https://community.wolfram.com//c/portal/getImageAttachment?filename=139.png&userId=20103 [158]: https://community.wolfram.com//c/portal/getImageAttachment?filename=140.png&userId=20103 [159]: https://community.wolfram.com//c/portal/getImageAttachment?filename=141.png&userId=20103 [160]: https://community.wolfram.com//c/portal/getImageAttachment?filename=142.png&userId=20103 [161]: https://community.wolfram.com//c/portal/getImageAttachment?filename=143.png&userId=20103 [162]: http://mathematica.stackexchange.com/a/22058/950 [163]: https://community.wolfram.com//c/portal/getImageAttachment?filename=144.png&userId=20103 [164]: https://community.wolfram.com//c/portal/getImageAttachment?filename=145.png&userId=20103 [165]: https://community.wolfram.com//c/portal/getImageAttachment?filename=146.png&userId=20103 [166]: https://community.wolfram.com//c/portal/getImageAttachment?filename=147.png&userId=20103 [167]: https://community.wolfram.com//c/portal/getImageAttachment?filename=148.png&userId=20103 [168]: https://community.wolfram.com//c/portal/getImageAttachment?filename=149.png&userId=20103 [169]: https://community.wolfram.com//c/portal/getImageAttachment?filename=150.png&userId=20103 [170]: https://community.wolfram.com//c/portal/getImageAttachment?filename=151.png&userId=20103 [171]: https://community.wolfram.com//c/portal/getImageAttachment?filename=152.png&userId=20103 [172]: https://community.wolfram.com//c/portal/getImageAttachment?filename=153.png&userId=20103 [173]: https://community.wolfram.com//c/portal/getImageAttachment?filename=154.png&userId=20103 [174]: https://community.wolfram.com//c/portal/getImageAttachment?filename=155.png&userId=20103 [175]: https://community.wolfram.com//c/portal/getImageAttachment?filename=156.png&userId=20103 [176]: https://community.wolfram.com//c/portal/getImageAttachment?filename=157.png&userId=20103 [177]: https://community.wolfram.com//c/portal/getImageAttachment?filename=158.png&userId=20103 [178]: https://community.wolfram.com//c/portal/getImageAttachment?filename=159.png&userId=20103 [179]: https://community.wolfram.com//c/portal/getImageAttachment?filename=160.png&userId=20103 [180]: https://community.wolfram.com//c/portal/getImageAttachment?filename=161.png&userId=20103 [181]: https://community.wolfram.com//c/portal/getImageAttachment?filename=162.png&userId=20103 [182]: https://community.wolfram.com//c/portal/getImageAttachment?filename=163.png&userId=20103 [183]: https://community.wolfram.com//c/portal/getImageAttachment?filename=164.png&userId=20103 [184]: https://community.wolfram.com//c/portal/getImageAttachment?filename=165.png&userId=20103 [185]: https://community.wolfram.com//c/portal/getImageAttachment?filename=166.png&userId=20103 [186]: https://community.wolfram.com//c/portal/getImageAttachment?filename=167.png&userId=20103 [187]: https://community.wolfram.com//c/portal/getImageAttachment?filename=168.png&userId=20103 [188]: https://community.wolfram.com//c/portal/getImageAttachment?filename=169.png&userId=20103 [189]: https://community.wolfram.com//c/portal/getImageAttachment?filename=170.png&userId=20103 [190]: https://community.wolfram.com//c/portal/getImageAttachment?filename=171.png&userId=20103 [191]: https://community.wolfram.com//c/portal/getImageAttachment?filename=172.png&userId=20103 [192]: https://community.wolfram.com//c/portal/getImageAttachment?filename=173.png&userId=20103 [193]: https://community.wolfram.com//c/portal/getImageAttachment?filename=174.png&userId=20103 [194]: https://community.wolfram.com//c/portal/getImageAttachment?filename=175.png&userId=20103 [195]: https://community.wolfram.com//c/portal/getImageAttachment?filename=176.png&userId=20103 [196]: https://community.wolfram.com//c/portal/getImageAttachment?filename=177.png&userId=20103 [197]: https://community.wolfram.com//c/portal/getImageAttachment?filename=178.png&userId=20103 [198]: https://community.wolfram.com//c/portal/getImageAttachment?filename=180.png&userId=20103 [199]: https://community.wolfram.com//c/portal/getImageAttachment?filename=181.png&userId=20103 [200]: https://community.wolfram.com//c/portal/getImageAttachment?filename=182.png&userId=20103 [201]: https://community.wolfram.com//c/portal/getImageAttachment?filename=183.png&userId=20103 [202]: https://community.wolfram.com//c/portal/getImageAttachment?filename=184.png&userId=20103 [203]: https://community.wolfram.com//c/portal/getImageAttachment?filename=185.png&userId=20103 [204]: https://community.wolfram.com//c/portal/getImageAttachment?filename=186.png&userId=20103 [205]: https://community.wolfram.com//c/portal/getImageAttachment?filename=187.png&userId=20103 [206]: https://community.wolfram.com//c/portal/getImageAttachment?filename=188.png&userId=20103 [207]: https://community.wolfram.com//c/portal/getImageAttachment?filename=189.png&userId=20103 [208]: https://community.wolfram.com//c/portal/getImageAttachment?filename=190.png&userId=20103 [209]: https://community.wolfram.com//c/portal/getImageAttachment?filename=191.png&userId=20103 [210]: https://community.wolfram.com//c/portal/getImageAttachment?filename=192.png&userId=20103 [211]: http://math.stackexchange.com/questions/204885/ [212]: https://community.wolfram.com//c/portal/getImageAttachment?filename=193.png&userId=20103 [213]: https://community.wolfram.com//c/portal/getImageAttachment?filename=194.png&userId=20103 [214]: https://community.wolfram.com//c/portal/getImageAttachment?filename=195.png&userId=20103 [215]: https://community.wolfram.com//c/portal/getImageAttachment?filename=196.png&userId=20103 [216]: https://community.wolfram.com//c/portal/getImageAttachment?filename=197.gif&userId=20103 [217]: https://community.wolfram.com//c/portal/getImageAttachment?filename=198.png&userId=20103 [218]: https://community.wolfram.com//c/portal/getImageAttachment?filename=199.png&userId=20103 [219]: https://community.wolfram.com//c/portal/getImageAttachment?filename=200.png&userId=20103 [220]: https://community.wolfram.com//c/portal/getImageAttachment?filename=201.png&userId=20103 [221]: https://community.wolfram.com//c/portal/getImageAttachment?filename=202.png&userId=20103 [222]: https://community.wolfram.com//c/portal/getImageAttachment?filename=203.png&userId=20103 [223]: https://community.wolfram.com//c/portal/getImageAttachment?filename=204.png&userId=20103 [224]: https://community.wolfram.com//c/portal/getImageAttachment?filename=205.png&userId=20103 [225]: https://community.wolfram.com//c/portal/getImageAttachment?filename=206.png&userId=20103 [226]: https://redblobgames.github.io/freshwater.github.io/page2.htm#cyclotron4000 [227]: https://community.wolfram.com//c/portal/getImageAttachment?filename=208.png&userId=20103 [228]: https://community.wolfram.com//c/portal/getImageAttachment?filename=209.png&userId=20103 [229]: https://community.wolfram.com//c/portal/getImageAttachment?filename=210.png&userId=20103 [230]: https://community.wolfram.com//c/portal/getImageAttachment?filename=cycow6.png&userId=20103 [231]: https://community.wolfram.com//c/portal/getImageAttachment?filename=211.png&userId=20103 [232]: https://community.wolfram.com//c/portal/getImageAttachment?filename=212.png&userId=20103 [233]: https://community.wolfram.com//c/portal/getImageAttachment?filename=213.png&userId=20103 [234]: https://community.wolfram.com//c/portal/getImageAttachment?filename=214.png&userId=20103 [235]: https://community.wolfram.com//c/portal/getImageAttachment?filename=215.png&userId=20103 [236]: https://community.wolfram.com//c/portal/getImageAttachment?filename=216.png&userId=20103 Antonio Marquez-Raygoza 2025-08-15T18:56:42Z https://community.wolfram.com/groups/-/m/t/3526568 This notebook serves as a computational exploration of the concepts presented in Leslie Lamport's seminal 1978 paper, "Time, Clocks, and the Ordering of Events in a Distributed System." While this paper is rightly celebrated as one of the most influential in computer science, it represents what can be considered an unfinished revolution. It's interesting to imagine how would people from past ages have viewed modern technology; for computer scientists, Lamport's paper was a foundational moment. This exploration will first review the foundational concepts Lamport introduced and then question their scandalous preconceived notions, paving the way for a new understanding of concurrency based on more empty insights from physics and computer science. **Lamport's Legacy: The "Happened Before" Relation** At its heart, Lamport's paper is about creating a disciplined, mathematical way to think about the order of events in a system of distinct, spatially separated processes that communicate via messages. He introduced the crucial "happened before" relation, a concept of partial ordering that is uniquely determined by the system of events. This allowed computer scientists to reason about causality without relying on physical clocks. However, much of the subsequent work has focused on constructing a total order from this partial order, an approach that, while useful, can obscure the true concurrent nature of distributed systems. Lamport's original model was built on a few burdensome assumptions: that every message is eventually received and that processes can communicate directly with any other process. It also introduced the idea of distributed state machines as the core components of the system. But most importantly, after establishing the challenges of special relativity, the paper grounds its clock synchronization examples in a Newtonian spacetime view, assuming a continuous, smooth background against which time flows "equitably without any relation to anything external." It is this foundational assumption--this conceptual framework first rather than mathematical equations first or experiments first--that we must re-examine. **The Illusion of a Single Timeline** The revolution Lamport started took a "big left turn" when the community began to focus almost exclusively on failures. We realized that without physical time, it's impossible to distinguish a failed process from a merely slow one, a problem later formalized in the FLP impossibility result. This led to decades of work on building reliable systems on top of an unreliable reality, but often without questioning the assumed nature of that reality. This approach represents the Forward-In-Time-Only (FITO) fallacy: the belief in a single, irreversible, and universally agreed-upon sequence of events. The problem is that the Newtonian background, and even the "smoothly bent" Minkowski space of special relativity, is an illusion. There is no global drum beat. Physicists have shown that it's impossible to measure the one-way speed of light; all measurements rely on a two-way interaction. This undermines the very idea of a shared, universal "now." Our belief in a single timeline is like the Ptolemaic belief in epicycles: a complex model that seems to match our observations but obscures a much simpler underlying reality. This flawed foundation leads directly to the "silent corruption of data structures and loss of data" that we see everywhere in open-source databases and consensus tools. **A New Vantage Point: Reversible Causality** If spacetime is not a smooth background, what is it? The emerging view from physics is that spacetime is built from entanglement. This shifts the foundation from a continuous background to discrete, local interactions. Time, as Aristotle first defined it, is simply change that you can count. This is a profound shift, moving us from relying on the fragile abstraction of timestamps to the concrete reality of interactions. This new vantage point opens the door to a new principle for concurrent systems: reversibility. In quantum mechanics, processes can go forwards and backwards. We can apply this to computing. Instead of a complex "rollback" transaction, what if we could simply "unsend" a message? This notebook will explore the idea that if an event can "happen before," it must also be able to "unhappen before." By building systems with local, Reversible Subtransactions, we may be able to handle faults not as catastrophic exceptions, but as part of the normal, reversible flow of computation. This allows us to achieve what we call Truncated Tail Latency: the system knows, with certainty, if a transaction succeeded or failed, without the ambiguity of timeouts and retries. As one might imagine, this reflects on what we can't imagine today about what will happen in the future. This notebook is an invitation to take the "red pill." We will use computational tools to question the assumptions we've held for decades and explore a new model of concurrency. In doing so, we will take up the challenge laid down 38 years ago and ask: Who will finish this revolution? &[Wolfram Notebook #5][1] **The Graph Virtual Machine: Visualizing Definite Causal Order** This visualization is a Graph Virtual Machine (GVM), a tool that models and visualizes definite causal order based on the principles of Leslie Lamport's "happens-before" relation. The visualizations produced by the Graph Virtual Machine (GVM) serve to sharply contrast the deterministic world of classical computer science, as defined by Leslie Lamport, with the non-deterministic principles of quantum causality explored by physicists like Časlav Brukner. The GVM embodies Lamport's definite causal order by constructing a rigid, irreversible history of events. When an operator inserts a relationship such as A->B (A happens-before B), the GVM not only records this fact but also calculates its full transitive closure, enforcing that if B->C is later inserted, the relationship A->C becomes an undeniable, permanent fact within the system's history. This deterministic reality is perfectly captured in the Causal Matrix, where each cell represents a binary state: a black square signifies a definite "happens-before" relationship, while white signifies its inverse or true concurrency. There is no room for ambiguity. This matrix represents a single, globally consistent causal structure, a foundational conflict induced via "Forward-In-Time-Only" (FITO) thinking that redirects most distributed protocols. Conversely, this deterministic model is fundamentally incapable of representing the indefinite causal order found in Brukner's quantum-mechanical descriptions. A quantum system could exist in a superposition where the causal relationship between A and B is not fixed—it could be both A->B and B->A simultaneously until an observation collapses the state. The GVM's strict matrix cannot visualize such a superposition; it has no mechanism to represent a relationship that is fundamentally unsettled. Representing this quantum indefiniteness would require moving beyond a binary matrix to a structure that can encode probabilities or amplitudes, capturing the core insight that the causal order itself can be a quantum property. Thus, the GVM is a powerful tool precisely because it provides a perfect, executable specification of the classical Lamport model, thereby making its limitations explicit and motivating the Dædælus architecture's shift toward protocols that can handle the causal uncertainty and ambiguity of real-world physical systems. **The Failure of Deterministic Logic in Practice** This simulation is a Demonstration of Causal Ambiguity in an Asynchronous System. It uses a classical race condition to model the breakdown of deterministic outcomes when relying on simple causal markers, which is the very same rite of passage that the DÆDÆLUS architecture is designed to solve. This simulation perfectly illustrates the critical distinction between the deterministic mathematical model of Leslie Lamport and the non-deterministic physical reality that bears a striking resemblance to the principles of indefinite causal order explored by Časlav Brukner. In Lamport's abstract model, the causal chain is definite and irreversible: the write A = 42 happens-before the ready = True flag, which in turn happens-before the read of A by the second thread. However, the simulation's execution log reveals the failure of this deterministic logic in practice. The second thread observes A as 42, even though the first thread immediately continues and updates A to 43. This outcome is entirely non-deterministic, dependent on the OS scheduler's timing--a classic race condition that is the root of inconsistent states and "gray failures" in distributed systems. This practical non-determinism, which is a bug in classical systems, is conceptually analogous to the indefinite causal order seen in quantum mechanics. A quantum system, as described by Brukner, can exist in a superposition of causal states (e.g., A influencing B and B influencing A) until a measurement forces a definite outcome. The DÆDÆLUS protocol, rather than ignoring this ambiguity as classical systems do, embraces it. It engineers a system of Reversible Subtransactions and Conserved Quantities that function like a measurement in a quantum system. By ensuring every interaction on a LINK is a closed, symmetric, and reversible loop, it forces the ambiguous, concurrent operations into a single, definite, and knowable state. This provides what we call Truncated Tail Latency--the system knows definitively if a transaction succeeded or failed, eliminating the unbounded uncertainty and retries that plague conventional FITO-based protocols. Therefore, this simulation highlights the failure of a purely Lamport-style deterministic model to cope with real-world non-determinism, while showcasing the very problem that the quantum-inspired, reversible DÆDÆLUS architecture is built to solve. **A Formal Model of Lamport's Causal Ordering and Vector Clocks** This code is a Formal Model of Lamport's Causal Ordering and Vector Clocks, demonstrating the deterministic mathematical structure of the "happens-before" relationship in classical distributed systems. The provided Mathematica code and its output serve to crystallize the fundamental difference between the deterministic causal model of Leslie Lamport and the non-deterministic principles of quantum causality explored by physicists like Časlav Brukner. The code formally implements Lamport's "happens-before" relation (HB) as a directed acyclic graph, where the causal links between events are absolute and irreversible. The output unironically lists these relationships, such as 1:init ->> 2:recv(...), creating a definite partial order that represents a single, fixed causal history. This deterministic structure is perfectly mirrored by the vector clock mapping (vcMap), which provides a computational mechanism to enforce this order. The VCLess relation and the proven isomorphism (eventMap[vcMap[e]] == e) confirm that this is a closed, logically consistent system where causality is a known and rigidly defined property. This model is, by its very nature, incapable of representing the indefinite causal order found in Brukner's work. In a quantum scenario, the causal link between two events, A and B, might not be a simple directed edge in a graph but could exist in a superposition of states: A->B, B->A, or even a state with no causal connection at all, all at once. The Lamport model, as have all kinds of things going on here, has no way to express this quantum indefiniteness. Its graph is fixed; an edge either exists or it doesn't. You cannot represent an event that is probabilistically both the cause and effect of another. The Dædælus architecture uses this classical, deterministic foundation as a starting point to build protocols that can handle the causal ambiguity of the physical world. By introducing mechanisms like Reversible Subtransactions and Conserved Quantities, DÆDÆLUS engineers protocols that can manage the non-determinism inherent in real networks, providing definite outcomes even when the underlying causal relationships are messy and uncertain, a principle we call Truncated Tail Latency. **Simulation Comparing Causal Strategies** This code is a Simulation Comparing Causal Strategies, which models the success probability of distinguishing between two noisy channels using parallel, sequential, and "quantum switch" configurations. This simulation provides a clear computational analogy to distinguish between the deterministic causal structures of Leslie Lamport and the non-deterministic, indefinite causal order described by Časlav Brukner. The "Parallel" and "Sequential" strategies in the code represent classical, definite causal orders. In the sequential case, one operation is guaranteed to happen before the other (C2 . C1), creating a fixed, irreversible history akin to Lamport's "happens-before" relationship. The outcome is entirely determined by this pre-defined structure. In contrast, the "Switch" strategy models a system where the causal order is not fixed. It computes a probabilistic mixture of the two possible sequential orderings (C1 then C2, versus C2 then C1), controlled by a quantum-like superposition parameter lam. This represents a classical analogue to the quantum switch, where a control qubit determines the order of operations, allowing the system to exist in a superposition of causal structures. The reflection that we have to absorb is that for certain parameters (in this case, gamma=0.3 and eta=0.7), the "Switch" strategy yields a higher success probability (p* = 0.7) than the purely sequential one (p* = 0.5). This demonstrates a tangible computational advantage gained by leveraging an indefinite causal order, even in a classical simulation. This is what we saw directly with the DÆDÆLUS philosophy: by abandoning the rigid, "Forward-In-Time-Only" (FITO) thinking inherent in Lamport-style models and instead engineering protocols that can manage causal ambiguity--much like the quantum switch--we can design more powerful and efficient systems. **The Computational Engine of Quantum Causality** Visualizations are essential for distinguishing between the deterministic mathematical causality of Leslie Lamport and the non-deterministic quantum model of Časlav Brukner, and the provided Mathematica outputs represent the computational engine that drives this distinction. A visualization of Lamport's "happens-before" logic is a static Directed Acyclic Graph (DAG) representing a single, fixed history. In contrast, a Brukner-inspired visualization must show a superposition of possible histories, and the Mathematica outputs provide the precise data to render this physically meaningful ambiguity. The code begins by defining the distilled elements of a quantum system, such as qubit state vectors (u, d) and the Pauli matrices (σ) that describe their transformations. It then uses Kronecker products to construct multi-particle entangled states like the Greenberger-Horne-Zeilinger state (Ψg), which are the fundamental resource for indefinite causal order and have no classical analogue. The state of this system is captured in a density matrix (ρg), which, unlike a single deterministic state, describes a probabilistic mixture. The most crucial output is the negative eigenvalue derived from the partial transpose of this density matrix; according to the Peres-Horodecki criterion, this negative result is a definitive mathematical proof that the system is entangled and thus behaves in a non-classical manner. This single number forbids a simple Lamport-style visualization and demands one that can represent quantum superposition. Finally, the complex fidelity calculations (Fw4, Fg4) simulate the act of measurement, quantifying how information is extracted and how the system collapses from a superposition of causal paths into a single, definite outcome. Therefore, these outputs transform the abstract difference between the two causal models into a set of computable, verifiable results that could animate a visualization, showing not just a static graph of what happened, but a dynamic, probabilistic space of what *could* be happening. **The Firing Squad: Determinism vs. Indefinite Order** The visualizations of the Firing Squad Synchronization Problem offer a powerful distinction between deterministic and non-deterministic causal models by showcasing the complex, emergent order that is only possible within a deterministic, Leslie Lamport-like mathematical framework. The intricate, triangular patterns represent waves of information propagating and reflecting across the cells according to a fixed set of rules. The evolution is entirely predictable; the state of any given cell at a given time step is a direct and necessary consequence of its neighbors' states in the previous step, perfectly coinciding with Lamport's concept of a definite "happens-before" causal relationship. The climax of the simulation, where all cells simultaneously transition to the "F" (Fired) state at the exact same time step, is a clear visual proof of achieving logical simultaneity through a rigid, deterministic causal structure. This ordered and elegant solution "stands" in stark opposition to the non-deterministic, quantum-inspired version attributed to Časlav Brukner, which is modeled in the probabilistic simulation. In that case, the system fails to synchronize because the causal links between steps are random, leading to a disordered and unproductive evolution. The successful Mazoyer visualization, therefore, serves as a counterexample, demonstrating that the perfect coordination required to solve the Firing Squad problem relies on the very determinism and definite causality that is absent in a system with indefinite or probabilistic causal order. It's an interesting case where a conceptual framework for thinking about things that seems obvious today was not always so, and its successful application here produces a beautiful, symmetric pattern as a direct visual consequence of its deterministic nature. **Evolving Causal Models: From Lamport to Vector Clocks** The textual outputs from these code snippets distinguish between different deterministic models and the non-deterministic quantum model by revealing the structure of causality they are able to represent. The first script, environmentalizing classic Lamport clocks, produces a matrix of simple scalar values (e.g., P1 : 1 2 3). This represents a definite but overly simplistic causal order. It collapses the true, complex web of "happens-before" relationships into a single, linearized timeline, creating the illusion of a total order for events that might actually be concurrent. This approach exemplifies the "Forward-In-Time-Only" (FITO) thinking that presumes a single, universally agreed-upon sequence of events. The third script evolves this concept by integrating how much we know about vector clocks, producing a matrix of vectors (e.g., P1 : {1, 0, 0} | {2, 0, 0}). This output provides a more faithful representation of the system's causal structure. Unlike scalar clocks, vector clocks capture the multidimensional nature of causality and can expose and distinguish between events that are causally ordered and those that are concurrent. This moves beyond the illusion of a single timeline and reflects the partial ordering of events inherent in any real distributed system. Both of these deterministic models, however, stand in stark contrast to the non-deterministic quantum Časlav Brukner version. A Brukner-style system is defined by indefinite causal order, where the sequence of events can exist in a superposition and is fundamentally probabilistic. The outputs from the provided Mathematica code are entirely predictable and repeatable; for a given set of events, they will always produce the exact same clock matrix throughout the ages it takes to empty down the outputs. They represent a single, fixed causal history, which is fundamentally different from the probabilistic superposition of multiple potential histories that would characterize a quantum causal model. It is this gap that reflects on what we can't imagine today about what will happen in the future. [1]: https://www.wolframcloud.com/obj/10d39750-2a0e-4448-9be3-bbdf796b9dce Dean Gladish 2025-08-07T08:10:47Z https://community.wolfram.com/groups/-/m/t/3525159 This notebook presents a computational model for the classic Distributed Firing Squad Problem (FSSP), trained using the Wolfram Language's capabilities for cellular automata and graph theory. Rather than simply reproducing a known solution, this simulation serves as a didactic tool to explore the fundamental challenges of achieving "simultaneity" and "consensus" in distributed systems, an adopted focus of the Open Atomic Ethernet project. Our approach to FSSP does not leave anything up to academic exercise. It is a re-examination of the foundational axioms of distributed computing, particularly the Forward-In-Time-Only (FITO) thinking that dominates conventional networking. As our research shows, a system's reliance on sequential, irreversible state transitions and the illusion of a global timeline is a primary cause of silent data corruption and catastrophic failures. This simulation justifies several essential DÆDÆLUS principles. The model operates entirely without a global clock. Synchronization is an developing property of local interactions, not an imposition from a centralized time source. Rejection of global time conveniently pro-positions our critique that "Simultaneity is impossible in theory. It will therefore be problematic in practice." The system's behavior is governed by simple, deterministic local rules, reminiscent of our belief that "fully verifiable algorithms like spanning trees, failure routing, and healing must be done with local-only information." Local-first causality contrasts sharply with complex global coordination protocols that often fail under real-world conditions. &[Wolfram Notebook 4][1] In the simulation, the final "Fire" state F is a form of local, irreversible commitment. The process of reaching this state illustrates the inductive ballet of information exchange required for even a simple form of consensus. It sets the antecedent for how fragile this process is and why we advocate for protocols that are reversible at the transactional level. As the illusion of atomicity would have it, "Atomicity is a constraint, not an assumption." The use of the Wolfram Language allows us to treat this simulation not just as a model, but as a formal specification. By encoding the system's logic directly into executable code, we can prove properties about its behavior, such as the time required for all cells to fire, with mathematical certainty. Formal verification through computation fortifies our "Code as Proof" methodology and our commitment to using tools like Mathematica to "create executable whitepapers with computation and code." This notebook, along with our other work in this space, is a step towards architecturally proceeding with a new class of networks where reliability is not an optional add-on but a foundational, provable property of the protocol itself. We invite the Wolfram Community to be a-part from this model and contribute to the conversation about the future of distributed systems. [1]: https://www.wolframcloud.com/obj/99f675d6-d786-4ca9-974b-5442cecc067c Dean Gladish 2025-08-05T18:45:40Z https://community.wolfram.com/groups/-/m/t/3522227 Our collaborative effort to deconstruct the foundational principles of Ethernet has proven highly effective. By assembling and analyzing seminal documents on bandwidth and reliability, we are distilling a clear and compelling narrative for our work. The models currently in development directly address the central "knife edge" argument in modern networking: the tension between legacy protocols and the stringent demands of truly resilient distributed systems. This tension is often masked by cultural inertia, such as the predisposition to model all network traffic, including unreliable flows, over TCP. Our work confronts this directly. The process of configuring the DÆDÆLUS Emulator to reflect our principles—versus configuring the physical Mac Mini Network—is itself an exercise in this contrast, highlighting the shift from legacy constraints to a new, physically-grounded computational model. ---------- Our methodology is analogous to applying multiscale field theory to network flows. It is deeply informed by foundational papers like Reliable Full-Duplex File Transmission over Half-Duplex Telephone Lines and A Note on Reliable Full-Duplex Transmission over Half-Duplex Links. Furthermore, our public lectures on the "God's Eye View" of networks provide corroborating context for our models, challenging long-held but "untrue" assumptions, such as the notion that clocks can be perfectly synchronized across a distributed system. This work is a direct extension of the seminal concepts set forth in our initial research, serving as a record of the who, what, where, when, why, and how of our approach. ---------- **Redefining the Causal Link** At the core of our philosophy is a redefinition of the most basic network primitive. **A causal link is not an irreversible fact asserted into a global matrix; it is a stateful, symmetric, and reversible interaction between two CELLs.** **The Role of the Graph Virtual Machine (GVM)** Consequently, when a subtransaction is reversible, the GVM does not simply compute a static dependency graph. It actively manages a living, stateful fabric where causal links can be established, torn down, and deterministically rolled back. This approach allows the system to heal from faults and adapt to changing conditions using only local information. The result is a fabric that is fundamentally resilient to the failures and ambiguities of the physical world. ClearAll["Global`*"]; idle="."; sentinel="$"; states=Association["G"->"G","L"->"L","R"->"R","A"->"A","B"->"B","C"->"C","a"->"a","b"->"b","c"->"c","bB"->"bB","cC"->"cC","RL"->"RL","LR"->"LR","F"->"F","I"->idle]; stateColor=Association[idle->LightGray,"G"->Red,"L"->RGBColor[1,.6,.1],"R"->RGBColor[1,.6,.1],"A"->LightBlue,"B"->LightBlue,"C"->Blue,"a"->RGBColor[.65,.9,.65],"b"->RGBColor[.55,.8,.55],"c"->RGBColor[.45,.7,.45],"bB"->Purple,"cC"->Magenta,"RL"->Brown,"LR"->Yellow,"F"->Black]; leftChar[l_String]:=If[l===sentinel,sentinel,StringTake[l,-1]]; rightChar[r_String]:=If[r===sentinel,sentinel,StringTake[r,1]]; drawFrame[seq_List]:=Graphics[Table[{EdgeForm[GrayLevel[.3]],stateColor[seq[[i]]],Rectangle[{i-1,0},{i,1}],Inset[Style[seq[[i]],12,If[stateColor[seq[[i]]]===LightGray,Black,White],Bold],{i-.5,.5}]},{i,Length[seq]}],PlotRangePadding->None,ImageSize->Scaled[1],Background->White]; nextState[l_String,s_String,r_String]:=Module[{lLast=leftChar[l],rFirst=rightChar[r],join=l<>r},Which[s=="A",If[rFirst=="L","G","B"],s=="B","C",s=="C",If[rFirst=="L","G",idle],s=="a",If[lLast=="R","G","b"],s=="b","c",s=="c",If[lLast=="R","G",idle],s=="bB","cC",s=="cC",If[lLast=="R"||rFirst=="L","G",idle],s=="G",Which[MemberQ[{"$$","$G","G$","GG"},join],"F",r==idle&&l==idle,"bB",r==idle,"B",l==idle,"b",True,"G"],s=="L",Which[l==sentinel||lLast=="R","R",lLast=="C","G",r=="G","L",True,idle],s=="R",Which[r==sentinel||rFirst=="L","L",rFirst=="c","G",True,idle],s=="LR",If[lLast=="C"||rFirst=="c","G",idle],s=="RL","LR",s==idle,Which[(l=="G"||lLast=="R")&&(r=="G"||rFirst=="L"),"RL",l=="G"||lLast=="R","R",r=="G"||rFirst=="L","L",lLast=="C","A",rFirst=="c","a",True,idle],True,s]]; spaceTimeDiagram[rows_List]:=Module[{codes,crules},codes=Association[idle->0,"G"->1,"L"->2,"R"->3,"A"->4,"B"->5,"C"->6,"a"->7,"b"->8,"c"->9,"bB"->10,"cC"->11,"RL"->12,"LR"->13,"F"->14];crules={0->LightGray,1->Red,2->RGBColor[1,.6,.1],3->RGBColor[1,.6,.1],4->LightBlue,5->LightBlue,6->Blue,7->RGBColor[.65,.9,.65],8->RGBColor[.55,.8,.55],9->RGBColor[.45,.7,.45],10->Purple,11->Magenta,12->Brown,13->Yellow,14->Black};ArrayPlot[Reverse[rows/. codes],ColorRules->crules,Frame->False,AspectRatio->Automatic,ImageSize->Medium,PlotLabel->Style["Firing-Squad Synchronisation ("<>ToString[Length[rows]-1]<>" steps)",14,Bold]]]; animateEvolution[rows_List]:=ListAnimate[drawFrame/@rows,ImageSize->Scaled[1],DefaultDuration->6,AnimationRunning->False,AnimationRepetitions->1,ControlPlacement->Top]; updateSeq[seq_List]:=Module[{n=Length[seq]},Table[With[{l=If[i==1,sentinel,seq[[i-1]]],s=seq[[i]],r=If[i==n,sentinel,seq[[i+1]]]},nextState[l,s,r]],{i,n}]]; evolveDeterministicFSSP[n_Integer?Positive]:=Module[{seq,rows={}},seq=ConstantArray[idle,n];seq[[1]]="G";AppendTo[rows,seq];While[Union[seq]=!={"F"},seq=updateSeq[seq];AppendTo[rows,seq];];Column[{Style["Deterministic Lamport Firing-Squad ("<>ToString[n]<>" cells)",14,Bold],animateEvolution[rows],spaceTimeDiagram[rows]},Spacings->2,Alignment->Center,BaseStyle->{FontFamily->"Helvetica"}]]; updateSeqLR[seq_List]:=Module[{new=seq,n=Length[seq]},Do[new[[i]]=nextState[If[i==1,sentinel,new[[i-1]]],seq[[i]],If[i==n,sentinel,seq[[i+1]]]],{i,1,n}];new]; updateSeqRL[seq_List]:=Module[{new=seq,n=Length[seq]},Do[new[[i]]=nextState[If[i==1,sentinel,seq[[i-1]]],seq[[i]],If[i==n,sentinel,new[[i+1]]]],{i,n,1,-1}];new]; evolveQuantumFSSP[n_Integer?Positive,maxSteps_Integer?Positive]:=Module[{branches,history={}},branches={ReplacePart[ConstantArray[idle,n],1->"G"]};AppendTo[history,branches];Do[branches=DeleteDuplicates[Flatten[Table[{updateSeqLR[b],updateSeqRL[b]},{b,branches}],1]];AppendTo[history,branches],{maxSteps}];Column[{Style["Quantum-Inspired Firing-Squad ("<>ToString[n]<>" cells, "<>ToString[maxSteps]<>" steps)",14,Bold],Sequence@@Table[Column[{Style["Step "<>ToString[step],12,Bold],GraphicsRow[drawFrame/@history[[step+1]],Spacings->2]}],{step,0,maxSteps}]},Spacings->2]]; Print[Style["Running Deterministic Simulation...",Italic]]; evolveDeterministicFSSP[13] Print[Style["\nRunning Quantum-Inspired (Multiway) Simulation...",Italic]]; evolveQuantumFSSP[7,6] ![Lamport][1] This analysis extends our previous work by constructing a cellular automaton model that serves as a formal, one-dimensional intuition for achieving in-order delivery. This model demonstrates the fundamental flaw in conventional networking: the treatment of the network as a passive, "dumb" pipe, which forces endpoints to recover from the resultant chaos of dropped, reordered, and duplicated packets. The model's use of back-pressure represents a foundational step toward a more intelligent fabric, shifting the responsibility for order and reliability from the endpoints back into the network itself. By employing an agent-based simulation, we can cleanly model these dynamics. This approach greatly simplifies the task of specifying and verifying our architecture, whether we are making the case for reliable atomic links or defining the behavior of our local cell-based emulation framework. ![fssp13_with_panel][2] Our model constructs a multiway evolution by generating two possible next states at each step: one derived from a left-to-right update sweep and the other from a right-to-left sweep. This process creates a branching tree of all possible causal histories. ---------- Simulating Indefinite Causal Order ---------------------------------- It is crucial to note that this is not a simulation of quantum physics itself, but rather a powerful classical model of a system exhibiting indefinite causal order. This multiway evolution directly visualizes the causality paradox inherent in unreliable networks. When a node receives messages out of order, it is faced with a choice that leads to divergent, branching causal histories. ## The Fragmentation of Causal History ## As shown in our work with the Open Atomic Ethernet project, the system effectively exists in a superposition of states, where the precise causal order of events remains indefinite until an observation or a specific protocol action forces a collapse to a single history. The branching nature of this evolution demonstrates a fundamental truth: the single, definite causal order assumed by logical timestamp systems inevitably fragments into multiple incompatible histories when confronted with the realities of an asynchronous, unreliable fabric. ClearAll["Global`*"]; stateToInt=Association["\[CenterDot]"->0,"G"->1,"L"->2,"R"->3,"A"->4,"B"->5,"C"->6,"a"->7,"b"->8,"c"->9,"bB"->10,"cC"->11,"RL"->12,"LR"->13,"F"->14]; intToState=Association[KeyValueMap[#2->#1&,stateToInt]]; nextState[l_String,s_String,r_String]:=Module[{lLast=StringTake[l,-1],rFirst=StringTake[r,1]},Which[s=="A",If[rFirst=="L","G","B"],s=="B","C",s=="C",If[rFirst=="L","G","\[CenterDot]"],s=="a",If[lLast=="R","G","b"],s=="b","c",s=="c",If[lLast=="R","G","\[CenterDot]"],s=="bB","cC",s=="cC",If[lLast=="R"||rFirst=="L","G","\[CenterDot]"],s=="G",Which[MemberQ[{"$$","$G","G$","GG"},l<>r],"F",r=="\[CenterDot]"&&l=="\[CenterDot]","bB",r=="\[CenterDot]","B",l=="\[CenterDot]","b",True,"G"],s=="L",Which[l=="$"||lLast=="R","R",lLast=="C","G",r=="G","L",True,"\[CenterDot]"],s=="R",Which[r=="$"||rFirst=="L","L",rFirst=="c","G",True,"\[CenterDot]"],s=="LR",If[lLast=="C"||rFirst=="c","G","\[CenterDot]"],s=="RL","LR",s=="\[CenterDot]",Which[(l=="G"||lLast=="R")&&(r=="G"||rFirst=="L"),"RL",l=="G"||lLast=="R","R",r=="G"||rFirst=="L","L",lLast=="C","A",rFirst=="c","a",True,"\[CenterDot]"],True,s]]; simulateFiringSquad[n_:21,maxSteps_:60]:=Module[{seq=ConstantArray["\[CenterDot]",n],history={},newSeq},seq[[1]]="G";AppendTo[history,seq];Do[newSeq=Table[With[{l=If[j==1,"$",seq[[j-1]]],r=If[j==n,"$",seq[[j+1]]]},nextState[l,seq[[j]],r]],{j,n}];AppendTo[history,newSeq];seq=newSeq;If[Union[seq]=={"F"},Break[]],{maxSteps}];history]; palette=ColorData["Rainbow"]/@Subdivide[0,1,14]; colorRules=Thread[Range[0,14]->palette]; firingSquadAnimate[n_:21,max_:60]:=Module[{hist=simulateFiringSquad[n,max]/. stateToInt},ListAnimate[(ArrayPlot[hist[[1;;#1]],ColorRules->colorRules,Frame->False,PixelConstrained->8,ImageSize->Large]&)/@Range[Length[hist]],AnimationRunning->False,AnimationRepetitions->1,DefaultDuration->0.25 Length[hist]]]; firingSquadAnimate[21,60] The central challenge in distributed systems is achieving reliable synchronization when faced with a branching, uncertain graph of causal possibilities. Conventional solutions attempt to solve this by forcing a single, linear timeline through global consensus protocols, but this approach is inherently brittle, slow, and does not scale. ---------- ## Pruning Causal Histories with Reversible Subtransactions ## **The DÆDÆLUS methodology offers a different path. Instead of forcing global agreement, we embrace the multiway graph of all possible causal histories and provide a mechanism to prune inconsistent branches safely and locally.** **If a sequence of operations along one branch leads to an inconsistent or undesirable state—a causal phantom—the transaction can be reversed. This unwinds the state changes precisely without a global rollback, allowing the system to prune inconsistent branches of the multiway graph locally and safely.** ---------- ## Practical Implications ## This methodology has direct implications for structuring systems like Git and iCloud, where file synchronization issues and filesystem corruption often stem from the inability to cleanly resolve divergent states. By providing a framework for local, reversible state changes, we can build systems that are not only scalable but also fundamentally more resilient to the inconsistencies that plague conventional synchronization models. ![fssp21][3] The primary methodology for formalizing understanding is the use of computational language. A principal example of this is the Wolfram Language. This approach requires one to take a conceptual understanding, formalize it in precise computational terms, and then execute it to observe its consequences. This process often reveals unexpected behaviors that fundamentally refine the original understanding. Historically, algorithms were engineered by humans; more recently, they are learned from data through progressive adaptation. We are pursuing a different approach: mining the computational universe for novel algorithms. Exhaustive searches within this universe consistently yield more unexpected and often more minimal results than incremental methods. The work presented here is a case in point, demonstrating the power of this methodology in practice. Module[{starCount = 2500, sceneR = 10, lineY = 4, presentBox = {0.8, 0.8}, swirlShift = -2, swirlR = 5, stars, timeline, swirl, frame, labels, quote}, stars = {White, PointSize[Tiny], Point[RandomPoint[Disk[{0, 0}, sceneR], starCount]]}; timeline = Module[{ticks = Range[-8, 8, 2], years}, years = 1950 + (ticks + 8) 25; Flatten[{White, Thickness[.004], Line[{{-8, lineY}, {8, lineY}}], Table[{Line[{{x, lineY - .2}, {x, lineY + .2}}], If[EvenQ[i], Text[Style[ToString[years[[i + 1]]], 9, White], {x, lineY - .6}]]}, {i, 0, Length[ticks] - 1}, {x, {ticks[[i + 1]]}}], Table[Text[ Style[If[EvenQ[k], "cause", "effect"], 9, White], {ticks[[k + 1]], lineY + 0.8}], {k, 0, Length[ticks] - 1}], {Cyan, Rectangle[{-(presentBox[[1]]/2), lineY + .25}, {presentBox[[1]]/ 2, lineY + .25 + presentBox[[2]]}]}, Text[Style["Present", 13, White], {0, lineY + 1.3}], Text[Style["Past", 11, White], {-8, lineY - 1}], Text[Style["Future", 11, White], {8, lineY - 1}]}]]; swirl = Module[{a = .05, b = .045, \[Theta]max = 24, d\[Theta] = .05, \[Phi]list}, \[Phi]list = Range[0, 2 \[Pi] - \[Pi]/8, \[Pi]/8]; Table[Line[ Table[With[{r = a Exp[b \[Theta]]}, r {Cos[\[Theta] + \[Phi]], Sin[\[Theta] + \[Phi]]}], {\[Theta], 0, \[Theta]max, d\[Theta]}]], {\[Phi], \[Phi]list}]]; frame = {White, Opacity[.5], Circle[{0, 0}, swirlR]}; labels = Table[With[{\[Theta] = (2 \[Pi] k)/8, tag = If[EvenQ[k], "cause", "effect"]}, Text[Style[tag, 10, White], (swirlR + 1) {Cos[\[Theta]], Sin[\[Theta]]}]], {k, 0, 7}]; quote = {Text[ Style["People assume that time is a strict progression of cause \ to effect, but actually, from a non-linear,\n non-subjective \ viewpoint, it's more like a big ball of wibbly-wobbly\[Ellipsis] \ timey-wimey\[Ellipsis] stuff.", 12, White, LineSpacing -> {1.2, 0}, TextJustification -> .5], {0, -7.3}, Center], Text[Style["\[LongDash] The Doctor", 11, White, Italic], {0, -8.2}]}; Graphics[{Black, Rectangle[{-sceneR, -sceneR}, {sceneR, sceneR}], stars, timeline, Translate[swirl, {0, swirlShift}], Translate[frame, {0, swirlShift}], Translate[labels, {0, swirlShift}], quote}, PlotRange -> {{-sceneR, sceneR}, {-sceneR, sceneR}}, Background -> Black, ImageSize -> 600]] The foundational insight of our work is the principle of reversibility: it is more robust to reverse a sequence of small, intermediate steps than to attempt to resolve a consistent global state in a single, complex operation. This "reversibility logic" is at the heart of the Æ-Link instruction set and is embedded within all of our scouting and routing algorithms. We utilize Mathematica as our primary tool for formalizing this principle. It serves as a comprehensive language for specification, configuration, and simulation, allowing us to model the fundamental physics of information flow. Our work on the *Distributed Firing Squad Problem* prepares us for this, framing the challenges of time, clocks, and event reordering that these models must solve. ---------- ## The Root of the Problem: The Façade of Newtonianism ## This approach is necessary because the fundamental issue plaguing modern distributed systems is the façade of Newtonianism. The assumption of a single, global, irreversible timeline is a flawed abstraction that leads to systemic, cascading failures. **Case Study: Git and iCloud Synchronization** The consequences of this flawed assumption are not theoretical; they manifest as persistent file synchronization corruption in widely used systems like Git and iCloud. The diamond structures that appear in a Git commit graph upon a merge are a direct visualization of divergent causal histories. Subsequent synchronization conflicts are often misdiagnosed, but they are symptoms of a deeper atomicity problem rooted in the unreliable, best-effort assumptions of the underlying Ethernet fabric. This is a manifestation of the "Ethernet Spacetime" misunderstanding that pervades modern infrastructure at Apple, AWS, and Google alike. ![THe Doctor][4] The evolution from the deterministic Firing Squad Problem (FSSP) to a multiway FSSP mirrors the paradigm shift from classical networking to the DÆDÆLUS architecture. We do not solve the problem of causal uncertainty by eliminating it with fragile global assumptions; rather, we provide the tools to navigate through it with local, verifiable, and reversible operations. Our objective is to produce modular components and high-level, human-readable code that makes each part of this complex system understandable on its own. ---------- **Modeling the Classic Ether** To ground this paradigm, we are developing a specific, agent-based model of the classic Ethernet. Initially focusing on a bidirectional, acknowledged data flow, the model is designed to replicate the packet transmission mechanics described in Metcalfe's seminal paper. While the statistical analysis from that work serves as a validation target, our primary objective is to create a clean, step-by-step simulation of the transmission process itself. ---------- **Simulation Architecture and Event Logging** The simulation is architected with the following principles: - Discrete, Integer-Based Time: Time advances in discrete integer steps, ensuring deterministic and repeatable behavior. - Atomic Event Processing: To handle events occurring at the same logical time, the simulation processes all simultaneous events before advancing the clock, ensuring consistency. - Per-Link State Machine: The link is the fundamental unit of serialization and is modeled as a state machine with discrete states: IDLE, BUSY, COLLISION, or JAM. - Event Log Output: The primary output is a per-link event log that records every packet transmission and state change. These logs are designed to be replayed, enabling the visualization of packet flows, collisions, and the creation of precise timeline diagrams. DynamicModule[{symbols={"CHERRY","GRAPE","LEMON","WATERMELON","ORANGE"},values=Association["CHERRY"->10,"GRAPE"->20,"LEMON"->30,"WATERMELON"->40,"ORANGE"->60],reelFinals,spinStart,spinning=False,godMode=False,winnings=0},reelFinals=ConstantArray["",3];spinStart=0;Deploy[Column[{Style["THE SLOTS",34,FontFamily->"Bebas Neue"],Spacer[20],Row[Table[With[{ii=ii},Dynamic[Style[If[spinning&&AbsoluteTime[]-spinStart<1.6,RandomChoice[symbols],reelFinals[[ii]]],FontSize->24],UpdateInterval->0.05]],{ii,1,3}],Spacer[20]],Spacer[20],Row[{Button["Spin",If[!spinning,spinning=True;spinStart=AbsoluteTime[];RunScheduledTask[reelFinals=Table[RandomChoice[symbols],{3}];If[godMode,reelFinals=ConstantArray[First[reelFinals],3];];If[Length[Union[reelFinals]]==1,winnings+=values[reelFinals[[1]]]];spinning=False;,{1.6,1}];],ImageSize->{80,40}],Spacer[20],Button["God's Eye",godMode=!godMode,Appearance->Dynamic[If[godMode,"Pressed","Normal"]],ImageSize->{80,40}]}],Spacer[20],Dynamic[Style["Winnings: "<>ToString[winnings],20]]},Alignment->Center]]] Replaying per-link event logs synchronously to achieve a cohesive, system-wide view requires a Global Timeframe. Within the simulation's "God's eye view," events on different links that share the same discrete integer timestamp are considered to have occurred simultaneously. ---------- **A Hybrid Simulation Architecture** To achieve this, we propose a hybrid simulation architecture that leverages the strengths of both Python and Mathematica. Rather than a purely symbolic approach, this pragmatic methodology uses Python for the core simulation and Mathematica for analysis and visualization. - The Simulation Engine (Python): The core agent-based simulation will be implemented in Python to leverage its robust ecosystem. We can use libraries like PyTransitions to formally define the link state machines (IDLE, BUSY, COLLISION, JAM). This allows us to model packet metadata (e.g., source, destination, ACK type) without simulating the exact bit patterns, focusing on the protocol's logical behavior. A Python foundation provides a clear path to scale the model from the initial half-duplex channel to more complex full-duplex and even Aloha-style contention systems. - The Analysis & Visualization Engine (Mathematica): The Python simulation will export detailed event logs as its primary artifact. These logs can then be imported into Mathematica to render precise timeline diagrams of link states and replay complex event sequences, such as packet collisions. This maintains our "code-as-proof" methodology, using the simulation output for formal analysis. ---------- This hybrid approach allows for rapid development by leveraging existing Python libraries while reserving Mathematica for its unparalleled strengths in formal analysis and visualization. It offers the most pragmatic and scalable path forward. ![July 19][5] The greatest challenge in distributed computing is not merely delivering data, but synchronizing action across multiple nodes in the face of causal ambiguity. The classic Firing Squad Synchronization Problem (FSSP) serves as a computational parable for this challenge, defining the problem of achieving simultaneous action among distributed agents. The classical FSSP assumes a deterministic world where a single, correct timeline can be established through an orchestrated exchange of signals, reflecting the conventional approach to networking that seeks to impose a single causal history on an inherently unpredictable system. The DÆDÆLUS paradigm reframes this problem from a multiway perspective. We begin with the system in an inert, inactivated state where causal relationships are yet to be defined. Instead of forcing a single outcome, our model allows the system to evolve into a causal superposition—a branching graph of all possible histories. This approach is not a direct simulation of quantum physics but a powerful, quantum-inspired model for systems with indefinite causal order. This journey from a deterministic FSSP to a multiway FSSP illustrates the fundamental departure of our methodology. We do not solve for a single, globally consistent state; instead, we provide the tools to navigate the multiway graph of possibilities. Our cellular automaton model for reliable delivery is built on this foundation, ensuring that a packet is either verifiably delivered or its failure is explicitly known, thereby pruning impossible branches from the causal tree. DynamicModule[{$happenedBeforeMatrix, $events = CharacterRange["A", "Z"], colorRules = {1 -> White, -1 -> White, 0 -> Black}, examples, resetGVM, insertLogic, processCommands, rebuild}, examples = Association[ "Linear Chain" -> StringRiffle[ Table["insert " <> $events[[i]] <> "->" <> $events[[i + 1]], {i, 1, 25}], "; "], "Diamond Shape" -> "insert A->B; insert A->C; insert B->D; insert C->D; insert D->E; \ insert E->F; insert E->G; insert F->H; insert G->H; insert H->I; \ insert I->J; insert I->K; insert J->L; insert K->L; insert L->M; \ insert M->N; insert M->O; insert N->P; insert O->P; insert P->Q; \ insert Q->R; insert Q->S; insert R->T; insert S->T; insert T->U; \ insert U->V; insert U->W; insert V->X; insert W->X; insert X->Y; \ insert Y->Z;", "Fork-Join" -> "insert A->B; insert A->C; insert A->D; insert B->E; insert C->E; \ insert D->E; insert E->F; insert F->G; insert F->H; insert G->I; \ insert H->I; insert I->J; insert J->K; insert J->L; insert J->M; \ insert K->N; insert L->N; insert M->N; insert N->O; insert O->P; \ insert O->Q; insert P->R; insert Q->R; insert R->S; insert S->T; \ insert S->U; insert S->V; insert T->W; insert U->W; insert V->W; \ insert W->X; insert X->Y; insert Y->Z;", "Parallel Streams" -> "insert A->B; insert C->D; insert E->F; insert G->H; insert I->J; \ insert K->L; insert M->N; insert O->P; insert Q->R; insert S->T; \ insert U->V; insert W->X; insert Y->Z;", "Random DAG" -> "insert A->D; insert A->C; insert B->D; insert B->E; insert C->F; \ insert D->G; insert E->H; insert F->H; insert G->I; insert H->J; \ insert I->K; insert J->K; insert K->L; insert L->M; insert L->N; \ insert M->O; insert N->P; insert O->Q; insert P->Q; insert Q->R; \ insert R->S; insert S->T; insert T->U; insert U->V; insert V->W; \ insert W->X; insert X->Y; insert Y->Z;", "Simple Cycle" -> "insert A->B; insert B->C; insert C->D; insert D->E; insert E->F; \ insert F->G; insert G->H; insert H->I; insert I->J; insert J->K; \ insert K->L; insert L->M; insert M->N; insert N->O; insert O->P; \ insert P->Q; insert Q->R; insert R->S; insert S->T; insert T->U; \ insert U->V; insert V->W; insert W->X; insert X->Y; insert Y->Z; \ insert Z->A;"]; resetGVM[] := ($happenedBeforeMatrix = ConstantArray[0, {Length[$events], Length[$events]}];); insertLogic[eA_String, eB_String] := Module[{posA, posB, n = Length[$events]}, posA = First[Flatten[Position[$events, eA]]]; posB = First[Flatten[Position[$events, eB]]]; If[$happenedBeforeMatrix[[posB, posA]] === 1, Return[]]; $happenedBeforeMatrix[[posA, posB]] = 1; $happenedBeforeMatrix[[posB, posA]] = -1; Do[If[$happenedBeforeMatrix[[k, posA]] === 1 && $happenedBeforeMatrix[[k, posB]] =!= 1, $happenedBeforeMatrix[[k, posB]] = 1; $happenedBeforeMatrix[[posB, k]] = -1;], {k, n}]; Do[If[$happenedBeforeMatrix[[posB, k]] === 1 && $happenedBeforeMatrix[[posA, k]] =!= 1, $happenedBeforeMatrix[[posA, k]] = 1; $happenedBeforeMatrix[[k, posA]] = -1;], {k, n}];]; processCommands[txt_String] := Module[{parts}, parts = StringSplit[txt, ";"]; Do[With[{c = StringTrim[part]}, If[StringStartsQ[c, "insert"], Module[{ev = StringSplit[StringTrim[StringDrop[c, 6]], "->"]}, If[Length[ev] == 2, insertLogic[ev[[1]], ev[[2]]]]]]], {part, parts}];]; rebuild[] := Module[{edges, Gfull, Gred, fullPlot, hassePlot}, edges = Flatten[ Table[If[$happenedBeforeMatrix[[i, j]] === 1, $events[[i]] -> $events[[j]], Nothing], {i, Length[$events]}, {j, Length[$events]}]]; Gfull = Graph[$events, edges, DirectedEdges -> True]; Gred = TransitiveReductionGraph[Gfull]; fullPlot = GraphPlot[edges, DirectedEdges -> True, VertexRenderingFunction -> ({Black, Disk[#1, 0.025], Black, Text[#2, #1]} &), PlotStyle -> {RGBColor[0, 0, 0.5]}, ImageSize -> {300, 250}]; hassePlot = GraphPlot[EdgeList[Gred] /. x_ \[DirectedEdge] y_ :> x -> y, DirectedEdges -> True, VertexRenderingFunction -> ({Black, Disk[#1, 0.025], Black, Text[#2, #1]} &), PlotStyle -> {RGBColor[0, 0, 0.5]}, ImageSize -> {300, 250}]; Column[{fullPlot, Spacer[10], hassePlot}]]; Column[Table[resetGVM[]; processCommands[examples[exName]]; Framed[Column[{Style[exName, Black, Bold, 16], Spacer[5], rebuild[], Spacer[10], MatrixPlot[$happenedBeforeMatrix, ColorRules -> colorRules, Mesh -> All, Frame -> True, FrameTicks -> {Table[{i, Style[$events[[i]], Black, 10]}, {i, Length[$events]}], Table[{j, Style[$events[[j]], Black, 10]}, {j, Length[$events]}]}, FrameTicksStyle -> Black, ImageSize -> {500, 450}, Background -> White]}], Background -> White, FrameStyle -> Black, RoundingRadius -> 6], {exName, Keys[examples]}], Spacings -> 2]] The evolveDeterministicFSSP function simulates the classical Firing Squad Synchronization Problem (FSSP). The simulation begins with a command from a single "General," initiating a sequence of signal propagations that reflect and interact until all "soldiers" fire simultaneously. The resulting space-time diagram reveals a single, predictable causal history. This simulation is a perfect embodiment of the Forward-In-Time-Only (FITO) fallacy that underpins conventional distributed systems. It is built on a set of computationally convenient but flawed assumptions: a single, definite causal order that is globally consistent and irreversible. This deterministic model is fundamentally fragile because it systematically conflicts with both relativistic physics and practical network constraints. The quest for a single, consistent timeline collides with physical reality, which does not provide a universal "now". Real-world networks, with their variable latencies, non-uniform topologies, and failure modes, violate the basic assumptions that make deterministic synchronization possible. Ultimately, you cannot synchronize clocks the way you think, and any model that relies on this illusion is destined to fail when confronted with physical reality. ![Rasterized][6] We present `DynamicNetworks`, a Mathematica-based simulation toolkit for interactively modeling and visualizing packet networks. The framework reproduces phenomena from early protocols like ALOHA and 1970s Ethernet—such as collision domains and retransmission timing—and extends to modern Clos networks and experimental systems like Open Atomic Ethernet, enabling direct experimentation with deterministic multicast and atomic commit semantics. Our tools emphasize time-evolving visualizations and real-time parameter tuning to bridge the gap between textbook theory and live systems intuition. A key question is whether this simulator can be merged with the DÆDÆLUS Emulator. The primary incompatibility lies in the simulator's reliance on a global ordering of events to synchronize transmissions—a construct our architecture explicitly rejects. A potential path forward involves developing a synchronization mechanism for the per-link logs generated by the emulator. These logs could then be replayed and visualized in Mathematica, replacing the global priority queue with a model grounded in the emulator's local, asynchronous reality. As computer engineers for DÆDÆLUS and project leads for Atomic Ethernet, we are interested in the fuzzy line between hardware and software, and in making small changes at the base of the tower that ripple all the way to the top. ---------- Causality as Computation: From Lamport's Logic to the Graph Virtual Machine ------------------------------------------------------------------------ The Firing Squad Problem highlights the challenge of synchronizing action in time, but the more fundamental problem is ordering the events themselves. To this end, we have developed an elegant, executable specification of Lamport's "happens-before" relation—the foundational logic for establishing causality in classical distributed systems. At the heart of this simulation is the insertLogic function. When a new causal link is introduced, the code computes the transitive closure of the entire system. This creates a mathematically consistent partial order, but it relies on an illusion of global knowledge. The resulting causality matrix represents a "God's-eye-view" of the event history, where the implications of a single message are instantly propagated across the entire logical structure. This model perfectly illustrates the Forward-In-Time-Only (FITO) assumptions that the DÆDÆLUS architecture is designed to transcend. Real systems do not have access to this instantaneous, global truth; they are composed of CELLs connected by LINKs, and each CELL operates from a strictly local perspective. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=lamport.png&userId=2553367 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=fssp13_with_panel.gif&userId=2553367 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=fssp21-ezgif.com-reverse.gif&userId=2553367 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=thedoctor.png&userId=2553367 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=slots_normal1-ezgif.com-optimize.gif&userId=2553367 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=rasterized.png&userId=2553367 Dean Gladish 2025-07-30T23:03:11Z https://community.wolfram.com/groups/-/m/t/3471630 &[Wolfram Notebook][1] Interestingly, - The sequence (-1)^n(n^(1/n)-1) is not "open" in the sense that it doesn't diverge or expand indefinitely. Instead, it oscillates . - It is not "closed" either for individual terms, because they do not settle into a single value or a finite set of values. Instead, we focus on the convergence of the series formed by these terms, which leads to the MRB constant. [1]: https://www.wolframcloud.com/obj/37cc3458-d4ab-4185-beaa-9fff64fa3417 Marvin Ray Burns A.G.S. (cum laude) 2025-05-30T23:02:03Z https://community.wolfram.com/groups/-/m/t/3452312 Comments on the post: [Photon propagation through variable-dimensional space][1] We can think of the path of engineering innovation in the Game of Life as like an effort to navigate through an ocean of computational irreducibility, finding islands of reducibility. That island mentality, reflects a bit of a "time out" diffraction, of Bessel functions to describe radial wave solutions and gravitational potentials in fractional-dimensional space. These mathematical functions have a very lucky solution; it's like the "catfish" of trigonometric scenarios; structured solutions emerge in seemingly chaotic environments. ClearAll["Global`*"]; FractionalBesselJ[\[Nu]_, r_] := (r)^((3 - D)/2)*BesselJ[\[Nu], r] PotentialSolution[D_, r_, z_, k_] := Module[{\[Nu], radialPart, verticalPart}, \[Nu] = (D - 3)/2; radialPart = FractionalBesselJ[\[Nu], k*r]; verticalPart = Exp[-k*Abs[z]]; radialPart*verticalPart] kValue = 0.1; DValues = {2.0, 2.5, 3.0}; plots = Table[ Plot3D[Evaluate[ PotentialSolution[D, Sqrt[x^2 + y^2], 0, kValue]], {x, -30, 30}, {y, -30, 30}, PlotRange -> All, PlotLabel -> StringForm["D=``", D], ColorFunction -> "TemperatureMap", AxesLabel -> {"X", "Y", "Potential"}, BoxRatios -> {1, 1, 0.7}], {D, DValues}]; Grid[Partition[plots, 3], Spacings -> {0, 0}] CircularVelocity[D_, r_?NumericQ] := Module[{\[Nu], k, integral}, \[Nu] = (D - 3)/2; k = 1/r; integral = NIntegrate[k^((3 - D)/2)*BesselJ[\[Nu], k*r]*k^(D/2), {k, 0, 1}, Method -> "GlobalAdaptive"]; Sqrt[Abs[integral*r]]] velocityPlot = Plot[Evaluate[Table[CircularVelocity[D, r], {D, {2.5, 3.0}}]], {r, 1, 30}, PlotStyle -> {Red, Blue}, PlotLegends -> {"D=2.5", "Newtonian (D=3)"}, AxesLabel -> {"Radius", "Circular Velocity"}, PlotLabel -> "Rotation Curve Comparison"] ![Radius 0][2] It's a lucky solution, structured Bessel functions are analogous to stable "islands" within irreducible mathematical complexity. But most of the time, the first step is to identify an objective, some purpose one can describe and wants to achieve. Here, instead of the new mayor in town we can revert to the old, simulation of circular velocities and rotation curves which are critical in astrophysics..the computational objective, is defined and "geared" towards structures like gliders which serve defined purposes in cellular automata, engineering goals. Velocity curves are purposefully and "intentionally" measured for the purpose of paralleling structured engineering in "Conway's Game of Life". ClearAll[potential]; potential[R_, z_, D_, k_] := (k*R)^((3 - D)/2)* BesselJ[(D - 3)/2, k*R]*Exp[-k*Abs[z]] DValue = 2.5; kValue = 1; Plot3D[potential[R, z, DValue, kValue], {R, 0.1, 5}, {z, -5, 5}, PlotRange -> All, AxesLabel -> {"R", "z", "Potential \[CapitalPhi](R,z)"}, PlotLabel -> Style["Fractional-Dimensional Potential (D = " <> ToString[DValue] <> ")", 14, Bold], ColorFunction -> "TemperatureMap", MeshFunctions -> {#3 &}, MeshStyle -> Opacity[0.3], ImageSize -> 600] ContourPlot[potential[R, z, DValue, kValue], {R, 0.1, 5}, {z, -5, 5}, FrameLabel -> {"R", "z"}, PlotLabel -> Style["Equipotential Contours (D = " <> ToString[DValue] <> ")", 14, Bold], ColorFunction -> "TemperatureMap", Contours -> 20, ImageSize -> 600] ![Equipotential 0][3] The K-night, this is the same thing that we took in, it's fractional cylindrical Laplacian engineering--whatever raw material is available..fashion it into something that aligns with human purposes. The fractional cylindrical Laplacian represents how fractional dimensions, Bessel functions, cylindrical coordinates (mathematical "raw materials") are fashioned to achieve named and defined objectives--solving wave equations in non-integer dimensions, basic mathematical "materials" show and represent the purposeful manipulation of complexity via the structural way that the Game of Life, its rivers cross in structurally unexpected and fun ways. FractionalCylindricalLaplacian[\[Psi]_, R_, \[Phi]_, z_, \[Alpha]R_, \[Alpha]\[Phi]_, \[Alpha]z_] := Module[{Dtotal = \[Alpha]R + \[Alpha]\[Phi] + \[Alpha]z}, (1/ R^(Dtotal - 2)* D[R^(Dtotal - 2)*D[\[Psi], R], R] + (1/(R^2*Sin[\[Phi]]^(Dtotal - 3)))* D[Sin[\[Phi]]^(Dtotal - 3)*D[\[Psi], \[Phi]], \[Phi]] + (1/ z^(\[Alpha]z - 1))*D[z^(\[Alpha]z - 1)*D[\[Psi], z], z])] FractionalCylindricalWaveSolution[R_, \[Phi]_, z_, k_, m_, Dtotal_, \[Alpha]R_, \[Alpha]\[Phi]_, \[Alpha]z_] := Module[{\[Lambda] = (Dtotal - 3)/2, radialSolution, angularSolution, zSolution}, radialSolution = (k*R)^((3 - Dtotal)/2)* BesselJ[(Dtotal - 3)/2 + m, k*R]; angularSolution = GegenbauerC[m, \[Lambda], Cos[\[Phi]]]; zSolution = Exp[-k*Abs[z]]; radialSolution*angularSolution*zSolution] Module[{M = 1.5*10^41, g\[Dagger] = 1.2*10^-10, G = 6.674*10^-11, l0, Rd, wd, kValues, Dtotal = 1.7, results}, l0 = Sqrt[G*M/g\[Dagger]]; Rd = 30000*9.461 e15; wd = Rd/l0; kValues = Subdivide[0.1, 2.0, 50]; results = Table[FractionalCylindricalWaveSolution[R, 0, 0, k, 0, Dtotal, 1, 1, 1], {k, kValues}, {R, 0.1*l0, 5*l0, l0/10}]; DensityPlot3D[ FractionalCylindricalWaveSolution[Sqrt[x^2 + y^2], ArcTan[y/x], z, 0.1, 0, Dtotal, 1, 1, 1], {x, -l0, l0}, {y, -l0, l0}, {z, -l0/10, l0/10}, PlotRange -> All, ColorFunction -> "TemperatureMap", AxesLabel -> {"X (m)", "Y (m)", "Z (m)"}, PlotLabel -> "Fractional-Dimensional Gravitational Potential"]] ![Frational 0][4] Why fractional? Well, it's like..a "rough" analogy would be the film North by Northwest, you just keep ordering cupcakes and whatever and it just becomes totally disgusting, but those are the delicatessens that show how, we Ruliologically engineer solutions to wave forms from fractional-dimensional equations. And, they don't simply occur "scientifically" or nationally, you just keep getting iterations and various issues with those iterations until you reach, the intentional creation and natural constraints that occur within the realm of computationally purposeful, engineered patterns in cellular automata. But hopefully we can get more action than that. Hopefully we can carefully construct patterns, not random occurrences, the closest next of kin which would be the constructed cellular automaton configurations. ClearAll["Global`*"]; radialSolution[R_, k_, D_] := (k*R)^((3 - D)/2)*BesselJ[(D - 3)/2, k*R] potential[R_, z_, D_, k_] := Module[{angularPart, radialPart, zPart}, angularPart = 1; radialPart = radialSolution[R, k, D]; zPart = Exp[-k*Abs[z]]; radialPart*angularPart*zPart] DValue = 2.5; kValue = 0.1; potentialField = Table[{R, z, potential[R, z, DValue, kValue]}, {R, 0.1, 10, 0.1}, {z, -5, 5, 0.1}]; potentialFieldFlat = Flatten[potentialField, 1]; ListPlot3D[potentialFieldFlat, AxesLabel -> {"R (kpc)", "z (kpc)", "Potential \[CapitalPhi](R,z)"}, PlotLabel -> Style["Fractional-Dimensional Potential (D=" <> ToString[DValue] <> ")", 16, Bold], ColorFunction -> "TemperatureMap", PlotRange -> All, Mesh -> None, PlotLegends -> BarLegend[Automatic], ImageSize -> Large, BoxRatios -> {1, 1, 0.5}] ![Potential 0][5] You can see the blocks and "Eaters", you can see the density plots and contour plots that's, if we want to get closer to the study of the pure phenomenon of innovation..everything that happens can be described in a uniform way. "The closest thing we have to a Hilbert space" is, with the standardization of complex solutions into "pretty" uniform, understandable forms, we get clear, human-readable configurations--much like visualizing automaton patterns for "better" understanding. With the snap of a finger, the reduction of computational complexity becomes relevantly reduced into a form that is analogous to the evolution of automaton states. ClearAll["Global`*"]; \[Alpha]1 = 0.5; \[Alpha]2 = 0.5; \[Alpha]3 = 1.0; Ddim = \[Alpha]1 + \[Alpha]2 + \[Alpha]3; m = 0; \[Beta]\[Rho] = 1.0; \[Beta]z = 1.0; \[Nu] = 0.5*Sqrt[(2 - \[Alpha]1 - \[Alpha]2)^2 + 4*m^2]; f[\[Rho]_] := \[Rho]^((1 - (\[Alpha]1 + \[Alpha]2)/ 2))*(BesselJ[\[Nu], \[Beta]\[Rho]*\[Rho]] + BesselY[\[Nu], \[Beta]\[Rho]*\[Rho]]); A = 0; B = 0; c = (2 - \[Alpha]2)/2; \[Xi][\[Phi]_] := Sin[\[Phi]]^2; g[\[Phi]_] := Hypergeometric2F1[A, B, c, \[Xi][\[Phi]]] + \[Xi][\[Phi]]^(1 - c)* Hypergeometric2F1[A - c + 1, B - c + 1, 2 - c, \[Xi][\[Phi]]]; n = 1 - \[Alpha]3/2; h[z_] := z^n*(BesselJ[n, \[Beta]z*z] + BesselY[n, \[Beta]z*z]); \[CapitalPsi][\[Rho]_, \[Phi]_, z_] := f[\[Rho]]*g[\[Phi]]*h[z]; Manipulate[ Plot3D[Re[\[CapitalPsi][\[Rho], CurlyPhi, z]], {\[Rho], 0.1, 10}, {z, 0.1, 10}, PlotRange -> All, AxesLabel -> {"\[Rho]", "z", "Re(\[CapitalPsi])"}, PlotLabel -> StringForm["Fractional Cylindrical Wave (D=``, \[Phi]=``)", Ddim, CurlyPhi], ColorFunction -> "Rainbow", MeshFunctions -> {#3 &}, PerformanceGoal -> "Quality"], {{CurlyPhi, \[Pi], "\[Phi]"}, 0, 2 \[Pi], \[Pi]/10, Appearance -> "Labeled"}, ControlPlacement -> Bottom] ![Wave 0][6] A typical manifestation of computational irreducibility, many small and seemingly random looking symmetries..results were "found". Fractional-dimensional gravitational potentials and field simulations sometimes started to appear : an important methodology, has revolved around so-called hasslers providing harnesses that rein in behavior. The gravitational potentials and fields, "being" complex, computationally irreducible phenomena that are effectively "harnessed" and viewed through these mathematical functions and simulations, "just as" hasslers rein in chaotic automaton behavior, in fact out of the corner of our simulation, here instead I think Simon Fischer our audience might be able to understand..engineered control in cellular automata, via the careful analysis and constraints..of behaviorally complex gravitational fields. ClearAll["Global`*"]; DValue = 2.5; m = 0; k = 1; Rd = 0.681; RadialSolution[R_] := (k*R)^((3 - DValue)/2)* BesselJ[(DValue - 3)/2 + m, k*R] AngularSolution[\[Phi]_] := GegenbauerC[m, (DValue - 3)/2, Cos[\[Phi]]] Psi[R_, \[Phi]_] := RadialSolution[R]*AngularSolution[\[Phi]] DensityPlot[ Psi[Sqrt[x^2 + y^2], ArcTan[x, y]], {x, -5, 5}, {y, -5, 5}, ColorFunction -> "SunsetColors", PlotLegends -> BarLegend[Automatic], FrameLabel -> {"X (kpc)", "Y (kpc)"}, PlotLabel -> StringForm["Fractional Potential (D = ``)", DValue], PlotRange -> All, Exclusions -> None, PlotPoints -> 100, ImageSize -> Large] If[DValue > 2, Plot3D[Psi[Sqrt[x^2 + y^2], ArcTan[x, y]], {x, -5, 5}, {y, -5, 5}, ColorFunction -> "SunsetColors", PlotLabel -> StringForm["3D Potential View (D = ``)", DValue], AxesLabel -> {"X", "Y", "\[CapitalPsi]"}, PlotRange -> All, Exclusions -> None, PlotPoints -> 50, BoxRatios -> {1, 1, 0.5}, ImageSize -> Large]] ![View Potential 0][7] With regard to these "isomorphisms"..cylindrical wave functions with Gegenbauer polynomials and "hypergeometric" functions, it's a beautiful thing; one theme to which we'll return later is that after certain functionality was first built, many optimizations achieving that functionality more robustly, exist, and the sophisticated mathematical constructs like Gegenbauer polynomials climb out of the picturesque, optimized solutions to fractional-dimensional problems, and that is where we get our improved, engineered automaton solutions from initial "complicated" constructions to simpler, optimized versions. The mathematically "optimized" formulation demonstrates engineered improvements. ClearAll["Global`*"]; dim = 2.5; radialTerm[\[Phi]_, R_, z_] := D[\[Phi][R, z], {R, 2}] + (dim - 2)/R*D[\[Phi][R, z], R]; angularTerm[\[Phi]_, R_, z_] := 0; verticalTerm[\[Phi]_, R_, z_] := D[\[Phi][R, z], {z, 2}]; fractionalLaplacian[\[Phi]_, R_, z_] := radialTerm[\[Phi], R, z] + angularTerm[\[Phi], R, z] + verticalTerm[\[Phi], R, z] == 0; \[Phi][R_, z_] := J[R] Z[z]; k = 1; Z[z_] := Exp[-k Abs[z]]; reducedEquation = fractionalLaplacian[\[Phi], R, z] /. Z[z] -> Exp[-k Abs[z]]; reducedRadialEquation = Simplify[reducedEquation, Assumptions -> {R > 0, z \[Element] Reals, k > 0}] /. J[R] -> j[R]; radialSolution = DSolve[reducedRadialEquation, j[R], R] // Simplify; generalSolution = \[Phi][R, z] -> (j[R] /. radialSolution[[1]]) Z[z]; TraditionalForm[generalSolution] radialFunction[R_] := R^((3 - dim)/2)*(BesselJ[(dim - 3)/2, k R] + BesselY[(dim - 3)/2, k R]); DensityPlot[ radialFunction[R]*Exp[-k Abs[z]] /. {k -> 1}, {R, 0.1, 5}, {z, -2, 2}, PlotLabel -> "Fractional Potential (D=2.5)", AxesLabel -> {"R", "z"}, ColorFunction -> "SunsetColors", PlotRange -> All, PlotPoints -> 100, ImageSize -> Large] ![aexes 0 ][8] And it's not, Wolfram Community's fault that I can't, for instance, put brackets, I can't put back slashes `\` "behind" or in front of the image name.. somewhere along the way, the Wolfram, the computational irreducibility is the spark in the system. The cage provides the control we need. That's right, these Partial Differential Equations, Fractional-Dimensional represent, computationally irreducible equations where, boundary conditions or cages ("constraints") allow structured solutions, which "at least" mirror, how chaotic behavior in automata is controlled for purposeful engineering. So the real complexity is the file system..complexity here is "caged" by boundary conditions to yield structured solutions. ClearAll["Global`*"]; FractionalCylindricalLaplacian[\[Phi]_, R_, z_, D_] := D[\[Phi], {R, 2}] + (D - 2)/R D[\[Phi], R] + D[\[Phi], {z, 2}]; RadialSolution[D_, k_, R_] := (k R)^((3 - D)/2) BesselJ[(D - 3)/2, k R]; ZSolution[k_, z_] := Exp[-k Abs[z]]; FractionalPotential[R_, z_, D_, k_] := RadialSolution[D, k, R]*ZSolution[k, z]; DValue = 2.5; kValue = 1; Plot[RadialSolution[DValue, kValue, R], {R, 0, 10}, PlotLabel -> Style["Radial Solution for D=" <> ToString[DValue], 16, Bold], AxesLabel -> {"R", "J(R)"}, PlotStyle -> {Thick, Blue}, GridLines -> Automatic, Frame -> True, ImageSize -> Large] Plot3D[FractionalPotential[R, z, DValue, kValue], {R, 0.1, 10}, {z, -5, 5}, PlotLabel -> Style["Fractional Potential (D=" <> ToString[DValue] <> ")", 16, Bold], AxesLabel -> {"R", "z", "\[CapitalPhi](R,z)"}, ColorFunction -> "TemperatureMap", PlotRange -> All, Mesh -> None, Boxed -> False, AxesOrigin -> {0, 0, 0}, ImageSize -> Large] ![Solution00][9] How did we do that? In the parametric and modular approach (it's a non-sequitur), the main emphasis tends to be on figuring out plans, then constructing things based on those plans. These, we have seen enough of the modular approach. Forget the modular approach. Personally, I would rather mirror structured engineering methods, where plans or oscillators, gliders, and guns in automata (modules) are systematically combined. It is systematic, engineered construction that is analogous to modular engineering in automata: parametric modules and `Manipulate` make it possible to engage in "building from history". ClearAll["Global`*"]; RadialSolutionD[R_, k_, D_, m_] := (k*R)^((3 - D)/2)* BesselJ[(D - 3)/2 + m, k*R] m = 0; k = 1; DValues = {2.0, 2.5, 3.0}; colorList = {Red, Green, Blue, Purple, Orange}; radialPlots = Table[Plot[RadialSolutionD[r, k, Dval, m], {r, 0.1, 10}, PlotRange -> All, PlotLabel -> Style["Radial Solution for D = " <> ToString[Dval], 14, Bold], AxesLabel -> {"R", "J(R)"}, PlotStyle -> {Thick, colorList[[i]]}, ImageSize -> {360, 360}, Frame -> True, GridLines -> Automatic, GridLinesStyle -> Directive[Gray, Dashed], AspectRatio -> 1/GoldenRatio], {Dval, DValues}, {i, Length[DValues]}]; GraphicsGrid[Partition[radialPlots, 2], Frame -> All, FrameStyle -> LightGray, Spacings -> {2, 2}, Background -> Lighter[Gray, 0.95], ImageSize -> 800] ![Radial 00][10] Via causal graphs and computational irreducibility, causal graphs are much more revealing. They show that there are lots of factored modular parts or irreducible blobs; although causal graphs are couched in structured solutions that reflect attempts to isolate "modular parts" or "irreducible blobs" through mathematical analysis much like analyzing structures in cellular automata. Sure, we can "extend" our..complex fractional solutions to implicitly explore irreducibility versus modularity--similar to how causal graphs differentiate modular (engineering) from chaotic (pure computational irreducibility). With a roll of the dice, we can computationally meta-engineer concepts from the Game of Life by harnessing complexity and 'achieving well-defined objectives', optimizing modularity, as well as the irreducible phenomena that we clarify visually, parametrically "explore" the creative engineering methodologies described, particularly the duality of structured plans versus computational exploration. Manipulate[ Module[{potential, R, z}, potential[R_, z_] = (k R)^((3 - D)/2)*BesselJ[(D - 3)/2, k R]* Exp[-k Abs[z]]; Plot3D[potential[r, zz], {r, 0, 5}, {zz, -5, 5}, PlotRange -> All, ColorFunction -> (ColorData["TemperatureMap"][#3] &), MeshFunctions -> {#3 &}, AxesLabel -> {"R", "z", "\[CapitalPhi](R,z)"}, PlotLabel -> Style[Row[{"Fractional-Dimensional Potential\n", "D = ", NumberForm[D, {3, 1}], ", k = ", NumberForm[k, {3, 1}]}], 14, Bold], BoxRatios -> {1, 1, 0.6}, PerformanceGoal -> "Quality"]], {{D, 2.5, "Dimension"}, 2, 3, 0.1, Appearance -> "Labeled", ImageSize -> Small}, {{k, 1.0, "Wave Number"}, 0.1, 2, 0.1, Appearance -> "Labeled", ImageSize -> Small}, ControlPlacement -> Left, TrackedSymbols :> {D, k}, FrameLabel -> Style["Fractional-Dimensional Gravitational Potential", 14, Bold]] ![Fractional Dimensional Potential0][11] Here we've got some fractional-dimensional potential landscape that demonstrates how a photon would propagate in a space where the effective dimensionality `D` varies from the familiar three-dimensional case. In a medium where the number of spatial degrees of freedom is not strictly integer-valued—such as in certain exotic materials, curved spacetimes, or fractal-like structures—the behavior of photons fundamentally changes: radial dispersion, wavefront expansion, and decay rates all depend sensitively on the true dimensionality. The radial factor `BesselJ((D−3)/2, kR)` reflects how the spread of the photon’s amplitude becomes either more concentrated or more diffuse depending on D, while the axial exponential decay mimics attenuation along the propagation direction. Thus, this visualization provides a controlled, tunable representation of how photon wave functions would morph when the fabric of space itself becomes effectively non-integer-dimensional—a concept tied deeply to cutting-edge theories in quantum gravity, metamaterials, and fractional field theories. It's on par with the goal of "engineering" and making visible otherwise computationally irreducible phenomena. ClearAll["Global`*"]; FractionalLaplacianCylindrical[\[Psi]_, R_, \[Phi]_, z_, D_] := Module[{\[Alpha]R, \[Alpha]\[Phi], \[Alpha]z = 1}, (1/R^(D - \[Alpha]z - 1))* D[R^(D - \[Alpha]z - 1)*D[\[Psi], R], R] + (1/R^2)* D[Sin[\[Phi]]^(D - 3)*D[\[Psi], \[Phi]], \[Phi]]/ Sin[\[Phi]]^(D - 3) + D[\[Psi], {z, 2}]]; RadialSolution[D_, \[Beta]_, k_, R_] := Module[{arg = Sqrt[\[Beta]^2 - k^2]*R}, R^((3 - D)/2)*BesselJ[(D - 3)/2, arg] /; arg >= 0]; AngularSolution[D_, \[Phi]_, m_] := GegenbauerC[m, (D - 3)/2, Cos[\[Phi]]]; VerticalSolution[k_, z_] := Exp[-k*Abs[z]]; WaveSolution[R_, \[Phi]_, z_, D_, \[Beta]_, k_, m_] := RadialSolution[D, \[Beta], k, R]*AngularSolution[D, \[Phi], m]* VerticalSolution[k, z]; DValue = 2.5; \[Beta]Value = 1; kValue = 0.5; mValue = 0; PolarPlot[AngularSolution[DValue, \[Phi], 0], {\[Phi], 0, 2 \[Pi]}, PlotRange -> All, ColorFunction -> "Rainbow", PlotLabel -> Style["Angular Distribution (D=2.5)", Bold, 14], Axes -> False, PolarAxes -> True, PolarGridLines -> Automatic, PolarTicks -> {"Degrees", Automatic}, ImageSize -> Medium] ![Angular Distribution][12] How does our Mathematica code cut short the dimensional attributes of the Laplace equation solutions? In this particular scenario (situation), the cylindrical and spherical symmetry allows us to symmetrically portray spherical and cylindrical solutions, to envision graphical wave functions and the gravitational potentials, and so the computational irreducibility tells us, that we can't know in advance that it dies out at all..so the die-hard patterns, leads to infinite diversity and richness of what's possible. The issue for us is to figure out what direction we want to go. These Mathematica plots introduce configurations of fractional Laplacian solutions across "various" different dimensionalities and symmetries. ClearAll["Global`*"]; RadialSolution[R_, k_, D_, m_] := (k R)^((3 - D)/2)* BesselJ[(D - 3)/2 + m, k R] AngularSolution[\[Phi]_, D_, m_] := GegenbauerC[m, (D - 3)/2, Cos[\[Phi]]] Potential[R_, \[Phi]_, D_] := Module[{k = 1, m = 0}, RadialSolution[R, k, D, m]*AngularSolution[\[Phi], D, m]] Manipulate[ Plot3D[Potential[R, \[Phi], D], {R, 0.1, 10}, {\[Phi], 0, \[Pi]}, AxesLabel -> {"R", "\[Phi]", "\[CapitalPhi](R,\[Phi])"}, PlotLabel -> Row[{"D = ", D}], ColorFunction -> "TemperatureMap", PlotRange -> All], {D, 2.1, 2.9, 0.1}, ControlPlacement -> Top] RadialSolution[R_, k_, D_, m_] := (k*R)^((3 - D)/2)* BesselJ[(D - 3)/2 + m, k*R] AngularSolution[\[Phi]_, D_, m_] := GegenbauerC[m, (D - 3)/2, Cos[\[Phi]]] GravitationalAcceleration[R_, D_] := With[{\[Epsilon] = 0.0001}, If[R > \[Epsilon], -Derivative[1, 0, 0][Potential][R, 0, D], 0]] CircularVelocity[R_, D_] := Sqrt[R*Abs[GravitationalAcceleration[R, D]]] Plot[Evaluate[Table[CircularVelocity[R, d], {d, 2.1, 2.6, 0.1}]], {R, 0.1, 10}, PlotLabel -> "Circular Velocity in Fractional Space", AxesLabel -> {"Radius (kpc)", "Velocity (km/s)"}, PlotLegends -> Table["D = " <> ToString[d], {d, 2.1, 2.6, 0.1}], GridLines -> Automatic, PlotRange -> All, ImageSize -> Large] ![jockpc0][13] In engineering, as it's traditionally been practiced, the main emphasis tends to be on figuring out plans, and then constructing things based on those plans, Typically, one starts from components one has, then tries to figure out how to combine them to incrementally build up what one wants. `radialSolution` `AngularSolution` `Potential` "these are all" fundamental functions that we incrementally combine to acquire and access richer phenomena and structures. ClearAll["Global`*"]; FractionalLaplacianCylindrical[D_][f_, {r_, \[Phi]_, z_}] := Module[{radial, angular, vertical}, radial = D[f, {r, 2}] + (D - 2)/r D[f, r]; angular = 1/r^2 (D[f, {\[Phi], 2}] + (D - 3)/Tan[\[Phi]] D[f, \[Phi]]); vertical = D[f, {z, 2}]; radial + angular + vertical]; FractionalCylindricalSolution[D_, k_, m_, {r_, \[Phi]_, z_}] := (k r)^((3 - D)/2)* BesselJ[(D - 3)/2 + m, k r]*GegenbauerC[m, (D - 3)/2, Cos[\[Phi]]]* Exp[-k Abs[z]]; Manipulate[ Module[{solution, potential}, solution = FractionalCylindricalSolution[D, k, m, {r, \[Phi], z}]; potential = solution /. {r -> Sqrt[x^2 + y^2], \[Phi] -> ArcTan[x, y], z -> z}; DensityPlot3D[ Evaluate[potential /. z -> 0], {x, -scale, scale}, {y, -scale, scale}, {z, -0.1, 0.1}, PlotRange -> All, ColorFunction -> "Rainbow", PlotLegends -> Automatic, AxesLabel -> {"X", "Y", "Z"}, PlotLabel -> Row[{"Fractional Dimension D = ", D, "\nWave Number k = ", k}]]], {{D, 3, "Dimension"}, 2, 3, 0.1, Appearance -> "Labeled"}, {{k, 1, "Wave Number"}, 0.1, 2, 0.1, Appearance -> "Labeled"}, {{m, 0, "Azimuthal Mode"}, 0, 3, 1, Appearance -> "Labeled"}, {{scale, 5, "Plot Scale"}, 1, 10, 1, Appearance -> "Labeled"}, TrackedSymbols :> {D, k, m, scale}] ![Scale 0][14] And if it was set up for a purpose, the meta engineering and the computational richness that plays a role in it, has about the ideological complexity of a fruit roll-up; but it really is that sense of helplessness that you get when you take something that's computationally irreducible and, put it in a cage that constrains it to do what one wants. The computational irreducibility is in a sense the spark in the system. The cage provides the control we need to harness that spark in a way that meets our objectives. And that, will hopefully make it possible for our "cage" to channel mathematical complexity and physicality into comprehensible and manageable computations, similar to how engineering constraints complexity to produce predictable outcomes. ClearAll["Global*"]; Potential[D_, k_, R_, z_] := (k*R)^((3 - D)/2)* BesselJ[(D - 3)/2, k*R]*Exp[-k*Abs[z]]; Manipulate[ Plot3D[Potential[D, 1, R, z], {R, 0.1, 5}, {z, -5, 5}, PlotRange -> All, AxesLabel -> {"R (kpc)", "z (kpc)", "\[CapitalPhi](R,z)"}, PlotLabel -> Style[Row[{"Dimension D = ", D}], 14, Bold], ColorFunction -> "Rainbow", MeshFunctions -> {#3 &}, MeshStyle -> Opacity[.5], BoundaryStyle -> None, Lighting -> "Accent", PerformanceGoal -> "Quality"], {{D, 2.5, "Spacetime Dimension"}, 2, 3, 0.1, Appearance -> "Labeled"}, ControlPlacement -> Top, SynchronousUpdating -> False] Plot[Evaluate@Table[Potential[D, 1, R, 0], {D, {2.0, 2.5, 3.0}}], {R, 0.1, 10}, PlotRange -> All, AxesLabel -> {"R (kpc)", "\[CapitalPhi](R,0)"}, PlotLabel -> Style["Radial Potential Profile (z=0)", 14, Bold], PlotLegends -> LineLegend[{"D=2.0", "D=2.5", "D=3.0"}, LegendFunction -> "Panel", LegendLabel -> "Spacetime Dimension"], PlotStyle -> {Dashed, DotDashed, Thick}, GridLines -> Automatic, GridLinesStyle -> Directive[Gray, Dotted], Background -> Transparent] ![3D Potential Animation][15] As for the human effort and algorithmic discovery, in the end we can think, of the path of engineering innovation as like an effort to allow exploration of fractional dimensions and facilitate understanding of "otherwise" irreducible behaviors. For the purpose of oscillations in symmetry, the formation of patterns belies the presence of computational irreducibility which makes it clear that we will not run out of inventions of discoveries. The only thing that might end is a set of objectives we're trying to meet. Our continual exploration of spherical potentials, cylindrical waves, and oscillators..complex structures increasingly showcase in fractional dimensions, the "endless" potential for exploration and discovery in mathematical physics. ![Radial 0][16] So now we can say that we have factored modular parts, that interact fairly rarely and each behave in a fairly simple way; it's realistic for us to just get our minds around what's going on. But when there's just an irreducible blob of activity, we have to compute too much and keep too much in mind at once for us to really understand what's going on. Our employment of modular, clearly-functional Mathematica `RadialSolution` or `FractionalLaplacianCylindrical` breaks down, complex mathematical concepts into simpler, manageable computational and visual components. radialSolution[R_, k_, D_] := (k R)^((3 - D)/2) BesselJ[(D - 3)/2, k R]; Manipulate[ Plot[radialSolution[r, 1, D], {r, 0, 10}, PlotRange -> {-0.5, 1.0}, AxesLabel -> {"Radial Distance (R)", "Potential \[CapitalPhi](R)"}, PlotLabel -> StringForm["Radial Solution (D = `1`)", D], PlotStyle -> {Thick, Blue}, ImageSize -> Large, Frame -> True, FrameLabel -> {"R", "\[CapitalPhi](R)"}, FrameStyle -> Directive[Black, 12], BaseStyle -> {FontFamily -> "Helvetica", FontSize -> 12}, GridLines -> Automatic, GridLinesStyle -> Directive[Gray, Dashed]], {{D, 3, "Dimension Parameter"}, 1, 3, 0.1, Appearance -> "Labeled"}, FrameLabel -> Style["Fractional-Dimensional Laplace Equation Solution", 14, Bold]] Manipulate[ RevolutionPlot3D[radialSolution[r, 1, D], {r, 0, 10}, PlotRange -> All, AxesLabel -> {"X", "Y", "\[CapitalPhi](R)"}, PlotLabel -> StringForm["Cylindrical Solution (D = `1`)", D], ColorFunction -> Function[{x, y, z, r}, ColorData["Rainbow"][z]], Boxed -> False, ImageSize -> Large, MeshStyle -> {Opacity[0.4], White}, PlotPoints -> 50, Lighting -> "Neutral"], {{D, 3, "Dimension Parameter"}, 1, 3, 0.1, Appearance -> "Labeled"}, FrameLabel -> Style["Fractional-Dimensional Laplace Equation Solution", 14, Bold]] ![Radial Solution Animation][17] ![Cylindrical][18] But as we "talked about", when there are factored modular parts that interact fairly rarely, we have to complete the circuit from complexity to understandability; something that's found by human effort is much less likely to be minimal. In effect, it's at least somewhat optimized for comprehensibility rather than optimized for minimality or ease of being found by search. The Simon Fischer article "makes" some prioritization of human comprehension, carefully structuring code to stand-out, crystallized scientific narratives and coherence, rather than purely "minimal" mathematical complexity. ClearAll["Global`*"]; Dval = 2.5; Rd = 1; G = 1; Sigma0 = 1; Rmax = 10; Sigma[R_] := Sigma0 Exp[-R/Rd]; ode = 1/R^(Dval - 2)*D[R^(Dval - 2)*D[Phi[R], R], R] == 4*Pi*G*Sigma[R]; bc = {Phi[Rmax] == 0, DirichletCondition[Phi[R] == -G*Sigma0*Rd^2, R == 0]}; sol = NDSolve[{ode, bc}, Phi, {R, 0, Rmax}, Method -> {"FiniteElement"}]; Vcirc[R_] := Sqrt[R*Abs[Evaluate[Derivative[1][Phi][R] /. sol[[1]]]]]; plots = Row[{Plot[Evaluate[Phi[R] /. sol], {R, 0, Rmax}, PlotLabel -> Style["Gravitational Potential", 16, Bold], AxesLabel -> {"R", "\[CapitalPhi](R)"}, ImageSize -> 350, PlotStyle -> {Thick, Blue}, GridLines -> Automatic, GridLinesStyle -> Directive[Gray, Dashed]], Plot[Vcirc[R], {R, 0.1, Rmax}, PlotLabel -> Style["Circular Velocity", 16, Bold], AxesLabel -> {"R", "V(R)"}, ImageSize -> 350, PlotStyle -> {Thick, Red}, PlotRange -> {All, {0, Automatic}}, GridLines -> Automatic, GridLinesStyle -> Directive[Gray, Dashed]]}]; plots ![Potential 0][19] It's a different objective with different results. And in particular, by asking to engineer understandable technology, one specifically eschews the phenomenon of computational irreducibility and the whole story of the emergence of complexity. Pedagogical effectiveness on engineering tools to intercept fractional-dimensional physics is personally, something that provides approachable methods to go through scientific complexity and frame our computational work as a sophisticated form of meta-engineering--one that creatively philosophizes systematic harnesses that can be used to power oscillators with many different periods, with algorithmic and human-driven innovation. ClearAll["Global`*"]; FractionalRadialLaplacian[F_, R_, D_] := D[F, {R, 2}] + (D - 2)/R D[F, R] - (D - 3) (D - 1)/(4 R^2) F; RadialSolution[R_, D_, k_] := (k R)^((3 - D)/2) BesselJ[(D - 3)/2, k R]; NormalizedSolution[R_, D_, k_] := RadialSolution[R, D, k]/RadialSolution[1, D, k]; Manipulate[ Plot[Evaluate@ Table[NormalizedSolution[r, dim, 1], {dim, dimensions}], {r, 0.1, 5}, PlotRange -> All, PlotStyle -> Table[{Thick, ColorData["DarkRainbow"][i]}, {i, Length[dimensions]}], AxesLabel -> {"Radius (R)", "Normalized Potential \[CapitalPhi](R)"}, PlotLabel -> Style["Fractional Radial Solutions (k=1)", Bold, 14], Frame -> True, FrameLabel -> {None, None, Style["Variation of \[CapitalPhi](R) with R for Different D", Bold, 12]}, GridLines -> Automatic, GridLinesStyle -> Directive[Gray, Dashed], Epilog -> {Text[ Style["D=3 (Newtonian)", Bold, 10], {3.5, 0.8}, {-1, 0}], Text[Style["D=2.5", Bold, 10], {3.5, 0.6}, {-1, 0}], Text[Style["D=2.0", Bold, 10], {3.5, 0.4}, {-1, 0}]}, ImageSize -> Large, PlotLegends -> Placed[LineLegend[Automatic, dimensions, LegendFunction -> "Frame", LegendLabel -> "Dimensions"], Right]], {{dimensions, {3, 2.5, 2}, "Dimensions"}, {3 -> "3D (Newtonian)", 2 -> "2D", 1.5 -> "1.5D"}}, ControlPlacement -> Top] ![Newton 0][20] By normalizing each solution at R = 1, we can compare how confinement, spreading, and decay properties evolve as D is tuned. In the context of photon propagation, this visualization shows that as dimensionality decreases, photons experience stronger radial localization (as in lower-dimensional materials or near gravitational anomalies), while at D = 3, the familiar Newtonian 1 / R behavior comes out. This simulation thus connects to broader physical theories where spatial dimensionality is dynamic or fractional, such as in effective field theories, quantum gravity models, or exotic condensed matter systems. It exemplifies the core idea from the uploaded text: actively "sculpting" the behavior of complex systems by altering their original rules of dimensionality. ClearAll["Global`*"]; SphericalLaplacianD[F_, r_, \[Theta]_, \[CurlyPhi]_, D_] := Module[{}, 1/r^(D - 1)*D[r^(D - 1)*D[F, r], r] + 1/(r^2*Sin[\[Theta]]^(D - 2))* D[Sin[\[Theta]]^(D - 2)*D[F, \[Theta]], \[Theta]] + 1/(r^2*Sin[\[Theta]]^2*Sin[\[CurlyPhi]]^(D - 3))* D[Sin[\[CurlyPhi]]^(D - 3)*D[F, \[CurlyPhi]], \[CurlyPhi]]]; CylindricalLaplacianD[F_, R_, \[CurlyPhi]_, z_, D_, \[Alpha]R_, \[Alpha]\[CurlyPhi]_, \[Alpha]z_] := Module[{}, (1/R^(D - 2))*D[R^(D - 2)*D[F, R], R] + 1/(R^2*Sin[\[CurlyPhi]]^(D - 3))* D[Sin[\[CurlyPhi]]^(D - 3)*D[F, \[CurlyPhi]], \[CurlyPhi]] + (1/ z^(\[Alpha]z - 1))*D[z^(\[Alpha]z - 1)*D[F, z], z]]; Print["Spherical Symmetry Solution:"]; Assuming[r > 0 && D > 1, solSpherical = DSolve[SphericalLaplacianD[F[r], r, \[Theta], \[CurlyPhi], D] == 0, F[r], r];]; radialSolution = F[r] /. solSpherical[[1]]; Print["Radial Solution: ", radialSolution]; Print["\nCylindrical Symmetry Solution:"]; gegenbauerSolution = GegenbauerC[n, \[Lambda], Cos[\[CurlyPhi]]]; radialEquation = (1/R^(D - 2))* D[R^(D - 2)*D[J[R], R], R] - (k^2 + (m (m + D - 3))/R^2) J[R] == 0; Assuming[R > 0 && D > 1, solRadial = DSolve[radialEquation, J[R], R];]; radialCylSolution = J[R] /. solRadial[[1]] /. {C[1] -> 1, C[2] -> 0}; verticalSolution = Exp[-k Abs[z]]; Print["General Solution:"]; Print["F[R,\[CurlyPhi],z] = ", radialCylSolution, " * ", gegenbauerSolution, " * ", verticalSolution]; Print["\nStandard 3D Case Verification:"]; Print["Spherical (D=3): ", SphericalLaplacianD[F[r], r, \[Theta], \[CurlyPhi], 3] // Simplify]; Print["Cylindrical (D=3): ", CylindricalLaplacianD[F[R], R, \[CurlyPhi], z, 3, 1, 1, 1] // Simplify]; ![Solutions 0][21] ClearAll["Global`*"]; Ddim = 2.5; radialEquation = r^2 R''[r] + (Ddim - 1) r R'[r] + (k^2 r^2 - n^2) R[r] == 0; radialSolution = DSolve[radialEquation /. n -> 0, R[r], r]; R[r_] = (R[r] /. radialSolution[[1]]) /. {C[1] -> 1, C[2] -> 0, k -> 1}; Z[z_] = Exp[-z]; Potential[r_, z_] = R[r]*Z[z]; Plot3D[Potential[r, z], {r, 0, 10}, {z, 0, 5}, PlotRange -> All, AxesLabel -> {"r", "z", "\[CapitalPhi](r,z)"}, PlotLabel -> StringForm["Potential in D=`` Dimensions", Ddim], ColorFunction -> "Rainbow", Mesh -> {10, 10}, MeshStyle -> Opacity[0.5], Boxed -> True, BoxRatios -> {1, 1, 0.5}, Lighting -> "Neutral", LabelStyle -> {FontSize -> 14, FontFamily -> "Helvetica"}] Plot[Potential[r, 0], {r, 0, 10}, PlotRange -> All, AxesLabel -> {"r", "\[CapitalPhi](r,0)"}, PlotLabel -> "Radial Potential Profile", PlotStyle -> {Thick, Red}, GridLines -> {None, Automatic}, GridLinesStyle -> Directive[Gray, Dashed], Frame -> True, FrameLabel -> {"Radius (r)", "Potential \[CapitalPhi]"}, LabelStyle -> {FontSize -> 14, FontFamily -> "Helvetica", Black}] ![0radial0][22] Computational irreducibility leads to infinite diversity and richness of the Bessel functions and fractional dimensions that are possible; computational systems (like the exemplary Mathematica) allow exploration into infinite mathematical structures. Human-driven construction ("exploration") rather than brute-force computational searches, deliberately designed radial equations and fractional solutions with clear objectives, show the computational complexity (irreducibility) by finding analytically or computationally reducible (manageable) solutions--exactly what we're doing by constructing fractional dimension solutions. ClearAll["Global`*"]; FractionalLaplacianCylindrical[D_, \[Psi]_, R_, \[Phi]_, z_] := Module[{}, 1/R^(D - 2) D[R^(D - 2) D[\[Psi], R], R] + 1/(R^2 Sin[D - 3]^\[Phi]) D[ Sin[D - 3]^\[Phi] D[\[Psi], \[Phi]], \[Phi]] + D[\[Psi], {z, 2}]]; \[Psi][R_, \[Phi]_, z_, t_] := J[R] \[CapitalPhi][\[Phi]] Z[z] T[t]; T[t_] := Exp[-I \[Omega] t]; Z[z_] := Exp[-kz Abs[z]]; \[CapitalPhi][\[Phi]_] := GegenbauerC[m, (D - 3)/2, Cos[\[Phi]]]; RadialEquation = 1/R^(D - 2) D[R^(D - 2) D[J[R], R], R] + (\[Omega]^2 - kz^2 - m (m + D - 3)/R^2) J[R] == 0; DValue = 2.5; mValue = 0; kzValue = 0.1; \[Omega]Value = 1; RadialSolution = NDSolveValue[{RadialEquation /. {D -> DValue, m -> mValue, kz -> kzValue, \[Omega] -> \[Omega]Value}, J[0.1] == 1, J'[0.1] == 0}, J, {R, 0.1, 10}]; WavePlot3D = DensityPlot3D[ Re[RadialSolution[R] GegenbauerC[mValue, (DValue - 3)/2, Cos[\[Phi]]] Exp[-kzValue z] Exp[-I \[Omega]Value t] /. t -> 0], {R, 0.1, 5}, {\[Phi], 0, 2 \[Pi]}, {z, -5, 5}, PlotLegends -> Automatic, ColorFunction -> "Rainbow", PlotRange -> All, AxesLabel -> {"R", "\[Phi]", "z"}, PlotLabel -> Style[StringForm["Cylindrical Wave in D=`` Dimension", DValue], 16, Bold]] ![Cylindrical 0][23] Things are invented, things are discovered, and somehow there's an arc of progress that's formed, phenomenally familiar from our overall experience of progress and innovation. Whether our Bessel functions (standard or fractional) represent structured innovation or simply extend well-known radial solutions (standard Bessel functions) to fractional dimensions--mathematical research exemplifies the force of deliberate "invention" in caging irreducibility and harnessing complexity; converting computational complexity into understandable and controllable mathematical solutions is part of what tipped me off to thinking about the ubiquitous computational capabilities of cellular automata and the phenomenon of computational irreducibility. ClearAll["Global`*"]; FractionalLaplacianCylindrical[D_, \[Phi]_, R_, \[CurlyPhi]_, z_] := Module[{}, 1/R^(D - 2)*D[R^(D - 2)*D[\[Phi], R], R] + 1/(R^2*Sin[\[CurlyPhi]]^(D - 3))* D[Sin[\[CurlyPhi]]^(D - 3)*D[\[Phi], \[CurlyPhi]], \[CurlyPhi]] + D[\[Phi], {z, 2}]]; RadialSolution[D_, R_, k_] := (k*R)^((3 - D)/2)* BesselJ[(D - 3)/2, k*R]; AngularSolution[D_, \[CurlyPhi]_] := GegenbauerC[0, (D - 3)/2, Cos[\[CurlyPhi]]]; Potential[D_, R_, z_, k_] := RadialSolution[D, R, k]*AngularSolution[D, \[CurlyPhi]]* Exp[-k*Abs[z]]; CircularVelocity[D_, R_, k_] := Module[{g}, g = -D[RadialSolution[D, R, k], R]; Sqrt[Abs[g]*R]]; MassDistribution[R_, Rd_] := Exp[-R/Rd]; Rd = 2.0; l0 = 9.788*^9; M = 1.5*^41; a0 = 1.2*^-10; sparcData = {{0.5, 50}, {1, 80}, {2, 110}, {5, 130}, {10, 120}, {15, 115}, {20, 110}}; ListPlot[sparcData, PlotStyle -> {Black, PointSize[0.02]}, Prolog -> {Opacity[0.2], LightGray, Rectangle[{0, 90}, {22, 140}]}, AxesLabel -> {"Radius (kpc)", "Velocity (km/s)"}, PlotLabel -> Style["Observed Circular Velocities", Bold, 14], PlotRange -> All, PlotLegends -> {"Data Points"}, GridLines -> Automatic, GridLinesStyle -> Directive[Gray, Dotted], Frame -> True, FrameLabel -> {"Radius (kpc)", "Circular Velocity (km/s)"}, LabelStyle -> {FontFamily -> "Helvetica", FontSize -> 12}] ![Observed 0 ][24] ClearAll["Global`*"]; radialSolution[D_, k_, r_] := (k*r)^((3 - D)/2)* BesselJ[(D - 3)/2 + 0, k*r]; zSolution[k_, z_] := Exp[-k*Abs[z]]; fractionalPotential[D_, k_][r_, z_] := radialSolution[D, k, r]*zSolution[k, z]; DValue = 2.5; kValue = 1; Plot3D[fractionalPotential[DValue, kValue][r, z], {r, 0.1, 5}, {z, -2, 2}, PlotRange -> All, AxesLabel -> {"r", "z", "\[CapitalPhi](r,z)"}, PlotLabel -> Style[StringForm["Fractional Potential (D = ``)", DValue], 16, Bold], ColorFunction -> "TemperatureMap", MeshFunctions -> {#3 &}, PerformanceGoal -> "Quality", Boxed -> True, MeshStyle -> {Gray, Opacity[0.5]}, PlotPoints -> 50] Plot[Evaluate@Table[radialSolution[D, 1, r], {D, 2.1, 3, 0.2}], {r, 0, 5}, PlotRange -> All, AxesLabel -> {"r", "R(r)"}, PlotLabel -> Style["Radial Solutions for Different Dimensions", Bold, 14], PlotLegends -> LineLegend[Automatic, Table[StringForm["D = ``", D], {D, 2.1, 3, 0.2}]], PlotStyle -> Table[ColorData[97][i], {i, 10}], GridLines -> Automatic, GridLinesStyle -> Directive[Gray, Dashed]] ![Different Dimensions][25] One learns "so much more" by being able to see at a glance the history of a system rather than just seeing frames in a video go by. Fractional wave solutions have latent Mathematica 3-dimensional plots, animations, density plots, which construct "cages" (mathematical constraints) around complex fractional solutions, allowing controlled exploration of wave behaviors and potential functions. Structures typically go back to basics in the parts they use. The use of classical mathematical tools such as Bessel and Gegenbauer functions as foundational components utilizes well-established mathematical functions, to write up fractional dimension concepts in general, transforming theoretical mathematical raw materials into practical, analyzable forms. ClearAll["Global`*"]; FractionalLaplacianCylindrical[\[Phi]_, R_, \[CurlyPhi]_, z_, D_] := Module[{dimR = D - 1}, 1/R^dimR D[R^dimR D[\[Phi], R], R] + 1/(R^2 Sin[\[CurlyPhi]]^(D - 3)) D[ Sin[\[CurlyPhi]]^(D - 3) D[\[Phi], \[CurlyPhi]], \[CurlyPhi]] + D[\[Phi], {z, 2}]]; \[Phi][R_, \[CurlyPhi]_, z_] = J[R] F[\[CurlyPhi]] Z[z]; RadialSolution[D_, k_, R_] := (k R)^((3 - D)/2) BesselJ[(D - 3)/2, k R]; AngularSolution[D_, m_, \[CurlyPhi]_] := GegenbauerC[m, (D - 3)/2, Cos[\[CurlyPhi]]]; VerticalSolution[k_, z_] := Exp[-k Abs[z]]; GeneralSolution[D_, R_, \[CurlyPhi]_, z_, kmax_] := Sum[c[m] RadialSolution[D, k[m], R] AngularSolution[D, m, \[CurlyPhi]] VerticalSolution[k[m], z], {m, 0, kmax}]; DValue = 2.5; kValue[m_] := 0.5 + m; c[m_] := 1/(m! + 1); Plot[Evaluate[ Table[Re[RadialSolution[DValue, kValue[m], R]], {m, 0, 3}]], {R, 0, 5}, PlotLabel -> Style["Radial Solutions for Different Modes", 16], AxesLabel -> {"R", "J(R)"}, PlotStyle -> Table[ColorData[97][i], {i, 4}], PlotLegends -> Table[StringForm["Mode m = ``", m], {m, 0, 3}], GridLines -> Automatic, GridLinesStyle -> {Gray, Dashed}, Frame -> True, FrameLabel -> {"Radius (R)", "Radial Function J(R)"}, LabelStyle -> Directive[FontFamily -> "Helvetica", FontSize -> 12]] ![Radial 01][26] \[Nu][D_, m_] := Sqrt[(3 - D)^2 + 4 m^2]/2; RadialSolution[\[Rho]_, D_, m_] := \[Rho]^((3 - D)/2)* BesselJ[\[Nu][D, m], \[Rho]]; WaveFunction[\[Rho]_, \[CurlyPhi]_, t_, D_, m_, \[Beta]_] := RadialSolution[\[Rho], D, m]*Cos[m \[CurlyPhi]]*Exp[I \[Beta] t]; Manipulate[ Plot3D[Re[WaveFunction[\[Rho], \[CurlyPhi], t, D, m, 1]], {\[Rho], 0.1, 10}, {\[CurlyPhi], 0, 2 \[Pi]}, PlotRange -> {-1, 1}, AxesLabel -> {"\[Rho]", "\[CurlyPhi]", "\[CapitalPsi](\[Rho],\[CurlyPhi])"}, ColorFunction -> Function[{x, y, z}, ColorData["Rainbow"][z]], PlotPoints -> 50, PerformanceGoal -> "Quality", Exclusions -> None, Mesh -> 15, MeshStyle -> Opacity[0.5], MeshFunctions -> {#3 &}, ImageSize -> 600, BoxRatios -> {1, 1, 0.5}, AxesOrigin -> {0, 0, 0}, PlotLabel -> Style[StringForm["Wave Function at Time t=``", t], 14, Bold], Ticks -> {Range[0, 10, 2], {0, \[Pi], 2 \[Pi]}, Automatic}, TicksStyle -> Directive[FontSize -> 12, FontFamily -> "Helvetica"]], {t, 0, 2 \[Pi], \[Pi]/10, Appearance -> "Labeled"}, {{D, 3, "Dimension (D)"}, 2, 3, 0.1, Appearance -> "Labeled"}, {{m, 0, "Angular Mode (m)"}, 0, 2, 1, Appearance -> "Labeled"}] ![wave function11][27] How does a photon-like wave function behave in a cylindrical space where the number of spatial dimensions is between 2 and 3? It defines a fractional cylindrical Laplacian that generalizes how waves spread radially, angularly, and vertically in such a space. The total wave function is separated into three parts: a radial part solved by a modified Bessel function, an angular part involving Gegenbauer polynomials to capture directional structure, and a vertical part that decays exponentially along the axis. A more general solution we can build by summing multiple angular modes, each weighted differently, allowing more complex wave patterns. So we see the real part of the evolving wave as time passes, and that is how both the dimension `D` and angular mode `m` affect the structure and motion of the wave. Physically, this setup simulates how photon propagation would change if the spatial area itself had a non-integer dimension, illustrating shifts in radial spread, angular localization, and decay behavior, which are important in contexts like fractal media, quantum gravity, and exotic optical systems. ClearAll["Global`*"]; k = 1; Potential[R_, z_, d_] := (k R)^((3 - d)/2)*BesselJ[(d - 3)/2, k R]* Exp[-k Abs[z]] Manipulate[ ContourPlot[Potential[R, z, d], {R, 0, 5}, {z, -5, 5}, Contours -> 20, PlotRange -> All, Frame -> True, FrameLabel -> {"Radial Distance (R)", "Vertical Height (z)"}, PlotLabel -> Style[StringForm["Fractional Dimension D = ``", d], 16, Bold], ColorFunction -> "DeepSeaColors", ColorFunctionScaling -> True, PlotLegends -> BarLegend[Automatic, LegendLabel -> "Potential (\[CapitalPhi])"], ImageSize -> Large, FrameTicksStyle -> Directive[FontSize -> 12, FontFamily -> "Helvetica"]], {{d, 2.5, "Dimension (D)"}, 1, 3, 0.1, Appearance -> "Labeled", LabelStyle -> Directive[FontSize -> 12]}, ControlPlacement -> Top, SaveDefinitions -> True] ![1 fractional GIF][28] ClearAll["Global`*"]; FractionalCylindricalLaplacian[\[Psi]_, {r_, \[CurlyPhi]_, z_}, D_] := Module[{\[Alpha]r, \[Alpha]\[CurlyPhi], \[Alpha]z}, \[Alpha]r = D - 1; \[Alpha]\[CurlyPhi] = 1; \[Alpha]z = 1; (1/r^(D - 2))* D[r^(D - 2)*D[\[Psi], r], r] + (1/(r^2*Sin[\[CurlyPhi]]^(D - 3)))* D[Sin[\[CurlyPhi]]^(D - 3)*D[\[Psi], \[CurlyPhi]], \[CurlyPhi]] + D[\[Psi], {z, 2}]] FractionalCylindricalWaveSolution[r_, \[CurlyPhi]_, z_, t_, D_, k_, m_] := Module[{radial, angular, temporal}, radial = (k*r)^((3 - D)/2)*BesselJ[(D - 3)/2 + m, k*r]; angular = GegenbauerC[m, (D - 3)/2, Cos[\[CurlyPhi]]]; temporal = Exp[-I*\[Omega]*t]; radial*angular*temporal] DValues = {2.0, 2.5, 3.0}; k = 1; m = 0; rRange = {r, 0.1, 10}; Plot[Evaluate[ Table[(k*r)^((3 - D)/2)*BesselJ[(D - 3)/2 + m, k*r], {D, DValues}]], Evaluate[rRange], PlotLegends -> Placed[("D = " <> ToString[#]) & /@ DValues, Right], PlotLabel -> "Fractional Bessel Radial Solutions (m=0)", AxesLabel -> {"r", "R(r)"}, PlotStyle -> {Automatic, Thick}, ColorFunction -> "Rainbow", ImageSize -> Large, Frame -> True, FrameLabel -> {"Radial Distance (r)", "Radial Function R(r)"}] D3Solution = (k*r)^((3 - 3)/2)*BesselJ[(3 - 3)/2 + 0, k*r]; StandardBessel = BesselJ[0, k*r]; Plot[{D3Solution, StandardBessel}, {r, 0, 10}, PlotLegends -> {"D=3 Solution", "Standard J0"}, PlotLabel -> "Verification of D=3 Case", PlotStyle -> {Dashed, Thick}, ImageSize -> Large, Frame -> True, FrameLabel -> {"r", "Bessel Function"}] ![Bessel 1 0 ][29] In practice, one can use both search and construction techniques to find patterns. Construction rather than brute-force search is the deliberate (human-driven) approach; by systematically exploring parameter spaces (like fractional dimension `D`, wave numbers `k`, and angular modes `m`), we slogged to 18 billion steps to curate and feature new ones, new ways to understand behavior in a computational way that is a mirror image that is not in line with the origin and I am still waiting for one of these switch engines, because in traditional engineering, a key strategy is modularity..to build a collection of independent subsystems from which the whole system can be then assembled. The modular approach of our Mathematica functions `RadialSolution` `AngularSolution` `VerticalSolution` break complex fractional cylindrical solutions into independently analyzable components. ClearAll["Global`*"]; radialEquation[D_, k_] := r^2 R''[r] + (D - 2) r R'[r] - k^2 r^2 R[r] == 0; radialSolution = DSolve[radialEquation[D, k], R[r], r] // Simplify; R[r_, D_, k_] := (k r)^((3 - D)/2)*BesselJ[(D - 3)/2, k r]; potential[r_, z_, D_, k_] := R[r, D, k]*Exp[-k Abs[z]]; Plot3D[potential[r, z, 2.5, 1], {r, 0, 5}, {z, -1, 1}, PlotRange -> All, AxesLabel -> {"r", "z", "\[CapitalPhi]"}, PlotLabel -> Style["Fractional Potential (D=2.5)", 16, Bold], ColorFunction -> {Red, Green, Blue}, Mesh -> True, MeshStyle -> Opacity[0.3], Boxed -> False, AxesOrigin -> {0, 0, 0}, ImageSize -> Large, Lighting -> "Neutral"] ContourPlot[potential[r, 0, 2.5, 1], {r, 0, 5}, {z, -0.1, 0.1}, FrameLabel -> {"r", "z"}, PlotLabel -> Style["Equipotential Lines at z=0", 16, Bold], ColorFunction -> {Red, Green, Blue}, Contours -> 20, PlotLegends -> BarLegend[Automatic, LegendLabel -> "Potential (\[CapitalPhi])"], ImageSize -> Large] ![Equipotential 0][30] ClearAll["Global`*"]; radialEquation[D_] := r^2*\[Phi]''[r] + (D - 1)* r*\[Phi]'[r] + (k^2*r^2 - m^2)*\[Phi][r] == 0; radialSolution[D_] := DSolveValue[{radialEquation[D], \[Phi][31] == 1, \[Phi]'[1] == 0}, \[Phi][r], r]; DensityPlot3D[ BesselJ[(2.5 - 3)/2, Sqrt[x^2 + y^2]]*(Sqrt[x^2 + y^2])^((3 - 2.5)/2)* Exp[-Abs[z]], {x, -5, 5}, {y, -5, 5}, {z, -1, 1}, PlotLegends -> Automatic, ColorFunction -> "TemperatureMap", PlotLabel -> "3D Potential Structure (D=2.5)", BoxRatios -> {1, 1, 0.3}, ImageSize -> 600] ![Structure 0][32] FractionalWaveSolution[D_, m_, k_, R_, phi_, z_] := (k R)^((3 - D)/2)* BesselJ[(D - 3)/2 + m, k R]*GegenbauerC[m, (D - 3)/2, Cos[phi]]* Exp[-k Abs[z]]; Manipulate[ DensityPlot[ FractionalWaveSolution[dimension, mode, waveNumber, r, phi, 0], {r, 0, 10}, {phi, 0, 2 Pi}, ColorFunction -> "SunsetColors", PlotLegends -> BarLegend[Automatic, LegendLabel -> "Amplitude"], FrameLabel -> {Style["R (radial distance)", 16], Style["\[Phi] (angular coordinate)", 16]}, PlotLabel -> Style[StringForm[ "Dimension D = ``, Mode m = ``, Wave Number k = ``", dimension, mode, waveNumber], 14], PlotRange -> All, Exclusions -> None, ImageSize -> Large], {{dimension, 2.5, "Dimension (D)"}, 1.1, 2.9, 0.1, Appearance -> "Labeled"}, {{mode, 0, "Mode (m)"}, 0, 2, 1, Appearance -> "Labeled"}, {{waveNumber, 1, "Wave Number (k)"}, 0.1, 2, 0.1, Appearance -> "Labeled"}, TrackedSymbols :> {dimension, mode, waveNumber}] ![2 fractional][33] The behavior of this potential reflects how forces or fields, such as those from photon propagation or gravity, would spread in a space that is not strictly two- or three-dimensional. Extending this, we also construct a 3D density plot showing the structure of the full potential across x-y-z directions. Finally, we build a more "complete" fractional wave function, incorporating both radial dependence and angular oscillations via Gegenbauer polynomials, and then we animate how the wave amplitude depends on the space dimension D, angular mode m, and wave number k. Altogether, this set of graphical structures shows how photon-like wave structures deform, spread, and oscillate differently when space itself has a fractional number of dimensions, bringing about some new behaviors not present in standard 2-dimensional or 3-dimensional physics. ClearAll["Global`*"]; FractionalLaplacianCylindrical[\[Phi]_, R_, \[CurlyPhi]_, z_, D_] := Module[{}, 1/R^(D - 2)*D[R^(D - 2)*D[\[Phi], R], R] + 1/(R^2*Sin[\[CurlyPhi]]^(D - 3))* D[Sin[\[CurlyPhi]]^(D - 3)*D[\[Phi], \[CurlyPhi]], \[CurlyPhi]] + D[\[Phi], {z, 2}]]; AngularSolution[\[CurlyPhi]_, D_, m_] := GegenbauerC[m, (D - 3)/2, Cos[\[CurlyPhi]]]; RadialSolution[R_, k_, D_, m_] := (k*R)^((3 - D)/2)* BesselJ[(D - 3)/2 + m, k*R]; GalacticPotential[R_, z_, D_, m_, k_] := RadialSolution[R, k, D, m]*AngularSolution[0, D, m]*Exp[-k*Abs[z]]; SurfaceDensity[R_, Rd_] := Exp[-R/Rd]; DValues = {1.5, 1.7, 2.0, 3.0}; Rd = 0.681; kValues = Range[0.1, 2, 0.2]; potentialGrid = Table[GalacticPotential[R, 0, D, 0, k]*SurfaceDensity[R, Rd], {D, DValues}, {R, 0.1, 5, 0.1}, {k, kValues}]; combinedPotential = Map[Mean, potentialGrid, {2}]; ListLinePlot[ Transpose@ Table[{#[[1]], #[[2]]} & /@ Transpose[{Range[0.1, 5, 0.1], combinedPotential[[i]]}], {i, Length[DValues]}], PlotRange -> All, PlotLegends -> Placed[LineLegend[DValues, LegendLabel -> "Dimension D"], Right], Frame -> True, FrameLabel -> {"Radius (kpc)", "Relative Potential"}, PlotLabel -> "Gravitational Potential in Fractional-Dimensional Space", GridLines -> Automatic, ImageSize -> 600, PlotMarkers -> Automatic, PlotStyle -> Table[ColorData["Rainbow"][i], {i, 0, 1, 1/Length[DValues]}]] ![potential 10][34] ClearAll["Global`*"]; radialEq = R''[r] + (0.5/r) R'[r] - R[r] == 0; radialSol = NDSolve[{radialEq, R[1] == 1, R'[1] == 0}, R, {r, 0.1, 10}]; Zz[z_] := Exp[-Abs[z]]; potential[R_, z_] := (R[r] /. radialSol[[1]] /. r -> R)*Zz[z]; Plot3D[potential[R, z], {R, 0.1, 10}, {z, -5, 5}, PlotLabel -> "Gravitational Potential in D=2.5", AxesLabel -> {"R (kpc)", "z (kpc)", "Potential \[CapitalPsi]"}, ColorFunction -> "TemperatureMap", MeshFunctions -> {#3 &}, Mesh -> 20, Contours -> 50, PlotRange -> All, ImageSize -> 600, PlotPoints -> 50] ![potenteial 10][35] ClearAll["Global`*"]; FractionalCylindricalLaplacian[\[Psi]_, r_, \[CurlyPhi]_, z_, D_] := Module[{\[Alpha]r, \[Alpha]\[CurlyPhi], \[Alpha]z}, \[Alpha]r = D/3; \[Alpha]\[CurlyPhi] = D/3; \[Alpha]z = D/3; 1/r^(\[Alpha]r - 1) D[r^(\[Alpha]r - 1) D[\[Psi], r], r] + 1/(r^2 Sin[\[CurlyPhi]]^(\[Alpha]\[CurlyPhi] - 1)) D[ Sin[\[CurlyPhi]]^(\[Alpha]\[CurlyPhi] - 1) D[\[Psi], \[CurlyPhi]], \[CurlyPhi]] + D[\[Psi], {z, 2}]/z^(1 - \[Alpha]z)]; FractionalBesselJ[\[Nu]_, x_, D_] := BesselJ[\[Nu] + (D - 3)/2, x]*x^((3 - D)/2); GegenbauerFactor[n_, D_] := Sqrt[Gamma[n + D - 2]/(Gamma[n + 1] Gamma[D - 2])]; CylindricalWaveSolution[r_, \[CurlyPhi]_, z_, k_, D_, n_] := Exp[-k Abs[z]]*GegenbauerFactor[n, D]*FractionalBesselJ[n, k r, D]* Cos[n \[CurlyPhi]]; Manipulate[ ListPlot3D[ Flatten[Table[{r Cos[\[CurlyPhi]], r Sin[\[CurlyPhi]], z, Abs[CylindricalWaveSolution[r, \[CurlyPhi], z, k, D, n]]}, {r, 0.1, 5, 0.1}, {\[CurlyPhi], 0, 2 \[Pi], \[Pi]/15}, {z, -1, 1, 0.1}], 2], ColorFunction -> "Rainbow", ColorFunctionScaling -> True, AxesLabel -> {"X", "Y", "Z"}, PlotLabel -> StringTemplate[ "Wave Amplitude in Fractional Space (D=``, k=``, n=``)"][D, k, n], PlotRange -> All, ImageSize -> 600], {{D, 3, "Dimension"}, 2, 3, 0.1, Appearance -> "Labeled"}, {{k, 1, "Wave Number"}, 0.5, 2, 0.1, Appearance -> "Labeled"}, {{n, 0, "Angular Mode"}, 0, 3, 1, Appearance -> "Labeled"}, ControlPlacement -> Left] ![Fraftioanl 10][36] Manipulate[ DensityPlot[(x^2 + y^2)^((1 - d/2)/2)* BesselJ[(2 - d)/2, k Sqrt[x^2 + y^2]]*Cos[k t - phase], {x, -10, 10}, {y, -10, 10}, PlotRange -> {-1, 1}, ColorFunction -> "SunsetColors", FrameLabel -> {"X", "Y"}, PlotLabel -> StringForm["D = `` | k = `` | t = ``", NumberForm[d, {3, 1}], NumberForm[k, {3, 1}], NumberForm[t, {3, 1}]], PlotPoints -> 50, PerformanceGoal -> "Quality"], {t, 0, 4 \[Pi], AnimationRate -> 1, Appearance -> "Labeled"}, {{d, 2.5, "Dimension D"}, 1, 3, 0.1, Appearance -> "Labeled"}, {{k, 0.5, "Wave Number"}, 0.1, 1, 0.1, Appearance -> "Labeled"}, {{phase, 0, "Phase"}, 0, 2 \[Pi], Appearance -> "Labeled"}, ControlPlacement -> Left, SynchronousUpdating -> False] ![123][37] We can also model how gravitational-like potentials and wave behaviors evolve in fractional-dimensional cylindrical spaces, where the number of dimensions D can vary between 2 and 3. First, we solve the radial part of the fractional Laplacian to generate gravitational potentials based on Bessel functions normalized for D, and show these potentials both as 3-dimensional surfaces and as 2-dimensional equipotential contours. We then construct galactic potentials by combining the radial field with a surface mass density profile, showing how the gravitational field strength changes across different effective dimensions. In the last part we model cylindrical wave solutions where radial, angular, and vertical behaviors are tied together, using a fractional form of the Bessel function and Gegenbauer polynomials, building the resulting wave amplitude across space. So yes, wave patterns depend on dimension D, wave number k, angular mode n, and phase; both potential fields and wave structures behave differently when the geometry of space itself is permitted to be fractional, setting up effects important for modeling photon propagation in fractal media, theories about gravity, and non-integer-dimensional physical systems. ClearAll["Global`*"]; FractionalCylindricalLaplacian[\[Psi]_, r_, \[CurlyPhi]_, z_, \[Alpha]r_, \[Alpha]\[CurlyPhi]_, \[Alpha]z_] := Module[{dim = \[Alpha]r + \[Alpha]\[CurlyPhi] + \[Alpha]z}, 1/r^(\[Alpha]r - 1) D[r^(\[Alpha]r - 1) D[\[Psi], r], r] + 1/(r^2 Sin[\[CurlyPhi]]^(\[Alpha]\[CurlyPhi] - 1)) D[ Sin[\[CurlyPhi]]^(\[Alpha]\[CurlyPhi] - 1) D[\[Psi], \[CurlyPhi]], \[CurlyPhi]] + D[\[Psi], {z, \[Alpha]z}]]; \[Psi][r_, \[CurlyPhi]_, z_] := R[r] \[CapitalPhi][\[CurlyPhi]] Z[z]; RadialSolution[D_, k_, r_] := BesselJ[(D - 3)/2, k r]/r^((3 - D)/2); AngularSolution[D_, m_, \[CurlyPhi]_] := GegenbauerC[m, (D - 3)/2, Cos[\[CurlyPhi]]] Sin[\[CurlyPhi]]^((3 - D)/2); AxialSolution[\[Alpha]z_, kz_, z_] := Exp[-kz Abs[z]^\[Alpha]z]; FractionalWavefunction[r_, \[CurlyPhi]_, z_, D_, k_, m_, kz_] := RadialSolution[D, k, r] AngularSolution[D, m, \[CurlyPhi]] AxialSolution[1, kz, z]; DValue = 2.5; kValue = 1; mValue = 0; kzValue = 0.5; Plot3D[FractionalWavefunction[r, \[CurlyPhi], 0, DValue, kValue, mValue, kzValue], {r, 0.1, 5}, {\[CurlyPhi], 0, 2 \[Pi]}, PlotPoints -> 100, ColorFunction -> "Rainbow", MeshFunctions -> {#3 &}, Mesh -> 20, PlotLabel -> Style["D=2.5 Cylindrical Wavefunction", 16, Bold], AxesLabel -> {"r", "\[CurlyPhi]", "\[CapitalPsi](r,\[CurlyPhi])"}, BoxRatios -> {1, 2, 1}, Lighting -> "Neutral", ViewPoint -> {2, -2, 1}, PerformanceGoal -> "Quality"] LogLogPlot[Abs[RadialSolution[DValue, kValue, r]]^2, {r, 0.1, 10}, PlotStyle -> {Thick, Red}, Frame -> True, FrameLabel -> {"r", "|R(r)|²"}, GridLines -> {None, Automatic}, GridLinesStyle -> Directive[Gray, Dashed], PlotLabel -> Style["Radial Probability Distribution", 14], PlotRange -> All] ![wavef0][38] ClearAll["Global`*"]; RadialSolution[D_, k_, R_] := (k R)^((3 - D)/2)* BesselJ[(D - 3)/2, k R]; Manipulate[ Plot[RadialSolution[D, 1, R], {R, 0, 10}, PlotRange -> {-0.6, 1.0}, PlotStyle -> {Thick}, AxesLabel -> {"Radial Distance R", "Radial Solution J(R)"}, PlotLabel -> Style[Row[{"Radial Solution for Fractional Dimension D = ", D}], Bold, 14], ImageSize -> Large, GridLines -> Automatic, Frame -> True, FrameLabel -> {"Radial Distance R", "Amplitude", None, None}, FrameStyle -> Directive[GrayLevel[0.2], 14], LabelStyle -> Directive[Black, 12], TicksStyle -> Black], {{D, 2.5, "Dimension D"}, 1.1, 2.9, 0.05, Appearance -> "Labeled"}, TrackedSymbols :> {D}] kValue = 1; DValue = 2.5; ContourPlot[(kValue R)^((3 - DValue)/2)* BesselJ[(DValue - 3)/2, kValue R]*Exp[-kValue Abs[z]], {R, 0.1, 10}, {z, -5, 5}, PlotRange -> All, ColorFunction -> "ThermometerColors", Contours -> 20, ContourShading -> True, Frame -> True, FrameLabel -> {"Radial Distance R", "Axial Distance z"}, FrameStyle -> Directive[GrayLevel[0.2], 14], PlotLabel -> Style[Row[{"Potential Contours for D = ", DValue}], Bold, 14], LabelStyle -> Directive[Black, 12], TicksStyle -> Black, ImageSize -> Large] ![potential contours][39] So when computational irreducibility is flashing in front of your face the reducibility is not going to work that well. What can the Game of Life tell us about complex systems of human governance or how to make those, things found by human effort like construction..these are much less likely to be minimal but they are, optimized for comprehensibility. Our detailed visual analysis over minimality is the way that we computationally randomizes, over the years, a lot of..a whole variety of different solutions have been found! Some are thoroughly controlled constructions; others are based on complex processes that are reined in. Specifically we compare fractional solutions to integer-dimensional (standard) solutions, dealing with raw direct comparative analysis--computationally reduce both controlled analytic forms and complex, numerical behaviors. ClearAll["Global`*"]; FractionalRadialSolution[D_, k_, r_] := (k*r)^((3 - D)/2)* BesselJ[(D - 3)/2 + m, k*r] m = 0; k = 1; rRange = {r, 0, 10}; Plot[Evaluate@ Table[FractionalRadialSolution[D, k, r], {D, {2.0, 2.5, 3.0}}], rRange, PlotStyle -> {Red, Green, Blue}, PlotLegends -> Placed[LineLegend[{2.0, 2.5, 3.0}, LegendLabel -> "Dimension D"], Right], AxesLabel -> {"r", "R(r)"}, PlotLabel -> "Fractional Radial Solutions (m=0)", GridLines -> Automatic, ImageSize -> 600] GegenbauerComponent[D_, \[CurlyPhi]_] := GegenbauerC[m, (D - 3)/2, Cos[\[CurlyPhi]]] DValue = 2.5; zValue = 1; DensityPlot3D[ FractionalRadialSolution[DValue, k, Sqrt[x^2 + y^2]]* GegenbauerComponent[DValue, ArcTan[x, y]]*Exp[-k*Abs[z]], {x, -5, 5}, {y, -5, 5}, {z, -zValue, zValue}, PlotLabel -> StringForm["Fractional Solution (D=``)", DValue], ColorFunction -> "Rainbow", BoxRatios -> {1, 1, 0.5}, ImageSize -> 600] ![Solutional Fractional 1][40] ClearAll["Global`*"]; Ddim = 2.5; \[Lambda] = (Ddim - 3)/2; {R, \[CurlyPhi], z} = {r, \[Phi], z}; k = 1; m = 0; angularSolution[\[CurlyPhi]_] := GegenbauerC[m, \[Lambda], Cos[\[CurlyPhi]]]; order = \[Lambda] + m; radialSolution[R_] := (k*R)^((3 - Ddim)/2)*BesselJ[order, k*R]; verticalSolution[z_] := Exp[-k*Abs[z]]; potential[R_, \[CurlyPhi]_, z_] := radialSolution[R]*angularSolution[\[CurlyPhi]]*verticalSolution[z]; DensityPlot3D[ potential[Sqrt[x^2 + y^2], ArcTan[x, y], z], {x, -5, 5}, {y, -5, 5}, {z, -2, 2}, ColorFunction -> "Rainbow", PlotLegends -> BarLegend[Automatic], AxesLabel -> {"X", "Y", "Z"}, PlotLabel -> "Potential in D=" <> ToString[Ddim] <> " Dimensions", PlotPoints -> 50, PerformanceGoal -> "Quality", PlotRange -> All] Plot[radialSolution[R], {R, 0, 10}, PlotRange -> All, AxesLabel -> {"R", "\[CapitalPhi](R)"}, PlotLabel -> "Radial Solution (D=" <> ToString[Ddim] <> ")", GridLines -> Automatic, PlotStyle -> Thick] PolarPlot[angularSolution[\[CurlyPhi]], {\[CurlyPhi], 0, 2 \[Pi]}, PlotLabel -> "Angular Solution (D=" <> ToString[Ddim] <> ")", GridLines -> Automatic, PlotStyle -> {Thick, Red}, PolarAxes -> True] ![Phenomenon1][41] ClearAll["Global`*"]; FractionalLaplacianCylindrical[D_, f_, R_] := D[f[R], {R, 2}] + (D - 2)/R D[f[R], R]; RadialSolution[D_, k_, R_] := (k R)^((3 - D)/2)*BesselJ[(D - 3)/2 + m, k R] /. m -> 0; Potential[D_, R_, kMax_, l0_, M_] := Module[{kd, wR, wd, sum, int, G = 6.674*^-11}, kd = 100; wd = 0.681; wR = R/l0; sum = M/(2 \[Pi] wd^2)*Exp[-wR/wd]; int = NIntegrate[ k^((5 - D)/2)*wR^((3 - D)/2)*BesselJ[(D - 1)/2, k wR]* BesselJ[(D - 3)/2, k wd]/(k^2 + wd^-2)^(3/2), {k, 0, kd}, Method -> "AdaptiveMonteCarlo"]; -2 \[Pi] G*Sqrt[\[Pi]]*Gamma[(D - 1)/2]/Gamma[D/2 - 1]*int]; CircularVelocity[D_, R_, l0_, M_] := Module[{gR}, gR = Abs[Potential[D, R, 100, l0, M]/R]; Sqrt[gR*R*l0]]; M = 1.5*^36; l0 = 9.788*^19; a0 = 1.2*^-10; acceleration = Table[{R, Abs[Potential[1.7, R, 100, l0, M]/R]}, {R, 0.1, 20, 0.5}]; ListLinePlot[acceleration, PlotLabel -> "Acceleration Profile (D=1.7)", AxesLabel -> {"R (kpc)", "Acceleration (m/s²)"}, ScalingFunctions -> "Log"] ![Acceleration profile][42] ClearAll["Global`*"]; Print[Style[ "Laplace's Equation in Cylindrical Coordinates for Fractional \ Dimensions", Bold, 22, Blue]]; radialEquation = r^2 R''[r] + (D - 1) r R'[r] + k^2 r^2 R[r] == 0; angularEquation = \[CapitalPsi]''[\[Phi]] + ((D - 3)/ Tan[\[Phi]]) \[CapitalPsi]'[\[Phi]] + k^2 \[CapitalPsi][\[Phi]] == 0; radialSolution = DSolveValue[radialEquation, R[r], r] // FullSimplify; radialSolution = radialSolution /. {C[1] -> C[3], C[2] -> C[4]}; angularSolution = DSolveValue[angularEquation, \[CapitalPsi][\[Phi]], \[Phi]] // FullSimplify; angularSolution = angularSolution /. {C[1] -> C[1], C[2] -> C[2]}; backgroundFade[dval_] := Blend[{Lighter[Blue, 0.8], RGBColor[0.05, 0.05, 0.2]}, Rescale[dval, {2, 3}]]; radialZoomRange[dval_] := {0, 10 - 5*(dval - 2)}; dynamicFontSize[dval_] := 12 + 4*(dval - 2); dynamicSceneCinematic[dval_] := Grid[{{Panel[ Column[{Style["Radial Solution (Expanded):", Bold, dynamicFontSize[dval], Darker[Blue]], TraditionalForm[ FunctionExpand[radialSolution /. D -> dval] // FullSimplify], Plot[(r)^((3 - dval)/2) BesselJ[(dval - 3)/2, r], {r, radialZoomRange[dval][[1]], radialZoomRange[dval][[2]]}, PlotRange -> {Automatic, Automatic}, PlotStyle -> Thick, Frame -> True, FrameLabel -> {Style["r", dynamicFontSize[dval], Black], Style["Radial Solution", dynamicFontSize[dval], Black]}, FrameStyle -> Directive[Black, 14], LabelStyle -> {Black, dynamicFontSize[dval]}, PlotLabel -> Style[Row[{"Bessel-based Radial Plot for D = ", NumberForm[dval, {2, 2}]}], Bold, dynamicFontSize[dval]], GridLines -> Automatic, ImageSize -> Medium]}, Spacings -> 2], Background -> backgroundFade[dval], FrameMargins -> Medium], Panel[Column[{Style["Angular Solution (Expanded):", Bold, dynamicFontSize[dval], Darker[Green]], TraditionalForm[ FunctionExpand[angularSolution /. D -> dval] // FullSimplify]}, Spacings -> 2], Background -> Lighter[Green, 0.85], FrameMargins -> Medium]}}, Alignment -> Center, Spacings -> 5]; cinematicAnimation = Manipulate[ dynamicSceneCinematic[ dval], {{dval, 2.0, "Fractional Dimension D"}, 2.0, 3.0, AnimatorElements -> "PlayPauseButton", AnimationRunning -> True, AnimationRate -> 0.01}, ControlPlacement -> Top, SaveDefinitions -> True]; cinematicAnimation ![Laplace01][43] Also we mustn't forget to model how wavefunctions, potentials, and gravitational-like forces behave in fractional-dimensional cylindrical spaces, where the dimension D is allowed to scale between 2 and 3. So we can demonstrate some fractional radial solutions using Bessel functions and Gegenbauer polynomials to describe the radial and angular behavior of fields and waves. These solutions plus exponential decay along the vertical axis make for some formidable, full 3D potentials for almost any wavefunction. The gravitational potential is a modular, surface mass density profile, and its dimensional variation...is in relation to our computed acceleration profiles based on the derived fractional potentials, helping to illustrate how gravitational forces would look in lower-dimensional or fractal-like settings. With the power of Mathematica, in real-time let's go exploring how the radial and angular structures evolve as the dimension D changes, focusing on features such as radial spread, angular localization, and attenuation along the vertical direction. In conclusion, the underlying spatial dimension has quite an effect on wave propagation & gravitational behavior, that's the connection to theoretical studies in photon transport, gravitational modeling, and fractional field theories. ClearAll["Global`*"]; radialSolution[D_, k_, R_] := (k R)^((3 - D)/2) BesselJ[(D - 3)/2, k R]; FractionalCylindricalSolution[R_, \[Phi]_, z_, D_, k_, m_] := Module[{\[Lambda], radial, angular, vertical}, \[Alpha]z = 1; \[Lambda] = (D - \[Alpha]z - 2)/2; radial = (k R)^((3 - D)/2) BesselJ[\[Lambda] + m, k R]; angular = GegenbauerC[m, \[Lambda], Cos[\[Phi]]]; vertical = Exp[-k Abs[z]]; radial*angular*vertical]; standardSolution[R_, k_] := BesselJ[0, k R]; Manipulate[ Module[{fractional, standard}, fractional = FractionalCylindricalSolution[R, 0, 0, D, 1, 0]; standard = standardSolution[R, 1]; Show[Plot[{fractional, standard}, {R, 0, 5}, PlotStyle -> {Thick, {Dashed, Red}}, PlotLegends -> Placed[{Style[ "Fractional Solution (D = " <> ToString@NumberForm[D, {2, 2}] <> ")", Black], Style["Standard Solution (D = 3)", Red]}, Above], Frame -> True, FrameLabel -> {"Radial Distance R", "Potential \[CapitalPhi](R)"}, FrameStyle -> Directive[Black, 14], LabelStyle -> {Black, 12}, ImageSize -> Large, PlotRange -> All, GridLines -> Automatic], PlotLabel -> Style["Comparison of Fractional and Standard Laplace Solutions", Bold, 16]]], {{D, 2.5, "Fractional Dimension D"}, 1.0, 3.0, 0.05, Appearance -> "Labeled"}, SaveDefinitions -> True] ![comparison10][44] ClearAll["Global`*"]; safeR[r_] := Max[r, 10^-6]; safePhi[\[Phi]_] := Which[Abs[Mod[\[Phi], \[Pi]] - \[Pi]/2] < 10^-6, \[Pi]/2 + 10^-6, Abs[Mod[\[Phi], \[Pi]] + \[Pi]/2] < 10^-6, -(\[Pi]/2) + 10^-6, True, \[Phi]]; FractionalCylindricalLaplacian[\[Psi]_, r_, \[Phi]_, z_, D_] := Module[{rr, pp}, rr = safeR[r]; pp = safePhi[\[Phi]]; (1/rr^(D - 2)) D[rr^(D - 2) D[\[Psi], r], r] + (1/rr^2) D[\[Psi], {\[Phi], 2}] + D[\[Psi], {z, 2}] + (D - 3)/(rr^2 Tan[pp]) D[\[Psi], \[Phi]]]; RadialSolution[r_, k_, D_] := safeR[r]^((3 - D)/2) BesselJ[(D - 3)/2, k*safeR[r]]; AngularSolution[\[Phi]_, m_, D_] := GegenbauerC[m, (D - 3)/2, Cos[safePhi[\[Phi]]]]; AxialSolution[z_, kz_] := Exp[-kz Abs[z]]; WaveSolution[r_, \[Phi]_, z_, k_, kz_, m_, D_] := RadialSolution[r, k, D]*AngularSolution[\[Phi], m, D]* AxialSolution[z, kz]; Manipulate[Module[{sol}, sol = WaveSolution[r, \[Phi], 0, k, kz, m, D]; ListPlot3D[ Flatten[Table[{r*Cos[\[Phi]], r*Sin[\[Phi]], Re[sol /. {r -> r, \[Phi] -> \[Phi], k -> k, m -> m}]}, {r, 0.01, 1, 0.05}, {\[Phi], 0, 2 \[Pi], \[Pi]/20}], 1], ColorFunction -> "Rainbow", PlotRange -> All, AxesLabel -> {"X", "Y", "\[CapitalPsi]"}, PlotLabel -> StringForm["Fractional Dimension D = ``", D]]], {{D, 2.5, "Dimension"}, 2, 3, 0.1, Appearance -> "Labeled"}, {{k, 1, "Radial Wave Number"}, 0.5, 5, 0.1, Appearance -> "Labeled"}, {{m, 0, "Angular Mode"}, 0, 5, 1, Appearance -> "Labeled"}, {{kz, 0, "Axial Wave Number"}, 0, 5, 0.1, Appearance -> "Labeled"}, {{plotType, "3D", "Plot Type"}, {"3D"}}, ControlPlacement -> Left] Plot3D[Re[ WaveSolution[Sqrt[x^2 + y^2], ArcTan[x, y], 0, 1, 0, 1, 2.5]], {x, -1, 1}, {y, -1, 1}, ColorFunction -> "Rainbow", AxesLabel -> {"X", "Y", "\[CapitalPsi]"}, PlotLabel -> "Cylindrical Wave in D=2.5 Space"] ![cylindrical][45] ![Wave Cylindrical][46] How do fractional-dimensional cylindrical spaces differ from the familiar standard three-dimensional case? Well, we've already built a fractional generalization of Laplace's equation, constructing radial solutions with Bessel functions and angular solutions with Gegenbauer polynomials, all non-integer dimensions considered..we compare the fractional solution to the standard D = 3 solution, to show how the field's radial behavior tightens or spreads depending on the space's dimensionality. A separate part constructs complete 3D wavefunctions that include radial, angular, and vertical decay components, using safe handling of singularities near r = 0 and critical angular points. Therefore the wave profile changes as the dimension D, radial wave number k, angular mode m, and axial wave number k vary. So fractional-dimensional geometry dramatically alters wave propagation, not just in photonic fields but also in exotic or effective lower-dimensional spaces. ClearAll["Global`*"]; FractionalLaplacianCylindrical[D_, f_, r_, \[Phi]_, z_] := Module[{\[Alpha]r = D - 2, \[Alpha]\[Phi] = 1, \[Alpha]z = 1}, (1/r^\[Alpha]r D[r^\[Alpha]r D[f, r], r] + (1/(r^2 Sin[\[Phi]]^(D - 3)) D[ Sin[\[Phi]]^(D - 3) D[f, \[Phi]], \[Phi]] + D[f, {z, 2}]))]; FractionalWaveSolution[D_, r_, \[Phi]_, z_, k_, m_] := Module[{radialPart = (k r)^((3 - D)/2) BesselJ[(D - 3)/2 + m, k r], angularPart = GegenbauerC[m, (D - 3)/2, Cos[\[Phi]]], verticalPart = Exp[-k Abs[z]]}, radialPart*angularPart*verticalPart]; Manipulate[ Module[{sol, coordinates}, sol = FractionalWaveSolution[D, r, \[Phi], 0, 1, 0]; coordinates = Table[{r Cos[\[Phi]], r Sin[\[Phi]], sol}, {r, 0.1, 5, 0.2}, {\[Phi], 0, 2 \[Pi], \[Pi]/20}]; ListPlot3D[Flatten[coordinates, 1], ColorFunction -> "Rainbow", PlotRange -> All, AxesLabel -> {"X", "Y", "Amplitude"}, PlotLabel -> StringForm["D=`` Cylindrical Wave", D], MeshFunctions -> {#3 &}, Mesh -> 10]], {{D, 2.5, "Fractional Dimension"}, 2, 3, 0.1, Appearance -> "Labeled"}, TrackedSymbols :> {D}] ![Fractional][47] radialSolution[D_, k_, R_] := (k*R)^((3 - D)/2)*BesselJ[(D - 3)/2, k*R] Manipulate[ Plot[radialSolution[D, k, R], {R, 0, 10}, PlotRange -> All, AxesLabel -> {"Radial Distance R", "Amplitude"}, PlotLabel -> Style[Row[{"Dimension D = ", D, ", Wave Number k = ", k}], 14, Bold], ImageSize -> 500, PlotStyle -> {Thick, ColorData[97, 1]}, GridLines -> Automatic, GridLinesStyle -> LightGray], {{D, 3, "Dimension D"}, 2, 3, 0.1, Appearance -> "Labeled"}, {{k, 1, "Wave Number k"}, 0.1, 2, 0.1, Appearance -> "Labeled"}, ControlPlacement -> Left, TrackedSymbols :> {D, k}] ![wave number][48] ClearAll["Global`*"]; radialEquation = J''[R] + ((D - 2)/R) J'[R] + k^2 J[R] == 0; radialSolution = DSolve[radialEquation, J[R], R]; radialFunction = J[R] /. radialSolution[[1]]; k = 1; dimensions = Range[2.1, 3, 0.1]; Plot3D[radialFunction /. {C[1] -> 1, C[2] -> 0, k -> 1}, {R, 0, 10}, {D, 2, 3}, AxesLabel -> {"R", "D", "J(R)"}, PlotLabel -> Style["Radial Solution vs Dimension", 16, Bold], ColorFunction -> "Rainbow", ImageSize -> 800] ![Dimension vs Radial][49] ClearAll["Global`*"]; FractionalCylindricalLaplacian[\[Psi]_, R_, \[Phi]_, z_, D_] := Module[{}, 1/R^(D - 2)*D[R^(D - 2)*D[\[Psi], R], R] + 1/(R^2*Sin[\[Phi]]^(D - 3))* D[Sin[\[Phi]]^(D - 3)*D[\[Psi], \[Phi]], \[Phi]] + D[\[Psi], {z, 2}]] \[CapitalPsi][R_, \[Phi]_, z_] := Rradial[R]*Rangular[\[Phi]]*Exp[-k*Abs[z]] Rangular[\[Phi]_] := GegenbauerC[m, (Ddim - 3)/2, Cos[\[Phi]]] Rradial[R_] := (k*R)^((3 - Ddim)/2)*BesselJ[(Ddim - 3)/2 + m, k*R] Ddim = 4.5; m = 0; k = 1; RadialPlot = Plot[Evaluate@ Table[Rradial[R] /. {Ddim -> d, m -> 0, k -> 1}, {d, {4.1, 4.5, 4.9, 5.0}}], {R, 0, 10}, PlotStyle -> {Thick, Dashed, Dotted, Thick}, PlotLegends -> Placed[LineLegend[{"D=4.1", "D=4.5", "D=4.9", "D=5.0"}, LegendFunction -> "Frame"], {Right, Top}], AxesLabel -> {"R", "\[Psi](R)"}, PlotLabel -> "Radial Wave Function in Fractional Dimensions"]; WavePlot3D = DensityPlot3D[ Evaluate[\[CapitalPsi][Sqrt[x^2 + y^2], ArcTan[x, y], z] /. {Ddim -> 4.5, m -> 0, k -> 1}], {x, -5, 5}, {y, -5, 5}, {z, -2, 2}, PlotLegends -> Automatic, ColorFunction -> "Rainbow", PlotLabel -> "3D Fractional Wave Solution (D=4.5)", AxesLabel -> {"X", "Y", "Z"}]; Grid[{{RadialPlot, WavePlot3D}}] ![wave solution 3][50] ClearAll["Global`*"]; FractionalCylindricalLaplacian[D_][f_, r_, \[Phi]_, z_] := Module[{\[Alpha]r = D - 2, \[Alpha]\[Phi] = 1, \[Alpha]z = 1}, (1/r^\[Alpha]r)*D[r^\[Alpha]r*D[f, r], r] + (1/r^2)* D[f, {\[Phi], 2}] + D[f, {z, 2}]]; FractionalCylindricalWaveSolution[D_, k_, m_, n_, r_, \[Phi]_, z_, t_] := Module[{radialPart, angularPart, zPart, timePart}, radialPart = BesselJ[(D - 3)/2 + m, k*r]; angularPart = Exp[I*m*\[Phi]]; zPart = Exp[-k*Abs[z]]; timePart = Exp[I*Sqrt[k^2 - n^2]*t]; radialPart*angularPart*zPart*timePart]; DValue = 2.5; kValue = 1; mValue = 0; Manipulate[ Module[{wave, coordinates}, wave = FractionalCylindricalWaveSolution[D, k, m, 0, r, \[Phi], 0, t]; coordinates = Table[{r*Cos[\[Phi]], r*Sin[\[Phi]], Re[wave]}, {r, 0.1, 5, 0.5}, {\[Phi], 0, 2 \[Pi], \[Pi]/20}]; ListPlot3D[Flatten[coordinates, 1], ColorFunction -> "Rainbow", PlotRange -> All, AxesLabel -> {"X", "Y", "Amplitude"}, PlotLabel -> StringForm["D=``, k=``, m=``", D, k, m]]], {{D, 2.5, "Dimension"}, 2.1, 2.9, 0.1, Appearance -> "Labeled"}, {{k, 1, "Wave Number"}, 0.5, 2, 0.1, Appearance -> "Labeled"}, {{m, 0, "Azimuthal Mode"}, 0, 2, 1, Appearance -> "Labeled"}, {t, 0, 2 \[Pi], AnimationRate -> 0.5}] Plot3D[Re[ FractionalCylindricalWaveSolution[0, 1, 0, 0, Sqrt[x^2 + y^2], ArcTan[x, y], 0, 0]], {x, -5, 5}, {y, -5, 5}, ColorFunction -> "Aquamarine", PlotRange -> All, AxesLabel -> {"X", "Y", "Amplitude"}, PlotLabel -> "Fractional Cylindrical Wave (D=0)"] ![Dimension 30][51] RadialSolution[D_, m_, k_, R_] := (k R)^((3 - D)/2) BesselJ[(D - 3)/2 + m, k R] VerticalSolution[k_, z_] := Exp[-k Abs[z]] FullSolution[D_, k_, R_, z_] := RadialSolution[D, 0, k, R]*VerticalSolution[k, z] Manipulate[ Plot3D[FullSolution[D, k, R, z], {R, 0.1, 10}, {z, -5, 5}, PlotLabel -> Row[{"Fractional Cylindrical Wave\nDimension D = ", D}], AxesLabel -> {"R", "z", "\[CapitalPhi](R,z)"}, ColorFunction -> "TemperatureMap", MeshFunctions -> {#3 &}, PlotRange -> All, PerformanceGoal -> "Quality"], {{D, 2.5, "Dimension"}, 1, 3, 0.1, Appearance -> "Labeled"}, {{k, 0.5, "Wave Number"}, 0.1, 2, 0.1, Appearance -> "Labeled"}, ControlPlacement -> Left] DensityPlot[FullSolution[2.5, 0.7, R, z], {R, 0.1, 10}, {z, -5, 5}, PlotLabel -> "Potential Distribution (D=2.5, k=0.7)", FrameLabel -> {"R", "z"}, ColorFunction -> "SunsetColors", PlotLegends -> Automatic] ![dist3][52] ClearAll["Global`*"]; FractionalLaplacianCylindrical[\[CapitalPhi]_, R_, \[Phi]_, z_, D_] := Module[{}, 1/R^(D - 2)*D[R^(D - 2)*D[\[CapitalPhi], R], R] + 1/(R^2*Sin[\[Phi]]^(D - 3))* D[Sin[\[Phi]]^(D - 3)*D[\[CapitalPhi], \[Phi]], \[Phi]] + D[\[CapitalPhi], {z, 2}]] SolutionForm[R_, z_, \[Phi]_, D_, k_, m_] := (k*R)^((3 - D)/2)* BesselJ[(D - 3)/2 + m, k*R]*GegenbauerC[m, (D - 3)/2, Cos[\[Phi]]]* Exp[-k*Abs[z]] DValue = 0.7; kValue = 0.1; mValue = 0; Potential[R_, z_, \[Phi]_] := SolutionForm[R, z, \[Phi], DValue, kValue, mValue] DensityPlot3D[ Potential[Sqrt[x^2 + y^2], z, ArcTan[x, y]], {x, -15, 15}, {y, -15, 15}, {z, -2, 2}, PlotLegends -> Automatic, ColorFunction -> "Rainbow", PlotRange -> All, AxesLabel -> {"X (kpc)", "Y (kpc)", "Z (kpc)"}, PlotLabel -> Style["Fractional-Dimensional Gravitational Potential (D=0.7)", 12, Bold]] ![07d][53] ClearAll["Global`*"]; DVal = 2.5; k = 1; c = 1; m = 0; radialEquation = R''[r] + ((DVal - 2)/r) R'[r] + (k^2 - m^2/r^2) R[r] == 0; radialSolution = DSolve[radialEquation, R[r], r] // Simplify; RSolution[r_] = radialSolution[[1, 1, 2]] /. {C[1] -> 1, C[2] -> 0} FPhi[\[CurlyPhi]_] = 1; TSolution[t_] = Exp[-I c k t]; Phi[r_, \[CurlyPhi]_, t_] = RSolution[r]*FPhi[\[CurlyPhi]]*Re[TSolution[t]]; Animate[Plot[Phi[r, 0, t], {r, 0.1, 10}, PlotRange -> {{0, 10}, {-1.2, 1.2}}, PlotLabel -> Style["Radial Wave Profile at t = " <> ToString[t] <> " (D = " <> ToString[DVal] <> ")", 14], AxesLabel -> {"Radius (r)", "Amplitude"}], {t, 0, 2 \[Pi], \[Pi]/10}] ![pit][54] Manipulate[ Module[{k = 1, radialSolution, angularSolution, combinedSolution}, radialSolution[r_] := (k*r)^((3 - dim)/2)* BesselJ[(dim - 3)/2 + m, k*r]; angularSolution[\[CurlyPhi]_] := GegenbauerC[m, (dim - 3)/2, Cos[\[CurlyPhi]]]; PolarPlot[ radialSolution[r]*angularSolution[\[CurlyPhi]] /. \[CurlyPhi] -> 0, {r, 0, 10}, PlotRange -> All, AxesLabel -> {"R", "Amplitude"}, PlotLabel -> Style[Row[{"Fractional Cylindrical Wave Solution\n", "Dimension D = ", NumberForm[dim, {3, 1}], ", Mode m = ", m}], 14, Bold], ImageSize -> 500, PlotStyle -> ColorData["Rainbow"][(dim - 1)/2], GridLines -> Automatic, GridLinesStyle -> LightGray]], {{dim, 2.0, "Space Dimension (D)"}, 1.1, 2.9, 0.1, Appearance -> "Labeled"}, {{m, 0, "Azimuthal Mode Number"}, 0, 3, 1, Appearance -> "Labeled"}, TrackedSymbols :> {dim, m}, ControlPlacement -> Left, Paneled -> True, FrameLabel -> Style["Fractional Space Wave Solutions", 14, Bold]] ![Fractional Polar Wave][55] DValue = 2.5; k = 1; omega = 1; c = 1; radialSolutionD[r_] := (k*r)^((3 - DValue)/2)* BesselJ[(DValue - 3)/2, k*r] radialSolution3D[r_] := BesselJ[0, k*r] timeSolution[t_] := Exp[-I*omega*t] waveFunction[r_, t_, D_] := Module[{radial}, radial = If[D == 3, radialSolution3D[r], radialSolutionD[r]]; radial*timeSolution[t]] Plot[{Abs[radialSolutionD[r]], Abs[radialSolution3D[r]]}, {r, 0, 10}, PlotStyle -> {Blue, Red}, PlotLegends -> {"D=2.5", "D=3"}, AxesLabel -> {"Radial Distance (R)", "Amplitude"}, PlotLabel -> "Radial Wave Solutions Comparison", BaseStyle -> 14] Plot3D[Re[waveFunction[r, t, 2.5]], {r, 0, 10}, {t, 0, 10}, AxesLabel -> {"R", "Time", "Re[\[Psi]]"}, PlotLabel -> "Cylindrical Wave in D=2.5 Space", ColorFunction -> "Rainbow", MeshFunctions -> {#3 &}, BaseStyle -> 14] ![comp1][56] d = 2.5; k = 1; radialSolution[r_] := r^((2 - d)/2)*BesselI[(d - 2)/2, k*r] zSolution[z_] := Exp[-k*z] potential[r_, z_] := radialSolution[r]*zSolution[z] Plot3D[potential[r, z], {r, 0.1, 5}, {z, 0, 5}, PlotRange -> All, AxesLabel -> {"R", "Z", "\[CapitalPhi]"}, PlotLabel -> StringForm["Fractional Laplace Equation (D=``)", d], ColorFunction -> "TemperatureMap"] ![laplace10][57] ClearAll["Global`*"]; Off[Power::indet]; Manipulate[ Module[{\[Nu], \[Mu], RSol, ZSol}, \[Nu] = Sqrt[((2 - 1 - 1)/2)^2 + m^2]; RSol[\[Rho]_] := \[Rho]^0*(BesselJ[\[Nu], \[Beta]\[Rho] \[Rho]] + BesselY[\[Nu], \[Beta]\[Rho] \[Rho]]); RSol[0] = Limit[RSol[\[Rho]], \[Rho] -> 0]; \[CapitalPhi][\[Theta]_] := Cos[m \[Theta]]; \[Mu] = (1 - \[Alpha]3)/2; ZSol[z_] := z^((1 - \[Alpha]3)/2) (BesselJ[\[Mu], \[Beta]z z] + BesselY[\[Mu], \[Beta]z z]); ZSol[0] = Limit[ZSol[z], z -> 0]; Column[{Plot[RSol[\[Rho]], {\[Rho], 0.1, 10}, AxesLabel -> {"\[Rho]", "R(\[Rho])"}, PlotLabel -> "Radial"], Plot[\[CapitalPhi][\[Theta]], {\[Theta], 0, 2 \[Pi]}, AxesLabel -> {"\[Theta]", "\[CapitalPhi](\[Theta])"}, PlotLabel -> "Angular"], Plot[ZSol[z], {z, 0.1, 10}, AxesLabel -> {"z", "Z(z)"}, PlotLabel -> "Longitudinal"]}]], {{m, 0, "m"}, 0, 5, 1, Appearance -> "Labeled"}, {{\[Alpha]3, 1, "\[Alpha]3"}, 0.1, 1, Appearance -> "Labeled"}, {{\[Beta]\[Rho], 1, "\[Beta]\[Rho]"}, 0, 2, Appearance -> "Labeled"}, {{\[Beta]z, 1, "\[Beta]z"}, 0, 2, Appearance -> "Labeled"}, TrackedSymbols :> {m, \[Alpha]3, \[Beta]\[Rho], \[Beta]z}] ![Angular][58] Here you will find fractional-dimensional cylindrical waves and gravitational potentials, where space has a non-integer dimension D. By solving modified Laplacian and Helmholtz equations, we show how radial spread, angular localization, and vertical decay are altered compared to standard three-dimensional behavior. The simulations resurface the old wave and field structures relevant to photon propagation, fractal media, and new gravity theories. ClearAll["Global`*"]; Ddim = 2.5; k = 1; radialODE = J''[R] + (Ddim - 2)/R J'[R] + k^2 J[R] == 0; radialSol = DSolve[radialODE, J[R], R]; radialSolution = J[R] /. radialSol[[1]]; verticalODE = Z''[z] - k^2 Z[z] == 0; verticalSol = DSolve[verticalODE, Z[z], z]; verticalSolution = Z[z] /. verticalSol[[1]]; potential[R_, z_] = radialSolution*verticalSolution; visualizationSolution = potential[R, z] /. {C[1] -> 1, C[2] -> 0, C[3] -> 1, C[4] -> 0}; Plot3D[Evaluate[visualizationSolution], {R, 0, 5}, {z, -5, 5}, PlotRange -> All, ColorFunction -> "TemperatureMap", AxesLabel -> {"R", "z", "\[CapitalPhi](R,z)"}, PlotLabel -> StringForm["Fractional-Dimensional Potential (D=``)", Ddim], MeshFunctions -> {#3 &}, Mesh -> 20, PerformanceGoal -> "Quality"] ContourPlot[Evaluate[visualizationSolution], {R, 0, 5}, {z, -5, 5}, FrameLabel -> {"R", "z"}, PlotLegends -> Automatic, ColorFunction -> "ThermometerColors", Contours -> 20, PlotLabel -> StringForm["Potential Contours (D=``)", Ddim]] ![d25][59] ClearAll["Global`*"]; FractionalLaplacianCylindrical[D_, f_, r_, \[Phi]_, z_] := Module[{}, 1/r^(D - 2) D[r^(D - 2) D[f, r], r] + 1/(r^2 Sin[\[Phi]]^(D - 3)) D[ Sin[\[Phi]]^(D - 3) D[f, \[Phi]], \[Phi]] + D[f, {z, 2}]]; FractionalHelmholtz[\[Psi]_, k_, D_, r_, \[Phi]_, z_] := FractionalLaplacianCylindrical[D, \[Psi][r, \[Phi], z], r, \[Phi], z] + k^2 \[Psi][r, \[Phi], z] == 0; \[Psi]Solution[r_, \[Phi]_, z_, D_, m_, kz_, n_] := Module[{kr = Sqrt[k^2 - kz^2]}, (BesselJ[(D - 3)/2 + m, kr r]/r^((D - 3)/2)* GegenbauerC[n, (D - 3)/2, Cos[\[Phi]]]*Exp[-kz Abs[z]])]; k = 1; m = 0; kz = 0.5; n = 0; Manipulate[ Module[{D = dim, kr = Sqrt[k^2 - kzVal^2]}, DensityPlot3D[ BesselJ[(D - 3)/2, kr r]/r^((D - 3)/2)*Cos[\[Phi]]* Exp[-kzVal Abs[z]], {r, 0, 10}, {\[Phi], 0, 2 \[Pi]}, {z, -2, 2}, PlotLabel -> Row[{"Fractional Dimension D = ", dim}], ColorFunction -> "TemperatureMap", BoxRatios -> {1, 1, 0.5}]], {{dim, 2.5, "Dimension D"}, 2.1, 3, 0.1, Appearance -> "Labeled"}, {{kzVal, 0.5, "Vertical Wave Number kz"}, 0, 1, 0.1, Appearance -> "Labeled"}] ![dim32][60] ClearAll["Global`*"]; FractionalLaplacianCylindrical[\[Psi]_, R_, \[CurlyPhi]_, z_, D_] := 1/R^(D - 2) D[R^(D - 2) D[\[Psi], R], R] + 1/(R^2 Sin[\[CurlyPhi]]^(D - 3)) D[ Sin[\[CurlyPhi]]^(D - 3) D[\[Psi], \[CurlyPhi]], \[CurlyPhi]] + D[\[Psi], {z, 2}] FractionalWaveSolution[R_, \[CurlyPhi]_, z_, D_, k_, m_] := Module[{\[Nu] = (3 - D)/2 + m, \[Lambda] = (D - 3)/2}, radial = (k R)^((3 - D)/2) BesselJ[\[Nu], k R]; angular = GegenbauerC[m, \[Lambda], Cos[\[CurlyPhi]]]; vertical = Exp[-k Abs[z]]; radial*angular*vertical] Dvals = {2.0, 2.5, 3.0}; k = 0.1; m = 0; z0 = 0; colors = ColorData["Rainbow"] /@ Rescale[Dvals]; labels = ("D = " <> ToString[#]) & /@ Dvals; curves = Table[FractionalWaveSolution[R, 0, z0, D, k, m], {D, Dvals}]; D25Wave[R_, \[CurlyPhi]_] := FractionalWaveSolution[R, \[CurlyPhi], z0, 2.5, k, m]; sphPlot = SphericalPlot3D[ D25Wave[r, \[CurlyPhi]], {r, 0, 20}, {\[CurlyPhi], 0, 2 \[Pi]}, PlotTheme -> "Detailed", Mesh -> None, ColorFunction -> Function[{x, y, z, th, ph}, ColorData["Thermometer"][z]], ColorFunctionScaling -> True, Lighting -> "Neutral", Boxed -> False, Axes -> False, ImageSize -> 450, PlotLabel -> Style["Wave Pattern in D = 2.5 Fractal Space", 16, Bold]] ![waver][61] ClearAll[RadialSolution]; RadialSolution[r_, D_, k_, m_] := (k r)^((3 - D)/2) BesselJ[(D - 3)/2 + m, k r] k = 1; m = 0; dims = Range[2, 3, 0.2]; colors = ColorData["BrightBands"] /@ Rescale[dims]; Plot[Evaluate@Table[RadialSolution[r, D, k, m], {D, dims}], {r, 0.1, 10}, PlotTheme -> "Detailed", PlotStyle -> Map[{#, Thick} &, colors], PlotLegends -> Placed[LineLegend[colors, ("D = " <> ToString[#]) & /@ dims, LegendLabel -> "Dimension"], Below], Frame -> True, FrameLabel -> (Style[#, 14, Bold] & /@ {"r", "R(r)"}), FrameTicksStyle -> Directive[FontSize -> 12], GridLines -> Automatic, ImageSize -> Medium, PlotLabel -> Style["Radial Wave Solutions for Varying D", 16, Bold]] Manipulate[ Plot[RadialSolution[r, D, k, m], {r, 0.1, 10}, PlotTheme -> "Detailed", PlotStyle -> {Thick, ColorData["DarkRainbow"][Rescale[D, {2, 3}]]}, Frame -> True, FrameLabel -> (Style[#, 14, Bold] & /@ {"r", "R(r)"}), FrameTicksStyle -> Directive[FontSize -> 12], PlotRange -> All, ImageSize -> Medium, PlotLabel -> Style["Radial Solution, D = " <> ToString[NumberForm[D, {2, 1}]], 16, Bold]], {{D, 2.5, "Dimension D"}, 2, 3, 0.1, Appearance -> "Labeled"}] \[Omega] = 1; \[Psi][r_, t_, D_] := RadialSolution[r, D, k, m]*Cos[\[Omega] t]; Animate[Plot[\[Psi][r, t, 2.5], {r, 0.1, 10}, PlotTheme -> "Detailed", PlotStyle -> {Thick, ColorData["TemperatureMap"][0.8]}, Frame -> True, FrameLabel -> (Style[#, 14, Bold] & /@ {"r", "\[Psi](r,t)"}), FrameTicksStyle -> Directive[FontSize -> 12], PlotRange -> {-1, 1}, ImageSize -> Medium, PlotLabel -> Style["Wave Propagation at D = 2.5", 16, Bold]], {t, 0, 2 \[Pi], Appearance -> "Labeled"}, AnimationRunning -> False, AnimationRate -> 0.5, ControlPlacement -> Top] ![varyd][62] ![radial solutions][63] ![wave propagation][64] ![sol-d30][65] Some more wave and potential solutions in spaces of fractional dimension D between 2 and 3. We solve modified radial and vertical differential equations that describe how potentials or fields propagate differently when the spatial dimension is non-integer, such as D = 2.5. These solutions are expressed using Bessel functions and Gegenbauer polynomials, capturing radial, angular, and axial behaviors. The resulting plots illustrate how the wave structure, oscillations, and decay patterns evolve as D varies, offering discussions about photon propagation, gravity, or field behavior in non-Euclidean or fractal-like spaces. ClearAll[radialWave]; radialWave[r_, d_, m_, k_] := r^((3 - d)/2) BesselJ[(d - 3)/2 + m, k r]; Manipulate[ Module[{colFrac, colStd}, colFrac = ColorData["DarkRainbow"][Rescale[d, {2, 3}]]; colStd = GrayLevel[0.4]; Plot[{radialWave[r, d, m, k], radialWave[r, 3, m, k]}, {r, 0.1, 10}, PlotTheme -> "Detailed", ImageSize -> 500, PlotRange -> {-1, 1}, PlotStyle -> {{colFrac, Thick}, {colStd, Dashed, Thick}}, Filling -> {1 -> Axis}, FillingStyle -> Directive[colFrac, Opacity[0.2]], Frame -> True, FrameLabel -> (Style[#, 14, Bold] & /@ {"r", "R(r)"}), FrameTicksStyle -> Directive[FontSize -> 12], GridLines -> Automatic, GridLinesStyle -> Directive[LightGray, Dashed], PlotLegends -> Placed[LineLegend[{colFrac, colStd}, {Style["Fractional D", 12], Style["Standard D=3", 12]}, LegendMarkerSize -> 30], Above], PlotLabel -> Style[Row[{"Radial Wave: ", Style["D=", Bold], NumberForm[d, {2, 1}], ", m=", m, ", k=", k}], 16, Bold]]], {{d, 3, "Dimension (D)"}, 2, 3, 0.1, Appearance -> "Labeled"}, {{m, 0, "Azimuthal Order (m)"}, 0, 2, 1, Appearance -> "Labeled"}, {{k, 1, "Wave Number (k)"}, 0.1, 5, 0.1, Appearance -> "Labeled"}, ControlPlacement -> Left] ![dimazu][66] Now, before the rest of our article slips out of our hands like it was about to (if something happens to our article Simon Fischer we might simply create a new revised article with the attributes of the old), thus that is why I'm making a new reply. It probably has something to do with the length of the post. But that's not our fault. It's something to do with the shark who hosts these forum discussion boards, but no need to fear because I will be able to load them back up, and continue onward on our creation, of radial wave solutions in fractional-dimensional space versus standard three-dimensional space. We may need a new article for this; don't hesitate to tell them, there's a need to have more demonstrations, of the radial part of the wave equation using Bessel functions, because..the wave shape changes depending on the fractional dimension, the azimuthal mode number, and the wave number and in order to show the fractional dimension solution, and in order to more properly describe how waves would propagate differently in spaces that are not exactly three-dimensional, which is important for understanding not just photon propagation but also gravitational fields, in fractal-like geometries..so please bear with us, we've already described most of what we want to describe with regard to how fractional Laplacians can play a role in modifications to wave dispersion in slightly higher-level physics. [at0]: https://community.wolfram.com/web/98fischersimon [at1]: https://community.wolfram.com/web/gmorbelli [at2]: https://community.wolfram.com/web/98fischersimon [at3]: https://community.wolfram.com/web/98fischersimon [at4]: https://community.wolfram.com/web/98fischersimon [at5]: https://community.wolfram.com/web/98fischersimon [1]: https://community.wolfram.com/groups/-/m/t/2574806 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=radius0.png&userId=2553367 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=equipotential0.png&userId=2553367 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=fractinoal0.png&userId=2553367 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=potential0.png&userId=2553367 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=wave00.png&userId=2553367 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=viewpotential0.png&userId=2553367 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=aexes0.png&userId=2553367 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=solution00.png&userId=2553367 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=radial00.png&userId=2553367 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=FractionalDimensionalPotential.gif&userId=2553367 [12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=angulardistribution0.png&userId=2553367 [13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=jockpc0.png&userId=2553367 [14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=scale0.png&userId=2553367 [15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3D_Potential_Animation.gif&userId=2553367 [16]: https://community.wolfram.com//c/portal/getImageAttachment?filename=radial0.png&userId=2553367 [17]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Radial_Solution_Animation.gif&userId=2553367 [18]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Cylindrical_Solution_Animation.gif&userId=2553367 [19]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1248potential0.png&userId=2553367 [20]: https://community.wolfram.com//c/portal/getImageAttachment?filename=newton0.png&userId=2553367 [21]: https://community.wolfram.com//c/portal/getImageAttachment?filename=solutions0.png&userId=2553367 [22]: https://community.wolfram.com//c/portal/getImageAttachment?filename=0radial0.png&userId=2553367 [23]: https://community.wolfram.com//c/portal/getImageAttachment?filename=cylindrical0.png&userId=2553367 [24]: https://community.wolfram.com//c/portal/getImageAttachment?filename=observed0.png&userId=2553367 [25]: https://community.wolfram.com//c/portal/getImageAttachment?filename=differentdimensions.png&userId=2553367 [26]: https://community.wolfram.com//c/portal/getImageAttachment?filename=radial01.png&userId=2553367 [27]: https://community.wolfram.com//c/portal/getImageAttachment?filename=11waveFunctionAnimation.gif&userId=2553367 [28]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1fractional_potential.gif&userId=2553367 [29]: https://community.wolfram.com//c/portal/getImageAttachment?filename=bessel10.png&userId=2553367 [30]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9171equipotential0.png&userId=2553367 [31]: https://community.wolfram.com//c/portal/getImageAttachment?filename=radius0.png&userId=2553367 [32]: https://community.wolfram.com//c/portal/getImageAttachment?filename=structure0.png&userId=2553367 [33]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2FractionalWaveAnimation.gif&userId=2553367 [34]: https://community.wolfram.com//c/portal/getImageAttachment?filename=potentail10.png&userId=2553367 [35]: https://community.wolfram.com//c/portal/getImageAttachment?filename=potentiela10.png&userId=2553367 [36]: https://community.wolfram.com//c/portal/getImageAttachment?filename=fractioanl10.png&userId=2553367 [37]: https://community.wolfram.com//c/portal/getImageAttachment?filename=123CylindricalWavePropagation.gif&userId=2553367 [38]: https://community.wolfram.com//c/portal/getImageAttachment?filename=wavef0.png&userId=2553367 [39]: https://community.wolfram.com//c/portal/getImageAttachment?filename=potentialcontours.png&userId=2553367 [40]: https://community.wolfram.com//c/portal/getImageAttachment?filename=solutionfractional1.png&userId=2553367 [41]: https://community.wolfram.com//c/portal/getImageAttachment?filename=phenomenone1.png&userId=2553367 [42]: https://community.wolfram.com//c/portal/getImageAttachment?filename=aceelerationprofile.png&userId=2553367 [43]: https://community.wolfram.com//c/portal/getImageAttachment?filename=laplace01.png&userId=2553367 [44]: https://community.wolfram.com//c/portal/getImageAttachment?filename=copmarioson10.png&userId=2553367 [45]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3FractionalCylindricalWave.gif&userId=2553367 [46]: https://community.wolfram.com//c/portal/getImageAttachment?filename=wavecylindrical01.png&userId=2553367 [47]: https://community.wolfram.com//c/portal/getImageAttachment?filename=fractionalWave.gif&userId=2553367 [48]: https://community.wolfram.com//c/portal/getImageAttachment?filename=radialSolution_D_k.gif&userId=2553367 [49]: https://community.wolfram.com//c/portal/getImageAttachment?filename=dimensionvsradial.png&userId=2553367 [50]: https://community.wolfram.com//c/portal/getImageAttachment?filename=wavesolution3.png&userId=2553367 [51]: https://community.wolfram.com//c/portal/getImageAttachment?filename=dimension30.png&userId=2553367 [52]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1863dist3.png&userId=2553367 [53]: https://community.wolfram.com//c/portal/getImageAttachment?filename=07d.png&userId=2553367 [54]: https://community.wolfram.com//c/portal/getImageAttachment?filename=pit.png&userId=2553367 [55]: https://community.wolfram.com//c/portal/getImageAttachment?filename=fractionalPolarWave.gif&userId=2553367 [56]: https://community.wolfram.com//c/portal/getImageAttachment?filename=comp1.png&userId=2553367 [57]: https://community.wolfram.com//c/portal/getImageAttachment?filename=laplace10.png&userId=2553367 [58]: https://community.wolfram.com//c/portal/getImageAttachment?filename=angular.png&userId=2553367 [59]: https://community.wolfram.com//c/portal/getImageAttachment?filename=d25.png&userId=2553367 [60]: https://community.wolfram.com//c/portal/getImageAttachment?filename=dime2.png&userId=2553367 [61]: https://community.wolfram.com//c/portal/getImageAttachment?filename=waver.png&userId=2553367 [62]: https://community.wolfram.com//c/portal/getImageAttachment?filename=varyd.png&userId=2553367 [63]: https://community.wolfram.com//c/portal/getImageAttachment?filename=radialSolutions.gif&userId=2553367 [64]: https://community.wolfram.com//c/portal/getImageAttachment?filename=wavePropagationD2.5.gif&userId=2553367 [65]: https://community.wolfram.com//c/portal/getImageAttachment?filename=sold30.png&userId=2553367 [66]: https://community.wolfram.com//c/portal/getImageAttachment?filename=dimazu.png&userId=2553367 Dean Gladish 2025-04-29T06:45:23Z https://community.wolfram.com/groups/-/m/t/3444782 In this [post][1], instead of symbolic strings, @Max Niederman's approach builds structure iteratively. In this framework, ideas from Emil Post's deterministic tag systems are applicable to non-deterministic scenarios. Whereas, in the past, we examined the growth rates of these systems and then disregarded the iterative expansion of multi-way systems due to their heavy computational demands, it turns out right now that we can look at the state evolution of multi-way systems. Moreover, in the cinematic universe of deterministic tag systems, the initial state carries information inefficiently--each bit is "charged" with thousands of electrons. Recognizing this inefficiency prompts the exploration of alternative informational carriers, such as photons, hinting at the promising potential of photonic computing. ClearAll[$LEGOPrototile, discreteRotate, MultiwayTransforms, GrowBrick, IntersectingQ, IterateMultiwayLEGO, DisplayMultiwayLEGO]; Unprotect[IntersectingQ]; IntersectingQ[vox1_, vox2_] := Not@FreeQ[Flatten[Outer[Equal, vox1, vox2, 1], 1], True]; Protect[IntersectingQ]; $LEGOPrototile = <|"Voxels" -> {{0, 0, 0}}, "Connectors" -> {{{0, 0, 0}, {1, 0, 0}}, {{0, 0, 0}, {0, 1, 0}}, {{0, 0, 0}, {0, 0, 1}}}|>; discreteRotate[dir_] := RotateLeft[dir, 1]; MultiwayTransforms[match_, move_] := {match[[2]], discreteRotate[move[[2]]]}; GrowBrick[transformation_] := Module[{shift = transformation[[1]]}, <| "Voxels" -> (# + shift) & /@ $LEGOPrototile["Voxels"], "Connectors" -> Map[{#[[1]] + shift, discreteRotate[#[[2]]]} &, $LEGOPrototile[ "Connectors"]]|>]; IterateMultiwayLEGO[data_] := Module[{max = Max[Keys[data["Structures"]]] + 1, funs, candidates, newTile}, funs = MapApply[MultiwayTransforms, Tuples[{data["Connectors"], $LEGOPrototile["Connectors"]}]]; candidates = Map[GrowBrick, funs]; candidates = Select[candidates, Not@IntersectingQ[#, data["Voxels"]] &]; If[candidates === {} || candidates === Null, data, newTile = First[candidates]; <|"Voxels" -> Union[data["Voxels"], newTile["Voxels"]], "Structures" -> Append[data["Structures"], max -> newTile], "Connectors" -> Union[data["Connectors"], newTile["Connectors"]]|>]]; DisplayMultiwayLEGO[data_] := Graphics3D[{EdgeForm[Directive[Thin, Gray]], MapIndexed[{ColorData["Rainbow"][#2[[1]]/ Length[data["Structures"]]], Cuboid[# - {0.45, 0.45, 0.45}, # + {0.45, 0.45, 0.45}]} &, data["Voxels"]], {Red, Sphere[#, 0.25] & /@ (First /@ data["Connectors"])}, {Green, Arrow[Tube[#, 0.07]] & /@ data["Connectors"]}}, Boxed -> False, Lighting -> "Neutral", ImageSize -> 200]; MultiwayLEGOExplorerStatic[iterations_ : 10] := Module[{data, genList}, data = <|"Voxels" -> $LEGOPrototile["Voxels"], "Structures" -> <|1 -> $LEGOPrototile|>, "Connectors" -> $LEGOPrototile["Connectors"]|>; genList = NestList[IterateMultiwayLEGO, data, iterations]; Row[MapIndexed[ Row[{Style["Generation " <> ToString[#2[[1]] - 1], Bold, 14], DisplayMultiwayLEGO[#]}] &, genList], Alignment -> Center]]; MultiwayLEGOExplorerStatic[2] ![Generation][2] This iterative, LEGO-inspired construction is analogous to how symbolic string instantiation works in tag systems. Just as a tag system evolves by applying production rules to strings, here the structure evolves through discrete rotations and translations that sequentially match those operations. Each iteration examines the potential for non-deterministic growth by selecting valid "tiles" (or LEGO pieces) that can connect without overlapping existing parts. Niederman's work emphasizes the complexity and cyclic nature of state evolution from simple iterative rules, and this LEGO analogy cyclically reveals a similar progression--albeit in a geometric context. Although the focus isn't yet strictly on building physical LEGO blocks, the analogy helps to illustrate the principles behind a binary string multi-way system format and tag-like string evolution. So let's look at some tag-like string evolution instead. ruledRule1044 = {{0, 0} -> {0, 1}, {0, 0} -> {1, 1}, {0, 1} -> {0, 1}, {0, 1} -> {1, 1}, {1, 0} -> {1, 0}, {1, 0} -> {1, 1}, {1, 1} -> {1, 0}, {1, 1} -> {1, 1}}; colorAssociation = <|1 -> Blue, 2 -> Cyan, 3 -> Green, 4 -> Brown, 5 -> Orange, 6 -> Red, 7 -> Magenta, 8 -> Purple|>; GenerateTransitions[state_] := Flatten[Table[ Module[{currentPair, matches}, currentPair = state[[i ;; i + 1]]; matches = Flatten[Position[ruledRule1044, currentPair -> _]]; Map[{state, ReplacePart[state, Thread[Range[i, i + 1] -> ruledRule1044[[#, 2]]]], #} &, matches]], {i, Length[state] - 1}], 1]; initialState = {0, 1, 1}; maxSteps = 3; edges = {}; states = {initialState}; currentStates = {initialState}; Do[newTransitions = Flatten[GenerateTransitions /@ currentStates, 1]; newStates = DeleteCases[DeleteDuplicates[newTransitions[[All, 2]]], Alternatives @@ states]; edges = Join[edges, newTransitions]; states = Union[states, newStates]; currentStates = newStates; If[Length[currentStates] == 0, Break[]], {maxSteps}]; edgeStyles = # -> colorAssociation[#2] & @@@ Transpose[{DirectedEdge @@@ edges[[All, ;; 2]], edges[[All, 3]]}]; formatState[s_List] := StringJoin[ToString /@ s]; stateLabels = Thread[states -> Map[Style[formatState[#], 12, Bold, Black] &, states]]; Graph[DirectedEdge @@@ edges[[All, ;; 2]], VertexLabels -> stateLabels, EdgeLabels -> Placed[Automatic, "Center"], EdgeStyle -> edgeStyles, VertexShapeFunction -> "Square", VertexSize -> Large, VertexStyle -> Directive[White, EdgeForm[Black]], GraphLayout -> {"LayeredDigraphEmbedding", "Orientation" -> Top}, PlotTheme -> "Detailed", PerformanceGoal -> "Quality", ImageSize -> 300] ![Multiway Iterative][3] The concept of multi-way tag evolution as it stands, as strings of binary digits that evolve readily according to non-deterministic rules, means that we don't have to look at multi-way tag evolution as it exists right now. The computational overhead, makes it possible for us to transform binary states. So this is all so far the multi-way nature of transitions, the "rabbit system" and multi-way extensions that color-code edges based on applied rules (e.g. the "twin horn system"), where color-coding emphasizes particular transitions. With a nifty bit of data wrangling we can re-do the non-deterministic rules and look at the evolution of binary digit strings from the beginning. colorAssociation1D = <|0 -> Black, 1 -> Blue, 2 -> Yellow|>; updateRule[{a_, b_, c_}] := Switch[{a, b, c}, {2, 2, 2}, 0, {_, 1, _}, Mod[a + c, 3], _, Mod[a + b + c, 3]]; gridWidth = 101; initialState = ConstantArray[0, gridWidth]; initialState[[Ceiling[gridWidth/2]]] = 1; numSteps = 100; getCircularTriplet[list_, i_] := Module[{n = Length[list]}, {list[[Mod[i - 2, n, 1]]], list[[i]], list[[Mod[i, n, 1]]]}]; history = NestList[ Table[updateRule[getCircularTriplet[#, i]], {i, Length[#]}] &, initialState, numSteps]; Panel[DynamicModule[{frame = 1}, Column[{Row[{Button["⏪", If[frame > 1, frame--], ImageSize -> Small], Button["⏩", If[frame < numSteps, frame++], ImageSize -> Small], Button["\[FilledRightTriangle]", While[frame < numSteps, frame++; Pause[0.05]], ImageSize -> Small]}], Dynamic[ArrayPlot[history[[1 ;; frame]], ColorRules -> Normal[colorAssociation1D], PixelConstrained -> 2, Frame -> False, ImageSize -> 800]]}, Alignment -> Center]], ImageSize -> 250] ![Image Progression][4] However, the binary state transitions alone don't fully explain the meaning of complex system dynamics. They don't fully explain the story and that is why we need to recall the evolution of say, a simple cellular automaton state through iterative application of rules wherein each iteration's outcome depends solely on local state patterns--analogous to local string manipulations in tag systems. The generation history of states, introduces temporal evolution which, while it might not tell us what we're plotting--the growth and evolution histories of tag system states--while it doesn't tell us the "now" it does tell us the development of complexity in the context of cyclic pattern formation, which for now represents a 1-dimensional cellular automaton with circular conditions. ruledRule1044 = {"00" -> "01", "00" -> "11", "01" -> "01", "01" -> "11", "10" -> "10", "10" -> "11", "11" -> "10", "11" -> "11"}; rulesWithIndices = MapIndexed[#1 -> #2[[1]] &, ruledRule1044]; graph = ResourceFunction["MultiwaySystem"][ruledRule1044, "00", 4, "EvolutionCausalGraph", GraphLayout -> "LayeredDigraphEmbedding"]; edgeTags = EdgeTags[graph]; edgeStyles = If[MatchQ[edgeTags, _Association] && Length[Keys[edgeTags]] === Length[EdgeList[graph]], Thread[EdgeList[ graph] -> (colorAssociation /@ (Lookup[rulesWithIndices, #, 1] & /@ (Values[edgeTags]))), Directive[Black, Thickness[0.004]] ];] styledGraph = Graph[graph, EdgeStyle -> edgeStyles, VertexStyle -> Black, VertexSize -> 0.8, VertexLabels -> Placed["Name", Center], EdgeLabels -> Placed["EdgeTag", 0.5], VertexLabelStyle -> Directive[White, Bold, 12], EdgeLabelStyle -> Directive[Black, Italic, 10], ImageSize -> 300, Prolog -> {Transparent, Rectangle[Scaled[{0, 0}], Scaled[{1, 1}]]}] ![Causal Niederman][5] Wolfram's built-in multi-way system framework mirrors eight degrees of freedom, that is the exact functionality that Niederman employs in `MultiwaySystem`; the rule tracking of rule-labeled edges (causal connections), is how we Ruliologically clarify how multi-way transformations branch out non-deterministically, leading to complex system states. So when you look at the graph styling with vertex labels and edge-tags, you'll emphasize the colorized role of specific transformations or production rules. colorAssociation = <|0 -> Blue, 1 -> Cyan, 2 -> Green, 3 -> Brown, 4 -> Orange, 5 -> Red, 6 -> Magenta, 7 -> Purple|>; Stabilize1D[s_, zc_] := Module[{i, newList}, i = FirstPosition[s, _?(# >= zc &)]; If[MissingQ[i], Return[s]]; i = i[[1]]; newList = ReplacePart[s, i -> s[[i]] - 2]; If[i > 1, newList = ReplacePart[newList, i - 1 -> newList[[i - 1]] + 1]]; If[i < Length[s], newList = ReplacePart[newList, i + 1 -> newList[[i + 1]] + 1]]; Stabilize1D[newList, zc]]; PossibilityGenerator1D[state_, zc_] := DeleteDuplicates@ Table[Module[{newState = state}, newState[[pos]] += 1; Stabilize1D[newState, zc]], {pos, Length@state}]; size = 3; Manipulate[ Module[{graph, initialState = PadRight[ConstantArray[0, size], 3]}, graph = ResourceFunction["NestGraphTagged"][ PossibilityGenerator1D[#, zc] &, {initialState}, steps, VertexShapeFunction -> (Inset[ ArrayPlot[{#2}, ColorRules -> colorAssociation, ImageSize -> 30, Mesh -> True, PlotLabel -> #2], #1, Center] &), VertexSize -> 0.8, EdgeStyle -> Directive[Thick, Blue], GraphLayout -> "LayeredDigraphEmbedding", ImageSize -> 600]; HighlightGraph[graph, Style[PathGraph[FindShortestPath[graph, initialState, #]], Directive[Thick, Red]] & /@ VertexList[graph]]], {{zc, 3, "Toppling Threshold"}, 2, 5, 1}, {{steps, 3, "Evolution Steps"}, 1, 5, 1}, ControlPlacement -> Top] ![Toppling Threshold][6] Multi-way tag systems can generate multiple states from single initial conditions. The "possibility generator" is a bottomless pit; it creates multiple outcomes for each state, via the use of `NestGraphTagged` to finitely enumerate multiple state evolutions, methods of finite reachable state spaces in tag systems. So if you really needed to enumerate the reachable state spaces, there you have the "toppling threshold" parameter which influences our investigation of how small parameter changes can drastically alter the kind of growth rates and open structural complexity of tag system state graphs. That's why we start out with the iterative evolution and visualization of complex states from simple local rules. We could create branching multi-way state graphs many times over and we will usually get non-deterministic expansions, which I suppose is an echo of the geometric and abstract symbolism "as analogs" to tag system operations, illustrating computational universality. That's why we need to make this clear. ruledRule1044 = {"00" -> "01", "00" -> "11", "01" -> "01", "01" -> "11", "10" -> "10", "10" -> "11", "11" -> "10", "11" -> "11"}; colorAssociation = <|1 -> Blue, 2 -> Cyan, 3 -> Green, 4 -> Brown, 5 -> Orange, 6 -> Red, 7 -> Magenta, 8 -> Purple|>; depth = 4; Module[{mwGraph, styledEdges, myGraph, vertexCount, edgeCount, meanVertexDegree, meanBetweenness, infoPanel}, mwGraph = ResourceFunction["MultiwaySystem"][ruledRule1044, "00", depth, "StatesGraph", EdgeLabels -> "EdgeTag", GraphLayout -> "LayeredDigraphEmbedding"]; styledEdges = MapIndexed[Tooltip[#1, "Edge " <> ToString[First[#2]]] &, MapIndexed[ Style[#1, colorAssociation[ Mod[First[#2], Length[colorAssociation], 1]]] &, EdgeList[mwGraph]]]; myGraph = Graph[styledEdges, VertexLabels -> Placed["Name", Center], VertexStyle -> White, VertexSize -> 0.3, VertexLabelStyle -> Directive[Black, Bold, 12], EdgeStyle -> Thickness[0.008], GraphLayout -> "LayeredDigraphEmbedding", PlotTheme -> "Detailed", ImageSize -> 100]; vertexCount = VertexCount[myGraph]; edgeCount = EdgeCount[myGraph]; meanVertexDegree = N[Mean[VertexDegree[myGraph]]]; meanBetweenness = N[Mean[BetweennessCentrality[myGraph]]]; infoPanel = Grid[{{"Vertex Count", vertexCount}, {"Edge Count", edgeCount}, {"Avg. Degree", NumberForm[meanVertexDegree, 3]}, {"Avg. Betweenness", NumberForm[meanBetweenness, 3]}}, Frame -> All, Background -> {None, {{LightBlue, White, LightBlue, White}}}]; Column[{Labeled[myGraph, "Multiway State Transition Graph (depth = " <> ToString[depth] <> ")", Top], infoPanel}, Spacings -> 2]] ![Multiway State Transition Graph][7] Multiway system string-based transitions are a meta-demonstration of the multi-way tag systems, which let us non-deterministically transform binary strings, that is until all possible state evolutions are revealed from an initial binary state. And then, we can differentiate rules via color-coded state transitions that format the vertex & edge count(s), the average vertex degree as well as the average betweenness centrality--metrics that are the last spiritual step to "state growth rate" and "path growth rate," quantitatively verifying the elementary cellular automaton in the context of Rule 30. rule30 = Association[{1, 1, 1} -> 0, {1, 1, 0} -> 0, {1, 0, 1} -> 0, {1, 0, 0} -> 1, {0, 1, 1} -> 1, {0, 1, 0} -> 1, {0, 0, 1} -> 1, {0, 0, 0} -> 0]; triplets = Tuples[{0, 1}, 3]; stateAssociation = AssociationThread[triplets -> Range[8]]; edges = Table[ Module[{currentTriplet, nextBit, nextTriplet, currentState, nextState}, currentTriplet = triplets[[i]]; nextBit = rule30[currentTriplet]; nextTriplet = {currentTriplet[[2]], currentTriplet[[3]], nextBit}; currentState = stateAssociation[currentTriplet]; nextState = stateAssociation[nextTriplet]; Labeled[currentState -> nextState, nextBit]], {i, Length[triplets]}]; colorAssociation = <|0 -> Gray, 1 -> Blue|>; edgeStyles = edges /. Labeled[edge_, tag_] :> Style[edge, colorAssociation[tag]]; vertexLabels = Thread[Range[8] -> (StringJoin /@ (ToString /@ # & /@ triplets))]; stateTransitionGraph = EdgeTaggedGraph[edgeStyles, VertexLabels -> vertexLabels, VertexLabelStyle -> 12, VertexSize -> 0.3, VertexStyle -> Black, EdgeLabels -> "EdgeTag", EdgeLabelStyle -> Directive[Black, Bold, 12], GraphLayout -> "SpringEmbedding", ImageSize -> Medium]; initialRow = {0, 0, 0, 1, 0, 0, 0}; steps = 10; caEvolution = CellularAutomaton[30, initialRow, steps]; caPlot = ArrayPlot[caEvolution, Mesh -> All, ColorRules -> {0 -> White, 1 -> Black}, Frame -> False, ImageSize -> Small]; Row[{stateTransitionGraph, Spacer[20], caPlot}] ![Rule 30 Cellular Automaton Plot][8] There are discrete-rule-based systems that "cut off" the deterministic cellular automaton Rule 30 alongside a "discontinuous" state transition graph where we can inspect how each neighborhood state mapped deterministically to another--relational navigation of deterministic tag systems to their more manifold non-deterministic multi-way dual visualizations (graph plus cellular automaton evolution) pairs graphical state evolution with the "previous forward" visual patterns to get the latest complexity and structural nuances via the generalized, multiway cellular automaton explorer. extractRuleBits[r_Integer] := IntegerDigits[r, 2, 8] standardNeighborhoods = {{1, 1, 1}, {1, 1, 0}, {1, 0, 1}, {1, 0, 0}, {0, 1, 1}, {0, 1, 0}, {0, 0, 1}, {0, 0, 0}}; states = Tuples[{0, 1}, 3]; stateAssociation = AssociationThread[states -> Range[Length[states]]]; colorAssociation = AssociationThread[ Range[Length[states]] -> (Hue /@ Rescale[Range[Length[states]]])]; buildEdges[ruleAssoc_] := Module[{edgesList = {}}, Do[Module[{currentState, nextState}, currentState = states[[i]]; nextState = RotateLeft[{ruleAssoc[RotateRight[currentState, 1]], ruleAssoc[currentState], ruleAssoc[RotateLeft[currentState, 1]]}]; AppendTo[ edgesList, {stateAssociation[currentState] -> stateAssociation[nextState], stateAssociation[currentState] -> stateAssociation[RotateRight[nextState, 1]], stateAssociation[currentState] -> stateAssociation[RotateLeft[nextState, 1]]}];], {i, Length[states]}]; DeleteDuplicates[Flatten[edgesList]]]; Manipulate[ Module[{bits, ruleAssoc, edges, graph}, bits = extractRuleBits[r]; ruleAssoc = AssociationThread[standardNeighborhoods -> bits]; edges = buildEdges[ruleAssoc]; graph = Graph[edges, VertexStyle -> Normal[colorAssociation], VertexShapeFunction -> "Square", VertexSize -> 0.2, EdgeStyle -> Directive[Opacity[0.5], GrayLevel[0.3]], GraphLayout -> "SpringElectricalEmbedding", ImageSize -> 800, PlotLabel -> Style["Rule " <> ToString[r], 20, Bold]]; Show[graph, ImageSize -> 800]], {{r, 30, "Rule Number"}, 0, 255, 1, Appearance -> "Labeled"}, TrackedSymbols :> {r}] ![Animated Rules][9] This generalized explorer allows users to select the, elementary cellular automaton rule (0-255). The multi-way behaviors interactively explore "race conditions" and Niederman's enumeration of state evolutions, allowing systematic exploration across parameter spaces, the point being that a slight modification in rules just drastically influences the structural complexity--as far as we're supposed to know, the enumeration and classification of dynamic and growth behaviors is all happening in the eyes of the user, in two dimensions. rule2D = <|{0, {0, 0, 0, 0}} -> 0, {0, {0, 0, 0, 1}} -> 1, {0, {0, 0, 1, 0}} -> 1, {0, {0, 0, 1, 1}} -> 0, {1, {1, 1, 1, 1}} -> 0|>; get4Neighbors[state_, i_, j_] := Module[{rows, cols}, {rows, cols} = Dimensions[state]; {If[i > 1, state[[i - 1, j]], 0], If[i < rows, state[[i + 1, j]], 0], If[j > 1, state[[i, j - 1]], 0], If[j < cols, state[[i, j + 1]], 0]}]; apply2DRule[state_, ruleAssoc_] := Module[{rows, cols, newState}, {rows, cols} = Dimensions[state]; newState = state; Do[Module[{c = state[[i, j]], n, key}, n = get4Neighbors[state, i, j]; key = {c, n}; If[KeyExistsQ[ruleAssoc, key], newState[[i, j]] = ruleAssoc[key], newState[[i, j]] = state[[i, j]]]], {i, rows}, {j, cols}]; newState]; initialState = RandomInteger[1, {10, 10}]; steps = 5; evolutionList = NestList[apply2DRule[#, rule2D] &, initialState, steps]; ArrayPlot[#, PlotRange -> {0, 1}, Mesh -> True, Frame -> False, ImageSize -> 200] & /@ evolutionList rule2Dmulti = <|{0, {0, 0, 0, 0}} -> {0, 1}, {0, {0, 0, 0, 1}} -> {1}, {1, {1, 1, 1, 1}} -> {0, 1}|>; apply2DMultirule[state_, ruleAssoc_] := Module[{rows, cols}, {rows, cols} = Dimensions[state]; FoldList[ Function[{acc, coords}, Flatten[acc /. {arr_ :> Table[ReplacePart[arr, coords -> possibility], {possibility, Lookup[ruleAssoc, {arr[[coords[[1]], coords[[2]]]], get4Neighbors[arr, coords[[1]], coords[[2]]]}, {arr[[ coords[[1]], coords[[2]]]]}]}]}, 1]], {state}, Flatten[Table[{i, j}, {i, rows}, {j, cols}], 1]]]; multiwayStep[state_] := apply2DMultirule[state, rule2Dmulti]; ![multiwaystep][10] The most impressive aspect of the original conceptual framework is this generalization into two dimensions--the local neighborhood rules get "saved" for later much like here and now, the neighborhood-based transformations in tag systems we present via `rule2Dmulti`, enabling each state to evolve into multiple outcomes (non-deterministically), creating complex branching behaviors that transition between multiple ways from simple local rules, from tag systems to higher-dimensional lattice structures and back. The voxels show in black and white that 3-dimensional structure growth keeps on updating and when we return we will find, the headlamp prototile multiway system is based on the same voxel structure that we explored laterally through our lattice structures. $HeadlampPrototile = Association["Voxels" -> {{0, 0, 0}}, "Ins" -> <|1 -> {{0, 0, 0}, {1, 0, 0}}|>, "Outs" -> <|1 -> {{0, 0, 0}, {-1, 0, 0}}|>]; FourTransforms[match_, offset_] := Transpose[{Table[ TranslationTransform[match + offset + RandomInteger[{-1, 1}, 3]], 4], Table[ RotationTransform[RandomReal[{-Pi/4, Pi/4}], RandomChoice[{{1, 0, 0}, {0, 1, 0}, {0, 0, 1}}], match + offset], 4]}]; TransformOne[ptfun_, vecfun_] := Module[{res = <||>}, res["Voxels"] = Map[ptfun, $HeadlampPrototile["Voxels"]]; res["Ins"] = MapAt[vecfun, MapAt[ptfun, $HeadlampPrototile["Ins"], {All, 1}], {All, 2}]; res["Outs"] = MapAt[vecfun, MapAt[ptfun, $HeadlampPrototile["Outs"], {All, 1}], {All, 2}]; res]; MultiwayVoxelEvolve[data_, gens_] := Module[{newData = data}, Do[newData = Catenate[ ParallelMap[ With[{offset = RandomChoice[#["Outs"][[1]]], match = #["Voxels"][[1]]}, FourTransforms[match, offset] // Map[Function[transform, TransformOne[transform[[1]], transform[[2]] ]]]] &, newData]], {gen, gens}]; newData]; DisplayMultiwayGrowth[data_] := Graphics3D[{EdgeForm[Thin], MapIndexed[{Hue[#2[[1]]/10], Cuboid[# - 0.5 {1, 1, 1}, # + 0.5 {1, 1, 1}]} &, Catenate[#["Voxels"] & /@ data]]}, Boxed -> False, Lighting -> "Neutral", SphericalRegion -> True]; Manipulate[SeedRandom[seed]; initial = {$HeadlampPrototile}; evolved = MultiwayVoxelEvolve[initial, generations]; DisplayMultiwayGrowth[evolved], {{generations, 3, "Generations"}, 1, 5, 1}, {{seed, 1, "Random Seed"}, 1, 100, 1}, ControlPlacement -> Top] ![Voxel Growth][11] Most notably the Niederman approach makes it possible to alter not just the cyclic stage of generational structures but also the seed value which allows for "reproducibility" that is the first, implementation that we have got to write down if we note that the abstraction, the symbolism of the multi-way rules coincides with the 3D voxel-based evolution and the way that the analogy of Niederman's mention of extending multi-way transformations beyond simple symbolic representations to intuitive structures plays out, is that the voxel evolution is inherently multi-way: each generation's structure can branch into various configurations non-deterministically. Our three-dimensional graphical representation prospectively sources universality-like behavior reminiscent of universal computation through multi-way systems through the lens of Niederman just so that yes, we can approach multi-way tag systems through multi-way branching that works through state transition graphs arising from simple rules, subjectivizes complexity through interactive "explorations" and statistical metrics analogous to the growth rate measures that originally symbolized one-dimensional formulations but now, they reinforce the three-dimensional and two-dimensional versatility of our visual analogs, expressly powering our multi-way computational frameworks and effectively exemplify the tangible nature of theoretical and computational representations of conceptual ideas, in multi-way tag systems. Multiway3D[rules_, init_, steps_] := Module[{mw, states, edges, coords, stateToCoord, cuboids, edgeLines, centroid, baseLabelPositions, extraAdjustments, xyPositions, groups}, mw = ResourceFunction["MultiwaySystem"][rules, init, steps, "StatesGraph"]; states = VertexList[mw]; edges = EdgeList[mw]; coords = Table[With[{s = If[StringQ[state], state, ToString[state]]}, {StringCount[s, "A"], StringCount[s, "B"], GraphDistance[mw, init, state]}], {state, states}]; stateToCoord = Thread[states -> coords]; cuboids = {EdgeForm[Directive[Black, Thin]], FaceForm[Directive[Opacity[0.8], LightGray]], Map[Cuboid[# - {0.45, 0.45, 0.45}, # + {0.45, 0.45, 0.45}] &, coords]}; edgeLines = {Directive[Thick, Blue], Line /@ (edges /. stateToCoord /. DirectedEdge -> List)}; centroid = Mean[coords]; baseLabelPositions = Map[# + (Normalize[# - centroid]*0.5 + {0, 0, 0.6}) &, coords]; xyPositions = coords[[All, {1, 2}]]; groups = Gather[Range[ Length[xyPositions]], (xyPositions[[#1]] === xyPositions[[#2]]) &]; extraAdjustments = ConstantArray[{0, 0, 0}, Length[coords]]; Do[If[Length[group] > 1, Module[{base, rad, perp, n, offsets}, base = coords[[First[group]]]; rad = Normalize[{base[[1]] - centroid[[1]], base[[2]] - centroid[[2]], 0}]; perp = {-rad[[2]], rad[[1]], 0}; n = Length[group]; offsets = Table[(i - (n + 1)/2)*0.2*perp, {i, 1, n}]; Do[ extraAdjustments[[group[[j]]]] = offsets[[j]], {j, 1, n}]]], {group, groups}]; Graphics3D[{cuboids, edgeLines, MapThread[ Text[Style[#1, FontSize -> 12, FontFamily -> "Helvetica", Bold, Black], #2 + extraAdjustments[[#3]]] &, {states, baseLabelPositions, Range[Length[states]]}]}, Axes -> True, AxesLabel -> {Style["A Count", Bold, 14], Style["B Count", Bold, 14], Style["Generation", Bold, 14]}, BoxRatios -> {1, 1, 1}, ViewPoint -> {2, 2, 2}, Lighting -> "Neutral", ImageSize -> 600]]; Multiway3D[{"A" -> "AB", "B" -> "A"}, "A", 4] ![ABBB][12] Three-dimensional space, if we look around we'll see how Niederman's concept of visualizing multi-way state graphs where each vertex represents system states after rule applications, can "be plotted" via `Multiway3D` in a three-dimensional coordinate system based on counts of symbols ("A" and "B") and generation steps, which can make us make the multi-way tag system (`{"A"->"AB", "B"->"A"}`) more precisely match Niederman's exploration of symbolic transformations as it becomes more 3-dimensional (symbol counts vs. generation number are fundamentally "different") in the sense of labeling & positioning, which come along with the "twin horn" or exponential-growth. But first, we should look at the quite animated, 3-dimensional rotating cuboid and quite possibly and interactively visualize some more abstract LEGO structures. Animate[Graphics3D[{EdgeForm[None], FaceForm[RGBColor[1, 0.5, 0.1, 0.5] ], Cuboid[{-1, -1, -1}, {1, 1, 1}] }, Boxed -> False, Lighting -> "Neutral", ViewPoint -> {4 Cos[t], 4 Sin[t], 2}, ImageSize -> 400 ], {t, 0, 2 Pi}, AnimationRunning -> True, AnimationRate -> 0.5] ![Cube Animation][13] One might think the complexity of these iterative growth processes can be represented auditorially. Who knows, everybody just visualizes whatever they want to visualize and the auditory attributes of these multi-way tag systems, they echo the iterations of systems that might otherwise seem too abstract, too complex to explore. The thing to remember is that where binary strings evolve according to non-deterministic rules, the color association assigns specific colors to different transition indices. Via `GenerateTransitions`, we can generate transitions by producing new states by scanning through the current binary string, matching each two-digit segment against the rule set, and replacing it with the corresponding outcome. Starting from an initial state such as `{0, 1, 1}`, the system iteratively applies these rules for a set number of steps. As new states are generated, a graph is constructed showing the transitions. Each edge in the graph is color-coded--this is why we call it the "rabbit system" or the "twin horn system"--because the transitions result from different applied rules. It's a simultaneous keeping track of the non-deterministic evolution of the system while transforming binary states, that's the multi-way transition approach. $HeadlampPrototile = Association["Voxels" -> {{0, 0, 0}}, "Ins" -> <|1 -> {{0, 0, 0}, {1, 0, 0}}|>, "Outs" -> <|1 -> {{0, 0, 0}, {-1, 0, 0}}|>]; FourPointTransforms[match_, move_] := Translate[IdentityMatrix[3], move[[1]]]; VectorTransform[match_, move_] := Rotate[IdentityMatrix[3], Pi/2, move[[2]]]; FourTransforms[match_, move_] := Transpose[{FourPointTransforms[match, move], VectorTransform[match, move]}]; TransformOne[ptfun_, vecfun_] := Module[{res = <||>}, res["Voxels"] = Map[ptfun, $HeadlampPrototile["Voxels"]]; res["Ins"] = MapAt[vecfun, MapAt[ptfun, $HeadlampPrototile["Ins"], {All, 1}], {All, 2}]; res["Outs"] = MapAt[vecfun, MapAt[ptfun, $HeadlampPrototile["Outs"], {All, 1}], {All, 2}]; res]; rules = {"A" -> "AB", "B" -> "A"}; init = "A"; multiwayGraph = ResourceFunction["MultiwaySystem"][rules, init, 3, "StatesGraphStructure"]; TransformFromState[state_] := Module[{chars = Characters[state], ptfun = Identity, vecfun = Identity}, Do[Switch[ch, "A", ptfun = TranslationTransform[{1, 0, 0}]@*ptfun, "B", ptfun = RotationTransform[Pi/2, {0, 0, 1}]@*ptfun], {ch, chars}]; {ptfun, vecfun}]; states = VertexList[multiwayGraph]; tileData = <||>; Do[{pt, vec} = TransformFromState[state]; tileData[state] = TransformOne[pt, vec]["Voxels"], {state, states}]; DynamicModule[{currentState = init, path = {init}}, Column[{GraphPlot[multiwayGraph, VertexShapeFunction -> (Inset[Button[#2, currentState = #2; path = FindShortestPath[multiwayGraph, init, #2]], #1] &), ImageSize -> 200], Dynamic@Graphics3D[{EdgeForm[Opacity[0.1]], MapIndexed[{ColorData["Rainbow"][First[#2]/Length[path]], Cuboid[# - {0.5, 0.5, 0.5}, # + {0.5, 0.5, 0.5}]} &, Catenate[tileData /@ path]]}, Boxed -> False, Lighting -> "Neutral", SphericalRegion -> True, ViewAngle -> 0.5, PlotLabel -> currentState]}]] ![Transform From State][14] The voxel-based headlamp prototile system above shows that we are beginning to bridge the gap between symbolic multi-way transformations, as explored by Niederman, and their 3-dimensional geometric counterparts. Although we have not yet fully translated all of Niederman's transformations into a completely voxelized, iterative construction process, we now have a framework for interpreting symbolic transformations in a tangible, 3-dimensional voxel form. Certainly we're not out of the woods yet but here we know now that we can instantiate physical structures that are "being" built iteratively in the above voxel-based headlamp prototile multiway evolution, the kind that theoretically concretizes the symbolic growth rules into tangible 3-dimensional voxel structures. Multiway3D[rule_, init_, steps_] := Module[{g, g3d, coords, vertices, edges}, g = ResourceFunction["MultiwaySystem"][rule, init, steps, "StatesGraph"]; g3d = Graph3D[g, GraphLayout -> "SpringElectricalEmbedding", VertexSize -> 0.1, EdgeStyle -> Directive[Opacity[0.5], Gray]]; coords = Thread[VertexList[ g3d] -> (VertexCoordinates /. AbsoluteOptions[g3d, VertexCoordinates])]; vertices = VertexList[g3d] /. coords; edges = EdgeList[g3d] /. a_ \[DirectedEdge] b_ :> Line[{a /. coords, b /. coords}]; Graphics3D[{{RGBColor[0.027, 0.545, 0.788], Cuboid[# - {0.1, 0.1, 0.1}, # + {0.1, 0.1, 0.1}] & /@ vertices}, {Gray, Tube[#, 0.02] & /@ edges}}, Boxed -> True, Lighting -> "Neutral", ImageSize -> Medium, ViewPoint -> {1.3, -2.4, 2.0}]]; DynamicModule[{step = 3, system = {"A" -> "AB", "B" -> "A"}, init = {"A"}}, Column[{Row[{Control[{{step, 3, "Steps"}, 1, 5, 1}], Spacer[20], Button["Reset", step = 3, ImageSize -> Medium]}], Dynamic@Multiway3D[system, init, step]}, Alignment -> Center]] ![Multiway 3d][15] In this system, each symbolic rule that defines how a state evolves can be directly linked to a geometric transformation, thereby concretizing abstract growth rules into physically interpretable voxel structures. In the subsequent section, we take a well-known symbolic tag system--represented by the rules `{"A" -> "AB", "B" -> "A"}`--and show how it can be transformed into a series of physical voxel transformations. If there's one thing we do know, however, it's that it IS possible to convert symbolic multi-way evolutions; we need to be reminded, this might be another, "Here comes honey goo goo" moment or it might be nothing but in any case it's not just another symbolic representation of a tag system. It might even be a more spatialized physicalization of the state graph mapping paradigm; we don't know the specific "details" but now we can be certain that there is a clear way to demonstrate the mapping from symbolic states (strings) to spatially transformed states (voxels). When I saw Niederman's symbolic-to-structural approach, I knew that I had to go at least try out making a more clickable graph via the interactive visual tools said and provided, because then we can have a frame of reference for user-guided exploration of states and paths. So check this out; there's another way, a multi-way variant of graphs that can always get better uses for the 3-dimensional spring-electrical embedding on state connections and transitions, which was superior to our non-visual embedding variant. Multiway3D[rule_, init_, steps_] := Module[{g = ResourceFunction["MultiwaySystem"][rule, init, steps, "StatesGraph"], coords, voxels, edges3D, labels}, coords = AssociationThread[VertexList[g], MapIndexed[ RotateLeft[{#2[[1]], 0, #2[[1]]/10}, Mod[#2[[1]], 3]] &, VertexList[g]]]; voxels = Map[Cuboid[# - {0.1, 0.1, 0.1}, # + {0.1, 0.1, 0.1}] &, Values[coords]]; edges3D = Map[Tube[{coords[#[[1]]], coords[#[[2]]]}, 0.02] &, EdgeList[g]]; labels = MapThread[ Text[Style[#1, 8, Black, Background -> White], #2, {-1.5, 0}] &, {VertexList[g], Values[coords]}]; DynamicModule[{view = {2, 2, 2}}, Column[{Graphics3D[{{RGBColor[0.4, 0.6, 1], edges3D}, {RGBColor[1, 0.4, 0.4], voxels}, {Black, labels}}, Lighting -> "Neutral", ViewPoint -> Dynamic[view], ImageSize -> 400, Boxed -> False, SphericalRegion -> True]}]]] Multiway3D[{"A" -> "AB", "B" -> "A"}, "A", 4] ![Graphic 4][16] The interesting thing about the 3-dimensional spring-electrical embedding is that it "implicitly contains" an alternative visual representation, which gives us another chance to do a lot of radial or layered layouts at once or maybe just clarify structural and relational complexity one step at a time within state graphs. Because I don't know, which graph variant raises the least questions. But I do know that having an interactive, clickable graph represents the multiway evolution of states. Each symbolic state (a string of letters) is transformed into a spatial configuration of voxels via a mapping function (here, through functions like `TransformFromState` and `TransformOne`). This visualization coupled with a 3-dimensional spring-electrical embedding generates many types of intuitively understandable state connections and transitions compared to any traditional non-visual embedding. MultiwayTagExplorer[] := DynamicModule[{rules, init = {1, 0, 1}, steps = 5, graph, path = {}, metrics}, rules = {{left___, 0, 0, s___} :> {left, s, 1, 0, 0}, {left___, 1, 0, s___} :> {left, s, 0, 1}, {left___, 0, 1, s___} :> {left, s, 1, 1, 0}, {left___, 1, 1, s___} :> {left, s, 0, 0, 0}}; graph = ResourceFunction["NestGraphTagged"][ReplaceList[rules], {init}, steps, VertexShapeFunction -> (Inset[ ArrayPlot[{#2}, ImageSize -> 40, ColorRules -> {0 -> Pink, 1 -> Darker@Cyan}], #1, Center] &), GraphLayout -> "LayeredDigraphEmbedding", PerformanceGoal -> "Quality"]; BFSMetrics[g_, start_, end_] := Module[{parent = <||>, queue = {start}, current, neighbors, metrics = <|"Visited" -> {}, "QueueSize" -> {}, "Density" -> {}|>}, While[Length[queue] > 0, current = First[queue]; queue = Rest[queue]; If[! KeyExistsQ[metrics["Visited"], current], AppendTo[metrics["Visited"], current]; AppendTo[metrics["QueueSize"], Length[queue]]; neighbors = AdjacencyList[g, current]; Do[If[! KeyExistsQ[parent, n], parent[n] = current; AppendTo[queue, n];], {n, neighbors}]; subgraph = Subgraph[g, metrics["Visited"]]; density = If[VertexCount[subgraph] > 1, N[EdgeCount[ subgraph]/(VertexCount[ subgraph] (VertexCount[subgraph] - 1)/2)], 0]; AppendTo[metrics["Density"], density];]; If[current === end, Break[]];]; metrics]; Column[{Grid[{{"Initial State:", InputField[ Dynamic[init, (init = #; graph = ResourceFunction["NestGraphTagged"][ ReplaceList[rules], {init}, steps]) &], Expression]}, {"Steps:", Slider[Dynamic[ steps, (steps = #; graph = ResourceFunction["NestGraphTagged"][ ReplaceList[rules], {init}, steps]) &], {1, 8, 1}]}}], Dynamic@ClickPane[ HighlightGraph[graph, {Style[path, Directive[Thick, Red]]}, ImageSize -> 800, VertexLabels -> Placed["Name", Center], EdgeLabels -> "EdgeTag", GraphHighlightStyle -> "Thick"], Function[coords, metrics = BFSMetrics[graph, init, VertexList[graph][[ First@Nearest[ GraphEmbedding[graph] -> Range[VertexCount[graph]], coords]]]]; path = FindShortestPath[graph, init, VertexList[graph][[ First@Nearest[ GraphEmbedding[graph] -> Range[VertexCount[graph]], coords]]]];]], Dynamic@If[Length[metrics["Visited"]] > 0, Column[{ListLinePlot[{metrics["QueueSize"], metrics["Density"]}, PlotLegends -> {"Queue Size", "Graph Density"}, PlotLabel -> "Exploration Metrics", ImageSize -> 400], Grid[{{"States Visited:", Length[metrics["Visited"]]}, {"Final Queue Size:", Last[metrics["QueueSize"]]}, {"Final Density:", Last[metrics["Density"]]}}, Frame -> All]}]]}]]; MultiwayTagExplorer[] ![Multiway Tag Explorer Animation][17] ![Exploration Metrics][18] I cannot advise in totality which method of demonstrating a multi-way tag system but I can fix the tag rules so that we know, what are the definitive Breadth-First Search metrics like queue size and graph density; how do we teach state / path growth rates to serve the purpose of complexity measurement in a practical, interactive way? How do we extend our, alteration of initial states and steps to the methodological and "systematic" enumeration of multi-way system behaviors? Binary tag rules with their state-to-state transitions will always cause the graph complexity metrics to be quantifiable, because that is how we measure complexity and growth. But that's not all. musicRules = {"A" -> "BC", "B" -> "ACD", "C" -> "DE", "D" -> "EF", "E" -> "FG", "F" -> "GH", "G" -> "HA", "H" -> "A"}; initState = "A"; steps = 6; evolution = NestList[StringReplace[#, musicRules] &, initState, steps]; finalState = Last[evolution]; stateSequence = Characters[finalState]; noteRules = <|"A" -> SoundNote["C4", 0.35], "B" -> SoundNote["D4", 0.35], "C" -> SoundNote["E4", 0.35], "D" -> SoundNote["F4", 0.35], "E" -> SoundNote["G4", 0.35], "F" -> SoundNote["A4", 0.35], "G" -> SoundNote["B4", 0.35], "H" -> SoundNote["C5", 0.35]|>; chordRules = {"A" -> SoundNote[{"C4", "E4", "G4"}, 0.35], "B" -> SoundNote[{"D4", "F4", "A4"}, 0.35], "C" -> SoundNote[{"E4", "G4", "B4"}, 0.35], "D" -> SoundNote[{"F4", "A4", "C5"}, 0.35], "E" -> SoundNote[{"G4", "B4", "D5"}, 0.35], "F" -> SoundNote[{"A4", "C5", "E5"}, 0.35], "G" -> SoundNote[{"B4", "D5", "F5"}, 0.35], "H" -> SoundNote[{"C5", "E5", "G5"}, 0.35]}; melody = Sound[RotateRight[stateSequence, 1] /. noteRules]; harmony = Sound[Partition[stateSequence, 2, 1] /. chordRules]; rhythm = Sound[Table[ SoundNote["C2", RandomChoice[{0.2, 0.25, 0.3, 0.35}]], {Length[ stateSequence]}]]; audioMelody = Audio[melody, SampleRate -> 44100]; audioHarmony = Audio[harmony, SampleRate -> 44100]; audioRhythm = Audio[rhythm, SampleRate -> 44100]; combinedAudio = AudioChannelCombine[{audioMelody, audioHarmony, audioRhythm}]; DynamicModule[{playState = "Stop"}, Column[{Labeled[ Column[{Style["Evolution String:", Bold, 14], finalState, Row[{Button[ Dynamic[If[playState === "Playing", "⏸", "\[FilledRightTriangle]"]], playState = If[playState === "Playing", "Paused", "Playing"]; If[playState === "Playing", AudioPlay[combinedAudio]], ImageSize -> {50, 50}], ProgressIndicator[ Dynamic[Clock[{1, Length[stateSequence], 1}]], {1, Length[stateSequence]}, ImageSize -> 300]}]}], Style["L-System Music Evolution", 16, Bold]]}]] ![L-System Music Evolution][19] The transformative creativity of symbolic multi-way rules doesn't matter with regard to multi-way rules so much as it "gives us" a greater perspective on multi-way system outputs; here, symbolic-to-spatial transformations become structured auditory experiences. The emergence of complexity from simple iterative rules is so much fun--that's the reason why this time we translate complexity into sound, harnessing the universality and expressive power of musical structures. ruledRule1044 = {{0, 0} -> {0, 1}, {0, 0} -> {1, 1}, {0, 1} -> {0, 1}, {0, 1} -> {1, 1}, {1, 0} -> {1, 0}, {1, 0} -> {1, 1}, {1, 1} -> {1, 0}, {1, 1} -> {1, 1}}; colorAssociation = <|1 -> Blue, 2 -> Cyan, 3 -> Green, 4 -> Brown, 5 -> Orange, 6 -> Red, 7 -> Magenta, 8 -> Purple|>; transitions = {{{0, 1, 1} -> {0, 1, 1}, {0, 1} -> {0, 1}}, {{0, 1, 1} -> {1, 1, 1}, {0, 1} -> {1, 1}}, {{0, 1, 1} -> {0, 1, 0}, {1, 1} -> {1, 0}}, {{0, 1, 1} -> {0, 1, 1}, {1, 1} -> {1, 1}}, {{1, 1, 1} -> {1, 1, 0}, {1, 1} -> {1, 0}}, {{1, 1, 1} -> {1, 1, 1}, {1, 1} -> {1, 1}}, {{0, 1, 0} -> {0, 1, 0}, {0, 1} -> {0, 1}}, {{0, 1, 0} -> {1, 1, 0}, {0, 1} -> {1, 1}}, {{1, 1, 0} -> {1, 0, 0}, {1, 1} -> {1, 0}}, {{1, 1, 0} -> {1, 1, 0}, {1, 1} -> {1, 1}}, {{1, 0, 0} -> {1, 0, 1}, {0, 0} -> {0, 1}}, {{1, 0, 0} -> {1, 1, 1}, {0, 0} -> {1, 1}}, {{1, 0, 1} -> {1, 0, 1}, {0, 1} -> {0, 1}}}; stateAssociation = <|{0, 1, 1} -> 1, {1, 1, 1} -> 2, {0, 1, 0} -> 3, {1, 1, 0} -> 4, {1, 0, 0} -> 5, {1, 0, 1} -> 6|>; myGraph = EdgeTaggedGraph[ Flatten[Table[ Style[stateAssociation[Flatten[Keys[trans[[1]]]]] -> stateAssociation[Flatten[Values[trans[[1]]]]], Directive[ colorAssociation[ Flatten[Position[ruledRule1044, trans[[2]]]][[1]]], Small], Arrowheads[0.012]], {trans, transitions}]], VertexStyle -> Black, VertexSize -> Large, VertexShapeFunction -> "Square", GraphLayout -> "LayeredDigraphEmbedding"]; Animate[HighlightGraph[myGraph, Take[EdgeList[myGraph], k]], {k, 1, Length[EdgeList[myGraph]], 1}, AnimationRepetitions -> 1, Paneled -> False, DisplayAllSteps -> True] ![Animated Graph][20] It turns out that we don't have to see the graph all at once; we can look at the map and cheat a little by animating state transitions to illustrate evolution dynamics that shows that it's just progressively revealing state complexity through dynamic visualization techniques that is, and the particular evolution paths highlighted in otherwise complex transition systems, that makes tracing paths possible as we apprehend these multiway transition graphs, and it shows Mathematica as this relentless animation powerhouse that maps out the corners of our multi-way transition graph. possibles = Flatten[Table[{{a, b}, {c, d}}, {a, {0, 1}}, {b, {0, 1}}, {c, {0, 1}}, {d, {0, 1}}], 3]; states = Union@Flatten[possibles, 1]; statesStr = ToString /@ states; colorAssociation = <|0 -> Gray, 1 -> Blue, 2 -> Green, 3 -> Red, 4 -> Orange, 5 -> Purple, 6 -> Brown, 7 -> Cyan, 8 -> Magenta, 9 -> Lime, 10 -> Pink, 11 -> Yellow, 12 -> Teal, 13 -> Coral, 14 -> Lavender, 15 -> Gold|>; dynamicRules = {{0, 0} -> {{0, 1}, {1, 0}}, {0, 1} -> {{1, 1}, {0, 0}}, {1, 0} -> {{1, 1}, {0, 1}}, {1, 1} -> {{0, 0}, {1, 0}}}; transitions = Flatten[Table[ DirectedEdge[before, after], {before, states}, {after, Replace[before, dynamicRules, {}]}], 1]; transitionsStr = transitions /. x_List :> ToString[x]; Graph[transitions, VertexStyle -> Thread[states -> (colorAssociation /@ Range[0, 15]~Take~Length[states])], EdgeStyle -> {e_ :> If[MemberQ[path, e], Directive[Thick, Red], Automatic]}, VertexLabels -> Placed["Name", Center], VertexSize -> 0.15, ImageSize -> 300] DynamicModule[{currentState = {0, 0}, path = {}, history = {{0, 0}}, gLocal}, gLocal = g; Column[{Button["Reset", currentState = {0, 0}; path = {}; history = {{0, 0}};], Grid[{{"Current State:", Framed[Style[Dynamic[currentState], Bold, 20], Background -> White]}, {"Possible Next States:", Dynamic@Column[Replace[currentState, dynamicRules, {}]]}}, Frame -> All], Button["Step Forward", Module[{nextStates = Replace[currentState, dynamicRules, {}]}, If[nextStates =!= {}, currentState = RandomChoice[nextStates]; AppendTo[path, DirectedEdge[ToString[history[[-1]]], ToString[currentState]]], currentState = {0, 0}; path = {}; history = {{0, 0}};]; AppendTo[history, currentState];]], Dynamic[Panel[ Grid[{{"Steps Taken:", Length[history]}, {"Current Path:", path}, {"Unique States Visited:", Length[Union[history]]}}, Frame -> All]]]}, Spacings -> 1]] ![Dynamic Walk Animation][21] ![Step Outside][22] And as we step forward, we sort of step outside of the evolution dynamics via path tracing and user-driven investigation of multi-way state evolution and transitions, by including metrics and state histories; otherwise how would we know whether this is from 2024 or 2016 type of a thing? Anyway, I think that the tracking and display of steps and unique states visited and paths, these are the metrics that strongly and scriptedly just the same connect Niederman's analytical approach, to complexity measurement, the graphical representations of "which" are a lot like pulling those abstract symbols apart, including complexity measurements that start out with a doll-like form of multi-way tag systems and transform them into something even more awesome--an exploration of the computational and expressive possibilities across all domains whether it's packing auditory domains full of lively auditory representations of our spatial and symbolic paradigm, all within these multi-way tag systems. ruledRule1044 = {{0, 0} -> {0, 1}, {0, 0} -> {1, 1}, {0, 1} -> {0, 1}, {0, 1} -> {1, 1}, {1, 0} -> {1, 0}, {1, 0} -> {1, 1}, {1, 1} -> {1, 0}, {1, 1} -> {1, 1}}; ruleAssoc = GroupBy[ruledRule1044, First -> Last]; evolve[state_] := Flatten[RandomChoice[ruleAssoc[#]] & /@ Partition[state, 2]]; Manipulate[SeedRandom[seed]; currentEvolution = NestList[evolve, initialState, steps]; ArrayPlot[Transpose[Reverse[currentEvolution]], Mesh -> True, ColorRules -> {0 -> White, 1 -> Black}, Frame -> True, FrameTicks -> {{Range[0, steps], Range[0, steps]}, {Range[Length[initialState]], None}}, PlotLabel -> "Non-deterministic Cellular Automaton Evolution (Rotated)", ImageSize -> 500] , {{steps, 10, "Generations"}, 1, 50, 1, Appearance -> "Labeled"}, {{seed, 42, "Random Seed"}, 1, 100, 1, Appearance -> "Labeled"}, {{initialState, {0, 1, 1, 0}}, ControlType -> None}, Button["New Random Seed", seed = RandomInteger[{1, 1000}], ImageSize -> Medium], Button["Reset Initial State", initialState = {0, 1, 1, 0}, ImageSize -> Medium], ControlPlacement -> Top, Paneled -> True, Initialization :> (initialState = {0, 1, 1, 0};)] ![CA Evolution][23] ![CA Evolution][24] And so you see multi-way tag systems allow for non-deterministic outcomes; it is these multiple possible outcomes that can result from a single state. That is how this multiple possible outcomes thing works; we don't have any non-deterministic outcomes to represent and allow in the first place, meaning multiple possible outcomes can result from a single state. So we use `RandomChoice` to non-deterministically produce different results on each run based on random selections, just as Niederman describes multi-way systems. In later parts of the description there is a hint of a contrast amongst the processes required to guide "non-deterministic outcomes" like photons (by changing refractive indices) with those used for electrons (doping semiconductors), an underinterpretation of the different physical phenomena (for example, the interference of light) that provide new computing possibilities. colorAssociation = <|0 -> Blue, 1 -> Cyan, 2 -> Green, 3 -> Brown, 4 -> Orange, 5 -> Red, 6 -> Magenta, 7 -> Purple, 8 -> Blue|>; IsStable2D[grid_, zc_] := AllTrue[Flatten[grid], # < zc &]; Stabilize2D[grid_, zc_] := Module[{dims = Dimensions[grid], newGrid = grid}, While[! IsStable2D[newGrid, zc], Do[If[newGrid[[i, j]] >= zc, newGrid[[i, j]] -= zc; If[i > 1, newGrid[[i - 1, j]] += 1]; If[i < dims[[1]], newGrid[[i + 1, j]] += 1]; If[j > 1, newGrid[[i, j - 1]] += 1]; If[j < dims[[2]], newGrid[[i, j + 1]] += 1];], {i, dims[[1]]}, {j, dims[[2]]}];]; newGrid]; DynamicModule[{grid = ConstantArray[0, {21, 21}]}, Column[{"Click cells to add sand grains (max 3 shown):", ClickPane[ Dynamic[ArrayPlot[Map[Mod[#, 8] &, grid, {2}], ColorRules -> {n_ :> colorAssociation[n]}, ImageSize -> 250, Mesh -> True, PlotRange -> {{0, 21}, {0, 21}}, Frame -> False]], Function[pt, Module[{x, y}, x = Clip[Floor[pt[[1]]] + 1, {1, 21}]; y = Clip[21 - Floor[pt[[2]]], {1, 21}]; grid = ReplacePart[grid, {x, y} -> grid[[x, y]] + 1]; grid = Stabilize2D[grid, 4];]]]}]] ![Sandpile Click Animation][25] Isn't it a stabilizing thing? When in the open close case of sandpile models, the state stability involves state evolution and fixed points. Descriptively, evolution functions and the stability of states are a "sieve" that brings our local systems to an eventually "reachable" stable "formulation" of states or fixed points. Similarly, our sandpile model repeatedly applies a transformation until a stable state (where no more updates are required or attributable) is reached. Fixed-point graphs breed stability in multi-way tag systems. SandStep[s_] := s + ListConvolve[{{0, 1, 0}, {1, -4, 1}, {0, 1, 0}}, UnitStep[s - 4], 2, 0]; initialState = CenterArray[{{25}}, {11, 11}]; evolution = NestList[SandStep, initialState, 15]; StateHash[grid_] := Hash[Integer[Round[grid]]]; graph = TransitiveReductionGraph@ RelationGraph[ AnyTrue[Flatten@#2, # > 3] && ContainsExactly[Integer[Round[#2]], {0, 1, 2, 3, 4}] && StateHash[#1] == StateHash[SandStep[#1]] &, evolution, VertexShapeFunction -> (Inset[ ArrayPlot[#2, ColorRules -> {0 -> White, 1 -> LightBlue, 2 -> Cyan, 3 -> Blue, 4 -> Darker@Red, _?Negative -> Black}, PixelConstrained -> 2, ImageSize -> 30], #1, Center, Scaled[0.15]] &), GraphLayout -> {"LayeredDigraphEmbedding", "Orientation" -> Bottom}, EdgeStyle -> Directive[Orange, Thickness[0.003]], VertexSize -> 1.5, PerformanceGoal -> "Quality"]; GraphPlot3D[graph, VertexStyle -> Normal@AssociationThread[VertexList[graph], ColorData["Rainbow"] /@ Rescale[VertexDegree[graph]]], EdgeStyle -> Directive[Blue, Opacity[0.3]], PlotTheme -> "Detailed", Boxed -> False, ViewVertical -> {0, 0, 1}, VertexSize -> 0.2, ImageSize -> 800] Manipulate[ ArrayPlot[evolution[[step]], ColorRules -> {0 -> White, 1 -> LightBlue, 2 -> Cyan, 3 -> Blue, 4 -> Darker@Red, _?Negative -> Black}, Epilog -> {Red, PointSize[0.03], Point /@ Position[evolution[[step]], _?(# >= 4 &)]}, ImageSize -> 300], {{step, 1, "Generation"}, 1, Length@evolution, 1, Appearance -> "Labeled"}, ControlPlacement -> Top] ![Sandpile Evolution 1][26] ![Matrices Cell Pile][27] The extensive employment of 2-dimensional and 3-dimensional remembrances finish the structure and dynamics of multi-way state evolution, such as the "Twin Horn System" which automatically interprets how states transition and evolve, reverting us to an understanding of system-atic graph-theoretical measurements as we use them, and as we "relate" them to Niederman's systematic analysis, of state graphs. states = Tuples[{0, 1}, 2]; ruledRule1044 = {{0, 0} -> {0, 1}, {0, 0} -> {1, 1}, {0, 1} -> {0, 1}, {0, 1} -> {1, 1}, {1, 0} -> {1, 0}, {1, 0} -> {1, 1}, {1, 1} -> {1, 0}, {1, 1} -> {1, 1}}; edges = Flatten[ Table[{DirectedEdge[#[[1]], #[[2]]], n} & /@ Take[ruledRule1044, {n}], {n, Length[ruledRule1044]}], 1]; colorAssociation = <|1 -> Blue, 2 -> Cyan, 3 -> Green, 4 -> Brown, 5 -> Orange, 6 -> Red, 7 -> Magenta, 8 -> Purple|>; myGraph = Graph[edges[[All, 1]], EdgeStyle -> Thread[edges[[All, 1]] -> (edges[[All, 2]] /. colorAssociation)], EdgeLabels -> {e_ :> Placed["Index", Tooltip]}, VertexLabels -> Placed["Name", Center], VertexStyle -> Directive[Black, EdgeForm[White]], VertexSize -> 0.25, VertexLabelStyle -> Directive[White, Bold, 8], EdgeLabelStyle -> Directive[Red, Italic, 12], PerformanceGoal -> "Quality", GraphLayout -> "LayeredDigraphEmbedding", ImageSize -> 200]; metrics = {{"Vertex Count", VertexCount[myGraph]}, {"Edge Count", EdgeCount[myGraph]}, {"Mean Vertex Degree", N@Mean[VertexDegree[myGraph]]}, {"Mean In-Degree", N@Mean[VertexInDegree[myGraph]]}, {"Mean Betweenness", N@Mean[BetweennessCentrality[myGraph]]}}; Grid[Prepend[metrics, {"Metric", "Value"}], Frame -> All, Alignment -> Left, Background -> {None, {LightBlue, {LightOrange, LightGreen}}}] // Framed[#, RoundingRadius -> 10] &; Row[{myGraph, Spacer[20], %}, Alignment -> Center] ![MyGraph Spacer][28] While Niederman's work primarily focuses on including graph complexity examination and "exploratory" growth characteristics using measures like state growth rate and path growth rate, we here can significantly characterize system complexity and connectivity of intermediate stages by hovering over nodes, the tooltips that provide epilogical quantifications of the complexity of the evolution of Cellular Automata. stateAssociation = <|{0, 1, 1} -> 1, {1, 1, 1} -> 2, {0, 1, 0} -> 3, {1, 1, 0} -> 4, {1, 0, 0} -> 5, {1, 0, 1} -> 6|>; colorAssociation = <|1 -> Blue, 2 -> Cyan, 3 -> Green, 4 -> Magenta, 5 -> Orange, 6 -> Red|>; rule = 30; width = 61; steps = 30; initialState = SparseArray[{Ceiling[width/2] -> 1}, width]; ca = CellularAutomaton[rule, initialState, steps]; getNeighborhoods[array_] := Module[{padded}, padded = PadLeft[PadRight[array, Length[array] + 2], Length[array] + 2]; Partition[padded, 3, 1]]; colorMatrix = Table[neighborhoods = getNeighborhoods[ca[[i]]]; Replace[neighborhoods, stateAssociation, {1}] /. _Missing -> 7, {i, 1, Length[ca]}]; coloredCA = Map[colorAssociation[#] &, colorMatrix, {2}]; ArrayPlot[coloredCA, ColorRules -> Join[Normal[colorAssociation], {7 -> None}], PixelConstrained -> 10, Frame -> False, AspectRatio -> 1/2] ![Colored New Aspect Ratio Cellular Automata][29] And these rule-based systems, they will not stop evolving iteratively from initial states according to simple local rules! They're going to iteratively and recursively detail the natural analogies intrinsic to these multi-way systems like the Cellular Automaton-based systems we've discussed. And so we restructure the rule enumeration and system specification structure effectively enumerating possible transformation rules and evaluating system behavior, by skipping over rules systematically and enumerating their pretensive impact on system dynamics ala transition matrices and eigen values, much like the existing definition and labeling of rule sets. colorAssociation = <|0 -> Black, 1 -> Blue, 2 -> Cyan, 3 -> Green, 4 -> Brown, 5 -> Orange, 6 -> Red, 7 -> Magenta, 8 -> Purple, 9 -> Yellow, 10 -> Pink|>; InitializeGrid[size_] := RandomInteger[{0, 9}, {size, size}]; UpdateGrid[grid_] := Module[{neighborSum, probUpdate, newGrid, sweepProbability = 0.02, rows, cols, i, j, newValue}, neighborSum = ListConvolve[{{1, 1, 1}, {1, 0, 1}, {1, 1, 1}}, grid, {2, 2}, 0]; probUpdate = Map[If[2 <= # <= 7, Rescale[#, {2, 7}, {0.3, 1}], 0] &, neighborSum, {2}]; newGrid = MapThread[ If[RandomReal[] < #2, Mod[#1 + 1, 10], #1] &, {grid, probUpdate}, 2]; {rows, cols} = Dimensions[newGrid]; Do[If[RandomReal[] < sweepProbability, i = RandomInteger[{1, rows - 2}]; j = RandomInteger[{1, cols - 2}]; newValue = RandomInteger[{0, 9}]; newGrid[[i ;; i + 2, j ;; j + 2]] = ConstantArray[newValue, {3, 3}];], {5} ]; newGrid]; SimulateCA[size_, generations_] := Module[{evolution}, evolution = NestList[UpdateGrid, InitializeGrid[size], generations]; ListAnimate[ ArrayPlot[#, ColorRules -> Normal[colorAssociation], Mesh -> False, PlotRange -> {0, 9}, ImageSize -> 500] & /@ evolution, AnimationRate -> 8, ControlPlacement -> Top]]; SimulateCA[100, 300] ![CA Simulation][30] Furthermore--we're used to enumerating rules systematically--now we can explore the adjacency and or rotation matrices. Eigenvalues, are a relational matrix tool for analyzing growth rates. So when we utilize adjacency matrices to analytically calculate growth rates for finite systems (e.g., the Fibonacci-like "rabbit system"), we build matrix representations and adjust them if they don't work out right away, right? Well, it depends on how many matrix representations came before us and how much facilitation of similar analytical and geometric state transitions we can evolve, and their derivatives in the form of symmetries and firm non-deterministic evolution throughout our randomized rule selections, which do directly implement them, the multi-way non-determinism described by Niederman. That's why I don't just "discard" the state stabilization and fixed points; it turns out that the sandpile stabilization mirrors the examination of fixed points and equilibrium states in the context of state evolution, so for Niederman's use of graphs we can understand complex state evolution. I think that the local-rule-based evolution based on index-adjacent rotation matrices brings about the analytical and algebraic methods for enunciating the growth and evolution rates, and comes to embody key conceptual frameworks and computational methods not just in multi-way tag systems analysis but also in non-deterministic dynamics, in all the analytical methods that we need. State evolution and complexity was awesome, loved it. colorAssociation = <|0 -> Black, 1 -> Blue, 2 -> Cyan, 3 -> Green, 4 -> Brown|>; initializeGrid[size_] := SparseArray[{{Ceiling[size/2], Ceiling[size/2]} -> 4}, {size, size}]; stabilize[grid_] := FixedPoint[ Module[{dims = Dimensions[grid], temp = #}, Do[If[temp[[i, j]] >= 4, temp[[i, j]] -= 4; If[i > 1, temp[[i - 1, j]] += 1]; If[i < dims[[1]], temp[[i + 1, j]] += 1]; If[j > 1, temp[[i, j - 1]] += 1]; If[j < dims[[2]], temp[[i, j + 1]] += 1];], {i, dims[[1]]}, {j, dims[[2]]}]; temp] &, grid]; addGrain[grid_] := Module[{new = grid, pos, dims = Dimensions[grid]}, pos = RandomInteger[{1, #}, 2] & /@ dims; new[[pos[[1]], pos[[2]]]] += 1; stabilize[new]]; SeedRandom[42]; size = 5; initialState = initializeGrid[size]; states = NestList[addGrain, initialState, 8]; ListAnimate[ ArrayPlot[#, ColorRules -> colorAssociation, PlotLabel -> "Step " <> ToString[#2]] & @@@ Transpose[{states, Range[0, Length[states] - 1]}], AnimationRate -> 1, ImageSize -> 75] stateGraph = Graph[DirectedEdge @@@ Partition[Range[Length[states]], 2, 1], VertexShapeFunction -> (Inset[ ArrayPlot[states[[#2]], ColorRules -> colorAssociation, ImageSize -> 50], #1, Center] &), VertexSize -> 1.5, EdgeStyle -> Directive[Orange, Thick, Arrowheads[0.02]], GraphLayout -> "LayeredDigraphEmbedding", ImageSize -> 150, PlotLabel -> Style["State Transition Graph", 12, Bold]]; stateGraph ![Sandpile Evolution][31] ![Bitmap States Graph][32] This is why it's so important to facilitate analytical and geometric to decide to place some symmetrical obstacles into our state transitions, via adjacency matrices that serve as the foundation of mathematizing our linear algebraic operations which are still non-deterministic. But it's really about harnessing interference effects, opening up altogether new computational paradigms that initializations like electrons do not allow. There are "several" fabrication methods: traditional semiconductor etching (which requires doping to create narrow, electron-conducting channels) versus guiding light via channels that differ in refractive index. This not only draws in attention to the fundamental material differences but also brings up the thin veneer that--with photons--you might also bounce between interference effects for what that's worth. Here's an example of a rotation matrix: axis = {1, 0, 1}; normAxis = axis/Sqrt[axis . axis]; angle = Pi/3; rotationMatrix3 = RotationMatrix[angle, normAxis]; rotationMatrix3 // MatrixForm ![Rotation Matrix][33] This rotation operation relates to the geometric and symmetric transformation Niederman implies when discussing multi-dimensional state visualization. It goes a long way in supporting exploration of state-space symmetry in full visualizations of multi-way evolution graphs. And there are nontrivial interactions of light with matter. While detecting photons typically requires conversion back to electrical signals (using the photoelectric effect), it's the unique phenomena--like frequency shifting and interference--that promise additional functionalities (for instance, doing Fourier transforms in hardware). These effects answer the question of the possibility of a photonic switch that could function analogously (yet differently) to a transistor, a key component that drives conventional electronics. ruleSet = {{{0, 0, 0} -> {0, 0, 1}, "Rule A"}, {{0, 0, 1} -> {0, 1, 1}, "Rule B"}, {{0, 1, 0} -> {1, 0, 0}, "Rule C"}, {{0, 1, 1} -> {1, 1, 0}, "Rule D"}, {{1, 0, 0} -> {0, 0, 1}, "Rule E"}, {{1, 0, 1} -> {1, 1, 1}, "Rule F"}, {{1, 1, 0} -> {0, 1, 0}, "Rule G"}, {{1, 1, 1} -> {1, 0, 1}, "Rule H"}}; colorRules = Association[ MapIndexed[#[[2]] -> ColorData["Rainbow"][#2[[1]]/Length[ruleSet]] &, ruleSet]]; matrixTable = Grid[Prepend[ Map[Function[ r, {ToString[r[[1, 1]]], "\[RightArrow]", ToString[r[[1, 2]]], ":", r[[2]]}], ruleSet], {"Input State", "", "Output State", "", "Rule"}], Frame -> All]; edges = Map[ Function[r, Module[{lhs, rhs, lab}, lhs = r[[1, 1]]; rhs = r[[1, 2]]; lab = r[[2]]; Labeled[DirectedEdge[lhs, rhs], lab]]], ruleSet]; allStates = Union[Flatten[Map[{#[[1, 1]], #[[1, 2]]} &, ruleSet], 1]]; stateGraph = Graph[edges, VertexLabels -> "Name", GraphLayout -> "LayeredDigraphEmbedding", VertexStyle -> Directive[Black], ImageSize -> 400, PlotLabel -> Style["State Transition Graph", 16, Bold]]; Grid[{{Style["Transformation Matrix", Bold, 14]}, {matrixTable}, {stateGraph}}, Spacings -> {2, 2}] ![Transformation and State][34] These clearly defined state transitions resemble Niederman's from now on approach to tagging and reproducible rule-set within multi-way tag systems. Trying out a bunch of rules within multi-way tag systems opens the door to labeling rules corresponding to Niederman's rendition of state-graphs and rule-enumeration systems. These rule-enumeration systems frame the well-known mathematical fact about regular (Platonic) solids, contrast the limitless variety of regular polygons in 2 dimensions with the strict limitations in 3 dimensions--a classical result in geometry. Can we just extend these ideas into four dimensions and go beyond the traditional, transition to questions about hyper-platonic solids and their potential utility? For example, in network design or error-correcting codes through sphere packing? ruledRule1044 = {{0, 0} -> {0, 1}, {0, 0} -> {1, 1}, {0, 1} -> {0, 1}, {0, 1} -> {1, 1}, {1, 0} -> {1, 0}, {1, 0} -> {1, 1}, {1, 1} -> {1, 0}, {1, 1} -> {1, 1}}; colorAssociation = <|1 -> Blue, 2 -> Cyan, 3 -> Green, 4 -> Brown, 5 -> Orange, 6 -> Red, 7 -> Magenta, 8 -> Purple|>; stateAssociation = <|{0, 0} -> 1, {0, 1} -> 2, {1, 0} -> 3, {1, 1} -> 4|>; edges = Table[Module[{from, to}, from = rule[[1]]; to = rule[[2]]; stateAssociation[from] -> stateAssociation[to]], {rule, ruledRule1044}]; edgeStyles = Table[Directive[colorAssociation[i], Thickness[0.005], Arrowheads[{{0.015, 0.7}}]], {i, Length[edges]}]; transitionGraph = Graph[edges, EdgeLabels -> Placed["Index", 0.5], EdgeStyle -> Thread[edges -> edgeStyles], VertexLabels -> "Name", VertexLabelStyle -> Directive[Black, Bold, 16], VertexSize -> 0.3, VertexStyle -> White, GraphLayout -> "SpringElectricalEmbedding", ImageSize -> 400]; vertexCount = VertexCount[transitionGraph]; edgeCount = EdgeCount[transitionGraph]; meanDegree = Mean[VertexDegree[transitionGraph]]; betweenness = Mean[BetweennessCentrality[transitionGraph]]; statsPanel = Grid[{{"Vertex Count", vertexCount}, {"Edge Count", edgeCount}, {"Average Degree", NumberForm[meanDegree, 3]}, {"Average Betweenness", NumberForm[betweenness, 3]}}, Alignment -> Left, Background -> {None, {LightBlue, LightOrange}}, Dividers -> {False, True}, ItemStyle -> Bold, Frame -> True, FrameStyle -> GrayLevel[0.8]]; Row[{transitionGraph, Spacer[20], statsPanel}, Alignment -> Top] ![Vertices All][35] Vertex count, edge count, degree, betweenness centrality--these metrics are comparative quantitative measure for characterizing system complexity and growth rates. And of course, the categorization of complexity and growth behaviors of multi-way systems. I think that the geometric conversation can straightforwardly say for sure that by naming the 20-cell and 60-cell four-dimensional objects, sure three dimensions limit us to only five Platonic solids..higher dimensions allow for new echelons of regular structures. rule1044 = {{{0, 0}, {0, 1}}, {{0, 0}, {1, 1}}, {{0, 1}, {0, 1}}, {{0, 1}, {1, 1}}, {{1, 0}, {1, 0}}, {{1, 0}, {1, 1}}, {{1, 1}, {1, 0}}, {{1, 1}, {1, 1}}}; rules = #[[1]] -> #[[2]] & /@ rule1044; stateAssociation = <|{0, 1, 1} -> 1, {1, 1, 1} -> 2, {0, 1, 0} -> 3, {1, 1, 0} -> 4, {1, 0, 0} -> 5, {1, 0, 1} -> 6|>; colorAssociation = <|1 -> Blue, 2 -> Cyan, 3 -> Green, 4 -> Brown, 5 -> Orange, 6 -> Red, 7 -> Magenta, 8 -> Purple|>; Manipulate[ Module[{evolution}, evolution = ResourceFunction["MultiwaySystem"][rules, {{0, 1, 1}}, steps, "StatesGraph", GraphLayout -> "LayeredDigraphEmbedding"]; Graph[evolution, VertexStyle -> Thread[VertexList[evolution] -> Lookup[colorAssociation, Lookup[stateAssociation, VertexList[evolution], 7]]], VertexSize -> 0.5, EdgeStyle -> Directive[Gray, Thickness[0.001]], VertexLabels -> Placed["Name", Center], PerformanceGoal -> "Quality", ImageSize -> 400]], {steps, 1, 6, 1, Appearance -> "Labeled"}, ControlPlacement -> Top, FrameMargins -> 0] ![Multiway System 1][36] This is essentially the same approach to visualize multi-way evolution through directed graphs, texturizing the non-deterministic transitions and branching nature of the evolution of states. There are some practical applications of this approach such as designing optimal switching networks or developing new algorithms that benefit from high-dimensional geometry. But we had made ourselves into the ultimate, cultural and psychological reflection of the impact of interacting with advanced AIs. The grammatical issue of emotional attachment to advanced AIs that "know you better than you know yourself", thereby links the discussion of AI agents with syntactical questions about human-machine interaction and relationships. In doing so, we parrot the implications of AI personalization and trust, which intersects tag systems with the multi-language capacity of AI and human perception. colorAssociation = <|0 -> Black, 1 -> Blue, 2 -> Cyan, 3 -> Green, 4 -> Brown, 5 -> Orange, 6 -> Red, 7 -> Magenta, 8 -> Purple|>; InitializeGrid[size_] := ArrayPad[RandomInteger[{0, 1}, {size, size}], 1, "Periodic"]; EvolutionRule[grid_] := Module[{newGrid, neighbors, cell}, newGrid = ConstantArray[0, Dimensions[grid]]; Do[neighbors = Total@Flatten@grid[[i - 1 ;; i + 1, j - 1 ;; j + 1]] - grid[[i, j]]; cell = grid[[i, j]]; newGrid[[i, j]] = Switch[cell, 0, If[neighbors == 3, 1, 0], 1, If[2 <= neighbors <= 3, 2, 1], 2, If[1 <= neighbors <= 4, 3, 2], 3, If[neighbors > 4, 4, If[neighbors < 2, 2, 3]], 4, If[EvenQ[neighbors], 5, 4], 5, If[OddQ[neighbors], 6, 5], 6, 7, 7, 8, 8, 0];, {i, 2, Length[grid] - 1}, {j, 2, Length[grid] - 1}]; ArrayPad[newGrid[[2 ;; -2, 2 ;; -2]], 1, "Periodic"]]; DynamicModule[{grid = InitializeGrid[50], running = True}, Column[{Button[Dynamic[running], running = ! running, Appearance -> "Palette"], Dynamic[If[running, grid = EvolutionRule[grid]]; ArrayPlot[grid[[2 ;; -2, 2 ;; -2]], PixelConstrained -> 8, ColorRules -> Normal[colorAssociation], Frame -> False, ImageSize -> 500]]}, Alignment -> Center]] ![Evolving CA][37] We have this idea which frequently refers to cellular automata-like transformations. Our Cellular Automata rules define state evolution that is syntactically and conventionally iterative, in the directive construction of locally-interactive state systems. Shifting focus to practical design considerations, we wish for multi-way tag systems not only to record isomorphisms (such as with cellular automata or sandpile models) but also to interact more fluidly with the user experience. Although this topic seems distinct from next-level wearable geometry like photonic computing, both areas share a common thread: they discuss how subtle design choices (whether in hardware materials, sensor technology, or interface interaction) can make a significant difference in usability and efficiency. ruledRule1044 = {{0, 0} -> {0, 1}, {0, 0} -> {1, 1}, {0, 1} -> {0, 1}, {0, 1} -> {1, 1}, {1, 0} -> {1, 0}, {1, 0} -> {1, 1}, {1, 1} -> {1, 0}, {1, 1} -> {1, 1}}; colorAssociation = <|1 -> Blue, 2 -> Cyan, 3 -> Green, 4 -> Brown, 5 -> Orange, 6 -> Red, 7 -> Magenta, 8 -> Purple|>; states = Union[ruledRule1044[[All, 1]], ruledRule1044[[All, 2]]]; edges = DirectedEdge @@@ ruledRule1044; edgeStyles = Table[edges[[i]] -> colorAssociation[i], {i, Length[edges]}]; stateGraph = Graph[states, edges, EdgeStyle -> edgeStyles, VertexLabels -> Placed["Name", Center], VertexStyle -> Directive[Black, EdgeForm[White]], VertexSize -> 0.35, VertexLabelStyle -> Directive[White, Bold, 14], GraphLayout -> "LayeredDigraphEmbedding", ImageSize -> 300, PlotLabel -> Style["Non-Deterministic State Transitions", White, Bold, 24]]; graphMetrics = {{"Vertex Count", VertexCount[stateGraph]}, {"Edge Count", EdgeCount[stateGraph]}, {"Mean Vertex Degree", N[Mean[VertexDegree[ stateGraph]]]}, {"Mean Betweenness Centrality", N[Mean[BetweennessCentrality[stateGraph]]]}}; Grid[{{stateGraph}, Sequence @@ ({Style[#[[1]], Bold], #[[2]]} & /@ graphMetrics)}, Alignment -> Left, Dividers -> All, Background -> {None, {LightGray, {White}}}, FrameStyle -> Directive[Gray, Thick]]; Animate[HighlightGraph[stateGraph, Subgraph[stateGraph, Evaluate[Take[EdgeList[stateGraph], n]]]], {n, 0, Length[edges], 1}] ![State Transitions][38] In the same way that the prior sandpile stabilization algorithms analyze system stability, fixed points, and state complexity, our analysis of tag systems includes principles of iterative stabilization and equilibrium. It relates to the earlier technical discussions by contrasting the rigorous, precision-oriented details in state complexity technology (like electron/photon channels) with the process management that exists beneath large-scale innovation. Both the iterative and the ideal approach require detailed planning, measured milestones, and recognition of when to pause for review and quality control. rules = {"A" -> "AB", "A" -> "BA", "B" -> "AA"}; colorRules = <|"A" -> "AB" -> Red, "A" -> "BA" -> Blue, "B" -> "AA" -> Green|>; evolutions = ResourceFunction["MultiwaySystem"][rules, "A", 4, "StatesGraph", VertexLabels -> "Name", GraphLayout -> "LayeredDigraphEmbedding"]; styledEdges = Map[# /. DirectedEdge[a_, b_, c_] :> Style[DirectedEdge[a, b, c], colorRules[c]] &, EdgeList[evolutions]]; styledGraph = Graph[styledEdges, VertexLabels -> "Name", GraphLayout -> "LayeredDigraphEmbedding", VertexSize -> 0.2, EdgeLabels -> Placed["EdgeTag", 0.5], EdgeLabelStyle -> Directive[Black, Italic, 10], EdgeStyle -> Thick, VertexStyle -> Directive[LightBlue, EdgeForm[Black]], ImageSize -> 800]; styledGraph ![Styled Graph][39] We started out with 2-dimensional state transition graphs and now, our 3-dimensional cellular automaton integrations extend the Niederman framework to three-dimensional cellular automata. I thought the spatial and temporal complexities suggested in state-graph embeddings were easily recognizable, until I saw the multi-dimensional embeddings. The type of embeddings that we're talking about aren't iterative but they are coordinated in vector space and controlled deployment in the development process--this is a resounding theme of the systematic approach found in both scientific research and engineering. Whether you're designing cellular automata or managing a complex multiway system, constructing a time series is crucial. SandStep[s_] := s + ListConvolve[{{0, 1, 0}, {1, -4, 1}, {0, 1, 0}}, UnitStep[s - 4], 2, 0]; AddGrain[grid_] := Module[{x, y, dim = Length[grid]}, {x, y} = RandomInteger[{1, dim}, 2]; ReplacePart[grid, {x, y} -> grid[[x, y]] + 5]]; Stabilize[grid_] := Most@FixedPointList[SandStep, grid]; InitializeGrid[size_, height_] := CenterArray[{{height}}, {size, size}]; Manipulate[ Module[{gridState = If[reset, InitializeGrid[21, initialHeight], currentGrid]}, If[add, currentGrid = AddGrain[gridState]; avalancheSteps = Stabilize[currentGrid]; step = 1; add = False; reset = False]; Column[{ArrayPlot[ If[avalancheMode && step <= Length[avalancheSteps], avalancheSteps[[step]], currentGrid], ColorFunction -> "TemperatureMap", ImageSize -> 400, PlotLabel -> If[avalancheMode, "Avalanche Step: " <> ToString[step], "Current State"]], If[avalancheMode && Length[avalancheSteps] > 1, Row[{"Avalanche Progress: ", ProgressIndicator[step/Length[avalancheSteps]], Button["Next Step", If[step < Length[avalancheSteps], step++, step = 1]]}], Nothing]}]], {{currentGrid, InitializeGrid[21, 4]}, ControlType -> None}, {{avalancheSteps, {}}, ControlType -> None}, {{step, 1}, ControlType -> None}, {{add, False}, ControlType -> None}, {{reset, False}, ControlType -> None}, Row[{Button["Add Grain", add = True; reset = False, ImageSize -> 100], Button["Reset", currentGrid = InitializeGrid[21, initialHeight]; reset = True; step = 1, ImageSize -> 100]}], Control[{{initialHeight, 4, "Initial Center Height"}, 1, 10, 1}], Control[{{avalancheMode, True, "Show Avalanche Steps"}, {True, False}}], TrackedSymbols :> {add, reset, initialHeight, avalancheMode, step}] ![Sandpile Avalanche][40] I would think that the Sandpile Model matches non-deterministic evolution via random choices, conceptualizing multi-way systems as where multiple outcomes are exponentially actualized from single direct states, branching out into complex state-spaces. Although these state spaces are traditionally seen as a haven for endless possibilities, the reality is filled with experimental mathematics which serve as a bridge in the discussion about non-deterministic versus deterministic evolution--whether to pursue research in an academic bubble or embrace the challenges of entrepreneurial ventures where decisions must be made rapidly and holistically. possibles = Tuples[{0, 1}, 2]; ruledRule1044 = {{0, 0} -> {0, 1}, {0, 0} -> {1, 1}, {0, 1} -> {0, 1}, {0, 1} -> {1, 1}, {1, 0} -> {1, 0}, {1, 0} -> {1, 1}, {1, 1} -> {1, 0}, {1, 1} -> {1, 1}}; colorAssociation = <|1 -> Blue, 2 -> Cyan, 3 -> Green, 4 -> Brown, 5 -> Orange, 6 -> Red, 7 -> Magenta, 8 -> Purple|>; edges = Flatten[ Table[With[{rule = ruledRule1044[[n]]}, DirectedEdge[rule[[1]], rule[[2]], n]], {n, Length[ruledRule1044]}], 1]; stateTransitionGraph = EdgeTaggedGraph[edges, EdgeStyle -> Table[edge -> colorAssociation[edge[[3]]], {edge, edges}], VertexLabels -> "Name", VertexShapeFunction -> "Square", VertexSize -> 0.1, EdgeLabels -> "EdgeTag", ImageSize -> Large, GraphLayout -> "SpringElectricalEmbedding"]; stateTransitionGraph ![State Transition Graph 3][41] My answer would be not to visually analyze all the different graph layout methods, but to look at these sandpiles and state transition graphs as being in the context of Gaussian noise. It means that the assumption that we make about the noise being Gaussian can also be violated. Because what we can do is we can make good use of the appearances of the objects as the appearances of the objects change and or we're looking at not just one target but multiple targets. This is the story of analytics, the admonition that champions a STEM mindset in entrepreneurship. It conveys that the analytical skills cultivated in rigorous scientific study (like problem solving with mathematics or physics) are equally valuable in business strategy and decision-making. ruledRule1044 = {{0, 0} -> {0, 1}, {0, 0} -> {1, 1}, {0, 1} -> {0, 1}, {0, 1} -> {1, 1}, {1, 0} -> {1, 0}, {1, 0} -> {1, 1}, {1, 1} -> {1, 0}, {1, 1} -> {1, 1}}; stateAssociation = <|{0, 1, 1} -> 1, {1, 1, 1} -> 2, {0, 1, 0} -> 3, {1, 1, 0} -> 4, {1, 0, 0} -> 5, {1, 0, 1} -> 6|>; colorAssociation = <|1 -> Blue, 2 -> Cyan, 3 -> Green, 4 -> Brown, 5 -> Orange, 6 -> Red, 7 -> Magenta, 8 -> Purple|>; transitions = {}; Do[currentState = stateAssocKeys[[i]]; Do[If[MatchQ[Part[currentState, j ;; j + 1], rule[[1]]], nextState = ReplacePart[ currentState, {j -> rule[[2, 1]], j + 1 -> rule[[2, 2]]}]; If[KeyExistsQ[stateAssociation, nextState], AppendTo[ transitions, {stateAssociation[currentState] -> stateAssociation[nextState], rule}]]], {j, 2}, {rule, ruledRule1044}], {i, Length[stateAssocKeys = Keys[stateAssociation]]}]; edges = Style[DirectedEdge @@ #[[1]], Directive[ colorAssociation@First@Flatten[Position[ruledRule1044, #[[2]]]], Thickness[0.003], Arrowheads[0.02]]] & /@ transitions; stateGraph = EdgeTaggedGraph[edges, VertexLabels -> {v_ :> Placed[Framed[Style[v, 14, White], Background -> Darker@Gray, RoundingRadius -> 5], Center]}, VertexStyle -> Darker[Gray, 0.8], VertexSize -> 0.25, VertexShapeFunction -> "RoundedRectangle", GraphLayout -> "SpringElectricalEmbedding", EdgeLabels -> Placed["EdgeTag", 0.6], Prolog -> {White, Opacity[0.1], Rectangle[Scaled[{0, 0}], Scaled[{1, 1}]]}]; graphMetrics = {{"Vertex Count", VertexCount@stateGraph}, {"Edge Count", EdgeCount@stateGraph}, {"Mean Degree", N@Mean@VertexDegree@stateGraph}, {"Diameter", GraphDiameter@stateGraph}, {"Clustering Coefficient", N@Mean@LocalClusteringCoefficient@stateGraph}}; Grid[Prepend[graphMetrics, {"Metric", "Value"}], Frame -> All, Alignment -> Left, Background -> {None, {Lighter[Yellow, 0.9], {White}}}] Labeled[stateGraph, Style["Cellular Automaton State Transition Graph", 16, Bold], Top] ![Cellular Automaton State Transition Graph][42] But nonetheless we don't understand, that the multi-way state evolutions can be understood through various embeddings, which beats all the computational complexity through pattern recognition in multi-way systems; the quantum lattice evolution that we do and the "Quantum Fibonacci" mentioned is still a fresh and unused, quantum-like complex interaction. We can think of multi-way systems via the island mentality that encompasses all elements of fractal growth. It ties back to the earlier technical discussions on photonic computing and geometry, where precise quantitative thinking is essential, and emphasizes that such skills enable one to analyze markets, manage projects, and ultimately innovate. possibles = Flatten[Table[{{a, b}, {c, d}}, {a, {0, 1}}, {b, {0, 1}}, {c, {0, 1}}, {d, {0, 1}}], 3]; mf = FunctionRepository["MultiwaySystem"]; visualizeTransitions[ruleNumber_, steps_] := Module[{rule, initState, statesGraph, cat}, rule = IntegerDigits[ruleNumber, 2, 8]; initState = {CenterArray[1, {3, 3}]}; statesGraph = mf["CellularAutomaton" -> {2, {2, 1}, rule}, initState, steps, "StatesGraph", GraphLayout -> {"LayeredDigraphEmbedding", "Orientation" -> Top}, VertexShapeFunction -> (Inset[ ArrayPlot[#2, Mesh -> All, ImageSize -> 30, ColorRules -> {0 -> Black, 1 -> White}], #1, Center, 0.1] &), EdgeStyle -> Directive[Thickness[0.005], Opacity[0.5], Gray], VertexSize -> 0.2, PerformanceGoal -> "Quality"];]; Manipulate[ Column[{Grid[{{visualizeTransitions[ruleNumber, steps], ArrayPlot[ CellularAutomaton[{ruleNumber, 2, 1}, {{1}, 0}, steps], ColorRules -> {0 -> Black, 1 -> White}, Frame -> False, ImageSize -> 300]}}, Spacings -> {2, 1}]}], {{ruleNumber, 110, "Rule Number"}}, {{steps, 5, "Evolution Steps"}, 1, 10, 1, Appearance -> "Labeled"}] ![Rule 110][43] It's one thing to look at these pretty black and white graphs, however we can decide to entertain vertex degree and diameter and centrality--graph metrics that technicalize the quantitative structural properties and growth complexity of state graph metrics and analysis. rules = {{0, 0} -> {0, 1}, {0, 0} -> {1, 1}, {0, 1} -> {1, 0}, {0, 1} -> {1, 1}, {1, 0} -> {0, 0}, {1, 0} -> {0, 1}, {1, 1} -> {0, 0}, {1, 1} -> {1, 0}}; init = {{0, 0, 0}}; evograph = ResourceFunction["MultiwaySystem"][rules, init, 4, "StatesGraph"]; vertexList = VertexList[evograph]; vertexColors = AssociationThread[vertexList, ColorData["SolarColors"] /@ Rescale[Hash /@ vertexList]]; Graph[evograph, VertexStyle -> Normal[vertexColors], GraphLayout -> "LayeredDigraphEmbedding", VertexSize -> 0.7, VertexShapeFunction -> "Capsule", EdgeStyle -> Directive[GrayLevel[0.3], Thickness[0.0015]], VertexLabels -> Placed["Name", Tooltip], ImageSize -> Medium, AspectRatio -> 1/2, PerformanceGoal -> "Quality"] ![All Evo Graph][44] We were right the first time about multi-dimensional, voxel-based evolutions that correspond directly to the Niederman, sophisticated approach to visualizing complex evolutionary state-graphs, including multi-dimensional embeddings which embed spatial analysis reflecting multiple outcomes from single initial conditions. By mapping symbolic states directly to their corresponding 3-dimensional voxel arrangements, users can now explore the evolution of the system through both state transitions and physical transformations. This approach innovates a robust frame of reference for user-guided exploration and may lead to the relationship between symbolic and spatial representations in complex systems. ruledRuleComplex = {{0, 0} -> {0, 1}, {0, 0} -> {1, 2}, {0, 1} -> {2, 0}, {0, 1} -> {1, 1}, {1, 0} -> {0, 2}, {1, 0} -> {2, 1}, {1, 1} -> {0, 0}, {1, 1} -> {2, 2}, {1, 2} -> {0, 1}, {1, 2} -> {2, 0}, {2, 0} -> {0, 0}, {2, 0} -> {1, 2}, {2, 1} -> {2, 0}, {2, 1} -> {0, 2}, {2, 2} -> {1, 1}, {2, 2} -> {0, 2}}; colorAssociation = <|0 -> Gray, 1 -> Blue, 2 -> Cyan, 3 -> Green, 4 -> Brown, 5 -> Orange, 6 -> Red, 7 -> Magenta, 8 -> Purple|>; stringRules = Map[ToString[#[[1]]] -> ToString[#[[2]]] &, ruledRuleComplex]; Manipulate[ Module[{dynGraph, dynVertices, target, foundPaths, highlightPath}, dynGraph = ResourceFunction["MultiwaySystem"][stringRules, {"{0, 1}"}, generations, "StatesGraph", GraphLayout -> {"LayeredDigraphEmbedding", "Orientation" -> Left}, VertexShapeFunction -> (With[{state = ToExpression[#2]}, {colorAssociation[FromDigits[state, 3]], EdgeForm[Black], Disk[#1, 0.15], Text[Style[#2, White, Bold], #1]}] &), EdgeStyle -> Directive[Thick, Gray], VertexSize -> 0.4, ImageSize -> 400]; dynVertices = VertexList[dynGraph]; target = If[Length[dynVertices] > 1, First[Select[dynVertices, (# =!= "{0, 1}") &]], "{0, 1}"]; foundPaths = FindPath[dynGraph, "{0, 1}", target, {3}, All]; highlightPath = If[foundPaths === {}, Graph[{}, {}], PathGraph[foundPaths[[1]]]]; HighlightGraph[dynGraph, highlightPath, GraphHighlightStyle -> Directive[Thick, Red], PlotLabel -> Style[Row[{"Path length ", 3, " in a ", generations, " generation graph from {0, 1} to ", target}], 12, Bold]]], {{generations, 1, "Generations"}, 1, 4, 1, Appearance -> "Labeled"}] ![Complex Evolution Generations][45] That's what brings these graph layouts for intuitive interpretation "onto" the quantitative characterization from looking at piles of sand to characterizing the quantitative complexity of a poptart or attending to the higher-dimensional state-space that is reachable via rule-based iterative transformations and quantum-like evolution which takes advantage of the spatial dynamics that, may be the foundation of multi-way tag systems but that aren't the deterministic, concrete computational representation of the collective concepts explored in Niederman's article, at least not yet. But anyway. possibles = Flatten[Table[{{a, b}, {c, d}}, {a, {0, 1}}, {b, {0, 1}}, {c, {0, 1}}, {d, {0, 1}}], 3]; transitionRules = {{0, 0} -> {0, 1}, {0, 1} -> {1, 1}, {1, 0} -> {1, 0}, {1, 1} -> {1, 0}}; colorAssociation = <|0 -> Blue, 1 -> Red, 2 -> Green, 3 -> Orange|>; stateAssociation[grid_] := Hash[grid, "MD5"]; ApplyRules[grid_] := Module[{newGrid}, newGrid = Partition[grid /. transitionRules, 2]] GenerateEvolutionGraph[initialState_, generations_] := Module[{states = {initialState}, edges = {}}, Do[states = DeleteDuplicates@ Flatten[Function[g, With[{newStates = ApplyRules /@ g}, edges = Join[edges, Thread[g -> newStates]]; newStates]] /@ states, 1];, {generations}]; {states, edges}] Manipulate[ Module[{states, edges, graph, vd, ed, mvd}, {states, edges} = GenerateEvolutionGraph[Partition[RandomInteger[1, 4], 2], generations]; graph = Graph[edges, VertexShapeFunction -> (Inset[ Style[Framed[MatrixForm[#2], FrameStyle -> Directive[Thick, #2 /. colorAssociation]], EdgeForm[Black], Background -> White], #, {0, 0}, {0.1, 0.1}] &), EdgeStyle -> Directive[Gray, Thickness[0.003]], GraphLayout -> "LayeredDigraphEmbedding", PerformanceGoal -> "Quality", ImageSize -> 400]; vd = VertexDegree[graph]; mvd = Mean[vd]; Column[{graph, Grid[{{"Vertex Count", VertexCount[graph]}, {"Edge Count", EdgeCount[graph]}, {"Max Degree", Max[vd]}, {"Min Degree", Min[vd]}, {"Mean Degree", mvd}}, Frame -> All]}]], {{generations, 3, "Generations"}, 1, 5, 1, Appearance -> "Labeled"}, Button["New Initial State", None, ImageSize -> Medium], ControlPlacement -> Top] ![Evolution Graph Generations][46] So in the first evolution graph example. Without much of an explanation we find a collection of possible two-digit pairs that is created from binary values, and we have to figure out--provided a set of transition rules--for instance, replacing {0, 0} with {0, 1} and so on..what are the binary transitions? Well, the numerical values are inextricably associated via colors and, the grid state that is hashed for uniqueness..the transformation of the `ApplyRules` transforms a flat list (or grid) by applying these transitions and then partitions the result back into two-element blocks. InitializeQuantumGrowth[] := Association["Position" -> {{0, 0, 0}}, "Directions" -> {IdentityMatrix[3]}, "States" -> {1}, "History" -> {}]; QuantumTransform[state_] := Module[{newstates}, newstates = Switch[state, 1, {{2, RotationMatrix[Pi/2, {1, 0, 0}]}, {3, RotationMatrix[Pi/2, {0, 1, 0}]}}, 2, {{1, RotationMatrix[-Pi/2, {1, 0, 0}]}, {3, RotationMatrix[Pi/2, {0, 0, 1}]}}, 3, {{1, RotationMatrix[-Pi/2, {0, 1, 0}]}, {2, RotationMatrix[-Pi/2, {0, 0, 1}]}}, _, {}]; Map[Association["State" -> #[[1]], "Rotation" -> #[[2]]] &, newstates]]; IterateQuantumGrowth[data_] := Module[{newpositions = {}, newdirections = {}, newstates = {}, newhistory, max}, newhistory = data["History"]; max = Length[data["Position"]]; Do[Module[{pos, dir, state, transforms}, pos = data["Position"][[i]]; dir = data["Directions"][[i]]; state = data["States"][[i]]; transforms = QuantumTransform[state]; Do[Module[{newdir, newpos}, newdir = t["Rotation"] . dir; newpos = pos + newdir[[1]]; If[! MemberQ[data["Position"], newpos], AppendTo[newpositions, newpos]; AppendTo[newdirections, newdir]; AppendTo[newstates, t["State"]]; newhistory = Append[newhistory, {pos, newpos}];]], {t, transforms}]], {i, max}]; If[Length[newpositions] > 0, Association["Position" -> Join[data["Position"], newpositions], "Directions" -> Join[data["Directions"], newdirections], "States" -> Join[data["States"], newstates], "History" -> newhistory], data]]; VisualizeQuantumGrowth[data_] := Graphics3D[{Thickness[0.02], MapThread[{Hue[#/3], Line[#2]} &, {data["States"][[2 ;;]], data["History"]}], MapThread[{Hue[#/3], Specularity[White, 20], Sphere[#2, 0.3]} &, {data["States"], data["Position"]}]}, Lighting -> "Neutral", Boxed -> False, PlotRange -> {{-10, 10}, {-10, 10}, {-10, 10}}, ImageSize -> 300]; qgrowth = Nest[IterateQuantumGrowth, InitializeQuantumGrowth[], 6]; VisualizeQuantumGrowth[qgrowth] ![Quantum Growth Rotation][47] Next, we iteratively apply the rules over a set number of generations; as new states are generated, edges representing their evolution are constructed and later visualized as a directed graph. That is why we set the number of generations and generate a new initial state, while providing statistical summaries such as vertex count, edge count, and average degree..to show, how binary state transitions can be systematically explored, and how the resulting evolution can be encoded graphically. MultiwayVoxelEvolution[rules_, init_, generations_] := Module[{statesGraph, coordMap, edges, voxels, lines}, statesGraph = ResourceFunction["MultiwaySystem"][rules, init, generations, "StatesGraph"]; coordMap = Association[ MapIndexed[ ToString[#1] -> {Mod[Hash[ToString[#1], "Adler32"], 10], Mod[Hash[ToString[#1], "CRC32"], 10], Mod[Hash[ToString[#1], "MD5"], 10]} &, VertexList[statesGraph]]]; edges = List @@@ (EdgeList[ statesGraph] /. (a_ -> b_) :> {ToString[a], ToString[b]}); voxels = Table[{Hue[Norm[pt]/30, 1, 1], Cuboid[pt - 0.4, pt + 0.4]}, {pt, Values[coordMap]}]; lines = Map[Function[edge, Module[{pts = Lookup[coordMap, edge]}, {GrayLevel[0.3, 0.5], Tube[{pts[[1]] + RandomReal[{-0.1, 0.1}, 3], pts[[2]] + RandomReal[{-0.1, 0.1}, 3]}, 0.05]}]], edges]; Manipulate[ Graphics3D[{voxels, lines}, Boxed -> False, SphericalRegion -> True, ViewPoint -> {Sin[\[Theta]] Cos[\[Phi]], Sin[\[Theta]] Sin[\[Phi]], Cos[\[Theta]]}, PlotLabel -> Style["Multiway System Evolution", 16]], {{\[Theta], \[Pi]/4}, 0, \[Pi]}, {{\[Phi], \[Pi]/4}, 0, 2 \[Pi]}, TrackedSymbols -> {\[Theta], \[Phi]}]] MultiwayVoxelEvolution[{"A" -> "AB", "AB" -> "BA", "B" -> "A"}, "A", 5] ![Multiway Voxel Generation 2][48] The introduction of a "quantum growth" simulation..wherein the system, is initialized as a single voxel at the origin with an associated state and a list of possible directional transformations..the function `QuantumTransform` assigns new states and rotations to the current state--for example, if the current state is 1, it may spawn new voxels rotated by ±90° around a given axis. The appellation of the iterative function `IterateQuantumGrowth` then makes it easy for us to examine each current voxel's state and direction, apply the corresponding transformations, and expand and fold the overarching structure while recording the growth history. Finally, `VisualizeQuantumGrowth` takes the accumulated positions and histories, rendering a 3-dimensional graphic where lines trace the growth path and spheres show the evolving voxels with colors based on their state. MultiwayQuantumLattice[rules_, init_, steps_] := Module[{statesGraph, edges, vertices, coordMap, quantumStates, depthMap, rotations, quantumColor}, statesGraph = ResourceFunction["MultiwaySystem"][rules, init, steps, "StatesGraph", GraphLayout -> {"LayeredEmbedding", "Orientation" -> Top}]; vertices = VertexList[statesGraph]; edges = EdgeList[statesGraph]; quantumStates = AssociationThread[vertices, Map[Count[#, "1"]/Max[1, StringLength[#]] &, vertices]]; quantumColor[x_] := Blend[{RGBColor[0.27, 0.34, 1., 0.145], RGBColor[0.34, 0.27, 1., 0.145]}, x]; depthMap = AssociationThread[vertices, GraphDistance[statesGraph, First[vertices], #] & /@ vertices]; coordMap = Association@ MapThread[#1 -> {Cos[#2*2 Pi/5], Sin[#2*2 Pi/5], depthMap[#1]/2} &, {vertices, Range[Length[vertices]] - 1}]; rotations = Table[RotationMatrix[\[Theta], {0, 0, 1}], {\[Theta], 0, 2 Pi, Pi/2}]; Graphics3D[{{Opacity[0.2], LightBlue, Map[Line[{{0, 0, 0}, #}] &, Values[coordMap]]}, {Specularity[1, 50], MapThread[{quantumColor[#2], GeometricTransformation[ Cuboid[#1 - {0.1, 0.1, 0}, #1 + {0.1, 0.1, 0.2}], rotations]} &, {Values[coordMap], Values[quantumStates]}]}, {Thick, Opacity[0.5], Map[{ColorData["Rainbow"][RandomReal[]], Tube[{Lookup[coordMap, #[[1]]], Lookup[coordMap, #[[2]]]}, 0.02]} &, edges]}}, Boxed -> False, Lighting -> {"Ambient", White}, ViewPoint -> {3, 1, 1}, ImageSize -> 400, PlotLabel -> Style["Quantum Multiway Lattice", 12], SphericalRegion -> True]] QuantumFibonacciSystem[] := MultiwayQuantumLattice[{"A" -> "AB", "B" -> "A"}, "A", 6] QuantumFibonacciSystem[] ![Quantum Multiway Rotation][49] This module illuminates how discrete rotational and translational operations can model a kind of “quantum” twist in a spatial setting. In other geometries, the code demonstrates a direct mapping from symbolic multiway systems to voxel-based 3D structures. A voxel prototype (the “headlamp prototile”) is defined with voxel positions and connectors for incoming and outgoing links. Functions for geometric transformations—one that shifts points (FourPointTransforms) and another that rotates vectors (VectorTransform)—combine into a transformation routine (FourTransforms) that applies both translation and rotation. A symbolic rule system (e.g., {"A" -> "AB", "B" -> "A"}) is then processed by a function (TransformFromState) which reads each symbol from a state string and applies a corresponding transformation. The transformed states yield specific voxel arrangements via TransformOne. An interactive 3D graph, built with dynamic controls, lets users click through the state space; each state is represented with a clickable button inserted into a 3D view, and paths through the state graph are available. This example embodies the idea that a symbolic evolution—long studied by Niederman—can be grounded in tangible 3D geometries, providing an interactive exploration of how abstract strings translate into spatial structures. LEGOMultiwayExplorer[rules_, init_, steps_] := DynamicModule[{g, coords, vertices, colors, currentState = init, path = {}, vertexColor1}, g = ResourceFunction["MultiwaySystem"][rules, init, steps, "StatesGraph"]; coords = GraphEmbedding[ Graph3D[g, GraphLayout -> "SpringElectricalEmbedding"]]; vertices = VertexList[g]; colors = Hue /@ Rescale[StringLength /@ vertices]; vertexColor1 = First[colors]; Column[{Dynamic[ Graphics3D[{EdgeForm[Thin], MapThread[{If[MemberQ[path, #1], Yellow, If[#1 === First[vertices], vertexColor1, #2]], Cuboid[#3 - {0.4, 0.4, 0.2}, #3 + {0.4, 0.4, 0.2}], If[#1 == currentState, {Red, Sphere[#3, 0.3]}, {}]} &, {vertices, colors, coords}]}, Boxed -> True, Lighting -> "Neutral", ImageSize -> 400, SphericalRegion -> True, PlotLabel -> Style["LEGO Multiway System Explorer", 16]]], Row[{Button["Reset", currentState = init; path = {}, ImageSize -> Medium], PopupMenu[ Dynamic[currentState, (currentState = #; AppendTo[path, #]) &], vertices], ColorSlider[Dynamic[vertexColor1], ImageSize -> {200, 40}]}, Spacer[20]]}]] LEGOMultiwayExplorer[{"A" -> "AB", "B" -> "BA"}, "A", 4] ![LEGO Multiway Evolution][50] It turns out that we can compute a state graph of symbolic evolutions and assign each vertex a 3D coordinate based on its graph depth. The resulting voxels are placed according to these coordinates, and edges between states are rendered as tubes. This creates a “layered” display that combines state transitions with spatial embedding. Multiway3DVisualization[rules_, init_, steps_] := Module[{g, vertices, edges, depths, coordMap, counter, coords, voxels, colors, tubes, plotLabel}, g = ResourceFunction["MultiwaySystem"][rules, init, steps, "StatesGraph"]; vertices = VertexList[g]; edges = EdgeList[g]; depths = AssociationMap[GraphDistance[g, init, #] &, vertices]; coordMap = <||>; counter = <||>; Do[depth = depths[v]; If[! KeyExistsQ[counter, depth], counter[depth] = 0]; coordMap[v] = {counter[depth], 0, depth}; counter[depth] += 1, {v, vertices}]; coords = Lookup[coordMap, vertices]; voxels = Map[Cuboid[# - {0.2, 0.2, 0.1}, # + {0.2, 0.2, 0.1}] &, coords]; colors = ColorData["Rainbow"] /@ Rescale[depths /@ vertices]; tubes = Map[With[{p1 = coordMap[#[[1]]], p2 = coordMap[#[[2]]]}, {GrayLevel[0.3], Tube[{p1, p2}, 0.02]}] &, edges]; Graphics3D[{EdgeForm[Thin], MapThread[{#1, #2} &, {colors, voxels}], tubes}, Boxed -> True, Lighting -> "Neutral", Axes -> True, AxesLabel -> {"X", "Y", "Generation"}, ViewVertical -> {0, 0, 1}, ViewPoint -> {2, 2, 2}]]; Multiway3DVisualization[{"A" -> "AB", "B" -> "A"}, "A", 4] ![1 Multiway 3d Visualization][51] `MultiwayQuantumLattice` further redoes this concept by computing the much-coveted, quantum-inspired lattice. Each node is assigned a quantum “density” based on its symbolic content (for example, the proportion of ones in a binary string). We've got our color mixer as well as the 3D spring-electrical layout that we use to highlight the connections between symbolic states. Together, these tools show albeit as slowly as possible that both multiway and quantum lattice systems can join different facets of complex symbolic dynamics in three dimensions. colorAssociation = <|0 -> White, 1 -> RGBColor[0.2, 0.4, 0.9], 2 -> RGBColor[0.3, 0.7, 0.9], 3 -> RGBColor[0.1, 0.8, 0.3], _ -> RGBColor[0.9, 0.2, 0.1] |>; SandStep[s_] := s + ListConvolve[{{0, 1, 0}, {1, -4, 1}, {0, 1, 0}}, UnitStep[s - 4], 2, 0]; DynamicModule[{grid = ConstantArray[0, {41, 41}], running = False}, grid[[20, 20]] = 5000; Column[{Button[If[running, "Stop", "Start"], running = ! running, ImageSize -> {100, 30}], Dynamic[If[running, grid = SandStep[grid]; Pause[0.01];]; ArrayPlot[grid, ColorRules -> Normal[colorAssociation], PixelConstrained -> 2, PlotRangePadding -> 0, ImageSize -> 500, Epilog -> {Text[Style["Click to add sand!", 12, Black], Scaled[{0.5, 0.03}]]}]], Button["Add Sand", grid += RandomInteger[1, {41, 41}]*5;, ImageSize -> {100, 30}]}, Alignment -> Center]] ![Sandpile Start and Add][52] ![Add Sand][53] A sandpile model is ordered in two dimensions. Here the grid starts with a high concentration of “grains” at a central point..the SandStep function, using convolution with a kernel, simulates the redistribution of sand when a cell exceeds a critical threshold. The evolution of the sandpile is then animated interactively, with quite similar buttons for starting, adding extra sand, or resetting the grid. Additional versions show an Abelian sandpile model experientially evolving over time, complete with statistics and multiway state transitions that can be visualized as graphs. GetRowCol[s_, i_] := Module[{dim, row, col}, dim = Length[s]; row = Ceiling[i/dim]; col = i - (row - 1)*dim; {row, col}]; ReplaceHeight2D[s_, {row_, col_}, diff_] := If[row < 1 || row > Length[s] || col < 1 || col > Length[s[[row]]], s, ReplacePart[s, {row, col} -> s[[row, col]] + diff]]; ChangeGrain2D[s_List, {}] := s; ChangeGrain2D[s_List, vertexDiff_List] := Module[{vertex, row, col, diff, newList}, vertex = Keys[vertexDiff[[1]]]; {row, col} = vertex; diff = Values[vertexDiff[[1]]]; newList = ReplaceHeight2D[s, {row, col}, diff]; ChangeGrain2D[newList, Rest[vertexDiff]]]; IsStable2D[s_, zc_] := AllTrue[Flatten[s], # < zc &]; Stabilize2D[s_, zc_] := Module[{i, dim, row, col, assoc, dec}, i = FirstPosition[Flatten[s], _?(# >= zc &)][[1]]; dim = Length[s]; {row, col} = GetRowCol[s, i]; assoc = Join[{{row, col} -> -4}, If[row > 1, {{row - 1, col} -> 1}, {}], If[col > 1, {{row, col - 1} -> 1}, {}], If[row < dim, {{row + 1, col} -> 1}, {}], If[col < dim, {{row, col + 1} -> 1}, {}]]; dec = ChangeGrain2D[s, assoc]; If[IsStable2D[dec, zc], dec, Stabilize2D[dec, zc]]]; IndexPossibility2D[s_, i_, zc_] := Module[{row, col, newList}, {row, col} = GetRowCol[s, i]; newList = ChangeGrain2D[s, {{row, col} -> 1}]; If[IsStable2D[newList, zc], newList, Stabilize2D[newList, zc]]]; PossibilityGenerator2D[s_, zc_] := DeleteDuplicates[ Table[IndexPossibility2D[s, i, zc], {i, Length[Flatten[s]]}]] init = {{{0, 0}, {0, 0}}, {{0, 0}, {0, 0}}}; graph = ResourceFunction["NestGraphTagged"][ PossibilityGenerator2D[#, 2] &, init, 3, "StateLabeling" -> True, VertexShapeFunction -> (Framed[ArrayPlot[#2, Mesh -> All], FrameStyle -> LightGray] &), GraphLayout -> "LayeredDigraphEmbedding", VertexSize -> 1.5, ImageSize -> Full]; Labeled[graph, Column[{Style["Sandpile Multiway System", 16], Row[{"Vertex count: ", VertexCount[graph]}], Row[{"Edge count: ", EdgeCount[graph]}], Row[{"Average degree: ", N@Mean[VertexDegree[graph]]}]}, Alignment -> Center], Top] ![Sandpile Multiway System 1][54] I hope this answers all your questions..we could even add a 2D cellular automaton reminiscent of forest-fire models. A grid is initialized with a given density of “trees” (active cells) and an ignited cell in the center. A custom rule set governs the spread (or death) of trees based on their neighbors. After all that, an interface with clickable toggles allows the user to modify the grid and step through the evolution, providing insight into how local interactions give rise to a million, complex patterns. grid = CenterArray[0, {21, 21}]; grid[[10, 10]] = 100; colorAssociation = <|0 -> White, 1 -> RGBColor[0.9, 0.9, 1], 2 -> RGBColor[0.7, 0.7, 1], 3 -> RGBColor[0.4, 0.4, 1], 4 -> RGBColor[0.2, 0.2, 1], _ -> Blue|>; SandStep[grid_] := Module[{newgrid = grid}, Do[If[newgrid[[i, j]] >= 4, newgrid[[i, j]] -= 4; If[i > 1, newgrid[[i - 1, j]] += 1]; If[i < 21, newgrid[[i + 1, j]] += 1]; If[j > 1, newgrid[[i, j - 1]] += 1]; If[j < 21, newgrid[[i, j + 1]] += 1];], {i, 21}, {j, 21}]; newgrid]; sandpileEvolution = NestList[SandStep, grid, 45]; Animate[ArrayPlot[sandpileEvolution[[frame]], ColorRules -> colorAssociation, PlotRange -> {0, 4}, PixelConstrained -> 10, Epilog -> {Text[Style["Step: " <> ToString[frame - 1], Bold, 18], Scaled[{0.5, 0.95}]], Text[Style["2D Abelian Sandpile Model", Bold, 14], Scaled[{0.5, 0.02}]]}], {frame, 1, Length[sandpileEvolution], 1}, AnimationRepetitions -> 1, AnimationRate -> 5, DisplayAllSteps -> True] ![2 Sandpile Animation][55] This version uses a 3D grid where each cell’s “height” is updated based on its surrounding cells. The evolving 3D structure is then rendered using ListPlot3D in an animated fashion, offering a spatial perspective on the sandpile dynamics. It's one thing to just go between mechanisms and say "binary transitions" or quantum lattice growth, voxel transformations and cellular automata, or even sandpile models..but the common theme that binds us is the translation of symbolic rules into concrete spatial or graphical evolutions. SandStep[s_List, zc_Integer] := Module[{dims = Dimensions[s], new = s}, Do[If[s[[i, j]] >= zc, new[[i, j]] -= 4; Do[If[1 <= x <= dims[[1]] && 1 <= y <= dims[[2]], new[[x, y]] += 1], {x, i - 1, i + 1}, {y, j - 1, j + 1}]], {i, dims[[1]]}, {j, dims[[2]]}]; new]; GenerateStates[init_List, zc_Integer, steps_Integer] := NestWhileList[SandStep[#, zc] &, init, UnsameQ[##] &, 2, steps]; MultiwaySandpileGraph[init_List, zc_Integer, steps_Integer] := Module[{states, transitions, graphRules}, states = GenerateStates[init, zc, steps]; transitions = DirectedEdge @@@ Partition[states, 2, 1]; graphRules = {VertexShapeFunction -> ({EdgeForm[Black], Inset[ArrayPlot[#2, ColorRules -> {0 -> White, 1 -> Blue, 2 -> Yellow, 3 -> Red}, Frame -> False, AspectRatio -> Automatic, ImageSize -> {40, 40}], #1, Center, Automatic]} &), VertexSize -> 1.5, EdgeStyle -> Directive[Gray, Thickness[0.003]], GraphLayout -> "SpringElectricalEmbedding", PerformanceGoal -> "Quality"}; Graph[transitions, graphRules]]; Manipulate[ Module[{grid = CenterArray[{{initialGrains}}, {gridSize, gridSize}]}, MultiwaySandpileGraph[grid, criticalThreshold, steps]], {{gridSize, 5, "Grid Size"}, 3, 7, 1, Appearance -> "Labeled"}, {{criticalThreshold, 4, "Critical Threshold"}, 3, 6, 1, Appearance -> "Labeled"}, {{initialGrains, 100, "Initial Grains"}, 50, 500, 50, Appearance -> "Labeled"}, {{steps, 5, "Evolution Steps"}, 1, 10, 1, Appearance -> "Labeled"}, ControlPlacement -> Left, FrameLabel -> {{None, None}, {None, Style["Multiway Sandpile Evolution", Bold, 14]}}] ![Multiway Sandpile Evolution][56] ![Original 1 Multiway Sandpile Evolution][57] By moving from abstract symbolic systems to physical, often voxel-based representations, hopefully this segment embodies Niederman’s vision of concretizing tag system rules. Whether using interactive graphs, animated 2D plots, or 3D spatial arrangements, these examples provide multiple frames of reference to explore complex system dynamics interactively and visually. Stabilize2D[s_, zc_] := Module[{pos, dim, row, col, assoc, dec}, pos = FirstPosition[Flatten[s], _?(# >= zc &)]; If[pos === Missing["NotFound"], Return[s]]; pos = pos[[1]]; dim = Length[s]; {row, col} = QuotientRemainder[pos - 1, dim] + {1, 1}; assoc = Join[{{row, col} -> -zc}, If[row > 1, {{row - 1, col} -> 1}, {}], If[col > 1, {{row, col - 1} -> 1}, {}], If[row < dim, {{row + 1, col} -> 1}, {}], If[col < dim, {{row, col + 1} -> 1}, {}]]; dec = ReplacePart[s, assoc]; If[Max[Flatten[dec]] < zc, dec, Stabilize2D[dec, zc]]]; SandpileStep[s_, zc_] := Module[{i, j, newS}, {i, j} = RandomInteger[{1, Length[s]}, 2]; newS = ReplacePart[s, {i, j} -> s[[i, j]] + 1]; Stabilize2D[newS, zc]]; grid = ConstantArray[0, {21, 21}]; evolution = NestList[SandpileStep[#, 4] &, grid, 600]; ListAnimate[ ArrayPlot[#, ColorFunction -> "SunsetColors", ImageSize -> Medium] & /@ evolution, AnimationRepetitions -> Infinity] ![Sandpile Simulation 1][58] It's one thing to have an iterative stabilization procedure for a two-dimensional sandpile model..we can have a function that scans the grid `s` for any cell whose value meets or exceeds the critical threshold `zc`. Once such a cell is found, it computes its row and column indices using a quotient–remainder calculation. It then “topples” the cell by subtracting zc from it and adding 1 grain to each of its four (up/down/left/right) neighbors. The process is repeated recursively until no cell exceeds the threshold. Then in `SandpileStep[s, zc]`, a random cell is chosen, and one grain is added to it. Then, the grid is stabilized using the procedure described above. This models a single update step of the sandpile evolution. The evolution of the grid is generated by iteratively applying SandpileStep (600 iterations in the example). An animated ArrayPlot uses a color scheme (here, “SunsetColors”) to visualize the discrete snippets of time as the sandpile evolves. colorAssociation = <|0 -> White, 1 -> RGBColor[0.2, 0.6, 1], 2 -> RGBColor[0.1, 0.8, 0.3], 3 -> RGBColor[1, 0.4, 0.2], _ -> Black|>; SandStep[s_] := s + ListConvolve[{{0, 1, 0}, {1, -4, 1}, {0, 1, 0}}, UnitStep[s - 4], 2, 0]; initialGrid = CenterArray[1000, {41, 41}]; evolution = NestList[SandStep, initialGrid, 100]; ListAnimate[ ArrayPlot[#, ColorRules -> colorAssociation, Mesh -> True, MeshStyle -> Directive[Gray, Thickness[0.005]], Frame -> False, PlotRangePadding -> 0, ImageSize -> 500] & /@ evolution, AnimationRepetitions -> Infinity] ![Sandpile Evolution 3][59] A second, much understated example uses a different update rule based on convolution..in this variation, the grid is updated by adding a correction computed with a convolution kernel (which here is designed to mimic the redistribution process when a cell topples) and using UnitStep to identify where the sand exceeds the threshold (in this case, 4). The system starts with a central cell given a high value (e.g., 1000 grains) and evolves for a set number of steps (e.g., 100 iterations). The evolution is animated using ArrayPlot with a specified color association that maps different values to colors, making the toppling and propagation visually apparent. It almost looks like a breakfast item, however we don't have to use the same color scheme. It turns out that we can shift focus from a sandpile to models that simulate different types of spreading dynamics. width = 50; height = 50; density = 0.6; ignitionProb = 0.0001; growthProb = 0.01; stateColors = <|0 -> Gray, 1 -> Darker[Green], 2 -> Orange|>; currentGrid = Table[If[RandomReal[] < density, 1, 0], {height}, {width}]; currentGrid[[height/2, width/2]] = 2; EvolveGrid[grid_] := Module[{newGrid = grid}, Do[If[grid[[i, j]] == 2, newGrid[[i, j]] = 0; Do[Do[If[ 1 <= x <= height && 1 <= y <= width && grid[[x, y]] == 1, newGrid[[x, y]] = 2], {x, i - 1, i + 1}], {y, j - 1, j + 1}]], {i, height}, {j, width}]; Do[If[grid[[i, j]] == 0 && RandomReal[] < growthProb, newGrid[[i, j]] = 1]; If[grid[[i, j]] == 1 && RandomReal[] < ignitionProb, newGrid[[i, j]] = 2], {i, height}, {j, width}]; newGrid]; DynamicModule[{grid = currentGrid}, Column[{Button["Reset", grid = currentGrid], Dynamic[ArrayPlot[grid, ColorRules -> Normal[stateColors], PixelConstrained -> 10, Frame -> False, ImageSize -> 300]], Button["Next Step", grid = EvolveGrid[grid], ImageSize -> 300]}]] ![Forest Fire][60] ![Forest Fire][61] So everybody knows about sand piles. Now, when we simulate forest fires temporally, we start out with some specified tree density. One cell in the center is ignited (set to a distinct state, here indicated by the value 2). Cells with fire (value 2) are `EvolveGridded` to extinguish, and the fire spreads to any neighboring cell that has a tree (value 1). In addition, empty cells (value 0) may grow trees with a small probability, and trees (value 1) may spontaneously ignite, the definition of the stochastic nature of a forest-fire model. We could reset the grid or we could advance the simulation one step at a time. stateColors = <|0 -> White, 1 -> Black, 2 -> Red, 3 -> Blue|>; InitializeGrid[size_, density_] := Table[RandomChoice[{1 - density, density} -> {0, 1}], {size}, {size}]; ApplyCellularRules[grid_] := Module[{neighbors, newGrid, size = Length[grid]}, neighbors = ListConvolve[{{1, 1, 1}, {1, 0, 1}, {1, 1, 1}}, grid, {2, 2}, 0]; newGrid = Table[Which[ grid[[i, j]] == 1 && (neighbors[[i, j]] < 2 || neighbors[[i, j]] > 3), 3, grid[[i, j]] == 0 && neighbors[[i, j]] == 3, 2, True, grid[[i, j]] /. {2 -> 1, 3 -> 0}], {i, size}, {j, size}]; newGrid]; DynamicModule[{grid = InitializeGrid[50, 0.2], running = False, size = 50}, Panel[Column[{Grid[{{Dynamic[ ArrayPlot[grid, ColorRules -> stateColors, PixelConstrained -> 2, Background -> Yellow, Epilog -> {Text[Style["Click to toggle!", 12, Blue], Scaled[{0.5, 0.9}]], Text[Style[ ToString[Count[Flatten[grid], 1]] <> " living cells", 12, Blue], Scaled[{0.5, 0.07}]]}]]}, {Panel[ Column[{Button["Next Step", grid = ApplyCellularRules[grid], ImageSize -> {80, 30}], Button["Randomize", grid = InitializeGrid[size, 0.2], ImageSize -> {87, 30}], Button["Clear", grid = ConstantArray[0, {size, size}], ImageSize -> {80, 30}]}], "Controls", ImageSize -> {100, 120}]}}], DynamicWrapper[Graphics[{}, ImageSize -> 1], If[CurrentValue["MouseOver"], With[{pos = MousePosition["Graphics"]}, If[ListQ[pos] && ! running, With[{x = Clip[Round[size - pos[[2]]], {1, size}], y = Clip[Round[pos[[1]] + 1], {1, size}]}, If[CurrentValue["MouseClickTest"], grid[[x, y]] = 1 - grid[[x, y]];]]]]]]}, Alignment -> Center]], TrackedSymbols :> {running}, Initialization :> (If[running, grid = ApplyCellularRules[grid]; Pause[0.1]])] ![Sandpile Evolution 4][62] Stabilizing a 2-dimensional sandpile requires an iterative stabilization procedure for a two-dimensional sandpile model. There's a bit of another version where you add a scaled contribution (multiplied by 2) from a convolution kernel and use an EventHandler within a DynamicModule. In this setup, users can click on cells (using the mouse in the ArrayPlot) to add grains and then watch the system evolve automatically through a series of stabilization steps. SandStep[s_] := Module[{topple, add}, topple = UnitStep[s - 4]; add = ListConvolve[{{0, 1, 0}, {1, 0, 1}, {0, 1, 0}}, topple, 2, 0]; s - 4*topple + add]; colorAssociation = <|0 -> White, 1 -> Blue, 2 -> Cyan, 3 -> Green, 4 -> Brown, 5 -> Orange, 6 -> Red, 7 -> Magenta, 8 -> Purple|>; size = 61; initialGrid = ConstantArray[0, {size, size}]; initialGrid[[Ceiling[size/2], Ceiling[size/2]]] = 2000; steps = 1200; simulation = NestList[SandStep, initialGrid, steps]; Animate[ArrayPlot[simulation[[frame]], ColorRules -> Normal[colorAssociation], PlotRange -> {0, 8}, Frame -> False, ImageSize -> 500], {frame, 1, Length[simulation], 1}, AnimationRepetitions -> 1, RefreshRate -> 10] ![Sandpile Forward Back][63] Yet another interactive simulation revisits the sandpile model using a dynamic interface. A grid is initialized with sand (or trees, or empty spaces) and updated interactively as the user clicks on the display. There's a small lift, a segue between resetting the grid, randomizing the grid, or clearing it—all while the simulation visually updates the number of “living cells” (trees) and true state. SandStep[s_] := s + 2*ListConvolve[{{0, 1, 0}, {1, -4, 1}, {0, 1, 0}}, UnitStep[s - 4], 2, 0] DynamicModule[{grid = ConstantArray[0, {41, 41}], step = 0, colors = {GrayLevel[0.8], Blue, Orange, Red, Darker@Red}}, Column[{Row[{Button[ "Reset", (grid = ConstantArray[0, {41, 41}]; step = 0;), ImageSize -> 100], Button["Random Seed", (grid = RandomInteger[3, {41, 41}]; step = 0;), ImageSize -> 140]}], Dynamic[EventHandler[ ArrayPlot[grid, ColorFunction -> Function[x, Which[x == 0, colors[[1]], 1 <= x < 4, colors[[2]], x == 4, colors[[3]], 5 <= x < 8, colors[[4]], x >= 8, colors[[5]]]], ColorFunctionScaling -> False, PlotRangePadding -> 0, ImageSize -> 500, Epilog -> {Text[Style["Step: " <> ToString[step], Bold], Scaled[{0.1, 0.95}]]}], "MouseClicked" :> (With[{pos = MousePosition["Graphics"] /. Missing["KeyAbsent", _] :> {0.5, 0.5}}, With[{center = Round@First@ Nearest[Tuples[Range /@ Dimensions[grid]], pos*Reverse@Dimensions[grid] + 0.5, 1]}, grid[[center[[1]], center[[2]]]] += 1; grid = NestWhile[Function[g, step++; SandStep[g]], grid, UnsameQ, 2, 50];]])]]}]] ![1 Sandpile Click Animation][64] Each of these examples makes us more prepared for our sandpile models, to momentarily focus on the way local changes (adding grains and toppling) create complex, evolving patterns. Whereas the forest-fire simulations semantically chip away at probabilistic spread and regrowth, adding a stochastic element. But it's the cellular automata I've got to watch out for--these are the automata that illustrate classic neighbor-based rule evolutions that lead to newfound structures. InitializeSandpile3D[size_, initialHeight_] := CenterArray[{{{initialHeight}}}, {size, size, size}]; SandStep3D[s_] := s + ListConvolve[{{{0, 0, 0}, {0, 1, 0}, {0, 0, 0}}, {{0, 1, 0}, {1, -6, 1}, {0, 1, 0}}, {{0, 0, 0}, {0, 1, 0}, {0, 0, 0}}}, UnitStep[s - 6], 2, 0]; Module[{evolution, colorScheme}, evolution = NestList[SandStep3D, InitializeSandpile3D[15, 100], 50]; colorScheme = "SolarColors"; ListAnimate[ MapIndexed[ ListPlot3D[#1, ColorFunction -> Function[{x, y, z}, ColorData[colorScheme][z]], ColorFunctionScaling -> False, PlotRange -> All, DataRange -> {{-1, 1}, {-1, 1}}, Mesh -> True, Boxed -> False, Axes -> True, SphericalRegion -> True, ImageSize -> 600, PlotLabel -> Style["Step " <> ToString[#2[[1]]], 18, Bold]] &, evolution], AnimationRate -> 2, ControlPlacement -> Top]] For the 3D extension, the function `InitializeSandpile3D` creates a three-dimensional grid with a central “height” (or number of grains) at the middle voxel. The function SandStep3D uses a three-dimensional convolution kernel that mimics the toppling process in three dimensions. The evolution is then visualized using a series of 3D plots (via ListPlot3D), which are animated to show how the 3D sandpile evolves over a sequence of steps. Different color schemes (such as “SolarColors”) slide through various perceptions of height and depth. But it's really the iterative application of localized rules, that along with proper stabilization techniques, that yield behavior that shines through both two-dimensional and three-dimensional models and, reinforces the connection between the algorithms and their visual output. ![1 Sandpile Forward Back][65] ![Sandpile Animation][66] ![Sandpile Model ][67] ![sandpile][68] [1]: https://community.wolfram.com/groups/-/m/t/3216229 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=generation.png&userId=2553367 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=multi-way-iterative.png&userId=2553367 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=imageprogression.png&userId=2553367 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=causal-niederman.png&userId=2553367 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=topplingthreshold.png&userId=2553367 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=multiwaystatetransitiongraph.png&userId=2553367 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=rule30caplot.png&userId=2553367 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=animated_rules.gif&userId=2553367 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=multiwaystep.png&userId=2553367 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=voxelGrowth.gif&userId=2553367 [12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=abbb.png&userId=2553367 [13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=cube_animation.gif&userId=2553367 [14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=transformfromstate.png&userId=2553367 [15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Multiway3DAnimation5.gif&userId=2553367 [16]: https://community.wolfram.com//c/portal/getImageAttachment?filename=graphic4.png&userId=2553367 [17]: https://community.wolfram.com//c/portal/getImageAttachment?filename=MultiwayTagExplorerAnimation.gif&userId=2553367 [18]: https://community.wolfram.com//c/portal/getImageAttachment?filename=explorationmetrics.png&userId=2553367 [19]: https://community.wolfram.com//c/portal/getImageAttachment?filename=lsystemmusicevolution.png&userId=2553367 [20]: https://community.wolfram.com//c/portal/getImageAttachment?filename=AnimatedGraph.gif&userId=2553367 [21]: https://community.wolfram.com//c/portal/getImageAttachment?filename=DynamicWalkAnimation.gif&userId=2553367 [22]: https://community.wolfram.com//c/portal/getImageAttachment?filename=stepforward.png&userId=2553367 [23]: https://community.wolfram.com//c/portal/getImageAttachment?filename=CAEvolution.gif&userId=2553367 [24]: https://community.wolfram.com//c/portal/getImageAttachment?filename=caevolution.png&userId=2553367 [25]: https://community.wolfram.com//c/portal/getImageAttachment?filename=SandpileClickAnimation.gif&userId=2553367 [26]: https://community.wolfram.com//c/portal/getImageAttachment?filename=SandpileEvolution1.gif&userId=2553367 [27]: https://community.wolfram.com//c/portal/getImageAttachment?filename=matricescellpile.png&userId=2553367 [28]: https://community.wolfram.com//c/portal/getImageAttachment?filename=myGraphSpacer.png&userId=2553367 [29]: https://community.wolfram.com//c/portal/getImageAttachment?filename=newaspectratiocoloredcellularautomata.png&userId=2553367 [30]: https://community.wolfram.com//c/portal/getImageAttachment?filename=CASimulation.gif&userId=2553367 [31]: https://community.wolfram.com//c/portal/getImageAttachment?filename=SandpileEvolution.gif&userId=2553367 [32]: https://community.wolfram.com//c/portal/getImageAttachment?filename=bitmapstatesgraph.png&userId=2553367 [33]: https://community.wolfram.com//c/portal/getImageAttachment?filename=rotationmatrix.png&userId=2553367 [34]: https://community.wolfram.com//c/portal/getImageAttachment?filename=transformationandstate.png&userId=2553367 [35]: https://community.wolfram.com//c/portal/getImageAttachment?filename=verticesall.png&userId=2553367 [36]: https://community.wolfram.com//c/portal/getImageAttachment?filename=MultiwaySystemEvolution1.gif&userId=2553367 [37]: https://community.wolfram.com//c/portal/getImageAttachment?filename=EvolvingCA.gif&userId=2553367 [38]: https://community.wolfram.com//c/portal/getImageAttachment?filename=StateTransitions.gif&userId=2553367 [39]: https://community.wolfram.com//c/portal/getImageAttachment?filename=styledgraph.png&userId=2553367 [40]: https://community.wolfram.com//c/portal/getImageAttachment?filename=SandpileAvalanche.gif&userId=2553367 [41]: https://community.wolfram.com//c/portal/getImageAttachment?filename=statetransitiongraph3.png&userId=2553367 [42]: https://community.wolfram.com//c/portal/getImageAttachment?filename=CellularAutomatonStateTransitionGraph.png&userId=2553367 [43]: https://community.wolfram.com//c/portal/getImageAttachment?filename=rule110.png&userId=2553367 [44]: https://community.wolfram.com//c/portal/getImageAttachment?filename=allevograph.png&userId=2553367 [45]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ComplexEvolutionGenerations.gif&userId=2553367 [46]: https://community.wolfram.com//c/portal/getImageAttachment?filename=EvolutionGraphGenerations.gif&userId=2553367 [47]: https://community.wolfram.com//c/portal/getImageAttachment?filename=QuantumGrowthRotation.gif&userId=2553367 [48]: https://community.wolfram.com//c/portal/getImageAttachment?filename=MultiwayVoxelEvolution2.gif&userId=2553367 [49]: https://community.wolfram.com//c/portal/getImageAttachment?filename=QuantumMultiwayRotation.gif&userId=2553367 [50]: https://community.wolfram.com//c/portal/getImageAttachment?filename=LEGOMultiwayEvolution.gif&userId=2553367 [51]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1Multiway3DVisualization.gif&userId=2553367 [52]: https://community.wolfram.com//c/portal/getImageAttachment?filename=SandpileStartAndAdd.gif&userId=2553367 [53]: https://community.wolfram.com//c/portal/getImageAttachment?filename=addsand.png&userId=2553367 [54]: https://community.wolfram.com//c/portal/getImageAttachment?filename=sandpilemultiwaysystem1.png&userId=2553367 [55]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2SandpileAnimation.gif&userId=2553367 [56]: https://community.wolfram.com//c/portal/getImageAttachment?filename=multiwaysandpileevolution.png&userId=2553367 [57]: https://community.wolfram.com//c/portal/getImageAttachment?filename=multiwaysandpileversionoriginal1.png&userId=2553367 [58]: https://community.wolfram.com//c/portal/getImageAttachment?filename=SandpileSimulation1.gif&userId=2553367 [59]: https://community.wolfram.com//c/portal/getImageAttachment?filename=SandpileEvolution3.gif&userId=2553367 [60]: https://community.wolfram.com//c/portal/getImageAttachment?filename=forestfire.png&userId=2553367 [61]: https://community.wolfram.com//c/portal/getImageAttachment?filename=forestfire.gif&userId=2553367 [62]: https://community.wolfram.com//c/portal/getImageAttachment?filename=SandpileEvolution4.gif&userId=2553367 [63]: https://community.wolfram.com//c/portal/getImageAttachment?filename=sandpile_forwardback.gif&userId=2553367 [64]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1SandpileClickSimulation.gif&userId=2553367 [65]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1Sandpile3D_ForwardBack.gif&userId=2553367 [66]: https://community.wolfram.com//c/portal/getImageAttachment?filename=sandpile_animation.gif&userId=2553367 [67]: https://community.wolfram.com//c/portal/getImageAttachment?filename=sandpile_model2.gif&userId=2553367 [68]: https://community.wolfram.com//c/portal/getImageAttachment?filename=sandpile.gif&userId=2553367 Dean Gladish 2025-04-15T18:50:51Z https://community.wolfram.com/groups/-/m/t/3391505 ![astronomy][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=astro.jpeg&userId=911151 [2]: https://www.wolframcloud.com/obj/4298384a-c34d-4a4a-be94-d6709810756a Wolfram Education Programs 2025-02-10T21:14:52Z https://community.wolfram.com/groups/-/m/t/3367474 Hello, My goal is to define a multi-layer graph structure with some basics operations such as (Vertex/EdgeList, AdjacencyList, Edge/VertesCount, MultiGraphPlot...) in Mathematica/WolframLanguage. A multi-layer graph (or multiplex graph) G(X, E1, E2, ..., EN) is defined by a single set of vertices X and multiple sets of edges (directed or not) E1, E2, ... EN. Various representations may be used to represent such graphs: ![Multiplex grpah representaiton: On the left a representation using layers and on the right a projected view of the graph.][1] *On the left a representation using layers and on the right a projected view of the graph.* I have done few attempts I want to share with the community in the case I missed something or I get usefull advices. To run the tests lets define a to toy dataset: individuals = { 1, 2, 3}; friendWith = { 1 \[UndirectedEdge] 2}; workWith = { 1 \[UndirectedEdge] 2}; **First attempt : Staying as closed as possible from the Graph function/primitive of the language:** First observation: **Graph[...]** supports multi-edges so we can have a graph with multiple edges linking two vertices if these two vertices are linked in multiple layers. g = Graph[ individuals, Join[ friendWith, workWith ], VertexLabels -> "Name" ] ![enter image description here][2] At this point we want to differenciate the edges according to the layer they are part of. Mathematica allows edge labeling: g = Graph[ individuals, Join[ Map[ Labeled[#, "friendWith"] &, friendWith], Map[ Labeled[#, "workWith"] &, workWith] ], VertexLabels -> "Name" ] ![enter image description here][3] Unfortunately only the last labeling is stored. Mathematica seems to maintain a unique general list of the egde labels making impossible to differenciate them this way. This option seems to be a dead way. **Second attempt : Defining a meta structure** An tedious alternative is to introduce a custom data structure like: MutliGraph::usage="MutliGraph[ g1_Graph, g2_Graph, ..., gN_Graph] represents a multilayer graph"; And recoding the basics services we need: EdgeLists[ graphs_MultiGraph ] := Map[ EdgeList, List @@ graphs ] ; MultiGraph /: EdgeList[ graphs_MultiGraph ] := Join @@ EdgeLists[ graphs ] ; VertexLists[ graphs_MultiGraph ] := Map[ VertexList, List @@ graphs ] MultiGraph /: VertexList[ graphs_MultiGraph ] := Union @@ VertexLists[ graphs ] ; AdjacencyLists[ graphs_MultiGraph ] := Map[ AdjacencyList, List @@ graphs ] ; MultiGraph /: AdjacencyList[ graphs_MultiGraph ] := AdjacencyList @ Graph[ VertexList[ graphs ] , EdgeList[ graphs ] ] ; EdgeCounts[ graphs_MultiGraph ] := Map[ EdgeCount, List @@ graphs ] ; MultiGraph /: EdgeCount[ graphs_MultiGraph ] := Total @ EdgeCounts @ graphs ; MultiGraph /: Subgraph[ graphs_MultiGraph, selection_ ] := Apply[ MultiGraph, Map[ Subgraph[ #, selection ] &, List @@ graphs ] ] ; This second option do the job but is way less flexible. I thank everyone reading this and I would be gratefull for any advice. Regards, Guillaume [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=multiplex_graph.png&userId=3363970 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=multiedge_graph.png&userId=3363970 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=multilabelededge_graph.png&userId=3363970 Guillaume Santini 2025-01-30T15:35:25Z https://community.wolfram.com/groups/-/m/t/3356963 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4427hero.png&userId=20103 [2]: https://www.wolframcloud.com/obj/eab26829-fd68-498c-842d-7e7f6ba89497 William H 2025-01-15T05:37:57Z