Snowflakes

[SierraKen]

Here is a modification (mod) of B+'s "Basic Polygon and Multiplier Mod" of snowflakes falling down. He probably has made this before but I thought I would try it myself. 
Thanks B+!

Code: (Select All)

'Snowflakes - mod from B+'s Basic Polygon and Multiplier Mod
'b+ 2022-07-13, SierraKen 2022-07-13

_Title "Snowflakes" 'b+ 2022-07-13, SierraKen 2022-07-13

Dim xc(500), yc(500), r(500), n(500), x(500), y(500)

' a circle is 360 degree
' a polyon of n side has central angles 360 / n  > think of a pie the central angle are the angle of slices in center
Screen _NewImage(800, 600, 32)
_ScreenMove 350, 100

Randomize Timer
Do
    _Limit 30
    If Rnd > .25 Then
        t = t + 1
        If t > 495 Then t = 0
        xc(t) = Rnd * _Width
        yc(t) = 1
        r(t) = Rnd * 20
        n(t) = Int(Rnd * 10) + 3
    End If
    For tt = 1 To t
        yc(tt) = yc(tt) + 1
        For m = 1 To n(tt) - 1
            For angle = 0 To 720 Step 360 / n(tt) ' step the size of pie angles
                ' let xC, yC be the coordinates at the center of the pie circle
                ' let r be the radius of the pie
                ' then the n outside points are
                x(tt) = xc(tt) + r(tt) * Cos(m * _D2R(angle) - _Pi / 2) ' x coordinate of outter edge point
                y(tt) = yc(tt) + r(tt) * Sin(m * _D2R(angle) - _Pi / 2) ' y coordinate of outter edge point
                If angle = 0 Then PSet (x(tt), y(tt)) Else Line -(x(tt), y(tt)) ' outter edge edge
                Line (xc(tt), yc(tt))-(x(tt), y(tt)) ' slice from center of pie
            Next
        Next m
    Next tt
    _Display
    Cls
Loop Until InKey$ = Chr$(27)

[James D Jarvis]

I admit it I'm impressed by your polygons, but i like my snowflakes  more branch-like

Code: (Select All)

'let it snow
'press any key to quit when running
Screen _NewImage(800, 500, 32)
Randomize Timer
Dim flakearm$(300)
Dim fx(300), fy(300), fv(300, 2), frot(300)

Color _RGB32(255, 255, 255), _RGB32(10, 10, 150)
'build flakes
For f = 1 To 300
    r1 = Int(Rnd * 12) + 4
    r2 = r1 / 4 + Int(Rnd * (r1 / 4))

    flakearm$(f) = " r" + Str$(r1) + "f" + Str$(r2) + "h" + Str$(r2) + "e" + Str$(r2) + "g" + Str$(r2) + "r" + Str$(r1 / 2)
    If Rnd * 6 > 3 Then flakearm$(f) = flakearm$(f) + "f" + Str$(r2) + "h" + Str$(r2) + "e" + Str$(r2) + "g" + Str$(r2)
    If Rnd * 6 > 4 Then flakearm$(f) = flakearm$(f) + "r3" + "f" + Str$(r2 / 2) + "h" + Str$(r2 / 2) + "e" + Str$(r2 / 2) + "g" + Str$(r2 / 2) + "r2"
    fx(f) = Int(Rnd * 800)
    fy(f) = Int(Rnd(50)) - 80
    fv(f, 1) = Rnd * (r1 / 16) - Rnd * (r1 / 16)
    fv(f, 2) = Rnd * (r1 / 4)
    frot(f) = Int(Rnd * 28)
Next f
'snow
Do
    _Limit 30
    Cls
    For f = 1 To 200
        For d = 0 + frot(f) To 360 + frot(f) Step 60
            PSet (fx(f), fy(f))
            Draw "ta" + Str$(d) + flakearm$(f)
        Next d
        fx(f) = fx(f) + fv(f, 1): fy(f) = fy(f) + fv(f, 2)
        If fy(f) > 550 Then fy(f) = -3 * (Rnd * 30)
        If fx(f) < -30 Or fx(f) > 830 Then
            fx(f) = Int(Rnd * 600) + 100
            fy(f) = -3 * (Rnd * 30)
            frot(f) = Int(Rnd * 28)
        End If
        If Rnd * 8 > 6.5 Then frot(f) = frot(f) + Rnd * 1.2 - Rnd * 2.4
    Next f
    _Display
    a$ = InKey$
