weight distributions to have correct estimations after reduction

AI/Rulebased.hs

@@ -4,7 +4,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 
 module AI.Rulebased (
-    mkAIEnv, testds, remove789s, reduce
+    mkAIEnv, testds, simplify
 ) where
 
 import Data.Ord
@@ -185,7 +185,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 +197,20 @@ 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])
-reduce Hand1 (_, h2, h3, _) = (h2, h3)
-reduce Hand2 (h1, _, h3, _) = (h1, h3)
-reduce Hand3 (h1, h2, _, _) = (h1, h2)
+            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] -> M.Map Distribution Int
+simplify hand ds = M.foldl' f M.empty cleaned
+    where cleaned = remove789s hand ds
+          f m (d, n) = M.insert d n m
 
 onPlayed :: MonadPlayer m => CardS Played -> AI m ()
 onPlayed c = do
@@ -264,17 +265,17 @@ 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 = M.mapKeys (toPiles table) 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
-    vals <- M.toList <$> foldWithLimit limit runOnPiles M.empty piless
+            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 (M.toList piless)
     liftIO $ print vals
     return $ fst $ maximumBy (comparing snd) vals
 
@@ -292,10 +293,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

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)