` Green Gandalf's fractal terrain and texture demo
 
set display mode 640,480,32
set text opaque
sync on: sync rate 60: sync
autocam off`: color backdrop 0
 
set cursor 20,20
 
n=8: dispersion#=512: k=0 ` n=8 gives a 256x256 bitmap
 
maxgrid=2^n: g=maxgrid
dim col(3,maxgrid,maxgrid) as float
dim col2(3,maxgrid,maxgrid) as float
`dim levRed(5): dim levGreen(5): dim levBlue(5)
base as dword
global cx#: global cy#: global cz#
 
im=1: gosub makeImage ` prepare initial image
 
gosub makeCrudeHeightMap
 
` modify crude height map
gosub modifyCrudeHeightmap
 
` make terrain
gosub makeTerrain
 
end
 
make_bitmap:
  create bitmap im,maxgrid+1,maxgrid+1
  lock pixels
    for i=0 to maxgrid
      for j=0 to maxgrid
        gosub dotij
      next j
    next i
  unlock pixels
  ` save base image
  get image 1, 0, 0, 256, 256
  if file exist("baseImage.png") then delete file "baseImage.png"
  save image "baseImage.png",1
  set current bitmap 0
  cls
  copy bitmap im,0
  center text screen width()/2,screen height()/2+20,"Initial Random Fractal Image"
  center text screen width()/2,screen height()/2+40,"used for preparing textures."
  center text screen width()/2,screen height()/2+80,"Press any key to continue"
  sync
  wait key
return
 
dotij:
  dot i,j,rgb(col(1,i,j),col(2,i,j),col(3,i,j))
return
 
diamond_step:
  i=mid: i1=i-mid: i2=i+mid
  while i<maxgrid
    j=mid: j1=j-mid: j2=j+mid
    while j<maxgrid
      av#=(col(r,i1,j1)+col(r,i1,j2)+col(r,i2,j1)+col(r,i2,j2))/4.0
      ` calculate random values between -1 and 1
      u#=rnd(16384)/8192.0-1.0
      col(r,i,j)=av#+u#*d#`+m#
      inc j,g: inc j1,g: inc j2,g
    endwhile
    inc i,g: inc i1,g: inc i2,g
  endwhile
return
 
square_step:
  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
      av#=0
      if i1<0  ` check for need to wrap around i value
        inc av#,col(r,i2,j)+col(r,i2,j)
      else
        if i2>maxgrid
          inc av#,col(r,i1,j)+col(r,i1,j)
        else
          inc av#,col(r,i1,j)+col(r,i2,j)
        endif
      endif
      if j1<0  ` check for need to wrap around j value
        inc av#,col(r,i,j2)+col(r,i,j2)
      else
        if j2>maxgrid
          inc av#,col(r,i,j1)+col(r,i,j1)
        else
          inc av#,col(r,i,j1)+col(r,i,j2)
        endif
      endif
      av#=av#/4
      ` calculate random value between -1 and 1
      u#=rnd(16384)/8192.0-1.0
      col(r,i,j)=av#+u#*d#`+m#
      col(r,maxgrid,j)=col(r,0,j) ` copy opposite edge
      inc j,g: inc j1,g: inc j2,g
    endwhile
    if j=maxgrid then col(r,i,j)=col(r,i,0) ` copy opposite edge
    inc i,mid: inc i1,mid: inc i2,mid
  endwhile
return
 
makeImage:
  ` creates a fractal image loosely based on the "diamond-square algorithm"
  ` Produces a fractal image loosely based on the "diamond-square algorithm"
  ` described in following website
  `          http://www.gameprogrammer.com/fractal.html
  cls
  randomize timer()
  for r=1 to 3  ` process each colour component separately
    g=maxgrid
    d#=dispersion#
    for i=0 to maxgrid
      for j=0 to maxgrid
        col(r,i,j)=k
      next j
    next i
 
    ` main loop
    while g>1
      mid=g/2
 
      ` diamond step - calculates new diamond corners from squares
      gosub diamond_step
 
      ` square step - calculates new square corners from diamonds
      gosub square_step
 
      d#=d#/2.0: m#=m#/2.0: g=g/2
    endwhile
 
    ` now scale heightmap values to byte range
    min#=col(r,0,0): max#=min#
    for i=0 to maxgrid
      for j=0 to maxgrid
        u#=col(r,i,j)
        if u#<min#
          min#=u#
        else
          if u#>max# then max#=u#
        endif
      next j
    next i
    max#=256/(max#-min#)
    for i=0 to maxgrid
      for j=0 to maxgrid
        temp=int((col(r,i,j)-min#)*max#)
        ` range check for byte just in case
        if temp<0
          col(r,i,j)=0
        else
          if temp>255
            col(r,i,j)=255
          else
            col(r,i,j)=temp
          endif
        endif
      next j
    next i
  next r
 
  gosub make_bitmap
 
