Use the Z and X key to rotate world around the poles.
Unlike the other example that had a binary image in the data statements I have instead used a resized image free download from here,
https://all-free-download.com/free-phot ... 31181.html
Code: Select all
chdir exepath()
' needed to load .png image
#include once "FBImage.bi"
'some useful defines
Const Pi = 4 * Atn(1)
Dim Shared As single TwoPi = 8 * Atn(1)
Dim Shared As single RtoD = 180 / Pi ' radians * RtoD = degrees
Dim Shared As single DtoR = Pi / 180 ' degrees * DtoR = radians
screenres 1280,600,32
dim shared as any ptr worldMap2
worldMap2 = imagecreate (360,180)
worldMap2 = LoadRGBAFile("worldMap3.png")
'bload "worldMap3.bmp",worldMap2
dim shared as integer posx,posy
posx = 640 'position of iso display on screen
posy = 300
type POINT3D
as integer x
as integer y
as integer z
as ulong c
end type
dim shared as integer TOT
'==========================================================================
dim shared as Point3D abs3D() 'absolute positions
dim shared as Point3D rel3D() 'relative positions after any rotation
dim shared as single angle,x,y,z,rx,ry,rz,px,py
dim shared as single aRotX,aRotY,aRotZ
dim shared as single ratioX,ratioY,ratioZ
aRotX = 245
aRotY = 157
aRotZ = 304
'creates points
dim as single radius
radius = 80
for angle1 as single = 0 to 179 step 360/(radius*7)
for angle2 as single = 0 to 359 step 360/(radius*7)
redim preserve abs3D(TOT+1)
redim preserve rel3D(TOT+1)
abs3D(TOT).c = point(angle2,angle1,worldMap2)
abs3D(TOT).x = radius * sin((angle1)*DtoR) * cos((angle2)*DtoR)
abs3D(TOT).y = radius * sin((angle1)*DtoR) * sin((angle2)*DtoR)
abs3D(TOT).z = radius * cos((angle1)*DtoR)
TOT = TOT + 1
next angle2
next angle1
'create axis points
for x as single = -250 to 250
redim preserve abs3D(TOT+1)
redim preserve rel3D(TOT+1)
abs3D(TOT).x = x
abs3D(TOT).y = 0
abs3D(TOT).z = 0
abs3D(TOT).c = rgb(255,0,0)
TOT = TOT + 1
next x
for y as single = -250 to 250
redim preserve abs3D(TOT+1)
redim preserve rel3D(TOT+1)
abs3D(TOT).x = 0
abs3D(TOT).y = y
abs3D(TOT).z = 0
abs3D(TOT).c = rgb(0,255,0)
TOT = TOT + 1
next y
for z as single = -250 to 250
redim preserve abs3D(TOT+1)
redim preserve rel3D(TOT+1)
abs3D(TOT).x = 0
abs3D(TOT).y = 0
abs3D(TOT).z = z
abs3D(TOT).c = rgb(0,0,255)
TOT = TOT + 1
next z
' sub coded by dodicat
Sub QsortZ(array() As Point3D,begin As Long,Finish As Ulong)
Dim As Long i=begin,j=finish
Dim As Point3D x =array(((I+J)\2))
While I <= J
While array(I).z > X .z:I+=1:Wend
While array(J).z < X .z:J-=1:Wend
If I<=J Then Swap array(I),array(J): I+=1:J-=1
Wend
If J >begin Then QsortZ(array(),begin,J)
If I <Finish Then QsortZ(array(),I,Finish)
End Sub
'rotate points up to TOT-1 and copy the result to relative list
sub rotatePoints()
dim as single cosAngleX,sinAngleX,angleX
dim as single cosAngleY,sinAngleY,angleY
dim as single cosAngleZ,sinAngleZ,angleZ
angleX = aRotX*DtoR
cosAngleX = cos(angleX)
sinAngleX = sin(angleX)
angleY = aRotY*DtoR
cosAngleY = cos(angleY)
sinAngleY = sin(angleY)
angleZ = aRotZ*DtoR
cosAngleZ = cos(angleZ)
sinAngleZ = sin(angleZ)
'=========================================
dim as single x2,y2,z2,x3,y3,z3
for i as integer = 0 to TOT - 1
x2 = (abs3D(i).x * cosAngleZ) - (abs3D(i).y * sinAngleZ)
y2 = (abs3D(i).x * sinAngleZ) + (abs3D(i).y * cosAngleZ)
x3 = (x2 * cosAngleY) - (abs3D(i).z * sinAngleY)
z2 = (x2 * sinAngleY) + (abs3D(i).z * cosAngleY)
y3 = (y2 * cosAngleX) - (z2 * sinAngleX)
z3 = (y2 * sinAngleX) + (z2 * cosAngleX)
rel3D(i).x = x3
rel3D(i).y = y3
rel3D(i).z = z3
rel3D(i).c = abs3D(i).c
next i
'sort by distance along z axis
Qsortz(rel3D(),Lbound(rel3D),Ubound(rel3D)) '***dodisort code ***
end sub
sub update()
screenlock
cls
'draw points in rel3D list
for i as integer = 0 to TOT-1
circle ((rel3D(i).x - (-rel3D(i).z) + posx), ((rel3D(i).x + (-rel3D(i).z) )/1.5) + posy + rel3D(i).y),1,rel3D(i).c,,,,f
next i
locate 2,1
print " X or Z key to rotate z axis POLES"
print
print " arrow keys to rotate x and y axis"
print
print " Space bar resets orientation to start"
print
print " rotX ";aRotX;" rotY =";aRotY;" rotZ =";aRotZ
screenunlock
end sub
update()
dim as single now1
now1 = timer
do
rotatePoints()
if multikey(&H39) then 'space key to reset all angles of rotation to zero
aRotX = 245
aRotY = 157
aRotZ = 304
while multikey(&H39):wend
end if
'rotate around x axis
if multikey(&H48) then
aRotX = aRotX + 1
if aRotX = 360 then aRotX = 0
end if
if multikey(&H50) then
aRotX = aRotX - 1
if aRotX < 0 then aRotX = 359
end if
'rotate around y axis
if multikey(&H4B) then
aRotY = aRotY + 1
if aRotY = 360 then aRotY = 0
end if
if multikey(&H4D) then
aRotY = aRotY - 1
if aRotY < 0 then aRotY = 359
end if
'rotate around z axis
if multikey(&H2C) then 'Z KEY
aRotZ = aRotZ + 1
if aRotZ = 360 then aRotZ = 0
end if
if multikey(&H2D) then 'X KEY
aRotZ = aRotZ - 1
if aRotZ < 0 then aRotZ = 359
end if
update()
sleep 2
loop until multikey(&H01)
FBImage.bi
Code: Select all
#ifndef __FBImage_bi__
#define __FBImage_bi__
#ifdef __FB_WIN32__
# libpath "lib/win"
#else
# libpath "lib/lin"
#endif
#ifndef __FB_64BIT__
# inclib "FBImage-32-static"
#else
# inclib "FBImage-64-static"
#endif
' Load BMP, PNG, JPG, TGA, DDS from file or memory as FBImage
' screenres 640,480,32 ' <--- RGBA
' var jpg = LoadRGBAFile("test_rgb.jpg")
' put (0,0),jpg,PSET
'
' var png = LoadRGBAFile("test_rgba.png")
' put (256,0),png,ALPHA
' var img = LoadRGBAFile("filenotfound.xxx")
' if img=0 then
' print "error: loading filenotfound.xxx " & *GetLastResult()
' end if
' Save RGB image as PNG
' var ok = SavePNGFile(img,"test_rgb.png")
' Save RGBA image as PNG
' var ok = SavePNGFile(img,"test_rgba.png",true)
extern "C"
declare function LoadRGBAFile(byval filename as const zstring ptr) as any ptr
declare function LoadRGBAMemory(byval buffer as const any ptr, byval buffersize as long) as any ptr
declare function GetLastResult() as const zstring ptr
declare function SavePNGFile (byval img as any ptr, byval filename as const zstring ptr,byval saveAlpha as boolean=false) as boolean
end extern
' load (32bit) RGBA image and convert it for 16 bit RGB mode
function Load16BitRGB(filename as const zstring ptr) as any ptr
#define RGB16(_r,_g,_b) ((((_b) shr 3) shl 11) or (((_g) shr 2) shl 5) or ((_r) shr 3))
var imgSrc = LoadRGBAFile(filename)
if imgSrc=0 then return 0
dim as integer w,h,spitch,dpitch
dim as ubyte ptr s
imageinfo imgSrc,w,h,,spitch,s
var imgDst = ImageCreate(w,h,0,16)
dim as ushort ptr d
imageinfo imgDst,,,,dpitch,d
dpitch shr= 1 ' pitch in bytes to pitch in pixels
for y as integer =1 to h
dim as integer i
for x as integer =0 to w-1
d[x] = RGB16(s[i],s[i+1],s[i+2])
i+=4 ' next source pixel
next
s+=spitch ' next src row
d+=dpitch ' next dst row
next
ImageDestroy imgSrc
return imgDst
#undef RGB16
end function
namespace Base64
static as string*64 B64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" _
& "abcdefghijklmnopqrstuvwxyz" _
& "0123456789+/"
Function EncodeMemory(buffer as any ptr,size as long) As String
#define E0 (S[j] shr 2)
#define E1 (((S[j] and &H03) shl 4) + (S[j+1] shr 4))
#define E2 (((S[j+1] and &H0F) shl 2) + (S[j+2] shr 6))
#define E3 (S[j+2] and &H3F)
dim as long nChars = size
if nChars=0 then return ""
dim as ubyte ptr S=buffer
dim as long j,k,m = nChars mod 3
dim as string r=string(((nChars+2)\3)*4,"=")
nChars-= (m+1)
For j = 0 To nChars Step 3
r[k]=B64[e0] : r[k+1]=B64[e1] : r[k+2]=B64[e2] : r[k+3]=B64[e3]:k+=4
Next
if m then
r[k]=B64[e0] : r[k+1]=B64[e1] : r[k+3]=61
If m = 2 Then r[k+2]=B64[e2] Else r[k+2]=61
end if
return r
#undef E0
#undef E1
#undef E2
#undef E3
End Function
Function DecodeMemory(s As String,byref nBytes as integer) As any ptr
#define P0(p) instr(B64,chr(s[n+p]))-1
dim as long nChars=Len(s)
if nChars<1 then return 0
nBytes=nChars : nChars-=1
dim as ubyte ptr O,buffer=callocate(nBytes)
O=buffer
for n As long = 0 To nChars Step 4
var b = P0(1), c = P0(2), d = P0(3)
if b>-1 then
var a = P0(0) : *O = (a shl 2 + b shr 4) : O+=1
end if
if c>-1 then *O = (b shl 4 + c shr 2) : O+=1
if d>-1 then *O = (c shl 6 + d) : O+=1
next
return buffer
#undef P0
end function
end namespace
#endif ' __FBImage_bi__
