Screen.hs

-- | Console handling code
-- (c) JP Moresmau 2009
module MoresmauJP.Core.Screen where


import Control.Monad.State
import Control.Monad.Writer
import Char
import Data.List
import Data.Maybe

import MoresmauJP.Util.Random

-- | a Screen represent a certain UI state, with possible actions
data Screen a = Screen {
	actions::[Action a] -- ^ possible action in that screen
	}

-- | Action doable in the ui
data Action a = Action {
	actionName::String -- ^ the name of the action (what to type)
	, actionDescription::String -- ^ the description (showed when using help)
	, actionFunction::(ActionFunction a) -- ^ the function to call
	}

-- | a Monad transformer, wrapping state (a), IO and Random
type ScreenT a b= (RandT (StateT a IO)) b 

-- | Screen Message to display
type ScreenMessage = String

-- | Screen Messages
type ScreenMessages = [ScreenMessage]

-- | add a ScreenMessage to the current messages
addScreenMessage :: (MonadWriter ScreenMessages m,Monad m)=> ScreenMessage -> m ()
addScreenMessage msg=tell [msg]
	
-- | A Monad Transformer, ScreenT with GameState and returning Widgets
type GSWScreenT a= ScreenT (GameState a) (Widget a)

-- | The real Monad Transformer used: allows to write messages, get random number, stores
-- a state of a GameState containing a, returning Widgets
type WScreenT a=WriterT ScreenMessages (RandT (StateT (GameState a) IO)) (Widget a)

instance (Monad m) =>  MonadRandom (WriterT ScreenMessages (RandT m)) where
	getRandomRange =lift . getRandomRange
	getSplit = lift getSplit


-- | An Action function get its arguments typed in the GUI and works in a WScreenT
type ActionFunction a = [String] -> WScreenT a

-- | GameState: the data (a) and the current screen
data GameState a = GameState {gsData::a -- ^ the data
	, screen::Maybe (Screen a) -- ^ the current screen
	}

-- | Widgets are the actual ui component returned by an action
data Widget a= 
	-- | simple line of text
	WText {
		wtext::String -- ^ line of text
		}
	-- | list of items
	| WList {witems :: [String] -- ^ lines of text
		} 
	-- | ask for the user to type in a string
	| WInput {
		witems :: [String] -- ^ lines of text
		, wact::(String -> WScreenT a) -- ^ handler action
		}
	-- | choose an item from a list
	| WCombo {
		witems :: [String] -- ^ lines of text
		,wlist :: [String] -- ^ list items
		,wact :: (String -> WScreenT a) -- ^ handler action
		}
	-- | asks a yes/no question 
	| WCheck {
		witems :: [String]  -- ^ lines of text
		,wquestion :: String -- ^ question 
		,wdefault :: Bool -- ^ default answer 
		,wbact :: (Bool -> WScreenT a) -- ^ handler action
		}
	-- | placeholder for no action 
	| WNothing

-- | a widget and a gamestate
type ScreenState a = (Widget a,GameState a)

