Главная страница Случайная страница КАТЕГОРИИ: АвтомобилиАстрономияБиологияГеографияДом и садДругие языкиДругоеИнформатикаИсторияКультураЛитератураЛогикаМатематикаМедицинаМеталлургияМеханикаОбразованиеОхрана трудаПедагогикаПолитикаПравоПсихологияРелигияРиторикаСоциологияСпортСтроительствоТехнологияТуризмФизикаФилософияФинансыХимияЧерчениеЭкологияЭкономикаЭлектроника |
FrmGame
Public Class frmGame
Class counter Public colour As Char Public x As Integer Public y As Integer Public king As Boolean Public selected As Boolean Public live As Boolean
Public Sub New(nx, ny, ncolour) x = nx y = ny colour = ncolour king = False live = True End Sub
Private Sub kinged() king = True End Sub
Public Sub die() live = False End Sub
Public Sub click() selected = Not (selected) End Sub
Public Sub move(nx, ny) x = nx y = ny
If colour = " W" And y = 0 Then kinged() End If
If colour = " B" And y = 7 Then kinged() End If
End Sub
End Class
Class AI
Public colour As Char Public pieces(23) As Boolean
Public Sub findMoves() If colour = " B" Then For n = 0 To 11 pieces(n) = False
If frmGame.movePossible(frmGame.counters(n)) Then pieces(n) = True End If Next Else For n = 12 To 13 pieces(n) = False
If frmGame.movePossible(frmGame.counters(n)) Then pieces(n) = True End If Next End If End Sub
Public Sub makeMove() Dim temp As Integer
Do temp = GetRandom(0, 23) Loop While pieces(temp) = False
If colour = " B" Then AImoveBlack(temp) Else AImoveWhite(temp) End If
End Sub
Public Sub AImoveBlack(id) Dim tempx, tempy, tox, toy, king As Integer tempx = frmGame.counters(id).x tempy = frmGame.counters(id).y
'give full range of moves if king If frmGame.counters(id).king = True Then king = 3 Else king = 1 End If
If frmGame.jumpPossible(frmGame.counters(id)) Then Do Select Case GetRandom(0, king) Case 0 tox = tempx + 2 toy = tempy + 2 Case 1 tox = tempx - 2 toy = tempy + 2 Case 2 tox = tempx + 2 toy = tempy - 2 Case 3 tox = tempx - 2 toy = tempy - 2 End Select
Loop While frmGame.validMove(frmGame.counters(id), tox, toy) = False Else 'single move Do 'give a random space for the piece to move Select Case GetRandom(0, king) Case 0 tox = tempx + 1 toy = tempy + 1 Case 1 tox = tempx - 1 toy = tempy + 1 Case 2 tox = tempx + 1 toy = tempy - 1 Case 3 tox = tempx - 1 toy = tempy - 1 End Select
Loop While frmGame.validMove(frmGame.counters(id), tox, toy) = False End If
'move the piece to the safe location frmGame.movePiece(tox, toy) End Sub
Public Sub AImoveWhite(id) Dim tempx, tempy, tox, toy, king As Integer tempx = frmGame.counters(id).x tempy = frmGame.counters(id).y
'give full range of moves if king If frmGame.counters(id).king = True Then king = 3 Else king = 1 End If
If frmGame.jumpPossible(frmGame.counters(id)) Then Do Select Case GetRandom(0, king) Case 0 tox = tempx + 2 toy = tempy - 2 Case 1 tox = tempx - 2 toy = tempy - 2 Case 2 tox = tempx + 2 toy = tempy + 2 Case 3 tox = tempx - 2 toy = tempy + 2 End Select
Loop While frmGame.validMove(frmGame.counters(id), tox, toy) = False Else 'single move Do 'give a random space for the piece to move Select Case GetRandom(0, king) Case 0 tox = tempx + 1 toy = tempy - 1 Case 1 tox = tempx - 1 toy = tempy - 1 Case 2 tox = tempx + 1 toy = tempy + 1 Case 3 tox = tempx - 1 toy = tempy + 1 End Select
Loop While frmGame.validMove(frmGame.counters(id), tox, toy) = False End If
'move the piece to the safe location frmGame.movePiece(tox, toy) End Sub
'from https://stackoverflow.com/questions/18676/random-int-in-vb-net Public Function GetRandom(ByVal Min As Integer, ByVal Max As Integer) As Integer Dim Generator As System.Random = New System.Random() Return Generator.Next(Min, Max) End Function End Class
Public counters(23) As counter Dim sqsize As Integer ' size of each piece on the board Dim offx, offy As Integer 'the offsets for the baord from the top and bottom Dim turn As Char 'records whose go it is Dim selectedpiece As Integer = 99 'records if a piece has been picked up
'set up AI pieces Dim BlackAI As AI Dim WhiteAI As AI
Public Property playerBlack As Integer Public Property playerWhite As Integer
Private Sub frmGame_Load(sender As Object, e As EventArgs) Handles MyBase.Load
'initiate all the counters counters(0) = New counter(0, 0, " B") counters(1) = New counter(2, 0, " B") counters(2) = New counter(4, 0, " B") counters(3) = New counter(6, 0, " B") counters(4) = New counter(1, 1, " B") counters(5) = New counter(3, 1, " B") counters(6) = New counter(5, 1, " B") counters(7) = New counter(7, 1, " B") counters(8) = New counter(0, 2, " B") counters(9) = New counter(2, 2, " B") counters(10) = New counter(4, 2, " B") counters(11) = New counter(6, 2, " B") counters(12) = New counter(1, 7, " W") counters(13) = New counter(3, 7, " W") counters(14) = New counter(5, 7, " W") counters(15) = New counter(7, 7, " W") counters(16) = New counter(0, 6, " W") counters(17) = New counter(2, 6, " W") counters(18) = New counter(4, 6, " W") counters(19) = New counter(6, 6, " W") counters(20) = New counter(1, 5, " W") counters(21) = New counter(3, 5, " W") counters(22) = New counter(5, 5, " W") counters(23) = New counter(7, 5, " W")
'set timers lblBlackTime.Text = 600 lblWhiteTime.Text = 600
offx = 44 offy = 44
sqsize = 30
turn = " B" loadPlayers(frmLogin.playerId1, frmLogin.playerId2)
'set up the AI if necessary If lblBlackName.Text = " COMPUTER" Then BlackAI = New AI BlackAI.colour = " B" AIMove() End If
If lblWhiteName.Text = " COMPUTER" Then WhiteAI = New AI WhiteAI.colour = " W" End If
'load the timer lblBlackTime.Text = frmLogin.lstTime.Value lblWhiteTime.Text = frmLogin.lstTime.Value
End Sub
Public Sub AIMove() If lblBlackName.Text = " COMPUTER" And turn = " B" Then BlackAI.findMoves() BlackAI.makeMove() End If
If lblWhiteName.Text = " COMPUTER" And turn = " W" Then WhiteAI.findMoves() WhiteAI.makeMove() End If End Sub
Private Sub loadPlayers(id1, id2) ' load the player details into the labels on the page
Dim ds As New DataSet dbConnector.connect() dbConnector.reset()
If frmLogin.chkAIBlack.Checked = False Then ds = dbConnector.SQLselect(" SELECT Username FROM tblUsers WHERE ID = " & id1) lblBlackName.Text = ds.Tables(" Results").Rows(0).Item(0) Else lblBlackName.Text = " COMPUTER" End If
dbConnector.reset() ds.Reset() If frmLogin.chkAIWhite.Checked = False Then ds = dbConnector.SQLselect(" SELECT Username FROM tblUsers WHERE ID = " & id2) lblWhiteName.Text = ds.Tables(" Results").Rows(0).Item(0) Else lblWhiteName.Text = " COMPUTER" End If End Sub
Public Sub selectPiece(bx, by) ' either selects or changes selection of piece For n = 0 To 23 counters(n).selected = False
If (counters(n).live = True) And (counters(n).colour = turn) Then If (counters(n).x = bx) And (counters(n).y = by) Then counters(n).selected = True selectedpiece = n
End If End If Next End Sub
Public Sub movePiece(bx, by)
'if it is a move then check that it is valid move ' remove pieces ' change turn
If selectedpiece < > 99 Then
If validMove(counters(selectedpiece), bx, by) Then Dim tempx As Integer = 0 Dim tempy As Integer = 0
'delete any intermediate counter If (counters(selectedpiece).x - bx) ^ 2 > 1 Or (counters(selectedpiece).y - by) ^ 2 > 1 Then
tempx = (counters(selectedpiece).x + bx) / 2 tempy = (counters(selectedpiece).y + by) / 2
deletePiece(tempx, tempy) End If
'move piece to the new location counters(selectedpiece).move(bx, by)
'can they make another legal move if they have jumped NOT single move If jumpPossible(counters(selectedpiece)) And tempx < > 0 Then counters(selectedpiece).selected = True 'don't allow player to make another move Else 'change turns and reset selected pieces changeTurn() selectedpiece = 99 End If End If End If
'eng game if no more moves are possible If finishGame(turn) < > " False" Then GameOver(finishGame(turn)) End If
'paint the board to the screen Invalidate() End Sub
Private Sub frmGame_MouseClick(sender As Object, e As MouseEventArgs) Handles Me.MouseClick Dim bx, by As Integer
'calculate the box being clicked bx = Math.Floor(((e.X - offx) / sqsize) + 0) by = Math.Floor(((e.Y - offy) / sqsize) + 0)
selectPiece(bx, by) movePiece(bx, by)
'makes an AI move if needed AIMove() End Sub
Private Sub frmGame_MouseMove(sender As Object, e As MouseEventArgs) Handles Me.MouseMove 'for debugging the mouse click location lblmx.Text = e.X lblmy.Text = e.Y End Sub
Private Sub frmGame_Paint(sender As Object, e As PaintEventArgs) Handles Me.Paint 'draws the screen and board Dim tempcol As Brush Dim pallete As Drawing.Graphics = Me.CreateGraphics
drawBoard(pallete, tempcol) drawPieces(pallete, tempcol) End Sub
Private Sub drawBoard(ByRef g, ByRef tempcol) 'draw the board
For x = 0 To 7 For y = 0 To 7 'make chequer pattern If (x + y) Mod 2 = 1 Then tempcol = Brushes.Black Else tempcol = Brushes.Coral End If 'draw the square g.FillRectangle(tempcol, (x * sqsize) + offx, (y * sqsize) + offy, sqsize, sqsize)
Next Next End Sub
Private Sub drawPieces(ByRef g, ByRef tempcol) ' draw the pieces For n = 0 To 23 If counters(n).live = True Then
If counters(n).king = True Then tempcol = Brushes.Black g.FillEllipse(tempcol, (counters(n).x * sqsize) + (offx - 2), (counters(n).y * sqsize) + (offy - 2), sqsize, sqsize) End If
' set the correct colours If counters(n).colour = " B" And counters(n).selected = True Then tempcol = Brushes.Black End If
If counters(n).colour = " B" And counters(n).selected = False Then tempcol = Brushes.Purple End If
If counters(n).colour = " W" And counters(n).selected = True Then tempcol = Brushes.White End If
If counters(n).colour = " W" And counters(n).selected = False Then tempcol = Brushes.Gray End If
'draw to screen g.FillEllipse(tempcol, (counters(n).x * sqsize) + offx, (counters(n).y * sqsize) + offy, sqsize, sqsize)
End If
Next
End Sub
Private Function validMove(ByRef origin, x, y)
'cannot move to a black square If (x + y) Mod 2 = 1 Then Return False End If
'cannot move into an occupied space If freeSpace(x, y) = False Then Return False End If
' cannot move backwards If origin.king = False Then If origin.colour = " B" And y < origin.y Then Return False End If
If origin.colour = " W" And y > origin.y Then Return False End If End If
' move outside board? If moveInside(x, y) = False Then Return False End If
' move on self If x = origin.x And y = origin.y Then Return False End If
'jumped too many spaces If (origin.x - x) ^ 2 > 4 Or (origin.y - y) ^ 2 > 4 Then Return False End If
Dim tempx, tempy As Integer tempx = (origin.x + x) / 2 tempy = (origin.y + y) / 2
'tried to jump own piece If (origin.x - x) ^ 2 = 4 Or (origin.y - y) ^ 2 = 4 Then For n = 0 To 23 If counters(n).x = tempx And counters(n).y = tempy And origin.colour = counters(n).colour And counters(n).live Then Return False End If Next End If
'tried to jump blank space If (origin.x - x) ^ 2 = 4 Or (origin.y - y) ^ 2 = 4 Then Dim trackenemy As Boolean = False
For n = 0 To 23 If counters(n).x = tempx And counters(n).y = tempy And origin.colour < > counters(n).colour And counters(n).live Then trackenemy = True End If Next
If trackenemy = False Then Return False End If End If
'else Return True End Function
Private Function movePossible(origin) 'move is possible if either jump or sinlgle space moves are possible If jumpPossible(origin) Or normalMovePossible(origin) Then Return True Else Return False End If
End Function
Private Function normalMovePossible(origin) ' is a normal single space move possible? If origin.colour = " B" And moveBlackPossible(origin) Then Return True End If
If origin.colour = " W" And moveWhitePossible(origin) Then Return True End If
'' for Kings If origin.king = True And (moveWhitePossible(origin) Or moveBlackPossible(origin)) Then Return True End If
Return False
End Function
Private Function moveBlackPossible(origin) 'checks squares below the current position If freeSpace(origin.x + 1, origin.y + 1) Then Return True End If If freeSpace(origin.x - 1, origin.y + 1) Then Return True End If
Return False End Function
Private Function moveWhitePossible(origin) 'checks squares above the current position If freeSpace(origin.x + 1, origin.y - 1) Then Return True End If If freeSpace(origin.x - 1, origin.y - 1) Then Return True End If
Return False End Function
Private Function jumpPossible(origin) ' is a jump move possible? '' for Kings If origin.king = True And (jumpUpPossible(origin) Or jumpDownPossible(origin)) Then Return True End If
If origin.colour = " B" Then If jumpDownPossible(origin) Then Return True End If End If
If origin.colour = " W" Then If jumpUpPossible(origin) Then Return True End If
End If
Return False
End Function
Private Function jumpDownPossible(origin) If freeSpace(origin.x + 1, origin.y + 1) = False And freeSpace(origin.x + 2, origin.y + 2) = True Then If retColourSquare(origin.x + 1, origin.y + 1) < > origin.colour Then Return True End If End If If freeSpace(origin.x - 1, origin.y + 1) = False And freeSpace(origin.x - 2, origin.y + 2) = True Then If retColourSquare(origin.x - 1, origin.y + 1) < > origin.colour Then Return True End If End If
Return False End Function
Private Function jumpUpPossible(origin) If freeSpace(origin.x + 1, origin.y - 1) = False And freeSpace(origin.x + 2, origin.y - 2) = True Then If retColourSquare(origin.x + 1, origin.y - 1) < > origin.colour Then Return True End If End If If freeSpace(origin.x - 1, origin.y - 1) = False And freeSpace(origin.x - 2, origin.y - 2) = True Then If retColourSquare(origin.x - 1, origin.y - 1) < > origin.colour Then Return True End If End If
Return False End Function
Private Function moveInside(x, y) 'checks that the move is within the board If x > 7 Or x < 0 Or y > 7 Or y < 0 Then Return False End If
Return True End Function
'is the space being looked at free? Private Function freeSpace(x, y) If moveInside(x, y) = False Then Return False End If
For n = 0 To 23 If counters(n).x = x And counters(n).y = y And counters(n).live Then Return False End If Next
Return True
End Function
Private Function retColourSquare(x, y) 'returns the colour of a counter on a given square For n = 0 To 23 If counters(n).x = x And counters(n).y = y And counters(n).live Then Return counters(n).colour End If Next Return " Blank" End Function
Private Function finishGame(colour) 'finish game? Dim countwhite As Integer = 0 Dim countblack As Integer = 0
For n = 0 To 23 If counters(n).live Then If counters(n).colour = " W" Then countwhite = countwhite + 1 ElseIf counters(n).colour = " B" Then countblack = countblack + 1 End If End If Next
'if no counters left or time run out If countblack = 0 Or lblBlackTime.Text < = 0 Then MsgBox(" Game over! White wins") Return " White" End If
If countwhite = 0 Or lblWhiteTime.Text < = 0 Then MsgBox(" Game over! Black wins") Return " Black" End If
' check that no moves are possible for all pieces For n = 0 To 23 If counters(n).colour = colour And movePossible(counters(n)) And counters(n).live Then Return " False" End If Next
Return " Draw" End Function
Private Function deletePiece(x, y) 'removes a piece when jumping it For n = 0 To 23 If counters(n).x = x And counters(n).y = y Then counters(n).die() Return True End If Next
MsgBox(" Error can't find piece to delete at" & x & ", " & y)
Return False End Function
Private Sub changeTurn() 'change turn If turn = " W" Then turn = " B" lblBlackName.Text = " => " & lblBlackName.Text lblWhiteName.Text = lblWhiteName.Text.Replace(" =", " ") lblWhiteName.Text = lblWhiteName.Text.Replace(" > ", " ")
Else turn = " W" lblWhiteName.Text = " => " & lblWhiteName.Text lblBlackName.Text = lblBlackName.Text.Replace(" =", " ") lblBlackName.Text = lblBlackName.Text.Replace(" > ", " ") End If toggleTimer() End Sub
Private Sub toggleTimer() 'change the timer from one side to another If tmrBlack.Enabled = True Then tmrBlack.Enabled = False tmrWhite.Enabled = True Else tmrBlack.Enabled = True tmrWhite.Enabled = False End If End Sub
Private Sub GameOver(result) 'Game Over Script Dim sql As String Dim winner As Integer
If result = " Black" Then winner = playerBlack End If If result = " White" Then winner = playerWhite End If If result = " Draw" Then winner = 0 End If
tmrBlack.Enabled = False tmrWhite.Enabled = False
MsgBox(result)
'save game 'only save games where players are ALL human If frmLogin.chkAIBlack.Checked = False And frmLogin.chkAIWhite.Checked = False Then dbConnector.connect() sql = " INSERT INTO tblGame (GameDate, WhitePlayer, BlackPlayer, Winner)" sql += " VALUES ('" & Date.Now() & " ', " & playerWhite & ", " & playerBlack & ", " & winner & "); "
dbConnector.SQLinsert(sql) End If
frmScores.Show() Me.Close()
End Sub
Private Sub tmrBlack_Tick(sender As Object, e As EventArgs) Handles tmrBlack.Tick 'decrease the clock by one second lblBlackTime.Text = lblBlackTime.Text - 1 End Sub
Private Sub tmrWhite_Tick(sender As Object, e As EventArgs) Handles tmrWhite.Tick 'decrease the clock by one second lblWhiteTime.Text = lblWhiteTime.Text - 1 End Sub End Class (iii) Testing [5 marks] An attempt should be made to show that all parts of the system have been tested, including those sections dealing with unexpected or invalid data as well as extreme cases. Showing that many other cases of test data are likely to work – by including the outputs that they produce – is another important feature. Evidence of testing is essential. Comments by teachers and others are of value, but the test plan must be supported by evidence in the report of a properly designed testing process. The examiner must be left in no doubt that the system actually works to the satisfaction of the client. This evidence may be in the form of hardcopy output and screen dumps.
Example 4b: library system project.
|