add ai system and a decent simulation based ai

.gitignore

@@ -0,0 +1,8 @@
+*
+
+!*.*
+!*/
+
+*.hi
+*.o
+*.prof

AI/Human.hs

@@ -0,0 +1,37 @@
+module AI.Human where
+
+import Control.Monad.Trans (liftIO)
+
+import Player
+import Pile
+import Card
+import Utils
+import Render
+
+data Human = Human { getTeam :: Team
+                   , getHand :: Hand }
+              deriving Show
+
+instance Player Human where
+    team = getTeam
+    hand = getHand
+    chooseCard p table _ hand = do
+        trumpCol <- trumpColour
+        turnCol <- turnColour
+        let possible = filter (isAllowed trumpCol turnCol hand) hand
+        c <- liftIO $ askIO (map getCard table) possible hand
+        return $ (c, p)
+
+askIO :: [Card] -> [Card] -> [Card] -> IO Card
+askIO table possible hand = do
+    putStrLn "Your hand"
+    render hand
+    putStrLn "These options are possible"
+    render possible
+    putStrLn "These cards are on the table"
+    render table
+    idx <- query
+        "Which card do you want to play? Give the index of the card"
+    if idx >= 0 && idx < length possible
+        then return $ possible !! idx
+        else askIO table possible hand

AI/Rulebased.hs

