Programming Sampler

Examples of small programs written in the Mathematica language.

Difference Tables

\(DifferenceTable[list_, \ n_]\  := 
\ \ \ \ \ \ \ \ \ \ \ 
      NestList[Drop[#, \ 1]\  - \ Drop[#, \ \(-1\)]\ &, list, \ n]\)

DifferenceTable[Table[(i^2)  +  i  +  1,  {i,  8}], 3]

Gray Code

GrayCode[m_] := Nest[Join[#, Length[#] + Reverse[#]]&, {0}, m]

ListPlot[GrayCode[8]]

Mandelbrot and Julia Sets

\(\(MandelbrotFunction = 
      Compile[{{c, _Complex}}, 
        \(-Length[
            FixedPointList[#\^2 + c\ &, c, 50, 
              SameTest -> \((Abs[#2] > 2.0\ &)\)]]\)]; \)\)

DensityPlot[
      MandelbrotFunction[x + y I], {x, -2, 0.5}, {y, -1, 1}, 
      Mesh -> False, AspectRatio -> Automatic, Frame -> False, 
      PlotPoints -> 125];

\(\(JuliaFunction = 
      Compile[{{c, _Complex}, {k, _Complex}}, 
        \(-Length[
            FixedPointList[#\^2 + k\ &, c, 35, 
              SameTest -> \((Abs[#2] > 2.0\ &)\)]]\)]; \)\)

Show[
      GraphicsArray[
        Table[DensityPlot[
            JuliaFunction[x + I y, a + b I], {x, -1.1, 1.1}, {y, 
              -1.1, 1.1}, Mesh -> False, Frame -> False, 
            Axes -> False, PlotPoints -> 35, AspectRatio -> 1, 
            DisplayFunction -> Identity], {b, -1.0, 1.0, 0.333}, {a, 
            -2.0, 1.0, 0.333}]]];

Moving Averages

MovingAverage[data_List, n_Integer?Positive] := 
      Drop[Plus@@NestList[RotateRight, data, n - 1], n - 1]/n

MovingAverage[ {1., 2., 3., 4., 5., 6.}, 2]

MovingAverage[ {a, b, c, d, e, f, g}, 5]

Game of Life

LifeStepArray[a_List] := 
      MapThread[If[#1 == 1 && #2 == 4 || #2 == 3, 1, 0] &, 
        {a, (∑_(i = -1)^1)(∑_(j = -1)^1) RotateLeft[
                a, {i, j}]}, 2]

𝒩 = Flatten[Array[List, {3, 3}, -1], 1];

LifeStep[pos_] := 
      With[{u = 
            Split[Sort[Flatten[Outer[Plus, pos, 𝒩, 1], 1]]]}, 
        Cases[u, {x_, _, _} -> x] ⋃ 
          Cases[u, {x_, _, _, _} -> x] ⋂ pos]

ggun
       = {{1, -13}, {2, -12}, {2, -13}, {3, -12}, {3, 
          -14}, {4, -23}, {5, -22}, {5, -24}, {6, -11}, {
          6, -20}, {6, -21}, {6, -25}, {6, -35}, {6, 
          -36}, {7, -11}, {7, -12}, {7, -13}, {7, -14}, {
          7, -20}, {7, -21}, {7, -25}, {7, -35}, {7, 
          -36}, {8, -1}, {8, -2}, {8, -12}, {8, -13}, {8, 
          -14}, {8, -15}, {8, -20}, {8, -21}, {8, -25}, {
          9, -1}, {9, -2}, {9, -12}, {9, -15}, {9, -22}, {
          9, -24}, {10, -6}, {10, -12}, {10, -13}, {10, 
          -14}, {10, -15}, {10, -23}, {11, -6}, {11, 
          -11}, {11, -12}, {11, -13}, {11, -14}, {12, 
          -11}};

MapIndexed[Cuboid[Flatten[{#1,  First[#2]}]]&, 
      NestList[LifeStep, ggun, 10],  {2}];

Show[Graphics3D[%]];

Mellin Transforms

Mellin[f_ + g_, s_, t_] := Mellin[f, s, t] + Mellin[g, s, t]

Mellin[c_ f_, s_, t_] := c Mellin[f, s, t] /; FreeQ[c, t]

\(Mellin[Log[t_]\^k_\ f_, s_, t_] := 
      ∂\_{s, k}Mellin[f, s, t] /; IntegerQ[k] && Positive[k]\)

Mellin[\(t_\^k_.\) ((f_)^((k_)))[t_],s_,t_]:=\(\((\(-1\))\)\^k\ Pochhammer[s - k, k]\ Mellin[f, s, t] /;          IntegerQ[k] && Positive[k]\)

\(Mellin[t_\^z_\ f_, s_, t_] := Mellin[f, s + z, t]\)

Mellin[((f_)^((k_)))[t_],s_,t_]:=\(\((\(-1\))\)\^k\ Pochhammer[s - k, k]\ Mellin[f, s - k, t] /;          IntegerQ[k] && Positive[k]\)

Mellin[Exp[a_ t_] f_, s_, t_] := 
      Gamma[s]/(((-a))^s) /; Re[a] < 0

Mellin[
        a (t^2) F''[t]  + b t  F'[t] + c Exp[-t] F[t], 
        s, t]  //  Simplify

Integration over a Triangle

TriangleIntegrate[a_ + b_, {x_, y_}] := 
      TriangleIntegrate[a, {x, y}] + TriangleIntegrate[b, {x, y}]

TriangleIntegrate[c_ z_, {x_, y_}] := 
      c TriangleIntegrate[z, {x, y}] /; FreeQ[c, x | y]

TriangleIntegrate[(((x_ | y_))^p)_., {x_, y_}] := 
      ((p!)/((p + 2)!))

\(TriangleIntegrate[x_\^p_.\ y_\^q_., {x_, y_}] := 
      \(\(p!\)\ \(q!\)\)\/\(\((p + q + 2)\)!\)\)

TriangleIntegrate[c_, {x_, y_}] := (c/2) /; FreeQ[c, x | y]

TriangleIntegrate[(x^5) (x^2) + a x y + 5, {x, y}]

Weights for Finite Differences

(Subscript[c, 0, 0, 0])[𝓅_] := 1

(Subscript[c, k_?NonNegative, i_, j_])[𝓅_] := 0 /; i < k

(Subscript[c, k_?Negative, i_, j_])[𝓅_] := 0

\(c\_\(k_?NonNegative, i_, i_\)[𝓅_] := 
	
      \(ω\_\(i - 2\)[𝓅\_i, 𝓅]\/ω\_\(i - 1\)[
                𝓅\_\(i + 1\), 𝓅]\)\((
            k\ c\_\(k - 1, i - 1, i - 1\)[𝓅] - 
              \(𝓅\_i\)c\_\(k, i - 1, i - 1\)[𝓅])\) /; 
        i ≥ k\)

\(c\_\(k_?NonNegative, i_, j_\)[𝓅_] := 
	
      \(𝓅\_\(i + 1\)\ c\_\(k, i - 1, j\)[𝓅] - 
            k\ c\_\(k - 1, i - 1, j\)[𝓅]\)\/\(𝓅\_\(i + 1
                \) - 𝓅\_\(j + 1\)\) /; 
        i ≥ k && j ≤ i\)

(Subscript[ω, i])_[y_, 𝓅_] := 
      (∏_(j = 1)^(i + 1))(y - (Subscript[𝓅, j])) ; 
    (Subscript[((𝓅_List)), i])_ := 
      𝓅[[i]]

Table[(Subscript[c, 2, 9 - 1, j])[Range[ -4,  4]], {j, 0, 9 - 1}]