+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Programs (https://staging.qb64phoenix.com/forumdisplay.php?fid=7)
+---- Thread: USA Flag (/showthread.php?tid=103)
USA Flag - vince - 04-21-2022
Waving and shaded 3D US flag. Drawn according to official specification
Code: (Select All)
deflng a-z
sw = 640
sh = 480
dim shared pi as double
pi = 4*atn(1)
screen _newimage(sw*2, sh, 32)
h = 300
w = 1.9*h
a = h/7
img = _newimage(w, h, 32)
_dest img
x0 = 0
y0 = 0
line (0, 0)-step(w, h),_rgb(255,255,255),bf
for i=0 to 6
line (0, i*h*2/13)-step(w, h/13),_rgb(255*0.698,255*0.132,255*0.203),bf
next
line (0, 0)-step(w*2/5, h*7/13),_rgb(255*0.234,255*0.233,255*0.430),bf
for i=0 to 4
for j=0 to 5
starf (j*2 + 1)*w*2/(5*12), (i*2 + 1)*h*7/130, h*4/(13*5*2), _rgb(255,255,255)
next
next
for i=1 to 4
for j=1 to 5
starf (j*2)*w*2/(5*12), (i*2)*h*7/130, h*4/(13*5*2), _rgb(255,255,255)
next
next
_dest 0
_putimage (sw/2 - w/2, sh/2 - h/2), img
_source img
x0 = sw/2 - w/2 + sw
y0 = sh/2 - h/2 '+ sh
dim t as double
dim z as double
dim xx as double, yy as double
dim dx as double, dy as double
do
t = t + 0.2
line (sw,0)-step(sw, sh),_rgb(0,0,0),bf
for y=0 to h + a*0.707 step 1
for x=0 to w + a*0.707 step 1
z = (0.1 + 0.4*(x/w))*a*sin(x/35 - y/70 - t) + 0.5*a
dz = 50*a*cos(x/35 - y/70 - t)/35
xx = x + z*0.707 - a*0.707
yy = y - z*0.707
if (int(xx) >=0 and int(xx) < w - 1 and int(yy) >= 0 and int(yy) < h - 1) then
tl = point(int(xx), int(yy))
tr = point(int(xx) + 1, int(yy))
bl = point(int(xx), int(yy) + 1)
br = point(int(xx) + 1, int(yy) + 1)
dx = xx - int(xx)
dy = yy - int(yy)
r =_round((1 - dy)*((1 - dx)* _red(tl) + dx* _red(tr)) + dy*((1 - dx)* _red(bl) + dx* _red(br)))
g = _round((1 - dy)*((1 - dx)*_green(tl) + dx*_green(tr)) + dy*((1 - dx)*_green(bl) + dx*_green(br)))
b = _round((1 - dy)*((1 - dx)* _blue(tl) + dx* _blue(tr)) + dy*((1 - dx)* _blue(bl) + dx* _blue(br)))
r = r + dz
g = g + dz
b = b + dz
if r<0 then r = 0
if r>255 then r = 255
if g<0 then g = 0
if g>255 then g = 255
if b<0 then b = 0
if b>255 then b = 255
pset (x0 + x, y0 - a*0.707 + y), _rgb(r,g,b)
end if
next
next
_display
_limit 50
loop until _keyhit = 27
sleep
system
sub starf(x, y, r, c)
pset (x + r*cos(pi/2), y - r*sin(pi/2)),c
for i = 0 to 5
xx = r*cos(i*4*pi/5 + pi/2)
yy = r*sin(i*4*pi/5 + pi/2)
line -(x + xx, y - yy),c
next
paint (x, y),c
for i = 0 to 5
xx = r*cos(i*4*pi/5 + pi/2)/2
yy = r*sin(i*4*pi/5 + pi/2)/2
paint (x + xx, y - yy),c
next
end subRE: USA Flag - Jack - 04-21-2022
very nice
RE: USA Flag - Pete - 04-21-2022
Hey who let Vince FLAG Steve's forum?!
Nice graphics. I like the waving effect.
Pete
RE: USA Flag - Dav - 04-21-2022
Really beautiful effect. The touch of reflection as it waves makes it seem so realistic.
Nice coding!
- Dav
RE: USA Flag - Pete - 04-22-2022
From the Archives of The QJurassic Forum, via TheBOB, 2003
Code: (Select All)
'*******************
'STARS and STRIPES
'By TheBOB / 2003
'*******************
_TITLE "Stars and Strips by Bob Seguin"
DEFINT A-Z
SCREEN 12
OUT &H3C8, 4
OUT &H3C9, 63
OUT &H3C9, 0
OUT &H3C9, 0
OUT &H3C8, 5
OUT &H3C9, 0
OUT &H3C9, 0
OUT &H3C9, 25
OUT &H3C8, 8
OUT &H3C9, 60
OUT &H3C9, 60
OUT &H3C9, 63
PSET (113, 98), 15
DRAW "ta216 r18 ta72 r18 ta288 r18 ta144 r18 ta0 r18"
PAINT (0, 0), 4, 15
PAINT (105, 105), 14, 4
PAINT (0, 0), 0, 14
PSET (98, 109), 14
PSET (100, 108), 14
FOR x = 97 TO 114
FOR y = 102 TO 109
IF POINT(x, y) = 14 THEN PSET (x, y), 6
NEXT y
NEXT x
DIM StarBOX(140)
GET (95, 90)-(115, 110), StarBOX()
PAINT (0, 0), 5
FOR y = 60 TO 372 STEP 52
LINE (50, y)-(589, y + 24), 4, BF
IF y < 372 THEN LINE (50, y + 25)-(589, y + 51), 15, BF
NEXT y
LINE (50, 60)-(290, 240), 1, BF
FOR x = 64 TO 254 STEP 38
FOR y = 70 TO 206 STEP 34
PUT (x, y), StarBOX()
IF x < 254 AND y < 206 THEN PUT (x + 19, y + 17), StarBOX()
NEXT y
NEXT x
'Initialize "wave" variables
x1 = 0
x3 = 215
x5 = 430
DO
Count = Count + 1
x = INT(RND * 6)
y = INT(RND * 5)
x = x * 38 + 64
y = y * 34 + 70
IF x < 254 AND y < 206 AND Count MOD 2 THEN x = x + 19: y = y + 17
LINE (x, y)-(x + 18, y + 19), 1, BF
StartTIME# = TIMER
DO: LOOP WHILE TIMER < StartTIME# + 0
PUT (x, y), StarBOX()
'Add extra twinkle effect
IF Count MOD 3 THEN
PAINT (x + 9, y + 14), 11, 1
WAIT &H3DA, 8
WAIT &H3DA, 8, 8
PAINT (x + 9, y + 14), 15, 1
WAIT &H3DA, 8
WAIT &H3DA, 8, 8
PAINT (x + 9, y + 14), 1, 1
PUT (x, y), StarBOX()
END IF
'Increment 'wave' variables
x1 = x1 + 1
x2 = x1 + 80
x3 = x3 + 1
x4 = x3 + 80
x5 = x5 + 1
x6 = x5 + 80
'reset "wave" variables to left of screen when indicated
IF x1 = 600 THEN x1 = -45
IF x3 = 600 THEN x3 = -45
IF x5 = 600 THEN x5 = -45
'Draw "waves"
FOR y = 60 TO 372
IF POINT(x1, y) = 8 THEN PSET (x1, y), 15
IF POINT(x2, y) = 15 THEN PSET (x2, y), 8
IF POINT(x3, y) = 8 THEN PSET (x3, y), 15
IF POINT(x4, y) = 15 THEN PSET (x4, y), 8
IF POINT(x5, y) = 8 THEN PSET (x5, y), 15
IF POINT(x6, y) = 15 THEN PSET (x6, y), 8
NEXT y
IF Count = 32767 THEN Count = 1
LOOP WHILE INKEY$ = ""
SYSTEMRE: USA Flag - Dimster - 04-22-2022
Star for the District of Columbia is likely on the back of the flag???
RE: USA Flag - Pete - 04-22-2022
(04-22-2022, 06:53 PM)Dimster Wrote: Star for the District of Columbia is likely on the back of the flag???
Right, cozzied up nicely next to the star for Purto Rico!
Pete
RE: USA Flag - SierraKen - 04-23-2022
Very cool Vince. I still have your older one, but this one is side to side, not top and bottom. The shading is perfect.
Very neat Pete. I like the glimmer effect.
Here is my U.S. Flag from 2020, and also code by someone named rattrapmax6.
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 a little help on the hills!
'Thank you also to someone named rattrapmax6 for the waving code.
_Title "U.S. Flag - Use space bar to change hills background."
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
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
hour$ = Left$(Time$, 2)
hour = Val(hour$)
If hour < 21 And hour >= 6 Then
Paint (2, 2), _RGB32(0, 205, 255)
End If
_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
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