Image to Sphere and Rotate
2 Sample Demos:
Code: (Select All)
_Title "Cheese + Sphere = Moon" '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 2) As Long
For i = 1 To 2
map(i) = growCheese&
_PutImage , map(i), 0
Next
Do While _KeyDown(27) = 0
Cls
For i = 1 To 2
Select Case i
Case 1: x = 300: y = 175: rr = 120
Case 2: x = 900: y = 500: rr = 350
Case 3: x = 1175: y = 525: rr = 90
Case 4: x = 300: y = 540: rr = 151
End Select
xoff = (_Width(map&(i)) + xoff - _Height(map&(i)) / 360) Mod _Width(map&(i))
projectImagetoSphere map(i), x, y, rr, xoff
Next
_Display
_Limit 60
Loop
Sub projectImagetoSphere (image&, x0, y0, sr, xo)
r = _Height(image&) / 2
iW = _Width(image&) - 20
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 iW, 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 + 50: maxHoleLife = 10: 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 SubHere's one with Earth Map and a Grid Image placed over it:
Code: (Select All)
_Title "Image to Sphere" 'b+ 2022-05-23
Randomize Timer
Const wW = 1280, wH = 720
Screen _NewImage(wW, wH, 32)
_ScreenMove 65, 0
'_MouseHide
map& = _LoadImage("worldmap.png")
mw& = _Width(map&)
mh& = _Height(map&)
grid& = _NewImage(mw&, mh&, 32)
_Dest grid&
Color &HFF000000
drawGrid 0, 0, (mw& - 1) / 36, (mh& - 1) / 18, 36, 18
_Dest 0
'Color , &HFFFFFFFF ' test grid
'Cls
'_PutImage (0, 0), grid&, 0
'End
While _KeyDown(27) = 0
_PutImage , map&, 0
_PutImage , grid&, 0
xoff = (xoff + 4) Mod (_Width(map&) + 1)
a = a + _Pi(2 / 320)
x = 640 + 330 * Cos(a): y = 360 + 58 * Sin(a)
projectImagetoSphere map&, x, y, 300, xoff
projectImagetoSphere grid&, x, y, 300, xoff
_Display
_Limit 60
Wend
Sub projectImagetoSphere (image&, x0, y0, sr, xo)
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 iW, tv * iH)
_Dest 0
PSet (x * scale + x0, y * scale + y0), pc~&
Next x
Next y
End Sub
Sub drawGrid (x, y, xs, ys, xn, yn) ' top left x, y, x side, y side, number of x, nmber of y
Dim As Long i, dx, dy
dx = xs * xn: dy = ys * yn
For i = 0 To xn
Line (x + xs * i, y)-(x + xs * i, y + dy)
Next
For i = 0 To yn
Line (x, y + ys * i)-(x + dx, y + ys * i)
Next
End Sub
b = b + ...