Demo 3D - Cave v3

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

Demo 3D - Cave v3

Post by pf shadoko »

Hi guys,

an update of my cave demo
not much improvement, except that I added strata
I can now vary the brightness (texture alpha layer X stratum colour alpha layer)
ha yes also, it must work everywhere, it uses glsl shaders
so:
compile in opengl

ps: a little bug when underwater, should be fixed with the new version of PB

Code: Select all

; demo 3d - grotte-v3 - Pf Shadoko - 2020

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 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 i,j, apos,pos, acol.l,col.l,p,lt.s
    n-1
    Dim pal(n)
    
    Repeat
        apos=pos
        acol=col
        i+1
        lt=StringField(gradient,i,"/"):If lt="":Break:EndIf
        pos=ValF(lt)*n
        p=FindString(lt,",")
        If p
            col=Val(Mid(lt,p+1))
            If inv  :col=CoRBinv(col):EndIf
            If alpha:col | $ff000000:EndIf
        Else
            col=acol
        EndIf
        For j=apos To pos:pal(j)=ColorBlend(acol,col,(j-apos)/(pos-apos)):Next
    ForEver
EndProcedure

Procedure Array2Dlimit(Array t.f(2),*min.float,*max.float)
    Protected i,j,dx1,dy1
    Protected.f v,smin,smax
    
    dy1 = ArraySize(t(), 1)
    dx1 = ArraySize(t(), 2)
    smax = -1e10
    smin =  1e10
    For j=0 To dy1
        For i=0 To dx1
            v=t(j,i)
            If v<smin : smin=v: EndIf
            If v>smax : smax=v: EndIf
        Next
    Next
    *min\f=smin
    *max\f=smax
EndProcedure

