Build a yaku dictionary indexed by Cards

KoiKoi.hs

@@ -1,24 +1,8 @@
 module KoiKoi where
 
 import CCard
-import Data.Bits (popCount, (.&.))
-import System.Random (randomRIO)
-
-type Points = Int
-
-data Player = Player {
-      hand :: Pack
-    , captured :: Pack
-    , scored :: [Yaku]
-  }
-
-data State = State {
-      players :: (Player, Player)
-    , river :: Pack
-    , deck :: [ Card ]
-    , month :: Flower
-    , turn :: Bool
-  }
+import Data.Bits (popCount, (.&.), shift, testBit)
+import Data.Map (Map, empty, insert, unionWith)
 
 data Yaku =
     Goko
@@ -33,37 +17,58 @@ data Yaku =
   | Kasu
   | TsukimiZake
   | HanamiZake
+  | TsukiFuda
+  deriving (Show)
+type Points = Int
+type Score = Pack -> Maybe (Yaku, Points)
 
-yakus :: [ Pack -> Maybe (Yaku, Points) ]
-yakus = [
-      (\p -> lightsYaku (popCount p) (p `contains` RainMan)) . (lights .&.)
-    , is inoshikacho InoShikaCho
+data Player = Player {
+      hand :: Pack
+    , captured :: Pack
+    , scored :: Map Yaku Points
+  }
+
+data State = State {
+      players :: (Player, Player)
+    , river :: Pack
+    , deck :: [ Card ]
+    , month :: Flower
+    , turn :: Bool
+  }
+
+has :: Pack -> (Yaku, Points) -> (Pack, Score)
+has pack points =
+  (pack, \p -> if p == pack then Just points else Nothing)
+
+moreThan :: Int -> Pack -> Yaku -> (Pack, Score)
+moreThan count pack yaku =
+  (pack, (\n -> if n > 0 then Just (yaku, n) else Nothing) . ($count) . (-) . popCount)
+
+hikari :: (Pack, Score)
+hikari = (lights, \p -> rate (popCount p) (p `contains` RainMan))
+  where
+    rate 5 _ = Just (Goko, 10)
+    rate 4 hasRainMan = if hasRainMan then Just (AmeShiko, 7) else Just (Shiko, 8)
+    rate n hasRainMan = if not hasRainMan && n > 2 then Just (Sanko, 5) else Nothing
+
+tsukiFuda :: Flower -> (Pack, Score)
+tsukiFuda flower = has (0xf `shift` (fromEnum flower * 4)) (TsukiFuda, 8)
+
+index :: (Pack, Score) -> Map Card [Score]
+index (pack, score) =
+  foldl (\map card ->
+    if testBit pack $ fromEnum card then insert card [score . (.&.) pack] map else map
+  ) empty cards
+
+yakus :: Map Card [Score]
+yakus = foldl (\map -> unionWith (++) map . index) empty [
+      hikari
+    , has inoshikacho (InoShikaCho, 5)
     , moreThan 4 animals Tane
-    , is poetry Akatan
-    , is blue Aotan
+    , has poetry (Akatan, 5)
+    , has blue (Aotan, 5)
     , moreThan 4 ribbons Tan
     , moreThan 9 plain Kasu
-    , is (set [SakeCup, FullMoon]) TsukimiZake
-    , is (set [SakeCup, CampCurtain]) HanamiZake
+    , has (set [SakeCup, FullMoon]) (TsukimiZake, 5)
+    , has (set [SakeCup, CampCurtain]) (HanamiZake, 5)
   ]
-  where
-    lightsYaku 5 _ = Just (Goko, 10)
-    lightsYaku 4 hasRainMan = if hasRainMan then Just (AmeShiko, 7) else Just (Shiko, 8)
-    lightsYaku n hasRainMan = if not hasRainMan && n > 2 then Just (Sanko, 8) else Nothing
-    moreThan points set yaku =
-      threshold yaku . (\x -> x - points) . popCount . (set .&.)
-    threshold yaku n
-      | n > 0 = Just (yaku, n)
-      | otherwise = Nothing
-    is set yaku pack = if set == pack then Just (yaku, 5) else Nothing
-
-shuffle :: [a] -> IO [a]
-shuffle l =
-  aux (length l) l
-  where
-    aux n [] = return []
-    aux n (h:t) = do
-      cut <- randomRIO (0, n-1)
-      shuffled <- shuffle t
-      let (top, bottom) = splitAt cut shuffled
-      return $ top ++ h : bottom