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]
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]
网格细分的方法和思路
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
小结
分形的应用领域
1、数学：动力系统
2、物理：布朗运动，流体力学中的湍流
3、化学：酶的构造，
4、生物：细胞的生长
5、地质：地质构造
6、天文：土星上的光环
其他：计算机，经济，社会，艺术等等要产生开头所展示的美丽的复变函数以及其他迭代图像，只需对相关代码输入参数进行改变即可。
- 由于网页不兼容等原因，一些代码可能直接拷贝黏贴不能运行。需要源代码的同学联系我qq@96297540