PureBasic Forums - English

Posted: **Mon Apr 20, 2020 7:47 pm**

Hello, coders,

a little update of my cave demo with normal mapping
it uses a script embedded in pb 5.72
this one works only under windows (HLSL), the demo works however in degraded mode
(if someone can convert to GLSL...)

the textures are based on a simple Heightmap
- the diffuse texture is obtained from a color gradient based on the heightmap
- the normalmap texture is obtained via the 'textureArray2NM' procedure (which converts a heightmap array into a normalmap)
it's rudimentary, but it's enough to give a very realistic rendering...

Code: Select all

; demo 3d - grotte-v2 - Pf Shadoko - 2019

EnableExplicit
;{ ============================= biblio
Structure f2
  x.f
  y.f
EndStructure

Structure f3
  x.f
  y.f
  z.f
EndStructure

Structure PB_MeshVertexV
  p.f3
  n.f3
  t.f3
  u.f
  v.f
  color.l
EndStructure

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

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

Macro add3d(p,p1,p2)
  p\x=p1\x+p2\x
  p\y=p1\y+p2\y
  p\z=p1\z+p2\z
EndMacro

Macro mul3d(p1,v)
  p1\x*(v)
  p1\y*(v)
  p1\z*(v)
EndMacro

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

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

Procedure Pvectoriel3d(*r.f3,*p.f3,*q.f3)
*r\x=*p\y * *q\z - *p\z * *q\y 
*r\y=*p\z * *q\x - *p\x * *q\z 
*r\z=*p\x * *q\y - *p\y * *q\x 
EndProcedure

Procedure defmatrot(*p.f3,w.f, orientation=0)
  Global.f3 lo_p,lo_q,lo_r
  Protected pp.f3, l.f
  
  vec3d(lo_p,*p\x,*p\y,*p\z)
  l=lng3d(lo_p)  
  Select orientation
    Case 0:vec3d(pp,Cos(w),0,Sin(w))
    Case 1:vec3d(pp,0,Cos(w),Sin(w))
    Case 2:vec3d(pp,Cos(w),Sin(w),0)
  EndSelect
  pvectoriel3d(lo_q,lo_p,pp  ):Norme3d(lo_q,l)
  pvectoriel3d(lo_r,lo_p,lo_q):Norme3d(lo_r,l)
EndProcedure

Procedure calcmatrot(*v.f3, *u.f3)
  Protected.f x=*u\x, y=*u\y, z=*u\z
  *v\x=lo_p\x * x + lo_q\x * y + lo_r\x * z
  *v\y=lo_p\y * x + lo_q\y * y + lo_r\y * z
  *v\z=lo_p\z * x + lo_q\z * y + lo_r\z * z
EndProcedure

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 interpol(v,v1,v2,r=0.5)
  v=v1*(1-r)+v2*r
EndMacro

Procedure interpol3D(*R.f3, *V1.f3, *V2.f3, r.f)
  *R\x = *V1\x + r * (*V2\x - *V1\x)
  *R\y = *V1\y + r * (*V2\y - *V1\y)
  *R\z = *V1\z + r * (*V2\z - *V1\z)
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 string2f2(Array s.f2(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,p
  n-1
  Dim pal(n)
  split(lt(),gradient,"/")
  
  Macro lparam(i)
    pos=ValF(lt(i))*n
    p=FindString(lt(i),",")
    If p: col=Val(Mid(lt(i),p+1)):Else:col=acol:EndIf
    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.f2(0)
  string2f2(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 t2norme(Array t.l(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.l(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.l(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 heightmap(Array t.l(2),rnd, dx.w, dy.w, Re.w)
    Protected i,j,n,d,dd,dx1=dx-1,dy1=dy-1,R, rr,dec,tt
    Dim t.l(dy1, dx1)
    
    RandomSeed(rnd)
    n = 1<<re
    dd=min(dx,dy) / n: If dd<1:dd=1:EndIf
    rr = $4000-1:r=rr>>1
    j=0:While j<dy1:i=0:While i<dx1: t(j,i) = Random(rr) - R:i+dd:Wend:j+dd:Wend
    While dd > 1
        d = dd / 2
        j=d:While j<dy
            i=d:While i<dx
                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
            i+dd:Wend
        j+dd:Wend
        dec=0
        j=0:While j<dy:dec=1-dec
            i=dec*d:While i<dx
                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
            i+dd:Wend
        j+d:Wend
        dd/2:r/2:rr/2:d=dd/2
    Wend     
EndProcedure

Procedure.i triangle(Array t.l(2),*p1.f3, *p2.f3, *p3.f3)
    Protected.f3 e,p1,p2,p3,p4,  vg,vd,  vdg,vdd
    Protected i,j, dx1,dy1,dc.f
    dx1=ArraySize(t(),1)
    dy1=ArraySize(t(),2)
    
    vec3d(p1,*p1\x,*p1\y,*p1\z)
    vec3d(p2,*p2\x,*p2\y,*p2\z)
    vec3d(p3,*p3\x,*p3\y,*p3\z)
    If p1\y>p3\y:e=p1:p1=p3:p3=e:EndIf
    If p1\y>p2\y:e=p1:p1=p2:p2=e:EndIf
    If p2\y>p3\y:e=p2:p2=p3:p3=e:EndIf
    interpol3D(p4,p1,p3,(p2\y-p1\y)/(p3\y-p1\y))
    If p4\x>p2\x:e=p4:p4=p2:p2=e:EndIf
       
    Macro demitriangle(pgh,pgb,pdh,pdb)
        vg=pgh:sub3d(vdg,pgb,pgh):mul3d(vdg,1/(pgb\y-pgh\y))
        vd=pdh:sub3d(vdd,pdb,pdh):mul3d(vdd,1/(pdb\y-pdh\y))
        For j=pgh\y To pgb\y-1
            For i=vg\x To vd\x:t(i & dx1,j & dy1)=vg\z+(i-vg\x)*dc:Next
            add3d(vg,vg,vdg)
            add3d(vd,vd,vdd)        
        Next
    EndMacro
    
    dc=(p4\z-p2\z)/(p4\x-p2\x)
    If p4\y>p1\y:demitriangle(p1,p4,p1,p2):EndIf
    If p3\y>p4\y:demitriangle(p4,p3,p2,p3):EndIf
EndProcedure

Procedure heightmapcristal(Array h.l(2),rnd, dx.w, dy.w, d.w)
Protected i,j,dx1=dx-1,dy1=dy-1,r=d*0.25,n=dx/d,n1=n-1
Protected.f3 t00,t10,t01,t11,e

Dim t.f3(n,n)
Dim h(dx1,dy1)
RandomSeed(rnd)
For j=0 To n
    For i=0 To n
        With t(i,j)
            \x=i*d+Random(2*r)-r
            \y=j*d+Random(2*r)-r
            \z=Random(4000)
        EndWith
Next:Next
For i=0 To n:t(i,n)=t(i,0):t(i,n)\y+n*d:Next
For j=0 To n:t(n,j)=t(0,j):t(n,j)\x+n*d:Next

For i=0 To n1:For j=0 To n1
        t00=t(i+0,j+0)
        t10=t(i+1,j+0)
        t01=t(i+0,j+1)
        t11=t(i+1,j+1)
        If Random(1):e=t00:t00=t10:t10=e:  e=t01:t01=t11:t11=e:EndIf
        triangle(h(),t00,t11,t01)
        triangle(h(),t00,t11,t10)
Next:Next
EndProcedure

Procedure textureArray2NM(Array hm.l(2),imgNM,amplitude.f)
  Protected i,j,dx,dy,h00,h10,h01
  Protected.f x,y,z,l, max=255/amplitude,max2=max*max
  Protected.f3 p
  dx=ArraySize(hm(),2)+1
  dy=ArraySize(hm(),1)+1
  Dim bmp.l(dy-1,dx-1)
  For j=0 To dy-1
    For i=0 To dx-1
      h00=hm(j,i)
      h10=hm(j,(i+1) % dx)
      h01=hm((j+1) % dy,i)
      p\x=h00-h10
      p\y=h00-h01
      l=min(p\x*p\x+p\y*p\y,max2)
      p\z=Sqr(max2-l)
      Norme3D(p,127)
      bmp(j,i)=RGBA(p\z+128,p\y+128,p\x+128,255)
    Next
  Next  
  CreateTexture(imgNM,dx,dy)
  StartDrawing(TextureOutput(imgNM)):CopyMemory(@bmp(0,0),DrawingBuffer(),dx*dy*4):StopDrawing()
EndProcedure

Procedure textureHM2NM(imgHM,imgNM,amplitude.f)
  Protected i,j,dx,dy,c
  StartDrawing(TextureOutput(imgHM))
  dx=OutputWidth()
  dy=OutputHeight()
  Dim hm.l(dy-1,dx-1)
  Dim bmp.l(dy-1,dx-1)
  CopyMemory(DrawingBuffer(),@bmp(0,0),dx*dy*4)
  StopDrawing()
  For j=0 To dy-1
    For i=0 To dx-1
      c=bmp(j,i)
      hm(j,i)=Red(c)+Green(c)+Blue(c)
    Next
  Next
  textureArray2NM(hm(),imgNM,amplitude/3)
EndProcedure

Procedure Embos(Array s.l(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.l(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 superpose(Array s.l(2),n.w=1)
  Protected i,j,k,dx,dy,x,y,ii,jj
  
  dy = ArraySize(s(), 1)
  dx = ArraySize(s(), 2)
  Dim T.l(dy,dx)
  For k=1 To n
    x=Random(dx)
    y=Random(dy)
    For j=0 To dy
      For i=0 To dx
        t(i,j)+s((i+x) & dx,(j+y) & dy)
      Next
    Next
  Next
  CopyArray(t(),s())
EndProcedure

Procedure minauto(Array s.l(2),n.w=1)
    Protected i,j,dx,dy,dy1,dy2
    
    dy = ArraySize(s(), 1):dy2=dy/2
    dx = ArraySize(s(), 2)
    Dim t.l(0,0):CopyArray(s(),t())
    For j=0 To dy:For i=0 To dx:s(j,i)=min(t(j,i),t((j+dy2) & dy,i)):Next:Next
EndProcedure

Procedure contraste(Array s.l(2),lissage.w=1)
  Protected i,j,k,dx,dy
  
  dy = ArraySize(s(), 1)
  dx = ArraySize(s(), 2)
  Dim T.l(dy,dx)
  CopyArray(s(),t())
  lisser2d(t(),lissage,lissage)
    For j=0 To dy
      For i=0 To dx
        s(i,j)-t(i,j)
      Next
    Next
EndProcedure

Procedure texture(tex,dx,dy,rnd=0,f=0,lissage=0,embos=100,amplitude.f=1,profil.s="0,0/1,1",grad.s="0,$000000/1,$ffffff")
  Protected Dim t.l(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)
  ;heightmapcristal(t(),rnd,dx,dy,16)
  lisser2d(t(),lissage,lissage,2)
  If Embos<>100:Embos(t(),Embos,0):EndIf
  ;minauto(t())
  ;superpose(t(),2)
  ;contraste(t(),2)
  t2norme(t(),0,1023,profil)
  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()
  
  textureArray2NM(t(),tex+1,amplitude)
  
  ProcedureReturn tex
EndProcedure
;}===================================================================================================================================================

;######################################################################################################

#halo=20
#eau=21
Global lum=1,ex,ey
Global Dim plight.f3(7)
Global Dim blight(7)
Global Dim ligness.f3(0)

Procedure grotte(num=1)
  Protected i,j,k,kj,  di=128,di1=di-1,di2=di/2,  dj=1024,dj1=dj-1,  icolor,    ntile=8,brillance,stadens
  Protected.f r,a,x,y,z,  sta,   liss,ampl, ray,rayam
  Protected.f3 p1,p2,n,ni,dir,ddir,adir,diram,p,pc,rnd
  Dim hmr.l(0,0)
  Dim ligness.f3(dj+1)
  Dim rayon.f(dj+1)
   
  Select num
    Case 1:brillance= 8:stadens=20:liss=2:ampl=0.5:texture(1,512,512,0,  4,1,100,2,"0,0/0.7,0.4/1,1","0,$66ccff/0.4,$4488ff/0.4,$4477ff/1,$4477ff")
    Case 2:brillance= 1:stadens= 0:liss=1:ampl=0.6:texture(1,512,512,1,  4,0,100,2,"0,0/0.8,1/1,0","0,$88bbff/0.7,$4488bb/1,$ffffff")
    Case 3:brillance=10:stadens= 0:liss=2:ampl=0.8:texture(1,512,512,1,  2,0,100,2,"0,1/0.4,0.5/0.5,0/0.6,0.5/1,1","0,$6699aa/0.5,$99eeff/1,$77ddff")
    Case 4:brillance= 8:stadens=20:liss=1:ampl=0.7:texture(1,512,512,1,  2,2,10,2,"0,0/0.3,0.7/1,1","0,$88bbff/0.7,$4488bb/1,$ffffff")
    Case 5:brillance= 4:stadens= 5:liss=0:ampl=0.6:texture(1,512,512,0,  4,1,100,4,"0,0/0.6,0.6/0.75,0.8/1,1","0,$0088ff/0.6,$0055bb/1,$2288ff")
    Case 6:brillance=4:stadens= 0:liss=1:ampl=0.5:texture(1,512,512,0,  3,2,0,1,"0,1/0.4,0.8/0.8,0/1,0","0,$006688/0.7,$00aaff/1,$ffffff")
    Case 7:brillance=2:stadens= 0:liss=2:ampl=0.7:texture(1,512,512,0,  3,1,100,4,"0,0/0.4,0.3/0.6,0.7/1,1","0,$66bbff/0.3,$6688bb/0.35,$44aaff/0.6,$4488bb/0.65,$66bbee/1,$4488ff")
    ;Case 8:brillance=8:stadens= 0:liss=1:ampl=0.5:texture(1,512,512,1,  3,1,100,1,"0,1/0.4,0.5/0.45,0.3/0.5,0/0.55,0.3/0.6,0.5/1,1","0,$446688/0.5,$88ccff/1,$ffffff")
    ;Case 8:brillance=8:stadens= 0:liss=0:ampl=0.5:texture(1,512,512,1,  5,0,100,2,"0,0/1,1","0,$00ffff/1,$ffff00")
    Case 8:brillance=4:stadens= 0:liss=2:ampl=0.5:texture(1,512,512,1,  3,4,100,4,"0,0/0.5,0.5/1,1","0,$00ffff/1,$ffff00")
  EndSelect
  
  CreateBillboardGroup(0,MaterialID(#halo),0.5,0.5):HideBillboardGroup(0,1-lum)
  SetLightColor(10, #PB_Light_SpecularColor, $111111*brillance):HideLight(10,lum)
  MoveCamera(0,0,0,0.5,#PB_Absolute):CameraLookAt(0,0,0,2)
  
  ;texture paroie
  GetScriptMaterial(1,"ParallaxOcclusionMapping"):MaterialTextureAliases(1,TextureID(1),TextureID(2),0,0)
  ;CreateMaterial(1,TextureID(1))
  MaterialFilteringMode(1,#PB_Material_Anisotropic,4)
  
  ;relief
  heightmap(hmr(),num,di,dj,2)
  lisser2d(hmr(),liss,liss,1)
  t2norme(hmr(),-1024,1024,"0,0/0.1,0/0.9,1/1,1")
  RandomSeed(num)
  r=0.01
  vec3d(ddir,0,0,10)
  For j=0 To dj+1
    ray=ray+pom(1)-(ray-2)*0.01
    interpol(rayam,rayam,ray,0.01)
    rayam=limite(rayam,1,3)
    rayon(j)=rayam
    vec3d(rnd,pom(1)-p\x*r,pom(1/4)-p\y*r*4,0.05)
    add3d(ddir,ddir,rnd):norme3d(ddir,rayon(j)*4)
    add3d(dir,dir,ddir)
    norme3d(dir,0.1)
    interpol3D(diram,diram,dir,0.1)
    add3d(p,p,diram)
    ligness(j)=p
  Next
  rayon(0)=0
  
  Dim t.PB_MeshVertexV(di,128)
  
  
  For k=0 To (dj-1)/128
    pc=ligness(k*128+64)
    For j=0 To 128:kj=k*128+j
      adir=dir:sub3d(dir,ligness(kj+1),ligness(kj))
      defmatrot(dir,0)
      For i=0 To di
        r=rayon(kj)*10*(1+hmr(kj & dj1,i  & di1)/1024*ampl)
        a=i/di*2*#PI
        vec3d(p,0,-Cos(a)*r,-Sin(a)*r)
        calcmatrot(p,p)
        add3d(p,p,ligness(kj))
        sub3d(p,p,pc)
        If Random(1000)<stadens And Abs(i-di2)<16 And j>0 And j<127 And r>25:sta=pom(0.4)+0.4:Else:sta=0:EndIf  
        vec3d(t(i,j)\p,p\x,p\y-sta, p\z)
        t(i,j)\u= i/di*ntile
        t(i,j)\v=kj/128*ntile
      Next
    Next
    CreateDataMesh(k,t())
    NormalizeMesh(k)
    BuildMeshTangents(k)
    CreateEntity(k,MeshID(k),MaterialID(1),pc\x,pc\y,pc\z)
    
    CreateLight(k, $111111*15, pc\x,pc\y,pc\z)
    SetLightColor(k, #PB_Light_SpecularColor, $111111*brillance)
    LightAttenuation(k, 30,1)
    HideLight(k,1-lum)
    blight(k)= AddBillboard(0,pc\x,pc\y,pc\z)
    ;Debug BillboardX(1,0)
    ;BillboardLocate(0,0,pc\x,pc\y,pc\z)
    plight(k)=pc
  Next
EndProcedure

Procedure affiche3d()
  Static.f MouseX,Mousey,keyx,keyz,  fdf.l, i.l,a,ai,n.i,pl.f3
  
  Repeat
    ExamineMouse()
    MouseX = -MouseDeltaX() *  0.05
    MouseY = -MouseDeltaY() *  0.05
    ExamineKeyboard()
    keyx=(-Bool(KeyboardPushed(#PB_Key_Left)<>0)+Bool(KeyboardPushed(#PB_Key_Right)<>0))*0.02
    keyz=(-Bool(KeyboardPushed(#PB_Key_Down)<>0)+Bool(KeyboardPushed(#PB_Key_Up   )<>0)+MouseButton(1)-MouseButton(2))*0.02+MouseWheel()*2
    For i=1 To 7
      If KeyboardReleased(#PB_Key_F1+i-1):grotte(i):EndIf
    Next
    If KeyboardReleased(#PB_Key_F11):lum=1-lum:HideLight(10,lum):HideBillboardGroup(0,1-lum):For i=0 To 7:HideLight(i,1-lum):Next:EndIf
    If KeyboardReleased(#PB_Key_F12):fdf=1-fdf:If fdf:CameraRenderMode(0,#PB_Camera_Wireframe):Else:CameraRenderMode(0,#PB_Camera_Textured):EndIf:EndIf
    RotateCamera(0, MouseY, MouseX, 0, #PB_Relative):MoveCamera  (0, KeyX, 0, -keyz) :MoveCamera(0,CameraX(0),max(CameraY(0),-1.9),CameraZ(0),#PB_Absolute) 
    For i=0 To 7:ai=a+i:pl=plight(i):pl\x+Sin(ai*3)/2:pl\y+Sin(ai*5)/2:pl\z+Sin(ai*7)/2:MoveLight(i,pl\x,pl\y,pl\z,#PB_Absolute):BillboardLocate(blight(i),0,pl\x,pl\y,pl\z):Next:a+0.01
    ;For i=0 To 7:pl=plight(i):MoveLight(i,pl\x,pl\y+Sin(a),pl\z,#PB_Absolute):BillboardLocate(blight(i),0,pl\x,pl\y+Sin(a),pl\z):Next:a+0.1
    ;For i=0 To 7:pl=ligness((n+i*128)& 1023):MoveLight(i,pl\x,pl\y+Sin(a),pl\z,#PB_Absolute):BillboardLocate(blight(i),0,pl\x,pl\y+Sin(a),pl\z):Next:n+1
    MoveLight(10,CameraX(0),CameraY(0),CameraZ(0),#PB_Absolute):LightDirection(0,CameraDirectionX(0),CameraDirectionY(0),CameraDirectionZ(0))
    CameraReflection(1,0,EntityID(#eau))   
    RenderWorld()
    DisplayTransparentSprite(0,8,8)
    FlipBuffers()
  Until WindowEvent()=#PB_Event_CloseWindow  Or KeyboardPushed(#PB_Key_Escape) Or MouseButton(2)
EndProcedure

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

Procedure main()
  InitKeyboard():InitMouse():InitEngine3D():InitSprite() 
  ExamineDesktops()
  ex=DesktopWidth(0)
  ey=DesktopHeight(0) 
  OpenWindow(0,0,0,ex,ey,"",#PB_Window_BorderLess|#PB_Window_ScreenCentered)
  OpenWindowedScreen(WindowID(0), 0, 0, WindowWidth(0),WindowHeight(0))
  LoadFont(0,"arial",12)
  menu()
  
  ;-------------------- scene
  Add3DArchive(#PB_Compiler_Home + "examples/3d/Data/Scripts/MaterialScriptsGeneric", #PB_3DArchive_FileSystem )
  Parse3DScripts()
  CreateLight( 10, $111111*15, 0, 0, 0,#PB_Light_Spot):SpotLightRange(10, 0, 80,2):LightAttenuation(10, 50,1)
  AmbientColor($111111*2)
  CreateCamera(0, 0, 0, 100, 100)
  CameraBackColor(0,$ff8888)
  CameraRange(0,0,100000)
  
  ; halo lumineux
  CreateTexture(#halo,256,256):StartDrawing(TextureOutput(#halo))
  DrawingMode(#PB_2DDrawing_Gradient):GradientColor(0,$ffffff):GradientColor(1,0):CircularGradient(128,128,128):Circle(128,128,128,$ffffff)
  StopDrawing()
  CreateMaterial(#halo,TextureID(#halo))
  MaterialBlendingMode(#halo,#PB_Material_Add)
  SetMaterialColor(#halo,#PB_Material_SelfIlluminationColor,$ffffff)
  
  ; eau
  CreateCamera(1,0,0,100,100) :CameraBackColor(1,$ff8888)
  CreateRenderTexture(#eau,CameraID(1),ex/2,ey/2)
  CreateMaterial(#eau,TextureID(#eau))
  SetMaterialColor(#eau,#PB_Material_SelfIlluminationColor,$ffffffff)
  SetMaterialAttribute(#eau,#PB_Material_ProjectiveTexturing,1)
  CreateTexture(#eau+1,4,4):StartDrawing(TextureOutput(#eau+1)):DrawingMode(#PB_2DDrawing_AllChannels):Box(0,0,4,4,$88ffcc88):StopDrawing()
  AddMaterialLayer(#eau,TextureID(#eau+1),#PB_Material_Modulate)
  MaterialBlendingMode(#eau,#PB_Material_AlphaBlend)
  CreatePlane(#eau,25,100,1,1,1,1)
  CreateEntity(#eau,MeshID(#eau),MaterialID(#eau),0,-2,50)
  
  grotte(1)
  
  affiche3d()
EndProcedure

main()

Posted: **Tue Apr 21, 2020 6:12 am**

Great stuff! Especially the Flashlight makes a more realistic impression.

Since I am experimenting with VR (Oculus Quest) Is it possible to render a stereo view with Ogre?

Posted: **Tue Apr 21, 2020 11:49 am**

pf shadoko, you sir, are a genius. All your stuff is beautiful.

Posted: **Tue Apr 21, 2020 7:40 pm**

Awesome, as always !

Posted: **Tue Apr 21, 2020 11:38 pm**

Welcome to Planet Earth pf shadoko.

We come in peace and admire your work......

Posted: **Wed Apr 22, 2020 1:40 am**

Cool demo, I like F3 the most. but all the caves are incredible.

Posted: **Sat Apr 25, 2020 11:24 am**

Hi,

thanks for the comments

@ Dige : I do not know if the occulusquest admits a PC video input, if it is the case it is necessary to know accepted stereoscopic format (screen divided in 2 vertically or horizontally ...)

@ IdeasVacuum : I come from a distant galaxy, there we master PB for hundreds of million years.

Posted: **Sun Apr 26, 2020 11:17 am**

pf shadoko wrote: @ Dige : I do not know if the occulusquest admits a PC video input, if it is the case it is necessary to know accepted stereoscopic format (screen divided in 2 vertically or horizontally ...)

Yes, I can link PC via USB3 cable or wireless. The stereoscopic format ist side by side (divides vertically)

Posted: **Sun Apr 26, 2020 3:14 pm**

@pf shadoko
VERY nice as usual.

Posted: **Tue Apr 28, 2020 6:48 pm**

@ Dige:

Can you try this example and tell me if it works?
I created two cameras on top of each other.
note:
1 - I don't know which screen area corresponds to which eye. Maybe the variable 'eyespacing' should be negative.
2 - the result should be stretched vertically
3 - Moving : arrow keys + Mouse - [Esc] quit

Code: Select all

;########################
Define.f eyespacing=0.2
;########################

Define.f ratio=1, keyx,keyz,MouseX,Mousey,yaw

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

InitEngine3D():InitSprite():InitKeyboard():InitMouse()

ExamineDesktops()
ex=DesktopWidth (0)*ratio
ey=DesktopHeight(0)*ratio
OpenWindow(0, 0,0, ex,ey, "Moving : arrow keys + Mouse - [Esc] quit",#PB_Window_ScreenCentered|#PB_Window_BorderLess)
OpenWindowedScreen(WindowID(0), 0, 0, ex, ey, 0, 0, 0)
CreateCamera(0, 0, 0, 100, 50):MoveCamera(0,eyespacing/2,0,0):CameraLookAt(0,0,0,100)
CreateCamera(1, 0, 50, 100, 50):MoveCamera(1, -eyespacing/2,0,0):CameraLookAt(1,0,0,100)

CreateNode(0)
AttachNodeObject(0,CameraID(0))
AttachNodeObject(0,CameraID(1))

CreateLight(0,$ffffff,-1000,1000,0)
AmbientColor($444444)
CreateSphere(0,2,32,32)
CreateTexture(0,512,256)
  StartDrawing(TextureOutput(0))
  For i=0 To 1000
    Line(Random(511),0,1,511,Random($ffffff))
    Line(0,Random(511),511,1,Random($ffffff))
  Next
  StopDrawing()
  
For i=0 To 99
    CreateMaterial(i,TextureID(0))
    col=Random($ffffff)
    SetMaterialColor(i,#PB_Material_DiffuseColor,col)
    SetMaterialColor(i,#PB_Material_AmbientColor,col)
    SetMaterialColor(i,#PB_Material_SpecularColor,$ffffff)
    MaterialShininess(i,128)
Next

For i=0 To 1000
    CreateEntity(i,MeshID(0),MaterialID(i % 100),Random(100)-50,pom(50),pom(50))
    ScaleEntity(i,2+pom(0.5),1+pom(0.5),1+pom(0.5))
    RotateEntity(i,pom(180),pom(180),pom(180))
Next

Repeat
    Repeat: Until  WindowEvent() = 0   
    ExamineMouse()
    ExamineKeyboard()
    MouseX = -MouseDeltaX() *  0.05
    MouseY = -MouseDeltaY() *  0.05
    keyx=(-Bool(KeyboardPushed(#PB_Key_Left)<>0)+Bool(KeyboardPushed(#PB_Key_Right)<>0))*0.1
    keyz=(-Bool(KeyboardPushed(#PB_Key_Down)<>0)+Bool(KeyboardPushed(#PB_Key_Up)<>0))*0.1
    RotateNode(0, -MouseY, MouseX, 0, #PB_Relative):MoveNode(0, -keyx, 0, keyz,#PB_Local )
    RenderWorld()
    FlipBuffers()   
Until KeyboardReleased(#PB_Key_Escape) Or MouseButton(1)

Posted: **Tue Apr 28, 2020 10:08 pm**

Hi pf shadoko. Great Stuff have enjoyed fiddling with your code

Works well. and the last code you asked "Dige" to try works well on Win Pro x64 1909.

As I`m currently learning and using UE4.24.3 and 25 (running in windows and Linux) With RTX|DRTX Win side lol. So as I`m more interested in this kind of work|code and it seems like your the one to show the community and myself what PB can achive with so little code in regards of 3D Texture, materials, PBR, bla bla and so on.

Thank you for the code examples

and please continue ! Take`s me back to "AMOS" - PB that is!

PB is so underrated, 600 lines of code, compiles in a instant. runs flawlessly. A Big thanks to Fred & Team for PB! Could not for forget or leave pb if I wanted too!.

Zebuddi

Ps Last code example x64 exe = 138kb + 11.3mb 3dEngine.dll wonder how ue4 and the big game engines would fair for something akin

Posted: **Wed Apr 29, 2020 1:42 pm**

Lovely stuff as usual. You're stuff is very impressive. (now connect landscape, ocean and caves, and we almost have a game!

)

Zebuddi123 wrote:Take`s me back to "AMOS" - PB that is!

Really. PB is so underrated it's actually funny. I must say it's more like Blitz Basic vibe on amiga for me tho. AMOS was a bit dodgy... I remember getting guru meditation all the time with that damn file requester...

Posted: **Wed Apr 29, 2020 2:10 pm**

PureBasic was a 'fork' of BlitzBasic for Amiga

Posted: **Sat May 02, 2020 5:19 pm**

Fred wrote:PureBasic was a 'fork' of BlitzBasic for Amiga

Indeed, it has "nitrogenous bases" inherited from the Amiga Blitz Basic, Okey dokey

PureBasic Forums - English

Demo 3D - Cave v2 (Shader HLSL)

Demo 3D - Cave v2 (Shader HLSL)

Re: Demo 3D - Cave v2 (Shader HLSL)

Re: Demo 3D - Cave v2 (Shader HLSL)

Re: Demo 3D - Cave v2 (Shader HLSL)

Re: Demo 3D - Cave v2 (Shader HLSL)

Re: Demo 3D - Cave v2 (Shader HLSL)

Re: Demo 3D - Cave v2 (Shader HLSL)

Re: Demo 3D - Cave v2 (Shader HLSL)

Re: Demo 3D - Cave v2 (Shader HLSL)

Re: Demo 3D - Cave v2 (Shader HLSL)

Re: Demo 3D - Cave v2 (Shader HLSL)

Re: Demo 3D - Cave v2 (Shader HLSL)

Re: Demo 3D - Cave v2 (Shader HLSL)

Re: Demo 3D - Cave v2 (Shader HLSL)