Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Happy 4th of July!
#1
Here is a waving U.S. flag with changing hills in the background and moving clouds in the sky. This is from 2 years ago originally and last February for the clouds. 
Thank you to B+, Vince and someone named rattrapmax6 for the clouds!


Code: (Select All)
'Made to honor the U.S. Flag.
'By Sierraken
'Feel free to use any or all of this code in your own applications or games.
'Updated with better flag waving and a hills fix on June 16, 2020.
'Thank you to B+ for help on the hills!
'Update again on Feb. 8, 2022 from B+, Vince and someone named rattrapmax6 for the clouds, thank you!

_Title "U.S. Flag"
Screen _NewImage(800, 600, 32)
Cls
x = 150
y = 100
Dim cf&(113000)

Const nn = 1
Const twidth = 640, theight = 480, zoom = 128
Dim Shared noise(nn * twidth * theight) '//the noise array
Dim Shared texture(nn * twidth * theight) '//texture array
Dim Shared pal(256) As _Unsigned Long '//color palette

Screen _NewImage(640, 480, 32)
MakePalette 255, 155, 255, 10, 100, 180
GenerateNoise
buildtexture

Dim vs As Long
vs = _NewImage(twidth, theight, 32)
_Dest vs
drawtexture 0
_Dest 0

ii = 0
jj = -1
kk = 0



GoSub hills:

'Stars
Line (x, y)-(x + 185, y + 130), _RGB32(0, 0, 255), BF
For xx = 155 To 345 Step 32
    For yy = 105 To 220 Step 28
        Line (xx + 2, yy + 12)-(xx + 7, yy), _RGB32(255, 255, 255)
        Line (xx + 7, yy)-(xx + 13, yy + 12), _RGB32(255, 255, 255)
        Line (xx + 13, yy + 12)-(xx, yy + 5), _RGB32(255, 255, 255)
        Line (xx, yy + 5)-(xx + 15, yy + 5), _RGB32(255, 255, 255)
        Line (xx + 15, yy + 5)-(xx + 2, yy + 12), _RGB32(255, 255, 255)
        Paint (xx + 7, yy + 2), _RGB32(255, 255, 255)
        Paint (xx + 7, yy + 6), _RGB32(255, 255, 255)
        Paint (xx + 11, yy + 10), _RGB32(255, 255, 255)
        Paint (xx + 4, yy + 10), _RGB32(255, 255, 255)
        Paint (xx + 3, yy + 6), _RGB32(255, 255, 255)
        Paint (xx + 12, yy + 6), _RGB32(255, 255, 255)
    Next yy
Next xx

For xx = 172 To 329 Step 32
    For yy = 118.9 To 213.05 Step 28
        Line (xx + 2, yy + 12)-(xx + 7, yy), _RGB32(255, 255, 255)
        Line (xx + 7, yy)-(xx + 13, yy + 12), _RGB32(255, 255, 255)
        Line (xx + 13, yy + 12)-(xx, yy + 5), _RGB32(255, 255, 255)
        Line (xx, yy + 5)-(xx + 15, yy + 5), _RGB32(255, 255, 255)
        Line (xx + 15, yy + 5)-(xx + 2, yy + 12), _RGB32(255, 255, 255)
        Paint (xx + 7, yy + 2), _RGB32(255, 255, 255)
        Paint (xx + 7, yy + 6), _RGB32(255, 255, 255)
        Paint (xx + 11, yy + 10), _RGB32(255, 255, 255)
        Paint (xx + 4, yy + 10), _RGB32(255, 255, 255)
        Paint (xx + 3, yy + 6), _RGB32(255, 255, 255)
        Paint (xx + 12, yy + 6), _RGB32(255, 255, 255)
    Next yy
Next xx

'Stripes
For rs = 100 To 230 Step 37.2
    w = w + 1
    Line (335, rs)-(612.5, rs + 18.6), _RGB32(255, 0, 0), BF
    If w > 3 Then GoTo nex:
    Line (335, rs + 18.6)-(612.5, rs + 37.2), _RGB32(255, 255, 255), BF
Next rs
nex:
w = 0
For rs = 230 To 341.6 Step 37.2
    r = r + 1
    Line (150, rs)-(612.5, rs + 18.6), _RGB32(255, 255, 255), BF
    If r > 3 Then GoTo nex2:
    Line (150, rs + 18.6)-(612.5, rs + 37.2), _RGB32(255, 0, 0), BF
Next rs
nex2:
r = 0
For fy = 100 To 341.6
    For fx = 150 To 612.5
        t5 = t5 + 1
        cf&(t5) = Point(fx, fy)
    Next fx
Next fy
t = 20
On Timer(3) GoSub hills:
Timer On

