Skip to content
Browse files

First draft of TicTacToe domain (doesn't run though).

  • Loading branch information...
1 parent e18356b commit 7473fa216285c1ac7a98da050359a02c25ccf7c5 @jdhibberd jdhibberd committed
Showing with 236 additions and 118 deletions.
  1. +1 −1 .gitignore
  2. +232 −116 Beagle/Domain/TicTacToe.hs
  3. +3 −1 Main.hs
View
2 .gitignore
@@ -1,4 +1,4 @@
*.swp
*.hi
*.o
-main
+Main
View
348 Beagle/Domain/TicTacToe.hs
@@ -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
View
4 Main.hs
@@ -10,6 +10,8 @@ import Control.Monad.State
import Data.List (sortBy)
import System.Random
+import Debug.Trace
+
-- | Create a new genotype consisting of randomly chosen genes.
mkgenotype :: RandomGen g => g -> (Genotype, g)
mkgenotype = f D.genotypeLength
@@ -22,7 +24,7 @@ evalPopulation :: Population
-> State Counters [(Genotype, Score)]
evalPopulation p = do
modify . incrGenotypes . length $ p
- return . sort . map eval $ p
+ return . sort . map eval $ traceShow p p
where sort = sortBy (\a b -> compare (snd a) (snd b))
-- | Generate a list (population) of genotypes consisting of randomly chosen

0 comments on commit 7473fa2

Please sign in to comment.
Something went wrong with that request. Please try again.