《倒映在水面上的星夜》

注:请点击“https://community.wolfram.com/groups/-/m/t/1599255”上Wolfram社区下载本文对应的笔记本文件。

这个有意思的小动画是在我闲暇随意摆弄Dynamic(http://reference.wolfram.com/language/ref/Dynamic.html)的时候折腾出来的。画完后感觉不错,所以就拿出来分享了。

事情的起因是我想知道最新版Mathematica运行在我那台五岁高龄的Thinkpad上到底能在一个场景里跑得动多少个动态图元。所以我先写了个简单的测试:


With[{num = 40, aspRatio = 3, splineOrder = 10},
        With[{freqSet = Rescale @ Range @ num},
            DynamicModule[
                {
                    y = 0,
                    pts = Thread[
                        {
                            Rescale[Range @ num, {1, num}, aspRatio * {-1, 1}],
                            0
                        }
                    ]
                },
                DynamicWrapper[
                    Graphics[
                        {
                            {
                                CapForm @ "Round",
                                Hue[0.58, 0.45, 0.55],
                                AbsoluteThickness @ 5,
                                BSplineCurve[
                                    Dynamic @ pts, SplineDegree -> splineOrder, SplineKnots -> "Unclamped"
                                ]
                            },
                            {
                                CapForm @ "Round", JoinForm @ "Round", GrayLevel @ 0.7, AbsoluteThickness @ 3,
                                Line @ Dynamic @ pts
                            },
                            {
                                Hue[0.1, 0.5, 0.95, 0.7],
                                AbsolutePointSize @ 20,
                                Point @ Dynamic @ pts
                            }
                        },
                        PlotRange -> {aspRatio * {-1, 1}, {-1.2, 1.2}},
                        PlotRangePadding -> Scaled[0.05],
                        ImageSize -> 600
                    ],
                    y = Clock[{0, Infinity, 1 / 60}];
                    pts = MapIndexed[
                        Function[
                            {freq, idx},
                            {
                                Rescale[idx[[1]], {1, num}, aspRatio * {-1, 1}],
                                Sin[2 * Pi * freq * y]
                            }
                        ],
                        freqSet
                    ]
                ]
            ]
        ]
    ]

这个测试运行起来非常流畅,各个动态元素的位置也完美同步,索性起了玩心,把它改了一下:试图避免太短、太明显的重复周期,同时也尝试在点和曲线的动态中体现出一点潮汐的感觉。这幅图我给它起名叫《永恒涨落》:

 With[
        {
            winding = 8, corners = 6, radius = 1, shift = 2, gravityPower = 10, freqPower = 1 / 3, symmetricDir = Pi / 2
        },
        With[{num = (corners * winding) + 1},
            With[
                {
                    ω = Function[Rescale[#, {0, 1}, {0.2, 1}]][
                        Function[
                            x,
                            Plus[
                                1, -(TriangleWave[{0, 2}, (x - 1) * x] ^ (1 / freqPower))
                            ]
                        ][Rescale @ Range @ num]
                    ]
                },
                DynamicModule[
                    {
                        t = 0,
                        pts = Function[
                            Function[
                                {θ, d},
                                (radius + d) * {Cos[θ], Sin @ θ}
                            ]@@@#
                        ][
                            Thread[
                                {
                                    Rescale[
                                        Range @ num,
                                        {1, num},
                                        {0, winding * 2 * Pi} + symmetricDir
                                    ],
                                    0
                                }
                            ]
                        ]
                    },
                    DynamicWrapper[
                        Graphics[
                            {
                                {
                                    Hue[0.1, 0.2, 0.9],
                                    AbsoluteThickness @ 1,
                                    Map[
                                        Circle[{0, 0}, #]&,
                                        Rescale[
                                            Rescale[Range[100]] ^ gravityPower,
                                            {0, 1},
                                            {Max[0, radius + -shift], radius + shift}
                                        ]
                                    ]
                                },
                                {GrayLevel @ 0.85, Line @ Dynamic @ pts},
                                {
                                    Hue[0, 0.55, 0.85, 0.3],
                                    AbsolutePointSize @ 10,
                                    Point @ Dynamic @ Most @ pts
                                },
                                {
                                    GrayLevel[0.7, 0.4],
                                    EdgeForm @ {Black, AbsoluteThickness @ 1},
                                    FilledCurve[BSplineCurve[Dynamic @ Most @ pts, SplineClosed -> True]]
                                }
                            },
                            PlotRange -> ((radius + shift) * {{-1, 1}, {-1, 1}}),
                            PlotRangePadding -> Scaled[0.05],
                            Axes -> False, ImageSize -> 500
                        ],
                        t = Clock[{0, Infinity, 1 / 60}];
                        pts = Function[
                            Function[
                                {θ, d},
                                (radius + d) * {Cos[θ], Sin @ θ}
                            ]@@@#
                        ][
                            MapIndexed[
                                Function[
                                    {ω, idx},
                                    {
                                        Rescale[
                                            idx[[1]],
                                            {1, num},
                                            {0, winding * 2 * Pi} + symmetricDir
                                        ],
                                        Times[
                                            shift,
                                            Subtract[
                                                2 * ((Sin[ω * t] + 1) / 2) ^ gravityPower,
                                                1
                                            ]
                                        ]
                                    }
                                ],
                                ω
                            ]
                        ]
                    ]
                ]
            ]
        ]
    ]

既然是闲暇时的随意摆弄,自然还有很多(失败的)尝试。而我自觉不错的里面,个人最喜欢的还是本文题图的这幅图。因为灵感来源于梵高的名作,所以我给它起了个名字叫《倒映在水面上的星夜》。虽然不知道读者的观感怎样,但在我的想象里,这是一个晴朗的冬夜,安静到只有细微的浪声,空气晶莹剔透,星空垂照大地。每颗星星都散溢着各自神秘的光辉(来自科学的吐槽:可能源自冬季空气中悬浮的冰晶的折射),共同照亮了天空下一片宁静的水面。而水面随风漾起的每一层波纹,也各自倒映了一个朦胧的、摇曳的星影。而真正令我惊叹的,是如此可爱的一幅图画,竟然能用两千个字符的Wolfram语言的代码完整描述,而Mathematica——即使在我这台老古董笔记本上——也能流畅无碍地运行这动态场景。

这里我把这幅《倒映在水面上的星夜》的代码附在下面了。其中需要注意的是,为了动画场景永不重复(通过在不同星星间采用无理数周期比),我们刻意回避了Clock(http://reference.wolfram.com/language/ref/Clock.html)的使用,转而采用了自己写的迭代。

一些可以尝试的事情:

试着调整最外层[With](http://reference.wolfram.com/language/ref/With.html)的参数,例如把`baseColorFunc`改为`ColorData["SunsetColors"]`之类的,看看有什么效果;试着根据自己的显示器长宽比来调整`aspRatio`,然后在Mathematica菜单里选择Window > FullScreen,看看怎样得到那个专属于你的宁静星夜的壁纸。

With[
        {
            (* time step of the animation: *) Δt            = 0.05, 
            (* number of stars:            *) n             = 50, 
            (* maximal size of stars:      *) radius        = 1.5, 
            (* color theme:                *) baseColorFunc = ColorData @ "StarryNightColors",
            (* geometric properties of the water region: *)
            waterBase = -2, waterWidth = 5, 
            (* geometric properties of the final drawing: *)
            height = 20, imageHeight = 700, aspRatio = 1 / GoldenRatio
        },
        With[{width = (height + (-waterBase) + waterWidth) / aspRatio},
            Apply[
                Function[{θ0, ω, expr},
                    DynamicModule[{θ = θ0},
                        DynamicWrapper[
                            Deploy @ Activate @ expr,
                            θ = Mod[θ + ω * Δt, 2 * Pi]
                        ]
                    ]
                ]
            ][
                Module[{cx, cy, Δx, Δy, color},
                    {
                        RandomReal[{0, Pi / 2}, n],
                        RandomReal[{0.3, 1}, n],
                        Inactive[Graphics][
                            {
                                (* background: *)
                                Module[
                                    {
                                        h = height + (-waterBase) + waterWidth + 10,
                                        w = width + 5,
                                        m = 10, Δh, cf = baseColorFunc /* (Darker[#, 0.5]&)
                                    },
                                    Δh = h / m;
                                    MapThread[
                                        Function[
                                            {y, c1, c2},
                                            {
                                                EdgeForm[],
                                                Polygon[
                                                    {
                                                        {-5, y},
                                                        {w, y},
                                                        {w, y + Δh},
                                                        {-5, y + Δh}
                                                    },
                                                    VertexColors -> Map[cf, {c1, c1, c2, c2}]
                                                ]
                                            }
                                        ],
                                        {
                                            Function[
                                                Rescale[
                                                    #,
                                                    {1, m},
                                                    {(waterBase + -waterWidth) - 5, height + 5 + -Δh}
                                                ]
                                            ][Range @ m],
                                            Most[
                                                Function[0.4 * (1 + -#) ^ 5][Rescale[Range[m + 1]]]
                                            ],
                                            Rest[
                                                Function[0.4 * (1 + -#) ^ 5][Rescale[Range[m + 1]]]
                                            ]
                                        }
                                    ]
                                ],
                                (* foreground: *)
                                MapThread[
                                    Function[
                                        {cpos, r, idx, shineShift},
                                        {cx, cy} = cpos;
                                        {Δx, Δy} = cpos + -({width, height} / 2);
                                        (* base color: *)
                                        color = baseColorFunc[
                                            1 + -Norm[{Δx, Δy} / {width, height}, 1]
                                        ];
                                        {
                                            (* one star: *)
                                            {
                                                FaceForm @ {Append[(* transparency: *) 0.7][color]},
                                                EdgeForm[],
                                                Polygon[
                                                    Map[
                                                        Function[cpos + r * #],
                                                        {
                                                            {0, 1},
                                                            {Cos[Dynamic[θ[[idx]]]], 0},
                                                            {0, -1},
                                                            {-Cos[Dynamic[θ[[idx]]]], 0}
                                                        }
                                                    ]
                                                ]
                                            },
                                            (* and its reflection: *)
                                            {
                                                RightComposition[
                                                    ColorConvert[#, "LAB"]&,
                                                    (* adjust luminance according to shineShift (i.e. y-coords): *)
                                                    ReplacePart[
                                                        1 -> RightComposition[
                                                            Function[Cos[2 * #]],
                                                            Function[((# + 1) / 2) ^ 0.5],
                                                            Function[
                                                                Rescale[
                                                                    #,
                                                                    {0, 1},
                                                                    Plus[
                                                                        (* mean luminance, lower the brighter: *)
                                                                        Rescale[shineShift, {-1, 1}, {0.4, 0.7}],
                                                                        (* luminance variation range, lower the more active: *)
                                                                        {-1, 1} * Rescale[shineShift, {-1, 1}, {0.3, 0.03}]
                                                                    ]
                                                                ]
                                                            ]
                                                        ][Dynamic[θ[[idx]]]]
                                                    ],
                                                    (* transparency: *)
                                                    Append[Function[Rescale[#, {-1, 1}, {0.2, 0.6}]][shineShift]]
                                                ][color],
                                                (* abstract blur: *)
                                                AbsoluteThickness[Function[Rescale[#, {-1, 1}, {10, 1}]][shineShift]],
                                                Line[
                                                    Function[
                                                        {
                                                            {
                                                                Plus[
                                                                    cx, -(Times[
                                                                        r,
                                                                        Times[
                                                                            #3,
                                                                            Times[
                                                                                1 / 2,
                                                                                1 + -(#2 * Cos[Dynamic[θ[[idx]]]])
                                                                            ]
                                                                        ]
                                                                    ])
                                                                ],
                                                                #
                                                            },
                                                            {
                                                                Plus[
                                                                    cx,
                                                                    Times[
                                                                        r,
                                                                        Times[
                                                                            #3,
                                                                            (1 / 2) * (1 + #2 * Sin[Dynamic[θ[[idx]]]])
                                                                        ]
                                                                    ]
                                                                ],
                                                                #
                                                            }
                                                        }
                                                    ][
                                                        (* y-coords: *)
                                                        Plus[
                                                            waterBase,
                                                            waterWidth * ((Rescale[shineShift, {-1, 1}] ^ 0.5) - 1)
                                                        ],
                                                        (* variance: *)
                                                        Rescale[shineShift, {-1, 1}, {1, 0.2}],
                                                        (* mean radius: *)
                                                        Rescale[shineShift, {-1, 1}, {2, 4}]
                                                    ]
                                                ]
                                            }
                                        }
                                    ],
                                    {
                                        Join[
                                            ScalingTransform[{3 / 4, 3 / 4}, {width, height} / 2][
                                                RandomPoint[Rectangle[{0, 0}, {width, height}], Ceiling[n / 4]]
                                            ],
                                            RandomPoint[
                                                Rectangle[{0, 0}, {width, height}],
                                                (n + -Ceiling[n / 4]) - 1
                                            ],
                                            {{width, height} / 2}
                                        ],
                                        radius * RandomReal[{1 / height, 1}, n],
                                        Range @ n,
                                        RandomReal[{-1, 1}, n]
                                    }
                                ]
                            },
                            PlotRange -> {{0, width}, {waterBase + -waterWidth, height}},
                            PlotRangePadding -> {{2, 2}, {1, 2}},
                            Background -> None,
                            ImageSize -> {Automatic, imageHeight}
                        ]
                    }
                ]
            ]
        ]
    ]

原文发布于微信公众号 - WOLFRAM(WolframChina)

原文发表时间:2019-04-01

本文参与腾讯云自媒体分享计划,欢迎正在阅读的你也加入,一起分享。

发表于

我来说两句

0 条评论
登录 后参与评论

扫码关注云+社区

领取腾讯云代金券