@@ -0,0 +1,405 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module AI.Rulebased (
+    mkAIEnv
+) where
+
+import Data.Ord
+import Data.Monoid ((<>))
+import Data.List
+import Control.Monad.State
+import Control.Monad.Reader
+import qualified Data.Map.Strict as M
+
+import Player
+import qualified Player.Utils as P
+import Pile
+import Card
+import Utils
+import Skat (Skat, modifyp, mkSkatEnv) 
+import Operations
+
+data AIEnv = AIEnv { getTeam :: Team
+                   , getHand :: Hand
+                   , table :: [CardS Played]
+                   , fallen :: [CardS Played]
+                   , myHand :: [Card]
+                   , guess :: Guess
+                   , simulationDepth :: Int }
+             deriving Show
+
+setTable :: [CardS Played] -> AIEnv -> AIEnv
+setTable tab env = env { table = tab }
+
+setHand :: [Card] -> AIEnv -> AIEnv
+setHand hand env = env { myHand = hand }
+
+setFallen :: [CardS Played] -> AIEnv -> AIEnv
+setFallen fallen env = env { fallen = fallen }
+
+setDepth :: Int -> AIEnv -> AIEnv
+setDepth depth env = env { simulationDepth = depth }
+
+modifyg :: MonadPlayer m => (Guess -> Guess) -> AI m ()
+modifyg f = modify g
+    where g env@(AIEnv {guess}) = env { guess = f guess }
+    
+type AI m = StateT AIEnv m
+
+instance MonadPlayer m => MonadPlayer (AI m) where
+    trumpColour = lift $ trumpColour
+    turnColour = lift $ turnColour
+    showSkat = lift . showSkat
+
+instance MonadPlayerOpen m => MonadPlayerOpen (AI m) where
+    showPiles = lift $ showPiles
+
+type Simulator m = ReaderT Piles (AI m)
+
+instance MonadPlayer m => MonadPlayer (Simulator m) where
+    trumpColour = lift $ trumpColour
+    turnColour = lift $ turnColour
+    showSkat = lift . showSkat
+
+instance MonadPlayer m => MonadPlayerOpen (Simulator m) where
+    showPiles = ask
+
+runWithPiles :: MonadPlayer m
+             => Piles -> Simulator m a -> AI m a
+runWithPiles ps sim = runReaderT sim ps
+
+instance Player AIEnv where
+    team = getTeam
+    hand = getHand
+    chooseCard p table fallen hand = runStateT (do
+        modify $ setTable table
+        modify $ setHand hand
+        modify $ setFallen fallen
+        choose) p
+    onCardPlayed p card = execStateT (do
+        onPlayed card) p
+    chooseCardOpen p = evalStateT chooseOpen p
+
+value :: Card -> Int
+value (Card Ace _) = 100
+value _            = 0
+
+data Option = H Hand
+            | Skt
+              deriving (Show, Eq, Ord)
+
+-- | possible card distributions
+type Guess = M.Map Card [Option]
+
+newGuess :: Guess
+newGuess = M.fromList l
+    where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) allCards
+
+hasBeenPlayed :: Card -> Guess -> Guess
+hasBeenPlayed card = M.delete card
+
+has :: Hand -> [Card] -> Guess -> Guess
+has hand cs = M.mapWithKey f
+    where f card hands
+            | card `elem` cs = [H hand]
+            | otherwise      = hands
+
+hasNoLonger :: MonadPlayer m => Hand -> Colour -> AI m ()
+hasNoLonger hand colour = do
+    trCol <- trumpColour
+    modifyg $ hasNoLonger_ trCol hand colour
+
+hasNoLonger_ :: Colour -> Hand -> Colour -> Guess -> Guess
+hasNoLonger_ trColour hand effCol = M.mapWithKey f
+    where f card hands
+            | effectiveColour trColour card == effCol && (H hand) `elem` hands = filter (/=H hand) hands
+            | otherwise = hands
+
+isSkat :: [Card] -> Guess -> Guess
+isSkat cs = M.mapWithKey f
+    where f card hands
+            | card `elem` cs = [Skt]
+            | otherwise      = hands
+
+type Turn = (CardS Played, CardS Played, CardS Played)
+
+analyzeTurn :: MonadPlayer m => Turn -> AI m ()
+analyzeTurn (c1, c2, c3) = do
+    modifyg (getCard c1 `hasBeenPlayed`)
+    modifyg (getCard c2 `hasBeenPlayed`)
+    modifyg (getCard c3 `hasBeenPlayed`)
+    trCol <- trumpColour
+    let turnCol = getColour $ getCard c1
+        demanded = effectiveColour trCol (getCard c1)
+        col2 = effectiveColour trCol (getCard c2)
+        col3 = effectiveColour trCol (getCard c3)
+    if col2 /= demanded
+        then origin c2 `hasNoLonger` demanded
+        else return ()
+    if col3 /= demanded
+        then origin c3 `hasNoLonger` demanded
+        else return ()
+
+type Distribution = ([Card], [Card], [Card], [Card])
+
+toPiles :: [CardS Played] -> Distribution -> Piles
+toPiles table (h1, h2, h3, skt) = Piles (cs1 ++ cs2 ++ cs3) table ss
+    where cs1 = map (putAt Hand1) h1
+          cs2 = map (putAt Hand2) h2
+          cs3 = map (putAt Hand3) h3
+          ss  = map (putAt SkatP) skt
+
+distributions :: Guess -> (Int, Int, Int, Int) -> [Distribution]
+distributions guess nos =
+        helper (sortBy (comparing $ length . snd) $ M.toList guess) nos
+    where helper []           _ = []
+          helper ((c, hs):[]) ns = map fst (distr c hs ns)
+          helper ((c, hs):gs) ns =
+                let dsWithNs = distr c hs ns
+                    go (d, ns') = map (d <>) (helper gs ns')
+                in concatMap go dsWithNs
+          distr card hands (n1, n2, n3, n4) =
+                let f card (H Hand1) =
+                        (([card], [], [], []), (n1+1, n2, n3, n4))
+                    f card (H Hand2) =
+                        (([], [card], [], []), (n1, n2+1, n3, n4))
+                    f card (H Hand3) =
+                        (([], [], [card], []), (n1, n2, n3+1, n4))
+                    f card Skt =
+                        (([], [], [], [card]), (n1, n2, n3, n4+1))
+                    isOk (H Hand1) = n1 < cardsPerHand
+                    isOk (H Hand2) = n2 < cardsPerHand
+                    isOk (H Hand3) = n3 < cardsPerHand
+                    isOk Skt       = n4 < 2
+                in filterMap isOk (f card) hands
+          cardsPerHand = (length guess - 2) `div` 3
+
+simplify :: Int -> [Distribution] -> [Distribution]
+simplify 10 ds = nubBy is789Variation ds
+simplify _ ds = ds
+
+is789Variation :: Distribution -> Distribution -> Bool
+is789Variation (ha1, ha2, ha3, sa) (hb1, hb2, hb3, sb) =
+        f ha1 hb1 && f ha2 hb2 && f ha3 hb3 && f sa sb
+    where f cs1 cs2
+             | n789s cs1 /= n789s cs2 = False
+             | otherwise = and (zipCs (c789s cs1) (c789s cs2))
+
+zipCs :: [[Card]] -> [[Card]] -> [Bool]
+zipCs xs ys = zipWith g xs ys
+
+c789s :: [Card] -> [[Card]]
+c789s cs = groupBy (grouping getColour) $
+    sortBy (comparing getColour) $
+    filter ((==(0 :: Int)) . count) cs
+
+n789s :: [Card] -> [Card]
+n789s cs = filter ((/=(0 :: Int)) . count) cs
+
+g :: [a] -> [b] -> Bool
+g xs ys = length xs == length ys
+
+onPlayed :: MonadPlayer m => CardS Played -> AI m ()
+onPlayed c = do
+    liftIO $ print c
+    modifyg (getCard c `hasBeenPlayed`)
+    trCol <- trumpColour
+    turnCol <- turnColour
+    let col = effectiveColour trCol (getCard c)
+    case turnCol of
+        Just demanded -> if col /= demanded
+            then origin c `hasNoLonger` demanded else return ()
+        Nothing -> return ()
+
+choose :: MonadPlayer m => AI m Card
+choose = do
+    handCards <- gets myHand
+    table <- gets table
+    case length table of
+        0 -> if length handCards >= 7
+            then chooseLead
+            else chooseStatistic
+        n -> chooseStatistic
+
+chooseStatistic :: MonadPlayer m => AI m Card
+chooseStatistic = do
+    h <- gets getHand
+    handCards <- gets myHand
+    let depth = case length handCards of
+                    0 -> 0
+                    1 -> 1
+                    -- simulate whole game
+                    2 -> 2
+                    3 -> 3
+                    -- simulate only partially
+                    4 -> 2
+                    5 -> 1
+                    6 -> 1
+                    7 -> 1
+                    8 -> 1
+                    9 -> 1
+                    10 -> 1
+    modify $ setDepth depth
+    guess__ <- gets guess
+    self <- get
+    maySkat <- showSkat self
+    let guess_ = (hand self `has` handCards) guess__
+        guess = case maySkat of
+            Just cs -> (cs `isSkat`) guess_
+            Nothing -> guess_
+    table <- gets table
+    let ns = case length table of
+                0 -> (0,  0,  0, 0)
+                1 -> (-1, 0, -1, 0)
+                2 -> (0,  0, -1, 0)
+    let dis = distributions guess ns
+        disNo = length dis
+        piless = map (toPiles table) dis
+        limit = if depth == 1 && length table == 2
+            then 1
+            else min 10000 $ disNo `div` 2
+    liftIO $ putStrLn $ "possible distrs " ++ show disNo
+    vals <- M.toList <$> foldWithLimit limit runOnPiles M.empty piless
+    liftIO $ print vals
+    return $ fst $ maximumBy (comparing snd) vals
+
+foldWithLimit :: Monad m
+              => Int
+              -> (M.Map k Int -> a -> m (M.Map k Int))
+              -> M.Map k Int
+              -> [a]
+              -> m (M.Map k Int)
+foldWithLimit _     _ start []     = return start
+foldWithLimit limit f start (x:xs) = do
+    case M.size (M.filter (>=limit) start) of
+        0 -> do m <- f start x
+                foldWithLimit limit f m xs
+        _ -> return start
+
+runOnPiles :: MonadPlayer m
+           => M.Map Card Int -> Piles -> AI m (M.Map Card Int)
+runOnPiles m ps = do
+    c <- runWithPiles ps chooseOpen
+    return $ M.insertWith (+) c 1 m
+
+chooseOpen :: (MonadState AIEnv m, MonadPlayerOpen m) => m Card
+chooseOpen = do
+    piles <- showPiles
+    hand <- gets getHand
+    let myCards = handCards hand piles
+    possible <- filterM (P.isAllowed myCards) myCards
+    case length myCards of
+        0 -> do
+            liftIO $ print hand
+            liftIO $ print piles
+            error "no cards left to choose from"
+        1 -> return $ head myCards
+        _ -> chooseSimulating
+
+chooseSimulating :: (MonadState AIEnv m, MonadPlayerOpen m)
+                 => m Card
+chooseSimulating = do
+    piles <- showPiles
+    hand <- gets getHand
+    let myCards = handCards hand piles
+    possible <- filterM (P.isAllowed myCards) myCards
+    case possible of
+        [card] -> return card
+        cs -> do
+            results <- mapM simulate cs
+            let both = zip results cs
+                best = maximumBy (comparing fst) both
+            return $ snd best
+
+simulate :: (MonadState AIEnv m, MonadPlayerOpen m)
+         => Card -> m Int
+simulate card = do
+    -- retrieve all relevant info
+    piles <- showPiles
+    turnCol <- turnColour
+    trumpCol <- trumpColour
+    myTeam <- gets getTeam
+    myHand <- gets getHand
+    depth <- gets simulationDepth
+    let newDepth = depth - 1
+        -- create a virtual env with 3 ai players
+        ps = Players
+            (PL $ mkAIEnv Team Hand1 newDepth)
+            (PL $ mkAIEnv Team Hand2 newDepth)
+            (PL $ mkAIEnv Single Hand3 newDepth)
+        env = mkSkatEnv piles turnCol trumpCol ps
+    -- simulate the game after playing the given card
+    (sgl, tm) <- liftIO $ evalStateT (do
+        modifyp $ playCard card
+        turnGeneric playOpen depth (next myHand)) env
+    let v = if myTeam == Single then (sgl, tm) else (tm, sgl)
+    -- put the value into context for when not the whole game is
+    -- simulated
+    predictValue v
+
+predictValue :: (MonadState AIEnv m, MonadPlayerOpen m)
+             => (Int, Int) -> m Int
+predictValue (own, others) = do
+    hand <- gets getHand
+    piles <- showPiles
+    let cs = handCards hand piles
+    pot <- potential cs
+    return $ own + pot
+
+potential :: (MonadState AIEnv m, MonadPlayerOpen m)
+          => [Card] -> m Int
+potential cs = do
+    tr <- trumpColour
+    let trs = filter (isTrump tr) cs
+        value = count cs
+    positions <- filter (==0) <$> mapM position cs
+    return $ length trs * 10 + value + length positions * 5
+
+position :: (MonadState AIEnv m, MonadPlayer m)
+         => Card -> m Int
+position card = do
+    tr <- trumpColour
+    guess <- gets guess
+    let effCol = effectiveColour tr card
+        l = M.toList guess
+        cs = filterMap ((==effCol) . effectiveColour tr . fst) fst l
+        csInd = zip [0..] cs
+        Just (pos, _) = find ((== card) . snd) csInd
+    return pos
+
+leadPotential :: (MonadState AIEnv m, MonadPlayer m)
+              => Card -> m Int
+leadPotential card = do
+    pos <- position card
+    isTr <- P.isTrump card 
+    let value = count card
+    case pos of
+        0 -> return value
+        _ -> return $ -value
+
+chooseLead :: (MonadState AIEnv m, MonadPlayer m) => m Card
+chooseLead = do
+    cards <- gets myHand
+    possible <- filterM (P.isAllowed cards) cards
+    pots <- mapM leadPotential possible
+    return $ snd $ maximumBy (comparing fst) (zip pots possible)
+
+mkAIEnv :: Team -> Hand -> Int -> AIEnv
+mkAIEnv tm h depth = AIEnv tm h [] [] [] newGuess depth
+
+-- | TESTING VARS
+
+aienv :: AIEnv
+aienv = AIEnv Single Hand3 [] [] [] newGuess 10
+
+testguess :: Guess
+testguess = isSkat (take 2 $ drop 10 allCards)
+        $ Hand3 `has` (take 10 allCards) $ m
+    where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) (take 32 allCards)
+          m = M.fromList l
+
+testds :: [Distribution]
+testds = distributions testguess (0, 0, 0, 0)

