WPFとVB.NET、回転したコントロールをマウスドラッグでグリッドスナップ、SortedListはスゴイヤツ

Imports System.Windows.Controls.Primitives

Class MainWindow
    Private Const grid As Integer = 70 'グリッドの大きさ

    'グリッドをPathで描画
    Private Sub DrawGridLine()
        Dim pFigure As PathFigure
        Dim pGeometry As New PathGeometry
        '横線
        For i As Integer = 0 To 50
            pFigure = New PathFigure
            pFigure.StartPoint = New Point(i * grid, 0)
            pFigure.Segments.Add(New LineSegment(New Point(i * grid, 350), True))
            pGeometry.Figures.Add(pFigure)
        Next
        '縦線
        For i As Integer = 0 To 35
            pFigure = New PathFigure
            pFigure.StartPoint = New Point(0, i * grid)
            pFigure.Segments.Add(New LineSegment(New Point(500, i * grid), True))
            pGeometry.Figures.Add(pFigure)
        Next

        '描画
        Dim mPath As New Path With {.Stroke = Brushes.Blue, .StrokeThickness = 1, .Data = pGeometry}
        canvas1.Children.Add(mPath)
        Panel.SetZIndex(mPath, -1) '背面に移動

    End Sub

    'ドラッグ移動
    Private Sub thumb1_DragDelta(sender As Object, e As DragDeltaEventArgs) Handles thumb1.DragDelta
        Dim p As Point = GetOnCanvas(sender)
        Dim x As Double = p.X + e.HorizontalChange
        Dim y As Double = p.Y + e.VerticalChange

        x = x - (x Mod grid)
        y = y - (y Mod grid)
        Dim t As ExThumb = DirectCast(sender, ExThumb)
        SetOnCanvas(t, x, y)

    End Sub

    '対象を指定座標にセット
    Private Overloads Sub SetOnCanvas(t As ExThumb, x As Double, y As Double)
        Canvas.SetLeft(t, x)
        Canvas.SetTop(t, y)
        t.Locate = New Point(x, y)
    End Sub
    Private Overloads Sub SetOnCanvas(t As ExThumb, p As Point)
        Call SetOnCanvas(t, p.X, p.Y)
    End Sub

    '対象の座標を取得
    Private Function GetOnCanvas(obj As Object) As Point
        Return New Point(Canvas.GetLeft(obj), Canvas.GetTop(obj))
    End Function

    '基本座標と4頂点の差を記録
    Private Sub SetDiffPoint(t As ExThumb)
        Dim gt As GeneralTransform = t.TransformToVisual(canvas1)
        Dim BaseP As Point = New Point(Canvas.GetLeft(t), Canvas.GetTop(t))

        With t
            .Locate = BaseP '基本座標
            .DiffLTop = gt.Transform(New Point(0, 0)) - BaseP '左上頂点座標 - 基本座標
            .DiffRTop = gt.Transform(New Point(t.Width, 0)) - BaseP
            .DiffRDown = gt.Transform(New Point(t.Width, t.Height)) - BaseP
            .DiffLDown = gt.Transform(New Point(0, t.Height)) - BaseP
        End With
    End Sub

    '起動中
    Private Sub MainWindow_Initialized(sender As Object, e As EventArgs) Handles Me.Initialized
        Call DrawGridLine()
    End Sub

    '起動直後
    Private Sub MainWindow_Loaded(sender As Object, e As RoutedEventArgs) Handles Me.Loaded
        Call SetDiffPoint(thumb2) '起動中ではExThumbが表示されていないので起動直後
    End Sub

    '左上を最寄りのグリッドに合わせる
    Private Sub btLTop_Click(sender As Object, e As RoutedEventArgs) Handles btLTop.Click
        Call SetFitPoint(thumb2, thumb2.DiffLTop)
    End Sub
    '右上を最寄りのグリッドに合わせる
    Private Sub btRTop_Click(sender As Object, e As RoutedEventArgs) Handles btRTop.Click
        Call SetFitPoint(thumb2, thumb2.DiffRTop)
    End Sub

    '指定した頂点をグリッドに合わせる
    Private Sub SetFitPoint(t As ExThumb, fit As Point)
        '左上の座標が最寄りのグリッドからどれだけ離れているか距離を取得
        '離れているぶんを移動
        Dim fp As Point = t.Locate + fit 'グリッドに合わせたい頂点座標
        Dim x As Double = GetNearGridPoint(fp.X) '最寄りのグリッドx座標
        Dim y As Double = GetNearGridPoint(fp.Y) 'y座標

        Dim nx As Double = x - fp.X '最寄りのグリッド座標 - 今の座標 = 距離
        nx = t.Locate.X + nx '今の座標 + 距離 = グリッドにぴったりになる座標
        Dim ny As Double = y - fp.Y
        ny = t.Locate.Y + ny

        Call SetOnCanvas(t, nx, ny) '座標をセット
        't.Locate = New Point(nx, ny)
    End Sub

    '距離取得
    Private Function GetNearGridPoint(xy As Double) As Double
        Dim m As Double = xy Mod grid
        If m > grid / 2 Then
            Return xy + grid - m
        Else
            Return xy - m
        End If
    End Function

    'ドラッグ移動
    Private Sub thumb2_DragDelta(sender As Object, e As DragDeltaEventArgs) Handles thumb2.DragDelta
        Dim t As ExThumb = DirectCast(sender, ExThumb)
        Dim mp As New Point(e.HorizontalChange, e.VerticalChange) '移動距離
        Dim np As Point = GetNearPoint(t, mp) '最寄りのグリッドまでの距離取得
        np = np + t.Locate + mp '最寄りのグリッド ＋ 今の座標 ＋ 移動距離 ＝ ピッタリの座標
        Call SetOnCanvas(t, np) '座標指定
    End Sub

    '最寄りのグリッドにピッタリの座標になるために移動する分の座標を返す
    Private Function GetNearPoint(t As ExThumb, addPoint As Point) As Point
        '四角形(ExThumb)の座標
        Dim bp As Point = t.Locate + addPoint
        '4頂点の現在の座標
        Dim LT As Point = t.DiffLTop + bp '左上の頂点座標
        Dim RT As Point = t.DiffRTop + bp
        Dim RD As Point = t.DiffRDown + bp
        Dim LD As Point = t.DiffLDown + bp
        '4頂点それぞれの最寄りのグリッド座標
        Dim ltg As Point = GetXYDistance(LT) '左上の頂点に一番近いグリッド座標
        Dim rtg As Point = GetXYDistance(RT)
        Dim rdg As Point = GetXYDistance(RD)
        Dim ldg As Point = GetXYDistance(LD)
        'それぞれのグリッドまでの距離
        Dim ltd As Double = GetDistance(LT, ltg) '左上の頂点からグリッド座標までの距離
        Dim rtd As Double = GetDistance(RT, rtg)
        Dim rdd As Double = GetDistance(RD, rdg)
        Dim ldd As Double = GetDistance(LD, ldg)
        '現在の座標と最寄りのグリッド座標の差
        LT = ltg - LT '左上頂点の最寄りのグリッド - 現在の左上
        RT = rtg - RT
        RD = rdg - RD
        LD = ldg - LD

        '4頂点の中から一番近い
        '一番近い座標を得るためにSortedListに座標の差を入れる
        'SortedListはKeyの順番で自動でソートしてくれる
        '        ジェネリックコレクション その3 SortedListとSortedDictionary (System.Collections.Generic) - Programming/.NET Framework/コレクション - 総武ソフトウェア推進所
        'http://smdn.jp/programming/netfx/collections/2_generic_3_sortedlist_sorteddictionary/#indexed_access

        Dim sl As New SortedList(Of Double, Point)
        sl.Add(ltd, LT)
        sl.Add(rtd, RT)
        sl.Add(rdd, RD)
        sl.Add(ldd, LD)
        Dim neko As Point = sl.Values(0)
        '座標の修正値を返す、
        'この座標と現在の座標を足したものが最寄りのグリッドにピッタリの座標になる
        Return sl.Values(0)
    End Function

    '指定座標から一番近いグリッドの座標を返す
    Private Function GetXYDistance(dp As Point) As Point
        Dim x As Double = GetNearGridPoint(dp.X) '最寄りのグリッドx座標
        Dim y As Double = GetNearGridPoint(dp.Y) 'y座標
        Return New Point(x, y)
    End Function

    '2点間の距離を返す
    Private Function GetDistance(p1 As Point, p2 As Point) As Double
        Dim x As Double = p1.X - p2.X
        Dim y As Double = p1.Y - p2.Y
        Dim rd As Double = Math.Sqrt(x ^ 2 + y ^ 2)
        Return rd
    End Function

    Private Sub bt2_Click(sender As Object, e As RoutedEventArgs) Handles bt2.Click
        Dim neko As ExThumb = thumb2
        Dim p As Point = GetNearPoint(thumb2, New Point(0, 0))
    End Sub

    Private Sub btAutoFit_Click(sender As Object, e As RoutedEventArgs) Handles btAutoFit.Click
        Dim p As Point = GetNearPoint(thumb2, New Point(0, 0))
        Dim np As Point = p + thumb2.Locate
        Call SetOnCanvas(thumb2, np)
        thumb2.Locate = np

    End Sub
End Class

Public Class ExThumb
    Inherits Thumb
    Public Property Locate As Point 'ExThumb自身の座標、基本になる座標
    Public Property DiffLTop As Point 'Locateから左上頂点座標までの差
    Public Property DiffRTop As Point '右上
    Public Property DiffRDown As Point '右下
    Public Property DiffLDown As Point '左下

End Class

'毎回計算するのはめんどいからExThumbに4頂点の座標のプロパティをもたせたほうが良さそう
'4頂点の座標は元の座標からの差を記録したほうが良さそう
'そうすれば4頂点の変更はExThumbの変形時だけに留められる