09-06-2022, 12:05 AM
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 Sub