3D Planet Builder

[c4s]

Looked kinda strange the result but reducing #WorldSize worked. Thanks idle!

[electrochrisso]

Yes this does the trick idle.
I get a reasonable result with #WorldSize=2048.
I will do more testing and see how high I can go, I suspect it will need to be a multiple of a base number.

[BasicallyPure]

Added clouds.

[kinglestat]

Nice work!

[Psychophanta]

Nice,
perhaps, in a not far future, there will be needed to build a new planet for real...

[firace]

Adapted original code to run under PB6.03 and high DPI. Thanks BasicallyPure for sharing this beautiful program!

Code: Select all

; ----------------------------
;
; PlanetBuilder.pb V1.04 - by BasicallyPure 12.26.2011
;
; PureBasic 4.60 (x86)
;
; Windows & Linux fullscreen or windowed
; MacOS windowed only
;
; ----------------------------


EnableExplicit

Select MessageRequester("Planet Builder","Open Fullscreen?",#PB_MessageRequester_YesNoCancel)
   Case #PB_MessageRequester_Yes
      Define fullscreen = #True
   Case #PB_MessageRequester_No
      Define fullscreen = #False
   Case #PB_MessageRequester_Cancel
      End
EndSelect

#WorldSize = 2048
#Regolith  = 0 ; material#
#surface   = 0 ; texture#
#Sphere    = 0 ; mesh#
#Planet    = 0 ; entity#

Declare Verify(result,text.s)
Declare MakePlanet(grid.i)

Verify(InitEngine3D(),"Engine3D")
Verify(InitSprite(),"InitSprite")
Verify(InitKeyboard(),"Keyboard")

ExamineDesktops()
Define w = DesktopWidth(0)
Define h = DesktopHeight(0)

If fullscreen
   Verify(OpenScreen(w,h,32,"",#PB_Screen_SmartSynchronization),"OpenScreen")
Else
   w * 0.5 : h * 0.5
   Define flags = #PB_Window_SystemMenu | #PB_Window_ScreenCentered | #PB_Window_MinimizeGadget
   Define text.s = "--- Planet Builder --- Space = new planet, "
   text + ",arrow keys + shift = adjust view, 'Esc' = end"
   Verify(OpenWindow(0,0,0,w,h,text,flags),"OpenWindow")
   Verify(OpenWindowedScreen(WindowID(0),0,0,w*DesktopResolutionX(),h*DesktopResolutionY(),0,0,0),"WindowedScreen")
EndIf

KeyboardMode(#PB_Keyboard_International)

; create a sphere mesh to use as a planet
Define Radius = 5
CreateSphere(#Sphere, Radius, 50, 50)

; make a camera
CreateCamera(0, 0, 0, 100, 100)
MoveCamera(0, 0, 0, 15)
; CameraX
; let there be light
AmbientColor(RGB(15,15,15))
CreateLight(0,RGB(255,255,255),-500,0,500)

SetFrameRate(30)

Define event
Define.f KeyX, KeyY, KeyZ, CamZ

Repeat ;******* main program loop ********
   MakePlanet(#False) ;#True/#False = turn grid on/off
   
   ; create regolith material from the finished surface texture
   CreateMaterial(#Regolith, TextureID(#surface))
   
   ; create a planet entity from the mesh and material
   CreateEntity(#Planet, MeshID(#Sphere), MaterialID(#Regolith))
   
   RotateEntity(#Planet, 0, 0, -10, #PB_Absolute)
   
   Repeat ;event loop
      If fullscreen = #False
         Repeat
            event = WindowEvent()
            If event = #PB_Event_CloseWindow
               End
            EndIf
         Until Not event
      EndIf
      
      If ExamineKeyboard()
         KeyX = 0 : KeyY = 0 : KeyZ = 0 : CamZ = 0
         If KeyboardPushed(#PB_Key_Left)
            If KeyboardPushed(#PB_Key_LeftShift) Or KeyboardPushed(#PB_Key_RightShift)
               KeyZ = -1
            Else
               KeyY = -1
            EndIf
         ElseIf KeyboardPushed(#PB_Key_Right)
            If KeyboardPushed(#PB_Key_LeftShift) Or KeyboardPushed(#PB_Key_RightShift)
               KeyZ = 1
            Else
               KeyY = 1
            EndIf
         ElseIf KeyboardPushed(#PB_Key_Up)
            If KeyboardPushed(#PB_Key_LeftShift) Or KeyboardPushed(#PB_Key_RightShift)
               KeyX = -1
            Else
               CamZ = -0.25
            EndIf
         ElseIf KeyboardPushed(#PB_Key_Down)
            If KeyboardPushed(#PB_Key_LeftShift) Or KeyboardPushed(#PB_Key_RightShift)
               KeyX = 1
            Else
               CamZ = 0.25
            EndIf
         EndIf
      EndIf
     
      RotateEntity(#Planet, KeyX, 0.1 + KeyY,KeyZ, #PB_Relative)
     
      MoveCamera(0, 0, 0, CamZ) ;zoom in/out
     
      RenderWorld()
      FlipBuffers()
     
      If KeyboardPushed(#PB_Key_Escape)
         End
      EndIf
     
   Until KeyboardReleased(#PB_Key_Space)
ForEver

Procedure MakePlanet(grid.i)
   ; creates a planet surface texture
   
   Protected MapSize = #WorldSize - 1
   Protected equator = Int(MapSize/2)
   Protected arcticCircle = Sqr(MapSize)*16
   Protected sealevel.a = 128
   Protected mtntop.a = 192
   Protected seafloor.a = 64
   Protected m, n, x, y
   Protected Linux.i = #False
   
   CompilerIf #PB_Compiler_OS = #PB_OS_Linux Or #PB_Compiler_OS = #PB_OS_MacOS
      Linux = #True
   CompilerEndIf
   
   ; create array for MapSize * MapSize surface map
   ; x = longitude, y = latitude
   ; elements represent altitude ranging from 0 to 255
   Dim Alt.a(MapSize,MapSize)
   Dim CloudMap.a(MapSize,MapSize)
   
   ; ------------------------------------------------------
   Protected bias.i = 2 ; must be >= 1
   Protected Amp = 11 ; must be >= 2*bias
   Protected halfway.f = Amp / 2.0
   
   Macro SteerAltitude(elevation, TargetArray = Alt)
      If elevation > mtntop
         n = Amp - bias
      ElseIf elevation < seafloor
         n = Amp + bias
      Else
         n = Amp
      EndIf

      elevation + Random(n) - halfway
      
      TargetArray#(x,y) = elevation
   EndMacro
   ; -------------------------------------------------------
   
   
   ;-- assign altitude values for the map edges ------------
   Protected Rref.a = sealevel + Random(128) - 64
   Protected Lref.a = sealevel
   Protected Tref.a = sealevel + Random(128) - 64
   Protected Bref.a = sealevel + Random(128) - 64
   
   For m = 0 To MapSize
      x = 0 : y = m ;left edge
      SteerAltitude(Lref) : CloudMap(x,y) = Lref
      x = MapSize ;right edge
      SteerAltitude(Rref) : CloudMap(x,y) = Rref
      x = m : y = 0 ;top edge
      SteerAltitude(Tref) 
      y = MapSize ;bottom edge
      SteerAltitude(Bref)
   Next
   ; -------------------------------------------------------
   
   
   ;-- assign altitude values for the remaing elements -----
   Protected altitude.a
   Protected dir, stop
   x = MapSize - 1 : dir = -1 : stop = 0
   For y = 1 To equator
      dir = -dir : stop = MapSize - stop : x = MapSize - stop + dir
      Repeat
         altitude = (Alt(x-dir,y) + Alt(x,y-1)) >> 1
         SteerAltitude(altitude)
         y = MapSize - y ;switch hemisphere
         altitude = (Alt(x-dir,y) + Alt(x,y+1)) >> 1
         SteerAltitude(altitude)
         y = MapSize - y ;restore y
         x + dir
      Until x = stop
   Next
   ; -------------------------------------------------------
   
   ;-- assign altitude values for CloudMap -----------------
   seafloor = mtntop - seafloor
   y = MapSize - 1 : dir = -1 : stop = 0
   For x = 1 To MapSize
      dir = -dir : stop = MapSize - stop : y = MapSize - stop + dir
      Repeat
         altitude = (CloudMap(x,y-dir) + CloudMap(x-1,y)) >> 1
         SteerAltitude(altitude,CloudMap)
         y + dir
      Until y = stop
   Next
   seafloor = mtntop - seafloor ;restore seafloor to former level
   ; --------------------------------------------------------
   
   
   ;--- magic seam eraser  ---------------------------------
   Protected avg.a, ratio.f
   
   Macro SeamEraser(TargetArray)
      For y = 0 To MapSize
         n = MapSize
         For x = 0 To 50
            avg = (TargetArray(x,y) + TargetArray(n,y)) >> 1
            ratio = x / 50
            TargetArray(x,y) = TargetArray(x,y) * ratio + avg*(1 - ratio)
            TargetArray(n,y) = TargetArray(n,y) * ratio + avg*(1 - ratio)
            n - 1
         Next
      Next
   EndMacro
   
   ;erase longitude seam & cloud seam
   SeamEraser(Alt)
   SeamEraser(CloudMap)
   
   ;erase equator seam
      Protected startY = equator + 1
      Protected endY = startY + 100
      For x = 0 To MapSize
         n = equator
         For y = startY To endY
            avg = (Alt(x,y) + alt(x,n)) >> 1
            ratio = (y-startY) / 100
            Alt(x,y) = Alt(x,y)*ratio + avg*(1 - ratio)
            Alt(x,n) = Alt(x,n)*ratio + avg*(1- ratio)
            n - 1
         Next
      Next
   ; ---------------------------------------------------------
   
   ;-- make craters ------------------------------------
   Protected distance.f, latAbsf.f
   Protected Cx, Cy, s, radius.i
   Protected scale = MapSize / 50
   
   For m = 0 To Random(scale) + scale ;set number of craters
      radius = 3 + Random(scale) ;crater size
      Cx = Random(MapSize) ;define crater location
      Cy = Radius << 1 + Random(MapSize - Radius << 2) ;keey away from poles
      For y = cy - radius << 1 To cy + radius << 1
         latAbsf = Abs(y-equator) * #PI / (MapSize - 1) ; absolute latitude in radians
         For s = cx - radius << 1 To cx + radius << 1
            distance = Sqr((cx-s)*(cx-s)*4*Cos(latAbsf) + (cy-y)*(cy-y))
            
            ;allow longitude seam crossing
            If s > MapSize
               x = s - MapSize
            ElseIf s < 0
               x = MapSize + s
            Else
               x = s
            EndIf
            
            ;set crater depth = 15, set rim height = 60/2
            If distance < radius
               altitude = Alt(x,y) - 15 + 60/(radius-distance+2)
            Else
               altitude = Alt(x,y) + 60/(distance-radius+2)
            EndIf
            
            SteerAltitude(altitude)
         Next
      Next
   Next
   ; ------------------------------------------------------
   
   ; --- make grid (optional) -----------------------------
   If grid
      Protected Inc.f = MapSize / 24.0
      Protected xf.f, yf.f
      yf = 0
      Repeat
         xf = 0
         Repeat
            Alt(Int(xf),Int(yf)) = 255
            Alt(Int(yf),Int(xf)) = 255
            xf + 1
         Until xf > MapSize
         yf + Inc
      Until yf > MapSize
   EndIf
   ; --------------------------------------------------------
   
   ;--- averaging (pucker) filter for polar regions ---------
   Protected sum, poleLat = MapSize - equator
   Protected latAbs, boundry = poleLat * 0.8

   For y = 0 To MapSize
      latAbs = Abs(poleLat-y)
      If latAbs > boundry
         sum = 0
         For x = 0 To MapSize
            sum + Alt(x,y)
         Next
         avg = sum / MapSize
         ratio = (poleLat-latAbs) / (poleLat-boundry)
         For x = 0 To MapSize
            Alt(x,y) = (Alt(x,y)*ratio + avg*(1-ratio))
         Next
      EndIf
   Next
   ; -------------------------------------------------------------
   
   
   If IsTexture(#surface)
      FreeTexture(#surface)
   EndIf
   
   CreateTexture(#surface,#WorldSize,#WorldSize)
   
   ; -------------------------------------------------------------
   StartDrawing(TextureOutput(#surface))
   
   Protected snow, latitude
   Protected.a red, green, blue
   For y = 0 To MapSize ;y = latitude
      For x = 0 To MapSize ;x = longitude
         
         If CloudMap(x,y) > sealevel + 48
            altitude = CloudMap(x,y) + 16
            red = altitude : Green = altitude : blue = altitude
         Else
            altitude = Alt(x,y)
            latitude = Abs(y - equator)
            If altitude >> 1 + latitude + 128 > arcticCircle ;snow
               snow = altitude/3 + 170
               red = snow : green = snow : blue = snow
            Else
               If altitude < sealevel ;water
                  red = 32 : green = 32 : blue = sealevel + altitude
               ElseIf altitude < (sealevel + 24) ;grass
                  red = 0 : green = altitude : blue = 0
               ElseIf altitude < (sealevel + 48) ;desert
                  red = altitude : green = altitude : blue = altitude >> 1
               ElseIf altitude < mtntop : altitude >> 1 ; rock
                  red = altitude : green = altitude : blue = altitude
               Else ;snow
                  red = altitude : green = altitude : blue = altitude
               EndIf
            EndIf
         EndIf
         
         ; Red and Blue are reversed on Linux textures so deal with it
         If Linux : Swap red, blue : EndIf
         
         Plot(x,y,RGB(red,green,blue))
      Next
   Next
   
   StopDrawing()
   ; -----------------------------------------------------------------
   
EndProcedure

Procedure Verify(result,text.s)
   If result = #False
      text +  " failed To initialize."
      MessageRequester("Error!",text)
      End
   EndIf
   ProcedureReturn result
EndProcedure

[Psychophanta]

@firace, fails in PB6.03 x86

[firace]

@firace, fails in PB6.03 x86

What's the error message?

[firace]

Does anyone know how the sphere's "edges" could be made smoother?

[Psychophanta]

What's the error message?

"Engine3D Failed to initialize"

[marc_256]

@firace

Does anyone know how the sphere's "edges" could be made smoother?

Code: Select all

  #PB_AntialiasingMode_None: No antialiasing (default).
  #PB_AntialiasingMode_x2  : x2 fullscreen antialiasing (FSAA).
  #PB_AntialiasingMode_x4  : x4 fullscreen antialiasing (FSAA).
  #PB_AntialiasingMode_x6  : x6 fullscreen antialiasing (FSAA).

Marc

[firace]

@firace

Does anyone know how the sphere's "edges" could be made smoother?

Code: Select all

  #PB_AntialiasingMode_None: No antialiasing (default).
  #PB_AntialiasingMode_x2  : x2 fullscreen antialiasing (FSAA).
  #PB_AntialiasingMode_x4  : x4 fullscreen antialiasing (FSAA).
  #PB_AntialiasingMode_x6  : x6 fullscreen antialiasing (FSAA).

Marc

Excellent, thanks! I had no idea about these options...

[firace]

What's the error message?

"Engine3D Failed to initialize"

This is usually due to the Engine3d DLL not being found. Are you able to run other 3D codes for the forum?

[Psychophanta]

This is usually due to the Engine3d DLL not being found. Are you able to run other 3D codes for the forum?

https://www.purebasic.fr/english/viewtopic.php?t=82007