Générateur de terrains

Programmation avancée de jeux en PureBasic
kelebrindae
Messages : 579
Inscription : ven. 11/mai/2007 15:21

Générateur de terrains

Message par kelebrindae »

Bonjour à tous,

Je poste ce code ici, parce que je ne vois pas trop à quoi il peut servir en dehors d'un jeu, mais c'est plutôt en lien avec ce thread-ci:
http://www.purebasic.fr/french/viewtopic.php?t=8307

Bref. Il s'agit d'un générateur de terrains aléatoires.
A partir d'un nombre quelconque, il génère une heightmap, calcule la pente, la température, détermine le type de "sol" (herbe, forêt, désert, etc.), ajoute une ou deux rivières, et de la glace là où il fait froid.

Vous pouvez vous amuser à changer les moyennes/écarts-types pour modifier la probabilité d'apparition des types de terrain, ou bien juste entrer un "seed" au hasard pour voir ce que ça donne; j'ai eu des résultats intéressants avec ma date de naissance ou mon n° de sécu. :wink:

Que dire de plus... Ah oui:
- Les rivières sont un peu pourries, il faut que je revois ça...
- Le calcul des proba pour les terrains est probablement faux, vu que je l'ai fait de mémoire (mes cours de stat' en Fac sont loin), mais comme ça ne marche pas trop mal, je n'y ai pas touché. Si un puriste veut corriger la formule, aucun problème! :)

Voilà, amusez-vous bien!

[EDIT]: ajout de champs "niveau des océans" et "Baisse de température en fonction de l'altitude".

Code : Tout sélectionner

; Author: Kelebrindae
; Date: july,21, 2008
; PB version: v4.10
; OS: Windows XP

; ---------------------------------------------------------------------------------------------------------------
; Purpose:
; ---------------------------------------------------------------------------------------------------------------
; - Generates an heightmap from a diamond-square + Voronoi algorithm
; - Computes altitude, slope, temperature for each cell of the heightmap
; - Determines what terrain type (grass, forest, mountain, etc.) is predominant
; - Draw an image from these datas
;
; It should look like a (very simple) earth-like map.
;
; ---------------------------------------------------------------------------------------------------------------
; Known Problems:
; ---------------------------------------------------------------------------------------------------------------
; - Rivers algorithm could be better


;- Constants
#e = 2.718281828459045235

Enumeration
  #Window_0
EndEnumeration

Enumeration
  #Image_2
  #Image_1
  #BT_close
  #RS_height
  #RS_slope
  #RS_temp
  #FL_teq
  #teqLabel
  #FL_seed
  #SeedLabel
  #FL_tpol
  #TpolLabel
  #LabelAverage
  #LabelVariance
  #FL_heightAv
  #FL_heightVt
  #FL_tempAv
  #FL_tempVt
  #FL_slopeAv
  #FL_slopeVt
  #heightLabel
  #tempLabel
  #slopeLabel
  #CB_terrain
  #terrainLabel
  #Text_17
  #Text_18
  #RT_terrain
  #BT_redraw
  #FL_sealevel
  #sealevelLabel
  #FL_temploss
  #templossLabel
EndEnumeration

