09-10-2024, 07:42 PM
(This post was last modified: 09-10-2024, 09:58 PM by TerryRitchie.)
Over in one of @bplus threads: https://qb64phoenix.com/forum/showthread.php?tid=272
I was intrigued by his sphere mapping routine. In that thread you can see the process I went through modifying the code attempting to make it faster. Here is what I believe to be the final modified version of bplus' code squeezing as much speed as I could out of it.
The routines use the QB64pe _MEM statements for outright speed. Pay particular attention to the rendering subroutine, RenderSphere. It uses the metacommands $CHECKING:OFF and $CHECKING:ON for an even greater boost in speed. If you are uncomfortable with these metacommands simply REM or remove them.
Documentation on how to use this little library is contained at the top of the code. A demo is also included in the code showing the simplicity of its use.
The .ZIP file below contains the world map image for the demo.
Update: The code below has been modified per NakedApe's discovery of an issue with Mac systems.
I was intrigued by his sphere mapping routine. In that thread you can see the process I went through modifying the code attempting to make it faster. Here is what I believe to be the final modified version of bplus' code squeezing as much speed as I could out of it.
The routines use the QB64pe _MEM statements for outright speed. Pay particular attention to the rendering subroutine, RenderSphere. It uses the metacommands $CHECKING:OFF and $CHECKING:ON for an even greater boost in speed. If you are uncomfortable with these metacommands simply REM or remove them.
Documentation on how to use this little library is contained at the top of the code. A demo is also included in the code showing the simplicity of its use.
The .ZIP file below contains the world map image for the demo.
Update: The code below has been modified per NakedApe's discovery of an issue with Mac systems.
Code: (Select All)
'+----------------------------------------------------------------------------------------------------------------------------------+
'| Fake Sphere Mapping |
'| v2.0 |
'| Terry Ritchie |
'| |
'| 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." |
'| Furthermore, the idea of using a longitude map came from here: http://fredericgoset.ovh/informatique/oldschool/en/spheremap.html |
'| |
'| DOCUMENTATION: |
'| |
'| STEP 1: Create a structure to hold a sphere. |
'| -------------------------------------------- |
'| DIM Mars AS D2SPHERE ' a sphere structure to contain Mars |
'| |
'| |
'| STEP 2: Create the sphere from the structure to be used in later renderings. |
'| ---------------------------------------------------------------------------- |
'| MakeSphere Sphere, Radius, SphereImage |
'| |
'| Sphere - a variable declared as TYPE D2SPHERE |
'| Radius - the desired radius of the rendered output image |
'| Note: passing a value of zero for radius results in the sphere height equaling the height of the texture image |
'| SphereImage - the texture image used to map the surface of the sphere |
'| |
'| Example: MakeSphere Mars, 0, MarsImage ' create a sphere with a height equaling the texture image |
'| |
'| |
'| STEP 3: Render the sphere output image. |
'| --------------------------------------- |
'| RenderSphere Sphere, xOffset |
'| |
'| Sphere - a variable declared as TYPE D2SPHERE and previously processed through the MakeSphere subroutine |
'| xOffset - the x coordinate offset within the texture map image to start rendering |
'| Note: the RenderSphere subroutine will modify xOffset and return the result as needed |
'| |
'| Example: RenderSphere Mars, 0 ' render an output image of the sphere |
'| |
'| |
'| STEP 4: Utilize the rendered image. |
'| ----------------------------------- |
'| The rendered output image will be contained in the sub-variable .Sphere of the variable declared as TYPE D2SPHERE. |
'| |
'| Example: _PUTIMAGE(0, 0), Mars.Sphere ' displayed the rendered sphere |
'| |
'| |
'| STEP 5: Clean up after yourself by removing all memory and image assets associated with the sphere when finished with it. |
'| ------------------------------------------------------------------------------------------------------------------------- |
'| FreeSphere Sphere |
'| |
'| Sphere - a variable declared as TYPE D2SPHERE and previously processed through the MakeSphere subroutine |
'| |
'| Example: FreeSphere Mars ' the sphere is no longer needed |
'| |
'| You can create as many sphere objects as memory allows, that's why it's important to remove unused spheres. |
'| |
'+----------------------------------------------------------------------------------------------------------------------------------+
OPTION _EXPLICIT ' declare those variables son
TYPE D2SPHERE ' 2D MAPPED SPHERE PROPERTIES
Image AS LONG ' texture image to map onto sphere
Sphere AS LONG ' rendered output image
ImageWidth AS INTEGER ' width of image
ImageHeight AS INTEGER ' height of image
mImage AS _MEM ' memory contents of texture image
mSphere AS _MEM ' memory contents of output image
mMap AS _MEM ' memory contents of longitude map
END TYPE
' --------------------------
'| Begin demonstration code |
' --------------------------
DIM Earth AS D2SPHERE ' a sphere structure to display Earth
DIM EarthImage AS LONG ' Earth's texture map
DIM EarthOffset AS INTEGER ' x location of texture map to begin drawing
EarthImage = _LOADIMAGE("worldmap3.png", 32) ' load texture map
MakeSphere Earth, 0, EarthImage ' create the Earth sphere structure
_FREEIMAGE EarthImage ' texture map no longer needed
SCREEN _NEWIMAGE(_WIDTH(Earth.Sphere), _HEIGHT(Earth.Sphere), 32) ' graphics screen same size as output image
EarthOffset = 0 ' reset texture map x offset
DO ' begin demo loop
RenderSphere Earth, EarthOffset ' render the sphere image at x offset
_PUTIMAGE (0, 0), Earth.Sphere ' display the output image
EarthOffset = EarthOffset + 1 ' increment texture map x offset
_DISPLAY ' update screen with changes
LOOP UNTIL _KEYDOWN(27) ' leave when ESC key pressed
FreeSphere Earth ' free all sphere assets
SYSTEM ' return to the operating system
' ------------------------
'| End demonstration code |
' ------------------------
'------------------------------------------------------------------------------------------------------------------------------------------+
SUB FreeSphere (Sphere AS D2SPHERE) ' |
'+-------------------------------------------------------------------------------------------------------------------------------------+
'| Frees all memory and image assets associated with a sphere. Very important to use this to free assets before exiting program! |
'| |
'| Sphere - a user defined type variable as SPHERE |
'+-------------------------------------------------------------------------------------------------------------------------------------+
_MEMFREE Sphere.mMap ' free memory assets
_MEMFREE Sphere.mSphere
_MEMFREE Sphere.mImage
_FREEIMAGE Sphere.Image ' free image assets
_FREEIMAGE Sphere.Sphere
END SUB
'------------------------------------------------------------------------------------------------------------------------------------------+
SUB RenderSphere (Sphere AS D2SPHERE, xOffset AS INTEGER) ' |
'+-------------------------------------------------------------------------------------------------------------------------------------+
'| Renders a sphere's output image (.Sphere) |
'| |
'| Sphere - a user defined type variable as SPHERE |
'| xOffset - x location within texture image to begin (note that this value can be changed by the subroutine and passed back) |
'+-------------------------------------------------------------------------------------------------------------------------------------+
DIM x AS INTEGER ' horizontal counter
DIM y AS INTEGER ' vertical counter
DIM Mapx AS INTEGER ' longitude map x coordinate
DIM Pixel AS _UNSIGNED LONG ' image pixel
DIM MapOffset AS _OFFSET ' memory location within longitude map
DIM SphereOffset AS _OFFSET ' memory location within output image
DIM ImageOffset AS _OFFSET ' memory location within texture image
$CHECKING:OFF
IF xOffset > Sphere.ImageWidth - 1 THEN xOffset = 0 ' reset x offset if needed
y = 0 ' reset vertical counter
DO ' begin vertical loop
MapOffset = Sphere.mMap.OFFSET + (y * Sphere.ImageHeight * 2) ' start of horizontal line within longitude map
SphereOffset = Sphere.mSphere.OFFSET + (y * Sphere.ImageHeight * 4) ' start of horizontal line within output image
ImageOffset = Sphere.mImage.OFFSET + (y * Sphere.ImageWidth * 8) ' start of horizontal line within texture image
x = 0 ' reset horizontal counter
DO ' begin horizontal loop
_MEMGET Sphere.mMap, MapOffset + (x * 2), Mapx ' get x texture coordinate
IF Mapx <> -1 THEN ' valid coordinate?
_MEMGET Sphere.mImage, ImageOffset + (Mapx + xOffset) * 4, Pixel ' yes, get pixel from image
_MEMPUT Sphere.mSphere, SphereOffset + (x * 4), Pixel ' apply pixel to output image
END IF
x = x + 1 ' increment horizontal counter
LOOP UNTIL x = Sphere.ImageHeight ' leave when entire horizontal line processed
y = y + 1 ' increment vertical counter
LOOP UNTIL y = Sphere.ImageHeight ' leave when entire vertical line processed
$CHECKING:ON
END SUB
'------------------------------------------------------------------------------------------------------------------------------------------+
SUB MakeSphere (Sphere AS D2SPHERE, UserRadius AS INTEGER, Image AS LONG) ' |
'+-------------------------------------------------------------------------------------------------------------------------------------+
'| Create a sphere structure to be used later when rendering the sphere. |
'| |
'| Sphere - a user defined type variable as SPHERE |
'| UserRadius - the desired sphere radius (supply a value of zero to use the radius of the image) |
'| BaseImage - the image to be mapped onto the sphere |
'| |
'| Example: MakeSphere Earth, 0, WorldMap ' define sphere using radius of image |
'| |
'| Note: NakedApe on the QB64pe forum noted a change was needed in the code below. |
'| BaseImage = _COPYIMAGE(Image) needed to be changed to _COPYIMAGE(Image, 32) |
'| Without this change the code would not run on a Mac. Thanks to NakedApe for pointing this out. |
'+-------------------------------------------------------------------------------------------------------------------------------------+
CONST HALFPI = 1.570796326794897 ' half of Pi
CONST rPI = .318309891613572 ' Pi reciprocated
DIM TempImage AS LONG ' temporary resizing image if modifying radius
DIM BaseImage AS LONG ' final image to map to sphere
DIM Radius AS SINGLE ' sphere radius
DIM Index AS _UNSIGNED LONG ' array memory offset for each value
DIM sLongitude AS SINGLE ' sine longitude calculation
DIM Longitude AS SINGLE ' longitude calculation
DIM x AS INTEGER ' horizontal counter
DIM y AS INTEGER ' vertical counter
IF UserRadius <> 0 THEN ' use the radius of the base image?
' ------------------------------------------------------------
'| Resize base image to fit passed in radius supplied by user |
' ------------------------------------------------------------
TempImage = _NEWIMAGE((_WIDTH(Image) * UserRadius * 2) / _HEIGHT(Image), UserRadius * 2, 32) ' no, create resized temp image
_PUTIMAGE (0, 0)-(_WIDTH(TempImage) - 1, _HEIGHT(TempImage) - 1), Image, TempImage ' resize base image into temp image
BaseImage = _COPYIMAGE(TempImage) ' copy temp image to base image
_FREEIMAGE TempImage ' remove temp image
ELSE ' yes
BaseImage = _COPYIMAGE(Image, 32) ' copy image to base image
END IF
' --------------------------------
'| Create image and memory assets |
' --------------------------------
Sphere.ImageWidth = _WIDTH(BaseImage) ' get width of base image
Sphere.ImageHeight = _HEIGHT(BaseImage) ' get height of base image
Sphere.Image = _NEWIMAGE(Sphere.ImageWidth * 2, Sphere.ImageHeight * 2, 32) ' create texture image
_PUTIMAGE (0, 0), BaseImage, Sphere.Image ' draw base image left justified on texture image
_PUTIMAGE (Sphere.ImageWidth, 0), BaseImage, Sphere.Image ' draw base image right justified on texture image
Sphere.mImage = _MEMIMAGE(Sphere.Image) ' get memory contents of texture image
Sphere.Sphere = _NEWIMAGE(Sphere.ImageHeight, Sphere.ImageHeight, 32) ' create output image
Sphere.mSphere = _MEMIMAGE(Sphere.Sphere) ' get memory contents of output image
Sphere.mMap = _MEMNEW(Sphere.ImageHeight * Sphere.ImageHeight * 2) ' create longitude array in memory
' -------------------------------------------------------------------
'| Create a longitude map of sphere |
'| The idea of using a translation array comes from this site: |
'| http://fredericgoset.ovh/informatique/oldschool/en/spheremap.html |
' -------------------------------------------------------------------
Radius = Sphere.ImageHeight * .5 ' calculate sphere radius
y = 0 ' reset vertical counter
DO ' begin vetical loop
x = 0 ' reset horizontal counter
DO ' begin horizontal loop
Index = (y * Sphere.ImageHeight + x) * 2 ' memory location within nMap
' -----------------------------------------------------------------
'| (x - radius) = centered x position |
'| (y - radius) = centered y position |
'| (y - radius) / radius = sine latitude |
'| _ASIN((y - radius) / radius) = latitude |
'| radius * COS(_ASIN((y - radius) / radius) = sphere radius |
' -----------------------------------------------------------------
sLongitude = (x - Radius) / (Radius * COS(_ASIN((y - Radius) / Radius))) ' calculate sine longitude of pixel
IF ABS(sLongitude) <= 1 THEN ' is pixel inside the circle?
Longitude = _ASIN(sLongitude) + HALFPI ' yes, complete longitude calculation
_MEMPUT Sphere.mMap, Sphere.mMap.OFFSET + Index, (Longitude * Sphere.ImageWidth * .5) * rPI AS INTEGER ' store image x coor
ELSE ' no, pixel is outside of circle
_MEMPUT Sphere.mMap, Sphere.mMap.OFFSET + Index, -1 AS INTEGER ' mark x coordinate as outside of circle
END IF
x = x + 1 ' increment horizontal counter
LOOP UNTIL x = Sphere.ImageHeight ' leave when entire horizontal line processed
y = y + 1 ' increment vertical counter
LOOP UNTIL y = Sphere.ImageHeight ' leave when entire vertical line processed
END SUB