Radian Ferris Wheel

[james2464]

I added some background, so I could try a moving cloud effect.

Code: (Select All)

'ferris wheel with clouds
'james2464 - Nov 12 2022

Dim Shared scx, scy As Integer
scx = 800: scy = 600
Screen _NewImage(scx, scy, 32)

Const PI = 3.141592654#
Randomize Timer

Dim Shared bg&, cd&(20)
bg& = _NewImage(scx + 1, scy + 1, 32)
For ct = 1 To 20
    cd&(ct) = _NewImage(301, 101, 32)
Next ct

Dim Shared c(100) As Long
colour1

Type movingcloud
    x As Single
    y As Single
    xv As Single
End Type
Dim Shared cloud(20) As movingcloud
Dim Shared cloudtotal

cloudtotal = 6
makeclouds

background1
_PutImage (1, 1)-(scx - 1, scy - 1), 0, bg&, (1, 1)-(scx - 1, scy - 1) 'take snapshot of screen



'origin
xx = 400
yy = 300
w = 220 'wheel radius
p = 15 'number of positions
'=====================================================
h = _Hypot(w, 0)
h1 = _Atan2(0, w)
'=====================================================
Do
    _Limit 30
    Cls
    _PutImage (0, 0)-(scx, scy), bg&, 0 'draw background

    For ct = 1 To cloudtotal
        _PutImage (cloud(ct).x, cloud(ct).y)-(cloud(ct).x + 500, cloud(ct).y + 100), cd&(ct), 0 'cloud
        cloud(ct).x = cloud(ct).x + cloud(ct).xv
        If cloud(ct).x > 1000 Then
            cloud(ct).x = -600
            cloud(ct).y = Rnd * 200 - 20
            cloud(ct).xv = Rnd * .2 + .3
        End If
    Next ct

    Circle (xx, yy), w, c(0)
    Line (xx, yy)-(xx - 50, yy + w + 40), c(0)
    Line (xx, yy)-(xx + 50, yy + w + 40), c(0)
    Line (xx - 50, yy + w + 40)-(xx + 50, yy + w + 40), c(0)
    h1 = h1 + .002
    If h1 >= PI * 2 Then h1 = 0
    '-------------------------------------------------
    For t = 1 To p
        h2 = h1 + ((PI * 2) / p) * t
        x = Cos(h2) * h: y = Sin(h2) * h
        Line (xx, yy)-(xx + x, yy + y), c(0)
        Line (xx + x - 7, yy + y - 1)-(xx + x + 7, yy + y + 1), c(12), BF
        Line (xx + x, yy + y)-(xx + x, yy + y + 15), c(0)
        Line (xx + x - 7, yy + y + 15)-(xx + x + 7, yy + y + 25), c(12), BF
    Next t
    _Display
Loop

Sub background1
    Cls
    Line (1, 1)-(scx - 1, scy - 1), c(1), BF
    y = 400
    For t = 1 To y
        m = 255 * ((400 - t) / 400)
        c(99) = _RGBA(150, 150, 255, m)
        Line (1, t)-(scx - 1, t), c(99)
    Next t

    ty = scy - y
    For t = y To scy
        t2 = ((scy - t) * 2)
        m = 255 * ((scy - t2) / scy)
        c(99) = _RGBA(50, 150, 50, m)
        Line (1, t)-(scx - 1, t), c(99)
    Next t
End Sub



Sub colour1
    c(0) = _RGB(0, 0, 0)
    c(1) = _RGB(255, 255, 255)
    c(2) = _RGB(255, 255, 0)
    c(3) = _RGB(255, 0, 0)
    c(4) = _RGB(0, 255, 0)
    c(5) = _RGB(0, 255, 255)
    c(6) = _RGB(255, 0, 255)
    c(7) = _RGB(30, 30, 255)
    c(8) = _RGB(150, 150, 250)
    c(9) = _RGB(250, 150, 150)
    c(10) = _RGB(150, 250, 150)
    c(11) = _RGB(150, 150, 255) 'sky blue
    c(12) = _RGB(150, 75, 125) 'cars
    c(13) = _RGB(255, 0, 0)
    c(14) = _RGB(50, 150, 50) 'ground
End Sub



Sub makeclouds

    'create cloud images with clear background

    For ct = 1 To cloudtotal

        Cls 'cloud 1
        Line (0, 0)-(302, 102), c(1), B
        For t = 1 To 80
            x1 = Rnd * 260 - 130
            y1 = Rnd * 60 - 30
            d1 = Rnd * 12 + 7
            For d = d1 To .1 Step -.1
                c(99) = _RGB(250 - y1 * 1.2, 250 - y1 * 1.2, 250 - y1 * 1.2)
                Circle (150 + x1, 50 + y1), d, c(99) 'outline
            Next d
        Next t
        _PutImage (1, 1)-(301, 101), 0, cd&(ct), (1, 1)-(300, 100)
        _ClearColor c(0), cd&(ct)

        'starting position
        cloud(ct).x = Rnd * 800 - 400: cloud(ct).y = Rnd * 200 - 20
        'speed
        cloud(ct).xv = Rnd * .2 + .3
    Next ct

End Sub