mathematica迭代与分形

分形是无限嵌套层次的精细结构,在不同尺度下具有某种相似性。

——赵永成


分形图像欣赏:

这里写图片描述
这里写图片描述
这里写图片描述
这里写图片描述
这里写图片描述
这里写图片描述
这里写图片描述
这里写图片描述
这里写图片描述
这里写图片描述
这里写图片描述

分形的特性

  • 具有无限精细的结构
  • 局部与整体的相似性
  • 具有非拓扑维数,并且它大于对应的拓扑维数
  • 具有随机性
  • 在大多数情况下,分形可以用非常
    简单的方法确定,可能由迭代产生。
   (* hilbert曲线*)
Udrawing[{p_, a_, dr_}] := 
 Module[{sw, nw, ne, se}, sw = {p[[1]] - a/2, p[[2]] - a/2};
  nw = {p[[1]] - a/2, p[[2]] + a/2};
  ne = {p[[1]] + a/2, p[[2]] + a/2}; se = {p[[1]] + a/2, p[[2]] - a/2};
  uline = 
   Which[dr == 0, {sw, nw, ne, se}, dr == 1, {nw, ne, se, sw}, 
    dr == 2, {ne, se, sw, nw}, dr == 3, {se, sw, nw, ne}];
  uline]


Hilbert[element_] := 
 Block[{o, a, dr, p = {Null, Null, Null, Null}, sona, sondr, us = {}},
   For[i = 1, i <= Length[element], i++, o = element[[i, 1]];
   a = element[[i, 2]]; dr = element[[i, 3]];
   p[[1]] = o + {-a/2, -a/2}; p[[2]] = o + {-a/2, a/2};
   p[[3]] = o + {a/2, a/2}; p[[4]] = o + {a/2, -a/2}; sona = a/2;
   sondr = 
    Which[dr == 0, {1, 0, 0, 3}, dr == 1, {0, 2, 1, 1}, 
     dr == 2, {2, 1, 3, 2}, dr == 3, {3, 3, 2, 0}];
   son = Table[{p[[i]], sona, sondr[[i]]}, {i, 1, 4}];
   AppendTo[us, son];]; us = Flatten[us, 1]; us]


n = 2;
son = Nest[Hilbert, {{{0, 0}, 1, 0}}, n];
 pics = {};
For[i = 1, i <= 4^n, i++, temp = Graphics[Line[Udrawing[son[[i]]]]]; 
  AppendTo[pics, temp]];
Show[pics]




Hi[n_] := 
  Block[{}, d = {{1/4, 1/4}, {1/4, 3/4}, {3/4, 3/4}, {3/4, 1/4}};
   For[i = 1, i < n, i++, d = 1/2*d;
    k = Length[d];
    lu = Table[d[[j]] + {0, 1/2}, {j, 1, k}];
    ru = Table[d[[j]] + {1/2, 1/2}, {j, 1, k}];
    ld = d.{{0, -1}, {1, 0}};
    ld = Reverse[ld];
    ld = Table[ld[[j]] + {0, 1/2}, {j, 1, k}];
    rd = d.{{0, 1}, {-1, 0}};
    rd = Reverse[rd];
    rd = Table[rd[[j]] + {1, 0}, {j, 1, k}];
    d = {};
    AppendTo[d, ld];
    AppendTo[d, lu];
    AppendTo[d, ru];
    AppendTo[d, rd];
    d = Flatten[d, 1];];
   b = Line[d];
   Graphics[b]];
Hi[7]

hilbert曲线

Julia集和Mandelbrot集

JM[reZ0_,imZ0_,remu_,immu_,n_,M_]:=Block[
{s=0,z,mu},
z=reZ0+imZ0*I;
mu=remu+immu*I;
While[Abs[z]<=M&&s<=n-1,z=z^2+mu;s++];
s]

(*Julia = Table[{JM[x, y, -1.25, -0.01, 50, 2]}, {x, -1, 1, 
   0.01}, {y, -1, 1, 0.01}]*)


DensityPlot[JM[x, y, -1.25`, -0.01`, 50, 2], {x, -1, 1}, {y, -1, 1}]
DensityPlot[JM[-1.25, -0.01,x,y,50, 2],{x,-1,1},{y,-1,1}]
IFS迭代系统
IFS[A_, B_, C0_, pA_, pB_, pC_, z0_, n_] := 
 Block[{ifs = {z0}, temp, z1 = z0}, 
  For[i = 1, i <= n, i++, temp = RandomReal[]; 
   z1 = Which[temp < pA, (A + z1)/2, temp < pA + pB, (B + z1)/2, 
     temp <= 1, (C0 + z1)/2]; AppendTo[ifs, z1]];
  ifs] 
