Advertisement
Guest User

Untitled

a guest
Dec 5th, 2012
134
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Option Explicit On
  2. Imports System.IO
  3.  
  4. Public Class Form1
  5.     Structure DPoint
  6.         Dim X As Double
  7.         Dim Y As Double
  8.         Sub New(ByVal pX As Double, ByVal pY As Double)
  9.             X = pX
  10.             Y = pY
  11.         End Sub
  12.         Function ToInt()
  13.             Return New Point(CInt(Math.Round(X)), CInt(Math.Round(Y)))
  14.         End Function
  15.         Function Round(Optional ByVal digits As Integer = 0, Optional ByVal mode As System.MidpointRounding = MidpointRounding.AwayFromZero)
  16.             Return New DPoint(Math.Round(X, digits, mode), Math.Round(Y, digits, mode))
  17.         End Function
  18.         Public Shared Operator <>(ByVal a As DPoint, ByVal b As DPoint) As Boolean
  19.             If a.X <> b.X Then Return False
  20.             If a.Y <> b.Y Then Return False
  21.             Return True
  22.         End Operator
  23.         Public Shared Operator =(ByVal a As DPoint, ByVal b As DPoint) As Boolean
  24.             If a.X <> b.X Then Return False
  25.             If a.Y <> b.Y Then Return False
  26.             Return True
  27.         End Operator
  28.         Public Shared Operator +(ByVal a As DPoint, ByVal b As DPoint) As DPoint
  29.             Return New DPoint(a.X + b.X, a.Y + b.Y)
  30.         End Operator
  31.         Public Shared Operator -(ByVal a As DPoint, ByVal b As DPoint) As DPoint
  32.             Return New DPoint(a.X - b.X, a.Y - b.Y)
  33.         End Operator
  34.         Public Shared Operator *(ByVal a As DPoint, ByVal b As DPoint) As DPoint
  35.             Return New DPoint(a.X * b.X, a.Y * b.Y)
  36.         End Operator
  37.         Public Shared Operator /(ByVal a As DPoint, ByVal b As DPoint) As DPoint
  38.             Return New DPoint(a.X / b.X, a.Y / b.Y)
  39.         End Operator
  40.         Public Shared Operator /(ByVal a As DPoint, ByVal b As Double) As DPoint
  41.             Return New DPoint(a.X / b, a.Y / b)
  42.         End Operator
  43.         Public Shared Operator *(ByVal a As DPoint, ByVal b As Double) As DPoint
  44.             Return New DPoint(a.X * b, a.Y * b)
  45.         End Operator
  46.         Public Shared Operator +(ByVal a As DPoint, ByVal b As Double) As DPoint
  47.             Return New DPoint(a.X + b, a.Y + b)
  48.         End Operator
  49.         Public Shared Operator -(ByVal a As DPoint, ByVal b As Double) As DPoint
  50.             Return New DPoint(a.X - b, a.Y - b)
  51.         End Operator
  52.     End Structure
  53.     Dim MainImage As New DynamicBitmap
  54.     Dim Points() As DPoint = {New DPoint(0.0, 0.0), New DPoint(10.0, 10.0), New DPoint(10.0, 15.0), New DPoint(15.0, 15.0), New DPoint(20.0, -20.0), New DPoint(-20.0, -20.0), New DPoint(0.0, -10.0), New DPoint(-10.0, -10.0), New DPoint(-10.0, 0.0)}
  55.     Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
  56.         Dim temp As New DynamicBitmap
  57.         MainImage.CreateGrid(500, 500, 1, 1)
  58.         temp.LoadBitmap("map.jpg")
  59.         MainImage.DrawOnSurface(temp.Bitmap, temp.Rectangle, MainImage.Rectangle)
  60.         MainImage.Surface.DrawLine(Pens.Black, 0, 250, 500, 250)
  61.         MainImage.Surface.DrawLine(Pens.Black, 250, 0, 250, 500)
  62.         For i As Integer = 0 To Points.Length - 2
  63.             MainImage.Surface.DrawLine(Pens.Black, PointToImage(Points(i).ToInt()), PointToImage(Points(i + 1).ToInt()))
  64.         Next
  65.  
  66.         PictureBox1.Image = MainImage.Bitmap
  67.         PictureBox1.Refresh()
  68.     End Sub
  69.     Function DrawCross(ByVal Point As Point, ByVal color As Pen) As Integer
  70.         MainImage.Surface.DrawLine(color, Point.X - 1, Point.Y - 1, Point.X + 1, Point.Y + 1)
  71.         MainImage.Surface.DrawLine(color, Point.X + 1, Point.Y - 1, Point.X - 1, Point.Y + 1)
  72.         Return 1
  73.     End Function
  74.     Function PointToImage(ByVal P1 As Point) As Point
  75.         Return New Point(250 + (P1.X * 10), 250 - (P1.Y * 10))
  76.     End Function
  77.     Function PointToImage(ByVal P1() As Point) As Point()
  78.         Dim ret(0 To P1.Length - 1) As Point
  79.         For i As Integer = 0 To P1.Length - 1
  80.             ret(i) = New Point(250 + (P1(i).X * 10), 250 - (P1(0).Y * 10))
  81.         Next
  82.         Return ret
  83.     End Function
  84.     Function PointToImage(ByVal P1 As DPoint) As Point
  85.         Return New Point(250 + CInt(P1.X * 10), 250 - CInt(P1.Y * 10))
  86.     End Function
  87.     Function PointToImage(ByVal P1() As DPoint) As Point()
  88.         Dim ret(0 To P1.Length - 1) As Point
  89.         For i As Integer = 0 To P1.Length - 1
  90.             ret(i) = New Point(250 + (CInt(P1(i).X * 10.0)), 250 - (CInt(P1(0).Y * 10.0)))
  91.         Next
  92.         Return ret
  93.     End Function
  94.     Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
  95.         Dim B() As DPoint = Points
  96.         Dim len As Integer = 0
  97.         len = (B.Length - 2)
  98.         Dim u(len) As DPoint
  99.         len = (u.Length - 2)
  100.         Dim bs(len) As DPoint
  101.         Dim n(len) As DPoint
  102.  
  103.         Dim dist As Double = 2.0
  104.         Dim PL(len) As DPoint
  105.         Dim PR(len) As DPoint
  106.         Dim P((PL.Length + PR.Length) - 1) As DPoint
  107.         For i As Integer = 0 To u.Length - 1 '1.Determine each u(k)
  108.            u(i) = B(i + 1) - B(i)
  109.         Next
  110.         For i As Integer = 0 To bs.Length - 1 '2.Determine each bisector b(k)   and unit bisector n(k)
  111.            bs(i) = New DPoint(-(u(i) + u(i + 1)).Y, (u(i) + u(i + 1)).X)
  112.             Dim divider As Double = ((bs(i).X * bs(i).X) + (bs(i).Y * bs(i).Y))
  113.             n(i) = bs(i) / Math.Sqrt(divider)
  114.         Next
  115.         For i As Integer = 0 To PL.Length - 1 '3.Determine the points P′ and P′′. | ′ = 0, ′′ = 1
  116.            PL(i) = B(i + 1) + (n(i) * dist)
  117.             PR(i) = B(i + 1) - (n(i) * dist)
  118.             P(i) = PL(i)
  119.         Next
  120.         For i As Integer = 0 To PL.Length - 1 '3.Determine the points P′ and P′′. | ′ = 0, ′′ = 1
  121.            P(PL.Length + i) = PR((PL.Length - 1) - i)
  122.         Next
  123.  
  124.         Dim Polygon(P.Length + 2) As DPoint
  125.         Polygon(0) = B(0)
  126.         For i As Integer = 0 To PL.Length - 1
  127.             Polygon(i + 1) = P(i)
  128.         Next
  129.         Polygon(PL.Length + 1) = B(B.Length - 1)
  130.         For i As Integer = 0 To PL.Length - 1
  131.             Polygon(PL.Length + i + 2) = P(PL.Length + i)
  132.         Next
  133.         Polygon(Polygon.Length - 1) = B(0)
  134.  
  135.         For i As Integer = 0 To Polygon.Length - 2
  136.             MainImage.Surface.DrawLine(Pens.Red, PointToImage(Polygon(i).ToInt()), PointToImage(Polygon(i + 1).ToInt()))
  137.         Next
  138.         MainImage.Surface.DrawLine(Pens.Red, PointToImage(Polygon(Polygon.Length - 1).ToInt()), PointToImage(Polygon(0).ToInt()))
  139.  
  140.         PictureBox1.Image = MainImage.Bitmap
  141.         PictureBox1.Refresh()
  142.     End Sub
  143. End Class
  144.  
  145.  
  146. Public Class DynamicBitmap
  147.  
  148.     'Completed 28 May 2010
  149.    'Updated to Version 2.4 on 18 June 2010
  150.    'Current Version 2.4.0
  151.  
  152.     Private clsBitmapImage As Bitmap
  153.     Private clsBitmapMemory As Bitmap
  154.     Private clsGraphicsBuffer As Graphics
  155.  
  156.     Private isGrid As Boolean
  157.     Private tlWidth As Integer
  158.     Private tlHeight As Integer
  159.     Private rowCnt As Integer
  160.     Private columnCnt As Integer
  161.     Private bmpFileName As String
  162.  
  163.     Private doesExist As Boolean
  164.  
  165.     Public Path() As Integer
  166.  
  167.     Public Enum Direction
  168.         North
  169.         South
  170.         East
  171.         West
  172.         NorthEast
  173.         SouthEast
  174.         NorthWest
  175.         SouthWest
  176.     End Enum
  177.  
  178.     Public Sub DrawOnSurface(ByVal source As Bitmap, ByVal srcRectangle As Rectangle, ByVal destRectangle As Rectangle, _
  179.                              Optional ByVal Stretch As Boolean = True, Optional ByVal Center As Boolean = False, _
  180.                              Optional ByVal InterpolMode As Drawing2D.InterpolationMode = Drawing2D.InterpolationMode.Default)
  181.  
  182.         Dim texBrush As TextureBrush = New TextureBrush(source)
  183.         Dim tmpL As Integer, tmpT As Integer
  184.  
  185.         clsGraphicsBuffer.InterpolationMode = InterpolMode
  186.         If Stretch = True Then
  187.             clsGraphicsBuffer.DrawImage(source, destRectangle, srcRectangle, GraphicsUnit.Pixel)
  188.         Else
  189.             If Center = False Then
  190.                 clsGraphicsBuffer.DrawImage(source, destRectangle.X, destRectangle.Y, srcRectangle, GraphicsUnit.Pixel)
  191.             Else
  192.                 tmpL = destRectangle.X + ((destRectangle.Width - srcRectangle.Width) / 2)
  193.                 tmpT = destRectangle.Y + ((destRectangle.Height - srcRectangle.Height) / 2)
  194.                 clsGraphicsBuffer.DrawImage(source, tmpL, tmpT, srcRectangle, GraphicsUnit.Pixel)
  195.             End If
  196.  
  197.         End If
  198.         texBrush.Dispose()
  199.     End Sub
  200.  
  201.  
  202.  
  203.  
  204.     ''' <summary>
  205.    ''' INITIALIZING CLASS SECTION
  206.    ''' : 3 Options to initialize this class - load a bitmap, create a blank bitmap, or create parameters for a grid and subsequent blank bitmap
  207.    ''' </summary>
  208.    ''' <param name="fromFileName"></param>
  209.    ''' <remarks></remarks>
  210.    Public Sub LoadBitmap(ByVal fromFileName As String, Optional ByVal tilesWidth As Integer = 0, Optional ByVal tilesHeight As Integer = 0)
  211.         isGrid = False 'Only set to true if "CreateGrid" is called
  212.        clsBitmapImage = New Bitmap(fromFileName)
  213.         clsGraphicsBuffer = Graphics.FromImage(clsBitmapImage)
  214.         bmpFileName = fromFileName
  215.         TileHeight = tilesHeight
  216.         TileWidth = tilesWidth
  217.         doesExist = True
  218.     End Sub
  219.     Public Sub CreateBitmap(ByVal bmpWidth As Integer, ByVal bmpHeight As Integer)
  220.         isGrid = False 'Only set to true if "CreateGrid" is called
  221.        clsBitmapImage = New Bitmap(bmpWidth, bmpHeight)
  222.         clsGraphicsBuffer = Graphics.FromImage(clsBitmapImage)
  223.         TileWidth = bmpWidth
  224.         TileHeight = bmpHeight
  225.         doesExist = True
  226.     End Sub
  227.     Public Sub CreateGrid(ByVal tilesWidth As Integer, ByVal tilesHeight As Integer, ByVal rowCount As Integer, ByVal columnCount As Integer)
  228.  
  229.         'The isGrid variable tells the TileWidth/TileHeight properties not to automatically
  230.        'determine the row/column count since the user has specified those variables in this subroutine
  231.        isGrid = True
  232.  
  233.         'Creates a blank bitmap equal to the size of the grid
  234.        CreateBitmap(columnCount * tilesWidth, rowCount * tilesHeight)
  235.  
  236.         'Sets the dimensions of the specified grid
  237.        TileWidth = tilesWidth
  238.         TileHeight = tilesHeight
  239.  
  240.         'Sets the row and column count based on what the user has input
  241.        rowCnt = rowCount
  242.         columnCnt = columnCount
  243.  
  244.  
  245.  
  246.         doesExist = True
  247.     End Sub
  248.  
  249.  
  250.  
  251.  
  252.  
  253.     ''' <summary>
  254.    ''' TILE METHODS SECTION
  255.    '''  : Tiles can be either grid cells or sprite blocks, depending on how the user is using the class
  256.    ''' </summary>
  257.    ''' <value></value>
  258.    ''' <returns></returns>
  259.    ''' <remarks></remarks>
  260.    Public Property TileHeight As Integer
  261.         'Sets the value of the tile height (for the user, this may be a cell property
  262.        'or sprite property if LoadBitmap was called and a tile sheet file was loaded
  263.        Get
  264.             TileHeight = tlHeight
  265.         End Get
  266.         Set(ByVal value As Integer)
  267.             tlHeight = value
  268.             If tlHeight = 0 Then tlHeight = clsBitmapImage.Height
  269.             'If the user is setting parameters for a sprite map or tile sheet,
  270.            'the property automatically determines the row count
  271.            If isGrid = False Then
  272.                 rowCnt = Math.Truncate(clsBitmapImage.Height / tlHeight)
  273.             End If
  274.         End Set
  275.     End Property
  276.     Public Property TileWidth As Integer
  277.         'Sets the value of the tile width (for the user, this may be a cell property
  278.        'or sprite property if LoadBitmap was called and a tile sheet file was loaded
  279.        Get
  280.             TileWidth = tlWidth
  281.         End Get
  282.         Set(ByVal value As Integer)
  283.             tlWidth = value
  284.             If tlWidth = 0 Then tlWidth = clsBitmapImage.Width
  285.             'If the user is setting parameters for a sprite map or tile sheet,
  286.            'the property automatically determines the column count
  287.            If isGrid = False Then
  288.                 columnCnt = Math.Truncate(clsBitmapImage.Width / tlWidth)
  289.             End If
  290.         End Set
  291.     End Property
  292.  
  293.     Public ReadOnly Property TileCount As Integer
  294.         Get
  295.             TileCount = rowCnt * columnCnt
  296.             Return TileCount
  297.         End Get
  298.     End Property
  299.     Public ReadOnly Property Point(Optional ByVal TileIndex As Integer = 0) As Point
  300.         Get
  301.             'Sets default point to upper left/top position of bitmap
  302.            Point.X = 0
  303.             Point.Y = 0
  304.  
  305.             'Error Handling
  306.            If TileIndex < 1 Then Exit Property
  307.             If TileIndex > TileCount Then Exit Property
  308.             If TileIndex = 1 And TileCount = 1 Then Exit Property
  309.  
  310.             'Determine X point
  311.            Point.X = TileIndex
  312.             Do While Point.X > columnCnt
  313.                 Point.X -= columnCnt
  314.             Loop
  315.             Point.X -= 1
  316.             Point.X = (TileWidth * Point.X)
  317.  
  318.             'Determine Y point
  319.            Point.Y = TileIndex - 1
  320.             Point.Y = Math.Truncate(Point.Y / columnCnt)
  321.             Point.Y = Point.Y * TileHeight
  322.  
  323.             Return Point
  324.         End Get
  325.     End Property
  326.     Public ReadOnly Property Rectangle(Optional ByVal TileIndex As Integer = 0) As Rectangle
  327.         Get
  328.             'Sets default rectangle to entire bitmap
  329.            Rectangle = New Rectangle(0, 0, clsBitmapImage.Width, clsBitmapImage.Height)
  330.  
  331.             'Error Handling
  332.            If TileIndex < 1 Then Exit Property
  333.             If TileIndex > TileCount Then Exit Property
  334.             If TileIndex = 1 And TileCount = 1 Then Exit Property
  335.  
  336.             'Sets rectangle to the specified tile
  337.            Rectangle = New Rectangle(Point(TileIndex), New Size(TileWidth, TileHeight))
  338.  
  339.             Return Rectangle
  340.         End Get
  341.     End Property
  342.  
  343.     Public Function Tile(ByVal AtPoint As Point) As Integer
  344.         'Passes parameters to primary Tile Function below
  345.        Return Tile(AtPoint.X, AtPoint.Y)
  346.     End Function
  347.     Public Function Tile(ByVal X As Integer, ByVal Y As Integer) As Integer
  348.         'Determines which tile the X,Y values reside in.  If 0 is returned, X,Y values are outside of bitmap area
  349.        Tile = 0
  350.  
  351.         'Error Handling
  352.        If X < 0 Or Y < 0 Then Exit Function
  353.         'In the event the bitmap is larger than the tiled area, class does not check against bitmap.height/width properties
  354.        If X >= (TileWidth * columnCnt) Or Y >= (TileHeight * rowCnt) Then Exit Function
  355.  
  356.         'At this point, we know that a valid point within the bitmap was passed
  357.        Tile = 1
  358.         If TileCount = 1 Then Exit Function
  359.  
  360.         Dim thisColumn As Integer
  361.         Dim thisRow As Integer
  362.  
  363.         thisColumn = Math.Truncate(X / TileWidth)
  364.         thisRow = Math.Truncate(Y / TileHeight)
  365.  
  366.         Tile = (thisRow * columnCnt) + thisColumn + 1
  367.     End Function
  368.  
  369.     Public Function TileNeighbor(ByVal TileIndex As Integer, ByVal MoveTo As Direction, Optional ByVal StepCount As Integer = 1) As Integer
  370.         'Return the tile index of the tile directly next to this position
  371.        'StepCount is how many tiles it steps in the specified direction
  372.        Dim pntInTile As Point
  373.  
  374.         TileNeighbor = 0
  375.  
  376.         'Error Handling
  377.        If TileIndex < 1 Then Exit Function
  378.         If TileIndex > TileCount Then Exit Function
  379.         If TileIndex = 1 And TileCount = 1 Then Exit Function
  380.         If StepCount > columnCnt And StepCount > rowCnt Then Exit Function
  381.         If StepCount < 1 Then StepCount = 1
  382.  
  383.         'Get the point value of the TileIndex
  384.        pntInTile = Point(TileIndex)
  385.  
  386.         'Add to either the X or Y values of the point value to move to a neighboring tile
  387.        For clsI As Integer = 1 To StepCount
  388.             Select Case MoveTo
  389.                 Case Direction.North
  390.                     pntInTile.Y -= TileHeight
  391.                 Case Direction.NorthEast
  392.                     pntInTile.X += TileWidth
  393.                     pntInTile.Y -= TileHeight
  394.                 Case Direction.East
  395.  
  396.                     pntInTile.X += TileWidth
  397.                 Case Direction.SouthEast
  398.                     pntInTile.X += TileWidth
  399.                     pntInTile.Y += TileHeight
  400.                 Case Direction.South
  401.                     pntInTile.Y += TileHeight
  402.                 Case Direction.SouthWest
  403.                     pntInTile.X -= TileWidth
  404.                     pntInTile.Y += TileHeight
  405.                 Case Direction.West
  406.                     pntInTile.X -= TileWidth
  407.                 Case Direction.NorthWest
  408.                     pntInTile.X -= TileWidth
  409.                     pntInTile.Y -= TileHeight
  410.             End Select
  411.         Next
  412.  
  413.         'Check to see if is a valid tile (will return 0 if not)
  414.        TileNeighbor = Tile(pntInTile)
  415.  
  416.     End Function
  417.  
  418.  
  419.  
  420.  
  421.     ''' <summary>
  422.    ''' Functions and Subroutines
  423.    '''  : Primary workings of the class module
  424.    ''' </summary>
  425.    ''' <remarks></remarks>
  426.    Public Sub DrawTileLines()
  427.         'Passes parameters to primary function below
  428.        DrawTileLines(Color.Black)
  429.     End Sub
  430.     Public Sub DrawTileLines(ByVal LineColor As Color, Optional ByVal HideBorder As Boolean = False)
  431.         'Will draw lines onto the bitmap
  432.  
  433.         'Tiles are considered directly next to each other, so technically there is no boundary between tiles
  434.        'The border pixels of each tile will be drawn over when this subroutine is called
  435.  
  436.         Dim defPen As Pen
  437.         Dim point1 As Point
  438.         Dim point2 As Point
  439.  
  440.         'Default Pen is defined
  441.        defPen = New Pen(LineColor, 1)
  442.  
  443.         'Draw column lines
  444.        For c As Long = 0 To columnCnt
  445.             If HideBorder = True And (c = 0 Or c = columnCnt) Then
  446.                 'Do not draw first or last column lines
  447.            Else
  448.                 'Set starting point to draw column lines
  449.                point1.X = (TileWidth * c)
  450.                 point1.Y = 0
  451.  
  452.                 'Set ending point to draw column lines
  453.                point2.X = point1.X
  454.                 point2.Y = (TileHeight * rowCnt)
  455.  
  456.                 'Draw each column line
  457.                If c <> columnCnt Then
  458.                     clsGraphicsBuffer.DrawLine(defPen, point1.X, point1.Y, point2.X, point2.Y - 1)
  459.                 Else
  460.                     'Draw last line 1 pixel to the left
  461.                    clsGraphicsBuffer.DrawLine(defPen, point1.X - 1, point1.Y, point2.X - 1, point2.Y - 1)
  462.                 End If
  463.             End If
  464.         Next
  465.  
  466.         'Draw row lines
  467.        For r As Long = 0 To rowCnt
  468.             If HideBorder = True And (r = 0 Or r = rowCnt) Then
  469.                 'Do not draw first or last row lines
  470.            Else
  471.                 'Set starting point to draw row lines
  472.                point1.X = 0
  473.                 point1.Y = (TileHeight * r)
  474.  
  475.                 'Set ending point to draw row lines
  476.                point2.X = (TileWidth * columnCnt)
  477.                 point2.Y = point1.Y
  478.  
  479.                 'Draw each row line
  480.                If r <> rowCnt Then
  481.                     clsGraphicsBuffer.DrawLine(defPen, point1.X, point1.Y, point2.X - 1, point2.Y)
  482.                 Else
  483.                     'Draw last line 1 pixel higher
  484.                    clsGraphicsBuffer.DrawLine(defPen, point1.X, point1.Y - 1, point2.X - 1, point2.Y - 1)
  485.                 End If
  486.             End If
  487.         Next
  488.     End Sub
  489.     Public Sub MakeTransparent()
  490.         MakeTransparent(Color.Magenta)
  491.     End Sub
  492.     Public Sub MakeTransparent(ByVal transparentColor As Color)
  493.         clsBitmapImage.MakeTransparent(transparentColor)
  494.     End Sub
  495.     Public Sub AlphaBlend(Optional ByVal Alpha As Integer = 75)
  496.         Dim i As Integer
  497.         Dim j As Integer
  498.         Dim clr As Color
  499.         Dim newClr As Color
  500.         For i = 0 To clsBitmapImage.Width - 1
  501.             For j = 0 To clsBitmapImage.Height - 1
  502.                 clr = clsBitmapImage.GetPixel(i, j)
  503.                 newClr = Color.FromArgb(Alpha, clr.R, clr.G, clr.B)
  504.                 clsBitmapImage.SetPixel(i, j, newClr)
  505.             Next
  506.         Next
  507.     End Sub
  508.     Public Sub Text(ByVal txtString As String, ByVal printBox As Rectangle, ByVal useFont As Font, ByVal useBrush As Brush)
  509.         Dim strFormat As New StringFormat
  510.  
  511.         strFormat.Alignment = StringAlignment.Center
  512.         strFormat.LineAlignment = StringAlignment.Center
  513.  
  514.         clsGraphicsBuffer.DrawString(txtString, useFont, useBrush, printBox, strFormat)
  515.     End Sub
  516.     Public Sub FillTile(ByVal X As Integer, ByVal Y As Integer, ByVal fillColor As Color, Optional ByVal OutlineOnly As Boolean = False)
  517.         'Passes parameters to primary FillTile Function below
  518.        FillTile(Tile(X, Y), fillColor, OutlineOnly)
  519.     End Sub
  520.     Public Sub FillTile(ByVal TileIndex As Integer, ByVal fillColor As Color, Optional ByVal OutlineOnly As Boolean = False)
  521.         'Fills the specified tile with a solid color; optional outline only
  522.        Dim outlinePen As Pen
  523.  
  524.         'Error Handling
  525.        If TileIndex < 1 Then Exit Sub
  526.         If TileIndex > TileCount Then Exit Sub
  527.  
  528.         outlinePen = New Pen(fillColor)
  529.  
  530.         clsGraphicsBuffer.DrawRectangle(outlinePen, Rectangle(TileIndex))
  531.  
  532.         If OutlineOnly = True Then Exit Sub
  533.  
  534.         clsGraphicsBuffer.FillRectangle(New SolidBrush(fillColor), Rectangle(TileIndex))
  535.  
  536.     End Sub
  537.     Public Sub FloodFill(ByVal X As Integer, ByVal Y As Integer, ByVal newColor As Color)
  538.         'Passes parameters to primary FloodFill subroutine below
  539.        Dim clsAPoint As Point
  540.         clsAPoint.X = X
  541.         clsAPoint.Y = Y
  542.         FloodFill(clsAPoint, newColor)
  543.     End Sub
  544.     Public Sub FloodFill(ByVal AtPoint As Point, ByVal newColor As Color)
  545.         Dim oldColor As Color = clsBitmapImage.GetPixel(AtPoint.X, AtPoint.Y)
  546.  
  547.         If oldColor.ToArgb <> newColor.ToArgb Then
  548.             Dim pts As New Stack(1000)
  549.             pts.Push(New Point(AtPoint.X, AtPoint.Y))
  550.             clsBitmapImage.SetPixel(AtPoint.X, AtPoint.Y, newColor)
  551.  
  552.             Do While pts.Count > 0
  553.                 Dim pt As Point = DirectCast(pts.Pop(), Point)
  554.  
  555.                 If pt.X > 0 Then ProcessPoint(pts, pt.X - 1, pt.Y, oldColor, newColor)
  556.                 If pt.Y > 0 Then ProcessPoint(pts, pt.X, pt.Y - 1, oldColor, newColor)
  557.                 If pt.X < clsBitmapImage.Width - 1 Then ProcessPoint(pts, pt.X + 1, pt.Y, oldColor, newColor)
  558.                 If pt.Y < clsBitmapImage.Height - 1 Then ProcessPoint(pts, pt.X, pt.Y + 1, oldColor, newColor)
  559.             Loop
  560.  
  561.         End If
  562.     End Sub
  563.     Private Sub ProcessPoint(ByVal pts As Stack, ByVal X As Integer, ByVal Y As Integer, ByVal oldColor As Color, ByVal newColor As Color)
  564.         Dim clr As Color = clsBitmapImage.GetPixel(X, Y)
  565.         If clr.Equals(oldColor) Then
  566.             pts.Push(New Point(X, Y))
  567.             clsBitmapImage.SetPixel(X, Y, newColor)
  568.         End If
  569.     End Sub
  570.  
  571.  
  572.     Public Sub ImageStore()
  573.         clsBitmapMemory = New Bitmap(clsBitmapImage)
  574.     End Sub
  575.     Public Sub ImageRestore()
  576.         DrawOnSurface(clsBitmapMemory, New Rectangle(0, 0, clsBitmapMemory.Width, clsBitmapMemory.Height), Rectangle, False)
  577.     End Sub
  578.  
  579.     ''' <summary>
  580.    ''' Basic Class Properties
  581.    ''' </summary>
  582.    ''' <value></value>
  583.    ''' <returns></returns>
  584.    ''' <remarks></remarks>
  585.    Public ReadOnly Property Exists() As Boolean
  586.         Get
  587.             Exists = doesExist
  588.         End Get
  589.     End Property
  590.     Public ReadOnly Property Bitmap As Bitmap
  591.         Get
  592.             Bitmap = clsBitmapImage
  593.         End Get
  594.     End Property
  595.     Public ReadOnly Property Surface As Graphics
  596.         Get
  597.             Surface = clsGraphicsBuffer
  598.         End Get
  599.     End Property
  600.     Public ReadOnly Property FileName As String
  601.         Get
  602.             FileName = vbNullString
  603.             If bmpFileName <> vbNullString Then FileName = bmpFileName
  604.         End Get
  605.     End Property
  606.     Public Sub Clear()
  607.         Clear(Color.White)
  608.     End Sub
  609.     Public Sub Clear(ByVal clrColor As Color, Optional ByVal transparentFill As Boolean = False)
  610.         Dim fillPen As Pen
  611.         fillPen = New Pen(clrColor)
  612.         clsGraphicsBuffer.FillRectangle(New SolidBrush(clrColor), New Rectangle(0, 0, clsBitmapImage.Width, clsBitmapImage.Height))
  613.         If transparentFill = True Then FloodFill(Point(1), Color.FromArgb(0, 255, 255, 255))
  614.     End Sub
  615.     Public Sub Dispose()
  616.         clsGraphicsBuffer.Dispose()
  617.         clsBitmapImage.Dispose()
  618.         doesExist = False
  619.     End Sub
  620.  
  621.     ''' <summary>
  622.    ''' PATH FINDING VARIABLES, ALGORITHM, AND FUNCTIONS START HERE
  623.    ''' </summary>
  624.    ''' <remarks></remarks>
  625.    Private Enum NodeStatus
  626.         Closed = 0
  627.         Open = 1
  628.         NotEvaluated = 2
  629.     End Enum
  630.     Private Structure Node
  631.         Dim ParentNode As Integer 'Index of parent node
  632.        Dim MoveCost As Integer 'Pulled from MovementCost()
  633.        Dim ScoreG As Integer 'Movement cost from start point to this node
  634.        Dim ScoreH As Integer 'Best guess movement cost from this node to end point
  635.        Dim ScoreF As Integer 'Sum of ScoreG and ScoreH (estimated total movement cost from start to end point)
  636.        Dim Status As NodeStatus 'Determines if node is in the closed or opened list
  637.    End Structure
  638.     Private ANode() As Node
  639.  
  640.     Public Function FindPath(ByVal MovementCost() As Integer, ByVal StartNode As Integer, ByVal EndNode As Integer, Optional ByVal allowDiagonalMoves As Boolean = True) As Boolean
  641.  
  642.         FindPath = False 'If false, no path has been found or bad data has been passed to FindPath function
  643.  
  644.         'Error catching
  645.        If TileCount <= 1 Then Exit Function 'no grid properties have been defined
  646.        If StartNode < 1 Then Exit Function 'node outside the grid area
  647.        If StartNode > TileCount Then Exit Function 'node outside the grid area
  648.        If EndNode < 1 Then Exit Function 'node outside the grid area
  649.        If EndNode > TileCount Then Exit Function 'node outside the grid area
  650.        If UBound(MovementCost) <> TileCount Then Exit Function 'movement cost count doesn't match tile count
  651.  
  652.         'Create nodes based on grid dimensions and transfer data from MovementCost()
  653.        ReDim ANode(TileCount)
  654.         'Ignore ANode(0) to ensure nodes equal the grid dimensions exactly as used in the DynamicBitmap class (grid tiles start on 1, not 0)
  655.        For i As Integer = 1 To TileCount
  656.             ANode(i).MoveCost = MovementCost(i)
  657.             ANode(i).Status = NodeStatus.NotEvaluated
  658.         Next
  659.  
  660.         'Reset solution path in case it was previously populated
  661.        ReDim Path(0)
  662.         Path(0) = 0
  663.  
  664.         'Add the start node to the open list
  665.        ANode(StartNode).Status = NodeStatus.Open
  666.  
  667.         'Determine the F score for the start node
  668.        'The ComputeScore function "by references" the Node, so values are changed without having to use the '=' sign
  669.        ComputeScore(StartNode, EndNode, allowDiagonalMoves)
  670.  
  671.  
  672.         'Determine which neighbors to view (vertical/horizontal only or include diagonal neighbors)
  673.        'Values relate directly to "Direction" enum (See "Public Enum Direction" at top of DymamicBitmap class for more info)
  674.        Dim neighborCnt As Integer = 3 'Directions 0 to 3
  675.        If allowDiagonalMoves = True Then neighborCnt = 7 'Directions 0 to 7
  676.  
  677.         'Initalize variables
  678.        Dim thisNode As Integer 'The current node we are working with
  679.        Dim thisNeighbor As Integer 'The current neighbor of current node we are working with
  680.  
  681.  
  682.         'Begin the main A* pathfinding operations
  683.        Do
  684.             'Get the node with the lowest F score
  685.            thisNode = LowestF()
  686.  
  687.             'If thisNode = 0, then there are no more open nodes (no path found)
  688.            If thisNode = 0 Then Exit Function
  689.  
  690.             'Move thisNode to the closed list
  691.            ANode(thisNode).Status = NodeStatus.Closed
  692.  
  693.             'Check to see if thisNode is the target node.  If it is, exit the loop (path found)
  694.            If thisNode = EndNode Then Exit Do
  695.  
  696.             'Go through each neighbor of 'thisNode'
  697.            For aNeighbor = 0 To neighborCnt
  698.                 thisNeighbor = TileNeighbor(thisNode, aNeighbor)
  699.  
  700.                 'If thisNeighbor = 0, then it's outside the grid
  701.                'If the movement cost of thisNeighbor = 0, then it's a wall or other obstacle that can't be passed over
  702.                'If thisNeighbor is on the closed list, ignore it
  703.                If thisNeighbor <> 0 And ANode(thisNeighbor).MoveCost <> 0 And ANode(thisNeighbor).Status <> NodeStatus.Closed Then
  704.  
  705.  
  706.                     'If this neighbor is already on the open list, check to see if this route would be better
  707.                    'In other words, check to see if it's G score would be lower using thisNode as it's parent
  708.                    If ANode(thisNeighbor).Status = NodeStatus.Open Then
  709.  
  710.                         'Temporary save the data from thisNeighbor so we can evaluate it against thisNode as it's parent
  711.                        Dim tempNode As Node
  712.                         tempNode = ANode(thisNeighbor)
  713.  
  714.                         'Calcuate the new scores based on thisNode as it's parent
  715.                        ANode(thisNeighbor).ParentNode = thisNode
  716.                         ComputeScore(thisNeighbor, EndNode, allowDiagonalMoves)
  717.  
  718.                         'Compare the two G values
  719.                        'If the new G score is higher than the original G score (longer route), restore thisNeighbor's original properties from tempNode
  720.                        'If the new G score is lower (faster route) then leave the changes that were made in the previous step
  721.                        If ANode(thisNeighbor).ScoreG >= tempNode.ScoreG Then ANode(thisNeighbor) = tempNode
  722.  
  723.                     Else
  724.                         'This neighbor has not yet been examined by any other node
  725.                        'This is a possible route; add this neighbor to the open list, set thisNode as it's parent, and calculate F score
  726.                        ANode(thisNeighbor).Status = NodeStatus.Open
  727.                         ANode(thisNeighbor).ParentNode = thisNode
  728.                         ComputeScore(thisNeighbor, EndNode, allowDiagonalMoves)
  729.  
  730.                     End If
  731.  
  732.                 End If
  733.             Next
  734.         Loop
  735.  
  736.  
  737.         'PATH HAS BEEN FOUND
  738.  
  739.  
  740.         'Work backwards from the end node to determine our path and populate it into a temporary array
  741.        Dim ReversePath() As Integer
  742.         Dim Xcounter As Integer = 0
  743.         thisNode = EndNode
  744.         Do
  745.             'Count each node and populate it into a temporary array
  746.            Xcounter = Xcounter + 1
  747.             ReDim Preserve ReversePath(Xcounter - 1)
  748.             ReversePath(Xcounter - 1) = thisNode
  749.  
  750.             'If we've reached the start node, exit loop
  751.            If thisNode = StartNode Then Exit Do
  752.  
  753.             'Set the next 'thisNode' to the parent of the node we are on (work backwards until the start node is reached)
  754.            thisNode = ANode(thisNode).ParentNode
  755.         Loop
  756.  
  757.  
  758.         'Reverse the order of our path so that Path(0) = startNode and Ubound(Path) = endNode
  759.        ReDim Path(Xcounter - 1)
  760.         For theNextNode As Integer = 0 To Xcounter - 1
  761.             Path(theNextNode) = ReversePath(UBound(ReversePath) - theNextNode)
  762.         Next
  763.  
  764.         FindPath = True
  765.  
  766.     End Function
  767.     Private Function LowestF() As Integer
  768.         'Returns the node with the lowest F score on the Open list
  769.        Dim chkScore As Integer
  770.         Dim lowScore As Integer
  771.  
  772.         LowestF = 0
  773.  
  774.         'Set our lowScore large enough that the first node evaluated will become our default first low score
  775.        lowScore = 32767
  776.  
  777.  
  778.         'Evaluate each of the nodes
  779.        For iNode As Integer = 1 To TileCount
  780.             'Compare open list nodes with the current lowest score
  781.            If ANode(iNode).Status = NodeStatus.Open Then
  782.  
  783.                 'If the current nodes F score is lower, change it to the current lowest node
  784.                chkScore = ANode(iNode).ScoreF
  785.                 If chkScore <= lowScore Then
  786.                     LowestF = iNode
  787.                     lowScore = chkScore
  788.                 End If
  789.             End If
  790.         Next
  791.  
  792.         'If LowestF = 0, then there were no open nodes
  793.    End Function
  794.     Private Sub ComputeScore(ByRef computeNode As Integer, ByVal ENode As Integer, ByVal ad As Boolean)
  795.         'Determines the G, H, and F values of the argument node
  796.  
  797.         'DETERMINE G VALUE
  798.        ANode(computeNode).ScoreG = 0
  799.         'If the node has no parent, value G is 0
  800.        If ANode(computeNode).ParentNode <> 0 Then
  801.  
  802.             'Set the G value of the node equal to it's parents G value
  803.            ANode(computeNode).ScoreG = ANode(ANode(computeNode).ParentNode).ScoreG
  804.  
  805.  
  806.             'If the parent is on the same row or column, increase G value
  807.            'by 10 * the movement cost of this node
  808.            If TileRow(ANode(computeNode).ParentNode) = TileRow(computeNode) Or _
  809.                     TileColumn(ANode(computeNode).ParentNode) = TileColumn(computeNode) Then
  810.  
  811.                 ANode(computeNode).ScoreG = ANode(computeNode).ScoreG + (10 * ANode(computeNode).MoveCost)
  812.  
  813.             Else
  814.  
  815.                 'If the parent isn't on the same row or column, it is diagonal from this node;
  816.                'increase G value by 14 * the movement cost of this node if diagonal moves are allowed
  817.                If ad = True Then ANode(computeNode).ScoreG = ANode(computeNode).ScoreG + (14 * ANode(computeNode).MoveCost)
  818.  
  819.                 'If diagonal moves are not allowed, this movement will take both a horizontal and vertical move to reach (x20)
  820.                If ad = False Then ANode(computeNode).ScoreG = ANode(computeNode).ScoreG + (20 * ANode(computeNode).MoveCost)
  821.  
  822.             End If
  823.  
  824.         End If
  825.  
  826.  
  827.         'DETERMINE H VALUE
  828.        ANode(computeNode).ScoreH = 0
  829.  
  830.         Dim tmpRowDist As Integer
  831.         Dim tmpColDist As Integer
  832.  
  833.         'Get the row and column distance from this node to the end node
  834.        tmpRowDist = Math.Abs(TileRow(computeNode) - TileRow(ENode))
  835.         tmpColDist = Math.Abs(TileColumn(computeNode) - TileColumn(ENode))
  836.  
  837.         'Compute H value based on estimated distance to end node
  838.        If tmpRowDist < tmpColDist Then
  839.             ANode(computeNode).ScoreH = (4 * tmpRowDist) + (10 * tmpColDist)
  840.         Else
  841.             ANode(computeNode).ScoreH = (10 * tmpRowDist) + (4 * tmpColDist)
  842.         End If
  843.  
  844.         'DETERMINE F VALUE
  845.        'Add the distance from the start node (G)
  846.        'to the estimated distance to the end node (H)
  847.        ANode(computeNode).ScoreF = ANode(computeNode).ScoreG + ANode(computeNode).ScoreH
  848.     End Sub
  849.     Public Function TileRow(ByVal TileIndex As Integer) As Integer
  850.         'Returns the row this tile is located on
  851.        TileRow = Math.Truncate((TileIndex - 1) / columnCnt) + 1
  852.     End Function
  853.     Public Function TileColumn(ByVal TileIndex As Integer) As Integer
  854.         'Returns the column this tile is located on
  855.        TileColumn = ((TileIndex - 1) Mod columnCnt) + 1
  856.         If TileIndex <= columnCnt Then TileColumn = TileIndex
  857.     End Function
  858.  
  859.  
  860.  
  861.  
  862. End Class
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement