intricacy-0.3.8: Interact.hs

-- This file is part of Intricacy
-- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see http://www.gnu.org/licenses/.

module Interact (interactUI) where 

import Control.Monad.State
import Control.Applicative
import qualified Data.Vector as Vector
import qualified Data.Map as Map
import Data.Map (Map)
import Control.Monad.Writer
import Control.Monad.Trans.Error
import Control.Monad.Trans.Maybe
import Data.Maybe
import Data.Char
import Data.List
import Control.Concurrent.STM
import Control.Concurrent
import System.Directory
import System.FilePath
import Data.Array
import Data.Function (on)

import Hex
import Command
import Physics
import Mundanities
import AsciiLock
import GameState
import GameStateTypes
import EditGameState
import Frame
import Lock
import Cache
import Database
import Protocol
import Metagame
import ServerAddr
import MainState
import InputMode
import Maxlocksize
import InteractUtil

interactUI :: UIMonad uiM => StateT MainState uiM InteractSuccess
interactUI = do
    lift $ drawMessage ""
    (IMMeta==) . ms2im <$> get >>= flip when (void $ do
	flag <- gets newAsync
	unblock <- lift unblockInput
	_ <- liftIO $ forkIO $ forever $ do
	    atomically $ readTVar flag >>= check >> writeTVar flag False
	    unblock

	-- draw before testing auth, lest a timeout mean a blank screen
	drawMainState

	testAuth
	refreshUInfoUI
	tbdg <- lift $ getUIBinding IMMeta CmdTutorials
	(isNothing <$> gets curAuth >>=) $ flip when $
	    lift $ drawMessage $ "Welcome. To play the tutorial levels, press '"++tbdg++"'."
	)
    setMark startMark
    loop

    where
	loop = do
	    mainSt <- get
	    let im = ms2im mainSt
	    when (im == IMPlay) checkWon
	    when (im == IMMeta) $ (checkAsyncErrors >>) $ void.runMaybeT $ 
		mourNameSelected >>=
		    flip when (lift purgeInvalidUndecls)
	    drawMainState
	    cmds <- lift $ getSomeInput im
	    runErrorT (mapM_ (processCommand im) cmds) >>= \x -> case x of
		Left ret -> do
		    lift $ drawMessage ""
		    return ret
		Right _ -> loop

-- | TODO: neater would be to use a stream (see package 'pipes') for
-- input?
getSomeInput im = do
    cmds <- getInput im
    if null cmds then getSomeInput im else return cmds

newtype InteractSuccess = InteractSuccess Bool
instance Error InteractSuccess where
    noMsg = InteractSuccess False

processCommand :: UIMonad uiM => InputMode -> Command -> ErrorT InteractSuccess (StateT MainState uiM) ()
processCommand im CmdQuit = do
    case im of
	IMReplay -> throwError $ InteractSuccess False
	IMPlay -> lift (gets psIsSub) >>= flip when (throwError $ InteractSuccess False)
	IMEdit -> lift editStateUnsaved >>= flip unless (throwError $ InteractSuccess True)
	_ -> return ()
    title <- lift $ getTitle
    really <- lift $ lift $ confirm $ "Really quit" ++ maybe "" (" from "++) title ++ "?"
    when really $ throwError $ InteractSuccess False
processCommand im CmdForceQuit = throwError $ InteractSuccess False
processCommand IMPlay CmdOpen = do
    st <- gets psCurrentState
    frame <- gets psFrame
    if checkSolved (frame,st) then throwError $ InteractSuccess True else lift.lift $ drawError "Locked!"
processCommand im cmd = lift $ processCommand' im cmd

processCommand' :: UIMonad uiM => InputMode -> Command -> StateT MainState uiM ()
processCommand' im CmdHelp = lift $ do
    showHelp im
    void $ textInput "[press a key or RMB]" 1 False True Nothing Nothing
processCommand' im CmdBind = lift $ flip (>>) (drawMessage "") $ void $ runMaybeT $ do
	lift $ drawMessage "Command to bind: "
	cmd <- msum $ repeat $ do
	    cmd <- MaybeT $ listToMaybe <$> getInput im
	    guard $ not.null $ describeCommand cmd
	    return cmd
	lift $ drawMessage ("key to bind to \"" ++ describeCommand cmd ++ "\" (repeat binding to delete): ")
	ch <- MaybeT getChRaw
	guard $ ch /= '\ESC'
	lift $ setUIBinding im cmd ch

