introducing prob monad

skat.cabal

@@ -1,10 +1,10 @@
 cabal-version: 1.12
 
+-- This file has been generated from package.yaml by hpack version 0.35.0.
 --
 -- see: https://github.com/sol/hpack
 --
+-- hash: ad886ff4da12419d3067287c82ddcc50c9a54d9d56bd4d4d640929eac6c0bbc5
 
 name:           skat
 version:        0.1.0.8
@@ -29,6 +29,7 @@ library
   exposed-modules:
       Skat
       Skat.AI.Human
+      Skat.AI.Markov
       Skat.AI.Minmax
       Skat.AI.Online
       Skat.AI.Rulebased

src/Skat/AI/Markov.hs

@@ -0,0 +1,413 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+
+module Skat.AI.Markov (
+) where
+
+import Control.Monad.State
+import Control.Exception (assert)
+import Control.Monad.Fail
+import Data.Ord
+import Text.Read (readMaybe)
+import Data.List (maximumBy, sortBy)
+import Debug.Trace
+import Data.Ratio
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import qualified Skat as S
+import qualified Skat.Card as S
+import qualified Skat.Operations as S
+import qualified Skat.Pile as S
+import qualified Skat.Player as S hiding (trumpColour, turnColour)
+import qualified Skat.Render as S
+--import TestEnvs (env3, shuffledEnv2)
+
+data Probability d a = Or (Set a) d
+                     | Probability { value :: a
+                                   , probability :: d
+                                   }
+
+newtype Distribution d a = Distribution { runDistribution :: [Probability d a] }
+
+instance Num d => Monad (Distribution d) where
+    return :: a -> Distribution d a
+    return x = Distribution [Probability x 1]
+    (>>=) :: Distribution d a -> (a -> Distribution d b) -> Distribution d b
+    (Distribution ps) >>= f = Distribution $ do
+        (Probability x1 p1) <- ps
+        let (Distribution ds) = f x1
+        (Probability x2 p2) <- ds
+        return $ Probability x2 (p1*p2)
+
+instance Num d => Applicative (Distribution d) where
+    pure = return
+    (<*>) = ap
+
+instance Num d => Functor (Distribution d) where
+    fmap = liftM
+
+sumDist :: (Num d, Ord a) => Distribution d a -> Distribution d a
+sumDist = distFromMap . distToMap
+    where distToMap (Distribution ps) = Map.fromListWith (+) $ do
+            (Probability x p) <- ps
+            return (x, p)
+          distFromMap m = Distribution $ do
+            (x, p) <- Map.toList m
+            return $ Probability x p
+
+deriving instance (Show d, Show a) => Show (Probability d a)
+deriving instance (Show d, Show a) => Show (Distribution d a)
+deriving instance (Eq d, Eq a) => Eq (Probability d a)
+deriving instance (Eq d, Eq a) => Eq (Distribution d a)
+deriving instance (Ord d, Ord a) => Ord (Probability d a)
+deriving instance (Ord d, Ord a) => Ord (Distribution d a)
+
+draw :: StateT (Set S.Card) (Distribution Rational) S.Card
+draw = do
+    cards <- get
+    card <- lift $ Distribution $ Set.toList $ Set.map (flip Probability $ (1 % (fromIntegral $ length cards))) cards
+    let cards' = Set.delete (card) cards
+    put cards'
+    return card
+
+{-
+draw2 :: StateT (Set S.Card) Identity (Distribution Rational S.Card)
+draw2 = do
+    cards <- get
+    cards <- get
+    card <- lift $ Distribution $ Set.toList $ Set.map (flip Probability $ (1 % (fromIntegral $ length cards))) cards
+    let cards' = Set.delete (card) cards
+    put cards'
+    return card
+-}
+
+coprod :: (Ord a, Num d) => Probability d a -> Probability d a -> Probability d a
+coprod (Probability x p) (Probability y q) = Or (Set.fromList [x,  y]) $ p + q
+
+skat :: Distribution Rational (Set S.Card, Set S.Card, Set S.Card, Set S.Card)
+skat = (flip evalStateT) (Set.fromList $ take 8 S.allCards) $ do
+    fstHand <- replicateM 2 draw
+    sndHand <- replicateM 2 draw
+    trdHand <- replicateM 2 draw
+    skt <- replicateM 2 draw
+    return ( Set.fromList fstHand
+           , Set.fromList sndHand
+           , Set.fromList trdHand
+           , Set.fromList skt
+           )
+
+coin :: Distribution Rational Bool
+coin = Distribution [ Probability True (1%2), Probability False (1%2)]
+
+tosstwice :: Distribution Rational (Bool, Bool)
+tosstwice = do
+    c1 <- coin
+    c2 <- coin
+    return (c1, c2)
+
+debug :: Bool
+debug = False
+
+class (Ord v, Eq v) => Value v where
+    invert :: v -> v
+    win :: v
+    loss :: v
+
+class Player p where
+    maxing :: p -> Bool
+
+class (Traversable l, Monad m, Value v, Player p, Eq t) => MonadGame t l v p m | m -> t, m -> p, m -> v, m -> l where
+    currentPlayer :: m p
+    turns :: m (l t)
+    play :: t -> m ()
+    simulate :: t -> m a -> m a
+    evaluate :: m v
+    over :: m Bool
+
+class (MonadIO m, Show t, Show v, Show p, MonadGame t l v p m) => PlayableGame t l v p m | m -> t, m -> p, m -> v where
+    showTurns :: m ()
+    showBoard :: m ()
+    askTurn :: m (Maybe t)
+    showTurn :: t -> m ()
+    winner :: m (Maybe p)
+
+-- Skat implementation
+
+instance Player S.PL where
+    maxing p = S.team p == S.Team
+
+instance Value Int where
+    invert = negate
+    win = 120
+    loss = -120
+
+instance MonadGame (S.CardS S.Owner) [] Int S.PL S.Skat where
+    currentPlayer = do
+        hand <- gets S.currentHand
+        pls <- gets S.players
+        return $! S.player pls hand
+    turns = S.allowedCards
+        --player <- currentPlayer
+        --trCol <- gets S.trumpColour
+        --return $! if maxing player
+        --    then sortBy (optimalTeam trCol) cards
+        --    else sortBy (optimalSingle trCol) cards
+    play = S.play_
+    simulate card action = do
+        --oldCurrent <- gets S.currentHand
+        --oldTurnCol <- gets S.turnColour
+        backup <- get
+        play card
+        --oldWinner <- currentPlayer
+        res <- action
+        --S.undo_ card oldCurrent oldTurnCol (S.team oldWinner)
+        put backup
+        return $! res
+    over = ((==0) . length) <$!> S.allowedCards
+    evaluate = do
+        player <- currentPlayer
+        piles <- gets S.piles
+        let (sgl, tm) = S.count piles
+        return $! (if maxing player then tm - sgl else sgl - tm)
+
+potentialByType :: S.Type -> Int
+potentialByType S.Ace = 11
+potentialByType S.Jack = 10
+potentialByType S.Ten = 4
+potentialByType S.Seven = 7
+potentialByType S.Eight = 7
+potentialByType S.Nine = 7
+potentialByType S.Queen = 5
+potentialByType S.King = 5
+
+optimalSingle :: S.Colour -> S.Card -> S.Card -> Ordering
+optimalSingle trCol (S.Card t1 _) (S.Card t2 _) = (comparing potentialByType) t2 t1
+
+optimalTeam :: S.Colour -> S.Card -> S.Card -> Ordering
+optimalTeam trCol (S.Card t1 _) (S.Card t2 _) = (comparing potentialByType) t2 t1
+
+-- TIC TAC TOE implementation
+
+data TicTacToe = Tic | Tac | Toe
+                 deriving (Eq, Ord)
+
+instance Show TicTacToe where
+    show Tic = "O"
+    show Tac = "X"
+    show Toe = "_"
+
+data WinLossTie = Loss | Tie | Win
+                  deriving (Eq, Show, Ord)
+
+instance Value WinLossTie where
+    invert Win = Loss
+    invert Loss = Win
+    invert Tie = Tie
+    win = Win
+    loss = Loss
+
+data GameState = GameState { getBoard :: [TicTacToe]
+                           , getCurrent :: Bool }
+             deriving Show
+
+instance Player Bool where
+    maxing = id
+
+instance Monad m => MonadGame Int [] WinLossTie Bool (StateT GameState m) where
+    currentPlayer = gets getCurrent
+    turns = do
+        board <- gets getBoard
+        let fields = zip [0..] board
+        return $ map fst $ filter ((==Toe) . snd) fields
+    play turn = do
+        env <- get
+        let value = if getCurrent env then Tic else Tac
+            board' = updateAt turn (getBoard env) value
+            current' = not $ getCurrent env
+        put $ GameState board' current'
+    simulate turn action = do
+        backup <- get
+        play turn
+        res <- action
+        put backup
+        return $! res
+    evaluate = do
+        board <- gets getBoard
+        current <- currentPlayer
+        let mayWinner = ticWinner board
+        case mayWinner of
+            Just Tic -> return $ if current then Win else Loss
+            Just Tac -> return $ if current then Loss else Win
+            Just Toe -> return Tie
+            Nothing -> return Tie
+    over = do
+        board <- gets getBoard
+        case ticWinner board of
+            Just _ -> return True
+            _      -> return False
+
+ticWinner :: [TicTacToe] -> Maybe TicTacToe
+ticWinner board
+    | ticWon    = Just Tic
+    | tacWon    = Just Tac
+    | over      = Just Toe
+    | otherwise = Nothing
+  where ticWon = hasWon $ map (==Tic) board
+        tacWon = hasWon $ map (==Tac) board
+        hasWon (True:_:_:True:_:_:True:_:_:[]) = True
+        hasWon (True:_:_:_:True:_:_:_:True:[]) = True
+        hasWon (_:True:_:_:True:_:_:True:_:[]) = True
+        hasWon (_:_:True:_:_:True:_:_:True:[]) = True
+        hasWon (_:_:True:_:True:_:True:_:_:[]) = True
+        hasWon (True:True:True:_:_:_:_:_:_:[]) = True
+        hasWon (_:_:_:True:True:True:_:_:_:[]) = True
+        hasWon (_:_:_:_:_:_:True:True:True:[]) = True
+        hasWon _                               = False
+        over = (length $ filter (==Toe) board) == 0
+
+updateAt :: Int -> [a] -> a -> [a]
+updateAt n xs y = map f $ zip [0..] xs
+    where f (i, x) = if i == n then y else x
+
+toss :: Distribution Rational Coin
+toss = Distribution [Probability Head (1%2), Probability Tail (1%2)]
+
+data Coin = Head
+          | Tail
+            deriving (Show, Eq, Ord)
+
+data CoinGameState = CGS { tosses :: [Coin]
+                         , turn :: Int }
+                     deriving (Show, Eq)
+
+initCGS :: CoinGameState
+initCGS = CGS { tosses = []
+              , turn = 0
+              }
+
+markov :: StateT CoinGameState (Distribution Rational) Int
+markov = do
+    coin <- lift toss
+    cgs <- get
+    let newtosses = coin:(tosses cgs)
+        newturn = turn cgs + 1
+    put $ cgs { tosses = newtosses
+              , turn = newturn }
+    if length (filter (==Head) newtosses) >= 3 || (newturn >= 10)
+        then return newturn
+        else markov
+
+{-
+choose :: (MonadIO m, Show v, Show t, Show p, Value v, Eq t, Player p, MonadGame t l v p m)
+       => Int
+       -> m t
+choose depth = fst <$> minmax depth (error "choose") loss win
+
+emptyBoard :: [TicTacToe]
+emptyBoard = [Toe, Toe, Toe, Toe, Toe, Toe, Toe, Toe, Toe]
+
+otherBoard :: [TicTacToe]
+otherBoard = [Tic, Tac, Tac, Tic, Tac, Tic, Toe, Tic, Toe]
+
+print9x9 :: (Int -> IO ()) -> IO ()
+print9x9 pr = pr 0 >> pr 1 >> pr 2 >> putStrLn ""
+    >> pr 3 >> pr 4 >> pr 5 >> putStrLn ""
+    >> pr 6 >> pr 7 >> pr 8 >> putStrLn ""
+
+printBoard :: [TicTacToe] -> IO ()
+printBoard board = print9x9 pr >> putStrLn ""
+    where pr n = putStr (show $ board !! n) >> putStr " "
+
+printOptions :: [Int] -> IO ()
+printOptions opts = print9x9 pr
+    where pr n
+            | n `elem` opts = putStr (show n) >> putStr " "
+            | otherwise     = putStr "  "
+
+instance MonadIO m => PlayableGame Int [] WinLossTie Bool (StateT GameState m) where
+    showBoard = do
+        board <- gets getBoard
+        liftIO $ printBoard board
+    showTurns = turns >>= liftIO . printOptions
+    winner = do
+        board <- gets getBoard
+        let win = ticWinner board
+        case win of
+            Just Toe -> return Nothing
+            Just Tic -> return $ Just True
+            Just Tac -> return $ Just False
+            Nothing -> return Nothing
+    askTurn = readMaybe <$> liftIO getLine
+    showTurn _ = return ()
+
+instance PlayableGame (S.CardS S.Owner) [] Int S.PL S.Skat where
+    showBoard = do
+        liftIO $ putStrLn ""
+        table <- S.getp S.tableCards
+        liftIO $ putStr "Table: "
+        liftIO $ print table
+    showTurns = do
+        cards <- turns
+        player <- currentPlayer
+        liftIO $ print player
+        liftIO $ S.render cards
+    winner = do
+        piles <- gets S.piles
+        pls <- gets S.players
+        let res = S.count piles :: (Int, Int)
+            winnerTeam = trace (show res) $ if fst res > snd res then S.Single else S.Team
+            winners = filter ((==winnerTeam) . S.team) (S.playersToList pls)
+        return $ Just $ head winners
+    askTurn = do
+        cards <- turns
+        let sorted = cards
+        input <- liftIO getLine
+        case readMaybe input of
+            Just n -> if n >= 0 && n < length sorted then return $ Just (sorted !! n)
+                else return Nothing
+            Nothing -> return Nothing
+    showTurn card = do
+        player <- currentPlayer
+        liftIO $ putStrLn $ show player ++ " plays " ++ show card
+
+playCLI :: (MonadFail m, Read t, PlayableGame t l v p m) => m ()
+playCLI = do
+    gameOver <- over
+    if gameOver
+        then announceWinner
+        else do
+            when debug showBoard
+            current <- currentPlayer
+            turn <- choose 10
+            when debug $ showTurn turn
+            play turn
+            playCLI
+   where
+      readTurn :: (MonadFail m, Read t, PlayableGame t l v p m) => m t
+      readTurn = do
+        options <- turns
+        showTurns
+        liftIO $ putStr "> "
+        mayTurn <- askTurn
+        case mayTurn of
+            Just val -> if val `elem` options then return val else readTurn
+            Nothing -> readTurn
+      announceWinner = do
+        showBoard
+        win <- winner
+        liftIO $ putStrLn $ show win ++ " wins the game!"
+
+playTicTacToe :: IO ()
+playTicTacToe = void $ (flip runStateT) (GameState emptyBoard True) playCLI
+-}