ifs = IFS[{1, 1}, {-1, 2}, {0, 3}, 0.5, 0.2, 0.3, {0, 0}, 1000];
ListPlot[ifs]
aff[P_] := Block[
  {l = Length[P], newp = {}, S = {
     {{1, 0, 0}, {2/3, 1/3, 0}, {2/3, 0, 1/3}}, {{2/3, 0, 1/3}, {2/3, 
       1/3, 0}, {1/3, 1/3, 1/3}}, {{1/3, 1/3, 1/3}, {0, 1/3, 
       2/3}, {1/3, 0, 2/3}}, {{1/3, 0, 2/3}, {0, 1/3, 2/3}, {0, 0, 
       1}}}}, For[i = 1, i <= l, i++, temp = S.P[[i]]; 
   AppendTo[newp, temp]] ; Flatten[newp, 1]]
p = {{{-1, 0}, {0, 1}, {1, 0}}};
t = Nest[aff, p, 6]
Graphics[Polygon /@ t]

coch曲线

网格细分的方法和思路
tetraM = Flatten[
  Table[{x, y, z}, {x, {-1, 1}}, {y, {-1, 1}}, {z, {-1, 1}}], 2]
tetraP = {{1, 2, 4, 3}, {3, 4, 8, 7}, {5, 6, 8, 7}, {1, 2, 6, 5}, {2, 
   4, 8, 6}, {1, 3, 7, 5}}
displaymesh[M_, P_] := 
  Block[{i}, 
   Graphics3D[Polygon[Table[M[[P[[i]]]], {i, 1, Length[P]}]]]];
refine[S_] := 
 Block[{newP = {}, i, lengthP = 4}, 
  For[i = 1, i <= 4, i++, 
   AppendTo[newP, (S[[i]] + S[[Mod[i, 4] + 1]])/2]];
  AppendTo[newP, Sum[S[[i]]/4, {i, 1, lengthP}]];
  Q = Join[S, newP];
  T = {{1, 5, 9, 8}, {5, 2, 6, 9}, {6, 3, 7, 9}, {4, 7, 9, 8}};
  Table[Q[[T[[i]]]], {i, 1, Length[T]}]]

S = {{-1, -1, -1}, {-1, -1, 1}, {-1, 1, 1}, {-1, 1, -1}}
Graphics3D[Polygon[refine[S]]]
各图形光滑细分格式汇总
(*koch曲线*)
s = {( {
     {1, 0, 0},
     {2/3, 1/3, 0},
     {2/3, 0, 1/3}
    } ), ( {
     {2/3, 0, 1/3},
     {2/3, 1/3, 0},
     {1/3, 1/3, 1/3}
    } ), ( {
     {1/3, 1/3, 1/3},
     {0, 1/3, 2/3},
     {1/3, 0, 2/3}
    } ), ( {
     {1/3, 0, 2/3},
     {0, 1/3, 2/3},
     {0, 0, 1}
    } )};
t = {( {
     {0, 0},
     {1, 2},
     {2, 0}
    } )};
aff[t_] := Flatten[Table[s.t[[i]], {i, 1, Length[t]}], 1];
aggPlot[t_] := 
  Show[Graphics[Polygon /@ t], AspectRatio -> Automatic, 
   PlotRange -> All];
iteraff[t_, k_] := Nest[aff, t, k];
aggPlot[iteraff[t, 5]]
Null

(*B样条曲线*)
p = t;
s = 1/4*{( {
      {3, 1, 0},
      {1, 3, 0},
      {0, 3, 1}
     } ), ( {
      {1, 3, 0},
      {0, 3, 1},
      {0, 1, 3}
     } )};

aff[s_, t_] := Flatten[Table[s.t[[i]], {i, 1, Length[t]}], 1];
aggPlot[t_] := 
  Show[Graphics[Polygon /@ t], AspectRatio -> Automatic, 
   PlotRange -> All];
iteraff[s_, t_, k_] := Nest[aff, t, k];

Show[Graphics[{GrayLevel[0.6], Polygon[Flatten[p, 1]]}], 
 Graphics[Point /@ Flatten[iteraff[s, p, 3], 1]], 
 Graphics[Line /@ iteraff[s, p, 4]]]

Null

 (*space mesh*)