processCommand' _ CmdSuspend = lift $ suspend
processCommand' _ CmdRedraw = lift $ redraw
processCommand' im CmdMark = void.runMaybeT $ do
    guard $ im `elem` [IMEdit, IMPlay, IMReplay]
    str <- MaybeT $ lift $ textInput "Mark: " 1 False True Nothing Nothing
    ch <- MaybeT $ return $ listToMaybe str
    guard $ ch `notElem` [startMark, '\'']
    lift $ setMark ch
processCommand' im CmdJumpMark = void.runMaybeT $ do
    guard $ im `elem` [IMEdit, IMPlay, IMReplay]
    str <- MaybeT $ lift $ textInput
	"Jump to mark (\"'\" to unjump): " 1 False True Nothing Nothing
    ch <- MaybeT $ return $ listToMaybe str
    lift $ jumpMark ch
processCommand' im CmdReset = jumpMark startMark
processCommand' IMMeta (CmdSelCodename mname) = void.runMaybeT $ do
    name <- msum [ MaybeT $ return $ mname
	, do
	    newCodename <- (map toUpper <$>) $ MaybeT $ lift $ textInput "Codename:" 3 False True Nothing Nothing
	    guard $ length newCodename == 3
	    return newCodename
	]
    guard $ validCodeName name
    lift $ do
	modify $ \ms -> ms { codenameStack = (name:codenameStack ms) }
	invalidateUInfo name
	refreshUInfoUI
processCommand' IMMeta CmdHome = void.runMaybeT $ do
    ourName <- mgetOurName
    lift $ do
	modify $ \ms -> ms { codenameStack = (ourName:codenameStack ms) }
	refreshUInfoUI
processCommand' IMMeta CmdBackCodename = do
    stack <- gets codenameStack
    when (length stack > 1) $ do
	modify $ \ms -> ms { codenameStack = tail stack }
	refreshUInfoUI
processCommand' IMMeta CmdSetServer = void.runMaybeT $ do
    saddr <- gets curServer
    saddrs <- liftIO $ knownServers
    newSaddrstr <- MaybeT $ lift $ textInput "Set server:" 256 False False
	    (Just $ map saddrStr saddrs) (Just $ saddrStr saddr)
    newSaddr <- MaybeT $ return $ strToSaddr newSaddrstr
    modify $ \ms -> ms { curServer = newSaddr }
    unless (nullSaddr newSaddr) $
	msum [ void $ MaybeT $ getFreshRecBlocking RecServerInfo
	, modify $ \ms -> ms { curServer = saddr }
	]
processCommand' IMMeta CmdToggleCacheOnly =
    not <$> gets cacheOnly >>= \c -> modify $ \ms -> ms {cacheOnly = c}

processCommand' IMMeta CmdRegister = void.runMaybeT $ do
    newName <- mgetCurName
    mauth <- gets curAuth
    let isUs = maybe False ((==newName).authUser) mauth
    confirmOrBail $ if isUs then "Really reset password?" else "Register codename "++newName++"?"
    passwd <- (hashPassword newName <$>) $ MaybeT $ lift $
	textInput "Enter new password:" 64 True False Nothing Nothing
    lift $ if isUs then do
	    resp <- curServerAction $ ResetPassword passwd
	    case resp of
		ServerAck -> do
		    lift $ drawMessage "New password set."
		    modify $ \ms -> ms {curAuth = Just $ Auth newName passwd}
		ServerError err -> lift $ drawError err
		_ -> lift $ drawMessage $ "Bad server response: " ++ show resp
	else do
	    modify $ \ms -> ms {curAuth = Just $ Auth newName passwd}
	    resp <- curServerAction Register
	    case resp of
		ServerAck -> do
		    invalidateUInfo newName
		    refreshUInfoUI
		    lift $ drawMessage "Registered!"
		ServerError err -> do
		    lift $ drawError err
		    modify $ \ms -> ms {curAuth = Nothing}
		_ -> lift $ drawMessage $ "Bad server response: " ++ show resp
