PureBasic

Code : Tout sélectionner

; demo 3d - grotte - Pf Shadoko - 2018

EnableExplicit

Structure vector2
  x.f
  y.f
EndStructure

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

Structure Svertex2
  p.vector3
  n.vector3
  diag.b
  ai.b
  aj.b
  uv.vector2
  color.l
EndStructure

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

Procedure.f Mini(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 vec3d(v,vx,vy,vz)
  v\x=vx
  v\y=vy
  v\z=vz
EndMacro

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

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

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

Procedure Pvectoriel3d(*r.vector3,*p.vector3,*q.vector3)
*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

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 sub3D(p,p1,p2)
  p\x=p1\x-p2\x
  p\y=p1\y-p2\y
  p\z=p1\z-p2\z
EndMacro

Macro interpol(v,v1,v2,r=0.5)
  v=v1*(1-r)+v2*r
EndMacro

Procedure interpol3D(*R.Vector3, *V1.Vector3, *V2.Vector3, 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 defmatrot(*p.vector3,w.f, Array m.f(2),orientation=0)
  Protected.vector3 pp,p,q,r
  Protected.f l
  vec3d(p,*p\x,*p\y,*p\z)
  l=lng3d(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(q,p,pp):Norme3d(q,l)
  pvectoriel3d(r,p,q) :Norme3d(r,l)
  m(0,0)=p\x:m(0,1)=q\x:m(0,2)=r\x
  m(1,0)=p\y:m(1,1)=q\y:m(1,2)=r\y
  m(2,0)=p\z:m(2,1)=q\z:m(2,2)=r\z
EndProcedure

Procedure calcmatrot(*v.vector3, *u.vector3, Array m.f(2))
  Protected.f x=*u\x, y=*u\y, z=*u\z
  *v\x=m(0,0) * x + m(0,1) * y + m(0,2) * z
  *v\y=m(1,0) * x + m(1,1) * y + m(1,2) * z
  *v\z=m(2,0) * x + m(2,1) * y + m(2,2) * z
EndProcedure


Procedure addvertex(px.f,py.f,pz.f, nx.f,ny.f,nz.f, u.f,v.f,c=0)
    MeshVertexPosition(px,py,pz)
    MeshVertexNormal(nx,ny,nz)
    MeshVertexTextureCoordinate(u,v)  
    MeshVertexColor(c)
EndProcedure

Procedure Createsurface(mesh,Array t.Svertex2(2))
  Protected p,i,j,m,diag,nx=ArraySize(t(),2),nz=ArraySize(t(),1)
  Protected.vector3 d1,d2,n
  m=CreateMesh(mesh):If mesh=-1:mesh=m:EndIf
  For j=0 To nz
    For i=0 To nx
      With t(j,i)
        addvertex(\P\x,\p\y,\p\z,\n\x,\n\y,\n\z,\uv\x,\uv\y,\color)
      EndWith
    Next
  Next  
  For j=0 To nz-1
    For i=0 To nx-1
      p=j*(nx+1)+i
      diag=t(j,i)\diag
      If diag=0
        sub3d(d1,t(j,i)\p,t(j+1,i+1)\p)
        sub3d(d2,t(j+1,i)\p,t(j,i+1)\p)
        If lng3d(d1)>lng3d(d2):diag=1:Else:diag=-1:EndIf
      EndIf
      If diag=1
        MeshFace(p,p+nx+1,p+1): MeshFace(p+nx+2,p+1,p+nx+1)
      Else
        MeshFace(p+nx+1,p+nx+2,p): MeshFace(p+1,p,p+nx+2)
      EndIf
    Next
  Next
  FinishMesh(1)
  NormalizeMesh(mesh)
  UpdateMeshBoundingBox(mesh)
  ProcedureReturn mesh
EndProcedure

Procedure Split(Array t.s(1),l.s,sep.s=",",nmax=100)
    Protected ap.l,p.l,n,ls
    Dim t(nmax)
    ls=Len(sep)
    l+sep
    p=1-ls
    Repeat
        ap=p+ls:p=FindString(l,sep,ap)
        If p=0:Break:EndIf
        n+1
        t(n)= Mid(l,ap,p-ap)
    ForEver
    ReDim t(n)
  EndProcedure
  
Procedure string2vector2(Array s.vector2(1),txt.s)
  Dim tt.s(0)
  Dim t.s(0)
  Protected i,n
  
  split(tt(),txt,"/",100)
  n=ArraySize(tt())
  Dim s(n-1)
  For i=1 To n
    split(t(),tt(i)+",0",",")
    With s(i-1)
      \x=ValF(t(1))
      \y=ValF(t(2))
    EndWith
  Next
EndProcedure

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

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

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

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

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

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

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

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

Procedure lisser2D(Array s.w(2),di.w, dj.w,pass=1,loop=1)
  If di=0 And dj=0:ProcedureReturn:EndIf
  Protected i,j,k,dii,djj,dx,dy,dij,tx
  dx = ArraySize(s(), 2):di=mini(di,dx)
  dy = ArraySize(s(), 1):dj=mini(dj,dy)
  Dim d.w(dy,dx)
  dii=di+1
  djj=dj+1
  dij = dii * djj
  Dim lx(0)
  Dim ly(0)
  If loop
    Tmodulo (lx(), dx, di+1)
    Tmodulo (ly(), dy, dj+1) 
  Else
    Tlimite(lx(), dx, di+1)
    Tlimite(ly(), dy, dj+1)
  EndIf  
  ;Debug "-------------":For i=0 To ArraySize(lx()):Debug lx(i):Next
  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.w(2),rnd, dx.w, dy.w, Re.w)
  Protected i,j,ii,jj,n,d,dd,dx1=dx-1,dy1=dy-1,l,R, rr,dec
  
  RandomSeed(rnd)
  n = 1<<re
  dd=mini(dx,dy) / n: If dd<1:dd=1:EndIf
  Dim t.w(dy-1, dx-1)
  rr = $1fff:r=rr>>1
  For jj = 0 To dy/dd - 1:j=jj*dd: For ii = 0 To dx/dd - 1:i=ii*dd: t(j,i) = Random(rr) - R: Next: Next
  l = dd
  While dd > 1
    d = dd / 2
    For jj = 0 To dy/dd - 1  :j=jj*dd+d
      For ii = 0 To dx/dd - 1:i=ii*dd+d
        t(j,i) = (t((j - d) & dy1,(i - d) & dx1) + t((j - d) & dy1,(i + d) & dx1) + t((j + d) & dy1,(i + d) & dx1) + t((j + d) & dy1,(i - d) & dx1)) / 4 + Random(rr) - R
      Next
    Next
    For jj = 0 To dy/d - 1  :j=jj*d:dec=1- jj & 1
      For ii = 0 To dx/dd - 1:i=ii*dd+dec*d
        t(j,i) = (t(j,(i - d) & dx1) + t(j,(i + d) & dx1) + t((j - d) & dy1,i) + t((j + d) & dy1,i)) / 4 + Random(rr) - R
      Next
    Next
    l/2
    dd/2
    r/2:rr/2
  Wend 
EndProcedure

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

Global lumnb,lum

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

Procedure grotte(num=1)
  Protected i,j,k,ii,jj,is,js,di=128,di2=di/2,  dj=1024,  icolor,   lhm=128,lhm1=lhm-1,   ntile=16,brillance,   strate_grad.s,stadens
  Protected.f r,a,x,y,z,  sta,   liss,ampl, ray,rayam
  Protected.vector3 p1,p2,n,ni,dir,ddir,adir,diram,p,ap,rnd
  Dim hmr.w(0,0)
  Dim hms.w(0,0)
  Dim grads.l(0)
  Dim ligness.vector3(dj)
  Dim rayon.f(dj)
  Dim mtx.f(2,2)
   
  Select num
    Case 1
      texture(1,512,512,2,4,0,-1000,"0,$44aadd/0.7,$88eeff/1,$448888")
      brillance=$444444
      strate_grad="0,$000000/0.4,$004488/0.7,$888888/1,$888888"
      stadens=20
      liss=2
      ampl=0.8
    Case 2
      texture(1,512,512,1,2,1,9,"0,$99ccee / 0.5,$3388bb / 1,$112244")
      strate_grad="0,$664444/0.5,$004488/1,$888888"
      stadens=5
      liss=1
      ampl=0.6
    Case 3
      texture(1,512,512,0,7,1,-1000,"0,$004488/0.7,$4488ff/0.7,$224466/1,$4488cc")
      brillance=$222222
      strate_grad="0,$0088ff / 0.4,$2244aa / 0.6,$888888 / 1,$0066ff"
      liss=8
      ampl=0.9
  EndSelect
  
  lumnb=0
  MoveCamera(0,0,0,1,#PB_Absolute):CameraLookAt(0,0,0,2)
  
  RandomSeed(num)
  r=0.05
  vec3d(ddir,0,0,10)
  For j=0 To dj
    ray=ray+pom(1)-(ray-2)*0.01
    interpol(rayam,rayam,ray,0.01)
    rayon(j)=limite(rayam,1,3)
    
    vec3d(rnd,pom(1)-p\x*r,pom(1)-p\y*r,0.1)
    add3d(ddir,ddir,rnd):norme3d(ddir,rayon(j)*4)
    add3d(dir,dir,ddir)
    norme3d(dir,0.1)
    interpol3D(diram,diram,dir,0.05)
    add3d(p,p,diram)
    ligness(j)=p
  Next
  rayon(0)=0
  
  Dim t.svertex2(di,dj-1)
  
  ;texture paroie
  CreateMaterial(1,TextureID(1)):MaterialCullingMode(1,#PB_Material_NoCulling)
  SetMaterialColor(1, #PB_Material_SpecularColor,brillance ):MaterialShininess(1, 20)
  SetMaterialColor(1, #PB_Material_AmbientColor,-1)
  MaterialFilteringMode(1,#PB_Material_Anisotropic,4)
  SetMaterialColor(1, #PB_Material_AmbientColor,-1)
  ; relief
  heightmap(hmr(),5,lhm,lhm,1)
  lisser2d(hmr(),liss,liss,1)
  t2norme(hmr(),-1024,1024,"")
  ;strates
  heightmap(hms(),0,lhm,lhm,3)
  lisser2d(hms(),0,0,1)
  t2norme(hms(),0,1023,"")
  gradienttoarray(grads(),1024,strate_grad)
  
  For j=0 To dj-1
    adir=dir:sub3d(dir,ligness(j+1),ligness(j))
    defmatrot(dir,0,mtx(),0)
    For i=0 To di
      a=i/di*2*#PI
      ii=i & lhm1
      jj=j & lhm1
      r=rayon(j)*10*(1+hmr(ii,jj)/1024*ampl+pom(0.0))
      vec3d(p,0,-Cos(a)*r,Sin(a)*r)
      calcmatrot(p,p,mtx())
      add3d(p,p,ligness(j))
      is=(j*4) & lhm1
      js=Int(p\y*32) & lhm1
      icolor=grads(hms(is,js)) 
      If Random(1000)<stadens And Abs(i-di2)<16 And r>25:sta=pom(0.4)+0.4:icolor=$ffffff:Else:sta=0:EndIf  
      vec3d(t(i,j)\p,p\x,p\y-sta, p\z)
      vec2d(t(i,j)\uv,i/lhm*ntile,j/lhm*ntile)
      t(i,j)\color=icolor   
      If 1 And i=di2 And j & 127=64
        lumnb+1
        CreateLight(lumnb, $444444, p\x,p\y-0.5,p\z)
        SetLightColor(lumnb, #PB_Light_SpecularColor, $444444)
        LightAttenuation(lumnb, rayon(j)*15,0.5)
        HideLight(lumnb,1-lum)
      EndIf
    Next
  Next

  createsurface(1,t())
  CreateEntity(1,MeshID(1),MaterialID(1))
  
EndProcedure

Procedure affiche3d()
  Static.f MouseX,Mousey,keyx,keyy,keyz,a,  fdf
  Protected i,event,transit=200
  
  Repeat
    event=WindowEvent()  
    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))*0.02+MouseWheel()*2
    If KeyboardReleased(#PB_Key_F1):grotte(1):EndIf
    If KeyboardReleased(#PB_Key_F2):grotte(2):EndIf
    If KeyboardReleased(#PB_Key_F3):grotte(3):EndIf
    If KeyboardReleased(#PB_Key_F11):lum=1-lum:HideLight(0,lum):For i=1 To lumnb: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),maxi(CameraY(0),-2.9),CameraZ(0),#PB_Absolute) 
    MoveLight(0,CameraX(0),CameraY(0),CameraZ(0),#PB_Absolute):LightDirection(0,CameraDirectionX(0),CameraDirectionY(0),CameraDirectionZ(0))
    RenderWorld()
    DisplayTransparentSprite(0,8,8)
    FlipBuffers()
  Until event=#PB_Event_CloseWindow  Or KeyboardPushed(#PB_Key_Escape)
EndProcedure

Procedure menu()
  Protected p=8
  Macro DT(t1,t2)
    DrawText(8,p,t1)
    DrawText(100,p,t2)
    p+22
  EndMacro
  CreateSprite(0,220,190,#PB_Sprite_AlphaBlending)
  StartDrawing(SpriteOutput(0))
  DrawingMode(#PB_2DDrawing_AllChannels)
  DrawingFont(FontID(0))
  Box(0,0,220,190,$44000000)
  DrawingMode(#PB_2DDrawing_AllChannels|#PB_2DDrawing_Outlined)
  Box(0,0,220,190,$ffffffff)
  BackColor($44000000)
  FrontColor($ffffffff)
  dt("Moving:","")
  dt("Cursor + Mouse","")
  dt("","")
  dt("Controls:","")
  dt("[F1]->[F3]","Select cave")
  dt("[F11]","Light on/off")
  dt("[F12]","Wireframe")
  dt("[Esc]","Quit")
  StopDrawing()
EndProcedure

Procedure main()
  Protected i,ex,ey,r.f=1
  ExamineDesktops()
  ex=DesktopWidth(0)
  ey=DesktopHeight(0)
  
  InitKeyboard():InitMouse():InitEngine3D():InitSprite() 
  OpenWindow(0,0,0,ex*r,ey*r,"",#PB_Window_BorderLess|#PB_Window_ScreenCentered)
  OpenWindowedScreen(WindowID(0), 0, 0, WindowWidth(0),WindowHeight(0))
  LoadFont(0,"arial",14)
  menu()
  ;-------------------- scene
  CreateLight(0, $444444, 100, 100, 0,#PB_Light_Spot):SetLightColor(0, #PB_Light_SpecularColor, $444444):SpotLightRange(0, 0, 80,2):LightAttenuation(0, 100,0)
  AmbientColor($444444)
  CreateCamera(0, 0, 0, 100, 100)
  CameraBackColor(0,$ff8888)
  CameraRange(0,0,100000)
  CameraLookAt(0, 0, 0, 1)
  
  grotte()
  ;eau
  texture(2,256,256,0,4,0,-1000,"0,$aa226644/1,$aa000000")
  CreateMaterial(2,TextureID(2))
  SetMaterialColor(2, #PB_Material_SpecularColor, $ffffff):MaterialShininess(2, 5)
  SetMaterialAttribute(2,#PB_Material_EnvironmentMap,#PB_Material_ReflectionMap)
  MaterialBlendingMode(2,#PB_Material_AlphaBlend)
  CreatePlane(2,25,100,64,256,1,1)
  CreateEntity(2,MeshID(2),MaterialID(2),0,-3,50)
  affiche3d()
EndProcedure
  
main()