Rem Volumetric Particle Weather - By TDK_Man
Rem DBC Challenges Feb 2008
 
Gosub Setup
T1=Timer(): T2=Timer()
Repeat
  If Timer()-T1 > 300 Then Gosub Move_Clouds: T1=Timer()
  If Timer()-T2 > 10 Then Gosub Handle_Weather: T2=Timer()
  If Spacekey()=1
    Gosub Change_Weather_Type
  Endif
  Sync
  Center Text 400,580,"Move Around With The Mouse And Press Space To Alter The Weather"
  Select WType
    Case 1: Text 0,580," Clear         ": EndCase
    Case 2: Text 0,580," Rain         ": EndCase
    Case 3: Text 0,580," Hail         ": EndCase
    Case 4: Text 0,580," Snow         ": EndCase
  EndSelect
  Text 740,580,"FPS: "+Str$(Screen FPS())
Until OKToExit=True
End
 
MouseLook:
  CX#=CAMERA ANGLE X(): CY#=CAMERA ANGLE Y(): CZ#=CAMERA ANGLE Z()
  CX#=Wrapvalue(CX#+mousemovey())
  CY#=Wrapvalue(CY#+mousemovex())
  Rotate Camera CX#,CY#,CZ#
  If MouseClick()=1 Then Move Camera 0.4
  If MouseClick()=2 Then Move Camera -0.4
  Gh#=Get Ground Height(1,Camera Position X(),Camera Position Z())
  Position Camera Camera Position X(),Gh#+1.5,Camera Position Z()
Return
 
Handle_Weather:
  Gosub MouseLook
  Select WType
    Case 2
      Rem Rain
      If Rnd(200)=0
        Color Ambient Light RGB(255,255,255)
        Sync
        Color Ambient Light RGB(AmbLight,AmbLight,AmbLight)
      Endif
      Gosub Move_Weather
    EndCase
    Case 3
      Rem Hail
      Gosub Move_Weather
    EndCase
    Case 4
      Rem Snow
      Gosub Move_Weather
    EndCase
  EndSelect
Return
 
Change_Weather_Type:
  Inc WType: If WType=5 Then WType=1
  Select WType
    Case 1
      Rem All Calm
        FirstObj=4000
        For N=FirstObj To FirstObj+1200
          If Object Exist(N) Then Delete Object N
        Next N
        EndAmbLight=255
        For N=AmbLight To EndAmbLight
          Color Ambient Light RGB(N,N,N)
          Fog Distance N*50
          Gosub MouseLook
          Wait .1
        Next N
        Fog Off
        AmbLight=EndAmbLight
        FirstObj=1000
    EndCase
    Case 2
      Rem Rain 10003
      FirstObj=1000
      For N=FirstObj To FirstObj+1200
        If Object Exist(N) Then Delete Object N
      Next N
      EndAmbLight=16
      Fog On: Fog Color RGB(5,25,5): Fog Distance AmbLight*50
      For N=AmbLight To EndAmbLight Step -1
        Color Ambient Light RGB(N,N,N)
        Fog Distance N*50
        Gosub MouseLook
        Wait .1
      Next N
      AmbLight=EndAmbLight
      Rem Rain Parameters
      NumParticles(WType,0)=1200
      Gravity#=-1.1
      PLife(WType,0) = 120
      PSizeX(WType,0) = 2.0: PSizeZ(WType,0) = 10.0
      XDir#(WType,0) = 3.0: YDir#(WType,0) = 20.0: ZDir#(WType,0) = 3.0
      FirstObj=2000
      Gosub Make_Weather_Particles
    EndCase
    Case 3
      Rem Hail 10004
      FirstObj=2000
      For N=FirstObj To FirstObj+1200
        If Object Exist(N) Then Delete Object N
      Next N
      EndAmbLight=48
      Fog On: Fog Color RGB(35,35,35): Fog Distance AmbLight*50
      For N=AmbLight To EndAmbLight Step -1
        Color Ambient Light RGB(N,N,N)
        Fog Distance N*50
        Gosub MouseLook
        Wait .1
      Next N
      AmbLight=EndAmbLight
      Rem Hail Parameters
      NumParticles(WType,0)=1000
      Gravity#=-0.4
      PLife(WType,0)=80
      PSizeX(WType,0) = 1.0: PSizeZ(WType,0) = 1.0
      XDir#(WType,0) = 1.1: YDir#(WType,0) = 4.0: ZDir#(WType,0) = 1.1
      FirstObj=3000
      Gosub Make_Weather_Particles
    EndCase
    Case 4
      Rem Snow 10005
      FirstObj=3000
      For N=FirstObj To FirstObj+1200
        If Object Exist(N) Then Delete Object N
      Next N
      EndAmbLight=16
      Fog On: Fog Color RGB(185,225,185): Fog Distance AmbLight*50
      For N=AmbLight To EndAmbLight Step -1
        Color Ambient Light RGB(N,N,N)
        Fog Distance N*50
        Gosub MouseLook
        Wait .1
      Next N
      AmbLight=EndAmbLight
      Rem Snow Parameters
      NumParticles(WType,0)=1000
      Gravity#=-0.002
      PLife(WType,0)=1000
      PSizeX(WType,0) = 4.0: PSizeZ(WType,0) = 4.0
      XDir#(WType,0) = 6.0: YDir#(WType,0) = 3.0: ZDir#(WType,0) = 6.0
      FirstObj=4000
      Gosub Make_Weather_Particles
    EndCase
  EndSelect
  Repeat
  Until Spacekey()=0
