reversi in vba
Jan. 16th, 2004 04:56 pm![[personal profile]](https://www.dreamwidth.org/img/silk/identity/user.png){kind=small}
saint_monkeyanother macro for an online resume of vba. this one is reversi in an excel worksheet, complete with three separate opponent AI's. this one needs a lot of cleaning up, it has a lot of spaghetti in it, but i couldn't get the logic worked out any other way. it needs some work in the "Invalid Move" department, and it also needs to detect an opponent's pass better, now i work out a pass by changing cell value in A1 from W to B manually. but i don't want to lose the code, so here it is:
the board is on the ActiveSheet, in cells b2:I9, you might want to outline those cells in a thick border... just DON'T color those cell interiors Red, whatever you do.
the macro uses cells a1, a13:a18 for it's own purposes, ni addition to the board.
i've got four buttons on the sheet, one called "Done" with "SetMove" set to it, another called "Reset" with "SetBoard" set to it, another called "Show My Moves" with "MyMoves" assigned to it, and a final one called "Show Opponent's Moves" with "OpponentMoves" assigned to it. since this is very much a work in progress, i welome any feedback (i know i need to work to remove the GoTo's, and i need to dimension my variables properly, and utilize a naming standard, as a macro recorder taught programmer i tend to kludge things together.)
after you've set up the sheet, click "reset" "o" is a white cell, "*" is a black one, you play white, and you go first. select the cell you'd like to move into and click "done" the computer will make your move and then will make it's own. whn cell "A1" goes back to "W" it is your turn again. the computer will not detect a turn where you can not move, so you will have to notice those yourself. change the "W" to "B" and then click "Done" and that facilitates a "Pass." If you are any good at reversi at all, you will probably win against the AI most times. it only has a few tests, but if you are silly and abandon corners to it, the the Il Cattivo processor may just squeak a game by you.
watch out for wrapped lines.
'begin code here, paste into the vbe in a new workbook...
'reversi
'
Sub SetMove()
'assigned to a button,
'accepts the active cell
'as a play
Play = Range("A1").Value
Select Case Play
Case "W"
Call MakeMove
Call IlCattivo
Case "B"
Call IlBuono
End Select
Call Score
End Sub
Sub Score()
'counts the cells and keeps the score
Range("B2:I9").Select
For Each Cell In Selection
If Cell.Value = "o" Then wcount = wcount + 1
If Cell.Value = "*" Then bcount = bcount + 1
If Cell.Value = "" Then fcount = fcount + 1
Next Cell
Select Case fcount
Case 0
If bcount > wcount Then Range("K13").Value = "Black has won by " & bcount - wcount & " cells, Black:" & bcount & " White:" & wcount
If wcount > bcount Then Range("K13").Value = "White has won by " & wcount - bcount & " cells, White:" & wcount & " Black:" & bcount
If bcount = wcount Then Range("K13").Value = "This game is a draw, the score is " & bcount & " all."
Case Else
Range("K13").Value = "Black has " & bcount & ", White has " & wcount & ", with " & fcount / 2 & " turns remaining."
End Select
End Sub
Sub MyMoves()
'shows the moves available for the player
'with the active turn
Play = Range("A1").Value
Cola = 3
Call FindMoves(Play, Cola)
End Sub
Sub FutureMoves()
Play = Range("A1").Value
Cola = 3
Call FindMoves(Play, Cola)
End Sub
Sub OpponentMoves()
'shows moves for the player
'who does NOT have the active turn
Play = Range("A1").Value
Select Case Play
Case "B"
Play = "W"
Case "W"
Play = "B"
End Select
Cola = 4
PTable = "B2:I9"
Call FindMoves(Play, Cola)
End Sub
Sub FindMoves(Play, Cola)
'<--- look at the board, discover possible moves
'<--- copy moves to an array
'<--- "Play" is required, it is generally the value in A1
'<--- "Cola" is the color to set the cell interior for possible moves
Dim war(0 To 64)
Select Case Play
Case "W"
Whom = "o"
Op = "*"
Nxt = "B"
Case "B"
Whom = "*"
Op = "o"
Nxt = "W"
End Select
Range("B2:I9").Select
wcount = 0
'locate all cells that might contain moves.
For Each Cell In Selection
' first find the cells that have opponent's color
If Cell.Value = Op Then
TestRange = Cell.Address
Range(TestRange).Activate
' then look in all eight surrounding cells for a blank
If ActiveCell.Offset(1, 0).Value = "" Then 'down
'check to see that the possible play is inside the board
totest = ActiveCell.Offset(1, 0).Address
Select Case Range(totest).Column
Case "1"
GoTo n2:
Case "10"
GoTo n2:
End Select
Select Case Range(totest).Row
Case "1"
GoTo n2:
Case "10"
GoTo n2:
End Select
1:
'if it is, move one cell in the opposite direction
Call up
'if you find a cell that contains your tile, then you know you
'have a valid move, add it to the array, otherwise, loop.
'the next 7 sections of the code are simply this code
'just moving in the other 7 directions
'the 2: n2: and Out: tags allow one to
'either prematurely pop up to the top of the loop, "a top"
'or skip out of the current loop entirely "a drop"
'and move on to the next possible move lookup.
'this is where most of the spaghetti shows up, but sometimes i need
'to reliably terminate a loop, and i can't think of the sometimes
'counter intuitive logic required to write a complex loop
'that would serve without the "Drops and Tops"
If ActiveCell.Value = Whom Then
wcount = wcount + 1: war(wcount) = totest: GoTo n2:
ElseIf ActiveCell.Value = Op Then GoTo 1:
End If
End If
n2:
Range(TestRange).Activate
If ActiveCell.Offset(-1, 0).Value = "" Then ' up
totest = ActiveCell.Offset(-1, 0).Address
Select Case Range(totest).Column
Case "1"
GoTo n3:
Case "10"
GoTo n3:
End Select
Select Case Range(totest).Row
Case "1"
GoTo n3:
Case "10"
GoTo n3:
End Select
2:
Call down
If ActiveCell.Value = Whom Then
wcount = wcount + 1: war(wcount) = totest: GoTo n3:
ElseIf ActiveCell.Value = Op Then GoTo 2:
End If
End If
n3:
Range(TestRange).Activate
If ActiveCell.Offset(0, -1).Value = "" Then 'left
totest = ActiveCell.Offset(0, -1).Address
Select Case Range(totest).Column
Case "1"
GoTo n4:
Case "10"
GoTo n4:
End Select
Select Case Range(totest).Row
Case "1"
GoTo n4:
Case "10"
GoTo n4:
End Select
3:
Call right
If ActiveCell.Value = Whom Then
wcount = wcount + 1: war(wcount) = totest: GoTo n4::
ElseIf ActiveCell.Value = Op Then GoTo 3:
End If
End If
n4:
Range(TestRange).Activate
If ActiveCell.Offset(0, 1).Value = "" Then 'right
totest = ActiveCell.Offset(0, 1).Address
Select Case Range(totest).Column
Case "1"
GoTo n5:
Case "10"
GoTo n5:
End Select
Select Case Range(totest).Row
Case "1"
GoTo n5:
Case "10"
GoTo n5:
End Select
4:
Call left
If ActiveCell.Value = Whom Then
wcount = wcount + 1: war(wcount) = totest: GoTo n5:
ElseIf ActiveCell.Value = Op Then GoTo 4:
End If
End If
n5:
Range(TestRange).Activate
If ActiveCell.Offset(1, 1).Value = "" Then 'downright
totest = ActiveCell.Offset(1, 1).Address
Select Case Range(totest).Column
Case "1"
GoTo n6:
Case "10"
GoTo n6:
End Select
Select Case Range(totest).Row
Case "1"
GoTo n6:
Case "10"
GoTo n6:
End Select
5:
Call upleft
If ActiveCell.Value = Whom Then
wcount = wcount + 1: war(wcount) = totest: GoTo n6:
ElseIf ActiveCell.Value = Op Then GoTo 5:
End If
End If
n6:
Range(TestRange).Activate
If ActiveCell.Offset(1, -1).Value = "" Then 'downleft
totest = ActiveCell.Offset(1, -1).Address
Select Case Range(totest).Column
Case "1"
GoTo n7:
Case "10"
GoTo n7:
End Select
Select Case Range(totest).Row
Case "1"
GoTo n7:
Case "10"
GoTo n7:
End Select
6:
Call upright
If ActiveCell.Value = Whom Then
wcount = wcount + 1: war(wcount) = totest: GoTo n7:
ElseIf ActiveCell.Value = Op Then GoTo 6:
End If
End If
n7:
Range(TestRange).Activate
If ActiveCell.Offset(-1, 1).Value = "" Then 'upright
totest = ActiveCell.Offset(-1, 1).Address
Select Case Range(totest).Column
Case "1"
GoTo n8:
Case "10"
GoTo n8:
End Select
Select Case Range(totest).Row
Case "1"
GoTo n8:
Case "10"
GoTo n8:
End Select
7:
Call downleft
If ActiveCell.Value = Whom Then
wcount = wcount + 1: war(wcount) = totest: GoTo n8:
ElseIf ActiveCell.Value = Op Then GoTo 7:
End If
End If
n8:
Range(TestRange).Activate
If ActiveCell.Offset(-1, -1).Value = "" Then 'upleft
totest = ActiveCell.Offset(-1, -1).Address
Select Case Range(totest).Column
Case "1"
GoTo n9:
Case "10"
GoTo n9:
End Select
Select Case Range(totest).Row
Case "1"
GoTo n9:
Case "10"
GoTo n9:
End Select
8:
Call downright
If ActiveCell.Value = Whom Then
wcount = wcount + 1: war(wcount) = totest: GoTo Out:
ElseIf ActiveCell.Value = Op Then GoTo 8:
n9:
End If
End If
End If
Out:
Next Cell
For x = 1 To wcount
Range(war(x)).Interior.ColorIndex = Cola
Mess = Mess & " " & war(x)
Next x
Range("B2").Select
End Sub
Sub MakeMove()
'<--- makemove reads the activecell as the cell that the opponent moved into
'<--- it reads the state of surrounding cells and alters the board based upon
'<--- that move. it then sets the board for an opponent to move,
'<--- to play without the computer, set this to a button and play one white
'<--- and one black. one need only to select the cell on one's move,
'<--- no need to type the "o" or the "*"
'<---
'<---
Whom = Range("A1").Value
Select Case Whom
Case "W"
Whom = "o"
Op = "*"
Nxt = "B"
Case "B"
Whom = "*"
Op = "o"
Nxt = "W"
End Select
Dim mbar(0 To 7)
Move = ActiveCell.Address
If Range(Move).Column = "1" Then
GoTo n8:
ElseIf Range(Move).Column = "10" Then
GoTo n8:
ElseIf Range(Move).Row = "1" Then
GoTo n8:
ElseIf Range(Move).Row = "10" Then
GoTo n8:
End If
Range("B2:I9").Select
Selection.Interior.ColorIndex = None
Range(Move).Activate
If ActiveCell.Value <> Empty Then GoTo n8:
If ActiveCell.Offset(1, 0).Value = Op Then 'down
ActiveCell.Offset(1, 0).Activate
1:
Call down
If ActiveCell.Value = Whom Then
Range(Move, ActiveCell.Address).Select
For Each Flip In Selection
Range(Flip.Address).Value = Whom
Next Flip
Success = 1
GoTo n1:
ElseIf ActiveCell.Value = Op Then GoTo 1:
ElseIf ActiveCell.Value = "" Then GoTo n1:
End If
End If
n1:
Range(Move).Activate
If ActiveCell.Offset(-1, 0).Value = Op Then 'up
ActiveCell.Offset(-1, 0).Activate
2:
Call up
If ActiveCell.Value = Whom Then
Range(Move, ActiveCell.Address).Select
For Each Flip In Selection
Range(Flip.Address).Value = Whom
Next Flip
Success = 1
GoTo n2:
ElseIf ActiveCell.Value = Op Then GoTo 2:
ElseIf ActiveCell.Value = "" Then GoTo n2:
End If
End If
n2:
Range(Move).Activate
If ActiveCell.Offset(0, -1).Value = Op Then 'left
ActiveCell.Offset(0, -1).Activate
3:
Call left
If ActiveCell.Value = Whom Then
Range(Move, ActiveCell.Address).Select
For Each Flip In Selection
Range(Flip.Address).Value = Whom
Next Flip
Success = 1
GoTo n3:
ElseIf ActiveCell.Value = Op Then GoTo 3:
ElseIf ActiveCell.Value = "" Then GoTo n3:
End If
End If
n3:
Range(Move).Activate
If ActiveCell.Offset(0, 1).Value = Op Then 'right
ActiveCell.Offset(0, 1).Activate
4:
Call right
If ActiveCell.Value = Whom Then
Range(Move, ActiveCell.Address).Select
For Each Flip In Selection
Range(Flip.Address).Value = Whom
Next Flip
Success = 1
GoTo n4:
ElseIf ActiveCell.Value = Op Then GoTo 4:
ElseIf ActiveCell.Value = "" Then GoTo n4:
End If
End If
n4:
mcount = 0
Range(Move).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
If ActiveCell.Offset(1, 1).Value = Op Then 'downright
ActiveCell.Offset(1, 1).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
5:
Call downright
If ActiveCell.Value = Whom Then
mbar(mcount) = ActiveCell.Address
For m = 0 To mcount
mwhere = mbar(m)
Range(mwhere).Value = Whom
Next m
Success = 1
GoTo n5:
ElseIf ActiveCell.Value = Op Then mbar(mcount) = ActiveCell.Address: mcount = mcount + 1: GoTo 5:
ElseIf ActiveCell.Value = "" Then GoTo n5:
End If
End If
n5:
mcount = 0
Range(Move).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
If ActiveCell.Offset(1, -1).Value = Op Then 'downleft
ActiveCell.Offset(1, -1).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
6:
Call downleft
If ActiveCell.Value = Whom Then
mbar(mcount) = ActiveCell.Address
For m = 0 To mcount
mwhere = mbar(m)
Range(mwhere).Value = Whom
Next m
Success = 1
GoTo n6:
ElseIf ActiveCell.Value = Op Then mbar(mcount) = ActiveCell.Address: mcount = mcount + 1: GoTo 6:
ElseIf ActiveCell.Value = "" Then GoTo n6:
End If
End If
n6:
mcount = 0
Range(Move).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
If ActiveCell.Offset(-1, 1).Value = Op Then 'upright
ActiveCell.Offset(-1, 1).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
7:
Call upright
If ActiveCell.Value = Whom Then
mbar(mcount) = ActiveCell.Address
For m = 0 To mcount
mwhere = mbar(m)
Range(mwhere).Value = Whom
Next m
Success = 1
GoTo n7:
ElseIf ActiveCell.Value = Op Then mbar(mcount) = ActiveCell.Address: mcount = mcount + 1: GoTo 7:
ElseIf ActiveCell.Value = "" Then GoTo n7:
End If
End If
n7:
mcount = 0
Range(Move).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
If ActiveCell.Offset(-1, -1).Value = Op Then 'upleft
ActiveCell.Offset(-1, -1).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
8:
Call upleft
If ActiveCell.Value = Whom Then
mbar(mcount) = ActiveCell.Address
For m = 0 To mcount
mwhere = mbar(m)
Range(mwhere).Value = Whom
Next m
Success = 1
GoTo n8:
ElseIf ActiveCell.Value = Op Then mbar(mcount) = ActiveCell.Address: mcount = mcount + 1: GoTo 8:
ElseIf ActiveCell.Value = "" Then GoTo n8:
End If
End If
n8:
Select Case Success
Case 0
MsgBox "Invalid Move, Try Again."
GoTo Out:
Case Else
Range("A1").Value = Nxt
End Select
Out:
End Sub
Sub IfMove()
'
Whom = Range("A1").Value
Select Case Whom
Case "W"
Whom = "o"
Op = "*"
Nxt = "B"
Case "B"
Whom = "*"
Op = "o"
Nxt = "W"
End Select
Dim mbar(0 To 7)
Dim possar(0 To 63)
Move = ActiveCell.Address
Range(Move).Activate
possar(pcount) = Range(Move).Address
If ActiveCell.Value <> Empty Then GoTo n8:
If ActiveCell.Offset(1, 0).Value = Op Then 'down
ActiveCell.Offset(1, 0).Activate
1:
Call down
If ActiveCell.Value = Whom Then
Range(Move, ActiveCell.Address).Select
For Each Flip In Selection
If Flip.Address <> Move Then possar(pcount) = Flip.Address
pcount = pcount + 1
Next Flip
Success = 1
GoTo n1:
ElseIf ActiveCell.Value = Op Then GoTo 1:
ElseIf ActiveCell.Value = "" Then GoTo n1:
End If
End If
n1:
Range(Move).Activate
If ActiveCell.Offset(-1, 0).Value = Op Then 'up
ActiveCell.Offset(-1, 0).Activate
2:
Call up
If ActiveCell.Value = Whom Then
Range(Move, ActiveCell.Address).Select
For Each Flip In Selection
If Flip.Address <> Move Then possar(pcount) = Flip.Address
pcount = pcount + 1
Next Flip
Success = 1
GoTo n2:
ElseIf ActiveCell.Value = Op Then GoTo 2:
ElseIf ActiveCell.Value = "" Then GoTo n2:
End If
End If
n2:
Range(Move).Activate
If ActiveCell.Offset(0, -1).Value = Op Then 'left
ActiveCell.Offset(0, -1).Activate
3:
Call left
If ActiveCell.Value = Whom Then
Range(Move, ActiveCell.Address).Select
For Each Flip In Selection
If Flip.Address <> Move Then possar(pcount) = Flip.Address
pcount = pcount + 1
Next Flip
Success = 1
GoTo n3:
ElseIf ActiveCell.Value = Op Then GoTo 3:
ElseIf ActiveCell.Value = "" Then GoTo n3:
End If
End If
n3:
Range(Move).Activate
If ActiveCell.Offset(0, 1).Value = Op Then 'right
ActiveCell.Offset(0, 1).Activate
4:
Call right
If ActiveCell.Value = Whom Then
Range(Move, ActiveCell.Address).Select
For Each Flip In Selection
If Flip.Address <> Move Then possar(pcount) = Flip.Address
pcount = pcount + 1
Next Flip
Success = 1
GoTo n4:
ElseIf ActiveCell.Value = Op Then GoTo 4:
ElseIf ActiveCell.Value = "" Then GoTo n4:
End If
End If
n4:
mcount = 0
Range(Move).Activate
'mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
If ActiveCell.Offset(1, 1).Value = Op Then 'downright
ActiveCell.Offset(1, 1).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
5:
Call downright
If ActiveCell.Value = Whom Then
mbar(mcount) = ActiveCell.Address
For m = 0 To mcount
mwhere = mbar(m)
possar(pcount) = mwhere
pcount = pcount + 1
Next m
Success = 1
GoTo n5:
ElseIf ActiveCell.Value = Op Then mbar(mcount) = ActiveCell.Address: mcount = mcount + 1: GoTo 5:
ElseIf ActiveCell.Value = "" Then GoTo n5:
End If
End If
n5:
mcount = 0
Range(Move).Activate
If ActiveCell.Offset(1, -1).Value = Op Then 'downleft
ActiveCell.Offset(1, -1).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
6:
Call downleft
If ActiveCell.Value = Whom Then
mbar(mcount) = ActiveCell.Address
For m = 0 To mcount
mwhere = mbar(m)
possar(pcount) = mwhere
pcount = pcount + 1
Next m
Success = 1
GoTo n6:
ElseIf ActiveCell.Value = Op Then mbar(mcount) = ActiveCell.Address: mcount = mcount + 1: GoTo 6:
ElseIf ActiveCell.Value = "" Then GoTo n6:
End If
End If
n6:
mcount = 0
Range(Move).Activate
'mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
If ActiveCell.Offset(-1, 1).Value = Op Then 'upright
ActiveCell.Offset(-1, 1).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
7:
Call upright
If ActiveCell.Value = Whom Then
mbar(mcount) = ActiveCell.Address
For m = 0 To mcount
mwhere = mbar(m)
possar(pcount) = mwhere
pcount = pcount + 1
Next m
Success = 1
GoTo n7:
ElseIf ActiveCell.Value = Op Then mbar(mcount) = ActiveCell.Address: mcount = mcount + 1: GoTo 7:
ElseIf ActiveCell.Value = "" Then GoTo n7:
End If
End If
n7:
mcount = 0
Range(Move).Activate
If ActiveCell.Offset(-1, -1).Value = Op Then 'upleft
ActiveCell.Offset(-1, -1).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
8:
Call upleft
If ActiveCell.Value = Whom Then
mbar(mcount) = ActiveCell.Address
For m = 0 To mcount
mwhere = mbar(m)
possar(pcount) = mwhere
pcount = pcount + 1
Next m
Success = 1
GoTo n8:
ElseIf ActiveCell.Value = Op Then mbar(mcount) = ActiveCell.Address: mcount = mcount + 1: GoTo 8:
ElseIf ActiveCell.Value = "" Then GoTo n8:
End If
End If
n8:
Range("A13").Value = pcount
Range("A14").Value = Move
End Sub
Sub IlBrutto()
Range("K1").Value = "Il Brutto is loaded."
Call MyMoves
Range("B2:I9").Select
For Each Cell In Selection
Cola = Range(Cell.Address).Interior.ColorIndex
If Cola <> 3 Then
Else
Range(Cell.Address).Activate
Call IfMove
pcount = Range("A13").Value
Move = Range("A14").Value
If pcount > bestcount Then
bestcount = pcount
Range("A15").Value = Move
End If
End If
Next Cell
Best = Range("A15").Value
Select Case Best
Case Is <> Empty
Range(Best).Activate
Range("A13:A16").ClearContents
Call MakeMove
Case Else
MsgBox "I must pass.", , "Il Brutto"
Range("A1").Value = "W"
End Select
End Sub
Sub IlBuono()
Range("K1").Value = "Il Buono is loaded."
'plays just like il Brutto with an additional logical test to:
'1) capture an open corner if available
'2) avoid providing an option to open a corner to an opponent
'3) offer no higher priority to points around a corner if the corner is already captured.
Call MyMoves
Range("B2:I9").Select
For Each Cell In Selection
Cola = Range(Cell.Address).Interior.ColorIndex
If Cola <> 3 Then
Else
Range(Cell.Address).Activate
TestCorner = Cell.Address
Range(Cell.Address).Activate
Select Case TestCorner
Case "$B$2"
Call MakeMove
GoTo Out:
Case "$I$2"
Call MakeMove
GoTo Out:
Case "$B$9"
Call MakeMove
GoTo Out:
Case "$I$9"
Call MakeMove
GoTo Out:
Case "$C$2"
If Range("B2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$C$3"
If Range("B2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$B$3"
If Range("B2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$H$2"
If Range("I2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$H$3"
If Range("I2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$I$3"
If Range("I2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$C$8"
If Range("B9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$B$8"
If Range("B9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$C$9"
If Range("B9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$H$8"
If Range("I9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$I$8"
If Range("I9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$H$9"
If Range("I9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case Else
End Select
Normal:
Call IfMove
pcount = Range("A13").Value
Move = Range("A14").Value
If pcount > bestcount Then
bestcount = pcount
Range("A15").Value = Move
End If
End If
CornerOut:
Next Cell
Best = Range("A15").Value
Select Case Best
Case Is <> Empty
Range(Best).Activate
Range("A13:A16").ClearContents
Call MakeMove
Case Else
cornered = Range("A18").Value
Select Case cornered
Case Is = Empty
MsgBox "I must pass.", , "Il Buono"
Range("A1").Value = "W"
Case Else
badmove = cornered
Range(badmove).Activate
Range("A18").Value = ""
Call MakeMove
Out:
End Select
End Select
End Sub
Sub IlCattivo()
'plays with the corner test first, and then
'will consider all possible moves for himself,
'and will tally the results for all possible opponent moves
'resulting from his move.
'he will make the move that results in the fewest
'conversions for an opponent who plays like Il Brutto.
Range("K1").Value = "Il Cattivo is loaded."
'On Error Resume Next
Application.ScreenUpdating = False
Dim Arr()
Dim ColArr()
Range("B2:I9").Select
Range("A13:A17").ClearContents
rcount = Selection.Rows.count
ccount = Selection.Columns.count
Play = Range("A1").Value
Cola = 3
'Find and color all available moves for me.
Call FindMoves(Play, Cola)
ReDim Arr(rcount, ccount)
'loop through all cells on the board, save their pre-move state.
'two arrays required, one for value of cell, the other for move color
Range("B2:I9").Select
For Each Precell In Selection
Range(Precell.Address).Activate
Arr((Precell.Row) - 2, (Precell.Column) - 2) = Range(Precell.Address).Value
Next Precell
Range("B2:I9").Select
ReDim ColArr(rcount, ccount)
For Each ColCell In Selection
Range(ColCell.Address).Activate
ColArr((ColCell.Row) - 2, (ColCell.Column) - 2) = Range(ColCell.Address).Interior.ColorIndex
Next ColCell
Range("B2:I9").Select
For Each Cell In Selection
Cola2 = Range(Cell.Address).Interior.ColorIndex
If Cola2 <> 3 Then
Else
'Test For Corner, if free, take it... if sets up opponent, treat normally,
'if the corner is already taken play normally
Range(Cell.Address).Activate
TestCorner = Cell.Address
Range(Cell.Address).Activate
Select Case TestCorner
Case "$B$2"
Call MakeMove
GoTo Out:
Case "$I$2"
Call MakeMove
GoTo Out:
Case "$B$9"
Call MakeMove
GoTo Out:
Case "$I$9"
Call MakeMove
GoTo Out:
Case "$C$2"
If Range("B2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$C$3"
If Range("B2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$B$3"
If Range("B2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$H$2"
If Range("I2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$H$3"
If Range("I2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$I$3"
If Range("I2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$C$8"
If Range("B9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$B$8"
If Range("B9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$C$9"
If Range("B9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$H$8"
If Range("I9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$I$8"
If Range("I9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$H$9"
If Range("I9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case Else
End Select
Normal:
'<--- red colored interior
Range(Cell.Address).Activate
ThisMove = Cell.Address
'<--- Make this move
Range("A1").Value = "B"
Call IfMove
'see how many cells are altered by my move
mycount = Range("A13").Value
Range("A1").Value = "B"
Range(ThisMove).Activate
Call MakeMove
'test opponent's possibilities after my move
Range("A1").Value = "W"
Call MyMoves
Range("B2:I9").Select
For Each OpCell In Selection
Cola = Range(OpCell.Address).Interior.ColorIndex
If Cola <> 3 Then
Else
Range(OpCell.Address).Activate
Call MakeMove
pcount = Range("A13").Value
diff = mycount - pcount
If Range("A17").Value <> Empty Then prediff = Range("A17").Value Else prediff = 0
Move = Range("A14").Value
'does this move offset fewer cells than other moves?
If diff >= prediff Then
prediff = diff
Range("A18").Value = ThisMove
Range("A16").Value = pcount
Range("A17").Value = prediff
End If
End If
Next OpCell
'<-- copy the result to a test range
End If
Range("B2:I9").Select
For Each PostCell In Selection
rval = PostCell.Row - 2
cval = PostCell.Column - 2
Range(PostCell.Address).Value = Arr(rval, cval)
Next PostCell
Range("B2:I9").Select
For Each PostCol In Selection
rval = PostCol.Row - 2
cval = PostCol.Column - 2
Range(PostCol.Address).Interior.ColorIndex = ColArr(rval, cval)
Next PostCol
CornerOut:
Next Cell
Best = Range("A18").Value
Select Case Best
Case Is <> Empty
Range(Best).Activate
Range("A13:A18").ClearContents
Range("A1").Value = "B"
For Each PostCell In Selection
rval = PostCell.Row - 2
cval = PostCell.Column - 2
Range(PostCell.Address).Value = Arr(rval, cval)
Next PostCell
Range(Best).Activate
Call MakeMove
Case Else
For Each PostCell In Selection
rval = PostCell.Row - 2
cval = PostCell.Column - 2
Range(PostCell.Address).Value = Arr(rval, cval)
Next PostCell
Range("A1").Value = "B"
Call IlBuono
End Select
Out:
Application.ScreenUpdating = True
End Sub
Sub setboard()
Range("A1").Value = "W"
Range("B2:I9").Select
Selection.ClearContents
Selection.Interior.ColorIndex = None
With Selection
.RowHeight = "13.2"
.ColumnWidth = "1.22"
End With
Range("e5").Value = "*"
Range("f5").Value = "o"
Range("e6").Value = "o"
Range("f6").Value = "*"
Call Score
End Sub
Sub down()
ActiveCell.Offset(1, 0).Activate
End Sub
Sub up()
ActiveCell.Offset(-1, 0).Activate
End Sub
Sub left()
ActiveCell.Offset(0, -1).Activate
End Sub
Sub right()
ActiveCell.Offset(0, 1).Activate
End Sub
Sub downright()
ActiveCell.Offset(1, 1).Activate
End Sub
Sub downleft()
ActiveCell.Offset(1, -1).Activate
End Sub
Sub upright()
ActiveCell.Offset(-1, 1).Activate
End Sub
Sub upleft()
ActiveCell.Offset(-1, -1).Activate
End Sub
the board is on the ActiveSheet, in cells b2:I9, you might want to outline those cells in a thick border... just DON'T color those cell interiors Red, whatever you do.
the macro uses cells a1, a13:a18 for it's own purposes, ni addition to the board.
i've got four buttons on the sheet, one called "Done" with "SetMove" set to it, another called "Reset" with "SetBoard" set to it, another called "Show My Moves" with "MyMoves" assigned to it, and a final one called "Show Opponent's Moves" with "OpponentMoves" assigned to it. since this is very much a work in progress, i welome any feedback (i know i need to work to remove the GoTo's, and i need to dimension my variables properly, and utilize a naming standard, as a macro recorder taught programmer i tend to kludge things together.)
after you've set up the sheet, click "reset" "o" is a white cell, "*" is a black one, you play white, and you go first. select the cell you'd like to move into and click "done" the computer will make your move and then will make it's own. whn cell "A1" goes back to "W" it is your turn again. the computer will not detect a turn where you can not move, so you will have to notice those yourself. change the "W" to "B" and then click "Done" and that facilitates a "Pass." If you are any good at reversi at all, you will probably win against the AI most times. it only has a few tests, but if you are silly and abandon corners to it, the the Il Cattivo processor may just squeak a game by you.
watch out for wrapped lines.
'begin code here, paste into the vbe in a new workbook...
'reversi
'
Sub SetMove()
'assigned to a button,
'accepts the active cell
'as a play
Play = Range("A1").Value
Select Case Play
Case "W"
Call MakeMove
Call IlCattivo
Case "B"
Call IlBuono
End Select
Call Score
End Sub
Sub Score()
'counts the cells and keeps the score
Range("B2:I9").Select
For Each Cell In Selection
If Cell.Value = "o" Then wcount = wcount + 1
If Cell.Value = "*" Then bcount = bcount + 1
If Cell.Value = "" Then fcount = fcount + 1
Next Cell
Select Case fcount
Case 0
If bcount > wcount Then Range("K13").Value = "Black has won by " & bcount - wcount & " cells, Black:" & bcount & " White:" & wcount
If wcount > bcount Then Range("K13").Value = "White has won by " & wcount - bcount & " cells, White:" & wcount & " Black:" & bcount
If bcount = wcount Then Range("K13").Value = "This game is a draw, the score is " & bcount & " all."
Case Else
Range("K13").Value = "Black has " & bcount & ", White has " & wcount & ", with " & fcount / 2 & " turns remaining."
End Select
End Sub
Sub MyMoves()
'shows the moves available for the player
'with the active turn
Play = Range("A1").Value
Cola = 3
Call FindMoves(Play, Cola)
End Sub
Sub FutureMoves()
Play = Range("A1").Value
Cola = 3
Call FindMoves(Play, Cola)
End Sub
Sub OpponentMoves()
'shows moves for the player
'who does NOT have the active turn
Play = Range("A1").Value
Select Case Play
Case "B"
Play = "W"
Case "W"
Play = "B"
End Select
Cola = 4
PTable = "B2:I9"
Call FindMoves(Play, Cola)
End Sub
Sub FindMoves(Play, Cola)
'<--- look at the board, discover possible moves
'<--- copy moves to an array
'<--- "Play" is required, it is generally the value in A1
'<--- "Cola" is the color to set the cell interior for possible moves
Dim war(0 To 64)
Select Case Play
Case "W"
Whom = "o"
Op = "*"
Nxt = "B"
Case "B"
Whom = "*"
Op = "o"
Nxt = "W"
End Select
Range("B2:I9").Select
wcount = 0
'locate all cells that might contain moves.
For Each Cell In Selection
' first find the cells that have opponent's color
If Cell.Value = Op Then
TestRange = Cell.Address
Range(TestRange).Activate
' then look in all eight surrounding cells for a blank
If ActiveCell.Offset(1, 0).Value = "" Then 'down
'check to see that the possible play is inside the board
totest = ActiveCell.Offset(1, 0).Address
Select Case Range(totest).Column
Case "1"
GoTo n2:
Case "10"
GoTo n2:
End Select
Select Case Range(totest).Row
Case "1"
GoTo n2:
Case "10"
GoTo n2:
End Select
1:
'if it is, move one cell in the opposite direction
Call up
'if you find a cell that contains your tile, then you know you
'have a valid move, add it to the array, otherwise, loop.
'the next 7 sections of the code are simply this code
'just moving in the other 7 directions
'the 2: n2: and Out: tags allow one to
'either prematurely pop up to the top of the loop, "a top"
'or skip out of the current loop entirely "a drop"
'and move on to the next possible move lookup.
'this is where most of the spaghetti shows up, but sometimes i need
'to reliably terminate a loop, and i can't think of the sometimes
'counter intuitive logic required to write a complex loop
'that would serve without the "Drops and Tops"
If ActiveCell.Value = Whom Then
wcount = wcount + 1: war(wcount) = totest: GoTo n2:
ElseIf ActiveCell.Value = Op Then GoTo 1:
End If
End If
n2:
Range(TestRange).Activate
If ActiveCell.Offset(-1, 0).Value = "" Then ' up
totest = ActiveCell.Offset(-1, 0).Address
Select Case Range(totest).Column
Case "1"
GoTo n3:
Case "10"
GoTo n3:
End Select
Select Case Range(totest).Row
Case "1"
GoTo n3:
Case "10"
GoTo n3:
End Select
2:
Call down
If ActiveCell.Value = Whom Then
wcount = wcount + 1: war(wcount) = totest: GoTo n3:
ElseIf ActiveCell.Value = Op Then GoTo 2:
End If
End If
n3:
Range(TestRange).Activate
If ActiveCell.Offset(0, -1).Value = "" Then 'left
totest = ActiveCell.Offset(0, -1).Address
Select Case Range(totest).Column
Case "1"
GoTo n4:
Case "10"
GoTo n4:
End Select
Select Case Range(totest).Row
Case "1"
GoTo n4:
Case "10"
GoTo n4:
End Select
3:
Call right
If ActiveCell.Value = Whom Then
wcount = wcount + 1: war(wcount) = totest: GoTo n4::
ElseIf ActiveCell.Value = Op Then GoTo 3:
End If
End If
n4:
Range(TestRange).Activate
If ActiveCell.Offset(0, 1).Value = "" Then 'right
totest = ActiveCell.Offset(0, 1).Address
Select Case Range(totest).Column
Case "1"
GoTo n5:
Case "10"
GoTo n5:
End Select
Select Case Range(totest).Row
Case "1"
GoTo n5:
Case "10"
GoTo n5:
End Select
4:
Call left
If ActiveCell.Value = Whom Then
wcount = wcount + 1: war(wcount) = totest: GoTo n5:
ElseIf ActiveCell.Value = Op Then GoTo 4:
End If
End If
n5:
Range(TestRange).Activate
If ActiveCell.Offset(1, 1).Value = "" Then 'downright
totest = ActiveCell.Offset(1, 1).Address
Select Case Range(totest).Column
Case "1"
GoTo n6:
Case "10"
GoTo n6:
End Select
Select Case Range(totest).Row
Case "1"
GoTo n6:
Case "10"
GoTo n6:
End Select
5:
Call upleft
If ActiveCell.Value = Whom Then
wcount = wcount + 1: war(wcount) = totest: GoTo n6:
ElseIf ActiveCell.Value = Op Then GoTo 5:
End If
End If
n6:
Range(TestRange).Activate
If ActiveCell.Offset(1, -1).Value = "" Then 'downleft
totest = ActiveCell.Offset(1, -1).Address
Select Case Range(totest).Column
Case "1"
GoTo n7:
Case "10"
GoTo n7:
End Select
Select Case Range(totest).Row
Case "1"
GoTo n7:
Case "10"
GoTo n7:
End Select
6:
Call upright
If ActiveCell.Value = Whom Then
wcount = wcount + 1: war(wcount) = totest: GoTo n7:
ElseIf ActiveCell.Value = Op Then GoTo 6:
End If
End If
n7:
Range(TestRange).Activate
If ActiveCell.Offset(-1, 1).Value = "" Then 'upright
totest = ActiveCell.Offset(-1, 1).Address
Select Case Range(totest).Column
Case "1"
GoTo n8:
Case "10"
GoTo n8:
End Select
Select Case Range(totest).Row
Case "1"
GoTo n8:
Case "10"
GoTo n8:
End Select
7:
Call downleft
If ActiveCell.Value = Whom Then
wcount = wcount + 1: war(wcount) = totest: GoTo n8:
ElseIf ActiveCell.Value = Op Then GoTo 7:
End If
End If
n8:
Range(TestRange).Activate
If ActiveCell.Offset(-1, -1).Value = "" Then 'upleft
totest = ActiveCell.Offset(-1, -1).Address
Select Case Range(totest).Column
Case "1"
GoTo n9:
Case "10"
GoTo n9:
End Select
Select Case Range(totest).Row
Case "1"
GoTo n9:
Case "10"
GoTo n9:
End Select
8:
Call downright
If ActiveCell.Value = Whom Then
wcount = wcount + 1: war(wcount) = totest: GoTo Out:
ElseIf ActiveCell.Value = Op Then GoTo 8:
n9:
End If
End If
End If
Out:
Next Cell
For x = 1 To wcount
Range(war(x)).Interior.ColorIndex = Cola
Mess = Mess & " " & war(x)
Next x
Range("B2").Select
End Sub
Sub MakeMove()
'<--- makemove reads the activecell as the cell that the opponent moved into
'<--- it reads the state of surrounding cells and alters the board based upon
'<--- that move. it then sets the board for an opponent to move,
'<--- to play without the computer, set this to a button and play one white
'<--- and one black. one need only to select the cell on one's move,
'<--- no need to type the "o" or the "*"
'<---
'<---
Whom = Range("A1").Value
Select Case Whom
Case "W"
Whom = "o"
Op = "*"
Nxt = "B"
Case "B"
Whom = "*"
Op = "o"
Nxt = "W"
End Select
Dim mbar(0 To 7)
Move = ActiveCell.Address
If Range(Move).Column = "1" Then
GoTo n8:
ElseIf Range(Move).Column = "10" Then
GoTo n8:
ElseIf Range(Move).Row = "1" Then
GoTo n8:
ElseIf Range(Move).Row = "10" Then
GoTo n8:
End If
Range("B2:I9").Select
Selection.Interior.ColorIndex = None
Range(Move).Activate
If ActiveCell.Value <> Empty Then GoTo n8:
If ActiveCell.Offset(1, 0).Value = Op Then 'down
ActiveCell.Offset(1, 0).Activate
1:
Call down
If ActiveCell.Value = Whom Then
Range(Move, ActiveCell.Address).Select
For Each Flip In Selection
Range(Flip.Address).Value = Whom
Next Flip
Success = 1
GoTo n1:
ElseIf ActiveCell.Value = Op Then GoTo 1:
ElseIf ActiveCell.Value = "" Then GoTo n1:
End If
End If
n1:
Range(Move).Activate
If ActiveCell.Offset(-1, 0).Value = Op Then 'up
ActiveCell.Offset(-1, 0).Activate
2:
Call up
If ActiveCell.Value = Whom Then
Range(Move, ActiveCell.Address).Select
For Each Flip In Selection
Range(Flip.Address).Value = Whom
Next Flip
Success = 1
GoTo n2:
ElseIf ActiveCell.Value = Op Then GoTo 2:
ElseIf ActiveCell.Value = "" Then GoTo n2:
End If
End If
n2:
Range(Move).Activate
If ActiveCell.Offset(0, -1).Value = Op Then 'left
ActiveCell.Offset(0, -1).Activate
3:
Call left
If ActiveCell.Value = Whom Then
Range(Move, ActiveCell.Address).Select
For Each Flip In Selection
Range(Flip.Address).Value = Whom
Next Flip
Success = 1
GoTo n3:
ElseIf ActiveCell.Value = Op Then GoTo 3:
ElseIf ActiveCell.Value = "" Then GoTo n3:
End If
End If
n3:
Range(Move).Activate
If ActiveCell.Offset(0, 1).Value = Op Then 'right
ActiveCell.Offset(0, 1).Activate
4:
Call right
If ActiveCell.Value = Whom Then
Range(Move, ActiveCell.Address).Select
For Each Flip In Selection
Range(Flip.Address).Value = Whom
Next Flip
Success = 1
GoTo n4:
ElseIf ActiveCell.Value = Op Then GoTo 4:
ElseIf ActiveCell.Value = "" Then GoTo n4:
End If
End If
n4:
mcount = 0
Range(Move).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
If ActiveCell.Offset(1, 1).Value = Op Then 'downright
ActiveCell.Offset(1, 1).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
5:
Call downright
If ActiveCell.Value = Whom Then
mbar(mcount) = ActiveCell.Address
For m = 0 To mcount
mwhere = mbar(m)
Range(mwhere).Value = Whom
Next m
Success = 1
GoTo n5:
ElseIf ActiveCell.Value = Op Then mbar(mcount) = ActiveCell.Address: mcount = mcount + 1: GoTo 5:
ElseIf ActiveCell.Value = "" Then GoTo n5:
End If
End If
n5:
mcount = 0
Range(Move).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
If ActiveCell.Offset(1, -1).Value = Op Then 'downleft
ActiveCell.Offset(1, -1).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
6:
Call downleft
If ActiveCell.Value = Whom Then
mbar(mcount) = ActiveCell.Address
For m = 0 To mcount
mwhere = mbar(m)
Range(mwhere).Value = Whom
Next m
Success = 1
GoTo n6:
ElseIf ActiveCell.Value = Op Then mbar(mcount) = ActiveCell.Address: mcount = mcount + 1: GoTo 6:
ElseIf ActiveCell.Value = "" Then GoTo n6:
End If
End If
n6:
mcount = 0
Range(Move).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
If ActiveCell.Offset(-1, 1).Value = Op Then 'upright
ActiveCell.Offset(-1, 1).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
7:
Call upright
If ActiveCell.Value = Whom Then
mbar(mcount) = ActiveCell.Address
For m = 0 To mcount
mwhere = mbar(m)
Range(mwhere).Value = Whom
Next m
Success = 1
GoTo n7:
ElseIf ActiveCell.Value = Op Then mbar(mcount) = ActiveCell.Address: mcount = mcount + 1: GoTo 7:
ElseIf ActiveCell.Value = "" Then GoTo n7:
End If
End If
n7:
mcount = 0
Range(Move).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
If ActiveCell.Offset(-1, -1).Value = Op Then 'upleft
ActiveCell.Offset(-1, -1).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
8:
Call upleft
If ActiveCell.Value = Whom Then
mbar(mcount) = ActiveCell.Address
For m = 0 To mcount
mwhere = mbar(m)
Range(mwhere).Value = Whom
Next m
Success = 1
GoTo n8:
ElseIf ActiveCell.Value = Op Then mbar(mcount) = ActiveCell.Address: mcount = mcount + 1: GoTo 8:
ElseIf ActiveCell.Value = "" Then GoTo n8:
End If
End If
n8:
Select Case Success
Case 0
MsgBox "Invalid Move, Try Again."
GoTo Out:
Case Else
Range("A1").Value = Nxt
End Select
Out:
End Sub
Sub IfMove()
'
Whom = Range("A1").Value
Select Case Whom
Case "W"
Whom = "o"
Op = "*"
Nxt = "B"
Case "B"
Whom = "*"
Op = "o"
Nxt = "W"
End Select
Dim mbar(0 To 7)
Dim possar(0 To 63)
Move = ActiveCell.Address
Range(Move).Activate
possar(pcount) = Range(Move).Address
If ActiveCell.Value <> Empty Then GoTo n8:
If ActiveCell.Offset(1, 0).Value = Op Then 'down
ActiveCell.Offset(1, 0).Activate
1:
Call down
If ActiveCell.Value = Whom Then
Range(Move, ActiveCell.Address).Select
For Each Flip In Selection
If Flip.Address <> Move Then possar(pcount) = Flip.Address
pcount = pcount + 1
Next Flip
Success = 1
GoTo n1:
ElseIf ActiveCell.Value = Op Then GoTo 1:
ElseIf ActiveCell.Value = "" Then GoTo n1:
End If
End If
n1:
Range(Move).Activate
If ActiveCell.Offset(-1, 0).Value = Op Then 'up
ActiveCell.Offset(-1, 0).Activate
2:
Call up
If ActiveCell.Value = Whom Then
Range(Move, ActiveCell.Address).Select
For Each Flip In Selection
If Flip.Address <> Move Then possar(pcount) = Flip.Address
pcount = pcount + 1
Next Flip
Success = 1
GoTo n2:
ElseIf ActiveCell.Value = Op Then GoTo 2:
ElseIf ActiveCell.Value = "" Then GoTo n2:
End If
End If
n2:
Range(Move).Activate
If ActiveCell.Offset(0, -1).Value = Op Then 'left
ActiveCell.Offset(0, -1).Activate
3:
Call left
If ActiveCell.Value = Whom Then
Range(Move, ActiveCell.Address).Select
For Each Flip In Selection
If Flip.Address <> Move Then possar(pcount) = Flip.Address
pcount = pcount + 1
Next Flip
Success = 1
GoTo n3:
ElseIf ActiveCell.Value = Op Then GoTo 3:
ElseIf ActiveCell.Value = "" Then GoTo n3:
End If
End If
n3:
Range(Move).Activate
If ActiveCell.Offset(0, 1).Value = Op Then 'right
ActiveCell.Offset(0, 1).Activate
4:
Call right
If ActiveCell.Value = Whom Then
Range(Move, ActiveCell.Address).Select
For Each Flip In Selection
If Flip.Address <> Move Then possar(pcount) = Flip.Address
pcount = pcount + 1
Next Flip
Success = 1
GoTo n4:
ElseIf ActiveCell.Value = Op Then GoTo 4:
ElseIf ActiveCell.Value = "" Then GoTo n4:
End If
End If
n4:
mcount = 0
Range(Move).Activate
'mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
If ActiveCell.Offset(1, 1).Value = Op Then 'downright
ActiveCell.Offset(1, 1).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
5:
Call downright
If ActiveCell.Value = Whom Then
mbar(mcount) = ActiveCell.Address
For m = 0 To mcount
mwhere = mbar(m)
possar(pcount) = mwhere
pcount = pcount + 1
Next m
Success = 1
GoTo n5:
ElseIf ActiveCell.Value = Op Then mbar(mcount) = ActiveCell.Address: mcount = mcount + 1: GoTo 5:
ElseIf ActiveCell.Value = "" Then GoTo n5:
End If
End If
n5:
mcount = 0
Range(Move).Activate
If ActiveCell.Offset(1, -1).Value = Op Then 'downleft
ActiveCell.Offset(1, -1).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
6:
Call downleft
If ActiveCell.Value = Whom Then
mbar(mcount) = ActiveCell.Address
For m = 0 To mcount
mwhere = mbar(m)
possar(pcount) = mwhere
pcount = pcount + 1
Next m
Success = 1
GoTo n6:
ElseIf ActiveCell.Value = Op Then mbar(mcount) = ActiveCell.Address: mcount = mcount + 1: GoTo 6:
ElseIf ActiveCell.Value = "" Then GoTo n6:
End If
End If
n6:
mcount = 0
Range(Move).Activate
'mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
If ActiveCell.Offset(-1, 1).Value = Op Then 'upright
ActiveCell.Offset(-1, 1).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
7:
Call upright
If ActiveCell.Value = Whom Then
mbar(mcount) = ActiveCell.Address
For m = 0 To mcount
mwhere = mbar(m)
possar(pcount) = mwhere
pcount = pcount + 1
Next m
Success = 1
GoTo n7:
ElseIf ActiveCell.Value = Op Then mbar(mcount) = ActiveCell.Address: mcount = mcount + 1: GoTo 7:
ElseIf ActiveCell.Value = "" Then GoTo n7:
End If
End If
n7:
mcount = 0
Range(Move).Activate
If ActiveCell.Offset(-1, -1).Value = Op Then 'upleft
ActiveCell.Offset(-1, -1).Activate
mbar(mcount) = ActiveCell.Address: mcount = mcount + 1
8:
Call upleft
If ActiveCell.Value = Whom Then
mbar(mcount) = ActiveCell.Address
For m = 0 To mcount
mwhere = mbar(m)
possar(pcount) = mwhere
pcount = pcount + 1
Next m
Success = 1
GoTo n8:
ElseIf ActiveCell.Value = Op Then mbar(mcount) = ActiveCell.Address: mcount = mcount + 1: GoTo 8:
ElseIf ActiveCell.Value = "" Then GoTo n8:
End If
End If
n8:
Range("A13").Value = pcount
Range("A14").Value = Move
End Sub
Sub IlBrutto()
Range("K1").Value = "Il Brutto is loaded."
Call MyMoves
Range("B2:I9").Select
For Each Cell In Selection
Cola = Range(Cell.Address).Interior.ColorIndex
If Cola <> 3 Then
Else
Range(Cell.Address).Activate
Call IfMove
pcount = Range("A13").Value
Move = Range("A14").Value
If pcount > bestcount Then
bestcount = pcount
Range("A15").Value = Move
End If
End If
Next Cell
Best = Range("A15").Value
Select Case Best
Case Is <> Empty
Range(Best).Activate
Range("A13:A16").ClearContents
Call MakeMove
Case Else
MsgBox "I must pass.", , "Il Brutto"
Range("A1").Value = "W"
End Select
End Sub
Sub IlBuono()
Range("K1").Value = "Il Buono is loaded."
'plays just like il Brutto with an additional logical test to:
'1) capture an open corner if available
'2) avoid providing an option to open a corner to an opponent
'3) offer no higher priority to points around a corner if the corner is already captured.
Call MyMoves
Range("B2:I9").Select
For Each Cell In Selection
Cola = Range(Cell.Address).Interior.ColorIndex
If Cola <> 3 Then
Else
Range(Cell.Address).Activate
TestCorner = Cell.Address
Range(Cell.Address).Activate
Select Case TestCorner
Case "$B$2"
Call MakeMove
GoTo Out:
Case "$I$2"
Call MakeMove
GoTo Out:
Case "$B$9"
Call MakeMove
GoTo Out:
Case "$I$9"
Call MakeMove
GoTo Out:
Case "$C$2"
If Range("B2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$C$3"
If Range("B2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$B$3"
If Range("B2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$H$2"
If Range("I2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$H$3"
If Range("I2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$I$3"
If Range("I2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$C$8"
If Range("B9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$B$8"
If Range("B9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$C$9"
If Range("B9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$H$8"
If Range("I9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$I$8"
If Range("I9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$H$9"
If Range("I9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case Else
End Select
Normal:
Call IfMove
pcount = Range("A13").Value
Move = Range("A14").Value
If pcount > bestcount Then
bestcount = pcount
Range("A15").Value = Move
End If
End If
CornerOut:
Next Cell
Best = Range("A15").Value
Select Case Best
Case Is <> Empty
Range(Best).Activate
Range("A13:A16").ClearContents
Call MakeMove
Case Else
cornered = Range("A18").Value
Select Case cornered
Case Is = Empty
MsgBox "I must pass.", , "Il Buono"
Range("A1").Value = "W"
Case Else
badmove = cornered
Range(badmove).Activate
Range("A18").Value = ""
Call MakeMove
Out:
End Select
End Select
End Sub
Sub IlCattivo()
'plays with the corner test first, and then
'will consider all possible moves for himself,
'and will tally the results for all possible opponent moves
'resulting from his move.
'he will make the move that results in the fewest
'conversions for an opponent who plays like Il Brutto.
Range("K1").Value = "Il Cattivo is loaded."
'On Error Resume Next
Application.ScreenUpdating = False
Dim Arr()
Dim ColArr()
Range("B2:I9").Select
Range("A13:A17").ClearContents
rcount = Selection.Rows.count
ccount = Selection.Columns.count
Play = Range("A1").Value
Cola = 3
'Find and color all available moves for me.
Call FindMoves(Play, Cola)
ReDim Arr(rcount, ccount)
'loop through all cells on the board, save their pre-move state.
'two arrays required, one for value of cell, the other for move color
Range("B2:I9").Select
For Each Precell In Selection
Range(Precell.Address).Activate
Arr((Precell.Row) - 2, (Precell.Column) - 2) = Range(Precell.Address).Value
Next Precell
Range("B2:I9").Select
ReDim ColArr(rcount, ccount)
For Each ColCell In Selection
Range(ColCell.Address).Activate
ColArr((ColCell.Row) - 2, (ColCell.Column) - 2) = Range(ColCell.Address).Interior.ColorIndex
Next ColCell
Range("B2:I9").Select
For Each Cell In Selection
Cola2 = Range(Cell.Address).Interior.ColorIndex
If Cola2 <> 3 Then
Else
'Test For Corner, if free, take it... if sets up opponent, treat normally,
'if the corner is already taken play normally
Range(Cell.Address).Activate
TestCorner = Cell.Address
Range(Cell.Address).Activate
Select Case TestCorner
Case "$B$2"
Call MakeMove
GoTo Out:
Case "$I$2"
Call MakeMove
GoTo Out:
Case "$B$9"
Call MakeMove
GoTo Out:
Case "$I$9"
Call MakeMove
GoTo Out:
Case "$C$2"
If Range("B2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$C$3"
If Range("B2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$B$3"
If Range("B2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$H$2"
If Range("I2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$H$3"
If Range("I2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$I$3"
If Range("I2").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$C$8"
If Range("B9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$B$8"
If Range("B9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$C$9"
If Range("B9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$H$8"
If Range("I9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$I$8"
If Range("I9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case "$H$9"
If Range("I9").Value = "" Then Range("A18").Value = TestCorner: GoTo CornerOut Else GoTo Normal:
Case Else
End Select
Normal:
'<--- red colored interior
Range(Cell.Address).Activate
ThisMove = Cell.Address
'<--- Make this move
Range("A1").Value = "B"
Call IfMove
'see how many cells are altered by my move
mycount = Range("A13").Value
Range("A1").Value = "B"
Range(ThisMove).Activate
Call MakeMove
'test opponent's possibilities after my move
Range("A1").Value = "W"
Call MyMoves
Range("B2:I9").Select
For Each OpCell In Selection
Cola = Range(OpCell.Address).Interior.ColorIndex
If Cola <> 3 Then
Else
Range(OpCell.Address).Activate
Call MakeMove
pcount = Range("A13").Value
diff = mycount - pcount
If Range("A17").Value <> Empty Then prediff = Range("A17").Value Else prediff = 0
Move = Range("A14").Value
'does this move offset fewer cells than other moves?
If diff >= prediff Then
prediff = diff
Range("A18").Value = ThisMove
Range("A16").Value = pcount
Range("A17").Value = prediff
End If
End If
Next OpCell
'<-- copy the result to a test range
End If
Range("B2:I9").Select
For Each PostCell In Selection
rval = PostCell.Row - 2
cval = PostCell.Column - 2
Range(PostCell.Address).Value = Arr(rval, cval)
Next PostCell
Range("B2:I9").Select
For Each PostCol In Selection
rval = PostCol.Row - 2
cval = PostCol.Column - 2
Range(PostCol.Address).Interior.ColorIndex = ColArr(rval, cval)
Next PostCol
CornerOut:
Next Cell
Best = Range("A18").Value
Select Case Best
Case Is <> Empty
Range(Best).Activate
Range("A13:A18").ClearContents
Range("A1").Value = "B"
For Each PostCell In Selection
rval = PostCell.Row - 2
cval = PostCell.Column - 2
Range(PostCell.Address).Value = Arr(rval, cval)
Next PostCell
Range(Best).Activate
Call MakeMove
Case Else
For Each PostCell In Selection
rval = PostCell.Row - 2
cval = PostCell.Column - 2
Range(PostCell.Address).Value = Arr(rval, cval)
Next PostCell
Range("A1").Value = "B"
Call IlBuono
End Select
Out:
Application.ScreenUpdating = True
End Sub
Sub setboard()
Range("A1").Value = "W"
Range("B2:I9").Select
Selection.ClearContents
Selection.Interior.ColorIndex = None
With Selection
.RowHeight = "13.2"
.ColumnWidth = "1.22"
End With
Range("e5").Value = "*"
Range("f5").Value = "o"
Range("e6").Value = "o"
Range("f6").Value = "*"
Call Score
End Sub
Sub down()
ActiveCell.Offset(1, 0).Activate
End Sub
Sub up()
ActiveCell.Offset(-1, 0).Activate
End Sub
Sub left()
ActiveCell.Offset(0, -1).Activate
End Sub
Sub right()
ActiveCell.Offset(0, 1).Activate
End Sub
Sub downright()
ActiveCell.Offset(1, 1).Activate
End Sub
Sub downleft()
ActiveCell.Offset(1, -1).Activate
End Sub
Sub upright()
ActiveCell.Offset(-1, 1).Activate
End Sub
Sub upleft()
ActiveCell.Offset(-1, -1).Activate
End Sub