;- Fonts
Global FontID1
FontID1 = LoadFont(1, "Arial", 11)
Global FontID2
FontID2 = LoadFont(2, "Arial Narrow", 48)
Global FontID3
FontID3 = LoadFont(4, "Arial", 11, #PB_Font_Bold)

;- Data structures
Structure VoronoiPoint2D
  x.l
  y.l
  dist.f
EndStructure

Structure geostat_struct
  latitude.f
  slope.l
  temperature.f
  height.l
  probaterrain.f[10]
  isWater.b
  couleur.l
EndStructure

Structure terrain_struct
  name.s
  heightAv.f
  heightVt.f
  slopeAv.f
  slopeVt.f
  temperatureAv.f
  temperatureVt.f
  couleur.l
EndStructure

;- Global definitions
maxgrid = 512 ; must be a power of 2
Global Dim diamond.b(maxgrid,maxgrid)
Global Dim voronoi.b(maxgrid,maxgrid)
Global Dim heightmap.b(6,maxgrid,maxgrid)
Global Dim geostat.geostat_struct(6,maxgrid,maxgrid)
Global Dim terrain.terrain_struct(10)

; Tundra
terrain(1)\name = "Tundra"
terrain(1)\heightAv = 1
terrain(1)\heightVt = 4
terrain(1)\slopeAv = 0
terrain(1)\slopeVt = 2.5
terrain(1)\temperatureAv = 0
terrain(1)\temperatureVt = 1.5
terrain(1)\couleur = $79A700
; Herbe
terrain(2)\name = "Grass"
terrain(2)\heightAv = 1
terrain(2)\heightVt = 3
terrain(2)\slopeAv = 0
terrain(2)\slopeVt = 2
terrain(2)\temperatureAv = 18
terrain(2)\temperatureVt = 3.5
terrain(2)\couleur = $5AD00F
; Forêt
terrain(3)\name = "Forest"
terrain(3)\heightAv = 1.1
terrain(3)\heightVt = 3
terrain(3)\slopeAv = 5
terrain(3)\slopeVt = 3
terrain(3)\temperatureAv = 25
terrain(3)\temperatureVt = 2
terrain(3)\couleur = $3EA300
; Désert
terrain(4)\name = "Desert"
terrain(4)\heightAv = 1.3
terrain(4)\heightVt = 5
terrain(4)\slopeAv = 0
terrain(4)\slopeVt = 1.25
terrain(4)\temperatureAv = 50
terrain(4)\temperatureVt = 2
terrain(4)\couleur = $E5DFAD
; Montagne
terrain(5)\name = "Mountain"
terrain(5)\heightAv = 1.7
terrain(5)\heightVt = 2
terrain(5)\slopeAv = 20
terrain(5)\slopeVt = 3
terrain(5)\temperatureAv = 10
terrain(5)\temperatureVt = 2
terrain(5)\couleur = $BBBBBB

Global tpol.f = -20,teq.f = 50,waterLevel.l=127,seed.l=4321,oldseed.l=seed,equivHeightToTemp.f = -0.4; temperature loss when you climb up 1 unit

EnableExplicit

;- ---------- Procedures ----------
;- --- Heightmap generation ---
;************************************************************************************
; Name: makeDiamondSquare
; Purpose: Creates an array of fractal noise (looks like Perlin) that can be used as
;          a heightmap
; Parameters:
;   - size of the array (a square of size x size)
;   - dispersion
;   - seed: albeit the noise is random, a seed always produces the same result
; Return-value: none, but the result is stored in the "diamond" array
;************************************************************************************
Procedure makeDiamondSquare(maxgrid.l,dispersion.f,seed.l)

  Protected gridstep.l,mid.l,n.l
  Protected i.l,i1.l,i2.l
  Protected j.l,j1.l,j2.l,js.l
  Protected u.f,average.f
  Protected dispStep.f,min.f=999999,max.f=-999999,ratio.f
  Protected Dim temp.f(maxgrid,maxgrid)
  
  RandomSeed(seed)

  gridstep=maxgrid
  dispStep=dispersion

  ; main loop
  While gridstep>1
    mid=gridstep/2

    ; Diamond step - calculates new diamond corners from squares
    i=mid
    i1=i-mid
    i2=i+mid
    
    While i<maxgrid
      j=mid
      j1=j-mid
      j2=j+mid
      
      While j<maxgrid
        ; Average of surrounding points
        average=(temp(i1,j1)+temp(i1,j2)+temp(i2,j1)+temp(i2,j2))/4
        
        ; calculate random values between -1 and 1
        u=Random(16384)/8192 - 1
        
        ; Diamond value
        temp(i,j)=average+u*dispStep
        j+gridstep
        j1+gridstep
        j2+gridstep
      Wend
      
      i+gridstep
      i1+gridstep
      i2+gridstep
    Wend

    ; square Step - calculates new square corners from diamonds
    i=0
    i1=i-mid
    i2=i+mid
    js=0
    
    While i<maxgrid
      js=mid-js ; toggle start values of j loop
      j=js
      j1=j-mid
      j2=j+mid
      
      While j<maxgrid;+1
        average=0
        If i1<0  ; check For need To wrap around i value
          average+temp(i2,j)+temp(i2,j)
        Else
          If i2>maxgrid
            average+temp(i1,j)+temp(i1,j)
          Else
            average+temp(i1,j)+temp(i2,j)
          EndIf
        EndIf
        
        If j1<0  ; check For need To wrap around j value
          average+temp(i,j2)+temp(i,j2)
        Else
          If j2>maxgrid
            average+temp(i,j1)+temp(i,j1)
          Else
            average+temp(i,j1)+temp(i,j2)
          EndIf
        EndIf     
        average=average/4
        
        ; calculate random value between -1 And 1
        u=Random(16384)/8192-1
        
        temp(i,j)=average+u*dispStep
        temp(maxgrid,j)=temp(0,j) ; copy opposite edge
        j+gridstep
        j1+gridstep
        j2+gridstep
        
      Wend
      If j=maxgrid
        temp(i,j)=temp(i,0) ; copy opposite edge
      EndIf
      i+mid
      i1+mid
      i2+mid
    Wend

    dispStep/2
    gridstep/2
  Wend

; Keep values in Byte range (between 0 and 255)
  For i=0 To maxgrid-1
    For j=0 To maxgrid-1
      ; Min /max values
      If temp(i,j)<min
        min=temp(i,j)
      Else
        If temp(i,j)>max
          max=temp(i,j)
        EndIf
      EndIf   
    Next j
  Next i
  
  ratio=256.0/(max-min)
  For i=0 To maxgrid-1
    For j=0 To maxgrid-1
      n=(temp(i,j)-min)*ratio
      If n<0
        diamond(i,j)=0
      Else
        If n>255
          diamond(i,j)=255
        Else
          diamond(i,j)=n
        EndIf
      EndIf
    Next j
  Next i

 
EndProcedure

;************************************************************************************
; Name: makeVoronoi
; Purpose: Creates a modified Voronoi diagram that can be used to simulate tectonic
;          plates
; Parameters:
;   - size of the array (a square of size x size)
;   - number of regions
;   - number of points in each region (a point is the "center" of a Voronoi plate)
;   - seed: albeit the diagram is random, a seed always produces the same result
; Return-value: none, but the result is stored in the "voronoi" array
;************************************************************************************
Procedure makeVoronoi(maxgrid.l,nbregion.l,nbpts.l,seed.l)

  Protected NewList ftpoint.VoronoiPoint2D()
  Protected Dim coef.f(nbregion*nbregion*nbpts)
  Protected i.l,j.l,k.l,n.l
  Protected min.f=999999,max.f=-999999,ratio.f
  Protected Dim temp.f(maxgrid,maxgrid)


  RandomSeed(seed)
  coef(0)=-1
  coef(1)=-2
  coef(2)=0.5

  ; In each region of the grid, place some points
  For i=0 To nbregion-1
    For j =0 To nbregion-1
      n=Random(nbpts)
      For k=1 To n
        AddElement(ftpoint())
        ftpoint()\x=i*(maxgrid/nbregion)+Random(maxgrid/nbregion)
        ftpoint()\y=j*(maxgrid/nbregion)+Random(maxgrid/nbregion)
        ;Debug StrF(ftpoint()\x)+","+StrF(ftpoint()\y)
      Next k
    Next j
  Next i
  
  ; For each cell of the grid, compute distance to each point, sort points according to distance.
  ; => value = coef * distance
  For i=0 To maxgrid-1
    For j=0 To maxgrid-1
    
      ForEach ftpoint()     
        ftpoint()\dist = Sqr((ftpoint()\x-i)*(ftpoint()\x-i)+(ftpoint()\y-j)*(ftpoint()\y-j))
      Next
      SortStructuredList(ftpoint(),0,OffsetOf(VoronoiPoint2D\dist),#PB_Sort_Float)
      
      k=0
      ForEach ftpoint()
        temp(i,j) + coef(k)*ftpoint()\dist
        k+1
      Next     
      
      ; Min /max values
      If temp(i,j)<min
        min=temp(i,j)
      Else
        If temp(i,j)>max
          max=temp(i,j)
        EndIf
      EndIf   
      
    Next j
  Next i

; Keep values in Byte range (between 0 and 255)
  ratio=256.0/(max-min)
  For i=0 To maxgrid-1
    For j=0 To maxgrid-1
      n=(temp(i,j)-min)*ratio
      If n<0
        voronoi(i,j)=0
      Else
        If n>255
          voronoi(i,j)=255
        Else
          voronoi(i,j)=n
        EndIf
      EndIf
    Next j
  Next i
  
EndProcedure

;************************************************************************************
; Name: MakeHeightmap
; Purpose: Mix a diamond-square array and a Voronoi diagram to obtain the final heightmap
; Parameters:
;   - number of the heightmap
;   - size of the array (a square of size x size); Diamond, Voronoi, and Heightmap must
;     have the same size
;   - use the diamond-square array (param = 1) or not (param = -1)
;   - use the Voronoi diagram (param = 1) or not (param = -1)
; Return-value:  none, but the result is stored in the "heightmap" array
;************************************************************************************
Procedure makeHeightmap(numHmap.b,maxgrid.l,Diamond.b,Voronoi.b)

  Protected i.l,j.l,k1.l,k2.l
  Protected min.f=999999,max.f=-999999,ratio.f,temp.f
  Protected Dim temp.f(maxgrid,maxgrid)

  ; for each point of the array:
  For i=0 To maxgrid-1
    For j=0 To maxgrid-1
    
      ; both arrays will be used
      If Voronoi>-1 And Diamond>-1 
        k1=(diamond(i,j) & 255)
        k2=(voronoi(i,j) & 255)
        temp(i,j) = k1*k2
      Else
        ; only diamond-square
        If Diamond>-1
          k1=(diamond(i,j) & 255)
          temp(i,j) = k1
        Else
          ; only Voronoi
          If Voronoi>-1
            k2=(voronoi(i,j) & 255)
            temp(i,j) = k2
          EndIf
        EndIf
      EndIf    
    
      ; Store Min / Max values
      If temp(i,j)<min
        min=temp(i,j)
      Else
        If temp(i,j)>max
          max=temp(i,j)
        EndIf
      EndIf
    
    Next j
  Next i
  
  ; The heightmap values must be between 0 and 255
  ratio = 255.0/(max-min)
  For i=0 To maxgrid-1
    For j=0 To maxgrid-1
      temp = (temp(i,j)-min)*ratio
      ;Debug temp
      If temp<0
        heightmap(numHmap,i,j)=0
      Else
        If temp>255
          heightmap(numHmap,i,j)=255
        Else
          heightmap(numHmap,i,j)=temp
        EndIf
      EndIf
    Next j
  Next i

EndProcedure

;- --- Image generation ---
;************************************************************************************
; Name: ComputeGeoStats
; Purpose: Compute height, slope, temperature, ice/snow, terrain type and color for
;          each cell of an heightmap
; Parameters:
;   - number of the heightmap
;   - size of the array (a square of size x size)
;   - sea level (between 0-255)
;   - Temperature at poles (usually cold)
;   - Temperature at equator (usually hot)
;   - seed: albeit the map is random, a seed always produces the same result
; Return-value:  none, but the results are stored in the "geostat" array
;************************************************************************************
Procedure ComputeGeoStats(numHmap.b,maxgrid.l,waterLevel.l,tpol.f,teq.f,seed.l)

  Protected heightAboveWater.l
  Protected i.l,j.l,k.l
  Protected x.l,y.l,newx.l,newy.l
  Protected p.l,h1.l,h2.l,maxp.l
  Protected red1.l,red2.l,green1.l,green2.l,blue1.l,blue2.l,red.f,green.f,blue.f
  Protected exp.f,cumul.f,icegradient.f,icecolor.l

  RandomSeed(seed)
  
  maxgrid-1
  For i=0 To maxgrid
    For j = 0 To maxgrid
    
      ; Altitude
      geostat(numHmap,i,j)\height = heightmap(numHmap,i,j)&255
      
      ; Slope
      h1= geostat(numHmap,i,j)\height
      geostat(numHmap,i,j)\slope=0
      
      If i>0
        h2=heightmap(numHmap,i-1,j)&255
        p=Abs( h1 - h2 )
        If p>geostat(numHmap,i,j)\slope
          geostat(numHmap,i,j)\slope = p
        EndIf
      EndIf

      If i<maxgrid
        h2=heightmap(numHmap,i+1,j)&255
        p=Abs( h1 - h2 )
        If p>geostat(numHmap,i,j)\slope
          geostat(numHmap,i,j)\slope = p
        EndIf
      EndIf

      If j>0
        h2=heightmap(numHmap,i,j-1)&255
        p=Abs( h1 - h2 )
        If p>geostat(numHmap,i,j)\slope
          geostat(numHmap,i,j)\slope = p
        EndIf
      EndIf

      If j<maxgrid
        h2=heightmap(numHmap,i,j+1)&255
        p=Abs( h1 - h2 )
        If p>geostat(numHmap,i,j)\slope
          geostat(numHmap,i,j)\slope = p
        EndIf
      EndIf
      If geostat(numHmap,i,j)\slope > maxp
        maxp = geostat(numHmap,i,j)\slope
      EndIf

      ; Temperature
      geostat(numHmap,i,j)\latitude = Cos((j-maxgrid/2)/maxgrid *#PI)
      heightAboveWater=geostat(numHmap,i,j)\height - waterlevel
      If heightAboveWater <0
        heightAboveWater = 0
      EndIf
      geostat(numHmap,i,j)\temperature = tpol + geostat(numHmap,i,j)\latitude*(teq-tpol) + equivHeightToTemp*heightAboveWater
      
      If geostat(numHmap,i,j)\height<waterlevel
        ; This point is under sea level
        geostat(numHmap,i,j)\isWater=2
      
        ; underwater points => shades of blue
        red1=0:green1=3:blue1=92
        red2=0:green2=130:blue2=220
        
        red=red1+(red2-red1)*(geostat(numHmap,i,j)\height/waterlevel)
        green=green1+(green2-green1)*(geostat(numHmap,i,j)\height/waterlevel)
        blue=blue1+(blue2-blue1)*(geostat(numHmap,i,j)\height/waterlevel)
      
        ; water depth causes temperature variation
        geostat(numHmap,i,j)\temperature-(geostat(numHmap,i,j)\height-waterlevel)*0.075
      Else       
        ; This point is above sea level
        geostat(numHmap,i,j)\isWater=0
        
        ; Probability computation for each terrain type
        cumul=0:red=0:green=0:blue=0
        For k=1 To 5
          exp = Abs(terrain(k)\temperatureAv - geostat(numHmap,i,j)\temperature)/terrain(k)\temperatureVt
          exp + Abs(terrain(k)\slopeAv - geostat(numHmap,i,j)\slope)/terrain(k)\slopeVt
          exp + Abs(terrain(k)\heightAv*waterLevel - geostat(numHmap,i,j)\height)/terrain(k)\heightVt
          geostat(numHmap,i,j)\probaterrain[k] = Pow(#e,-exp)
          
          cumul+geostat(numHmap,i,j)\probaterrain[k]
        Next k
        
        ; Mix terrains colors according to probability
        For k=1 To 5
          geostat(numHmap,i,j)\probaterrain[k]/cumul
          blue+Red(terrain(k)\couleur)*geostat(numHmap,i,j)\probaterrain[k]
          green+Green(terrain(k)\couleur)*geostat(numHmap,i,j)\probaterrain[k]
          red+Blue(terrain(k)\couleur)*geostat(numHmap,i,j)\probaterrain[k]
        Next k
                
      EndIf
  
      geostat(numHmap,i,j)\couleur = RGB(red,green,blue)
      
    Next j
  Next i
  
  ; Generate a few rivers
  j=0
  For i=1 To Random(6)
    Repeat
      x=Random(maxgrid)
      y=Random(maxgrid)
      j+1
    Until geostat(numHmap,x,y)\isWater<>2 Or j=1000
    
    Repeat
      geostat(numHmap,x,y)\couleur = RGB(0,130,220)
      geostat(numHmap,x,y)\isWater=1
      h1=999
      newx=0:newy=0
      If x>0
        If geostat(numHmap,x-1,y)\isWater <>1 And geostat(numHmap,x-1,y)\height < h1
          newx=x-1:newy=y
          h1=geostat(numHmap,newx,newy)\height
        EndIf 
      EndIf
      If x<maxgrid
        If geostat(numHmap,x+1,y)\isWater <>1 And geostat(numHmap,x+1,y)\height < h1
          newx=x+1:newy=y
          h1=geostat(numHmap,newx,newy)\height
        EndIf 
      EndIf
      If y>0
        If geostat(numHmap,x,y-1)\isWater <>1 And geostat(numHmap,x,y-1)\height < h1
          newx=x:newy=y-1
          h1=geostat(numHmap,newx,newy)\height
        EndIf 
      EndIf
      If y<maxgrid
        If geostat(numHmap,x,y+1)\isWater <>1 And geostat(numHmap,x,y+1)\height < h1
          newx=x:newy=y+1
          h1=geostat(numHmap,newx,newy)\height
        EndIf 
      EndIf
      x=newx:y=newy
      
    Until geostat(numHmap,x,y)\isWater=2 Or (newx=0 And newy=0)
    
  Next i

  ; Add ice/snow, slope marking
  For i=0 To maxgrid
    For j=0 To maxgrid
      red=Red(geostat(numHmap,i,j)\couleur)
      green=Green(geostat(numHmap,i,j)\couleur)
      blue=Blue(geostat(numHmap,i,j)\couleur)
    
      ; Ice / snow
      If geostat(numHmap,i,j)\temperature < 0
        If geostat(numHmap,i,j)\temperature < 0
          icegradient= -geostat(numHmap,i,j)\temperature / 5
        EndIf
        
        If icegradient>1
          icegradient=1
        EndIf         
        icecolor=247+Random(8)
        
        red=red*(1-icegradient) + icecolor*icegradient
        green=green*(1-icegradient) + icecolor*icegradient
        blue=blue*(1-icegradient) + icecolor*icegradient        
      EndIf 
      
      ; Slopes are darker
      If geostat(numHmap,i,j)\isWater<2    
        red-geostat(numHmap,i,j)\slope * 3
        green-geostat(numHmap,i,j)\slope * 3
        blue-geostat(numHmap,i,j)\slope * 3        
      EndIf     
        
      ; RGB must stay between 0-255
      If red<0 
        red=0
      Else
        If red>255
          red=255
        EndIf
      EndIf
      If green<0 
        green=0
      Else
        If green>255
          green=255
        EndIf
      EndIf
      If blue<0 
        blue=0
      Else
        If blue>255
          blue=255
        EndIf
      EndIf
        
      geostat(numHmap,i,j)\couleur = RGB(red,green,blue)

    Next j
  Next i

EndProcedure

;************************************************************************************
; Name: MakeTerrainImage
; Purpose: Draw the map
; Parameters:
;   - number of the image
;   - number of the heightmap / geostats array
;   - size of the array (a square of size x size)
;   - Type of map to draw: "terrain","altitude","slope", "temperature"
; Return-value:  none
;************************************************************************************
Procedure MakeTerrainImage(numImage.l,numHmap.b,maxgrid.l,imageType.s)

  Protected i.l,j.l,color.l
  Protected red.f,green.f,blue.f

  StartDrawing(ImageOutput(numImage))
  
  For i=0 To maxgrid-1
    For j=0 To maxgrid-1
    
      Select imageType
      
        Case "altitude"
          color = heightmap(numHmap,i,j) & 255
          color = RGB(color,color,color)
          
        Case "temperature"
          If i>1 And i<maxgrid-1 And j>1 And j<maxgrid-1 And geostat(numHmap,i,j)\isWater>0 And (geostat(numHmap,i-1,j)\isWater=0 Or geostat(numHmap,i+1,j)\isWater=0 Or geostat(numHmap,i,j-1)\isWater=0 Or geostat(numHmap,i,j+1)\isWater=0)
            color=0
          Else
            red = (geostat(numHmap,i,j)\temperature - tpol)*255/(teq-tpol)
            If red>255
              red=255
            EndIf
            If red<0
              red=0
            EndIf
            blue = 255-red
            green=blue/2
            color=RGB(red,green,blue)
          EndIf
          
        Case "slope"
          color = geostat(numHmap,i,j)\slope*32
          If color > 255
            color = 255
          EndIf
          color = RGB(color,color,color)
          
        Case "terrain"
          color = geostat(numHmap,i,j)\couleur   
          
      EndSelect
      Plot(i,j,color)
    Next j
  Next i
  
  StopDrawing()

EndProcedure
DisableExplicit

;- ---------- Main program ----------
dispersion = 512
makeDiamondSquare(maxgrid,dispersion,seed)
makeVoronoi(maxgrid,3,4,seed)
makeHeightmap(0,512,1,1)

ComputeGeoStats(0,maxgrid,waterLevel,tpol,teq,seed)

CreateImage(0,512,512)
CreateImage(1,512,512)
MakeTerrainImage(0,0,512,"terrain")
MakeTerrainImage(1,0,512,"altitude")

;- Window & Gadgets
OpenWindow(#Window_0, 215, 143, 1049, 710, "Terrain generator",  #PB_Window_SystemMenu | #PB_Window_MinimizeGadget | #PB_Window_TitleBar )
CreateGadgetList(WindowID(#Window_0))
  ImageGadget(#Image_2, 530, 5, 512, 512, 0)
  ImageGadget(#Image_1, 15, 5, 512, 512, 1)
  TextGadget(#SeedLabel, 20, 530, 40, 20, "Seed:", #PB_Text_Right)
  SetGadgetFont(#SeedLabel, FontID1)
  StringGadget(#FL_seed, 65, 525, 85, 25, "", #PB_String_Numeric)
  SetGadgetFont(#FL_seed, FontID1)
  StringGadget(#FL_tpol, 290, 525, 45, 25, "", #PB_String_Numeric)
  SetGadgetFont(#FL_tpol, FontID1)
  TextGadget(#TpolLabel, 160, 530, 125, 20, "Polar temperature:", #PB_Text_Right)
  SetGadgetFont(#TpolLabel, FontID1)
  StringGadget(#FL_teq, 475, 525, 50, 25, "", #PB_String_Numeric)
  SetGadgetFont(#FL_teq, FontID1)
  TextGadget(#teqLabel, 345, 530, 130, 20, "Equat. temperature:", #PB_Text_Right)
  SetGadgetFont(#teqLabel, FontID1)
  StringGadget(#FL_sealevel, 660, 525, 50, 25, "", #PB_String_Numeric)
  SetGadgetFont(#FL_sealevel, FontID1)
  TextGadget(#sealevelLabel, 530, 530, 130, 20, "Sea level (0->255):", #PB_Text_Right)
  SetGadgetFont(#sealevelLabel, FontID1)
  StringGadget(#FL_temploss, 970, 525, 60, 25, "", #PB_String_Numeric)
  SetGadgetFont(#FL_temploss, FontID1)
  TextGadget(#templossLabel, 700, 530, 270, 20, "Temperature loss by unit above water:", #PB_Text_Right)
  SetGadgetFont(#templossLabel, FontID1)
  
  OptionGadget(#RS_height, 660, 600, 85, 20, "Altitude")
  SetGadgetFont(#RS_height, FontID1)
  SetGadgetState(#RS_height,1)
  OptionGadget(#RS_slope, 750, 600, 85, 20, "Slope")
  SetGadgetFont(#RS_slope, FontID1)
  OptionGadget(#RS_temp, 840, 600, 110, 20, "Temperature")
  SetGadgetFont(#RS_temp, FontID1)
  
  Frame3DGadget(#RT_terrain, 15, 555, 415, 110, "Individual terrain settings")
  ComboBoxGadget(#CB_terrain, 25, 610, 105, 300)
  SetGadgetFont(#CB_terrain, FontID1)
  TextGadget(#terrainLabel, 25, 587, 95, 20, "Terrain Type:")
  SetGadgetFont(#terrainLabel, FontID1)
  TextGadget(#Text_17, 137, 613, 30, 20, "=>")
  SetGadgetFont(#Text_17, FontID5)
  TextGadget(#Text_18, 170, 580, 25, 75, "{")
  SetGadgetFont(#Text_18, FontID2)
  SetGadgetFont(#RT_terrain, FontID1)
  TextGadget(#LabelAverage, 285, 565, 60, 20, "Average")
  SetGadgetFont(#LabelAverage, FontID1)
  TextGadget(#LabelVariance, 355, 565, 60, 20, "Variance")
  SetGadgetFont(#LabelVariance, FontID1)
  StringGadget(#FL_heightAv, 290, 585, 50, 25, "", #PB_String_Numeric)
  SetGadgetFont(#FL_heightAv, FontID1)
  StringGadget(#FL_heightVt, 360, 585, 50, 25, "", #PB_String_Numeric)
  SetGadgetFont(#FL_heightVt, FontID1)
  StringGadget(#FL_tempAv, 290, 610, 50, 25, "", #PB_String_Numeric)
  SetGadgetFont(#FL_tempAv, FontID1)
  StringGadget(#FL_tempVt, 360, 610, 50, 25, "", #PB_String_Numeric)
  SetGadgetFont(#FL_tempVt, FontID1)
  StringGadget(#FL_slopeAv, 290, 635, 50, 25, "", #PB_String_Numeric)
  SetGadgetFont(#FL_slopeAv, FontID1)
  StringGadget(#FL_slopeVt, 360, 635, 50, 25, "", #PB_String_Numeric)
  SetGadgetFont(#FL_slopeVt, FontID1)
  TextGadget(#heightLabel, 195, 587, 90, 20, "Altitude:", #PB_Text_Right)
  SetGadgetFont(#heightLabel, FontID1)
  TextGadget(#tempLabel, 195, 612, 90, 20, "Temperature:", #PB_Text_Right)
  SetGadgetFont(#tempLabel, FontID1)
  TextGadget(#slopeLabel, 195, 637, 90, 20, "Slope:", #PB_Text_Right)
  SetGadgetFont(#slopeLabel, FontID1)
  
  ButtonGadget(#BT_redraw, 435, 595, 95, 30, "&Redraw")
  SetGadgetFont(#BT_redraw, FontID1)
  ButtonGadget(#BT_close, 470, 675, 95, 30, "&Close")
  SetGadgetFont(#BT_close, FontID1)


For i=1 To 5
  AddGadgetItem(#CB_terrain,-1,terrain(i)\name)
Next i

SetGadgetText(#FL_seed,Str(seed))
SetGadgetText(#FL_tpol,StrF(tpol,2))
SetGadgetText(#FL_teq,StrF(teq,2))
SetGadgetText(#FL_seaLevel,Str(waterLevel))
SetGadgetText(#FL_temploss,StrF(equivHeightToTemp,3))

SetGadgetState(#image_1,ImageID(0))
SetGadgetState(#image_2,ImageID(1))

;- Main loop
Repeat
  
  EventID = WaitWindowEvent()      
  Select EventID
    
    Case 0         
      Delay(1)
    
    Case #PB_Event_CloseWindow
      Quit = 1
      
    Case #PB_Event_Gadget
      
      Select EventGadget()
                     
        Case #RS_height
          MakeTerrainImage(1,0,maxgrid,"altitude")          
          SetGadgetState(#image_2,ImageID(1))   
        Case #RS_temp
          MakeTerrainImage(1,0,maxgrid,"temperature")          
          SetGadgetState(#image_2,ImageID(1))   
        Case #RS_slope
          MakeTerrainImage(1,0,maxgrid,"slope")          
          SetGadgetState(#image_2,ImageID(1))   
               
        Case #CB_terrain
          n=GetGadgetState(#CB_terrain)+1
          If n>0
            SetGadgetText(#FL_heightAv,StrF(terrain(n)\heightAv,2))
            SetGadgetText(#FL_heightVt,StrF(terrain(n)\heightVt,2))
            SetGadgetText(#FL_tempAv,StrF(terrain(n)\temperatureAv,2))
            SetGadgetText(#FL_tempVt,StrF(terrain(n)\temperatureVt,2))
            SetGadgetText(#FL_slopeAv,StrF(terrain(n)\slopeAv,2))
            SetGadgetText(#FL_slopeVt,StrF(terrain(n)\slopeVt,2))
          EndIf
        
        Case #FL_heightAv
          n=GetGadgetState(#CB_terrain)+1
          If n>0
            terrain(n)\heightAv = ValF(GetGadgetText(#FL_heightAv))
          EndIf
        Case #FL_heightVt
          n=GetGadgetState(#CB_terrain)+1
          If n>0
            terrain(n)\heightVt = ValF(GetGadgetText(#FL_heightVt))
          EndIf
        Case #FL_tempAv
          n=GetGadgetState(#CB_terrain)+1
          If n>0
            terrain(n)\temperatureAv = ValF(GetGadgetText(#FL_tempAv))
          EndIf
        Case #FL_tempVt
          n=GetGadgetState(#CB_terrain)+1
          If n>0
            terrain(n)\temperatureVt = ValF(GetGadgetText(#FL_tempVt))
          EndIf
        Case #FL_slopeAv
          n=GetGadgetState(#CB_terrain)+1
          If n>0
            terrain(n)\slopeAv = ValF(GetGadgetText(#FL_slopeAv))
          EndIf
        Case #FL_heightVt
          n=GetGadgetState(#CB_terrain)+1
          If n>0
            terrain(n)\slopeVt = ValF(GetGadgetText(#FL_slopeVt))
          EndIf
                                       
        Case #BT_redraw
          seed = Val(GetGadgetText(#FL_seed))
          tpol = ValF(GetGadgetText(#FL_tpol))
          teq = ValF(GetGadgetText(#FL_teq))
          waterLevel = Val(GetGadgetText(#FL_seaLevel))
          equivHeightToTemp = ValF(GetGadgetText(#FL_temploss))
          
          If seed<>oldseed
            makeDiamondSquare(maxgrid,dispersion,seed)
            makeVoronoi(maxgrid,3,4,seed)
            makeHeightmap(0,maxgrid,1,1)
            oldseed=seed
          EndIf  
          ComputeGeoStats(0,maxgrid,waterLevel,tpol,teq,seed)
          MakeTerrainImage(0,0,maxgrid,"terrain")
          If GetGadgetState(#RS_height)=1
            MakeTerrainImage(1,0,maxgrid,"altitude")
          EndIf
          If GetGadgetState(#RS_temp)=1
            MakeTerrainImage(1,0,maxgrid,"temperature")
          EndIf
          If GetGadgetState(#RS_slope)=1
            MakeTerrainImage(1,0,maxgrid,"slope")
          EndIf
          SetGadgetState(#image_1,ImageID(0))
          SetGadgetState(#image_2,ImageID(1))

        Case #BT_close
          quit=1          
          
      EndSelect 
      
  EndSelect    
  
Until Quit
Dernière modification par kelebrindae le mar. 22/juil./2008 10:47, modifié 1 fois.
Backup
Messages : 14526
Inscription : lun. 26/avr./2004 0:40

Message par Backup »

bon boulot !! :D
Frenchy Pilou
Messages : 2194
Inscription : jeu. 27/janv./2005 19:07

Message par Frenchy Pilou »

L'IGN chez soi :)
Le fait de cliquer sur OK sort du programme, c'est normal?
Octavius
Messages : 312
Inscription : jeu. 26/juil./2007 12:10

Message par Octavius »

Génial !!! :D Franchement j'adore !

EDIT: juste une remarque, est-ce qu'on ne pourrait pas ajouter une petite fonction pour ajuster le niveau des océans ?
kelebrindae
Messages : 579
Inscription : ven. 11/mai/2007 15:21

Message par kelebrindae »

Merci! :D

@Frenchy Pilou:
Oui, c'est normal, mais je reconnais que le libellé du bouton n'est pas très clair => ce devrait être "Close".

@Octavius:
J'ai ajouté deux champs saisissables dans le code ci-dessus:
- Le niveau de l'eau (entre 0 et 255. il n'y a pas de contrôle: si vous sortez de ces valeurs, il y a de grandes chances pour que ça plante...)
- La baisse de température en fonction de l'altitude au-dessus du niveau de la mer (normalement, plus on est loin du niveau de la mer, plus ça caille!).

Remarque: Les champs "numeric" de PB me troublent: on ne peut pas entrer le signe "-", ni le "." décimal. :?
Comment corrige-t-on cela ?
Backup
Messages : 14526
Inscription : lun. 26/avr./2004 0:40

Message par Backup »

.......
Dernière modification par Backup le mar. 19/août/2014 12:50, modifié 1 fois.
kelebrindae
Messages : 579
Inscription : ven. 11/mai/2007 15:21

Message par kelebrindae »

Dobro a écrit :en utilisant un editor gadget et en filtrant toi meme
oooh, pas cool :(

Merci quand même pour l'info, Dobro.
Cls
Messages : 620
Inscription : mer. 22/juin/2005 8:51
Localisation : Nantes

Message par Cls »

Très sympa ce code, merci ;)
Octavius
Messages : 312
Inscription : jeu. 26/juil./2007 12:10

Message par Octavius »

J'ai quelques autres idées d'améliorations :
- Rajouter les boutons 'Next' et 'Previous' au-dessus et en-dessous de 'Redraw' pour passer aux 'Seed' suivants et précédents (avec un redraw automatique).
- Proposer l'option de rendre la carte "sphérique", c'est-à-dire que la partie gauche de la carte puisse se joindre harmonieusement à la partie droite de la carte.
- Pouvoir choisir les dimensions, ici on 1*1, ce serait bien de pouvoir choisir 2*1 (2 fois plus large que haut).

Une carte deux fois plus large que haute et avec un continuum tout autour de l'équateur, ça ferait une superbe projection de Mercator qu'on pourrait appliquer directement sur une sphère! :D
Octavius
Messages : 312
Inscription : jeu. 26/juil./2007 12:10

Message par Octavius »

Au fait, je connais des gens que ça pourrait intéresser ton programme, est-ce que je peux publier l'exécutable sur un autre forum ?
kelebrindae
Messages : 579
Inscription : ven. 11/mai/2007 15:21

Message par kelebrindae »

Proposer l'option de rendre la carte "sphérique"
Un moyen simple d'y parvenir est de désactiver l'utilisation du diagramme de Voronoi dans la constitution de la map, en remplaçant à la ligne 759

Code : Tout sélectionner

makeHeightmap(0,512,1,1)
par

Code : Tout sélectionner

makeHeightmap(0,512,1,-1)
=> l'algorithme Diamond-Square produit naturellement des données "tileable" que tu peux juxtaposer sans problème.

Si tu veux garder Voronoi, ce sera un peu plus pénible.
Tu peux peut-être voir avec cette procédure, que j'utilise dans le code de génération de planètes:

Code : Tout sélectionner

;************************************************************************************
; Name: eraseSeam
; Purpose: Blends the seam between two heightmaps
; Parameters:
;   - number of the first heightmap
;   - side of the first heightmap to blend (top, bottom, left, or right)
;   - number of the second heightmap
;   - side of the second heightmap to blend (top, bottom, left, or right)
;   - size of the array (a square of size x size); both Heightmaps must
;     have the same size
;   - percentage of that size that will be blended
; Return-value:  none
;************************************************************************************
Procedure eraseSeam(numHmap1.l,side1.s,numHmap2.l,side2.s,maxgrid.l,percent.b)

  Protected i.l,j.l,width.l,seamwidth.l,color.l
  Protected x1.l,y1.l,x2.l,y2.l
  Protected h1.l,h2.l,h.l
  Protected ratio1.f,ratio2.f
  
  width = maxgrid-1
  seamwidth = ( width*percent/100 )/2
    
  For i=0 To seamwidth
  
    ratio1=(seamwidth-(i/2))/seamwidth
    ratio2=(i/2)/seamwidth
  
    For j=0 To maxgrid-1
    
      Select side1
        Case "top"
          x1 = j
          y1 = seamwidth-i
        Case "bottom"
          x1 = j
          y1 = width-seamwidth+i
        Case "left"
          x1 = seamwidth-i
          y1 = j
        Case "right"
          x1 = width-seamwidth+i
          y1 = j
      EndSelect
      
      Select side2
        Case "top"
          x2 = j
          y2 = seamwidth-i
          If side1 = "top" Or side1 = "right"
            x2=maxgrid-1-j
          EndIf         
        Case "bottom"
          x2 = j
          y2 = width-seamwidth+i
          If side1 = "bottom" Or side1 = "left"
            x2=maxgrid-1-j
          EndIf
        Case "left"
          x2 = seamwidth-i
          y2 = j
          If side1 = "bottom" Or side1 = "left"
            x2=maxgrid-1-j
          EndIf
        Case "right"
          x2 = width-seamwidth+i
          y2 = j
          If side1 = "top" Or side1 = "right"
            x2=maxgrid-1-j
          EndIf         
      EndSelect
    
      h1=heightmap(numHmap1,x1,y1) & 255
      h2=heightmap(numHmap2,x2,y2) & 255

      h=h1*ratio1 + h2*ratio2      
      heightmap(numHmap1,x1,y1)=h
      
      h=h2*ratio1 + h1*ratio2
      heightmap(numHmap2,x2,y2)=h      
    Next j
    
  Next i

EndProcedure
=> ça "mélange" les bords de deux heightmaps pour effacer les jointures (à lancer avant le calcul des couleurs). Si tu passes le même n° de heightmap pour numHmap1 et numHmap2, genre:

Code : Tout sélectionner

eraseseam([n° map],"right",[n° map],"left",[taille map],25)
ça devrait permettre de wrapper la gauche et la droite de la map...

Par contre, dans les deux cas, ça te donnera une texture de type "cylindre" plutôt que "sphère": il manque la déformation aux pôles. Jette un oeil ici:
http://ozviz.wasp.uwa.edu.au/~pbourke/t ... spheremap/
Dans la section "Texture map correction for spherical mapping", tu trouveras des infos (et même du pseudo-code) sur le sujet.

Pour les autres demandes, je te laisse faire :wink: . En effet, je ne vais utiliser ce code qu'avec le mesh généré là: http://www.purebasic.fr/french/viewtopic.php?t=8307, qui emploie 6 maps différentes; mes besoins en terme de textures sont donc différents.
je connais des gens que ça pourrait intéresser ton programme, est-ce que je peux publier l'exécutable sur un autre forum ?
Oui, aucun problème. Tu peux leur transmettre l'exe ou même le source si ça peux leur être utile; après tout, ce qui est posté sur un forum devient public, et peut être utilisé/modifié par chacun en fonction de ses besoins (c'est toute la beauté d'internet!).
comtois
Messages : 5172
Inscription : mer. 21/janv./2004 17:48
Contact :

Message par comtois »

Bravo , bon boulot.
http://purebasic.developpez.com/
Je ne réponds à aucune question technique en PV, utilisez le forum, il est fait pour ça, et la réponse peut profiter à tous.
Répondre