{-# LANGUAGE NamedFieldPuns #-}
module KoiKoi where

import CCard
import Data.Bits (popCount, (.|.), (.&.))
import Data.Map (Map, adjust, empty, fromList, 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

data Player = Player {
      hand :: Pack
    , captured :: Pack
    , scored :: Score
  } deriving (Show)

data Turn = Player1 | Player2 deriving (Eq, Ord, Show)

switch :: Turn -> Turn
switch Player1 = Player2
switch _ = Player1

data Step = PlayACard | ChooseWhichCard Card | Scored deriving (Show)

data Game = Game {
      players :: Map Turn Player
    , river :: Pack
    , deck :: [ Card ]
    , turn :: Turn
    , month :: Flower
    , step :: Step
  } | Over {
      winner :: Turn
  } deriving (Show)

data Move = Drop Card | Take (Card, Card) | Choose Card | KoiKoi Bool

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 _ =
  (\n -> if n > 0 then Just (yaku, n) else Nothing) . ($count) . (-) . popCount

lights :: [Card]
lights = [Crane, CampCurtain, FullMoon, RainMan, Phoenix]

hikari :: Pack -> YakuFinder
hikari _ pack = rate (popCount 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 . (.&.) 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]

yakus :: Map Card [YakuFinder]
yakus = 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))
  ]

capture :: Flower -> Pack -> [Card] -> (Score, Pack)
capture month pack cards =
  let newPack = foldl add pack cards in
  let monthYakus = (unionWith (++) yakus . index $ tsukiFuda month) in
  let yakuFinders = foldl (\finders card -> monthYakus ! card ++ finders) [] cards in
  (foldl (\score -> foldr (uncurry insert) score . ($newPack)) empty yakuFinders, newPack)

foldApply :: [[a] -> ([a], [a])] -> [[a]] -> [[a]]
foldApply [] init = init
foldApply (f:fs) [x] =
  let (a,b) = f x in a : foldApply fs [b]

deal :: IO Game
deal = do
  shuffled <- shuffle cards
  let [hand1,hand2,river,deck] = foldApply (take 3 . repeat $ splitAt 8) [shuffled]
  let players = fromList [
            (Player1, Player {hand = packOfCards hand1, captured = packOfCards [], scored = empty})
          , (Player2, Player {hand = packOfCards hand2, captured = packOfCards [], scored = empty})
        ]
  return $ Game {
        players
      , river = packOfCards river
      , deck
      , turn = Player1
      , month = Pine
      , step = PlayACard
    }

makeSure :: Bool -> String -> Either String ()
makeSure check message = if check then return () else fail message

{-
playACard :: Game -> Card -> Card -> Either String Game
playACard (Game {players, river, month}) c1 c2 = do
  makeSure (hand `contains` c1) "You don't have that card"
  capture
-}

turnOver :: Game -> Either String Game
turnOver game@(Game { players, river, deck, turn, month, step }) =
  case deck of
    [] -> fail "Deck got empty"
    next : cards ->
      let game = game { deck = cards } in
      let canTake = sameMonth next .&. river in
      Right $ case popCount canTake of
        0 -> game { river = add river next }
        1 ->
          let current@(Player { captured, scored }) = players ! turn in
          let (score, newPack) = capture month captured (next:cardsOfPack canTake) in
          let game = game { players = insert turn (current { captured = newPack, scored = unionWith max scored score }) players } in
          if null score
            then game { step = PlayACard, turn = switch turn }
            else game { step = Scored }
        _ -> game { step = ChooseWhichCard next }

{-
play :: Game -> Move -> Either String Game
play game@(Game { players, river, deck, turn, month, step }) = playFrom step
  where
    playFrom PlayACard (Drop card) = do
      makeSure (month card .&. river == 0) "This card takes another one in the river"
      return $ game {
        player = 
        river = add card river
      }
    playFrom PlayACard (Take (card1, card2)) = do
      makeSure (card1 `pair` card2) "Cards aren't from the same month"
      makeSure (river `contains` card2) "That card isn't in the river"
      let player = case turn of
        Player1 -> fst players
        _ -> snd players
      playACard player c1 c2

    playFrom (ChooseWhichCard card1) (Choose card2) =
      makeSure (card1 `pair` card2) "Cards aren't from the same month"
      makeSure (river `contains` card2) "That card isn't in the river"

    playFrom Scored (KoiKoi yes) =

    playFrom _ _ = fail "Invalid move"
-}