Do
    _Limit 10

    kk = kk + 1
    ii = ii + 1
    If ii >= 640 Then
        ii = 0
        jj = Not jj
    End If

    If jj Then
        _PutImage (ii, 0)-Step(640, 480), vs
        _PutImage (ii, 0)-Step(-640, 480), vs
    Else
        _PutImage (ii + 640, 0)-Step(-640, 480), vs
        _PutImage (ii - 640, 0)-Step(640, 480), vs
    End If

    'Sky
    _PutImage , hills&, 0
    'Flag Pole
    For sz = .25 To 10 Step .25
        Circle (145, 80), sz, _RGB32(122, 128, 166)
    Next sz
    Line (142, 80)-(147, 600), _RGB32(122, 128, 166), BF
    fx2 = fx2 + 1.2
    If fx2 > 5 Then fx2 = 1.2
    For fy = 100 To 341.6
        For fx = 150 To 612.5
            t6 = t6 + 1
            PSet ((Sin(fy * 0.017453 / fx2) * t) + fx, (Sin(fx * 0.017453 / fx2) * t) + fy), cf&(t6)
        Next fx
    Next fy
    t6 = 0
    If tt = 0 Then t = t + 1
    If t > 10 Then tt = 1
    If tt = 1 Then t = t - 1
    If t < -10 Then tt = 0
    a$ = InKey$
    If a$ = Chr$(27) Then End
    If a$ = " " Then GoSub hills:
    _Display
    Cls
Loop

hills:
'Random Hills
If hills& <> 0 Then _FreeImage hills&
hills& = _NewImage(_Width, _Height, 32)
_Dest hills&
Randomize Timer
hills = Int(Rnd * 40) + 3
For h = 1 To hills
    Randomize Timer
    hx = Int(Rnd * 800) + 1
    size = Int(Rnd * 450) + 75
    cl = Int(Rnd * 55)
    shape = Rnd
    For sz = .25 To size Step .25
        cl = cl + .05
        Circle (hx, 599), sz, _RGB32(10, cl, 20), , , shape
    Next sz
Next h
_Dest 0
Return

'//interpolation code by rattrapmax6
Sub MakePalette (sr, sg, sb, er, eg, eb) ' (b+) start and end RGB's ? yes
    Dim i, istart(3), iend(3), ishow(3), rend(3), interpol(3)

    interpol(0) = 255
    istart(1) = sr
    istart(2) = sg
    istart(3) = sb
    iend(1) = er
    iend(2) = eg
    iend(3) = eb
    interpol(1) = (istart(1) - iend(1)) / interpol(0)
    interpol(2) = (istart(2) - iend(2)) / interpol(0)
    interpol(3) = (istart(3) - iend(3)) / interpol(0)
    rend(1) = istart(1)
    rend(2) = istart(2)
    rend(3) = istart(3)

    For i = 0 To 255
        ishow(1) = rend(1)
        ishow(2) = rend(2)
        ishow(3) = rend(3)

        pal(i) = _RGB32(ishow(1), ishow(2), ishow(3))

        rend(1) = rend(1) - interpol(1)
        rend(2) = rend(2) - interpol(2)
        rend(3) = rend(3) - interpol(3)
    Next i
End Sub

'//generates random noise.
Sub GenerateNoise ()
    Dim As Long x, y

    For x = 0 To nn * twidth - 1
        For y = 0 To theight - 1
            zz = Rnd
            noise(x + y * twidth) = zz
        Next y
    Next x

End Sub

Function SmoothNoise (x, y)
    '//get fractional part of x and y
    Dim fractx, fracty, x1, y1, x2, y2, value
    fractx = x - Int(x)
    fracty = y - Int(y)

    '//wrap around
    x1 = (Int(x) + nn * twidth) Mod twidth
    y1 = (Int(y) + theight) Mod theight

    '//neighbor values
    x2 = (x1 + nn * twidth - 1) Mod twidth
    y2 = (y1 + theight - 1) Mod theight

    '//smooth the noise with bilinear interpolation
    value = 0.0
    value = value + fractx * fracty * noise(x1 + y1 * twidth)
    value = value + fractx * (1 - fracty) * noise(x1 + y2 * twidth)
    value = value + (1 - fractx) * fracty * noise(x2 + y1 * twidth)
    value = value + (1 - fractx) * (1 - fracty) * noise(x2 + y2 * twidth)

    SmoothNoise = value
End Function

Function Turbulence (x, y, size)
    Dim value, initialsize

    initialsize = size
    While (size >= 1)
        value = value + SmoothNoise(x / size, y / size) * size
        size = size / 2.0
    Wend
    Turbulence = (128.0 * value / initialsize)
End Function

'//builds the texture.
Sub buildtexture
    Dim x, y

    For x = 0 To nn * twidth - 1
        For y = 0 To theight - 1
            texture(x + y * nn * twidth) = Turbulence(x, y, zoom)
        Next y
    Next x
End Sub

'//draws texture to screen.
Sub drawtexture (dx)
    Dim x, y
    Dim As Long c, r, g, b

    For x = 0 To twidth - 1
        For y = 0 To theight - 1
            c = pal(texture(((x + dx) + y * nn * twidth)))
            r = _Red(c)
            g = _Green(c)
            b = _Blue(c)
            c = _RGB(r - 0.2 * y, g - 0.2 * y, b - 0.2 * b)
            PSet (x, y), c 'pal(texture(((x + dx) + y * nn*twidth)))
        Next y
    Next x
End Sub
Reply
#2
Thumbs up! And Let Freedom Ring!
https://qb64phoenix.com/forum/showthread...66#pid3666
b = b + ...
Reply
#3
Very cool fireworks B+!
Reply




Users browsing this thread: 2 Guest(s)