InteractUtil.hs

   1 -- This file is part of Intricacy
   2 -- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 module InteractUtil where
  12
  13 import           Control.Applicative
  14 import           Control.Monad.State
  15 import           Control.Monad.Trans.Maybe
  16 import           Control.Monad.Writer
  17 import           Data.Array
  18 import           Data.Char
  19 import           Data.Function             (on)
  20 import           Data.List
  21 import           Data.Map                  (Map)
  22 import qualified Data.Map                  as Map
  23 import           Data.Maybe
  24 import           System.Directory
  25
  26 import           Command
  27 import           EditGameState
  28 import           Frame
  29 import           GameState
  30 import           GameStateTypes
  31 import           Hex
  32 import           InputMode
  33 import           Lock
  34 import           MainState
  35 import           Metagame
  36 import           Mundanities
  37 import           Physics
  38 import           Protocol
  39 import           Util
  40
  41 checkWon :: UIMonad uiM => MainStateT uiM ()
  42 checkWon = do
  43     st <- gets psCurrentState
  44     frame <- gets psFrame
  45     wasSolved <- gets psSolved
  46     let solved = checkSolved (frame,st)
  47     when (solved /= wasSolved) $ do
  48         modify $ \ps -> ps {psSolved = solved}
  49         obdg <- lift $ getUIBinding IMPlay CmdOpen
  50         lift $ if solved then do
  51                 drawMessage $ "Unlocked! '"++obdg++"' to open."
  52                 reportAlerts st [AlertUnlocked]
  53             else clearMessage
  54
  55 doForce force = do
  56     st <- gets esGameState
  57     let (st',alerts) = runWriter $ resolveSinglePlForce force st
  58     lift (reportAlerts st' alerts) >> pushEState st'
  59 drawTile pos tile painting = do
  60     modify $ \es -> es {selectedPiece = Nothing}
  61     lastMP <- gets lastModPos
  62     modifyEState $ modTile tile pos lastMP painting
  63     modify $ \es -> es {lastModPos = pos}
  64 paintTilePath frame tile from to = if from == to
  65     then modify $ \es -> es {lastModPos = to}
  66     else do
  67         let from' = hexVec2HexDirOrZero (to-^from) +^ from
  68         when (inEditable frame from') $ drawTile from' tile True
  69         paintTilePath frame tile from' to
  70
  71 adjustSpringTension :: UIMonad uiM => PieceIdx -> Int -> MainStateT uiM ()
  72 adjustSpringTension p dl = do
  73     st <- gets esGameState
  74     let updateConn c@(Connection r e@(p',_) (Spring d l))
  75             | p' == p
  76             , let c' = Connection r e (Spring d $ l + dl)
  77             , springExtensionValid st c'
  78             = c'
  79             | otherwise = c
  80     pushEState $ st { connections = updateConn <$> connections st }
  81
  82 pushEState :: UIMonad uiM => GameState -> MainStateT uiM ()
  83 pushEState st = do
  84     st' <- gets esGameState
  85     sts <- gets esGameStateStack
  86     when (st' /= st) $ modify $ \es -> es {esGameState = st, esGameStateStack = st':sts, esUndoneStack = []}
  87 pushPState :: UIMonad uiM => (GameState,PlayerMove) -> MainStateT uiM ()
  88 pushPState (st,pm) = do
  89     st' <- gets psCurrentState
  90     stms <- gets psGameStateMoveStack
  91     when (st' /= st) $ modify $ \ps -> ps {psCurrentState = st,
  92             psGameStateMoveStack = (st',pm):stms, psUndoneStack = []}
  93 modifyEState :: UIMonad uiM => (GameState -> GameState) -> MainStateT uiM ()
  94 modifyEState f = do
  95     st <- gets esGameState
  96     pushEState $ f st
  97
  98 doPhysicsTick :: UIMonad uiM => PlayerMove -> GameState -> uiM (GameState, [Alert])
  99 doPhysicsTick pm st =
 100     let r@(st',alerts) = runWriter $ physicsTick pm st in
 101     reportAlerts st' alerts >> return r
 102
 103 nextLock :: Bool -> FilePath -> IO FilePath
 104 nextLock newer path = do
 105     lockdir <- confFilePath "locks"
 106     time <- (Just <$> (fullLockPath path >>= getModificationTime))
 107         `catchIO` const (return Nothing)
 108     paths <- getDirContentsRec lockdir
 109     maybe path (drop (length lockdir + 1) . fst) . listToMaybe .
 110         (if newer then id else reverse) . sortBy (compare `on` snd) .
 111         filter (maybe (const True)
 112             (\x y -> (if newer then (<) else (>)) x (snd y)) time) <$>
 113         (\p -> (,) p <$> getModificationTime p) `mapM` paths
 114
 115 hasLocks :: IO Bool
 116 hasLocks = do
 117     lockdir <- confFilePath "locks"
 118     not.null <$> getDirContentsRec lockdir
 119
 120 setLockPath :: UIMonad uiM => FilePath -> MainStateT uiM ()
 121 setLockPath path = do
 122     lock <- liftIO $ fullLockPath path >>= readLock
 123     modify $ \ms -> ms {curLockPath = path, curLock = lock}
 124
 125 declare undecl@(Undeclared soln ls al) = do
 126     ourName <- mgetOurName
 127     ourUInfo <- mgetUInfo ourName
 128     [pbdg,ebdg,hbdg] <- mapM (lift.lift . getUIBinding IMMeta)
 129         [ CmdPlaceLock Nothing, CmdEdit, CmdHome ]
 130     haveLock <- gets (isJust . curLock)
 131     idx <- askLockIndex "Secure behind which lock?"
 132         (if haveLock
 133             then "First you must place ('"++pbdg++"') a lock to secure your solution behind, while at home ('"++hbdg++"')."
 134             else "First design a lock in the editor ('"++ebdg++"'), behind which to secure your solution.")
 135         (\i -> isJust $ userLocks ourUInfo ! i)
 136     guard $ isJust $ userLocks ourUInfo ! idx
 137     lift $ curServerActionAsyncThenInvalidate
 138         (DeclareSolution soln ls al idx)
 139         -- rather than recurse through the tree to find what scores may have
 140         -- changed as a result of this declaration, or leave it to timeouts
 141         -- and explicit refreshes to reveal it, we just invalidate all UInfos.
 142         (Just AllCodenames)
 143
 144 startMark = '^'
 145
 146 marksSet :: UIMonad uiM => MainStateT uiM [Char]
 147 marksSet = do
 148     mst <- get
 149     return $ case ms2im mst of
 150         IMEdit   -> Map.keys $ esMarks mst
 151         IMPlay   -> Map.keys $ psMarks mst
 152         IMReplay -> Map.keys $ rsMarks mst
 153         _        -> []
 154
 155 jumpMark :: UIMonad uiM => Char -> MainStateT uiM ()
 156 jumpMark ch = do
 157     mst <- get
 158     void.runMaybeT $ case ms2im mst of
 159         IMEdit -> do
 160             st <- liftMaybe $ ch `Map.lookup` esMarks mst
 161             lift $ setMark True '\'' >> pushEState st
 162         IMPlay -> do
 163             mst' <- liftMaybe $ ch `Map.lookup` psMarks mst
 164             put mst' { psMarks = Map.insert '\'' mst $ psMarks mst }
 165         IMReplay -> do
 166             mst' <- liftMaybe $ ch `Map.lookup` rsMarks mst
 167             put mst' { rsMarks = Map.insert '\'' mst $ rsMarks mst }
 168         _ -> return ()
 169
 170 setMark :: (Monad m) => Bool -> Char -> MainStateT m ()
 171 setMark overwrite ch = get >>= \mst -> case mst of
 172     -- ugh... remind me why I'm not using lens?
 173     EditState { esMarks = marks, esGameState = st } ->
 174         put $ mst { esMarks = insertMark ch st marks }
 175     PlayState {} -> put $ mst { psMarks = insertMark ch mst $ psMarks mst }
 176     ReplayState {} -> put $ mst { rsMarks = insertMark ch mst $ rsMarks mst }
 177     _ -> return ()
 178     where insertMark = Map.insertWith $ \new old -> if overwrite then new else old
 179
 180 askLockIndex :: UIMonad uiM => [Char] -> String -> (Int -> Bool) -> MaybeT (MainStateT uiM) Int
 181 askLockIndex prompt failMessage pred = do
 182     let ok = filter pred [0,1,2]
 183     case length ok of
 184         0 -> (lift.lift) (drawError failMessage) >> mzero
 185         1 -> return $ head ok
 186         _ -> ask ok
 187     where
 188         ask ok = do
 189             let prompt' = prompt ++ " [" ++ intersperse ',' (lockIndexChar <$> ok) ++ "]"
 190             idx <- MaybeT $ lift $ (((charLockIndex<$>).listToMaybe) =<<) <$>
 191                 textInput prompt' 1 False True Nothing Nothing
 192             if idx `elem` ok then return idx else ask ok
 193 confirmOrBail :: UIMonad uiM => String -> MaybeT (MainStateT uiM) ()
 194 confirmOrBail prompt = (guard =<<) $ lift.lift $ confirm prompt
 195 confirm :: UIMonad uiM => String -> uiM Bool
 196 confirm prompt = do
 197     drawPrompt False $ prompt ++ " [y/N] "
 198     setYNButtons
 199     waitConfirm <* endPrompt
 200     where
 201         waitConfirm = do
 202             cmds <- getInput IMTextInput
 203             maybe waitConfirm return (msum $ ansOfCmd <$> cmds)
 204         ansOfCmd (CmdInputChar 'y') = Just True
 205         ansOfCmd (CmdInputChar 'Y') = Just True
 206         ansOfCmd (CmdInputChar c)   = if isPrint c then Just False else Nothing
 207         ansOfCmd CmdRedraw          = Just False
 208         ansOfCmd CmdRefresh         = Nothing
 209         ansOfCmd CmdUnselect        = Nothing
 210         ansOfCmd _                  = Just False
 211
 212 -- | TODO: draw cursor
 213 textInput :: UIMonad uiM => String -> Int -> Bool -> Bool -> Maybe [String] -> Maybe String -> uiM (Maybe String)
 214 textInput prompt maxlen hidden endOnMax mposss init = getText (fromMaybe "" init, Nothing) <* endPrompt
 215     where
 216         getText :: UIMonad uiM => (String, Maybe String) -> uiM (Maybe String)
 217         getText (s,mstem) = do
 218             drawPrompt (length s == maxlen) $ prompt ++ " " ++ if hidden then replicate (length s) '*' else s
 219             if endOnMax && isNothing mstem && maxlen <= length s
 220             then return $ Just $ take maxlen s
 221             else do
 222                 cmds <- getInput IMTextInput
 223                 case foldM applyCmd (s,mstem) cmds of
 224                     Left False        -> return Nothing
 225                     Left True         -> return $ Just s
 226                     Right (s',mstem') -> getText (s',mstem')
 227             where
 228                 applyCmd (s,mstem) (CmdInputChar c) = case c of
 229                     '\ESC' -> Left False
 230                     '\a' -> Left False -- ^G
 231                     '\ETX' -> Left False -- ^C
 232                     '\n' -> Left True
 233                     '\r' -> Left True
 234                     '\NAK' -> Right ("",Nothing)  -- ^U
 235                     '\b' -> Right (take (length s - 1) s, Nothing)
 236                     '\DEL' -> Right (take (length s - 1) s, Nothing)
 237                     '\t' -> case mposss of
 238                         Nothing -> Right (s,mstem)
 239                         Just possibilities -> case mstem of
 240                             Nothing -> let
 241                                 completions = filter (completes s) possibilities
 242                                 pref = if null completions then s else
 243                                     let c = head completions
 244                                     in head [ c' | n <- reverse [0..length c],
 245                                         let c'=take n c, all (completes c') completions ]
 246                                 in Right (pref,Just pref)
 247                             Just stem -> let
 248                                 completions = filter (completes stem) possibilities
 249                                 later = filter (>s) completions
 250                                 s' | null completions = s
 251                                    | null later = head completions
 252                                    | otherwise = minimum later
 253                                 in Right (s',mstem)
 254                     _ -> Right $ if isPrint c
 255                             then ((if length s >= maxlen then id else (++[c])) s, Nothing)
 256                             else (s,mstem)
 257                 applyCmd x (CmdInputSelLock idx) =
 258                     setTextOrSubmit x [lockIndexChar idx]
 259                 applyCmd x (CmdInputSelUndecl (Undeclared _ _ (ActiveLock name idx))) =
 260                     setTextOrSubmit x $ name++[':',lockIndexChar idx]
 261                 applyCmd x (CmdInputCodename name) =
 262                     setTextOrSubmit x name
 263                 applyCmd x CmdRefresh = Right x
 264                 applyCmd x CmdUnselect = Right x
 265                 applyCmd _ _ = Left False
 266         completes s s' = take (length s) s' == s
 267         setTextOrSubmit (s,_) t = if s == t then Left True else Right (t,Nothing)