+1 @TerryRitchie for deep dive into this, specially impressed getting with Paul Dunn!
Terry, do you think that seam between Asia and Americas is from not precise 2:1 ratio of image?
I am suspecting that seam is why I did not switch the 3 and 6 back to 3.1415... and 2*Pi.
As it stands, no offense but it is kinda yucky.
The Red and White checkered glode seems fine! and good speed on both.
For everyone's convenience I've got all relevant files zipped into a project folder for easy download and viewing.
I added a modified version of Terry's Update version demo dressed up a tiny bit.
Update: On my mod of Terry's demo of his update Image2Sphere, escape refused to work even with a _keyclear so to exit the last demo use spacebar.
Someone, @SMcNeill might know, why _keydown(32) works fine but _Keydown(27) doesn't even with _KeyClear???
PS thanks @vince
Update: well _Keyclear doen't work with _Keydown for one thing! Maybe the code was running so fast that the last escape keypress was still being held down when we hit the loop code.
So a _delay to get free of the last escape keypress
EDIT: 9/7/2024 fixed bplus mod code of the last demo so now you can use escape for all demos.
Terry, do you think that seam between Asia and Americas is from not precise 2:1 ratio of image?
I am suspecting that seam is why I did not switch the 3 and 6 back to 3.1415... and 2*Pi.
As it stands, no offense but it is kinda yucky.
The Red and White checkered glode seems fine! and good speed on both.
For everyone's convenience I've got all relevant files zipped into a project folder for easy download and viewing.
I added a modified version of Terry's Update version demo dressed up a tiny bit.
Update: On my mod of Terry's demo of his update Image2Sphere, escape refused to work even with a _keyclear so to exit the last demo use spacebar.
Someone, @SMcNeill might know, why _keydown(32) works fine but _Keydown(27) doesn't even with _KeyClear???
PS thanks @vince
Update: well _Keyclear doen't work with _Keydown for one thing! Maybe the code was running so fast that the last escape keypress was still being held down when we hit the loop code.
So a _delay to get free of the last escape keypress
Code: (Select All)
Option _Explicit
_Title "bplus mod TerryRitchie Sphere2Image Update.bas" ' b+ 2024-09-06
Const wW = 800 ' screen width
Const wH = 600 ' screen height
Dim map As Long ' world map image
Dim Sphere As Long ' returned sphere image
Dim xoff As Integer ' map image x offset
Dim x As Integer ' counter
Dim y As Integer ' counter
Dim PaintNow As Integer ' paint toggle
Screen _NewImage(wW, wH, 32)
' ---------------------------------
_Title "PRESS ESC TO MOVE THROUGH DEMOS" ' bplus mod
' ---------------------------------
' Spinning sphere example
map = _LoadImage("worldmap.png", 32)
While _KeyDown(27) = 0 ' ESC key pressed?
xoff = (xoff + 1) Mod (_Width(map) + 1) ' no, rotate left (can't go right because of MOD use)
Image2Sphere map, Sphere, 100, xoff ' map image to sphere
_PutImage (300, 200), Sphere ' bplus mod
_Display
_Limit 60
Wend
_FreeImage map
_AutoDisplay
Cls
' Static spehere demo
map = _NewImage(600, 600, 32) ' create a red/white checkerboard image
_Dest map
Cls , _RGB32(255, 255, 255)
For y = 0 To 599 Step 30
If y / 30 Mod 2 = 0 Then PaintNow = 1 Else PaintNow = 0
For x = 0 To 599 Step 30
PaintNow = 1 - PaintNow
If PaintNow Then Line (x, y)-(x + 29, y + 29), _RGB32(255, 0, 0), BF
Next x
Next y
_Dest 0
Image2Sphere map, Sphere, 0, -1 ' map image to sphere without resizing (1 to 1 image to sphere)
_PutImage (0, 0), Sphere
Sleep
Cls
_Delay .5 ' <<<< get your finger off last escape keypress fixed 9/7/2024 !!!!!!!!!!!!
Dim xo As Integer ' bplus mod
While _KeyDown(27) = 0 ' note: _keyclear doesn't do anything for _Keydown
xo = xo + 1
Image2Sphere map, Sphere, 100, xo ' map image to sphere with resizing
_PutImage (300, 200), Sphere
Wend
'------------------------------------------------------------------------------------------------------------------+
Sub Image2Sphere (InImage As Long, OutImage As Long, Radius As Integer, xo As Integer) ' |
'+-------------------------------------------------------------------------------------------------------------+
'| Fake Sphere Mapping |
'| |
'| Adapted from code by bplus: https://qb64phoenix.com/forum/showthread.php?tid=272&pid=2647#pid2647 |
'| Which was adapted from code by Paul Dunn: https://www.youtube.com/watch?v=0EGDJybA_HE |
'| I contacted Paul Dunn and confirmed that the code in the video above is his original work. |
'| Quote from Paul, "yep, this one is mine, worked out from an algorithm for mapping lat/long to a rectangle." |
'| |
'| Maps an image to a sphere. |
'| |
'| InImage : image passed in |
'| OutImage : processed output image |
'| Radius : sphere radius |
'| xo : input image x offset (supplying a negative value will not scale the input image) |
'| |
'| If you wish to create a rotating image (such as a globe or planet) the input image (InImage) must be twice |
'| as wide as it is high. xo will then control the current view of the image on the sphere. |
'| |
'| If you wish to map an image 1 to 1 onto a sphere then the input image (InImage) must have the same width |
'| and height (a square). xo must be set to a negative value so no scaling occurs. Radius will have no effect |
'| because Radius will be calculated based on the input image. |
'| |
'| Anything other than the two conditions above will yield, let's say, "interesting" effects. |
'| |
'| NOTE: the larger the sphere to be created the slower this algorithm performs. |
'+-------------------------------------------------------------------------------------------------------------+
Const rPI = .31830981 ' value of Pi recipricated
Const rTWOPI = .1591549 ' twice the value of Pi recipricated
Const HALFPI = 1.5707963 ' half the value of Pi
Dim iWidth As Integer ' width of input image
Dim iHeight As Integer ' height of input image
Dim x As Integer ' location along horizontal line within sphere
Dim y As Integer ' vertical location within sphere
Dim LineLength As Integer ' length of horizontal line within sphere
Dim ix As Single ' location of x within scaled image
Dim iy As Single ' location of y within scaled image
Dim oSource As Long ' calling SOURCE
Dim oDest As Long ' calling DESTINATION
Dim ScaledImage As Long ' temporary scaled input image
' -----------------------------------
'| Scale input image to match radius |
' -----------------------------------
If xo < 0 Then ' don't scale image?
ScaledImage = _CopyImage(InImage) ' yes, just make a copy of image
Radius = _Height(ScaledImage) * .5 ' calculate radius
xo = 0 ' reset x offset value
Else ' image needs scaling
ScaledImage = _NewImage(Radius * 4, Radius * 2, 32) ' create scaled image canvas
_PutImage , InImage, ScaledImage ' stretch input image to scaled canvas
End If
iWidth = _Width(ScaledImage) ' width of scaled image
iHeight = _Height(ScaledImage) ' height of scaled image
' ----------------------------
'| Set scaled image as source |
' ----------------------------
oSource = _Source ' get calling source
_Source ScaledImage ' POINT data will be retireved from scaled image
' ----------------------
'| Prepare output image |
' ----------------------
oDest = _Dest ' get calling destination
If OutImage < -1 Then _FreeImage OutImage ' remove residual image if it exists
OutImage = _NewImage(iHeight, iHeight, 32) ' create square output image
_Dest OutImage ' draw on output image
' ---------------------
'| Map image to sphere |
' ---------------------
$Checking:Off
y = -Radius + 1 ' start at top of sphere
Do ' begin vertical loop
LineLength = Sqr(Radius * Radius - y * y) ' calculate line length across sphere at current y location
' -------------------------------------------------------------------
'| We want to use the full height of the scaled image here ( * rPI ) |
'| The value returned here will be 0 to 1 (0% to 100%) |
' -------------------------------------------------------------------
iy = (_Asin(y / Radius) + HALFPI) * rPI ' calculate how far to come down vertically (y) within scaled image
x = -LineLength + 1 ' start at left side of line
Do ' begin horizontal loop
' --------------------------------------------------------------------------
'| We only want to use half the width of the scaled image here ( * rTWOPI ) |
'| The value returned will be 0 to .5 (0% to 50%) |
' --------------------------------------------------------------------------
ix = (_Asin(x / LineLength) + HALFPI) * rTWOPI ' calculate how far to go horizontally (x) within scaled image
' ----------------------------------------------------------------------------------------------------
'| Multiply ix and iy by scaled image width and height to get location of pixel on scaled image. |
'| Then, map that pixel onto the output image within the current horizontal line length. |
' ----------------------------------------------------------------------------------------------------
PSet (x + Radius, y + Radius), Point((xo + ix * iWidth) Mod iWidth, iy * iHeight) ' map scaled image pixel to output image
x = x + 1 ' move one pixel across line to the right
Loop Until x > LineLength - 1 ' leave when right side of line reached
y = y + 1 ' move one pixel down the sphere
Loop Until y > Radius - 1 ' leave when bottom of sphere reached
$Checking:On
' -----------------------------------------
'| Restore original source and destination |
' -----------------------------------------
_FreeImage ScaledImage ' remove temporary scaled image
_Source oSource ' restore calling source
_Dest oDest ' restore calling destination
End SubEDIT: 9/7/2024 fixed bplus mod code of the last demo so now you can use escape for all demos.
b = b + ...