LandWaterGenerator -TizzyT

    Public Function PerlinNoise(ByVal RNG As Random, ByVal X As Integer, ByVal Y As Integer, ByVal Level As Integer) As Bitmap
        If X Mod 2 = 1 OrElse Y Mod 2 = 1 Then Throw New Exception("Demensions must be multiple of 2")
        Dim Noise As New Func(Of Integer, Integer, Random, Bitmap)(Function(X2, Y2, RNG2)
                                                                       Dim bm As New Bitmap(X2, Y2, PixelFormat.Format32bppArgb)
                                                                       Dim lbm As New LockBitmap(bm)
                                                                       lbm.LockBits()
                                                                       lbm.FillNoise(RNG)
                                                                       lbm.UnlockBits()
                                                                       Return bm
                                                                   End Function)
        Dim XX As Integer = X : Dim YY As Integer = Y
        Dim bmp As Bitmap = Noise(X, Y, RNG)
        Dim matrix As New ColorMatrix With {.Matrix33 = 2 / 3}
        Dim attributes As New ImageAttributes()
        attributes.SetColorMatrix(matrix, ColorMatrixFlag.Default, ColorAdjustType.Bitmap)
        attributes.SetWrapMode(WrapMode.TileFlipXY)
        Using gfx As Graphics = Graphics.FromImage(bmp)
            gfx.InterpolationMode = InterpolationMode.HighQualityBicubic
            gfx.CompositingMode = CompositingMode.SourceOver
            gfx.CompositingQuality = CompositingQuality.HighQuality
            gfx.PixelOffsetMode = PixelOffsetMode.HighQuality
            gfx.SmoothingMode = SmoothingMode.HighQuality
            XX /= 2 : YY /= 2
            While XX > 0 AndAlso YY > 0 AndAlso Level + 1 > 0
                Using bm As Bitmap = Noise(XX, YY, RNG)
                    gfx.DrawImage(bm, New Rectangle(0, 0, X, Y), 0, 0, bm.Width, bm.Height, GraphicsUnit.Pixel, attributes)
                End Using
                XX /= 2 : YY /= 2 : Level -= 1
            End While
            'Return bmp
        End Using
        bmp = ResizeImage(bmp, X, Y, 1, 0.66)
        Dim lr As New LockBitmap(bmp)
        lr.LockBits()
        lr.Threshold(154)
        lr.UnlockBits()
        bmp = ResizeImage(bmp, X, Y, 1, 0.66)
        Return bmp
    End Function

    Public Function ResizeImage(IMG As Image,
                            W As Integer,
                            H As Integer,
                            Optional Opacity As Single = 1.0,
                            Optional Blur As Single = 0.0,
                            Optional CompositingMode As CompositingMode = CompositingMode.SourceOver,
                            Optional CompositingQuality As CompositingQuality = CompositingQuality.HighQuality,
                            Optional InterpolationMode As InterpolationMode = InterpolationMode.HighQualityBicubic,
                            Optional SmoothingMode As SmoothingMode = SmoothingMode.HighQuality,
                            Optional PixelOffsetMode As PixelOffsetMode = PixelOffsetMode.HighQuality,
                            Optional WrapMode As WrapMode = WrapMode.TileFlipXY) As Bitmap
        If W < 1 Then W = 1 : If H < 1 Then H = 1
        Dim destRect As New Rectangle(0, 0, W, H), destImage As New Bitmap(W, H)
        destImage.SetResolution(IMG.HorizontalResolution, IMG.VerticalResolution)
        Using g = Graphics.FromImage(destImage) : With g
                .CompositingMode = CompositingMode
                .CompositingQuality = CompositingQuality
                .InterpolationMode = InterpolationMode
                .SmoothingMode = SmoothingMode
                .PixelOffsetMode = PixelOffsetMode : End With
            Using WM = New ImageAttributes()
                If Opacity < 1.0 Then WM.SetColorMatrix(New ColorMatrix With {.Matrix33 = Opacity}, ColorMatrixFlag.Default, ColorAdjustType.Bitmap)
                WM.SetWrapMode(WrapMode)
                g.DrawImage(IMG, destRect, 0, 0, IMG.Width, IMG.Height, GraphicsUnit.Pixel, WM)
            End Using
        End Using
        If Blur > 0.0 AndAlso Blur <= 1.0 Then Return ResizeImage(ResizeImage(destImage, W - (W * Blur), H - (H * Blur)), W, H)
        Return destImage
    End Function