AI/Stupid.hs

@@ -0,0 +1,18 @@
+module AI.Stupid where
+
+import Player
+import Pile
+import Card
+
+data Stupid = Stupid { getTeam :: Team
+                     , getHand :: Hand }
+              deriving Show
+
+instance Player Stupid where
+    team = getTeam
+    hand = getHand
+    chooseCard p _ _ hand = do
+        trumpCol <- trumpColour
+        turnCol <- turnColour
+        let possible = filter (isAllowed trumpCol turnCol hand) hand
+        return (head possible, p)

AI/Test.hs

@@ -0,0 +1,39 @@
+import Card
+import Pile
+import Utils
+
+import qualified Data.Map.Strict as M
+import Data.Monoid ((<>))
+
+type Guess = M.Map Card [Hand]
+type Distribution = ([Card], [Card], [Card])
+
+distributions :: Guess -> [Distribution]
+distributions guess = --filter equilibrated
+        (helper (M.toList guess) (0, 0, 0))
+    where helper []           _ = []
+          helper ((c, hs):[]) ns = map fst (distr c hs ns)
+          helper ((c, hs):gs) ns =
+                let dsWithNs = distr c hs ns
+                    go (d, ns') = map (d <>) (helper gs ns')
+                in concatMap go dsWithNs
+          distr card hands (n1, n2, n3) =
+                let f card Hand1 = (([card], [], []), (n1+1, n2, n3))
+                    f card Hand2 = (([], [card], []), (n1, n2+1, n3))
+                    f card Hand3 = (([], [], [card]), (n1, n2, n3+1))
+                    isOk Hand1 = n1 < cardsPerHand
+                    isOk Hand2 = n2 < cardsPerHand
+                    isOk Hand3 = n3 < cardsPerHand
+                in filterMap isOk (f card) hands
+          equilibrated (cs1, cs2, cs3) =
+              let ls = [length cs1, length cs2, length cs3]
+              in (maximum ls - minimum ls) <= 1 
+          cardsPerHand = (length guess `div` 3)
+
+testguess :: Guess
+testguess = foldr (Hand3 `has`) m (take 10 allCards)
+    where l = map (\c -> (c, [Hand1, Hand2, Hand3])) (take 30 allCards)
+          m = M.fromList l
+
+main :: IO ()
+main = print $ length $ distributions testguess

