2018-03-10 23:25:44 +01:00
|
|
|
module Hanafuda (
|
|
|
|
Card(..)
|
|
|
|
, Flower(..)
|
|
|
|
, Monthly
|
|
|
|
, Pack
|
|
|
|
, add
|
|
|
|
, cards
|
2018-03-28 22:39:01 +02:00
|
|
|
, cardsOfPack
|
2018-03-10 23:25:44 +01:00
|
|
|
, contains
|
2018-03-15 22:32:24 +01:00
|
|
|
, empty
|
2018-03-10 23:25:44 +01:00
|
|
|
, flower
|
|
|
|
, intersection
|
|
|
|
, match
|
|
|
|
, packOfCards
|
|
|
|
, remove
|
|
|
|
, shuffle
|
|
|
|
, size
|
|
|
|
) where
|
2018-01-22 22:49:34 +01:00
|
|
|
|
2018-02-05 18:14:11 +01:00
|
|
|
import Data.Word (Word64)
|
|
|
|
import Data.Bits (
|
|
|
|
clearBit
|
|
|
|
, popCount
|
|
|
|
, setBit
|
|
|
|
, shift
|
|
|
|
, testBit
|
|
|
|
, xor
|
|
|
|
, (.&.)
|
|
|
|
, countTrailingZeros
|
|
|
|
)
|
|
|
|
import System.Random (randomRIO)
|
2019-01-08 22:34:29 +01:00
|
|
|
import Control.Monad.IO.Class (MonadIO(..))
|
2018-03-05 16:29:10 +01:00
|
|
|
import Control.Monad.Reader (Reader)
|
2018-02-05 18:14:11 +01:00
|
|
|
|
2018-01-22 22:49:34 +01:00
|
|
|
data Flower =
|
|
|
|
Pine
|
|
|
|
| Plum
|
|
|
|
| Cherry
|
|
|
|
| Wisteria
|
|
|
|
| Iris
|
|
|
|
| Peony
|
|
|
|
| BushClover
|
|
|
|
| SusukiGrass
|
|
|
|
| Chrysanthemum
|
|
|
|
| Maple
|
|
|
|
| Willow
|
|
|
|
| Paulownia
|
2018-02-05 18:14:11 +01:00
|
|
|
deriving (Eq, Ord, Enum, Show)
|
|
|
|
|
|
|
|
data Card =
|
|
|
|
Pine0 | Pine1 | PinePoetry | Crane
|
|
|
|
| Plum0 | Plum1 | PlumPoetry | BushWarbler
|
|
|
|
| Cherry0 | Cherry1 | CherryPoetry | CampCurtain
|
|
|
|
| Wisteria0 | Wisteria1 | WisteriaRed | Cuckoo
|
|
|
|
| Iris0 | Iris1 | IrisRed | EightPlankBridge
|
|
|
|
| Peony0 | Peony1 | PeonyBlue | Butterflies
|
|
|
|
| BushClover0 | BushClover1 | BushCloverRed | Boar
|
|
|
|
| SusukiGrass0 | SusukiGrass1 | Geese | FullMoon
|
|
|
|
| Chrysanthemum0 | Chrysanthemum1 | ChrysanthemumBlue | SakeCup
|
|
|
|
| Maple0 | Maple1 | MapleBlue | Deer
|
|
|
|
| Lightning | WillowRed | Swallow | RainMan
|
|
|
|
| Paulownia0 | Paulownia1 | Sand | Phoenix
|
|
|
|
deriving (Eq, Ord, Enum, Show)
|
|
|
|
|
|
|
|
flower :: Card -> Flower
|
|
|
|
flower = toEnum . (`div` 4) . fromEnum
|
|
|
|
|
2018-03-05 16:29:10 +01:00
|
|
|
type Monthly a = Reader Flower a
|
|
|
|
|
2018-03-07 17:32:28 +01:00
|
|
|
newtype Pack = Pack { unpack :: Word64 } deriving (Eq)
|
2018-02-05 18:14:11 +01:00
|
|
|
|
|
|
|
empty :: Pack
|
2018-03-07 17:32:28 +01:00
|
|
|
empty = Pack 0
|
2018-02-05 18:14:11 +01:00
|
|
|
|
|
|
|
packOfCards :: [Card] -> Pack
|
2018-03-07 17:32:28 +01:00
|
|
|
packOfCards = foldl add empty
|
2018-02-05 18:14:11 +01:00
|
|
|
|
|
|
|
smallest :: Pack -> Card
|
2018-03-07 17:32:28 +01:00
|
|
|
smallest = toEnum . countTrailingZeros . unpack
|
2018-02-05 18:14:11 +01:00
|
|
|
|
|
|
|
cardsOfPack :: Pack -> [Card]
|
2018-03-07 17:32:28 +01:00
|
|
|
cardsOfPack (Pack 0) = []
|
|
|
|
cardsOfPack p =
|
|
|
|
let c = smallest p in
|
|
|
|
c : cardsOfPack (remove p c)
|
2018-02-05 18:14:11 +01:00
|
|
|
|
2018-03-10 23:25:44 +01:00
|
|
|
instance Show Pack where
|
|
|
|
show = ("packOfCards " ++) . show . cardsOfPack
|
|
|
|
|
2018-03-07 17:32:28 +01:00
|
|
|
portEnum :: Enum e => (Word64 -> Int -> b) -> Pack -> e -> b
|
|
|
|
portEnum f (Pack p) = f p . fromEnum
|
2018-02-05 18:14:11 +01:00
|
|
|
|
|
|
|
contains :: Pack -> Card -> Bool
|
2018-03-07 17:32:28 +01:00
|
|
|
contains = portEnum testBit
|
2018-02-05 18:14:11 +01:00
|
|
|
|
2018-02-25 23:17:51 +01:00
|
|
|
size :: Pack -> Int
|
2018-03-07 17:32:28 +01:00
|
|
|
size (Pack p) = popCount p
|
2018-02-25 23:17:51 +01:00
|
|
|
|
2018-02-05 18:14:11 +01:00
|
|
|
add :: Pack -> Card -> Pack
|
2018-03-07 17:32:28 +01:00
|
|
|
add p = Pack . portEnum setBit p
|
2018-02-05 18:14:11 +01:00
|
|
|
|
|
|
|
remove :: Pack -> Card -> Pack
|
2018-03-07 17:32:28 +01:00
|
|
|
remove p = Pack . portEnum clearBit p
|
|
|
|
|
|
|
|
portBinary :: (Word64 -> Word64 -> Word64) -> Pack -> Pack -> Pack
|
|
|
|
portBinary operator (Pack a) (Pack b) = Pack $ operator a b
|
2018-02-05 18:14:11 +01:00
|
|
|
|
|
|
|
intersection :: Pack -> Pack -> Pack
|
2018-03-07 17:32:28 +01:00
|
|
|
intersection = portBinary (.&.)
|
2018-02-05 18:14:11 +01:00
|
|
|
|
|
|
|
difference :: Pack -> Pack -> Pack
|
2018-03-07 17:32:28 +01:00
|
|
|
difference = portBinary (\a b -> a `xor` (a .&. b))
|
2018-02-05 18:14:11 +01:00
|
|
|
|
|
|
|
sameMonth :: Card -> Pack
|
2018-03-07 17:32:28 +01:00
|
|
|
sameMonth card = Pack $ 0xf `shift` (fromEnum card .&. 0xfc)
|
2018-02-05 18:14:11 +01:00
|
|
|
|
|
|
|
cards :: [Card]
|
|
|
|
cards = [Pine0 .. Phoenix]
|
|
|
|
|
2019-01-08 22:34:29 +01:00
|
|
|
shuffle :: MonadIO m => [a] -> m [a]
|
2018-02-05 18:14:11 +01:00
|
|
|
shuffle l =
|
|
|
|
aux (length l) l
|
|
|
|
where
|
2018-03-19 12:28:15 +01:00
|
|
|
aux _ [] = return []
|
2018-02-05 18:14:11 +01:00
|
|
|
aux n (h:t) = do
|
2019-01-08 22:34:29 +01:00
|
|
|
cut <- liftIO $ randomRIO (0, n-1)
|
2018-02-05 18:14:11 +01:00
|
|
|
shuffled <- shuffle t
|
|
|
|
let (top, bottom) = splitAt cut shuffled
|
|
|
|
return $ top ++ h : bottom
|
|
|
|
|
2018-03-10 23:25:44 +01:00
|
|
|
match :: Card -> Pack -> Either String (Pack, [Card])
|
|
|
|
match card pack =
|
2018-02-05 18:14:11 +01:00
|
|
|
let sameMonthCards = sameMonth card `intersection` pack in
|
2018-02-25 23:17:51 +01:00
|
|
|
case size sameMonthCards of
|
2018-03-07 17:50:01 +01:00
|
|
|
0 -> Right (add pack card, [])
|
|
|
|
1 -> Right (difference pack sameMonthCards, card : cardsOfPack sameMonthCards)
|
2018-03-10 23:25:44 +01:00
|
|
|
_ -> Left "This card can match several others"
|