{-# LANGUAGE TupleSections #-}

module Main (main) where

import Prelude hiding (catch)
import Control.Applicative ((<$>))
import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)
--import Control.Monad (unless)
import Data.Function (on)
import Data.List ((\\), maximumBy, transpose)
import Data.Maybe ({-isJust,-} mapMaybe)
import System.Environment (getArgs)
import System.IO (Handle, hGetLine, hFlush, hPutStrLn)
import System.Process (ProcessHandle, runInteractiveCommand, terminateProcess)

import Poker.Cards
import Poker.Hands


data Player = Player
  { pName :: String
  , pScore :: Int
  , pStdin :: Handle
  , pStdout :: Handle
  , pProc :: ProcessHandle }

instance Show Player where
  show p = show (pName p, pScore p)

initPlayer :: String -> String -> IO Player
initPlayer name exec = do
  (inh, outh, _, proch) <- runInteractiveCommand exec
  return $ Player name 0 inh outh proch


initGame :: IO [Player]
initGame = do
  nes <- pairs <$> getArgs
  mapM (uncurry initPlayer) nes
  where
    pairs (n:e:as) = (n, e) : pairs as
    pairs _ = []


dealCards :: Player -> [Card] -> IO ()
dealCards p cs = do
  hPutStrLn (pStdin p) $ unwords $ map show cs
  hFlush (pStdin p)

readHand :: Player -> Int -> IO (Maybe Hand)
readHand p n = do
  cs <- map read . words <$> hGetLine (pStdout p)
  case hands cs of
    [] -> return Nothing
    (h,_):_ -> return $ if length (cardList h) == n then Just h else Nothing

checkPlay :: [Card] -> [Hand] -> Maybe [Hand]
checkPlay cs ply = if nonInc ply && sameSet then Just ply else Nothing
  where
    sameSet =
      let cs' = concatMap cardList ply
      in cs \\ cs' == [] && cs' \\ cs == []
    nonInc (h1:h2:hs)
      | h1 >= h2 = nonInc (h2:hs)
      | otherwise = False
    nonInc _ = True

play :: Player -> [Card] -> IO (Maybe [Hand])
play p cs = do
  dealCards p cs
  mTopH <- readHand p 5
  mMidH <- readHand p 5
  mBotH <- readHand p 3
  return $ sequence [mTopH, mMidH, mBotH] >>= checkPlay cs


removeDQs :: [(Player, Maybe [Hand])] -> [(Player, [Hand])]
removeDQs = mapMaybe $ \(p, mh) -> (p,) <$> mh

liftHs :: [(Player, [Hand])] -> [[(Player, Hand)]]
liftHs = map $ \(p, hs) -> map (p,) hs

winners :: [[(Player, Hand)]] -> [(Player, Hand)]
winners = map $ maximumBy (compare `on` snd)

homog :: Eq a => [a] -> Bool
homog = all (uncurry (==)) . pairs
  where
    pairs (x:y:zs) = (x, y) : pairs (y:zs)
    pairs _ = []

update :: Player -> Int -> [Player] -> [Player]
update _ _ [] = []
update p pts (p':ps)
  | pName p == pName p' = p' { pScore = pts + pScore p' } : ps
  | otherwise = p' : update p pts ps

bonusT :: Hand
bonusT = FourKind (read "(2c, 2d, 2h, 2s)") []

bonusM :: Hand
bonusM = FullHouse (read "(2c, 2d, 2h)") (read "(3c, 3d)")

bonusB :: Hand
bonusB = ThreeKind (read "(2c, 2d, 2h)") []

score :: [Player] -> [(Player, Hand)] -> [Player]
score ps ((pT, hT):(pM, hM):(pB, hB):_) =
  update pT ptsT $
  update pM ptsM $
  update pB ptsB ps
  where
    ptsT = ptsS + if hT >= bonusT then 2 else 1
    ptsM = if hM >= bonusM then 2 else 1
    ptsB = if hB >= bonusB then 2 else 1
    ptsS = if homog $ map pName [pT, pM, pB] then 1 else 0
score _ _ = error "score called with < 3 rounds"

threadIOs :: [IO a] -> IO [a]
threadIOs acts = mapM go acts >>= mapM takeMVar
  where
    go act = do
      m <- newEmptyMVar
      _ <- forkIO $ act >>= putMVar m
      return m

playRound :: [Player] -> IO [Player]
playRound ps = do
  ds <- deals <$> shuffle deck
  mPlays <- threadIOs $ map (uncurry play) $ zip ps ds
  let ps' = score ps $ winners $ transpose $ liftHs $ removeDQs $ zip ps mPlays
  return ps'
  where
    deals [] = []
    deals xs = let (d, cs) = splitAt 13 xs in d : deals cs


untilM :: Monad m => (a -> Bool) -> (a -> m a) -> a -> m a
untilM c f x
  | c x = return x
  | otherwise = f x >>= untilM c f

main :: IO ()
main = do
  ps <- initGame
  ps' <- untilM (any ((>= 11) . pScore)) playRound ps
  mapM_ (putStrLn . show) ps'
  mapM_ (terminateProcess . pProc) ps'
