Implement a naive AI believing cards have an intrinsinc value not depending on the context of the game

src/AI.hs

@@ -3,19 +3,89 @@ module AI (
     move
   ) where
 
+import Data.List (sortOn)
 import Data.Map ((!))
-import Hanafuda (cardsOfPack, sameMonth)
+import Data.Ord (Down(..))
+import Data.Set (Set, member)
+import qualified Data.Set as Set (fromList, intersection, unions)
+import Hanafuda (
+      Card(..), Flower(..), Pack
+    , cardsOf, cardsOfPack, contains, empty,flower, packOfCards, sameMonth, size, union
+  )
 import Hanafuda.Player (Player(..), Players(..))
-import Hanafuda.KoiKoi (GameBlueprint(..), Move(..), PlayerKey, Step(..))
+import Hanafuda.KoiKoi (GameBlueprint(..), Move(..), PlayerKey, Step(..), Score)
 import Hanafuda.Message (PublicGame)
 
 move :: PlayerKey -> PublicGame -> Move
-move me (Game {step = ToPlay, players = Players p}) =
+
-  Play . head . cardsOfPack . hand $ p ! me
+move me (Game {step = ToPlay, month, players = Players p, river}) =
-move me (Game {step = Turned card, river}) =
+  case getAvailableCards myHand (cardsOfPack river) of
-  Choose . last . cardsOfPack $ sameMonth card river
+    [] -> Play $ worstFor month (p ! (nextPlayer $ p ! me)) myHand
+    available ->
+      let riverCard = bestFor month (p ! me) available in
+      let matchingCards = cardsOfPack . sameMonth riverCard . hand $ p ! me in
+      capture (bestFor month (p ! me) matchingCards) riverCard river
   where
-    last [] = error "Empty list"
+    myHand = cardsOfPack . hand $ p ! me
-    last [x] = x
+
-    last (x:xs) = last xs
+move me (Game {step = Turned card, month, players = Players p, river}) =
-move me _ = KoiKoi True
+  Choose . bestFor month (p ! me) . cardsOfPack $ sameMonth card river
+
+move me (Game {players = Players p}) = KoiKoi $ hand (p ! me) /= empty
+
+capture :: Card -> Card -> Pack -> Move
+capture card caught river =
+  if size (sameMonth card river) == 1
+  then Play card
+  else Capture (card, caught)
+
+getAvailableCards :: [Card] -> [Card] -> [Card]
+getAvailableCards hand =
+  filter ((`member` flowersInHand) . flower)
+  where
+    flowersInHand = Set.fromList $ flower <$> hand
+
+choose :: Ord a => (Card -> a) -> [Card] -> Card
+choose sortCriterion = head . sortOn sortCriterion
+
+bestFor :: Flower -> Player Score -> [Card] -> Card
+bestFor monthFlower player = choose (Down . rank monthFlower player)
+
+worstFor :: Flower -> Player Score -> [Card] -> Card
+worstFor monthFlower player = choose (rank monthFlower player)
+
+rank :: Flower -> Player Score -> Card -> Int
+rank monthFlower _ card
+  | isTrueLight card = 5
+  | card == RainMan = 2
+  | isSpecialRibbon card = 4
+  | isRibbon card = 3
+  | isSpecialAnimal card = 4
+  | isAnimal card = 3
+  | isMonthly monthFlower card = 4
+  | otherwise = 1
+
+isTrueLight :: Card -> Bool
+isTrueLight = (packOfCards [Crane, CampCurtain, FullMoon, Phoenix] `contains`)
+
+isSpecialRibbon :: Card -> Bool
+isSpecialRibbon = ((aotan `union` akatan) `contains`)
+  where
+    aotan = packOfCards [PeonyBlue, ChrysanthemumBlue, MapleBlue]
+    akatan = packOfCards [PinePoetry, PlumPoetry, CherryPoetry]
+
+isRibbon :: Card -> Bool
+isRibbon card = isSpecialRibbon card || packOfCards other `contains` card
+  where
+    other = [WisteriaRed, IrisRed, BushCloverRed, WillowRed]
+
+isSpecialAnimal :: Card -> Bool
+isSpecialAnimal = (packOfCards [Butterflies, Boar, SakeCup, Deer] `contains`)
+
+isAnimal :: Card -> Bool
+isAnimal card = (isSpecialAnimal card) || (packOfCards other `contains` card)
+  where
+    other = [BushWarbler, Cuckoo, EightPlankBridge, Geese, Swallow]
+
+isMonthly :: Flower -> Card -> Bool
+isMonthly monthFlower = (cardsOf monthFlower `contains`)