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