Loop Until a$ <> ""

[bplus]

Some more flakey designs ;-))

Code: (Select All)

_Title "draw flake test 2" '   B+ 2018-12-05 from JB 2016-11-07
' revist 2021-11-24 and demo better. ' revise again for 2022-07-14 post
Const XMAX = 400, YMAX = 400
Randomize Timer
Screen _NewImage(XMAX, YMAX, 32)
_ScreenMove 400, 150
Do
    DV = 2.1 + .4 * Rnd 'global dictates density of flake
    rr = 45 * Rnd + 3
    For rAng = 0 To _Pi / 16 Step _Pi(1 / 120)
        Cls
        rFlake XMAX * .5, YMAX * .5, rr, DV, rAng
        _Display
        _Limit 6
    Next
Loop Until _KeyDown(27)

Sub rFlake (x, y, r, DV, rAng)
    'DV = flake density
    Color _RGBA32(225, 225, 245, 100)
    For a = 0 To 5
        armX = x + r * Cos(a * _Pi(1 / 3) + rAng)
        armY = y + r * Sin(a * _Pi(1 / 3) + rAng)
        Line (x, y)-(armX, armY)
        If r > 2.5 Then rFlake armX, armY, r / DV, DV, rAng
    Next
End Sub

[SierraKen]

Very cool James, and good use of the draw command. B+ way cool, I wish I could learn how to do equations like that without just copying, maybe someday.

[SierraKen]

To make more realistic snowflakes, I changed n (points) to just 13 which is my favorite one. I also added background hills that change with the Space Bar and the Copy to Clipboard feature in case people want to make their own Christmas decorations or cards using another graphics program to paste it to. I also added the ability for the snowflakes to wiggle and the smaller ones move faster to simulate depth, as well as a blue sky. 

Code: (Select All)

'Snowflakes - mod from B+'s Basic Polygon and Multiplier Mod
'b+ 2022-07-13, SierraKen 2022-07-13
'Changed n to only be 13 so I got rid of n.
'Added hills and clipboard.
'Added the snowflakes to wiggle and move at different speeds.

_Title "Snowflakes - Space Bar changes hills - C copies to clipboard - Esc quits" 'b+ 2022-07-13, SierraKen 2022-07-13

Dim xc(500), yc(500), r(500), x(500), y(500), fx(500), rr(500), hillx(100), sz3(100)
Dim img As Long

Screen _NewImage(800, 600, 32)
_ScreenMove 350, 100
start:
Cls
Randomize Timer
Paint (0, 50), _RGB32(0, 128, 255)
For hills = 3 To 20
    cl = 255
    hillx(hills) = Rnd * 800
    sz = (Rnd * 300) + 100
    For sz2 = .25 To sz Step .25
        cl = cl - .05
        sz3(hills) = sz2
        Circle (hillx(hills), 600), sz2, _RGB32(cl, cl, cl)
    Next sz2
Next hills