Return
 
Make_Clouds:
  Rem Create Cloud Particles
  For N = 1 To NumParticles(0,0)
    Make Object Plain N,PSizeX(0,0),PSizeZ(0,0)
    Set Object N, 1, 1, 1, 0, 1, 0, 1
    XRotate Object N,270
    Texture Object N,Glow_Particle
    XRange = (Container_Width/10)-(PSizeX(0,0)/10)
    ParticleX#(0,N) = (Rnd(XRange)-(XRange/2))*10.0 + Container_X
    YRange = Container_Height
    ParticleY#(0,N) = Container_Y + (Rnd(YRange)-(YRange/2))
    ZRange = (Container_Depth/10)-(PSizeZ(0,0)/10)
    ParticleZ#(0,N) = (Rnd(ZRange)-(ZRange/2))*10.0 + Container_Z
    XVel#(0,N) = Rnd(XDir#(0,0)) - (XDir#(0,0)/2.0)
    YVel#(0,N) = Rnd(YDir#(0,0)) - (YDir#(0,0)/2.0)
    ZVel#(0,N) = Rnd(ZDir#(0,0)) - (ZDir#(0,0)/2.0)
    Position Object N,ParticleX#(0,N),ParticleY#(0,N),ParticleZ#(0,N)
    Ghost Object On N
  Next N
Return
 
Move_Clouds:
  Rem Move Cloud Particles
  For N = 1 To NumParticles(0,0)
    ParticleX#(0,N) = ParticleX#(0,N) + XVel#(0,N)
    If ParticleX#(0,N)>Right#-(PSizeX(0,0)/2) Or ParticleX#(0,N)<Left#+(PSizeX(0,0)/2) Then XVel#(0,N) = 0.0-XVel#(0,N)
    ParticleY#(0,N) = ParticleY#(0,N) + YVel#(0,N)
    If ParticleY#(0,N)>Top# Or ParticleY#(0,N)<Bottom# Then YVel#(0,N) = 0.0-YVel#(0,N)
    ParticleZ#(0,N) = ParticleZ#(0,N) + ZVel#(0,N)
    If ParticleZ#(0,N)>Back#-(PSizeZ(0,0)/2) Or ParticleZ#(0,N)<Front#+(PSizeZ(0,0)/2) Then ZVel#(0,N) = 0.0-ZVel#(0,N)
    Position Object N,ParticleX#(0,N),ParticleY#(0,N),ParticleZ#(0,N)
  Next N
Return
 
