-- Copyright (c) 2014-2015 Jonathan M. Lange -- -- 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 (PlayerSet, getDiscards, isProtected, 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 ..]