Koodit: VB.NET: Linssiefekti

Imports System.Drawing.Imaging
Imports System.Runtime.InteropServices

Public Class frmLens
    Inherits System.Windows.Forms.Form

    ' yleisiä muuttujia
    Private bmp As Bitmap
    Private waves As Long(,,)
    Private bmpWidth As Integer
    Private bmpHeight As Integer
    Private activeBuffer As Integer = 0
    Private weHaveWaves As Boolean
    Private bmpBytes As Byte()
    Private bmpBitmapData As BitmapData

    ' asettaa linssin säteen
    Private LensRadius As Integer = 35

    Dim fps As Long

    Dim fnt As New Font("Arial", 20)

#Region " Windows Form Designer generated code "

    Public Sub New()
        MyBase.New()

        'This call is required by the Windows Form Designer.
        InitializeComponent()

        'Haluamme piirtää itse -> ei automaattipäivitystä
        SetStyle(ControlStyles.UserPaint, True)
        'Piirto tapahtuu vain ja ainoastaan paint metodissa
        SetStyle(ControlStyles.AllPaintingInWmPaint, True)
        'Haluamme käyttää myös kaksoispuskurointia
        SetStyle(ControlStyles.DoubleBuffer, True)

    End Sub

    'Form overrides dispose to clean up the component list.
    Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean)
        If disposing Then
            If Not (components Is Nothing) Then
                components.Dispose()
            End If
        End If
        MyBase.Dispose(disposing)
    End Sub

    'Required by the Windows Form Designer
    Private components As System.ComponentModel.IContainer

    'NOTE: The following procedure is required by the Windows Form Designer
    'It can be modified using the Windows Form Designer.
    'Do not modify it using the code editor.
    Friend WithEvents EffectTimer As System.Windows.Forms.Timer
    Friend WithEvents picSurface As System.Windows.Forms.PictureBox
    <System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent()
        Me.components = New System.ComponentModel.Container
        Me.EffectTimer = New System.Windows.Forms.Timer(Me.components)
        Me.picSurface = New System.Windows.Forms.PictureBox
        Me.SuspendLayout()
        '
        'EffectTimer
        '
        Me.EffectTimer.Enabled = True
        Me.EffectTimer.Interval = 1
        '
        'picSurface
        '
        Me.picSurface.Anchor = CType((((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Bottom) _
                    Or System.Windows.Forms.AnchorStyles.Left) _
                    Or System.Windows.Forms.AnchorStyles.Right), System.Windows.Forms.AnchorStyles)
        Me.picSurface.Location = New System.Drawing.Point(0, 0)
        Me.picSurface.Name = "picSurface"
        Me.picSurface.Size = New System.Drawing.Size(448, 368)
        Me.picSurface.TabIndex = 0
        Me.picSurface.TabStop = False
        '
        'frmLens
        '
        Me.AutoScaleBaseSize = New System.Drawing.Size(5, 13)
        Me.ClientSize = New System.Drawing.Size(448, 366)
        Me.Controls.Add(Me.picSurface)
        Me.Name = "frmLens"
        Me.Text = "Lens"
        Me.ResumeLayout(False)

    End Sub

