Voici la deuxième version du générateur de terrains.
Le but était de permettre de zoomer un grand nombre de fois sur un point de la carte, en ajoutant à la volée des détails aléatoires.
C'est là qu'intervient le générateur de nombres pseudo-aléatoires que j'ai eu tellement de mal à mettre au point (http://www.purebasic.fr/french/viewtopic.php?t=8348) => pour des coordonnées données sur la carte, les détails générés doivent toujours être les mêmes (de façon à retrouver le même relief d'une fois sur l'autre).
Bon, le code n'est pas super-fini: la génération de la carte initiale n'utilise plus de diagramme de Voronoi, les rivières disparaissent quand on zoome, et les cartes des hauteurs et des pentes gardent la trace des pixels initiaux, ce qui génère des motifs carrés lors du coloriage du relief.
Mais bon, je pars en vacances demain et je voulais poster ce truc avant de partir et de tout oublier...
Accessoirement, si quelqu'un a une idée pour corriger le problème des "motifs carrés", je suis preneur car je n'ai aucune idée quant à la façon de procéder (et je ne suis même pas sûr de comprendre la source du problème)...
Merci d'avance!Code : Tout sélectionner
; Author: Kelebrindae
; Date: august, 05, 2008
; PB version: v4.20
; OS: Windows XP
; ---------------------------------------------------------------------------------------------------------------
; Purpose:
; ---------------------------------------------------------------------------------------------------------------
; - Generates an heightmap from a diamond-square 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
; - You can zoom the map to show smaller areas
;
; It should look like a (very simple) earth-like map.
;
; ---------------------------------------------------------------------------------------------------------------
; Known Problems:
; ---------------------------------------------------------------------------------------------------------------
; - Rivers disappear when you zoom
; - Square patterns appears in the "slope" maps, affecting relief coloring
;- Constants
#e = 2.718281828459045235
#MAXUNITSIZE = 4096
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
#TB_anim
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 geostat_struct
latitude.f
slope.f
temperature.f
height.f
probaterrain.f[10]
isWater.b
couleur.l
EndStructure
Structure geotype_struct
minheight.f
maxheight.f
EndStructure
Structure terrain_struct
name.s
heightAv.f
heightVt.f
slopeAv.f
slopeVt.f
temperatureAv.f
temperatureVt.f
couleur.l
EndStructure
Structure myBITMAPINFO
bmiHeader.BITMAPINFOHEADER
bmiColors.RGBQUAD[1]
EndStructure
;- Global definitions
maxgrid = 512 ; must be a power of 2
Global Dim geostat.geostat_struct(6,maxgrid,maxgrid)
Global Dim geotype.geotype_struct(6)
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,equivHeightToTemp.f = -0.4; temperature loss when you climb up 1 unit
Global waterLevel.l=127,seed.l=4321
Global zoomlevel.l=0,unitSize.f = #MAXUNITSIZE/Pow(2,zoomlevel)
Global xori.f,yori.f
EnableExplicit
;- ---------- Procedures ----------
;- --- Heightmap generation ---
;************************************************************************************
; Name: noise3D
; Purpose: Pseudo-Random Number Generator (PRNG)
; Parameters:
; - x,y,z : coords of a point, or any other triplet of floats
; Return-value: a "random" number between -1 and 1
;************************************************************************************
Procedure.f noise3D(x.f,y.f,z.f)
Protected n.l,n2.q
; " n = Math.floor(x+y*57+z*131); "
n2=Int(x*1.7+y*57+z*131)
n=n2%2147483647
; " n = (n<<13)^n "
n=(n<<13)!n
; " (n*(n*n*15731+789221)+1376312589) & 0x7FFFFFFF "
n=(n*(n*n*15731+789221)+1376312589) & $7FFFFFFF
ProcedureReturn (1.0-n/1073741824.0)
EndProcedure
;************************************************************************************
; 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(numHmap.l,maxgrid.l,unitSize.f,seed.l,xori.l,yori.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,addVal.f
Protected noiseScale.f,min.f=999999,max.f=-999999,ratio.f
Protected Dim temp.f(maxgrid,maxgrid)
gridstep=maxgrid
noiseScale=unitSize/2
i=0:j=0
temp(i,j)=noise3D(xori+(i*unitSize),yori+(j*unitSize),seed)*noiseScale
i=maxgrid:j=0
temp(i,j)=noise3D(xori+(i*unitSize),yori+(j*unitSize),seed)*noiseScale
i=0:j=maxgrid
temp(i,j)=noise3D(xori+(i*unitSize),yori+(j*unitSize),seed)*noiseScale
i=maxgrid:j=maxgrid
temp(i,j)=noise3D(xori+(i*unitSize),yori+(j*unitSize),seed)*noiseScale
; 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
u=noise3D(xori+(i*unitSize),yori+(j*unitSize),seed)
; Diamond value
temp(i,j)=average+u*noiseScale
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+noise3D(xori+(i1*unitSize),yori+(j*unitSize),seed)*noiseScale+temp(i2,j)
average+temp(i2,j)+temp(i2,j)
;Debug "i1,j = " + Str(i1)+","+Str(j)+ " / "+StrF(noise3D(xori+(i1*unitSize),yori+(j*unitSize),seed)*noiseScale) + " / " + StrF(average)
Else
If i2>maxgrid
;average+temp(i1,j)+noise3D(xori+(i2*unitSize),yori+(j*unitSize),seed)*noiseScale
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+noise3D(xori+(i*unitSize),yori+(j1*unitSize),seed)*noiseScale+temp(i,j2)
average+temp(i,j2)+temp(i,j2)
Else
If j2>maxgrid
;average+temp(i,j1)+noise3D(xori+(i*unitSize),yori+(j2*unitSize),seed)*noiseScale
average+temp(i,j1)+temp(i,j1)
Else
average+temp(i,j1)+temp(i,j2)
EndIf
EndIf
average/4
; calculate random value between -1 And 1
;u=Random(16384)/8192-1
u=noise3D(xori+(i*unitSize),yori+(j*unitSize),seed)
temp(i,j)=average+u*noiseScale
;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
noiseScale/2
gridstep/2
Wend
; Keep values in Byte range (between 0 and 255)
For i=0 To maxgrid
For j=0 To maxgrid
; 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
addVal = -(min+(127.0/255.0)*(max-min))
Debug "min\max = " + StrF(min)+" \ "+StrF(max) + " | " + StrF(addVal)
; ratio=255.0/(max-min)
For i=0 To maxgrid-1
For j=0 To maxgrid-1
geostat(numhMap,i,j)\height=temp(i,j)+addVal
; n=(temp(i,j)-min)*ratio
; If n<0
; heightmap(numhMap,i,j)=0
; Else
; If n>255
; heightmap(numhMap,i,j)=255
; Else
; heightmap(numhMap,i,j)=n
; EndIf
; EndIf
Next j
Next i
geotype(numhMap)\minheight=min+addVal
geotype(numhMap)\maxheight=max+addVal
EndProcedure
;- --- Image generation ---
Macro terrainLatitude(matrixPoint,coordNS,distanceNS)
matrixPoint#\latitude = Cos((coordNS-distanceNS/2)/distanceNS *#PI)
EndMacro
Macro terrainTemperature(matrixPoint,minH)
; Temperature
h=(matrixPoint#\height - minH)*ratio
If matrixPoint#\height >= 0
heightAboveWater=h - waterlevel
Else
heightAboveWater = 0
EndIf
matrixPoint#\temperature = tpol + matrixPoint#\latitude*(teq-tpol) + equivHeightToTemp*heightAboveWater
EndMacro
Macro terrainSlope(matrixName,i,j)
h1= matrixName#(i,j)\height
matrixName#(i,j)\slope=0
p=0
If i>0
h2=matrixName#(i-1,j)\height
p=Abs( h1 - h2 )
; If p>matrixName#(i,j)\slope
; matrixName#(i,j)\slope = p
; EndIf
EndIf
If i<maxgrid
h2=matrixName#(i+1,j)\height
p+Abs( h1 - h2 )
; p=Abs( h1 - h2 )
; If p>matrixName#(i,j)\slope
; matrixName#(i,j)\slope = p
; EndIf
EndIf
If j>0
h2=matrixName#(i,j-1)\height
p+Abs( h1 - h2 )
; p=Abs( h1 - h2 )
; If p>matrixName#(i,j)\slope
; matrixName#(i,j)\slope = p
; EndIf
EndIf
If j<maxgrid
h2=matrixName#(i,j+1)\height
p+Abs( h1 - h2 )
; p=Abs( h1 - h2 )
; If p>matrixName#(i,j)\slope
; matrixName#(i,j)\slope = p
; EndIf
EndIf
matrixName#(i,j)\slope=p/4.0
matrixName#(i,j)\slope*((#MAXUNITSIZE/unitSize)/4)
EndMacro
Macro terrainColor(matrixPoint)
; Color
If matrixPoint#\height<0
; This point is under sea level
matrixPoint#\isWater=2
; underwater points => shades of blue
red1=0:green1=3:blue1=92
red2=0:green2=130:blue2=220
red=red1+(red2-red1)*(h /waterlevel)
green=green1+(green2-green1)*(h /waterlevel)
blue=blue1+(blue2-blue1)*(h /waterlevel)
; water depth causes temperature variation
matrixPoint#\temperature-(h -waterlevel)*0.075
Else
; This point is above sea level
matrixPoint#\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 - matrixPoint#\temperature)/terrain(k)\temperatureVt
exp + Abs(terrain(k)\slopeAv - matrixPoint#\slope)/terrain(k)\slopeVt
exp + Abs(terrain(k)\heightAv*waterLevel - h)/terrain(k)\heightVt
matrixPoint#\probaterrain[k] = Pow(#e,-exp)
cumul+matrixPoint#\probaterrain[k]
Next k
; Mix terrains colors according to probability
For k=1 To 5
matrixPoint#\probaterrain[k]/cumul
blue+Red(terrain(k)\couleur)*matrixPoint#\probaterrain[k]
green+Green(terrain(k)\couleur)*matrixPoint#\probaterrain[k]
red+Blue(terrain(k)\couleur)*matrixPoint#\probaterrain[k]
Next k
EndIf
matrixPoint#\couleur = RGB(red,green,blue)
EndMacro
;************************************************************************************
; 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,zoomlevel.l,waterLevel.l,tpol.f,teq.f,seed.l)
Protected i.l,j.l,k.l
Protected x.l,y.l,newx.l,newy.l
Protected p.f,h1.f,h2.f,ratio.f;,maxp.f
Protected heightAboveWater.l,h.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,unitSize.f = #MAXUNITSIZE/Pow(2,zoomlevel)
RandomSeed(seed)
ratio = 255.0/(geotype(numHmap)\maxHeight-geotype(numHmap)\minHeight)
maxgrid-1
For i=0 To maxgrid
For j = 0 To maxgrid
; Slope
h1= geostat(numHmap,i,j)\height
geostat(numHmap,i,j)\slope=0
p=0
If i>0
h2=geostat(numHmap,i-1,j)\height
p=Abs( h1 - h2 )
; If p>geostat(numHmap,i,j)\slope
; geostat(numHmap,i,j)\slope = p
; EndIf
EndIf
If i<maxgrid
h2=geostat(numHmap,i+1,j)\height
p+Abs( h1 - h2 )
; If p>geostat(numHmap,i,j)\slope
; geostat(numHmap,i,j)\slope = p
; EndIf
EndIf
If j>0
h2=geostat(numHmap,i,j-1)\height
p+Abs( h1 - h2 )
; If p>geostat(numHmap,i,j)\slope
; geostat(numHmap,i,j)\slope = p
; EndIf
EndIf
If j<maxgrid
h2=geostat(numHmap,i,j+1)\height
p+Abs( h1 - h2 )
; If p>geostat(numHmap,i,j)\slope
; geostat(numHmap,i,j)\slope = p
; EndIf
EndIf
geostat(numHmap,i,j)\slope=p/4.0
geostat(numHmap,i,j)\slope*((#MAXUNITSIZE/unitSize)/4)
; Latitude
terrainLatitude(geostat(numHmap,i,j),(j*#MAXUNITSIZE),(maxgrid*#MAXUNITSIZE))
; Temperature
terrainTemperature(geostat(numHmap,i,j),geotype(numHmap)\minHeight)
; Terrain Type
terrainColor(geostat(numHmap,i,j))
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
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,icecolor.l
Protected red.f,green.f,blue.f,icegradient.f,ratio.f
Protected hDC.l,hBmp.l,*mem.l,picl_X.l,picl_Y.l,picl_D.l
Protected bmi.myBITMAPINFO,*pixel.LONG
hDC=StartDrawing(ImageOutput(numImage))
hBmp = ImageID(numImage)
picl_X = ImageWidth(numImage)
picl_Y = ImageHeight(numImage)+1
picl_D = ImageDepth(numImage)
*mem = AllocateMemory(picl_X*picl_Y*4)
bmi.myBITMAPINFO
bmi\bmiHeader\biSize = SizeOf(BITMAPINFOHEADER)
bmi\bmiHeader\biWidth = picl_X
bmi\bmiHeader\biHeight = picl_Y
bmi\bmiHeader\biPlanes = 1
bmi\bmiHeader\biBitCount = 32
bmi\bmiHeader\biCompression = #BI_RGB
GetDIBits_(hDC,hBmp,1,picl_Y,*mem,bmi,#DIB_RGB_COLORS)
ratio = 255.0/(geotype(numHmap)\maxHeight-geotype(numHmap)\minHeight)
*pixel = *mem
For j=maxgrid-1 To 0 Step-1
For i=0 To maxgrid-1
Select imageType
Case "altitude"
color = (geostat(numHmap,i,j)\height - geotype(numHmap)\minHeight)*ratio
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(blue,green,red)
EndIf
Case "slope"
color = geostat(numHmap,i,j)\slope*32
If color > 255
color = 255
EndIf
color = RGB(color,color,color)
Case "terrain"
; Add ice/snow, slope marking
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 * 4
green-geostat(numHmap,i,j)\slope * 4
blue-geostat(numHmap,i,j)\slope * 4
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
color = RGB(blue,green,red)
EndSelect
*pixel\l=color
*pixel + 4
Next i
Next j
SetDIBits_(hDC,hBmp,1,maxgrid+1,*mem,bmi,#DIB_RGB_COLORS)
StopDrawing()
FreeMemory(*mem)
EndProcedure
;- --- Zoom ---
; Let's consider a part of the grid:
;
; A ab B
; ac m bd
; C cd D
;
; -> ABCD are the known heights of the parent.
; -> efghi are the heights you want to fill.
; With Diamond Square, you are generating those heights are a function of the adjacent heights:
;
; m = ds4 ( A, B, C, D)
; ab = ds2 ( A, B )
; ac = ds2 ( A, C )
; bd = ds2 ( B, D )
; cd = ds2 ( C, D )
;
; ds2 and ds4 do the following: they average their arguments, and add a small pseudo-random displacement
; that is scaled by the frequency of the grid. In other words:
;
; ds2 ( N, M ) = (N + M) / 2 + h * scale
; ds4 ( N, M, O, P ) = (N + M + O + P) / 4 + h * scale
;
; You can choose scale as you want to make terrain more or less rough, the idea being that it gets lower and lower
; each time you go deeper in the quadtree. Ex: use a lookup table that is a function of the quadtree node level.
Procedure ZoomX2(numHmap.l,maxgrid.l,zoomlevel.l,seed.f,iori.l,jori.l,xori.f,yori.f,unitsize.f)
Protected Dim temp.geostat_struct(maxgrid,maxgrid)
Protected i.l,j.l,k.l,n.l,iloc.l,jloc.l
Protected A.f,B.f,C.f,D.f,noiseScale.f
Protected heightAboveWater.l,h.l
Protected exp.f,cumul.f
Protected p.f,h1.f,h2.f
Protected red1.l,red2.l,green1.l,green2.l,blue1.l,blue2.l,red.f,green.f,blue.f
Protected ratio.f = 255.0/(geotype(numHmap)\maxHeight-geotype(numHmap)\minHeight)
Protected totalNS.l=maxgrid*#MAXUNITSIZE
noiseScale=unitSize/(#MAXUNITSIZE/4)
For j=0 To maxgrid-2 Step 2
For i=0 To maxgrid-2 Step 2
iloc=iori+i/2:jloc=jori+j/2
A=geostat(numhMap,iloc,jloc)\height
temp(i,j)\height=A
temp(i,j)\latitude=geostat(numhMap,iloc,jloc)\latitude
temp(i,j)\slope=geostat(numhMap,iloc,jloc)\slope
temp(i,j)\temperature=geostat(numhMap,iloc,jloc)\temperature
temp(i,j)\isWater=geostat(numhMap,iloc,jloc)\isWater
temp(i,j)\couleur=geostat(numhMap,iloc,jloc)\couleur
For k=0 To 5
temp(i,j)\probaterrain[k]=geostat(numhMap,iloc,jloc)\probaterrain[k]
Next k
iloc=iori+1+i/2
B=geostat(numhMap,iloc,jloc)\height
temp(i+2,j)\height=B
temp(i+2,j)\latitude=geostat(numhMap,iloc,jloc)\latitude
temp(i+2,j)\slope=geostat(numhMap,iloc,jloc)\slope
temp(i+2,j)\temperature=geostat(numhMap,iloc,jloc)\temperature
temp(i+2,j)\isWater=geostat(numhMap,iloc,jloc)\isWater
temp(i+2,j)\couleur=geostat(numhMap,iloc,jloc)\couleur
For k=0 To 5
temp(i+2,j)\probaterrain[k]=geostat(numhMap,iloc,jloc)\probaterrain[k]
Next k
iloc=iori+i/2:jloc=jori+1+j/2
C=geostat(numhMap,iloc,jloc)\height
temp(i,j+2)\height=C
temp(i,j+2)\latitude=geostat(numhMap,iloc,jloc)\latitude
temp(i,j+2)\slope=geostat(numhMap,iloc,jloc)\slope
temp(i,j+2)\temperature=geostat(numhMap,iloc,jloc)\temperature
temp(i,j+2)\isWater=geostat(numhMap,iloc,jloc)\isWater
temp(i,j+2)\couleur=geostat(numhMap,iloc,jloc)\couleur
For k=0 To 5
temp(i,j+2)\probaterrain[k]=geostat(numhMap,iloc,jloc)\probaterrain[k]
Next k
iloc=iori+1+i/2
D=geostat(numhMap,iloc,jloc)\height
temp(i+2,j+2)\height=D
temp(i+2,j+2)\latitude=geostat(numhMap,iloc,jloc)\latitude
temp(i+2,j+2)\slope=geostat(numhMap,iloc,jloc)\slope
temp(i+2,j+2)\temperature=geostat(numhMap,iloc,jloc)\temperature
temp(i+2,j+2)\isWater=geostat(numhMap,iloc,jloc)\isWater
temp(i+2,j+2)\couleur=geostat(numhMap,iloc,jloc)\couleur
For k=0 To 5
temp(i+2,j+2)\probaterrain[k]=geostat(numhMap,iloc,jloc)\probaterrain[k]
Next k
; A=temp(i,j)\height
; B=temp(i+2,j)\height
; C=temp(i,j+2)\height
; D=temp(i+2,j+2)\height
; Debug Str(i)+","+Str(j)
; Debug "A = "+StrF(A)+" | B = "+StrF(B)+" | C = "+StrF(C)+" | D = "+StrF(D)
; Debug "ab = "+StrF(temp(i+1,j)\height)+" | ac = "+StrF(temp(i,j+1)\height)+" | bd = "+StrF(temp(i+2,j+1)\height)+" | cd = "+StrF(temp(i+1,j+2)\height)+" | m = "+StrF(temp(i+1,j+1)\height)
; iloc=iori+i/2:jloc=jori+j/2
; Height / latitude / temperature for new points
If i=0
temp(i,j+1)\height = (A+C)/2 + noise3D(xori+(i*unitSize),yori+((j+1)*unitSize),seed) * noiseScale ;ac
terrainLatitude(temp(i,j+1),(yori+((j+1)*unitSize)),totalNS)
terrainTemperature(temp(i,j+1),geotype(numHmap)\minHeight)
EndIf
If j=0
temp(i+1,j)\height = (A+B)/2 + noise3D(xori+((i+1)*unitSize),yori+(j*unitSize),seed) * noiseScale ; ab
terrainLatitude(temp(i+1,j),(yori+(j*unitSize)),totalNS)
terrainTemperature(temp(i+1,j),geotype(numHmap)\minHeight)
EndIf
temp(i+1,j+1)\height=(A+B+C+D)/4 + noise3D(xori+((i+1)*unitSize),yori+((j+1)*unitSize),seed) * noiseScale ; m
terrainLatitude(temp(i+1,j+1),(yori+((j+1)*unitSize)),totalNS)
terrainTemperature(temp(i+1,j+1),geotype(numHmap)\minHeight)
temp(i+2,j+1)\height = (B+D)/2 + noise3D(xori+((i+2)*unitSize),yori+((j+1)*unitSize),seed) * noiseScale ; bd
terrainLatitude(temp(i+2,j+1),(yori+((j+1)*unitSize)),totalNS)
terrainTemperature(temp(i+2,j+1),geotype(numHmap)\minHeight)
temp(i+1,j+2)\height = (C+D)/2 + noise3D(xori+((i+1)*unitSize),yori+((j+2)*unitSize),seed) * noiseScale ; cd
terrainLatitude(temp(i+1,j+2),(yori+((j+2)*unitSize)),totalNS)
terrainTemperature(temp(i+1,j+2),geotype(numHmap)\minHeight)
; Slope
terrainSlope(temp,i,j)
terrainSlope(temp,i+1,j)
terrainSlope(temp,i,j+1)
terrainSlope(temp,i+1,j+1)
; Terrain types
terrainColor(temp(i,j))
terrainColor(temp(i+1,j))
terrainColor(temp(i,j+1))
terrainColor(temp(i+1,j+1))
; Debug "-> m = "+StrF(temp(i+1,j+1)\height)+" (noise = "+StrF(temp(i+1,j+1)\height-(A+B+C+D)/4)+") Temp° = " + StrF(temp(i+1,j+1)\temperature)
; Debug "-> ab = "+StrF(temp(i+1,j)\height)+" (noise = "+StrF(temp(i+1,j)\height-(A+B)/2)+") Temp° = " + StrF(temp(i+1,j)\temperature)
; Debug "-> ac = "+StrF(temp(i,j+1)\height)+" (noise = "+StrF(temp(i,j+1)\height-(A+C)/2)+") Temp° = " + StrF(temp(i,j+1)\temperature)
; Debug "-> bd = "+StrF(temp(i+2,j+1)\height)+" (noise = "+StrF(temp(i+2,j+1)\height-(B+D)/2)+") Temp° = " + StrF(temp(i+2,j+1)\temperature)
; Debug "-> cd = "+StrF(temp(i+1,j+2)\height)+" (noise = "+StrF(temp(i+1,j+2)\height-(C+D)/2)+") Temp° = " + StrF(temp(i+1,j+2)\temperature)
; Debug ""
Next i
Next j
; Copy the zoomed portion into the Geostat array
For i=0 To maxgrid-1
For j=0 To maxgrid-1
geostat(numhMap,i,j)\height=temp(i,j)\height
geostat(numhMap,i,j)\latitude=temp(i,j)\latitude
geostat(numhMap,i,j)\slope=temp(i,j)\slope
geostat(numhMap,i,j)\temperature=temp(i,j)\temperature
geostat(numhMap,i,j)\isWater=temp(i,j)\isWater
geostat(numhMap,i,j)\couleur=temp(i,j)\couleur
For k=0 To 5
geostat(numhMap,i,j)\probaterrain[k]
Next k
Next j
Next i
EndProcedure
DisableExplicit
;- ---------- Main program ----------
;- Initial map design
makeDiamondSquare(0,maxgrid,unitsize,seed,0,0)
ComputeGeoStats(0,maxgrid,zoomlevel,waterLevel,tpol,teq,seed)
CreateImage(0,maxgrid,maxgrid,32)
CreateImage(1,maxgrid,maxgrid,32)
MakeTerrainImage(0,0,maxgrid,"terrain")
MakeTerrainImage(1,0,maxgrid,"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_1, 15, 5, 512, 512, 1)
ImageGadget(#Image_2, 530, 5, 512, 512, 0)
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, 720, 530, 250, 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)
CheckBoxGadget(#TB_anim,660,630, 250, 25, "Animated zoom")
SetGadgetState(#TB_anim,1)
SetGadgetFont(#TB_anim, 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))
;- Zoom area sprite
InitSprite()
OpenWindowedScreen(WindowID(#Window_0),15,5,512,512,0,0,0)
StartDrawing(ScreenOutput())
DrawImage(ImageID(0),0,0)
StopDrawing()
CreateSprite(1,256,256)
StartDrawing(SpriteOutput(1))
Box(0,0,255,255,$000000)
DrawingMode(#PB_2DDrawing_Outlined)
Box(0,0,255,255,$00AA00):Box(2,2,251,251,$00AA00)
Box(1,1,253,253,$00DD00)
StopDrawing()
;- 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))
zoomLevel=0:unitSize=#MAXUNITSIZE/Pow(2,zoomLevel)
xori=0:yori=0
makeDiamondSquare(0,maxgrid,unitsize,seed,0,0)
ComputeGeoStats(0,maxgrid,zoomLevel,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))
;- Left-click on map to zoom
Case #image_1
x=xzoom:y=yzoom
If x>=0 And y>=0 And x<=maxgrid-255 And y<=maxgrid-255 And UnitSize>1
xori+(x*unitSize):yori+(y*unitSize)
zoomlevel+1
unitSize=#MAXUNITSIZE/Pow(2,zoomlevel)
ZoomX2(0,maxgrid,zoomlevel,seed,x,y,xori,yori,unitsize)
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
; Animated zoom
If GetGadgetState(#TB_anim)=1
For i=256 To 1 Step-16
StartDrawing(ScreenOutput())
DrawImage(ImageID(0),x-((256-i)*(x/256.0)),y-((256-i)*(y/256.0)),maxgrid-i,maxgrid-i)
StopDrawing()
FlipBuffers()
Next i
EndIf
StartDrawing(ScreenOutput())
DrawImage(ImageID(0),0,0)
StopDrawing()
FlipBuffers()
SetGadgetState(#image_1,ImageID(0))
SetGadgetState(#image_2,ImageID(1))
EndIf
Case #BT_close
quit=1
EndSelect
EndSelect
;- Move zoom area
If ElapsedMilliseconds()-timer>40
StartDrawing(ScreenOutput())
DrawImage(ImageID(0),0,0)
xzoom+127:yzoom+127
If xzoom>=0 And yzoom>=0 And xzoom<maxgrid And yzoom<maxgrid
DrawingMode(#PB_2DDrawing_Transparent)
DrawText(5,5,"x,y = "+Str(xori+xzoom*unitsize)+","+Str(yori+yzoom*unitsize)+" \ "+"Zoom x"+Str(Pow(2,zoomlevel))+", 1 pixel = "+StrF(unitSize,2),$FFFF00)
DrawText(5,20,"Lat. = "+ReplaceString(StrF(90-geostat(0,xzoom,yzoom)\latitude*90,2),".","°")+"' / Height = "+StrF(geostat(0,xzoom,yzoom)\height,2)+" / Slope = "+StrF(geostat(0,xzoom,yzoom)\slope,2)+" / Temp. = "+StrF(geostat(0,xzoom,yzoom)\temperature,2)+"°C",$FFFF00)
EndIf
StopDrawing()
xzoom=WindowMouseX(#Window_0)-15-127
yzoom=WindowMouseY(#Window_0)-5-127
If xzoom>=0 And xzoom<maxgrid-255 And yzoom>=0 And yzoom<maxgrid-255
DisplayTransparentSprite(1,xzoom,yzoom)
EndIf
FlipBuffers()
timer=ElapsedMilliseconds()
EndIf
Until Quit
