;ParticleSystem Test V3
Graphics3D 1024, 768, 32, 2

;Include "ParticleSystem V3.bb"

cam = CreateCamera():CameraRange Cam, 1, 10000

Size = 256

Ter = GenerateTerrain(Size, Size/8, Size/8, Size/4, .05, .25, 0, 512)
TerrainDetail Ter, 10240, 1
ScaleEntity Ter, 5, 500, 5
MoveEntity Ter, -(Size*5)/2, -250, -(Size*5)/2

Tex  = GenerateTerrainTexture(2, 512*512)
Tex2 = CreateTexture(Size, Size)
ScaleTexture Tex2, Size, -Size

AddColor(0, 0, 22, 0, 0, 102, 0, 25)
AddColor(0, 0, 102, 102, 75, 51, 25, 51)
AddColor(102, 75, 51, 204, 204, 0, 51, 75)
AddColor(204, 204, 0, 0, 153, 0, 75, 102)
AddColor(0, 153, 0, 153, 153, 0, 102, 153)
AddColor(153, 153, 0, 102, 51, 0, 153, 204)
AddColor(102, 51, 0, 153, 76, 0, 204, 225)
AddColor(153, 76, 0, 255, 255, 255, 225, 255)
IMG2 = ColorTerrain(Ter)
TransferIMGtoTex(IMG2, Tex2)

EntityTexture Ter, Tex, 0, 0:TextureBlend Tex, 2
EntityTexture Ter, Tex2, 0, 1:TextureBlend Tex2, 3

PositionEntity Cam, -250, 250, 0
PointEntity Cam, Ter

While Not KeyHit(1)
   Cls
   MoveEntity Cam, (KeyDown(32)-KeyDown(30)), (KeyDown(16)-KeyDown(18)), (KeyDown(17)-KeyDown(31))
   RotateEntity Cam, EntityPitch(Cam)+MouseYSpeed(), EntityYaw(Cam)-MouseXSpeed(), 0
   RenderWorld
   DrawImage IMG2, 0, 0
   MoveMouse 512, 384
   Flip
Wend


;---

Type TerrainColorSet
   Field LRed, LGre, LBlu
   Field HRed, HGre, HBlu
   Field Min, Max
End Type

Function AddColor(LR,LG,LB,HR,HG,HB,Mi,Ma)
   TCS.TerrainColorSet = New TerrainColorSet
   TCS\LRed = LR
   TCS\LGre = LG
   TCS\LBlu = LB
   TCS\HRed = HR
   TCS\HGre = HG
   TCS\HBlu = HB
   TCS\Min = Mi
   TCS\Max = Ma
   Return Handle(TCS.TerrainColorSet)
End Function

Function RemoveColor(H)
   TCS.TerrainColorSet = Object.TerrainColorSet(H)
   Delete TCS.TerrainColorSet
   Return 1
End Function

