MainState.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 {-# LANGUAGE TupleSections #-}
  12
  13 module MainState where
  14
  15 import           Control.Applicative
  16 import           Control.Concurrent
  17 import           Control.Concurrent.STM
  18 import           Control.Monad.State
  19 import           Control.Monad.Trans.Maybe
  20 import           Control.Monad.Writer
  21 import           Data.Array
  22 import           Data.Char
  23 import           Data.Function             (on)
  24 import           Data.List
  25 import           Data.Map                  (Map)
  26 import qualified Data.Map                  as Map
  27 import           Data.Maybe
  28 import           Data.Time.Clock
  29 import qualified Data.Vector               as Vector
  30 import           Safe
  31 import           System.Directory
  32 import           System.FilePath
  33
  34 import           AsciiLock
  35 import           Cache
  36 import           Command
  37 import           Database
  38 import           Frame
  39 import           GameStateTypes
  40 import           Hex
  41 import           InputMode
  42 import           Lock
  43 import           Maxlocksize
  44 import           Metagame
  45 import           Mundanities
  46 import           Physics
  47 import           Protocol
  48 import           ServerAddr
  49 import           Util
  50
  51 class (Applicative m, MonadIO m) => UIMonad m where
  52     runUI :: m a -> IO a
  53     initUI :: m Bool
  54     endUI :: m ()
  55     drawMainState :: MainStateT m ()
  56     reportAlerts :: GameState -> [Alert] -> m ()
  57     clearMessage :: m ()
  58     drawMessage :: String -> m ()
  59     drawPrompt :: Bool -> String -> m ()
  60     endPrompt :: m ()
  61     drawError :: String -> m ()
  62     showHelp :: InputMode -> HelpPage -> m Bool
  63     getInput :: InputMode -> m [ Command ]
  64     getChRaw :: m ( Maybe Char )
  65     unblockInput :: m (IO ())
  66     setUIBinding :: InputMode -> Command -> Char -> m ()
  67     getUIBinding :: InputMode -> Command -> m String
  68     impatience :: Int -> m Bool
  69     toggleColourMode :: m ()
  70     warpPointer :: HexPos -> m ()
  71     getUIMousePos :: m (Maybe HexPos)
  72     setYNButtons :: m ()
  73     onNewMode :: InputMode -> m ()
  74     withNoBG :: m () -> m ()
  75     suspend,redraw :: m ()
  76
  77     doUI :: m a -> IO (Maybe a)
  78     doUI m = runUI $ do
  79         ok <- initUI
  80         if ok then m >>= (endUI >>).return.Just else return Nothing
  81
  82 -- | this could be neatened using GADTs
  83 data MainState
  84     = PlayState
  85         { psCurrentState       :: GameState
  86         , psFrame              :: Frame
  87         , psLastAlerts         :: [Alert]
  88         , wrenchSelected       :: Bool
  89         , psSolved             :: Bool
  90         , psGameStateMoveStack :: [(GameState, PlayerMove)]
  91         , psUndoneStack        :: [PlayerMove]
  92         , psTitle              :: Maybe String
  93         , psTutLevel           :: Maybe Int
  94         , psIsSub              :: Bool
  95         , psSaved              :: Bool
  96         , psMarks              :: Map Char MainState
  97         }
  98     | ReplayState
  99         { rsCurrentState       :: GameState
 100         , rsLastAlerts         :: [Alert]
 101         , rsMoveStack          :: [PlayerMove]
 102         , rsGameStateMoveStack :: [(GameState, PlayerMove)]
 103         , rsTitle              :: Maybe String
 104         , rsMarks              :: Map Char MainState
 105         }
 106     | EditState
 107         { esGameState      :: GameState
 108         , esGameStateStack :: [GameState]
 109         , esUndoneStack    :: [GameState]
 110         , esFrame          :: Frame
 111         , esPath           :: Maybe FilePath
 112         , esTested         :: Maybe (GameState,Solution)
 113         , lastSavedState   :: Maybe (GameState, Bool)
 114         , selectedPiece    :: Maybe PieceIdx
 115         , selectedPos      :: HexPos
 116         , lastModPos       :: HexPos
 117         , esMarks          :: Map Char GameState
 118         }
 119     | InitState
 120         { tutProgress :: TutProgress
 121         , initLocks   :: InitLocks
 122         }
 123     | MetaState
 124         { curServer        :: ServerAddr
 125         , undeclareds      :: [Undeclared]
 126         , partialSolutions :: PartialSolutions
 127         , cacheOnly        :: Bool
 128         , curAuth          :: Maybe Auth
 129         , codenameStack    :: [Codename]
 130         , newAsync         :: TVar Bool
 131         , asyncCount       :: TVar Int
 132         , asyncError       :: TVar (Maybe String)
 133         , asyncInvalidate  :: TVar (Maybe Codenames)
 134         , randomCodenames  :: TVar [Codename]
 135         , userInfoTVs      :: Map Codename (TVar FetchedRecord, UTCTime)
 136         , indexedLocks     :: Map LockSpec (TVar FetchedRecord)
 137         , retiredLocks     :: Maybe [LockSpec]
 138         , curLockPath      :: FilePath
 139         , curLock          :: Maybe (Lock,Maybe Solution)
 140         , listOffset       :: Int
 141         , listOffsetMax    :: Bool
 142         , initiated        :: Bool
 143         }
 144
 145 type MainStateT = StateT MainState
 146
 147 data HelpPage = HelpPageInput | HelpPageGame | HelpPageInitiated Int | HelpPageFirstEdit
 148     deriving (Eq, Ord, Show)
 149
 150 ms2im :: MainState -> InputMode
 151 ms2im mainSt = case mainSt of
 152     PlayState {}   -> IMPlay
 153     ReplayState {} -> IMReplay
 154     EditState {}   -> IMEdit
 155     InitState {}   -> IMInit
 156     MetaState {}   -> IMMeta
 157
 158 newPlayState (frame,st) pms title tutLevel sub saved = PlayState st frame [] False False [] pms title tutLevel sub saved Map.empty
 159 newReplayState st soln title = ReplayState st [] soln [] title Map.empty
 160 newEditState (frame,st) msoln mpath = EditState st [] [] frame mpath
 161     ((st,)<$>msoln) (Just (st, isJust msoln)) Nothing (PHS zero) (PHS zero) Map.empty
 162 initInitState = do
 163     (tut,initLocks) <- readInitProgress
 164     return $ InitState tut initLocks
 165 initMetaState = do
 166     flag <- newTVarIO False
 167     errtvar <- newTVarIO Nothing
 168     invaltvar <- newTVarIO Nothing
 169     rnamestvar <- newTVarIO []
 170     counttvar <- newTVarIO 0
 171     (initiated, saddr', auth, path) <- confFilePath "metagame.conf" >>=
 172         fmap (fromMaybe (False, defaultServerAddr, Nothing, "")) . readReadFile
 173     let saddr = updateDefaultSAddr saddr'
 174     let names = maybeToList $ authUser <$> auth
 175     (undecls,partials) <- readServerSolns saddr
 176     mlock <- fullLockPath path >>= readLock
 177     return $ MetaState saddr undecls partials False auth names flag counttvar errtvar invaltvar rnamestvar Map.empty Map.empty Nothing path mlock 0 True initiated
 178
 179 type PartialSolutions = Map LockSpec SavedPlayState
 180 data SavedPlayState = SavedPlayState [PlayerMove] (Map Char [PlayerMove])
 181     deriving (Eq, Ord, Show, Read)
 182
 183 data TutProgress = TutProgress
 184     { tutSolved  :: Bool
 185     , tutLevel   :: Int
 186     , tutPartial :: Maybe SavedPlayState
 187     } deriving (Eq, Ord, Show, Read)
 188 initTutProgress = TutProgress False 1 Nothing
 189
 190 wrenchOnlyTutLevel, noUndoTutLevel :: Maybe Int -> Bool
 191 wrenchOnlyTutLevel = (`elem` (Just <$> [1..4]))
 192 noUndoTutLevel = (`elem` (Just <$> [1..7]))
 193
 194 data InitLock = InitLock
 195     { initLockName    :: String
 196     , initLockDesc    :: String
 197     , initLockLock    :: Lock
 198     , initLockSolved  :: Bool
 199     , initLockPartial :: Maybe SavedPlayState
 200     } deriving (Eq, Ord, Show, Read)
 201 type InitLocks = Map HexVec InitLock
 202
 203 accessibleInitLocks :: Bool -> InitLocks -> InitLocks
 204 accessibleInitLocks tutSolved initLocks =
 205     Map.filterWithKey (\v _ -> initLockAccessible v) initLocks
 206     where
 207     initLockAccessible :: HexVec -> Bool
 208     initLockAccessible v = or
 209         [ (v' == zero && tutSolved) ||
 210             (Just True == (initLockSolved <$> Map.lookup v' initLocks))
 211         | v' <- (v +^) <$> hexDirs ]
 212
 213 isLastInitLock :: InitLock -> Bool
 214 isLastInitLock = (== "END") . initLockName
 215
 216 savePlayState :: MainState -> SavedPlayState
 217 savePlayState ps = SavedPlayState (getMoves ps) $ Map.map getMoves $ psMarks ps
 218     where getMoves = reverse . map snd . psGameStateMoveStack
 219
 220 restorePlayState :: SavedPlayState -> Lock -> [PlayerMove] -> Maybe String -> Maybe Int -> Bool -> Bool -> MainState
 221 restorePlayState (SavedPlayState pms markPMs) (frame,st) redoPms title tutLevel sub saved =
 222     (stateAfterMoves pms) { psMarks = Map.map stateAfterMoves markPMs }
 223     where
 224         stateAfterMoves pms = let (stack,st') = applyMoves st pms
 225             in (newPlayState (frame, st') redoPms title tutLevel sub saved) { psGameStateMoveStack = stack }
 226         applyMoves st = foldl tick ([],st)
 227         tick :: ([(GameState,PlayerMove)],GameState) -> PlayerMove -> ([(GameState,PlayerMove)],GameState)
 228         tick (stack,st) pm = ((st,pm):stack,fst . runWriter $ physicsTick pm st)
 229
 230 readServerSolns :: ServerAddr -> IO ([Undeclared],PartialSolutions)
 231 readServerSolns saddr = if nullSaddr saddr then return ([],Map.empty) else do
 232     undecls <- confFilePath ("undeclared" ++ [pathSeparator] ++ saddrPath saddr) >>=
 233         fmap (fromMaybe []) . readReadFile
 234     partials <- confFilePath ("partialSolutions" ++ [pathSeparator] ++ saddrPath saddr) >>=
 235         fmap (fromMaybe Map.empty) . readReadFile
 236     return (undecls,partials)
 237
 238 readInitProgress :: IO (TutProgress,InitLocks)
 239 readInitProgress = do
 240     initConfDir <- confFilePath "initiation"
 241     initDataDir <- getDataPath "initiation"
 242     tut <- fromMaybe initTutProgress <$> readReadFile (initConfDir </> "tutProgress")
 243     locknames <- fromMaybe [] <$> readReadFile (initDataDir </> "initiation.map")
 244     let namesMap :: Map HexVec Codename
 245         namesMap = Map.fromList $
 246             [ (rotate (-j) (neg hw) +^ i *^ hu, name)
 247             | (j,line) <- zip [0..] locknames
 248             , (i,name) <- zip [0..] line ]
 249         readInitLock :: String -> IO (Maybe InitLock)
 250         readInitLock name = runMaybeT $ do
 251             desc <- MaybeT $ listToMaybe <$> readStrings (initDataDir </> name ++ ".text")
 252             lock <- (fst <$>) . MaybeT $ readLock (initDataDir </> name ++ ".lock")
 253             solved <- lift . (fromMaybe False <$>) . readReadFile $ initConfDir </> name ++ ".solved"
 254             partial <- lift . (fromMaybe Nothing <$>) . readReadFile $ initConfDir </> name ++ ".partial"
 255             return $ InitLock name desc lock solved partial
 256     initLocks <- Map.mapMaybe id <$> mapM readInitLock namesMap
 257     return (tut,initLocks)
 258
 259 writeServerSolns :: ServerAddr -> MainState -> IO ()
 260 writeServerSolns saddr MetaState { undeclareds=undecls,
 261         partialSolutions=partials } = unless (nullSaddr saddr) $ do
 262     confFilePath ("undeclared" ++ [pathSeparator] ++ saddrPath saddr) >>= flip writeReadFile undecls
 263     confFilePath ("partialSolutions" ++ [pathSeparator] ++ saddrPath saddr) >>= flip writeReadFile partials
 264
 265 readLock :: FilePath -> IO (Maybe (Lock, Maybe Solution))
 266 readLock path = runMaybeT $ msum
 267         [ (,Nothing) <$> MaybeT (readReadFile path)
 268         , do
 269             (mlock,msoln) <- lift $ readAsciiLockFile path
 270             lock <- liftMaybe mlock
 271             return (lock,msoln) ]
 272 -- writeLock :: FilePath -> Lock -> IO ()
 273 -- writeLock path lock = fullLockPath path >>= flip writeReadFile lock
 274
 275 writeInitState :: MainState -> IO ()
 276 writeInitState InitState { tutProgress = tut, initLocks = initLocks } = do
 277     initConfDir <- confFilePath "initiation"
 278     writeReadFile (initConfDir </> "tutProgress") tut
 279     let writeInitLockInfo :: InitLock -> IO ()
 280         writeInitLockInfo (InitLock name _ _ solved partial) = do
 281             writeReadFile (initConfDir </> name ++ ".solved") solved
 282             writeReadFile (initConfDir </> name ++ ".partial") partial
 283     mapM_ writeInitLockInfo initLocks
 284 writeInitState _ = return ()
 285
 286 writeMetaState :: MainState -> IO ()
 287 writeMetaState ms@MetaState { curServer=saddr, curAuth=auth, curLockPath=path, initiated=initiated } = do
 288     confFilePath "metagame.conf" >>= flip writeReadFile (initiated, saddr, auth, path)
 289     writeServerSolns saddr ms
 290 writeMetaState _ = return ()
 291
 292 getTitle :: UIMonad uiM => MainStateT uiM (Maybe (String, Int))
 293 getTitle = get >>= title . ms2im
 294     where
 295     title IMEdit = do
 296         mpath <- gets esPath
 297         unsaved <- editStateUnsaved
 298         isTested <- isJust <$> getCurTestSoln
 299         height <- gets $ aboveFrame . esFrame
 300         return $ Just ("editing " ++ fromMaybe "[unnamed lock]" mpath ++
 301                 (if isTested then " (Tested)" else "") ++
 302                 (if unsaved then " [+]" else "    "),
 303             height
 304             )
 305     title IMPlay = do
 306         height <- gets $ aboveFrame . psFrame
 307         gets $ ((, height) <$>) . psTitle
 308     title IMReplay = gets $ ((, maxHeight) <$>) . rsTitle
 309     title _ = return Nothing
 310     aboveFrame frame = min maxHeight $ 2 + frameSize frame
 311     maxHeight = maxlocksize + 1
 312
 313 editStateUnsaved :: UIMonad uiM => MainStateT uiM Bool
 314 editStateUnsaved = (isNothing <$>) $ runMaybeT $ do
 315     (sst,tested) <- MaybeT $ gets lastSavedState
 316     st <- gets esGameState
 317     guard $ sst == st
 318     nowTested <- isJust <$> lift getCurTestSoln
 319     guard $ tested == nowTested
 320
 321 getCurTestSoln :: UIMonad uiM => MainStateT uiM (Maybe Solution)
 322 getCurTestSoln = runMaybeT $ do
 323     (st',soln) <- MaybeT $ gets esTested
 324     st <- gets esGameState
 325     guard $ st == st'
 326     return soln
 327
 328 mgetOurName :: (UIMonad uiM) => MaybeT (MainStateT uiM) Codename
 329 mgetOurName = MaybeT $ gets ((authUser <$>) . curAuth)
 330 mgetCurName :: (UIMonad uiM) => MaybeT (MainStateT uiM) Codename
 331 mgetCurName = MaybeT $ gets (listToMaybe . codenameStack)
 332
 333 getUInfoFetched :: UIMonad uiM => Integer -> Codename -> MainStateT uiM FetchedRecord
 334 getUInfoFetched staleTime name = do
 335     uinfott <- gets (Map.lookup name . userInfoTVs)
 336     ($ uinfott) $ maybe set $ \(tvar,time) -> do
 337         now <- liftIO getCurrentTime
 338         if floor (diffUTCTime now time) > staleTime
 339             then set
 340             else liftIO $ readTVarIO tvar
 341     where
 342         set = do
 343             now <- liftIO getCurrentTime
 344             tvar <- getRecordCachedFromCur True $ RecUserInfo name
 345             modify $ \ms -> ms {userInfoTVs = Map.insert name (tvar, now) $ userInfoTVs ms}
 346             liftIO $ readTVarIO tvar
 347
 348 mgetUInfo :: UIMonad uiM => Codename -> MaybeT (MainStateT uiM) UserInfo
 349 mgetUInfo name = do
 350     RCUserInfo (_,uinfo) <- MaybeT $ (fetchedRC <$>) $ getUInfoFetched defaultStaleTime name
 351     return uinfo
 352     where defaultStaleTime = 300
 353
 354
 355 invalidateUInfo :: UIMonad uiM => Codename -> MainStateT uiM ()
 356 invalidateUInfo name =
 357     modify $ \ms -> ms {userInfoTVs = Map.delete name $ userInfoTVs ms}
 358
 359 invalidateAllUInfo :: UIMonad uiM => MainStateT uiM ()
 360 invalidateAllUInfo =
 361     modify $ \ms -> ms {userInfoTVs = Map.empty}
 362
 363 data Codenames = AllCodenames | SomeCodenames [Codename]
 364
 365 invalidateUInfos :: UIMonad uiM => Codenames -> MainStateT uiM ()
 366 invalidateUInfos AllCodenames          = invalidateAllUInfo
 367 invalidateUInfos (SomeCodenames names) = mapM_ invalidateUInfo names
 368
 369
 370 mgetLock :: UIMonad uiM => LockSpec -> MaybeT (MainStateT uiM) Lock
 371 mgetLock ls = do
 372     tvar <- msum [ MaybeT $ gets (Map.lookup ls . indexedLocks)
 373         , lift $ do
 374             tvar <- getRecordCachedFromCur True $ RecLock ls
 375             modify $ \ms -> ms { indexedLocks = Map.insert ls tvar $ indexedLocks ms }
 376             return tvar ]
 377     RCLock lock <- MaybeT $ (fetchedRC<$>) $ liftIO $ readTVarIO tvar
 378     return $ reframe lock
 379
 380 invalidateAllIndexedLocks :: UIMonad uiM => MainStateT uiM ()
 381 invalidateAllIndexedLocks =
 382     modify $ \ms -> ms { indexedLocks = Map.empty }
 383
 384 refreshUInfoUI :: (UIMonad uiM) => MainStateT uiM ()
 385 refreshUInfoUI = void.runMaybeT $ do
 386     modify $ \ms -> ms { listOffset = 0 }
 387     mourNameSelected >>? getRandomNames
 388     lift $ modify $ \ms -> ms {retiredLocks = Nothing}
 389     --lift.lift $ drawMessage ""
 390     where
 391         getRandomNames = do
 392             rnamestvar <- gets randomCodenames
 393             liftIO $ atomically $ writeTVar rnamestvar []
 394             flag <- gets newAsync
 395             saddr <- gets curServer
 396             void $ liftIO $ forkIO $ do
 397                 resp <- makeRequest saddr $
 398                     ClientRequest protocolVersion Nothing $ GetRandomNames 19
 399                 case resp of
 400                     ServedRandomNames names -> atomically $ do
 401                             writeTVar rnamestvar names
 402                             writeTVar flag True
 403                     _ -> return ()
 404
 405 mourNameSelected :: (UIMonad uiM) => MaybeT (MainStateT uiM) Bool
 406 mourNameSelected = liftM2 (==) mgetCurName mgetOurName
 407
 408 purgeInvalidUndecls :: (UIMonad uiM) => MainStateT uiM ()
 409 purgeInvalidUndecls = do
 410     undecls' <- gets undeclareds >>= filterM ((not<$>).invalid)
 411     modify $ \ms -> ms { undeclareds = undecls' }
 412     where
 413         invalid (Undeclared _ ls (ActiveLock name idx)) =
 414             (fromMaybe False <$>) $ runMaybeT $ do
 415                 uinfo <- mgetUInfo name
 416                 ourName <- mgetOurName
 417                 (`mplus` return True) $ do
 418                     linfo <- liftMaybe $ userLocks uinfo ! idx
 419                     return $ public linfo
 420                         || ourName `elem` accessedBy linfo
 421                         || lockSpec linfo /= ls
 422
 423
 424 curServerAction :: UIMonad uiM => Protocol.Action -> MainStateT uiM ServerResponse
 425 curServerAction act = do
 426     saddr <- gets curServer
 427     auth <- gets curAuth
 428     cOnly <- gets cacheOnly
 429     if cOnly then return $ ServerError "Can't contact server in cache-only mode"
 430         else (fromMaybe (ServerError "Request aborted") <$>) $
 431             lift $ withImpatience $ makeRequest saddr $ ClientRequest protocolVersion auth act
 432
 433 curServerActionAsyncThenInvalidate :: UIMonad uiM => Protocol.Action -> Maybe Codenames -> MainStateT uiM ()
 434 curServerActionAsyncThenInvalidate act names = do
 435     saddr <- gets curServer
 436     auth <- gets curAuth
 437     flag <- gets newAsync
 438     count <- gets asyncCount
 439     errtvar <- gets asyncError
 440     invaltvar <- gets asyncInvalidate
 441     cOnly <- gets cacheOnly
 442     void $ liftIO $ forkIO $ do
 443         atomically $ modifyTVar count (+1)
 444         resp <- if cOnly then return $ ServerError "Can't contact server in cache-only mode"
 445                 else makeRequest saddr $ ClientRequest protocolVersion auth act
 446         case resp of
 447             ServerError err -> atomically $ writeTVar errtvar $ Just err
 448             _               -> atomically $ writeTVar invaltvar names
 449         atomically $ writeTVar flag True
 450         atomically $ modifyTVar count (+(-1))
 451
 452 checkAsync :: UIMonad uiM => MainStateT uiM ()
 453 checkAsync = do
 454     void.runMaybeT $ do
 455         errtvar <- lift $ gets asyncError
 456         err <- MaybeT $ liftIO $ atomically $
 457                 readTVar errtvar <* writeTVar errtvar Nothing
 458         lift.lift $ drawError err
 459     void.runMaybeT $ do
 460         invaltvar <- lift $ gets asyncInvalidate
 461         names <- MaybeT $ liftIO $ atomically $
 462                 readTVar invaltvar <* writeTVar invaltvar Nothing
 463         lift $ invalidateUInfos names >> refreshUInfoUI
 464
 465 getRecordCachedFromCur :: UIMonad uiM => Bool -> Record -> MainStateT uiM (TVar FetchedRecord)
 466 getRecordCachedFromCur flagIt rec = do
 467     saddr <- gets curServer
 468     auth <- gets curAuth
 469     cOnly <- gets cacheOnly
 470     flag <- gets newAsync
 471     liftIO $ getRecordCached saddr auth
 472         (if flagIt then Just flag else Nothing) cOnly rec
 473
 474 getFreshRecBlocking :: UIMonad uiM => Record -> MainStateT uiM (Maybe RecordContents)
 475 getFreshRecBlocking rec = do
 476     tvar <- getRecordCachedFromCur False rec
 477     cOnly <- gets cacheOnly
 478     mfetched <- lift $ withImpatience $ atomically $ do
 479         fetched@(FetchedRecord fresh _ _) <- readTVar tvar
 480         check $ fresh || cOnly
 481         return fetched
 482     case mfetched of
 483         Nothing -> lift (drawError "Request aborted") >> return Nothing
 484         Just fetched ->
 485             case fetchError fetched of
 486                 Nothing  -> return $ fetchedRC fetched
 487                 Just err -> lift (drawError err) >> return Nothing
 488
 489 -- |indicate waiting for server, and allow cancellation
 490 withImpatience :: UIMonad uiM => IO a -> uiM (Maybe a)
 491 withImpatience m = do
 492     finishedTV <- liftIO $ newTVarIO Nothing
 493     id <- liftIO $ forkIO $ m >>= atomically . writeTVar finishedTV . Just
 494     let waitImpatiently ticks = do
 495             finished <- liftIO $ readTVarIO finishedTV
 496             if isJust finished
 497                 then return finished
 498                 else do
 499                     abort <- impatience ticks
 500                     if abort
 501                         then liftIO $ killThread id >> return Nothing
 502                         else waitImpatiently $ ticks+1
 503     waitImpatiently 0
 504
 505
 506 getRelScore :: (UIMonad uiM) => Codename -> MainStateT uiM (Maybe Int)
 507 getRelScore name = (fst<$>) <$> getRelScoreDetails name
 508 getRelScoreDetails name = runMaybeT $ do
 509     ourName <- mgetOurName
 510     guard $ ourName /= name
 511     uinfo <- mgetUInfo name
 512     ourUInfo <- mgetUInfo ourName
 513     -- Note that this is inverted when communicated in the interface: we show
 514     -- the number accessed rather than the number unaccessed.
 515     let (pos,neg) = (countUnaccessedBy ourUInfo name, countUnaccessedBy uinfo ourName)
 516     return (pos-neg,(pos,neg))
 517     where
 518         countUnaccessedBy ui name = length $ filter isNothing $ getAccessInfo ui name
 519
 520 accessedAL :: (UIMonad uiM) => ActiveLock -> MainStateT uiM Bool
 521 accessedAL (ActiveLock name idx) = (isJust <$>) $ runMaybeT $ do
 522     ourName <- mgetOurName
 523     guard $ ourName /= name
 524     uinfo <- mgetUInfo name
 525     guard $ isJust $ getAccessInfo uinfo ourName !! idx
 526
 527 getNotesReadOn :: UIMonad uiM => LockInfo -> MainStateT uiM [NoteInfo]
 528 getNotesReadOn lockinfo = (fromMaybe [] <$>) $ runMaybeT $ do
 529     ourName <- mgetOurName
 530     ourUInfo <- mgetUInfo ourName
 531     return $ filter (\n -> isNothing (noteBehind n)
 532             || n `elem` notesRead ourUInfo) $ lockSolutions lockinfo
 533
 534 testAuth :: UIMonad uiM => MainStateT uiM ()
 535 testAuth = isJust <$> gets curAuth >>? do
 536     resp <- curServerAction Authenticate
 537     case resp of
 538         ServerMessage msg -> lift $ drawMessage $ "Server: " ++ msg
 539         ServerError err -> do
 540             lift $ drawMessage err
 541             modify $ \ms -> ms {curAuth = Nothing}
 542         _ -> return ()
 543
 544 initiationHelpText :: [String]
 545 initiationHelpText =
 546     [ "Suddenly surrounded by hooded figures in your locked room."
 547     , "Gently abducted, now wordlessly released into this dingy hole."
 548     , ""
 549     , "Some disused dungeon, a honeycomb of cells separated by sturdy gates."
 550     , "From the far end, light filters through the sequential barriers."
 551     , "Freedom?"
 552     , "The gate mechanisms are foolishly accessible, merely locked."
 553     , "Lucky that they neglected to strip you of your lockpicks."
 554     , "Lucky, and odd..." ]
 555
 556 metagameHelpText :: [String]
 557 metagameHelpText =
 558     [ "By ruthlessly guarded secret arrangement, the council's agents can pick any lock in the city."
 559     , "A secret guild produces the necessary locks - apparently secure, but with fatal hidden flaws."
 560     , "A ritual game is played to determine the best designs."
 561     , "To master it, you must build locks which can be picked only by one who knows the secret,"
 562     , "and you must discover the secret flaws in the locks designed by your colleagues."
 563     , ""
 564     , "You may put forward up to three prototype locks. They will guard the secrets you discover."
 565     , "If you pick a colleague's lock, the rules require that a note is written on your solution."
 566     , "A note proves that a solution was found, while revealing no more details than necessary."
 567     , "To declare your solution, you must secure your note behind a lock of your own."
 568     , "If you are able to unlock a lock, you automatically read all the notes it secures."
 569     , "Reading three notes on a lock suffices to piece together the secrets of unlocking it."
 570     , ""
 571     , "The game judges players relative to each of their peers. There are no absolute rankings."
 572     , "You win a point of esteem against another player for one of their locks"
 573     , "if you have declared a solution to it, or if you have read three notes on it."
 574     , "You also win a point for each empty lock slot if you can unlock all full slots."
 575     , "Relative esteem is the points you win minus the points they win; +3 is best, -3 is worst."
 576     , ""
 577     , "If the secrets to one of your locks become widely disseminated, you may wish to replace it."
 578     , "Once replaced, a lock is \"retired\", and the notes it secured are read by everyone."
 579     ]
 580
 581 initiationCompleteText :: Int -> [String]
 582 initiationCompleteText 1 =
 583     [ "Emerging from the last of the cells to what you imagined might be freedom,"
 584     , "you find yourself in a lamplit room with a hooded figure."
 585     , ""
 586     , "\"So. You did acquire some skills in your former life. Enough for these toys, at least."
 587     , "Whether you have the devious creativity to improve on their designs... remains to be seen."
 588     , ""
 589     , "\"Nonetheless, we welcome you to our number. As for what exactly it is that you are joining..."
 590     , "no doubt you believe you have it all worked out already. Still, allow me to explain.\""
 591     , ""
 592     , "After a pause to examine your face, and a soft chuckle, the figure continues."
 593     , "\"Ah, you thought this would be the end? No, no, this is very much the beginning.\""
 594     ]
 595 initiationCompleteText 2 =
 596     [ "\"As you fatefully determined, every lock permitted in the city has a fatal hidden flaw."
 597     , "Those whose duties require it are entrusted with the secrets required to pick these locks."
 598     , "As for those who unauthorisedly discover, and even try to profit from, said secrets..."
 599     , "you come to us."
 600     , ""
 601     , "\"Our task, you see, is to produce the superficially secure locks necessary for this system:"
 602     , "locks pickable with minimal tools, but with this fact obscured by their mechanical complexity."
 603     , ""
 604     , "\"To push the designs to ever new extremes of intricacy, we run a ritual game."
 605     , "Today, we welcome you as its newest player."
 606     ]
 607 initiationCompleteText 3 =
 608     [ "\"The idea is simple."
 609     , "We each design locks, and we each attempt to solve the locks designed by the others."
 610     , ""
 611     , "\"You may put forward up to three prototype locks."
 612     , "They will guard the secrets you discover: when you pick a colleague's lock,"
 613     , "you may declare the fact by placing a note on its solution behind one of your locks."
 614     , "As long as the owner of the lock you picked is unable to read your note,"
 615     , "you score a point against them. This is now your aim in life."
 616     , ""
 617     , "\"If you find a lock too difficult or trivial to pick yourself,"
 618     , "you may find that reading other players' notes on it will lead you to a solution."
 619     , ""
 620     , "\"The finer details of the rules can wait. Your first task is to name yourself."
 621     , "For reasons which should be clear, our members are known exclusively by pseudonyms;"
 622     , "by tradition, these codenames are triplets of letters or symbols."
 623     , ""
 624     , "\"Go, choose your codename, have it entered in the registry."
 625     , "Then, you should begin work on your first lock."
 626     , "With a new initiate always comes the hope of some genuinely new challenge..."
 627     , "Perhaps you already have ideas?\""
 628     ]
 629 initiationCompleteText _ = []
 630
 631
 632 firstEditHelpText :: [String]
 633 firstEditHelpText =
 634     [ "Design a lock to protect your secrets."
 635     , ""
 636     , "It must be possible to pick your lock by pulling a sprung bolt from the hole in the top-right,"
 637     , "but you should place blocks, springs, pivots, and balls to make this as difficult as possible."
 638     , ""
 639     , "Place pieces with keyboard or mouse. Springs must be set next to blocks, and arms next to pivots."
 640     , "Repeatedly placing a piece in the same hex cycles through ways it can relate to its neighbours."
 641     , ""
 642     , "Use Test to prove that your lock is solvable, or Play to alternate between testing and editing."
 643     , "When you are done, Write your lock, then Quit from editing and Place your lock in a slot."
 644     , "You will then be able to Declare locks you solve, and others will attempt to solve your lock."
 645     , ""
 646     , "Your first lock is unlikely to stand for long against your more experienced peers;"
 647     , "examine their solutions to spot flaws in your design, and study their locks for ideas."
 648     ]