demo 3D - Grotte V3

Généralités sur la programmation 3D
Avatar de l’utilisateur
Guillot
Messages : 383
Inscription : jeu. 25/juin/2015 16:18

demo 3D - Grotte V3

Message par Guillot »

salut les geek,

une mise a jour de ma demo grotte
pas beaucoup d'améliorations, si ce n'est que j'ai rajouté des strates
je peux maintenant faire varier la brillance (couche alpha de la texture X couche alpha de la couleur de la strate)
ha oui aussi, ça doit marcher de partout, ça utilise les shaders glsl
donc:
compiler en opengl

ps: un petit bug quand on est sous l'eau, ça devrai être corrigé avec la nouvelle version de PB

Code : Tout sélectionner

; 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()
Avatar de l’utilisateur
Micoute
Messages : 2407
Inscription : dim. 02/oct./2011 16:17
Localisation : 50200 Coutances

Re: demo 3D - Grotte V3

Message par Micoute »

C'est merveilleusement merveilleux, merci professeur Shadoko pour le partage, j'ai été bluffé.
Microsoft Windows 10 Famille 64 bits : Carte mère : ASRock 970 Extreme3 R2.0 : Carte Graphique NVIDIA GeForce RTX 3080 : Processeur AMD FX 6300 6 cœurs 12 threads 3,50 GHz PB 5.73
Un homme doit être poli, mais il doit aussi être libre !
Avatar de l’utilisateur
Kwai chang caine
Messages : 6848
Inscription : sam. 23/sept./2006 18:32
Localisation : Isere

Re: demo 3D - Grotte V3

Message par Kwai chang caine »

Putain !!!! encore une fois sur le cul 8O
Heureusement que je suis assis quand je vois tes codes, sinon je pourrais prendre un abonnement au service gériatrique des coccyx de l'hopital de ma région :cry:

Cet effet de brillance sur les parois de la grotte, le reflet de l'eau..... :D
Cette fois ..plus de doutes on est plus en endoscopie du colon, mais bel et bien dans une grotte hyper réaliste

Chapeau bas....et merci pour la modif, je dois toujours mettre "Engine3D.dll" dans le même répertoire :wink:
T'es vraiment un dieu, je suis fier que tu fasses partie de la famille 8)
ImageLe bonheur est une route...
Pas une destination

PureBasic Forum Officiel - Site PureBasic
Avatar de l’utilisateur
Micoute
Messages : 2407
Inscription : dim. 02/oct./2011 16:17
Localisation : 50200 Coutances

Re: demo 3D - Grotte V3

Message par Micoute »

Kcc tu as dis tout haut, ce que j'ai pensé silencieusement.
Microsoft Windows 10 Famille 64 bits : Carte mère : ASRock 970 Extreme3 R2.0 : Carte Graphique NVIDIA GeForce RTX 3080 : Processeur AMD FX 6300 6 cœurs 12 threads 3,50 GHz PB 5.73
Un homme doit être poli, mais il doit aussi être libre !
Avatar de l’utilisateur
Kwai chang caine
Messages : 6848
Inscription : sam. 23/sept./2006 18:32
Localisation : Isere

Re: demo 3D - Grotte V3

Message par Kwai chang caine »

:lol:

Normal, KCC il est tout en gueule..... :mrgreen:

Image

Comme les crocodiles :lol:
ImageLe bonheur est une route...
Pas une destination

PureBasic Forum Officiel - Site PureBasic
G-Rom
Messages : 3532
Inscription : dim. 10/janv./2010 5:29

Re: demo 3D - Grotte V3

Message par G-Rom »

Efficace la génération procédurale. j'ai rajouté un fov de 90° pour un meilleur effet sur mon écran large.
Avatar de l’utilisateur
Micoute
Messages : 2407
Inscription : dim. 02/oct./2011 16:17
Localisation : 50200 Coutances

Re: demo 3D - Grotte V3

Message par Micoute »

Kwai chang caine a écrit : mar. 11/mai/2021 19:18 :lol:

Normal, KCC il est tout en gueule..... :mrgreen:

Image

Comme les crocodiles :lol:
Avec les petits bras aussi ?
Microsoft Windows 10 Famille 64 bits : Carte mère : ASRock 970 Extreme3 R2.0 : Carte Graphique NVIDIA GeForce RTX 3080 : Processeur AMD FX 6300 6 cœurs 12 threads 3,50 GHz PB 5.73
Un homme doit être poli, mais il doit aussi être libre !
Avatar de l’utilisateur
Kwai chang caine
Messages : 6848
Inscription : sam. 23/sept./2006 18:32
Localisation : Isere

Re: demo 3D - Grotte V3

Message par Kwai chang caine »

Si y'avait que les bras :oops: :lol:
ImageLe bonheur est une route...
Pas une destination

PureBasic Forum Officiel - Site PureBasic
Répondre