Do
    _Limit 2000
    Paint (0, 50), _RGB32(0, 128, 255)
    For hills = 3 To 20
        cl = 255
        For sz2 = .25 To sz3(hills) Step .25
            cl = cl - .075
            Circle (hillx(hills), 600), sz2, _RGB32(cl, cl, cl)
        Next sz2
    Next hills
    If Rnd > .75 Then
        t = t + 1
        If t > 495 Then t = 0
        xc(t) = Rnd * _Width
        yc(t) = -40
        r(t) = Rnd * 40
        rr(t) = 40 / r(t)
        fx(t) = (Rnd * 8) - 4
    End If
    For tt = 1 To t
        yc(tt) = yc(tt) + rr(tt)
        fx(tt) = fx(tt) + (Rnd * 8) - 4
        For m = 1 To 13 - 1
            For angle = 0 To 720 Step 360 / 13 ' step the size of pie angles
                ' let xC, yC be the coordinates at the center of the pie circle
                ' let r be the radius of the pie
                ' then the n outside points are
                x(tt) = xc(tt) + r(tt) * Cos(m * _D2R(angle) - _Pi / 2) ' x coordinate of outter edge point
                y(tt) = yc(tt) + r(tt) * Sin(m * _D2R(angle) - _Pi / 2) ' y coordinate of outter edge point
                If angle = 0 Then PSet (x(tt) + fx(tt), y(tt)) Else Line -(x(tt) + fx(tt), y(tt)) ' outter edge edge
                Line (xc(tt) + fx(tt), yc(tt))-(x(tt) + fx(tt), y(tt)) ' slice from center of pie
            Next
        Next m
    Next tt
    a$ = InKey$
    If a$ = " " Then GoTo start:
    If a$ = Chr$(27) Then End
    If a$ = "c" Or a$ = "C" Then
        _AutoDisplay
        If img& <> 0 Then _FreeImage (img&)
        img& = _CopyImage(0)
        _ClipboardImage = img&
        _Delay .25
        Color _RGB32(0, 0, 0), _RGB32(0, 128, 255)
        Locate 1, 1: Print "Copied To Clipboard"
        Color _RGB32(255, 255, 255)
        _Delay 2
    End If
    _Display
    Cls
Loop Until InKey$ = Chr$(27)

[James D Jarvis]

From watching 2 runs : You know what that last on needs don't ya? Piles of snow that grow as it snows.

[SierraKen]

Thanks for the idea James. I had done this already for a Christmas app I made a few years ago. So today I added the snowflakes to it instead of just round snow. Check it out:

Code: (Select All)

'Snowflakes 2 by SierraKen
'July 16, 2022
'Thanks to B+ for the snowflake design!
'Thanks to James D. Jarvis for the idea.

