05-06-2022, 01:24 PM
Cooled off some of the stars (more variance to the color). Added in reflective water, not thrilled with it yet but it's on the path.
Code: (Select All)
' alienskies 0.3
' By James D. Jarvis
' also includes other folks fine code found here https://qb64phoenix.com/forum/index.php
' fun little image genreating program
'now with bad reflective "water "
'
'press q to quit, any othjer key to generate a new image
Dim Shared imgmax_x, imgmax_y, MS&
imgmax_x = 800
imgmax_y = 600
Randomize Timer
MS& = _NewImage(imgmax_x, imgmax_y, 32)
Screen MS&
' "Some images can take a couple seconds to generate"
Do
'Cls
ectocheck = Rnd * 100
If ectocheck < 30 Then ectosky
starfield
moons
acheck = Rnd * 100
If acheck < 60 Then atm& = atmos
hrz = horizon
flatland hrz
gk& = Point(1, hrz)
ocheck = Rnd * 100
If ocheck < 50 Then ocean hrz, atm&, gk&
mcheck = Rnd * 100
If mcheck < 60 Then mountains gk&, hrz
askagain:
ask$ = LCase$(InKey$)
If ask$ = "" Then GoTo askagain
Cls
Loop Until ask$ = "q"
Sub moons
mm = Int(Rnd * 6)
If mm > 0 Then
For m = 1 To mm
mx = Int(Rnd * imgmax_x)
my = Int(Rnd * imgmax_y * .75)
mkr = Int(Rnd * 100) + 50: mkg = Int(Rnd * 100) + 50: mkb = Int(Rnd * 100) + 50
mklr& = _RGB32(mkr, mkg, mkb)
moonsize = Int(((Rnd * 200) + (Rnd * 200)) / 2)
orb mx, my, moonsize, mklr&, 1.8
kk = 1
ccheck = Int(Rnd * 100)
If ccheck < 90 Then
kk = craters(mx, my, moonsize, mklr&)
End If
moonfuzz mx, my, moonsize, mklr&, 10 + (kk * 3)
Next m
End If
End Sub
Sub mountains (gk&, hrz)
gc& = gk&
mh = Int(Rnd * 10) + 2
md = 1
For by = hrz To imgmax_y Step 4
x = 0
Do
If md = -1 Then mh = mh - Int(Rnd * 4)
If mh > 0 Then
Line (x, by - mh)-(x, by), gc&
gc& = gk&
For b = (by - mh + mh / 4) To mh + Int(Rnd * 6)
PSet (x, b), gc&
gc& = brighter(gc&, 13.5)
Next b
End If
If md = 1 Then mh = mh + Int(Rnd * 4) - Int(Rnd * 4)
If mh > 100 Then md = md - 1
x = x + 1
Loop Until x > imgmax_x
Next by
End Sub
Sub ocean (hrz, sk&, gk&)
Dim wx(imgmax_y, 2)
wtr = Int((_Red32(sk&) + _Red32(gk&)) / 3)
wtg = Int((_Green32(sk&) + _Green32(gk&)) / 3)
wtb = Int((_Blue32(sk&) + _Blue32(gk&)) / 3)
wk& = _RGB32(wtr, wtg, wtb)
wk2& = _RGB32(wtr * 1.15, wtg * 1.15, wtb * 1.15)
' wk& = _RGB32(255, 255, 255)
otop = hrz + Int(Rnd * 100)
wrate = (1 + Rnd * 10 / 2)
If otop > imgmax_x Then otop = imgmax_x
wx1 = Int(Rnd * (imgmax_x / 2) * wrate): wx2 = wx1 + Int(((Rnd * (imgmax / 2 + 60)) + 1) * wrate)
For w = otop To imgmax_y
wx1 = wx1 - Int(Rnd * 8): wx2 = wx2 + Int(Rnd * 8)
wx(w, 1) = wx1: wx(w, 2) = wx2
Next w
For w = otop To imgmax_y
Line (wx(w, 1), w)-(wx(w, 2), w), wk&
wx(w, 1) = wx(w, 1) + Int(Rnd * (w / 4)) 'changing these here for the reflection coming up
wx(w, 2) = wx(w, 2) - Int(Rnd * (w / 4))
Next w
For w = otop To imgmax_y
For xx = wx(w, 1) To wx(w, 2)
tk& = Point(xx, (imgmax_y) - (w - horz))
ttr = _Red32(tk&)
ttg = _Green32(tk&)
ttb = _Blue32(tk&)
tta = Int(Rnd * 50) + 25
tk& = _RGBA32(ttr, ttg, ttb, tta)
If Rnd * 4 < 2 Then
PSet (xx, w), tk&
Else
PSet (xx + Int(Rnd * 2) - Int(Rnd * 2), w), tk&
End If
Next xx
Next w
For w = otop To imgmax_y
For xx = wx(w, 1) To wx(w, 2)
wk2& = _RGBA32(wtr * 1.35, wtg * 1.35, wtb * 1.35, Int(Rnd * w / 4) + 50)
PSet (xx, w), wk2&
Next xx
For xx = wx(w, 1) To wx(w, 2) Step 2
tk& = Point(xx, (imgmax_y) - (w - horz))
ttr = _Red32(tk&)
ttg = _Green32(tk&)
ttb = _Blue32(tk&)
tta = Int(Rnd * 50) + 25
tk2& = _RGBA32(ttr * 1.5, ttg * 1.5, ttb * 1.5, tta)
PSet (xx, w), tk2&
Next xx
Next w
End Sub
Function atmos&
'add atmosphereic color
ar = Int(Rnd * 255)
ag = Int(Rnd * 255)
ab = Int(Rnd * 255)
aa = Int(Rnd * 85) + 10
For y = imgmax_y To 0 Step -1
a2 = Int(aa - y / 3)
ak& = _RGBA32(ar, ag, ab, aa - a2)
Line (0, y)-(imgmax_x, y), ak&
Next y
atmos& = _RGBA32(ar, ag, ab, aa)
End Function
Function horizon
maxh = imgmax_y * .5
hh = maxh + (Int(Rnd * 300) + 30)
If hh > imgmax_y Then hh = maxh
horizon = hh
End Function
Sub flatland (hr)
'slap down the ground
fr = Int(Rnd * 185)
fg = Int(Rnd * 185)
fb = Int(Rnd * 185)
lk& = _RGB32(fr, fg, fb)
kc = 0
For y = hr To imgmax_y
Line (0, y)-(imgmax_x, y), lk&
If kc = 4 Then lk& = brighter&(lk&, 1.1)
kc = kc + 1
If kc > 4 Then kc = 0
Next y
End Sub
Function craters (mx, my, mrd, mk&)
' put craters on those moons
' well mostly on the moons sometimes one walks off the edge, that'll get fixed eventually.
crmax = mrd * .2
numk = Int(Rnd * 24) + 12
For k = 1 To numk
crad = Int(Rnd * crmax) + 1
cx = mx + Int(Rnd * crmax * 4) - Int(Rnd * crmax * 4)
cy = my + Int(Rnd * crmax * 4) - Int(Rnd * crmax * 4)
nk& = mk&
orb cx, cy, crad, nk&, 1.9
Next k
craters = numk
End Function
Sub starfield
' generate goofy fuzzy stars
maxstars = Int(Rnd * 6000) + 50
starsize = Int(((Rnd * 3 + 1) + (Rnd * 3 + 1)) / 2)
For s = 1 To maxstars
bc = Int(Rnd * 100 + 155)
sx = Int(Rnd * imgmax_x)
sy = Int(Rnd * imgmax_y)
bb = 0
For sv = 1 To (starsize * starsize)
PSet (sx + Int(Rnd * starsize) - (Rnd * starsize), sy - Int(Rnd * starsize) + Int(Rnd * starsize)), _RGB32(bc - Int(Rnd * 5), bc - Int(Rnd * 5), bc - Int(Rnd * 5))
Next sv
Next s
End Sub
Function brighter& (ch&&, p)
'eventually going to replace this sub with a beter one
r = _Red(ch&&)
b = _Blue(ch&&)
g = _Green(ch&&)
If p < 0 Then p = 0
If p > 100 Then p = 100
p = p / 100
rdif = 255 - r: rc = rdif * p: brr = Int(r + rc): If brr > 255 Then brr = 255
gdif = 255 - g: gc = gdif * p: bgg = Int(g + gc): If bgg > 255 Then bgg = 255
bdif = 255 - b: bc = bdif * p: bbb = Int(b + bc): If bbb > 255 Then bbb = 255
brighter& = _RGB(brr, bgg, bbb)
End Function
Sub orb (XX As Long, YY As Long, Rd As Long, KK As Long, brt As Integer)
'false shaded 3d spheres
Dim nk As Long
nk = KK
ps = _Pi
p3 = _Pi / 3
p4 = _Pi / 4
If Rd < 10 Then ps = _Pi / 6 'so small radius orbs look cool too
rdc = p4 / Rd
For c = 0 To Int(Rd * .87) Step ps
nk = brighter&(nk, brt)
CircleFill XX, YY, Rd - (c), nk
XX = XX + rdc * (c * p3) ' could be fiddled with to move the center of the gradient
YY = YY - rdc * (c * 2 * p4) ' could be fiddled with to move the center of the gradient
Next c
End Sub
Sub CircleFill (CX As Long, CY As Long, R As Long, C As Long)
'sub by SMcNeill makes a filled circle without worrying about using the paint comamnd to fill an empty circle
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Sub moonfuzz (CX As Long, CY As Long, R As Long, C As Long, CHNC As Integer)
'CX and CY are to plot of the circle center R is the radius, c is the primary color, CHNC is the chance for noise to vary from from primary color
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R)
RadiusError = -Radius
X = Radius
Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
'checking to see if we should use the base color or slap down some random noise
For tx = CX - X To CX + X
chance = Rnd * 100
If chance < CHNC Then
dotc = Int(Rnd * 256)
PSet (tx, CY), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84)) 'drawing each point in the line because color can change from pixel to pixel
Else
' dotc = C let the color stay as drawn by orb
End If
Next tx
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
For tx = CX - Y To CX + Y
chance = Rnd * 100
If chance < CHNC Then
dotc = Int(Rnd * 256)
PSet (tx, CY - X), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84))
Else
' dotc = C let the color stay as drawn by orb
End If
Next tx
For tx = CX - Y To CX + Y
chance = Rnd * 100
If chance < CHNC Then
dotc = Int(Rnd * 256)
PSet (tx, CY + X), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84))
Else
' dotc = C let the color stay as drawn by orb
End If
Next tx
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
For tx = CX - X To CX + X
chance = Rnd * 100
If chance < CHNC Then
dotc = Int(Rnd * 256)
PSet (tx, CY - Y), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84))
Else
' dotc = C let the color stay as drawn by orb
End If
Next tx
For tx = CX - X To CX + X
chance = Rnd * 100
If chance < CHNC Then
dotc = Int(Rnd * 256)
PSet (tx, CY + Y), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84))
Else
'dotc = C let the color stay as drawn by orb
End If
Next tx
Wend
End Sub
Sub ectosky
Dim tim&
tim& = _NewImage(400, 300, 32)
_Dest tim&
sh = _Height
sw = _Width
Dim d, dv, vv
d = 1
dv = 1
vv = 1
' replim = Int(Rnd * 12) + 1
replim = 1
nr = 0
Do
tm = Rnd * Timer(.001)
dr = Int(Rnd * 255) + 1: dg = Int(Rnd * 255) + 1: db = Int(Rnd * 255) + 1
w = w + 5 / 83
wave1 = Rnd * 100
wave2 = Rnd * 100
wave3 = Rnd * 100
wave4 = Rnd * 100
If wave1 + wave2 < 100 Then w = w + 2 / 83
If wave3 + wav4 > 180 Then w = w - 3 / 75
If wave1 + wav4 < 40 Then w = w * .35
For y = 0 To sh
'_limit 1000
For x = 0 To sw
vl = Sin(distance(x + tm * w, y, 128, 128) / 8 + w)
If wave1 < 85 Then vl = vl + Sin(distance(x, y, 64, 64) / 8)
If wave2 < 80 Then vl = vl + Sin(distance(x, y + tm / 7, 192, 64) / 7)
If wave3 < 75 Then vl = vl + Sin(distance(x, y, 192, 100) / 8)
If wave4 < 60 Then vl = vl + Sin(distance(x, y, 45 + tm * w, 100) / 8)
If wave4 < 30 And wave1 < 50 Then vl = vl + Sin(distance(x, y, 45 + tm * w, (100 + tm) * w) / 8)
clr = 255 / (1.00001 * Abs(vl))
r = .9 * Abs(clr - dr): g = .4 * Abs(clr - dg): b = .5 * Abs(clr - db)
PSet (x, y), _RGB32(r, g, b)
Next
Next
If w > 1440 Or w < -1440 Then w = 0: d = d * -1
_Limit 6000
nr = nr + 1
Loop Until nr = replim 'genrating a still so we move through a few iterations for the ecto plasma
_PutImage , tim&, MS&
_Dest MS&
_FreeImage tim&
End Sub
Function distance (x1, y1, x2, y2) '//between two points x1,y1 and x2,y2
distance = ((x1 - x2) ^ 2 + (y1 - y2) ^ 2) ^ (.5)
End Function