3D Planet Builder

[BasicallyPure]

So here is my try at planet building.

click to see larger image...


Use arrow keys + shift to control view.
Space key to make new planet.

[edit] 12.20.2011
modified crater generation code to allow adjustment of max crater size without consequence.
[edit] 12.21.2011
improved averaging filter for polar regions.
[edit] 12.26.2011
added clouds

Code: Select all

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

CompilerIf #PB_Compiler_OS = #PB_OS_Linux
   If Not Subsystem("OpenGL")
      MessageRequester("Warning :", "Compile With OpenGL subsystem")
      End
   EndIf   
CompilerEndIf

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.8 : h * 0.75
   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,h,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)
CameraLocate(0, 0, 0, 15)

; 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

[infratec]

Hi,

when I start it in window mode it works normal.
When I press space for a new world, than the new world seems like a fish eye on top of the planet,
which changes its size if I zoom in or out.

I use Win XP SP3, also happens on Win 7.

Please check this.

Bernd

Btw.: Nice stuff. But the pole caps are to large brrrrr...

[infratec]

Hi,

it works, when I add

Code: Select all

If IsTexture(#surface) : FreeTexture(#surface) : EndIf
CreateTexture(#surface,#WorldSize,#WorldSize)

Before

Code: Select all

StartDrawing(TextureOutput(#surface))

Bernd

P.S.: The first CreateTexture() can be removed

[luis]

Nice start!

Only complaint is the planets are really all the same, would be nice to get very different planets every time.

But it's good !

Btw.: Nice stuff. But the pole caps ar eto large brrrrr...

"ar eto large" = too large ?

That's true but for contemporary earth only. You don't know where this planet is, where is its star, how much it's tilted, how big it is, if the ice you see is solid water or something else, etc. etc. etc.

[BasicallyPure]

Hi,

it works, when I add

Code: Select all

If IsTexture(#surface) : FreeTexture(#surface) : EndIf
CreateTexture(#surface,#WorldSize,#WorldSize)

Before

Code: Select all

StartDrawing(TextureOutput(#surface))

Bernd

P.S.: The first CreateTexture() can be removed

Thank you,
I have changed the code above.
BTW, when run with Linux the original code did not exibit the problem you described.
I did see the problem with windows but didn't know how to fix it.

B.P.

[jamirokwai]

So here is my try at planet building.

click to see larger image...


Use arrow keys + shift to control view.
Space key to make new planet.

Hi there,

just change Line 154 from

Code: Select all

CompilerIf #PB_Compiler_OS = #PB_OS_Linux

to

Code: Select all

CompilerIf #PB_Compiler_OS = #PB_OS_Linux Or #PB_Compiler_OS = #PB_OS_MacOS

And it works on Mac OS X windowed. Fullscreen doesn't work...
Probably, ogre-fullscreen on Mac OS X is broken (at least on my dual-screen, the demos don't work).

[BasicallyPure]

Hi there,

just change Line 154 from

Code: Select all

CompilerIf #PB_Compiler_OS = #PB_OS_Linux

to

Code: Select all

CompilerIf #PB_Compiler_OS = #PB_OS_Linux Or #PB_Compiler_OS = #PB_OS_MacOS

done

[netmaestro]

Looks great, nice and realistic. Thanks for sharing this good work.

[idle]

added a terrain routine to it but it really needs to be changed to subdivision tessellation routine

Code: Select all

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

CompilerIf #PB_Compiler_OS = #PB_OS_Linux
   If Not Subsystem("OpenGL")
      MessageRequester("Warning :", "Compile With OpenGL subsystem")
      End
   EndIf   
CompilerEndIf

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 = 4096 ;texture size 
#Regolith  = 0 ; material#
#surface   = 0 ; texture#
#Sphere    = 0 ; mesh#
#Planet    = 0 ; entity#

Declare Verify(result.l,text.s)
Declare MakePlanet(Planet.l)

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.8 : h * 0.75
   Define flags.l = #PB_Window_SystemMenu | #PB_Window_ScreenCentered
   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,h,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)
CameraLocate(0, 0, 0, 2000)

; let there be light
AmbientColor(RGB(15,15,15))
CreateLight(0,RGB(255,255,255),-2000,0,2000)

SetFrameRate(30)

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

Repeat
   MakePlanet(#Planet)
   RotateEntity(#Planet, 0, 0, -23.5, #PB_Absolute)
   
   Repeat
      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 = -2.5
            EndIf
         ElseIf KeyboardPushed(#PB_Key_Down)
            If KeyboardPushed(#PB_Key_LeftShift) Or KeyboardPushed(#PB_Key_RightShift)
               KeyX = 1
            Else
               CamZ = 2.5
            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 KeyboardPushed(#PB_Key_Space)
 ForEver
 
Procedure.i createPlanet(Array texture.a(2),size,radius.i,maxHeight.f,nbCols.f,nbRows.f) 
  Protected numImage.i,imSizeX.f,imSizeY.f, height.i,px,py
 Protected x.f,y.f,z.f,u.f,v.f
  Protected numMesh.i,i.i,i2.i,j.i
  Protected v0.i,v1.i,v2.i,v3.i
  Protected scaleY.f
 
  Protected alpha.f,calpha.f,salpha.f
  Protected theta.f,ctheta.f,stheta.f
   
  
  imSizeX = (size-1) 
  imSizeY = (size-1) 
  
  ; Create the mesh
  numMesh = CreateMesh(#PB_Any)
  scaleY = 1/255 * maxHeight  
 
  ; Create the vertices, according to heightmap values
    
  ;alpha = StepAlpha
 For j = 0 To nbRows
    alpha = j * #PI / (nbRows + 1)
    calpha = Cos(alpha)
    salpha = Sin(alpha)

    For i = 0 To nbCols
     
      theta =i * #PI * 2.0 / nbCols
      ctheta = Cos(theta)
      stheta = Sin(theta)
     
      ; x,y,z are the vertex's position on a 1 unit radius sphere
      x = salpha * ctheta
      y = calpha
      z = -salpha * stheta
     
      ; Compute uv coords, and get height from heightmap
      If i < nbCols     
        u = i / nbCols
        v = (1 - y)/2
        px = u*imsizeX
        py = v *imSizeY
        height = texture(px,py)
      Else
        ; This ensures correct wrapping
        u = 1
        v = (1 - y)/2
        py = v * imSizeY
        height = texture(0,py)
      EndIf
     
      ; "Push" the vertex into place
      x * (radius + height * scaleY)
      y * (radius + height * scaleY)
      z * (radius + height * scaleY)
     
      AddMeshVertex(x,y,z)
      MeshVertexColor($FFFFFF)
      MeshVertexTextureCoordinate( u,v )
    Next i
  Next j
  StopDrawing()
 
 
  ; Create the faces
  For j=0 To nbRows - 1
    For i = 0 To nbCols - 1
      v0 = i + j*(nbRows + 1)
      v1 = v0 + 1
      v2 = i + (j+1)*(nbRows + 1)
      v3 = v2 + 1
     
      AddMeshFace(v0, v2, v3 )
      AddMeshFace(v0, v3, v1 )
    Next i
  Next j
 
  ; Finish and normalize the mesh
  FinishMesh()
  NormalizeMesh(numMesh)
 
  ProcedureReturn numMesh
EndProcedure

Procedure MakePlanet(EntityNumber.l)
   ; creates a planet entity
   
   Protected MapSize = #WorldSize - 1
   Protected equator = Int(MapSize/2)
   Protected arcticCircle = mapsize/2 ;Sqr(MapSize)*15
   Protected bias.i = 2 ; must be >= 1
   Protected Amp = 11; ; must be >= 2*bias
   Protected halfway.f = Amp / 2.0
   Protected sealevel.a = 128
   Protected altitude.a = sealevel
   Protected Rref.a = sealevel
   Protected Lref.a = sealevel
   Protected Tref.a = sealevel ;+ Random(32) - 32
   Protected Bref.a = sealevel ;+ Random(32) - 32
   Protected mtntop.a = 192
   Protected seafloor.a = 64
   Protected.l m, n, x, y, dir, stop, sum
   Protected.a red, green, blue
   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 x MapSize surface map
   ; x = longitude, y = latitude
   ; elements represent altitude ranging from 0 to 255
   Dim Alt.a(MapSize,MapSize)
   
   
   Macro SteerAltitude(elevation)
      If elevation > mtntop
         n = Amp - bias
      ElseIf elevation < seafloor
         n = Amp + bias
      Else
         n = Amp
      EndIf

      elevation + Random(n) - halfway
     
      If elevation > 255 : elevation = 255 : EndIf ;511 - elevation : EndIf
      If elevation < 0 : elevation = 0 : EndIf;-elevation : EndIf
     
      Alt(x,y) = elevation
   EndMacro
   
   
   ;-- assign altitude values for the map edges ------------
   For m = 0 To MapSize
      x = 0 : y = m ;left edge
      SteerAltitude(Lref) ;macro
      x = MapSize ;right edge
      SteerAltitude(Rref) ;macro
      y = 0 : x = m ;top edge
      SteerAltitude(Tref) ;macro
      y = MapSize ;bottom edge
      SteerAltitude(Bref) ;macro
   Next
   ; -------------------------------------------------------
   
   
   ;-- assign altitude values for the remaing elements -----
   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) ;macro
         y = MapSize - y ;switch hemisphere
         altitude = (Alt(x-dir,y) + Alt(x,y+1)) >> 1
         SteerAltitude(altitude) ;macro
         y = MapSize - y ;restore y
         x + dir
      Until x = stop
   Next
   ; -------------------------------------------------------
   
   
   ;--- magic seam eraser  ---------------------------------
   
   ;erase longitude seam
   Protected avg.a, ratio.f
   For y = 0 To MapSize
      n = MapSize
      For x = 0 To 50
         avg = (alt(x,y) + alt(n,y)) >> 1
         ratio = x / 50
         alt(x,y) = alt(x,y)*ratio + avg*(1 - ratio)
         alt(n,y) = alt(n,y)*ratio + avg*(1 - ratio)
         n - 1
      Next
   Next
   
   ;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
   ; ---------------------------------------------------------
   
   ;mark the equator - just for fun
   ;For x = 0 To MapSize : alt(x,equator) = 255 : Next
   
   ;--- averaging filter for polar reigons -----------
   Protected latAbs.f, circum.l, blocksize.l
   For y = 0 To MapSize
      latAbs = Abs(y-equator) * #PI / (MapSize - 1) ; absolute latitude in radians
      circum = Cos(latAbs) * MapSize ; circumference in pixels at latitude y
      If circum = 0 : circum = 1 : EndIf
      blocksize = MapSize / circum
      If blocksize > 1
         x = 0
         Repeat
            sum = 0
            For n = x To x + blocksize - 1
               If n > MapSize : blocksize = n - x : n - 1 : Break : EndIf
               sum + Alt(n,y)
            Next
            avg = sum / blocksize
            For n = x To x + blocksize - 1
               Alt(n,y) = avg 
            Next
            x + blocksize
         Until x >= MapSize
      EndIf
   Next
   ; ---------------------------------------------------
   
   
   ;-- make craters ------------------------------------
   Protected distance.f
   Protected Cx, Cy, radius.i
   
   For m = 0 To Random(30) + 30 ;set number of craters
      radius = 5 + Random(15) ;crater size
      Cx = 40 + Random(MapSize-80) ;define crater location
      Cy = 40 + Random(MapSize-80)
      For y = Cy - radius << 1 To Cy + radius << 1
         For x = Cx - radius << 1 To Cx + radius << 1
            distance = Sqr((Cx-x)*(Cx-x)*4 + (Cy-y)*(Cy-y))
            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
   ; --------------------------------------------------
   
   If IsTexture(#surface) : FreeTexture(#surface) : EndIf
   
   CreateTexture(#surface,#WorldSize,#WorldSize)
   
   StartDrawing(TextureOutput(#surface))
   
   Protected snow.l, latitude.l
   For y = 0 To MapSize ;y = latitude
      For x = 0 To MapSize ;x = longitude
         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
               alt(x,y) = sealevel  
             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
         ; 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()
   
   ; create regolith material from the finished surface texture
   CreateMaterial(#Regolith, TextureID(#surface))
   Protected planet 
   planet = createPlanet(Alt(),mapsize,1000,100,255,255)
   
   ; create a planet entity from the mesh and material
   CreateEntity(EntityNumber, MeshID(planet), MaterialID(#Regolith))
   
EndProcedure

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

[BasicallyPure]

Well that certainly adds the third dimension.
The code does crash for me on line 198:

Code: Select all

  FreeImage(numImage)

Removing the line makes it work.
This was with Linux, I haven't tried it with windows.

It does have some problems however:
The water has ridges.
The craters seem to disappear.
Runs slow even with debugger off (which helps a lot).
It must be doing a lot of calculations.

One thing I like about my original simple code is the speed.
It can poop out a lot of planets really fast if you need it.

----------Edit: ----------
OK, I'm impressed. Changing maxHeight to 10 in the createPlanet procedure gives good results.
createPlanet procedure adds a nice smoothing effect to the graphics and it looks more realistic.
----------EndEdit ------

Nice start!
Only complaint is the planets are really all the same, would be nice to get very different planets every time.

That is my thought as well.
A good planet maker should be like a box of chocolates if you know what I mean?
You never know what your going to get!

It wouldn't be that difficult to create some variation simply by changing the water and grass colours to
shades of brown and/or grey. This would simulate a more barren hostile planet.
You could also remove the polar caps and add a lot more craters.

I really would have liked to add clouds to my planet maker but didn't have any good ideas on how to do that.

An atmosphere effect would be nice as well. Maybe this could be achieved by using particle emitters? to
create a fog effect around the perimeter of the planet. It would have to be superimposed over the planet so
it would not move as the planet rotated. I haven't begun to explore particle emitters yet so maybe in the future
I can give it a try.

B.P.

[c4s]

For me idle's code keeps crashing on line 411:

Code: Select all

Plot(x,y,RGB(red,green,blue))  ; ERROR: Outside of drawing area

[Kwai chang caine]

BasicallyPure when i run your jewel, just a word came out of my mouth
SPLENDID !!!


Thanks a lot for this great effect

@IDLE

The code does crash for me on line 198:
FreeImage(numImage)

For me too (VISTA)
And if i comment this line that's works

[luis]

I really would have liked to add clouds to my planet maker but didn't have any good ideas on how to do that.

Probably I would try to generate another layer with clouds on, like a bigger outer sphere, and then draw the original planet inside it. This way the outer layer could move at a different speed and you would get the effect of clouds formations moving on the planet. You could use more than one layer to added realism. The harder part is to generate nice looking clouds.

[electrochrisso]

BasicallyPure when i run your jewel, just a word came out of my mouth
SPLENDID !!!

Couldn't agree more to that one, great coding.
Unfortunately idle mod not work for me either.

[idle]

If it's not running try to reduce the #worldsize maybe you card doesn't support a texture that large
and delete the freeimage() it was left over from when the routine was loading a hightmap.