06-29-2022, 06:10 PM
not a whole re-write yet but a change to the moon generating code that I haven't shoved into place yet.
Code: (Select All)
'a better moon 2
'going to be doing a rewrite of alienskies
'here's a slightly more interestign moon
'press Q to quit
' this is just a piece of larger program so it's got a few biases that don't make sense in a solor demo
Dim Shared imgmax_x, imgmax_y, MS&, cp&
Dim Shared nopaint As _Unsigned Long
imgmax_x = 800
imgmax_y = 600
Randomize Timer
MS& = _NewImage(imgmax_x, imgmax_y, 32)
cp& = _NewImage(imgmax_x, imgmax_y, 32)
Screen MS&
nopaint = Point(1, 1)
Do
Cls
_Limit 1
bettermoon
_Display
A$ = InKey$
Loop Until A$ = "q"
Sub bettermoon
mx = 200 + Int(Rnd * 200)
my = 150 + Int(Rnd * 150)
' mx = Int(Rnd * (imgmax_x / 2)) + (imgmax_x / 4)
' my = Int(Rnd * (imgmax_y / 2)) + (imgmax_x / 4)
mc = Int(Rnd * 100) + 1: mm = Int(Rnd * 100) + 1: my = Int(Rnd * 100) + 1: mk = Int(Rnd * 100) + 1:
mklr& = cmyk~&(mc, mm, my, mk)
' moonsize = Int(((Rnd * 200) + (Rnd * 200)) / 2)
moonsize = Int(((Rnd * 200) + 50 + (Rnd * 200) + 50) / 2)
orb mx, my, moonsize, mklr&, 1.8
_Dest cp&
orb mx, my, moonsize, mklr&, 1.8
_Dest MS&
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)
moonshadow mx, my, moonsize, mklr&
End Sub
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
lighten_cmyk 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 ACircleFill (CX As Long, CY As Long, R As Long, C As _Unsigned 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
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
Function craters (mx, my, mrd, mk&)
' put craters on those moons
crmax = mrd * .24
numk = Int(Rnd * 24) + 12
_Dest cp&
'Line (0, 0)-(img_maxx - 1, img_maxy - 1), _RGB32(0, 0, 0) ' <---- why isn't this overwritng the old image on cp&
For k = 1 To numk
crad = Int(Rnd * crmax) + 1
cgominx = mx - mrd + crad: cgomax = mx + mrd - crad
cgominy = my - mrd + crad: cgomay = my + mrd - crad
cx = Int(Rnd * (cgomax - cgominx)) + cgominx + 1
cy = Int(Rnd * (cgomay - cgominy)) + cgominy + 1
nk& = mk&
orb cx, cy, crad, nk&, 1.9
Next k
_Dest MS&
cratercopy mx, my, mrd
_Dest cp&
Cls
_Source MS&
_Dest MS&
craters = numk
End Function
Sub cratercopy (CX As Long, CY As Long, R As Long)
'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
_Source cp&
_Dest MS&
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
dotc& = Point(tx, CY)
If dotc& <> nopaint Then PSet (tx, CY), dotc& 'drawing each point in the line because color can change from pixel to pixel
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
dotc& = Point(tx, CY - X)
If dotc& <> nopaint Then PSet (tx, CY - X), dotc&
Next tx
For tx = CX - Y To CX + Y
dotc& = Point(tx, CY + X)
If dotc& <> nopaint Then PSet (tx, CY + X), dotc&
Next tx
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
For tx = CX - X To CX + X
dotc& = Point(tx, CY - Y)
If dotc& <> nopaint Then PSet (tx, CY - Y), dotc&
Next tx
For tx = CX - X To CX + X
dotc& = Point(tx, CY + Y)
If dotc& <> nopaint Then PSet (tx, CY + Y), dotc&
Next tx
Wend
_Dest cp&
_Dest MS&
End Sub
Sub moonshadow (mx, my, moonsize, mklr&)
nm = moonsize + Int(Rnd * 30) - (Rnd * 30)
moffx = mx + Int(Rnd * nm) - Int(Rnd * nm)
moffy = my + Int(Rnd * nm) - Int(Rnd * nm)
ACircleFill moffx, moffy, nm, _RGB32(0, 0, 0, 100)
ACircleFill moffx, moffy, (nm * .98), _RGB32(0, 0, 0, 150)
CircleFill moffx, moffy, (nm * .95), _RGB32(0, 0, 0, 254)
End Sub
Function cmyk~& (c As Long, m As Long, y As Long, k As Long)
' CMYK process color Cyan, Magenta, Yellow, Black each expressed as a percent from 0 to 100
r = 255 * (100 - c)
r = (r / 100) * ((100 - k) / 100)
g = 255 * (100 - m)
g = (g / 100) * ((100 - k) / 100)
b = 255 * (100 - y)
b = (b / 100) * ((100 - k) / 100)
cmyk~& = _RGB32(r, g, b)
End Function
Function get_c (klr As _Unsigned Long)
r = _Red32(klr)
c = Int((1 + 1 / 255 - (r / 255)) * 100)
get_c = c
End Function
Function get_m (klr As _Unsigned Long)
g = _Green32(klr)
m = Int((1 + 1 / 255 - (g / 255)) * 100)
get_m = m
End Function
Function get_y (klr As _Unsigned Long)
b = _Blue32(klr)
y = Int((1 + 1 / 255 - (b / 255)) * 100)
get_y = y
End Function
Function get_k (klr As _Unsigned Long)
r = _Red32(klr)
g = _Green32(klr)
b = _Blue32(klr)
c = Int((1 + 1 / 255 - (r / 255)) * 100)
m = Int((1 + 1 / 255 - (g / 255)) * 100)
y = Int((1 + 1 / 255 - (b / 255)) * 100)
If c = m And m = y Then
k = m
Else
k = 0
End If
get_k = k
End Function
Sub get_cmyk (klr As _Unsigned Long, c, m, y, k)
r = _Red32(klr)
g = _Green32(klr)
b = _Blue32(klr)
c = Int((1 + 1 / 255 - (r / 255)) * 100)
m = Int((1 + 1 / 255 - (g / 255)) * 100)
y = Int((1 + 1 / 255 - (b / 255)) * 100)
If c = m And m = y Then
k = m
m = 0
y = 0
c = 0
Else
k = 0
End If
End Sub
Sub lighten_cmyk (klr As _Unsigned Long, pp)
'lightens all four CMYK color channels by the same relative %
r = _Red32(klr)
g = _Green32(klr)
b = _Blue32(klr)
c = Int((1 + 1 / 255 - (r / 255)) * 100)
m = Int((1 + 1 / 255 - (g / 255)) * 100)
y = Int((1 + 1 / 255 - (b / 255)) * 100)
If c = m And m = y Then
k = m
m = 0
y = 0
c = 0
Else
k = 0
End If
c = c * ((100 - pp) / 100)
m = m * ((100 - pp) / 100)
y = y * ((100 - pp) / 100)
k = k * ((100 - pp) / 100)
klr = cmyk~&(c, m, y, k)
End Sub
Sub darken_cmyk (klr As _Unsigned Long, pp)
'lightens all four CMYK color channels by the same relative %
r = _Red32(klr)
g = _Green32(klr)
b = _Blue32(klr)
c = Int((1 + 1 / 255 - (r / 255)) * 100)
m = Int((1 + 1 / 255 - (g / 255)) * 100)
y = Int((1 + 1 / 255 - (b / 255)) * 100)
If c = m And m = y Then
k = m
m = 0
y = 0
c = 0
Else
k = 0
End If
c = c * ((100 + pp) / 100): If c > 100 Then c = 100
m = m * ((100 + pp) / 100): If m > 100 Then m = 100
y = y * ((100 + pp) / 100): If y > 100 Then y = 100
k = k * ((100 + pp) / 100): If k > 100 Then k = 100
klr = cmyk~&(c, m, y, k)
End Sub
Sub add_cyan (klr As _Unsigned Long, cc)
r = _Red32(klr)
g = _Green32(klr)
b = _Blue32(klr)
c = Int((1 + 1 / 255 - (r / 255)) * 100) + cc
m = Int((1 + 1 / 255 - (g / 255)) * 100)
y = Int((1 + 1 / 255 - (b / 255)) * 100)
If c = m And m = y Then
k = m
m = 0
y = 0
c = 0
Else
k = 0
End If
If c > 100 Then c = 100
If c < 0 Then c = 0
klr = cmyk~&(c, m, y, k)
End Sub
Sub add_magenta (klr As _Unsigned Long, mm)
r = _Red32(klr)
g = _Green32(klr)
b = _Blue32(klr)
c = Int((1 + 1 / 255 - (r / 255)) * 100)
m = Int((1 + 1 / 255 - (g / 255)) * 100) + mm
y = Int((1 + 1 / 255 - (b / 255)) * 100)
If c = m And m = y Then
k = m
m = 0
y = 0
c = 0
Else
k = 0
End If
If m > 100 Then m = 100
If m < 0 Then m = 0
klr = cmyk~&(c, m, y, k)
End Sub
Sub add_yellow (klr As _Unsigned Long, yy)
r = _Red32(klr)
g = _Green32(klr)
b = _Blue32(klr)
c = Int((1 + 1 / 255 - (r / 255)) * 100)
m = Int((1 + 1 / 255 - (g / 255)) * 100)
y = Int((1 + 1 / 255 - (b / 255)) * 100) + yy
If c = m And m = y Then
k = m
m = 0
y = 0
c = 0
Else
k = 0
End If
If y > 100 Then y = 100
If y < 0 Then y = 0
klr = cmyk~&(c, m, y, k)
End Sub
Sub add_black (klr As _Unsigned Long, kk)
r = _Red32(klr)
g = _Green32(klr)
b = _Blue32(klr)
c = Int((1 + 1 / 255 - (r / 255)) * 100)
m = Int((1 + 1 / 255 - (g / 255)) * 100)
y = Int((1 + 1 / 255 - (b / 255)) * 100) + yy
If c = m And m = y Then
k = m + kk
m = 0
y = 0
c = 0
Else
k = 0 + kk
End If
If k > 100 Then k = 100
If k < 0 Then k = 0
klr = cmyk~&(c, m, y, k)
End Sub
Function mix_cmyk~& (klr1 As _Unsigned Long, klr2 As _Unsigned Long)
'evenly mix two colors
r1 = _Red32(klr1)
g1 = _Green32(klr1)
b1 = _Blue32(klr1)
c1 = Int((1 + 1 / 255 - (r1 / 255)) * 100)
m1 = Int((1 + 1 / 255 - (g1 / 255)) * 100)
y1 = Int((1 + 1 / 255 - (b1 / 255)) * 100)
If c1 = m1 And m1 = y1 Then
k1 = m1
m1 = 0
y1 = 0
c1 = 0
Else
k1 = 0
End If
r2 = _Red32(klr2)
g2 = _Green32(klr2)
b2 = _Blue32(klr2)
c2 = Int((1 + 1 / 255 - (r2 / 255)) * 100)
m2 = Int((1 + 1 / 255 - (g2 / 255)) * 100)
y2 = Int((1 + 1 / 255 - (b2 / 255)) * 100)
If c2 = m2 And m2 = y2 Then
k2 = m2
m2 = 0
y2 = 0
c2 = 0
Else
k2 = 0
End If
c = Int((c1 + c2) / 2)
m = Int((m1 + m2) / 2)
y = Int((y1 + y2) / 2)
k = Int((k1 + k2) / 2)
mix_cmyk~& = cmyk~&(c, m, y, k)
End Function
Function add_cmyk~& (klr1 As _Unsigned Long, klr2 As _Unsigned Long)
'add channels in each color max vlaue wil be 100 per channel
r1 = _Red32(klr1)
g1 = _Green32(klr1)
b1 = _Blue32(klr1)
c1 = Int((1 + 1 / 255 - (r1 / 255)) * 100)
m1 = Int((1 + 1 / 255 - (g1 / 255)) * 100)
y1 = Int((1 + 1 / 255 - (b1 / 255)) * 100)
If c1 = m1 And m1 = y1 Then
k1 = m1
m1 = 0
y1 = 0
c1 = 0
Else
k1 = 0
End If
r2 = _Red32(klr2)
g2 = _Green32(klr2)
b2 = _Blue32(klr2)
c2 = Int((1 + 1 / 255 - (r2 / 255)) * 100)
m2 = Int((1 + 1 / 255 - (g2 / 255)) * 100)
y2 = Int((1 + 1 / 255 - (b2 / 255)) * 100)
If c2 = m2 And m2 = y2 Then
k2 = m2
m2 = 0
y2 = 0
c2 = 0
Else
k2 = 0
End If
c = c1 + c2: If c > 100 Then c = 100
m = m1 + m2: If m > 100 Then m = 100
y = y1 + y2: If y > 100 Then y = 100
k = k1 + k2: If k > 100 Then k = 100
add_cmyk~& = cmyk~&(c, m, y, k)
End Function