Card.hs

@@ -1,8 +1,15 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+
 module Card where
 
 import Data.List
+import System.Random (newStdGen)
 import Utils
 
+class Countable a b where
+    count :: a -> b
+
 data Type = Seven
           | Eight
           | Nine
@@ -13,13 +20,13 @@ data Type = Seven
           | Jack
             deriving (Eq, Ord, Show, Enum)
 
-countType :: Type -> Int
-countType Ace   = 11
-countType Ten   = 10
-countType King  = 4
-countType Queen = 3
-countType Jack  = 2
-countType _     = 0
+instance Countable Type Int where
+    count Ace   = 11
+    count Ten   = 10
+    count King  = 4
+    count Queen = 3
+    count Jack  = 2
+    count _     = 0
 
 data Colour = Diamonds
             | Hearts
@@ -28,75 +35,16 @@ data Colour = Diamonds
               deriving (Eq, Ord, Show, Enum, Read)
 
 data Card = Card Type Colour
-            deriving (Eq, Show)
+            deriving (Eq, Show, Ord)
 
-countCard :: Card -> Int
-countCard (Card t _) = countType t
+getColour :: Card -> Colour
+getColour (Card _ c) = c
 
-count :: [Card] -> Int
-count = sum . map countCard
+instance Countable Card Int where
+    count (Card t _) = count t
 
-data Team = Team | Single
-            deriving (Show, Eq, Ord, Enum)
-
-data Space = Table | Hand1 | Hand2 | Hand3 | WonTeam | WonSingle | SkatP
-             deriving (Show, Eq, Ord, Enum)
-
-teamPile :: Team -> Space
-teamPile Team = WonTeam
-teamPile Single = WonSingle
-
-playerHand :: Index -> Space
-playerHand One = Hand1
-playerHand Two = Hand2
-playerHand Three = Hand3
-
-playerOfHand :: Space -> Index
-playerOfHand Hand1 = One
-playerOfHand Hand2 = Two
-playerOfHand Hand3 = Three
-
-data CardS = CardS { getCard :: Card
-                   , getSpace :: Space
-                   , getOwner :: Space }
-             deriving (Show, Eq)
-
-moveCard :: Card -> Space -> [CardS] -> [CardS]
-moveCard card sp cards = map f cards
-    where f c = if card == getCard c then c { getSpace = sp } else c
-
-findCards :: Space -> [CardS] -> [Card]
-findCards sp cards = foldr f [] cards
-    where f (CardS c s _) cs
-                | s == sp   = c : cs 
-                | otherwise = cs
-
-data Index = One | Two | Three
-             deriving (Show, Ord, Eq, Enum)
-
-next :: Index -> Index
-next One = Two
-next Two = Three
-next Three = One
-
-prev :: Index -> Index
-prev One = Three
-prev Two = One
-prev Three = Two
-
-data Player = Player { team :: Team
-                     , index :: Index }
-              deriving Show
-
-data Players = Players Player Player Player
-               deriving Show
-
-player :: Players -> Index -> Player
-player (Players p _ _) One   = p
-player (Players _ p _) Two   = p
-player (Players _ _ p) Three = p
-
-type Hand = [Card]
+instance Countable [Card] Int where
+    count = sum . map count
 
 equals :: Colour -> Maybe Colour -> Bool
 equals col (Just x) = col == x
@@ -112,31 +60,40 @@ effectiveColour trumpCol card@(Card _ col) =
     if trump then trumpCol else col
   where trump = isTrump trumpCol card
 
-isAllowed :: Colour -> Maybe Colour -> Hand -> Card -> Bool
+isAllowed :: Colour -> Maybe Colour -> [Card] -> Card -> Bool
 isAllowed trumpCol turnCol cs card =
     if col `equals` turnCol
         then True
         else not $ any (\ca -> effectiveColour trumpCol ca `equals` turnCol && ca /= card) cs
   where col = effectiveColour trumpCol card
 
-putAt :: Space -> Card -> CardS
-putAt sp c = CardS c sp sp
+compareCards :: Colour
+             -> Maybe Colour
+             -> Card
+             -> Card
+             -> Ordering
+compareCards _ _ (Card Jack col1) (Card Jack col2) = compare col1 col2
+compareCards trumpCol turnCol c1@(Card tp1 col1) c2@(Card tp2 col2) =
+    case (trp1, trp2) of
+        (True, True) -> compare tp1 tp2
+        (False, False) -> case compare (col1 `equals` turnCol)
+                                       (col2 `equals` turnCol) of
+                            EQ -> compare tp1 tp2
+                            v -> v
+        _ -> compare trp1 trp2
+  where trp1 = isTrump trumpCol c1
+        trp2 = isTrump trumpCol c2
 
