Landscape v4

Everything related to 3D programming
User avatar
pf shadoko
Enthusiast
Enthusiast
Posts: 280
Joined: Thu Jul 09, 2015 9:07 am

Landscape v4

Post by pf shadoko »

Image
Hello, coders,

In this version I added some grass
and you'll see, we can put a lot of it, it surprised me, especially since the rendering is done twice (for reflection)
Otherwise, I didn't bust my ass for the textures, but it looks pretty good.

For v5 I will add trees


PS: remove the debogger, otherwise the creation of the decor is a little long.
if it is slow, you can reduce the resolution of the RTT (line 638 -> CreateRenderTexture(#water,CameraID(1),ex/2,ey/2)

Code: Select all

; ----------------------------------------------------------------------------------------------------------
;   Paysage V4 - pf Shadoko - 2018
; ----------------------------------------------------------------------------------------------------------


;{ ============================= biblio
Structure Vector2
  x.f
  y.f
EndStructure

Structure Vector3
  x.f
  y.f
  z.f
EndStructure

Macro vec3d(v,vx,vy,vz)
  v\x=vx
  v\y=vy
  v\z=vz
EndMacro

Procedure.f lng3D(*v.Vector3)
  ProcedureReturn Sqr(*V\x * *V\x + *V\y * *V\y + *V\z * *V\z)
EndProcedure

Procedure Norme3D(*V.Vector3,l.f=1)
  Protected.f lm
  lm = l / lng3d(*v)
  *V\x * lm
  *V\y * lm
  *V\z * lm  
EndProcedure

Macro sub3D(p,p1,p2)
  p\x=p1\x-p2\x
  p\y=p1\y-p2\y
  p\z=p1\z-p2\z
EndMacro

Procedure.f Max(v1.f,v2.f)
  If v1>v2:ProcedureReturn v1:Else:ProcedureReturn v2:EndIf
EndProcedure

Procedure.f Min(v1.f,v2.f)
  If v1<v2:ProcedureReturn v1:Else:ProcedureReturn v2:EndIf
EndProcedure

Procedure.f limite(V.f, i.f, s.f)
  If V < i :v=i:EndIf
  If V > s :v=s:EndIf
  ProcedureReturn V
EndProcedure

Macro vec2d(v,vx,vy)
  v\x=vx
  v\y=vy
EndMacro

Procedure.f interpolarray2d(Array tt.w(2),x.f,y.f)
  Protected.l i0, j0,i1,j1,dx1,dy1
  Protected.f dx, dy
  dx1=ArraySize(tt(),1)
  dy1=ArraySize(tt(),2)
  i0 = Int(X) & dx1:i1=(i0+1) & dx1: dx = X - Int(x)
  j0 = Int(Y) & dy1:j1=(j0+1) & dy1: dy = Y - Int(y)
  ProcedureReturn (((1 - dx) * tt(j0,i0) + dx * tt(j0,i1)) * (1 - dy) + ((1 - dx) * tt(j1,i0) + dx * tt(j1,i1)) * dy)
EndProcedure

Procedure.f POM(v.f)
  ProcedureReturn (Random(v*1000)-v*500)/500
EndProcedure

Procedure Split(Array t.s(1),l.s,sep.s=",",nmax=100)
  Protected ap.l,p.l,n,ls
  Dim t(nmax)
  ls=Len(sep)
  l+sep
  p=1-ls
  Repeat
    ap=p+ls:p=FindString(l,sep,ap)
    If p=0:Break:EndIf
    n+1
    t(n)= Mid(l,ap,p-ap)
  ForEver
  ReDim t(n)
EndProcedure

Procedure string2vector2(Array s.vector2(1),txt.s)
  Dim tt.s(0)
  Dim t.s(0)
  Protected i,n
  
  split(tt(),txt,"/",100)
  n=ArraySize(tt())
  Dim s(n-1)
  For i=1 To n
    split(t(),tt(i)+",0",",")
    With s(i-1)
      \x=ValF(t(1))
      \y=ValF(t(2))
    EndWith
  Next
EndProcedure

Procedure CoRBinv(c.l)
  ProcedureReturn  RGBA(Blue(c),Green(c),Red(c),Alpha(c))
EndProcedure

Procedure ColorBlend(color1.l, color2.l, blend.f)
  Protected r.w,g.w,b.w,a.w
  r=  Red(color1) + (Red(color2)     - Red(color1)) * blend
  g=Green(color1) + (Green(color2) - Green(color1)) * blend
  b= Blue(color1) + (Blue(color2) -   Blue(color1)) * blend
  a=Alpha(color1) + (Alpha(color2) - Alpha(color1)) * blend
  ProcedureReturn  RGBA(r,g,b,a)
EndProcedure

Procedure GradientToArray(Array pal.l(1),n,gradient.s,inv.b=0,alpha.b=0)
  Protected Dim lt.s(0)
  Protected i,j, apos,pos, acol.l,col.l
  n-1
  Dim pal(n)
  split(lt(),gradient,"/")
  
  Macro lparam(i)
    pos=ValF(lt(i))*n
    col=Val(Mid(lt(i),FindString(lt(i),",")+1))
    If inv  :col=CoRBinv(col):EndIf
    If alpha:col | $ff000000:EndIf
  EndMacro
  
  lparam(1)
  For i=2 To ArraySize(lt())
    apos=pos
    acol=col
    lparam(i)
    For j=apos To pos:pal(j)=ColorBlend(acol,col,(j-apos)/(pos-apos)):Next
  Next
EndProcedure

Procedure Finterpol(Array F.f(1),t.s,rx.f=1,ry.f=1,oy.f=0)
  Protected.l i,j,n,c,ac
  Protected.f y,dx,dy,p
  Protected Dim s.vector2(0)
  string2vector2(s(),t)
  n=ArraySize(s())
  For i=0 To n
    s(i)\x*rx
    s(i)\y*ry+oy
  Next  
  Dim f(Int(s(n)\x))
  For j=0 To n-1
    y=s(j)\y
    dx=s(j+1)\x-s(j)\x
    dy=s(j+1)\y-s(j)\y
    p=dy/dx
    ac=c
    While c<=s(j+1)\x
      f(c)=y+p*(c-ac):c+1
    Wend
  Next
EndProcedure

Procedure copyimagetotexture(im,tx)
  Protected n=CreateTexture(tx,ImageWidth(im),ImageHeight(im))
  If tx=-1:tx=n:EndIf
  StartDrawing(TextureOutput(tx))
  DrawingMode(#PB_2DDrawing_AllChannels)
  DrawImage(ImageID(im),0,0)
  StopDrawing()
  ProcedureReturn tx
EndProcedure

Procedure t2norme(Array t.w(2),dmin.w,dmax.w,profil.s="")
  Protected smin.w,smax.w,dx1,dy1,i,j,sr,dr
  If profil="":profil="0,0/1,1":EndIf
  dy1 = ArraySize(t(), 1)
  dx1 = ArraySize(t(), 2)
  smax = -32768
  smin =  32767
  For j=0 To dy1
    For i=0 To dx1
      If t(j,i)>smax : smax=t(j,i): EndIf
      If t(j,i)<smin : smin=t(j,i): EndIf
    Next
  Next
  sr=smax-smin
  dr=dmax-dmin
  
  Protected Dim conv.f(sr)
  Finterpol(conv(),profil,sr,dr,dmin)
  
  For j=0 To dy1
    For i=0 To dx1
      t(j,i)=conv(t(j,i)-smin)
    Next
  Next
EndProcedure

Procedure Tmodulo(Array T(1), max, marge)
  Protected i,d=max-marge/2
  Dim T(max + 2*marge): For i = 0 To max + 2*marge: T(i) = (i+d) % (max+1): Next 
EndProcedure

Procedure Tlimite(Array T(1), max, marge)
  Protected i
  Dim T(max + 2*marge): For i = 0 To max + 2*marge: T(i) = limite(i-1-marge/2, 0, max): Next
EndProcedure

Procedure lisser2D(Array s.w(2),di.w, dj.w,pass=1,loop=1)
  If di=0 And dj=0:ProcedureReturn:EndIf
  Protected i,j,k,dii,djj,dx,dy,dij,tx
  dx = ArraySize(s(), 2):di=min(di,dx)
  dy = ArraySize(s(), 1):dj=min(dj,dy)
  Dim d.w(dy,dx)
  dii=di+1
  djj=dj+1
  dij = dii * djj
  Dim lx(0)
  Dim ly(0)
  If loop
    Tmodulo (lx(), dx, di+1)
    Tmodulo (ly(), dy, dj+1) 
  Else
    Tlimite(lx(), dx, di+1)
    Tlimite(ly(), dy, dj+1)
  EndIf  
  For k=1 To pass
    Dim ty.l(dx)
    For j = 0 To djj - 1: For i = 0 To dx: ty(i) + s(ly(j),i): Next: Next    
    For j = 0 To dy
      For i = 0 To dx: ty(i) + s(ly(djj+j),i) - s(ly(j),i): Next
      tx=0:For i = 0 To dii-1: tx+ty(lx(i)): Next
      For i = 0 To dx: tx + ty(lx(dii+i)) - ty(lx(i) ): d(j,i) = tx / dij: Next
    Next
    CopyArray(d(),s())
  Next
EndProcedure

Procedure Embos(Array s.w(2), px.w=0, py.w=0)
  Protected i,j,dx,dy
  px=1<<Int(Abs(px))*Sign(px)
  py=1<<Int(Abs(py))*Sign(py)
  
  Macro gra(j0,i0,j1,i1)
    t(j0,i0)=Abs(s(j0,i0)-s(j0,i1)+px)+Abs(s(j0,i0)-s(j1,i0)+py)
  EndMacro
  dy = ArraySize(s(), 1)
  dx = ArraySize(s(), 2)
  Dim T.w(dy,dx)
  For j=0 To dy-1
    For i=0 To dx-1
      gra(j,i,j+1,i+1)
    Next
    gra(j,dx,j+1,0)
  Next
  For i = 0 To dx-1
    gra(dy,i,0,i+1)
  Next
  gra(dy,dx,0,0)
  CopyArray(t(),s())
EndProcedure

Procedure heightmap(Array t.w(2),rnd, dy.w, dx.w, Re.w)
  Protected i,j,ii,jj,n,d,dd,dx1=dx-1,dy1=dy-1,l,R, rr,dec
  
  RandomSeed(rnd)
  n = 1<<re
  dd=min(dx,dy) / n: If dd<1:dd=1:EndIf
  Dim t.w(dy-1, dx-1)
  rr = $1fff:r=rr>>1
  For jj = 0 To dy/dd - 1:j=jj*dd: For ii = 0 To dx/dd - 1:i=ii*dd: t(j,i) = Random(rr) - R: Next: Next
  l = dd
  While dd > 1
    d = dd / 2
    For jj = 0 To dy/dd - 1  :j=jj*dd+d
      For ii = 0 To dx/dd - 1:i=ii*dd+d
        t(j,i) = (t((j - d) & dy1,(i - d) & dx1) + t((j - d) & dy1,(i + d) & dx1) + t((j + d) & dy1,(i + d) & dx1) + t((j + d) & dy1,(i - d) & dx1)) / 4 + Random(rr) - R
      Next
    Next
    For jj = 0 To dy/d - 1  :j=jj*d:dec=1- jj & 1
      For ii = 0 To dx/dd - 1:i=ii*dd+dec*d
        t(j,i) = (t(j,(i - d) & dx1) + t(j,(i + d) & dx1) + t((j - d) & dy1,i) + t((j + d) & dy1,i)) / 4 + Random(rr) - R
      Next
    Next
    l/2
    dd/2
    r/2:rr/2
  Wend 
EndProcedure
;}================================================================================================


Procedure texture(tex,dx,dy,rnd=0,f=0,lissage=0,embos=-1000,grad.s="0,$000000/1,$ffffff")
  Protected Dim t.w(0,0)
  Protected Dim bmp.l(dy-1,dx-1)
  Protected Dim grad.l(0):gradienttoarray(grad(),1024,grad,1)
  Protected i,j,n
  
  heightmap(t(),rnd,dx,dy,f)
  lisser2d(t(),lissage,lissage,2) 
  If embos<>-1000:embos(t(),embos,embos):EndIf
  t2norme(t(),0,1023)
  For j=0 To dy-1:For i=0 To dx-1:bmp(j,i)=grad(t(j,i)):Next:Next
  
  n=CreateTexture(tex,dx,dy)
  If tex=-1:tex=n:EndIf
  StartDrawing(TextureOutput(tex))
  CopyMemory(@ bmp(0,0),DrawingBuffer(),dx*dy*4)
  StopDrawing()
  ProcedureReturn tex
EndProcedure

Procedure matiereherbes(num,dx,dy,pal.s,c3,base.f,gr,nb) 
  c3 | $ff000000
  Protected i,j,px1,py1,px2,py2,a.f,c,dx2=dx/2,dy2=dy/2,rx,ry,gg,im,mat,tex,n
  Protected Dim pal.l(100)
  
  GradientToArray(pal(),256,pal,0,1)
  im=CreateImage(-1,dx,dy,32, #PB_Image_Transparent )
  StartDrawing(ImageOutput(im))
  Box(0, 0, dx,dy, pal(50))
  StopDrawing()
  StartVectorDrawing(ImageVectorOutput(im))
  For i=0 To dx
    c=pal(Random(255))
    px2=dx2+pom(dx2*base):py2=dy
    px1=px2+pom(dx2*(1-base)):py1=dy*0.5+pom(dy*0.2)
    MovePathCursor(px2-0.1,py2):AddPathLine(px1,py1):AddPathLine(px2+0.1,py2):VectorSourceColor(c):FillPath(#PB_Path_Preserve):StrokePath(1)
    If gr And i<nb:gg=gr*(1+pom(0.2)):AddPathEllipse(px1,py1+gg,gg*2,gg):VectorSourceColor(c3):FillPath():EndIf
  Next
  StopVectorDrawing()
  n=CopyImagetotexture(im,num):If num=-1:tex=n:Else:tex=num:EndIf
  n=CreateMaterial(num,TextureID(tex)):If num=-1:mat=n:Else:mat=num:EndIf
  MaterialFilteringMode(mat,#PB_Material_Anisotropic,4)
  SetMaterialAttribute(mat,#PB_Material_AlphaReject,128)
  MaterialCullingMode(mat, #PB_Material_NoCulling)
  ;SetMaterialColor(mat, #PB_Material_AmbientColor,-1)
  ProcedureReturn mat
EndProcedure
;######################################################################################################
Structure PB_MeshVertexV
  p.vector3
  n.vector3
  t.vector3
  u.f
  v.f
  color.l
EndStructure

Structure sobjet
  col.l
  nb.w
  mat.i
EndStructure

#dd=10:#tt=1<<6:#tt1=#tt-1:#tt2=#tt/2
#di=1<<#dd:#di1=#di-1:#dit=#di/#tt:#dit1=#dit-1
#dj=1<<#dd:#dj1=#dj-1:#djt=#dj/#tt:#djt1=#djt-1
#nblod=1

Global lumnb,lum,ex,ey
Global Dim h.w(0,0)
Global Dim g.w(0,0)
Global Dim c.w(#di,#dj)
Global Dim v.PB_MeshVertexV(#di,#dj)
Global Dim repartition.b(300,400,9)
Global Dim obj.sobjet(10)
Enumeration objet:#ciel=10:#eau:#terrain=100:EndEnumeration

Procedure DefObjet(num,altmin.w,altmax.w,pentemin.w,pentemax.w,couleur.l,nombre=0,mat=0,proba=10)
  Protected i,j,k
  For i=altmin To altmax
    For j=pentemin To pentemax
      For k=0 To proba-1
        repartition(i,j,k)=num
        obj(num)\col=couleur
        obj(num)\nb=nombre
      Next
    Next
  Next
EndProcedure

Procedure terrain_tile(pi,pj,n, r=1)
  Protected i,j,k,o,im,  tt=#tt/r, tt1=tt+1,         nv,  decx=pi+#tt2,decz=pj+#tt2
  Protected.f x,y,z,a,ca,sa,  x1,y1,z1, x2,y2,z2, h,l,nb,nsm
  Protected.PB_MeshVertexV vv
  Dim t.PB_MeshVertexV(tt,tt)
  
  For j=0 To tt
    For i=0 To tt
      t(i,j)=v(pi+i* r,pj+j* r)
      t(i,j)\p\x-decx
      t(i,j)\p\z-decz
    Next
  Next   
  
  CreateMesh(n):CreateDataMesh(-2,t())
  ; ------------- jointure des tuiles de LOD differents
  Macro addv:MeshVertex(vv\p\x-decx,vv\p\y,vv\p\z-decz,   vv\u,vv\v,  vv\color, vv\n\x,vv\n\y,vv\n\z):nv+1:EndMacro
  nv=MeshVertexCount(n)
  If r>1
    For i=0 To tt-1
      im=i*r+r/2
      vv=v(pi,pj+im)    :addV:MeshFace(nv,i+1,i)
      vv=v(pi+#tt,pj+im):addV:MeshFace(nv,i+tt1*tt,i+1+tt1*tt)
      vv=v(pi+im,pj)    :addV:MeshFace(nv,i*tt1,(i+1)*tt1)
      vv=v(pi+im,pj+#tt):addV:MeshFace(nv,(i+1)*tt1+tt,i*tt1+tt)
    Next
  EndIf
  SetMeshMaterial(n,MaterialID(1))
  ; ------------- herbes
  If r=1
    For o=1 To 6
      nb=obj(o)\nb
      If nb
        h=TextureHeight(20+o)/128
        AddSubMesh():nv=0:nsm+1
        SetMeshMaterial(n,MaterialID(20+o),SubMeshCount(n)-1)
        ;Debug o
        For j=0 To #tt
          For i=0 To #tt
            vv=v(pi+i,pj+j)
            ;mul3d(vv\n,2)
            If c(pi+i,pj+j)=o
              For k=1 To nb
                a=pom(#PI):ca=Cos(a):sa=Sin(a)
                x=vv\p\x+pom(0.5)
                z=vv\p\z+pom(0.5)
                x1=x+ca:z1=z+sa:y1=interpolarray2d(h(),z1,x1)/16
                x2=x-ca:z2=z-sa:y2=interpolarray2d(h(),z2,x2)/16
                Protected hh.f=h*(1+pom(0.2))
                MeshVertex(x1-decx,y1+hh,z1-decz,0,0,$ffffff,vv\n\x,vv\n\y,vv\n\z)
                MeshVertex(x2-decx,y2+hh,z2-decz,1,0,$ffffff,vv\n\x,vv\n\y,vv\n\z)
                MeshVertex(x1-decx,y1+0,z1-decz ,0,1,$ffffff,vv\n\x,vv\n\y,vv\n\z)
                MeshVertex(x2-decx,y2+0,z2-decz ,1,1,$ffffff,vv\n\x,vv\n\y,vv\n\z)
                MeshFace(nv+0,nv+1,nv+2)
                MeshFace(nv+2,nv+1,nv+3)
                nv+4
              Next
            EndIf
          Next
        Next 
      EndIf
    Next
  EndIf
  
  FinishMesh(1)
EndProcedure

Procedure terrain(rep,liss,hmin,hmax,profil.s)
  Protected i,j,k,n,r ,h,g, c
  heightmap(h(),5,#di,#dj,rep-10+#dd);!!!
  lisser2d(h(),liss,liss)
  t2norme(h(),hmin,hmax,profil)
  For j=0 To #dj1:For i=0 To #dj1:h(i,j)+Sin(i*#PI/256)*Sin(j*#PI/128)*200:Next:Next
  CopyArray(h(),g())
  embos(g(),0,0)
  
  For j=0 To #dj1
    For i=0 To #dj1
      h=h(i,j)
      g=g(i,j)
      c(i,j)=repartition(h/8+100,g,Random(9))
      With v(i,j)
        vec3d(\p,i,h/16,j)
        vec3d(\n,h-h((i+1) & #di1,j),16,h-h(i,(j+1) & #dj1)):norme3d(\n)
        \u=i/8
        \v=j/8
        \color=obj(c(i,j))\col
      EndWith      
    Next
  Next
  For i=0 To #di:v(i,#dj)=v(i,0):v(i,#dj)\p\z=#dj:v(i,#dj)\v=#dj/8:Next
  For j=0 To #dj:v(#di,j)=v(0,j):v(#di,j)\p\x=#di:v(#di,j)\u=#di/8:Next
  
  For j=0 To #djt1
    For i=0 To #dit1
      For k=0 To #nblod:r=1<<k
        n=#terrain+j*#dit+i
        terrain_tile(i*#tt,j*#tt,n+256*k,r)
        If k:AddMeshManualLOD(n,n+256*k,64*r):EndIf
      Next
    Next
  Next
EndProcedure

Procedure rendertile(init=0)
  Static api,pi=1000,  apj,pj=1000,  i0,i1,  j0,j1,  e,m,cpt
  If init:api=0:pi=1000:apj=0:pj=1000:EndIf
  Protected i,j
  api=pi:pi=(CameraX(0)-#di/2)/#tt:If pi<api:i0=pi:i1=api-1:Else:i0=api+1+#dit1:i1=pi+#dit1:EndIf
  apj=pj:pj=(CameraZ(0)-#dj/2)/#tt:If pj<apj:j0=pj:j1=apj-1:Else:j0=apj+1+#djt1:j1=pj+#djt1:EndIf
  cpt=0
  For j=pj To pj+#djt1
    For i=pi To pi+#dit1
      If (i>=i0 And i<=i1) Or (j>=j0 And j<=j1)
        e=#terrain+(j & #djt1)*#dit+(i & #dit1)
        m=#terrain+(j & #djt1)*#dit+(i & #dit1)
        CreateEntity(e,MeshID(m),#PB_Material_None,i*#tt+#tt2,0,j*#tt+#tt2)
        cpt+1
      EndIf
    Next
  Next 
  MoveEntity(#eau,pi*#tt+#di/2,-0.4,(pj+#djt/2)*#tt,#PB_Absolute)
EndProcedure

Procedure selectterrain(n)
  DefObjet(0,0,300,0,200,$777777)
  Select n
    Case 1     
      DefObjet(1,101,200,0,10,$009922,2,Matiereherbes(21,256,64*1.5,"0,$003311/1,$227744",$ffffff, 0.8,1,100))
      DefObjet(2,101,200,10,15,$008844,2,Matiereherbes(22,256,64*2,"0,$003322/1,$226655",$0000ff, 0.8,2,25))
      DefObjet(3,101,200,15,200,$006666)
      DefObjet(4,0,100,0,200,$00ccff)
      DefObjet(8,0,99,0,200,$004400,0,0,8)
      DefObjet(5,100,101,0,2,$002200,8,Matiereherbes(25,256,128,"0,$002200/1,$335522",0, 0.2,0,0),4)
      DefObjet(6,100,101,2,4,$88ffff,4,Matiereherbes(26,256,256,"0,$002222/1,$66aaaa",0, 0.2,0,0),2)
      DefObjet(7,0,200,25,200,$ffffaaaa)
      terrain(4,2,-200,800,"0,0/0.4,0.2/0.7,0.4/1,1")
    Case 2
      DefObjet(1,101,200,0,10,$004444,3,Matiereherbes(21,256,64*1.5,"0,$002222/1,$225544",$880088, 0.8,1,200))
      DefObjet(2,101,200,10,200,$0088ff)
      DefObjet(4,0,101,0,200,$00ccff)
      DefObjet(5,0,100,0,200,$004400,0,0,4)
      DefObjet(6,100,101,0,4,$002200,8,Matiereherbes(26,256,128,"0,$002200/1,$335522",0, 0.2,0,0),4)
      DefObjet(7,0,200,25,200,$ffffff)
      terrain(4,2,-100,500,"0,0.5/0.3,0.3/0.6,0.0/0.7,0.5/1,1")
    Case 3
      DefObjet(1,0,300,0,200,$aaaa88)
      DefObjet(2,101,300,0,10,$224422,4,Matiereherbes(22,256,64*2,"0,$002200/1,$224444",$ffffff, 0.6,2,30))
      DefObjet(3,101,300,0,4,$003322,4,Matiereherbes(23,256,64*4,"0,$002222/1,$224444",$004422, 0.2,3,100))
      terrain(3,1,-100,1000,"0,1/0.3,0.6/0.5,0.0/0.7,0.4/1,1")
    Case 4
      DefObjet(1,101,300,0,100,$006600,4,Matiereherbes(21,256,64*1,"0,$002211/1,$226644",$ff8888, 0.8,1,20))
      DefObjet(3,101,150,0,4,$000000,4,Matiereherbes(23,256,64*4,"0,$001111/1,$333333",$004400, 0.2,3,400),1)
      DefObjet(4,0,100,0,200,$ffffff)
      DefObjet(7,0,200,25,200,$88aaff)
      terrain(4,1,-120,500,"0,0/0.4,0.2/0.45,0.4/0.7,0.6/0.8,1/1,0.9")
    Case 5
      DefObjet(1,101,200,0,5,$008888)
      DefObjet(2,101,200,5,15,$0066aa)
      DefObjet(3,101,200,15,200,$0066ff)
      DefObjet(5,100,100,0,5,$002200,8,Matiereherbes(25,256,128,"0,$002200/1,$335555",0, 0.2,0,0),8)
      terrain(5,1,-100,600,"0,0/0.5,0.2/0.51,0.3/0.6,0.35/0.61,0.6/0.7,0.65/0.71,0.85/1,1")
  EndSelect
  rendertile(1)
EndProcedure

Procedure affiche3d()
  Static.f MouseX,Mousey, mdx,mdy,amo=0.05,keyx,keyy,keyz,y, ysol
  Protected i,  fly=1, fdf,   ac
  
  CameraReflection(1,0,EntityID(#eau))   
  Repeat
    ExamineMouse()
    mdx+(MouseDeltaX()-mdx)*amo:MouseX-mdx *  0.1
    mdy+(MouseDeltaY()-mdy)*amo:MouseY-mdy *  0.1
    ExamineKeyboard()
    If KeyboardReleased(#PB_Key_F1):selectterrain(1):EndIf
    If KeyboardReleased(#PB_Key_F2):selectterrain(2):EndIf
    If KeyboardReleased(#PB_Key_F3):selectterrain(3):EndIf
    If KeyboardReleased(#PB_Key_F4):selectterrain(4):EndIf
    If KeyboardReleased(#PB_Key_F5):selectterrain(5):EndIf
    If KeyboardReleased(#PB_Key_F11):fly=1-fly:amo=1-fly*0.95:EndIf
    If KeyboardReleased(#PB_Key_F12):fdf=1-fdf:If fdf:CameraRenderMode(0,#PB_Camera_Wireframe):Else:CameraRenderMode(0,#PB_Camera_Textured):EndIf:EndIf
    keyx=(-Bool(KeyboardPushed(#PB_Key_Left))+Bool(KeyboardPushed(#PB_Key_Right)))*0.1
    keyz=(-Bool(KeyboardPushed(#PB_Key_Down))+Bool(KeyboardPushed(#PB_Key_Up   )))*0.1+MouseWheel()*10
    RotateCamera(0, MouseY, MouseX,  -mdx *fly, #PB_Absolute)
    MoveCamera  (0, KeyX, 0, -keyz-fly*0.1) 
    ysol=max(0.2,interpolarray2d(h(), CameraZ(0)+#dj*100, CameraX(0)+#di*100)/16+1.6):If fly:y=max(ysol,CameraY(0)):Else:y=ysol:EndIf
    MoveCamera(0,CameraX(0),y,CameraZ(0),#PB_Absolute) 
    rendertile()
    CameraReflection(1,0,EntityID(#eau))   
    RenderWorld()
    DisplayTransparentSprite(0,8,8)
    FlipBuffers()
  Until KeyboardPushed(#PB_Key_Escape)
EndProcedure

Procedure menu()
  Protected p=4
  Macro DT(t1,t2)
    DrawText(8,p,t1)
    DrawText(100,p,t2)
    p+22
  EndMacro
  CreateSprite(0,220,182,#PB_Sprite_AlphaBlending)
  StartDrawing(SpriteOutput(0))
  DrawingMode(#PB_2DDrawing_AllChannels)
  DrawingFont(FontID(0))
  Box(0,0,220,182,$44000000)
  DrawingMode(#PB_2DDrawing_AllChannels|#PB_2DDrawing_Outlined)
  Box(0,0,220,182,$44ffffff)
  BackColor($44000000)
  FrontColor($ffffffff)
  dt("Moving :","")
  dt("Arrow keys + Mouse","")
  dt("","")
  dt("Controls :","")
  dt("[F1]->[F5]","Select terrain")
  dt("[F11]","Fly / Walk")
  dt("[F12]","Wireframe")
  dt("[Esc]","Quit")
  StopDrawing()
EndProcedure

Procedure main()
  Protected i,r.f=1
  ExamineDesktops()
  ex=DesktopWidth(0)*r
  ey=DesktopHeight(0)*r
  
  InitKeyboard():InitMouse():InitEngine3D():InitSprite() 
  ;OpenWindow(0,0,0,ex,ey,"",#PB_Window_BorderLess|#PB_Window_ScreenCentered):OpenWindowedScreen(WindowID(0), 0, 0, WindowWidth(0),WindowHeight(0))
  OpenScreen(ex,ey,32,"")
  LoadFont(0,"arial",12)
  menu()
  ;-------------------- scene
  CreateLight(0, $777777, 10000, 10000, 10000)
  AmbientColor($777777)
  CreateCamera(0, 0, 0, 100, 100)
  CameraLookAt(0, 0, 0, 1)
  Add3DArchive(#PB_Compiler_Home + "examples/3d/Data/Textures", #PB_3DArchive_FileSystem)
  Parse3DScripts()
  Fog($ff8888,200,0,700)
  
  ;terrain
  texture(1,512*2,512*2,1,2,1,-10,"0,$ff112222/1,$ff66cccc")
  CreateMaterial(1,TextureID(1))
  MaterialFilteringMode(1,#PB_Material_Anisotropic,4)
  SetMaterialColor(1, #PB_Material_AmbientColor,-1)
  
  ;eau
  CreateCamera(1,0,0,100,100)  
  CreateRenderTexture(#eau,CameraID(1),ex/1,ey/1)
  CreateMaterial(#eau,TextureID(#eau))
  SetMaterialAttribute(#eau,#PB_Material_ProjectiveTexturing,1)
  CreateTexture(#eau+1,4,4):StartDrawing(TextureOutput(#eau+1)):DrawingMode(#PB_2DDrawing_AllChannels):Box(0,0,4,4,$bbffccaa):StopDrawing()
  AddMaterialLayer(#eau,TextureID(#eau+1),#PB_Material_Modulate)
  MaterialBlendingMode(#eau,#PB_Material_AlphaBlend)
  CreatePlane(#eau,#di*1.4,#dj*1.4,1,1,1,1)
  CreateEntity(#eau,MeshID(#eau),MaterialID(#eau))
  
  ;ciel
  CameraBackColor(0,$ff8888):CameraRange(0,0.1,10000)
  texture(#ciel,256,256,0,0,0,-1000,"0,$ffff0000/0.5,$ffffffff/1,$ff888888")
  CreateMaterial(#ciel,TextureID(#ciel)):ScaleMaterial(#ciel,2,2)
  SetMaterialColor(#ciel,#PB_Material_SelfIlluminationColor,$ffffff):MaterialCullingMode(#ciel, #PB_Material_AntiClockWiseCull)
  CreatePlane(#ciel,100000,100000,1,1,640,640):  CreateEntity(#ciel,MeshID(#ciel),MaterialID(#ciel),0,100,0)
  
  selectterrain(1)
  affiche3d()
EndProcedure

main()
Last edited by pf shadoko on Thu Jun 06, 2019 11:18 am, edited 1 time in total.
User avatar
oreopa
Enthusiast
Enthusiast
Posts: 281
Joined: Sat Jun 24, 2006 3:29 am
Location: Edinburgh, Scotland.

Re: Landscape v4

Post by oreopa »

Very nice indeed. Grass and flowers look good. Keep going!
Proud supporter of PB! * Musician * C64/6502 Freak
ymerdy
User
User
Posts: 10
Joined: Thu Jan 18, 2018 11:54 pm

Re: Landscape v4

Post by ymerdy »

Wow, thank you Shadoko,
I especially like how you present successive versions with evolutions on each step.
Looks like a tutorial on how to develop a no man's sky like!
Will we have creatures on V6 :wink: ?
Fred
Administrator
Administrator
Posts: 16617
Joined: Fri May 17, 2002 4:39 pm
Location: France
Contact:

Re: Landscape v4

Post by Fred »

This work is way beyond my 3D understanding and i'm really amazed what can be done in such a few lines. Also very smooth on an old 3D card, good work !
HanPBF
Enthusiast
Enthusiast
Posts: 562
Joined: Fri Feb 19, 2010 3:42 am

Re: Landscape v4

Post by HanPBF »

Stunning!!!
Thanks a lot for the source!
Dude
Addict
Addict
Posts: 1907
Joined: Mon Feb 16, 2015 2:49 pm

Re: Landscape v4

Post by Dude »

I'm loving this series of updates! :)
User avatar
DK_PETER
Addict
Addict
Posts: 898
Joined: Sat Feb 19, 2011 10:06 am
Location: Denmark
Contact:

Re: Landscape v4

Post by DK_PETER »

Looks really good.
Well done! :)
Current configurations:
Ubuntu 20.04/64 bit - Window 10 64 bit
Intel 6800K, GeForce Gtx 1060, 32 gb ram.
Amd Ryzen 9 5950X, GeForce 3070, 128 gb ram.
Poshu
Enthusiast
Enthusiast
Posts: 459
Joined: Tue Jan 25, 2005 7:01 pm
Location: Canada

Re: Landscape v4

Post by Poshu »

I get an array out of bound whenever I try the F5 terrain, and it's pretty impressive otherwise :3
User avatar
pf shadoko
Enthusiast
Enthusiast
Posts: 280
Joined: Thu Jul 09, 2015 9:07 am

Re: Landscape v4

Post by pf shadoko »

@ poshu :
replace line 369 by
Global Dim repartition.b(300,400,9)

or remove debug mode (it's much faster)
User avatar
TI-994A
Addict
Addict
Posts: 2512
Joined: Sat Feb 19, 2011 3:47 am
Location: Singapore
Contact:

Re: Landscape v4

Post by TI-994A »

From what I'm able to see, it's simply fantastic. But the screen keeps going to black, then revealing the view again in an upward-curtain fashion.

Any idea what could be causing this?
Texas Instruments TI-99/4A Home Computer: the first home computer with a 16bit processor, crammed into an 8bit architecture. Great hardware - Poor design - Wonderful BASIC engine. And it could talk too! Please visit my YouTube Channel :D
User avatar
pf shadoko
Enthusiast
Enthusiast
Posts: 280
Joined: Thu Jul 09, 2015 9:07 am

Re: Landscape v4

Post by pf shadoko »

sorry, this demo don't work on TI99-4A :mrgreen:

try with openwindow instead openscreen:
line 617 - 618
User avatar
TI-994A
Addict
Addict
Posts: 2512
Joined: Sat Feb 19, 2011 3:47 am
Location: Singapore
Contact:

Re: Landscape v4

Post by TI-994A »

pf shadoko wrote:sorry, this demo don't work on TI99-4A :mrgreen:
Wouldn't it be something if it did?

It works with OpenWindowedScreen(), and I must say - Wow!

Thank you for sharing. :D
Texas Instruments TI-99/4A Home Computer: the first home computer with a 16bit processor, crammed into an 8bit architecture. Great hardware - Poor design - Wonderful BASIC engine. And it could talk too! Please visit my YouTube Channel :D
Mythros
Enthusiast
Enthusiast
Posts: 306
Joined: Mon Aug 19, 2013 3:28 pm

Re: Landscape v4

Post by Mythros »

Any way you could add multi-layered texture painting & splatmap where you can change the detail of each texture of the splatmap?

Thanks, & keep up the awesome work!
User avatar
Kukulkan
Addict
Addict
Posts: 1352
Joined: Mon Jun 06, 2005 2:35 pm
Location: germany
Contact:

Re: Landscape v4

Post by Kukulkan »

I tried with PB5.70 x64 on Windows 7 and get

[11:38:26] Waiting for executable to start...
[11:38:26] Executable type: Windows - x64 (64bit, Unicode)
[11:38:26] Executable started.
[11:38:27] [ERROR] Line: 590
[11:38:27] [ERROR] Invalid memory access. (read error at address 0)
[11:38:54] The Program was killed.

What's wrong?
Fred
Administrator
Administrator
Posts: 16617
Joined: Fri May 17, 2002 4:39 pm
Location: France
Contact:

Re: Landscape v4

Post by Fred »

You can try with 'opengl' as subsystem
Post Reply