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