Screen _NewImage(800, 600, 32)
Dim rr(600)
Dim stackx(2000), stacky(2000), stackr(2000)
Dim cx As Integer, cy As Integer, r As Integer, c As _Unsigned Long
Dim xc(2000), yc(2000), fx(2000), x(2000), y(2000)
size = 1
_Title "Snowflakes 2"
Do
    _Limit 20
    a$ = InKey$
    If a$ = Chr$(27) Then End
    'Hill
    For sz = .25 To 700 Step .25
        cl = cl + .05
        Circle (400, 1100), sz, _RGB32(0, cl, 0)
    Next sz
    cl2 = cl
    cl = 0
    'Tree
    tx = 390: ty = 400: r = 10: c = _RGB32(255, 0, 0)
    Line (tx, ty)-(tx + 20, ty - 74), _RGB32(183, 127, 127), BF
    Line (tx, ty - 75)-(tx + 20, ty - 75), _RGB32(127, 255, 127)
    'left side
    Line (tx, ty - 75)-(tx - 150, ty - 75), _RGB32(127, 255, 127)
    Line (tx - 150, ty - 75)-(tx, ty - 150), _RGB32(127, 255, 127)
    cx = tx - 150: cy = ty - 75
    'fillCircle cx, cy, r, c
    Line (tx, ty - 150)-(tx - 100, ty - 150), _RGB32(127, 255, 127)
    Line (tx - 100, ty - 150)-(tx, ty - 200), _RGB32(127, 255, 127)
    cx = tx - 100: cy = ty - 150
    'fillCircle cx, cy, r, c
    Line (tx, ty - 200)-(tx - 50, ty - 200), _RGB32(127, 255, 127)
    Line (tx - 50, ty - 200)-(tx + 5, ty - 250), _RGB32(127, 255, 127)
    cx = tx - 50: cy = ty - 200
    'fillCircle cx, cy, r, c
    'right side
    Line (tx + 20, ty - 75)-(tx + 170, ty - 75), _RGB32(127, 255, 127)
    Line (tx + 170, ty - 75)-(tx + 20, ty - 150), _RGB32(127, 255, 127)
    cx = tx + 170: cy = ty - 75
    'fillCircle cx, cy, r, c
    Line (tx + 20, ty - 150)-(tx + 120, ty - 150), _RGB32(127, 255, 127)
    Line (tx + 120, ty - 150)-(tx + 20, ty - 200), _RGB32(127, 255, 127)
    cx = tx + 120: cy = ty - 150
    'fillCircle cx, cy, r, c
    Line (tx + 20, ty - 200)-(tx + 70, ty - 200), _RGB32(127, 255, 127)
    Line (tx + 70, ty - 200)-(tx + 5, ty - 250), _RGB32(127, 255, 127)
    cx = tx + 70: cy = ty - 200
    'fillCircle cx, cy, r, c
    cx = tx + 5: cy = ty - 260
    r = 10
    c = _RGB32(255, 255, 127)
    'fillCircle cx, cy, r, c
    Paint (tx, ty - 77), _RGB32(127, 255, 127)
    If Rnd > .96 Then
        tt = tt + 1
        If tt > 495 Then tt = 0
        xc(tt) = Rnd * _Width
        yc(tt) = -40
        rr(tt) = (Rnd * 20) + 10
        fx(tt) = (Rnd * 8) - 4
    End If

    For t = 1 To tt
        yc(t) = yc(t) + 1
        yc(t) = yc(t) + (Rnd * 5)
        fx(t) = fx(t) + (Rnd * 8) - 4
        For m = 1 To 13 - 1
            For angle = 0 To 720 Step 360 / 11
                x(t) = xc(t) + rr(t) * Cos(m * _D2R(angle) - _Pi / 2)
                y(t) = yc(t) + rr(t) * Sin(m * _D2R(angle) - _Pi / 2)
                If angle = 0 Then PSet (x(t) + fx(t), y(t)) Else Line -(x(t) + fx(t), y(t))
                Line (xc(t) + fx(t), yc(t))-(x(t) + fx(t), y(t))
            Next
        Next m
        cl2 = Int(cl2)
        For check = 100 To 200 Step .25
            If Point(xc(t), yc(t) + rr(t) + 1) = _RGB32(0, check, 0) Then GoTo stacked:
        Next check
        If Point(xc(t), yc(t) + rr(t) + 1) = _RGB32(127, 255, 127) Then GoTo stacked:
        'If Point(xc(t), yc(t) + rr(t) + 1) = _RGB32(255, 255, 127) Then GoTo stacked:
        'If Point(xc(t), yc(t) + rr(t) + 1) = _RGB32(255, 0, 0) Then GoTo stacked:
    Next t
    nex:
    If snow <> 0 Then
        For sn = 1 To snow
            cx = stackx(sn)
            cy = stacky(sn)
            r = stackr(sn)
            c = _RGB32(252, 252, 252)
            fillCircle cx, cy, r, c
        Next sn
    End If
    _Display
    Line (0, 0)-(_Width, _Height), _RGB32(0, 0, 0), BF
Loop

stacked:
snow = snow + 1
If snow > 1800 Then snow = 1: size = 1
If snow / 200 = Int(snow / 200) Then size = size * 1.4
stackx(snow) = xc(t)
stacky(snow) = yc(t) - (size / 2) + rr(t)
stackr(snow) = (rr(t) / 2) + size
xc(t) = -200: yc(t) = 800: rr(t) = 0
GoTo nex:

'from Steve Gold standard
Sub fillCircle (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
    Dim Radius As Integer, RadiusError As Integer
    Dim X As Integer, Y As Integer
    Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
    If Radius = 0 Then PSet (CX, CY), C: Exit Sub
    Line (CX - X, CY)-(CX + X, CY), C, BF
    While X > Y
        RadiusError = RadiusError + Y * 2 + 1
        If RadiusError >= 0 Then
            If X <> Y + 1 Then
                Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
    Wend
End Sub

[vinceg2022]

Very mesmerizing Ken, nice job

[James D Jarvis]

nice.

[SierraKen]

Thanks guys!