Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.EditorInput
Imports System
' This line is not mandatory, but improves loading performance
<Assembly: CommandClass(GetType(Minesweeper.MyCommands))>
Namespace Minesweeper
Public Class MyCommands
'This is the main Minesweeper command.
'It createas a new document, and invokes the worker
'command(RUNMINESWEEPER) in the new document.
<CommandMethod(
"SGP_Minesweeper", "MINESWEEPER", "MINESWEEPER",
CommandFlags.Session
)>
Public Shared Sub Minesweeper()
Dim doc As Document = Application.DocumentManager.Add("")
Application.DocumentManager.MdiActiveDocument = doc
doc.SendStringToExecute("RUNMINESWEEPER ", True, False, False)
End Sub
'This is the worker command invoked usign SendStringToExecute
'It starts the game running in the new doc created by the
' MINESWEEPER command.
<CommandMethod(
"SGP_Minesweeper", "RUNMINESWEEPER", CommandFlags.Modal
)>
Public Shared Sub RunMinesweeper()
Try
'Make sure new document has the text style we need
DefineTextStyle()
'Instantiate the game controller class and set game running
Dim cls As New AcadMinesweeper
cls.DoIt()
Catch ex As Autodesk.AutoCAD.Runtime.Exception
Application.DocumentManager.MdiActiveDocument.Editor.
WriteMessage(vbCrLf &
"Sorry - An error occurred. Game aborted." & vbCrLf)
End Try
End Sub
'Adds a new text style to the drawing (if not already there)
Private Shared Sub DefineTextStyle()
Dim db As Database = HostApplicationServices.WorkingDatabase
Dim tm As Autodesk.AutoCAD.DatabaseServices.TransactionManager
tm = db.TransactionManager
Dim myT As Transaction = tm.StartTransaction()
Try
Dim st As TextStyleTable =
CType(
tm.GetObject(
db.TextStyleTableId, OpenMode.ForWrite, False),
TextStyleTable)
If Not st.Has("MinesweeperStyle") Then
Dim str As TextStyleTableRecord =
New TextStyleTableRecord()
str.Name = "MinesweeperStyle"
st.Add(str)
str.FileName = "txt.shx"
str.TextSize = 1.0
str.IsShapeFile = True
tm.AddNewlyCreatedDBObject(str, True)
End If
myT.Commit()
Finally
myT.Dispose()
End Try
End Sub
End Class
'This class governs our logic in AutoCAD.
'It uses the MinesweeperMgr class to hold/query/edit the game data.
'(Really needs a little more work to push more of the game logic
'to Minesweeper Mgr).
Public Class AcadMinesweeper
'Links ObjectId of MText representing a mine cell to the row and
' column of the mine cell it represents
Private Structure MineElement
Public Id As ObjectId
Public Row As Integer
Public Col As Integer
End Structure
Private mMineMgr As New MinesweeperMgr 'Our manager class
Private mMinefield() As MineElement ' Array of ObjectIds relating
' MText to their row and col
'Main game controller function
Public Sub DoIt()
Dim ed As Editor =
Application.DocumentManager.MdiActiveDocument.Editor
'Prompt user for values to setup minefield
If Not PromptSetup() Then
ed.WriteMessage(
vbCrLf & "You cancelled setup - aborting command" & vbCrLf)
Exit Sub
End If
'Tell manager class to setup its grid
'I'm use this MinesweeperMgr class to keep the game data
'(in MinesweeperMgr) separated from the UI logic
'(in AcadMinesweeper), so I can re-use it in other apps
mMineMgr.InitMinefield()
'Transfer calculated grid from the manager to the current
'document/drawing
If Not SetupGrid() Then
ed.WriteMessage(
vbCrLf & "There was a problem setting up the minefield" &
" - aborting command" & vbCrLf)
Exit Sub
End If
Dim startTime As DateTime = DateTime.Now
' The game loop
While PromptMineAction()
End While
' Game over - tell user how long the game lasted.
Dim timeInterval As TimeSpan = DateTime.Now - startTime
ed.WriteMessage(
vbCrLf & "Time taken = " & timeInterval.TotalSeconds &
" seconds" & vbCrLf)
End Sub
' Prompt user to perform an action - clear/mark/unmark a cell
' in the minefield
Private Function PromptMineAction() As Boolean
'bMarking governs behavior depending on whether we're
'clearing mines or marking them
Static bMarking As Integer
Dim strMsg As String = ""
Dim strKeyword As String = ""
'Setup prompts and keywords according to bMarking
Select Case bMarking
Case False
strMsg = "Select a cell to uncover:"
strKeyword = "Mark"
Case True
strMsg = "Select a cell to mark/unmark:"
strKeyword = "Uncover"
End Select
'Prompt user to perform action
Dim ed As Editor =
Application.DocumentManager.MdiActiveDocument.Editor
Dim opts As New PromptEntityOptions(vbCrLf & strMsg)
opts.Keywords.Add(strKeyword)
opts.AppendKeywordsToMessage = True
opts.AllowNone = True
Dim res As PromptEntityResult = ed.GetEntity(opts)
'If user cancelled the command prompt then we end the game
'(returning false ends the game loop).
If res.Status = PromptStatus.Cancel Then
ed.WriteMessage(
vbCrLf & "You cancelled the game. Byeee!" & vbCrLf)
Return False
End If
' Don't let user escape command by pressing enter -
' just loop around again
If res.Status = PromptStatus.None Then
Return True
End If
'If user entered keyword, then we're toggling between
' mine clearing and mine marking
If res.Status = PromptStatus.Keyword Then
Select Case res.StringResult
Case "Mark"
bMarking = True
Case Else
bMarking = False
End Select
Return True
'If user selected an entity (which must be MText
' because this is a new document, and that's all
' we added to it), then we use the ObjectId to
' retrieve its row and column in the grid.
ElseIf res.Status = PromptStatus.OK Then
Dim elem As MineElement = FindInMinefield(res.ObjectId)
'This next if statement should never be used.
If elem.Id = ObjectId.Null Then
ed.WriteMessage(
vbCrLf & "You didn't select a cell in the minefield." &
vbCrLf)
Return True
End If
'Check they didn't pick on a cell they already uncovered.
If mMineMgr.CellIsUnCovered(elem.Row, elem.Col) Then
ed.WriteMessage(
vbCrLf & "This cell is already uncovered. " &
"Pick another." & vbCrLf)
Return True
End If
'If we got to here, then MText was picked, it is in the
'grid, and it isn't uncovered yet.
'If we're marking cells ...
If bMarking Then
'MarkCell toggles mark status
Dim oldCellVal As MineCell =
mMineMgr.MarkCell(elem.Row, elem.Col)
If oldCellVal.Status = CellStatus.Covered Then
'If cell was marked then we unmark it
If oldCellVal.Status = CellStatus.Marked Then
SetText(elem.Id, "X")
Else 'If cell wasn't marked, we mark it.
SetText(elem.Id, "M")
End If
'Go to next loop iteration
Return True
End If
Else 'If we're clearing cells
Dim oldCellVal As MineCell =
mMineMgr.UncoverCell(elem.Row, elem.Col)
If oldCellVal.isBomb Then
'We hit a bomb - game over
SetText(elem.Id, "*")
ed.WriteMessage(
vbCrLf & "You hit a mine. Game Over!." & vbCrLf)
Return False
Else
' It wasn't a bomb
SetText(elem.Id, oldCellVal.Value.ToString)
' If we've cleared all cells except the bombs,
' then we won - game over.
If mMineMgr.AllEmptyCellsUncovered Then
ed.WriteMessage(
vbCrLf & "Congratulations. " &
"You cleared all the mines." & vbCrLf)
Return False
Else 'Carry on game
Return True
End If
End If
End If
End If
End Function
'Set the text for an MText entity with the provided ObjectId
Private Sub SetText(
ByVal objId As ObjectId, ByVal strText As String)
Dim db As Database =
Application.DocumentManager.MdiActiveDocument.Database
Using tr As Transaction =
db.TransactionManager.StartTransaction
Dim txt As MText = tr.GetObject(objId, OpenMode.ForWrite)
txt.Contents = strText
tr.Commit()
End Using
End Sub
'Retrieve text from the MText entity with the provided ObjectId
Private Function GetText(ByVal objId As ObjectId)
Dim strText As String
Dim db As Database =
Application.DocumentManager.MdiActiveDocument.Database
Using tr As Transaction =
db.TransactionManager.StartTransaction
Dim txt As MText = tr.GetObject(objId, OpenMode.ForRead)
strText = txt.Contents
tr.Commit()
End Using
Return strText
End Function
' Find MineElement with provided ObjectId in our array of all
' mine cells. This is how we asociate row and column value
' with an MText entity
Private Function FindInMinefield(
ByVal objId As ObjectId) As MineElement
For Each elem As MineElement In mMinefield
If elem.Id = objId Then
Return elem
End If
Next
'If we didn't find it, we return a blank - calling function
'should query for null ObjectId
Return New MineElement
End Function
'Create all the MText entities in our grid and zoom to fill
'screen
Private Function SetupGrid() As Boolean
Dim bFlag As Boolean = False
Dim db As Database =
Application.DocumentManager.MdiActiveDocument.Database
Try
Using tr As Transaction =
db.TransactionManager.StartTransaction
Dim tst As TextStyleTable =
tr.GetObject(db.TextStyleTableId, OpenMode.ForRead)
Dim textStyleId As ObjectId = tst.Item("MinesweeperStyle")
Dim btr As BlockTableRecord =
CType(
tr.GetObject(
SymbolUtilityServices.GetBlockModelSpaceId(db),
OpenMode.ForWrite),
BlockTableRecord)
Dim rows As Integer = mMineMgr.MinefieldRows
Dim cols As Integer = mMineMgr.MinefieldColumns
ReDim mMinefield(rows * cols - 1)
For i As Integer = 0 To rows - 1
For j = 0 To cols - 1
Using txt As MText = New MText
txt.SetDatabaseDefaults()
txt.TextStyleId = textStyleId
txt.Location = New Point3d(i, j, 0)
txt.Width = 1.0
txt.Height = 1.0
txt.TextHeight = 0.8
txt.Attachment = AttachmentPoint.MiddleCenter
mMinefield(i * rows + j).Id = btr.AppendEntity(txt)
mMinefield(i * rows + j).Row = i
mMinefield(i * rows + j).Col = j
txt.Contents = "X"
tr.AddNewlyCreatedDBObject(txt, True)
End Using
Next
Next
tr.Commit()
ModelZoomExtents()
End Using
bFlag = True
Catch ex As Autodesk.AutoCAD.Runtime.Exception
bFlag = False
End Try
' If bFlag is true, then all mtexts were added to
'DB without problem
Return bFlag
End Function
'Prompt user for grid size and number of mines, and pass those
'to the MinesweeperMgr to initialize itself
Private Function PromptSetup() As Boolean
Dim ed As Editor =
Application.DocumentManager.MdiActiveDocument.Editor
Dim opts1 As New PromptIntegerOptions(
"Enter Minefield width:")
opts1.LowerLimit = 1
opts1.UpperLimit = 100
opts1.DefaultValue = 10
Dim res1 As PromptIntegerResult = ed.GetInteger(opts1)
If res1.Status <> PromptStatus.OK Then
Return False
End If
mMineMgr.MinefieldRows = res1.Value
opts1.Message = "Enter minefield height:"
res1 = ed.GetInteger(opts1)
If res1.Status <> PromptStatus.OK Then
Return False
End If
mMineMgr.MinefieldColumns = res1.Value
opts1.Message = "Enter number of mines:"
opts1.UpperLimit =
mMineMgr.MinefieldRows * mMineMgr.MinefieldColumns
opts1.DefaultValue =
mMineMgr.MinefieldRows * mMineMgr.MinefieldColumns / 6
res1 = ed.GetInteger(opts1)
If res1.Status <> PromptStatus.OK Then
Return False
End If
mMineMgr.NumMines = res1.Value
Return True
End Function
'The next two functions are helper functions to zoom to the grid.
'Code copied from ADN DevNote
Public Sub SetViewportToExtents(
ByVal db As Database, ByVal vtr As ViewportTableRecord)
'Let's update the database extents first
'True gives the best fit but will take time
db.UpdateExt(True)
'Get the screen aspect ratio to calculate the height and width
Dim scrRatio As Double = (vtr.Width / vtr.Height)
'Prepare Matrix for DCS to WCS transformation
Dim matWCS2DCS As Matrix3d =
Matrix3d.PlaneToWorld(vtr.ViewDirection)
'For DCS target point is the origin
matWCS2DCS =
Matrix3d.Displacement(vtr.Target - Point3d.Origin) *
matWCS2DCS
'WCS Xaxis is twisted by twist angle
matWCS2DCS =
Matrix3d.Rotation(
-vtr.ViewTwist, vtr.ViewDirection, vtr.Target) *
matWCS2DCS
matWCS2DCS = matWCS2DCS.Inverse()
'Tranform the extents to the DCS defined by the viewdir
Dim extents As New Extents3d(db.Extmin, db.Extmax)
extents.TransformBy(matWCS2DCS)
'Width of the extents in current view
Dim width As Double =
(extents.MaxPoint.X - extents.MinPoint.X)
'Height of the extents in current view
Dim height As Double =
(extents.MaxPoint.Y - extents.MinPoint.Y)
'Get the view center point
Dim center As New Point2d(
(extents.MaxPoint.X + extents.MinPoint.X) * 0.5,
(extents.MaxPoint.Y + extents.MinPoint.Y) * 0.5)
'Check if the width 'fits' in current window
'If not then get the new height as per the viewport's
'aspect(ratio)
If width > (height * scrRatio) Then
height = width / scrRatio
End If
vtr.Height = height
vtr.Width = height * scrRatio
vtr.CenterPoint = center
vtr.IconEnabled = False
End Sub
Public Sub ModelZoomExtents()
Dim doc As Document =
Application.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Dim ed As Editor = doc.Editor
Using Tx As Transaction =
db.TransactionManager.StartTransaction()
ed.UpdateTiledViewportsInDatabase()
Dim viewportTableRec As ViewportTableRecord =
TryCast(
Tx.GetObject(
ed.ActiveViewportId, OpenMode.ForWrite),
ViewportTableRecord)
SetViewportToExtents(db, viewportTableRec)
ed.UpdateTiledViewportsFromDatabase()
Tx.Commit()
End Using
End Sub
End Class
End Namespace
Namespace Minesweeper
Public Class MinesweeperException
Inherits Exception
End Class
'Each cell can have one of these three statuses
Public Enum CellStatus
Covered
Uncovered
Marked
End Enum
Public Structure MineCell
Public Sub New(
ByVal status As CellStatus, ByVal val As Integer,
ByVal bomb As Boolean, ByVal marked As Boolean)
status = status
isBomb = bomb
Value = val
End Sub
Public Status As CellStatus 'Covered/Uncovered/Marked
Public Value As Integer 'No of neighboring cells containing bombs
Public isBomb As Boolean 'Is this cell a bomb?
End Structure
Public Class MinesweeperMgr
Private mRows As Integer 'Rows in grid
Private mCols As Integer 'Columns in grid
Private mMineArray(,) As MineCell 'The grid
Private mNumMines As Integer 'Number of mines hidden in grid
Private mNumCellsUncovered 'Number of cells currently uncovered
Public ReadOnly Property NumCellsUncovered() As Integer
Get
Return mNumCellsUncovered
End Get
End Property
Private Function IncrementNumCellsUncovered() As Integer
mNumCellsUncovered = mNumCellsUncovered + 1
Return mNumCellsUncovered
End Function
Public Property MinefieldRows() As Integer
Get
Return mRows
End Get
Set(ByVal value As Integer)
If value > 0 Then
mRows = value
If NumMines > mRows * MinefieldColumns Then
NumMines = mRows * MinefieldColumns
End If
Else
Throw New MinesweeperException
End If
End Set
End Property
Public Property MinefieldColumns() As Integer
Get
Return mCols
End Get
Set(ByVal value As Integer)
If value > 0 Then
mCols = value
If NumMines > MinefieldRows * mCols Then
NumMines = MinefieldRows * mCols
End If
Else
Throw New MinesweeperException
End If
End Set
End Property
Public Property NumMines() As Integer
Get
Return mNumMines
End Get
Set(ByVal value As Integer)
If mNumMines <= (mCols * mRows) Then
mNumMines = value
Else
mNumMines = mCols * mRows
End If
End Set
End Property
Public ReadOnly Property MineArray() As MineCell(,)
Get
Return mMineArray
End Get
End Property
Public Function GetCell(
ByVal row As Integer, ByVal col As Integer) As MineCell
If row >= 0 And row < MinefieldRows And
col >= 0 And col < MinefieldColumns Then
Return mMineArray(row, col)
Else
Throw New MinesweeperException
End If
End Function
Public Function SetCell(
ByVal row As Integer, ByVal col As Integer,
ByVal value As MineCell) As Boolean
If row >= 0 And row < MinefieldRows And
col >= 0 And col < MinefieldColumns Then
mMineArray(row, col) = value
Return True
Else
Throw New MinesweeperException
End If
End Function
Public Function UncoverCell(
ByVal row As Integer, ByVal col As Integer) As MineCell
Dim curCellVal As MineCell = MineArray(row, col)
If curCellVal.Status <> CellStatus.Uncovered Then
MineArray(row, col).Status = CellStatus.Uncovered
IncrementNumCellsUncovered()
End If
Return curCellVal
End Function
'Toggle cell between Covered and Marked Status.
'Does nothing for Uncovered cells.
'Returns previous MineCell values.
Public Function MarkCell(
ByVal row As Integer, ByVal col As Integer) As MineCell
Dim curCellVal As MineCell = MineArray(row, col)
If curCellVal.Status = CellStatus.Covered Then
MineArray(row, col).Status = CellStatus.Marked
ElseIf curCellVal.Status = CellStatus.Marked Then
MineArray(row, col).Status = CellStatus.Covered
End If
Return curCellVal
End Function
'Returns true if cell is uncovered
Public Function CellIsUnCovered(
ByVal row As Integer, ByVal col As Integer) As Boolean
Dim curCellVal As MineCell = MineArray(row, col)
If MineArray(row, col).Status = CellStatus.Uncovered Then
Return True
Else
Return False
End If
End Function
'Returns true if we've cleared all our non-mine cells
Public Function AllEmptyCellsUncovered() As Boolean
Return NumCellsUncovered =
MinefieldColumns * MinefieldRows - NumMines
End Function
Public Sub InitMinefield()
InitMinefield(MinefieldRows, MinefieldColumns, NumMines)
End Sub
Private Sub ResetNumCellsUncovered()
mNumCellsUncovered = 0
End Sub
'Initialize grid, and put the mines in random locations
Public Sub InitMinefield(
ByVal rows As Integer, ByVal cols As Integer,
ByVal num As Integer)
If rows < 1 Or cols < 1 Or num < 1 Then
Throw New MinesweeperException
End If
MinefieldRows = rows
MinefieldColumns = cols
If num > rows * cols Then
NumMines = rows * cols
Else
NumMines = num
End If
ResetNumCellsUncovered()
'Initialize grid (array) to represent minefield
ReDim mMineArray(rows - 1, cols - 1)
' Add mines to grid (value of -1 means a mine is at
' that location)
Randomize()
Dim i As Integer = 0
Do
Dim rndRow As Integer = Rnd() * (MinefieldRows - 1)
Dim rndCol As Integer = Rnd() * (MinefieldColumns - 1)
If mMineArray(rndRow, rndCol).isBomb = False Then
mMineArray(rndRow, rndCol).Value = -1
mMineArray(rndRow, rndCol).isBomb = True
mMineArray(rndRow, rndCol).Status = CellStatus.Covered
i = i + 1
End If
Loop While i < num
' Now mines are added, we populate the rest of the grid
' with the numbers to indicate how many mines are in
' neighbouring(cells)
For i = 0 To MinefieldRows - 1
For j As Integer = 0 To MinefieldColumns - 1
' If this cell contains a mine then don't process it
If mMineArray(i, j).isBomb = True Then
Continue For
End If
Dim mineCounter As Integer = 0
'Check grid cells around this one looking for mines ...
' i-1,j-1 | i,j-1 | i+1,j-1
' i-1,j | i,j | i+1,j
' i-1,j+1 | i,j+1 | i+1,j+1
For k As Integer = -1 To 1
For l As Integer = -1 To 1
' Skip over cells outside bounds of minefield
If (i + k < 0) Or (i + k > MinefieldRows - 1) Or
(j + l < 0) Or (j + l > MinefieldColumns - 1) Then
Continue For
End If
'Don't include cell (i,j)
If k = 0 And l = 0 Then
Continue For
End If
If mMineArray(i + k, j + l).isBomb = True Then
mineCounter = mineCounter + 1
End If
Next
Next
mMineArray(i, j).Value = mineCounter
mMineArray(i, j).Status = CellStatus.Covered
Next
Next
End Sub
End Class
End Namespace
发表于 2011-7-7 17:21:39
置顶卡
变色卡
显身卡