-distribute :: [Card] -> [CardS]
-distribute cards = map (putAt Hand1) hand1
-        ++ map (putAt Hand2) hand2
-        ++ map (putAt Hand3) hand3
-        ++ map (putAt SkatP) skt
-    where round1 = chunksOf 3 (take 9 cards)
-          skt = take 2 $ drop 9 cards
-          round2 = chunksOf 4 (take 12 $ drop 11 cards)
-          round3 = chunksOf 3 (take 9 $ drop 23 cards)
-          hand1 = concatMap (!! 0) [round1, round2, round3]
-          hand2 = concatMap (!! 1) [round1, round2, round3]
-          hand3 = concatMap (!! 2) [round1, round2, round3]
+sortCards :: Colour -> Maybe Colour -> [Card] -> [Card]
+sortCards trumpCol turnCol cs = sortBy (compareCards trumpCol turnCol) cs
 
-playersFromTable :: Players -> [CardS] -> [Player]
-playersFromTable ps = map (player ps . playerOfHand . getOwner)
+highestCard :: Colour -> Maybe Colour -> [Card] -> Card
+highestCard trumpCol turnCol cs = maximumBy (compareCards trumpCol turnCol) cs
+
+shuffleCards :: IO [Card]
+shuffleCards = do
+    gen <- newStdGen
+    return $ shuffle gen allCards
 
 -- TESTING VARS
 
@@ -155,15 +112,10 @@ c4 = Card Queen Hearts
 c5 :: Card
 c5 = Card Jack Clubs
 
-h1 :: Hand
+h1 :: [Card]
 h1 = [c1,c2,c3,c4,c5]
 
 allCards :: [Card]
 allCards = [ Card t c | t <- tps, c <- cols ]
     where tps = [Seven .. Jack]
           cols = [Diamonds .. Clubs]
-
-distributePutSkat :: [Card] -> [CardS]
-distributePutSkat cards = foldr (\c m -> moveCard c WonSingle m) distributed skt
-    where distributed = distribute cards
-          skt = findCards SkatP distributed

Main.hs

@@ -4,13 +4,54 @@ import Control.Monad.State
 
 import Card
 import Skat
-import Reizen
 import Operations
+import Player
+import Pile
 
+import AI.Stupid
+import AI.Human
+import AI.Rulebased
 
 main :: IO ()
-main = do
-    env <- reizen
-    (sgl, tm) <- evalStateT runGame env
-    putStrLn $ "Single player has " ++ show sgl ++ " points."
-    putStrLn $ "Team has " ++ show tm ++ " points."
+main = putStrLn "Hello World"
+
+env :: SkatEnv
+env = SkatEnv piles Nothing Spades playersExamp
+    where piles = distribute allCards 
+
+envStupid :: SkatEnv
+envStupid = SkatEnv piles Nothing Spades pls2
+    where piles = distribute allCards 
+
+playersExamp :: Players
+playersExamp = Players
+    (PL $ Stupid Team Hand1)
+    (PL $ Stupid Team Hand2)
+    (PL $ mkAIEnv Single Hand3 10)
+
+pls2 :: Players
+pls2 = Players
+    (PL $ Stupid Team Hand1)
+    (PL $ Stupid Team Hand2)
+    (PL $ Stupid Team Hand3)
+
+shuffledEnv :: IO SkatEnv
+shuffledEnv = do
+    cards <- shuffleCards
+    return $ SkatEnv (distribute cards) Nothing Spades playersExamp
+
+env2 :: SkatEnv
+env2 = SkatEnv piles Nothing Spades playersExamp
+    where hand1 = [Card Seven Clubs, Card King Clubs, Card Ace Clubs, Card Queen Diamonds]
+          hand2 = [Card Seven Hearts, Card King Hearts, Card Ace Hearts, Card Queen Spades]
+          hand3 = [Card Seven Spades, Card King Spades, Card Ace Spades, Card Queen Clubs]
+          h1 = map (putAt Hand1) hand1
+          h2 = map (putAt Hand2) hand2
+          h3 = map (putAt Hand3) hand3
+          piles = Piles (h1 ++ h2 ++ h3) [] []
+
+testAI :: Int -> IO ()
+testAI n = do
+    let acs = repeat (shuffledEnv >>= evalStateT (turnGeneric playOpen 10 Hand1) )
+    vals <- sequence (take n acs)
+    putStrLn $ "average won points " ++ show (fromIntegral (sum (map fst vals)) / fromIntegral n)

Operations.hs

@@ -7,28 +7,11 @@ import Data.Ord
 
 import Card
 import Skat
+import Pile
+import Player (chooseCard, Players(..), Player(..), PL(..),
+    updatePlayer, playersToList, player)
 import Utils (shuffle)
 
-compareCards :: Colour
-             -> Maybe Colour
-             -> Card
-             -> Card
-             -> Ordering
-compareCards _ _ (Card Jack col1) (Card Jack col2) = compare col1 col2
-compareCards trumpCol turnCol c1@(Card tp1 col1) c2@(Card tp2 col2) =
-    case compare trp1 trp2 of
-        EQ ->
-            case compare (col1 `equals` turnCol)
-                         (col2 `equals` turnCol) of
-                EQ -> compare tp1 tp2
-                v -> v
-        v  -> v
-  where trp1 = isTrump trumpCol c1
-        trp2 = isTrump trumpCol c2
-
-sortCards :: Colour -> Maybe Colour -> [Card] -> [Card]
-sortCards trumpCol turnCol cs = sortBy (compareCards trumpCol turnCol) cs
-
 compareRender :: Card -> Card -> Ordering
 compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of
     EQ -> compare t1 t2
@@ -37,167 +20,69 @@ compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of
 sortRender :: [Card] -> [Card]
 sortRender = sortBy compareRender
 
--- | finishes the calculation of a match
-turning :: Index -> Skat (Int, Int)
-turning n = undefined
-
-turn2 :: Index -> Skat (Int, Int)
-turn2 n = do
-    t <- table
+turnGeneric :: (PL -> Skat Card)
+            -> Int
+            -> Hand
+            -> Skat (Int, Int)
+turnGeneric playFunc depth n = do
+    table <- getp tableCards
     ps <- gets players
     let p = player ps n
