add parallel computing features not sure if this is a real improvement

.gitignore

@@ -6,3 +6,4 @@
 *.hi
 *.o
 *.prof
+*.hp

AI/Rulebased.hs

@@ -4,9 +4,11 @@
 {-# LANGUAGE FlexibleContexts #-}
 
 module AI.Rulebased (
-    mkAIEnv, testds, remove789s, reduce
+    mkAIEnv, testds, simplify
 ) where
 
+import Control.Parallel.Strategies
+
 import Data.Ord
 import Data.Monoid ((<>))
 import Data.List
@@ -163,6 +165,7 @@ compareGuess (c1, ops1) (c2, ops2)
 distributions :: Guess -> (Int, Int, Int, Int) -> [Distribution]
 distributions guess nos =
         helper (sortBy compareGuess $ M.toList guess) nos
+        `using` parList rdeepseq
     where helper []           _ = []
           helper ((c, hs):[]) ns = map fst (distr c hs ns)
           helper ((c, hs):gs) ns =
@@ -185,7 +188,9 @@ distributions guess nos =
                 in filterMap isOk (f card) hands
           cardsPerHand = (length guess - 2) `div` 3
 
-abstract :: [Card] -> (Int, Int, Int, Int)
+type Abstract = (Int, Int, Int, Int)
+
+abstract :: [Card] -> Abstract
 abstract cs = foldr f (0, 0, 0, 0) cs
     where f c (clubs, spades, hearts, diamonds) =
             let v = getID c in
@@ -195,21 +200,21 @@ abstract cs = foldr f (0, 0, 0, 0) cs
                 Spades -> (clubs, spades + 1 + v*100, hearts, diamonds)
                 Clubs -> (clubs + 1 + v*100, spades, hearts, diamonds)
 
-remove789s :: Hand -> [Distribution] -> [Distribution]
-remove789s hand ds = fst $ foldl' f ([], S.empty) ds
-    where f (cleaned, abstracts) d =
+remove789s :: Hand
+           -> [Distribution]
+           -> M.Map (Abstract, Abstract) (Distribution, Int)
+remove789s hand ds = foldl' f M.empty ds
+    where f cleaned d =
             let (c1, c2) = reduce hand d
                 a = (abstract c1, abstract c2) in
-            if a `S.member` abstracts then (cleaned, abstracts)
-            else (d : cleaned, S.insert a abstracts)
-
-reduce :: Hand -> Distribution -> ([Card], [Card])
+            M.insertWith (\(oldD, n) _ -> (oldD, n+1)) a (d, 1) cleaned
           reduce Hand1 (_, h2, h3, _) = (h2, h3)
           reduce Hand2 (h1, _, h3, _) = (h1, h3)
           reduce Hand3 (h1, h2, _, _) = (h1, h2)
 
-simplify :: Hand -> [Distribution] -> [Distribution]
-simplify = remove789s
+simplify :: Hand -> [Distribution] -> [(Distribution, Int)]
+simplify hand ds = M.elems cleaned
+    where cleaned = remove789s hand ds
 
 onPlayed :: MonadPlayer m => CardS Played -> AI m ()
 onPlayed c = do
@@ -244,9 +249,9 @@ chooseStatistic = do
                     2 -> 2
                     3 -> 3
                     -- simulate only partially
-                    4 -> 2
-                    5 -> 1
-                    6 -> 1
+                    4 -> 3
+                    5 -> 2
+                    6 -> 2
                     7 -> 1
                     8 -> 1
                     9 -> 1
@@ -264,16 +269,16 @@ chooseStatistic = do
                 0 -> (0,  0,  0, 0)
                 1 -> (-1, 0, -1, 0)
                 2 -> (0,  0, -1, 0)
-    let dis' = distributions guess ns
-        disNo' = length dis'
-        dis = simplify Hand3 dis'
-        disNo = length dis
-        piless = map (toPiles table) dis
+    let realDis = distributions guess ns
+        realDisNo = length realDis
+        reducedDis = simplify Hand3 realDis
+        reducedDisNo = length reducedDis
+        piless = map (\(d, n) -> (toPiles table d, n)) reducedDis
         limit = if depth == 1 && length table == 2
             then 1
-            else min 10000 $ disNo `div` 2
-    liftIO $ putStrLn $ "possible distrs without simp " ++ show disNo'
-    liftIO $ putStrLn $ "possible distrs " ++ show disNo
+            else min 10000 $ realDisNo `div` 2
+    liftIO $ putStrLn $ "possible distrs without simp " ++ show realDisNo
+    liftIO $ putStrLn $ "possible distrs " ++ show reducedDisNo
     vals <- M.toList <$> foldWithLimit limit runOnPiles M.empty piless
     liftIO $ print vals
     return $ fst $ maximumBy (comparing snd) vals
@@ -292,10 +297,10 @@ foldWithLimit limit f start (x:xs) = do
         _ -> return start
 
 runOnPiles :: MonadPlayer m
-           => M.Map Card Int -> Piles -> AI m (M.Map Card Int)
-runOnPiles m ps = do
+           => M.Map Card Int -> (Piles, Int) -> AI m (M.Map Card Int)
+runOnPiles m (ps, n) = do
     c <- runWithPiles ps chooseOpen
-    return $ M.insertWith (+) c 1 m
+    return $ M.insertWith (+) c n m
 
 chooseOpen :: (MonadState AIEnv m, MonadPlayerOpen m) => m Card
 chooseOpen = do

AI/Test2.hs

@@ -2,4 +2,4 @@ import AI.Rulebased
 import Pile
 
 main :: IO ()
-main = print $ length $ remove789s Hand3 testds
+main = print $ length $ simplify Hand3 testds

Card.hs

@@ -6,6 +6,7 @@ module Card where
 import Data.List
 import System.Random (newStdGen)
 import Utils
+import Control.DeepSeq
 
 class Countable a b where
     count :: a -> b
@@ -57,6 +58,9 @@ instance Countable Card Int where
 instance Countable [Card] Int where
     count = sum . map count
 
+instance NFData Card where
+    rnf (Card t c) = t `seq` c `seq` ()
+
 equals :: Colour -> Maybe Colour -> Bool
 equals col (Just x) = col == x
 equals col Nothing = True

Main.hs

@@ -13,7 +13,23 @@ import AI.Human
 import AI.Rulebased
 
 main :: IO ()
-main = putStrLn "Hello World"
+main = testAI 10
+
+testAI :: Int -> IO ()
+testAI n = do
+    let acs = repeat runAI
+    vals <- sequence (take n acs)
+    putStrLn $ "average won points " ++ show (fromIntegral (sum vals) / fromIntegral n)
+
+runAI :: IO Int
+runAI = do
+    env <- shuffledEnv
+    let ps = piles env
+        cs = handCards Hand3 ps
+        trs = filter (isTrump Spades) cs
+    if length trs >= 5 && any ((==32) . getID) cs
+        then fst <$> evalStateT (turn Hand1) env
+        else runAI
 
 env :: SkatEnv
 env = SkatEnv piles Nothing Spades playersExamp
@@ -50,8 +66,3 @@ env2 = SkatEnv piles Nothing Spades playersExamp
           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)

Pile.hs

@@ -14,7 +14,7 @@ data Team = Team | Single
 
 data CardS p = CardS { getCard :: Card
                      , getPile :: p }
-               deriving (Show, Eq)
+               deriving (Show, Eq, Ord)
 
 instance Countable (CardS p) Int where
     count = count . getCard
@@ -34,15 +34,15 @@ prev Hand3 = Hand2
 
 data Played = Table Hand
             | Won Hand Team
-              deriving (Show, Eq)
+              deriving (Show, Eq, Ord)
 
 data SkatP = SkatP
-             deriving (Show, Eq)
+             deriving (Show, Eq, Ord)
 
 data Piles = Piles { hands :: [CardS Hand]
                    , played :: [CardS Played]
                    , skat :: [CardS SkatP] }
-             deriving (Show, Eq)
+             deriving (Show, Eq, Ord)
 
 instance Countable Piles (Int, Int) where
     count ps = (sgl, tm)