Imports System.Drawing.Imaging
Imports System.Runtime.InteropServices
Public Class LockBitmap
    Private source As Bitmap = Nothing
    Private Iptr As IntPtr = IntPtr.Zero
    Private bitmapData As BitmapData = Nothing
    Public Property Pixels() As Byte()
        Get
            Return m_Pixels
        End Get
        Set(value As Byte())
            m_Pixels = value
        End Set
    End Property
    Private m_Pixels As Byte()
    Public Property Depth() As Integer
        Get
            Return m_Depth
        End Get
        Private Set(value As Integer)
            m_Depth = value
        End Set
    End Property
    Private m_Depth As Integer
    Public Property Width() As Integer
        Get
            Return m_Width
        End Get
        Private Set(value As Integer)
            m_Width = value
        End Set
    End Property
    Private m_Width As Integer
    Public Property Height() As Integer
        Get
            Return m_Height
        End Get
        Private Set(value As Integer)
            m_Height = value
        End Set
    End Property
    Private m_Height As Integer
    Public Sub New(source As Bitmap)
        Me.source = source
    End Sub
    Public Sub LockBits()
        Try
            Width = source.Width
            Height = source.Height
            Dim PixelCount As Integer = Width * Height
            Dim rect As New Rectangle(0, 0, Width, Height)
            Depth = Image.GetPixelFormatSize(source.PixelFormat)
            'If Depth <> 16 Then Throw New ArgumentException("Only 8, 24 and 32 bpp images are supported.")
            bitmapData = source.LockBits(rect, ImageLockMode.ReadWrite, source.PixelFormat)
            Dim [step] As Integer = Depth / 8
            Pixels = New Byte(PixelCount * [step] - 1) {}
            Iptr = bitmapData.Scan0
            Marshal.Copy(Iptr, Pixels, 0, Pixels.Length)
        Catch ex As Exception
            Throw ex
        End Try
    End Sub
    Public Sub UnlockBits()
        Try
            Marshal.Copy(Pixels, 0, Iptr, Pixels.Length)
            source.UnlockBits(bitmapData)
            bitmapData = Nothing
        Catch ex As Exception
            Throw ex
        End Try
    End Sub
    Public Function GetPixel(x As Integer, y As Integer) As Color
        Dim clr As Color = Color.Empty
        Dim cCount As Integer = Depth / 8
        Dim i As Integer = ((y * Width) + x) * cCount
        If i > Pixels.Length - cCount Then Throw New IndexOutOfRangeException()
        If Depth = 32 Then
            Dim b As Byte = Pixels(i)
            Dim g As Byte = Pixels(i + 1)
            Dim r As Byte = Pixels(i + 2)
            Dim a As Byte = Pixels(i + 3)
            clr = Color.FromArgb(a, r, g, b)
        End If
        If Depth = 24 Then
            Dim b As Byte = Pixels(i)
            Dim g As Byte = Pixels(i + 1)
            Dim r As Byte = Pixels(i + 2)
            clr = Color.FromArgb(r, g, b)
        End If
        If Depth = 8 Then
            Dim c As Byte = Pixels(i)
            clr = Color.FromArgb(c, c, c)
        End If
        Return clr
    End Function
    Public Sub SetPixel(x As Integer, y As Integer, color As Color)
        Dim cCount As Integer = Depth / 8
        Dim i As Integer = ((y * Width) + x) * cCount
        If Depth = 32 Then
            Pixels(i) = color.B
            Pixels(i + 1) = color.G
            Pixels(i + 2) = color.R
            Pixels(i + 3) = color.A
        End If
        If Depth = 24 Then
            Pixels(i) = color.B
            Pixels(i + 1) = color.G
            Pixels(i + 2) = color.R
        End If
        If Depth = 8 Then Pixels(i) = color.B
    End Sub
    Public Sub FillNoise(ByVal RNG As Random)
        If bitmapData IsNot Nothing Then
            RNG.NextBytes(m_Pixels)
        End If
    End Sub
    Public Sub Threshold(ByVal value As Byte)
        If bitmapData IsNot Nothing Then
            For i = 1 To m_Pixels.Length - 1 Step 4
                If m_Pixels(i) < value Then
                    m_Pixels(i) = 0
                    m_Pixels(i - 1) = 255
                Else
                    m_Pixels(i) = 255
                    m_Pixels(i - 1) = 0
                End If
                m_Pixels(i + 1) = 0
                m_Pixels(i + 2) = 255
            Next
        End If
    End Sub
End Class