Message Boards Message Boards

[GIF] Starry Night over Water

MODERATOR NOTE: a submission to computations art contest, see more: https://wolfr.am/CompArt-22.
The complete notebook of this post is attached at the end.


starry<em>nightover_water

This cute little animation came to me while I was playing with Dynamic. I found it very lovely so would like to share it to the community.

So I wanted to know how many Dynamic primitives my 5 years old laptop can handle in one scene (i.e. Graphics). This is my first test scenario:

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
                ]
            ]
        ]
    ]
]

helix

Not too shabby! The motions are smooth, the points align perfectly.

Now this one I call Everlasting Tide:

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
                                        ]
                                    ]
                                }
                            ],
                            ω
                        ]
                    ]
                ]
            ]
        ]
    ]
]

everlasting_tide

But back to my most beloved animation at the beginning. I introduce to you: Starry Night over Water. A winter night is painted by the palette of the cosmos. Each star whirls in its own delight, unknowingly lighting the quiet water below in a blurry expansion of everchanging hues. I'm really thrilled how such a lovely piece of animation can be created with a little more than 2000 character in code, and the background optimization done by Mathematica to make it run so smoothly.

P.S. I have used explicit iteration here instead of Clock to drive the animation, so that this small quiet world shall be immune from a certain overflow ;)

Things to try:

Playing with the parameters of the outmost With, say, changing baseColorFunc to ColorData["SunsetColors"], or changing aspRatio to match your monitor then menu-bar > 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}
                    ]
                }
            ]
        ]
    ]
]

starry<em>nightover_water

Attachments:
POSTED BY: Silvia Hao
7 Replies

Great idea there!

So to create a GIF, I think it would be convenient to introduce the total number of frames:

With[{frames = 120}
 , With[{
   (* time step of the animation: *) Δt = 1/frames
   (* ...... *)

To ensure the GIF is periodical, ω should be constrained, so:

(* ...... *)
Module[{cx, cy, Δx, Δy, color},
    {
        (* θ0: *) RandomReal[{0, Pi / 2}, n],
        (* ω: *)(* instead of RandomReal[{0.3, 1}, n]: *)
        2 Pi RandomInteger[{1, 5}, n] ,
(* ...... *)

Finally, instead of:

Function[{θ0, ω, expr},
                DynamicModule[{θ = θ0},
                    DynamicWrapper[
                        Deploy @ Activate @ expr,
                        θ = Mod[θ + ω * Δt, 2 * Pi]
                    ]]]

a static generator is needed:

Function[{θ0, ω, expr},
   Block[{θ = θ0 + k ω Δt, 
     Dynamic = Identity},
    expr // Deploy // Inactive[Function][k, #] & // Activate
    ]
]

So assemble them together:

frameGen = With[{frames = 120},#]& @ With[
    {
        (* time step of the animation: *) Δt            = 1./frames, 
        (* 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]]]] *)
                Block[{θ = θ0 + k ω Δt, Dynamic = Identity},
                   expr // Deploy // Inactive[Function][k, #] & // Activate
                ]
            ]
        ][
            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[
                                                    {
                                                        {cx - 1/2 r (#3 (1 - #2 Cos[Dynamic[θ[[idx]]]])), #1},
                                                        {cx + 1/2 r (#3 (1 + #2 Sin[Dynamic[θ[[idx]]]])), #1}
                                                    }
                                                ][
                                                    (* 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}
                    ]}]]]];

Generating frames:

frames = With[{frames = 120}, RightComposition[frameGen, Rasterize] /@ Range[frames]];

Exporting to GIF:

Export["starry_night_over_water.gif", frames, "GIF",  "DisplayDurations" -> .1]
POSTED BY: Silvia Hao

Works great -- Thanks!

POSTED BY: Anton Antonov

How can this Deployed dynamic be converted into images frames?

The exported movie would be great as Zoom background (this month.)

POSTED BY: Anton Antonov

Beautiful and calming! Saving for my attempts at meditation. And it's great to see such clear, logical beautifully-formatted code.

Posted 6 years ago

Lovely post!

POSTED BY: Casper YC

enter image description here - Congratulations! This post is now a Staff Pick as distinguished by a badge on your profile! Thank you, keep it coming, and consider contributing your work to the The Notebook Archive!

POSTED BY: EDITORIAL BOARD

Great post, and thanks for providing the notebook for download.

Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract