## iso Earth revisited

User projects written in or related to FreeBASIC.
BasicCoder2
Posts: 3738
Joined: Jan 01, 2009 7:03
Location: Australia

### iso Earth revisited

In this version I have used the redim preserve and also reduced the pixel count from 155,961 to 64,800 by computing how many pixels to set around circles of different diameters. The larger the radius of the circle the more pixels required to join the dots.

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,

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)

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
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)
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)

The above version uses FBImage.bi to load a .png file
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
' put (0,0),jpg,PSET
'
' put (256,0),png,ALPHA

' if img=0 then
' 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))
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__

worldMap3.png