-- 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 (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 ..]