QB64 Phoenix Edition
trying to draw a better moon - Printable Version

+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Help Me! (https://staging.qb64phoenix.com/forumdisplay.php?fid=10)
+---- Thread: trying to draw a better moon (/showthread.php?tid=438)

trying to draw a better moon - James D Jarvis - 05-19-2022

working on my alienskies program posted elsewhere and I'm trying to develop a better method of rendering the moons so the craters don't jump off the moon. I'm trying a rendering methods where I draw the craters in a separate image  and then I scan that image layer only copying the pixels on that image layer that are inside the space of the moon. That's working but when I attempt to clear the image holding the craters to draw fresh craters it just isn't clearing out the old craters.  I suspect it's in the order of my _dest and _source calls but I'm lost and can't see where the error is. Anyone want to take a look and offer advice I'd really appreciate it?

Code: (Select All)
'not better mooon
'arrggghhhh   ..... why isn't this working????
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) <- the crater paint image
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
    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 because I'm focusing on the problem for now
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
    _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 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


RE: trying to draw a better moon - bplus - 05-19-2022

Missing Dim Shared or setting of the variables that were supposed to black out the last image ie img_maxx and img_maxy.  Also CLS seems to work instead of Line statement:
Code: (Select All)
Function craters (mx, my, mrd, mk&)
    ' put craters on those moons
    crmax = mrd * .24
    numk = Int(Rnd * 24) + 12
    _Dest cp&
    Cls
    '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
    _Source MS&
    _Dest MS&

    craters = numk
End Function


RE: trying to draw a better moon - James D Jarvis - 05-19-2022

I'm still getting incorrect output with the correction you noted.
The original moon is being rendered away. Hmmm.... I probably have a mistake in the logic of the crater copy.

Don't want this:
[Image: image.png]

RE: trying to draw a better moon - bplus - 05-19-2022

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?

RE: trying to draw a better moon - James D Jarvis - 05-19-2022

(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


RE: trying to draw a better moon - bplus - 05-19-2022

Looks good, there is a way to project a flat image onto a sphere, like the map of Earth onto a globe, I'm not sure you want to go that far?

RE: trying to draw a better moon - James D Jarvis - 05-19-2022

(05-19-2022, 04:41 PM)bplus Wrote: Looks good, there is a way to project a flat image onto a sphere, like the map of Earth onto a globe, I'm not sure you want to go that far?

I've been considering it. Not every "moon" in the alien skies has to be a moon like our moon they could be planets with atmospheres and oceans.

And now that I think about it probably would have been a better way to do the craters.

RE: trying to draw a better moon - bplus - 05-21-2022

OK a nice little sub for putting an image into a sphere. I tried with Outline of countries map of Earth image, a couple of Mars images plus 3 plasma images (really cool alien look) but I went to pack it all in a zip and 6.58 MB yikes this forum is never going to allow all that in one pop. So I just made cheese with different colors and bacteria and projected those images into spheres. But go ahead and try with real images!

Cheese + Sphere = Moon
Code: (Select All)
_Title "Cheese + Sphere = Moon, press any 6 times" 'b+ 2022-05-20
Randomize Timer
Const wW = 1280, wH = 720
Screen _NewImage(wW, wH, 32)
_ScreenMove 80, 0
_MouseHide
stars& = _LoadImage("stars.png")
Dim map(1 To 7) As Long
For i = 1 To 7
    map(i) = growCheese&
    _PutImage , map(i), 0
Next
Cls
_PutImage , stars&, 0
projectImagetoSphere map(1), 300, 175, 120
Sleep
projectImagetoSphere map(2), 900, 500, 350
Sleep
projectImagetoSphere map(3), 1175, 525, 90
Sleep
projectImagetoSphere map(4), 100, 350, 120
Sleep
projectImagetoSphere map(5), 700, 500, 120
Sleep
projectImagetoSphere map(6), 640, 200, 180
Sleep
projectImagetoSphere map(7), 400, 540, 151
Sleep

Sub projectImagetoSphere (image&, x0, y0, sr)
    r = _Height(image&) / 2
    iW = _Width(image&)
    iH = _Height(image&)
    scale = sr / r
    For y = -r To r
        x1 = Sqr(r * r - y * y)
        tv = (_Asin(y / r) + 1.5) / 3
        For x = -x1 + 1 To x1
            tu = (_Asin(x / x1) + 1.5) / 6
            _Source image&
            pc~& = Point((xo + tu * iW) Mod wW, tv * iH)
            _Dest 0
            PSet (x * scale + x0, y * scale + y0), pc~&
        Next x
    Next y
End Sub

Function growCheese& () 'make this more self contained than first version, all hole stuff just in here
    curr& = _Dest
    map& = _NewImage(wW, wH, 32)
    _Dest map&
    nHoles = Rnd * 200 + 100: maxHoleLife = 20: maxHoleRadius = Rnd * 10 + 7: tfStart = 1
    Dim hx(nHoles), hy(nHoles), hLife(nHoles)
    For i = 1 To nHoles
        GoSub newHole
    Next
    r = Rnd * 155 + 100: g = Rnd * 255: b = Int(Rnd * 2) * (Rnd * 155 + 100)
    tfStart = 0
    For layr = 1 To 30
        Line (0, 0)-(wW, wH), _RGBA32(r, g, b, 50), BF 'layer of cheese
        For i = 1 To nHoles 'holes in layer
            If hLife(i) + 1 > maxHoleLife Then GoSub newHole Else hLife(i) = hLife(i) + 1
            hx(i) = hx(i) + Rnd * 2 - 1
            hy(i) = hy(i) + Rnd * 2 - 1
            If hLife(i) < maxHoleRadius Then
                radius = hLife(i)
            ElseIf maxHoleLife - hLife(i) < maxHoleRadius Then
                radius = maxHoleLife - hLife(i)
            Else
                radius = maxHoleRadius
            End If
            Color _RGBA32(0, 0, 0, 80)
            fcirc hx(i), hy(i), radius
        Next
    Next
    _Dest curr&
    growCheese& = map&
    Exit Function

    newHole:
    hx(i) = wW * Rnd
    hy(i) = wH * Rnd
    If tfStart Then hLife(i) = Int(Rnd * maxHoleLife) Else hLife(i) = 1
    Return

End Function

'Steve McNeil's  copied from his forum   note: Radius is too common a name
Sub fcirc (CX As Long, CY As Long, R As Long)
    Dim subRadius As Long, RadiusError As Long
    Dim X As Long, Y As Long

    subRadius = Abs(R)
    RadiusError = -subRadius
    X = subRadius
    Y = 0

    If subRadius = 0 Then PSet (CX, CY): Exit Sub

    ' Draw the middle span here so we don't draw it twice in the main loop,
    ' which would be a problem with blending turned on.
    Line (CX - X, CY)-(CX + X, CY), , 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), , BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF
    Wend
End Sub

   

And the infinitely used Stars Image:

RE: trying to draw a better moon - Pete - 05-21-2022

As an ASCII SCRREN 0 guy, I can only offer this ASCII full moon: (_|_)

Hey nice work guys! The one on the left looks very realistic.

Pete