Package with cabal and implement game automaton

This commit is contained in:
Sasha 2018-03-05 16:29:10 +01:00
parent 034fee8ecd
commit dfccff2915
11 changed files with 390 additions and 86 deletions

3
.gitignore vendored
View file

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

5
ChangeLog.md Normal file
View file

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

30
LICENSE Normal file
View file

@ -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.

79
Yaku.hs
View file

@ -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))
]

33
hanafuda.cabal Normal file
View file

@ -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

View file

@ -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)
1 -> Just (difference pack sameMonthCards, add sameMonthCards card)
0 -> Just (add pack card, [])
1 -> Just (difference pack sameMonthCards, card : cardsOfPack sameMonthCards)
_ -> Nothing

62
src/Hanafuda/Day.hs Normal file
View file

@ -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}

39
src/Hanafuda/Game.hs Normal file
View file

@ -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

66
src/Hanafuda/Month.hs Normal file
View file

@ -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}

90
src/Hanafuda/Yaku.hs Normal file
View file

@ -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

56
src/Hanafuda/Year.hs Normal file
View file

@ -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}