Procedure Finterpol(Array F.f(1),profil.s,rx.f=1,ry.f=1,oy.f=0)
    Protected.l i,j,n,c,ac,   t.s
    Protected.f y,dx,dy,p
    
    n=CountString(profil,"/")
    Dim s.f2(n)
    For i=0 To n
        t=StringField(profil,i+1,"/")
        s(i)\x=ValF(t)*rx
        s(i)\y=ValF(StringField(t,2,","))*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 blur2D(Array s.f(2),di.w, dj.w,pass=1,loop=1)
    If di=0 And dj=0:ProcedureReturn:EndIf
    Protected i,j,k,d,dii,djj,dx,dy,dij,tx.f
    
    dx = ArraySize(s(), 2):di=min(di,dx)
    dy = ArraySize(s(), 1):dj=min(dj,dy)
    Dim d.f(dy,dx)
    dii=di+1
    djj=dj+1
    dij = dii * djj
    
    If loop
        d=dx-dii/2:Dim lx(dx + 2*dii): For i = 0 To dx + 2*dii: lx(i) = (i+d) % (dx+1): Next
        d=dx-dii/2:Dim ly(dy + 2*djj): For i = 0 To dy + 2*djj: ly(i) = (i+d) % (dy+1): Next    
    Else
        Dim lx(dx + 2*dii): For i = 0 To dx + 2*dii: lx(i) = limite(i-1-dii/2, 0, dx): Next
        Dim ly(dy + 2*djj): For i = 0 To dy + 2*djj: ly(i) = limite(i-1-djj/2, 0, dy): Next
    EndIf  
    For k=1 To pass
        Dim ty.f(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 Embos2D(Array s.f(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.f(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.f(2),n.w=1)
  Protected i,j,k,dx,dy,x,y,ii,jj
  
  dy = ArraySize(s(), 1)
  dx = ArraySize(s(), 2)
  Dim T.f(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 Noise2d(Array t.f(2), dx.w, dy.w,rnd, oinit.b, onb.b=16)
    Protected i,j,n,d,dd,d3,dx1=dx-1,dy1=dy-1,coef.f=9,den.f=1/(2*coef-2),amp.f=1/$1000
    Dim t(dy1, dx1)
    
    RandomSeed(rnd)
    n = 1<<oinit
    dd=min(dx,dy) / n: If dd<1:dd=1:EndIf
    j=0:While j<dy1:i=0:While i<dx1: t(j,i) = (Random($2000) - $1000)*amp:i+dd:Wend:j+dd:Wend
    While dd > 1
        If onb=0:amp=0:EndIf
        d = dd / 2:d3=d*3:amp/2
        j=d:While j<dy
            i=0:While i<dx
                t(j,i) = (-t((j - d3) & dy1,i) - t((j +d3) & dy1,i) + coef*(t((j - d) & dy1,i) + t((j + d) & dy1,i))) *den + (Random($2000) - $1000)*amp
            i+dd:Wend
        j+dd:Wend
        j=0:While j<dy
            i=d:While i<dx
                t(j,i) = (-t(j,(i - d3) & dx1) - t(j,(i +d3) & dx1) + coef*(t(j,(i - d) & dx1) + t(j,(i + d) & dx1))) *den + (Random($2000) - $1000)*amp
            i+dd:Wend
        j+d:Wend
        dd/2:onb-1
    Wend     
EndProcedure

Procedure outline2d(Array t.f(2),dmin.f,dmax.f,outline.s="0,0/1,1")
    Protected dx1,dy1,i,j,k,xi
    Protected.f smin,smax,sr,dr,tt,x,y0,y1,x0
    
    dy1 = ArraySize(t(), 1)
    dx1 = ArraySize(t(), 2)
    Array2Dlimit(t(),@smin,@smax)
    sr=smax-smin
    dr=dmax-dmin
    
    Protected Dim conv.f(100)
    Finterpol(conv(),outline,100)
    For j=0 To dy1
        For i=0 To dx1
            x=(t(j,i)-smin)/sr*99
            xi=Int(x):x0=x-xi
            y0=conv(xi)
            y1=conv(xi+1)
            t(j,i)=(y1*x0+y0*(1-x0))*dr+dmin
        Next
    Next
EndProcedure

Procedure textureArrayToColor(tex,Array t.f(2),grad.s="0,$000000/1,$ffffff")
    Protected i,j,n,dx,dy
    Protected.f min,max,r
    
    dx=ArraySize(t(),2)+1
    dy=ArraySize(t(),1)+1
    Dim bmp.l(dy-1,dx-1)
    
    Protected Dim grad.l(0):gradienttoarray(grad(),1024,grad,1)
    Array2Dlimit(t(),@min,@max):r=1023/(max-min)
    For j=0 To dy-1:For i=0 To dx-1:n=(t(j,i)-min)*r:bmp(j,i)=grad(n):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 textureArrayToNM(tex,Array t.f(2),amplitude.f)
    Protected i,j,n,dx,dy
    Protected.f h00,h10,h01,x,y,z,l, max=1/amplitude,max2=max*max
    Protected.f3 p
    
    dx=ArraySize(t(),2)+1
    dy=ArraySize(t(),1)+1
    Dim bmp.l(dy-1,dx-1)
    For j=0 To dy-1
        For i=0 To dx-1
            h00=t(j,i)
            h10=t(j,(i+1) % dx)
            h01=t((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  
    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 SelfAddArray2d(Array s.f(2))
    Protected i,j,dx,dy,dx2,dy2
    
    dy = ArraySize(s(), 1):dy2=dy/2
    dx = ArraySize(s(), 2):dx2=dx/2
    Dim t.f(0,0):CopyArray(s(),t())
    For j=0 To dy:For i=0 To dx:s(j,i)=t(j,i)+t((j+dy2) & dy,i):Next:Next
EndProcedure

Procedure triangle(Array t.f(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.f(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.f(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($1000)/$1000
        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 minauto(Array s.f(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.f(2),lissage.w=1)
  Protected i,j,k,dx,dy
  
  dy = ArraySize(s(), 1)
  dx = ArraySize(s(), 2)
  Dim T.f(dy,dx)
  CopyArray(s(),t())
  blur2D(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.f(0,0)
  Protected Dim tr.f(0,0)
  Protected i,j,n
  
  Noise2d(t(),dx,dy,rnd,f)
  ;heightmapcristal(t(),rnd,dx,dy,16)
  blur2D(t(),lissage,lissage,2)
  If Embos<>100:Embos2D(t(),Embos,0):EndIf
  outline2d(t(),0,1,profil)
  
  textureArraytocolor(tex,t(),grad)
    
  textureArraytoNM(tex+1,t(),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, prec=512)
  Protected i,j,k,kj,is,js,  di=128,di1=di-1,di2=di/2,  dj=1024,dj1=dj-1,  icolor,    ntile=8,brillance,stadens,strate_grad.s
  Protected.f r,a,x,y,z,  sta,   liss,ampl, amps, ray,rayam
  Protected.f3 p1,p2,n,ni,dir,ddir,adir,diram,p,pc,rnd
  Dim hmr.f(0,0)
  Dim hms.f(0,0)
  Dim grads.l(0)
  Dim ligness.f3(dj+1)
  Dim rayon.f(dj+1)
   
  Select num
    Case 1:stadens=20:liss=2:ampl=0.5:texture(1,prec,prec,0,  4,1,100,12,"0,0/0.7,0.4/1,1","0,$ff66ccff/0.4,$ff4488ff/1,$00ffffff"):amps=0.5:strate_grad="0,$888888/0.4,$ffffff/0.7,$ff0088ff/1,$ff00aaaa"
    Case 2:stadens= 0:liss=0:ampl=1.0:texture(1,prec,prec,1,  4,0,100,12,"0,0/0.8,1/1,0","0,$4488bbff/0.8,$444488bb/0.9,$ffffffff/1"):amps=0.8:strate_grad="0,$ffaa8888/0.4,$ff88aaff/0.6,$ffffffff/0.7,$ffffffff/1,$ff888888"
    Case 3:stadens= 0:liss=2:ampl=0.8:texture(1,prec,prec,1,  2,0,100,12,"0,1/0.4,0.5/0.5,0/0.6,0.5/1,1","0,$ff888888/0.2,$ffaaaaaa/0.5,$ffffffff/1"):amps=0.2:strate_grad="0,$00aadddd/0.2/0.6,$ffaaffff/1"
    Case 4:stadens=20:liss=1:ampl=0.4:texture(1,prec,prec,1,  2,2,10,8,"0,0/0.3,0.7/1,1","0,$00448888/0.5,$00448888/0.7,$ff4488bb/1,$ffffffff"):amps=0.5:strate_grad="0,$ff88ffff/0.4,$ffffffff/0.6,$8888ff/1"
    Case 5:stadens= 0:liss=2:ampl=0.6:texture(1,prec,prec,0,  4,0,100,12,"0,0/1,1","0,$0088ff88/0.7,$00ff8888/0.8,$ff66ffff/1,$ff66ffff"):amps=0.8:strate_grad="0,$ffffff88/0.6,$ff8888ff/0.7/1,$ffffffff"
  EndSelect
  
  CreateBillboardGroup(0,MaterialID(#halo),0.5,0.5):HideBillboardGroup(0,1-lum):HideLight(10,lum)
  MoveCamera(0,0,0,0.5,#PB_Absolute):CameraLookAt(0,0,0,2)
  
  ;texture paroie
  GetScriptMaterial(1,"bump"):MaterialTextureAliases(1,TextureID(1),TextureID(2),0,0)
  MaterialFilteringMode(1,#PB_Material_Anisotropic,4)
  SetMaterialColor(1, #PB_Light_SpecularColor, $111111*8):MaterialShininess(1,$11*8)
  
  ;relief
  Noise2d(hmr(),di,dj,num,2)
  blur2D(hmr(),liss,liss,1)
  outline2d(hmr(),-1,1)
  
  ;strates
  Noise2d(hms(),128,128,0,3)
  blur2D(hms(),8,0,1)
  outline2d(hms(),-1,1,"0,0/0.4,0.3/0.6,0.7/1,1")
  gradienttoarray(grads(),1024,strate_grad)

  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/2)-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
              With t(i,j)
                  r=rayon(kj)*10*(1+hmr(kj & dj1,i  & di1)*ampl)
                  a=i/di*2*#PI
                  vec3d(p,0,-Cos(a)*r,-Sin(a)*r)
                  calcmatrot(p,p)
                  add3d(p,p,ligness(kj))
                  p\x-pc\x
                  p\z-pc\z
                  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(\p,p\x,p\y-sta, p\z)
                  is=kj & 127
                  js=Int(p\y*32) & 127
                  \p\x+hms(is,js)*amps*Sin(a)
                  \u= i/di*ntile
                  \v=kj/128*ntile
                  \color=grads(Int((hms(is,js)+1)*512))
                  If p\y+2<0:\color=ColorBlend(\color,$444400,limite(-(p\y+2)/2,0,1)):EndIf
              EndWith
          Next
      Next
      CreateDataMesh(k,t())
      NormalizeMesh(k)
      BuildMeshTangents(k)
    CreateEntity(k,MeshID(k),MaterialID(1),pc\x,0,pc\z)
    
    CreateLight(k, $ffffff, pc\x,pc\y,pc\z)
    LightAttenuation(k, 20,1)
    HideLight(k,1-lum)
    blight(k)= AddBillboard(0,pc\x,pc\y,pc\z)
    plight(k)=pc
  Next
EndProcedure

Procedure affiche3d()
  Static.f MouseX,Mousey,depX,depz,dist,  fdf.l, i.l,a,ai,n.i,pl.f3
  
  Repeat
    ExamineMouse()
    MouseX = -MouseDeltaX() *  0.05
    MouseY = -MouseDeltaY() *  0.05
    ExamineKeyboard()
    depX=(-Bool(KeyboardPushed(#PB_Key_Left)<>0)+Bool(KeyboardPushed(#PB_Key_Right)<>0))*0.02
    depz=(-Bool(KeyboardPushed(#PB_Key_Down)<>0)+Bool(KeyboardPushed(#PB_Key_Up   )<>0)+MouseButton(1)-MouseButton(2))*0.02+MouseWheel()*1
    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):dist+(depz-dist)*0.1:MoveCamera  (0, depX, 0, -dist)

    If CameraY(0)>-2
        Fog($000000,1,0,200):MaterialCullingMode(#eau,#PB_Material_ClockWiseCull)
    Else
        Fog($222200,1,0,10 ):MaterialCullingMode(#eau,#PB_Material_AntiClockWiseCull)
    EndIf

    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
    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] -> [F5]","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):LightAttenuation(10, 25,1)
  AmbientColor($111111*2)
  CreateCamera(0, 0, 0, 100, 100)
  ;CameraBackColor(0,$ff8888)
  CameraRange(0,0,1000)
  Fog($0,1,0,1000)
  
  ; halo lumineux
  CreateTexture(#halo,256,256):StartDrawing(TextureOutput(#halo))
  DrawingMode(#PB_2DDrawing_AllChannels|#PB_2DDrawing_Gradient):GradientColor(0,$ffffffff):GradientColor(1,$00ffffff):CircularGradient(128,128,128):Box(0,0,256,256)
  StopDrawing()
  CreateMaterial(#halo,TextureID(#halo))
  MaterialBlendingMode(#halo,#PB_Material_AlphaBlend)
  SetMaterialColor(#halo,#PB_Material_SelfIlluminationColor,$ffffff)
  
  ; eau
  CreateCamera(1,0,0,100,100) :CameraBackColor(1,$ff8888)
  CreateRenderTexture(#eau,CameraID(1),ex/2,ey/2)
  Protected Dim t.f(0,0)
  Noise2d(t(),128,128,0,2):blur2D(t(),1,1,2):outline2d(t(),-0.1,0.1,"0,0/0.5,1/1,0"):textureArraytoNM(#eau+1,t(),8)
  GetScriptMaterial(#eau,"water_rtt"):MaterialTextureAliases(#eau,TextureID(#eau+1),TextureID(#eau),0,0):SetMaterialColor(#eau,#PB_Material_DiffuseColor,$22000000)
  MaterialBlendingMode(#eau,#PB_Material_AlphaBlend)
  MaterialCullingMode(#eau, #PB_Material_NoCulling)  
  CreatePlane(#eau,64,128,64,128,32,64);:TransformMesh(#eau,0,-0.05,0,1,1,1,0,0,0)
  CreateEntity(#eau,MeshID(#eau),MaterialID(#eau),0,-2,50)
  
  grotte(1, 512)
  
  affiche3d()
EndProcedure

main()
Cyllceaux
Enthusiast
Enthusiast
Posts: 315
Joined: Mon Jun 23, 2014 1:18 pm
Contact:

Re: Demo 3D - Cave v3

Post by Cyllceaux »

hey shadoko,

I really love this kind of Demos... But every time I saw the first cave (F1), it always reminds me on an image of a colonoscopy. :)
User avatar
Keya
Addict
Addict
Posts: 1833
Joined: Thu Jun 04, 2015 7:10 am

Re: Demo 3D - Cave v3

Post by Keya »

screenshot please? thanks :)
Cyllceaux
Enthusiast
Enthusiast
Posts: 315
Joined: Mon Jun 23, 2014 1:18 pm
Contact:

Re: Demo 3D - Cave v3

Post by Cyllceaux »

Image

Image
User avatar
Keya
Addict
Addict
Posts: 1833
Joined: Thu Jun 04, 2015 7:10 am

Re: Demo 3D - Cave v3

Post by Keya »

WOW!!!!!! that looks incredible!!! :)
thankyou very much for the screenshots
Rinzwind
Enthusiast
Enthusiast
Posts: 384
Joined: Wed Mar 11, 2009 4:06 pm
Location: NL

Re: Demo 3D - Cave v3

Post by Rinzwind »

Mouse movement is unusable here (laser mouse with dpi switch). Not sure what causes it. Already tried lowering the multiplication value.
User avatar
Fangbeast
PureBasic Protozoa
PureBasic Protozoa
Posts: 4644
Joined: Fri Apr 25, 2003 3:08 pm
Location: Not Sydney!!! (Bad water, no goats)

Re: Demo 3D - Cave v3

Post by Fangbeast »

Hello Pf Shadoko. In your previous cave code without the new additions, the cave demo worked here with opengl in the subsystem.

I put opengl in the subsystem area now and the code crashes at Procedure main()
InitKeyboard():InitMouse():InitEngine3D():InitSprite()

"Invalid memory access: (read error at address 1720320"

Is there anything I might have missed? I am assuming that case in the subsystem is not a problem? (Ie OpenGL, OPENGL, opengl etc)
Amateur Radio, D-STAR/VK3HAF
User avatar
pf shadoko
Enthusiast
Enthusiast
Posts: 163
Joined: Thu Jul 09, 2015 9:07 am

Re: Demo 3D - Cave v3

Post by pf shadoko »

@ Rinzwind:
it's a dpi problem, in my case it's strange, when I open PB, the first program I run works normally
tell me if it's similar for you.
relaunch PB, copy the code (activate opengl) and run it

@ Fangbeast:
curious
can you break down the line and tell me which "init" crashes?
you can write "opengl" any way you want
User avatar
Fangbeast
PureBasic Protozoa
PureBasic Protozoa
Posts: 4644
Joined: Fri Apr 25, 2003 3:08 pm
Location: Not Sydney!!! (Bad water, no goats)

Re: Demo 3D - Cave v3

Post by Fangbeast »


@ Fangbeast:
curious
can you break down the line and tell me which "init" crashes?
you can write "opengl" any way you want
Good morning, no coffee yet. I spaced out the lines and got the crash at the InitEngine3D() line. Have the feeling I've done something that I don't know about because I know nothing about graphics.

Procedure main()

InitKeyboard()

InitMouse()

InitEngine3D() ; Crash specifically at this line
Amateur Radio, D-STAR/VK3HAF
User avatar
pf shadoko
Enthusiast
Enthusiast
Posts: 163
Joined: Thu Jul 09, 2015 9:07 am

Re: Demo 3D - Cave v3

Post by pf shadoko »

this is the first instruction executed
I conclude that opengl does not work for you
Can you test an example of the doc in opengl and tell me if it works ?
User avatar
Fangbeast
PureBasic Protozoa
PureBasic Protozoa
Posts: 4644
Joined: Fri Apr 25, 2003 3:08 pm
Location: Not Sydney!!! (Bad water, no goats)

Re: Demo 3D - Cave v3

Post by Fangbeast »

Good morning. I assume you mean the OpenGLGadget and the terrain demos?

Both work without defining OpenGL subsystem in settings for their respective codes.
Amateur Radio, D-STAR/VK3HAF
ludoke
Enthusiast
Enthusiast
Posts: 150
Joined: Fri Jul 08, 2016 5:35 pm
Location: Essen (Belgium)

Re: Demo 3D - Cave v3

Post by ludoke »

Hello,

I try to run this demo ,but I see only a white screen.What am I doing wrong?
I tried it with pB 32 and 64bit version 5.73.
User avatar
DK_PETER
Addict
Addict
Posts: 871
Joined: Sat Feb 19, 2011 10:06 am
Location: Denmark
Contact:

Re: Demo 3D - Cave v3

Post by DK_PETER »

@pf shadoko
Really nice :-)

@Rinzwind
Enabling DPI aware in compiler options should fix the mouse issue.

@Fangbeats and ludoke: change the init code and examine the engine debug file.
Remember to add 'Opengl' to the library Subsystem in compiler options

Code: Select all

If InitEngine3D(#PB_Engine3D_DebugLog) = 0
  MessageRequester("Oops!", "Didn't get passed the InitEngine")
  ;Examine engine3D.log file for clues" (text file)
  End
EndIf
If InitSprite() = 0
  MessageRequester("Sprite", "Unable to initialize InitSprite)
  End
EndIf
“Tell me and I forget. Teach me and I remember. Involve me and I learn.”
— Benjamin Franklin
Current configurations:
Windows 10, Intel 6800K, GeForce Gtx 1060, 32 gb ram.
Windows 10, Amd Ryzen 9 5950X, GeForce 3070, 128 gb ram.
User avatar
pf shadoko
Enthusiast
Enthusiast
Posts: 163
Joined: Thu Jul 09, 2015 9:07 am

Re: Demo 3D - Cave v3

Post by pf shadoko »

@ Fangbeats
no, I would like you to test on a PB example (in the help you will find many examples) with defining opengl as subsystem
and tell me if it works
box_80
User
User
Posts: 94
Joined: Mon Sep 03, 2012 8:52 pm

Re: Demo 3D - Cave v3

Post by box_80 »

I wondered about the crazy mouse movement. Thanks for the info. Nice cave demo Pf Shadoko.
Post Reply