Purify types into newtypes to ease writing instances

src/Hanafuda/Card.hs

@@ -51,49 +51,52 @@ flower = toEnum . (`div` 4) . fromEnum
 
 type Monthly a = Reader Flower a
 
-type Pack = Word64
+newtype Pack = Pack { unpack :: Word64 } deriving (Eq)
 
 empty :: Pack
-empty = 0
+empty = Pack 0
 
 packOfCards :: [Card] -> Pack
-packOfCards = foldl add 0
+packOfCards = foldl add empty
 
 smallest :: Pack -> Card
-smallest = toEnum . countTrailingZeros
+smallest = toEnum . countTrailingZeros . unpack
 
 cardsOfPack :: Pack -> [Card]
-cardsOfPack 0 = []
+cardsOfPack (Pack 0) = []
-cardsOfPack pack =
+cardsOfPack p =
-  let n = countTrailingZeros pack in
+  let c = smallest p in
-  toEnum n : cardsOfPack (clearBit pack n)
+  c : cardsOfPack (remove p c)
 
-port :: (Bits a, Enum e) => (a -> Int -> b) -> a -> e -> b
+portEnum :: Enum e => (Word64 -> Int -> b) -> Pack -> e -> b
-port f bits = f bits . fromEnum
+portEnum f (Pack p) = f p . fromEnum
 
 contains :: Pack -> Card -> Bool
-contains = port testBit
+contains = portEnum testBit
 
 size :: Pack -> Int
-size = popCount
+size (Pack p) = popCount p
 
 add :: Pack -> Card -> Pack
-add = port setBit
+add p = Pack . portEnum setBit p
 
 remove :: Pack -> Card -> Pack
-remove = port clearBit
+remove p = Pack . portEnum clearBit p
+
+portBinary :: (Word64 -> Word64 -> Word64) -> Pack -> Pack -> Pack
+portBinary operator (Pack a) (Pack b) = Pack $ operator a b
 
 union :: Pack -> Pack -> Pack
-union = (.|.)
+union = portBinary (.|.)
 
 intersection :: Pack -> Pack -> Pack
-intersection = (.&.)
+intersection = portBinary (.&.)
 
 difference :: Pack -> Pack -> Pack
-difference a b = a `xor` (a .&. b)
+difference = portBinary (\a b -> a `xor` (a .&. b))
 
 sameMonth :: Card -> Pack
-sameMonth card = 0xf `shift` (fromEnum card .&. 0xfc)
+sameMonth card = Pack $ 0xf `shift` (fromEnum card .&. 0xfc)
 
 cards :: [Card]
 cards = [Pine0 .. Phoenix]

src/Hanafuda/Game.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 module Hanafuda.Game where
 
-import Data.Map (Map, empty, fromList)
+import Data.Map (Map, empty, fromList, (!))
 import Hanafuda.Card (Card, Pack, packOfCards)
 import Hanafuda.Yaku (Score, Points)
 
@@ -21,9 +21,15 @@ data PlayerState = PlayerState {
   }
 type Players = Map Player PlayerState
 
-initPlayers :: [Card] -> [Card] -> Players
+players :: [Player]
-initPlayers hand1 hand2 =
+players = [Player1, Player2]
-  fromList [(Player1, player hand1), (Player2, player hand2)]
+
+deal :: [a] -> Map Player a
+deal = fromList . zip players
+
+initPlayers :: [[Card]] -> Players
+initPlayers =
+  deal . map player
   where
     player cards = PlayerState {
         hand = packOfCards cards

src/Hanafuda/Month.hs

@@ -1,7 +1,5 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
 module Hanafuda.Month where
 
 import Hanafuda.Card (Card, Flower(Pine), cards, shuffle, packOfCards)
@@ -26,7 +24,10 @@ data Over = Over {
     , score :: Int
   }
 
-type Month = Either Over On
+newtype Month = Month (Either Over On)
+
+go :: On -> Month
+go = Month . Right
 
 new :: Player -> [Card] -> On
 new playing shuffled =
@@ -42,25 +43,25 @@ new playing shuffled =
   where
     take8 = state $ splitAt 8
     ([hand1, hand2, river], next:stock) = runState (replicateM 3 take8) shuffled
-    players = initPlayers hand1 hand2
+    players = initPlayers [hand1, hand2]
 
 next :: On -> IO On
-next month@(On {flower, oyake}) = do
+next (On {flower, oyake}) = do
   shuffled <- shuffle cards
-  return $ (new (Game.next oyake) cards) {flower = succ flower}
+  return $ (new (Game.next oyake) shuffled) {flower = succ flower}
 
 instance Game On Month where
-  play month@(On {flower, day, playing, players, stock = next : moreStock}) move =
+  play on@(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}
+        Month . Left $ Over {winner = playing, score = foldl (+) 0 yakus}
       after (Day {step = Day.Over False, player, river}) =
         let otherPlayer = Game.next playing in
-        Right $ month {
+        go $ on {
             players = insert playing player players
           , playing = otherPlayer
           , day = (Day.new river (players ! otherPlayer) next) { month = flower }
           , stock = moreStock
         }
-      after newDay = Right $ month {day = newDay}
+      after newDay = go $ on {day = newDay}

src/Hanafuda/Year.hs

@@ -1,14 +1,13 @@
 {-# 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 Hanafuda.Month (Month(..), flower, next, score, winner)
 import qualified Hanafuda.Month as Month (On(..), Over(..), new)
-import Hanafuda.Game (Game(..), Player(Player1), Scores)
+import Hanafuda.Game (Game(..), Player(Player1), Scores, deal)
-import Data.Map (Map, empty, insert, (!))
+import Data.Map (Map, insert, (!))
 import System.Random (StdGen)
 
 data Mode = FirstAt Int | WholeYear
@@ -22,35 +21,38 @@ data Over = Over {
     finalScores :: Scores
   }
 
-type Year = IO (Either Over On)
+newtype Year = Year (Either Over On)
 
-new :: Mode -> Year
+go :: On -> IO Year
+go = return . Year . Right
+
+new :: Mode -> IO Year
 new mode = do
   shuffled <- shuffle cards
-  return . Right $ On {
+  go $ On {
         mode
       , month = Month.new Player1 shuffled
-      , scores = empty
+      , scores = deal $ cycle [0]
     }
 
-consolidate :: On -> Player -> Int -> Year
+consolidate :: On -> Player -> Int -> IO Year
-consolidate year@(On {mode, month, scores}) winner score =
+consolidate on@(On {mode, month, scores}) winner score =
   case mode of
-    FirstAt n | n <= newScore -> over
+    FirstAt n | n <= newScore -> stop
     FirstAt n -> continue
-    WholeYear | flower month == Paulownia -> over
+    WholeYear | flower month == Paulownia -> stop
     WholeYear -> continue
   where
     newScore = scores ! winner + score
     newScores = insert winner newScore scores
-    over = return . Left $ Over {finalScores = newScores}
+    stop = return . Year . Left $ Over {finalScores = newScores}
     continue = do
       nextMonth <- next month
-      return . Right $ year {scores = newScores, month = nextMonth}
+      go $ on {scores = newScores, month = nextMonth}
 
-instance Game On Year where
+instance Game On (IO Year) where
-  play year@(On {mode, month}) move =
+  play on@(On {mode, month}) move =
     fmap after $ play month move
     where
-      after (Left (Month.Over {winner, score})) = consolidate year winner score
+      after (Month (Left (Month.Over {winner, score}))) = consolidate on winner score
-      after (Right newMonth) = return . Right $ year {month = newMonth}
+      after (Month (Right newMonth)) = go $ on {month = newMonth}