type World
   meshID as integer
   width as float
   depth as float
   xsegs as integer
   zsegs as integer
endtype
 
null = make vector3(1)
null = make vector3(2)
null = make matrix4(3) : projection matrix4 3
null = make matrix4(4) : view matrix4 4
null = make matrix4(5) : world matrix4 5
 
#constant N1 = 6
#constant N2 = 7
#constant N3 = 8
#constant N4 = 9
#constant T1 = 10
#constant T2 = 11
 
for t = 6 to 11
   null = make vector3(t)
next t
 
 
 
global myWorld as World
 
myWorld.meshID = 1
myWorld.width = 1000
myWorld.depth = 1000
myWorld.xsegs = 20
myWorld.zsegs = 20
 
`load image "D:\programming\dbpro projects\terrain_texture.jpg", 1
 
createWorldMesh(myWorld)
make object 1,1,0
position object 1,0,1,0
 
for z = 0 to myWorld.zsegs
   for x = 0 to myWorld.xsegs
   `setHeight(myWorld,x,z,rnd(20))
   next x
next z
make mesh from memblock 1,1
change mesh 1,0,1
`texture object 1,1
`scale object texture 1, 10, 10
 
 
 
sync on
sync rate 60
 
cy1# = 200
camera = 2
 
ink rgb(255,0,0),0
 
