This little program generates a random terrain (using a diamond-square algorithm to produce a 2D Perlin-like noise), and computes temperature and slope for each point of the map. Then, using altitude/temperature/slope, it determines which kind of terrain is predominant (desert, forest, tundra, etc..) and colors the map accordingly.
You can also zoom on the generated map (up to x4096), and the program will generate all the needed informations on-the-fly.
There's a bug in this code, one I didn't manage to fix: even though the details are correctly generated during the zooming process, the "pixels" of the initial map still appear, causing large square patterns; And I don't know how to blend these patterns seamlessly with its neighbours.
If someone's got an idea...
Code: Select all
; 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 in this
; altitute/slope/temperature configuration.
; - Draw an image from these datas.
; - You can zoom the map to show smaller areas (up to x4096)
;
; It should look like a (very simple) earth-like map.
;
; ---------------------------------------------------------------------------------------------------------------
; Known Problems:
; ---------------------------------------------------------------------------------------------------------------
; - Rivers disappear when you zoom
; - Square patterns (the "pixels" in the initial zoom level) appears in the "slope" maps,
; affecting relief coloring, and I don't know how to "blend" them seamlessly
;- Constants
#e = 2.718281828459045235
#MAXUNITSIZE = 4096
#USEAPIDRAWING = #True ; set this to false in 4.40, or to compile under Mac or Linux
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
CompilerIf #USEAPIDRAWING = #True
Structure myBITMAPINFO
bmiHeader.BITMAPINFOHEADER
bmiColors.RGBQUAD[1]
EndStructure
CompilerEndif
;- 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+(waterLevel/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 ---
;************************************************************************************
; Name: terrainLatitude
; Purpose: determine the latitude of a point (i.e. map it on a sphere and see how close
; it is from the north pole)
; Parameters:
; - point of the map
; - north/south coordinates of the map at the current zoom level
; - distance between the "northest" and the "southest" point on the map
; (i.e. scale of the map at the current zoom level)
;************************************************************************************
Macro terrainLatitude(matrixPoint,coordNS,distanceNS)
matrixPoint#\latitude = Cos((coordNS-distanceNS/2)/distanceNS *#PI)
EndMacro
;************************************************************************************
; Name: terrainTemperature
; Purpose: determine the temperature of a point, according to its latitude and altitude
; Parameters:
; - point of the map
; - altitude of the deepest point in the map
;************************************************************************************
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
;************************************************************************************
; Name: terrainSlope
; Purpose: determine the slope of a point, according to the points around it
; Parameters:
; - point of the map
; - coords i,j of the point
;************************************************************************************
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
;************************************************************************************
; Name: terrainColor
; Purpose: determine the color of a point, according to its terrain type, temperature, etc..
; Parameters:
; - point of the map
;************************************************************************************
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
CompilerIf #USEAPIDRAWING = #True
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)
*pixel = *mem
CompilerElse
StartDrawing(ImageOutput(numImage))
CompilerEndIf
ratio = 255.0/(geotype(numHmap)\maxHeight-geotype(numHmap)\minHeight)
For j=maxgrid-1 To 0 Step-1
For i=0 To maxgrid-1
Select imageType
Case "altitude"
red = (geostat(numHmap,i,j)\height - geotype(numHmap)\minHeight)*ratio
green = red:blue = Red ; (greyscale)
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
EndIf
Case "slope"
red = geostat(numHmap,i,j)\slope*32
If red > 255
red = 255
EndIf
green = red:blue = Red ; (greyscale)
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
EndSelect
CompilerIf #USEAPIDRAWING = #True
color=RGB(blue,green,red)
*pixel\l=color
*pixel + 4
CompilerElse
color=RGB(red,green,blue)
Plot(i,j,color)
CompilerEndIf
Next i
Next j
CompilerIf #USEAPIDRAWING = #True
SetDIBits_(hDC,hBmp,1,maxgrid+1,*mem,bmi,#DIB_RGB_COLORS)
CompilerEndIf
StopDrawing()
CompilerIf #USEAPIDRAWING = #True
FreeMemory(*mem)
CompilerEndIf
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 zoom 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]=temp(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 )
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
