Random Walks, random pebble drops, fractals, and other stuff...

Libraries

AppendTo[$Path, "C:\\windows\\desktop"];

AppendTo[$Path, "E:\\lib"];

AppendTo[$Path, Environment["HOME"] <> "/lib"];

Get["Util.m"]

Constants

webDir = "E:\\www\\misc\\fractals\\";

webDir = "C:\\windows\\desktop\\";

webDir = "./";

maxX = 1000;
maxY = 1000;

n = 3;

corners = nGonPoints[n]

corners = {Round[{maxX/2, maxY/2}]}~Join~corners

corners = {{1, 1}, {maxX, 1}, {1, maxY}, {maxX, maxY}, 
        Floor[1/2*{maxX, maxY}]}

corners = 
      Table[{Random[Integer, {1, maxX}], 
          Random[Integer, {1, maxY}]}, {6}]

corners = {{1, 1}, Round[{maxX/2, 1}], {maxX, 1}, 
        Round[{maxX/2, maxY}]}

updateGrid = fractal;

fractalInit[];

Functions

middleInit[] := (
{x, 
            y} = {Quotient[maxX, 2], 
            Quotient[maxY, 2]}; 
grid = 
          Table[0, {maxX}, {maxY}];)

randomInit[] := (
{x, 
            y} = {Random[Integer, {1, maxX}], 
            Random[Integer, {1, maxY}]}; 
grid = 
          Table[0, {maxX}, {maxY}];)

heightCost[{x_, y_}] := 
      If[! (1 ≤ x ≤ maxX && 
              1 ≤ y ≤ maxY), Infinity, 
        grid[[x, y]]]

inBoundsCost[{x_, 
          y_}] := If[! (1 ≤ x ≤ maxX && 
              1 ≤ y ≤ maxY), 1, 0]

neighbors[{x_, y_}] := {{x + 1, y}, {x, y + 1}, {x - 1, y}, {x, 
          y - 1}, {x + 1, y + 1}, {x + 1, y - 1}, {x - 1, y + 1}, {x - 1, 
          y - 1}}

stableQ[{x_, y_}] := 
      heightCost[{x, y}] ≤ 
        Min[heightCost /@ neighbors[{x, y}]]

pickOne[l_List] := l[[Random[Integer, {1, Length[l]}]]]

pickN[n_, l_List] := Take[shuffle[l], n]

ringList[{x_, y_}] := {{x + 2, y - 2}, {x + 2, y - 1}, {x + 2, 
          y}, {x + 2, y + 1}, {x + 2, y + 2}, {x - 2, y - 2}, {x - 2, 
          y - 1}, {x - 2, y}, {x - 2, y + 1}, {x - 2, y + 2}, {x, y - 2}, {x, 
          y + 2}, {x + 1, y - 2}, {x + 1, y + 2}, {x - 1, y - 2}, {x - 1, 
          y + 2}}

incrementEach[l_] := grid[[Sequence @@ #]]++ & /@ 
        l

scaleToGrid[{x_, y_}] := {Max[1, Min[maxX, Round[maxX/2 (x + 1)]]], 
        Max[1, Min[maxY, Round[maxY/2 (y + 1)]]]}

nGonPoints[n_, startAngle_:  0] := 
      Module[{i, angles, unscaled}, 
angles = 
          Drop[Table[
              i, {i, startAngle, startAngle + 2  Pi, 
                2  Pi/n}], -1]; 
unscaled = {Cos[#], 
                Sin[#]} & /@ angles; 
scaleToGrid /@ 
          unscaled]

dropPebbles[] := (
{x, y} = 
          Floor[pickOne[{{1/3*maxX, 1/3*maxY}, {1/3*maxX, 
                  2/3*maxY}, {2/3*maxX, 
                  1/2*maxY}}]]; 
While[! stableQ[{x, 
                y}], {x, y} = 
            argMin[heightCost, 
              shuffle[neighbors[{x, y}]]]]; 
grid[[x, 
              y]]++)

selfAvoidingPath[] := (
{x, y} = 
          argMin[heightCost, 
            shuffle[neighbors[{x, y}]]]; 
grid[[x, 
              y]]++)

fractal[] := (
{x, y} = 
          Floor[({x, y} + pickOne[corners])/
              2]; 
grid[[x, y]]++)

fractalInit[] := (
{x, y} = 
          pickOne[corners]; 
grid = 
          Table[0, {maxX}, {maxY}];)

rachelRings[] := (
{x, y} = 
          argMax[If[heightCost[#] == 0, -Infinity, -heightCost[#]] &, 
            shuffle[Flatten[
                Table[{i, j}, {i, 1 + 2, maxX - 2}, {j, 1 + 2, maxY - 2}], 
                1]]]; 
incrementEach[
          ringList[{x, y}]])

bowling[] := {  }

caption[] := 
      StringJoin @@ ToString /@ {
maxX,  "x", 
            maxY, " ", 
" i=", 
            Plus @@ Flatten[grid], 
  
  
" maxHt=", 
            Max[Flatten[grid]], 
" avgHt=", 
            N[(Plus @@ Flatten[grid])/
                Length[Flatten[
                    grid]]]}

graph[] := 
      ListDensityPlot[grid, Background -> Hue[0, 0, 0], 
        Mesh -> False, FrameLabel -> {caption[], ""}, 
        Frame -> True, FrameTicks -> False, Axes -> False, 
        ColorFunction -> (If[# ≤ 0, Hue[0, 0, 0], 
                Hue[- .83*# +  .67]] &)]

graph3D[] := ListPlot3D[grid]

Run it...

interruptedWhile[abort, graph[], True, updateGrid[]]

Export[webDir <> "fractal" <> ToString[n] <> "-test.jpg", 
      graph[], "JPEG", ImageResolution -> 400]

Scratch

CheckAbort[
      While[True, AbortProtect[updateGrid[]]], graph[];]

Histogram[Count[Flatten[grid], #] & /@ 
          Range[Min[Flatten[grid]], Max[Flatten[grid]]], 
        FrequencyData -> True];