DO
 
   oldcx# = camera position x()
   oldcz# = camera position z()
 
 
   if camera = 1
      gosub _camera_control
   else
      gosub _control_camera
 
      if mousemovex() <> 0 OR mousemovey() <> 0 OR oldcx# <> camera position x() OR oldcz# <> camera position z()
         obj = pick object(mousex(), mousey(),1,1)
         if obj = 0
 
         else
            wx# = camera position x() + get pick vector x()
            wy# = camera position y() + get pick vector y()
            wz# = camera position z() + get pick vector z()
         endif
      endif
 
      if mouseclick() = 1 then raiseGround(wx#, wz#, 0.5)
      if mouseclick() = 2 then raiseGround(wx#, wz#, -0.5)
 
      if mouseclick() > 0 then calculateNormals(myWorld)
 
      outlineTile(myWorld, wx#, wz#)
   endif
 
   rem pick camera
   if inkey$() = "1" then camera = 1
   if inkey$() = "2" then camera = 2
 
 
   set cursor 0,0
   print screen fps()
 
   sync
LOOP
 
 
 
 
 
REM
function outlineTile(w as World,wx#,wz#)
   sx# = w.width / w.xsegs
   sz# = w.depth / w.zsegs
   tilex = wx# / sx#
   tilez = wz# / sz#
 
   project3dTo2d(1,tilex*sx#,getHeight#(w,tilex,tilez),tilez*sz#)
   x1 = x vector3(1)
   y1 = y vector3(1)
 
   project3dTo2d(1,tilex*sx#,getHeight#(w,tilex,tilez+1),(tilez+1)*sz#)
   x2 = x vector3(1)
   y2 = y vector3(1)
 
   project3dTo2d(1,(tilex+1)*sx#,getHeight#(w,tilex+1,tilez+1),(tilez+1)*sz#)
   x3 = x vector3(1)
   y3 = y vector3(1)
 
   project3dTo2d(1,(tilex+1)*sx#,getHeight#(w,tilex+1,tilez),tilez*sz#)
   x4 = x vector3(1)
   y4 = y vector3(1)
 
   line x1,y1,x2,y2
   line x2,y2,x3,y3
   line x3,y3,x4,y4
   line x1,y1,x4,y4
endfunction
 
 
 
REM
function raiseGround(wx#, wz#, height#)
 
   sx# = myWorld.width / myWorld.xsegs
   sz# = myWorld.depth / myWorld.zsegs
   x = (camera position x() + get pick vector x()) / sx#
   z = (camera position z() + get pick vector z()) / sz#
 
   setheight(myWorld, x, z, getHeight#(myWorld,x,z)+height#)
   setheight(myWorld, x, z+1, getHeight#(myWorld,x,z+1)+height#)
   setheight(myWorld, x+1, z+1, getHeight#(myWorld,x+1,z+1)+height#)
   setheight(myWorld, x+1, z, getHeight#(myWorld,x+1,z)+height#)
 
   make mesh from memblock myWorld.meshID, myWorld.meshID
   change mesh myWorld.meshID, 0, myWorld.meshID
   `texture object myWorld.meshID, 1
   `scale object texture myWorld.meshID, 10,10
 
endfunction
 
 
 
 
REM
function getHeight#(w as world, x as integer, z as integer)
   if x < 0 OR x > w.xsegs OR z < 0 OR z > w.zsegs then exitfunction 0.0
   height# = 0.0
   if x < w.xsegs and z < w.zsegs
      pos = z*w.xsegs*216 + x*216 + 12
      height# = memblock float(w.meshID, pos+4)
   else
      if x = w.xsegs
         if z = w.zsegs
            pos = (z-1)*w.xsegs*216 + (x-1)*216 + 12
            height# = memblock float(w.meshID, pos+76)
         else
            pos = z*w.xsegs*216 + (x-1)*216 + 12
            height# = memblock float(w.meshID, pos+184)
         endif
      else
         pos = (z-1)*w.xsegs*216 + x*216 + 12
         height# = memblock float(w.meshID, pos+40)
      endif
   endif
endfunction height#
 
 
 
REM set the height at (X,Z)
REM must set multiple verts per point because verts are not shared
function setHeight(w as World, x as integer, z as integer, height as float)
   if x < 0 OR x > w.xsegs OR z < 0 OR z > w.zsegs then exitfunction
 
   rem verts 3 and 5
   if x > 0 and z > 0
      tx = x-1
      tz = z-1
      pos = tz*w.xsegs*216 + tx*216 + 12
      write memblock float w.meshID, pos+76, height
      write memblock float w.meshID, pos+148, height
   endif
 
   rem vert 2
   if x < w.xsegs and z > 0
      tx = x
      tz = z-1
      pos = tz*w.xsegs*216 + tx*216 + 12
      write memblock float w.meshID, pos+40, height
   endif
 
   rem vert 6
   if x > 0 and z < w.xsegs
      tx = x-1
      tz = z
      pos = tz*w.xsegs*216 + tx*216 + 12
      write memblock float w.meshID, pos+184, height
   endif
 
   rem verts 1 and 4
   if x < w.xsegs and z < w.zsegs
      tx = x
      tz = z
      pos = tz*w.xsegs*216 + tx*216 + 12
      write memblock float w.meshID, pos+4, height
      write memblock float w.meshID, pos+112, height
   endif
 
endfunction
 
 
 
function project3dTo2d(result as integer,x as float, y as float, z as float)
   set vector3 result,x,y,z
   view matrix4 4
   project vector3 result,result,3,4,5
endfunction
 
 
 
_Control_Camera:
   cspd# = 2.0
   if upkey() then inc cz#,cspd#
   if downkey() then dec cz#,cspd#
   if rightkey() then inc cx#,cspd#
   if leftkey() then dec cx#,cspd#
   if scancode()=30 then inc cy1#,1
   if scancode()=44 then dec cy1#,1
 
   if cy1# < 0 then cy1# = 0
 
   position camera cx#,cy1#,cz#
   offsetx#=cx#
   offsety#=0
   offsetz#=cz#+200
   point camera offsetx#,offsety#,offsetz#
RETURN
 
 
_camera_control:
   spd# = 2
   if upkey()=1
    cx#=newxvalue(cx#,a#,spd#)
    cz#=newzvalue(cz#,a#,spd#)
   endif
   if downkey()=1
    cx#=newxvalue(cx#,a#,-spd#)
    cz#=newzvalue(cz#,a#,-spd#)
   endif
   if leftkey()=1
    cx#=newxvalue(cx#,wrapvalue(a#-90.0),spd#)
    cz#=newzvalue(cz#,wrapvalue(a#-90.0),spd#)
   endif
   if rightkey()=1
    cx#=newxvalue(cx#,wrapvalue(a#+90.0),spd#)
    cz#=newzvalue(cz#,wrapvalue(a#+90.0),spd#)
   endif
 
   cy# = getGroundHeight#(myWorld,cx#,cz#)
   a#=wrapvalue(a#+(mousemovex()/3.0))
   cxa#=cxa#+(mousemovey()/3.0)
   if cxa#<-90.0 then cxa#=-90.0
   if cxa#>90.0 then cxa#=90.0
   position camera cx#,cy#+40,cz#
   rotate camera wrapvalue(cxa#),a#,0
RETURN
 
 
 
 
REM returns the height on the world mesh at position (x,z)
function getGroundHeight#(w as World, x as float, z as float)
   id = w.meshID
   tsx# = w.width / w.xsegs
   tsz# = w.depth / w.zsegs
 
   row = z / tsz#
   column = x / tsx#
 
   if row < 0 OR row >= w.xsegs OR column < 0 OR column >= w.zsegs then exitfunction 0.0
 
   tile = row*w.xsegs + column
   znorm# = z - row * tsz#
   xnorm# = x - column * tsx#
 
   rem get the triangle
   if tsz#*xnorm# >= tsx#*znorm#
      pos = 12 + tile*216+112
      y1# = memblock float(id,pos)
      y2# = memblock float(id,pos+36)
      y3# = memblock float(id,pos+72)
      y# = y1#+(znorm#/tsz#)*(y2#-y3#)+(xnorm#/tsx#)*(y3#-y1#)
   else
      pos = 12 + tile*216+4
      y1# = memblock float(id,pos)
      y2# = memblock float(id,pos+36)
      y3# = memblock float(id,pos+72)
      y# = y1#+(znorm#/tsz#)*(y2#-y1#)+(xnorm#/tsx#)*(y3#-y2#)
   endif
endfunction y#
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
function calculateNormals(w as World)
 
   tsx# = w.width/w.xsegs
   tsz# = w.depth/w.zsegs
 
   for z = 1 to w.zsegs-1
      for x = 1 to w.xsegs-1
 
         count = 0
 
         rem root
         set vector3 2, x*tsx#, getHeight#(w,x,z), z*tsz#
 
 
         rem upper right
         set vector3 T1,0,getHeight#(w,x,z+1),tsz#
         set vector3 T2,tsx#,getHeight#(w,x+1,z),0
         subtract vector3 T1,T1,2
         subtract vector3 T2,2,T2
         cross product vector3 N1,T1,T2
         normalize vector3 N1, N1
 
         rem upper left
         set vector3 T1,0,getHeight#(w,x,z+1),tsz#
         set vector3 T2,-tsx#,getHeight#(w,x-1,z),0
         subtract vector3 T1,T1,2
         subtract vector3 T2,2,T2
         cross product vector3 N2,T1,T2
         normalize vector3 N2, N2
 
         rem lower left
         set vector3 T1,0,getHeight#(w,x,z-1),-tsz#
         set vector3 T2,-tsx#,getHeight#(w,x-1,z),0
         subtract vector3 T1,T1,2
         subtract vector3 T2,2,T2
         cross product vector3 N3,T1,T2
         normalize vector3 N3, N3
 
         rem lower right
         set vector3 T1,0,getHeight#(w,x,z-1),-tsz#
         set vector3 T2,tsx#,getHeight#(w,x+1,z),0
         subtract vector3 T1,T1,2
         subtract vector3 T2,2,T2
         cross product vector3 N4,T1,T2
         normalize vector3 N4, N4
 
         rem average 4 normals
         add vector3 N1,N1,N2
         add vector3 N1,N1,N3
         add vector3 N1,N1,N4
         divide vector3 N1,4
         `normalize vector3 N1, N1
 
         nx# = x vector3(N1)
         ny# = y vector3(N1)
         nz# = z vector3(N1)
 
         setNormal(w, x, z, nx#, ny#, nz#)
 
 
      next x
   next z
endfunction
 
 
 
 
 
 
 
 
 
 
 
 
 
function calculateNormals2(w as World)
 
   tsx# = w.width/w.xsegs
   tsz# = w.depth/w.zsegs
 
   for z = 1 to w.zsegs-1
      for x = 1 to w.xsegs-1
 
         count = 0
 
         rem upper right
         set vector3 T1,x*tsx#,getHeight#(w,x,z+1),(z+1)*tsz#
         set vector3 T2,(x+1)*tsx#,getHeight#(w,x+1,z),z*tsz#
         cross product vector3 N1,T1,T2
         normalize vector3 N1, N1
 
         rem upper left
         set vector3 T1,x*tsx#,getHeight#(w,x,z+1),(z+1)*tsz#
         set vector3 T2,(x-1)*tsx#,getHeight#(w,x-1,z),z*tsz#
         cross product vector3 N2,T1,T2
         normalize vector3 N2, N2
 
         rem lower left
         set vector3 T1,x*tsx#,getHeight#(w,x,z-1),(z-1)*tsz#
         set vector3 T2,(x-1)*tsx#,getHeight#(w,x-1,z),z*tsz#
         cross product vector3 N3,T1,T2
         normalize vector3 N3, N3
 
         rem lower right
         set vector3 T1,x*tsx#,getHeight#(w,x,z-1),(z-1)*tsz#
         set vector3 T2,(x+1)*tsx#,getHeight#(w,x+1,z),z*tsz#
         cross product vector3 N4,T1,T2
         normalize vector3 N4, N4
 
         rem average 4 normals
         add vector3 N1,N1,N2
         add vector3 N1,N1,N3
         add vector3 N1,N1,N4
         divide vector3 N1,4
         `normalize vector3 N1, N1
 
         nx# = x vector3(N1)
         ny# = y vector3(N1)
         nz# = z vector3(N1)
 
 
         `setNormal(w, x, z, nx#, ny#, nz#)
 
 
         subtract vector3 N1,N2,N1
         subtract vector3 N2,N3,N2
 
         cross product vector3 N1,N1,N2
         `normalize vector3 N1, N1
 
         nx# = x vector3(N1)
         ny# = y vector3(N1)
         nz# = z vector3(N1)
 
         setNormal(w, x, z, nx#, ny#, nz#)
 
 
      next x
   next z
endfunction
 
 
 
 
 
 
REM set the normal at (X,Z)
function setNormal(w as World, x as integer, z as integer, nx as float, ny as float, nz as float)
   if x < 0 OR x > w.xsegs OR z < 0 OR z > w.zsegs then exitfunction
 
   rem verts 3 and 5
   if x > 0 and z > 0
      tx = x-1
      tz = z-1
      pos = tz*w.xsegs*216 + tx*216 + 12
      write memblock float w.meshID, pos+84,nx
      write memblock float w.meshID, pos+88,ny
      write memblock float w.meshID, pos+92,nz
 
      write memblock float w.meshID, pos+156, nx
      write memblock float w.meshID, pos+160, ny
      write memblock float w.meshID, pos+164, nz
   endif
 
   rem vert 2
   if x < w.xsegs and z > 0
      tx = x
      tz = z-1
      pos = tz*w.xsegs*216 + tx*216 + 12
      write memblock float w.meshID, pos+48, nx
      write memblock float w.meshID, pos+52, ny
      write memblock float w.meshID, pos+56, nz
   endif
 
   rem vert 6
   if x > 0 and z < w.xsegs
      tx = x-1
      tz = z
      pos = tz*w.xsegs*216 + tx*216 + 12
      write memblock float w.meshID, pos+192, nx
      write memblock float w.meshID, pos+196, ny
      write memblock float w.meshID, pos+200, nz
   endif
 
   rem verts 1 and 4
   if x < w.xsegs and z < w.zsegs
      tx = x
      tz = z
      pos = tz*w.xsegs*216 + tx*216 + 12
      write memblock float w.meshID, pos+12, nx
      write memblock float w.meshID, pos+16, ny
      write memblock float w.meshID, pos+20, nz
 
      write memblock float w.meshID, pos+120, nx
      write memblock float w.meshID, pos+124, ny
      write memblock float w.meshID, pos+128, nz
   endif
endfunction
 
 
 
REM set the diffuse at (X,Z)
function setDiffuse(w as World, x as integer, z as integer, color as dword)
   if x < 0 OR x > w.xsegs OR z < 0 OR z > w.zsegs then exitfunction
 
   rem verts 3 and 5
   if x > 0 and z > 0
      tx = x-1
      tz = z-1
      pos = tz*w.xsegs*216 + tx*216 + 12
      write memblock dword w.meshID, pos+96, color
      write memblock dword w.meshID, pos+168, color
   endif
 
   rem vert 2
   if x < w.xsegs and z > 0
      tx = x
      tz = z-1
      pos = tz*w.xsegs*216 + tx*216 + 12
      write memblock dword w.meshID, pos+60, color
   endif
 
   rem vert 6
   if x > 0 and z < w.xsegs
      tx = x-1
      tz = z
      pos = tz*w.xsegs*216 + tx*216 + 12
      write memblock dword w.meshID, pos+204, color
   endif
 
   rem verts 1 and 4
   if x < w.xsegs and z < w.zsegs
      tx = x
      tz = z
      pos = tz*w.xsegs*216 + tx*216 + 12
      write memblock dword w.meshID, pos+24, color
      write memblock dword w.meshID, pos+132, color
   endif
 
endfunction
 
 
 
 
REM creates a matrix-like mesh
function createWorldMesh(w as World)
 
   id = w.meshID
   width# = w.width
   depth# = w.depth
   xsegs = w.xsegs
   zsegs = w.zsegs
 
   rem 6 verts per square, 36 bytes per vert
   size = 12 + xsegs*zsegs*6*36
   make memblock id, size
 
   rem write 12 byte header
   write memblock dword id, 0, 338
   write memblock dword id, 4, 36
   write memblock dword id, 8, xsegs*zsegs*6
 
   sizeX# = width# / xsegs
   sizeZ# = depth# / zsegs
 
   for z = 1 to zsegs
      for x = 1 to xsegs
         pos = 12 + (xsegs*(z-1) + (x-1))*216 : `216 bytes per square (36*6)
 
         x1# = (x-1)*sizeX#
         z1# = (z-1)*sizeZ#
         x2# = x*sizeX#
         z2# = z*sizeZ#
 
         u1# = x1#/width#
         v1# = z1#/depth#
         u2# = x2#/width#
         v2# = z2#/depth#
 
         writeVertex(id,pos,x1#,0,z1#,0,1,0,u1#,v1#)
         writeVertex(id,pos+36,x1#,0,z2#,0,1,0,u1#,v2#)
         writeVertex(id,pos+72,x2#,0,z2#,0,1,0,u2#,v2#)
         writeVertex(id,pos+108,x1#,0,z1#,0,1,0,u1#,v1#)
         writeVertex(id,pos+144,x2#,0,z2#,0,1,0,u2#,v2#)
         writeVertex(id,pos+180,x2#,0,z1#,0,1,0,u2#,v1#)
 
      next x
   next z
 
   make mesh from memblock id, id
endfunction
 
 
 
 
REM x,y,z, normals(x,y,z), diffuse color, UV
function writeVertex(id, pos, x#, y#, z#, nx#, ny#, nz#, u#, v#)
   write memblock float id, pos, x#
   write memblock float id, pos+4, y#
   write memblock float id, pos+8, z#
   write memblock float id, pos+12, nx#
   write memblock float id, pos+16, ny#
   write memblock float id, pos+20, nz#
   write memblock dword id, pos+24, rgb(255,255,255)
   write memblock float id, pos+28, u#
   write memblock float id, pos+32, v#
endfunction