waterdeep/src/ConsoleUI.hs

#! /usr/bin/runhaskell
{-# LANGUAGE GADTs           #-}
{-# LANGUAGE RankNTypes      #-}
{-# LANGUAGE TemplateHaskell #-}

module Main (main) where

import Control.Applicative
import Control.Monad
import Control.Monad.Prompt
import Control.Monad.Random
import Control.Monad.State
import Data.IORef
import Data.List
import Data.Monoid
import Data.Traversable (traverse)
import Lens.Family2
import Lens.Family2.Stock
import Lens.Family2.State
import Lens.Family2.TH
import System.IO
import System.Random
import System.Random.Shuffle
import Text.Printf
import Waterdeep.Actions
import Waterdeep.Buildings
import Waterdeep.Logic
import Waterdeep.Quests
import Waterdeep.Types
import Waterdeep.Util

import qualified Data.IntMap   as IM
import qualified Data.Map      as M
import qualified Data.MultiSet as MS

data DisplayState =
   DisplayState
      { _gameState    :: WaterdeepState
      , _gameMessages :: [String]
      }
makeLenses ''DisplayState

f1 = Faction "Jesters" Blue
l1 = Lord "Prince Henry XXX" "" (QuestBonus [Skullduggery, Commerce] 4)
p1 = ("Harry", f1, l1)

f2 = Faction "Pilots" Green
l2 = Lord "Princess Anastasia" "" (QuestBonus [Arcana, Warfare] 4)
p2 = ("Ned", f2, l2)

i1 = IntrigueCard { _intrigueTitle  = "Graduation Day"
                  , _intrigueType   = Utility
                  , _intrigueAction = do
                        takeResources 2 [Wizard]
                        forOneOpponent (takeResources 1 [Wizard])
                  , _intrigueQuote  = ""
                  }

i2 = IntrigueCard { _intrigueTitle  = "Call for Adventurers"
                  , _intrigueType   = Utility
                  , _intrigueAction = do
                        takeResources 2 [Cleric, Fighter, Rogue, Wizard]
                        forOneOpponent (takeResources 1 [Cleric, Fighter, Rogue, Wizard])
                  , _intrigueQuote  = ""
                  }

clearScreen :: IO ()
clearScreen = putStr "\o033[H\o033[2J" >> hFlush stdout

showTavern :: MS.MultiSet Resource -> String
showTavern = intercalate ", " . map showResource . MS.toAscOccurList
   where showResource (r, n) = show n ++ " " ++ show r

printWaterdeep :: WaterdeepState -> IO ()
printWaterdeep w = do
   let playerStates = map snd $ IM.toAscList $ w ^. gamePlayerStates
   clearScreen
   putStrLn ("Players: " ++ intercalate ", " (map (^. playerName) playerStates))
   putStrLn ("First Player: " ++
      (w ^. gamePlayerState (w ^. gameFirstPlayer) . playerName))
   putStrLn ("Current Round: " ++ show (w ^. gameCurrentRound))
   let p = w ^. gameCurrentPlayer
   when (p /= noPlayerID) $
      putStrLn ("Current Player: " ++ (w ^. gamePlayerState p . playerName))
   putStrLn ""
   putStrLn "Cliffwatch Inn:"
   forM_ (w ^. gameCliffwatchInn) $ \q -> do
      putStrLn ("  " ++ (q ^. questTitle))
   putStrLn ""
   putStrLn "Builder's Hall:"
   forM_ (w ^.. gameBuildersHall . traverse) $ \b -> do
      printf "  %s (%d gold -> %d points)\n"
             (b ^. building . buildingTitle)
             (b ^. building . buildingCost)
             (b ^. buildingAccumulation)
   putStrLn ""
   forM_ playerStates $ \p -> do
      printf "%s's State (%s):\n" (p ^. playerName)
         (show (p ^.  playerFaction . factionColor))
      putStrLn ("  Score:      " ++ show (p ^.  playerScore))
      putStrLn ("  Tavern:     " ++ (p ^.  playerTavern  . to showTavern))
      putStrLn ("  Incomplete: " ++ showItems (p ^.. playerIncompleteQuests . traverse . questTitle))
      putStrLn ("  Complete:   " ++ showItems (p ^.. playerCompletedQuests  . traverse . questTitle))
      putStrLn ("  Intrigues:  " ++ showItems (p ^.. playerIntrigueCards    . traverse . intrigueTitle))
      putStrLn ("  Agent Pool: " ++ show (p ^.  playerAgentsInPool))
      putStrLn ""

showItems :: [String] -> String
showItems ss = intercalate ", " groups
   where
      groups = map withCount $ group $ sort ss
      withCount [x] = x
      withCount xs@(x:_) = x ++ " (x" ++ show (length xs) ++ ")"

drawState :: IORef DisplayState -> IO ()
drawState ref = do
   ds <- readIORef ref
   printWaterdeep (ds ^. gameState)
   forM_ (ds ^. gameMessages) putStrLn 
   unless (null (ds ^. gameMessages)) $ putStrLn ""

menuPrompt :: IORef DisplayState -> IO () -> WaterdeepPrompt a -> IO a
menuPrompt ref redraw (NotifyState w) = do
   modifyIORef ref (gameState .~ w)
   redraw
menuPrompt ref redraw (Broadcast s)   = do
   modifyIORef ref (gameMessages %~ ((s:) . take 4))
   redraw
menuPrompt ref redraw prm@(SolicitChoice p t cs) = do
   let menuSize = length cs
   let blankLine = putStrLn ""
   w <- view gameState <$> readIORef ref

   fix $ \doMenu -> do
      putStrLn t
      printMenu $ zipWith (\i c -> show i ++ ") " ++ fst c) [1..] cs

      putStr (w ^. gamePlayerState p . playerName)
      putStr "> " >> hFlush stdout
      response <- getLine
      --response <- show <$> getRandomR (1, menuSize)

      case reads response of
         (ix,""):_ | ix >= 1 && ix <= menuSize ->
            blankLine >> return (snd $ cs !! (ix-1))
         _ -> do
            redraw
            putStrLn ("ERROR: Expected a number between 1 and " ++ show menuSize ++ ".")
            blankLine
            doMenu

printMenu :: [String] -> IO ()
printMenu cs = do
   let n   = length cs
   let h   = (n `div` 3) `max` 5
   let cw  = (maximum $ map length cs)
   let cs' = map (take cw . (++ (repeat ' '))) cs
   let (c1, cs'') = splitAt h cs'
   let (c2, c3)   = splitAt h cs''
   let rows = zipWith3 (\a b c -> a ++ "  " ++ b ++ "  " ++ c)
                       c1 (c2 ++ repeat "") (c3 ++ repeat "")
   mapM_ putStrLn rows

main :: IO ()
main = do
   w0  <- newGame [p1, p2] defaultQuestDeck (mrepeat 4 [i1, i2]) defaultBuildingDeck <$> getSplit
   ref <- newIORef (DisplayState { _gameState = w0, _gameMessages = [] })
   runWaterdeepM (menuPrompt ref (drawState ref)) waterdeepGame w0
   return ()