Make_Weather_Particles:
  Rem Create Weather Particles
  For N = 1 To NumParticles(WType,0)
    Make Object Plain N+FirstObj,PSizeX(WType,0),PSizeZ(WType,0)
    Set Object N+FirstObj,1,0,1,1,0,1,0
    Select WType
      Case 2
        Rem Rain
        Texture Object N+FirstObj,10003
      EndCase
      Case 3
        Rem Hail
        Texture Object N+FirstObj,10004
      EndCase
      Case 4
        Rem Snow
        Texture Object N+FirstObj,10005
      EndCase
    EndSelect
    PLife(WType,N)=Rnd(PLife(WType,0))+PLife(WType,0)
    XVel#(WType,N) = Rnd(XDir#(WType,0))
    YVel#(WType,N) = 0.0-(Rnd(YDir#(WType,0))+(YDir#(WType,0)/2))
    ZVel#(WType,N) = Rnd(ZDir#(WType,0))
    ParticleX#(WType,N) = (Rnd(5000)-2500) + 2500
    ParticleY#(WType,N) = Bottom#-5000
    ParticleZ#(WType,N) = (Rnd(5000)-2500) + 2500
    Bouncing(WType,N)=0
    Position Object N+FirstObj,ParticleX#(WType,N),ParticleY#(WType,N),ParticleZ#(WType,N)
    Ghost Object On N+FirstObj
  Next N
  ParticlesDead = False
Return
 
Move_Weather:
  Rem Move Weather Particles
  For N = 1 To NumParticles(WType,0)
    ParticleX#(WType,N) = ParticleX#(WType,N) + XVel#(WType,N)
    ParticleY#(WType,N) = ParticleY#(WType,N) + YVel#(WType,N)
    ParticleZ#(WType,N) = ParticleZ#(WType,N) + ZVel#(WType,N)
    Rem Add Gravity
    ParticleY#(WType,N) = ParticleY#(WType,N) + Gravity#
    PLife(WType,N) = PLife(WType,N)-1
    Position Object N+FirstObj,ParticleX#(WType,N),ParticleY#(WType,N),ParticleZ#(WType,N)
    If WType <> 4 Then Set Object To Camera Orientation N+FirstObj
    Floor# = Get Ground Height(1,ParticleX#(WType,N),ParticleZ#(WType,N))
    If WType = 2: Rem Rain
      If ParticleY#(WType,N) < Floor#
        XVel#(WType,N) = Rnd(XDir#(WType,0))
        YVel#(WType,N) = 0.0-(Rnd(YDir#(WType,0))+(YDir#(WType,0)))
        ZVel#(WType,N) = Rnd(ZDir#(WType,0))
        ParticleX#(WType,N) = (Rnd(800)-400) + Camera Position X()
        ParticleY#(WType,N) = Bottom#-5000
        ParticleZ#(WType,N) = (Rnd(800)-400) + Camera Position Z()
        PLife(WType,N) = PLife(WType,0)
      Endif
    Endif
    If WType = 3: Rem Hail
      If ParticleY#(WType,N) < Floor#+0.2
        Rem Hit Floor - No Time To Finish Bouncing...
        rem If Bouncing(WType,N)=0 Then YVel#(WType,N) = -0.1: Bouncing(WType,N)=1
        If PLife(WType,N) > 0: Rem Still Life Left
          ParticleY#(WType,N)=Floor#+0.2
          Position Object N+FirstObj,ParticleX#(WType,N),ParticleY#(WType,N),ParticleZ#(WType,N)
          RemStart
          If Bouncing(WType,N)=1
            Position Object N+FirstObj,ParticleX#(WType,N),Floor#+1.0,ParticleZ#(WType,N)
            ParticleX#(WType,N) = 0.0
            ParticleY#(WType,N) = ParticleY#(WType,N) + YVel#(WType,N)
            ParticleZ#(WType,N) = 0.0
            Bouncing(WType,N)=0
          Endif
          Remend
        Else
          Rem No Life Left
          XVel#(WType,N) = Rnd(XDir#(WType,0))/32.0
          YVel#(WType,N) = 0.0-(Rnd(YDir#(WType,0))+(YDir#(WType,0)/2))
          ZVel#(WType,N) = Rnd(ZDir#(WType,0))/32.0
          ParticleX#(WType,N) = Camera Position X() + (Rnd(200)-100)
          ParticleY#(WType,N) = Bottom#-5000
          ParticleZ#(WType,N) = Camera Position Z() + (Rnd(200)-100)
          PLife(WType,N) = PLife(WType,0)
          rem Bouncing(WType,N)=0
        Endif
      Else
        Rem Moving
        ParticleY#(WType,N) = ParticleY#(WType,N) + YVel#(WType,N)
        Position Object N+FirstObj,ParticleX#(WType,N),ParticleY#(WType,N),ParticleZ#(WType,N)
      Endif
    Endif
    If WType = 4: Rem Snow
      If ParticleY#(WType,N) < Floor#
        XVel#(WType,N) = Rnd(XDir#(WType,0))
        YVel#(WType,N) = 0.0-(Rnd(YDir#(WType,0))+(YDir#(WType,0)/6))
        ZVel#(WType,N) = Rnd(ZDir#(WType,0))
        ParticleX#(WType,N) = (Rnd(500)-250.0) + Camera Position X()
        ParticleY#(WType,N) = Bottom#-5000
        ParticleZ#(WType,N) = (Rnd(500)-250.0) + Camera Position Z()
        PLife(WType,N) = PLife(WType,0)
      Endif
    Endif
  Next N
