+- 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: Planet View (/showthread.php?tid=858)
Pages:
1
2
Planet View - James D Jarvis - 09-05-2022
Creates randomly generated animations of alien worlds.
Code: (Select All)
' Planet View v0.1
'by James D. Jarvis
'creates animated views of randomly generated worlds
'
' press any key for a new planet, esc to quit
'
Screen _NewImage(800, 600, 32)
Dim Shared map&
Randomize Timer
map& = _NewImage(480, 360, 32)
cloud& = _NewImage(480, 360, 32)
Dim p As _Unsigned Long
Dim alpha$(24), con$(30), roman$(12)
For x = 1 To 24
Read alpha$(x)
Next x
For x = 1 To 30
Read con$(x)
Next x
For x = 1 To 12
Read roman$(x)
Next x
Do
makemap map&
_Source map&
gw = _Width - 1
gh = _Height
_Dest 0
_Source 0
r = Int(40 + Rnd * 240)
r2 = r * r
xc = _Width / 2
yc = _Height / 2
xo = 0
planet$ = alpha$(Int(1 + Rnd * 24)) + "-" + alpha$(Int(1 + Rnd * 24)) + "-" + con$(Int(1 + Rnd * 30)) + " " + roman$(Int(Rnd * 12)) + "-" + Chr$(Int(97 + Rnd * 26))
Do
_Limit 30
_Source map&
_Dest 0
Cls
Print planet$
For y = -r + 1 To r - 1
x1 = Sqr(r2 - y * y)
tv = (_Asin(y / r) + 1.5) / 3
For x = -x1 To x1
tu = (_Asin(x / x1) + 1.5) / 6
_Source map&
p = Point((xo + tu * gw) Mod gw, tv * gh)
PSet (x + xc, y + yc), p
Next x
Next y:
xo = xo + 1
co = co + 1.5
_Display
kk$ = InKey$
Loop Until kk$ <> ""
Loop Until kk$ = Chr$(27)
Data " Alpha","Beta","Gamma","Delta","Epsilon","Zeta"
Data "Eta"," Theta","Iota","Kappa","Lambda","Mu"
Data "Nu","Xi","Omicron 16","Pi","Rho","Sigma"
Data "Tau","Upsilon","Phi","Chi","Psi","Omega"
Data "Aries","Taurus","Gemini","Cancer","Leo","Virgo","Libra","Scorpio","Ophiuchus","Sagitarius"
Data "Capricorn","Pisces","Aquila","Cassiopeia"," Cygnus","Andromeda","Apus","Canis","Centaurus","Cetus"
Data "Corvus","Draco","Fornax","Hydraxis","Tyranus","Zecadus","Voltanis","Adromeda","Rigel","Zaris"
Data "I","II","III","IV","V","VI","VII","VIII","IX","X","XI","XII"
Sub makemap (m&)
Dim mcolor As _Unsigned Long
Dim sea As _Unsigned Long
Dim p As _Unsigned Long
Dim pp(4) As _Unsigned Long
Dim tklr(4, 3) As Long
_Source m&
_Dest m&
'Screen map&
mw = _Width
mh = _Height
rr& = Int(Rnd * 128 + 64)
bb& = Int(Rnd * 128 + 64)
gg& = Int(Rnd * 128 + 64)
mcolor = _RGB32(rr&, gg&, bb&)
Line (0, 0)-(mw, mh), mcolor, BF
mares = Int(Rnd * 60) - 30
icecap = Int(((Rnd * mh + Rnd * mh) / 2) / Int(1 + Rnd * 3))
For y = 0 To mh
For x = 0 To mw
cv = Int(1 + Rnd * 20) + Int(1 + Rnd * 21)
If y < (icecap + Rnd * 8) Then cv = Int(Rnd * 6)
If y > (mh - icecap + Rnd * 8) Then cv = Int(Rnd * 6)
Select Case cv
Case 1, 2, 3, 4
Line (x, y)-(x + Rnd * 6, y + Rnd * 3), _RGB32(Int((rr& - Rnd * 24 + 255) / 2), Int((gg& - Rnd * 24 + 255) / 2), Int((bb& - Rnd * 24 + 255) / 2)), BF
Case 5
r = Int(2 + Rnd * 6)
For cr = 0 To r
Circle (x, y), cr, _RGB32(rr& + cr, gg& + cr, bb& + cr)
Next cr
Case 35
r = Int(2 + Rnd * 24)
For cr = 0 To r
Circle (x, y), cr, _RGB32(Int((rr& - Rnd * 24 + 187) / 2), Int((gg& - Rnd * 24 + 187) / 2), Int((bb& - Rnd * 24 + 187) / 2)), BF
Next cr
Case 9, 10, 11, 12
Line (x, y)-(x + Rnd * 6, y + Rnd * 3), _RGB32(Int((rr& + 12 + Rnd * 64) / 2), Int((gg& + 8 + Rnd * 32) / 2), Int((bb& + 12 + Rnd * 4) / 2)), BF
Case 21
Line (x, y)-(x + Rnd * 6, y + Rnd * 3), mcolor, BF
Case 35
Circle (x, y), Int(2 + Rnd * 6), _RGB32(Int((rr& - Rnd * 24 + 255) / 2), Int((gg& - Rnd * 24 + 255) / 2), Int((bb& - Rnd * 24 + 255) / 2)), BF
End Select
Next
Next
If mares > 0 Then
mbr& = Int((Rnd * 96 + rr&) / 2)
mbg& = Int((Rnd * 96 + gg&) / 2)
mbb& = Int((Rnd * 96 + bb&) / 2)
sea = _RGB32(mbr&, mbg&, mbb&)
For mm = 1 To mares
sx = Rnd * _Width * .75 + 42
sy = icecap * 2 + Rnd * (_Height - icecap * 3)
r = Int(12 + Rnd * 30)
rsqrd = r * r
my = -r
While my <= r
x = Sqr(rsqrd - my * my)
x1 = Int(Rnd * (r - Abs(x)))
x2 = Int(Rnd * (r - Abs(x)))
Line (sx - x - x1, sy + my)-(sx + x + x2, sy + my), sea, BF
If Rnd * 6 < 4.5 Then
For c = 0 To Int(1 + Rnd * x1) Step 0.5
Circle (sx - x - x1, sy + my), c, sea
Next c
End If
If Rnd * 6 < 4.5 Then
For c = 0 To x1 - (Rnd * 3) Step 0.5
Circle (sx + x + x2, sy + my), c, sea
Next c
my = my + 1
End If
Wend
Next mm
End If
bands = Int(Rnd * 39) - 32
If bands > 0 Then
bdiv = mh / bands
y = bands
For b = 1 To bands
y = y + bdiv - Rnd * 6 + Rnd * 6
tbr& = Int((Rnd * 256 + rr&) / 2)
tbb& = Int((Rnd * 256 + gg&) / 2)
tbg& = Int((Rnd * 256 + bb&) / 2)
thick = Int(7 + Rnd * 20)
Line (0, y)-(mw, y + thick), _RGB32(tbr&, tbb&, tbg&, Int(140 + Rnd * 80)), BF
For xn = 0 To thick
reps = Int(2 + Rnd * 5)
For breps = 1 To reps
Line (mw / 2 + Int(Rnd * mw / 2), y)-(mw, y + thick), _RGB32(tbr&, tbb&, tbg&, Int(140 + Rnd * 80)), BF
Next
Next xn
Line (0, y)-(mw, y + thick), _RGB32(200, 200, 200, Int(Rnd * 200 + 40)), BF
Next b
End If
'average the pixels
For y = 1 To mh - 1
For x = 1 To mw - 1
p = Point(x, y)
pp(1) = Point(x + 1, y)
pp(2) = Point(x - 1, y)
pp(3) = Point(x, y - 1)
pp(4) = Point(x, y + 1)
For n = 1 To 4
tklr(n, 1) = _Red32(pp(n))
tklr(n, 2) = _Green32(pp(n))
tklr(n, 3) = _Blue32(pp(n))
Next n
tr& = Int((_Red32(p) + tklr(1, 1) + tklr(2, 1) + tklr(2, 1) + tklr(2, 1)) / 5)
tg& = Int((_Green32(p) + tklr(1, 2) + tklr(2, 2) + tklr(2, 2) + tklr(2, 2)) / 5)
tb& = Int((_Blue32(p) + tklr(1, 3) + tklr(2, 3) + tklr(2, 3) + tklr(2, 3)) / 5)
PSet (x, y), _RGB32(tr&, tg&, tb&)
Next
Next
c = Int(1 + Rnd * 3)
a = Int(Rnd * 200)
If c = 1 Then 'cloud layer is extra blurry
For y = 1 To mh - 1
For x = 1 To mw - 1
p = Point(x, y)
pp(1) = Point(x + 1, y)
pp(2) = Point(x - 1, y)
pp(3) = Point(x, y - 1)
pp(4) = Point(x, y + 1)
For n = 1 To 4
tklr(n, 1) = _Red32(pp(n))
tklr(n, 2) = _Green32(pp(n))
tklr(n, 3) = _Blue32(pp(n))
Next n
tr& = Int((_Red32(p) + tklr(1, 1) + tklr(2, 1) + tklr(2, 1) + tklr(2, 1) + 512) / 7)
tg& = Int((_Green32(p) + tklr(1, 2) + tklr(2, 2) + tklr(2, 2) + tklr(2, 2) + 512) / 7)
tb& = Int((_Blue32(p) + tklr(1, 3) + tklr(2, 3) + tklr(2, 3) + tklr(2, 3) + 512) / 7)
PSet (x, y), _RGB32(tr&, tg&, tb&, Int((a + Rnd * 256) / 2))
Next
Next
End If
'fix the seam - not perfect but it gets it right now and again
For y = 1 To mh
mix = Int(5 + Rnd * 5)
p = Point(mw - mix, y)
PSet (mx, y), p
Next y
End SubRE: Planet View - SierraKen - 09-05-2022
That's just incredible! Thanks James!!
RE: Planet View - James D Jarvis - 09-06-2022
added a few more features.
Code: (Select All)
' Planet View v0.2
'by James D. Jarvis
'creates animated views of randomly generated worlds
'
' press any key for a new planet, esc to quit
'
Screen _NewImage(800, 600, 32)
Dim Shared map&
Randomize Timer
map& = _NewImage(480, 360, 32)
cloud& = _NewImage(480, 360, 32)
Dim p As _Unsigned Long
Dim alpha$(24), con$(30), roman$(12)
For x = 1 To 24
Read alpha$(x)
Next x
For x = 1 To 30
Read con$(x)
Next x
For x = 1 To 12
Read roman$(x)
Next x
Do
makemap cloud&, 1
makemap map&, 0
_Source map&
gw = _Width - 1
gh = _Height
_Dest 0
_Source 0
r = Int(40 + Rnd * 240)
r2 = r * r
xc = _Width / 2
yc = _Height / 2
xo = 0
cd = Int((1 + Rnd * 2) + (1 + Rnd * 2)) - 1
planet$ = alpha$(Int(1 + Rnd * 24)) + "-" + alpha$(Int(1 + Rnd * 24)) + "-" + con$(Int(1 + Rnd * 30)) + " " + roman$(Int(Rnd * 12)) + "-" + Chr$(Int(97 + Rnd * 26))
cnt = 0
Do
_Limit 30
_Source map&
_Dest 0
Cls
Print planet$
For y = -r + 1 To r - 1
x1 = Sqr(r2 - y * y)
tv = (_Asin(y / r) + 1.5) / 3
For x = -x1 To x1
tu = (_Asin(x / x1) + 1.5) / 6
_Source map&
p = Point((xo + tu * gw) Mod gw, tv * gh)
PSet (x + xc, y + yc), p
'uncomment to show cloud deck
'_Source cloud&
' p = Point((co + tu * gw + cd) Mod gw + cd, tv * gh + cd)
' pr& = _Red32(p)
' pg& = _Green32(p)
' pb& = _Blue32(p)
'pa& = Int(64 + Rnd * 64)
' PSet (x + xc, y + yc), _RGB32(pr&, pg&, pb&, pa&)
Next x
Next y:
xo = xo + 1
'uncomment to show seperate cloud deck, seam isnt as cleaned on that
' co = co + 1.5
cnt = cnt + 1
_Display
kk$ = InKey$
'uncomment following lines to have the planets automatically reset
' If cnt > 800 Then
' kk$ = "A"
'cnt = 0
' End If
Loop Until kk$ <> ""
Loop Until kk$ = Chr$(27)
Data " Alpha","Beta","Gamma","Delta","Epsilon","Zeta"
Data "Eta"," Theta","Iota","Kappa","Lambda","Mu"
Data "Nu","Xi","Omicron 16","Pi","Rho","Sigma"
Data "Tau","Upsilon","Phi","Chi","Psi","Omega"
Data "Aries","Taurus","Gemini","Cancer","Leo","Virgo","Libra","Scorpio","Ophiuchus","Sagitarius"
Data "Capricorn","Pisces","Aquila","Cassiopeia"," Cygnus","Andromeda","Apus","Canis","Centaurus","Cetus"
Data "Corvus","Draco","Fornax","Hydraxis","Tyranus","Zecadus","Voltanis","Adromeda","Rigel","Zaris"
Data "I","II","III","IV","V","VI","VII","VIII","IX","X","XI","XII"
Sub makemap (m&, mt)
Dim mcolor As _Unsigned Long
Dim sea As _Unsigned Long
Dim p As _Unsigned Long
Dim pp(4) As _Unsigned Long
Dim tklr(4, 3) As Long
_Source m&
_Dest m&
'Screen map&
mw = _Width
mh = _Height
rr& = Int(Rnd * 128 + 64)
bb& = Int(Rnd * 128 + 64)
gg& = Int(Rnd * 128 + 64)
mcolor = _RGB32(rr&, gg&, bb&)
Line (0, 0)-(mw, mh), mcolor, BF
mares = Int(Rnd * 60) - 30
If mt = 1 Then mares = 0
icecap = Int(((Rnd * mh + Rnd * mh) / 2) / Int(1 + Rnd * 3))
If mt = 1 Then icecap = Int(Sqr(icecap))
For y = 0 To mh
For x = 0 To mw
cv = Int(1 + Rnd * 20) + Int(1 + Rnd * 21)
If y < (icecap + Rnd * 8) Then cv = Int(Rnd * 6)
If y > (mh - icecap + Rnd * 8) Then cv = Int(Rnd * 6)
Select Case cv
Case 1, 2, 3, 4
Line (x, y)-(x + Rnd * 6, y + Rnd * 3), _RGB32(Int((rr& - Rnd * 24 + 255) / 2), Int((gg& - Rnd * 24 + 255) / 2), Int((bb& - Rnd * 24 + 255) / 2)), BF
Case 5
r = Int(2 + Rnd * 6)
For cr = 0 To r
Circle (x, y), cr, _RGB32(rr& + cr, gg& + cr, bb& + cr)
Next cr
Case 35
r = Int(2 + Rnd * 24)
For cr = 0 To r
Circle (x, y), cr, _RGB32(Int((rr& - Rnd * 24 + 187) / 2), Int((gg& - Rnd * 24 + 187) / 2), Int((bb& - Rnd * 24 + 187) / 2)), BF
Next cr
Case 9, 10, 11, 12
Line (x, y)-(x + Rnd * 6, y + Rnd * 3), _RGB32(Int((rr& + 12 + Rnd * 64) / 2), Int((gg& + 8 + Rnd * 32) / 2), Int((bb& + 12 + Rnd * 4) / 2)), BF
Case 21
Line (x, y)-(x + Rnd * 6, y + Rnd * 3), mcolor, BF
Case 35
Circle (x, y), Int(2 + Rnd * 6), _RGB32(Int((rr& - Rnd * 24 + 255) / 2), Int((gg& - Rnd * 24 + 255) / 2), Int((bb& - Rnd * 24 + 255) / 2)), BF
End Select
Next
Next
If mt = 0 And Rnd * 6 < 1.5 Then 'add canals
nopc = Int(3 + Rnd * 8)
For x = 1 To nopc
cy = Int(_Height / 2 + Rnd * _Height * .1)
nx = Int(Rnd * _Width)
sx = Int(Rnd * _Width)
Line (nx, 0)-(nx - sx + nx, cy), _RGB32(rr& * .95, gg& * .9, bb& * .85)
Line (nx - sx + nx, cy)-(sx, _Height), _RGB32(rr& * .95, gg& * .9, bb& * .85)
Next x
nopc = Int(3 + Rnd * (nopc * 2))
For x = 1 To nopc
cx1 = Int(Rnd * _Width)
cx2 = Int(Rnd * _Width)
cx1 = Int(Rnd * _Height)
cx2 = Int(Rnd * _Height)
Line (cx1, cy1)-(cx2, cy2), _RGB32(rr& * .95, gg& * .9, bb& * .85)
Next x
End If
If mt = 0 Then mcc = Rnd * 50
If mt = 1 Then mcc = 0
If mcc < 3 Then 'add megastructures
mr& = Int(Rnd * 200)
mg& = Int(Rnd * 200)
mb& = Int(Rnd * 200)
ma& = Int(120 + Rnd * 60)
ms = 1 + Int(Rnd * 8)
If Rnd * 6 < 2 Then
ms = ms + Int(1 + Rnd * 8)
If Rnd * 6 < 2 Then ms = ms + Int(1 + Rnd * 12)
End If
shapedeg = (360 / Int(3 + Rnd * 9))
mos = 3 + Int(Rnd * 4)
For msr = 1 To ms
cx = Int(Rnd * _Width)
cy = Int(((Rnd * _Height) + (Rnd * _Height)) / 2)
rad = Int(3 + Rnd * 30)
turn = Int(Rnd * 180)
For rr = 0 To rad Step mos
x = rr * Sin(0.01745329 * deg)
y = rr * Cos(0.01745329 * deg)
Line (cx + x, cy + y)-(cx + x, cy + y), _RGB32(mr&, mg&, nb&, ma&)
For deg = turn To turn + 360 Step shapedeg
x2 = rr * Sin(0.01745329 * deg)
y2 = rr * Cos(0.01745329 * deg)
Line -(cx + x2, cy + y2), _RGB32(mr&, mg&, nb&, ma&)
Next
Next rr
Next
End If
If mares > 0 Then
mbr& = Int((Rnd * 96 + rr&) / 2)
mbg& = Int((Rnd * 96 + gg&) / 2)
mbb& = Int((Rnd * 96 + bb&) / 2)
sea = _RGB32(mbr&, mbg&, mbb&)
For mm = 1 To mares
sx = Rnd * _Width * .75 + 42
sy = icecap * 2 + Rnd * (_Height - icecap * 3)
r = Int(12 + Rnd * 30)
rsqrd = r * r
my = -r
While my <= r
x = Sqr(rsqrd - my * my)
x1 = Int(Rnd * (r - Abs(x)))
x2 = Int(Rnd * (r - Abs(x)))
Line (sx - x - x1, sy + my)-(sx + x + x2, sy + my), sea, BF
If Rnd * 6 < 4.5 Then
For c = 0 To Int(1 + Rnd * x1) Step 0.5
Circle (sx - x - x1, sy + my), c, sea
Next c
End If
If Rnd * 6 < 4.5 Then
For c = 0 To x1 - (Rnd * 3) Step 0.5
Circle (sx + x + x2, sy + my), c, sea
Next c
my = my + 1
End If
Wend
Next mm
End If
bands = Int(Rnd * 39) - 32
If bands > 0 Then
bdiv = mh / bands
y = bands
For b = 1 To bands
y = y + bdiv - Rnd * 6 + Rnd * 6
tbr& = Int((Rnd * 256 + rr&) / 2)
tbb& = Int((Rnd * 256 + gg&) / 2)
tbg& = Int((Rnd * 256 + bb&) / 2)
thick = Int(7 + Rnd * 20)
Line (0, y)-(mw, y + thick), _RGB32(tbr&, tbb&, tbg&, Int(140 + Rnd * 80)), BF
For xn = 0 To thick
reps = Int(2 + Rnd * 5)
For breps = 1 To reps
Line (mw / 2 + Int(Rnd * mw / 2), y)-(mw, y + thick), _RGB32(tbr&, tbb&, tbg&, Int(140 + Rnd * 80)), BF
Next
Next xn
Line (0, y)-(mw, y + thick), _RGB32(200, 200, 200, Int(Rnd * 200 + 40)), BF
Next b
End If
'average the pixels
For y = 1 To mh
For x = 1 To mw
p = Point(x, y)
pp(1) = Point(x + 1, y)
pp(2) = Point(x - 1, y)
pp(3) = Point(x, y - 1)
pp(4) = Point(x, y + 1)
For n = 1 To 4
tklr(n, 1) = _Red32(pp(n))
tklr(n, 2) = _Green32(pp(n))
tklr(n, 3) = _Blue32(pp(n))
Next n
tr& = Int((_Red32(p) + tklr(1, 1) + tklr(2, 1) + tklr(2, 1) + tklr(2, 1)) / 5)
tg& = Int((_Green32(p) + tklr(1, 2) + tklr(2, 2) + tklr(2, 2) + tklr(2, 2)) / 5)
tb& = Int((_Blue32(p) + tklr(1, 3) + tklr(2, 3) + tklr(2, 3) + tklr(2, 3)) / 5)
PSet (x, y), _RGB32(tr&, tg&, tb&)
Next
Next
c = Int(1 + Rnd * 3)
If mt = 1 Then c = 1
a = Int(Rnd * 200)
If c = 1 Then 'cloud layer is extra blurry
For y = 1 To mh - 1
For x = 1 To mw - 1
p = Point(x, y)
pp(1) = Point(x + 1, y)
pp(2) = Point(x - 1, y)
pp(3) = Point(x, y - 1)
pp(4) = Point(x, y + 1)
For n = 1 To 4
tklr(n, 1) = _Red32(pp(n))
tklr(n, 2) = _Green32(pp(n))
tklr(n, 3) = _Blue32(pp(n))
Next n
tr& = Int((_Red32(p) + tklr(1, 1) + tklr(2, 1) + tklr(2, 1) + tklr(2, 1) + 512) / 7)
tg& = Int((_Green32(p) + tklr(1, 2) + tklr(2, 2) + tklr(2, 2) + tklr(2, 2) + 512) / 7)
tb& = Int((_Blue32(p) + tklr(1, 3) + tklr(2, 3) + tklr(2, 3) + tklr(2, 3) + 512) / 7)
PSet (x, y), _RGB32(tr&, tg&, tb&, Int((a + Rnd * 256) / 2))
Next
Next
End If
'fix the seam
' For y = 1 To mh
'mix = Int(5 + Rnd * 5)
'p = Point(mw - mix, y)
' PSet (mx, y), p
' Next y
If mt = 1 Then
For y = 1 To mh
mix = Int(5 + Rnd * 5)
For mx = 0 To mix
p = Point(mx, y)
PSet (mw - mx, y), p
Next mx
Next y
End If
End SubRE: Planet View - OldMoses - 09-06-2022
That's amazing stuff there.
RE: Planet View - mnrvovrfc - 09-06-2022
This program should be put on the double, into the "QB64 Samples" library.
I wouldn't have had the patience with all the trigonometry done for the spots and stuff like that on planet surface. Good job J.D.!
RE: Planet View - James D Jarvis - 09-06-2022
Thanks for the compliments. I'd love to take all the credit but the quick spherical mapping is an old routine that has been out for ages. The planet surface is all fairly simple image gen (except for that darn seam). The speed of modern computers really lets QB64 shine.
RE: Planet View - johnno56 - 09-06-2022
VERY cool indeed... Well done!
RE: Planet View - Kernelpanic - 09-08-2022
Quote:Creates randomly generated animations of alien worlds.
Really great! I should really take a look at the graphics under Basic. . . but I'm too lazy for that. That's it!
RE: Planet View - 40wattstudio - 09-10-2022
That is REALLY COOL!!! I feel like the creative envelope of QB64 has just been expanded a little bit further.
RE: Planet View - bplus - 09-10-2022
You 'all know I posted a drawing tool for doing this back in May 24, 2022?
https://staging.qb64phoenix.com/showthread.php?tid=272&pid=2647#pid2647
And see Jarvis comment just after, reply #19 ;-)) good judgement.
All you have to do is provide an image and some x, y, scale specs to the Subroutine.
Here is a shot of Cheese maker image converted into rotating moons:
@dbox looks like QBJS does not like &'s