return
 
dotij2:
  select m
    case 3
      minBlue=200: minGrey=85
      grey=(col(1,i,j)+col(2,i,j)+col(3,i,j))/3
      if grey<minBlue
        if grey<minGrey then grey=minGrey
        blue=minBlue
      else
        blue=grey
      endif
      red=grey: green=grey
    endcase
    case 4
      brown1=60: brown2=128: brownA=20: brownB=200
      brown=(col(1,i,j)+col(2,i,j)+col(3,i,j))/3
      if brown<brown1
        brown = (brown*brownA)/brown1
        blue=brown: green=blue/2: red=green/2
      else
        if brown<brown2
          brown = ((brown-brown1)*(brownB-brownA))/(brown2-brown1)+brownA
          blue=brown: green=blue*0.8: red=green*0.6
        else
          brown = ((brown-brown2)*(255-brownB))/(255-brown2)+brownB
          blue=brown: green=blue*0.9: red=green*0.8
        endif
      endif
    endcase
    case 6
      freq#=35.0*360.0/255.0
      grey=32*(0.5-sin(freq#*(col(1,i,j)+col(2,i,j)+col(3,i,j))/3.0)^2)+127.6
      red=grey: green=grey: blue=grey
    endcase
    case 9
      in1=100: in2=170: out0=0: out1=20: out2=180
      grey=(col2(1,i,j)+col2(2,i,j)+col2(3,i,j))/3
      if grey<in1
        red = grey*(out1-out0)/in1+out0: green=80: blue=5
      else
        if grey<in2
          red = (grey-in1)*(out2-out1)/(in2-in1)+out1
          green=(grey-in1)*(out2-80)/(in2-in1)+80
          blue=(grey-in1)*(100-5)/(in2-in1)+5
        else
          red = (grey-in2)*(255-out2)/(255-in2)+out2
          green=(grey-in2)*(255-out2)/(255-in2)+out2
          blue=(grey-in2)*(255-100)/(255-in2)+100
        endif
      endif
 
    endcase
    case default
      red=col(1,i,j): green=col(2,i,j): blue=col(3,i,j)
    endcase
  endselect
  dot i,j,rgb(red,green,blue)
return
 
modifyImage:
  create bitmap m*10,maxgrid+1,maxgrid+1
  lock pixels
    for i=0 to maxgrid
      for j=0 to maxgrid
        gosub dotij2
      next j
    next i
  unlock pixels
  set current bitmap 0
  cls
  copy bitmap m*10,0
  center text screen width()/2,screen height()/2,"Press any key to continue"
  center text screen width()/2,screen height()/2+50,"Space bar to quit"
  sync
  wait key
  set current bitmap m*10
  if image exist(m*10)=0 then get image m*10,0,0,256,256
  set current bitmap 0
return
 
makeCrudeHeightMap:
  if bitmap exist(5)=0 then create bitmap 5,256,256
  set current bitmap 5
  cls rgb(0,0,0)
  ` create random low wide plateaus (dark grey)
    ink rgb(63,63,63),0
  for p1=1 to 12
    left=rnd(160)+15: right= left+64
    top= rnd(160)+15: bottom=top+64
    box left, top, right, bottom
    ` create random medium plateaus (medium grey)
  next p1
  ink rgb(144,144,144),0
  for p2=1 to 24
    left=rnd(160)+31: right= left+32
    top= rnd(160)+31: bottom=top+32
    box left, top, right, bottom
  next p2
  ` create random high plateaus (white)
  ink rgb(255,255,255),0
  for p3=1 to 36
    left=rnd(144)+47: right= left+16
    top= rnd(144)+47: bottom=top+16
    box left, top, right, bottom
  next p3
 
  set current bitmap 0
  cls
  copy bitmap 5,0
  center text screen width()/2,screen height()/2,"Initial random heightmap"
  center text screen width()/2,screen height()/2+50,"Press any key to continue"
  sync
  wait key
  ` now smooth the heightmap several times
  cls
  center text screen width()/2,screen height()/2,"Blurring heightmap - please wait"
  sync
  lock pixels
    for b=1 to 5
      blur bitmap 5, 6
    next b
    ` find max height value of each colour component
    maxr=0: maxg=0: maxb=0
    for i=0 to 255
      for j=0 to 255
        base=point(i,j)
        if rgbr(base)>maxr then maxr=rgbr(base)
        if rgbg(base)>maxg then maxg=rgbg(base)
        if rgbb(base)>maxb then maxb=rgbb(base)
      next j
    next i
    ` find factor for each colour component
    rf#=1020.0/((maxr+255)^2)
    gf#=1020.0/((maxg+255)^2)
    bf#=1020.0/((maxb+255)^2)
  unlock pixels
  cls
  copy bitmap 5,0
  center text screen width()/2,screen height()/2,"Blurred random heightmap"
  center text screen width()/2,screen height()/2+50,"Press any key to continue"
  sync
  wait key
 
return
 
modifyCrudeHeightmap:
  ` apply random image to crude heightmap
  set current bitmap 5
  lock pixels
    for i=0 to 255
      for j=0 to 255
        base=point(i,j)
        red=  rgbr(base)*(maxr-rgbr(base)+col(1,i,j))*rf#
        green=rgbg(base)*(maxg-rgbg(base)+col(2,i,j))*gf#
        blue= rgbb(base)*(maxb-rgbb(base)+col(3,i,j))*bf#
        dot i,j,rgb(red,green,blue)
        col2(1,i,j)=red: col2(2,i,j)=green: col2(3,i,j)=blue:
      next j
    next i
  unlock pixels
  ` get the final heightmap
  get image 5,0,0,256,256,1
  set current bitmap 0
  cls
  copy bitmap 5,0
  center text screen width()/2,screen height()/2,"Modified heightmap"
  center text screen width()/2,screen height()/2+50,"Press any key to continue"
  sync
  wait key
 
return
 
makeTerrain:
  ` make the terrain and save the images used
  set current bitmap 0
  cls
  center text screen width()/2,screen height()/2,"Ready to prepare textures"
  center text screen width()/2,screen height()/2+50,"Press any key to continue"
  sync
  wait key
 
  ` create base texture
  m=9: gosub modifyImage
  ` save the base texture
  if file exist("tempBase.png") then delete file "tempBase.png"
  save image "tempBase.png",90
 
  ` create detail texture
  m=6: gosub modifyImage
  ` save the detail texture
  if file exist("tempDetail.png") then delete file "tempDetail.png"
  save image "tempDetail.png",60
 
  ` save the heightmap
  if file exist("tempHmap.png") then delete file "tempHmap.png"
  save image "tempHmap.png",5
  set current bitmap 0
 
  ` create the sky sphere
  make object sphere 15,3000
  position object 15, 384,-500,384
  xrotate object 15, 90
  m=3: gosub modifyImage
  ` save the sky image
  if file exist("tempSky.png") then delete file "tempSky.png"
  save image "tempSky.png",30
  texture object 15, 30
  set object cull 15,0
 
  ` create the sea plain
  make object plain 25,3000,3000
  position object 25, 0,20,0
  xrotate object 25, -90
  m=4: gosub modifyImage
  ` save the sea image
  if file exist("tempSea.png") then delete file "tempSea.png"
  save image "tempSea.png",40
  texture object 25, 40
  `set object cull 15,0
 
  `create some fog
  fog on
  fog color rgb(255,0,0)
  fog distance 2000
 
  cls
  xscale#=3: yscale#=0.6: zscale#=3
  make object terrain 1                            ` create the terrain object
  set terrain heightmap 1, "tempHmap.png"          ` set the heightmap
  set terrain scale 1, xscale#, yscale#, zscale#   ` set the scale
  set terrain split 1, 4                          ` split value by 16 * 16
  set terrain tiling 1, 16                         ` detail map tiling
  set terrain light 1, 1, -0.25, 0, 1, 1, 1, 0.5  ` light - xdir, ydir, zdir, red, green, blue, intensity
  set terrain texture 1, 90, 60                        ` base and detail texture
 
  build terrain 1                                    ` finally build the terrain
 
  cx#=384: cy#=get terrain ground height(1,cx#,cz#)+10: cz#=384
  position camera cx#, cy#,cz#
  point camera 0, cy#, 0
  ink 0,0
  set text transparent
  set text font "Arial"
  set text size 12
  repeat
   ` cls
    text 20,15,"fps="+str$(screen fps())
    text 20,30,"camx="+str$(camera position x(),1)
    text 20,45,"camy="+str$(camera position y(),1)
    text 20,60,"camz="+str$(camera position z(),1)
    text 20,90,"Move forwards/backwards with up/down arrow keys."
    text 20,115,"Use mouse to control camera."
    text 20,130,"Press and hold <return> for fog, <space> to quit."
    positionCamera()
    scroll object texture 15,0.0002,0.0002
    scroll object texture 25,0.0001,0.0001
    update terrain
    if returnkey()>0
      fog on
      fog color rgb(200,200,200)
      fog distance 1000
    else
      fog off
    endif
    sync
  until spacekey()>0
 
  end
return
 
function positionCamera()
  control camera using arrowkeys 0,1,0
  cx#=cx#+mousemovey():cy#=cy#+mousemovex()
  rotate camera cx#,cy#,0
  camx#=camera position x(): camz#=camera position z()
  camy#=get terrain ground height(1,camx#,camz#)+10
  position camera camx#,camy#,camz#
endfunction