processCommand' IMMeta CmdAuth = void.runMaybeT $ do
    auth <- lift $ gets curAuth
    if isJust auth then do
	confirmOrBail "Log out?"
	modify $ \ms -> ms {curAuth = Nothing}
    else do
	name <- mgetCurName
	passwd <- (hashPassword name <$>) $ MaybeT $ lift $
	    textInput ("Enter password for "++name++":") 64 True False Nothing Nothing
	lift $ do
	    modify $ \ms -> ms {curAuth = Just $ Auth name passwd}
	    resp <- curServerAction $ Authenticate
	    case resp of
		ServerAck -> (lift $ drawMessage "Authenticated.")
		ServerMessage msg -> (lift $ drawMessage $ "Server: " ++ msg)
		ServerError err -> do
		    lift $ drawError err
		    modify $ \ms -> ms {curAuth = auth}
		_ -> lift $ drawMessage $ "Bad server response: " ++ show resp
processCommand' IMMeta (CmdSolve midx) = void.runMaybeT $ do
    name <- mgetCurName
    uinfo <- mgetUInfo name
    idx <- msum [ MaybeT $ return midx
	, askLockIndex "Solve which lock?" "No lock to solve!" (\i -> isJust $ userLocks uinfo ! i) ]
    ls <- MaybeT $ return $ lockSpec <$> userLocks uinfo ! idx
    undecls <- lift (gets undeclareds)
    msum [ do
	    undecl <- MaybeT $ return $ find (\(Undeclared _ ls' _) -> ls == ls') undecls
	    _ <- MaybeT $ gets curAuth
	    confirmOrBail "Declare existing solution?"
	    void.lift.runMaybeT $ -- ignores MaybeT failures
		declare undecl
	, do
	    RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls
	    soln <- solveLock lock $ Just $
		"solving " ++ name ++ ":" ++ [lockIndexChar idx] ++ "  (#" ++ show ls ++")"
	    mourName <- lift $ (authUser <$>) <$> gets curAuth
	    guard $ mourName /= Just name
	    let undecl = Undeclared soln ls (ActiveLock name idx) 
	    msum [ do
		    _ <- MaybeT $ gets curAuth
		    confirmOrBail "Declare solution?"
		    declare undecl
		, unless (any (\(Undeclared _ ls' _) -> ls == ls') undecls) $
		    modify $ \ms -> ms { undeclareds = (undecl : undeclareds ms) }
		]
	]
processCommand' IMMeta (CmdPlayLockSpec mls) = void.runMaybeT $ do
    ls <- msum [ MaybeT $ return mls
	, do 
	    tls <- MaybeT . lift $ textInput "Lock number:" 16 False False Nothing Nothing
	    MaybeT . return $ fst <$> (listToMaybe $ (reads :: ReadS Int) tls)
	]
    RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls
    solveLock lock $ Just $ "solving " ++ show ls
    
processCommand' IMMeta (CmdDeclare mundecl) = void.runMaybeT $ do
    mourNameSelected >>= guard
    name <- mgetCurName
    undecls <- lift $ gets undeclareds
    guard $ not $ null undecls
    declare =<< msum [ MaybeT $ return mundecl
	, if length undecls == 1
	then return $ head undecls
	else do
	    which <- MaybeT $ lift $ textInput
		("Declare which solution?")
		5 False True Nothing Nothing
	    MaybeT $ return $ msum
		[ do
		    i <- fst <$> (listToMaybe $ (reads :: ReadS Int) which)
		    guard $ 0 < i && i <= length undecls
		    return $ undecls !! (i-1)
		, listToMaybe $ [ undecl
		    | undecl@(Undeclared _ _ (ActiveLock name' i)) <- undecls
		    , or [ take (length which) (name' ++ ":" ++ [lockIndexChar i]) ==
			    map toUpper which 
			, name'==name && [lockIndexChar i] == which
			] ]
		]
	]
processCommand' IMMeta (CmdViewSolution mnote) = void.runMaybeT $ do
    note <- msum [ MaybeT $ return mnote, do
	ourName <- mgetOurName
	name <- mgetCurName
	uinfo <- mgetUInfo name
	noteses <- lift $ sequence
	    [ case mlockinfo of
		Nothing -> return []
		Just lockinfo -> (++lockSolutions lockinfo) <$> do
			ns <- getNotesReadOn lockinfo 
			return $ if length ns < 3 then [] else ns
	    | mlockinfo <- elems $ userLocks uinfo ]
	idx <- askLockIndex "View solution to which lock?" "No solutions to view" $ not.null.(noteses!!)
	let notes = noteses!!idx
	    authors = map noteAuthor notes
	author <- if length notes == 1
	    then return $ noteAuthor $ head notes 
	    else (map toUpper <$>) $ MaybeT $ lift $
		textInput ("View solution by which player? ["
		    ++ intercalate "," (take 3 authors)
		    ++ if length authors > 3 then ",...]" else "]")
		3 False True (Just $ authors) Nothing
	MaybeT $ return $ find ((==author).noteAuthor) notes
	]
    let ActiveLock name idx = noteOn note
    uinfo <- mgetUInfo name
    ls <- lockSpec <$> MaybeT (return $ userLocks uinfo ! idx)
    RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls
    RCSolution soln <- MaybeT $ getFreshRecBlocking $ RecNote note
    lift.lift $ execStateT interactUI $ newReplayState (snd.reframe$lock) soln $ Just $
	"viewing solution by " ++ noteAuthor note ++ " to " ++ name ++ [':',lockIndexChar idx]

processCommand' IMMeta (CmdPlaceLock midx) = void.runMaybeT $ do
    mourNameSelected >>= guard
    ourName <- mgetOurName
    (lock,msoln) <- msum [MaybeT $ gets curLock
	, do
	    ebdg <- lift.lift $ getUIBinding IMMeta CmdEdit
	    lift.lift $ drawError $ "No lock selected; '"++ebdg++"' to edit one."
	    mzero]
    lockpath <- lift $ gets curLockPath
    ourUInfo <- mgetUInfo ourName
    idx <- msum [ MaybeT $ return midx
	, askLockIndex ("Place " ++ show lockpath ++ " in which slot?") "bug" $ const True
	]
    when (isJust $ userLocks ourUInfo ! idx) $
	confirmOrBail "Really retire existing lock?"
    soln <- msum [ MaybeT $ return msoln,
	solveLock lock $ Just $ "testing lock" ]
    lift $ do 
	curServerActionAsync $ SetLock lock idx soln
	invalidateUInfo ourName
	refreshUInfoUI

processCommand' IMMeta CmdSelectLock = void.runMaybeT $ do
    lockdir <- liftIO $ confFilePath "locks"
    paths <- liftIO $ map (drop (length lockdir + 1)) <$> getDirContentsRec lockdir
    path <- MaybeT $ lift $ textInput "Lock name:" 1024 False False (Just paths) Nothing
    lift $ setLockPath path
processCommand' IMMeta CmdNextLock =
    gets curLockPath >>= liftIO . nextLock True >>= setLockPath
processCommand' IMMeta CmdPrevLock =
    gets curLockPath >>= liftIO . nextLock False >>= setLockPath
processCommand' IMMeta CmdNextPage =
    modify $ \ms -> ms { listOffset = listOffset ms + 1 }
processCommand' IMMeta CmdPrevPage =
    modify $ \ms -> ms { listOffset = max 0 $ listOffset ms - 1 }
processCommand' IMMeta CmdEdit = void.runMaybeT $ do
    (lock, msoln) <- msum [ MaybeT $ gets curLock
	, do
	    frame <- BasicFrame <$> msum [ do
		    _ <- gets curServer
		    RCServerInfo (ServerInfo size _) <- MaybeT $ getFreshRecBlocking RecServerInfo
		    return size
		, do
		    sizet <- MaybeT $ lift $ textInput
			("Lock size: [3-" ++ show maxlocksize ++ "]") 2 False False Nothing Nothing
		    size <- MaybeT $ return $ fst <$> (listToMaybe $ (reads :: ReadS Int) sizet)
		    guard $ 3 <= size && size <= maxlocksize
		    return size
		]
	    return ((frame, baseState frame), Nothing)
	]
    path <- lift $ gets curLockPath
    newPath <- MaybeT $ lift $ (esPath <$>) $ execStateT interactUI $ newEditState (reframe lock)
	msoln (if null path then Nothing else Just path)
    lift $ setLockPath newPath
processCommand' IMMeta CmdTutorials = void.runMaybeT $ do
    tutdir <- liftIO $ getDataPath "tutorial"
    tuts <- liftIO $ (sort . map (takeWhile (/='.')) . filter (isSuffixOf ".lock")) <$>
	getDirectoryContents tutdir `catchIO` (const $ return [])
    when (null tuts) $ do
	lift.lift $ drawError "No tutorial levels found"
	mzero
    -- s <- MaybeT $ lift $ textInput ("Play which tutorial level? [1-"++show (length tuts)++"]")
	    -- (length (show (length tuts))) False True Nothing Nothing
    -- i <- MaybeT $ return $ fst <$> (listToMaybe $ (reads :: ReadS Int) s)
    -- guard $ 1 <= i && i <= length tuts
    let i = 1
    let dotut i = do
	let name = tuts !! (i-1)
	let pref = tutdir ++ [pathSeparator] ++ name
	(lock,_) <- MaybeT $ liftIO $ readLock (pref ++ ".lock")
	text <- liftIO $ (fromMaybe "" . listToMaybe) <$> (readStrings (pref ++ ".text") `catchIO` const (return []))
	_ <- solveLock lock $ Just $ "Tutorial " ++ show i ++ ": " ++ text
	if i+1 <= length tuts then do
		-- confirmOrBail $ "Tutorial level completed! Play next tutorial level (" ++ show (i+1) ++ ")?"
		dotut $ i+1
	    else lift $ do 
		mauth <- gets curAuth
		cbdg <- lift $ getUIBinding IMMeta $ CmdSelCodename Nothing
		rbdg <- lift $ getUIBinding IMMeta CmdRegister
		lift $ drawMessage $ if isNothing mauth
		    then "Tutorial completed! To play on the server, pick a codename ('"++cbdg++
			"') and register it ('"++rbdg++"')."
		    else "Tutorial completed!"
    dotut i
processCommand' IMMeta CmdShowRetired = void.runMaybeT $ do
    name <- mgetCurName
    newRL <- lift (gets retiredLocks) >>= \rl -> case rl of
	Nothing -> do
	    RCLockSpecs lss <- MaybeT $ getFreshRecBlocking $ RecRetiredLocks name
	    return $ Just lss
	Just _ -> return Nothing
    lift $ modify $ \ms -> ms {retiredLocks = newRL}
    
processCommand' IMPlay CmdUndo = do
    st <- gets psCurrentState
    stack <- gets psGameStateMoveStack
    ustms <- gets psUndoneStack
    unless (null stack) $ do
	let (st',pm) = head stack
	modify $ \ps -> ps {psCurrentState=st', psGameStateMoveStack = tail stack,
	    psLastAlerts = [], psUndoneStack = (st,pm):ustms}
processCommand' IMPlay CmdRedo = do
    ustms <- gets psUndoneStack
    case ustms of 
	[] -> return ()
	ustm:ustms' -> do
	    pushPState ustm
	    modify $ \ps -> ps {psUndoneStack = ustms'}
processCommand' IMPlay (CmdManipulateToolAt pos) = do
    board <- stateBoard <$> gets psCurrentState
    wsel <- gets wrenchSelected
    void.runMaybeT $ msum $ [ do
	    tile <- MaybeT $ return $ snd <$> Map.lookup pos board
	    guard $ case tile of {WrenchTile _ -> True; HookTile -> True; _ -> False}
	    lift $ processCommand' IMPlay $ CmdTile tile
	] ++ [ do
	    tile <- MaybeT $ return $ snd <$> Map.lookup (d<+>pos) board
	    guard $ tileType tile == if wsel then WrenchTile zero else HookTile
	    lift $ processCommand' IMPlay $ CmdDir WHSSelected $ neg d
	    | d <- hexDirs ]
processCommand' IMPlay (CmdDrag pos dir) = do
    board <- stateBoard <$> gets psCurrentState
    wsel <- gets wrenchSelected
    void.runMaybeT $ do
	tile <- MaybeT $ return $ snd <$> Map.lookup pos board
	guard $ case tile of {WrenchTile _ -> True; HookTile -> True; _ -> False}
	lift $ processCommand' IMPlay $ CmdDir WHSSelected $ dir
	board' <- stateBoard <$> gets psCurrentState
	msum [ do
		tile' <- MaybeT $ return $ snd <$> Map.lookup pos' board'
		guard $ tileType tile' == if wsel then WrenchTile zero else HookTile
		lift.lift $ warpPointer $ pos'
	    | pos' <- map (<+>pos) $ hexDisc 2 ]

processCommand' IMPlay cmd = do
    wsel <- gets wrenchSelected
    st <- gets psCurrentState
    let push whs dir 
	    | whs == WHSWrench || (whs == WHSSelected && wsel) =
		Just $ WrenchPush dir
	    | otherwise = Just $ HookPush dir
	torque whs dir 
	    | whs == WHSHook || (whs == WHSSelected && not wsel)=
		Just $ HookTorque dir
	    | otherwise = Nothing
	(wsel', pm) =
	    case cmd of
		CmdTile (WrenchTile _) -> (True, Nothing)
		CmdTile HookTile -> (False, Nothing)
		CmdTile (ArmTile _ _) -> (False, Nothing)
		CmdToggle -> (not wsel, Nothing)
		CmdDir whs dir -> (wsel, push whs dir)
		CmdRotate whs dir -> (wsel, torque whs dir)
		CmdWait -> (wsel, Just NullPM)
		CmdSelect -> (wsel, Just NullPM)
		_ -> (wsel, Nothing)
    modify $ \ps -> ps {wrenchSelected = wsel'}
    case pm of
	 Nothing -> return ()
	 Just pm' -> do
	    (st',alerts) <- lift $ doPhysicsTick pm' st
	    modify $ \ps -> ps {psLastAlerts = alerts}
	    pushPState (st',pm')

processCommand' IMReplay (CmdReplayBack 1) = void.runMaybeT $ do
    (st',pm) <- MaybeT $ listToMaybe <$> gets rsGameStateMoveStack
    lift $ modify $ \rs -> rs {rsCurrentState=st'
	, rsGameStateMoveStack = tail $ rsGameStateMoveStack rs
	, rsMoveStack = pm:rsMoveStack rs}
processCommand' IMReplay (CmdReplayBack n) = replicateM_ n $
    processCommand' IMReplay (CmdReplayBack 1)
processCommand' IMReplay (CmdReplayForward 1) = void.runMaybeT $ do
    pm <- MaybeT $ listToMaybe <$> gets rsMoveStack
    lift $ do
	st <- gets rsCurrentState
	(st',_) <- lift $ doPhysicsTick pm st
	modify $ \rs -> rs {rsCurrentState = st'
	    , rsGameStateMoveStack = (st,pm):rsGameStateMoveStack rs
	    , rsMoveStack = tail $ rsMoveStack rs}
processCommand' IMReplay (CmdReplayForward n) = replicateM_ n $
    processCommand' IMReplay (CmdReplayForward 1)
processCommand' IMReplay CmdUndo = processCommand' IMReplay (CmdReplayBack 1)
processCommand' IMReplay CmdRedo = processCommand' IMReplay (CmdReplayForward 1)

processCommand' IMEdit CmdPlay = do
    st <- gets $ head.esGameStateStack
    frame <- gets esFrame
    modify $ \es -> es {selectedPiece = Nothing}
    subPlay (frame,st)
processCommand' IMEdit CmdTest = do
    frame <- gets esFrame
    modifyEState (\st -> snd $ canonify (frame, st))
    modify $ \es -> es {selectedPiece = Nothing}
    mpath <- gets esPath
    st <- gets $ head.esGameStateStack
    void.runMaybeT $ do
	soln <- solveLock (frame,st) $ Just $ "testing " ++ fromMaybe "[unnamed lock]" mpath
	lift $ modify $ \es -> es { esTested = Just (st, soln) }
processCommand' IMEdit CmdUndo = do
    st:sts <- gets esGameStateStack
    usts <- gets esUndoneStack
    unless (null sts) $ modify $ \es -> es {esGameStateStack = sts, esUndoneStack = st:usts}
processCommand' IMEdit CmdRedo = do
    usts <- gets esUndoneStack
    case usts of 
	[] -> return ()
	ust:usts' -> do
	    pushEState ust
	    modify $ \es -> es {esUndoneStack = usts'}
processCommand' IMEdit CmdUnselect =
    modify $ \es -> es {selectedPiece = Nothing}
processCommand' IMEdit CmdSelect = do
    selPiece <- gets selectedPiece
    selPos <- gets selectedPos
    st:_ <- gets esGameStateStack
    let selPiece' =
	    if isJust selPiece
		then Nothing
		else liftM fst $ Map.lookup selPos $ stateBoard st
    modify $ \es -> es {selectedPiece = selPiece'}
processCommand' IMEdit (CmdDir _ dir) = do
    selPos <- gets selectedPos
    selPiece <- gets selectedPiece
    frame <- gets esFrame
    case selPiece of
	Nothing -> modify $ \es -> es {selectedPos = checkEditable frame selPos $ dir <+> selPos}
	Just p -> doForce $ Push p dir
processCommand' IMEdit (CmdMoveTo newPos) = do
    frame <- gets esFrame
    modify $ \es -> es {selectedPos = truncateToEditable frame newPos}
processCommand' IMEdit (CmdDrag pos dir) = do
    board <- stateBoard.head <$> gets esGameStateStack
    void.runMaybeT $ do
	selIdx <- MaybeT $ gets selectedPiece
	idx <- MaybeT $ return $ fst <$> Map.lookup pos board
	guard $ idx == selIdx
	lift $ processCommand' IMEdit $ CmdDir WHSSelected $ dir
	board' <- stateBoard.head <$> gets esGameStateStack
	msum [ do
		idx' <- MaybeT $ return $ fst <$> Map.lookup pos' board'
		guard $ idx' == selIdx
		lift.lift $ warpPointer $ pos'
	    | pos' <- [dir<+>pos, pos] ]
processCommand' IMEdit (CmdRotate _ dir) = do
    selPiece <- gets selectedPiece
    case selPiece of
	Nothing -> return ()
	Just p -> doForce $ Torque p dir
processCommand' IMEdit (CmdTile tile) = do
    selPos <- gets selectedPos
    drawTile selPos (Just tile) False
processCommand' IMEdit (CmdPaint tile) = do
    selPos <- gets selectedPos
    drawTile selPos tile True
processCommand' IMEdit (CmdPaintFromTo tile from to) = do
    frame <- gets esFrame
    paintTilePath tile (truncateToEditable frame from) (truncateToEditable frame to)
processCommand' IMEdit CmdMerge = do
    selPos <- gets selectedPos
    st:_ <- gets esGameStateStack
    lift $ drawMessage "Merge in which direction?"
    let getDir = do
	cmd <- lift $ head <$> getSomeInput IMEdit
	case cmd of
	    CmdDir _ mergeDir -> return $ Just mergeDir
	    CmdDrag _ mergeDir -> return $ Just mergeDir
	    CmdMoveTo _ -> getDir
	    _ -> return $ Nothing
    mergeDir <- getDir
    case mergeDir of
	Just mergeDir -> modifyEState $ mergeTiles selPos mergeDir True
	_ -> return ()
    -- XXX: merging might invalidate selectedPiece
    modify $ \es -> es {selectedPiece = Nothing}
    lift $ drawMessage ""
processCommand' IMEdit CmdWait = do
    st:_ <- gets esGameStateStack
    (st',_) <- lift $ doPhysicsTick NullPM st
    pushEState st'

processCommand' IMEdit CmdDelete = do
    selPos <- gets selectedPos
    selPiece <- gets selectedPiece
    st:_ <- gets esGameStateStack
    case selPiece of
	Nothing -> drawTile selPos Nothing False
	Just p -> do modify $ \es -> es {selectedPiece = Nothing}
		     modifyEState $ delPiece p
processCommand' IMEdit CmdWriteState = void.runMaybeT $ do
    path <- lift $ gets esPath
    newPath <- MaybeT $ lift $ textInput "Save lock as:" 1024 False False Nothing path
    guard $ not $ null newPath
    fullPath <- liftIO $ fullLockPath newPath
    (liftIO (doesFileExist fullPath `catchIO` const (return True)) >>=) $ flip when $
	confirmOrBail $ "Really overwrite '"++fullPath++"'?"
    lift $ do
	st <- gets $ head.esGameStateStack
	frame <- gets esFrame
	msoln <- getCurTestSoln
	merr <- liftIO $ ((writeAsciiLockFile fullPath msoln $ canonify (frame, st)) >> return Nothing)
	    `catchIO` (return . Just . show)
	modify $ \es -> es {lastSavedState = Just (st,isJust msoln)}
	case merr of
	    Nothing -> modify $ \es -> es {esPath = Just newPath}
	    Just err -> lift $ drawError $ "Write failed: "++err
processCommand' _ _ = return ()

hashPassword :: String -> String -> String
-- ^ salt password
hashPassword name password = hash $ "IY" ++ name ++ password

subPlay :: UIMonad uiM => Lock -> StateT MainState uiM ()
subPlay lock =
    pushEState =<< psCurrentState <$> (lift $ execStateT interactUI $ newPlayState lock Nothing True)

solveLock :: UIMonad uiM => Lock -> Maybe String -> MaybeT (StateT MainState uiM) Solution
solveLock lock title = do
    (InteractSuccess solved, ps) <- lift.lift $ runStateT interactUI $ newPlayState (reframe lock) title False
    guard $ solved
    return $ reverse $ (map snd) $ psGameStateMoveStack ps