Return
 
Make_Textures:
  Create Bitmap 1,256,256
  Rem Cloud Particle
  C#=200: D#=0.0
  For N=1 To 54
    Ink RGB(C#,C#,C#),0
    Circle 63,63,N
    Circle 63,64,N
    Dec C#,D#: Inc D#,0.12
  Next N
  Get Image 10003,0,0,129,129
  CLS
  For N=1 To 12
    Paste Image 10003,Rnd(128),Rnd(128),1
  Next N
  For N=1 To 8
    Blur Bitmap 1,3
  Next N
  Get Image 10002,0,0,256,256
  Delete Image 10003
  Rem Rain Particle 10003
  CLS 0
  Ink RGB(255,255,255),0
  For N=1 To 6
    Circle 31,47,N
    Circle 31,48,N
  Next N
  For N=26 To 37
    Line 31,6,N,47
    Line 31,6,N,46
  Next N
  Blur Bitmap 1,4
  Get Image 10003,0,0,65,65
  Rem Hail Particle 10004
  CLS 0
  Ink RGB(255,255,255),0
  For N=1 To 6
    Circle 31,31,N
    Circle 31,32,N
  Next N
  Blur Bitmap 1,1
  Get Image 10004,0,0,65,65
  Rem Snow Particle 10005 (T)
  Set Text Font "Wingdings",1
  Set Text Size 64
  Text 6,0,"T"
  Blur Bitmap 1,4
  Get Image 10005,0,0,65,65
  Set Text Font "Tahoma",1
  Set Text Size 16
  Set Current Bitmap 0
  Delete Bitmap 1
Return
 
Setup:
  Set Display Mode 800,600,32
  Hide Mouse
  Sync On: Sync Rate 0: CLS 0
  AutoCam Off
  Randomize Timer()
  Backdrop On
  Color Backdrop 0
  True=1: False=0
 
  Dim NumParticles(10,0)
  Dim PLife(10,1200)
  Dim PSizeX(10,0)
  Dim PSizeZ(10,0)
  Dim Bouncing(10,1200)
  Dim ParticleX#(10,1200)
  Dim ParticleY#(10,1200)
  Dim ParticleZ#(10,1200)
  Dim XDir#(10,0)
  Dim YDir#(10,0)
  Dim ZDir#(10,0)
  Dim XVel#(10,1200)
  Dim YVel#(10,1200)
  Dim ZVel#(10,1200)
 
  Glow_Particle = 10002
  Container_Width=30000
  Container_Height=1000
  Container_Depth=30000
  WType=1: FirstObj=1000
 
  AmbLight=255: Color Ambient Light RGB(AmbLight,AmbLight,AmbLight)
  Fog On: Fog Distance AmbLight*50
 
  NumParticles(0,0) = ((Container_Width+Container_Depth)/Container_Height)*2.5
  XDir#(0,0) = 8.0
  YDir#(0,0) = 2.0
  ZDir#(0,0) = 8.0
  PSizeX(0,0) = Container_Width/2.5
  PSizeZ(0,0) = Container_Depth/3.5
 
  Gosub Make_Textures
  RandomWorld(1,5000,5000,50,50,128,1)
  Container_X=2500
  Container_Y=Get Ground Height(1,2500.0,2500.0)+6000
  Container_Z=2500
 
  Left# = 0.0-(Container_Width/2.0)+Container_X: Right# = Container_Width/2.0+Container_X
  Bottom# = Container_Y - (Container_Height/2.0)
  Top# = Container_Y + (Container_Height/2.0)
  Front# = 0.0-(Container_Depth/2.0)+Container_Z: Back# = Container_Depth/2.0+Container_Z
  Gosub Make_Clouds
 
  Position Camera 2440.0,Get Ground Height(1,2440.0,2440.0)+2.0,2440.0
  Ink RGB(255,255,255),0
Return
 
Function RandomWorld(MatNum,MatWid,MatHig,TilesX,TilesZ,TextureSize,Hilly)
  Set Camera Range 1.0,500000
  Create Bitmap 1,640,480
  CLS RGB(0,50,0)
  For N=1 To 3000
    Shade = Rnd(100)+50
    Ink RGB(0,Shade,0),0
    Dot RND(TextureSize),RND(TextureSize)
  Next N
  Blur Bitmap 1,3
  Get Image 10000,0,0,TextureSize,TextureSize
  CLS 0
  For N=0 To 128
    Ink RGB(N,N,255-N),0
    Line 0,N,256,N
  Next N
  Get Image 10001,0,0,256,256: Rem Sides
  Set Current Bitmap 0
  Delete Bitmap 1
  Make Matrix MatNum,MatWid,MatHig,TilesX,TilesZ
  Prepare Matrix Texture MatNum,10000,1,1
  If Hilly=1
    For N=1 To 140
      X=Rnd(46)+2: Z=Rnd(46)+2
      Set Matrix Height MatNum,X,Z,3000.0
    Next N
    For N=0 To TilesX
      Set Matrix Height MatNum,0,N,Rnd(100)+400
      Set Matrix Height MatNum,50,N,Rnd(100)+400
      Set Matrix Height MatNum,N,0,Rnd(100)+400
      Set Matrix Height MatNum,N,50,Rnd(100)+400
    Next N
    For N=1 To 20
      For Z=0 to TilesZ
        For X=0 to TilesX
          P0#=Get Matrix Height(MatNum,X,Z)
          If Z-1>=0
            P1#=Get Matrix Height(MatNum,X,Z-1)
          Else
            P1#=P0#
          Endif
          If X+1<=TilesX
            P2#=Get Matrix Height(MatNum,X+1,Z)
          Else
            P2#=P0#
          Endif
          If Z+1<=TilesZ
            P3#=Get Matrix Height(MatNum,X,Z+1)
          Else
            P3#=P0#
          Endif
          If X-1>=0
            P4#=Get Matrix Height(MatNum,X-1,Z)
          Else
            P4#=P0#
          Endif
          Average#=(P0#+P1#+P2#+P3#+P4#)/5.0
          RHeight#=Average#
          Set Matrix Height MatNum,X,Z,RHeight#
        Next X
      Next Z
    Next N
  Endif
  For Z=1 to TilesZ
    For X=1 to TilesX
      h8#=get matrix height(MatNum,x,z-1)*3
      h4#=get matrix height(MatNum,x-1,z)*3
      h#=get matrix height(MatNum,x,z)*3
      h2#=get matrix height(MatNum,x,z)*3
      x1#=(x-1)*25.0
      y1#=h#
      x2#=(x+0)*25.0
      y2#=h4#
      dx#=x2#-x1#
      dy#=y2#-y1#
      ax#=atanfull(dx#,dy#)
      ax#=wrapvalue(90-ax#)
      z1#=(z-1)*25.0
      y1#=h2#
      z2#=(z+0)*25.0
      y2#=h8#
      dz#=z2#-z1#
      dy#=y2#-y1#
      az#=atanfull(dz#,dy#)
      az#=wrapvalue(90-az#)
      nx#=sin(ax#)
      ny#=cos(ax#)
      nz#=sin(az#)
      Set Matrix Normal MatNum,x,z,nx#,ny#,nz#
    next X
  next Z
  Update Matrix MatNum
  Rem SkySphere
  Make Object Sphere 10500,0.0-(MatWid*9.0)
  ZRotate Object 10500,180
  Fix Object Pivot 10500
  Set Object 10500,1,1,1,0,1,0,1
  Texture Object 10500,10001
  Position Object 10500,MatWid/2,-1000,MatHig/2
EndFunction