fork download
copy 
  1. {-# LANGUAGE DeriveFunctor #-}
  2.  
  3. import Data.Maybe
  4. import Data.Sequence hiding (zip, filter, length)
  5. import Data.Foldable
  6. import Data.Monoid
  7. import Control.Arrow
  8.  
  9. newtype Fix f = Fix { unFix :: f (Fix f) }
  10.  
  11. cata :: Functor f => (f a -> a) -> Fix f -> a
  12. cata f = f . fmap (cata f) . unFix
  13. ana :: Functor f => (a -> f a) -> a -> Fix f
  14. ana f = Fix . fmap (ana f) . f
  15.  
  16. data Player = Cross | Nought
  17.     deriving (Eq, Show)
  18. type Cell = Maybe Player
  19. e :: Cell
  20. e = Nothing
  21.  
  22. -- always 9 cells
  23. data Board = Board { getPlayer :: Player, getCells :: Seq Cell }
  24. type Move = Int
  25. (!?) :: Seq a -> Move -> a
  26. s !? m = index s m
  27. showCell :: Cell -> String
  28. showCell Nothing = " "
  29. showCell (Just Cross) = "x"
  30. showCell (Just Nought) = "o"
  31. instance Show Board where
  32.     show (Board p cells) = "+---+---+---+\n"
  33.                         ++ "| " ++ showCell (cells !? 0)
  34.                            ++ " | " ++ showCell (cells !? 1)
  35.                                ++ " | " ++ showCell (cells !? 2) ++ " |\n"
  36.                         ++ "+---+---+---+\n"
  37.                         ++ "| " ++ showCell (cells !? 3)
  38.                            ++ " | " ++ showCell (cells !? 4)
  39.                                ++ " | " ++ showCell (cells !? 5) ++ " |\n"
  40.                         ++ "+---+---+---+\n"
  41.                         ++ "| " ++ showCell (cells !? 6)
  42.                            ++ " | " ++ showCell (cells !? 7)
  43.                                ++ " | " ++ showCell (cells !? 8) ++ " |\n"
  44.                         ++ "+---+---+---+\n"
  45.                         ++ "It's " ++ show p ++ "'s turn\n"
  46.  
  47. -- a game tree is a tree with a current board
  48. -- and a list of moves and their outcomes
  49. data GameTreeF b m f = Tree b [(m, f)]
  50.     deriving (Functor)
  51. type GameTree b m = Fix (GameTreeF b m)
  52.  
  53. other :: Player -> Player
  54. other Cross = Nought
  55. other Nought = Cross
  56.  
  57. -- decide on a winner. The first found winner is taken, no matter if more exist
  58. decide :: Board -> Maybe Player
  59. decide (Board p cells) = getAlt $
  60.                          isWinner 0 1 2 <> isWinner 3 4 5 <> isWinner 6 7 8 <>
  61.                          isWinner 0 3 6 <> isWinner 1 4 7 <> isWinner 2 5 8 <>
  62.                          isWinner 0 4 8 <> isWinner 2 4 6 where
  63.     sameAs :: Cell -> Cell -> Cell
  64.     sameAs (Just Cross) (Just Cross) = Just Cross
  65.     sameAs (Just Nought) (Just Nought) = Just Nought
  66.     sameAs _ _ = Nothing
  67.     isWinner a b c = Alt $ (cells !? a) `sameAs` (cells !? b) `sameAs` (cells !? c)
  68.  
  69. initialState :: Board
  70. initialState = (Board Cross (fromList $ map (const Nothing) [0..8]))
  71.  
  72. findMoves :: Board -> [Move]
  73. findMoves (Board p cells) = map fst $ filter (isNothing . snd) $ zip [0..] $ toList cells
  74.  
  75. applyMove :: Board -> Move -> Board
  76. applyMove (Board player cells) move = Board (other player) (update move (Just player) cells)
  77.  
  78. fullGameTree :: Board -> GameTree Board Move
  79. fullGameTree = ana singleStep where
  80.     singleStep board = Tree board $ map (id &&& applyMove board) (findMoves board)
  81.  
  82. -- TTT is decidable, so either -1 | 0 | 1
  83. data MinimaxRating = Loss | Draw | Win deriving (Eq, Ord, Show)
  84. invertRating Win = Loss
  85. invertRating Draw = Draw
  86. invertRating Loss = Win
  87.  
  88. minimax :: GameTree Board Move -> (MinimaxRating, [Move])
  89. minimax = cata singleStep where
  90.     mergeInMove (m, (r, ms)) = (invertRating r, m:ms)
  91.     compareMoves (m, ms) (n, ns) = compare m n <> compare (length ns) (length ms)
  92.     singleStep (Tree board []) = (Draw, [])
  93.     singleStep (Tree board moves) = case decide board of
  94.         Just winner | winner == getPlayer board -> (Win, [])
  95.         Just winner -> (Loss, [])
  96.         Nothing -> maximumBy compareMoves $ map mergeInMove moves
  97.  
  98. --computeKITree :: GameTree Board Move -> GameTree (Board, MinimaxRating, [Move]) Move
  99. --computeKITree = _
  100.  
  101. playMove = flip applyMove
  102. crossWin :: Board -> Board
  103. crossWin = playMove 6 . playMove 8
  104.  
  105. main = putStrLn $ show $ minimax . fullGameTree $ crossWin $ initialState
  106.  
  107.  
Success #stdin #stdout 0s 0KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
(Win,[5,7,2])
https://ideone.com/4QxrQz
language:
Haskell (ghc 8.4.4)
created:
6 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!