Untitled

ecobayod

Jun 11th, 2024

162

Never

Add comment

Not a member of Pastebin yet? Sign Up, it unlocks many cool features!

VisualBasic 5.52 KB | None | 0 0

raw download clone embed print report

Public Class Form1
Dim mode = 0
Dim playing = False
Dim currentTime = 12.0
Dim playbackSpeed = 1.0
Dim selectedLayer = 0
Dim level = 0.0
Dim location As Point = Nothing
Dim floodMap As Bitmap
Dim isFloodMapStale = True
Private Function clampFlood(level As Integer) As Bitmap
Dim flood = My.Resources.flood
Dim width As Integer = flood.Width
Dim height As Integer = flood.Height
Dim clamped As New Bitmap(width, height)
For y As Integer = 0 To height - 1
For x As Integer = 0 To width - 1
Dim color As Color = flood.GetPixel(x, y)
Dim value As Integer = color.R
Dim gradientColor As Color
If color.A < 120 OrElse value >= level Then
gradientColor = Color.FromArgb(0, 0, 0, 0)
Else
gradientColor = Color.FromArgb(200, 30, 30, Int(color.R * 0.6))
End If
clamped.SetPixel(x, y, gradientColor)
Next
Next
Return clamped
End Function
Private Sub updateImage()
Dim map As Bitmap
If selectedLayer = 1 Then
map = My.Resources.distance
ElseIf selectedLayer = 2 Then
map = My.Resources.elevation
Else
map = My.Resources.bitmap
End If
Using g = Graphics.FromImage(map)
If isFloodMapStale Then
floodMap = clampFlood(Int(255 * level))
isFloodMapStale = False
End If
g.DrawImage(floodMap, 0, 0, 512, 512)
If location <> Nothing Then
Dim marker = My.Resources.location
g.DrawImage(marker, location.X - 9, location.Y - 24, 18, 24)
End If
End Using
ptrMap.Image = map
End Sub
Private Sub updateView()
If playing Then
btnPlay.Text = "Pause"
tmrPlayback.Enabled = True
Else
btnPlay.Text = "Play"
tmrPlayback.Enabled = False
End If
rbNone.Checked = (selectedLayer = 0)
rbDist.Checked = (selectedLayer = 1)
rbElev.Checked = (selectedLayer = 2)
If mode = 1 Then
tmrPlayback.Enabled = False
trbTime.Enabled = False
Else
trbTime.Enabled = True
level = currentTime / 24.0
End If
If location <> Nothing Then
Dim pixel = My.Resources.flood.GetPixel(location.X, location.Y)
Dim heightMap = My.Resources.height.Clone()
Dim value = pixel.R
If pixel.A > 127 AndAlso value < Int(255 * level) Then
Dim height = (Int(255 * level) - value) / 255
Dim y As Integer = Int(height * 157)
Dim offset As Integer = 157 - y
Using g = Graphics.FromImage(heightMap)
Dim col = Color.FromArgb(128, Color.Blue)
Using brush As New SolidBrush(col)
g.FillRectangle(brush, 0, offset, 242, y)
End Using
End Using
End If
ptrHeight.Image = heightMap
End If
trbSpeed.Value = Int(10.0 * playbackSpeed)
trbTime.Value = Int(3.0 * currentTime)
updateImage()
End Sub
Private Sub btnPlay_Click(sender As Object, e As EventArgs) Handles btnPlay.Click
playing = Not playing
updateView()
End Sub
Private Sub btnCurrent_Click(sender As Object, e As EventArgs) Handles btnCurrent.Click
playing = False
currentTime = 12.0
updateView()
End Sub
Private Sub tmrPlayback_Tick(sender As Object, e As EventArgs) Handles tmrPlayback.Tick
currentTime = (currentTime + playbackSpeed) Mod 24
updateView()
End Sub
Private Sub trbSpeed_Scroll(sender As Object, e As EventArgs) Handles trbSpeed.Scroll
playbackSpeed = trbSpeed.Value / 10.0
updateView()
End Sub
Private Sub trbTime_Scroll(sender As Object, e As EventArgs) Handles trbTime.Scroll
currentTime = trbTime.Value / 3.0
updateView()
End Sub
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
updateView()
End Sub
Private Sub rbNone_CheckedChanged(sender As Object, e As EventArgs) Handles rbNone.CheckedChanged, rbDist.CheckedChanged, rbElev.CheckedChanged
If rbNone.Checked Then
selectedLayer = 0
ElseIf rbDist.Checked Then
selectedLayer = 1
Else
selectedLayer = 2
End If
updateView()
End Sub
Private Sub tmrRefresh_Tick(sender As Object, e As EventArgs) Handles tmrRefresh.Tick
isFloodMapStale = True
End Sub
Private Sub trbHeight_Scroll(sender As Object, e As EventArgs) Handles trbHeight.Scroll
level = trbHeight.Value / 30.0
updateView()
End Sub
Private Sub TabPage1_Enter(sender As Object, e As EventArgs) Handles TabPage1.Enter
mode = 0
updateView()
End Sub
Private Sub TabPage2_Enter(sender As Object, e As EventArgs) Handles TabPage2.Enter
mode = 1
updateView()
End Sub
Private Sub ptrMap_MouseClick(sender As Object, e As MouseEventArgs) Handles ptrMap.MouseClick
location = New Point(e.X, e.Y)
updateView()
End Sub
End Class

Add Comment

Please, Sign In to add comment