Skip to content

Commit

Permalink
First draft of TicTacToe domain (doesn't run though).
Browse files Browse the repository at this point in the history
  • Loading branch information
@jdhibberd
jdhibberd committed Apr 29, 2012
1 parent e18356b commit 7473fa2
Show file tree
Hide file tree
Showing 3 changed files with 236 additions and 118 deletions.
2 changes: 1 addition & 1 deletion .gitignore
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
*.swp
*.hi
*.o
main
Main
348 changes: 232 additions & 116 deletions Beagle/Domain/TicTacToe.hs
View file
Original file line number Diff line number Diff line change
@@ -1,157 +1,273 @@
{-

-- TODO(jhibberd) Maybe, if all problems could be modelled as functions that
-- take varying numbers of state as arguments and return state, the algorithm
-- would be easier to develop?

-- TODO(jhibberd) Throw in lots of functions that could be useful and let the
-- natural selection process pick the ones it finds most useful.

{- Board positions are labelled as follows:
A | B | C
-----------
D | E | F
-----------
G | H | I
-}

module Beagle.Domain
( Gene(..)
, genemap
, stop
, genotypeLength
, mutationsPerGenotype
, populationSize
, randomSeed
, runner
) where
-}

import Data.Dynamic
import qualified Data.Map as Map
import System.Random
import Debug.Trace
import Data.Typeable
import System.IO.Unsafe
import System.Random

genotypeLength = 6 :: Int
mutationsPerGenotype = 2 :: Int
populationSize = 10 :: Int
randomSeed = 6 :: Int

{- Board positions are labelled as follows:
A | B | C
-----------
D | E | F
-----------
G | H | I
instance Typeable Mark where
typeOf N = mkTyConApp (mkTyCon3 "Beagle" "Domain" "N") []
typeOf X = mkTyConApp (mkTyCon3 "Beagle" "Domain" "X") []
typeOf O = mkTyConApp (mkTyCon3 "Beagle" "Domain" "O") []

-}
genotypeLength = 50 :: Int
mutationsPerGenotype = 2 :: Int
populationSize = 100 :: Int
randomSeed = 6 :: Int

{-
data Gene = Play
| If
| Not
| TakenByMe
| TakenByThem
| A
| B
| C
| D
| E
| F
| G
| H
| I
| Empty
data Gene = PlayA | PlayB | PlayC | PlayD | PlayE | PlayF | PlayG | PlayH
| PlayI | IsAX | IsBX | IsCX | IsDX | IsEX | IsFX | IsGX | IsHX
| IsIX | IsAO | IsBO | IsCO | IsDO | IsEO | IsFO | IsGO | IsHO
| IsIO | IsAN | IsBN | IsCN | IsDN | IsEN | IsFN | IsGN | IsHN
| IsIN | Branch | Or | And | DoNothing | Empty
deriving (Ord, Eq, Show, Enum)
-}
{-
genemap :: Map.Map Gene Dynamic

genemap :: Map.Map Gene (Dynamic, Int)
genemap = Map.fromList [
(Play, toDyn play),
(IfCondition, toDyn ifCondition),
(Not, toDyn not),
(TakenByMe, toDyn takenByMe),
(TakenByThem, toDyn takenByThem),
(A, toDyn A),
(B, toDyn B),
(C, toDyn C),
(D, toDyn D),
(E, toDyn E),
(F, toDyn F),
(G, toDyn G),
(H, toDyn H),
(I, toDyn I)
(PlayA, (toDyn playA, 1)),
(PlayB, (toDyn playB, 1)),
(PlayC, (toDyn playC, 1)),
(PlayD, (toDyn playD, 1)),
(PlayE, (toDyn playE, 1)),
(PlayF, (toDyn playF, 1)),
(PlayG, (toDyn playG, 1)),
(PlayH, (toDyn playH, 1)),
(PlayI, (toDyn playI, 1)),
(IsAX, (toDyn isAX, 1)),
(IsBX, (toDyn isBX, 1)),
(IsCX, (toDyn isCX, 1)),
(IsDX, (toDyn isDX, 1)),
(IsEX, (toDyn isEX, 1)),
(IsFX, (toDyn isFX, 1)),
(IsGX, (toDyn isGX, 1)),
(IsHX, (toDyn isHX, 1)),
(IsIX, (toDyn isIX, 1)),
(IsAO, (toDyn isAO, 1)),
(IsBO, (toDyn isBO, 1)),
(IsCO, (toDyn isCO, 1)),
(IsDO, (toDyn isDO, 1)),
(IsEO, (toDyn isEO, 1)),
(IsFO, (toDyn isFO, 1)),
(IsGO, (toDyn isGO, 1)),
(IsHO, (toDyn isHO, 1)),
(IsIO, (toDyn isIO, 1)),
(IsAN, (toDyn isAN, 1)),
(IsBN, (toDyn isBN, 1)),
(IsCN, (toDyn isCN, 1)),
(IsDN, (toDyn isDN, 1)),
(IsEN, (toDyn isEN, 1)),
(IsFN, (toDyn isFN, 1)),
(IsGN, (toDyn isGN, 1)),
(IsHN, (toDyn isHN, 1)),
(IsIN, (toDyn isIN, 1)),
(Branch, (toDyn branch, 3)),
(Or, (toDyn or', 2)),
(And, (toDyn and', 2)),
(DoNothing, (toDyn doNothing, 1))
]
-}

data Position = A | B | C | D | E | F | G | H | I deriving (Enum)
data State = Free | X | O deriving (Eq, Show)
type Board = [State]
runner = (toDyn runner', 1 :: Int)

type Pos = Int
data Mark = N | X | O deriving (Eq, Show)
type Grid = [Mark]
data GameState = Draw | XWins | OWins | Open deriving (Show)
data Turn = XTurn | OTurn
type State = (Bool, Grid)

{-
play :: Board -> Position -> Board
play b p = map (\x i -> if i == p then Me else x) . zip b [A..I]
-- | Gene functions ============================================================

-- | Functions for making a move -----------------------------------------------

takenByMe :: Board -> Position -> Bool
takenByMe b p = (b !! (formEnum p)) == Me
playA, playB, playC, playD, playE, playF, playG, playH, playI :: State -> State

takenByThem :: Board -> Position -> Bool
takenByThem b p = (b !! (formEnum p)) == Them
-}
play :: Mark -> Pos -> State -> State
play m p (_, grid)
| grid !! p /= N = toState grid -- skip move
| otherwise = let (x,_:xs) = splitAt p grid
in toState (x++(m:xs))

-- TODO(jhibberd) Throw in lots of functions that could be useful and let the
-- natural selection process pick the ones it finds most useful.
playA = play O 0
playB = play O 1
playC = play O 2
playD = play O 3
playE = play O 4
playF = play O 5
playG = play O 6
playH = play O 7
playI = play O 8

-- | Functions for determining the current board state -------------------------

isAX, isBX, isCX, isDX, isEX, isFX, isGX, isHX, isIX :: State -> State
isAO, isBO, isCO, isDO, isEO, isFO, isGO, isHO, isIO :: State -> State
isAN, isBN, isCN, isDN, isEN, isFN, isGN, isHN, isIN :: State -> State

is :: Pos -> Mark -> State -> State
is p m (_, grid) = (grid !! p == m, grid)

isAX = is 0 X
isBX = is 1 X
isCX = is 2 X
isDX = is 3 X
isEX = is 4 X
isFX = is 5 X
isGX = is 6 X
isHX = is 7 X
isIX = is 8 X
isAO = is 0 O
isBO = is 1 O
isCO = is 2 O
isDO = is 3 O
isEO = is 4 O
isFO = is 5 O
isGO = is 6 O
isHO = is 7 O
isIO = is 8 O
isAN = is 0 N
isBN = is 1 N
isCN = is 2 N
isDN = is 3 N
isEN = is 4 N
isFN = is 5 N
isGN = is 6 N
isHN = is 7 N
isIN = is 8 N

playA :: Board -> Board
playA b = play O b 0
-- | Functions for controlling program flow ------------------------------------

isAX :: Board -> Bool
isAO :: Board -> Bool
branch :: State -> State -> State -> State
branch (True, _) x _ = x
branch (False, _) _ x = x

branch :: Bool -> Board -> Board -> Board
or' :: State -> State -> State
or' (True, x) _ = (True, x)
or' _ (True, x) = (True, x)
or' (False, x) _ = (False, x)

-- | Fitness function mechanics ------------------------------------------------
and' :: State -> State -> State
and' (True, x) (True, _) = (True, x)
and' (_, x) _ = (False, x)

play :: State -> Board -> Int -> Board
play t b p
| b !! p /= Free = error "Position not free."
| otherwise = let (x,_:xs) = splitAt p b
in (x ++ (t:xs))
doNothing :: State -> State
doNothing = id

getState :: Board -> GameState
getState b
| wins b = XWins
| wins (reverseb b) = OWins
| filter (== Free) b == [] = Draw
| otherwise = Open

reverseb :: Board -> Board
reverseb = map (\x -> case x of
-- | Fitness function mechanics ================================================

getState :: Grid -> GameState
getState grid
| doesXWin grid = XWins
| doesXWin (reverse' grid) = OWins
| filter (==N) grid == [] = Draw
| otherwise = Open

toState :: Grid -> State
toState grid = (False, grid)

fromState :: State -> Grid
fromState (_, grid) = grid

reverse' :: Grid -> Grid
reverse' = map (\x -> case x of
X -> O
O -> X
x -> x)

wins :: Board -> Bool
wins [X, X, X, _, _, _, _, _, _] = True
wins [_, _, _, X, X, X, _, _, _] = True
wins [_, _, _, _, _, _, X, X, X] = True
wins [X, _, _, X, _, _, X, _, _] = True
wins [_, X, _, _, X, _, _, X, _] = True
wins [_, _, X, _, _, X, _, _, X] = True
wins [X, _, _, _, X, _, _, _, X] = True
wins [_, _, X, _, X, _, X, _, _] = True
wins _ = False

hostPlay :: (RandomGen g) => Board -> g -> (Board, g)
hostPlay b g = let (i, g') = randomR (0, (length freeonly)-1) g
i'' = freeonly !! i
in (play X b i'', g')
where zipped = zip b [0..]
freeonly = map snd $ filter ((==Free) . fst) zipped

-- | TODO(jhibberd) This function will be substituted for the genotype.
clientPlay :: Board -> Board
clientPlay b =
let i = read .unsafePerformIO $ getLine
in play O b i

runner :: (RandomGen g) => Board -> g -> Turn -> GameState
runner b g t =
case getState (traceShow b b) of
doesXWin :: Grid -> Bool
doesXWin [X, X, X, _, _, _, _, _, _] = True
doesXWin [_, _, _, X, X, X, _, _, _] = True
doesXWin [_, _, _, _, _, _, X, X, X] = True
doesXWin [X, _, _, X, _, _, X, _, _] = True
doesXWin [_, X, _, _, X, _, _, X, _] = True
doesXWin [_, _, X, _, _, X, _, _, X] = True
doesXWin [X, _, _, _, X, _, _, _, X] = True
doesXWin [_, _, X, _, X, _, X, _, _] = True
doesXWin _ = False

hostPlay :: (RandomGen g) => Grid -> g -> (Grid, g)
hostPlay grid g = let (i, g') = randomR (0, (length freeonly)-1) g
i'' = freeonly !! i
in (fromState $ play X i'' (toState grid), g')
where zipped = zip grid [0..]
freeonly = map snd $ filter ((==N) . fst) zipped

toScore :: Int -> Float
toScore = (/10) . fromIntegral

numLoses :: [Bool] -> Int
numLoses = length . filter (==False)

runner' :: (State -> State) -> Float
runner' f = toScore . numLoses $ runner'' f numGames g OTurn
where g = mkStdGen 6
numGames = 3

runner'' :: (RandomGen g)
=> (State -> State)
-> Int
-> g
-> Turn
-> [Bool]
runner'' _ 0 _ _ = []
runner'' f n g t = let (outcome, g') = playGame f newGrid g t
in outcome: runner'' f (n-1) g' nextT
where newGrid = toState (replicate 9 N)
nextT = case t of
XTurn -> OTurn
OTurn -> XTurn

-- TODO(jhibberd) Should probably be win=3, draw=1, loss=0
playGame :: (RandomGen g)
=> (State -> State)
-> State
-> g
-> Turn
-> (Bool, g)
playGame f (_, grid) g t =
case getState (traceShow grid grid) of
Open -> case t of
XTurn -> let (b', g') = hostPlay b g
in runner b' g' OTurn
OTurn -> runner (clientPlay b) g XTurn
x -> x
XTurn -> let (b', g') = hostPlay grid g
in playGame f (toState b') g' OTurn
OTurn -> playGame f (f $ toState grid) g XTurn
XWins -> (False, g)
OWins -> (True, g)
Draw -> (False, g)

-- | Manual testing of the runner ----------------------------------------------

-- | Mock genotype that allows the user to manually control how the genotype
-- behaves.
mockF :: State -> State
mockF (_, grid) = let i = read .unsafePerformIO $ getLine
in play O i (toState grid)

main = print $ runner (replicate 9 Free) (mkStdGen 3) XTurn
main = print $ runner' mockF

Loading

0 comments on commit 7473fa2

Please sign in to comment.