Package with cabal and implement game automaton

.gitignore

@@ -1,2 +1 @@
-*.hi
+/dist/*
-*.o

ChangeLog.md

@@ -0,0 +1,5 @@
+# Revision history for hanafuda
+
+## 0.1.0.0  -- 2018-03-03
+
+* Game automaton, packaged with cabal

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2018, Sasha
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Sasha nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Yaku.hs

@@ -1,79 +0,0 @@
-module Yaku where
-
-import Card (Card(..), Flower, Pack, size, contains, intersection, packOfCards)
-import Data.Map (Map, empty, insert, unionWith)
-
-data Yaku =
-    Goko
-  | Shiko
-  | AmeShiko
-  | Sanko
-  | InoShikaCho
-  | Tane
-  | Akatan
-  | Aotan
-  | Tan
-  | Kasu
-  | TsukimiZake
-  | HanamiZake
-  | TsukiFuda
-  deriving (Eq, Ord, Show)
-type Points = Int
-type YakuFinder = Pack -> Maybe (Yaku, Points)
-type Score = Map Yaku Points
-
-fixed :: (Yaku, Points) -> Pack -> YakuFinder
-fixed points indicatorSet pack = if pack == indicatorSet then Just points else Nothing
-
-moreThan :: Int -> Yaku -> (Pack -> YakuFinder)
-moreThan count yaku _ pack =
-  let n = size pack - count in
-  if n > 0 then Just (yaku, n) else Nothing
-
-lights :: [Card]
-lights = [Crane, CampCurtain, FullMoon, RainMan, Phoenix]
-
-hikari :: Pack -> YakuFinder
-hikari _ pack = rate (size pack) (pack `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 -> ([Card], Pack -> YakuFinder)
-tsukiFuda flower = (map toEnum $ map (fromEnum flower * 4 +) [0..3], fixed (TsukiFuda, 8))
-
-index :: ([Card], Pack -> YakuFinder) -> Map Card [YakuFinder]
-index (cards, scorer) =
-  let pack = packOfCards cards in
-  foldl (\map card -> insert card [scorer pack . intersection pack] map) empty cards
-
-inoshikacho :: [Card]
-inoshikacho = [Butterflies, Boar, Deer]
-
-animals :: [Card]
-animals = [BushWarbler, Cuckoo, EightPlankBridge, Geese, SakeCup, Swallow] ++ inoshikacho
-
-blue :: [Card]
-blue = [PeonyBlue, ChrysanthemumBlue, MapleBlue]
-
-poetry :: [Card]
-poetry = [PinePoetry, PlumPoetry, CherryPoetry]
-
-ribbons = [WisteriaRed, IrisRed, BushCloverRed, WillowRed] ++ blue ++ poetry
-
-plain :: [Card]
-plain = (foldl (++) [] [map toEnum [4*i, 4*i+1] | i <- [0..10]]) ++ Lightning : [Paulownia0 .. Sand]
-
-allYakus :: Map Card [YakuFinder]
-allYakus = foldl (\map -> unionWith (++) map . index) empty [
-      (lights, hikari)
-    , (inoshikacho, fixed (InoShikaCho, 5))
-    , (animals, moreThan 4 Tane)
-    , (poetry, fixed (Akatan, 5))
-    , (blue, fixed (Aotan, 5))
-    , (ribbons, moreThan 4 Tan)
-    , (plain, moreThan 9 Kasu)
-    , ([SakeCup, FullMoon], fixed (TsukimiZake, 5))
-    , ([SakeCup, CampCurtain], fixed (HanamiZake, 5))
-  ]

hanafuda.cabal

@@ -0,0 +1,33 @@
+-- Initial hanafuda.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                hanafuda
+version:             0.1.0.0
+synopsis:            A game of Hanafuda (a family of japanese card games)
+-- description:         
+homepage:            https://framagit.org/sasha/hanafuda
+license:             BSD3
+license-file:        LICENSE
+author:              Sasha
+maintainer:          sasha+frama@marvid.fr
+-- copyright:           
+category:            Game
+build-type:          Simple
+extra-source-files:  ChangeLog.md
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Hanafuda.Year
+                     , Hanafuda.Month
+                     , Hanafuda.Day
+                     , Hanafuda.Game
+                     , Hanafuda.Yaku
+                     , Hanafuda.Card
+  -- other-modules:
+  -- other-extensions:    
+  build-depends:       base >=4.10 && <4.11
+                     , containers
+                     , mtl
+                     , random
+  hs-source-dirs:      src
+  default-language:    Haskell2010

src/Hanafuda/Card.hs

@@ -1,4 +1,4 @@
-module Card where
+module Hanafuda.Card where
 
 import Data.Word (Word64)
 import Data.Bits (
@@ -14,6 +14,7 @@ import Data.Bits (
     , countTrailingZeros
   )
 import System.Random (randomRIO)
+import Control.Monad.Reader (Reader)
 
 data Flower =
     Pine
@@ -48,13 +49,15 @@ data Card =
 flower :: Card -> Flower
 flower = toEnum . (`div` 4) . fromEnum
 
+type Monthly a = Reader Flower a
+
 type Pack = Word64
 
 empty :: Pack
 empty = 0
 
 packOfCards :: [Card] -> Pack
-packOfCards = foldl setBit 0 . map fromEnum
+packOfCards = foldl add 0
 
 smallest :: Pack -> Card
 smallest = toEnum . countTrailingZeros
@@ -106,10 +109,10 @@ shuffle l =
       let (top, bottom) = splitAt cut shuffled
       return $ top ++ h : bottom
 
-pair :: Card -> Pack -> Maybe (Pack, Pack)
+pair :: Card -> Pack -> Maybe (Pack, [Card])
 pair card pack =
   let sameMonthCards = sameMonth card `intersection` pack in
   case size sameMonthCards of
-    0 -> Just (add pack card, empty)
+    0 -> Just (add pack card, [])
-    1 -> Just (difference pack sameMonthCards, add sameMonthCards card)
+    1 -> Just (difference pack sameMonthCards, card : cardsOfPack sameMonthCards)
     _ -> Nothing

src/Hanafuda/Day.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Hanafuda.Day where
+
+import Hanafuda.Card (Card, Pack, Flower(Pine), contains, flower, packOfCards, pair, remove)
+import Hanafuda.Yaku (rate)
+import Hanafuda.Game (Game(..), Move(..), PlayerState, meld, yakus)
+import Data.Map (Map, adjust, empty, fromList, insert, union, (!))
+import Control.Monad.Reader (runReader)
+
+data Step = ToPlay | ToChoose (Maybe Card) | Scored | Over Bool
+
+data Day = Day {
+      river :: Pack
+    , month :: Flower
+    , player :: PlayerState
+    , next :: Card
+    , step :: Step
+    , trick :: [Card]
+  }
+
+new :: Pack -> PlayerState -> Card -> Day
+new river player next = Day {
+      river
+    , month = Pine
+    , player
+    , next
+    , step = ToPlay
+    , trick = []
+  }
+
+instance Game Day Day where
+  play day@(Day {river, step, next, trick}) move =
+    case (step, move) of
+      (ToPlay, Play card) ->
+        case pair card river of
+          Just (newRiver, newCaptured) -> turnOver $ day {river = newRiver, trick = newCaptured}
+          Nothing -> Right $ day {step = ToChoose (Just card)}
+      (ToChoose maybeCard, Choose caught) ->
+        let (continue, card) = maybe (end, next) ((,) turnOver) maybeCard in
+        if card `canCatch` caught
+          then turnOver $
+            day {river = remove river caught, trick = [card, caught] ++ trick}
+          else Left "You can't choose that card"
+      (Scored, KoiKoi win) -> Right $ day {step = Over win}
+      (_, _) -> Left "You can't play this move in that state"
+    where
+      canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2
+
+turnOver :: Day -> Either String Day
+turnOver day@(Day {river, next, trick}) =
+  case pair next river of
+    Just (newRiver, newCaptured) -> end $ day {river = newRiver, trick = trick ++ newCaptured}
+    Nothing -> Right $ day {step = ToChoose Nothing}
+
+end :: Day -> Either String Day
+end day@(Day {month, trick, player}) =
+  let (scored, newMeld) = runReader (rate (meld player) trick) month in
+  let updatedPlayer = day {player = player {meld = newMeld, yakus = scored `union` (yakus player)}} in
+  Right $ if null scored
+    then updatedPlayer {step = Over False}
+    else updatedPlayer {step = Scored}

src/Hanafuda/Game.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Hanafuda.Game where
+
+import Data.Map (Map, empty, fromList)
+import Hanafuda.Card (Card, Pack, packOfCards)
+import Hanafuda.Yaku (Score, Points)
+
+data Player =
+    Player1
+  | Player2
+  deriving (Eq, Ord)
+
+next :: Player -> Player
+next Player1 = Player2
+next _ = Player1
+
+data PlayerState = PlayerState {
+      hand :: Pack
+    , meld :: Pack
+    , yakus :: Score
+  }
+type Players = Map Player PlayerState
+
+initPlayers :: [Card] -> [Card] -> Players
+initPlayers hand1 hand2 =
+  fromList [(Player1, player hand1), (Player2, player hand2)]
+  where
+    player cards = PlayerState {
+        hand = packOfCards cards
+      , meld = packOfCards []
+      , yakus = empty
+    }
+
+data Move = Play Card | Choose Card | KoiKoi Bool
+
+type Scores = Map Player Points
+
+class Game a b where
+  play :: a -> Move -> Either String b

src/Hanafuda/Month.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Hanafuda.Month where
+
+import Hanafuda.Card (Card, Flower(Pine), cards, shuffle, packOfCards)
+import Hanafuda.Day (Day(..))
+import qualified Hanafuda.Day as Day (Step(Over), next, new)
+import Hanafuda.Game (Game(..), Move, Player, Players, PlayerState(..), initPlayers)
+import qualified Hanafuda.Game as Game (next)
+import Data.Map ((!), insert)
+import Control.Monad.State (replicateM, runState, state)
+
+data On = On {
+      flower :: Flower
+    , players :: Players
+    , day :: Day
+    , playing :: Player
+    , lastScored :: Player
+    , oyake :: Player
+    , stock :: [Card]
+  } 
+data Over = Over {
+      winner :: Player
+    , score :: Int
+  }
+
+type Month = Either Over On
+
+new :: Player -> [Card] -> On
+new playing shuffled =
+  On {
+        flower = Pine
+      , players
+      , day = Day.new (packOfCards river) (players ! playing) next
+      , playing
+      , lastScored = playing
+      , oyake = playing
+      , stock
+    }
+  where
+    take8 = state $ splitAt 8
+    ([hand1, hand2, river], next:stock) = runState (replicateM 3 take8) shuffled
+    players = initPlayers hand1 hand2
+
+next :: On -> IO On
+next month@(On {flower, oyake}) = do
+  shuffled <- shuffle cards
+  return $ (new (Game.next oyake) cards) {flower = succ flower}
+
+instance Game On Month where
+  play month@(On {flower, day, playing, players, stock = next : moreStock}) move =
+    fmap after $ play day move
+    where
+      after (Day {step = Day.Over True, player = PlayerState {yakus}}) =
+        Left $ Over {winner = playing, score = foldl (+) 0 yakus}
+      after (Day {step = Day.Over False, player, river}) =
+        let otherPlayer = Game.next playing in
+        Right $ month {
+            players = insert playing player players
+          , playing = otherPlayer
+          , day = (Day.new river (players ! otherPlayer) next) { month = flower }
+          , stock = moreStock
+        }
+      after newDay = Right $ month {day = newDay}

src/Hanafuda/Yaku.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Hanafuda.Yaku where
+
+import Hanafuda.Card (Card(..), Flower, Monthly, Pack, add, contains, intersection, packOfCards, size)
+import qualified Data.Map as M (Map, empty, insert, unionWith, (!))
+import qualified Data.Set as S (Set, empty, insert, singleton, union)
+import Control.Monad.Reader (reader)
+
+data Yaku =
+    Lights
+  | InoShikaCho
+  | Tane
+  | Akatan
+  | Aotan
+  | Tan
+  | Kasu
+  | TsukimiZake
+  | HanamiZake
+  | TsukiFuda
+  deriving (Eq, Ord, Show)
+type YakuRater = Pack -> Maybe Points
+type Points = Int
+type Score = M.Map Yaku Points
+
+data YakuFinder = YakuFinder {
+      yaku :: Yaku
+    , rater :: YakuRater
+  }
+
+instance Eq YakuFinder where
+  a == b = yaku a == yaku b
+
+instance Ord YakuFinder where
+  compare a b = compare (yaku a) (yaku b)
+
+type YakuByCard = M.Map Card (S.Set YakuFinder)
+
+lights :: Pack -> YakuRater
+lights _ pack = rate (size pack) (pack `contains` RainMan)
+  where
+    goko = 10
+    shiko = 8
+    ameshiko = 7
+    sanko = 5
+    rate 5 _ = Just goko
+    rate 4 hasRainMan = if hasRainMan then Just ameshiko else Just shiko
+    rate n hasRainMan = if not hasRainMan && n > 2 then Just sanko else Nothing
+
+fixed :: Points -> Pack -> YakuRater
+fixed points indicatorSet pack = if pack == indicatorSet then Just points else Nothing
+
+moreThan :: Int -> (Pack -> YakuRater)
+moreThan count _ pack =
+  let n = size pack - count in
+  if n > 0 then Just n else Nothing
+
+index :: (Yaku, [Card], (Pack -> YakuRater)) -> YakuByCard
+index (yaku, cards, scorer) =
+  let pack = packOfCards cards in
+  let yakuFinder = YakuFinder {yaku, rater = scorer pack . intersection pack} in
+  foldl (\map card -> M.insert card (S.singleton yakuFinder) map) M.empty cards
+
+finders :: Monthly YakuByCard
+finders = do
+  monthCardPlus <- reader $ (+) . (4*) . fromEnum
+  return $ foldl (\map -> M.unionWith S.union map . index) M.empty [
+        (Lights, [Crane, CampCurtain, FullMoon, RainMan, Phoenix], lights)
+      , (InoShikaCho, inoshikacho, fixed 5)
+      , (Tane, [BushWarbler, Cuckoo, EightPlankBridge, Geese, SakeCup, Swallow] ++ inoshikacho, moreThan 4)
+      , (Akatan, akatan, fixed 5)
+      , (Aotan, aotan, fixed 5)
+      , (Tan, [WisteriaRed, IrisRed, BushCloverRed, WillowRed] ++ aotan ++ akatan, moreThan 4)
+      , (Kasu, (foldl (++) [] [map toEnum [4*i, 4*i+1] | i <- [0..10]]) ++ Lightning : [Paulownia0 .. Sand], moreThan 9)
+      , (TsukimiZake, [SakeCup, FullMoon], fixed 3)
+      , (HanamiZake, [SakeCup, CampCurtain], fixed 3)
+      , (TsukiFuda, map (toEnum . monthCardPlus) [0..3], fixed 5)
+    ]
+  where
+    inoshikacho = [Butterflies, Boar, Deer]
+    aotan = [PeonyBlue, ChrysanthemumBlue, MapleBlue]
+    akatan = [PinePoetry, PlumPoetry, CherryPoetry]
+
+rate :: Pack -> [Card] -> Monthly (Score, Pack)
+rate pack cards = do
+  yakusToCheck <- fmap toCheck finders
+  return (foldl scored M.empty yakusToCheck, newPack)
+  where
+    newPack = foldl add pack cards
+    toCheck map = foldl (\set key -> S.union set (map M.! key)) S.empty cards
+    scored score (YakuFinder {yaku, rater}) = foldr (M.insert yaku) score $ rater newPack

src/Hanafuda/Year.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Hanafuda.Year where
+
+import Hanafuda.Card (Flower(Paulownia), cards, shuffle)
+import Hanafuda.Month (flower, next, score, winner)
+import qualified Hanafuda.Month as Month (On(..), Over(..), new)
+import Hanafuda.Game (Game(..), Player(Player1), Scores)
+import Data.Map (Map, empty, insert, (!))
+import System.Random (StdGen)
+
+data Mode = FirstAt Int | WholeYear
+
+data On = On {
+      mode :: Mode
+    , month :: Month.On
+    , scores :: Scores
+  }
+data Over = Over {
+    finalScores :: Scores
+  }
+
+type Year = IO (Either Over On)
+
+new :: Mode -> Year
+new mode = do
+  shuffled <- shuffle cards
+  return . Right $ On {
+        mode
+      , month = Month.new Player1 shuffled
+      , scores = empty
+    }
+
+consolidate :: On -> Player -> Int -> Year
+consolidate year@(On {mode, month, scores}) winner score =
+  case mode of
+    FirstAt n | n <= newScore -> over
+    FirstAt n -> continue
+    WholeYear | flower month == Paulownia -> over
+    WholeYear -> continue
+  where
+    newScore = scores ! winner + score
+    newScores = insert winner newScore scores
+    over = return . Left $ Over {finalScores = newScores}
+    continue = do
+      nextMonth <- next month
+      return . Right $ year {scores = newScores, month = nextMonth}
+
+instance Game On Year where
+  play year@(On {mode, month}) move =
+    fmap after $ play month move
+    where
+      after (Left (Month.Over {winner, score})) = consolidate year winner score
+      after (Right newMonth) = return . Right $ year {month = newMonth}