CommandLine.hs

-- Copyright (c) 2014-2015 Jonathan M. Lange <jml@mumak.net>
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Haverer.CLI.CommandLine (
  ConsoleText(..),
  formatScores,
  pickNumPlayers,
  pickCardToPlay,
  pickPlay
  ) where

import BasicPrelude hiding (round)
import Control.Error hiding (readMay)

import qualified Data.Map as Map

import Haverer.Action (Play(..), viewAction)
import Haverer.Deck (Card(..))
import Haverer.Player (getDiscards, isProtected)
import Haverer.PlayerSet (PlayerSet, toPlayers)
import Haverer.Round (
  Event(..),
  Result(..),
  Round,
  Victory(..),
  getPlayerMap,
  remainingCards
  )

import Haverer.CLI.Prompt (
  ConsoleText,
  repeatedlyPrompt,
  chooseItem,
  chooseItem',
  underline,
  toText
  )



instance ConsoleText Card where
  toText = show


instance ConsoleText a => ConsoleText (Round a) where

  toText round =
    "Cards remaining: " ++ show (remainingCards round) ++ ".\n\n" ++
    underline '-' "All discards" ++ "\n" ++
    Map.foldrWithKey (\k a b -> formatPlayer k a ++ "\n" ++ b) "" (getPlayerMap round)
    where
      formatPlayer pid player =
        toText pid ++ ": " ++ intercalate ", " (map toText (getDiscards player)) ++ playerStatus player
      playerStatus player =
        case isProtected player of
         Just True -> " (protected)"
         Just False -> ""
         Nothing -> " (eliminated)"


instance (Eq a, ConsoleText a, Show a) => ConsoleText (Result a) where

  -- FIXME: Don't have quite enough information here to disambiguate between
  -- Soldier attack failing due to wrong guess and Soldier attack failing due to
  -- Priestess.
  toText (Played (viewAction -> (pid1, Soldier, Guess pid2 card)) NoChange) =
    toText pid1 ++ " wrongly guessed " ++ toText pid2 ++ " had a " ++ toText card
    ++ ". Nothing happened, maybe it was the right guess and they were protected."

  -- FIXME: Don't have quite enough information here to disambiguate between
  -- Knight attack failing due to tie and Knight attack failing due to
  -- Priestess.
  toText (Played (viewAction -> (pid1, Knight, Attack pid2)) NoChange) =
    toText pid1 ++ " attacked " ++ toText pid2 ++ " with a Knight, but nothing happened. "
    ++ "Because of a bug in the software, you don't know if it's because of a tie or "
    ++ "because " ++ toText pid2 ++ " is protected by the Priestess."

  toText (Played (viewAction -> (pid1, card, Attack pid2)) NoChange) =
    toText pid1 ++ " played " ++ toText card ++ " against " ++ toText pid2 ++
    ", but they were protected by the Priestess, so nothing happened"

  toText (Played (viewAction -> (pid1, card, NoEffect)) NoChange) =
    toText pid1 ++ " played " ++ toText card

  toText (BustedOut pid c1 c2) =
    toText pid ++ " busted out, holding " ++ toText c1 ++ " and " ++ toText c2

  toText (Played (viewAction -> (pid, Priestess, _)) (Protected p))
    | p == pid =
        toText pid ++ " played Priestess, protecting themselves from harm"
    | otherwise = error "BUG: " ++ show pid ++ " played Priestess but ended up protecting " ++ show p

  toText (Played _ (SwappedHands pid1 pid2)) =
    toText pid2 ++ " swapped hands with " ++ toText pid1

  toText (Played (viewAction -> (pid1, Soldier, Guess pid2 card)) (Eliminated loser))
    | loser == pid2 =
        toText pid1 ++ " correctly guessed " ++ toText pid2 ++ " had a " ++ toText card
        ++ ". " ++ toText pid2 ++ " has been eliminated"
    | otherwise = error "BUG: Soldier attacked " ++ show pid2 ++ " but eliminated " ++ show loser

  toText (Played (viewAction -> (pid1, Knight, Attack pid2)) (Eliminated loser)) =
    toText pid1 ++ " attacked " ++ toText pid2 ++ " with a Knight " ++
    (if loser == pid1
     then "and lost. "
     else (if loser == pid2 then "and won. " else error "BUG: Knight!")) ++
    toText loser ++ " has been eliminated"

  toText (Played (viewAction -> (pid1, Prince, NoEffect)) (Eliminated loser))
    | loser == pid1 = toText pid1 ++ " played the Prince, eliminating themselves"
    | otherwise = error "BUG: " ++ show pid1 ++ " played Prince, but " ++ show loser ++ " eliminated."

  -- FIXME: There are two reasons they could lose here: 1. Discard Prince, 2.
  -- Discard last card. Disambiguate between them.
  toText (Played (viewAction -> (pid1, Wizard, Attack pid2)) (Eliminated loser))
    | loser == pid2 =
        toText pid1 ++ " played Wizard on " ++ toText pid2 ++ " forcing them to discard "
        ++ "and thus be eliminated from the round"
    | otherwise = error "BUG: Wizard attacked " ++ show pid2 ++ " but eliminated " ++ show loser

  toText (Played _ (ForcedDiscard pid)) =
    toText pid ++ " was forced to discard their hand and draw another card"

  -- XXX: This is revealed to all who are watching the console.
  toText (Played _ (ForcedReveal pid1 pid2 card)) =
    toText pid1 ++ ": " ++ toText pid2 ++ " is holding a " ++ toText card

  toText event = "UNKNOWN: " ++ show event


