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

data Screen a = Screen {actions::[Action a]}

data Action a = Action {
	actionName::String,
	actionDescription::String,
	actionFunction::(ActionFunction a)
	}

type ScreenT a b= (RandT (StateT a IO)) b 


type ScreenMessage = String
type ScreenMessages = [ScreenMessage]

addScreenMessage :: (MonadWriter ScreenMessages m,Monad m)=> ScreenMessage -> m ()
addScreenMessage msg=tell [msg]
	

type GSWScreenT a= ScreenT (GameState a) (Widget a)
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


	
type ActionFunction a = [String] -> WScreenT a

data GameState a = GameState {gsData::a,
	screen::Maybe (Screen a)
	}

data Widget a= WText String |
	WList [String] |
	WInput [String] (String -> WScreenT a) |
	WCombo [String] [String] (String -> WScreenT a) |
	WCheck [String] String Bool (Bool -> WScreenT a) |
	WNothing

type ScreenState a = (Widget a,GameState a)

getShowCombo :: Show b => [String] -> [b] ->  ((ComboResult b) -> WScreenT a) -> Widget a
getShowCombo= getMappedCombo show

getMappedCombo :: (b->String) -> [String] -> [b] ->  ((ComboResult b) -> WScreenT a) -> Widget a
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)
		
getPretypedWidget :: Widget a -> [String] -> WScreenT a
getPretypedWidget wc@(WCombo _ choices af) (typed:_) = do
	let chosen=filter (\(x,_)->x==typed) (zipWith (\a b -> ((show a),b)) [1..] choices)
	if (null chosen)
		then return wc
		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

data ComboResult a= Empty | Unknown String | Exact a
	deriving (Show,Read)
	
start :: ScreenState a -> IO(a)
start gs = 
	do
		commandLoop gs
		
commandLoop :: ScreenState a -> IO(a)
commandLoop (w,gs)=do
	GameState s2 _ <- ioRandT (commandLoop2 w) gs
	--sg<-getStdGen
	--GameState s2 _ <- execStateT (evalRandT (runWriterT $ commandLoop2 w) (ProductionRandom sg)) gs
	
	return s2
	
commandLoop2 :: Widget a -> GSWScreenT a
commandLoop2 w = do
	--msgs <- lift $ getMessages
	--listen
	--when (not $ null msgs) (liftIO $ (mapM_ putStrLn (reverse msgs)))								
	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 (reverse 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


renderWidget :: Widget a -> IO(Maybe(WScreenT a))
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))
				
getArgs :: IO([String])				
getArgs = do
	input <- getLine
	return (words input)

			
help :: Bool -> ActionFunction a
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)))
	tell ["help1"]
	tell ["help2"]
	return (wl) 

unknown ::ActionFunction a
unknown args = return (WText ("I do not understand the command " ++ (head args)))

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

choice :: [String] -> ActionFunction a
choice ss _ = return (WList ss)

backAction :: Screen a -> Action a
backAction sc=Action "back" "Go back to main screen" (back sc)

back :: Screen a -> ActionFunction a
back sc _ =do
	(GameState a _) <- get
	put (GameState a (Just sc))
	return (WText "Back")

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]
				
getAction :: String -> [Action a] -> ActionFunction a
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)
	
{--
combineActionAfterIO :: ScreenState a -> ActionFunction a -> Event -> IO (ScreenState a)
combineActionAfterIO ss1@(w1,gs) af e = do
	(w2,gs2)<-af e gs 
	return (combineWidget w1 w2,gs2)

combineActionBeforeIO :: ScreenState a -> ActionFunction a -> Event -> IO (ScreenState a)
combineActionBeforeIO ss1@(w1,gs) af e = do
	(w2,gs2)<-af e gs 
	return (combineWidget w2 w1,gs2)
--}	
{--combineActionAfter :: Widget a -> [String] -> ActionFunction a
combineActionAfter w1 cmds= do 
	w2<-af cmds
	return (combineWidget w1 w2)
	--}
	
{--
combineActionBefore :: ScreenState a -> PureActionFunction a ->  [String] -> ScreenState a
combineActionBefore ss1@(w1,gs) af e =
	let (w2,gs2)=af e gs 
	in (combineWidget w2 w1,gs2)
	--}

combineMaybeWidget :: Widget a -> Maybe (Widget a) -> Widget a
combineMaybeWidget w Nothing = w
combineMaybeWidget w1 (Just w2) =combineWidget w1 w2
	
combineWidget :: Widget a -> Widget a -> Widget a
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"