-    hand <- cardsAt (playerHand $ index p)
-    if length hand == 0
-        then countGame
-        else case length t of
-            0 -> play p >> turn2 (next n)
-            1 -> do
-                modify (setTurnColour . f . head $ t)
-                play p
-                turn2 (next n)
-            2 -> play p >> evaluateTable >>= turn2
-            3 -> evaluateTable >>= turn2
-   where f (Card _ col) = Just col
+    hand <- getp $ handCards n
+    trCol <- gets trumpColour
+    case length table of
+        0 -> playFunc p >> turnGeneric playFunc depth (next n)
+        1 -> do
+            modify $ setTurnColour
+                (Just $ effectiveColour trCol $ head table)
+            playFunc p
+            turnGeneric playFunc depth (next n)
+        2 -> playFunc p >> turnGeneric playFunc depth (next n)
+        3 -> do
+            w <- evaluateTable
+            if depth <= 1 || length hand == 0
+                then countGame
+                else turnGeneric playFunc (depth - 1) w
 
-simulate :: Team -> Index -> Skat (Int, Int)
-simulate team n = do
-    t <- table
-    ps <- gets players
-    let p = player ps n
-    hand <- cardsAt (playerHand $ index p)
-    if length hand == 0
-        then countGame
-        else case length t of
-            0 -> playOpen team p >> simulate team (next n)
-            1 -> do
-                modify (setTurnColour . f . head $ t)
-                playOpen team p
-                simulate team (next n)
-            2 -> playOpen team p >> evaluateTable >>= simulate team
-            3 -> evaluateTable >>= simulate team
-   where f (Card _ col) = Just col
+turn :: Hand -> Skat (Int, Int)
+turn n = turnGeneric play 10 n
 
-evaluateTable :: Skat Index
+evaluateTable :: Skat Hand
 evaluateTable = do
     trumpCol <- gets trumpColour
     turnCol <- gets turnColour
-    t <- table
-    ts <- tableS
+    table <- getp tableCards
     ps <- gets players
-    let psOrdered = playersFromTable ps ts
-        l = zip psOrdered t
-        g a b = compareCards trumpCol turnCol (snd a) (snd b)
-        (winner, _) = last (sortBy g l)
-        pile = teamPile $ team winner
-    forM t (\c -> move c pile)
+    let winningCard = highestCard trumpCol turnCol table
+    Just winnerHand <- getp $ originOfCard winningCard
+    let winner = player ps winnerHand
+    modifyp $ cleanTable (team winner)
     modify $ setTurnColour Nothing
-    return $ index winner
+    return $ hand winner
 
 countGame :: Skat (Int, Int)
-countGame = do
-    sgl <- count <$> cardsAt WonSingle
-    tm <- count <$> cardsAt WonTeam
-    return (sgl, tm)
+countGame = getp count
 
-turn :: Index -> Skat Index
-turn n = do
-    ps <- gets players
-    let p1 = player ps n
-        p2 = player ps (next n)
-        p3 = player ps (next $ next n)
-    c1@(Card _ col) <- play p1
-    modify $ setTurnColour (Just col)
-    c2 <- play p2
-    c3 <- play p3
-    trumpCol <- gets trumpColour
-    turnCol <- gets turnColour
-    let l = zip3 [p1, p2, p3] [c1, c2, c3] [n, next n, next $ next n]
-        g a b = compareCards trumpCol turnCol (f a) (f b)
-        (winner, _, idx) = last (sortBy g l)
-        pile = teamPile $ team winner
-    move c1 pile
-    move c2 pile
-    move c3 pile
-    modify $ setTurnColour Nothing
-    return idx
- where f (_, x, _) = x
-
-play :: Player -> Skat Card
+play :: (Show p, Player p) => p -> Skat Card
 play p = do
-    table <- table
+    liftIO $ putStrLn "playing"
+    table <- getp tableCardsS
     turnCol <- gets turnColour
     trump <- gets trumpColour
-    hand <- cardsAt (playerHand $ index p)
-    let card = playCard p table hand trump turnCol
-    move card Table
+    hand <- getp $ handCards (hand p)
+    fallen <- getp played
+    (card, p') <- chooseCard p table fallen hand
+    modifyPlayers $ updatePlayer p'
+    modifyp $ playCard card
+    ps <- fmap playersToList $ gets players
+    table' <- getp tableCardsS
+    ps' <- mapM (\p -> onCardPlayed p (head table')) ps
+    mapM_ (modifyPlayers . updatePlayer) ps'
     return card
 
-playOpen :: Team -> Player -> Skat Card
-playOpen team p = do
-    card <- playCardOpenAI team p
-    move card Table
+playOpen :: (Show p, Player p) => p -> Skat Card
+playOpen p = do
+    --liftIO $ putStrLn $ show (hand p) ++ " playing open"
+    card <- chooseCardOpen p
+    modifyp $ playCard card
     return card