instance ConsoleText a => ConsoleText (Victory a) where
  toText (SoleSurvivor pid card) =
    toText pid ++ " wins as the only remaining player, holding " ++ toText card
  toText (HighestCard card [winner] _) =
    toText winner ++ " wins holding " ++ toText card
  toText (HighestCard card winners _) =
    "Many winners holding " ++ toText card ++ ": " ++ intercalate ", " (map toText winners)


formatScores :: ConsoleText playerId => [(playerId, Int)] -> Text
formatScores scores =
  underline '-' "Scores" ++ "\n" ++
  unlines (map formatScore scores)
  where formatScore (pid, score) = toText pid ++ ": " ++ toText score


pickNumPlayers :: IO Int
pickNumPlayers =
  repeatedlyPrompt "Pick number of players: " parseNumPlayers
  where
    parseNumPlayers s = do
      i <- note errMsg (readMay s)
      assertErr errMsg (2 <= i && i <= 4)
      return i
    errMsg = "Please enter a number between 2 and 4" :: Text


pickCardToPlay :: (Card, Card) -> IO Card
pickCardToPlay (dealt, hand) =
  chooseItem "\nPlease choose a card: " [dealt, hand]


pickPlay :: ConsoleText playerId => Card -> PlayerSet playerId -> IO (Play playerId)
pickPlay card players =
  case card of
   Soldier -> pickGuess players
   Clown -> pickAttack players
   Knight -> pickAttack players
   Priestess -> return NoEffect
   Wizard -> pickAttack players
   General -> pickAttack players
   Minister -> return NoEffect
   Prince -> return NoEffect


-- XXX: Exclude self-targeting when it's not legal
pickTarget :: ConsoleText playerId => PlayerSet playerId -> IO playerId
pickTarget ps = chooseItem "\nPlease choose a target: " (toPlayers ps)

pickAttack :: ConsoleText playerId => PlayerSet playerId -> IO (Play playerId)
pickAttack players = fmap Attack (pickTarget players)

pickGuess :: ConsoleText playerId => PlayerSet playerId -> IO (Play playerId)
pickGuess players = do
  target <- pickTarget players
  guess <- pickGuessCard
  return $ Guess target guess
  where pickGuessCard = chooseItem' "\nWhat card do they have?" 2 [Clown ..]