3D Planet Builder

Share your advanced PureBasic knowledge/code with the community.
c4s
Addict
Addict
Posts: 1981
Joined: Thu Nov 01, 2007 5:37 pm
Location: Germany

Re: 3D Planet Builder

Post by c4s »

Looked kinda strange the result but reducing #WorldSize worked. Thanks idle!
If any of you native English speakers have any suggestions for the above text, please let me know (via PM). Thanks!
User avatar
electrochrisso
Addict
Addict
Posts: 980
Joined: Mon May 14, 2007 2:13 am
Location: Darling River

Re: 3D Planet Builder

Post by 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.
PureBasic! Purely one of the best 8)
User avatar
BasicallyPure
Enthusiast
Enthusiast
Posts: 536
Joined: Thu Mar 24, 2011 12:40 am
Location: Iowa, USA

Re: 3D Planet Builder

Post by BasicallyPure »

Added clouds.
BasicallyPure
Until you know everything you know nothing, all you have is what you believe.
kinglestat
Enthusiast
Enthusiast
Posts: 732
Joined: Fri Jul 14, 2006 8:53 pm
Location: Malta
Contact:

Re: 3D Planet Builder

Post by kinglestat »

Nice work!
I may not help with your coding
Just ask about mental issues!

http://www.lulu.com/spotlight/kingwolf
http://www.sen3.net
User avatar
Psychophanta
Addict
Addict
Posts: 4946
Joined: Wed Jun 11, 2003 9:33 pm
Location: Lípetsk, Russian Federation
Contact:

Re: 3D Planet Builder

Post by Psychophanta »

Nice,
perhaps, in a not far future, there will be needed to build a new planet for real... :?
http://www.zeitgeistmovie.com

While world=business:world+mafia:Wend
Will never leave this forum until the absolute bugfree PB :mrgreen:
firace
Addict
Addict
Posts: 899
Joined: Wed Nov 09, 2011 8:58 am

Re: 3D Planet Builder

Post by 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
User avatar
Psychophanta
Addict
Addict
Posts: 4946
Joined: Wed Jun 11, 2003 9:33 pm
Location: Lípetsk, Russian Federation
Contact:

Re: 3D Planet Builder

Post by Psychophanta »

@firace, fails in PB6.03 x86
http://www.zeitgeistmovie.com

While world=business:world+mafia:Wend
Will never leave this forum until the absolute bugfree PB :mrgreen:
firace
Addict
Addict
Posts: 899
Joined: Wed Nov 09, 2011 8:58 am

Re: 3D Planet Builder

Post by firace »

Psychophanta wrote: Sun Dec 03, 2023 5:54 pm @firace, fails in PB6.03 x86
What's the error message?
firace
Addict
Addict
Posts: 899
Joined: Wed Nov 09, 2011 8:58 am

Re: 3D Planet Builder

Post by firace »

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

Image
User avatar
Psychophanta
Addict
Addict
Posts: 4946
Joined: Wed Jun 11, 2003 9:33 pm
Location: Lípetsk, Russian Federation
Contact:

Re: 3D Planet Builder

Post by Psychophanta »

firace wrote: Sun Dec 03, 2023 10:32 pm What's the error message?
"Engine3D Failed to initialize"
http://www.zeitgeistmovie.com

While world=business:world+mafia:Wend
Will never leave this forum until the absolute bugfree PB :mrgreen:
marc_256
Enthusiast
Enthusiast
Posts: 729
Joined: Thu May 06, 2010 10:16 am
Location: Belgium
Contact:

Re: 3D Planet Builder

Post by 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
- every professional was once an amateur - greetings from Pajottenland - Belgium -
PS: sorry for my english I speak flemish ...
firace
Addict
Addict
Posts: 899
Joined: Wed Nov 09, 2011 8:58 am

Re: 3D Planet Builder

Post by firace »

marc_256 wrote: Mon Dec 04, 2023 1:15 pm @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
Addict
Addict
Posts: 899
Joined: Wed Nov 09, 2011 8:58 am

Re: 3D Planet Builder

Post by firace »

Psychophanta wrote: Mon Dec 04, 2023 10:58 am
firace wrote: Sun Dec 03, 2023 10:32 pm 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?
User avatar
Psychophanta
Addict
Addict
Posts: 4946
Joined: Wed Jun 11, 2003 9:33 pm
Location: Lípetsk, Russian Federation
Contact:

Re: 3D Planet Builder

Post by Psychophanta »

firace wrote: Tue Dec 05, 2023 11:10 pm 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
http://www.zeitgeistmovie.com

While world=business:world+mafia:Wend
Will never leave this forum until the absolute bugfree PB :mrgreen:
Post Reply