#End Region

    Private Sub frmWater_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles MyBase.Load
        ' Ladataan bittikartta
        bmp = New Bitmap("C:/koe.jpg")
        ' otetaan ylös arvot(lukeminen suoraan muuttujasta nopeampaa)
        bmpHeight = bmp.Height
        bmpWidth = bmp.Width
        ' alustetaan aaltotaulukko
        ReDim Me.waves(bmpWidth, bmpHeight, 2)
        ' hankitaan bittikartta dataa(NOPEA TAPA!!!)
        ReDim Me.bmpBytes(bmpWidth * bmpHeight * 4)
        bmpBitmapData = bmp.LockBits(New Rectangle(0, 0, bmpWidth, bmpHeight), ImageLockMode.ReadWrite, PixelFormat.Format32bppArgb)
        Marshal.Copy(bmpBitmapData.Scan0, bmpBytes, 0, bmpWidth * bmpHeight * 4)

        PutLens(Int(Rnd() * bmpWidth), Int(Rnd() * bmpHeight), Int(Rnd() * 100) + 100)
    End Sub

    Private Sub picSurface_Paint(ByVal sender As Object, ByVal e As System.Windows.Forms.PaintEventArgs) Handles picSurface.Paint
        Dim tmp As Bitmap = bmp.Clone()
        Dim x, y As Integer
        Dim xOffset, yOffset As Integer
        Dim alpha As Integer
        If (weHaveWaves) Then
            Dim tmpData As BitmapData = tmp.LockBits(New Rectangle(0, 0, bmpWidth, bmpHeight), ImageLockMode.ReadWrite, PixelFormat.Format32bppArgb)
            Dim tmpBytes(bmpWidth * bmpHeight * 4) As Byte
            Marshal.Copy(tmpData.Scan0, tmpBytes, 0, bmpWidth * bmpHeight * 4)

            x = 1
            Do While (x < (bmpWidth - 1))
                y = 1
                Do While (y < (bmpHeight - 1))
                    'Tämä on johdettu raytracingistä(AH!) heijastetaan oikea pikseli siten,
                    'että saadaan aikaan valoa taittava efekti.
                    xOffset = waves(x - 1, y, activeBuffer) - waves(x + 1, y, activeBuffer) >> 3
                    yOffset = waves(x, y - 1, activeBuffer) - waves(x, y + 1, activeBuffer) >> 3
                    If ((Not (xOffset = 0)) Or (Not (yOffset = 0))) Then
                        'tsekkaa törmailyt(heijastetuille pikseleille)
                        If (x + xOffset >= bmpWidth - 1) Then xOffset = bmpWidth - x - 1
                        If (x + xOffset < 0) Then xOffset = -x

                        If (y + yOffset >= bmpHeight - 1) Then yOffset = bmpHeight - y - 1
                        If (y + yOffset < 0) Then yOffset = -y
                        'luodaan alpha(tarvitaan vain, jos kuvassa on kohtia, joissa on alpha arvoja[läpinäkyvyyttä])
                        alpha = CInt(200 - xOffset)
                        If (alpha < 0) Then
                            alpha = 0
                        ElseIf (alpha > 255) Then
                            alpha = 254
                        End If
                        'asetetaan värit oikeisiin kohtiin(napataan oikeasta kohdasta bittitaulukkoa)
                        tmpBytes(4 * (x + y * bmpWidth)) = bmpBytes(4 * (x + xOffset + (y + yOffset) * bmpWidth))
                        tmpBytes(4 * (x + y * bmpWidth) + 1) = bmpBytes(4 * (x + xOffset + (y + yOffset) * bmpWidth) + 1)
                        tmpBytes(4 * (x + y * bmpWidth) + 2) = bmpBytes(4 * (x + xOffset + (y + yOffset) * bmpWidth) + 2)
                        tmpBytes(4 * (x + y * bmpWidth) + 3) = alpha
                    End If
                    y += 1
                Loop 'y
                x += 1
            Loop 'x
            'kopioidaan data takasin
            Marshal.Copy(tmpBytes, 0, tmpData.Scan0, bmpWidth * bmpHeight * 4)
            tmp.UnlockBits(tmpData)
        End If
        e.Graphics.DrawImage(tmp, 0, 0, picSurface.ClientRectangle.Width, picSurface.ClientRectangle.Height)
        e.Graphics.DrawString("fps: " & fps, fnt, Brushes.Black, 50, 50)
    End Sub

    Private Sub PutLens(ByVal x As Integer, ByVal y As Integer, ByVal height As Short)
        ' Simuloi pyöreää linssiä
        ' täyttää aaltotaulukon sopivilla arvoilla
        ' Käytetään hyväksi kosiniaaltoa
        ' (Jos tykkäät geomatriasta/algebrasta RAKASTAT tätä aliohjelmaa
        ' Silloin tulet nauttimaan myös renderöinnin "raytracing" osuudesta)
        ' Perustuu samaan kaavaan, kuin vesiefekti

        ' Nyt meillä ON aaltoja :D
        weHaveWaves = True
        Dim radius As Integer = LensRadius
        'etäisyyden neliö
        Dim distSquared As Double
        'aloitetaan "pallon" reunoilta
        Dim i As Integer = -radius
        Dim tmpX, tmpY As Integer
        Array.Clear(waves, 0, waves.Length)

        Do While (i <= radius)
            Dim j As Integer = -radius
            Do While (j <= radius)
                tmpX = x + i
                tmpY = y + j
                If (((tmpX >= 0) And (tmpX < bmpWidth - 1)) And ((tmpY >= 0) And (tmpY < bmpHeight - 1))) Then
                    ' i:n ja j:n välisen etäisyyden neliö
                    distSquared = Math.Sqrt(i * i + j * j)
                    ' jos etäisyys on < säde silloin linssi on "oikein"
                    If (distSquared < radius) Then
                        ' pistetään kosiniaaltoa silmukan osoittamaan paikkaan
                        waves(x + i, y + j, activeBuffer) = CShort(Math.Cos(distSquared * Math.PI / radius) * -height)
                    End If
                End If
                j += 1
            Loop 'j
            i += 1
        Loop 'i
    End Sub

    Private Sub picSurface_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles picSurface.MouseMove
        ' Koska bittikarttaa skaalataan, täytyy hiiren koordinaatteja hieman säätää...
        Dim realX As Integer = CInt((e.X / CDbl(picSurface.ClientRectangle.Width)) * bmpWidth)
        Dim realY As Integer = CInt((e.Y / CDbl(picSurface.ClientRectangle.Height)) * bmpHeight)
        PutLens(realX, realY, 350)
    End Sub

    Private Sub frmWater_Activated(ByVal sender As Object, ByVal e As System.EventArgs) Handles MyBase.Activated
        Do
            Dim d As Long = Now().Millisecond
            Dim ft As Long
            picSurface.Invalidate()
            Application.DoEvents()
            ft = Now().Millisecond - d
            If ft <> 0 Then fps = 1 / ft * 1000
        Loop
    End Sub

    Private Sub frmWater_Closed(ByVal sender As Object, ByVal e As System.EventArgs) Handles MyBase.Closed
        End
    End Sub
End Class