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