05-19-2022, 04:29 PM
(05-19-2022, 04:18 PM)bplus Wrote: It does eliminate repeating the last sets of craters being shown with the new set.
Well you have to fix at least that line statement to fix because it is just drawing at pixel (0,0).
Can you narrow down the further error to a single procedure or are you missing some Shared variables being set?
Thanks for the help . I think I have a fix for now, just the tiniest bit of input from someone else can kick me into a useful path, thanks again. I'm placing the base moon render into the cp& as well and moving the CLS in the crater function to a different spot in the data flow and it works so far.
Code: (Select All)
'almost better mooon
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 = 400
my = 300
' mx = Int(Rnd * (imgmax_x / 2)) + (imgmax_x / 4)
' my = Int(Rnd * (imgmax_y / 2)) + (imgmax_x / 4)
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)
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& turned off becasue of the error
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
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
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&)
'this isn't perfect but it works. It's currentyl commented out in the main routine
moffx = mx + Int(Rnd * moonsize) - Int(Rnd * moonsize)
moffy = my + Int(Rnd * moonsize) - Int(Rnd * moonsize)
CircleFill moffx, moffy, moonsize, _RGB32(0, 0, 0)
End Sub