-- | get a Combo widget that uses the show method of the objects passed to automatically build the list
getShowCombo :: Show b => [String] -- ^ lines of text
	-> [b] -- ^ objects to display in list 
	->  ((ComboResult b) -> WScreenT a) -- ^ handler action (gets the selected object as parameter
	-> Widget a -- ^ the resulting widget
getShowCombo= getMappedCombo show

-- | get a Combo widget that uses an arbitrary method of the objects passed to automatically build the list
getMappedCombo :: (b->String) -- ^ the method to use to translate the object in a string from the menu
	-> [String] -- ^ lines of text
	-> [b] -- ^ objects to display in list 
	->  ((ComboResult b) -> WScreenT a) -- ^ handler action (gets the selected object as parameter
	-> Widget a -- ^ the resulting widget
getMappedCombo myShow s objs af=
	let 
		objWithNames=map (\x->(x,myShow x)) objs
		af2=(\s2 -> do 
			if null s2
				then
					af Empty
				else
					do
					let objChosen=listToMaybe (map fst (filter (\x->(snd x) == s2) objWithNames))
					case objChosen of
						Just oc->af (Exact oc)
						Nothing->af (Unknown s2)
						)
	in (WCombo s (map snd objWithNames) af2)
		
-- | checks if the rest of the command line is already an option from the menu
getPretypedWidget :: Widget a -- ^ the original widget
	-> [String] -- ^ the rest of the parameters typed by the user
	-> WScreenT a -- ^ the result
getPretypedWidget wc@(WCombo _ choices af) (typed:_) = do
	-- see if the next parameter is a number corresponding to one of the items in the list
	let chosen=filter (\(x,_)->x==typed) (zipWith (\a b -> ((show a),b)) [1..] choices)
	if (null chosen)
		then return wc
		-- we have a match, run the action
		else af (snd $ head chosen)
getPretypedWidget w _=return w
		
removeWithName :: [Action a] -> [Action b] -> [Action a]
removeWithName aa ab=
	let names=(map actionName aa) \\ (map actionName ab)
	in filter (\a -> elem (actionName a) names) aa

-- | result from a user action
data ComboResult a= Empty -- ^ no result, nothing chosen
	 | Unknown String -- ^ unknown result (typed something not in a list)
	 | Exact a -- ^ proper choice
	deriving (Show,Read)
	
-- | start a UI loop
start :: ScreenState a -- ^ initial state
	-> IO(a) -- ^ result
start (w,gs)=do
	GameState s2 _ <- ioRandT (commandLoop2 w) gs
	return s2
	
-- | internal UI loop
commandLoop2 :: Widget a -- ^ current widget to render 
	-> GSWScreenT a -- ^ screen monad we run in
commandLoop2 w = do
	af<- liftIO $ renderWidget w
	scr <- gets screen
	if (isJust scr)
		then
			if isJust af
				then
					do
						(w2,msgs) <-runWriterT $ fromJust af
						when (not $ null msgs) (liftIO $ (mapM_ putStrLn msgs))	
						commandLoop2 w2
				else		
					do
						liftIO $ putStr ">"
						input <- liftIO $ getLine
						let cmds = words input
						if null cmds
							then
								commandLoop2 WNothing
							else
								do
									let (cmd:_)=cmds
									let af2 = getAction (map Char.toLower cmd) (actions $ fromJust scr)
									(w2,msgs)<-runWriterT (af2 cmds)
									when (not $ null msgs) (liftIO $ (mapM_ putStrLn msgs))	
									commandLoop2 w2
		else
			return WNothing

-- | render a widget onto the console
renderWidget :: Widget a -- ^ the widget to render	
	-> IO(Maybe(WScreenT a)) -- ^ the result (may be empty)
renderWidget (WNothing)= do
	return Nothing
renderWidget (WText s)= do
	putStrLn s
	return Nothing
renderWidget (WList ss)=do
	mapM_ putStrLn ss
	return Nothing
renderWidget (WInput ss1 af)=do
	mapM_ putStrLn ss1
	input <- getLine
	return (Just $ af input)
renderWidget (WCheck ss1 s def af)=do
	mapM_ putStrLn ss1
	let choices=if def then " (Y/n)" else " (y/N)"
	putStrLn (s ++choices)
	cmds <- getArgs
	let ch=if null cmds
		then def
		else (map toUpper (head cmds))=="Y"
	return (Just (af ch))
renderWidget (WCombo ss1 ss2 af)=do
	mapM_ putStrLn ss1
	let choices=zipWith (\a b -> ((show a),b)) [1..] ss2
	mapM_ putStrLn (map (\(a,b) -> a ++ ": "++b) choices)
	cmds <- getArgs
	let chosen=if null cmds
		then [("","")]
		else filter (\(x,_)->x==(head cmds)) choices
	if null chosen
		then return (Just $ af "")
		else return (Just $ af (snd $ head chosen))
			
-- | get arguments typed in at the command line	
getArgs :: IO([String])	-- ^ the resulting arguments			
getArgs = do
	input <- getLine
	return (words input)

-- | show help with available commands			
help :: Bool -- ^ display help on system commands too? 
	-> ActionFunction a -- ^ the handler function 
help withSystem _ = do
	let	f (Action s1 s2 _)= (s1++": "++s2)
	let	sysLines= if withSystem
			then (map f systemActions)
			else []
	gs <- get
	let acts=actions $ fromJust $ screen gs
	let wl=WList (sort ( sysLines ++
			(map f acts)))
	return (wl) 

-- | default handler for unknown actions
unknown :: ActionFunction a
unknown args = return (WText ("I do not understand the command " ++ (head args)))

-- | quit the game action
quit :: ActionFunction a
quit _ = do
	modify (\gs->gs{screen=Nothing})
	return (WText ("Bye bye, hope you enjoyed the game!")) 

-- | when several actions could fit what the user typed, display the list of full names
choice :: [String] -- ^ possible actions
	-> ActionFunction a -- ^ resulting handler
choice ss _ = return (WList ss)

-- | back action
backAction :: Screen a -- ^ Screen to go back to 
	-> Action a -- ^ resulting action
backAction sc=Action "back" "Go back to main screen" (back sc)

-- | back handler
back :: Screen a -- ^ Screen to go back to 
	-> ActionFunction a -- ^ result
back sc _ =do
	(GameState a _) <- get
	put (GameState a (Just sc))
	return (WText "Back")

-- | default system actions
systemActions :: [Action a]
systemActions = [Action "help" "Provides help on available actions" (help True)
	,Action "?" "Provides help on available actions" (help True)
	,Action "quit" "Exit the game" quit]
				
-- | get action from what the user typed and the possible actions
getAction :: String -- ^ the first word the user typed 
	-> [Action a] -- ^ the possible actions 
	-> ActionFunction a -- ^ the chosen action handler
getAction "help" _ = help True
getAction cmd acts =
	let	
		filt=(filter (\x->isPrefixOf cmd (map Char.toLower (actionName x))))
		possible=(filt systemActions) ++ (filt acts)
		l = length possible
	in
		if l==0 then
			unknown
		else if l==1 then
			actionFunction $ head possible
		else 
			choice (map (\(Action s1 _ _)->s1) possible)

-- | combine a widget with maybe another
combineMaybeWidget :: Widget a -- ^ initial widget 
	-> Maybe (Widget a) -- ^ next widget 
	-> Widget a -- ^ resulting widget
combineMaybeWidget w Nothing = w
combineMaybeWidget w1 (Just w2) =combineWidget w1 w2
	
-- | combine a widget with another	
combineWidget :: Widget a -- ^ initial widget 
	-> Widget a -- ^ next widget 
	-> Widget a -- ^ resulting widget
combineWidget WNothing a=a
combineWidget a WNothing=a
combineWidget (WText s1) (WText s2)=WList [s1,s2]
combineWidget (WText s1) (WList ss2)=WList (s1:ss2)
combineWidget (WText s1) (WInput ss1 ss2)=WInput (s1:ss1) ss2
combineWidget (WText s1) (WCheck ss1 ss2 ss3 ss4)=WCheck (s1:ss1) ss2 ss3 ss4
combineWidget (WText s1) (WCombo ss1 ss2 af)=WCombo (s1:ss1) ss2 af
combineWidget (WList ss1) (WText s2)=WList (ss1++[s2])
combineWidget (WList ss1) (WList ss2)=WList (ss1++ss2)
combineWidget (WList ss1) (WInput ss2 ss3)=WInput (ss1++ss2) ss3
combineWidget (WList s1) (WCheck ss1 ss2 ss3 ss4)=WCheck (s1++ss1) ss2 ss3 ss4
combineWidget (WList s1) (WCombo ss1 ss2 af)=WCombo (s1++ss1) ss2 af
combineWidget _ _=error "combineWidget: undefined combination"