iso Earth revisited

User projects written in or related to FreeBASIC.
BasicCoder2
Posts: 3739
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 definesConst Pi = 4 * Atn(1)Dim Shared As single TwoPi = 8 * Atn(1)Dim Shared As single RtoD = 180 / Pi   ' radians * RtoD = degreesDim Shared As single DtoR = Pi / 180   ' degrees * DtoR = radiansscreenres 1280,600,32dim shared as any ptr worldMap2worldMap2 = imagecreate (360,180)worldMap2 = LoadRGBAFile("worldMap3.png")'bload "worldMap3.bmp",worldMap2dim shared as integer posx,posyposx = 640  'position of iso display on screenposy = 300type POINT3D    as integer x    as integer y    as integer z    as ulong   cend typedim shared as integer TOT'==========================================================================dim shared as Point3D abs3D()  'absolute positionsdim shared as Point3D rel3D()  'relative positions after any rotationdim shared as single angle,x,y,z,rx,ry,rz,px,pydim shared as single aRotX,aRotY,aRotZdim shared as single ratioX,ratioY,ratioZaRotX = 245aRotY = 157aRotZ = 304'creates pointsdim as single radiusradius = 80for 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 angle2next angle1'create axis pointsfor 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 + 1next xfor 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 + 1next yfor 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 + 1next z' sub coded by dodicatSub 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 listsub 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 subsub 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 subupdate()dim as single now1now1 = timerdo        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 2loop 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 ptrdeclare function LoadRGBAMemory(byval buffer as const any ptr, byval buffersize as long) as any ptrdeclare function GetLastResult() as const zstring ptrdeclare function SavePNGFile (byval img as any ptr, byval filename as const zstring ptr,byval saveAlpha as boolean=false) as booleanend extern' load (32bit) RGBA image and convert it for 16 bit RGB modefunction 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 RGB16end functionnamespace 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 functionend namespace#endif ' __FBImage_bi__`

worldMap3.png