-
--- | cheating AI that knows all cards (open play)
-playCardOpenAI :: Team -> Player -> Skat Card
-playCardOpenAI team p = do
-    table <- table
-    turnCol <- gets turnColour
-    trump <- gets trumpColour
-    hand <- cardsAt (playerHand $ index p)
-    let possible = filter (isAllowed trump turnCol hand) hand
-        ownResult = if team == Single then fst else snd
-        ownIdx = index p
-    results <- forM possible (\card -> do
-        move card Table
-        val <- ownResult <$> simulate team ownIdx
-        move card (playerHand $ index p)
-        return (val, card))
-    return $ snd $ maximumBy (comparing fst) results
-
-playCard :: Player
-         -> [Card]
-         -> [Card]
-         -> Colour
-         -> Maybe Colour
-         -> Card
-playCard p table hand trump turnCol = head possible
-    where possible = filter (isAllowed trump turnCol hand) hand
-
-runGame :: Skat (Int, Int)
-runGame = do
-    foldM_ (\i _ -> turn i) One [1..10]
-    sgl <- fmap count $ cardsAt WonSingle
-    tm <- fmap count $ cardsAt WonTeam
-    return (sgl, tm)
-
-shuffleCards :: IO [Card]
-shuffleCards = do
-    gen <- newStdGen
-    return $ shuffle gen allCards
-
--- TESTING VARS
-
-env :: SkatEnv
-env = SkatEnv cards Nothing Spades playersExamp
-    where hand1 = take 10 allCards
-          hand2 = take 10 $ drop 10 allCards
-          hand3 = take 10 $ drop 20 allCards
-          skt = drop 30 allCards
-          cards = map (putAt Hand1) hand1
-               ++ map (putAt Hand2) hand2
-               ++ map (putAt Hand3) hand3
-               ++ map (putAt WonSingle) skt
-
-playersExamp :: Players
-playersExamp = Players (Player Team One) (Player Team Two) (Player Single Three)
-
-shuffledEnv :: IO SkatEnv
-shuffledEnv = do
-    cards <- shuffleCards
-    return $ SkatEnv (distribute cards) Nothing Spades playersExamp
-
-shuffledEnv2 :: IO SkatEnv
-shuffledEnv2 = do
-    cards <- shuffleCards
-    return $ SkatEnv (distributePutSkat cards) Nothing Spades playersExamp

Pile.hs

@@ -0,0 +1,108 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Pile where
+
+import Data.List
+
+import Card
+import Utils
+import Control.Exception
+
+data Team = Team | Single
+            deriving (Show, Eq, Ord, Enum)
+
+data CardS p = CardS { getCard :: Card
+                     , getPile :: p }
+               deriving (Show, Eq)
+
+instance Countable (CardS p) Int where
+    count = count . getCard
+
+data Hand = Hand1 | Hand2 | Hand3
+            deriving (Show, Eq, Ord)
+
+next :: Hand -> Hand
+next Hand1 = Hand2
+next Hand2 = Hand3
+next Hand3 = Hand1
+
+prev :: Hand -> Hand
+prev Hand1 = Hand3
+prev Hand2 = Hand1
+prev Hand3 = Hand2
+
+data Played = Table Hand
+            | Won Hand Team
+              deriving (Show, Eq)
+
+data SkatP = SkatP
+             deriving (Show, Eq)
+
+data Piles = Piles { hands :: [CardS Hand]
+                   , played :: [CardS Played]
+                   , skat :: [CardS SkatP] }
+             deriving (Show, Eq)
+
+instance Countable Piles (Int, Int) where
+    count ps = (sgl, tm)
+        where sgl = count (skatCards ps) + count (wonCards Single ps)
+              tm = count (wonCards Team ps)
+
+origin :: CardS Played -> Hand
+origin (CardS _ (Table hand)) = hand
+origin (CardS _ (Won hand _)) = hand
+
+originOfCard :: Card -> Piles -> Maybe Hand
+originOfCard card (Piles _ pld _) = origin <$> find ((==card) . getCard) pld
+
+playCard :: Card -> Piles -> Piles
+playCard card (Piles hs pld skt) = Piles hs' (ca : pld) skt
+    where (CardS _ hand, hs') = remove ((==card) . getCard) hs
+          ca = CardS card (Table hand)
+
+winCard :: Team -> CardS Played -> CardS Played
+winCard team (CardS card (Table hand)) = CardS card (Won hand team)
+winCard team c                         = c
+
+wonCards :: Team -> Piles -> [Card]
+wonCards team (Piles _ pld _) = filterMap (f . getPile) getCard pld
+    where f (Won _ tm) = tm == team
+          f _          = False
+
+cleanTable :: Team -> Piles -> Piles
+cleanTable winner ps@(Piles hs pld skt) = Piles hs pld' skt
+    where table = tableCards ps
+          pld' = map (winCard winner) pld
+
+tableCards :: Piles -> [Card]
+tableCards (Piles _ pld _) = filterMap (f . getPile) getCard pld
+    where f (Table _) = True
+          f _         = False
+
+tableCardsS :: Piles -> [CardS Played]
+tableCardsS (Piles _ pld _) = filter (f . getPile) pld
+    where f (Table _) = True
+          f _         = False
+
+handCards :: Hand -> Piles -> [Card]
+handCards hand (Piles hs _ _) = filterMap ((==hand) . getPile) getCard hs
+
+skatCards :: Piles -> [Card]
+skatCards (Piles _ _ skat) = map getCard skat
+
+putAt :: p -> Card -> CardS p
+putAt = flip CardS
+
+distribute :: [Card] -> Piles
+distribute cards = Piles hands [] (map (putAt SkatP) skt)
+    where round1 = chunksOf 3 (take 9 cards)
+          skt = take 2 $ drop 9 cards
+          round2 = chunksOf 4 (take 12 $ drop 11 cards)
+          round3 = chunksOf 3 (take 9 $ drop 23 cards)
+          hand1 = concatMap (!! 0) [round1, round2, round3]
+          hand2 = concatMap (!! 1) [round1, round2, round3]
+          hand3 = concatMap (!! 2) [round1, round2, round3]
+          hands = map (putAt Hand1) hand1
+            ++ map (putAt Hand2) hand2
+            ++ map (putAt Hand3) hand3

Player.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Player where
+
+import Control.Monad.IO.Class
+
+import Card
+import Pile
+
+class (Monad m, MonadIO m) => MonadPlayer m where
+    trumpColour :: m Colour
+    turnColour :: m (Maybe Colour)
+    showSkat :: Player p => p -> m (Maybe [Card])
+
+class (Monad m, MonadIO m, MonadPlayer m) => MonadPlayerOpen m where
+    showPiles :: m (Piles)
+
+class Player p where
+    team :: p -> Team
+    hand :: p -> Hand
+    chooseCard :: MonadPlayer m
+               => p
+               -> [CardS Played]
+               -> [CardS Played]
+               -> [Card]
+               -> m (Card, p)
+    onCardPlayed :: MonadPlayer m
+                 => p
+                 -> CardS Played
+                 -> m p
+    onCardPlayed p _ = return p
+    chooseCardOpen :: MonadPlayerOpen m
+                   => p
+                   -> m Card
+    chooseCardOpen p = do
+        piles <- showPiles
+        let table = tableCardsS piles
+            fallen = played piles
+            myCards = handCards (hand p) piles
+        fmap fst $ chooseCard p table fallen myCards
+
+data PL = forall p. (Show p, Player p) => PL p
+
+instance Show PL where
+    show (PL p) = show p
+
+instance Player PL where
+    team (PL p) = team p
+    hand (PL p) = hand p
+    chooseCard (PL p) table fallen hand = do
+        (v, a) <- chooseCard p table fallen hand
+        return $ (v, PL a)
+    onCardPlayed (PL p) card = do
+        v <- onCardPlayed p card
+        return $ PL v
+    chooseCardOpen (PL p) = chooseCardOpen p
+
+data Players = Players PL PL PL
+               deriving Show
+
+player :: Players -> Hand -> PL
+player (Players p _ _) Hand1 = p
+player (Players _ p _) Hand2 = p
+player (Players _ _ p) Hand3 = p
+
+updatePlayer :: (Show p, Player p) => p -> Players -> Players
+updatePlayer p (Players p1 p2 p3) = case hand p of
+    Hand1 -> Players (PL p) p2 p3
+    Hand2 -> Players p1 (PL p) p3
+    Hand3 -> Players p1 p2 (PL p)
+
+playersToList :: Players -> [PL]
+playersToList (Players p1 p2 p3) = [p1, p2, p3]

Player/Utils.hs

@@ -0,0 +1,18 @@
+module Player.Utils (
+    isAllowed, isTrump
+) where
+
+import Player
+import qualified Card as C
+import Card (Card)
+
+isAllowed :: MonadPlayer m => [Card] -> Card -> m Bool
+isAllowed hand card = do
+    trCol <- trumpColour
+    turnCol <- turnColour
+    return $ C.isAllowed trCol turnCol hand card
+
+isTrump :: MonadPlayer m => Card -> m Bool
+isTrump card = do
+    trCol <- trumpColour
+    return $ C.isTrump trCol card

Render.hs

@@ -1,7 +1,6 @@
 module Render where
 
 import Card
-import Operations
 import Data.List
 
 render :: [Card] -> IO ()

Skat.hs

@@ -1,11 +1,19 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+
 module Skat where
 
-import Card
 import Control.Monad.State
 import Control.Monad.Reader
 import Data.List
 
-data SkatEnv = SkatEnv { cards :: [CardS]
+import Card
+import Pile
+import Player (Players)
+import qualified Player as P
+
+data SkatEnv = SkatEnv { piles :: Piles
                        , turnColour :: Maybe Colour
                        , trumpColour :: Colour
                        , players :: Players }
@@ -13,24 +21,29 @@ data SkatEnv = SkatEnv { cards :: [CardS]
 
 type Skat = StateT SkatEnv IO
 
-table :: Skat [Card]
-table = gets cards >>= return . foldr f []
-    where f (CardS c Table _) cs = c : cs
-          f _               cs = cs
+instance P.MonadPlayer Skat where
+    trumpColour = gets trumpColour
+    turnColour = gets turnColour
+    showSkat p = case P.team p of
+        Single -> fmap (Just . skatCards) $ gets piles
+        Team -> return Nothing
 
-tableS :: Skat [CardS]
-tableS = gets cards >>= return . foldr f []
-    where f c@(CardS _ Table _) cs = c : cs
-          f _                   cs = cs
+instance P.MonadPlayerOpen Skat where
+    showPiles = gets piles
 
-move :: Card -> Space -> Skat ()
-move card sp = do
-    cs <- gets cards
-    let cs' = moveCard card sp cs
-    modify (\env -> env { cards = cs' })
+modifyp :: (Piles -> Piles) -> Skat ()
+modifyp f = modify g
+    where g env@(SkatEnv {piles}) = env { piles = f piles}
 
-cardsAt :: Space -> Skat [Card]
-cardsAt sp = gets cards >>= return . findCards sp
+getp :: (Piles -> a) -> Skat a
+getp f = gets piles >>= return . f
+
+modifyPlayers :: (Players -> Players) -> Skat ()
+modifyPlayers f = modify g
+    where g env@(SkatEnv {players}) = env { players = f players }
 
 setTurnColour :: Maybe Colour -> SkatEnv -> SkatEnv
 setTurnColour col sk = sk { turnColour = col }
+
+mkSkatEnv :: Piles -> Maybe Colour -> Colour -> Players -> SkatEnv
+mkSkatEnv = SkatEnv

Utils.hs

@@ -22,3 +22,21 @@ query s = do
     case l of
         Just x -> return x
         Nothing -> query s
+
+remove :: (a -> Bool) -> [a] -> (a, [a])
+remove pred xs = foldr f (undefined, []) xs
+    where f c (old, cs) = if pred c then (c, cs) else (old, c : cs)
+
+filterMap :: (a -> Bool) -> (a -> b) -> [a] -> [b]
+filterMap pred f as = foldr g [] as
+    where g a bs = if pred a then f a : bs else bs
+
+--filterM :: Monad m => (a -> m Bool) -> [a] -> m [a]
+--filterM _    []     = return []
+--filterM pred (x:xs) = do
+--    b <- pred x
+--    if b then filterM pred xs >>= \l -> return $ x : l
+--        else filterM pred xs
+
+grouping :: Eq a => (b -> a) -> b -> b -> Bool
+grouping f a b = f a == f b