09-05-2022, 07:37 PM
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 Sub