add 789 reduction

AI/Rulebased.hs

@@ -4,12 +4,13 @@
 {-# LANGUAGE FlexibleContexts #-}
 
 module AI.Rulebased (
-    mkAIEnv
+    mkAIEnv, testds, remove789s, reduce
 ) where
 
 import Data.Ord
 import Data.Monoid ((<>))
 import Data.List
+import qualified Data.Set as S
 import Control.Monad.State
 import Control.Monad.Reader
 import qualified Data.Map.Strict as M
@@ -152,9 +153,16 @@ toPiles table (h1, h2, h3, skt) = Piles (cs1 ++ cs2 ++ cs3) table ss
           cs3 = map (putAt Hand3) h3
           ss  = map (putAt SkatP) skt
 
+compareGuess :: (Card, [Option]) -> (Card, [Option]) -> Ordering
+compareGuess (c1, ops1) (c2, ops2)
+    | length ops1 == 1 = LT
+    | length ops2 == 1 = GT
+    | c1 > c2 = LT
+    | c1 < c2 = GT
+
 distributions :: Guess -> (Int, Int, Int, Int) -> [Distribution]
 distributions guess nos =
-        helper (sortBy (comparing $ length . snd) $ M.toList guess) nos
+        helper (sortBy compareGuess $ M.toList guess) nos
     where helper []           _ = []
           helper ((c, hs):[]) ns = map fst (distr c hs ns)
           helper ((c, hs):gs) ns =
@@ -177,30 +185,31 @@ distributions guess nos =
                 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
+abstract :: [Card] -> (Int, Int, Int, Int)
+abstract cs = foldr f (0, 0, 0, 0) cs
+    where f c (clubs, spades, hearts, diamonds) =
+            let v = getID c in
+            case getColour c of
+                Diamonds -> (clubs, spades, hearts, diamonds + 1 + v*100)
+                Hearts -> (clubs, spades, hearts + 1 + v*100, diamonds)
+                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 =
+            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)
+
+simplify :: Hand -> [Distribution] -> [Distribution]
+simplify = remove789s
 
 onPlayed :: MonadPlayer m => CardS Played -> AI m ()
 onPlayed c = do
@@ -255,12 +264,15 @@ chooseStatistic = do
                 0 -> (0,  0,  0, 0)
                 1 -> (-1, 0, -1, 0)
                 2 -> (0,  0, -1, 0)
-    let dis = distributions guess ns
+    let dis' = distributions guess ns
+        disNo' = length dis'
+        dis = simplify Hand3 dis'
         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 without simp " ++ show disNo'
     liftIO $ putStrLn $ "possible distrs " ++ show disNo
     vals <- M.toList <$> foldWithLimit limit runOnPiles M.empty piless
     liftIO $ print vals
@@ -396,10 +408,21 @@ 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)
+testguess = isSkat (take 2 $ drop 10 cs)
+        $ Hand3 `has` (take 10 cs) $ m
+    where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) (take 32 cs)
+          m = M.fromList l
+          cs = allCards
+
+testguess2 :: Guess
+testguess2 = isSkat (take 2 $ drop 6 cs)
+        $ Hand3 `has` [head cs, head $ drop 5 cs] $ m
+    where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) cs
           m = M.fromList l
+          cs = take 8 $ drop 8 allCards
 
 testds :: [Distribution]
 testds = distributions testguess (0, 0, 0, 0)
+
+testds2 :: [Distribution]
+testds2 = distributions testguess2 (0, 0, 0, 0)

AI/Test2.hs

@@ -0,0 +1,5 @@
+import AI.Rulebased
+import Pile
+
+main :: IO ()
+main = print $ length $ remove789s Hand3 testds

Card.hs

@@ -40,6 +40,17 @@ data Card = Card Type Colour
 getColour :: Card -> Colour
 getColour (Card _ c) = c
 
+getID :: Card -> Int
+getID (Card t _) = case t of
+    Seven -> 0
+    Eight -> 0
+    Nine -> 0
+    Queen -> 2
+    King -> 4
+    Ten -> 8
+    Ace -> 16
+    Jack -> 32
+
 instance Countable Card Int where
     count (Card t _) = count t