Function ColorTerrain(Ter)
   Size = TerrainSize(Ter)
   IMG = CreateImage(Size, Size)
   IMGB = ImageBuffer(IMG)
   LockBuffer IMGB
   For X = 0 To Size-1
      For Y = 0 To Size-1
         White = TerrainHeight(Ter, X, Y) * 255
         For TCS.TerrainColorSet = Each TerrainColorSet
            If White >= TCS\Min And White <= TCS\Max
               P# = Float(White-TCS\Min)/(TCS\Max-TCS\Min)
               R = TCS\LRed+((TCS\HRed-TCS\LRed)*P#)
               G = TCS\LGre+((TCS\HGre-TCS\LGre)*P#)
               B = TCS\LBlu+((TCS\HBlu-TCS\LBlu)*P#)
               RGB = (R Shl 16) Or (G Shl 8) Or B
               WritePixelFast X, Y, RGB, IMGB
            EndIf
         Next
      Next
   Next
   UnlockBuffer IMGB
   Return IMG
End Function

;---

Function TransferIMGToTex(IMG, Tex)
   W1 = ImageWidth(IMG):H1 = ImageHeight(IMG)
   IMGB = ImageBuffer(IMG)
   TexB = TextureBuffer(Tex)
   LockBuffer IMGB:LockBuffer TexB
   For X1 = 0 To W1-1
      For Y1 = 0 To H1-1
         RGB = ReadPixelFast(X1, Y1, IMGB)
         WritePixelFast X1, Y1, RGB, TexB
      Next
   Next
   UnlockBuffer IMGB:UnlockBuffer TexB
End Function

Function GenerateTerrainTexture(DiffuseAmount=2, Amount = 512)
   Tex = CreateTexture(512,512)
   TexB = TextureBuffer(Tex)
   LockBuffer TexB
   For A = 1 To Amount
      X = (X + 512/Amount)
      If X = 512:Y = (Y + 512/Amount):X = X - 512:EndIf
      W = Rand(0, 255)
      RGB = (255 Shl 24) Or (W Shl 16) Or (W Shl 8) Or W
      X2 = (X + Rand(-DiffuseAmount, DiffuseAmount)) Mod 512
      Y2 = (Y + Rand(-DiffuseAmount, DiffuseAmount)) Mod 512
      While X2 < 0:X2 = X2 + 512:Wend
      While Y2 < 0:Y2 = Y2 + 512:Wend
      WritePixelFast X,Y,RGB,TexB
   Next
   UnlockBuffer TexB
   Return Tex
End Function

;---

Dim TerrainDot(0,0)
;DAs hier generiert das Terrain---------------------------------------------------------------------------------------------------------------------
Function GenerateTerrain(Size, Amount, RadMin=24, RadMax=32, MinH# = 0, MaxH# = .5, MinXY=-1, MaxXY=-1)
   If MinXY = -1:MinXY = RadMax:EndIf
   If MaxXY = -1:MaxXY = Size-RadMax:EndIf
   M = CreateTerrain(Size)
   For A = 1 To Amount
      Dim TerrainDot(Size, Size)
      X = Rand(MinXY, MaxXY)
      Y = Rand(MinXY, MaxXY)
      Rad = Rand(RadMin, RadMax)
      He# = Rnd(MinH#, MaxH#)
      ModifyTerrain M, X, Y, MaX(TerrainHeight(M, X, Y)+He#, 1)
      For B = 1 To Rad
         ;Hier müsste der fehler dann sein----------------
         Ste# = 360
         C# = 0
         If B > 0:Ste# = 1.0/(Rad-B):EndIf
         While C# < 360
            NX = Floor(X+Cos(C#)*B) Mod Size-1
            NY = Floor(Y+Sin(C#)*B) Mod Size-1
            While NX < 0:NX = NX + Size:Wend
            While NY < 0:NY = NY + Size:Wend
            If TerrainDot(NX, NY) = 0
               NH# = Max#(TerrainHeight(M, NX, NY)+((He#*(1-(B/Float(Rad)))))*Cos((Float(B)/Rad)*90), 1)
               ModifyTerrain M, NX, NY, NH#
               TerrainDot(NX, NY) = 1
            EndIf
            C# = C# + Ste#
         Wend
         ;-------------------
      Next
   Next
   ;SmoothTerrain(M)
   Return M
End Function

Function SmoothTerrain(Ter)
   WH=TerrainSize(Ter)
   For X = 0 To WH:For Y = 0 To WH
      HM#=TerrainHeight#(Ter,X,Y)
      HL#=HM#:HR#=HM#:HU#=HM#:HD#=HM#
      If X-1 >= 0 HL#=TerrainHeight#(Ter,X-1,Y)
      If X+1 <= WH HR#=TerrainHeight#(Ter,X+1,Y)
      If Y-1 >= 0 HU#=TerrainHeight#(Ter,X,Y-1)
      If Y+1 <= WH HD#=TerrainHeight#(Ter,X,Y+1)
      NewH# = (HL#+HR#+HU#+HD#+HM#)/5
      ModifyTerrain Ter,X,Y,NewH#
   Next:Next
End Function

Function RecoverTerrainImage(Ter)
   Size = TerrainSize(Ter)
   IMG = CreateImage(Size, Size)
   IMGB = ImageBuffer(IMG)
   LockBuffer IMGB
   For X = 0 To Size-1
      For Y = 0 To Size-1
         H = TerrainHeight(Ter, X, Y) * 255
         WritePixelFast X, Y, (H Shl 16) Or (H Shl 8) Or H, IMGB
      Next
   Next
   UnlockBuffer IMGB
   Return IMG
End Function

Function Max#(A#,B#)
   If A#>B# Return B#
   Return A#
End Function
Function Min#(A#,B#)
   If A#<B# Return B#
   Return A#
End Function