PureBasic Forums - English

Code: Select all

;  ---------------------------------------------------------------------------------------------------------
;  demo 3D : Banc de poisson  V2 - Pf Shadoko - 2023
; -----------------------------------------------------------------------------------------------------------
EnableExplicit

;!//gccflags -O3 -march=native;

Macro f3:vector3:EndMacro

Macro def3d(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

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 / Sqr(*V\x * *V\x + *V\y * *V\y + *V\z * *V\z)
  *V\x * lm
  *V\y * lm
  *V\z * lm  
EndProcedure

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

Structure sespece
  num.b
  cible.f3
  v.f  ;vitesse
  prox.f
  prox2.f
EndStructure

Structure spoisson
  p.f3  ;position centre
  pt.f3 ;position tete
  v.f3  ;vitesse
  entity.i
  *e.sespece
EndStructure

Global nbe=-1,nbf=-1
Global Dim espece.sespece(20)
Global Dim p.spoisson(0)

Procedure poisson(ccoprs1,ccoprs2,ctete,cnageoire,robe,   Lo.f,ha.f,la.f,queue.f,  vit.f, nage.f, nb)
  Protected.f a,ai,jj,j1,rx,ry,rz,r
  Protected i,j,c,anbf,mat
  nbe+1  
  ; ---------------------- texture + material
  CreateTexture(nbe,512,256)
  StartDrawing(TextureOutput(nbe))
  DrawingMode(#PB_2DDrawing_AlphaBlend|#PB_2DDrawing_Gradient)
  GradientColor(0.0,$ff000000)
  GradientColor(0.5,ccoprs1)
  GradientColor(1.0,$ffffffff)
  LinearGradient(0,-100,0,300)
  Box(0,0,512,256,ccoprs1)
  ResetGradientColors()
  GradientColor(0,ctete)
  GradientColor(0.9,ctete)
  GradientColor(0.91,$22000000)
  GradientColor(1,ccoprs1)
  ClipOutput(0,70,512,200)
  CircularGradient(511,100,150)
  Circle(511,100, 150)
  UnclipOutput()
  DrawingMode(#PB_2DDrawing_AllChannels)
  Select robe
      Case 0:For i=30 To 400:Box(i,0,1,(Sin(i/7.5)+1.8)*40,ccoprs2):Next
      Case 1:For i=64 To 160 Step 24:Ellipse(200,i,150,4,ccoprs2):Next
      Case 2:For i=0 To 3:Circle(100+i*70,100,10,$ffffffff):Circle(100+i*70,100,8,ccoprs2):Next
  EndSelect
  Circle(420,85,16,$ff00ffff)
  Circle(420,85,8,0)
  Ellipse(512,128,60,10,$666666)
  If cnageoire
    Box(0,0,30,256,cnageoire)
    Ellipse(322,188,37,30,cnageoire)
    Ellipse(174,190,40,16,cnageoire)
    Ellipse(110,255,30,10,cnageoire)
    Box(130,0,92,28,cnageoire)
  EndIf
  StopDrawing()
  For i=0 To 7:mat=nbe*8+i
    CreateShaderMaterial(mat,0)
    MaterialShaderTexture(mat,TextureID(nbe),0,0,0)
    MaterialShaderParameter(mat,0,"phase",1,i/8,0,0,0)
    MaterialShininess(mat,64,$ffffff)
    MaterialFilteringMode(mat,#PB_Material_Anisotropic)
    SetMaterialAttribute(mat,#PB_Material_TAM,#PB_Material_ClampTAM)
  Next
  ; ---------------------- mesh
  Dim v.MeshVertex(16,16)
  For j=0 To 16
    jj=(j-8)/8:j1=j/16
    For i=0 To 16
      r=(1-jj*jj)
      ry=r*ha
      rx=r*la
      rz=j1
      a=i/16*2*#PI
      With v(j,i)
        If i>4 And i<12:ry*1.5:EndIf
        If j=10 And (i=2 Or i=14):rx*3:ry*1.5:rz-0.15:EndIf
        If j=0 :ry=ha:rz=-(1-Abs(Sin(a))*queue)*0.2:EndIf
        If i=8 And (j=5 Or j=6):ry*1.4:rz-0.15:EndIf
        \x=Sin(a)*rx
        \y=-Cos(a)*ry
        \z=(rz-0.5)*2*lo
        \Color=RGB(2*nage*vit/lo*255,(rz+0.2)/2*255,(1/nage+Pow(1-(rz+0.2)/1.2,nage))*lo)
        \u=j/16
        \v=Abs(8-i)/8
      EndWith
    Next
  Next
  CreateDataMesh(nbe,v(),1+8)
  ; ---------------------- info espece
  With espece(nbe)
    \num=nbe
    \v=vit
    \prox=lo*2
    \prox2=\prox*\prox
    def3D(\cible,pom(1000),pom(200)-300,pom(1000))
  EndWith
  ; ---------------------- creation poissons
  anbf=nbf
  nbf+nb
  ReDim p(nbf)
  For i=anbf+1 To nbf
    With p(i)
      def3D(\p,pom(1000),pom(200)-300,pom(1000))
      \pt=\p
      \e=espece(nbe)
      \entity=CreateEntity(-1,MeshID(\e\num),MaterialID(nbe*8+i&7))
      EntityFixedYawAxis(\entity,1)
    EndWith  
  Next 
EndProcedure

;-Desktop 

Structure akey
  ks.a[256]
EndStructure 

Prototype pProcessKeys(key.s) : Global *pProcessKeys.pProcessKeys 

Global keyhook, keys.akey 

#WH_MOUSE_LL = 14 
#WM_MOUSEHWHEEL = 526

Structure MSLLHOOKSTRUCT
  pt.POINT;
  mouseData.l;
  flags.l    ;
  time.l     ;
  dwExtraInfo.l;
EndStructure

Structure MouseData 
  x.i
  y.i
  deltaX.i
  deltay.i
  lbutton.i 
  mbutton.i
  rbutton.i
  MouseWheel.i 
EndStructure   

Global mousehook 
Global MouseData.MouseData

Procedure MouseProc(ncode.l,wParam.l,lParam.l)
  
  Static lpx,lpy
  Protected px,py,hwnd 
  Static mMouseInput.MSLLHOOKSTRUCT
  
  hwnd = GetForegroundWindow_()
  
  If hwnd =  GetActiveWindow_()  
    
    If ncode = #HC_ACTION
      
      If wParam 
        
        CopyMemory(lparam,@mMouseInput,SizeOf(MSLLHOOKSTRUCT))  
                
        MouseData\x = mMouseInput\pt\x
        MouseData\y = mMouseInput\pt\y 
        MouseData\MouseWheel  = 0 
        
        Select wParam
          Case #WM_LBUTTONDOWN
            MouseData\lbutton = 1 
          Case #WM_LBUTTONUP
            MouseData\lbutton = 0 
          Case #WM_MBUTTONDOWN 
            MouseData\mbutton = 1
          Case #WM_MBUTTONUP  
            MouseData\mbutton = 0
          Case #WM_RBUTTONDOWN
            mousedata\rbutton = 1
          Case #WM_RBUTTONUP
            MouseData\rbutton = 0 
          Case #WM_MOUSEMOVE 
            
            If lpx = 0 
              lpx = mMouseInput\pt\x 
            EndIf 
            mousedata\deltaX = mMouseInput\pt\x - lpx  
            
            If lpy = 0 
              lpy = mMouseInput\pt\y 
            EndIf 
            mousedata\deltaY =  mMouseInput\pt\y - lpy  
            
          Case #WM_MOUSEWHEEL
            If mMouseInput\mouseData > 0 
              MouseData\MouseWheel = 1
            Else 
              MouseData\MouseWheel = -1
            EndIf   
            
        EndSelect
        
        lpx = mMouseInput\pt\x 
        lpy = mMouseInput\pt\y 
      EndIf 
    EndIf 
    
  EndIf 
  
  ProcedureReturn CallNextHookEx_(Mousehook, nCode, wParam, lParam)
  
EndProcedure 

Procedure.i KeyProc(nCode.l,wParam.l,lParam.l)
  
  Protected *keyInput.KBDLLHOOKSTRUCT 
  
  Static pos,len  
  
  Protected ret.i, hwnd.i,thwnd.i 
  Protected rs.s=Space(2) 
  Protected doc 
  
  ret = CallNextHookEx_(Keyhook, nCode, wParam, lParam) 
  
  *keyInput = lParam 
  
  If nCode = #HC_ACTION 
    
    hwnd = GetForegroundWindow_()
    
    If hwnd =  GetActiveWindow_() 
      
      Select wParam  
          
        Case #WM_KEYUP 
          keys\ks[*keyInput\vkCode] = 0 
        Case #WM_KEYDOWN
          
          keys\ks[*keyInput\vkCode]= $fe
          
          If (GetAsyncKeyState_(#VK_SHIFT) & $8000)  
            keys\ks[#VK_SHIFT]=$fe
          Else 
            keys\ks[#VK_SHIFT]=0
          EndIf 
          
          If (GetAsyncKeyState_(#VK_CONTROL) & $8000)  
            keys\ks[#VK_CONTROL]=$fe
          Else 
            keys\ks[#VK_CONTROL]=0
          EndIf 
          
          If (GetAsyncKeyState_(#VK_LMENU) & $8000)  
            keys\ks[#VK_LMENU]=$fe
          Else
            keys\ks[#VK_LMENU]=0 
          EndIf 
          
          If (GetAsyncKeyState_(#VK_RMENU) & $8000)  
            keys\ks[#VK_RMENU]=$fe
          Else 
            keys\ks[#VK_RMENU]=0
          EndIf 
          
          If (keys\ks[#VK_ESCAPE] = 0 And keys\ks[#VK_LBUTTON] = 0)
            If ToUnicode_(*keyInput\vkCode,*keyInput\scanCode,@keys,@rs,1,2) 
              If *pProcessKeys
                *pProcessKeys(rs)              
              EndIf 
            EndIf   
          EndIf 
          
      EndSelect
    EndIf 
  EndIf    
  
  ProcedureReturn ret
  
EndProcedure 

Procedure KeyboardPushed_(VK_key)
  ProcedureReturn keys\ks[VK_key] 
EndProcedure   
Procedure KeyboardReleased_(VK_Key) 
  ProcedureReturn 1 - keys\ks[VK_key] 
EndProcedure   

Procedure MouseDeltaX_() 
  ProcedureReturn MouseData\deltax 
EndProcedure 

Procedure  MouseDeltaY_()
  ProcedureReturn MouseData\deltay  
EndProcedure   

Procedure MouseWheel_() 
  Protected ret 
  ret = MouseData\MouseWheel
  MouseData\MouseWheel = 0 
  ProcedureReturn ret
EndProcedure   

Procedure  MouseButton_(number) 
  Select number 
    Case 1
      ProcedureReturn MouseData\lbutton 
    Case 2 
      ProcedureReturn mousedata\mbutton
    Case 3 
      ProcedureReturn MouseData\rbutton 
  EndSelect    
       
EndProcedure   

Procedure SetHooks(hInstance)
  
  Keyhook = SetWindowsHookEx_(#WH_KEYBOARD_LL, @KeyProc(),hInstance,0) 
  Mousehook = SetWindowsHookEx_(#WH_MOUSE_LL, @MouseProc(),hInstance,0)
  
  If (Keyhook = 0 Or mouseHook = 0)  
    MessageRequester("hook", "can't get module handle")
  EndIf       
  
EndProcedure 

Procedure KillHooks()
  UnhookWindowsHookEx_(Keyhook)
  UnhookWindowsHookEx_(mousehook)
  KeyHook = 0  
EndProcedure 

Procedure EnumWindowsProc(hWnd,*Param.INTEGER)  
  Protected h, hworker                                                         
  h = FindWindowEx_(hWnd, 0, @"SHELLDLL_DefView", 0)   
  If h                                                                        
    hworker = FindWindowEx_(0, hWnd, @"WorkerW", 0)   
    If hworker                                                                 
      *Param\i = hworker 
    EndIf 
  EndIf                                                                        
  ProcedureReturn 1      
EndProcedure

Procedure.i GetDesktopWindow() 
  Protected hwndProgMan,hwndWallpaper                                         
  
  hwndProgMan = FindWindowEx_(0, 0, @"Progman", 0)                             
  
  If SendMessageTimeout_(hwndProgMan, #WM_NULL, #Null, #Null, #SMTO_ABORTIFHUNG, 1000, #Null)
    If SendMessageTimeout_(hwndProgMan, $052C, #Null, #Null, #SMTO_NORMAL, 1000, #Null) <> 0 
      hwndWallpaper = 0 
      EnumWindows_(@EnumWindowsProc(),@hwndWallpaper) 
    EndIf 
  EndIf                                                                       
  
  ProcedureReturn hwndWallpaper 
EndProcedure 

Prototype.i p_PrintWindow(hWnd, hdc, flags)
OpenLibrary(1, "User32.dll")
Global PrintWindow.p_PrintWindow = GetFunction(1, "PrintWindow")

Procedure GetWallpaper(mon=0) 
  Protected width,height,himage,hdc
  ExamineDesktops()
  width = DesktopWidth(mon) 
  height = DesktopHeight(mon) 
  hImage = CreateImage(0,Width,Height) 
  hDC  = StartDrawing(ImageOutput(0)) 
  printwindow(GetDesktopWindow(),hdc,0) 
  StopDrawing() 
  ProcedureReturn hImage 
EndProcedure

;-End desktop 

Procedure Processkeys(key.s) 
    Debug key 
EndProcedure   

*pProcessKeys = @Processkeys() 

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

Global spwallpaper,  wallpaper = GetWallpaper()
Global  width,height,hwnd,hdc  
ExamineDesktops() 
width = DesktopWidth(0)
height = DesktopHeight(0) 
hwnd = GetDesktopWindow() 
If hwnd 
  hdc = GetDC_(hwnd)
  If hdc
    OpenWindow(0,0,0,0,0,"poisson",#PB_Window_Invisible)
    
    SetHooks(GetModuleHandle_(0))
    
    If OpenWindowedScreen(hwnd, 0, 0, Width, Height, 0, 0, 0)
      
      spwallpaper = CreateSprite(#PB_Any,width,height)
      StartDrawing(SpriteOutput(spwallpaper)) 
      DrawImage(wallpaper,0,0) 
      StopDrawing() 
            
      CreateCamera(0, 0, 0, 100, 100):MoveCamera(0,0,-400,-1000):CameraLookAt(0,0,-300,0)
      CreateLight(0,$111111*8, -10000, 10000, -10000)
      AmbientColor($111111*6)
      Fog($886600,1,0,3000):CameraBackColor(0,$886600)
      
      Define.s vert_pg,frag_pg
      vert_pg="%#version 130%%uniform mat4 P24;//+24%uniform mat4 P0;//+0%uniform vec4 P77;//+77%uniform vec4 P76;//+76%uniform vec4 P44;//+44 0%uniform vec4 P31;//+31%uniform float P86;//+86 4%uniform float phase;//1%%varying vec3 oviewdir;%varying vec3 olightdir;%varying vec3 onormal;%varying vec2 ouv;%varying float ofogf;%varying float olum;%%void main()%{%vec4 v=gl_Vertex;%v.x+=sin((gl_Color.r*P86+gl_Color.g+phase)*6)*gl_Color.b*80;%oviewdir=normalize(P77.xyz-v.xyz);%olightdir=normalize(P44.xyz-v.xyz);%gl_Position=P24*v;%onormal=gl_Normal;%ouv=(gl_TextureMatrix[0]*gl_MultiTexCoord0).xy;%ofogf=P31.z>0?min(abs(gl_Position.z)*P31.w,1):0;%vec3 posv=(P0*v).xyz;%float d=min(abs(gl_Position.z),P31.z);%vec3 posl=P76.xyz+normalize(posv.xyz-P76.xyz)*d;%olum=1-clamp(-posl.y/3000,0,1);%}"
      frag_pg="%#version 130%%uniform vec4 P69;//+69 0%uniform vec4 P70;//+70 0%uniform vec4 P67;//+67 0%uniform float P36;//+36%uniform vec4 P30;//+30%%uniform sampler2D diffuseMap;//0%%varying vec3 oviewdir;%varying vec3 olightdir;%varying vec3 onormal;%varying vec2 ouv;%varying float ofogf;%varying float olum;%%void main()%{%vec3 normal=normalize(onormal);%vec3 viewdir=normalize(oviewdir);%vec3 lightdir=normalize(olightdir);%%vec4 tcolor=vec4(texture(diffuseMap,ouv));%%float dif=max(dot(lightdir,normal),0);%float spe=pow(max(dot(normalize(lightdir+viewdir),normal),0),P36);%vec4 color=vec4(tcolor.rgb,1)*(P67+P69*dif)+P70*tcolor.a*spe;%gl_FragColor=mix(color,P30,ofogf)*olum;%}"
      CreateShader(0,vert_pg,frag_pg)
      
      CreateShaderMaterial(100,0)
      MaterialCullingMode(100,#PB_Material_NoCulling)
      MaterialShininess(100,64,$ffffff)
      CreateSphere(100,30000,64,64)
      CreateEntity(0,MeshID(100),MaterialID(100))
      
      poisson($ff8888ff,$88444488,$ffaaaaaa,$000000,0,  130,40,35,0.6,7,4,1)
      poisson($ff888888,$88884444,$ffaaaaaa,$000000,0,  70,20,15,0.6,4,3,10)
      poisson($ffaaaaaa,$88666666,$ffaaaaaa,$44aaff,0,  40,8,6,0.5,3,2,100)
      poisson($ffaaaaaa,$ff444444,$ffccccdd,$66cccc,1,  30,12,7,0.5,2.5,2,150)
      poisson($880088ff,$88000000,$8800aaff,$4488cc,2,  30,12,7,0.5,2.5,2,150)
      poisson($8877bbdd,$880000ff,$8888bbcc,$7799ff,2,  20,12,5,0.2,2,2,200)
      poisson($880000ff,$ff0088ff,$880066cc,$0099ff,1,  20,7,4,0.2,1.5,3,200)
      
      Define.f f,   al,lg,lg2,    align.f=0.2
      Define ff.f3,f0.f3,cc.f3,d.f3,pt.f3,  *p.spoisson,*pi.spoisson,   t0,i,j,np,tok,Iespece,camp
      Define.f MouseX,Mousey,depx,depz,dist
      
      camp=0
      
      Repeat
        While WindowEvent():Wend
        ExamineKeyboard():ExamineMouse()
        depx=(-Bool(KeyboardPushed_(#VK_LEFT))+Bool(KeyboardPushed_(#VK_RIGHT)))*10
        depz=(-Bool(KeyboardPushed_(#VK_DOWN))+Bool(KeyboardPushed_(#VK_UP   )))*10+MouseWheel_()*100
        If KeyboardPushed_(#VK_SPACE)
          MouseX = -MouseDeltaX_() *  0.05
          MouseY = -MouseDeltaY_() *  0.05
          RotateCamera(0, MouseY, MouseX, 0, #PB_Relative)
        EndIf 
        dist+(depz-dist)*0.05:MoveCamera  (0, depX, 0, -dist)
        If KeyboardPushed_(#VK_F):camp ! 1:If camp:AttachEntityObject(p(1)\entity,"",CameraID(0)):RotateCamera(0,0,180,0):MoveCamera  (0, 0, 40, -170, 0):Else:DetachEntityObject(p(1)\entity,CameraID(0)):EndIf:EndIf
        If ElapsedMilliseconds()-t0>10000/(nbe+1):t0=ElapsedMilliseconds():Iespece=(Iespece+1)% (nbe+1):def3D(espece(Iespece)\cible,pom(1000),pom(200)-300,pom(1000)):EndIf
        
        For j=0 To nbf
          *p=p(j):np=0:ff=f0
          For i=0 To nbf:If i=j:Continue:EndIf
            *pi=p(i):With *pi
              sub3d(d,\pt,*p\pt)
              lg2=d\x*d\x+d\y*d\y+d\z*d\z:If lg2>\e\prox2:Continue:EndIf:lg=Sqr(lg2)
              tok=Bool(*p\e\num=\e\num)
              f=(tok - \e\prox/lg)*0.1:If IsNAN(f):Continue:EndIf
              al=align*tok
              ff\x+d\x*f+\v\x*al
              ff\y+d\y*f+\v\y*al
              ff\z+d\z*f+\v\z*al
              np+1
            EndWith
          Next
          sub3d(cc,*p\p,*p\e\cible):norme3d(cc,-0.1):add3d(*p\v,*p\v,cc)
          If np:norme3d(ff,0.2):add3d(*p\v,*p\v,ff):EndIf
          norme3d(*p\v,*p\e\v):*p\v\y*0.95
          pt=*p\v:norme3d(pt,*p\e\prox):add3d(*p\pt,*p\p,pt)
        Next
        For i=0 To nbf
          With p(i)
            add3d(\p,\p,\v)
            MoveEntity(\entity,\p\x,\p\y,\p\z,0)
            EntityDirection(\entity,\v\x,\v\y,\v\z,0,#PB_Vector_Z)	
          EndWith
        Next
        RenderWorld()
        FlipBuffers()    
      Until KeyboardPushed_(#VK_ESCAPE) Or MouseButton_(3)
      
      DisplayTransparentSprite(spwallpaper,0,0,255) 
      FlipBuffers() 
      
      CloseScreen()
      ReleaseDC_(hwnd,hdc) 
      
      KillHooks()
      
      CloseWindow(0) 
      
    EndIf 
  EndIf 
EndIf