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

Postby BasicCoder2 » Dec 06, 2020 5:55

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


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
' 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__


worldMap3.png
Image

Return to “Projects”

Who is online

Users browsing this forum: No registered users and 4 guests