trying to draw a better moon

[bplus]

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: