mcts progress

src/Skat/AI/Base.hs

@@ -7,6 +7,8 @@
 
 module Skat.AI.Base where
 
+import Data.Set (Set)
+import qualified Data.Set as S
 import System.Random (Random)
 import qualified System.Random as Rand
 import Control.Monad.State
@@ -49,14 +51,20 @@ class (MonadIO m, Show t, Show v, Show p, MonadGame t l v p m) => PlayableGame t
 class Choose t m | m -> t where 
     choose :: m t
 
-class MonadRandom m where
+class Monad m => MonadRandom m where
     random :: Random a => m a
+    randomR :: Random a => (a, a) -> m a
     chooser :: [a] -> m a
+    chooser [] = error "chooser: empty list"
+    chooser os = (os!!) <$> randomR (0, length os - 1)
+    chooserS :: Set a -> m a
+    chooserS set
+        | S.null set = error "chooserS: empty set"
+        | otherwise  = (`S.elemAt` set) <$> randomR (0, S.size set - 1)
 
 instance MonadRandom IO where
     random = Rand.randomIO
-    chooser [] = error "chooser: empty list"
-    chooser os = (os!!) <$> Rand.randomRIO (0, length os -1)
+    randomR = Rand.randomRIO
 
 instance MonadRandom (State Rand.StdGen) where
     random = do