displayMesh[{T_, G_}] := 
  Show[Graphics3D[Polygon /@ Table[G[[T[[i]]]], {i, 1, Length[T]}]], 
   Boxed -> False, ViewPoint -> {1.3`, -2.4`, 2.`}];

(*tetra={(1 3 2 1 2 4 1 4 3 2 3 4),(0 0 0 1 0 0 0 1 0 0 0 1)};
cube={(1 4 3 2 1 2 6 5 2 3 7 6 3 4 8 7 4 1 5 8 5 6 7 8),(0 0 0 1 0 0 \
1 1 0 0 1 0 0 0 1 1 0 1 1 1 1 0 1 1)};

displayMesh[tetra]*)
cube = {( {
     {1, 4, 3, 2},
     {1, 2, 6, 5},
     {2, 3, 7, 6},
     {3, 4, 8, 7},
     {4, 1, 5, 8},
     {5, 6, 7, 8}
    } ), ( {
     {0, 0, 0},
     {1, 0, 0},
     {1, 1, 0},
     {0, 1, 0},
     {0, 0, 1},
     {1, 0, 1},
     {1, 1, 1},
     {0, 1, 1}
    } )};
displayMesh[cube]
doughnut = {( {
     {1, 2, 6, 5},
     {2, 3, 7, 6},
     {3, 4, 8, 7},
     {4, 1, 5, 8},
     {9, 10, 14, 13},
     {10, 11, 15, 14},
     {11, 12, 16, 15},
     {12, 9, 13, 16},
     {1, 9, 10, 2},
     {2, 10, 11, 3},
     {3, 11, 12, 4},
     {4, 12, 9, 1},
     {5, 6, 14, 13},
     {6, 7, 15, 14},
     {7, 8, 16, 15},
     {8, 5, 13, 16}
    } ), ( {
     {1, 1, 1},
     {1, -1, 1},
     {-1, -1, 1},
     {-1, 1, 1},
     {3, 3, 1},
     {3, -3, 1},
     {-3, -3, 1},
     {-3, 3, 1},
     {1, 1, -1},
     {1, -1, -1},
     {-1, -1, -1},
     {-1, 1, -1},
     {3, 3, -1},
     {3, -3, -1},
     {-3, -3, -1},
     {-3, 3, -1}
    } )};
displayMesh[doughnut]
Null

 (*四边细分格式*)
M1 = ( {
    {1, 1, 1, 1},
    {1, 1, 1, 1},
    {1, 1, 1, 1},
    {1, 1, 1, 1}
   } );
M2 = 1/4*( {
     {4, 0, 0, 0},
     {0, 4, 0, 0},
     {0, 0, 4, 0},
     {0, 0, 0, 4},
     {2, 2, 0, 0},
     {0, 2, 2, 0},
     {0, 0, 2, 2},
     {2, 0, 0, 2},
     {1, 1, 1, 1}
    } );
quadAverage[{T_, p_}] := 
 Block[{newp = 0*p, val = Table[0, {Length[p]}]}, 
  Do[++val[[T[[l, i]]]], {l, Length[T]}, {i, Length[T[[l]]]}];
  Do[newp[[T[[i]]]] += M1.p[[T[[i]]]]/(4*val[[T[[i]]]]), {i, 
    Length[T]}];
  {T, newp}]

quadSub[{T_, p_}] := 
 Block[{idx, index, currIndex = Length[p], newT, newp}, 
  SetAttributes[idx, Orderless];
  idx[_, _] = 0;
  index[i_, j_] := 
   If[idx[i, j] == 0, idx[i, j] = ++currIndex, idx[i, j]];
  newp = Table[0, {2 Length[T] + 2 Length[p] + 10}];
  newT = {};
  Do[i00 = T[[i, 1]]; i20 = T[[i, 2]]; i22 = T[[i, 3]]; 
   i02 = T[[i, 4]];
   i01 = index[i00, i02]; i12 = index[i02, i22]; 
   i10 = index[i00, i20]; i21 = index[i20, i22];
   i11 = ++currIndex;
   newp[[{i00, i20, i22, i02, i10, i21, i12, i01, i11}]] = 
    M2.p[[T[[i]]]];
   newT = 
    Join[newT, {{i02, i01, i11, i12}, {i20, i21, i11, i10}, {i00, i10,
        i11, i01}, {i22, i12, i11, i21}}], {i, 1, Length[T]}]; {newT, 
   Take[newp, currIndex]}]


quadSub[cube]

displayMesh[Nest[quadSub, cube, 2]]
quadSub[doughnut]
quadAverage[doughnut]
displayMesh[quadAverage[Nest[quadSub, doughnut, 4]]]

displayMesh[
 Nest[Function[x, quadAverage[quadSub[x]]], doughnut, 4]]

(*三角细分格式*)

displayMesh[{T_, G_}] := 
  Show[Graphics3D[Polygon /@ Table[G[[T[[i]]]], {i, 1, Length[T]}]], 
   Boxed -> False, ViewPoint -> {1.3, -2.4, 2}];

tetra = {( {
     {1, 3, 2},
     {1, 2, 4},
     {1, 4, 3},
     {2, 3, 4}
    } ), ( {
     {0, 0, 0},
     {0, 1, 0},
     {Sqrt[3]/2, 1/2, 0},
     {Sqrt[3]/6, 1/2, Sqrt[6]/3}
    } )};
N1 = ( {
    {2, 3, 3},
    {3, 2, 3},
    {3, 3, 2}
   } );(*N1=(1  1   1
1   1   1
1   1   1

);*)
N2 = 1/2*( {
     {2, 0, 0},
     {0, 2, 0},
     {0, 0, 2},
     {1, 1, 0},
     {0, 1, 1},
     {1, 0, 1}
    } );

triAverage[{T_, p_}] := 
 Block[{newp = 0*p, val = Table[0, {Length[p]}]}, 
  Do[++val[[T[[l, i]]]], {l, Length[T]}, {i, Length[T[[l]]]}];
  Do[newp[[T[[i]]]] += N1.p[[T[[i]]]]/(8*val[[T[[i]]]]), {i, 
    Length[T]}];
  {T, newp}]

triSub[{T_, p_}] := 
 Block[{idx, index, currIndex = Length[p], newT, newp}, 
  SetAttributes[idx, Orderless];
  idx[_, _] = 0;
  index[i_, j_] := 
   If[idx[i, j] == 0, idx[i, j] = ++currIndex, idx[i, j]];
  newp = Table[0, {2 Length[T] + 2 Length[p] + 10}];
  newT = {};
  Do[i0 = T[[i, 1]]; i1 = T[[i, 2]]; i2 = T[[i, 3]];
   i01 = index[i0, i1]; i12 = index[i1, i2]; i02 = index[i0, i2];
   newp[[{i0, i1, i2, i01, i12, i02}]] = N2.p[[T[[i]]]];
   newT = 
    Join[newT, {{i0, i01, i02}, {i01, i1, i12}, {i02, i12, i2}}], {i, 
    1, Length[T]}]; {newT, Take[newp, currIndex]}]

displayMesh[tetra]
displayMesh[Nest[triSub, tetra, 3]]
displayMesh[Nest[Function[x, triAverage[triSub[x]]], tetra, 4]]



octa = {( {
     {1, 2, 5},
     {2, 3, 5},
     {3, 4, 5},
     {4, 1, 5},
     {2, 1, 6},
     {3, 2, 6},
     {4, 3, 6},
     {1, 4, 6}
    } ), ( {
     {1, 0, 0},
     {0, 1, 0},
     {-1, 0, 0},
     {0, -1, 0},
     {0, 0, 1},
     {0, 0, -1}
    } )};

displayMesh[octa]
displayMesh[Nest[triSub, octa, 3]]
displayMesh[Nest[Function[x, triAverage[triSub[x]]], octa, 4]]

stellatedocta = {( {
     {1, 2, 7},
     {2, 5, 7},
     {5, 1, 7},
     {2, 3, 8},
     {3, 5, 8},
     {5, 2, 8},
     {3, 4, 9},
     {4, 5, 9},
     {5, 3, 9},
     {4, 1, 10},
     {1, 5, 10},
     {2, 6, 12},
     {6, 3, 12},
     {4, 3, 13},
     {3, 6, 13},
     {6, 4, 13},
     {5, 4, 10},
     {2, 1, 11},
     {1, 6, 11},
     {6, 2, 11},
     {3, 2, 12},
     {1, 4, 14},
     {4, 6, 14},
     {6, 4, 14}
    } ), ( {
     {1, 0, 0},
     {0, 1, 0},
     {-1, 0, 0},
     {0, -1, 0},
     {0, 0, 1},
     {0, 0, -1},
     {1, 1, 1},
     {-1, 1, 1},
     {-1, -1, 1},
     {1, -1, 1},
     {1, 1, -1},
     {-1, 1, -1},
     {-1, -1, -1},
     {1, -1, -1}
    } )};
displayMesh[stellatedocta]
displayMesh[Nest[triSub, stellatedocta, 3]]
displayMesh[Nest[Function[x, triAverage[triSub[x]]], stellatedocta, 3]]
Null

B样条
回字体
三角迭代
正方体
正方体的细分
回字的细分
回字细分二

小结

  • 分形的应用领域
    1、数学:动力系统
    2、物理:布朗运动,流体力学中的湍流
    3、化学:酶的构造,
    4、生物:细胞的生长
    5、地质:地质构造
    6、天文:土星上的光环
    其他:计算机,经济,社会,艺术等等

  • 要产生开头所展示的美丽的复变函数以及其他迭代图像,只需对相关代码输入参数进行改变即可。

  • 由于网页不兼容等原因,一些代码可能直接拷贝黏贴不能运行。需要源代码的同学联系我qq@96297540
已标记关键词 清除标记
©️2020 CSDN 皮肤主题: 点我我会动 设计师:上身试试 返回首页