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.Factions
import Waterdeep.Intrigues
import Waterdeep.Logic
import Waterdeep.Lords
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

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
   printf "Round %d; First Player: %s; Current Player: %s\n"
      (w ^. gameCurrentRound)
      (w ^. gamePlayerState (w ^. gameFirstPlayer)   . playerName)
      (w ^. gamePlayerState (w ^. gameCurrentPlayer) . 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; %d points; %d agents):\n" (p ^. playerName)
         (show (p ^.  playerFaction . factionColor))
         (p ^.  playerScore)
         (p ^.  playerAgentsInPool)
      putStrLn ("  Tavern:      " ++ (p ^.  playerTavern  . to showTavern))
      putStrLn ("  Incomplete:  " ++ showItems (p ^.. playerIncompleteQuests . traverse . questTitle))
      putStrLn ("  Complete:    " ++ showItems (p ^.. playerCompletedQuests  . traverse . questTitle))
      putStrLn ("  Plot Quests: " ++ showItems (p ^.. playerPlotQuests       . traverse . questTitle))
      putStrLn ("  Intrigues:   " ++ showItems (p ^.. playerIntrigueCards    . traverse . intrigueTitle))
      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)
   mapM_ putStrLn $ take 4 $ ds ^. gameMessages
   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:))
   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
   players <- zip3 <$> pure ["Ludd", "Nudd"]
                   <*> shuffleM defaultFactions
                   <*> shuffleM defaultLords
   rndgen <- getSplit
   let w0 = newGame players defaultQuestDeck defaultIntrigueDeck defaultBuildingDeck rndgen
   ref <- newIORef (DisplayState { _gameState = w0, _gameMessages = [] })
   runWaterdeepM (menuPrompt ref (drawState ref)) waterdeepGame w0
   putStrLn "--- GAME LOG ---"
   mapM_ putStrLn . reverse . view gameMessages =<< readIORef ref
   return ()