@@ -64,9 +72,8 @@ instance MonadRandom (State Rand.StdGen) where
         let (a, gen') = Rand.random gen
         put gen'
         return a
-    chooser [] = error "chooser: empty list"
-    chooser os = do
+    randomR bds = do
         gen <- get
-        let (a, gen') = Rand.randomR (0, length os -1) gen
+        let (a, gen') = Rand.randomR bds gen
         put gen'
-        return (os !! a)
+        return a

src/Skat/AI/Games/Skat/Guess.hs

@@ -6,6 +6,7 @@ module Skat.AI.Games.Skat.Guess where
 
 import GHC.Generics (Generic, Generic1) 
 import Data.Ord
+import Data.Aeson
 import Data.Monoid ((<>))
 import Data.List
 import Data.Set (Set)
@@ -30,7 +31,7 @@ import Control.DeepSeq
 
 data Option = H Hand
             | Skt
-              deriving (Show, Eq, Ord, Generic, NFData)
+              deriving (Show, Eq, Ord, Generic, NFData, ToJSON)
 
 type Guess = Map Card (Set Option)
 
@@ -69,6 +70,22 @@ hasNoLonger trump hand effCol = M.mapWithKey f
                 S.filter (/=H hand) hands
             | otherwise = hands
 
+observe :: Trump -> Maybe TurnColour -> [CardS Played] -> Guess -> Guess
+observe _ Nothing _ guess = guess
+observe trpCol (Just turnCol) tbl oldGuess = foldr f oldGuess tbl
+    where f :: CardS Played -> Guess -> Guess
+          f c g = let col = effectiveColour trpCol (toCard c)
+                  in if col /= turnCol
+                      then hasNoLonger trpCol (uorigin $ getPile c) turnCol g
+                      else g
+
+observeS :: Guess -> Skat Guess
+observeS guess = do
+    trpCol <- trump
+    turnCol <- gets Skat.turnColour
+    tbl <- getp tableCards
+    pure $ observe trpCol turnCol tbl guess
+
 isSkat :: [Card] -> Guess -> Guess
 isSkat cs = M.mapWithKey f
     where f card hands
@@ -96,6 +113,36 @@ choosen = choosen2
 smplguess :: Guess
 smplguess = Hand1 `hasOnly` [(Card Seven Diamonds)..(Card Eight Hearts)] $! newGuess
 
+smplguess2 :: Guess
+smplguess2 = M.fromList
+    [ ( Card Seven Diamonds, S.fromList [H Hand2, H Hand3] )
+    , ( Card Eight Hearts, S.fromList [H Hand2, H Hand1]   )
+    , ( Card Nine Spades, S.fromList [H Hand1, H Hand2]    )
+    , ( Card Nine Diamonds, S.fromList [Skt]               )
+    , ( Card Eight Diamonds, S.fromList [Skt]              )
+    ]
+
+smplguess3 :: Guess
+smplguess3 = M.fromList 
+    [ (Card Nine Clubs, S.fromList [Skt])
+    , (Card Queen Clubs, S.fromList [Skt])
+    , (Card Ten Hearts, S.fromList [H Hand2,H Hand3])
+    , (Card Ace Diamonds, S.fromList [H Hand2])
+    ]
+
+smplguess4 :: Guess
+smplguess4 = M.fromList
+    [ (Card Seven Spades,   S.fromList [H Hand1])
+    , (Card Nine Spades,    S.fromList [H Hand1])
+    , (Card Eight Spades,   S.fromList [H Hand2])
+    , (Card Queen Diamonds, S.fromList [H Hand3])
+    , (Card Ace Diamonds,   S.fromList [H Hand3])
+    , (Card King Clubs,     S.fromList [H Hand2,H Hand3])
+    , (Card Ace Clubs,      S.fromList [H Hand2,H Hand3])
+    , (Card Nine Clubs,     S.fromList [Skt])
+    , (Card Queen Clubs,    S.fromList [Skt])
+    ]
+
 distributions2 :: Guess -> (Int, Int, Int, Int) -> [Distribution]
 distributions2 !guess1 !(n1, n2, n3, nskt) = do
     let h1cards = M.keys $!! M.filter (H Hand1 `elem`) guess1
@@ -142,7 +189,7 @@ randomChoice options = do
         g Skt       = n4 > 0
         opts = S.toList $ S.filter g options
     --when (null opts) $ error "randomChoice: after filtering options are empty"
-    option <-  lift $ chooser opts
+    option <- if null opts then (error ("randomChoice: opts empty, " ++ show options ++ " " ++ show (n1,n2,n3,n4)))  else lift (chooser opts)
     let (n1', n2', n3', n4') = case option of
             H Hand1 -> (n1-1, n2, n3, n4)
             H Hand2 -> (n1, n2-1, n3, n4)
@@ -163,9 +210,73 @@ randomGuess guess (n1, n2, n3, n4) = (flip evalStateT) ( cardsPerHand + n1
             let opts = M.findWithDefault (error "findWithDefault") card g
             o <- randomChoice opts
             pure $ M.insert card (S.singleton o) g
-        
+
+choosern :: (Eq a, Monad m, MonadRandom m) => Int -> [a] -> m [a]
+choosern 0  _   = pure []
+choosern _  []  = error "chooseRn: list is empty and n /= 0"
+choosern !n !os = do
+    o <- chooser os
+    let !os' = delete o os
+    rest <- choosern (n-1) os'
+    pure $ o : rest
+
+choosernS :: (Ord a, Monad m, MonadRandom m) => Int -> Set a -> m (Set a)
+choosernS 0  _   = pure S.empty
+choosernS !n !os
+    | S.size os == 0 = error "chooseRn: list is empty and n /= 0"
+    | otherwise = do
+        o <- chooserS os
+        let !os' = S.delete o os
+        rest <- choosernS (n-1) os'
+        pure $ S.insert o rest
+
+
+snd3 :: (a,b,c) -> b
+snd3 (a,b,c) = b
+
+randomDistr2 :: (MonadRandom m, Monad m) => Guess -> (Int, Int, Int, Int) -> m Distribution
+randomDistr2 guess1 (n1, n2, n3, _) = do
+    let h1cs = M.keysSet $!! M.filter (H Hand1 `S.member`) guess1
+        h2cs = M.keysSet $!! M.filter (H Hand2 `S.member`) guess1
+        h3cs = M.keysSet $!! M.filter (H Hand3 `S.member`) guess1
+        skcs = M.keysSet $!! M.filter (Skt `S.member`)     guess1
+        priority = M.filter ((==1) . S.size) guess1
+        predist = M.foldrWithKey
+            (\card opts dist -> M.insertWith (++) (S.elemAt 0 opts) [card] dist)
+            M.empty
+            priority
+        banned = M.keysSet priority
+        pots = sortBy (comparing $ \(_, cs, n) -> length cs - n)
+            $ [ (H Hand1, h1cs, nh1 - length (M.findWithDefault [] (H Hand1) predist))
+              , (H Hand2, h2cs, nh2 - length (M.findWithDefault [] (H Hand2) predist))
+              , (H Hand3, h3cs, nh3 - length (M.findWithDefault [] (H Hand3) predist))
+              , (Skt    , skcs, nh4 - length (M.findWithDefault [] Skt       predist))
+              ]
+    (dist, _) <- foldM f (predist, banned) pots
+
+    return ( M.findWithDefault (error "randomDistr: missing option Hand1") (H Hand1) dist
+           , M.findWithDefault (error "randomDistr: missing option Hand2") (H Hand2) dist
+           , M.findWithDefault (error "randomDistr: missing option Hand3") (H Hand3) dist
+           , M.findWithDefault (error "randomDistr: missing option Skt") Skt dist
+           )
+  where cardsPerHand = (length guess1-2-n1-n2-n3) `div` 3
+        nh1 = cardsPerHand + n1
+        nh2 = cardsPerHand + n2
+        nh3 = cardsPerHand + n3
+        nh4 = 2
+        f (dist, banned) (option, cards, n) = do
+            let available = S.filter (not . (`S.member` banned)) cards
+            cs <- if S.size available < n
+                    then error ("Not enough options available: wanted " ++ show n ++ " for " ++ show option ++ " and got " ++ show (length available) ++ ", " ++ show guess1 ++ " with " ++ show (n1, n2, n3))
+                    else choosernS n available
+            let dist' = M.insertWith (++) option (S.toList cs) dist
+            pure (dist', S.union banned cs)
+
 randomDistr :: (MonadRandom m, Monad m) => Guess -> (Int, Int, Int, Int) -> m Distribution
-randomDistr guess (n1, n2, n3, n4) = (flip evalStateT) ( cardsPerHand + n1
+randomDistr = randomDistr2
+        
+randomDistr1 :: (MonadRandom m, Monad m) => Guess -> (Int, Int, Int, Int) -> m Distribution
+randomDistr1 guess (n1, n2, n3, n4) = (flip evalStateT) ( cardsPerHand + n1
                                                        , cardsPerHand + n2
                                                        , cardsPerHand + n3
                                                        , 2 + n4

src/Skat/AI/MonteCarlo.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE TypeSynonymInstances #-}
@@ -9,9 +10,11 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DeriveGeneric #-}
 
 module Skat.AI.MonteCarlo where
 
+import GHC.Generics
 import Control.Monad.State
 import Control.Exception (assert)
 import Control.Monad.Fail
@@ -31,6 +34,7 @@ import System.Random (Random)
 import qualified System.Random as Rand
 import Text.Printf
 import Data.List.Split
+import Data.Aeson hiding (Value)
 
 import Skat.AI.Base hiding (simulate)
 import qualified Skat as S
@@ -48,6 +52,19 @@ type SimCount = Int
 data Tree t s = Leaf    s Bool (WinCount, SimCount)
               | Node    s Bool (WinCount, SimCount) [Tree t s]
               | Pending s t
+                deriving (Generic)
+
+instance (ToJSON t, ToJSON s) => ToJSON (Tree t s) where
+    toJSON x@Leaf{} = object [ "state" .= toJSON (treestate x)
+                             , "valuation" .= toJSON (valuation x)
+                             ]
+    toJSON x@(Node _ _ _ children) = object [ "state" .= toJSON (treestate x)
+                                            , "valuation" .= toJSON (valuation x)
+                                            , "children" .= toJSON children
+                                            ]
+    toJSON x@(Pending _ t) = object [ "valuation" .= ("pending" :: String)
+                                    , "turn" .= toJSON t
+                                    ]
 
 simruns :: Tree t s -> SimCount
 simruns (Leaf _ _ d)   = snd d
@@ -106,8 +123,10 @@ valuetonum v
     | v == tie  = 0.5
 -}
 
+{-
 restoint :: (Player p, Value v) => p -> v -> Float
 restoint p v = tonum $ if maxing p then v else invert v
+-}
 
 {-
 updateval :: (Player p, Value d) => p -> [d] -> (WinCount, SimCount) -> (WinCount, SimCount)
@@ -133,12 +152,13 @@ montecarlo (Pending state turn) = do
     let currentTeam = current state
         state' = execute turn state
     -- objectively get a final score of random playout (independent of perspective)
-    values <- replicateM 100 (simulate state')
-    let tr = if maxing (current state) then id else invert
+    values <- replicateM 1000 (simulate state')
+    let --tr = if maxing (current state) then id else invert
+        tr = id
         vs = fmap (tonum . tr) values
         n = sum vs
     --let v = if maxing (current state') then value else invert value
-    let val = (n, 100)
+    let val = (n, 1000)
     pure $ Leaf state' False val
 montecarlo (Leaf state terminal d)
    | terminal || length ms == 0 = pure $ Leaf state True d
@@ -152,20 +172,22 @@ montecarlo n@(Node state _ d children)
         in pure $ Node state True d' children
   | otherwise = do
         let myruns = snd d
-            cmp c = if isterminal c then -1 else selectcoeff myruns $ valuation c
+            cmp c
+                | isterminal c = -1
+                | otherwise = selectcoeff (maxing $ current state) myruns $ valuation c
             (idx, bestChild) =
                 maximumBy (comparing $ cmp . snd) $ zipWith (,) [0..] children
         updated <- montecarlo bestChild
         let cs = updateAt idx children updated
             newSimRuns = simruns updated - simruns bestChild + snd d
             diff = wins updated - wins bestChild
-            diff2 = 
-                if newSimRuns == snd d then 0
-                else
-                    if current state == current (treestate updated)
-                            then diff
-                            else fromIntegral (simruns updated) - diff
-            newWins = diff2 + fst d
+            --diff2 = 
+            --    if newSimRuns == snd d then 0
+            --    else
+            --        if current state == current (treestate updated)
+            --                then diff
+            --                else fromIntegral (simruns updated) - diff
+            newWins = diff + fst d
         --return $ trace ("updating node " ++ show diff2 ++ "\n" ++ show updated ++ "\n" ++ show bestChild) (Node state False (newWins, newSimRuns) cs)
         return $ Node state False (newWins, newSimRuns) cs
 
@@ -189,15 +211,17 @@ bestmove (Node s _ _ cs) = treestate $ selection (comparing $ rate . valuation)
           mxing = maxing . current $ s
           selection = if mxing then maximumBy else minimumBy
 -}
-bestmove :: Tree t s -> s
+bestmove :: (HasGameState t p d s, Player p) => Tree t s -> s
 bestmove (Leaf s _ _) = s
-bestmove (Node s _ _ cs) = treestate $ maximumBy (comparing $ rate . valuation) cs
+bestmove (Node s _ _ cs) = treestate $ choice (comparing $ rate . valuation) cs
     where rate (w, s) = w / fromIntegral s
+          choice = if maxing (current s) then maximumBy else minimumBy
 
-selectcoeff :: SimCount -> (WinCount, SimCount) -> Float
-selectcoeff _ (_, 0) = 10000000
-selectcoeff t (w, s) = w / fromIntegral s + explorationParam * sqrt (log (fromIntegral t) / fromIntegral s)
+selectcoeff :: Bool -> SimCount -> (WinCount, SimCount) -> Float
+selectcoeff _ _ (_, 0) = 10000000
+selectcoeff m t (w, s) = w' / fromIntegral s + explorationParam * sqrt (log (fromIntegral t) / fromIntegral s)
     where explorationParam = sqrt 2
+          w' = if m then w else fromIntegral s - w 
 
 reevaluate :: Tree t s -> (WinCount, SimCount)
 reevaluate tree
@@ -218,9 +242,10 @@ reevaluateminmax tree
         (Node state _ _ children) ->
             let vals = fmap ((\(w, s) -> w / fromIntegral s) . valuation) children
         --        m = maxing . current $ state
-                childrenMaxing = all (maxing . current . treestate) children
+                --childrenMaxing = all (maxing . current . treestate) children
                 selfMaxing = maxing . current $ state
-                newval = if childrenMaxing /= selfMaxing then 1 - maximum vals else maximum vals
+                choice = if selfMaxing then maximum else minimum
+                newval = choice vals
             in (newval, 1)
 
 --playCLI :: (MonadFail m, Read t, Choose t m, PlayableGame t l v p m) => m ()

src/Skat/AI/Skat.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -5,20 +6,26 @@
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveGeneric #-}
 
 module Skat.AI.Skat where
 
+import Data.String
+import System.IO
+import GHC.Generics
 import Control.Monad.State
 import Control.Exception (assert)
 import Control.Monad.Fail
 import Control.Monad.Writer
 import Data.Ord
+import Data.Aeson hiding (Value)
 import Text.Read (readMaybe)
 import Data.List (maximumBy, sortBy)
 import Debug.Trace
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import qualified System.Random as Rand
+import qualified Data.ByteString.Lazy.Char8 as BS8
 
 import System.IO.Unsafe
 
@@ -61,7 +68,14 @@ data SkatState = SkatState { skatEnv :: S.SkatEnv
                            , self :: S.Hand
                            , guess :: Guess
                            }
-                 deriving Show
+                 deriving (Show, Generic)
+
+instance ToJSON SkatState where
+    toJSON state = object [ "guess" .= toJSON (guess state)
+                          , "table" .= toJSON (S.tableCards $ S.piles $ skatEnv state)
+                          , "won_single" .= toJSON (S.wonCards S.Single $ S.piles $ skatEnv state)
+                          , "won_team" .= toJSON (S.wonCards S.Team $ S.piles $ skatEnv state)
+                          ]
 
 instance Draw SkatState where
     draw = show . S.tableCards . S.piles . skatEnv
@@ -129,6 +143,9 @@ data Turn = Turn { turnStartingEnv :: S.SkatEnv
                  , turnCard :: S.Card }
             deriving Show
 
+instance ToJSON Turn where
+    toJSON turn = object [ "turn_card" .= turnCard turn ]
+
 instance Draw Turn where
     draw = show . turnCard
 
@@ -140,9 +157,17 @@ instance HasGameState Turn Bool Float SkatState where
     monteevaluate s = let (sgl, tm) = ev S.countGame (skatEnv s)
         in if sgl > tm then 1.0 else 0.0 --fromIntegral sgl / (fromIntegral $ sgl + tm)
     execute turn state =
-        let newEnv = ex (S.play_ card) env
+        let tbl = ev (S.getp S.tableCards) env
+            curhand = S.currentHand env
+            trpCol :: S.Trump
+            trpCol = ev (S.getTrump <$> gets S.skatGame) env
+            turnCol = ev (gets S.turnColour) env
+            observed = observe trpCol turnCol (card':tbl) (guess state)
+            guess' = card `hasBeenPlayed` observed
+            card' = S.CardS card (S.P curhand)
+            newEnv = ex (S.play_ card) env
         in  state { skatEnv = newEnv
-                  , guess = card `hasBeenPlayed` (guess state)
+                  , guess = guess'
                   }
       where env = turnStartingEnv turn
             card = turnCard turn
@@ -202,10 +227,20 @@ playCLI n = do
                 liftIO $ putStrLn "iterating"
                 s <- get
                 let tree = Leaf s False (0, 0)
-                    t = runmonte n (foldM (\tree _ -> montecarlo tree) tree [1..100])
+                    l = length $ guess s
+                    depth
+                      | l >= 26   = 15
+                      | l >= 20   = 100
+                      | l >= 14   = 2000
+                      | otherwise = 5000
+                    t = runmonte n (foldM (\tree _ -> montecarlo tree) tree [1..depth])
                     newstate = bestmove t
-                --liftIO $ putStrLn $ visualise t
+                    json :: String
+                    json = BS8.unpack $ encode t
                 liftIO $ print newstate
+                --liftIO $ withFile "tree.json" WriteMode $ \handle ->
+                --    hPutStrLn handle json
+                --liftIO $ putStrLn $ visualise t
                 put newstate
                 lift (put $ skatEnv newstate)
             else do
@@ -215,7 +250,11 @@ playCLI n = do
                 lift $ play t
                 s <- get
                 env <- lift get
-                let s' = s { skatEnv = env }
+                let guess' = (S.toCard t) `hasBeenPlayed` (guess s)
+                observed <- lift $ observeS guess'
+                let s' = s { skatEnv = env
+                           , guess = observed
+                           }
                 put s'
             {-
             showBoard
@@ -245,13 +284,13 @@ initSkatEnv n =
     let gen = Rand.mkStdGen n
         --cards = S.shuffle gen S.allCards
         --piles = S.distribute cards
-        piles = S.cardDistr3
+        piles = S.cardDistr9
         players = P.Players
             (P.PL $ S.Stupid S.Single S.Hand1)
             (P.PL $ S.Stupid S.Team S.Hand2)
             (P.PL $ S.Stupid S.Team S.Hand3)
     in S.SkatEnv { S.piles = piles
-                 , S.turnColour = Nothing
+                 , S.turnColour = Just (S.TurnColour S.Hearts)
                  , S.skatGame = S.Colour S.Spades S.Einfach
                  , S.players = players
                  , S.currentHand = S.Hand1

src/Skat/Bidding.hs

@@ -153,6 +153,7 @@ modifierFactor Ouvert                       = 7
 allTrumps :: Game -> [Card]
 allTrumps (Grand _) = jacks
 allTrumps (Colour col _) = jacks ++ [Card t col | t <- [Ace,Ten .. Seven] ]
+allTrumps _              = []
 
 jacks :: [Card]
 jacks = [ Card Jack Clubs, Card Jack Spades, Card Jack Hearts, Card Jack Diamonds ]

src/Skat/Card.hs

@@ -33,7 +33,7 @@ data Type = Seven
           | Ten
           | Ace
           | Jack
-            deriving (Eq, Ord, Show, Enum, Read, Bounded, Generic, NFData)
+            deriving (Eq, Ord, Show, Enum, Read, Bounded, Generic, NFData, ToJSON)
 
 data NullType = NSeven
               | NEight
@@ -57,7 +57,7 @@ data Colour = Diamonds
             | Hearts
             | Spades
             | Clubs
-              deriving (Eq, Ord, Show, Enum, Read, Bounded, Generic, NFData)
+              deriving (Eq, Ord, Show, Enum, Read, Bounded, Generic, NFData, ToJSON)
 
 data Trump = TrumpColour Colour
            | Jacks
@@ -69,7 +69,7 @@ data TurnColour = TurnColour Colour
                   deriving (Show, Eq)
 
 data Card = Card !Type !Colour
-            deriving (Eq, Show, Ord, Read, Bounded, Generic)
+            deriving (Eq, Show, Ord, Read, Bounded, Generic, ToJSONKey)
 
 getType :: Card -> Type
 getType (Card t _) = t

src/Skat/Pile.hs

@@ -53,7 +53,7 @@ instance ToJSON p => ToJSON (CardS p) where
         object ["card" .= card, "pile" .= pile]
 
 data Hand = Hand1 | Hand2 | Hand3
-            deriving (Show, Eq, Ord, Read, Enum, Bounded, Generic, NFData)
+            deriving (Show, Eq, Ord, Read, Enum, Bounded, Generic, NFData, ToJSON)
 
 toInt :: Hand -> Int
 toInt Hand1 = 1
@@ -249,10 +249,10 @@ instance Serialize String [Trick] where
 
 cardDistr :: Piles
 cardDistr = emptyPiles hand1 hand2 hand3 skt
-    where hand3 = [Card Ace Spades, Card Jack Diamonds, Card Jack Clubs, Card King Spades,
+    where hand1 = [Card Ace Spades, Card Jack Diamonds, Card Jack Clubs, Card King Spades,
                    Card Nine Spades, Card Ace Diamonds, Card Queen Diamonds, Card Ten Clubs,
                    Card Eight Clubs, Card King Clubs]
-          hand1 = [Card Jack Spades, Card Jack Hearts, Card Ten Spades, Card Ace Hearts, Card Ten Hearts,
+          hand3 = [Card Jack Spades, Card Jack Hearts, Card Ten Spades, Card Ace Hearts, Card Ten Hearts,
                    Card Nine Hearts, Card Seven Clubs, Card Ace Clubs, Card King Diamonds,
                    Card Ten Diamonds]
           hand2 = [Card Eight Spades, Card Queen Spades, Card Seven Spades, Card Seven Diamonds,
@@ -302,3 +302,31 @@ cardDistr6 = emptyPiles hand1 hand2 hand3 skt
                    Card Seven Hearts, Card Eight Hearts, Card Queen Hearts
                    ]
           skt = [Card Nine Clubs, Card Queen Clubs]
+
+cardDistr7 :: Piles
+cardDistr7 = emptyPiles hand1 hand2 hand3 skt
+    where hand3 = [Card Eight Spades, Card Ace Clubs]
+          hand1 = [Card Seven Spades, Card Nine Spades]
+          hand2 = [Card Ace Hearts, Card Ten Clubs]
+          skt = [Card Nine Clubs, Card Seven Clubs]
+
+cardDistr8 :: Piles
+cardDistr8 = emptyPiles hand1 hand2 hand3 skt
+    where hand3 = [Card Ace Spades, Card Ace Clubs]
+          hand1 = [Card Jack Spades, Card Seven Spades]
+          hand2 = [Card Eight Hearts, Card King Clubs]
+          skt = [Card Nine Clubs, Card Seven Clubs]
+
+cardDistr9 :: Piles
+cardDistr9 = makePiles hand1 hand2 hand3 tbl skt
+    where hand1 = [Card Ace Spades, Card Jack Diamonds, Card Jack Clubs, Card King Spades,
+                   Card Nine Spades, Card Ace Diamonds, Card Queen Diamonds, Card Ten Clubs,
+                   Card Eight Clubs]
+          hand3 = [Card Jack Spades, Card Jack Hearts, Card Ten Spades, Card Ten Hearts,
+                   Card Nine Hearts, Card Seven Clubs, Card King Diamonds,
+                   Card Ten Diamonds]
+          hand2 = [Card Eight Spades, Card Seven Spades, Card Seven Diamonds,
+                   Card Seven Hearts, Card Eight Hearts, Card Queen Hearts,
+                   Card Nine Diamonds, Card Eight Diamonds]
+          skt = [Card Nine Clubs, Card Queen Clubs]
+          tbl = [CardS (Card Ace Hearts) (P Hand3), CardS (Card King Hearts) (P Hand2)]