-- This file is part of Intricacy -- Copyright (C) 2013 Martin Bays -- -- 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, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/. {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -cpp #-} module SDLUIMInstance () where import Graphics.UI.SDL hiding (flip) import qualified Graphics.UI.SDL as SDL import qualified Graphics.UI.SDL.TTF as TTF import Control.Concurrent.STM import Control.Applicative hiding ((<*>)) import System.Timeout import qualified Data.Map as Map import Data.Map (Map) import qualified Data.Vector as Vector import Data.Maybe import Control.Concurrent (threadDelay) import Control.Monad.State import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Data.Word import Data.Array import Data.List import Data.Function (on) import Data.Foldable (for_) --import Debug.Trace (traceShow) import MainState import Hex import Command import GameStateTypes import Lock import KeyBindings import Mundanities import Metagame import Protocol import Cache import Database import ServerAddr import Util import InputMode import SDLRender import SDLUI instance UIMonad (StateT UIState IO) where runUI m = evalStateT m nullUIState drawMainState = do lift $ clearButtons >> clearSelectables s <- get let mode = ms2im s lift $ waitFrame drawMainState' s lift . drawTitle =<< getTitle lift $ do drawButtons mode drawUIOptionButtons mode drawMsgLine drawShortMouseHelp mode refresh where drawMainState' (PlayState { psCurrentState=st, psLastAlerts=alerts, wrenchSelected=wsel }) = do canUndo <- null <$> gets psGameStateMoveStack canRedo <- null <$> gets psUndoneStack lift $ do let selTools = [ idx | (idx, PlacedPiece pos p) <- enumVec $ placedPieces st , or [wsel && isWrench p, not wsel && isHook p] ] drawMainGameState selTools False alerts st registerUndoButtons canUndo canRedo drawMainState' (ReplayState { rsCurrentState=st, rsLastAlerts=alerts } ) = do canUndo <- null <$> gets rsGameStateMoveStack canRedo <- null <$> gets rsMoveStack lift $ do drawMainGameState [] False alerts st registerUndoButtons canUndo canRedo renderToMain $ drawCursorAt Nothing drawMainState' (EditState { esGameStateStack=(st:sts), esUndoneStack=undostack, selectedPiece=selPiece, selectedPos=selPos }) = lift $ do drawMainGameState (maybeToList selPiece) True [] st renderToMain $ drawCursorAt $ if isNothing selPiece then Just selPos else Nothing registerUndoButtons (null sts) (null undostack) when (isJust selPiece) $ mapM_ registerButtonGroup [ singleButton (periphery 2 <+> 3<*>hw<+>hv) CmdDelete 0 [("delete",hu<+>neg hw)] , singleButton (periphery 2 <+> 3<*>hw) CmdMerge 1 [("merge",hu<+>neg hw)] ] sequence_ [ when (null . filter (pred . placedPiece) . Vector.toList $ placedPieces st) $ registerButton (periphery 0 <+> d) cmd 2 [("place",hu<+>neg hw),(tool,hu<+>neg hv)] | (pred,tool,cmd,d) <- [ (isWrench, "wrench", CmdTile $ WrenchTile zero, 3<*>hu <+> hv), (isHook, "hook", CmdTile $ HookTile, 3<*>hu <+> 2<*>hv)] ] drawPaintButtons drawMainState' (MetaState saddr undecls cOnly auth names _ _ _ rnamestvar _ _ mretired path mlock offset) = do let ourName = authUser <$> auth let selName = listToMaybe names let home = isJust ourName && ourName == selName lift $ renderToMain $ (erase >> drawCursorAt Nothing) lift $ do smallFont <- gets dispFontSmall renderToMain $ withFont smallFont $ renderStrColAtLeft messageCol (saddrStr saddr ++ if cOnly then " (cache only)" else "") $ serverPos <+> hu when (length names > 1) $ lift $ registerButton (codenamePos <+> neg hu <+> 2<*>hw) CmdBackCodename 0 [("back",3<*>hw)] runMaybeT $ do name <- MaybeT (return selName) FetchedRecord fresh err muirc <- lift $ getUInfoFetched 300 name lift $ do lift $ do unless fresh $ do smallFont <- gets dispFontSmall renderToMain $ withFont smallFont $ renderStrColAtLeft (opaquify $ dim errorCol) "(stale)" $ serverWaitPos maybe (return ()) (setMsgLineNoRefresh errorCol) err when (fresh && (isNothing ourName || isNothing muirc || home)) $ let reg = isNothing muirc && isNothing ourName in registerButton (codenamePos <+> 2<*>hu) (if reg then CmdRegister else CmdAuth) (if isNothing ourName then 2 else 0) [(if reg then "reg" else "auth", 3<*>hw)] (if isJust muirc then drawName else drawNullName) name codenamePos lift $ registerSelectable codenamePos 0 (SelSelectedCodeName name) drawRelScore name (codenamePos<+>hu) when (isJust muirc) $ lift $ registerButton retiredPos CmdShowRetired 5 [("retired",hu<+>neg hw)] for_ muirc $ \(RCUserInfo (_,uinfo)) -> case mretired of Just retired -> do fillArea locksPos (map (locksPos<+>) $ zero:[rotate n $ 4<*>hu<->4<*>hw | n <- [0,2,3,5]]) [ \pos -> (lift $ registerSelectable pos 1 (SelOldLock ls)) >> drawOldLock ls pos | ls <- retired ] lift $ registerButton (retiredPos <+> hv) (CmdPlayLockSpec Nothing) 1 [("play",hu<+>neg hw),("no.",hu<+>neg hv)] Nothing -> do sequence_ [ drawLockInfo (ActiveLock (codename uinfo) i) mlockinfo | (i,mlockinfo) <- assocs $ userLocks uinfo ] when (isJust $ msum $ elems $ userLocks uinfo) $ lift $ do registerButton interactButtonsPos (CmdSolve Nothing) 2 [("solve",hu<+>neg hw),("lock",hu<+>neg hv)] registerButton (interactButtonsPos<+>hw) (CmdViewSolution Nothing) 1 [("view",hu<+>neg hw),("soln",hu<+>neg hv)] when home $ do lift.renderToMain $ renderStrColAt messageCol "Home" (codenamePos<+>hw<+>neg hv) unless (null undecls) $ do lift.renderToMain $ renderStrColAtLeft messageCol "Undeclared:" (undeclsPos<+>2<*>hv<+>neg hu) lift $ registerButton (undeclsPos<+>hw<+>neg hu) (CmdDeclare Nothing) 2 [("decl",hv<+>4<*>neg hu),("soln",hw<+>4<*>neg hu)] fillArea (undeclsPos<+>hv) (map (undeclsPos<+>) $ hexDisc 1 ++ [hu<+>neg hw, neg hu<+>hv]) [ \pos -> (lift $ registerSelectable pos 0 (SelUndeclared undecl)) >> drawActiveLock al pos | undecl@(Undeclared _ _ al) <- undecls ] lift $ do maybe (drawEmptyMiniLock miniLockPos) (\lock -> drawMiniLock lock miniLockPos) (fst<$>mlock) registerSelectable miniLockPos 1 SelOurLock registerButton (miniLockPos<+>3<*>neg hw<+>2<*>hu) CmdEdit 2 [("edit",hu<+>neg hw),("lock",hu<+>neg hv)] registerButton lockLinePos CmdSelectLock 1 [] lift $ when (not $ null path) $ do renderToMain $ renderStrColAtLeft messageCol (take 16 path) $ lockLinePos <+> hu registerSelectable (lockLinePos <+> 2<*>hu) 1 SelLockPath sequence_ [ registerButton (miniLockPos <+> 2<*>neg hv <+> 2<*>hu <+> dv) cmd 1 [(dirText,hu<+>neg hw),("lock",hu<+>neg hv)] | (dv,cmd,dirText) <- [(zero,CmdPrevLock,"prev"),(neg hw,CmdNextLock,"next")] ] let tested = maybe False (isJust.snd) mlock when (isJust mlock && home) $ lift $ registerButton (miniLockPos<+>2<*>neg hw<+>3<*>hu) (CmdPlaceLock Nothing) (if tested then 2 else 1) [("place",hu<+>neg hw),("lock",hu<+>neg hv)] rnames <- liftIO $ atomically $ readTVar rnamestvar unless (null rnames) $ fillArea randomNamesPos (map (randomNamesPos<+>) $ hexDisc 2) [ \pos -> (lift $ registerSelectable pos 0 (SelRandom name)) >> drawName name pos | name <- rnames ] when (ourName /= selName) $ void $ runMaybeT $ do when (isJust ourName) $ lift.lift $ registerButton (codenamePos <+> hw <+> neg hv) CmdHome 1 [("home",3<*>hw)] sel <- liftMaybe selName us <- liftMaybe ourName ourUInfo <- mgetUInfo us selUInfo <- mgetUInfo sel let accesses = map (uncurry getAccessInfo) [(ourUInfo,sel),(selUInfo,us)] let posLeft = scoresPos <+> hw <+> neg hu let posRight = posLeft <+> 3<*>hu lift $ do drawRelScore sel scoresPos fillArea (posLeft<+>hw) (map (posLeft<+>) [zero,hw,neg hv]) [ \pos -> (lift $ registerSelectable pos 0 (SelScoreLock (Just sel) accessed $ ActiveLock us i)) >> drawNameWithCharAndCol us white (lockIndexChar i) col pos | i <- [0..2] , let accessed = accesses !! 0 !! i , let col | accessed == Just AccessedPub = dim pubColour | isJust accessed = dim $ scoreColour $ -3 | otherwise = obscure $ scoreColour 3 ] fillArea (posRight<+>hw) (map (posRight<+>) [zero,hw,neg hv]) [ \pos -> (lift $ registerSelectable pos 0 (SelScoreLock Nothing accessed $ ActiveLock sel i)) >> drawNameWithCharAndCol sel white (lockIndexChar i) col pos | i <- [0..2] , let accessed = accesses !! 1 !! i , let col | accessed == Just AccessedPub = obscure pubColour | isJust accessed = dim $ scoreColour $ 3 | otherwise = obscure $ scoreColour $ -3 ] (usUnacc,selUnacc) <- MaybeT $ (snd<$>) <$> getRelScoreDetails sel lift.lift.renderToMain $ sequence_ [renderStrColAt (scoreColour score) (sign:show (abs score)) pos | (sign,score,pos) <- [ ('-',usUnacc-3,posLeft<+>neg hv<+>hw) , ('+',3-selUnacc,posRight<+>neg hv<+>hw) ] ] drawMainState' _ = return () drawMessage = say drawPrompt full s = say $ s ++ (if full then "" else "_") endPrompt = say "" drawError = sayError reportAlerts = playAlertSounds getChRaw = do events <- liftIO getEvents if not.null $ [ True | MouseButtonDown _ _ ButtonRight <- events ] then return Nothing else maybe getChRaw (return.Just) $ listToMaybe $ [ ch | KeyDown (Keysym _ _ ch) <- events , ch /= '\0' ] setUIBinding mode cmd ch = modify $ \s -> s { uiKeyBindings = Map.insertWith (\[bdg] -> \bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs) mode [(ch,cmd)] $ uiKeyBindings s } getUIBinding mode cmd = ($cmd) <$> getBindingStr mode initUI = liftM isJust (runMaybeT $ do catchIOErrorMT $ SDL.init [InitVideo] catchIOErrorMT TTF.init lift $ do readUIConfigFile initVideo 0 0 liftIO $ setCaption "intricacy" "intricacy" w <- gets scrWidth h <- gets scrHeight liftIO $ warpMouse (fi $ w`div`2) (fi $ h`div`2) renderToMain $ erase liftIO $ enableUnicode True liftIO $ enableKeyRepeat 250 30 initAudio readBindings ) where catchIOErrorMT m = MaybeT $ liftIO $ catchIO (m >> return (Just ())) (\_ -> return Nothing) endUI = do writeUIConfigFile writeBindings liftIO $ quit unblockInput = return $ pushEvent VideoExpose suspend = return () redraw = return () getDrawImpatience = do curState <- get let pos = serverWaitPos return $ \ticks -> void $ flip runStateT curState $ do when (ticks>2) $ renderToMain $ do mapM (drawAtRel (FilledHexGlyph $ bright black)) [ pos <+> i<*>hu | i <- [0..3] ] withFont (dispFontSmall curState) $ renderStrColAtLeft errorCol ("waiting..."++replicate (ticks`mod`3) '.') $ pos refresh warpPointer pos = do (scrCentre, size) <- getGeom centre <- gets dispCentre let SVec x y = hexVec2SVec size (pos<->centre) <+> scrCentre liftIO $ warpMouse (fi x) (fi y) lbp <- gets leftButtonDown rbp <- gets rightButtonDown let [lbp',rbp'] = fmap (fmap (\_ -> (pos<->centre))) [lbp,rbp] modify $ \s -> s {leftButtonDown = lbp', rightButtonDown = rbp'} setYNButtons = do clearButtons registerButton (periphery 5 <+> hw) (CmdInputChar 'Y') 2 [] registerButton (periphery 5 <+> neg hv) (CmdInputChar 'N') 0 [] drawButtons IMTextInput refresh toggleColourMode = modify $ \s -> s {uiOptions = (uiOptions s){ useFiveColouring = not $ useFiveColouring $ uiOptions s}} getInput mode = do fps <- gets fps events <- liftIO $ nubMouseMotions <$> getEventsTimeout (10^6`div`fps) (cmds,uiChanged) <- if null events then return ([],False) else do oldUIState <- get cmds <- concat <$> mapM processEvent events setPaintFromCmds cmds newUIState <- get return (cmds,uistatesMayVisiblyDiffer oldUIState newUIState) now <- liftIO getTicks animFrameReady <- maybe False ( gets nextAnimFrameAt return $ cmds ++ if uiChanged || animFrameReady then [CmdRefresh] else [] where nubMouseMotions evs = -- drop all but last mouse motion event let nubMouseMotions' False (mm@(MouseMotion {}):evs) = mm:(nubMouseMotions' True evs) nubMouseMotions' True (mm@(MouseMotion {}):evs) = nubMouseMotions' True evs nubMouseMotions' b (ev:evs) = ev:(nubMouseMotions' b evs) nubMouseMotions' _ [] = [] in reverse $ nubMouseMotions' False $ reverse evs setPaintFromCmds cmds = sequence_ [ modify $ \s -> s { paintTileIndex = pti } | (pti,pt) <- zip [0..] paintTiles , cmd <- cmds , (isNothing pt && cmd == CmdDelete) || (isJust $ do pt' <- pt CmdTile t <- Just cmd guard $ ((==)`on`tileType) t pt') ] uistatesMayVisiblyDiffer uis1 uis2 = uis1 { mousePos = (zero,False), lastFrameTicks=0 } /= uis2 {mousePos = (zero,False), lastFrameTicks=0 } processEvent (KeyDown (Keysym _ _ ch)) = case mode of IMTextInput -> return [CmdInputChar ch] _ -> do setting <- gets settingBinding if isJust setting && ch /= '\0' then do modify $ \s -> s {settingBinding = Nothing} when (ch /= '\ESC') $ setUIBinding mode (fromJust setting) ch return [] else do uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings let mCmd = lookup ch $ uibdgs ++ bindings mode return $ maybeToList mCmd processEvent (MouseMotion {}) = do (oldMPos,_) <- gets mousePos (pos@(mPos,_),(sx,sy,sz)) <- getMousePos updateMousePos mode pos lbp <- gets leftButtonDown rbp <- gets rightButtonDown centre <- gets dispCentre let drag :: Maybe HexVec -> Maybe Command drag bp = do fromPos@(HexVec x y z) <- bp -- check we've dragged at least a full hex's distance: guard $ not.all (\(a,b) -> abs ((fi a) - b) < 1.0) $ [(x,sx),(y,sy),(z,sz)] let dir = hexVec2HexDirOrZero $ mPos <-> fromPos guard $ dir /= zero return $ CmdDrag (fromPos<+>centre) dir case mode of IMEdit -> case drag rbp of Just cmd -> return [cmd] Nothing -> if mPos /= oldMPos then do pti <- getEffPaintTileIndex return $ [ CmdMoveTo $ mPos <+> centre ] ++ (if isJust lbp then [ CmdPaintFromTo (paintTiles!!pti) (oldMPos<+>centre) (mPos<+>centre) ] else []) else return [] IMPlay -> return $ maybeToList $ msum $ map drag [lbp, rbp] _ -> return [] where mouseFromTo from to = do let dir = hexVec2HexDirOrZero $ to <-> from if dir /= zero then (CmdDir WHSSelected dir:) <$> mouseFromTo (from <+> dir) to else return [] processEvent (MouseButtonDown _ _ ButtonLeft) = do pos@(mPos,central) <- gets mousePos modify $ \s -> s { leftButtonDown = Just mPos } rb <- isJust <$> gets rightButtonDown mcmd <- cmdAtMousePos pos mode (Just False) let hotspotAction = listToMaybe $ map (\cmd -> return [cmd]) (maybeToList mcmd) ++ [ (modify $ \s -> s {paintTileIndex = i}) >> return [] | i <- take (length paintTiles) [0..] , mPos == paintButtonStart <+> i<*>hv ] ++ [ toggleUIOption uiOB1 >> updateHoverStr mode >> return [] | mPos == uiOptPos uiOB1 ] ++ [ toggleUIOption uiOB2 >> updateHoverStr mode >> return [] | mPos == uiOptPos uiOB2 ] ++ [ toggleUIOption uiOB3 >> updateHoverStr mode >> return [] | mPos == uiOptPos uiOB3 ] ++ [ toggleUIOption uiOB4 >> updateHoverStr mode >> return [] | mPos == uiOptPos uiOB4 ] ++ [ toggleUIOption uiOB5 >> updateHoverStr mode >> return [] | mPos == uiOptPos uiOB5 ] #ifdef SOUND ++ [ toggleUIOption uiOB6 >> updateHoverStr mode >> return [] | mPos == uiOptPos uiOB6 ] #endif if rb then return [ CmdWait ] else flip fromMaybe hotspotAction $ case mode of IMEdit -> do pti <- getEffPaintTileIndex return $ [ drawCmd (paintTiles!!pti) False ] IMPlay -> do centre <- gets dispCentre return $ [ CmdManipulateToolAt $ mPos <+> centre ] _ -> return [] processEvent (MouseButtonUp _ _ ButtonLeft) = do modify $ \s -> s { leftButtonDown = Nothing } return [] processEvent (MouseButtonDown _ _ ButtonRight) = do pos@(mPos,_) <- gets mousePos modify $ \s -> s { rightButtonDown = Just mPos } lb <- isJust <$> gets leftButtonDown if lb then return [ CmdWait ] else (fromMaybe [] <$>) $ runMaybeT $ msum [ do cmd <- MaybeT $ cmdAtMousePos pos mode Nothing guard $ mode /= IMTextInput -- modify $ \s -> s { settingBinding = Just cmd } return [ CmdBind $ Just cmd ] , do cmd <- MaybeT $ cmdAtMousePos pos mode (Just True) return [cmd] , case mode of IMPlay -> return [ CmdClear, CmdWait ] _ -> return [ CmdClear, CmdSelect ] ] processEvent (MouseButtonUp _ _ ButtonRight) = do modify $ \s -> s { rightButtonDown = Nothing } return [ CmdUnselect ] processEvent (MouseButtonDown _ _ ButtonWheelUp) = doWheel 1 processEvent (MouseButtonDown _ _ ButtonWheelDown) = doWheel $ -1 processEvent (MouseButtonDown _ _ ButtonMiddle) = do (mPos,_) <- gets mousePos modify $ \s -> s { middleButtonDown = Just mPos } rb <- isJust <$> gets rightButtonDown return $ if rb then [ CmdDelete ] else [] processEvent (MouseButtonUp _ _ ButtonMiddle) = do modify $ \s -> s { middleButtonDown = Nothing } return [] processEvent (VideoResize w h) = do initVideo w h return [ CmdRedraw ] processEvent VideoExpose = return [ CmdRedraw ] processEvent Quit = return [ CmdForceQuit ] processEvent _ = return [] doWheel dw = do rb <- isJust <$> gets rightButtonDown mb <- isJust <$> gets middleButtonDown if ((rb || mb || mode == IMReplay) && mode /= IMEdit) || (mb && mode == IMEdit) then return [ if dw == 1 then CmdUndo else CmdRedo ] else if mode /= IMEdit || rb then return [ CmdRotate WHSSelected dw ] else do modify $ \s -> s { paintTileIndex = (paintTileIndex s + dw) `mod` (length paintTiles) } return [] drawCmd mt True = CmdPaint mt drawCmd (Just t) False = CmdTile t drawCmd Nothing _ = CmdDelete getMousePos :: UIM ((HexVec,Bool),(Double,Double,Double)) getMousePos = do (scrCentre, size) <- getGeom (x,y,_) <- lift getMouseState let sv = (SVec (fi x) (fi y)) <+> neg scrCentre let mPos@(HexVec x y z) = sVec2HexVec size sv let (sx,sy,sz) = sVec2dHV size sv let isCentral = all (\(a,b) -> abs ((fi a) - b) < 0.5) $ [(x,sx),(y,sy),(z,sz)] return ((mPos,isCentral),(sx,sy,sz)) updateMousePos mode newPos = do oldPos <- gets mousePos when (newPos /= oldPos) $ do modify $ \ds -> ds { mousePos = newPos } updateHoverStr mode showHelp mode HelpPageInput = do bdgs <- nub <$> getBindings mode smallFont <- gets dispFontSmall renderToMain $ do erase let bdgWidth = (screenWidthHexes-6) `div` 3 showKeys chs = intercalate "/" (map showKeyFriendly chs) maxkeyslen = maximum . (0:) $ map (length.showKeys.map fst) $ groupBy ((==) `on` snd) bdgs extraHelpStrs = ["Mouse commands:", "Right-click on a button to set a keybinding;"] ++ case mode of IMPlay -> ["Click on tool to select, drag to move;", "Click by tool to move; right-click to wait;", "Scroll wheel to rotate hook;", "Scroll wheel with right button held down to undo/redo."] IMEdit -> ["Left-click to draw selected; scroll to change selection;", "Right-click on piece to select, drag to move;", "While holding right-click: left-click to advance time, middle-click to delete;", "Scroll wheel to rotate selected piece; scroll wheel while held down to undo/redo."] IMReplay -> ["Scroll wheel with right button held down to undo/redo."] IMMeta -> ["Left-clicking on something does most obvious thing;" , "Right-clicking does second-most obvious thing." , "" , "Basic game instructions:" , "Choose [C]odename, then [R]egister it;" , "select other players, and [S]olve their locks;" , "go [H]ome, then [E]dit and [P]lace a lock of your own;" , "you can then [D]eclare your solutions." , "Make other players green by solving their locks and not letting them solve yours."] renderStrColAt messageCol "Keybindings:" $ (screenHeightHexes`div`4)<*>(hv<+>neg hw) let keybindingsHeight = screenHeightHexes - (3 + length extraHelpStrs) sequence_ [ with $ renderStrColAtLeft messageCol ( keysStr ++ ": " ++ desc ) $ (x*bdgWidth-(screenWidthHexes-6)`div`2)<*>hu <+> neg hv <+> (screenHeightHexes`div`4 - y`div`2)<*>(hv<+>neg hw) <+> (y`mod`2)<*>hw | ((keysStr,with,desc),(x,y)) <- zip [(keysStr,with,desc) | group <- groupBy ((==) `on` snd) $ sortBy (compare `on` snd) bdgs , let cmd = snd $ head group , let desc = describeCommand cmd , not $ null desc , let chs = map fst group , let keysStr = showKeys chs , let with = if True -- 3*(bdgWidth-1) < length desc + length keysStr + 1 then withFont smallFont else id ] (map (`divMod` keybindingsHeight) [0..]) , (x+1)*bdgWidth < screenWidthHexes] sequence_ [ renderStrColAt messageCol str $ (screenHeightHexes`div`4 - y`div`2)<*>(hv<+>neg hw) <+> hw <+> (y`mod`2)<*>hw | (str,y) <- zip extraHelpStrs [keybindingsHeight..] ] refresh return True showHelp IMMeta HelpPageGame = do renderToMain $ do erase let headPos = (screenHeightHexes`div`4)<*>(hv<+>neg hw) renderStrColAt messageCol "Intricacy" headPos sequence_ [ renderStrColAt messageCol str $ headPos <+> (y`div`2)<*>(hw<+>neg hv) <+> (y`mod`2)<*>hw | (y,str) <- zip [2..] metagameHelpText ] return True showHelp _ _ = return False drawShortMouseHelp mode = do mwhs <- gets $ whsButtons.uiOptions showBT <- showButtonText <$> gets uiOptions when (showBT && isNothing mwhs) $ do let helps = shortMouseHelp mode smallFont <- gets dispFontSmall renderToMain $ withFont smallFont $ sequence_ [ renderStrColAtLeft (dim cyan) help (periphery 3 <+> neg hu <+> (2-n)<*>hv ) | (n,help) <- zip [0..] helps ] where shortMouseHelp IMPlay = [ "LMB: select/move tool" , "LMB+drag: move tool" , "Wheel: turn hook" , "RMB: wait a turn" , "RMB+Wheel: undo/redo" ] shortMouseHelp IMEdit = [ "LMB: paint; Ctrl+LMB: delete" , "Wheel: set paint type" , "RMB: select piece; drag to move" , "RMB+LMB: wait; RMB+MMB: delete piece" , "MMB+Wheel: undo/redo" ] shortMouseHelp IMReplay = [ "Wheel: advance/regress time" ] shortMouseHelp _ = [] -- waitEvent' : copy of SDL.Events.waitEvent, with the timeout increased -- drastically to reduce CPU load when idling. waitEvent' :: IO Event waitEvent' = loop where loop = do pumpEvents event <- pollEvent case event of NoEvent -> threadDelay 10000 >> loop _ -> return event getEvents = do e <- waitEvent' es <- pollEvents return $ e:es getEventsTimeout us = do es <- maybeToList <$> timeout us waitEvent' es' <- pollEvents return $ es++es' pollEvents = do e <- pollEvent case e of NoEvent -> return [] _ -> do es <- pollEvents return $ e:es updateHoverStr :: InputMode -> UIM () updateHoverStr mode = do p@(mPos,isCentral) <- gets mousePos showBT <- showButtonText <$> gets uiOptions hstr <- runMaybeT $ msum [ MaybeT ( cmdAtMousePos p mode Nothing ) >>= lift . describeCommandAndKeys , guard showBT >> MaybeT (helpAtMousePos p mode) , guard (showBT && mode == IMEdit) >> msum [ return $ "set paint mode: " ++ describeCommand (paintTileCmds!!i) | i <- take (length paintTiles) [0..] , mPos == paintButtonStart <+> i<*>hv ] , guard (mPos == uiOptPos uiOB1) >> describeUIOptionButton uiOB1 , guard (mPos == uiOptPos uiOB2) >> describeUIOptionButton uiOB2 , guard (mPos == uiOptPos uiOB3) >> describeUIOptionButton uiOB3 , guard (mPos == uiOptPos uiOB4) >> describeUIOptionButton uiOB4 , guard (mPos == uiOptPos uiOB5) >> describeUIOptionButton uiOB5 #ifdef SOUND , guard (mPos == uiOptPos uiOB6) >> describeUIOptionButton uiOB6 #endif ] modify $ \ds -> ds { hoverStr = hstr } where describeCommandAndKeys :: Command -> UIM String describeCommandAndKeys cmd = do uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings return $ describeCommand cmd ++ " [" ++ concat (intersperse "," (map showKeyFriendly $ findBindings (uibdgs ++ bindings mode) cmd)) ++ "]" fillArea :: HexVec -> [HexVec] -> [HexVec -> MainStateT UIM ()] -> MainStateT UIM () fillArea centre area draws = do offset <- gets listOffset let na = length area listButton cmd = \pos -> lift $ registerButton pos cmd 3 [] draws' = if offset > 0 && length draws > na then listButton CmdPrevPage : drop (max 0 $ min (length draws - (na-1)) (na-1 + (na-2)*(offset-1))) draws else draws selDraws = if length draws' > na then take (na-1) draws' ++ [listButton CmdNextPage] else take na draws' sequence_ $ map (uncurry ($)) $ zip selDraws $ sortBy (compare `on` hexVec2SVec 37) $ take (length selDraws) $ sortBy (compare `on` (hexLen . (<->centre))) area drawOldLock ls pos = void.runMaybeT $ msum [ do lock <- mgetLock ls lift.lift $ drawMiniLock lock pos , lift.lift.renderToMain $ renderStrColAt messageCol (show ls) pos ] drawName name pos = nameCol name >>= drawNameCol name pos drawNullName name pos = drawNameCol name pos $ invisible white drawNameCol name pos col = do lift.renderToMain $ do drawAtRel (playerGlyph col) pos renderStrColAt buttonTextCol name pos drawRelScore name pos = do col <- nameCol name relScore <- getRelScore name flip (maybe (return ())) relScore $ \score -> lift $ do renderToMain $ renderStrColAt col ((if score > 0 then "+" else "") ++ show score) pos registerSelectable pos 0 (SelRelScore score) drawNote note pos = case noteBehind note of Just al -> drawActiveLock al pos Nothing -> drawPublicNote (noteAuthor note) pos drawActiveLock al@(ActiveLock name i) pos = do accessed <- accessedAL al drawNameWithChar name (if accessed then accColour else white) (lockIndexChar i) pos drawPublicNote name = drawNameWithChar name pubColour 'P' drawNameWithChar name charcol char pos = do col <- nameCol name drawNameWithCharAndCol name charcol char col pos drawNameWithCharAndCol name charcol char col pos = do size <- fi.snd <$> lift getGeom let up = SVec 0 $ - (ysize size - size`div`2) let down = SVec 0 $ ysize size smallFont <- lift $ gets dispFontSmall lift.renderToMain $ do drawAtRel (playerGlyph col) pos displaceRender up $ renderStrColAt buttonTextCol name pos displaceRender down $ withFont smallFont $ renderStrColAt charcol [char] pos pubWheelAngle = 5 pubColour = colourWheel pubWheelAngle -- ==purple accColour = cyan nameCol name = do ourName <- (authUser <$>) <$> gets curAuth relScore <- getRelScore name return $ dim $ case relScore of Nothing -> Pixel $ if ourName == Just name then 0xc0c0c000 else 0x80808000 Just score -> scoreColour score scoreColour :: Int -> Pixel scoreColour score = Pixel $ case score of 0 -> 0x80800000 1 -> 0x70a00000 2 -> 0x40c00000 3 -> 0x00ff0000 (-1) -> 0xa0700000 (-2) -> 0xc0400000 (-3) -> 0xff000000 drawLockInfo :: ActiveLock -> Maybe LockInfo -> MainStateT UIM () drawLockInfo al@(ActiveLock name i) Nothing = do let centre = hw<+>neg hv <+> 7*(i-1)<*>hu lift $ drawEmptyMiniLock centre drawNameWithCharAndCol name white (lockIndexChar i) (invisible white) centre ourName <- (authUser <$>) <$> gets curAuth lift $ registerSelectable centre 3 $ SelLockUnset (ourName == Just name) al drawLockInfo al@(ActiveLock name i) (Just lockinfo) = do let centre = locksPos <+> 7*(i-1)<*>hu let accessedByPos = centre <+> 3<*>(hv <+> neg hw) let accessedPos = centre <+> 2<*>(hw <+> neg hv) let notesPos = centre <+> 3<*>(hw <+> neg hv) ourName <- (authUser <$>) <$> gets curAuth runMaybeT $ msum [ do lock <- mgetLock $ lockSpec lockinfo lift.lift $ do drawMiniLock lock centre registerSelectable centre 3 $ SelLock al , lift $ do drawActiveLock al centre lift $ registerSelectable centre 3 $ SelLock al ] size <- snd <$> lift getGeom lift $ do renderToMain $ displaceRender (SVec size 0) $ renderStrColAt (brightish white) "PRIVY" $ accessedByPos <+> hv registerSelectable (accessedByPos <+> hv) 0 SelPrivyHeader registerSelectable (accessedByPos <+> hv <+> hu) 0 SelPrivyHeader if public lockinfo then lift $ do renderToMain $ renderStrColAt pubColour "All" accessedByPos registerSelectable accessedByPos 1 SelPublicLock else if null $ accessedBy lockinfo then lift.renderToMain $ renderStrColAt dimWhiteCol "No-one" accessedByPos else fillArea accessedByPos [ accessedByPos <+> d | j <- [0..2], i <- [-2..3] , i-j > -4, i-j < 3 , let d = j<*>hw <+> i<*>hu ] $ [ \pos -> (lift $ registerSelectable pos 0 (SelSolution note)) >> drawNote note pos | note <- lockSolutions lockinfo ] ++ [ \pos -> (lift $ registerSelectable pos 0 (SelAccessed name)) >> drawName name pos | name <- accessedBy lockinfo \\ map noteAuthor (lockSolutions lockinfo) ] undecls <- gets undeclareds case if isJust $ guard . (|| public lockinfo) . (`elem` map noteAuthor (lockSolutions lockinfo)) =<< ourName then if public lockinfo then Just (pubColour,"Accessed!",AccessedPublic) else Just (accColour, "Solved!",AccessedSolved) else if any (\(Undeclared _ ls _) -> ls == lockSpec lockinfo) undecls then Just (yellow, "Undeclared",AccessedUndeclared) else Nothing of Just (col,str,selstr) -> lift $ do renderToMain $ renderStrColAt col str accessedPos registerSelectable accessedPos 1 (SelAccessedInfo selstr) Nothing -> do read <- take 3 <$> getNotesReadOn lockinfo unless (ourName == Just name) $ do let readPos = accessedPos <+> (-3)<*>hu lift.renderToMain $ renderStrColAt (if length read == 3 then accColour else dimWhiteCol) "Read:" $ readPos when (length read == 3) $ lift $ registerSelectable readPos 0 (SelAccessedInfo AccessedReadNotes) fillArea (accessedPos<+>neg hu) [ accessedPos <+> i<*>hu | i <- [-1..1] ] $ take 3 $ [ \pos -> (lift $ registerSelectable pos 0 (SelReadNote note)) >> drawNote note pos | note <- read ] ++ (repeat $ \pos -> (lift $ registerSelectable pos 0 SelReadNoteSlot >> renderToMain (drawAtRel (HollowGlyph $ dim green) pos))) lift $ do renderToMain $ displaceRender (SVec size 0) $ renderStrColAt (brightish white) "NOTES" $ notesPos <+> hv registerSelectable (notesPos <+> hv) 0 SelNotesHeader registerSelectable (notesPos <+> hv <+> hu) 0 SelNotesHeader if null $ notesSecured lockinfo then lift.renderToMain $ renderStrColAt dimWhiteCol "None" notesPos else fillArea notesPos [ notesPos <+> d | j <- [0..2], i <- [-2..3] , i-j > -4, i-j < 3 , let d = j<*>hw <+> i<*>hu ] [ \pos -> (lift $ registerSelectable pos 0 (SelSecured note)) >> drawActiveLock (noteOn note) pos | note <- notesSecured lockinfo ]