Demo 3D - Cave v2 (Shader HLSL)

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

Demo 3D - Cave v2 (Shader HLSL)

Post by pf shadoko »

Image Image

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()
dige
Addict
Addict
Posts: 1247
Joined: Wed Apr 30, 2003 8:15 am
Location: Germany
Contact:

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

Post by dige »

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?
"Daddy, I'll run faster, then it is not so far..."
User avatar
Fangbeast
PureBasic Protozoa
PureBasic Protozoa
Posts: 4747
Joined: Fri Apr 25, 2003 3:08 pm
Location: Not Sydney!!! (Bad water, no goats)

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

Post by Fangbeast »

pf shadoko, you sir, are a genius. All your stuff is beautiful.
Amateur Radio, D-STAR/VK3HAF
Fred
Administrator
Administrator
Posts: 16619
Joined: Fri May 17, 2002 4:39 pm
Location: France
Contact:

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

Post by Fred »

Awesome, as always !
IdeasVacuum
Always Here
Always Here
Posts: 6425
Joined: Fri Oct 23, 2009 2:33 am
Location: Wales, UK
Contact:

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

Post by IdeasVacuum »

Welcome to Planet Earth pf shadoko.

We come in peace and admire your work......
IdeasVacuum
If it sounds simple, you have not grasped the complexity.
box_80
Enthusiast
Enthusiast
Posts: 111
Joined: Mon Sep 03, 2012 8:52 pm

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

Post by box_80 »

Cool demo, I like F3 the most. but all the caves are incredible. :D
User avatar
pf shadoko
Enthusiast
Enthusiast
Posts: 285
Joined: Thu Jul 09, 2015 9:07 am

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

Post by pf shadoko »

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.
dige
Addict
Addict
Posts: 1247
Joined: Wed Apr 30, 2003 8:15 am
Location: Germany
Contact:

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

Post by dige »

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) :D
"Daddy, I'll run faster, then it is not so far..."
User avatar
DK_PETER
Addict
Addict
Posts: 898
Joined: Sat Feb 19, 2011 10:06 am
Location: Denmark
Contact:

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

Post by DK_PETER »

@pf shadoko
VERY nice as usual. :wink:
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.
User avatar
pf shadoko
Enthusiast
Enthusiast
Posts: 285
Joined: Thu Jul 09, 2015 9:07 am

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

Post by pf shadoko »

@ 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)
User avatar
Zebuddi123
Enthusiast
Enthusiast
Posts: 794
Joined: Wed Feb 01, 2012 3:30 pm
Location: Nottinghamshire UK
Contact:

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

Post by Zebuddi123 »

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 :)
malleo, caput, bang. Ego, comprehendunt in tempore
User avatar
oreopa
Enthusiast
Enthusiast
Posts: 281
Joined: Sat Jun 24, 2006 3:29 am
Location: Edinburgh, Scotland.

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

Post by oreopa »

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... :)
Proud supporter of PB! * Musician * C64/6502 Freak
Fred
Administrator
Administrator
Posts: 16619
Joined: Fri May 17, 2002 4:39 pm
Location: France
Contact:

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

Post by Fred »

PureBasic was a 'fork' of BlitzBasic for Amiga :)
User avatar
Psychophanta
Addict
Addict
Posts: 4975
Joined: Wed Jun 11, 2003 9:33 pm
Location: Lípetsk, Russian Federation
Contact:

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

Post by Psychophanta »

Fred wrote:PureBasic was a 'fork' of BlitzBasic for Amiga :)
Indeed, it has "nitrogenous bases" inherited from the Amiga Blitz Basic, Okey dokey
http://www.zeitgeistmovie.com

While world=business:world+mafia:Wend
Will never leave this forum until the absolute bugfree PB :mrgreen:
Post Reply