intricacy 0.7.2.3 → 0.8.0
raw patch · 86 files changed
+2569/−2032 lines, 86 filesdep +exceptionsdep +mime-mailsetup-changedbinary-added
Dependencies added: exceptions, mime-mail
Files
- AsciiLock.hs +94/−91
- BUILD +2/−3
- BinaryInstances.hs +37/−38
- BoardColouring.hs +19/−21
- CVec.hs +3/−3
- Cache.hs +26/−26
- Command.hs +17/−15
- CursesRender.hs +24/−11
- CursesUI.hs +101/−72
- CursesUIMInstance.hs +158/−106
- Database.hs +66/−65
- EditGameState.hs +22/−24
- Frame.hs +13/−13
- GameState.hs +51/−53
- GameStateTypes.hs +10/−10
- GraphColouring.hs +9/−9
- Hex.lhs +8/−8
- Init.hs +23/−22
- InputMode.hs +1/−1
- Interact.hs +209/−181
- InteractUtil.hs +45/−47
- Intricacy.hs +7/−7
- KeyBindings.hs +32/−21
- Lock.hs +12/−16
- MainState.hs +257/−167
- Metagame.hs +24/−24
- Mundanities.hs +37/−27
- NEWS +3/−0
- Physics.hs +41/−41
- Protocol.hs +51/−51
- README +12/−39
- SDLGlyph.hs +67/−57
- SDLRender.hs +49/−47
- SDLUI.hs +227/−208
- SDLUIMInstance.hs +394/−354
- Server.hs +93/−91
- ServerAddr.hs +3/−3
- Setup.hs +1/−1
- Util.hs +4/−4
- initiation/BAL.lock +17/−0
- initiation/BAL.text +1/−0
- initiation/CLR.lock +17/−0
- initiation/CLR.text +1/−0
- initiation/CMB.lock +17/−0
- initiation/CMB.text +1/−0
- initiation/COG.lock +17/−0
- initiation/COG.text +1/−0
- initiation/DIV.lock +17/−0
- initiation/DIV.text +1/−0
- initiation/END.lock +17/−0
- initiation/END.text +1/−0
- initiation/GAP.lock +17/−0
- initiation/GAP.text +1/−0
- initiation/HLD.lock +17/−0
- initiation/HLD.text +1/−0
- initiation/ICE.lock +17/−0
- initiation/ICE.text +1/−0
- initiation/ONE.lock +17/−0
- initiation/ONE.text +1/−0
- initiation/PLG.lock +17/−0
- initiation/PLG.text +1/−0
- initiation/RAT.lock +17/−0
- initiation/RAT.text +1/−0
- initiation/REP.lock +17/−0
- initiation/REP.text +1/−0
- initiation/RUN.lock +17/−0
- initiation/RUN.text +1/−0
- initiation/SOK.lock +17/−0
- initiation/SOK.text +1/−0
- initiation/initiation.map +3/−0
- intricacy.cabal +18/−11
- sounds/toolmove-01.ogg binary
- sounds/toolmove-02.ogg binary
- sounds/toolmove-03.ogg binary
- sounds/toolmove-04.ogg binary
- sounds/toolmove-05.ogg binary
- tutorial/07-pivots.lock +0/−11
- tutorial/07-pivots.text +0/−1
- tutorial/07-traps.lock +13/−0
- tutorial/07-traps.text +1/−0
- tutorial/09-pivots.lock +11/−0
- tutorial/09-pivots.text +1/−0
- tutorial/09-traps.lock +0/−13
- tutorial/09-traps.text +0/−1
- tutorial/10-puzzle.lock +0/−17
- tutorial/10-puzzle.text +0/−1
AsciiLock.hs view
@@ -8,29 +8,32 @@ -- 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 TupleSections #-}+ module AsciiLock (lockToAscii, lockOfAscii, stateToAscii , readAsciiLockFile, writeAsciiLockFile, monochromeOTileChar) where -import Data.Function (on)-import Control.Applicative-import Control.Monad-import Control.Arrow ((&&&))-import qualified Data.Map as Map-import Data.Map (Map)-import qualified Data.Vector as Vector-import Data.Maybe-import Data.Traversable as T-import Data.List+import Control.Applicative+import Control.Arrow ((&&&))+import Control.Monad+import Data.Function (on)+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Traversable as T+import qualified Data.Vector as Vector+import Safe (maximumBound) -import Lock-import GameStateTypes-import GameState-import BoardColouring-import Frame-import Hex-import CVec-import Util-import Mundanities+import BoardColouring+import CVec+import Frame+import GameState+import GameStateTypes+import Hex+import Lock+import Mundanities+import Util type AsciiLock = [String]@@ -46,8 +49,9 @@ lockOfAscii :: AsciiLock -> Maybe Lock lockOfAscii lines = do board <- asciiToBoard lines- let size = maximum $ map (hx . (-^origin)) $ Map.keys board+ let size = maximumBound 0 $ hx . (-^origin) <$> Map.keys board frame = BasicFrame size+ guard $ size > 0 st <- asciiBoardState frame board return (frame, st) @@ -55,9 +59,9 @@ boardToAscii colouring board = let asciiBoard :: Map CVec Char asciiBoard = Map.mapKeys (hexVec2CVec . (-^origin))- $ fmap (monochromeOTileChar colouring) board- (miny,maxy) = minmax $ map cy $ Map.keys asciiBoard- (minx,maxx) = minmax $ map cx $ Map.keys asciiBoard+ $ monochromeOTileChar colouring <$> board+ (miny,maxy) = minmax $ cy <$> Map.keys asciiBoard+ (minx,maxx) = minmax $ cx <$> Map.keys asciiBoard asciiBoard' = Map.mapKeys (-^CVec miny minx) asciiBoard in [ [ Map.findWithDefault ' ' (CVec y x) asciiBoard' | x <- [0..(maxx-minx)] ]@@ -70,10 +74,10 @@ | (line,y) <- zip lines [0..] , (ch,x) <- zip line [0..] , ch `notElem` "\t\r\n "]- (miny,maxy) = minmax $ map cy $ Map.keys asciiBoard+ (miny,maxy) = minmax $ cy <$> Map.keys asciiBoard midy = miny+(maxy-miny)`div`2 midline = filter ((==midy).cy) $ Map.keys asciiBoard- (minx,maxx) = minmax $ map cx $ midline+ (minx,maxx) = minmax $ cx <$> midline centre = CVec midy (minx+(maxx-minx)`div`2) in Map.mapKeys ((+^origin) . cVec2HexVec . (-^centre)) <$> T.mapM monoToOTile asciiBoard@@ -83,12 +87,12 @@ let addPreBase st = foldr addpp st (replicate 6 $ PlacedPiece origin $ Block []) addBase st = foldr addBaseOT st $ Map.toList $ Map.filter (isBaseTile.snd) board- isBaseTile (BlockTile _) = True- isBaseTile (PivotTile _) = True- isBaseTile HookTile = True+ isBaseTile (BlockTile _) = True+ isBaseTile (PivotTile _) = True+ isBaseTile HookTile = True isBaseTile (WrenchTile _) = True- isBaseTile (BallTile) = True- isBaseTile _ = False+ isBaseTile BallTile = True+ isBaseTile _ = False addBaseOT :: (HexPos,(PieceIdx,Tile)) -> GameState -> GameState addBaseOT (pos,(o,BlockTile [])) = addBlockPos o pos addBaseOT (pos,(-1,t)) = addpp $ PlacedPiece pos $ basePieceOfTile t@@ -101,13 +105,13 @@ componentifyNew st = foldr ((fst.).componentify) st $ filter (/=0) $ ppidxs st -- | we assume that the largest wholly out-of-bounds block is the frame setFrame st = fromMaybe st $ do- (idx,pp) <- listToMaybe $ map fst $ sortBy (flip compare `on` snd)+ (idx,pp) <- listToMaybe $ fst <$> sortBy (flip compare `on` snd) [ ((idx,pp),length vs) | (idx,pp) <- enumVec $ placedPieces st- , Block vs <- [placedPiece pp] , let fp = plPieceFootprint pp , not $ null fp- , all (not.inBounds frame) fp+ , not $ any (inBounds frame) fp+ , Block vs <- [placedPiece pp] ] return $ delPiece idx $ setpp 0 pp st baseSt = setFrame . componentifyNew . addBase . addPreBase $ GameState Vector.empty []@@ -133,8 +137,8 @@ , let pos' = i*^dir+^rpos , Just (_,SpringTile extn _) <- [ Map.lookup pos' board ] ] extnValue Compressed = 4- extnValue Relaxed = 2- extnValue Stretched = 1+ extnValue Relaxed = 2+ extnValue Stretched = 1 Just root = posLocus baseSt rpos Just end = posLocus baseSt epos Just $ flip addConn st $ Connection root end $ Spring dir $ twiceNatLen`div`2@@ -149,7 +153,7 @@ Just 2 -> '"' Just 3 -> '&' Just 4 -> '~'- _ -> '#'+ _ -> '#' monochromeOTileChar _ (_,t) = monochromeTileChar t monochromeTileChar :: Tile -> Char monochromeTileChar (PivotTile _) = 'o'@@ -165,75 +169,74 @@ monochromeTileChar BallTile = 'O' monochromeTileChar (SpringTile extn dir) | dir == hu = case extn of- Stretched -> 's'- Relaxed -> 'S'- Compressed -> '$'+ Stretched -> 's'+ Relaxed -> 'S'+ Compressed -> '$' | dir == hv = case extn of- Stretched -> 'z'- Relaxed -> 'Z'- Compressed -> '5'+ Stretched -> 'z'+ Relaxed -> 'Z'+ Compressed -> '5' | dir == hw = case extn of- Stretched -> '('- Relaxed -> '['- Compressed -> '{'+ Stretched -> '('+ Relaxed -> '['+ Compressed -> '{' | dir == neg hu = case extn of- Stretched -> 'c'- Relaxed -> 'C'- Compressed -> 'D'+ Stretched -> 'c'+ Relaxed -> 'C'+ Compressed -> 'D' | dir == neg hv = case extn of- Stretched -> ')'- Relaxed -> ']'- Compressed -> '}'+ Stretched -> ')'+ Relaxed -> ']'+ Compressed -> '}' | dir == neg hw = case extn of- Stretched -> '1'- Relaxed -> '7'- Compressed -> '9'+ Stretched -> '1'+ Relaxed -> '7'+ Compressed -> '9' monochromeTileChar _ = '?' monoToOTile :: Char -> Maybe OwnedTile-monoToOTile '#' = Just $ (1,BlockTile [])-monoToOTile '%' = Just $ (2,BlockTile [])-monoToOTile '"' = Just $ (3,BlockTile [])-monoToOTile '&' = Just $ (4,BlockTile [])-monoToOTile '~' = Just $ (5,BlockTile [])-monoToOTile ch = ((,) (-1)) <$> monoToTile ch+monoToOTile '#' = Just (1,BlockTile [])+monoToOTile '%' = Just (2,BlockTile [])+monoToOTile '"' = Just (3,BlockTile [])+monoToOTile '&' = Just (4,BlockTile [])+monoToOTile '~' = Just (5,BlockTile [])+monoToOTile ch = (-1,) <$> monoToTile ch monoToTile :: Char -> Maybe Tile-monoToTile 'o' = Just $ PivotTile zero-monoToTile '-' = Just $ ArmTile hu False+monoToTile 'o' = Just $ PivotTile zero+monoToTile '-' = Just $ ArmTile hu False monoToTile '\\' = Just $ ArmTile hv False-monoToTile '/' = Just $ ArmTile hw False-monoToTile '.' = Just $ ArmTile (neg hu) False-monoToTile '`' = Just $ ArmTile (neg hv) False+monoToTile '/' = Just $ ArmTile hw False+monoToTile '.' = Just $ ArmTile (neg hu) False+monoToTile '`' = Just $ ArmTile (neg hv) False monoToTile '\'' = Just $ ArmTile (neg hw) False-monoToTile '@' = Just $ HookTile-monoToTile '*' = Just $ WrenchTile zero-monoToTile 'O' = Just $ BallTile-monoToTile 's' = Just $ SpringTile Stretched hu-monoToTile 'S' = Just $ SpringTile Relaxed hu-monoToTile '$' = Just $ SpringTile Compressed hu-monoToTile 'z' = Just $ SpringTile Stretched hv-monoToTile 'Z' = Just $ SpringTile Relaxed hv-monoToTile '5' = Just $ SpringTile Compressed hv-monoToTile '(' = Just $ SpringTile Stretched hw-monoToTile '[' = Just $ SpringTile Relaxed hw-monoToTile '{' = Just $ SpringTile Compressed hw-monoToTile 'c' = Just $ SpringTile Stretched (neg hu)-monoToTile 'C' = Just $ SpringTile Relaxed (neg hu)-monoToTile 'D' = Just $ SpringTile Compressed (neg hu)-monoToTile ')' = Just $ SpringTile Stretched (neg hv)-monoToTile ']' = Just $ SpringTile Relaxed (neg hv)-monoToTile '}' = Just $ SpringTile Compressed (neg hv)-monoToTile '1' = Just $ SpringTile Stretched (neg hw)-monoToTile '7' = Just $ SpringTile Relaxed (neg hw)-monoToTile '9' = Just $ SpringTile Compressed (neg hw)-monoToTile _ = Nothing+monoToTile '@' = Just HookTile+monoToTile '*' = Just $ WrenchTile zero+monoToTile 'O' = Just BallTile+monoToTile 's' = Just $ SpringTile Stretched hu+monoToTile 'S' = Just $ SpringTile Relaxed hu+monoToTile '$' = Just $ SpringTile Compressed hu+monoToTile 'z' = Just $ SpringTile Stretched hv+monoToTile 'Z' = Just $ SpringTile Relaxed hv+monoToTile '5' = Just $ SpringTile Compressed hv+monoToTile '(' = Just $ SpringTile Stretched hw+monoToTile '[' = Just $ SpringTile Relaxed hw+monoToTile '{' = Just $ SpringTile Compressed hw+monoToTile 'c' = Just $ SpringTile Stretched (neg hu)+monoToTile 'C' = Just $ SpringTile Relaxed (neg hu)+monoToTile 'D' = Just $ SpringTile Compressed (neg hu)+monoToTile ')' = Just $ SpringTile Stretched (neg hv)+monoToTile ']' = Just $ SpringTile Relaxed (neg hv)+monoToTile '}' = Just $ SpringTile Compressed (neg hv)+monoToTile '1' = Just $ SpringTile Stretched (neg hw)+monoToTile '7' = Just $ SpringTile Relaxed (neg hw)+monoToTile '9' = Just $ SpringTile Compressed (neg hw)+monoToTile _ = Nothing minmax :: Ord a => [a] -> (a,a) minmax = minimum &&& maximum readAsciiLockFile :: FilePath -> IO (Maybe Lock, Maybe Solution)-readAsciiLockFile path = flip catchIO (const $ return (Nothing,Nothing)) $ do- lines <- readStrings path- return $ fromMaybe (lockOfAscii lines, Nothing) $ do+readAsciiLockFile path = fromLines <$> readStrings path+ where fromLines lines = fromMaybe (lockOfAscii lines, Nothing) $ do guard $ length lines > 2 let (locklines, [header,solnLine]) = splitAt (length lines - 2) lines guard $ isPrefixOf "Solution:" header@@ -242,5 +245,5 @@ writeAsciiLockFile :: FilePath -> Maybe Solution -> Lock -> IO () writeAsciiLockFile path msoln lock = do writeStrings path $ lockToAscii lock ++ case msoln of- Nothing -> []+ Nothing -> [] Just soln -> ["Solution:", show soln]
BUILD view
@@ -14,8 +14,7 @@ Install ghc, cabal, and development packages for the SDL dependencies above, then run cabal update && cabal install- which should result in various haskell packages being compiled and- installed, probably in ~/.cabal/ . The game can then be run as+ the intricacy binary should then be installed, possibly to ~/.cabal/bin/intricacy Running cabal install as root should install it somewhere global. @@ -25,7 +24,7 @@ To compile the server: cabal install -f Server -f -Game - The server will be installed in+ The server will be installed as e.g. ~/.cabal/bin/intricacy-server The server runs on port 27001 by default. It writes the game database to a directory 'intricacydb' under the directory from which it is run.
BinaryInstances.hs view
@@ -9,15 +9,15 @@ -- along with this program. If not, see http://www.gnu.org/licenses/. module BinaryInstances where-import Data.Binary-import qualified Data.Vector as Vector-import Control.Monad-import Data.Int (Int8)+import Control.Monad+import Data.Binary+import Data.Int (Int8)+import qualified Data.Vector as Vector -import GameStateTypes-import Physics-import Hex-import Frame+import Frame+import GameStateTypes+import Hex+import Physics newtype SmallInt = SmallInt {fromSmallInt :: Int} newtype SmallNat = SmallNat {fromSmallNat :: Int}@@ -25,27 +25,27 @@ put (SmallNat n) = if n < 255 then putWord8 (fromIntegral n) else putWord8 255 >> put n get = do n' <- get :: Get Word8- if n' == 255 then liftM SmallNat get else return $ SmallNat $ fromIntegral n'+ if n' == 255 then SmallNat <$> get else return . SmallNat $ fromIntegral n' instance Binary SmallInt where- put (SmallInt n) = if abs n < 127 then put ((fromIntegral n)::Int8) else put (127::Int8) >> put n+ put (SmallInt n) = if abs n < 127 then put (fromIntegral n :: Int8) else put (127::Int8) >> put n get = do n' <- get :: Get Int8- if n' == 127 then liftM SmallInt get else return $ SmallInt $ fromIntegral n'+ if n' == 127 then SmallInt <$> get else return . SmallInt $ fromIntegral n' putPackedNat,putPackedInt :: Int -> Put putPackedNat n = put $ SmallNat n putPackedInt n = put $ SmallInt n getPackedNat,getPackedInt :: Get Int-getPackedNat = liftM fromSmallNat get-getPackedInt = liftM fromSmallInt get+getPackedNat = fromSmallNat <$> get+getPackedInt = fromSmallInt <$> get newtype ShortList a = ShortList {fromShortList :: [a]} instance Binary a => Binary (ShortList a) where put (ShortList as) = putPackedNat (length as) >> mapM_ put as get = do n <- getPackedNat- ShortList `liftM` getMany n+ ShortList <$> getMany n -- | 'getMany n' get 'n' elements in order, without blowing the stack. -- [ copied from source of package 'binary' by Lennart Kolmodin ]@@ -67,26 +67,26 @@ return $ tupxy2hv (x,y) instance Binary g => Binary (PHS g) where put (PHS v) = put v- get = liftM PHS get+ get = PHS <$> get instance Binary GameState where put (GameState pps conns) = put (ShortList $ Vector.toList pps) >> put (ShortList conns)- get = liftM2 GameState (liftM (Vector.fromList . fromShortList) get) (liftM fromShortList get)+ get = liftM2 GameState (Vector.fromList . fromShortList <$> get) (fromShortList <$> get) instance Binary PlacedPiece where put (PlacedPiece ppos p) = put ppos >> put p get = liftM2 PlacedPiece get get instance Binary Piece where- put (Block patt) = put (0::Word8) >> put (ShortList patt)- put (Pivot arms) = put (1::Word8) >> put (ShortList arms)+ put (Block patt) = put (0::Word8) >> put (ShortList patt)+ put (Pivot arms) = put (1::Word8) >> put (ShortList arms) put (Hook arm stiffness) = put (2::Word8) >> put arm >> put stiffness- put (Wrench mom) = put (3::Word8) >> put mom- put Ball = put (4::Word8)+ put (Wrench mom) = put (3::Word8) >> put mom+ put Ball = put (4::Word8) get = do tag <- get :: Get Word8 case tag of- 0 -> liftM (Block . fromShortList) get- 1 -> liftM (Pivot . fromShortList) get+ 0 -> Block . fromShortList <$> get+ 1 -> Pivot . fromShortList <$> get 2 -> liftM2 Hook get get- 3 -> liftM Wrench get+ 3 -> Wrench <$> get 4 -> return Ball instance Binary Connection where put (Connection (ri,rp) (ei,ep) l) = putPackedInt ri >> put rp >> putPackedInt ei >> put ep >> put l@@ -95,39 +95,38 @@ rp <- get ei <- getPackedInt ep <- get- l <- get- return $ Connection (ri,rp) (ei,ep) l+ Connection (ri,rp) (ei,ep) <$> get instance Binary Link where- put (Free p) = put (0::Word8) >> put p+ put (Free p) = put (0::Word8) >> put p put (Spring d l) = put (1::Word8) >> put d >> putPackedInt l get = do tag <- get :: Get Word8 case tag of- 0 -> liftM Free get+ 0 -> Free <$> get 1 -> liftM2 Spring get getPackedInt instance Binary HookForce where- put NullHF = put (0::Word8)+ put NullHF = put (0::Word8) put (TorqueHF dir) = put (1::Word8) >> putPackedInt dir- put (PushHF v) = put (2::Word8) >> put v+ put (PushHF v) = put (2::Word8) >> put v get = do tag <- get :: Get Word8 case tag of 0 -> return NullHF- 1 -> liftM TorqueHF getPackedInt- 2 -> liftM PushHF get+ 1 -> TorqueHF <$> getPackedInt+ 2 -> PushHF <$> get instance Binary Frame where put (BasicFrame s) = putPackedInt s- get = liftM BasicFrame getPackedInt+ get = BasicFrame <$> getPackedInt instance Binary PlayerMove where- put NullPM = put (0::Word8)- put (HookPush v) = put (1::Word8) >> put v+ put NullPM = put (0::Word8)+ put (HookPush v) = put (1::Word8) >> put v put (HookTorque dir) = put (2::Word8) >> putPackedInt dir- put (WrenchPush v) = put (3::Word8) >> put v+ put (WrenchPush v) = put (3::Word8) >> put v get = do tag <- get :: Get Word8 case tag of 0 -> return NullPM- 1 -> liftM HookPush get- 2 -> liftM HookTorque getPackedInt- 3 -> liftM WrenchPush get+ 1 -> HookPush <$> get+ 2 -> HookTorque <$> getPackedInt+ 3 -> WrenchPush <$> get
BoardColouring.hs view
@@ -10,21 +10,21 @@ module BoardColouring where -import Control.Applicative-import Control.Monad-import Data.Function (on)-import qualified Data.Map as Map-import Data.Map (Map)-import qualified Data.Set as Set-import Data.Set (Set)-import Data.List-import Data.Maybe+import Control.Applicative+import Control.Monad+import Data.Function (on)+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set -import Hex-import GameState-import GameStateTypes-import Util-import GraphColouring+import GameState+import GameStateTypes+import GraphColouring+import Hex+import Util type PieceColouring = Map PieceIdx Int @@ -32,8 +32,7 @@ colouredPieces colourFixed st = [ idx | (idx, PlacedPiece _ p) <- enumVec $ placedPieces st , isPivot p ||- and [ isBlock p, idx > 0- , or [ colourFixed, not $ null $ springsEndAtIdx st idx ] ] ]+ isBlock p && (idx > 0) && colourFixed || not (null $ springsEndAtIdx st idx) ] pieceTypeColouring :: GameState -> [PieceIdx] -> PieceColouring pieceTypeColouring st coloured = Map.fromList@@ -43,8 +42,7 @@ boardColouring :: GameState -> [PieceIdx] -> PieceColouring -> PieceColouring-boardColouring st coloured lastCol =- fiveColour graph lastCol+boardColouring st coloured = fiveColour graph where board = stateBoard st graph = Map.fromList [ (idx, nub $ neighbours idx)@@ -82,11 +80,11 @@ mNext = listToMaybe [ (pos', rotate (h-2) basedir) | h <- [1..5]- , let pos' = (rotate h basedir)+^pos+ , let pos' = rotate h basedir+^pos , (fst <$> Map.lookup pos' board) /= Just idx ] (path,ns) = case mNext of- Nothing -> ([],[])+ Nothing -> ([],[]) Just next -> march idx startPos next False- in (pos:path, (maybeToList mn)++ns)+ in (pos:path, maybeToList mn++ns)
CVec.hs view
@@ -10,9 +10,9 @@ module CVec where -import Hex-import Data.Semigroup as Sem-import Data.Monoid+import Data.Monoid+import Data.Semigroup as Sem+import Hex data CVec = CVec { cy, cx :: Int } deriving (Eq, Ord, Show)
Cache.hs view
@@ -10,26 +10,26 @@ module Cache where -import Network.Fancy-import Control.Concurrent.STM-import Control.Concurrent-import Control.Applicative-import Control.Exception-import Control.Monad.Trans.Reader-import System.Directory-import Control.Monad-import Data.Maybe-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BL-import Data.Binary-import System.IO-import System.FilePath+import Control.Applicative+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Catch+import Control.Monad.Trans.Reader+import Data.Binary+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import Data.Maybe+import Network.Fancy+import System.Directory+import System.FilePath+import System.IO -import Database-import Protocol-import Metagame-import Mundanities-import ServerAddr+import Database+import Metagame+import Mundanities+import Protocol+import ServerAddr data FetchedRecord = FetchedRecord {fresh :: Bool, fetchError :: Maybe String, fetchedRC :: Maybe RecordContents} deriving (Eq, Show)@@ -37,11 +37,11 @@ getRecordCached :: ServerAddr -> Maybe Auth -> Maybe (TVar Bool) -> Bool -> Record -> IO (TVar FetchedRecord) getRecordCached saddr _ _ _ _ | nullSaddr saddr = do- atomically $ newTVar $ FetchedRecord True (Just "No server set.") Nothing+ newTVarIO (FetchedRecord True (Just "No server set.") Nothing) getRecordCached saddr auth mflag cOnly rec = do fromCache <- withCache saddr $ getRecord rec let fresh = isJust fromCache && invariantRecord rec- tvar <- atomically $ newTVar $ FetchedRecord fresh Nothing fromCache+ tvar <- newTVarIO (FetchedRecord fresh Nothing fromCache) unless (cOnly || fresh) $ void $ forkIO $ getRecordFromServer fromCache tvar return tvar where@@ -80,21 +80,21 @@ makeRequest saddr@(ServerAddr host port) request = handle (return . ServerError . (show::SomeException -> String)) $ withStream (IP host port) makeRequest'- `catchIO` (const $ return $ ServerError $ "Cannot connect to "++saddrStr saddr++"!")+ `catchIO` const (return $ ServerError $ "Cannot connect to "++saddrStr saddr++"!") where makeRequest' hdl = do BS.hPut hdl $ BL.toStrict $ encode request hFlush hdl- (decode . BL.fromStrict) `liftM` BS.hGetContents hdl+ decode . BL.fromStrict <$> BS.hGetContents hdl knownServers :: IO [ServerAddr]-knownServers = flip catchIO (const $ return []) $ do+knownServers = ignoreIOErr $ do cachedir <- confFilePath "cache" saddrstrs <- getDirectoryContents cachedir >>= filterM (\dir -> doesFileExist $ cachedir++[pathSeparator]++dir++[pathSeparator]++"serverInfo")- return $ concat $ map (maybeToList . strToSaddr) saddrstrs+ return $ mapMaybe strToSaddr saddrstrs withCache :: ServerAddr -> DBM a -> IO a withCache saddr m = do- cachedir <- (++[pathSeparator]++saddrPath saddr) `liftM` confFilePath "cache"+ cachedir <- (++pathSeparator : saddrPath saddr) <$> confFilePath "cache" runReaderT m cachedir
Command.hs view
@@ -9,9 +9,9 @@ -- along with this program. If not, see http://www.gnu.org/licenses/. module Command where-import Hex-import GameStateTypes-import Metagame+import GameStateTypes+import Hex+import Metagame data Command = CmdDir WrHoSel HexDir | CmdRotate WrHoSel TorqueDir | CmdWait@@ -32,10 +32,11 @@ | CmdInputCodename Codename | CmdInputSelUndecl Undeclared | CmdWriteState- | CmdTutorials+ | CmdInitiation | CmdShowRetired | CmdPlayLockSpec (Maybe LockSpec) | CmdSetServer | CmdToggleCacheOnly | CmdSelCodename (Maybe Codename) | CmdBackCodename | CmdHome+ | CmdSolveInit (Maybe HexVec) | CmdSolve (Maybe LockIndex) | CmdDeclare (Maybe Undeclared) | CmdViewSolution (Maybe NoteInfo) | CmdSelectLock | CmdNextLock | CmdPrevLock@@ -73,7 +74,7 @@ describeCommand (CmdReplayForward _) = "advance replay" describeCommand (CmdReplayBack _) = "rewind replay" describeCommand CmdWriteState = "write lock"-describeCommand CmdTutorials = "play tutorial levels"+describeCommand CmdInitiation = "revisit initiation" describeCommand CmdShowRetired = "toggle showing retired locks" describeCommand CmdSetServer = "set server" describeCommand CmdToggleCacheOnly = "toggle offline mode"@@ -81,14 +82,15 @@ ++ maybe "" (' ':) mname describeCommand CmdBackCodename = "select last player" describeCommand CmdHome = "select self"+describeCommand (CmdSolveInit _) = "solve lock" describeCommand (CmdSolve mli) = "solve lock" ++ maybe "" ((' ':).(:"").lockIndexChar) mli describeCommand (CmdPlayLockSpec mls) = "find lock by number" ++ maybe "" ((' ':).show) mls describeCommand (CmdDeclare mundecl) = "declare solution"- ++ maybe "" (\_->" [specified solution]") mundecl+ ++ maybe "" (const " [specified solution]") mundecl describeCommand (CmdViewSolution mnote) = "view lock solution"- ++ maybe "" (\_->" [specified solution]") mnote+ ++ maybe "" (const " [specified solution]") mnote describeCommand CmdSelectLock = "choose lock by name" describeCommand CmdNextLock = "next lock" describeCommand CmdPrevLock = "previous lock"@@ -106,15 +108,15 @@ describeCommand CmdHelp = "help" describeCommand _ = "" -tileStr HookTile = "hook"-tileStr (WrenchTile _) = "wrench"-tileStr (ArmTile _ _) = "arm"-tileStr (PivotTile _) = "pivot"+tileStr HookTile = "hook"+tileStr (WrenchTile _) = "wrench"+tileStr (ArmTile _ _) = "arm"+tileStr (PivotTile _) = "pivot" tileStr (SpringTile _ _) = "spring"-tileStr (BlockTile _) = "block"-tileStr BallTile = "ball"-whsStr WHSWrench = "wrench"-whsStr WHSHook = "hook"+tileStr (BlockTile _) = "block"+tileStr BallTile = "ball"+whsStr WHSWrench = "wrench"+whsStr WHSHook = "hook" whsStr WHSSelected = "tool" dirStr v | v == hu = "right"
CursesRender.hs view
@@ -10,16 +10,16 @@ module CursesRender where +import Data.Char (ord)+import Data.Map (Map)+import qualified Data.Map as Map import qualified UI.HSCurses.Curses as Curses-import Data.Char (ord)-import qualified Data.Map as Map-import Data.Map (Map) -import Hex-import CVec-import GameStateTypes-import BoardColouring (PieceColouring)-import AsciiLock+import AsciiLock+import BoardColouring (PieceColouring)+import CVec+import GameStateTypes+import Hex -- From Curses.CursesHelper: -- | Converts a list of 'Curses.Color' pairs (foreground color and@@ -66,7 +66,7 @@ c | cdir == hu = '-' | cdir == hv = '\\' | cdir == hw = '/'- | otherwise = '?'+ | otherwise = '-' a = if principal then bold else a0 in (c,a) tileChar HookTile = ('@',bold)@@ -79,12 +79,25 @@ ownedTileGlyph :: Bool -> PieceColouring -> [PieceIdx] -> OwnedTile -> Glyph ownedTileGlyph mono@True colouring reversed ot =- Glyph (monochromeOTileChar colouring ot) white a0+ Glyph (monochromeOTileChar' colouring ot) white a0+ where+ -- |add fifth colour, to differentiate from lock frame;+ -- adding this to the asciilock format would break back-compatibility.+ monochromeOTileChar' colouring (idx,BlockTile _) =+ case Map.lookup idx colouring of+ Just 0 -> ';'+ Just 1 -> '%'+ Just 2 -> '"'+ Just 3 -> '&'+ Just 4 -> '~'+ _ -> '#'+ monochromeOTileChar' colouring ot = monochromeOTileChar colouring ot ownedTileGlyph mono@False colouring reversed (owner,t) = let (ch,attr) = tileChar t pair = case Map.lookup owner colouring of Nothing -> 0- Just n -> n+1+ Just 3 -> cyan -- replace blue with cyan for visibility+ Just n -> n+1 rev = owner `elem` reversed in Glyph ch pair (Curses.setReverse attr rev)
CursesUI.hs view
@@ -10,40 +10,41 @@ module CursesUI where -import qualified UI.HSCurses.Curses as Curses-import Control.Concurrent.STM-import Control.Applicative-import qualified Data.Map as Map-import Data.Map (Map)-import Data.Semigroup as Sem-import Data.Monoid-import Data.Array-import Data.Maybe-import Data.List-import Control.Monad.Trans.Maybe-import Control.Monad.State-import Data.Function (on)+import Control.Applicative+import Control.Concurrent.STM+import Control.Monad.State+import Control.Monad.Trans.Maybe+import Data.Array+import Data.Bifunctor (second)+import Data.Function (on)+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Monoid+import Data.Semigroup as Sem+import qualified UI.HSCurses.Curses as Curses -import Hex-import GameState (stateBoard)-import GameStateTypes-import BoardColouring-import Frame-import KeyBindings-import Command-import Mundanities-import ServerAddr-import InputMode-import CursesRender-import CVec+import BoardColouring+import CVec+import Command+import CursesRender+import Frame+import GameState (stateBoard)+import GameStateTypes+import Hex+import InputMode+import KeyBindings+import Mundanities+import ServerAddr data UIState = UIState- { dispCPairs::[Curses.Pair]- , dispCentre::HexPos- , dispLastCol::PieceColouring+ { dispCPairs :: [Curses.Pair]+ , dispCentre :: HexPos+ , dispLastCol :: PieceColouring , uiKeyBindings :: Map InputMode KeyBindings- , monochrome::Bool- , message::Maybe (Curses.Attr, ColPair, String)}+ , monochrome :: Bool+ , message :: Maybe (Curses.Attr, ColPair, String)} type UIM = StateT UIState IO nullUIState = UIState [] (PHS zero) Map.empty Map.empty False Nothing @@ -61,14 +62,14 @@ getBindings :: InputMode -> UIM KeyBindings getBindings mode = do- uibdgs <- Map.findWithDefault [] mode <$> gets uiKeyBindings+ uibdgs <- gets (Map.findWithDefault [] mode . uiKeyBindings) return $ uibdgs ++ bindings mode bindingsStr :: InputMode -> [Command] -> UIM String bindingsStr mode cmds = do bdgs <- getBindings mode return $ (("["++).(++"]")) $ intercalate "," $- map (maybe "" showKey . findBinding bdgs) cmds+ maybe "" showKey . findBinding bdgs <$> cmds data Gravity = GravUp | GravLeft | GravRight | GravDown | GravCentre@@ -84,9 +85,9 @@ d $ CVec y $ x + shift where shift = case gravity of- GravLeft -> 0- GravRight -> max 0 $ w - w'- _ -> max 0 . (`div` 2) $ w - w'+ GravLeft -> 0+ GravRight -> max 0 $ w - w'+ GravCentre -> w - w' `div` 2 instance Sem.Semigroup Draw where (Draw w d) <> (Draw w' d') =@@ -106,27 +107,46 @@ bindingsDraw = bindingsDrawColour white bindingsDrawColour :: ColPair -> KeyBindings -> [Command] -> Draw bindingsDrawColour col bdgs cmds =- mconcat . ((stringDraw a0 col "[") :) . (++ [stringDraw a0 col "]"]) .+ mconcat . (stringDraw a0 col "[" :) . (++ [stringDraw a0 col "]"]) . intersperse (stringDraw a0 col ",") $- catMaybes $ ((keyDraw <$>) . findBinding bdgs) <$> cmds+ catMaybes $ (keyDraw <$>) . findBinding bdgs <$> cmds where keyDraw = stringDraw bold col . showKeyFriendlyShort +bindingDrawChar :: KeyBindings -> Curses.Attr -> Command -> Draw+bindingDrawChar bdgs a cmd = mconcat . maybeToList $+ stringDraw a white . (:[]) . showKeyChar <$> findBinding bdgs cmd++drawDirBindings :: InputMode -> KeyBindings -> WrHoSel -> Draw+drawDirBindings mode bdgs whs = Draw 5 $ \cpos -> do+ let c | mode == IMEdit = '_'+ | otherwise = case whs of+ WHSHook -> '@'+ WHSWrench -> '*'+ WHSSelected -> '_'+ gl = Glyph c white a0+ drawAtCVec gl cpos+ sequence_ [ doDrawAt (cpos +^ hexVec2CVec dir) .+ bindingDrawChar bdgs bold $ CmdDir whs dir+ | dir <- hexDirs ]+ data BindingsEntry = BindingsEntry String [Command] -drawBindingsTables :: InputMode -> Frame -> UIM ()-drawBindingsTables mode frame | mode `elem` [ IMEdit, IMPlay ] = do+drawBindingsTables :: InputMode -> (Command -> Bool) -> Frame -> UIM ()+drawBindingsTables mode censor frame | mode `elem` [ IMEdit, IMPlay ] = do bdgs <- getBindings mode (h,w) <- liftIO Curses.scrSize let startRight = frameWidth frame + 3 let maxWidth = (w `div` 2) - startRight - 1 let entryDraws (BindingsEntry desc cmds) = (greyDraw desc, bindingsDraw bdgs cmds)- forM_ [GravLeft, GravRight] $ \grav ->- let table = bindingsTable mode grav- drawsTable = map (\(line, entry) -> (line, entryDraws entry)) table- maxDesc = maximum $ map (drawWidth . fst . snd) drawsTable- maxBdgs = maximum $ map (drawWidth . snd . snd) drawsTable+ forM_ [GravLeft, GravRight] $ \grav -> do+ let table = filter (\(_,BindingsEntry _ cs) -> not $ null cs) $+ second (\(BindingsEntry s cs) -> BindingsEntry s $ filter censor cs) <$>+ bindingsTable mode grav+ drawsTable = second entryDraws <$> table+ maxDesc = maximum $ drawWidth . fst . snd <$> drawsTable+ maxBdgs = maximum $ drawWidth . snd . snd <$> drawsTable descX = (w `div` 2) + if grav == GravRight then startRight + maxBdgs + 2 else -(startRight + maxBdgs + 2 + maxDesc)@@ -135,7 +155,7 @@ else -(startRight + maxBdgs) oppGrav = if grav == GravRight then GravLeft else GravRight useDescs = maxDesc + 1 + maxBdgs <= maxWidth- in sequence_+ sequence_ [ do when (maxBdgs <= maxWidth) $ doDrawAt (CVec y bdgsX) $ alignDraw@@ -146,18 +166,35 @@ | (yoff, (descDraw, bdgsDraw)) <- drawsTable , let y = (h `div` 2) + yoff ]+ when (mode `elem` [IMPlay,IMEdit] && grav == GravLeft && maxWidth >= 5) $+ let (halfw,poss)+ | maxWidth < 15 = (3,[CVec (-5) 0])+ | maxWidth < 19 = (7,[CVec (-4) 0, CVec (-6) 5, CVec (-6) (-5)])+ | otherwise = (9,[CVec (-5) 0, CVec (-5) 7, CVec (-5) (-7)])+ in sequence_ [ doDrawAt pos $ drawDirBindings mode bdgs whs+ | (whs,pos) <- zip [WHSSelected, WHSWrench, WHSHook] $+ (CVec (h `div` 2) ((w `div` 2) - startRight -+ min (maxWidth - halfw) (max (maxBdgs+1) halfw)) +^) <$> poss ]+ when (mode == IMEdit && grav == GravRight && maxWidth >= 9) $+ let c = CVec ((h`div`2) - 4) ((w`div`2) + startRight ++ min (maxWidth - 5) (max (maxBdgs+1) 5))+ in sequence_ [ do+ drawAtCVec gl (c +^ CVec 0 x)+ doDrawAt (c +^ CVec 1 x) . bindingDrawChar bdgs bold $ CmdTile tile+ | (x,tile) <- zip [-4,-2,0,2,4]+ [ BlockTile []+ , SpringTile Relaxed zero+ , PivotTile zero+ , ArmTile zero False+ , BallTile ]+ , let gl = Glyph (fst $ tileChar tile) white a0 ]+ where bindingsTable IMPlay GravLeft =- [ (-5, BindingsEntry "move tool" $- map (CmdDir WHSSelected) hexDirs)- , (-4, BindingsEntry "select tool"+ [ (-2, BindingsEntry "select tool" [CmdToggle, CmdTile $ WrenchTile zero, CmdTile HookTile])- , (-3, BindingsEntry "move hook" $- map (CmdDir WHSHook) hexDirs)- , (-2, BindingsEntry "move wrench" $- map (CmdDir WHSWrench) hexDirs)- , (-1, BindingsEntry "rotate hook"- [CmdRotate whs dir | whs <- [WHSSelected, WHSHook], dir <- [-1,1]])+ , (-1, BindingsEntry "rotate hook" $+ nub [CmdRotate whs dir | whs <- [WHSSelected, WHSHook], dir <- [-1,1]]) , ( 0, BindingsEntry "wait" [CmdWait]) , ( 2, BindingsEntry "open lock" [CmdOpen]) , ( 4, BindingsEntry "undo, redo" [CmdUndo, CmdRedo])@@ -179,25 +216,17 @@ , (7, BindingsEntry "quit" [CmdQuit]) ] bindingsTable IMEdit GravLeft =- [ (-4, BindingsEntry "move" $ map (CmdDir WHSSelected) hexDirs)- , (-3, BindingsEntry "rotate"- [CmdRotate whs dir | whs <- [WHSSelected], dir <- [-1,1]])- , (-1, BindingsEntry "select" [CmdSelect])- , ( 0, BindingsEntry "delete" [CmdDelete])- , ( 1, BindingsEntry "merge" [CmdMerge])+ [ (-1, BindingsEntry "rotate" $+ nub [CmdRotate whs dir | whs <- [WHSSelected, WHSHook], dir <- [-1,1]])+ , ( 0, BindingsEntry "select" [CmdSelect])+ , ( 1, BindingsEntry "delete" [CmdDelete])+ , ( 2, BindingsEntry "merge" [CmdMerge]) , ( 4, BindingsEntry "undo, redo" [CmdUndo, CmdRedo]) , ( 5, BindingsEntry "marks" [CmdMark, CmdJumpMark, CmdReset]) ] bindingsTable IMEdit GravRight = [ (-7, BindingsEntry "help" [CmdHelp]) , (-6, BindingsEntry "bind" [CmdBind Nothing])- , (-4, BindingsEntry "place" $ map CmdTile- [ BlockTile []- , SpringTile Relaxed zero- , PivotTile zero- , ArmTile zero False- , BallTile- ]) , (-1, BindingsEntry "test" [CmdTest]) , ( 0, BindingsEntry "play" [CmdPlay]) , ( 1, BindingsEntry "step" [CmdWait])@@ -206,7 +235,7 @@ ] bindingsTable _ _ = [] -drawBindingsTables _ _ = return ()+drawBindingsTables _ _ _ = return () -- |frameWidth = maximum . map (abs . cx . hexVec2CVec) . -- blockPattern . placedPiece . framePiece@@ -232,7 +261,7 @@ drawAtWithGeom :: Glyph -> HexPos -> Geom -> UIM () drawAtWithGeom gl pos geom@(scrCentre,centre) =- drawAtCVec gl $ scrCentre +^ (hexVec2CVec $ pos -^ centre)+ drawAtCVec gl $ scrCentre +^ hexVec2CVec (pos -^ centre) drawAtCVec :: Glyph -> CVec -> UIM () drawAtCVec gl cpos = do@@ -247,7 +276,7 @@ drawStrGrey = drawStr a0 0 drawStrCentred :: Curses.Attr -> ColPair -> CVec -> [Char] -> UIM () drawStrCentred attr col v str =- drawStr attr col (truncateCVec $ (v +^ CVec 0 (-length str `div` 2))) str+ drawStr attr col (truncateCVec (v +^ CVec 0 (-length str `div` 2))) str drawCursorAt :: Maybe HexPos -> UIM ()@@ -256,7 +285,7 @@ drawCursorAt (Just pos) = do geom@(scrCentre,centre) <- getGeom liftIO $ Curses.cursSet Curses.CursorVisible- liftIO $ move $ scrCentre +^ (hexVec2CVec $ pos -^ centre)+ liftIO $ move $ scrCentre +^ hexVec2CVec (pos -^ centre) drawState :: [PieceIdx] -> Bool -> [Alert] -> GameState -> UIM () drawState reversed colourFixed alerts st = do@@ -269,7 +298,7 @@ let colouring = boardColouring st (colouredPieces colourFixed st) lastCol mono <- gets monochrome sequence_ [ drawAtWithGeom glyph pos geom |- (pos,glyph) <- Map.toList $ fmap (ownedTileGlyph mono colouring reversed) $ stateBoard st+ (pos,glyph) <- Map.toList $ ownedTileGlyph mono colouring reversed <$> stateBoard st ] return colouring
CursesUIMInstance.hs view
@@ -8,50 +8,51 @@ -- 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, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} module CursesUIMInstance () where -import qualified UI.HSCurses.Curses as Curses-import qualified UI.HSCurses.CursesHelper as CursesH-import Control.Concurrent.STM-import Control.Concurrent-import Control.Applicative-import Data.Char (ord)-import Data.Monoid-import qualified Data.Map as Map-import Data.Map (Map)-import Data.Array-import Data.Maybe-import Data.List-import Data.Char (chr)-import Control.Monad.Trans.Maybe-import Control.Concurrent (threadDelay)-import Control.Monad.State-import Data.Function (on)-import Data.Foldable (for_)+import Control.Applicative+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad.State+import Control.Monad.Trans.Maybe+import Data.Array+import Data.Char (chr, ord)+import Data.Foldable (for_)+import Data.Function (on)+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Monoid+import Safe (maximumBound)+import qualified UI.HSCurses.Curses as Curses+import qualified UI.HSCurses.CursesHelper as CursesH -import Hex-import GameStateTypes-import Physics-import Frame-import Command-import KeyBindings-import ServerAddr-import Cache-import Database-import Metagame-import Protocol-import Util-import InputMode-import MainState-import CursesUI-import CursesRender-import CVec+import CVec+import Cache+import Command+import CursesRender+import CursesUI+import Database+import Frame+import GameStateTypes+import Hex+import InputMode+import KeyBindings+import MainState+import Metagame+import Physics+import Protocol+import ServerAddr+import Util drawName :: Bool -> CVec -> Codename -> MainStateT UIM () drawName showScore pos name = do- ourName <- (authUser <$>) <$> gets curAuth+ ourName <- gets ((authUser <$>) . curAuth) relScore <- getRelScore name let (attr,col) = case relScore of Just 0 -> (a0,yellow)@@ -88,6 +89,7 @@ fillBox :: CVec -> CVec -> Int -> Gravity -> [CVec -> MainStateT UIM ()] -> MainStateT UIM Int fillBox (CVec t l) (CVec b r) width grav draws = do+ offset <- gets listOffset let half = width`div`2 starty = (if grav == GravDown then b else t) cv = (b+t)`div`2@@ -99,26 +101,33 @@ GravRight -> CVec cv r GravCentre -> CVec cv ch locs = sortBy (compare `on` dist) $ concat- [ map (CVec j) [ l+margin + (width+1)*i | i <- [0..(r-l-(2*margin))`div`(width+1)] ]+ [ [CVec j (l + margin + (width + 1) * i)+ | i <- [0 .. (r - l - (2 * margin)) `div` (width + 1)]] | j <- [t..b]- , let margin = if (j-starty)`mod`2 == 0 then half else width ]+ , let margin = if even (j-starty) then half else width ] dist v = sqlen $ v -^ gravCentre sqlen (CVec y x) = (y*(width+1))^2+x^2- selDraws <- do- offset <- gets listOffset- let na = length locs- nd = length draws- return $ drop (max 0 $ min (nd - na) (na*offset)) $ draws- let zipped = zip locs selDraws- sequence_ $ map (uncurry ($)) $ zip selDraws locs- return $ (if grav==GravDown then (minimum.(b:)) else (maximum.(t:))) [ y | (CVec y x,_) <- zipped ]+ na = length locs+ nd = length draws+ drawChar c = \cvec -> lift . drawStr bold white cvec $ ' ':c:" "+ draws' = if offset > 0 && length draws > na+ then drop (max 0 $ na-1 + (na-2)*(offset-1)) draws+ ++ [drawChar '<']+ else draws+ (selDraws,allDrawn) = if length draws' > na+ then (take (na-1) draws' ++ [drawChar '>'], False)+ else (take na draws', True)+ zipped = zip locs selDraws+ unless allDrawn . modify $ \ms -> ms { listOffsetMax = False }+ mapM_ (uncurry ($)) (zip selDraws locs)+ return $ (if grav==GravDown then minimum.(b:) else maximum.(t:)) [ y | (CVec y x,_) <- zipped ] drawLockInfo al@(ActiveLock name i) lockinfo = do (h,w) <- liftIO Curses.scrSize let [left,vcentre,right] = [ (k+2*i)*w`div`6 + (1-k) | k <- [0,1,2] ]- let [top,bottom] = [6, h-1]+ let [top,bottom] = [6, h-2] let hcentre = (top+bottom)`div`2 - 1- ourName <- (authUser <$>) <$> gets curAuth+ ourName <- gets ((authUser <$>) . curAuth) (lockTop, lockBottom) <- (fromJust<$>)$ runMaybeT $ msum [ do@@ -133,18 +142,16 @@ ] startOn <-- if (public lockinfo)- then lift $ drawStrCentred bold white (CVec (lockTop-1) vcentre) "Everyone!"+ if public lockinfo+ then lift $ drawStrCentred bold magenta (CVec (lockTop-1) vcentre) "Public" >> return (lockTop-1) else if null $ accessedBy lockinfo- then lift $ drawStrCentred a0 white (CVec (lockTop-1) vcentre) "No-one"+ then lift $ drawStrCentred a0 white (CVec (lockTop-1) vcentre) "None" >> return (lockTop-1) else fillBox (CVec (top+1) (left+1)) (CVec (lockTop-1) (right-1)) 5 GravDown $- [ \pos -> drawNote pos note | note <- lockSolutions lockinfo ] ++- [ \pos -> drawName False pos name- | name <- accessedBy lockinfo \\ map noteAuthor (lockSolutions lockinfo) ]- lift $ drawStrCentred a0 white (CVec (startOn-1) vcentre) "Accessed by:"+ [ (`drawNote` note) | note <- lockSolutions lockinfo ]+ lift $ drawStrCentred a0 white (CVec (startOn-1) vcentre) "Solutions:" undecls <- gets undeclareds if isJust $ guard . (|| public lockinfo) . (`elem` accessedBy lockinfo) =<< ourName@@ -158,7 +165,7 @@ s = vcentre - (length rntext+(3+1)*3)`div`2 lift $ drawStr a0 white (CVec (lockBottom+1) s) rntext void $ fillBox (CVec (lockBottom+1) (s+length rntext+1)) (CVec (lockBottom+1) right) 3 GravLeft- [ \pos -> drawName False pos name | name <- map noteAuthor read ]+ [ \pos -> drawName False pos name | name <- noteAuthor <$> read ] lift $ drawStrCentred a0 white (CVec (lockBottom+2) vcentre) "Notes held:" if null $ notesSecured lockinfo@@ -166,14 +173,14 @@ drawStrCentred a0 white (CVec (lockBottom+3) vcentre) "None" else void $ fillBox (CVec (lockBottom+3) (left+1)) (CVec bottom (right-1)) 5 GravUp- [ (`drawActiveLock` al) | al <- map noteOn $ notesSecured lockinfo ]+ [ (`drawActiveLock` al) | al <- noteOn <$> notesSecured lockinfo ] data HelpReturn = HelpNone | HelpDone | HelpContinue Int showHelpPaged :: Int -> InputMode -> HelpPage -> UIM Bool showHelpPaged from mode page =- showHelpPaged' from mode page >>= \ret -> case ret of+ showHelpPaged' from mode page >>= \case HelpNone -> return False HelpDone -> return True HelpContinue from' -> do@@ -186,8 +193,8 @@ erase (h,w) <- liftIO Curses.scrSize let bdgWidth = 39- showKeys chs = intercalate "/" (map showKey chs)- maxkeyslen = maximum $ map (length.showKeys.map fst) $ groupBy ((==) `on` snd) bdgs+ showKeys chs = intercalate "/" (showKey <$> chs)+ maxkeyslen = maximum $ length . showKeys . map fst <$> groupBy ((==) `on` snd) bdgs drawStrCentred a0 cyan (CVec 0 (w`div`2)) "Bindings:" let groups = filter (not . null . describeCommand . snd . head) $ drop from $ groupBy ((==) `on` snd) $ sortBy (compare `on` snd) bdgs@@ -199,22 +206,23 @@ | group <- groups , let cmd = snd $ head group , let desc = describeCommand cmd- , let chs = map fst group+ , let chs = fst <$> group , let keysStr = showKeys chs , let pad = max 0 $ minimum [maxkeyslen + 1 - length keysStr, bdgWidth - length desc - length keysStr - 1 - 1]- ]- (map (`divMod` (h-3)) [0..])+ ] $ (`divMod` (h-3)) <$> [0..] , (x+1)*bdgWidth < w] sequence_ draws refresh return $ if length draws < length groups then HelpContinue $ from + length draws else HelpDone+showHelpPaged' from IMInit HelpPageGame =+ drawBasicHelpPage from ("INTRICACY",magenta) (initiationHelpText,magenta) showHelpPaged' from IMMeta HelpPageGame = drawBasicHelpPage from ("INTRICACY",magenta) (metagameHelpText,magenta) showHelpPaged' from IMMeta (HelpPageInitiated n) =- drawBasicHelpPage from ("Initiation complete",magenta) (initiationHelpText n,magenta)+ drawBasicHelpPage from ("Initiation complete",magenta) (initiationCompleteText n,magenta) showHelpPaged' from IMEdit HelpPageFirstEdit = drawBasicHelpPage from ("Your first lock:",magenta) (firstEditHelpText,green) showHelpPaged' _ _ _ = return HelpNone@@ -223,9 +231,8 @@ drawBasicHelpPage from (title,titleCol) (body,bodyCol) = do erase (h,w) <- liftIO Curses.scrSize- drawStrCentred a0 titleCol (CVec 0 $ w`div`2) title let strs = drop from $- if w >= maximum (map length metagameHelpText)+ if w >= maximum (length <$> metagameHelpText) then body else let wrap max = wrap' max max@@ -237,9 +244,11 @@ else '\n' : wrap' max max (w:ws) else let prepend = if left == max then w else ' ':w in prepend ++ wrap' max (left - length prepend) ws- in lines . wrap w . words $ intercalate " " body+ in lines . wrap w . words $ unwords body+ top = max 0 $ (h - length strs) `div` 2+ drawStrCentred a0 titleCol (CVec top $ w`div`2) title let draws = [drawStrCentred a0 bodyCol (CVec y $ w`div`2) str |- (y,str) <- zip [2..h-2] $ strs ]+ (y,str) <- zip [top+2..h-2] strs ] sequence_ draws return $ if length draws < length strs then HelpContinue $ from + length draws@@ -248,17 +257,17 @@ charify :: Curses.Key -> Maybe Char charify key = case key of- Curses.KeyChar ch -> Just ch+ Curses.KeyChar ch -> Just ch Curses.KeyBackspace -> Just '\b'- Curses.KeyLeft -> Just '4'- Curses.KeyRight -> Just '6'- Curses.KeyDown -> Just '2'- Curses.KeyUp -> Just '8'- Curses.KeyHome -> Just '7'- Curses.KeyNPage -> Just '3'- Curses.KeyPPage -> Just '9'- Curses.KeyEnd -> Just '1'- _ -> Nothing+ Curses.KeyLeft -> Just '4'+ Curses.KeyRight -> Just '6'+ Curses.KeyDown -> Just '2'+ Curses.KeyUp -> Just '8'+ Curses.KeyHome -> Just '7'+ Curses.KeyNPage -> Just '3'+ Curses.KeyPPage -> Just '9'+ Curses.KeyEnd -> Just '1'+ _ -> Nothing handleEsc k@(Curses.KeyChar '\ESC') = do Curses.timeout 100@@ -279,26 +288,69 @@ drawMainState' s lift refresh where- drawMainState' (PlayState { psCurrentState=st, psLastAlerts=alerts,- wrenchSelected=wsel, psFrame=frame }) = lift $ do+ drawMainState' PlayState { psCurrentState=st, psLastAlerts=alerts,+ wrenchSelected=wsel, psFrame=frame, psTutLevel=tutLevel } = lift $ do drawState [] False alerts st- drawBindingsTables IMPlay frame+ drawBindingsTables IMPlay filterBindings frame drawCursorAt $ listToMaybe [ pos | (_, PlacedPiece pos p) <- enumVec $ placedPieces st- , or [wsel && isWrench p, not wsel && isHook p] ]- drawMainState' (ReplayState {}) = do+ , (wsel && isWrench p) || (not wsel && isHook p) ]+ where+ filterBindings (CmdRotate _ _) = not $ wrenchOnlyTutLevel tutLevel+ filterBindings CmdUndo = not $ noUndoTutLevel tutLevel+ filterBindings CmdRedo = not $ noUndoTutLevel tutLevel+ filterBindings CmdMark = not $ noUndoTutLevel tutLevel+ filterBindings CmdJumpMark = not $ noUndoTutLevel tutLevel+ filterBindings CmdReset = not $ noUndoTutLevel tutLevel+ filterBindings _ = True+ drawMainState' ReplayState {} = do lift . drawState [] False [] =<< gets rsCurrentState lift $ drawCursorAt Nothing- drawMainState' (EditState { esGameState=st, selectedPiece=selPiece,- selectedPos=selPos, esFrame=frame }) = lift $ do+ drawMainState' EditState { esGameState=st, selectedPiece=selPiece,+ selectedPos=selPos, esFrame=frame } = lift $ do drawState (maybeToList selPiece) True [] st- drawBindingsTables IMEdit frame+ drawBindingsTables IMEdit (const True) frame drawCursorAt $ if isNothing selPiece then Just selPos else Nothing- drawMainState' (MetaState {curServer=saddr, undeclareds=undecls,+ drawMainState' InitState {initLocks=initLocks, tutProgress=TutProgress{tutSolved=tutSolved}} = lift $ do+ drawCursorAt Nothing+ (h,w) <- liftIO Curses.scrSize+ when (h<15 || w<30) $ liftIO CursesH.end >> error "Terminal too small!"+ let centre = CVec (h`div`2) (w`div`2)+ drawStrCentred bold white (centre +^ CVec (-5) 0) "I N T R I C A C Y"+ bdgs <- getBindings IMInit+ doDrawAt (centre +^ CVec 5 0) . alignDraw GravCentre 0 $ bindingsDraw bdgs [CmdSolveInit Nothing] <> greyDraw " solve lock"+ doDrawAt (centre +^ CVec 6 0) . alignDraw GravCentre 0 $ bindingsDraw bdgs [CmdHelp] <> greyDraw " help"+ doDrawAt (centre +^ CVec 7 0) . alignDraw GravCentre 0 $ bindingsDraw bdgs [CmdQuit] <> greyDraw " quit"+ let cvec v = clampHoriz $ centre +^ CVec y (3*x-1) where+ CVec y x = hexVec2CVec v+ clampHoriz (CVec y x) = CVec y . max 0 $ min (w-4) x+ drawInitLock v = do+ let pos = tutPos +^ 2 *^ v+ drawStr bold (if solved v then green else red) (cvec pos) (name v)+ sequence_+ [ drawStr a0 green (cvec $ pos +^ h) str+ | (h,str) <- [(hu,"---"), (neg hv," \\ "), (neg hw," / ")]+ , let v' = v +^ h+ , abs (hy v') < 2 && hx v' >= 0 && hz v' <= 0+ , v' `Map.member` accessible || (isLast v && h == hu)+ , solved v || solved v' ]+ drawInitLock zero+ mapM_ drawInitLock $ Map.keys accessible+ where+ accessible = accessibleInitLocks tutSolved initLocks+ tutPos = maximumBound 0 (hx <$> Map.keys accessible) *^ neg hu+ name v | v == zero = "TUT"+ | otherwise = maybe "???" initLockName $ Map.lookup v accessible+ solved v | v == zero = tutSolved+ | otherwise = Just True == (initLockSolved <$> Map.lookup v accessible)+ isLast v | v == zero = False+ | otherwise = Just True == (isLastInitLock <$> Map.lookup v accessible)+ drawMainState' MetaState {curServer=saddr, undeclareds=undecls, cacheOnly=cOnly, curAuth=auth, codenameStack=names, randomCodenames=rnamestvar, retiredLocks=mretired, curLockPath=path,- curLock=lock}) = do- let ourName = liftM authUser auth+ curLock=lock} = do+ modify $ \ms -> ms { listOffsetMax = True }+ let ourName = authUser <$> auth let selName = listToMaybe names let home = isJust ourName && ourName == selName (h,w) <- liftIO Curses.scrSize@@ -309,14 +361,14 @@ let serverBdgsDraw = bindingsDraw bdgs [CmdSetServer, CmdToggleCacheOnly] lockBdgsDraw = bindingsDraw bdgs $- [CmdEdit] ++ if path == "" then [] else [CmdPlaceLock Nothing]- leftBdgsWidth = (+3) . maximum $ map drawWidth [serverBdgsDraw, lockBdgsDraw]- helpDraw = bindingsDraw bdgs [CmdTutorials] <> greyDraw " tutorial " <>+ CmdEdit : [CmdPlaceLock Nothing | path /= ""]+ leftBdgsWidth = (+3) . maximum $ drawWidth <$> [serverBdgsDraw, lockBdgsDraw]+ helpDraw = bindingsDraw bdgs [CmdInitiation] <> greyDraw " initiation " <> bindingsDraw bdgs [CmdHelp] <> greyDraw " help" serverTextDraw = greyDraw . take (w - leftBdgsWidth - drawWidth helpDraw - 1) $ " Server: " ++ saddrStr saddr ++ (if cOnly then " (offline mode) " else "") lockBdgsDraw' = bindingsDraw bdgs $- [CmdSelectLock] ++ if path == "" then [] else [CmdNextLock, CmdPrevLock]+ CmdSelectLock : if path == "" then [] else [CmdNextLock, CmdPrevLock] lockTextDraw = greyDraw . take (w - leftBdgsWidth - drawWidth lockBdgsDraw' - 1) $ " Lock: " ++ path ++ replicate 5 ' ' doDrawAt (CVec 0 0) $ alignDraw GravLeft leftBdgsWidth serverBdgsDraw <> serverTextDraw@@ -342,16 +394,15 @@ void $ fillBox (CVec 6 2) (CVec (h-1) (w-2)) 5 GravCentre [ \pos -> lift $ drawStrGrey pos $ show ls | ls <- retired ] lift $ doDrawAt (CVec 5 (w`div`3)) $ bindingsDraw bdgs $- [CmdShowRetired] ++ if null retired- then [] else [CmdPlayLockSpec Nothing]+ CmdShowRetired : [CmdPlayLockSpec Nothing | not (null retired)] Nothing -> do sequence_ [ drawLockInfo (ActiveLock (codename uinfo) i) lockinfo | (i,Just lockinfo) <- assocs $ userLocks uinfo ] unless (null $ elems $ userLocks uinfo) $ lift $ doDrawAt (CVec 5 (w`div`3)) $ bindingsDraw bdgs $- [CmdSolve Nothing] ++ if isJust ourName then [CmdViewSolution Nothing] else []+ CmdSolve Nothing : [CmdViewSolution Nothing | isJust ourName] when (isJust ourName && ourName == selName) $ do- rnames <- liftIO $ atomically $ readTVar rnamestvar+ rnames <- liftIO $ readTVarIO rnamestvar unless (null rnames) $ void $ fillBox (CVec 2 0) (CVec 5 (w`div`3)) 3 GravCentre [ \pos -> drawName False pos name | name <- rnames ]@@ -381,10 +432,10 @@ let accessed = [ ActiveLock us i | i<-[0..2] , Just lock <- [ userLocks ourUInfo ! i ]- , public lock || selName `elem` map Just (accessedBy lock) ]+ , public lock || selName `elem` (Just <$> accessedBy lock) ] guard $ not $ null accessed let str = "has accessed:"- let s = (w-(4 + length str + 6*(length accessed)))`div`2+ let s = (w-(4 + length str + 6*length accessed))`div`2 let y = 4 lift $ do drawName False (CVec y (s+1)) sel@@ -399,12 +450,13 @@ liftIO $ threadDelay $ 5*10^4 where drawAlert (AlertCollision pos) = drawAt cGlyph pos- drawAlert _ = return ()+ drawAlert _ = return () cGlyph = Glyph '!' 0 a0 + clearMessage = say "" drawMessage = say- drawPrompt full s = say s >> (liftIO $ void $ Curses.cursSet Curses.CursorVisible)- endPrompt = say "" >> (liftIO $ void $ Curses.cursSet Curses.CursorInvisible)+ drawPrompt full s = liftIO (void $ Curses.cursSet Curses.CursorVisible) >> say s+ endPrompt = say "" >> liftIO (void $ Curses.cursSet Curses.CursorInvisible) drawError = sayError showHelp = showHelpPaged 0@@ -412,7 +464,7 @@ getChRaw = (charify<$>) $ liftIO $ CursesH.getKey (return ()) >>= handleEsc setUIBinding mode cmd ch = modify $ \s -> s { uiKeyBindings =- Map.insertWith (\[bdg] -> \bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs)+ Map.insertWith (\ [bdg] bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs) mode [(ch,cmd)] $ uiKeyBindings s } getUIBinding mode cmd = do bdgs <- getBindings mode@@ -468,5 +520,5 @@ unblockBinding = (toEnum 0, CmdRefresh) -- c.f. unblockInput above flip (maybe $ return []) mch $ \ch -> if mode == IMTextInput- then return $ [ CmdInputChar ch `fromMaybe` lookup ch [unblockBinding] ]- else (maybeToList . lookup ch . (unblockBinding:)) <$> getBindings mode+ then return [ CmdInputChar ch `fromMaybe` lookup ch [unblockBinding] ]+ else maybeToList . lookup ch . (unblockBinding:) <$> getBindings mode
Database.hs view
@@ -10,26 +10,27 @@ module Database where -import Data.Maybe-import Data.Tuple (swap)-import Data.Char (toUpper)-import Control.Applicative-import Control.Monad-import System.IO-import System.FilePath-import System.Directory-import Control.Monad.Trans.Reader-import Control.Monad.IO.Class+import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import qualified Data.ByteString.Char8 as CS import qualified Data.ByteString.Lazy.Char8 as CL-import qualified Data.ByteString.Char8 as CS+import Data.Char (toUpper)+import Data.Maybe+import Data.Tuple (swap)+import System.Directory+import System.FilePath+import System.IO -import Crypto.Hash (hashlazy, Digest, SHA1, digestToHexByteString)-import Crypto.Types.PubKey.RSA (PublicKey, PrivateKey)+import Crypto.Hash (Digest, SHA1,+ digestToHexByteString, hashlazy)+import Crypto.Types.PubKey.RSA (PrivateKey, PublicKey) -import Protocol-import Metagame-import Lock-import Mundanities+import Lock+import Metagame+import Mundanities+import Protocol sha1 :: CL.ByteString -> Digest SHA1 sha1 = hashlazy@@ -67,29 +68,29 @@ deriving (Eq, Show) rcOfServerResp (ServedServerInfo x) = RCServerInfo x-rcOfServerResp (ServedLock x) = RCLock x-rcOfServerResp (ServedSolution x) = RCSolution x-rcOfServerResp (ServedUserInfo x) = RCUserInfo x-rcOfServerResp (ServedRetired x) = RCLockSpecs x-rcOfServerResp (ServedPublicKey x) = RCPublicKey x-rcOfServerResp _ = error "no corresponding rc"+rcOfServerResp (ServedLock x) = RCLock x+rcOfServerResp (ServedSolution x) = RCSolution x+rcOfServerResp (ServedUserInfo x) = RCUserInfo x+rcOfServerResp (ServedRetired x) = RCLockSpecs x+rcOfServerResp (ServedPublicKey x) = RCPublicKey x+rcOfServerResp _ = error "no corresponding rc" -invariantRecord (RecUserInfo _) = False-invariantRecord (RecUserInfoLog _) = False+invariantRecord (RecUserInfo _) = False+invariantRecord (RecUserInfoLog _) = False invariantRecord (RecPasswordLegacy _) = False invariantRecord (RecPasswordArgon2 _) = False-invariantRecord (RecRetiredLocks _) = False-invariantRecord (RecNote _) = False-invariantRecord (RecEmail _) = False-invariantRecord _ = True+invariantRecord (RecRetiredLocks _) = False+invariantRecord (RecNote _) = False+invariantRecord (RecEmail _) = False+invariantRecord _ = True -askForRecord RecServerInfo = GetServerInfo-askForRecord (RecUserInfo name) = GetUserInfo name Nothing-askForRecord (RecLock ls) = GetLock ls-askForRecord (RecNote note) = GetSolution note+askForRecord RecServerInfo = GetServerInfo+askForRecord (RecUserInfo name) = GetUserInfo name Nothing+askForRecord (RecLock ls) = GetLock ls+askForRecord (RecNote note) = GetSolution note askForRecord (RecRetiredLocks name) = GetRetired name-askForRecord RecPublicKey = GetPublicKey-askForRecord _ = error "no corresponding request"+askForRecord RecPublicKey = GetPublicKey+askForRecord _ = error "no corresponding request" type DBM = ReaderT FilePath IO withDB :: FilePath -> DBM a -> IO a@@ -101,22 +102,22 @@ getRecord :: Record -> DBM (Maybe RecordContents) getRecord rec = do path <- recordPath rec- liftIO $ flip catchIO (const $ return Nothing) $ do+ liftIO . ignoreIOErrAlt $ do h <- openFile path ReadMode getRecordh rec h <* hClose h-getRecordh (RecPasswordLegacy _) h = ((RCPasswordLegacy <$>) . tryRead) <$> hGetStrict h-getRecordh (RecPasswordArgon2 _) h = ((RCPasswordArgon2 <$>) . tryRead) <$> hGetStrict h-getRecordh (RecEmail _) h = ((RCEmail <$>) . tryRead) <$> hGetStrict h-getRecordh (RecUserInfo _) h = ((RCUserInfo <$>) . tryRead) <$> hGetStrict h-getRecordh (RecUserInfoLog _) h = ((RCUserInfoDeltas <$>) . tryRead) <$> hGetStrict h-getRecordh (RecLock _) h = ((RCLock <$>) . tryRead) <$> hGetStrict h-getRecordh (RecNote _) h = ((RCSolution <$>) . tryRead) <$> hGetStrict h-getRecordh RecLockHashes h = ((RCLockHashes <$>) . tryRead) <$> hGetStrict h-getRecordh (RecRetiredLocks name) h = ((RCLockSpecs <$>) . tryRead) <$> hGetStrict h-getRecordh RecServerInfo h = ((RCServerInfo <$>) . tryRead) <$> hGetStrict h-getRecordh RecServerEmail h = ((RCEmail <$>) . tryRead) <$> hGetStrict h-getRecordh RecPublicKey h = ((RCPublicKey <$>) . tryRead) <$> hGetStrict h-getRecordh RecSecretKey h = ((RCSecretKey <$>) . tryRead) <$> hGetStrict h+getRecordh (RecPasswordLegacy _) h = (RCPasswordLegacy <$>) . tryRead <$> hGetStrict h+getRecordh (RecPasswordArgon2 _) h = (RCPasswordArgon2 <$>) . tryRead <$> hGetStrict h+getRecordh (RecEmail _) h = (RCEmail <$>) . tryRead <$> hGetStrict h+getRecordh (RecUserInfo _) h = (RCUserInfo <$>) . tryRead <$> hGetStrict h+getRecordh (RecUserInfoLog _) h = (RCUserInfoDeltas <$>) . tryRead <$> hGetStrict h+getRecordh (RecLock _) h = (RCLock <$>) . tryRead <$> hGetStrict h+getRecordh (RecNote _) h = (RCSolution <$>) . tryRead <$> hGetStrict h+getRecordh RecLockHashes h = (RCLockHashes <$>) . tryRead <$> hGetStrict h+getRecordh (RecRetiredLocks name) h = (RCLockSpecs <$>) . tryRead <$> hGetStrict h+getRecordh RecServerInfo h = (RCServerInfo <$>) . tryRead <$> hGetStrict h+getRecordh RecServerEmail h = (RCEmail <$>) . tryRead <$> hGetStrict h+getRecordh RecPublicKey h = (RCPublicKey <$>) . tryRead <$> hGetStrict h+getRecordh RecSecretKey h = (RCSecretKey <$>) . tryRead <$> hGetStrict h hGetStrict h = CS.unpack <$> concatMWhileNonempty (repeat $ CS.hGet h 1024) where concatMWhileNonempty (m:ms) = do@@ -133,18 +134,18 @@ h <- openFile path WriteMode putRecordh rc h hClose h-putRecordh (RCPasswordLegacy hpw) h = hPutStr h $ show hpw-putRecordh (RCPasswordArgon2 hpw) h = hPutStr h $ show hpw-putRecordh (RCEmail addr) h = hPutStr h $ show addr-putRecordh (RCUserInfo info) h = hPutStr h $ show info+putRecordh (RCPasswordLegacy hpw) h = hPutStr h $ show hpw+putRecordh (RCPasswordArgon2 hpw) h = hPutStr h $ show hpw+putRecordh (RCEmail addr) h = hPutStr h $ show addr+putRecordh (RCUserInfo info) h = hPutStr h $ show info putRecordh (RCUserInfoDeltas deltas) h = hPutStr h $ show deltas-putRecordh (RCLock lock) h = hPutStr h $ show lock-putRecordh (RCSolution solution) h = hPutStr h $ show solution-putRecordh (RCLockHashes hashes) h = hPutStr h $ show hashes-putRecordh (RCLockSpecs lss) h = hPutStr h $ show lss-putRecordh (RCServerInfo sinfo) h = hPutStr h $ show sinfo-putRecordh (RCPublicKey publicKey) h = hPutStr h $ show publicKey-putRecordh (RCSecretKey secretKey) h = hPutStr h $ show secretKey+putRecordh (RCLock lock) h = hPutStr h $ show lock+putRecordh (RCSolution solution) h = hPutStr h $ show solution+putRecordh (RCLockHashes hashes) h = hPutStr h $ show hashes+putRecordh (RCLockSpecs lss) h = hPutStr h $ show lss+putRecordh (RCServerInfo sinfo) h = hPutStr h $ show sinfo+putRecordh (RCPublicKey publicKey) h = hPutStr h $ show publicKey+putRecordh (RCSecretKey secretKey) h = hPutStr h $ show secretKey modifyRecord :: Record -> (RecordContents -> RecordContents) -> DBM () modifyRecord rec f = do@@ -175,12 +176,12 @@ listUsers :: DBM [Codename] listUsers = do dbpath <- ask- liftIO $ (map unpathifyName . filter ((==3).length)) <$>+ liftIO $ (unpathifyName <$>) . filter ((==3).length) <$> getDirectoryContents (dbpath++[pathSeparator]++"users") recordPath :: Record -> DBM FilePath recordPath rec =- (++ ([pathSeparator] ++ recordPath' rec)) <$> ask+ (++ (pathSeparator : recordPath' rec)) <$> ask where recordPath' (RecPasswordLegacy name) = userDir name ++ "passwd" recordPath' (RecPasswordArgon2 name) = userDir name ++ "passwd_argon2"@@ -205,7 +206,7 @@ -- | Hilariously, "CON", "PRN", "AUX", and "NUL" are reserved on DOS, and -- Windows apparently crashes rather than write a directory with that name!-winSux name = if map toUpper name `elem` ["CON","PRN", "AUX","NUL"]+winSux name = if (toUpper <$> name) `elem` ["CON","PRN", "AUX","NUL"] then '_':name else name @@ -214,10 +215,10 @@ -- To avoid collisions on case-insensitive filesystems, we use '_' as an -- escape character. dummyPunctuation = concatMap $ \c ->- fromMaybe [c] (('_':) . pure <$> lookup c pathifyAssocs)+ maybe [c] (('_':) . pure) (lookup c pathifyAssocs) unpathifyName = concatMap $ \c -> case c of '_' -> ""- _ -> pure $ fromMaybe c (lookup c $ map swap pathifyAssocs)+ _ -> pure $ fromMaybe c (lookup c $ swap <$> pathifyAssocs) pathifyAssocs = [ ('/','s') , ('.','d')
EditGameState.hs view
@@ -10,17 +10,17 @@ module EditGameState (modTile, mergeTiles) where -import Control.Applicative-import Data.Function (on)-import qualified Data.Map as Map-import Data.Map (Map)-import Data.Maybe-import Control.Monad-import Data.List+import Control.Applicative+import Control.Monad+import Data.Function (on)+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe -import Hex-import GameState-import GameStateTypes+import GameState+import GameStateTypes+import Hex --import Debug modTile :: Maybe Tile -> HexPos -> HexPos -> Bool -> GameState -> GameState@@ -28,9 +28,9 @@ let board = stateBoard st curOwnedTile = Map.lookup pos board (st',mowner) = case curOwnedTile of- Nothing -> (st,Nothing)+ Nothing -> (st,Nothing) Just (owner,SpringTile _ _) -> (delConnectionsIn pos st, Just owner)- Just (owner,_) -> delPiecePos owner pos st -- XXX may invalidate board's indices to st+ Just (owner,_) -> delPiecePos owner pos st -- XXX may invalidate board's indices to st board' = stateBoard st' addPiece p = addpp $ PlacedPiece pos p lastMOwner = do@@ -54,12 +54,12 @@ validSpringRootTile ot = case snd ot of BlockTile _ -> True PivotTile _ -> True- _ -> False+ _ -> False -- |Find next adjacent, skipping over current entity. nextOfAdjacents adjs loop = listToMaybe $ fromMaybe adjs $ do owner <- mowner i <- elemIndex owner adjs- return $ (dropWhile (== owner) $ drop i adjs) +++ return $ dropWhile (== owner) (drop i adjs) ++ if loop && i > 0 then adjs else [] in case mowner of Just o | protectedPiece o -> st@@ -75,7 +75,7 @@ else nextOfAdjacents adjacentBlocks False in case addToIdx of Nothing -> addPiece $ Block [zero]- Just b -> addBlockPos b pos+ Just b -> addBlockPos b pos Just (ArmTile armdir _) -> let adjacentPivots = [ idx | dir <- if armdir == zero then hexDirs else [armdir, neg armdir]@@ -85,7 +85,7 @@ else nextOfAdjacents adjacentPivots True in case addToIdx of Nothing -> id- Just p -> addPivotArm p pos+ Just p -> addPivotArm p pos Just (SpringTile _ _) -> let possibleSprings = [ Connection root end $ Spring sdir natLen | sdir <- hexDirs@@ -93,7 +93,7 @@ , Just (eidx, BlockTile _) <- [Map.lookup epos board'] , not $ protectedPiece eidx , (ridx, rpos) <- maybeToList $ castRay (neg sdir +^ pos) (neg sdir) board'- , Just True == (validSpringRootTile `liftM` Map.lookup rpos board')+ , Just True == (validSpringRootTile <$> Map.lookup rpos board') , let natLen = hexLen (rpos -^ epos) - 1 , natLen > 0 {-@@ -103,16 +103,14 @@ , not $ sdir' `elem` [sdir,neg sdir] ] -} , not $ connGraphPathExists st' eidx ridx- , let end = (eidx, epos -^ (placedPos $ getpp st' eidx))- , let root = (ridx, rpos -^ (placedPos $ getpp st' ridx))+ , let end = (eidx, epos -^ placedPos (getpp st' eidx))+ , let root = (ridx, rpos -^ placedPos (getpp st' ridx)) ] nextSpring = listToMaybe $ fromMaybe possibleSprings $ do (_,SpringTile _ _) <- curOwnedTile -- XXX: therefore the indices of st are still valid i <- findIndex (`elem` connections st) possibleSprings return $ drop (i+1) possibleSprings- in case nextSpring of- Nothing -> id- Just conn -> addConn conn+ in maybe id addConn nextSpring Just (PivotTile _) -> addPiece $ Pivot [] Just (WrenchTile _) -> addPiece $ Wrench zero Just HookTile -> let arm = listToMaybe [ dir |@@ -120,7 +118,7 @@ , isNothing $ Map.lookup (dir +^ pos) board' ] in case arm of Just armdir -> addPiece $ Hook armdir NullHF _ -> id- Just (BallTile) -> addPiece Ball+ Just BallTile -> addPiece Ball _ -> id ) st' @@ -133,7 +131,7 @@ (idx,tile) <- Map.lookup pos board (idx',tile') <- Map.lookup (dir+^pos) board guard $ idx /= idx'- guard $ all (not . protectedPiece) [idx,idx']+ guard $ not (any protectedPiece [idx,idx']) case tile of BlockTile _ -> do BlockTile _ <- Just tile'
Frame.hs view
@@ -10,14 +10,14 @@ module Frame where -import Data.List ((\\))-import qualified Data.Vector as Vector+import Data.List ((\\))+import qualified Data.Vector as Vector -import GameState-import GameStateTypes-import Hex+import GameState+import GameStateTypes+import Hex -data Frame = BasicFrame Int+newtype Frame = BasicFrame Int deriving (Eq, Ord, Show, Read) frameSize :: Frame -> Int@@ -33,7 +33,7 @@ baseState :: Frame -> GameState baseState f = GameState- (Vector.fromList $ [ framePiece f, bolt ] ++ (initTools f))+ (Vector.fromList $ [ framePiece f, bolt ] ++ initTools f) [] where bolt = PlacedPiece (bolthole f +^ origin) $ Block $@@ -41,14 +41,14 @@ framePiece :: Frame -> PlacedPiece framePiece f@(BasicFrame size) =- PlacedPiece origin $ Block $+ PlacedPiece origin . Block $ map (bolthole f +^) ( [ bw*^hu +^ n*^hv | n <- [0..bw] ] ++ [ bw*^hu +^ i*^hw +^ n*^hv | i <- [1..bw-1], n <- [0,bw+i] ])- ++ (map (entrance f +^) [neg hu +^ hv, 2 *^ neg hu, neg hu +^ hw,- 2 *^ hw, neg hv +^ hw])+ ++ map (entrance f +^) [neg hu +^ hv, 2 *^ neg hu, neg hu +^ hw,+ 2 *^ hw, neg hv +^ hw] ++ (concat [- map (rotate r) [ (n*^hu) +^ (size*^hw) | n <- [0..size-1] ] | r <- [0..5] ] \\+ [rotate r ((n *^ hu) +^ (size *^ hw)) | n <- [0 .. size - 1]] | r <- [0..5] ] \\ [bolthole f, entrance f]) where bw = boltWidth f @@ -62,8 +62,8 @@ boltArea,toolsArea :: Frame -> [HexPos]-boltArea f = map PHS- [ bolthole f +^ bw*^hu +^ i*^hw +^ n*^hv | i <- [1..bw-1], n <- [1..bw+i-1] ]+boltArea f = [PHS (bolthole f +^ bw *^ hu +^ i *^ hw +^ n *^ hv) |+ i <- [1 .. bw - 1], n <- [1 .. bw + i - 1]] where bw = boltWidth f toolsArea f = [entrance f +^ v +^ origin | v <- [ neg hu, hw, zero ] ]
GameState.hs view
@@ -9,41 +9,42 @@ -- along with this program. If not, see http://www.gnu.org/licenses/. {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-} module GameState where -import Control.Applicative-import Data.Function (on)-import qualified Data.Map as Map-import Data.Map (Map)-import qualified Data.Set as Set-import Data.Set (Set)-import qualified Data.Vector as Vector-import Data.Maybe-import Control.Monad-import Control.Monad.State-import Data.List-import Data.Vector (Vector, (!), (//))+import Control.Applicative+import Control.Monad+import Control.Monad.State+import Data.Function (on)+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Vector (Vector, (!), (//))+import qualified Data.Vector as Vector -import Hex-import Util-import GameStateTypes+import GameStateTypes+import Hex+import Util --import Debug ppidxs :: GameState -> [PieceIdx]-ppidxs = Vector.toList . (Vector.findIndices $ const True) . placedPieces+ppidxs = Vector.toList . Vector.findIndices (const True) . placedPieces getpp :: GameState -> PieceIdx -> PlacedPiece-getpp st idx = (placedPieces st) ! idx+getpp st idx = placedPieces st ! idx setpp :: PieceIdx -> PlacedPiece -> GameState -> GameState setpp idx pp st@(GameState pps _) =- let displacement = (placedPos $ getpp st idx) -^ placedPos pp+ let displacement = placedPos (getpp st idx) -^ placedPos pp updateConn conn@(Connection root@(ridx,rpos) end@(eidx,epos) link) | ridx == idx = Connection (ridx,rpos+^displacement) end link | eidx == idx = Connection root (eidx,epos+^displacement) link | otherwise = conn in st {placedPieces = pps // [(idx, pp)]- , connections = map updateConn $ connections st }+ , connections = updateConn <$> connections st } addpp :: PlacedPiece -> GameState -> GameState addpp pp st@(GameState pps _) = st {placedPieces = Vector.snoc pps pp}@@ -83,9 +84,9 @@ delPieceIn :: HexPos -> GameState -> GameState delPieceIn pos st =- case liftM fst $ Map.lookup pos $ stateBoard st of+ case fst <$> Map.lookup pos (stateBoard st) of Just idx -> delPiece idx st- _ -> st+ _ -> st setPiece :: PieceIdx -> Piece -> GameState -> GameState setPiece idx p st =@@ -93,9 +94,8 @@ adjustPieces :: (Piece -> Piece) -> GameState -> GameState adjustPieces f st =- st { placedPieces = fmap- (\pp -> pp { placedPiece = f $ placedPiece pp })- $ placedPieces st }+ st { placedPieces =+ (\pp -> pp { placedPiece = f $ placedPiece pp }) <$> placedPieces st } addBlockPos :: PieceIdx -> HexPos -> GameState -> GameState addBlockPos b pos st =@@ -108,7 +108,7 @@ in setPiece p (Pivot (pos -^ ppos:arms)) st locusPos :: GameState -> Locus -> HexPos-locusPos s (idx,v) = v +^ (placedPos $ getpp s idx)+locusPos s (idx,v) = v +^ placedPos (getpp s idx) posLocus :: GameState -> HexPos -> Maybe Locus posLocus st pos = listToMaybe [ (idx,pos-^ppos) |@@ -149,19 +149,19 @@ connGraphHeight :: GameState -> PieceIdx -> Int connGraphHeight st idx =- maximum (0 : map ((+1) . connGraphHeight st . fst . connectionRoot) (springsEndAtIdx st idx))+ maximum . (0:) $ (+1) . connGraphHeight st . fst . connectionRoot <$> springsEndAtIdx st idx type Digraph a = Map a (Set a) checkConnGraphAcyclic :: GameState -> Bool checkConnGraphAcyclic st = let idxs = ppidxs st- leaves dg = map fst $ filter (Set.null . snd) $ Map.toList dg+ leaves dg = (fst <$>) . filter (Set.null . snd) $ Map.toList dg checkDigraphAcyclic :: Ord a => Digraph a -> Bool checkDigraphAcyclic dg = case listToMaybe $ leaves dg of Nothing -> Map.null dg- Just leaf -> checkDigraphAcyclic $ Map.delete leaf $ fmap (Set.delete leaf) dg+ Just leaf -> checkDigraphAcyclic $ Map.delete leaf $ Set.delete leaf <$> dg in checkDigraphAcyclic $ Map.fromList- [ (idx, Set.fromList $ map (fst.connectionRoot) $ springsEndAtIdx st idx) | idx <- idxs ]+ [ (idx, Set.fromList $ fst . connectionRoot <$> springsEndAtIdx st idx) | idx <- idxs ] repossessConns :: GameState -> GameState -> GameState repossessConns st st' =@@ -225,8 +225,8 @@ stateBoard :: GameState -> GameBoard stateBoard st@(GameState plPieces conns) = addConnAdjs st conns $- (Map.unions $ map plPieceBoard $ enumVec plPieces) `Map.union`- (Map.unions $ map (connectionBoard st) conns)+ Map.unions (plPieceBoard <$> enumVec plPieces) `Map.union`+ Map.unions (connectionBoard st <$> conns) addConnAdjs :: GameState -> [Connection] -> GameBoard -> GameBoard addConnAdjs st = flip $ foldr addConnAdj@@ -238,21 +238,21 @@ addAdj pos d = Map.adjust (\(o,tile) -> (o,case tile of BlockTile adjs -> BlockTile (d:adjs)- _ -> tile))+ _ -> tile)) pos plPieceBoard :: (PieceIdx,PlacedPiece) -> GameBoard-plPieceBoard (idx,pp) = fmap (\x -> (idx,x)) $ plPieceMap pp+plPieceBoard (idx,pp) = (idx,) <$> plPieceMap pp plPieceMap :: PlacedPiece -> Map HexPos Tile-plPieceMap (PlacedPiece pos (Block pattern)) =- let pattSet = Set.fromList pattern+plPieceMap (PlacedPiece pos (Block patt)) =+ let pattSet = Set.fromList patt in Map.fromList [ (rel +^ pos, BlockTile adjs)- | rel <- pattern+ | rel <- patt , let adjs = filter (\dir -> (rel +^ dir) `Set.member` pattSet) hexDirs ] plPieceMap (PlacedPiece pos (Pivot arms)) = let overarmed = length arms > 2 in- Map.fromList $ (pos, PivotTile $ if overarmed then (head arms) else zero ) :+ Map.fromList $ (pos, PivotTile $ if overarmed then head arms else zero ) : [ (rel +^ pos, ArmTile rel main) | (rel,main) <- zip arms $ repeat False ] plPieceMap (PlacedPiece pos (Hook arm _)) =@@ -266,24 +266,24 @@ fullFootprint :: GameState -> PieceIdx -> [HexPos] -- ^footprint of piece and connections ending at it fullFootprint st idx = plPieceFootprint (getpp st idx) ++- (concat $ map (connectionFootPrint st) $ springsEndAtIdx st idx)+ concatMap (connectionFootPrint st) (springsEndAtIdx st idx) footprintAt :: GameState -> PieceIdx -> [HexPos] -- ^footprint of piece and any connections at it footprintAt st idx = plPieceFootprint (getpp st idx) ++- (concat $ map (connectionFootPrint st) $ springsAtIdx st idx)+ concatMap (connectionFootPrint st) (springsAtIdx st idx) footprintAtIgnoring :: GameState -> PieceIdx -> PieceIdx -> [HexPos] -- ^footprint of piece and any connections at it, except those with idx' footprintAtIgnoring st idx idx' = plPieceFootprint (getpp st idx) ++- (concat $ map (connectionFootPrint st) $ springsAtIdxIgnoring st idx idx')+ concatMap (connectionFootPrint st) (springsAtIdxIgnoring st idx idx') collisions :: GameState -> PieceIdx -> PieceIdx -> [HexPos] -- ^intersections of two pieces and their connections, disregarding -- the connections which connect the two pieces collisions st idx idx' = intersect (footprintAt st idx) (footprintAt st idx') \\- (concat $ map (connectionFootPrint st) $ connectionsBetween st idx idx')+ concatMap (connectionFootPrint st) (connectionsBetween st idx idx') connectionBoard :: GameState -> Connection -> GameBoard connectionBoard st (Connection root end@(eidx,_) (Spring dir natLen)) =@@ -307,7 +307,7 @@ where castRay' 0 _ = Nothing castRay' n pos = case Map.lookup pos board of- Nothing -> castRay' (n-1) (dir+^pos)+ Nothing -> castRay' (n-1) (dir+^pos) Just (idx,_) -> Just (idx,pos) validGameState :: GameState -> Bool@@ -322,25 +322,23 @@ (stateBoard $ GameState pps (conns \\ [c])) == Just (eidx, epos) && springExtensionValid st c- && (validRoot st root)- && (validEnd st end)+ && validRoot st root+ && validEnd st end | c@(Connection root@(ridx,_) end@(eidx,_) (Spring dir _)) <- conns- , let [rpos,epos] = map (locusPos st) [root,end] ]+ , let [rpos,epos] = locusPos st <$> [root,end] ] , and [ 1 == length (components $ Set.fromList patt)- | Block patt <- map placedPiece $ Vector.toList pps ]+ | Block patt <- placedPiece <$> Vector.toList pps ] ] validRoot st (idx,v) = case placedPiece $ getpp st idx of (Block _) -> True (Pivot _) -> v==zero- _ -> False+ _ -> False validEnd st (idx,_) = case placedPiece $ getpp st idx of (Block _) -> True- _ -> False+ _ -> False -checkValidHex (GameState pps conns) = and- [ all validPP $ Vector.toList pps- , all validConn conns ]+checkValidHex (GameState pps conns) = all validPP (Vector.toList pps) && all validConn conns where validVec (HexVec x y z) = x+y+z==0 validPos (PHS v) = validVec v@@ -349,9 +347,9 @@ validPiece (Block patt) = all validVec patt validPiece (Pivot arms) = all validDir arms validPiece (Hook dir _) = validDir dir- validPiece _ = True+ validPiece _ = True validConn (Connection (_,rv) (_,ev) link) = all validVec [rv,ev] && validLink link- validLink (Free v) = validVec v+ validLink (Free v) = validVec v validLink (Spring dir _) = validDir dir protectedPiece :: PieceIdx -> Bool
GameStateTypes.hs view
@@ -10,12 +10,12 @@ module GameStateTypes where -import Data.Map (Map)-import Data.Vector (Vector)-import Hex+import Data.Map (Map)+import Data.Vector (Vector)+import Hex data GameState = GameState { placedPieces :: Vector PlacedPiece,- connections :: [Connection] }+ connections :: [Connection] } deriving (Eq, Ord, Show, Read) data PlacedPiece = PlacedPiece { placedPos :: HexPos, placedPiece :: Piece }@@ -59,13 +59,13 @@ deriving (Eq, Ord, Show, Read) tileType :: Tile -> Tile-tileType (BlockTile _) = BlockTile []-tileType (PivotTile _) = PivotTile zero-tileType (ArmTile _ _) = ArmTile zero False-tileType (WrenchTile _) = WrenchTile zero-tileType (BallTile) = BallTile+tileType (BlockTile _) = BlockTile []+tileType (PivotTile _) = PivotTile zero+tileType (ArmTile _ _) = ArmTile zero False+tileType (WrenchTile _) = WrenchTile zero+tileType BallTile = BallTile tileType (SpringTile _ _) = SpringTile Relaxed zero-tileType t = t+tileType t = t type OwnedTile = (PieceIdx, Tile) type GameBoard = Map HexPos OwnedTile
GraphColouring.hs view
@@ -10,13 +10,13 @@ module GraphColouring (fiveColour) where -import qualified Data.Map as Map-import Data.Map (Map)-import qualified Data.Set as Set-import Data.Set (Set)+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set import qualified Data.Vector as Vector-import Data.List-import Data.Maybe type Colouring a = Map a Int type Graph a = (Set a, Set (Set a))@@ -44,7 +44,7 @@ fiveColour' :: Ord a => Colouring a -> PlanarGraph a -> Colouring a fiveColour' pref g | g == Map.empty = Map.empty fiveColour' pref g =- let adjsOf v = (nub $ g Map.! v) \\ [v]+ let adjsOf v = nub (g Map.! v) \\ [v] v0 = head $ filter ((<=5) . length . adjsOf) $ Map.keys g adjs = adjsOf v0 addTo c =@@ -52,9 +52,9 @@ in Map.insert v0 vc c in if length adjs < 5 then addTo $ fiveColour' pref $ deleteNode v0 g- else let (v',v'') = if adjs!!2 `elem` (g Map.! (adjs!!0))+ else let (v',v'') = if adjs!!2 `elem` (g Map.! head adjs) then (adjs!!1,adjs!!3)- else (adjs!!0,adjs!!2)+ else (head adjs,adjs!!2) in addTo $ demerge v' v'' $ fiveColour' pref $ merge v0 v' v'' g possCols :: Ord a => Colouring a -> a -> [Int]
Hex.lhs view
@@ -67,7 +67,7 @@ tupxy2hv (x,y) = HexVec x y (-(x+y)) hexLen :: HexVec -> Int-hexLen (HexVec x y z) = maximum $ map abs [x,y,z]+hexLen (HexVec x y z) = maximum $ abs <$> [x,y,z] hexDot :: HexVec -> HexVec -> Int hexDot (HexVec x y z) (HexVec x' y' z') = x*x'+y*y'+z*z'@@ -90,7 +90,7 @@ | -x > 0 && -y >= 0 = 3 | z > 0 && x >= 0 = 4 | -y > 0 && -z >= 0 = 5- | otherwise = error $ "Tried to take hextant of zero"+ | otherwise = error "Tried to take hextant of zero" -- hextant (rotate n hu) == n rotate :: Int -> HexVec -> HexVec@@ -108,7 +108,7 @@ cmpAngles v@(HexVec x y _) v'@(HexVec x' y' _) | v == zero && v' == zero = EQ | v == zero = LT- | compare (hextant v) (hextant v') /= EQ = + | hextant v /= hextant v' = compare (hextant v) (hextant v') | hextant v /= 0 = cmpAngles (rotate (-(hextant v)) v) (rotate (-(hextant v)) v')@@ -132,7 +132,7 @@ isHexDirOrZero v = hexLen v <= 1 hexDirs :: [HexDir]-hexDirs = map (`rotate` hu) [0..5]+hexDirs = (`rotate` hu) <$> [0..5] hexVec2HexDirOrZero :: HexVec -> HexDirOrZero hexVec2HexDirOrZero v@@ -153,9 +153,9 @@ scaleToLength n v@(HexVec x y z) = let l = hexLen v- lv' = map ((`div`l).(n*)) [x,y,z]+ lv' = (`div`l) . (n*) <$> [x,y,z] minI = fst $ minimumBy (compare `on` snd) $- zip [0..] $ map abs lv'+ zip [0..] $ abs <$> lv' [x'',y'',z''] = zipWith (-) lv' [ d | i <- [0..2] , let d = if i == minI then sum lv' else 0 ]@@ -186,7 +186,7 @@ class Differable a b c where (-^) :: a -> b -> c instance Grp g => Differable g g g where- x -^ y = x +^ (neg y)+ x -^ y = x +^ neg y newtype PHS g = PHS { getPHS :: g } deriving (Eq, Ord, Show, Read)@@ -204,7 +204,7 @@ 0 *^ _ = zero 1 *^ x = x n *^ x- | n < 0 = (-n) *^ (neg x)+ | n < 0 = (-n) *^ neg x | even n = (n `div` 2) *^ (x +^ x) | otherwise = x +^ ((n `div` 2) *^ (x +^ x))
Init.hs view
@@ -11,23 +11,24 @@ module Init where -import Control.Applicative-import Control.Monad-import Control.Monad.Trans-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.State-import Data.Maybe-import System.Exit-import System.Environment-import System.Directory-import System.FilePath-import System.Console.GetOpt+import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.State+import Data.Maybe+import System.Console.GetOpt+import System.Directory+import System.Environment+import System.Exit+import System.FilePath -import Lock-import MainState-import Interact-import Util-import Version+import Interact+import Lock+import MainState+import Mundanities+import Util+import Version data Opt = LockSize Int | ForceCurses | Help | Version deriving (Eq, Ord, Show)@@ -45,7 +46,7 @@ parseArgs :: [String] -> IO ([Opt],[String]) parseArgs argv = case getOpt Permute options argv of- (o,n,[]) -> return (o,n)+ (o,n,[]) -> return (o,n) (_,_,errs) -> ioError (userError (concat errs ++ usage)) setup :: IO (Maybe Lock,[Opt],Maybe String)@@ -71,18 +72,18 @@ main' msdlUI mcursesUI = do (mlock,opts,mpath) <- setup initMState <- case mlock of- Nothing -> initMetaState Just lock -> return $ newEditState lock Nothing mpath+ Nothing -> initMetaState void $ runMaybeT $ msum [ do finalState <- msum [ do guard $ ForceCurses `notElem` opts- sdlUI <- liftMaybe $ msdlUI+ sdlUI <- liftMaybe msdlUI MaybeT $ sdlUI $ interactUI `execStateT` initMState , do- cursesUI <- liftMaybe $ mcursesUI+ cursesUI <- liftMaybe mcursesUI MaybeT $ cursesUI $ interactUI `execStateT` initMState ]- when (isNothing mlock) $ lift $ writeMetaState finalState- lift $ exitSuccess+ lift $ writeMetaState finalState+ lift exitSuccess , lift exitFailure ]
InputMode.hs view
@@ -10,5 +10,5 @@ module InputMode where -data InputMode = IMEdit | IMPlay | IMReplay | IMMeta | IMTextInput | IMImpatience+data InputMode = IMEdit | IMPlay | IMReplay | IMInit | IMMeta | IMTextInput | IMImpatience deriving (Eq, Ord, Show, Read)
Interact.hs view
@@ -8,82 +8,83 @@ -- 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 LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} module Interact (interactUI) where -import Control.Monad.State-import Control.Applicative-import qualified Data.Vector as Vector-import qualified Data.Map as Map-import Data.Map (Map)-import Control.Monad.Writer-import Control.Monad.Trans.Except-import Control.Monad.Trans.Maybe-import Control.Exception-import Data.Maybe-import Data.Char-import Data.List-import Control.Concurrent.STM-import Control.Concurrent-import System.Directory-import System.FilePath-import Data.Array-import Data.Function (on)-import Safe (readMay)-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Char8 as CS+import Control.Applicative+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad.Catch+import Control.Monad.State+import Control.Monad.Trans.Except+import Control.Monad.Trans.Maybe+import Control.Monad.Writer+import Data.Array+import qualified Data.ByteString.Char8 as CS+import qualified Data.ByteString.Lazy as BL+import Data.Char+import Data.Function (on)+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import qualified Data.Vector as Vector+import Safe (readMay)+import System.Directory+import System.FilePath -import Crypto.Types.PubKey.RSA (PublicKey)-import Codec.Crypto.RSA (encrypt)-import Crypto.Random (newGenIO, SystemRandom)+import Codec.Crypto.RSA (encrypt)+import Crypto.Random (SystemRandom, newGenIO)+import Crypto.Types.PubKey.RSA (PublicKey) -import Hex-import Command-import Physics-import Mundanities-import AsciiLock-import GameState-import GameStateTypes-import EditGameState-import Frame-import Lock-import Cache-import Database-import Protocol-import Metagame-import ServerAddr-import MainState-import InputMode-import Maxlocksize-import InteractUtil-import Util+import AsciiLock+import Cache+import Command+import Database+import EditGameState+import Frame+import GameState+import GameStateTypes+import Hex+import InputMode+import InteractUtil+import Lock+import MainState+import Maxlocksize+import Metagame+import Mundanities+import Physics+import Protocol+import ServerAddr+import Util newtype InteractSuccess = InteractSuccess Bool interactUI :: UIMonad uiM => MainStateT uiM InteractSuccess-interactUI = do- im <- gets ms2im- lift $ onNewMode im- when (im == IMEdit) setSelectedPosFromMouse- when (im == IMMeta) $ do- spawnUnblockerThread+interactUI = (fromMaybe (InteractSuccess False) <$>) . runMaybeT $ do+ gets initiationRequired >>? lift doInitiation+ gets initiationRequired >>? mzero+ lift $ do+ im <- gets ms2im+ lift $ onNewMode im+ when (im == IMEdit) setSelectedPosFromMouse+ when (im == IMMeta) $ do+ spawnUnblockerThread - -- draw before testing auth, lest a timeout mean a blank screen- drawMainState+ -- draw before testing auth, lest a timeout mean a blank screen+ drawMainState - testAuth- refreshUInfoUI- tbdg <- lift $ getUIBinding IMMeta CmdTutorials- isNothing <$> gets curAuth >>?- lift $ drawMessage $ "Welcome. To play the tutorial levels, press '"++tbdg++"'."- setMark False startMark- interactLoop+ testAuth+ refreshUInfoUI+ setMark False startMark+ interactLoop where+ initiationRequired s = ms2im s == IMMeta && not (initiated s) interactLoop = do- mainSt <- get- let im = ms2im mainSt+ im <- gets ms2im when (im == IMPlay) checkWon when (im == IMMeta) $ (checkAsync >>) $ void.runMaybeT $ mourNameSelected >>? lift purgeInvalidUndecls@@ -91,7 +92,7 @@ cmds <- lift $ getSomeInput im runExceptT (mapM_ (processCommand im) cmds) >>= either- ((lift (drawMessage "") >>) . return)+ ((lift clearMessage >>) . return) (const interactLoop) -- | unblock input whenever the newAsync TVar is set to True@@ -112,6 +113,25 @@ execSubMainState :: UIMonad uiM => MainState -> MainStateT uiM MainState execSubMainState = (snd <$>) . runSubMainState +doInitiation :: UIMonad uiM => MainStateT uiM ()+doInitiation = do+ (InteractSuccess complete, s) <- runSubMainState =<< liftIO initInitState+ liftIO $ writeInitState s+ when complete $ do+ modify $ \s -> s {initiated = True}+ mauth <- gets curAuth+ when (isNothing mauth) $ do+ cbdg <- lift $ getUIBinding IMMeta $ CmdSelCodename Nothing+ rbdg <- lift $ getUIBinding IMMeta (CmdRegister False)+ let showPage p prompt = lift $ withNoBG $ showHelp IMMeta p >>? do+ void $ textInput prompt 1 False True Nothing Nothing+ showPage (HelpPageInitiated 1) "[Initiation complete. Press a key or RMB to continue]"+ showPage (HelpPageInitiated 2) "[Press a key or RMB to continue]"+ showPage (HelpPageInitiated 3) "[Press a key or RMB to continue]"+ lift $ drawMessage $+ "To join the game: pick a codename ('"++cbdg+++ "') and register it ('"++rbdg++"')."+ getSomeInput im = do cmds <- getInput im if null cmds then getSomeInput im else return cmds@@ -119,12 +139,11 @@ processCommand :: UIMonad uiM => InputMode -> Command -> ExceptT InteractSuccess (MainStateT uiM) () processCommand im CmdQuit = do case im of- IMReplay -> throwE $ InteractSuccess False- IMPlay -> lift (or <$> sequence [gets psIsSub, gets psSaved, null <$> gets psGameStateMoveStack])+ IMPlay -> lift (or <$> sequence [gets psIsSub, gets psSaved, gets (null . psGameStateMoveStack)]) >>? throwE $ InteractSuccess False IMEdit -> lift editStateUnsaved >>! throwE $ InteractSuccess True- _ -> return ()- title <- lift $ getTitle+ _ -> throwE $ InteractSuccess False+ title <- lift getTitle (lift . lift . confirm) ("Really quit" ++ (if im == IMEdit then " without saving" else "") ++ maybe "" (" from "++) title ++ "?")@@ -136,19 +155,67 @@ if checkSolved (frame,st) then throwE $ InteractSuccess True else lift.lift $ drawError "Locked!"++processCommand IMInit (CmdSolveInit Nothing) = void.runMaybeT $ do+ tutSolved <- lift . gets $ tutSolved . tutProgress+ accessible <- lift . gets $ accessibleInitLocks tutSolved . initLocks+ v <- if Map.null accessible then return zero else do+ let nameMap = Map.fromList $ ("TUT",zero) :+ [(initLockName l, v) | (v,l) <- Map.toList accessible]+ names = Map.keys nameMap+ name <- (map toUpper <$>) . MaybeT . lift . lift $+ textInput ("Solve which? ["+ ++ intercalate "," (take 3 names)+ ++ if length names > 3 then ",...]" else "]")+ 3 False True (Just names) Nothing+ MaybeT . return $ Map.lookup name nameMap+ lift . processCommand IMInit . CmdSolveInit $ Just v+processCommand IMInit (CmdSolveInit (Just v)) | v == zero = lift.void.runMaybeT $ do+ tutdir <- liftIO $ getDataPath "tutorial"+ tuts <- liftIO . ignoreIOErr $+ sort . map (takeWhile (/='.')) . filter (isSuffixOf ".lock") <$>+ getDirectoryContents tutdir+ when (null tuts) $ do+ lift.lift $ drawError "No tutorial levels found"+ mzero+ let dotut i msps = do+ let name = tuts !! (i-1)+ let pref = tutdir ++ [pathSeparator] ++ name+ (lock,_) <- MaybeT $ liftIO $ readLock (pref ++ ".lock")+ text <- liftIO $ fromMaybe "" . listToMaybe <$> readStrings (pref ++ ".text")+ solveLockSaving i msps (Just i) lock $ Just $ "Tutorial " ++ show i ++ ": " ++ text+ if i+1 <= length tuts+ then dotut (i+1) Nothing+ else lift $ do+ modify $ \is -> is {tutProgress = TutProgress True 1 Nothing}+ lift $ drawMessage "Tutorial complete!"+ TutProgress _ onLevel msps <- lift $ gets tutProgress+ dotut onLevel msps+processCommand IMInit (CmdSolveInit (Just v)) = void.runMaybeT $ do+ l@InitLock { initLockDesc=desc, initLockLock=lock, initLockPartial=partial } <-+ MaybeT . lift $ gets (Map.lookup v . initLocks)+ lift $ do+ (InteractSuccess solved, ps) <- lift . runSubMainState $+ maybe newPlayState restorePlayState partial (reframe lock) (Just desc) Nothing False True+ let updateLock initLock = initLock { initLockSolved = initLockSolved initLock || solved+ , initLockPartial = Just $ savePlayState ps }+ lift . modify $ \is -> is { initLocks = Map.adjust updateLock v $ initLocks is }+ when (solved && isLastInitLock l) . throwE $ InteractSuccess True+ processCommand im cmd = lift $ processCommand' im cmd processCommand' :: UIMonad uiM => InputMode -> Command -> MainStateT uiM () processCommand' im CmdHelp = lift $ do helpPages <- case im of+ IMInit -> return [HelpPageGame] IMMeta -> return [HelpPageInput, HelpPageGame] IMEdit -> do first <- not <$> liftIO hasLocks- return $ [HelpPageInput] ++ if first then [HelpPageFirstEdit] else []+ return $ HelpPageInput : [HelpPageFirstEdit | first] _ -> return [HelpPageInput] let showPage p = withNoBG $ showHelp im p >>? do void $ textInput "[press a key or RMB]" 1 False True Nothing Nothing- sequence_ $ map showPage helpPages+ mapM_ showPage helpPages processCommand' im (CmdBind mcmd)= lift $ (>> endPrompt) $ runMaybeT $ do cmd <- liftMaybe mcmd `mplus` do lift $ drawPrompt False "Command to bind: "@@ -164,7 +231,7 @@ processCommand' _ CmdSuspend = lift suspend processCommand' _ CmdRedraw = lift redraw processCommand' im CmdClear = do- lift $ drawMessage ""+ lift clearMessage when (im == IMMeta) $ modify $ \ms -> ms { retiredLocks = Nothing } processCommand' im CmdMark = void.runMaybeT $ do guard $ im `elem` [IMEdit, IMPlay, IMReplay]@@ -178,13 +245,15 @@ marks <- lift marksSet str <- MaybeT $ lift $ textInput ("Jump to mark [" ++ intersperse ',' marks ++ "]: ")- 1 False True (Just $ map (:[]) marks) Nothing+ 1 False True (Just $ (:[]) <$> marks) Nothing ch <- liftMaybe $ listToMaybe str lift $ jumpMark ch processCommand' im CmdReset = jumpMark startMark++processCommand' IMMeta CmdInitiation = doInitiation processCommand' IMMeta (CmdSelCodename mname) = void.runMaybeT $ do mauth <- gets curAuth- name <- msum [ liftMaybe $ mname+ name <- msum [ liftMaybe mname , do newCodename <- (map toUpper <$>) $ MaybeT $ lift $ textInput "Select codename:"@@ -194,13 +263,13 @@ ] guard $ validCodeName name lift $ do- modify $ \ms -> ms { codenameStack = (name:codenameStack ms) }+ modify $ \ms -> ms { codenameStack = name:codenameStack ms } invalidateUInfo name refreshUInfoUI processCommand' IMMeta CmdHome = void.runMaybeT $ do ourName <- mgetOurName lift $ do- modify $ \ms -> ms { codenameStack = (ourName:codenameStack ms) }+ modify $ \ms -> ms { codenameStack = ourName:codenameStack ms } refreshUInfoUI processCommand' IMMeta CmdBackCodename = do stack <- gets codenameStack@@ -209,10 +278,10 @@ refreshUInfoUI processCommand' IMMeta CmdSetServer = void.runMaybeT $ do saddr <- gets curServer- saddrs <- liftIO $ knownServers+ saddrs <- liftIO knownServers newSaddr' <- MaybeT $ ((>>= strToSaddr) <$>) $ lift $ textInput "Set server:" 256 False False- (Just $ map saddrStr saddrs) (Just $ saddrStr saddr)+ (Just $ saddrStr <$> saddrs) (Just $ saddrStr saddr) let newSaddr = if nullSaddr newSaddr' then defaultServerAddr else newSaddr' modify $ \ms -> ms { curServer = newSaddr } msum [ void.MaybeT $ getFreshRecBlocking RecServerInfo@@ -220,7 +289,7 @@ lift $ do modify $ \ms -> ms {curAuth = Nothing} get >>= liftIO . writeServerSolns saddr- (undecls,partials,_) <- liftIO (readServerSolns newSaddr)+ (undecls,partials) <- liftIO (readServerSolns newSaddr) modify $ \ms -> ms { undeclareds=undecls, partialSolutions=partials } rnamestvar <- gets randomCodenames liftIO $ atomically $ writeTVar rnamestvar []@@ -286,7 +355,7 @@ ServerError err -> lift $ drawError err _ -> lift $ drawMessage $ "Bad server response: " ++ show resp - + processCommand' IMMeta CmdAuth = void.runMaybeT $ do auth <- lift $ gets curAuth if isJust auth then do@@ -297,7 +366,7 @@ passwd <- inputPassword name False $ "Enter password for "++name++":" lift $ do modify $ \ms -> ms {curAuth = Just $ Auth name passwd}- resp <- curServerAction $ Authenticate+ resp <- curServerAction Authenticate case resp of ServerAck -> lift $ drawMessage "Authenticated." ServerMessage msg -> lift $ drawMessage $ "Server: " ++ msg@@ -321,10 +390,10 @@ declare undecl , do RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls- mpartial <- Map.lookup ls <$> gets partialSolutions- soln <- solveLockSaving ls mpartial False lock $ Just $+ mpartial <- gets (Map.lookup ls . partialSolutions)+ soln <- solveLockSaving ls mpartial Nothing lock $ Just $ "solving " ++ name ++ ":" ++ [lockIndexChar idx] ++ " (#" ++ show ls ++")"- mourName <- lift $ (authUser <$>) <$> gets curAuth+ mourName <- lift $ gets ((authUser <$>) . curAuth) guard $ mourName /= Just name let undecl = Undeclared soln ls (ActiveLock name idx) msum [ do@@ -332,7 +401,7 @@ confirmOrBail "Declare solution?" declare undecl , unless (any (\(Undeclared _ ls' _) -> ls == ls') undecls) $- modify $ \ms -> ms { undeclareds = (undecl : undeclareds ms) }+ modify $ \ms -> ms { undeclareds = undecl : undeclareds ms } ] ] processCommand' IMMeta (CmdPlayLockSpec mls) = void.runMaybeT $ do@@ -354,7 +423,7 @@ then return $ head undecls else do which <- MaybeT $ lift $ textInput- ("Declare which solution?")+ "Declare which solution?" 5 False True Nothing Nothing liftMaybe $ msum [ do@@ -364,11 +433,8 @@ , listToMaybe $ [ undecl | undecl@(Undeclared _ _ (ActiveLock name' i)) <- undecls- , or- [ take (length which) (name' ++ ":" ++ [lockIndexChar i]) ==- map toUpper which- , name'==name && [lockIndexChar i] == which- ]+ , (take (length which) (name' ++ ":" ++ [lockIndexChar i]) ==+ map toUpper which) || (name'==name && [lockIndexChar i] == which) ] ] ]@@ -386,14 +452,14 @@ | mlockinfo <- elems $ userLocks uinfo ] idx <- askLockIndex "View solution to which lock?" "No solutions to view" $ not.null.(noteses!!) let notes = noteses!!idx- authors = map noteAuthor notes+ authors = noteAuthor <$> notes author <- if length notes == 1 then return $ noteAuthor $ head notes else (map toUpper <$>) $ MaybeT $ lift $ textInput ("View solution by which player? [" ++ intercalate "," (take 3 authors) ++ if length authors > 3 then ",...]" else "]")- 3 False True (Just $ authors) Nothing+ 3 False True (Just authors) Nothing liftMaybe $ find ((==author).noteAuthor) notes let ActiveLock name idx = noteOn note uinfo <- mgetUInfo name@@ -416,7 +482,7 @@ askLockIndex ("Place " ++ show lockpath ++ " in which slot?") "bug" $ const True when (isJust $ userLocks ourUInfo ! idx) $ confirmOrBail "Really retire existing lock?"- soln <- (liftMaybe msoln `mplus`) $ solveLock lock $ Just $ "testing lock"+ soln <- (liftMaybe msoln `mplus`) $ solveLock lock $ Just "testing lock" lift $ curServerActionAsyncThenInvalidate (SetLock lock idx soln) (Just (SomeCodenames [ourName]))@@ -431,11 +497,12 @@ processCommand' IMMeta CmdPrevLock = gets curLockPath >>= liftIO . nextLock False >>= setLockPath processCommand' IMMeta CmdNextPage =- modify $ \ms -> ms { listOffset = listOffset ms + 1 }+ gets listOffsetMax >>!+ modify $ \ms -> ms { listOffset = listOffset ms + 1 } processCommand' IMMeta CmdPrevPage = modify $ \ms -> ms { listOffset = max 0 $ listOffset ms - 1 } processCommand' IMMeta CmdEdit = void.runMaybeT $ do- (lock, msoln) <- (MaybeT $ gets curLock) `mplus` do+ (lock, msoln) <- MaybeT (gets curLock) `mplus` do size <- msum [ do gets curServer@@ -458,49 +525,9 @@ newPath <- MaybeT $ (esPath <$>) $ execSubMainState $ newEditState (reframe lock) msoln (if null path then Nothing else Just path) lift $ setLockPath newPath-processCommand' IMMeta CmdTutorials = void.runMaybeT $ do- tutdir <- liftIO $ getDataPath "tutorial"- tuts <- liftIO $ (sort . map (takeWhile (/='.')) . filter (isSuffixOf ".lock")) <$>- getDirectoryContents tutdir `catchIO` (const $ return [])- when (null tuts) $ do- lift.lift $ drawError "No tutorial levels found"- mzero- -- s <- MaybeT $ lift $ textInput ("Play which tutorial level? [1-"++show (length tuts)++"]")- -- (length (show (length tuts))) False True Nothing Nothing- -- i <- liftMaybe $ readMay s- -- guard $ 1 <= i && i <= length tuts- let dotut i msps = do- let name = tuts !! (i-1)- let pref = tutdir ++ [pathSeparator] ++ name- (lock,_) <- MaybeT $ liftIO $ readLock (pref ++ ".lock")- text <- liftIO $ (fromMaybe "" . listToMaybe) <$> (readStrings (pref ++ ".text") `catchIO` const (return []))- solveLockSaving i msps True lock $ Just $ "Tutorial " ++ show i ++ ": " ++ text- if i+1 <= length tuts then do- -- confirmOrBail $ "Tutorial level completed! Play next tutorial level (" ++ show (i+1) ++ ")?"- dotut (i+1) Nothing- else lift $ do- modify $ \ms -> ms {tutProgress = (1,Nothing)}- mauth <- gets curAuth- cbdg <- lift $ getUIBinding IMMeta $ CmdSelCodename Nothing- rbdg <- lift $ getUIBinding IMMeta (CmdRegister False)- if isNothing mauth- then do- let showPage p prompt = lift $ withNoBG $ showHelp IMMeta p >>? do- void $ textInput prompt 1 False True Nothing Nothing- showPage (HelpPageInitiated 1) "[Tutorial complete! Press a key or RMB to continue]"- showPage (HelpPageInitiated 2) "[Press a key or RMB to continue]"- showPage (HelpPageInitiated 3) "[Press a key or RMB to continue]"- --showPage HelpPageGame "[Press a key or RMB to continue; you can review this information later with '?']"- lift $ drawMessage $ - "To join the game: pick a codename ('"++cbdg++- "') and register it ('"++rbdg++"')."- else lift $ drawMessage $ "Tutorial completed!"- - (onLevel,msps) <- lift $ gets tutProgress- dotut onLevel msps processCommand' IMMeta CmdShowRetired = void.runMaybeT $ do name <- mgetCurName- newRL <- lift (gets retiredLocks) >>= \rl -> case rl of+ newRL <- lift (gets retiredLocks) >>= \case Nothing -> do RCLockSpecs lss <- MaybeT $ getFreshRecBlocking $ RecRetiredLocks name if null lss@@ -529,26 +556,25 @@ pushPState (st',pm) modify $ \ps -> ps {psLastAlerts = alerts, psUndoneStack = ustms'} processCommand' IMPlay (CmdManipulateToolAt pos) = do- board <- stateBoard <$> gets psCurrentState+ board <- gets (stateBoard . psCurrentState) wsel <- gets wrenchSelected- void.runMaybeT $ msum $ [ do+ void.runMaybeT $ msum $ (do tile <- liftMaybe $ snd <$> Map.lookup pos board guard $ case tile of {WrenchTile _ -> True; HookTile -> True; _ -> False}- lift $ processCommand' IMPlay $ CmdTile tile- ] ++ [ do+ lift $ processCommand' IMPlay $ CmdTile tile) : [ do tile <- liftMaybe $ snd <$> Map.lookup (d+^pos) board guard $ tileType tile == if wsel then WrenchTile zero else HookTile lift $ processCommand' IMPlay $ CmdDir WHSSelected $ neg d | d <- hexDirs ] processCommand' IMPlay (CmdDrag pos dir) = do- board <- stateBoard <$> gets psCurrentState+ board <- gets (stateBoard . psCurrentState) wsel <- gets wrenchSelected void.runMaybeT $ do tp <- liftMaybe $ tileType . snd <$> Map.lookup pos board msum [ guard $ tp == HookTile , do guard $ tp == WrenchTile zero- board' <- lift $ stateBoard . fst . runWriter . physicsTick (WrenchPush dir) <$> gets psCurrentState+ board' <- lift $ gets ((stateBoard . fst . runWriter . physicsTick (WrenchPush dir)) . psCurrentState) msum $ [ do tp' <- liftMaybe $ tileType . snd <$> Map.lookup pos' board' guard $ tp' == WrenchTile zero@@ -556,13 +582,13 @@ , let pos' = d *^ dir +^ pos ] ++ [ (lift.lift $ warpPointer pos) >> mzero ] ]- lift $ processCommand' IMPlay $ CmdDir WHSSelected $ dir- board' <- stateBoard <$> gets psCurrentState+ lift $ processCommand' IMPlay $ CmdDir WHSSelected dir+ board' <- gets (stateBoard . psCurrentState) msum [ do tp' <- liftMaybe $ tileType . snd <$> Map.lookup pos' board' guard $ tp' == if wsel then WrenchTile zero else HookTile lift.lift $ warpPointer pos'- | pos' <- map (+^pos) $ hexDisc 2 ]+ | pos' <- (+^pos) <$> hexDisc 2 ] processCommand' IMPlay cmd = do wsel <- gets wrenchSelected@@ -579,14 +605,14 @@ (wsel', pm) = case cmd of CmdTile (WrenchTile _) -> (True, Nothing)- CmdTile HookTile -> (False, Nothing)- CmdTile (ArmTile _ _) -> (False, Nothing)- CmdToggle -> (not wsel, Nothing)- CmdDir whs dir -> (wsel, push whs dir)- CmdRotate whs dir -> (wsel, torque whs dir)- CmdWait -> (wsel, Just NullPM)- CmdSelect -> (wsel, Just NullPM)- _ -> (wsel, Nothing)+ CmdTile HookTile -> (False, Nothing)+ CmdTile (ArmTile _ _) -> (False, Nothing)+ CmdToggle -> (not wsel, Nothing)+ CmdDir whs dir -> (wsel, push whs dir)+ CmdRotate whs dir -> (wsel, torque whs dir)+ CmdWait -> (wsel, Just NullPM)+ CmdSelect -> (wsel, Just NullPM)+ _ -> (wsel, Nothing) modify $ \ps -> ps {wrenchSelected = wsel'} case pm of Nothing -> return ()@@ -596,7 +622,7 @@ pushPState (st',pm') processCommand' IMReplay (CmdReplayBack 1) = void.runMaybeT $ do- (st',pm) <- MaybeT $ listToMaybe <$> gets rsGameStateMoveStack+ (st',pm) <- MaybeT $ gets (listToMaybe . rsGameStateMoveStack) lift $ modify $ \rs -> rs {rsCurrentState=st' , rsLastAlerts = [] , rsGameStateMoveStack = tail $ rsGameStateMoveStack rs@@ -604,7 +630,7 @@ processCommand' IMReplay (CmdReplayBack n) = replicateM_ n $ processCommand' IMReplay (CmdReplayBack 1) processCommand' IMReplay (CmdReplayForward 1) = void.runMaybeT $ do- pm <- MaybeT $ listToMaybe <$> gets rsMoveStack+ pm <- MaybeT $ gets (listToMaybe . rsMoveStack) lift $ do st <- gets rsCurrentState (st',alerts) <- lift $ doPhysicsTick pm st@@ -652,7 +678,7 @@ let selPiece' = if isJust selPiece then Nothing- else liftM fst $ Map.lookup selPos $ stateBoard st+ else fmap fst . Map.lookup selPos $ stateBoard st modify $ \es -> es {selectedPiece = selPiece'} processCommand' IMEdit (CmdDir _ dir) = do selPos <- gets selectedPos@@ -664,23 +690,23 @@ processCommand' IMEdit (CmdMoveTo newPos) = setSelectedPos newPos processCommand' IMEdit (CmdDrag pos dir) = do- board <- stateBoard <$> gets esGameState+ board <- gets (stateBoard . esGameState) void.runMaybeT $ do selIdx <- MaybeT $ gets selectedPiece idx <- liftMaybe $ fst <$> Map.lookup pos board guard $ idx == selIdx- lift $ processCommand' IMEdit $ CmdDir WHSSelected $ dir- board' <- stateBoard <$> gets esGameState+ lift $ processCommand' IMEdit $ CmdDir WHSSelected dir+ board' <- gets (stateBoard . esGameState) msum [ do idx' <- liftMaybe $ fst <$> Map.lookup pos' board' guard $ idx' == selIdx- lift.lift $ warpPointer $ pos'+ lift.lift $ warpPointer pos' | pos' <- [dir+^pos, pos] ] processCommand' IMEdit (CmdRotate _ dir) = do selPiece <- gets selectedPiece case selPiece of Nothing -> return ()- Just p -> doForce $ Torque p dir+ Just p -> doForce $ Torque p dir processCommand' IMEdit (CmdTile tile) = do selPos <- gets selectedPos drawTile selPos (Just tile) False@@ -697,17 +723,17 @@ let getDir = do cmd <- lift $ head <$> getSomeInput IMEdit case cmd of- CmdDir _ mergeDir -> return $ Just mergeDir+ CmdDir _ mergeDir -> return $ Just mergeDir CmdDrag _ mergeDir -> return $ Just mergeDir- CmdMoveTo _ -> getDir- _ -> return $ Nothing+ CmdMoveTo _ -> getDir+ _ -> return Nothing mergeDir <- getDir case mergeDir of Just mergeDir -> modifyEState $ mergeTiles selPos mergeDir True- _ -> return ()+ _ -> return () -- XXX: merging might invalidate selectedPiece modify $ \es -> es {selectedPiece = Nothing}- lift $ drawMessage ""+ lift clearMessage processCommand' IMEdit CmdWait = do st <- gets esGameState (st',_) <- lift $ doPhysicsTick NullPM st@@ -726,17 +752,17 @@ newPath <- MaybeT $ lift $ textInput "Save lock as:" 1024 False False Nothing path guard $ not $ null newPath fullPath <- liftIO $ fullLockPath newPath- liftIO (doesFileExist fullPath `catchIO` const (return True)) >>?+ liftIO (fileExists fullPath) >>? confirmOrBail $ "Really overwrite '"++fullPath++"'?" lift $ do st <- gets esGameState frame <- gets esFrame msoln <- getCurTestSoln- merr <- liftIO $ ((writeAsciiLockFile fullPath msoln $ canonify (frame, st)) >> return Nothing)+ merr <- liftIO $ (writeAsciiLockFile fullPath msoln (canonify (frame, st)) >> return Nothing) `catchIO` (return . Just . show) modify $ \es -> es {lastSavedState = Just (st,isJust msoln)} case merr of- Nothing -> modify $ \es -> es {esPath = Just newPath}+ Nothing -> modify $ \es -> es {esPath = Just newPath} Just err -> lift $ drawError $ "Write failed: "++err processCommand' _ _ = return () @@ -782,25 +808,27 @@ subPlay :: UIMonad uiM => Lock -> MainStateT uiM () subPlay lock =- pushEState =<< psCurrentState <$> (execSubMainState $ newPlayState lock Nothing False True False)+ pushEState . psCurrentState =<< execSubMainState (newPlayState lock Nothing Nothing True False) -solveLock,solveLockTut :: UIMonad uiM => Lock -> Maybe String -> MaybeT (MainStateT uiM) Solution-solveLock = solveLock' False-solveLockTut = solveLock' True-solveLock' isTut lock title = do- (InteractSuccess solved, ps) <- lift $ runSubMainState $ newPlayState (reframe lock) title isTut False False- guard $ solved- return $ reverse $ (map snd) $ psGameStateMoveStack ps+solveLock :: UIMonad uiM => Lock -> Maybe String -> MaybeT (MainStateT uiM) Solution+solveLock = solveLock' Nothing+solveLock' tutLevel lock title = do+ (InteractSuccess solved, ps) <- lift $ runSubMainState $ newPlayState (reframe lock) title tutLevel False False+ guard solved+ return . reverse $ snd <$> psGameStateMoveStack ps -solveLockSaving :: UIMonad uiM => LockSpec -> Maybe SavedPlayState -> Bool -> Lock -> Maybe String -> MaybeT (MainStateT uiM) Solution-solveLockSaving ls msps isTut lock title = do+solveLockSaving :: UIMonad uiM => LockSpec -> Maybe SavedPlayState -> Maybe Int -> Lock -> Maybe String -> MaybeT (MainStateT uiM) Solution+solveLockSaving ls msps tutLevel lock title = do+ let isTut = isJust tutLevel (InteractSuccess solved, ps) <- lift $ runSubMainState $- ((maybe newPlayState restorePlayState) msps) (reframe lock) title isTut False True+ maybe newPlayState restorePlayState msps (reframe lock) title tutLevel False True if solved then do- unless isTut $ lift $ modify $ \ms -> ms { partialSolutions = Map.delete ls $ partialSolutions ms }- return $ reverse $ (map snd) $ psGameStateMoveStack ps+ unless isTut . lift . modify $ \ms -> ms { partialSolutions = Map.delete ls $ partialSolutions ms }+ return . reverse $ snd <$> psGameStateMoveStack ps else do- lift $ modify $ \ms -> if isTut then ms { tutProgress = (ls,Just $ savePlayState ps) }+ lift $ modify $ \ms -> if isTut+ then ms { tutProgress = (tutProgress ms)+ { tutLevel = ls, tutPartial = Just $ savePlayState ps } } else ms { partialSolutions = Map.insert ls (savePlayState ps) $ partialSolutions ms } mzero
InteractUtil.hs view
@@ -10,32 +10,32 @@ module InteractUtil where -import Control.Monad.State-import Control.Applicative-import qualified Data.Map as Map-import Data.Map (Map)-import Control.Monad.Writer-import Control.Monad.Trans.Maybe-import Data.Maybe-import Data.Char-import Data.List-import System.Directory-import Data.Array-import Data.Function (on)+import Control.Applicative+import Control.Monad.State+import Control.Monad.Trans.Maybe+import Control.Monad.Writer+import Data.Array+import Data.Char+import Data.Function (on)+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import System.Directory -import Hex-import Command-import Physics-import Mundanities-import GameStateTypes-import EditGameState-import Frame-import Lock-import Protocol-import Metagame-import MainState-import InputMode-import Util+import Command+import EditGameState+import Frame+import GameStateTypes+import Hex+import InputMode+import Lock+import MainState+import Metagame+import Mundanities+import Physics+import Protocol+import Util checkWon :: UIMonad uiM => MainStateT uiM () checkWon = do@@ -49,7 +49,7 @@ lift $ if solved then do drawMessage $ "Unlocked! '"++obdg++"' to open." reportAlerts st [AlertUnlocked]- else drawMessage ""+ else clearMessage doForce force = do st <- gets esGameState@@ -63,7 +63,7 @@ paintTilePath frame tile from to = if from == to then modify $ \es -> es {lastModPos = to} else do- let from' = (hexVec2HexDirOrZero $ to-^from) +^ from+ let from' = hexVec2HexDirOrZero (to-^from) +^ from when (inEditable frame from') $ drawTile from' tile True paintTilePath frame tile from' to @@ -115,7 +115,7 @@ ourUInfo <- mgetUInfo ourName [pbdg,ebdg,hbdg] <- mapM (lift.lift . getUIBinding IMMeta) [ CmdPlaceLock Nothing, CmdEdit, CmdHome ]- haveLock <- isJust <$> gets curLock+ haveLock <- gets (isJust . curLock) idx <- askLockIndex "Secure behind which lock?" (if haveLock then "First you must place ('"++pbdg++"') a lock to secure your solution behind, while at home ('"++hbdg++"')."@@ -135,10 +135,10 @@ marksSet = do mst <- get return $ case ms2im mst of- IMEdit -> Map.keys $ esMarks mst- IMPlay -> Map.keys $ psMarks mst+ IMEdit -> Map.keys $ esMarks mst+ IMPlay -> Map.keys $ psMarks mst IMReplay -> Map.keys $ rsMarks mst- _ -> []+ _ -> [] jumpMark :: UIMonad uiM => Char -> MainStateT uiM () jumpMark ch = do@@ -174,8 +174,8 @@ _ -> ask ok where ask ok = do- let prompt' = prompt ++ " [" ++ intersperse ',' (map lockIndexChar ok) ++ "]"- idx <- MaybeT $ lift $ join . (((charLockIndex<$>).listToMaybe)<$>) <$>+ let prompt' = prompt ++ " [" ++ intersperse ',' (lockIndexChar <$> ok) ++ "]"+ idx <- MaybeT $ lift $ (((charLockIndex<$>).listToMaybe) =<<) <$> textInput prompt' 1 False True Nothing Nothing if idx `elem` ok then return idx else ask ok confirmOrBail :: UIMonad uiM => String -> MaybeT (MainStateT uiM) ()@@ -188,16 +188,14 @@ where waitConfirm = do cmds <- getInput IMTextInput- case msum $ map ansOfCmd cmds of- Just answer -> return answer- Nothing -> waitConfirm+ maybe waitConfirm return (msum $ ansOfCmd <$> cmds) ansOfCmd (CmdInputChar 'y') = Just True ansOfCmd (CmdInputChar 'Y') = Just True- ansOfCmd (CmdInputChar c) = if isPrint c then Just False else Nothing- ansOfCmd CmdRedraw = Just False- ansOfCmd CmdRefresh = Nothing- ansOfCmd CmdUnselect = Nothing- ansOfCmd _ = Just False+ ansOfCmd (CmdInputChar c) = if isPrint c then Just False else Nothing+ ansOfCmd CmdRedraw = Just False+ ansOfCmd CmdRefresh = Nothing+ ansOfCmd CmdUnselect = Nothing+ ansOfCmd _ = Just False -- | TODO: draw cursor textInput :: UIMonad uiM => String -> Int -> Bool -> Bool -> Maybe [String] -> Maybe String -> uiM (Maybe String)@@ -211,8 +209,8 @@ else do cmds <- getInput IMTextInput case foldM applyCmd (s,mstem) cmds of- Left False -> return Nothing- Left True -> return $ Just s+ Left False -> return Nothing+ Left True -> return $ Just s Right (s',mstem') -> getText (s',mstem') where applyCmd (s,mstem) (CmdInputChar c) = case c of@@ -222,8 +220,8 @@ '\n' -> Left True '\r' -> Left True '\NAK' -> Right ("",Nothing) -- ^U- '\b' -> Right $ (take (length s - 1) s, Nothing)- '\DEL' -> Right $ (take (length s - 1) s, Nothing)+ '\b' -> Right (take (length s - 1) s, Nothing)+ '\DEL' -> Right (take (length s - 1) s, Nothing) '\t' -> case mposss of Nothing -> Right (s,mstem) Just possibilities -> case mstem of@@ -245,11 +243,11 @@ then ((if length s >= maxlen then id else (++[c])) s, Nothing) else (s,mstem) applyCmd x (CmdInputSelLock idx) =- setTextOrSubmit x $ [lockIndexChar idx]+ setTextOrSubmit x [lockIndexChar idx] applyCmd x (CmdInputSelUndecl (Undeclared _ _ (ActiveLock name idx))) = setTextOrSubmit x $ name++[':',lockIndexChar idx] applyCmd x (CmdInputCodename name) =- setTextOrSubmit x $ name+ setTextOrSubmit x name applyCmd x CmdRefresh = Right x applyCmd x CmdUnselect = Right x applyCmd _ _ = Left False
Intricacy.hs view
@@ -8,24 +8,24 @@ -- 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 CPP #-}+{-# LANGUAGE CPP #-} #ifdef APPLE {-# LANGUAGE ForeignFunctionInterface #-} #endif module Main where #ifdef MAIN_SDL-import qualified SDLUI (UIM)-import SDLUIMInstance ()+import qualified SDLUI (UIM)+import SDLUIMInstance () #endif #ifdef MAIN_CURSES-import qualified CursesUI (UIM)-import CursesUIMInstance ()+import qualified CursesUI (UIM)+import CursesUIMInstance () #endif -import Init-import MainState+import Init+import MainState #ifdef APPLE foreign export ccall hs_MAIN :: IO ()
KeyBindings.hs view
@@ -9,17 +9,17 @@ -- along with this program. If not, see http://www.gnu.org/licenses/. module KeyBindings (KeyBindings, bindings, findBindings, findBinding, showKey,- showKeyFriendly, showKeyFriendlyShort) where+ showKeyChar, showKeyFriendly, showKeyFriendlyShort) where -import Data.Maybe-import Data.Char-import Data.List-import Data.Bits (xor)+import Data.Bits (xor)+import Data.Char+import Data.List+import Data.Maybe -import Command-import Hex-import GameStateTypes-import InputMode+import Command+import GameStateTypes+import Hex+import InputMode type KeyBindings = [ (Char,Command) ] @@ -30,7 +30,7 @@ unmeta = meta lowerToo :: KeyBindings -> KeyBindings-lowerToo = concat . map addLower+lowerToo = concatMap addLower where addLower b@(c, cmd) = [ b, (toLower c, cmd) ] qwertyViHex =@@ -167,6 +167,8 @@ playBindings = playOnly ++ lockGlobal replayBindings = replayOnly ++ lockGlobal editBindings = editOnly ++ lockGlobal+initBindings = lowerToo+ [ ('S', CmdSolveInit Nothing) ] ++ miscGlobal metaBindings = lowerToo [ ('C', CmdSelCodename Nothing) , ('H', CmdHome)@@ -182,7 +184,7 @@ , ('O', CmdPrevLock) , ('N', CmdNextLock) , ('A', CmdAuth)- , ('T', CmdTutorials)+ , ('I', CmdInitiation) , ('+', CmdShowRetired) , ('#', CmdPlayLockSpec Nothing) , ('$', CmdSetServer)@@ -191,17 +193,18 @@ , ('<', CmdPrevPage) ] ++ miscGlobal -impatienceBindings = lowerToo $+impatienceBindings = lowerToo [ ('Q', CmdQuit) , (ctrl 'C', CmdQuit) ] bindings :: InputMode -> KeyBindings-bindings IMEdit = editBindings-bindings IMPlay = playBindings-bindings IMMeta = metaBindings-bindings IMReplay = replayBindings+bindings IMEdit = editBindings+bindings IMPlay = playBindings+bindings IMInit = initBindings+bindings IMMeta = metaBindings+bindings IMReplay = replayBindings bindings IMImpatience = impatienceBindings-bindings _ = []+bindings _ = [] findBindings :: KeyBindings -> Command -> [Char] findBindings bdgs cmd = nub@@ -211,20 +214,28 @@ findBinding :: KeyBindings -> Command -> Maybe Char findBinding = (listToMaybe.) . findBindings +showKey :: Char -> String showKey ch | isAscii (unmeta ch) = 'M':'-':showKey (unmeta ch) | isPrint ch = [ch]- | isPrint (unctrl ch) = ('^':[unctrl ch])+ | isPrint (unctrl ch) = '^':[unctrl ch] | otherwise = "[?]" -showKeyFriendly ' ' = "space"+showKeyFriendly ' ' = "space" showKeyFriendly '\r' = "return" showKeyFriendly '\n' = "newline" showKeyFriendly '\t' = "tab" showKeyFriendly '\b' = "bksp"-showKeyFriendly ch = showKey ch+showKeyFriendly ch = showKey ch showKeyFriendlyShort '\r' = "ret" showKeyFriendlyShort '\t' = "tab" showKeyFriendlyShort '\b' = "bksp"-showKeyFriendlyShort ch = showKey ch+showKeyFriendlyShort ch = showKey ch++showKeyChar :: Char -> Char+showKeyChar ch+ | isAscii (unmeta ch) = '['+ | isPrint ch = ch+ | isPrint (unctrl ch) = '^'+ | otherwise = '?'
Lock.hs view
@@ -9,16 +9,16 @@ -- along with this program. If not, see http://www.gnu.org/licenses/. module Lock where-import Control.Monad.Writer-import Data.Maybe-import qualified Data.Map as Map+import Control.Monad.Writer+import qualified Data.Map as Map+import Data.Maybe -import Frame-import GameState-import GameStateTypes-import Hex-import Util-import Physics+import Frame+import GameState+import GameStateTypes+import Hex+import Physics+import Util type Lock = (Frame, GameState) liftLock :: (GameState -> GameState) -> (Lock -> Lock)@@ -39,11 +39,7 @@ reframe l@(f, st) = addTools $ delTools $ liftLock (setpp 0 (framePiece f)) l validLock :: Lock -> Bool-validLock lock@(f,st) = and- [ st == stepPhysics st- , lock == reframe lock- , validGameState st- ]+validLock lock@(f,st) = (st == stepPhysics st) && (lock == reframe lock) && validGameState st type Solution = [PlayerMove] @@ -65,7 +61,7 @@ delTools = liftLock delTools' where delTools' :: GameState -> GameState delTools' st =- fromMaybe st $ listToMaybe + fromMaybe st $ listToMaybe [ delTools' $ delPiece idx st | (idx,pp) <- enumVec $ placedPieces st , isTool $ placedPiece pp ]@@ -90,5 +86,5 @@ [ delOOB $ liftLock (delPiece idx) l | (idx,_) <- enumVec $ placedPieces st , not $ isFrame idx- , all (not.inBounds f) $ fullFootprint st idx+ , not (any (inBounds f) (fullFootprint st idx)) , null $ springsEndAtIdx st idx]
MainState.hs view
@@ -8,42 +8,44 @@ -- 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 TupleSections #-}+ module MainState where -import Control.Monad.State-import Control.Applicative-import qualified Data.Vector as Vector-import qualified Data.Map as Map-import Data.Map (Map)-import Control.Monad.Writer-import Control.Monad.Trans.Maybe-import Data.Maybe-import Data.Char-import Data.List-import Control.Concurrent.STM-import Control.Concurrent-import System.Directory-import System.FilePath-import Data.Time.Clock-import Data.Array-import Data.Function (on)-import Safe+import Control.Applicative+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad.State+import Control.Monad.Trans.Maybe+import Control.Monad.Writer+import Data.Array+import Data.Char+import Data.Function (on)+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Time.Clock+import qualified Data.Vector as Vector+import Safe+import System.Directory+import System.FilePath -import Hex-import Mundanities-import AsciiLock-import GameStateTypes-import Physics-import Command-import Frame-import Lock-import Cache-import Database-import Protocol-import Metagame-import ServerAddr-import InputMode-import Util+import AsciiLock+import Cache+import Command+import Database+import Frame+import GameStateTypes+import Hex+import InputMode+import Lock+import Metagame+import Mundanities+import Physics+import Protocol+import ServerAddr+import Util class (Applicative m, MonadIO m) => UIMonad m where runUI :: m a -> IO a@@ -51,6 +53,7 @@ endUI :: m () drawMainState :: MainStateT m () reportAlerts :: GameState -> [Alert] -> m ()+ clearMessage :: m () drawMessage :: String -> m () drawPrompt :: Bool -> String -> m () endPrompt :: m ()@@ -78,59 +81,64 @@ -- | this could be neatened using GADTs data MainState = PlayState- { psCurrentState::GameState- , psFrame::Frame- , psLastAlerts::[Alert]- , wrenchSelected::Bool- , psSolved::Bool- , psGameStateMoveStack::[(GameState, PlayerMove)]- , psUndoneStack::[(GameState, PlayerMove)]- , psTitle::Maybe String- , psIsTut::Bool- , psIsSub::Bool- , psSaved::Bool- , psMarks::Map Char MainState+ { psCurrentState :: GameState+ , psFrame :: Frame+ , psLastAlerts :: [Alert]+ , wrenchSelected :: Bool+ , psSolved :: Bool+ , psGameStateMoveStack :: [(GameState, PlayerMove)]+ , psUndoneStack :: [(GameState, PlayerMove)]+ , psTitle :: Maybe String+ , psTutLevel :: Maybe Int+ , psIsSub :: Bool+ , psSaved :: Bool+ , psMarks :: Map Char MainState } | ReplayState- { rsCurrentState::GameState- , rsLastAlerts::[Alert]- , rsMoveStack::[PlayerMove]- , rsGameStateMoveStack::[(GameState, PlayerMove)]- , rsTitle::Maybe String- , rsMarks::Map Char MainState+ { rsCurrentState :: GameState+ , rsLastAlerts :: [Alert]+ , rsMoveStack :: [PlayerMove]+ , rsGameStateMoveStack :: [(GameState, PlayerMove)]+ , rsTitle :: Maybe String+ , rsMarks :: Map Char MainState } | EditState- { esGameState::GameState- , esGameStateStack::[GameState]- , esUndoneStack::[GameState]- , esFrame::Frame- , esPath::Maybe FilePath- , esTested::Maybe (GameState,Solution)- , lastSavedState::Maybe (GameState, Bool)- , selectedPiece::Maybe PieceIdx- , selectedPos::HexPos- , lastModPos::HexPos- , esMarks::Map Char GameState+ { esGameState :: GameState+ , esGameStateStack :: [GameState]+ , esUndoneStack :: [GameState]+ , esFrame :: Frame+ , esPath :: Maybe FilePath+ , esTested :: Maybe (GameState,Solution)+ , lastSavedState :: Maybe (GameState, Bool)+ , selectedPiece :: Maybe PieceIdx+ , selectedPos :: HexPos+ , lastModPos :: HexPos+ , esMarks :: Map Char GameState }+ | InitState+ { tutProgress :: TutProgress+ , initLocks :: InitLocks+ } | MetaState- { curServer :: ServerAddr- , undeclareds :: [Undeclared]+ { curServer :: ServerAddr+ , undeclareds :: [Undeclared] , partialSolutions :: PartialSolutions- , tutProgress :: TutProgress- , cacheOnly :: Bool- , curAuth :: Maybe Auth- , codenameStack :: [Codename]- , newAsync :: TVar Bool- , asyncCount :: TVar Int- , asyncError :: TVar (Maybe String)- , asyncInvalidate :: TVar (Maybe Codenames)- , randomCodenames :: TVar [Codename]- , userInfoTVs :: Map Codename (TVar FetchedRecord, UTCTime)- , indexedLocks :: Map LockSpec (TVar FetchedRecord)- , retiredLocks :: Maybe [LockSpec]- , curLockPath :: FilePath- , curLock :: Maybe (Lock,Maybe Solution)- , listOffset :: Int+ , cacheOnly :: Bool+ , curAuth :: Maybe Auth+ , codenameStack :: [Codename]+ , newAsync :: TVar Bool+ , asyncCount :: TVar Int+ , asyncError :: TVar (Maybe String)+ , asyncInvalidate :: TVar (Maybe Codenames)+ , randomCodenames :: TVar [Codename]+ , userInfoTVs :: Map Codename (TVar FetchedRecord, UTCTime)+ , indexedLocks :: Map LockSpec (TVar FetchedRecord)+ , retiredLocks :: Maybe [LockSpec]+ , curLockPath :: FilePath+ , curLock :: Maybe (Lock,Maybe Solution)+ , listOffset :: Int+ , listOffsetMax :: Bool+ , initiated :: Bool } type MainStateT = StateT MainState@@ -140,95 +148,164 @@ ms2im :: MainState -> InputMode ms2im mainSt = case mainSt of- PlayState {} -> IMPlay+ PlayState {} -> IMPlay ReplayState {} -> IMReplay- EditState {} -> IMEdit- MetaState {} -> IMMeta+ EditState {} -> IMEdit+ InitState {} -> IMInit+ MetaState {} -> IMMeta -newPlayState (frame,st) title isTut sub saved = PlayState st frame [] False False [] [] title isTut sub saved Map.empty+newPlayState (frame,st) title tutLevel sub saved = PlayState st frame [] False False [] [] title tutLevel sub saved Map.empty newReplayState st soln title = ReplayState st [] soln [] title Map.empty newEditState (frame,st) msoln mpath = EditState st [] [] frame mpath- ((\s->(st,s))<$>msoln) (Just (st, isJust msoln)) Nothing (PHS zero) (PHS zero) Map.empty+ ((st,)<$>msoln) (Just (st, isJust msoln)) Nothing (PHS zero) (PHS zero) Map.empty+initInitState = do+ (tut,initLocks) <- readInitProgress+ return $ InitState tut initLocks initMetaState = do- flag <- atomically $ newTVar False- errtvar <- atomically $ newTVar Nothing- invaltvar <- atomically $ newTVar Nothing- rnamestvar <- atomically $ newTVar []- counttvar <- atomically $ newTVar 0- (saddr', auth, path) <- confFilePath "metagame.conf" >>=- liftM (fromMaybe (defaultServerAddr, Nothing, "")) . readReadFile+ flag <- newTVarIO False+ errtvar <- newTVarIO Nothing+ invaltvar <- newTVarIO Nothing+ rnamestvar <- newTVarIO []+ counttvar <- newTVarIO 0+ (initiated, saddr', auth, path) <- confFilePath "metagame.conf" >>=+ fmap (fromMaybe (False, defaultServerAddr, Nothing, "")) . readReadFile let saddr = updateDefaultSAddr saddr' let names = maybeToList $ authUser <$> auth- (undecls,partials,tut) <- readServerSolns saddr+ (undecls,partials) <- readServerSolns saddr mlock <- fullLockPath path >>= readLock- return $ MetaState saddr undecls partials tut False auth names flag counttvar errtvar invaltvar rnamestvar Map.empty Map.empty Nothing path mlock 0+ return $ MetaState saddr undecls partials False auth names flag counttvar errtvar invaltvar rnamestvar Map.empty Map.empty Nothing path mlock 0 True initiated type PartialSolutions = Map LockSpec SavedPlayState-type TutProgress = (Int,Maybe SavedPlayState) data SavedPlayState = SavedPlayState [PlayerMove] (Map Char [PlayerMove]) deriving (Eq, Ord, Show, Read) +data TutProgress = TutProgress+ { tutSolved :: Bool+ , tutLevel :: Int+ , tutPartial :: Maybe SavedPlayState+ } deriving (Eq, Ord, Show, Read)+initTutProgress = TutProgress False 1 Nothing++wrenchOnlyTutLevel, noUndoTutLevel :: Maybe Int -> Bool+wrenchOnlyTutLevel = (`elem` (Just <$> [1..3]))+noUndoTutLevel = (`elem` (Just <$> [1..6]))++data InitLock = InitLock+ { initLockName :: String+ , initLockDesc :: String+ , initLockLock :: Lock+ , initLockSolved :: Bool+ , initLockPartial :: Maybe SavedPlayState+ } deriving (Eq, Ord, Show, Read)+type InitLocks = Map HexVec InitLock++accessibleInitLocks :: Bool -> InitLocks -> InitLocks+accessibleInitLocks tutSolved initLocks =+ Map.filterWithKey (\v _ -> initLockAccessible v) initLocks+ where+ initLockAccessible :: HexVec -> Bool+ initLockAccessible v = or+ [ (v' == zero && tutSolved) ||+ (Just True == (initLockSolved <$> Map.lookup v' initLocks))+ | v' <- (v +^) <$> hexDirs ]++isLastInitLock :: InitLock -> Bool+isLastInitLock = (== "END") . initLockName+ savePlayState :: MainState -> SavedPlayState savePlayState ps = SavedPlayState (getMoves ps) $ Map.map getMoves $ psMarks ps where getMoves = reverse . map snd . psGameStateMoveStack -restorePlayState :: SavedPlayState -> Lock -> (Maybe String) -> Bool -> Bool -> Bool -> MainState-restorePlayState (SavedPlayState pms markPMs) (frame,st) title isTut sub saved =+restorePlayState :: SavedPlayState -> Lock -> Maybe String -> Maybe Int -> Bool -> Bool -> MainState+restorePlayState (SavedPlayState pms markPMs) (frame,st) title tutLevel sub saved = (stateAfterMoves pms) { psMarks = Map.map stateAfterMoves markPMs } where stateAfterMoves pms = let (stack,st') = applyMoves st pms- in (newPlayState (frame, st') title isTut sub saved) { psGameStateMoveStack = stack }+ in (newPlayState (frame, st') title tutLevel sub saved) { psGameStateMoveStack = stack } applyMoves st pms = foldl tick ([],st) pms tick :: ([(GameState,PlayerMove)],GameState) -> PlayerMove -> ([(GameState,PlayerMove)],GameState) tick (stack,st) pm = ((st,pm):stack,fst . runWriter $ physicsTick pm st) -readServerSolns :: ServerAddr -> IO ([Undeclared],PartialSolutions,TutProgress)-readServerSolns saddr = if nullSaddr saddr then return ([],Map.empty,(1,Nothing)) else do+readServerSolns :: ServerAddr -> IO ([Undeclared],PartialSolutions)+readServerSolns saddr = if nullSaddr saddr then return ([],Map.empty) else do undecls <- confFilePath ("undeclared" ++ [pathSeparator] ++ saddrPath saddr) >>=- liftM (fromMaybe []) . readReadFile+ fmap (fromMaybe []) . readReadFile partials <- confFilePath ("partialSolutions" ++ [pathSeparator] ++ saddrPath saddr) >>=- liftM (fromMaybe Map.empty) . readReadFile- tut <- confFilePath "tutProgress" >>=- liftM (fromMaybe (1,Nothing)) . readReadFile- return (undecls,partials,tut)+ fmap (fromMaybe Map.empty) . readReadFile+ return (undecls,partials) -writeServerSolns saddr ms@(MetaState { undeclareds=undecls,-partialSolutions=partials, tutProgress=tut }) = unless (nullSaddr saddr) $ do+readInitProgress :: IO (TutProgress,InitLocks)+readInitProgress = do+ initConfDir <- confFilePath "initiation"+ initDataDir <- getDataPath "initiation"+ tut <- fromMaybe initTutProgress <$> readReadFile (initConfDir </> "tutProgress")+ locknames <- fromMaybe [] <$> readReadFile (initDataDir </> "initiation.map")+ let namesMap :: Map HexVec Codename+ namesMap = Map.fromList $+ [ (rotate (-j) (neg hw) +^ i *^ hu, name)+ | (j,line) <- zip [0..] locknames+ , (i,name) <- zip [0..] line ]+ readInitLock :: String -> IO (Maybe InitLock)+ readInitLock name = runMaybeT $ do+ desc <- MaybeT $ listToMaybe <$> readStrings (initDataDir </> name ++ ".text")+ lock <- (fst <$>) . MaybeT $ readLock (initDataDir </> name ++ ".lock")+ solved <- lift . (fromMaybe False <$>) . readReadFile $ initConfDir </> name ++ ".solved"+ partial <- lift . readReadFile $ initConfDir </> name ++ ".partial"+ return $ InitLock name desc lock solved partial+ initLocks <- Map.mapMaybe id <$> mapM readInitLock namesMap+ return (tut,initLocks)++writeServerSolns :: ServerAddr -> MainState -> IO ()+writeServerSolns saddr MetaState { undeclareds=undecls,+ partialSolutions=partials } = unless (nullSaddr saddr) $ do confFilePath ("undeclared" ++ [pathSeparator] ++ saddrPath saddr) >>= flip writeReadFile undecls confFilePath ("partialSolutions" ++ [pathSeparator] ++ saddrPath saddr) >>= flip writeReadFile partials- confFilePath ("tutProgress") >>= flip writeReadFile tut readLock :: FilePath -> IO (Maybe (Lock, Maybe Solution)) readLock path = runMaybeT $ msum- [ (\l->(l,Nothing)) <$> (MaybeT $ readReadFile path)+ [ (,Nothing) <$> MaybeT (readReadFile path) , do (mlock,msoln) <- lift $ readAsciiLockFile path lock <- liftMaybe mlock- return $ (lock,msoln) ]+ return (lock,msoln) ] -- writeLock :: FilePath -> Lock -> IO () -- writeLock path lock = fullLockPath path >>= flip writeReadFile lock -writeMetaState ms@(MetaState { curServer=saddr, curAuth=auth, curLockPath=path }) = do- confFilePath "metagame.conf" >>= flip writeReadFile (saddr, auth, path)+writeInitState :: MainState -> IO ()+writeInitState InitState { tutProgress = tut, initLocks = initLocks } = do+ initConfDir <- confFilePath "initiation"+ writeReadFile (initConfDir </> "tutProgress") tut+ let writeInitLockInfo :: InitLock -> IO ()+ writeInitLockInfo (InitLock name _ _ solved partial) = do+ writeReadFile (initConfDir </> name ++ ".solved") solved+ writeReadFile (initConfDir </> name ++ ".partial") partial+ mapM_ writeInitLockInfo initLocks+writeInitState _ = return ()++writeMetaState :: MainState -> IO ()+writeMetaState ms@MetaState { curServer=saddr, curAuth=auth, curLockPath=path, initiated=initiated } = do+ confFilePath "metagame.conf" >>= flip writeReadFile (initiated, saddr, auth, path) writeServerSolns saddr ms+writeMetaState _ = return () getTitle :: UIMonad uiM => MainStateT uiM (Maybe String)-getTitle = ms2im <$> get >>= \im -> case im of- IMEdit -> do+getTitle = get >>= title . ms2im+ where+ title IMEdit = do mpath <- gets esPath unsaved <- editStateUnsaved isTested <- isJust <$> getCurTestSoln return $ Just $ "editing " ++ fromMaybe "[unnamed lock]" mpath ++ (if isTested then " (Tested)" else "") ++ (if unsaved then " [+]" else " ")- IMPlay -> gets psTitle- IMReplay -> gets rsTitle- _ -> return Nothing+ title IMPlay = gets psTitle+ title IMReplay = gets rsTitle+ title _ = return Nothing editStateUnsaved :: UIMonad uiM => MainStateT uiM Bool editStateUnsaved = (isNothing <$>) $ runMaybeT $ do (sst,tested) <- MaybeT $ gets lastSavedState- st <- gets $ esGameState+ st <- gets esGameState guard $ sst == st nowTested <- isJust <$> lift getCurTestSoln guard $ tested == nowTested@@ -236,14 +313,14 @@ getCurTestSoln :: UIMonad uiM => MainStateT uiM (Maybe Solution) getCurTestSoln = runMaybeT $ do (st',soln) <- MaybeT $ gets esTested- st <- gets $ esGameState+ st <- gets esGameState guard $ st == st' return soln mgetOurName :: (UIMonad uiM) => MaybeT (MainStateT uiM) Codename-mgetOurName = MaybeT $ (authUser <$>) <$> gets curAuth+mgetOurName = MaybeT $ gets ((authUser <$>) . curAuth) mgetCurName :: (UIMonad uiM) => MaybeT (MainStateT uiM) Codename-mgetCurName = MaybeT $ listToMaybe <$> gets codenameStack+mgetCurName = MaybeT $ gets (listToMaybe . codenameStack) getUInfoFetched :: UIMonad uiM => Integer -> Codename -> MainStateT uiM FetchedRecord getUInfoFetched staleTime name = do@@ -252,13 +329,13 @@ now <- liftIO getCurrentTime if floor (diffUTCTime now time) > staleTime then set- else liftIO $ atomically $ readTVar tvar+ else liftIO $ readTVarIO tvar where set = do now <- liftIO getCurrentTime tvar <- getRecordCachedFromCur True $ RecUserInfo name modify $ \ms -> ms {userInfoTVs = Map.insert name (tvar, now) $ userInfoTVs ms}- liftIO $ atomically $ readTVar tvar+ liftIO $ readTVarIO tvar mgetUInfo :: UIMonad uiM => Codename -> MaybeT (MainStateT uiM) UserInfo mgetUInfo name = do@@ -278,18 +355,18 @@ data Codenames = AllCodenames | SomeCodenames [Codename] invalidateUInfos :: UIMonad uiM => Codenames -> MainStateT uiM ()-invalidateUInfos AllCodenames = invalidateAllUInfo+invalidateUInfos AllCodenames = invalidateAllUInfo invalidateUInfos (SomeCodenames names) = mapM_ invalidateUInfo names mgetLock :: UIMonad uiM => LockSpec -> MaybeT (MainStateT uiM) Lock mgetLock ls = do- tvar <- msum [ MaybeT $ (Map.lookup ls) <$> gets indexedLocks+ tvar <- msum [ MaybeT $ gets (Map.lookup ls . indexedLocks) , lift $ do tvar <- getRecordCachedFromCur True $ RecLock ls modify $ \ms -> ms { indexedLocks = Map.insert ls tvar $ indexedLocks ms } return tvar ]- RCLock lock <- MaybeT $ (fetchedRC<$>) $ liftIO $ atomically $ readTVar tvar+ RCLock lock <- MaybeT $ (fetchedRC<$>) $ liftIO $ readTVarIO tvar return $ reframe lock invalidateAllIndexedLocks :: UIMonad uiM => MainStateT uiM ()@@ -360,7 +437,7 @@ else makeRequest saddr $ ClientRequest protocolVersion auth act case resp of ServerError err -> atomically $ writeTVar errtvar $ Just err- _ -> atomically $ writeTVar invaltvar names+ _ -> atomically $ writeTVar invaltvar names atomically $ writeTVar flag True atomically $ modifyTVar count (+(-1)) @@ -398,16 +475,16 @@ Nothing -> lift (drawError "Request aborted") >> return Nothing Just fetched -> case fetchError fetched of- Nothing -> return $ fetchedRC fetched+ Nothing -> return $ fetchedRC fetched Just err -> lift (drawError err) >> return Nothing -- |indicate waiting for server, and allow cancellation withImpatience :: UIMonad uiM => IO a -> uiM (Maybe a) withImpatience m = do- finishedTV <- liftIO $ atomically $ newTVar Nothing+ finishedTV <- liftIO $ newTVarIO Nothing id <- liftIO $ forkIO $ m >>= atomically . writeTVar finishedTV . Just let waitImpatiently ticks = do- finished <- liftIO $ atomically $ readTVar finishedTV+ finished <- liftIO $ readTVarIO finishedTV if isJust finished then return finished else do@@ -426,7 +503,7 @@ uinfo <- mgetUInfo name ourUInfo <- mgetUInfo ourName let (neg,pos) = (countPoints ourUInfo uinfo, countPoints uinfo ourUInfo)- return $ (pos-neg,(pos,neg))+ return (pos-neg,(pos,neg)) where countPoints mugu masta = length $ filter (maybe False winsPoint) $ getAccessInfo mugu masta @@ -447,14 +524,26 @@ testAuth :: UIMonad uiM => MainStateT uiM () testAuth = isJust <$> gets curAuth >>? do- resp <- curServerAction $ Authenticate+ resp <- curServerAction Authenticate case resp of- ServerMessage msg -> (lift $ drawMessage $ "Server: " ++ msg)+ ServerMessage msg -> lift $ drawMessage $ "Server: " ++ msg ServerError err -> do lift $ drawMessage err modify $ \ms -> ms {curAuth = Nothing} _ -> return () +initiationHelpText :: [String]+initiationHelpText =+ [ "Suddenly surrounded by hooded figures in your locked room."+ , "Gently abducted, now wordlessly released into this dingy hole."+ , ""+ , "Some disused dungeon, a honeycomb of cells separated by sturdy gates."+ , "From the far end, light filters through the sequential barriers."+ , "Freedom?"+ , "The gate mechanisms are foolishly accessible, merely locked."+ , "Lucky that they neglected to strip you of your lockpicks."+ , "Lucky, and odd..." ]+ metagameHelpText :: [String] metagameHelpText = [ "By ruthlessly guarded secret arrangement, the council's agents can pick any lock in the city."@@ -466,69 +555,70 @@ , "You may put forward up to three prototype locks. They will guard the secrets you discover." , "If you pick a colleague's lock, the rules require that a note is written on your solution." , "A note proves that a solution was found, while revealing no more details than necessary."- --, "Composing notes is a tricky and ritual-bound art of its own, performed by independent experts." , "To declare your solution, you must secure your note behind a lock of your own." , "If you are able to unlock a lock, you automatically read all the notes it secures."- , "If you read three notes on a lock, you will piece together the secrets of unlocking that lock."+ , "Reading three notes on a lock suffices to piece together the secrets of unlocking it." , "" , "The game judges players relative to each of their peers. There are no absolute rankings."- , "You win a point of esteem against another player for each of their locks for which either:"- , "you have solved the lock and declared a note which the lock's owner has not read, or"- , "you have read three notes on the lock."+ , "You win a point of esteem against another player for one of their locks"+ , "if you have solved the lock and declared a note which remains unread by the lock's owner,"+ , "or if you have read three notes by other players on the lock." , "You also win a point for each empty lock slot if you can unlock all full slots." , "Relative esteem is the points you win minus the points they win; +3 is best, -3 is worst." , "" , "If the secrets to one of your locks become widely disseminated, you may wish to replace it."- , "However: once replaced, a lock is \"retired\", and the notes it secured are read by everyone."+ , "Once replaced, a lock is \"retired\", and the notes it secured are read by everyone." ] -initiationHelpText :: Int -> [String]-initiationHelpText 1 =- [ ""- , "So."+initiationCompleteText :: Int -> [String]+initiationCompleteText 1 =+ [ "Emerging from the last of the cells to what you imagined might be freedom,"+ , "you find yourself in a lamplit room with a hooded figure." , ""- , "This confirms that you have sufficient manual and mental dexterity to pick simple locks."- , "But have you the supple cunning required to improve on their designs? That remains to be seen."+ , "\"So. You did acquire some skills in your former life. Enough for these toys, at least."+ , "Whether you have the devious creativity to improve on their designs... remains to be seen." , ""- , "Nonetheless, we welcome you to our number. As for what it is exactly that you are joining..."- , "probably you think you have it all worked out already. Still, allow me to explain."+ , "\"Nonetheless, we welcome you to our number. As for what exactly it is that you are joining..."+ , "no doubt you believe you have it all worked out already. Still, allow me to explain.\"" , ""- , "But first: for reasons that will become clear,"- , "our members are known exclusively by pseudonyms - by tradition, a triplet of letters or symbols."- , "I am eager to hear what codename you will choose for yourself; do be thinking about it."+ , "After a pause to examine your face, and a soft chuckle, the figure continues."+ , "\"Ah, you thought this would be the end? No, no, this is very much the beginning.\"" ]-initiationHelpText 2 =- [ ""- , "Now."- , ""- , "As you fatefully determined, every lock permitted in the city has a fatal hidden flaw."+initiationCompleteText 2 =+ [ "\"As you fatefully determined, every lock permitted in the city has a fatal hidden flaw." , "Those whose duties require it are entrusted with the secrets required to pick these locks."- , "Those who unauthorisedly discover said secrets... come to us."+ , "As for those who unauthorisedly discover, and even try to profit from, said secrets..."+ , "you come to us." , ""- , "Our task is to produce the superficially secure locks necessary for this system:"+ , "\"Our task, you see, is to produce the superficially secure locks necessary for this system:" , "locks pickable with minimal tools, but with this fact obscured by their mechanical complexity." , ""- , "To push the designs to ever new extremes of intricacy, we run a ritual game."- , "You are to be its newest player."+ , "\"To push the designs to ever new extremes of intricacy, we run a ritual game."+ , "Today, we welcome you as its newest player." ]-initiationHelpText 3 =- [ ""+initiationCompleteText 3 =+ [ "\"The idea is simple." , "We each design locks, and we each attempt to solve the locks designed by the others." , ""- , "You may put forward up to three prototype locks."+ , "\"You may put forward up to three prototype locks." , "They will guard the secrets you discover: when you pick a colleague's lock," , "you may declare the fact by placing a note on its solution behind one of your locks." , "As long as the owner of the lock you picked is unable to read your note," , "you score a point against them. This is now your aim in life." , ""- , "If you find a lock too difficult or trivial to pick yourself,"+ , "\"If you find a lock too difficult or trivial to pick yourself," , "you may find that reading other players' notes on it will lead you to a solution." , ""- , "The finer details of the rules can wait."- , "Go now; choose a codename, explore the locks we have set,"- , "and begin your own experiments in the subtle art of lock design."+ , "\"The finer details of the rules can wait. Your first task is to name yourself."+ , "For reasons which should be clear, our members are known exclusively by pseudonyms;"+ , "by tradition, these codenames are triplets of letters or symbols."+ , ""+ , "\"Go, choose your codename, have it entered in the registry."+ , "Then, you should begin work on your first lock."+ , "With a new initiate always comes the hope of some genuinely new challenge..."+ , "Perhaps you already have ideas?\"" ]-initiationHelpText _ = []+initiationCompleteText _ = [] firstEditHelpText :: [String]@@ -541,7 +631,7 @@ , "Place pieces with keyboard or mouse. Springs must be set next to blocks, and arms next to pivots." , "Repeatedly placing a piece in the same hex cycles through ways it can relate to its neighbours." , ""- , "Use Test to prove your lock is solvable, or Play to alternate between testing and editing."+ , "Use Test to prove that your lock is solvable, or Play to alternate between testing and editing." , "When you are done, Write your lock, then Quit from editing and Place your lock in a slot." , "You will then be able to Declare locks you solve, and others will attempt to solve your lock." , ""
Metagame.hs view
@@ -10,16 +10,16 @@ module Metagame where -import Control.Applicative-import Data.Array-import Data.Binary-import Control.Monad-import Data.List (delete)-import Data.Char-import Data.Maybe+import Control.Applicative+import Control.Monad+import Data.Array+import Data.Binary+import Data.Char+import Data.List (delete)+import Data.Maybe -import GameStateTypes-import Lock+import GameStateTypes+import Lock notesNeeded = 3 maxLocks = 3@@ -49,7 +49,7 @@ deriving (Eq, Ord, Show, Read) winsPoint :: AccessedReason -> Bool winsPoint (AccessedPrivySolved True) = False-winsPoint _ = True+winsPoint _ = True getAccessInfo :: UserInfo -> UserInfo -> [Maybe AccessedReason] getAccessInfo accessedUInfo accessorUInfo =@@ -65,9 +65,9 @@ if countRead accessorUInfo linfo >= notesNeeded then AccessedPrivyRead else AccessedPrivySolved $ not.null $ [ n- | n <- lockSolutions linfo + | n <- lockSolutions linfo , noteAuthor n == accessor- , noteBehind n == Nothing || n `elem` notesRead accessedUInfo ]))+ , isNothing (noteBehind n) || n `elem` notesRead accessedUInfo ])) mlinfos countRead :: UserInfo -> LockInfo -> Int@@ -115,17 +115,17 @@ applyDeltas = foldr applyDelta applyDelta :: UserInfoDelta -> UserInfo -> UserInfo-applyDelta (AddRead n) info = info { notesRead = n:(notesRead info) }+applyDelta (AddRead n) info = info { notesRead = n:notesRead info } applyDelta (DelRead n) info = info { notesRead = delete n (notesRead info) } applyDelta (PutLock ls li) info = info { userLocks = userLocks info // [(li, Just $ initLockInfo ls)] } applyDelta (LockDelta li ld) info =- info { userLocks = userLocks info // [(li, liftM (applyLockDelta ld) (userLocks info ! li))] }+ info { userLocks = userLocks info // [(li, fmap (applyLockDelta ld) (userLocks info ! li))] } applyLockDelta (SetPubNote n) lockinfo = lockinfo { lockSolutions = map (\n' -> if n' == n then n {noteBehind=Nothing} else n') (lockSolutions lockinfo) }-applyLockDelta (AddSecured n) lockinfo = lockinfo { notesSecured = n:(notesSecured lockinfo) }+applyLockDelta (AddSecured n) lockinfo = lockinfo { notesSecured = n:notesSecured lockinfo } applyLockDelta (DelSecured n) lockinfo = lockinfo { notesSecured = delete n $ notesSecured lockinfo }-applyLockDelta (AddSolution n) lockinfo = lockinfo { lockSolutions = n:(lockSolutions lockinfo) }-applyLockDelta (AddAccessed name) lockinfo = lockinfo { accessedBy = name:(delete name $ accessedBy lockinfo) }+applyLockDelta (AddSolution n) lockinfo = lockinfo { lockSolutions = n:lockSolutions lockinfo }+applyLockDelta (AddAccessed name) lockinfo = lockinfo { accessedBy = name:delete name (accessedBy lockinfo) } applyLockDelta SetPublic lockinfo = lockinfo { public = True, lockSolutions = [], accessedBy = [], notesSecured = []} instance Binary UserInfo where@@ -133,9 +133,9 @@ get = liftM3 UserInfo get get get instance Binary UserInfoDelta where- put (AddRead note) = put (0::Word8) >> put note- put (DelRead note) = put (1::Word8) >> put note- put (PutLock ls li) = put (2::Word8) >> put ls >> put li+ put (AddRead note) = put (0::Word8) >> put note+ put (DelRead note) = put (1::Word8) >> put note+ put (PutLock ls li) = put (2::Word8) >> put ls >> put li put (LockDelta li ld) = put (3::Word8) >> put li >> put ld get = do tag <- get :: Get Word8@@ -146,12 +146,12 @@ 3 -> LockDelta <$> get <*> get instance Binary LockDelta where- put (SetPubNote note) = put (0::Word8) >> put note- put (AddSecured note) = put (1::Word8) >> put note- put (DelSecured note) = put (2::Word8) >> put note+ put (SetPubNote note) = put (0::Word8) >> put note+ put (AddSecured note) = put (1::Word8) >> put note+ put (DelSecured note) = put (2::Word8) >> put note put (AddSolution note) = put (3::Word8) >> put note put (AddAccessed name) = put (4::Word8) >> put name- put SetPublic = put (5::Word8)+ put SetPublic = put (5::Word8) get = do tag <- get :: Get Word8 case tag of
Mundanities.hs view
@@ -9,36 +9,40 @@ -- along with this program. If not, see http://www.gnu.org/licenses/. module Mundanities where-import Control.Applicative-import Control.Arrow-import Control.Monad-import qualified Control.Exception as E-import System.Directory-import System.Environment (getEnv)-import System.FilePath-import Data.Maybe-import Data.List-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BSC-import Paths_intricacy+import Control.Applicative+import Control.Arrow+import Control.Monad+import Control.Monad.Catch (MonadMask, catch, handle)+import Control.Monad.IO.Class (MonadIO)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import Data.List+import Data.Maybe+import Paths_intricacy+import System.Directory+import System.Environment (getEnv)+import System.FilePath --- | This is "catchIOError" in >=base-4.4, but we reimplement it to support--- older bases. catchIO :: IO a -> (IOError -> IO a) -> IO a-catchIO = E.catch+catchIO = catch -catchAll :: IO a -> (E.SomeException -> IO a) -> IO a-catchAll = E.catch+ignoreIOErr :: (MonadIO m, MonadMask m, Monoid a) => m a -> m a+ignoreIOErr = handle ((\_ -> return mempty) :: (Monad m, Monoid a) => IOError -> m a) +ignoreIOErrAlt :: (MonadIO m, MonadMask m, Alternative f) => m (f a) -> m (f a)+ignoreIOErrAlt = handle ((\_ -> return empty) :: (Monad m, Alternative f) => IOError -> m (f a))++unlessIOErr :: (MonadIO m, MonadMask m) => m Bool -> m Bool+unlessIOErr = (fromMaybe False <$>) . ignoreIOErrAlt . (Just <$>)+ readReadFile :: (Read a) => FilePath -> IO (Maybe a)-readReadFile file =- (tryRead . BSC.unpack <$> BS.readFile file)- `catchIO` (const $ return Nothing)+readReadFile file = ignoreIOErrAlt $ tryRead . BSC.unpack <$> BS.readFile file+ tryRead :: (Read a) => String -> Maybe a tryRead = (fst <$>) . listToMaybe . reads readStrings :: FilePath -> IO [String]-readStrings file = (lines . BSC.unpack) <$> BS.readFile file+readStrings file = ignoreIOErr $ lines . BSC.unpack <$> BS.readFile file writeReadFile :: (Show a) => FilePath -> a -> IO () writeReadFile file x = do@@ -61,21 +65,27 @@ makeConfDir :: IO () makeConfDir = confFilePath "" >>= createDirectoryIfMissing False +fileExists :: FilePath -> IO Bool+fileExists = unlessIOErr . doesFileExist+ mkdirhierto :: FilePath -> IO () mkdirhierto = mkdirhier . takeDirectory mkdirhier :: FilePath -> IO ()-mkdirhier path = do- exists <- doesDirectoryExist path- unless exists $ mkdirhierto path >> createDirectory path+mkdirhier = createDirectoryIfMissing True getDirContentsRec :: FilePath -> IO [FilePath]-getDirContentsRec path = flip catchIO (const $ return []) $ do- contents <- map ((path++[pathSeparator])++) <$> filter ((/='.').head) <$> getDirectoryContents path+getDirContentsRec path = ignoreIOErr $ do+ contents <- map ((path++[pathSeparator])++) . filter ((/='.').head) <$> getDirectoryContents path annotated <- (\p -> (,) p <$> doesDirectoryExist p) `mapM` contents let (dirs,files) = join (***) (map fst) $ partition snd annotated (files++) . concat <$> getDirContentsRec `mapM` dirs fullLockPath path = if isAbsolute path then return path- else (++(pathSeparator:path)) <$> confFilePath "locks"+ else do+ homePath <- getHomeDirectory+ locksPath <- confFilePath "locks"+ return $ if take 2 path == "~/"+ then homePath </> drop 2 path+ else locksPath </> path
NEWS view
@@ -1,5 +1,8 @@ This is an abbreviated summary; see the git log for gory details. +0.8:+ Add single-player introductory subgame ("initiation").+ Improve UI variously. 0.7.2.3: Hopefully work around curses build failures 0.7.2.1:
Physics.hs view
@@ -10,19 +10,19 @@ module Physics where -import qualified Data.Set as Set-import Data.Set (Set)-import qualified Data.Vector as Vector-import Control.Monad.State-import Control.Monad.Writer-import Data.Foldable (foldrM)-import Data.List-import Data.Vector (Vector, (!), (//))+import Control.Monad.State+import Control.Monad.Writer+import Data.Foldable (foldrM)+import Data.List+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Vector (Vector, (!), (//))+import qualified Data.Vector as Vector -import Hex-import Util-import GameState-import GameStateTypes+import GameState+import GameStateTypes+import Hex+import Util -- | a list of forces to try in order: newtype ForceChoice = ForceChoice {getForceChoice :: [Force]}@@ -30,14 +30,14 @@ type ForceChoices = Vector.Vector ForceChoice forceIdx :: Force -> PieceIdx-forceIdx force = case force of (Push idx _) -> idx+forceIdx force = case force of (Push idx _) -> idx (Torque idx _) -> idx isPush,isTorque,forceIsNull :: Force -> Bool isPush (Push _ _) = True-isPush _ = False+isPush _ = False isTorque = not . isPush-forceIsNull (Push _ dir) = dir == zero+forceIsNull (Push _ dir) = dir == zero forceIsNull (Torque _ dir) = dir == 0 getForcedpp :: GameState -> Force -> PlacedPiece@@ -51,13 +51,13 @@ toolForces st pm = Vector.fromList $ [ ForceChoice (wmom++wmove) | (widx, PlacedPiece _ (Wrench mom)) <- epps- , let wmom = if mom == zero then [] else [Push widx mom]+ , let wmom = [Push widx mom | mom /= zero] , let wmove = case pm of {WrenchPush v -> [Push widx v]; _ -> []} , not $ null (wmom++wmove) ] ++ case pm of HookTorque ht -> [ ForceChoice [Torque hidx ht] | hidx <- hidxs ]- HookPush hp -> [ ForceChoice [Push hidx hp] | hidx <- hidxs ]- _ -> []+ HookPush hp -> [ ForceChoice [Push hidx hp] | hidx <- hidxs ]+ _ -> [] where epps = enumVec $ placedPieces st hidxs = [ hidx | (hidx, PlacedPiece _ (Hook _ _)) <- epps ]@@ -89,11 +89,11 @@ setTools pm st = let hf = case pm of HookTorque dir -> TorqueHF dir- HookPush v -> PushHF v- _ -> NullHF+ HookPush v -> PushHF v+ _ -> NullHF in adjustPieces (\p -> case p of Hook arm _ -> Hook arm hf- _ -> p) st+ _ -> p) st physicsTick :: PlayerMove -> GameState -> Writer [Alert] GameState physicsTick pm st =@@ -101,7 +101,7 @@ (efs, dominates) = envForces st in do st' <- resolveForces tfs Vector.empty (\_ _->False) $ setTools pm st- tell $ [AlertIntermediateState st']+ tell [AlertIntermediateState st'] resolveForces Vector.empty efs dominates $ setTools NullPM st' stepPhysics :: GameState -> GameState@@ -114,11 +114,11 @@ resolveForces plForces eForces eDominates st = let pln = Vector.length plForces dominates i j = case map (< pln) [i,j] of- [True,False] -> True+ [True,False] -> True [False,False] -> eDominates (i-pln) (j-pln)- _ -> False- initGrps = fmap (propagate st True) plForces Vector.++- fmap (propagate st False) eForces+ _ -> False+ initGrps = (propagate st True <$> plForces) Vector.+++ (propagate st False <$> eForces) blockInconsistent :: Int -> Int -> StateT (Vector (Writer Any [Force])) (Writer [Alert]) () blockInconsistent i j = do grps <- mapM gets [(!i),(!j)]@@ -154,7 +154,7 @@ , Wrench mom <- [placedPiece $ getpp st idx] , mom `notElem` [zero,dir] ] in do- let unresisted = [ s | (s, (_, Any False)) <- enumVec $ fmap runWriter initGrps ]+ let unresisted = [ s | (s, (_, Any False)) <- enumVec $ runWriter <$> initGrps ] -- check for inconsistencies within, and between pairs of, forcegroups grps <- sequence [ blockInconsistent i j@@ -162,7 +162,7 @@ , i <= j ] `execStateT` initGrps - let [blocked, unblocked] = map (nub.concat.(map (fst.runWriter)).Vector.toList) $+ let [blocked, unblocked] = map (nub.concatMap (fst.runWriter) . Vector.toList) $ (\(x,y) -> [x,y]) $ Vector.partition (getAny.snd.runWriter) grps tell $ map AlertBlockedForce blocked tell $ map AlertAppliedForce unblocked@@ -170,9 +170,9 @@ return $ stopBlockedWrenches blocked unblocked $ foldr applyForce st unblocked resolveSinglePlForce :: Force -> GameState -> Writer [Alert] GameState-resolveSinglePlForce force st = resolveForces+resolveSinglePlForce force = resolveForces (Vector.singleton (ForceChoice [force])) Vector.empty- (\_ _->False) st+ (\_ _->False) applyForce :: Force -> GameState -> GameState applyForce f s =@@ -180,13 +180,13 @@ pp' = applyForceTo (getpp s idx) f pp'' = case (placedPiece pp',f) of ( Wrench _ , Push _ dir ) -> pp' {placedPiece = Wrench dir}- _ -> pp'+ _ -> pp' in- s { placedPieces = (placedPieces s) // [(idx, pp'')] }+ s { placedPieces = placedPieces s // [(idx, pp'')] } collisionsWithForce :: GameState -> Force -> PieceIdx -> [HexPos] collisionsWithForce st (Push idx dir) idx' =- intersect (map (dir+^) $ footprintAtIgnoring st idx idx') (footprintAtIgnoring st idx' idx)+ map (dir+^) (footprintAtIgnoring st idx idx') `intersect` footprintAtIgnoring st idx' idx collisionsWithForce st force idx' = collisions (applyForce force st) (forceIdx force) idx' @@ -210,9 +210,9 @@ (Block _) -> null springs (Wrench mom) -> case force of Push _ v -> v /= mom- _ -> True+ _ -> True (Hook _ hf) -> case force of- Push _ v -> hf /= PushHF v+ Push _ v -> hf /= PushHF v Torque _ dir -> hf /= TorqueHF dir _ -> False in fixed@@ -223,15 +223,15 @@ let pp@(PlacedPiece _ piece) = getpp st idx rpos = cpos -^ placedPos pp armPush = case- (dir `hexDot` ((rotate 1 rpos) -^ rpos)) `compare`- (dir `hexDot` ((rotate (-1) rpos) -^ rpos)) of+ (dir `hexDot` (rotate 1 rpos -^ rpos)) `compare`+ (dir `hexDot` (rotate (-1) rpos -^ rpos)) of GT -> Torque idx 1 LT -> Torque idx $ -1 EQ -> Push idx dir in case piece of- Pivot _ -> armPush+ Pivot _ -> armPush Hook _ (TorqueHF _) -> armPush- _ -> (Push idx dir)+ _ -> Push idx dir -- |propagateForce: return forces a force causes via bumps and fully -- compressed/extended springs@@ -270,11 +270,11 @@ -- forcechoice and the first results in a block due to resistance, try the -- next instead. propagate :: GameState -> Bool -> ForceChoice -> Writer Any [Force]-propagate st isPlSource fch = Set.toList `liftM` propagate' isPlSource Set.empty fch where+propagate st isPlSource fch = Set.toList <$> propagate' isPlSource Set.empty fch where propagate' isPlForce ps (ForceChoice (f:backups)) = if f `Set.member` ps then return ps else- let (ps', failed) = if pieceResists st f && (not isPlForce)+ let (ps', failed) = if pieceResists st f && not isPlForce then (ps, Any True) else runWriter $ foldrM (flip $ propagate' False)
Protocol.hs view
@@ -10,14 +10,14 @@ module Protocol where -import Data.Binary-import Control.Monad+import Control.Monad+import Data.Binary -import Crypto.Types.PubKey.RSA (PublicKey)+import Crypto.Types.PubKey.RSA (PublicKey) -import BinaryInstances-import Metagame-import Lock+import BinaryInstances+import Lock+import Metagame type ProtocolVersion = Int protocolVersion = 1 :: ProtocolVersion@@ -50,13 +50,13 @@ type Password = String needsAuth :: Action -> Bool-needsAuth GetServerInfo = False-needsAuth GetPublicKey = False-needsAuth (GetLock _) = False-needsAuth (GetUserInfo _ _) = False-needsAuth (GetRetired _) = False+needsAuth GetServerInfo = False+needsAuth GetPublicKey = False+needsAuth (GetLock _) = False+needsAuth (GetUserInfo _ _) = False+needsAuth (GetRetired _) = False needsAuth (GetRandomNames _) = False-needsAuth _ = True+needsAuth _ = True data ServerResponse = ServerAck@@ -102,59 +102,59 @@ get = do tag <- get :: Get Word8 case tag of- 0 -> return Authenticate- 1 -> return Register- 2 -> return GetServerInfo- 3 -> liftM GetLock get- 4 -> liftM2 GetUserInfo get get- 5 -> liftM GetHint get- 6 -> liftM GetSolution get- 7 -> liftM4 DeclareSolution get get get get- 8 -> liftM3 SetLock get get get- 9 -> liftM GetRandomNames get- 10 -> liftM ResetPassword get- 11 -> liftM GetRetired get- 12 -> liftM SetEmail get+ 0 -> return Authenticate+ 1 -> return Register+ 2 -> return GetServerInfo+ 3 -> GetLock <$> get+ 4 -> liftM2 GetUserInfo get get+ 5 -> GetHint <$> get+ 6 -> GetSolution <$> get+ 7 -> liftM4 DeclareSolution get get get get+ 8 -> liftM3 SetLock get get get+ 9 -> GetRandomNames <$> get+ 10 -> ResetPassword <$> get+ 11 -> GetRetired <$> get+ 12 -> SetEmail <$> get 13 -> return GetPublicKey- _ -> return UndefinedAction+ _ -> return UndefinedAction instance Binary Auth where put (Auth name pw) = put name >> put pw get = liftM2 Auth get get instance Binary ServerResponse where- put ServerAck = put (0::Word8)- put (ServerMessage mesg) = put (1::Word8) >> put mesg- put (ServerError err) = put (2::Word8) >> put err- put (ServedServerInfo sinfo) = put (3::Word8) >> put sinfo- put (ServedLock lock) = put (4::Word8) >> put lock- put (ServedUserInfo info) = put (5::Word8) >> put info+ put ServerAck = put (0::Word8)+ put (ServerMessage mesg) = put (1::Word8) >> put mesg+ put (ServerError err) = put (2::Word8) >> put err+ put (ServedServerInfo sinfo) = put (3::Word8) >> put sinfo+ put (ServedLock lock) = put (4::Word8) >> put lock+ put (ServedUserInfo info) = put (5::Word8) >> put info put (ServedUserInfoDeltas info) = put (6::Word8) >> put info- put (ServedSolution soln) = put (7::Word8) >> put soln- put (ServedHint hint) = put (8::Word8) >> put hint- put (ServedRandomNames names) = put (9::Word8) >> put names- put (ServerCodenameFree) = put (10::Word8)- put (ServerFresh) = put (11::Word8)- put (ServedRetired lss) = put (12::Word8) >> put lss+ put (ServedSolution soln) = put (7::Word8) >> put soln+ put (ServedHint hint) = put (8::Word8) >> put hint+ put (ServedRandomNames names) = put (9::Word8) >> put names+ put ServerCodenameFree = put (10::Word8)+ put ServerFresh = put (11::Word8)+ put (ServedRetired lss) = put (12::Word8) >> put lss put (ServedPublicKey publicKey) = put (13::Word8) >> put (show publicKey) get = do tag <- get :: Get Word8 case tag of- 0 -> return ServerAck- 1 -> liftM ServerMessage get- 2 -> liftM ServerError get- 3 -> liftM ServedServerInfo get- 4 -> liftM ServedLock get- 5 -> liftM ServedUserInfo get- 6 -> liftM ServedUserInfoDeltas get- 7 -> liftM ServedSolution get- 8 -> liftM ServedHint get- 9 -> liftM ServedRandomNames get+ 0 -> return ServerAck+ 1 -> ServerMessage <$> get+ 2 -> ServerError <$> get+ 3 -> ServedServerInfo <$> get+ 4 -> ServedLock <$> get+ 5 -> ServedUserInfo <$> get+ 6 -> ServedUserInfoDeltas <$> get+ 7 -> ServedSolution <$> get+ 8 -> ServedHint <$> get+ 9 -> ServedRandomNames <$> get 10 -> return ServerCodenameFree 11 -> return ServerFresh- 12 -> liftM ServedRetired get- 13 -> liftM (ServedPublicKey . read) get- _ -> return ServerUndefinedResponse+ 12 -> ServedRetired <$> get+ 13 -> ServedPublicKey . read <$> get+ _ -> return ServerUndefinedResponse instance Binary ServerInfo where put (ServerInfo sz str) = put sz >> put str get = liftM2 ServerInfo get get
README view
@@ -1,48 +1,23 @@-Intricacy-=========+# Intricacy A game of competitive puzzle-design. -http://mbays.freeshell.org/intricacy/---Playing-=======-Press 'T' on the starting screen to play the tutorials, which should lead you-to discover the main game mechanics. When you've finished or had enough of the-tutorials, select a codename with 'C' and register it with 'R'. The rest you-can hopefully figure out, but see below if you'd rather read about it.-+https://mbays.sdf.org/intricacy/ -Configuration-=============+## Configuration You can change keybindings in SDL mode by right-clicking on the corresponding button and pressing a key. -The buttons in the top right when solving/editing locks in SDL mode are as-follows:- * The three hexes toggles between two modes for colouring pieces; in one- mode (three yellow hexes), the colours are determined by the nature of- the pieces; in the other mode, adjacent pieces always get different- colours.- * The lone hex with optional arrow toggles "blockage annotations". These- are there to help you figure out what's going on when you can't- understand why a piece refuses to move. An orange arrow indicates a- blocked force, a purple arrow indicates a force which blocked another- force.- * The soundwave icon toggles sound.- * The narrow hex enscribed within a wide hex toggles between fullscreen- and windowed mode. The resolution used when switching to fullscreen - is that of the window prior to fullscreening.--Config files are saved in ~/.intricacy/ on unixoids, or something like-"...\Application Data\intricacy\" on windows. In particular, the locks you+Config files are saved in `~/.intricacy/` on unixoids, or something like+`...\Application Data\intricacy\` on windows. In particular, the locks you create in the lock editor are saved in there (and you can organise them into directories by including (back)slashs in the lock name). You can edit them in a text editor if you want - see AsciiLock.hs for what the characters mean. +If you want to cheat your way past initiation, change "False" to "True" in+`metagame.conf`. -Rough description of the game mechanics-=======================================++## Rough description of the game mechanics * Locks consist of blocks, pivots and balls. Blocks can be connected to other blocks by springs. Pivots have arms. When picking a lock, you control two tools - a hook, which acts as a mobile one-armed pivot, and a wrench,@@ -62,11 +37,10 @@ against a fixed piece such as a tool, it won't block the other force. -Full details of the metagame mechanics-======================================+## Full details of the metagame mechanics (Where by the 'game' I mean the lock-picking bit, and by the 'metagame' I mean the bit with the 3-letter codenames and the three lock slots and notes and so-on.)+on. If you haven't seen anything of the kind... keep solving those locks!) A player accesses a lock slot when one of the following holds (i) the player has read three notes on the lock in the slot;@@ -92,8 +66,7 @@ in one of your three lock slots. Once the note is placed, it can't be moved. -Full details of the game mechanics-==================================+## Full details of the game mechanics Springs are directed; one of the blocks it is connected to is the 'root', the other the 'end'. A block is stationary if it is not the end of any spring. The directed graph whose nodes are the blocks and whose edges are the springs is
SDLGlyph.hs view
@@ -10,27 +10,27 @@ module SDLGlyph where -import Graphics.UI.SDL-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.State-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Class-import Data.Map (Map)-import qualified Data.Map as Map-import qualified Data.List as List-import Control.Applicative-import System.Random (randomRIO)+import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State+import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map+import Graphics.UI.SDL+import System.Random (randomRIO) -import Hex-import SDLRender-import GameState-import GameStateTypes-import BoardColouring-import Physics-import Command-import Util+import BoardColouring+import Command+import GameState+import GameStateTypes+import Hex+import Physics+import SDLRender+import Util data ShowBlocks = ShowBlocksBlocking | ShowBlocksAll | ShowBlocksNone@@ -50,6 +50,8 @@ | HollowInnerGlyph Pixel | FilledHexGlyph Pixel | ButtonGlyph Pixel+ | PathGlyph HexDir Pixel+ | GateGlyph HexDir Pixel | UseFiveColourButton Bool | ShowBlocksButton ShowBlocks | ShowButtonTextButton Bool@@ -137,27 +139,25 @@ -- TODO: we should find a way to deal with at least some of these; -- springs in particular are common and expensive to draw. -- Maybe we could truncate the spring glyphs to a hex?- TileGlyph (BlockTile adjs) _ -> null adjs+ TileGlyph (BlockTile adjs) _ -> null adjs TileGlyph (SpringTile extn dir) _ -> False- SpringGlyph _ _ _ _ _ -> False- FilledHexGlyph _ -> False- HollowGlyph _ -> False- BlockedBlock _ _ _ -> False- BlockedPush _ _ -> False- CollisionMarker -> False- DisplacedGlyph _ _ -> False- _ -> True+ SpringGlyph {} -> False+ FilledHexGlyph _ -> False+ HollowGlyph _ -> False+ BlockedBlock {} -> False+ BlockedPush _ _ -> False+ CollisionMarker -> False+ DisplacedGlyph _ _ -> False+ _ -> True renderGlyph :: Glyph -> RenderM () renderGlyph (TileGlyph (BlockTile adjs) col) = rimmedPolygonR corners col $ bright col where corners = concat [- if or $ map adjAt [0,1]+ if any adjAt [0,1] then [corner $ hextant dir]- else if adjAt $ -1- then []- else [innerCorner dir]+ else [innerCorner dir | not (adjAt $ -1)] | dir <- hexDirs , let adjAt r = rotate r dir `elem` adjs ]@@ -180,13 +180,12 @@ let from = innerCorner $ neg mom to = edge $ neg mom- shifts = [ (1/2) **^ (b -^ a)- | rot <- [-1,0,1]- , let a = innerCorner $ neg mom- , let b = innerCorner $ rotate rot $ neg mom- ]+ shifts = [(1 / 2) **^ (b -^ a) |+ let a = innerCorner $ neg mom,+ rot <- [- 1, 0, 1],+ let b = innerCorner $ rotate rot $ neg mom] in sequence_- [ aaLineR (from+^shift) (to+^shift) $ col+ [ aaLineR (from+^shift) (to+^shift) col | shift <- shifts ] renderGlyph (TileGlyph BallTile col) =@@ -197,8 +196,8 @@ where n :: Int n = 3*case extn of- Stretched -> 1- Relaxed -> 2+ Stretched -> 1+ Relaxed -> 2 Compressed -> 4 brightness = dim dir' = if dir == zero then hu else dir@@ -214,7 +213,6 @@ rimmedCircleR zero (7/8) col $ bright col when (dir /= zero) $ aaLineR from to $ bright col- return () where from = rotFVec th c $ (7/8) **^ edge (neg dir) to = rotFVec th c $ (7/8) **^ edge dir@@ -222,12 +220,12 @@ th = - fi rot * pi / 12 renderGlyph (ArmGlyph rot dir col) =- thickLineR from to 1 col+ thickLineR from to 1 $ bright col where dir' = if dir == zero then hu else dir from = rotFVec th c $ edge $ neg dir' to = rotFVec th c $ innerCorner dir'- c = (2 **^ edge (neg dir'))+ c = 2 **^ edge (neg dir') th = - fi rot * pi / 12 renderGlyph (BlockedArm armdir tdir col) =@@ -252,7 +250,7 @@ renderGlyph (BlockedPush dir col) = do thickLineR zero tip 1 col- thickLineR tip (arms!!0) 1 col+ thickLineR tip (head arms) 1 col thickLineR tip (arms!!1) 1 col where tip@(FVec tx ty) = edge dir@@ -260,7 +258,7 @@ renderGlyph CollisionMarker = do -- rimmedCircle surf centre (size`div`3) (bright purple) $ bright purple- aaLineR start end $ col+ aaLineR start end col aaCircleR zero rad col where [start,end] = map (((1/2)**^) . corner) [0,3]@@ -281,6 +279,18 @@ renderGlyph (ButtonGlyph col) = renderGlyph (TileGlyph (BlockTile []) col) +renderGlyph (PathGlyph dir col) = do+ aaLineR from to col+ where+ from = edge $ neg dir+ to = edge dir++renderGlyph (GateGlyph dir col) = do+ aaLineR from to col+ where+ from = corner $ 1 + hextant dir+ to = corner $ 4 + hextant dir+ renderGlyph (UseFiveColourButton using) = rescaleRender (1/2) $ sequence_ [ displaceRender (corner h) $ renderGlyph@@ -302,10 +312,10 @@ sequence_ [ pixelR (FVec (1/3 + i/4) (-1/4)) (bright white) | i <- [-1..1] ] renderGlyph (UseSoundsButton use) = do- sequence [ arcR (FVec (-2/3) 0) r (-20) 20+ sequence_ [ arcR (FVec (-2/3) 0) r (-20) 20 (if use then bright green else dim red) | r <- [1/3,2/3,1] ]- when (not use) $+ unless use $ aaLineR (innerCorner hw) (innerCorner $ neg hw) $ dim red renderGlyph (WhsButtonsButton Nothing) = rescaleRender (1/3) $ do@@ -313,7 +323,7 @@ sequence_ [ displaceRender ((3/2) **^ edge dir) $ renderGlyph (ButtonGlyph (dim purple)) | dir <- hexDirs ]-renderGlyph (WhsButtonsButton (Just whs)) = rescaleRender (1/2) $ do+renderGlyph (WhsButtonsButton (Just whs)) = rescaleRender (1/3) $ do when (whs /= WHSHook) $ displaceRender (corner 0) $ renderGlyph (TileGlyph (WrenchTile zero) col) when (whs /= WHSWrench) $ do@@ -326,7 +336,7 @@ thickPolygonR corners 1 $ activeCol (not fs) thickPolygonR corners' 1 $ activeCol fs where- activeCol True = opaquify $ dim green+ activeCol True = opaquify $ dim green activeCol False = opaquify $ dim red corners = [ (2/3) **^ (if dir `elem` [hu,neg hu] then edge else innerCorner) dir | dir <- hexDirs ]@@ -335,13 +345,13 @@ renderGlyph (DisplacedGlyph dir glyph) = displaceRender (innerCorner dir) $ renderGlyph glyph -renderGlyph (UnfreshGlyph) = do+renderGlyph UnfreshGlyph = do let col = bright red renderGlyph (HollowInnerGlyph col) sequence_ [pixelR (FVec (i/4) 0) col | i <- [-1..1] ] -playerGlyph col = FilledHexGlyph col+playerGlyph = FilledHexGlyph cursorGlyph = HollowGlyph $ bright white @@ -351,13 +361,13 @@ drawCursorAt :: Maybe HexPos -> RenderM () drawCursorAt (Just pos) = drawAt cursorGlyph pos-drawCursorAt _ = return ()+drawCursorAt _ = return () drawBasicBG :: Int -> RenderM () drawBasicBG maxR = sequence_ [ drawAtRel (HollowGlyph $ colAt v) v | v <- hexDisc maxR ] where colAt v@(HexVec hx hy hz) = let- [r,g,b] = map (\h -> fi $ ((0xff*)$ 5 + abs h)`div`maxR) [hx,hy,hz]+ [r,g,b] = map (\h -> fi $ 0xff * (5 + abs h)`div`maxR) [hx,hy,hz] a = fi $ (0x70 * (maxR - abs (hexLen v)))`div`maxR in rgbaToPixel (r,g,b,a) @@ -366,8 +376,8 @@ let (pos,arms) = case getpp st idx of PlacedPiece pos (Pivot arms) -> (pos,arms) PlacedPiece pos (Hook arm _) -> (pos,[arm])- _ -> (pos,[])- col = if blocking then bright $ purple else dim $ colourOf colouring idx+ _ -> (pos,[])+ col = if blocking then bright purple else dim $ colourOf colouring idx sequence_ [ drawAt (BlockedArm arm dir col) (arm +^ pos) | arm <- arms ] drawBlocked st colouring blocking (Push idx dir) = do@@ -384,7 +394,7 @@ let (pos,arms) = case getpp st idx of PlacedPiece pos (Pivot arms) -> (pos,arms) PlacedPiece pos (Hook arm _) -> (pos,[arm])- _ -> (pos,[])+ _ -> (pos,[]) col = dim $ colourOf colouring idx sequence_ [ drawAt (TurnedArm arm dir col) (arm +^ pos) | arm <- arms ]
SDLRender.hs view
@@ -11,25 +11,25 @@ -- |SDLRender: generic wrapper around sdl-gfx for drawing on hex grids module SDLRender where -import Graphics.UI.SDL-import Graphics.UI.SDL.Primitives-import qualified Graphics.UI.SDL.TTF as TTF-import Data.Semigroup as Sem-import Data.Monoid-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Class-import Data.Map (Map)-import qualified Data.Map as Map-import Data.List (maximumBy)-import Data.Function (on)-import GHC.Int (Int16)-import Control.Applicative+import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Data.Function (on)+import Data.List (maximumBy)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Monoid+import Data.Semigroup as Sem+import GHC.Int (Int16)+import Graphics.UI.SDL+import Graphics.UI.SDL.Primitives+import qualified Graphics.UI.SDL.TTF as TTF -import Hex-import Util+import Hex+import Util -- |SVec: screen vectors, in pixels data SVec = SVec { cx, cy :: Int }@@ -60,15 +60,15 @@ -- So instead, we define a new operator: (**^) :: Float -> FVec -> FVec r **^ FVec x y = FVec (r*x) (r*y)- + hexVec2SVec :: Int -> HexVec -> SVec hexVec2SVec size (HexVec x y z) = SVec ((x-z) * size) (-y * 3 * ysize size) hexVec2FVec :: HexVec -> FVec hexVec2FVec (HexVec x y z) =- FVec (fi $ x-z) (-(fi y) * 3 * ylen)+ FVec (fi $ x-z) (-fi y * 3 * ylen) fVec2SVec :: Int -> FVec -> SVec fVec2SVec size (FVec x y) = SVec@@ -93,18 +93,18 @@ [ (i, abs $ c'-c) | i <- [1..3], let c' = unrounded Map.! i, let c = fi $ rounded Map.! i] [x,y,z] = map snd $ Map.toList $- Map.adjust (\x -> x - (sum $ Map.elems rounded)) maxdiff rounded+ Map.adjust (\x -> x - sum (Map.elems rounded)) maxdiff rounded in HexVec x y z data RenderContext = RenderContext- { renderSurf :: Surface- , renderBGSurf :: Maybe Surface+ { renderSurf :: Surface+ , renderBGSurf :: Maybe Surface , renderHCentre :: HexPos , renderSCentre :: SVec- , renderOffset :: FVec- , renderSize :: Int- , renderFont :: Maybe TTF.Font+ , renderOffset :: FVec+ , renderSize :: Int+ , renderFont :: Maybe TTF.Font } type RenderT = ReaderT RenderContext @@ -121,11 +121,11 @@ local $ \rc -> rc { renderOffset = renderOffset rc +^ d } recentreAt :: Monad m => HexVec -> RenderT m a -> RenderT m a-recentreAt v m = displaceRender (hexVec2FVec v) m+recentreAt v = displaceRender (hexVec2FVec v) rescaleRender :: Monad m => Float -> RenderT m a -> RenderT m a rescaleRender r = local $ (\rc -> rc- { renderSize = round $ r * (fi $ renderSize rc) } ) . applyOffset+ { renderSize = round $ r * fi (renderSize rc) } ) . applyOffset withFont :: Monad m => Maybe TTF.Font -> RenderT m a -> RenderT m a withFont font = local $ \rc -> rc { renderFont = font }@@ -136,7 +136,7 @@ c <- asks renderSCentre off <- asks renderOffset let SVec x y = c +^ fVec2SVec size (v +^ off)- return $ (fi x, fi y)+ return (fi x, fi y) renderLen :: Monad m => Integral i => Float -> RenderT m i renderLen l = do size <- asks renderSize@@ -173,15 +173,14 @@ void.liftIO $ filledCircle surf x y r col -- aaPolygon seems to be a bit buggy in sdl-gfx-0.6.0-aaPolygonR verts col =- aaLinesR (verts ++ take 1 verts) col+aaPolygonR verts = aaLinesR (verts ++ take 1 verts) -- aaCircle too aaCircleR v rad col = do (x,y) <- renderPos v r <- renderLen rad surf <- asks renderSurf- if (r <= 1) then void.liftIO $ pixel surf x y col+ if r <= 1 then void.liftIO $ pixel surf x y col else void.liftIO $ aaCircle surf x y r col @@ -202,7 +201,7 @@ thickLineR from to thickness col = let FVec dx dy = to -^ from baseThickness = (1/16)- s = baseThickness * thickness / (sqrt $ dx^2 + dy^2)+ s = baseThickness * thickness / sqrt (dx^2 + dy^2) perp = (s/2) **^ FVec dy (-dx) in rimmedPolygonR [ from +^ perp, to +^ perp@@ -213,8 +212,7 @@ sequence_ [ thickLineR v v' thickness col | (v,v') <- zip (take (length verts - 1) verts) (drop 1 verts) ] -thickPolygonR verts thickness col =- thickLinesR (verts ++ take 1 verts) thickness col+thickPolygonR verts = thickLinesR (verts ++ take 1 verts) ylen = 1 / sqrt 3@@ -286,9 +284,7 @@ colourOf :: Ord i => Map i Int -> i -> Pixel colourOf colouring idx =- case Map.lookup idx colouring of- Nothing -> white- Just n -> colourWheel n+ maybe white colourWheel (Map.lookup idx colouring) setPixelAlpha alpha (Pixel v) = Pixel $ v `div` 0x100 * 0x100 + alpha bright = setPixelAlpha 0xff@@ -319,20 +315,26 @@ let (r,g,b,_) = pixelToRGBA p in Color (fi r) (fi g) (fi b) -renderStrColAt,renderStrColAtLeft :: (Functor m, MonadIO m) => Pixel -> String -> HexVec -> RenderT m ()-renderStrColAt = renderStrColAt' True-renderStrColAtLeft = renderStrColAt' False-renderStrColAt' :: (Functor m, MonadIO m) => Bool -> Pixel -> String -> HexVec -> RenderT m ()-renderStrColAt' centred c str v = void $ runMaybeT $ do+data Alignment = Centred | LeftAligned | ScreenCentred+renderStrColAt,renderStrColAtLeft,renderStrColAtCentre ::+ (Functor m, MonadIO m) => Pixel -> String -> HexVec -> RenderT m ()+renderStrColAt = renderStrColAt' Centred+renderStrColAtLeft = renderStrColAt' LeftAligned+renderStrColAtCentre = renderStrColAt' ScreenCentred+renderStrColAt' :: (Functor m, MonadIO m) => Alignment -> Pixel -> String -> HexVec -> RenderT m ()+renderStrColAt' align c str v = void $ runMaybeT $ do font <- MaybeT $ asks renderFont fsurf <- MaybeT $ liftIO $ TTF.tryRenderTextBlended font str $ pixelToColor c (surf, scrCentre, off, size) <- lift $ asks $ liftM4 (,,,) renderSurf renderSCentre renderOffset renderSize let SVec x y = scrCentre +^ fVec2SVec size (off +^ hexVec2FVec v) +^ neg (SVec 0 ((surfaceGetHeight fsurf-1)`div`2) +^- if centred- then SVec ((surfaceGetWidth fsurf)`div`2) 0- else SVec 0 0)- void $ liftIO $ blitSurface fsurf Nothing surf (Just $ Rect x y 0 0)+ case align of+ Centred -> SVec (surfaceGetWidth fsurf`div`2) 0+ _ -> SVec 0 0)+ x' = case align of+ ScreenCentred -> cx scrCentre - (surfaceGetWidth fsurf `div` 2)+ _ -> x+ void $ liftIO $ blitSurface fsurf Nothing surf (Just $ Rect x' y 0 0) renderStrColAbove,renderStrColBelow :: (Functor m, MonadIO m) => Pixel -> String -> HexVec -> RenderT m () renderStrColAbove = renderStrColVShifted True
SDLUI.hs view
@@ -8,101 +8,106 @@ -- 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 CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-} module SDLUI 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-import qualified Data.Map as Map-import Data.Map (Map)-import Data.Maybe-import Control.Monad.State-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Reader-import Control.Arrow-import Data.Word-import Data.Array-import Data.List-import Data.Ratio-import Data.Function (on)-import Data.Time.Clock (getCurrentTime)-import System.FilePath+import Control.Applicative+import Control.Arrow+import Control.Concurrent.STM+import Control.Monad ((<=<))+import Control.Monad.State+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Data.Array+import Data.Function (on)+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Ratio+import Data.Time.Clock (getCurrentTime)+import Data.Word+import Graphics.UI.SDL hiding (flip)+import qualified Graphics.UI.SDL as SDL+import qualified Graphics.UI.SDL.TTF as TTF+import System.FilePath --import Debug.Trace (traceShow) #ifdef SOUND-import Graphics.UI.SDL.Mixer-import System.Random (randomRIO)+import Graphics.UI.SDL.Mixer+import System.Random (randomRIO) #endif -import Hex-import Command-import GameState (stateBoard)-import GameStateTypes-import BoardColouring-import Lock-import Physics-import GameState-import KeyBindings-import Mundanities-import Metagame-import SDLRender-import SDLGlyph-import InputMode-import Maxlocksize-import Util+import BoardColouring+import Command+import GameState+import GameStateTypes+import Hex+import InputMode+import KeyBindings+import Lock+import Maxlocksize+import Metagame+import Mundanities+import Physics+import SDLGlyph+import SDLRender+import Util -data UIState = UIState { scrHeight::Int, scrWidth::Int- , gsSurface::Maybe Surface- , bgSurface::Maybe Surface- , cachedGlyphs::CachedGlyphs- , lastDrawArgs::Maybe DrawArgs- , miniLocks::Map Lock Surface- , registeredSelectables::Map HexVec Selectable- , contextButtons::[ButtonGroup]- , uiOptions::UIOptions- , settingBinding::Maybe Command- , uiKeyBindings :: Map InputMode KeyBindings- , dispFont::Maybe TTF.Font- , dispFontSmall::Maybe TTF.Font- , lastFrameTicks::Word32- , paintTileIndex::Int- , leftButtonDown::Maybe HexVec, middleButtonDown::Maybe HexVec, rightButtonDown::Maybe HexVec- , mousePos::(HexVec,Bool)- , message::Maybe (Pixel, String)- , hoverStr :: Maybe String- , needHoverUpdate::Bool- , dispCentre::HexPos- , dispLastCol::PieceColouring- , animFrame::Int- , nextAnimFrameAt::Maybe Word32- , fps::Int+data UIState = UIState+ { scrHeight :: Int+ , scrWidth :: Int+ , gsSurface :: Maybe Surface+ , bgSurface :: Maybe Surface+ , cachedGlyphs :: CachedGlyphs+ , lastDrawArgs :: Maybe DrawArgs+ , miniLocks :: Map Lock Surface+ , registeredSelectables :: Map HexVec Selectable+ , contextButtons :: [ButtonGroup]+ , uiOptions :: UIOptions+ , settingBinding :: Maybe Command+ , uiKeyBindings :: Map InputMode KeyBindings+ , dispFont :: Maybe TTF.Font+ , dispFontSmall :: Maybe TTF.Font+ , lastFrameTicks :: Word32+ , paintTileIndex :: Int+ , leftButtonDown :: Maybe HexVec+ , middleButtonDown :: Maybe HexVec+ , rightButtonDown :: Maybe HexVec+ , mousePos :: (HexVec,Bool)+ , message :: Maybe (Pixel, String)+ , hoverStr :: Maybe String+ , dispCentre :: HexPos+ , dispLastCol :: PieceColouring+ , animFrame :: Int+ , nextAnimFrameAt :: Maybe Word32+ , fps :: Int #ifdef SOUND- , sounds::Map String [Chunk]+ , sounds :: Map String [Chunk] #endif } deriving (Eq, Ord, Show) type UIM = StateT UIState IO nullUIState = UIState 0 0 Nothing Nothing emptyCachedGlyphs Nothing Map.empty Map.empty [] defaultUIOptions Nothing Map.empty Nothing Nothing 0 0 Nothing Nothing Nothing- (zero,False) Nothing Nothing False (PHS zero) Map.empty 0 Nothing 50+ (zero,False) Nothing Nothing (PHS zero) Map.empty 0 Nothing 50 #ifdef SOUND Map.empty #endif data UIOptions = UIOptions- { useFiveColouring::Bool- , showBlocks::ShowBlocks- , whsButtons::Maybe WrHoSel- , useBackground::Bool- , fullscreen::Bool- , showButtonText::Bool- , useSounds::Bool- , uiAnimTime::Word32- , shortUiAnimTime::Word32+ { useFiveColouring :: Bool+ , showBlocks :: ShowBlocks+ , whsButtons :: Maybe WrHoSel+ , useBackground :: Bool+ , fullscreen :: Bool+ , showButtonText :: Bool+ , useSounds :: Bool+ , uiAnimTime :: Word32+ , shortUiAnimTime :: Word32 } deriving (Eq, Ord, Show, Read) defaultUIOptions = UIOptions False ShowBlocksBlocking Nothing True False True True 100 20@@ -141,7 +146,7 @@ modify $ \ds -> ds { lastFrameTicks = now } -data Button = Button { buttonPos::HexVec, buttonCmd::Command, buttonHelp::[ButtonHelp] }+data Button = Button { buttonPos :: HexVec, buttonCmd :: Command, buttonHelp :: [ButtonHelp] } deriving (Eq, Ord, Show) type ButtonGroup = ([Button],(Int,Int)) type ButtonHelp = (String, HexVec)@@ -149,33 +154,28 @@ singleButton pos cmd col helps = ([Button pos cmd helps], (col,0)) getButtons :: InputMode -> UIM [ ButtonGroup ] getButtons mode = do- mwhs <- gets $ whsButtons.uiOptions+ mwhs <- gets $ whsButtons . uiOptions cntxtButtons <- gets contextButtons return $ cntxtButtons ++ global ++ case mode of IMEdit -> [ singleButton (tl+^hv+^neg hw) CmdTest 1 [("test", hu+^neg hw)]- , singleButton (tl+^(neg hw)) CmdPlay 2 [("play", hu+^neg hw)]- , markGroup+ , singleButton (tl+^neg hw) CmdPlay 2 [("play", hu+^neg hw)]+ , markButtonGroup , singleButton (br+^2*^hu) CmdWriteState 2 [("save", hu+^neg hw)] ] ++ whsBGs mwhs mode ++ [ ([Button (paintButtonStart +^ hu +^ i*^hv) (paintTileCmds!!i) [] | i <- take (length paintTiles) [0..] ],(5,0)) ]- IMPlay ->- [ markGroup ]- ++ whsBGs mwhs mode- IMReplay -> [ markGroup ]+ IMPlay -> whsBGs mwhs mode+ IMReplay -> [ markButtonGroup ] IMMeta -> [ singleButton serverPos CmdSetServer 0 [("server",7*^neg hu)] , singleButton (serverPos+^hw) CmdToggleCacheOnly 0 [("offline",hv+^7*^neg hu),("mode",hw+^5*^neg hu)] , singleButton (codenamePos +^ 2*^neg hu) (CmdSelCodename Nothing) 2 [("code",hv+^5*^neg hu),("name",hw+^5*^neg hu)]- , singleButton (serverPos +^ 2*^neg hv +^ 2*^hw) CmdTutorials 3 [("play",hu+^neg hw),("tut",hu+^neg hv)]+ , singleButton (serverPos +^ 2*^neg hv +^ 2*^hw) CmdInitiation 3 [("initi",hu+^neg hw),("ation",hu+^neg hv)] ] _ -> [] where- markGroup = ([Button (tl+^hw) CmdMark [("set",hu+^neg hw),("mark",hu+^neg hv)]- , Button (tl+^hw+^hv) CmdJumpMark [("jump",hu+^neg hw),("mark",hu+^neg hv)]- , Button (tl+^hw+^2*^hv) CmdReset [("jump",hu+^neg hw),("start",hu+^neg hv)]],(0,1)) global = if mode `elem` [IMTextInput,IMImpatience] then [] else [ singleButton br CmdQuit 0 [("quit",hu+^neg hw)] , singleButton (tr +^ 3*^hv +^ 3*^hu) CmdHelp 3 [("help",hu+^neg hw)] ]@@ -184,31 +184,36 @@ whsBGs (Just whs) mode = let edit = mode == IMEdit in [ ( [ Button bl (if edit then CmdSelect else CmdWait) [] ], (0,0))- , ( [ Button (bl+^dir) (CmdDir whs dir)+ , ( [ Button (bl+^dir) (CmdDir whs dir) (if dir==hu then [("move",hu+^neg hw),(if edit then "piece" else whsStr whs,hu+^neg hv)] else [])- | dir <- hexDirs ], (5,0) )+ | dir <- hexDirs ], (5,0) ) ] ++- (if whs == WHSWrench then [] else- [ ( [ Button (bl+^((-2)*^hv))- (CmdRotate whs (-1))- [("turn",hu+^neg hw),("cw",hu+^neg hv)]- , Button (bl+^((-2)*^hw))- (CmdRotate whs 1)- [("turn",hu+^neg hw),("ccw",hu+^neg hv)]- ], (5,0) )- ]) ++- (if whs /= WHSSelected || mode == IMEdit then [] else- [ ( [ Button (bl+^(2*^hv)+^hw+^neg hu) (CmdTile $ HookTile) [("select",hu+^neg hw),("hook",hu+^neg hv)]- , Button (bl+^(2*^hv)+^neg hu) (CmdTile $ WrenchTile zero) [("select",hu+^neg hw),("wrench",hu+^neg hv)]- ], (2,0) ) ])+ ([( [ Button (bl+^((-2)*^hv))+ (CmdRotate whs (-1))+ [("turn",hu+^neg hw),("cw",hu+^neg hv)]+ , Button (bl+^((-2)*^hw))+ (CmdRotate whs 1)+ [("turn",hu+^neg hw),("ccw",hu+^neg hv)]+ ], (5,0) ) | whs /= WHSWrench]) +++ ([( [ Button (bl+^(2*^hv)+^hw+^neg hu) (CmdTile HookTile) [("select",hu+^neg hw),("hook",hu+^neg hv)]+ , Button (bl+^(2*^hv)+^neg hu) (CmdTile $ WrenchTile zero) [("select",hu+^neg hw),("wrench",hu+^neg hv)]+ ], (2,0) ) | whs == WHSSelected && mode /= IMEdit]) tr = periphery 0 tl = periphery 2 bl = periphery 3 br = periphery 5 +markButtonGroup = ([Button (tl+^hw) CmdMark [("set",hu+^neg hw),("mark",hu+^neg hv)]+ , Button (tl+^hw+^hv) CmdJumpMark [("jump",hu+^neg hw),("mark",hu+^neg hv)]+ , Button (tl+^hw+^2*^hv) CmdReset [("jump",hu+^neg hw),("start",hu+^neg hv)]],(0,1))+ where+ tl = periphery 2+ data AccessedInfo = AccessedSolved | AccessedPublic | AccessedReadNotes | AccessedUndeclared deriving (Eq, Ord, Show) data Selectable = SelOurLock+ | SelTut Bool+ | SelInitLock HexVec Bool | SelLock ActiveLock | SelLockUnset Bool ActiveLock | SelSelectedCodeName Codename@@ -234,8 +239,8 @@ registerSelectable :: HexVec -> Int -> Selectable -> UIM () registerSelectable v r s =- modify $ \ds -> ds {registeredSelectables = foldr- (`Map.insert` s) (registeredSelectables ds) $ map (v+^) $ hexDisc r}+ modify $ \ds -> ds {registeredSelectables = foldr (+ (`Map.insert` s) . (v+^)) (registeredSelectables ds) (hexDisc r)} registerButtonGroup :: ButtonGroup -> UIM () registerButtonGroup g = modify $ \ds -> ds {contextButtons = g:contextButtons ds} registerButton :: HexVec -> Command -> Int -> [ButtonHelp] -> UIM ()@@ -249,15 +254,17 @@ unless noUndo $ registerButton (periphery 2+^hu) CmdUndo 0 [("undo",hu+^neg hw)] unless noRedo $ registerButton (periphery 2+^hu+^neg hv) CmdRedo 2 [("redo",hu+^neg hw)] -commandOfSelectable IMMeta SelOurLock _ = Just $ CmdEdit+commandOfSelectable IMInit (SelTut _) _ = Just . CmdSolveInit $ Just zero+commandOfSelectable IMInit (SelInitLock v _) _ = Just . CmdSolveInit $ Just v+commandOfSelectable IMMeta SelOurLock _ = Just CmdEdit commandOfSelectable IMMeta (SelLock (ActiveLock _ i)) False = Just $ CmdSolve (Just i) commandOfSelectable IMMeta (SelLock (ActiveLock _ i)) True = Just $ CmdPlaceLock (Just i) commandOfSelectable IMMeta (SelScoreLock Nothing _ (ActiveLock _ i)) False = Just $ CmdSolve (Just i) commandOfSelectable IMMeta (SelScoreLock Nothing _ (ActiveLock _ i)) True = Just $ CmdPlaceLock (Just i)-commandOfSelectable IMMeta (SelScoreLock (Just _) _ _) _ = Just $ CmdHome+commandOfSelectable IMMeta (SelScoreLock (Just _) _ _) _ = Just CmdHome commandOfSelectable IMMeta (SelLockUnset True (ActiveLock _ i)) _ = Just $ CmdPlaceLock (Just i) commandOfSelectable IMMeta (SelSelectedCodeName _) False = Just $ CmdSelCodename Nothing-commandOfSelectable IMMeta (SelSelectedCodeName _) True = Just $ CmdHome+commandOfSelectable IMMeta (SelSelectedCodeName _) True = Just CmdHome commandOfSelectable IMMeta (SelUndeclared undecl) _ = Just $ CmdDeclare $ Just undecl commandOfSelectable IMMeta (SelReadNote note) False = Just $ CmdSelCodename $ Just $ noteAuthor note commandOfSelectable IMMeta (SelReadNote note) True = Just $ CmdViewSolution $ Just note@@ -268,7 +275,7 @@ commandOfSelectable IMMeta (SelSecured note) False = Just $ CmdSelCodename $ Just $ lockOwner $ noteOn note commandOfSelectable IMMeta (SelSecured note) True = Just $ CmdViewSolution $ Just note commandOfSelectable IMMeta (SelOldLock ls) _ = Just $ CmdPlayLockSpec $ Just ls-commandOfSelectable IMMeta (SelLockPath) _ = Just $ CmdSelectLock+commandOfSelectable IMMeta SelLockPath _ = Just CmdSelectLock commandOfSelectable IMTextInput (SelLock (ActiveLock _ i)) _ = Just $ CmdInputSelLock i commandOfSelectable IMTextInput (SelScoreLock _ _ (ActiveLock _ i)) _ = Just $ CmdInputSelLock i commandOfSelectable IMTextInput (SelLockUnset _ (ActiveLock _ i)) _ = Just $ CmdInputSelLock i@@ -279,13 +286,17 @@ commandOfSelectable IMTextInput (SelUndeclared undecl) _ = Just $ CmdInputSelUndecl undecl commandOfSelectable _ _ _ = Nothing +helpOfSelectable (SelTut False) = Just "Enter tutorials"+helpOfSelectable (SelTut True) = Just "Revisit tutorials"+helpOfSelectable (SelInitLock _ False) = Just "Attempt lock"+helpOfSelectable (SelInitLock _ True) = Just "Revisit solved lock" helpOfSelectable SelOurLock = Just "Design a lock." helpOfSelectable (SelSelectedCodeName name) = Just $- "Currently viewing "++name++"."-helpOfSelectable SelRelScore = Just $- "The extent to which you are held in higher esteem than this fellow guild member."-helpOfSelectable SelRelScoreComponent = Just $+ "Currently viewing player "++name++"."+helpOfSelectable SelRelScore = Just+ "The extent to which you are held in higher esteem than this player."+helpOfSelectable SelRelScoreComponent = Just "Contribution to total relative esteem." helpOfSelectable (SelLock (ActiveLock name i)) = Just $ name++"'s lock "++[lockIndexChar i]++"."@@ -294,36 +305,36 @@ helpOfSelectable (SelLockUnset False _) = Just "An empty lock slot." helpOfSelectable (SelUndeclared _) = Just- "Declare yourself able to unlock a lock by securing a note on it behind a lock of your own."+ "Declare your solution to a lock by securing a note on it behind a lock of your own." helpOfSelectable (SelRandom _) = Just- "Random set of guild members. Colours show relative esteem, bright red (-3) to bright green (+3)."+ "Random set of players. Colours show relative esteem, bright red (-3) to bright green (+3)." helpOfSelectable (SelScoreLock (Just name) Nothing _) = Just $- "Your lock, which "++name++" can not unlock."+ "Your lock. "++name++" can not not unlock it." helpOfSelectable (SelScoreLock (Just name) (Just AccessedPrivyRead) _) = Just $- "Your lock, on which "++name++" has read three notes: -1 to relative esteem."+ "Your lock. "++name++" has read three notes on it: -1 to relative esteem." helpOfSelectable (SelScoreLock (Just name) (Just (AccessedPrivySolved False)) _) = Just $- "Your lock, on which "++name++" has declared a note which you have not read: -1 to relative esteem."+ "Your lock. "++name++" has declared a note on it which you have not read: -1 to relative esteem." helpOfSelectable (SelScoreLock (Just name) (Just (AccessedPrivySolved True)) _) = Just $- "Your lock, on which "++name++" has declared a note which you have, however, read."-helpOfSelectable (SelScoreLock (Just name) (Just AccessedPub) _) = Just $- "Your lock, the secrets of which have been publically revealed: -1 to relative esteem."+ "Your lock. "++name++" has declared a note on it, but you have read that note."+helpOfSelectable (SelScoreLock (Just name) (Just AccessedPub) _) = Just+ "Your lock. Its secrets have been publically revealed: -1 to relative esteem." helpOfSelectable (SelScoreLock (Just name) (Just AccessedEmpty) _) = Just $- "Your empty lock slot; "++name++" can unlock all your locks: -1 to relative esteem."+ "Your empty lock slot. "++name++" can unlock all your locks: -1 to relative esteem." helpOfSelectable (SelScoreLock Nothing Nothing (ActiveLock name _)) = Just $- name++"'s lock, which you can not unlock."+ name++"'s lock. You can not unlock it." helpOfSelectable (SelScoreLock Nothing (Just AccessedPrivyRead) (ActiveLock name _)) = Just $- name++"'s lock, on which you have read three notes: +1 to relative esteem."+ name++"'s lock. You have read three notes on it: +1 to relative esteem." helpOfSelectable (SelScoreLock Nothing (Just (AccessedPrivySolved False)) (ActiveLock name _)) = Just $- name++"'s lock, on which you have declared a note which "++name++" has not read: +1 to relative esteem."+ name++"'s lock. You have declared a note on it which "++name++" has not read: +1 to relative esteem." helpOfSelectable (SelScoreLock Nothing (Just (AccessedPrivySolved True)) (ActiveLock name _)) = Just $- name++"'s lock, on which you have declared a note which "++name++" has, however, read."+ name++"'s lock. You have declared a note on it, but "++name++" has read your note." helpOfSelectable (SelScoreLock Nothing (Just AccessedPub) (ActiveLock name _)) = Just $- name++"'s lock, the secrets of which have been publically revealed: +1 to relative esteem."+ name++"'s lock. Its secrets have been publically revealed: +1 to relative esteem." helpOfSelectable (SelScoreLock Nothing (Just AccessedEmpty) (ActiveLock name _)) = Just $- name++"'s empty lock slot; you can unlock all "++name++"'s locks: +1 to relative esteem."+ name++"'s empty lock slot. You can unlock all "++name++"'s locks: +1 to relative esteem." helpOfSelectable (SelReadNote note) = Just $ "You have read "++noteAuthor note++"'s note on this lock."-helpOfSelectable SelReadNoteSlot = Just $+helpOfSelectable SelReadNoteSlot = Just "Reading three notes on this lock would suffice to reveal its secrets." helpOfSelectable (SelSecured note) = let ActiveLock owner idx = noteOn note in Just $ "Secured note on "++owner++"'s lock "++[lockIndexChar idx]++"."@@ -333,8 +344,8 @@ Nothing -> noteAuthor note ++ "'s note on this lock is public knowledge." helpOfSelectable (SelAccessed name) = Just $ name ++ " did not pick this lock, but learnt how to unlock it by reading three notes on it."-helpOfSelectable (SelPublicLock) = Just- "Notes behind retired or public locks are public; locks with three public notes are public."+helpOfSelectable SelPublicLock = Just+ "Notes behind retired or public locks are public; a lock with three public notes on it is public." helpOfSelectable (SelAccessedInfo meth) = Just $ case meth of AccessedSolved -> "You picked this lock and declared your solution, so may read any notes it secures." AccessedPublic -> "The secrets of this lock have been publically revealed."@@ -342,18 +353,18 @@ AccessedReadNotes -> "Having read three notes on others' solutions to this lock, you have unravelled its secrets." helpOfSelectable (SelOldLock ls) = Just $- "Retired lock, #"++show ls++". Any notes which were secured by the lock are now public knowledge."-helpOfSelectable SelLockPath = Just $+ "Retired lock #"++show ls++". Any notes which were secured by the lock are now public knowledge."+helpOfSelectable SelLockPath = Just "Select a lock by its name. The names you give your locks are not revealed to others."-helpOfSelectable SelPrivyHeader = Just $- "Fellow guild members able to unlock this lock, hence able to read its secured notes."-helpOfSelectable SelNotesHeader = Just $- "Secured notes. Notes are obfuscated sketches of method, proving success but revealing little."-helpOfSelectable SelToolWrench = Just $ "The wrench, one of your lockpicking tools. Click and drag to move."-helpOfSelectable SelToolHook = Just $ "The hook, one of your lockpicking tools. Click and drag to move, use mousewheel to turn."+helpOfSelectable SelPrivyHeader = Just+ "Notes on this lock declared by players who picked the lock."+helpOfSelectable SelNotesHeader = Just+ "Notes secured by this lock. These notes are read by everyone who can unlock the lock."+helpOfSelectable SelToolWrench = Just "The wrench, one of your lockpicking tools. Click and drag to move."+helpOfSelectable SelToolHook = Just "The hook, one of your lockpicking tools. Click and drag to move, use mousewheel to turn." cmdAtMousePos pos@(mPos,central) im selMode = do- buttons <- (concat . map fst) <$> getButtons im+ buttons <- concatMap fst <$> getButtons im sels <- gets registeredSelectables return $ listToMaybe $ [ buttonCmd button@@ -366,47 +377,46 @@ helpAtMousePos :: (HexVec, Bool) -> InputMode -> UIM (Maybe [Char]) helpAtMousePos (mPos,_) _ =- join . fmap helpOfSelectable . Map.lookup mPos <$> gets registeredSelectables+ gets $ (helpOfSelectable <=< Map.lookup mPos) . registeredSelectables -data UIOptButton a = UIOptButton { getUIOpt::UIOptions->a, setUIOpt::a->UIOptions->UIOptions,- uiOptVals::[a], uiOptPos::HexVec, uiOptGlyph::a->Glyph, uiOptDescr::a->String,- uiOptModes::[InputMode], onSet :: Maybe (a -> UIM ()) }+data UIOptButton a = UIOptButton { getUIOpt :: UIOptions->a, setUIOpt :: a->UIOptions->UIOptions,+ uiOptVals :: [a], uiOptPos :: HexVec, uiOptGlyph :: a->Glyph, uiOptDescr :: a->String,+ uiOptModes :: [InputMode], onSet :: Maybe (a -> UIM ()) } -- non-uniform type, so can't use a list... uiOB1 = UIOptButton useFiveColouring (\v o -> o {useFiveColouring=v}) [True,False]- (periphery 0 +^ 2 *^ hu) UseFiveColourButton+ (periphery 0 +^ 3 *^ hu +^ neg hv) UseFiveColourButton (\v -> if v then "Adjacent pieces get different colours" else "Pieces are coloured according to type") [IMPlay, IMReplay, IMEdit] Nothing uiOB2 = UIOptButton showBlocks (\v o -> o {showBlocks=v}) [ShowBlocksBlocking,ShowBlocksAll,ShowBlocksNone] (periphery 0 +^ 2 *^ hu +^ 2 *^ neg hv) ShowBlocksButton- (\v -> case v of+ (\case ShowBlocksBlocking -> "Blocking forces are annotated"- ShowBlocksAll -> "Blocked and blocking forces are annotated"- ShowBlocksNone -> "Blockage annotations disabled")+ ShowBlocksAll -> "Blocked and blocking forces are annotated"+ ShowBlocksNone -> "Blockage annotations disabled") [IMPlay, IMReplay] Nothing uiOB3 = UIOptButton whsButtons (\v o -> o {whsButtons=v}) [Nothing, Just WHSSelected, Just WHSWrench, Just WHSHook] (periphery 3 +^ 3 *^ hv) WhsButtonsButton- (\v -> case v of+ (\case Nothing -> "Click to show (and rebind) keyboard control buttons." Just whs -> "Showing buttons for controlling " ++ case whs of WHSSelected -> "selected piece; right-click to rebind"- WHSWrench -> "wrench; right-click to rebind"- WHSHook -> "hook; right-click to rebind")+ WHSWrench -> "wrench; right-click to rebind"+ WHSHook -> "hook; right-click to rebind") [IMPlay, IMEdit] Nothing uiOB4 = UIOptButton showButtonText (\v o -> o {showButtonText=v}) [True,False]- (periphery 0 +^ 2 *^ hu +^ 2 *^ hv) ShowButtonTextButton+ (periphery 0 +^ 2 *^ hu +^ 3 *^ hv) ShowButtonTextButton (\v -> if v then "Help text enabled" else "Help text disabled")- [IMPlay, IMEdit, IMReplay, IMMeta] Nothing+ [IMPlay, IMEdit, IMReplay, IMMeta, IMInit] Nothing uiOB5 = UIOptButton fullscreen (\v o -> o {fullscreen=v}) [True,False] (periphery 0 +^ 4 *^ hu +^ 2 *^ hv) FullscreenButton- (\v -> if v then "Currently in fullscreen mode; click to toggle" else- "Currently in windowed mode; click to toggle")- [IMPlay, IMEdit, IMReplay, IMMeta] (Just $ const $ initVideo 0 0)+ (\v -> if v then "Fullscreen mode active" else "Windowed mode active")+ [IMPlay, IMEdit, IMReplay, IMMeta, IMInit] (Just $ const $ initVideo 0 0) uiOB6 = UIOptButton useSounds (\v o -> o {useSounds=v}) [True,False]- (periphery 0 +^ 3 *^ hu +^ hv) UseSoundsButton+ (periphery 0 +^ 4 *^ hu +^ hv) UseSoundsButton (\v -> if v then "Sound effects enabled" else "Sound effects disabled") [IMPlay, IMEdit, IMReplay] Nothing@@ -422,20 +432,20 @@ drawUIOptionButton mode uiOB6 #endif drawUIOptionButton im b = when (im `elem` uiOptModes b) $ do- value <- gets $ (getUIOpt b).uiOptions+ value <- gets $ getUIOpt b . uiOptions renderToMain $ mapM_ (\g -> drawAtRel g (uiOptPos b)) [HollowGlyph $ obscure purple, uiOptGlyph b value] describeUIOptionButton :: UIOptButton a -> MaybeT UIM String describeUIOptionButton b = do- value <- gets $ (getUIOpt b).uiOptions+ value <- gets $ getUIOpt b . uiOptions return $ uiOptDescr b value -- XXX: hand-hacking lenses... toggleUIOption (UIOptButton getopt setopt vals _ _ _ _ monSet) = do- value <- gets $ getopt.uiOptions- let value' = head $ drop (1 + (fromMaybe 0 $ elemIndex value vals)) $ cycle vals+ value <- gets $ getopt . uiOptions+ let value' = cycle vals !! max 0 (1 + fromMaybe 0 (elemIndex value vals)) modifyUIOptions $ setopt value' case monSet of- Nothing -> return ()+ Nothing -> return () Just onSet -> onSet value' readUIConfigFile :: UIM ()@@ -444,7 +454,7 @@ mOpts <- liftIO $ readReadFile path case mOpts of Just opts -> modify $ \s -> s {uiOptions = opts}- Nothing -> return ()+ Nothing -> return () writeUIConfigFile :: UIM () writeUIConfigFile = do path <- liftIO $ confFilePath "SDLUI.conf"@@ -458,7 +468,7 @@ mbdgs <- liftIO $ readReadFile path case mbdgs of Just bdgs -> modify $ \s -> s {uiKeyBindings = bdgs}- Nothing -> return ()+ Nothing -> return () writeBindings :: UIM () writeBindings = do path <- liftIO $ confFilePath "bindings"@@ -468,7 +478,7 @@ getBindings :: InputMode -> UIM [(Char, Command)] getBindings mode = do- uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings+ uibdgs <- gets (Map.findWithDefault [] mode . uiKeyBindings) return $ uibdgs ++ bindings mode paintTiles :: [ Maybe Tile ]@@ -500,7 +510,7 @@ do let gl = case paintTiles!!i of Nothing -> HollowInnerGlyph $ dim purple- Just t -> TileGlyph t $ dim purple+ Just t -> TileGlyph t $ dim purple drawAtRel gl pos when selected $ drawAtRel cursorGlyph pos | i <- take (length paintTiles) [0..]@@ -515,21 +525,21 @@ messageLineCentre = ((maxlocksize+1)`div`2)*^hw +^ ((maxlocksize+1+1)`div`2)*^neg hv titlePos = (maxlocksize+1)*^hv +^ ((maxlocksize+1)`div`2)*^hu -screenWidthHexes,screenHeightHexes::Int+screenWidthHexes,screenHeightHexes :: Int screenWidthHexes = 32-screenHeightHexes = 25+screenHeightHexes = 26 getGeom :: UIM (SVec, Int) getGeom = do h <- gets scrHeight w <- gets scrWidth let scrCentre = SVec (w`div`2) (h`div`2) -- |size is the greatest integer such that- -- and [2*size*screenWidthHexes <= width- -- , 3*ysize size*screenHeightHexes <= height]+ -- and [2*size*screenWidthHexes < width+ -- , 3*ysize size*screenHeightHexes < height] -- where ysize size = round $ fi size / sqrt 3 -- Minimum allowed size is 2 (get segfaults on SDL_FreeSurface with 1).- let size = max 2 $ minimum [ w`div`(2*screenWidthHexes)- , floor $ sqrt 3 * (0.5 + (fi $ h`div`(3*screenHeightHexes)))]+ let size = max 2 $ minimum [ (w-1)`div`(2*screenWidthHexes)+ , floor $ sqrt 3 * (0.5 + fi ((h-1)`div`(3*screenHeightHexes)))] return (scrCentre, size) data DrawArgs = DrawArgs [PieceIdx] Bool [Alert] GameState UIOptions@@ -551,14 +561,14 @@ lastAnimFrame <- gets animFrame now <- liftIO getTicks- anim <- maybe False (<now) <$> gets nextAnimFrameAt+ anim <- gets (maybe False (<now) . nextAnimFrameAt) when anim $ modify $ \ds -> ds { animFrame = lastAnimFrame+1, nextAnimFrameAt = Nothing } animFrameToDraw <- gets animFrame- void $ if (lastArgs == Just args && lastAnimFrame == animFrameToDraw)+ void $ if lastArgs == Just args && lastAnimFrame == animFrameToDraw then do vidSurf <- liftIO getVideoSurface- gsSurf <- liftM fromJust $ gets gsSurface+ gsSurf <- gets (fromJust . gsSurface) liftIO $ blitSurface gsSurf Nothing vidSurf Nothing else do modify $ \ds -> ds { lastDrawArgs = Just args }@@ -571,9 +581,9 @@ splitAlerts frameAs (a:as) = splitAlerts (a:frameAs) as splitAlerts frameAs [] = [(frameAs,st,False)]- isGlobalAlert (AlertAppliedForce _) = False+ isGlobalAlert (AlertAppliedForce _) = False isGlobalAlert (AlertIntermediateState _) = False- isGlobalAlert _ = True+ isGlobalAlert _ = True let animAlertedStates = nub $ let ass = splitAlerts [] transitoryAlerts in if last ass == ([],st,False) then ass else ass ++ [([],st,False)]@@ -581,10 +591,9 @@ let (drawAlerts',drawSt,isIntermediate) = animAlertedStates !! animFrameToDraw let drawAlerts = drawAlerts' ++ globalAlerts -- let drawAlerts = takeWhile (/= AlertIntermediateState drawSt) alerts- nextIsSet <- isJust <$> gets nextAnimFrameAt+ nextIsSet <- gets (isJust . nextAnimFrameAt) when (not nextIsSet && frames > animFrameToDraw+1) $ do- time <- (if isIntermediate then uiAnimTime else shortUiAnimTime) <$>- gets uiOptions+ time <- gets ((if isIntermediate then uiAnimTime else shortUiAnimTime) . uiOptions) modify $ \ds -> ds { nextAnimFrameAt = Just $ now + time } let board = stateBoard drawSt@@ -594,9 +603,9 @@ then boardColouring drawSt coloured lastCol else pieceTypeColouring drawSt coloured modify $ \ds -> ds { dispLastCol = colouring }- gsSurf <- liftM fromJust $ gets gsSurface+ gsSurf <- gets (fromJust . gsSurface) renderToMainWithSurf gsSurf $ do- let tileGlyphs = fmap (ownedTileGlyph colouring highlight) board+ let tileGlyphs = ownedTileGlyph colouring highlight <$> board applyAlert (AlertAppliedForce f@(Torque idx tdir)) = let poss = case getpp drawSt idx of@@ -635,8 +644,8 @@ displaceSpring _ _ = id displaceSprings =- (flip (foldr $ displaceSpring True) $ springsRootAtIdx drawSt idx) .- (flip (foldr $ displaceSpring False) $ springsEndAtIdx drawSt idx)+ flip (foldr $ displaceSpring True) (springsRootAtIdx drawSt idx) .+ flip (foldr $ displaceSpring False) (springsEndAtIdx drawSt idx) applyAlert _ = id applyAlerts = flip (foldr applyAlert) drawAlerts@@ -647,9 +656,9 @@ ] when (showBlocks uiopts /= ShowBlocksNone) $ sequence_- $ [ drawBlocked drawSt colouring False force- | AlertBlockedForce force <- drawAlerts- , showBlocks uiopts == ShowBlocksAll ]+ $ [drawBlocked drawSt colouring False force |+ showBlocks uiopts == ShowBlocksAll,+ AlertBlockedForce force <- drawAlerts] ++ [ drawBlocked drawSt colouring True force | AlertBlockingForce force <- drawAlerts ] -- ++ [ drawBlocked drawSt colouring True force |@@ -676,9 +685,11 @@ alertSound (AlertDivertedWrench _) = Just "wrenchscrape" alertSound (AlertAppliedForce (Torque idx _)) | isPivot.placedPiece.getpp st $ idx = Just "pivot"+ | isTool.placedPiece.getpp st $ idx = Just "toolmove" alertSound (AlertAppliedForce (Push idx dir)) | isBall.placedPiece.getpp st $ idx = Just "ballmove"- alertSound (AlertAppliedForce (Push idx dir)) = do+ | isTool.placedPiece.getpp st $ idx = Just "toolmove"+ | otherwise = do (align,newLen) <- listToMaybe [(align,newLen) | c@(Connection (startIdx,_) (endIdx,_) (Spring outDir natLen)) <- connections st , let align = (if outDir == dir then 1 else if outDir == neg dir then -1 else 0)@@ -704,13 +715,13 @@ drawMiniLock :: Lock -> HexVec -> UIM () drawMiniLock lock v = do- surface <- Map.lookup lock <$> gets miniLocks >>= maybe new return+ surface <- gets miniLocks >>= maybe new return . Map.lookup lock renderToMain $ blitAt surface v where miniLocksize = 3 new = do (_, size) <- getGeom- let minisize = size `div` (ceiling $ lockSize lock % miniLocksize)+ let minisize = size `div` ceiling (lockSize lock % miniLocksize) let width = size*2*(miniLocksize*2+1) let height = ceiling $ fi size * sqrt 3 * fi (miniLocksize*2+1+1) surf <- liftIO $ createRGBSurface [] width height 16 0 0 0 0@@ -722,7 +733,7 @@ then boardColouring st coloured Map.empty else pieceTypeColouring st coloured draw = sequence_ [ drawAt glyph pos |- (pos,glyph) <- Map.toList $ fmap (ownedTileGlyph colouring []) $ stateBoard st ]+ (pos,glyph) <- Map.toList $ ownedTileGlyph colouring [] <$> stateBoard st ] liftIO $ runRenderM draw emptyCachedGlyphs $ RenderContext surf Nothing (PHS zero) (SVec (width`div`2) (height`div`2)) zero minisize Nothing clearOldMiniLocks@@ -740,7 +751,7 @@ getBindingStr :: InputMode -> UIM (Command -> String) getBindingStr mode = do setting <- gets settingBinding- uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings+ uibdgs <- gets (Map.findWithDefault [] mode . uiKeyBindings) return (\cmd -> if Just cmd == setting then "??" else maybe "" showKey $ findBinding (uibdgs ++ bindings mode) cmd)@@ -749,7 +760,7 @@ drawButtons mode = do buttons <- getButtons mode bindingStr <- getBindingStr mode- showBT <- showButtonText <$> gets uiOptions+ showBT <- gets (showButtonText . uiOptions) smallFont <- gets dispFontSmall renderToMain $ sequence_ $ concat [ [ do drawAtRel (ButtonGlyph col) v@@ -758,7 +769,7 @@ when showBT $ withFont smallFont $ recentreAt v $ rescaleRender (1/4) $ sequence_ [ renderStrColAtLeft white s dv | (s,dv) <- helps ]- | (i,(v,bdg,helps)) <- enumerate $ map (\b->(buttonPos b, bindingStr $ buttonCmd b, buttonHelp b)) $ buttonGroup+ | (i,(v,bdg,helps)) <- enumerate $ map (\b->(buttonPos b, bindingStr $ buttonCmd b, buttonHelp b)) buttonGroup , let col = dim $ colourWheel (base+inc*i) ] | (buttonGroup,(base,inc)) <- buttons ]@@ -774,16 +785,21 @@ -- current screen res rather than current window size (quitSubSystem [InitVideo] >> initSubSystem [InitVideo] >> initMisc) - fs <- fullscreen <$> gets uiOptions+ fs <- gets (fullscreen . uiOptions) liftIO $ do- (w',h') <- if (fs || (w,h)/=(0,0)) then return (w,h) else do+ (w',h') <- if fs || (w,h)/=(0,0) then return (w,h) else+#ifdef APPLE -- use smaller dimensions than the screen's, to work around a bug -- seen on mac, whereby a resizable window created with -- (w,h)=(0,0), or even with the (w,h) given by getDimensions -- after creating such a window, is reported to be larger than it -- is.- (w',h') <- getDimensions- return $ (4*w'`div`5,4*h'`div`5)+ do+ (w',h') <- getDimensions+ return (4*w'`div`5,4*h'`div`5)+#else+ getDimensions+#endif setVideoMode w' h' 0 $ if fs then [Fullscreen] else [Resizable] (w',h') <- liftIO getDimensions@@ -800,10 +816,10 @@ smallFont <- liftIO $ TTF.tryOpenFont fontpath (2*size`div`3) modify $ \ds -> ds { dispFont = font, dispFontSmall = smallFont } - useBG <- gets $ useBackground.uiOptions+ useBG <- gets $ useBackground . uiOptions mbg <- if useBG then do bgsurf <- liftIO $ createRGBSurface [] w' h' 16 0 0 0 0- renderToMainWithSurf bgsurf $ drawBasicBG $ 2*(max screenWidthHexes screenHeightHexes)`div`3+ renderToMainWithSurf bgsurf $ drawBasicBG $ 2*max screenWidthHexes screenHeightHexes`div`3 return $ Just bgsurf else return Nothing modify $ \ds -> ds { bgSurface = mbg }@@ -833,7 +849,7 @@ liftIO $ allocateChannels 16 let seqWhileJust (m:ms) = m >>= \ret -> case ret of Nothing -> return []- Just a -> (a:) <$> seqWhileJust ms+ Just a -> (a:) <$> seqWhileJust ms soundsdir <- liftIO $ getDataPath "sounds" sounds <- sequence [ do chunks <- liftIO $ seqWhileJust@@ -846,12 +862,13 @@ "-" ++ (if n < 10 then ('0':) else id) (show n) ++ ext | ext <- [".ogg", ".wav"] ] , let vol = case sound of- "pivot" -> 64+ "pivot" -> 64 "wrenchscrape" -> 64- _ -> 128+ "toolmove" -> 64+ _ -> 128 ] return (sound,chunks)- | sound <- ["hookblocked","hookarmblocked","wrenchblocked","wrenchscrape","pivot","unlocked","ballmove"]+ | sound <- ["hookblocked","hookarmblocked","wrenchblocked","wrenchscrape","pivot","unlocked","ballmove","toolmove"] ++ ["spring" ++ d ++ show l | d <- ["extend","contract"], l <- [1..12]] ] -- liftIO $ print sounds modify $ \s -> s { sounds = Map.fromList sounds }@@ -869,24 +886,26 @@ drawMsgLine = void.runMaybeT $ do (col,str) <- msum- [ ((,) dimWhiteCol) <$> MaybeT (gets hoverStr)- , MaybeT $ gets message+ [ MaybeT $ gets message+ , (dimWhiteCol,) <$> MaybeT (gets hoverStr) ] lift $ do renderToMain $ blankRow messageLineCentre smallFont <- gets dispFontSmall renderToMain $ (if length str > screenWidthHexes * 3 then withFont smallFont else id) $- renderStrColAt col str messageLineCentre+ renderStrColAtCentre col str messageLineCentre setMsgLineNoRefresh col str = do modify $ \s -> s { message = Just (col,str) }- unless (null str) $ modify $ \s -> s { hoverStr = Nothing } drawMsgLine setMsgLine col str = setMsgLineNoRefresh col str >> refresh -drawTitle (Just title) = renderToMain $ renderStrColAt messageCol title titlePos-drawTitle Nothing = return ()+clearMsg :: UIM ()+clearMsg = modify $ \s -> s { message = Nothing }++drawTitle (Just title) = renderToMain $ renderStrColAtCentre messageCol title titlePos+drawTitle Nothing = return () say = setMsgLine messageCol sayError = setMsgLine errorCol
SDLUIMInstance.hs view
@@ -8,48 +8,50 @@ -- 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 CPP #-}-{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} module SDLUIMInstance () where -import Graphics.UI.SDL hiding (flip, name)-import qualified Graphics.UI.SDL as SDL-import qualified Graphics.UI.SDL.TTF as TTF-import Control.Concurrent.STM-import Control.Applicative-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 Control.Applicative+import Control.Concurrent (threadDelay)+import Control.Concurrent.STM+import Control.Monad.State+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Data.Array+import Data.Foldable (for_)+import Data.Function (on)+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import qualified Data.Vector as Vector+import Data.Word+import Graphics.UI.SDL hiding (flip, name)+import qualified Graphics.UI.SDL as SDL+import qualified Graphics.UI.SDL.TTF as TTF+import Safe (maximumBound)+import System.Timeout --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 SDLGlyph-import SDLUI+import Cache+import Command+import Database+import GameStateTypes+import Hex+import InputMode+import KeyBindings+import Lock+import MainState+import Metagame+import Mundanities+import Protocol+import SDLGlyph+import SDLRender+import SDLUI+import ServerAddr+import Util instance UIMonad (StateT UIState IO) where runUI m = evalStateT m nullUIState@@ -57,204 +59,20 @@ lift $ clearButtons >> clearSelectables s <- get let mode = ms2im s- lift $ waitFrame+ lift waitFrame drawMainState' s lift . drawTitle =<< getTitle lift $ do drawButtons mode drawUIOptionButtons mode- gets needHoverUpdate >>? do- updateHoverStr mode- modify (\ds -> ds {needHoverUpdate=False})+ updateHoverStr mode drawMsgLine- drawShortMouseHelp mode+ drawShortMouseHelp mode s refresh- where- drawMainState' (PlayState { psCurrentState=st, psLastAlerts=alerts,- wrenchSelected=wsel, psIsTut=isTut, psSolved=solved }) = 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- lb <- isJust <$> gets leftButtonDown- rb <- isJust <$> gets leftButtonDown- when isTut $ do- centre <- gets dispCentre- sequence_- [ registerSelectable (pos -^ centre) 0 $- if isWrench p then SelToolWrench else SelToolHook- | PlacedPiece pos p <- Vector.toList $ placedPieces st- , not $ lb || rb- , isTool p- ]- registerUndoButtons canUndo canRedo- registerButton (periphery 0) CmdOpen (if solved then 2 else 0) $- [("open", hu+^neg hw)] ++ if solved && isTut- then [("Click-->",9*^neg hu)]- else []- 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 { esGameState=st, esGameStateStack=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, (-4)*^hv +^ hw),- (isHook, "hook", CmdTile $ HookTile, (-3)*^hv +^ hw) ] ]- drawPaintButtons- drawMainState' (MetaState {curServer=saddr, undeclareds=undecls,- cacheOnly=cOnly, curAuth=auth, codenameStack=names,- randomCodenames=rnamestvar, retiredLocks=mretired, curLockPath=path,- curLock=mlock, listOffset=offset, asyncCount=count}) = 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 purple- (saddrStr saddr ++ if cOnly then " (offline mode)" 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- pending <- ((>0) <$>) $ liftIO $ atomically $ readTVar count- lift $ do- lift $ do- unless ((fresh && not pending) || cOnly) $ do- smallFont <- gets dispFontSmall- let str = if pending then "(response pending)" else "(updating)"- renderToMain $ withFont smallFont $- renderStrColBelow (opaquify $ dim errorCol) str $ codenamePos- maybe (return ()) (setMsgLineNoRefresh errorCol) err- when (fresh && (isNothing ourName || isNothing muirc || home)) $- let reg = isNothing muirc || isJust ourName- in registerButton (codenamePos +^ 2*^hu)- (if reg then CmdRegister $ isJust ourName 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)]- when (isJust ourName) $- 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,selUInfo),(selUInfo,ourUInfo)]- let posLeft = scoresPos +^ hw +^ neg hu- let posRight = posLeft +^ 3*^hu- size <- snd <$> (lift.lift) getGeom- lift $ do- lift.renderToMain $ renderStrColAbove (brightish white) "ESTEEM" $ scoresPos- lift $ sequence_ [ registerSelectable (scoresPos+^v) 0 SelRelScore | v <- [hv, hv+^hu] ]- 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- | (maybe False winsPoint) 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- | (maybe False winsPoint) accessed = dim $ scoreColour $ 3- | otherwise = obscure $ scoreColour $ -3 ]- (posScore,negScore) <- MaybeT $ (snd<$>) <$> getRelScoreDetails sel- lift.lift $ sequence_- [ do- renderToMain $ renderStrColAt (scoreColour score) (sign:show (abs score)) pos- registerSelectable pos 0 SelRelScoreComponent- | (sign,score,pos) <-- [ ('-',-negScore,posLeft+^neg hv+^hw)- , ('+',posScore,posRight+^neg hv+^hw) ] ]-+ clearMessage = clearMsg drawMessage = say drawPrompt full s = say $ s ++ (if full then "" else "_")- endPrompt = say ""+ endPrompt = clearMsg drawError = sayError reportAlerts = playAlertSounds@@ -276,12 +94,12 @@ setUIBinding mode cmd ch = modify $ \s -> s { uiKeyBindings =- Map.insertWith (\[bdg] -> \bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs)+ 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+ initUI = (isJust <$>) . runMaybeT $ do catchIOErrorMT $ SDL.init #ifdef SOUND [InitVideo,InitAudio]@@ -292,21 +110,20 @@ lift $ do readUIConfigFile initVideo 0 0- liftIO $ initMisc+ liftIO initMisc w <- gets scrWidth h <- gets scrHeight liftIO $ warpMouse (fi $ w`div`2) (fi $ h`div`2)- renderToMain $ erase+ renderToMain erase initAudio readBindings- ) where- catchIOErrorMT m = MaybeT $ liftIO $ catchIO (m >> return (Just ())) (\_ -> return Nothing)+ catchIOErrorMT m = MaybeT . liftIO . ignoreIOErrAlt $ m >> return (Just ()) endUI = do writeUIConfigFile writeBindings- liftIO $ quit+ liftIO quit unblockInput = return $ pushEvent VideoExpose suspend = return ()@@ -314,13 +131,13 @@ impatience ticks = do liftIO $ threadDelay 50000- if (ticks>20) then do+ if ticks>20 then do let pos = serverWaitPos smallFont <- gets dispFontSmall renderToMain $ do- mapM (drawAtRel (FilledHexGlyph $ bright black)) [ pos +^ i*^hu | i <- [0..3] ]+ mapM_ (drawAtRel (FilledHexGlyph $ bright black)) [ pos +^ i*^hu | i <- [0..3] ] withFont smallFont $- renderStrColAtLeft errorCol ("waiting..."++replicate ((ticks`div`5)`mod`3) '.') $ pos+ renderStrColAtLeft errorCol ("waiting..."++replicate ((ticks`div`5)`mod`3) '.') pos clearButtons registerButton (pos +^ neg hv) CmdQuit 0 [("abort",hu+^neg hw)] drawButtons IMImpatience@@ -336,17 +153,16 @@ liftIO $ warpMouse (fi x) (fi y) lbp <- gets leftButtonDown rbp <- gets rightButtonDown- let [lbp',rbp'] = fmap (fmap (\_ -> (pos-^centre))) [lbp,rbp]+ let [lbp',rbp'] = ((const $ pos -^ centre) <$>) <$> [lbp,rbp] modify $ \s -> s {leftButtonDown = lbp', rightButtonDown = rbp'} getUIMousePos = do centre <- gets dispCentre- (Just.(+^centre).fst) <$> gets mousePos+ gets ((Just.(+^centre).fst) . mousePos) setYNButtons = do clearButtons- registerButton (periphery 5 +^ hw) (CmdInputChar 'Y') 2 []- registerButton (periphery 5 +^ neg hv) (CmdInputChar 'N') 0 []+ registerButton (periphery 5 +^ hw +^ neg hv) (CmdInputChar 'Y') 2 [("confirm",hu+^neg hw)] drawButtons IMTextInput refresh @@ -363,14 +179,15 @@ newUIState <- get return (cmds,uistatesMayVisiblyDiffer oldUIState newUIState) now <- liftIO getTicks- animFrameReady <- maybe False (<now) <$> gets nextAnimFrameAt- return $ cmds ++ if uiChanged || animFrameReady then [CmdRefresh] else []+ animFrameReady <- gets (maybe False (<now) . nextAnimFrameAt)+ unless (null cmds) clearMsg+ return $ cmds ++ [CmdRefresh | uiChanged || animFrameReady] 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)+ 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_@@ -378,7 +195,7 @@ | (pti,pt) <- zip [0..] paintTiles , cmd <- cmds , (isNothing pt && cmd == CmdDelete) ||- (isJust $ do+ isJust (do pt' <- pt CmdTile t <- Just cmd guard $ ((==)`on`tileType) t pt') ]@@ -396,10 +213,10 @@ when (ch /= '\ESC') $ setUIBinding mode (fromJust setting) ch return [] else do- uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings+ uibdgs <- gets (Map.findWithDefault [] mode . uiKeyBindings) let mCmd = lookup ch $ uibdgs ++ bindings mode return $ maybeToList mCmd- processEvent (MouseMotion {}) = do+ processEvent MouseMotion {} = do (oldMPos,_) <- gets mousePos (pos@(mPos,_),(sx,sy,sz)) <- getMousePos updateMousePos mode pos@@ -410,7 +227,7 @@ 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)]+ 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@@ -420,8 +237,8 @@ Nothing -> if mPos /= oldMPos then do pti <- getEffPaintTileIndex- return $ [ CmdMoveTo $ mPos +^ centre ] ++- (if isJust lbp then [ CmdPaintFromTo (paintTiles!!pti) (oldMPos+^centre) (mPos+^centre) ] else [])+ return $ CmdMoveTo (mPos +^ centre) :+ ([CmdPaintFromTo (paintTiles!!pti) (oldMPos+^centre) (mPos+^centre) | isJust lbp]) else return [] IMPlay -> return $ maybeToList $ msum $ map drag [lbp, rbp] _ -> return []@@ -434,11 +251,11 @@ processEvent (MouseButtonDown _ _ ButtonLeft) = do pos@(mPos,central) <- gets mousePos modify $ \s -> s { leftButtonDown = Just mPos }- rb <- isJust <$> gets rightButtonDown+ rb <- gets (isJust . rightButtonDown) mcmd <- cmdAtMousePos pos mode (Just False) let hotspotAction = listToMaybe $ map (\cmd -> return [cmd]) (maybeToList mcmd)- ++ [ (modify $ \s -> s {paintTileIndex = i}) >> return []+ ++ [ modify (\s -> s {paintTileIndex = i}) >> return [] | i <- take (length paintTiles) [0..] , mPos == paintButtonStart +^ i*^hv ] ++ [ toggleUIOption uiOB1 >> updateHoverStr mode >> return []@@ -461,10 +278,10 @@ else flip fromMaybe hotspotAction $ case mode of IMEdit -> do pti <- getEffPaintTileIndex- return $ [ drawCmd (paintTiles!!pti) False ]+ return [ drawCmd (paintTiles!!pti) False ] IMPlay -> do centre <- gets dispCentre- return $ [ CmdManipulateToolAt $ mPos +^ centre ]+ return [ CmdManipulateToolAt $ mPos +^ centre ] _ -> return [] processEvent (MouseButtonUp _ _ ButtonLeft) = do modify $ \s -> s { leftButtonDown = Nothing }@@ -472,7 +289,7 @@ processEvent (MouseButtonDown _ _ ButtonRight) = do pos@(mPos,_) <- gets mousePos modify $ \s -> s { rightButtonDown = Just mPos }- lb <- isJust <$> gets leftButtonDown+ lb <- gets (isJust . leftButtonDown) if lb then return [ CmdWait ] else (fromMaybe [] <$>) $ runMaybeT $ msum@@ -486,17 +303,17 @@ return [cmd] , case mode of IMPlay -> return [ CmdClear, CmdWait ]- _ -> return [ CmdClear, CmdSelect ] ]+ _ -> return [ CmdClear, CmdSelect ] ] processEvent (MouseButtonUp _ _ ButtonRight) = do modify $ \s -> s { rightButtonDown = Nothing }- return [ CmdUnselect ]+ return [ CmdUnselect | mode == IMEdit ] 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 []+ rb <- gets (isJust . rightButtonDown)+ return $ [CmdDelete | rb] processEvent (MouseButtonUp _ _ ButtonMiddle) = do modify $ \s -> s { middleButtonDown = Nothing } return []@@ -509,30 +326,30 @@ processEvent _ = return [] doWheel dw = do- rb <- isJust <$> gets rightButtonDown- mb <- isJust <$> gets middleButtonDown+ rb <- gets (isJust . rightButtonDown)+ mb <- gets (isJust . middleButtonDown) if ((rb || mb || mode == IMReplay) && mode /= IMEdit) || (mb && mode == IMEdit) then return [ if dw == 1 then CmdRedo else CmdUndo ] else if mode /= IMEdit || rb then return [ CmdRotate WHSSelected dw ] else do- modify $ \s -> s { paintTileIndex = (paintTileIndex s + dw) `mod` (length paintTiles) }+ modify $ \s -> s { paintTileIndex = (paintTileIndex s + dw) `mod` length paintTiles } return [] - drawCmd mt True = CmdPaint mt+ drawCmd mt True = CmdPaint mt drawCmd (Just t) False = CmdTile t- drawCmd Nothing _ = CmdDelete+ 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 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) $+ 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@@ -546,10 +363,7 @@ 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;"]+ let extraHelpStrs = (["Mouse commands:", "Hover over a button to see keys, right-click to rebind;"] ++ 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;",@@ -560,8 +374,8 @@ "Scroll wheel to rotate selected piece; scroll wheel while held down to undo/redo."] IMReplay -> ["Scroll wheel for undo/redo."] IMMeta -> ["Left-clicking on something does most obvious thing;"- , "Right-clicking does second-most obvious thing."]]- ++ case mode of+ , "Right-clicking does second-most obvious thing."])+ : case mode of IMMeta -> [[ "Basic game instructions:" , "Choose [C]odename, then [R]egister it;"@@ -570,45 +384,55 @@ , "you can then [D]eclare your solutions." , "Make other players green by solving their locks and not letting them solve yours."]] _ -> []- renderStrColAt cyan "Keybindings:" $ (screenHeightHexes`div`4)*^(hv+^neg hw)- let keybindingsHeight = screenHeightHexes - (3 + length extraHelpStrs + sum (map 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 (if firstLine then cyan else messageCol) str+ when False $ do+ renderStrColAtCentre cyan "Keybindings:" $ (screenHeightHexes`div`4)*^(hv+^neg hw)+ let keybindingsHeight = screenHeightHexes - (3 + length extraHelpStrs + sum (map length extraHelpStrs))+ bdgWidth = (screenWidthHexes-6) `div` 3+ showKeys chs = intercalate "/" (map showKeyFriendly chs)+ 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_ [ renderStrColAtCentre (if firstLine then cyan else messageCol) str $ (screenHeightHexes`div`4 - y`div`2)*^(hv+^neg hw) +^ hw +^ (y`mod`2)*^hw- | ((str,firstLine),y) <- (intercalate [("",False)] $ (map (`zip` (True:repeat False)) extraHelpStrs)) `zip` [(keybindingsHeight+1)..] ]+ | ((str,firstLine),y) <- intercalate [("",False)] (map (`zip`+ (True:repeat False)) extraHelpStrs) `zip`+ --[(keybindingsHeight+1)..]+ [((screenHeightHexes - sum (length <$> extraHelpStrs)) `div` 2)..]+ ] refresh return True+ showHelp IMInit HelpPageGame = do+ renderToMain $ drawBasicHelpPage ("INTRICACY",red) (initiationHelpText,purple)+ return True showHelp IMMeta HelpPageGame = do renderToMain $ drawBasicHelpPage ("INTRICACY",red) (metagameHelpText,purple) return True showHelp IMMeta (HelpPageInitiated n) = do- renderToMain $ drawBasicHelpPage ("Initiation complete",purple) (initiationHelpText n,red)+ renderToMain $ drawBasicHelpPage ("Initiation complete",purple) (initiationCompleteText n,red) return True showHelp IMEdit HelpPageFirstEdit = do renderToMain $ drawBasicHelpPage ("Your first lock:",purple) (firstEditHelpText,green) return True showHelp _ _ = return False - onNewMode mode = modify (\ds -> ds{needHoverUpdate=True}) >> say ""+ onNewMode mode = clearMsg withNoBG m = do bg <- gets bgSurface@@ -617,35 +441,251 @@ isNothing <$> gets bgSurface >>? modify (\uiState -> uiState{bgSurface=bg}) +drawMainState' :: MainState -> MainStateT UIM ()+drawMainState' PlayState { psCurrentState=st, psLastAlerts=alerts,+ wrenchSelected=wsel, psTutLevel=tutLevel, psSolved=solved } = do+ canUndo <- gets (null . psGameStateMoveStack)+ canRedo <- gets (null . psUndoneStack)+ let isTut = isJust tutLevel+ lift $ do+ let selTools = [ idx |+ (idx, PlacedPiece pos p) <- enumVec $ placedPieces st+ , (wsel && isWrench p) || (not wsel && isHook p) ]+ drawMainGameState selTools False alerts st+ lb <- gets (isJust . leftButtonDown)+ rb <- gets (isJust . leftButtonDown)+ when isTut $ do+ centre <- gets dispCentre+ sequence_+ [ registerSelectable (pos -^ centre) 0 $+ if isWrench p then SelToolWrench else SelToolHook+ | not $ lb || rb+ , PlacedPiece pos p <- Vector.toList $ placedPieces st+ , isTool p]+ unless (noUndoTutLevel tutLevel) $ do+ registerUndoButtons canUndo canRedo+ registerButtonGroup markButtonGroup+ registerButton (periphery 0) CmdOpen (if solved then 2 else 0) $+ ("open", hu+^neg hw) : [("Press-->",9*^neg hu) | solved && isTut]+drawMainState' ReplayState { rsCurrentState=st, rsLastAlerts=alerts } = do+ canUndo <- gets (null . rsGameStateMoveStack)+ canRedo <- gets (null . rsMoveStack)+ lift $ do+ drawMainGameState [] False alerts st+ registerUndoButtons canUndo canRedo+ renderToMain $ drawCursorAt Nothing+drawMainState' EditState { esGameState=st, esGameStateStack=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_+ [ unless (any (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, (-4)*^hv +^ hw),+ (isHook, "hook", CmdTile HookTile, (-3)*^hv +^ hw) ] ]+ drawPaintButtons+drawMainState' InitState {initLocks=initLocks, tutProgress=TutProgress{tutSolved=tutSolved}} = lift $ do+ renderToMain (erase >> drawCursorAt Nothing)+ renderToMain . renderStrColAtCentre white "I N T R I C A C Y" $ 3 *^ (hv +^ neg hw)+ drawInitLock zero+ mapM_ drawInitLock $ Map.keys accessible+ registerButton (tutPos +^ 3 *^ neg hu +^ hv) (CmdSolveInit Nothing) 2+ [("solve",hu+^neg hw),("lock",hu+^neg hv)]+ where+ accessible = accessibleInitLocks tutSolved initLocks+ tutPos = maximumBound 0 (hx <$> Map.keys accessible) *^ neg hu+ name v | v == zero = "TUT"+ | otherwise = maybe "???" initLockName $ Map.lookup v accessible+ solved v | v == zero = tutSolved+ | otherwise = Just True == (initLockSolved <$> Map.lookup v accessible)+ isLast v | v == zero = False+ | otherwise = Just True == (isLastInitLock <$> Map.lookup v accessible)+ drawInitLock v = do+ let pos = tutPos +^ 2 *^ v+ drawNameCol (name v) pos $ if solved v then brightish green else brightish yellow+ renderToMain $ sequence_+ [ (if open then PathGlyph h $ brightish white+ else GateGlyph h $ (if inbounds then dim else bright) white)+ `drawAtRel` (pos +^ h)+ | h <- hexDirs+ , let v' = v +^ h+ , let inbounds = abs (hy v') < 2 && hx v' >= 0 && hz v' <= 0+ , let acc = v' `Map.member` accessible || v' == zero+ , not acc || h `elem` [hu, neg hw, neg hv]+ , let open = inbounds && (solved v || solved v') && (acc || (isLast v && h == hu)) ]+ registerSelectable pos 0 $ if v == zero then SelTut (solved v) else SelInitLock v (solved v)+drawMainState' MetaState {curServer=saddr, undeclareds=undecls,+ cacheOnly=cOnly, curAuth=auth, codenameStack=names,+ randomCodenames=rnamestvar, retiredLocks=mretired, curLockPath=path,+ curLock=mlock, asyncCount=count} = do+ modify $ \ms -> ms { listOffsetMax = True }+ 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 purple+ (saddrStr saddr ++ if cOnly then " (offline mode)" else "")+ $ serverPos +^ hu -drawShortMouseHelp mode = do+ 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+ pending <- ((>0) <$>) $ liftIO $ readTVarIO count+ lift $ do+ lift $ do+ unless ((fresh && not pending) || cOnly) $ do+ smallFont <- gets dispFontSmall+ let str = if pending then "(response pending)" else "(updating)"+ renderToMain $ withFont smallFont $+ renderStrColBelow (opaquify $ dim errorCol) str codenamePos+ maybe (return ()) (setMsgLineNoRefresh errorCol) err+ when (fresh && (isNothing ourName || isNothing muirc || home)) $+ let reg = isNothing muirc || isJust ourName+ in registerButton (codenamePos +^ 2*^hu)+ (if reg then CmdRegister $ isJust ourName 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)]+ when (isJust ourName) $+ 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)+ (`drawMiniLock` 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 $ unless (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 $ readTVarIO 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,selUInfo),(selUInfo,ourUInfo)]+ let posLeft = scoresPos +^ hw +^ neg hu+ let posRight = posLeft +^ 3*^hu+ size <- snd <$> (lift.lift) getGeom+ lift $ do+ lift.renderToMain $ renderStrColAbove (brightish white) "ESTEEM" scoresPos+ lift $ sequence_ [ registerSelectable (scoresPos+^v) 0 SelRelScore | v <- [hv, hv+^hu] ]+ 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 = head accesses !! i+ , let col+ | accessed == Just AccessedPub = dim pubColour+ | maybe False winsPoint 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+ | maybe False winsPoint accessed = dim $ scoreColour 3+ | otherwise = obscure $ scoreColour $ -3 ]+ (posScore,negScore) <- MaybeT $ (snd<$>) <$> getRelScoreDetails sel+ lift.lift $ sequence_+ [ do+ renderToMain $ renderStrColAt (scoreColour score) (sign:show (abs score)) pos+ registerSelectable pos 0 SelRelScoreComponent+ | (sign,score,pos) <-+ [ ('-',-negScore,posLeft+^neg hv+^hw)+ , ('+',posScore,posRight+^neg hv+^hw) ] ]+++drawShortMouseHelp mode s = do mwhs <- gets $ whsButtons.uiOptions- showBT <- showButtonText <$> gets uiOptions+ showBT <- gets (showButtonText . uiOptions) when (showBT && isNothing mwhs) $ do- let helps = shortMouseHelp mode+ let helps = shortMouseHelp mode s smallFont <- gets dispFontSmall renderToMain $ withFont smallFont $ sequence_- [ renderStrColAtLeft (dim cyan) help+ [ renderStrColAtLeft (dim white) help (periphery 3 +^ neg hu +^ (2-n)*^hv ) | (n,help) <- zip [0..] helps ] where- shortMouseHelp IMPlay =+ shortMouseHelp IMPlay PlayState { psTutLevel = tutLevel } = [ "LMB: select/move tool"- , "LMB+drag: move tool"- , "Wheel: turn hook"- , "RMB: wait a turn"- , "RMB+Wheel: undo/redo"- ]- shortMouseHelp IMEdit =+ , "LMB+drag: move tool" ] +++ [ "Wheel: turn hook"+ | not $ wrenchOnlyTutLevel tutLevel ] +++ [ "RMB+Wheel: undo/redo"+ | not $ noUndoTutLevel tutLevel ] +++ [ "RMB: wait a turn"+ | isNothing tutLevel ]+ 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 =+ shortMouseHelp IMReplay _ = [ "Wheel: advance/regress time" ]- shortMouseHelp _ = []+ shortMouseHelp _ _ = [] -- waitEvent' : copy of SDL.Events.waitEvent, with the timeout increased -- drastically to reduce CPU load when idling.@@ -655,7 +695,7 @@ event <- pollEvent case event of NoEvent -> threadDelay 10000 >> loop- _ -> return event+ _ -> return event getEvents = do e <- waitEvent'@@ -670,7 +710,7 @@ updateHoverStr :: InputMode -> UIM () updateHoverStr mode = do p@(mPos,isCentral) <- gets mousePos- showBT <- showButtonText <$> gets uiOptions+ showBT <- gets (showButtonText . uiOptions) hstr <- runMaybeT $ msum [ MaybeT ( cmdAtMousePos p mode Nothing ) >>= lift . describeCommandAndKeys , guard showBT >> MaybeT (helpAtMousePos p mode)@@ -691,10 +731,10 @@ where describeCommandAndKeys :: Command -> UIM String describeCommandAndKeys cmd = do- uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings+ uibdgs <- gets (Map.findWithDefault [] mode . uiKeyBindings) return $ describeCommand cmd ++ " ["- ++ concat (intersperse ","- (map showKeyFriendly $ findBindings (uibdgs ++ bindings mode) cmd))+ ++ intercalate ","+ (map showKeyFriendly $ findBindings (uibdgs ++ bindings mode) cmd) ++ "]" @@ -705,16 +745,17 @@ 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+ drop (max 0 $ 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 ($)) $+ (selDraws,allDrawn) = if length draws' > na+ then (take (na-1) draws' ++ [listButton CmdNextPage], False)+ else (take na draws', True)+ unless allDrawn . modify $ \ms -> ms { listOffsetMax = False }+ mapM_ (uncurry ($)) ( zip selDraws $ sortBy (compare `on` hexVec2SVec 37) $ take (length selDraws) $ sortBy (compare `on` (hexLen . (-^centre)))- area+ area) drawOldLock ls pos = void.runMaybeT $ msum [ do lock <- mgetLock ls@@ -724,12 +765,14 @@ ] -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+drawName,drawNullName :: Codename -> HexVec -> MainStateT UIM ()+drawName name pos = nameCol name >>= lift . drawNameCol name pos+drawNullName name pos = lift . drawNameCol name pos $ invisible white++drawNameCol name pos col = renderToMain $ do+ drawAtRel (playerGlyph col) pos+ renderStrColAt buttonTextCol name pos+ drawRelScore name pos = do col <- nameCol name relScore <- getRelScore name@@ -756,7 +799,7 @@ drawNameWithCharAndCol name charcol char col pos = do size <- fi.snd <$> lift getGeom let up = FVec 0 $ 1/2 - ylen- let down = FVec 0 $ ylen+ let down = FVec 0 ylen smallFont <- lift $ gets dispFontSmall lift.renderToMain $ do drawAtRel (playerGlyph col) pos@@ -768,17 +811,17 @@ pubColour = colourWheel pubWheelAngle -- ==purple accColour = cyan nameCol name = do- ourName <- (authUser <$>) <$> gets curAuth+ ourName <- gets ((authUser <$>) . 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+ 0 -> 0x80800000+ 1 -> 0x70a00000+ 2 -> 0x40c00000+ 3 -> 0x00ff0000 (-1) -> 0xa0700000 (-2) -> 0xc0400000 (-3) -> 0xff000000@@ -788,14 +831,14 @@ let centre = hw+^neg hv +^ 7*(idx-1)*^hu lift $ drawEmptyMiniLock centre drawNameWithCharAndCol name white (lockIndexChar idx) (invisible white) centre- ourName <- (authUser <$>) <$> gets curAuth+ ourName <- gets ((authUser <$>) . curAuth) lift $ registerSelectable centre 3 $ SelLockUnset (ourName == Just name) al drawLockInfo al@(ActiveLock name idx) (Just lockinfo) = do let centre = locksPos +^ 7*(idx-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+ ourName <- gets ((authUser <$>) . curAuth) runMaybeT $ msum [ do lock <- mgetLock $ lockSpec lockinfo@@ -809,23 +852,21 @@ size <- snd <$> lift getGeom lift $ do- renderToMain $ displaceRender (FVec 1 0) $ renderStrColAt (brightish white) "UNLOCKED BY" $ accessedByPos +^ hv+ renderToMain $ displaceRender (FVec 1 0) $ renderStrColAt (brightish white) "SOLUTIONS" $ accessedByPos +^ hv registerSelectable (accessedByPos +^ hv) 0 SelPrivyHeader registerSelectable (accessedByPos +^ hv +^ hu) 0 SelPrivyHeader if public lockinfo then lift $ do- renderToMain $ renderStrColAt pubColour "All" accessedByPos+ renderToMain $ renderStrColAt pubColour "Public" accessedByPos registerSelectable accessedByPos 1 SelPublicLock else if null $ accessedBy lockinfo- then lift.renderToMain $ renderStrColAt dimWhiteCol "No-one" accessedByPos+ then lift.renderToMain $ renderStrColAt dimWhiteCol "None" 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) ]+ $ [ \pos -> lift (registerSelectable pos 0 (SelSolution note)) >> drawNote note pos+ | note <- lockSolutions lockinfo ] undecls <- gets undeclareds case if isJust $ guard . (|| public lockinfo) . (`elem` map noteAuthor (lockSolutions lockinfo)) =<< ourName@@ -844,12 +885,12 @@ unless (ourName == Just name) $ do let readPos = accessedPos +^ (-3)*^hu lift.renderToMain $ renderStrColAt (if length read == 3 then accColour else dimWhiteCol)- "Read:" $ readPos+ "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)))+ $ 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 (FVec 1 0) $ renderStrColAt (brightish white) "SECURING" $ notesPos +^ hv@@ -861,18 +902,17 @@ [ 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+ [ \pos -> lift (registerSelectable pos 0 (SelSecured note)) >> drawActiveLock (noteOn note) pos | note <- notesSecured lockinfo ] drawBasicHelpPage :: (String,Pixel) -> ([String],Pixel) -> RenderM () drawBasicHelpPage (title,titleCol) (body,bodyCol) = do erase- let headPos = (screenHeightHexes`div`4)*^(hv+^neg hw)- renderStrColAt titleCol title headPos+ let startPos = hv +^ (length body `div` 4)*^(hv+^neg hw)+ renderStrColAtCentre titleCol title $ startPos +^ hv +^neg hw sequence_- [ renderStrColAt bodyCol str $- headPos+ [ renderStrColAtCentre bodyCol str $+ startPos +^ (y`div`2)*^(hw+^neg hv) +^ (y`mod`2)*^hw- | (y,str) <- zip [1..] body- ]+ | (y,str) <- zip [0..] body ]
Server.hs view
@@ -12,67 +12,69 @@ module Main where -import Network.Fancy+import Network.Fancy -import Control.Concurrent (threadDelay,forkIO)-import Control.Applicative-import Control.Monad-import Control.Monad.Trans.State-import Control.Monad.Trans.Except-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Reader-import Control.Monad.Trans-import Control.Monad.IO.Class-import System.Random-import Data.Maybe-import Data.Word-import Data.Foldable (for_)-import Data.Time.Clock-import System.IO-import System.FilePath-import System.Directory (renameFile)-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Char8 as CS-import qualified Data.Binary as B-import qualified Data.Text as TS-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Short as TSh-import Data.Array-import Control.Exception-import System.IO.Error-import Data.List-import Data.Function (on)-import Pipes-import qualified Pipes.Prelude as P+import Control.Applicative+import Control.Concurrent (forkIO, threadDelay)+import Control.Exception.Base (evaluate)+import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Trans+import Control.Monad.Trans.Except+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State+import Data.Array+import qualified Data.Binary as B+import qualified Data.ByteString.Char8 as CS+import qualified Data.ByteString.Lazy as BL+import Data.Foldable (for_)+import Data.Function (on)+import Data.List+import Data.Maybe+import qualified Data.Text as TS+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Short as TSh+import Data.Time.Clock+import Data.Word+import Pipes+import qualified Pipes.Prelude as P+import System.Directory (renameFile)+import System.FilePath+import System.IO+import System.IO.Error+import System.Random -import Text.Feed.Import (parseFeedFromFile)-import Text.Feed.Export (xmlFeed)-import Text.Feed.Constructor-import qualified Text.XML as XML-import Data.Time.Format-import Data.Time.LocalTime+import Data.Time.Format+import Data.Time.LocalTime+import Text.Feed.Constructor+import Text.Feed.Export (xmlFeed)+import Text.Feed.Import (parseFeedFromFile)+import qualified Text.XML as XML -import Crypto.Types.PubKey.RSA (PublicKey, PrivateKey)-import Codec.Crypto.RSA (decrypt, generateKeyPair, RSAError)-import Crypto.Random (newGenIO, SystemRandom)-import qualified Crypto.Argon2 as A2+import Codec.Crypto.RSA (RSAError, decrypt, generateKeyPair)+import qualified Crypto.Argon2 as A2+import Crypto.Random (SystemRandom, newGenIO)+import Crypto.Types.PubKey.RSA (PrivateKey, PublicKey) +import Network.Mail.Mime (plainPart)+import qualified Network.Mail.SMTP as SMTP import qualified Text.Email.Validate-import qualified Network.Mail.SMTP as SMTP -import System.Environment-import System.Console.GetOpt-import System.Exit+import System.Console.GetOpt+import System.Environment+import System.Exit -import Protocol-import Metagame-import Lock-import Frame-import Database-import AsciiLock-import Mundanities-import Maxlocksize-import Version+import AsciiLock+import Database+import Frame+import Lock+import Maxlocksize+import Metagame+import Mundanities+import Protocol+import Version defaultPort = 27001 -- 27001 == ('i'<<8) + 'y' @@ -119,7 +121,7 @@ withDB dbpath $ setDefaultServerInfo locksize >> setKeyPair writeFile (lockFilePath dbpath) "" logh <- case listToMaybe [ f | LogFile f <- opts ] of- Nothing -> return stdout+ Nothing -> return stdout Just path -> openFile path AppendMode streamServer serverSpec{address = IPv4 "" port, threading=Threaded} $ handler dbpath delay logh mfeedPath sleepForever@@ -140,7 +142,7 @@ putRecord RecSecretKey $ RCSecretKey secretKey argon2 :: String -> ExceptT String IO String-argon2 s = either (throwE . show) (return) $+argon2 s = either (throwE . show) return $ TSh.unpack <$> A2.hashEncoded hashOptions (CS.pack s) (CS.pack salt) where salt = "intricacy salt"@@ -179,9 +181,9 @@ response <- handle (\e -> return $ ServerError $ show (e::SomeException)) $ do request <- B.decode <$> BL.hGetContents hdl let hostname = case addr of- IP n _ -> n- IPv4 n _ -> n- IPv6 n _ -> n+ IP n _ -> n+ IPv4 n _ -> n+ IPv6 n _ -> n Unix path -> path hashedHostname = take 8 $ hash hostname now <- liftIO getCurrentTime@@ -202,7 +204,7 @@ ++ (if not $ validLock $ reframe lock then " [INVALID LOCK] " else "\n" ++ unlines (lockToAscii lock)) ++ "[SOLN]" showAction (DeclareSolution soln ls target idx) = "DeclareSolution [SOLN] "- ++ (concat $ intersperse " " $ [show ls,show target,show idx])+ ++ unwords [show ls,show target,show idx] showAction act = show act showResponse :: ServerResponse -> String showResponse (ServedLock lock) = "ServedLock lock:\n" ++ unlines (lockToAscii lock)@@ -212,20 +214,20 @@ handleRequest :: FilePath -> Maybe FilePath -> ClientRequest -> IO ServerResponse handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do let lockMode = case action of- Authenticate -> ReadMode- GetServerInfo -> ReadMode- GetPublicKey -> ReadMode- GetLock _ -> ReadMode- GetUserInfo _ _ -> ReadMode- GetRetired _ -> ReadMode- GetSolution _ -> ReadMode+ Authenticate -> ReadMode+ GetServerInfo -> ReadMode+ GetPublicKey -> ReadMode+ GetLock _ -> ReadMode+ GetUserInfo _ _ -> ReadMode+ GetRetired _ -> ReadMode+ GetSolution _ -> ReadMode GetRandomNames _ -> ReadMode- _ -> ReadWriteMode+ _ -> ReadWriteMode -- check solutions prior to write-locking database:- (withDBLock dbpath ReadMode $ runExceptT checkRequest) >>= + withDBLock dbpath ReadMode (runExceptT checkRequest) >>= either (return . ServerError) (const $- withDBLock dbpath lockMode $ runExceptT handleRequest' >>= + withDBLock dbpath lockMode $ runExceptT handleRequest' >>= either (return . ServerError) return) where checkRequest = do@@ -251,7 +253,7 @@ when (frame /= BasicFrame serverSize) $ throwE $ "Server only accepts size "++show serverSize++" locks." unless (validLock $ reframe lock) $ throwE "Invalid lock!"- unless (not.checkSolved $ reframe lock) $ throwE "Lock not locked!"+ when (checkSolved $ reframe lock) $ throwE "Lock not locked!" RCLockHashes hashes <- getRecordErrored RecLockHashes `catchE` const (return (RCLockHashes [])) let hashed = hash $ show lock@@ -327,19 +329,19 @@ ls <- erroredDB $ newLockRecord lock let oldLockInfo = userLocks info ! idx execStateT (do- when (isJust $ oldLockInfo) $+ when (isJust oldLockInfo) $ lift (getALock al) >>= retireLock addDelta name $ PutLock ls idx ) [] >>= applyDeltasToRecords for_ oldLockInfo $ \oldui -> do lss <- getRetired name- erroredDB $ putRecord (RecRetiredLocks name) $ RCLockSpecs $ (lockSpec oldui):lss+ erroredDB $ putRecord (RecRetiredLocks name) $ RCLockSpecs $ lockSpec oldui:lss doNews $ "New lock " ++ alockStr al ++ "." return ServerAck GetRandomNames n -> do- names <- erroredDB $ listUsers- gen <- erroredIO $ getStdGen+ names <- erroredDB listUsers+ gen <- erroredIO getStdGen let l = length names namesArray = listArray (0,l-1) names negligible name = do@@ -360,7 +362,7 @@ erroredIO c = do ret <- liftIO $ catchIO (Right <$> c) (return.Left) case ret of- Left e -> throwE $ "Server IO error: " ++ show e+ Left e -> throwE $ "Server IO error: " ++ show e Right x -> return x erroredDB :: DBM a -> ExceptT String IO a erroredDB = erroredIO . withDB dbpath@@ -377,19 +379,19 @@ RCSolution soln <- getRecordErrored $ RecNote note return soln getServerInfo = do- RCServerInfo sinfo <- getRecordErrored $ RecServerInfo+ RCServerInfo sinfo <- getRecordErrored RecServerInfo return sinfo getPublicKey = do- RCPublicKey publicKey <- getRecordErrored $ RecPublicKey+ RCPublicKey publicKey <- getRecordErrored RecPublicKey return publicKey getRetired name = do- RCLockSpecs lss <- fromMaybe (RCLockSpecs []) <$> (erroredDB $ getRecord $ RecRetiredLocks name)+ RCLockSpecs lss <- fromMaybe (RCLockSpecs []) <$> erroredDB (getRecord $ RecRetiredLocks name) return lss getALock (ActiveLock name idx) = do info <- getUserInfo name checkValidLockIndex idx case ((!idx).userLocks) info of- Nothing -> throwE "Lock not set"+ Nothing -> throwE "Lock not set" Just lockinfo -> return lockinfo checkValidLockIndex idx = unless (0<=idx && idx < maxLocks) $ throwE "Bad lock index"@@ -431,7 +433,7 @@ when exists $ throwE "Codename taken" pw' <- decryptPassword pw >>= argon2 erroredDB $ putRecord (RecPasswordArgon2 name) (RCPasswordArgon2 pw')- erroredDB $ putRecord (RecUserInfo name) (RCUserInfo $ (1,initUserInfo name))+ erroredDB $ putRecord (RecUserInfo name) (RCUserInfo (1,initUserInfo name)) erroredDB $ putRecord (RecUserInfoLog name) (RCUserInfoDeltas []) resetPassword Nothing _ = throwE "Authentication required" resetPassword auth@(Just (Auth name _)) newpw = do@@ -444,7 +446,7 @@ serverAddr <- erroredDB $ getRecord RecServerEmail when (isNothing serverAddr) $ throwE "This server is not configured to support email notifications." let addr = CS.pack addressStr- when (not $ CS.null addr || Text.Email.Validate.isValid addr) $ throwE "Invalid email address"+ unless (CS.null addr || Text.Email.Validate.isValid addr) $ throwE "Invalid email address" erroredDB $ putRecord (RecEmail name) (RCEmail addr) checkCodeName :: Codename -> ExceptT String IO Bool checkCodeName name = do@@ -463,7 +465,7 @@ erroredDB $ modifyRecord (RecUserInfoLog name) $ \(RCUserInfoDeltas deltas') -> RCUserInfoDeltas $ deltas ++ deltas' erroredDB $ modifyRecord (RecUserInfo name) $- \(RCUserInfo (v,info)) -> RCUserInfo $+ \(RCUserInfo (v,info)) -> RCUserInfo (v+length deltas, applyDeltas info deltas) declareNote note@(NoteInfo _ _ target) behind@(ActiveLock name idx) = do accessLock name target =<< getCurrALock target@@ -492,16 +494,16 @@ scrapNote _ = return () unreadNote note@(NoteInfo name (Just al) _) = do lock <- getCurrALock al- mapM_ (\name' -> addDelta name' (DelRead note)) $ name:(accessedBy lock)+ mapM_ (\name' -> addDelta name' (DelRead note)) $ name:accessedBy lock publiciseNote note@(NoteInfo _ _ al@(ActiveLock name idx)) = do unreadNote note addDelta name $ LockDelta idx $ SetPubNote note publified <- checkSuffPubNotes al unless publified $ do lock <- getCurrALock al- accessorsOfNotesOnLock <- ((++ map noteAuthor (lockSolutions lock)).concat)- <$> (sequence- [ accessedBy <$> getCurrALock behind | NoteInfo _ (Just behind) _ <- lockSolutions lock ] )+ accessorsOfNotesOnLock <- (++ map noteAuthor (lockSolutions lock)).concat+ <$> sequence+ [ accessedBy <$> getCurrALock behind | NoteInfo _ (Just behind) _ <- lockSolutions lock ] forM_ accessorsOfNotesOnLock $ checkSuffReadNotes al checkSuffReadNotes target name = do info <- getCurrUserInfo name@@ -513,16 +515,16 @@ lock <- getCurrALock al let countPub = fromIntegral $ length $ filter (isNothing.noteBehind) $ lockSolutions lock- if (countPub == notesNeeded)+ if countPub == notesNeeded then publiciseLock al lock >> return True else return False -- | XXX we apply deltas right-to-left, so in the order of adding addDelta name delta = modify ((name,delta):) getCurrUserInfo name = do info <- lift $ getUserInfo name- (applyDeltas info . map snd . filter ((==name).fst)) <$> get+ applyDeltas info . map snd . filter ((==name).fst) <$> get getCurrALock al@(ActiveLock name idx) =- (fromJust.(!idx).userLocks) <$> getCurrUserInfo name+ fromJust.(!idx).userLocks <$> getCurrUserInfo name doNews :: String -> ExceptT String IO () doNews news = case mfeedPath of Nothing -> return ()@@ -547,7 +549,7 @@ lift.lift $ SMTP.sendMail "localhost" $ SMTP.simpleMail (makeAddr serverAddr) [makeAddr playerAddr] [] [] (TS.pack $ "[Intricacy] " ++ alockStr target ++" solved by " ++ solverName)- [SMTP.plainTextPart $ TL.pack $ "A solution to your lock " ++ alockStr target ++ " has been declared by " ++ solverName +++ [plainPart $ TL.pack $ "A solution to your lock " ++ alockStr target ++ " has been declared by " ++ solverName ++ " and secured behind " ++ alockStr behind ++ "." ++ "\n\n-----\n\nYou received this email from the game Intricacy" ++ "\n\thttp://sdf.org/~mbays/intricacy ." ++
ServerAddr.hs view
@@ -10,9 +10,9 @@ module ServerAddr where -import Data.List-import Data.Maybe-import Control.Applicative+import Control.Applicative+import Data.List+import Data.Maybe data ServerAddr = ServerAddr {hostname::String, port::Int} deriving (Eq, Ord, Show, Read)
Setup.hs view
@@ -8,5 +8,5 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/. -import Distribution.Simple+import Distribution.Simple main = defaultMain
Util.hs view
@@ -9,10 +9,10 @@ -- along with this program. If not, see http://www.gnu.org/licenses/. module Util where-import qualified Data.Vector as Vector-import Data.Vector (Vector)-import Control.Monad-import Control.Monad.Trans.Maybe+import Control.Monad+import Control.Monad.Trans.Maybe+import Data.Vector (Vector)+import qualified Data.Vector as Vector enumVec :: Vector a -> [(Int,a)] enumVec = Vector.toList . Vector.indexed
+ initiation/BAL.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " & % $ # " " " " + " o - & & } 9 [ # " " + " / & # # [ O # " # " + " & % # # # "+ " & & & & " " + " S S S S # 1 \ % " " + " ' # ] 1 & o Z " +" o O O # ) 1 & & & Z " + " o - O ) 1 & & & & " + " % # & & Z & " + " " # # & & 5 " +" * ' ' # & & " + " @ " O o & & # # & " + " " " / & & & & & " + " & & & & & & & & " + " " " " " " " " "
+ initiation/BAL.text view
@@ -0,0 +1,1 @@+Balance and trembling
+ initiation/CLR.lock view
@@ -0,0 +1,17 @@+ & & & & & & & & & + & " " " " " " & & & & + & " O O O O O " & & + & " " " " " " " " & & + & S S S S S S S S S S " " " " &+ & # # " # & & + & % % % % % % . o - # & & + & % % % % % % & +& % % ] % % % % # & + & % % ] % % % & + & % % ] % % & + & & \ ' % # % % % % % % & +& * ' o O o - % [ . o & + & @ & O / % [ & + & & & O % # & + & O O # & + & & & & & & & & &
+ initiation/CLR.text view
@@ -0,0 +1,1 @@+Everything must go!
+ initiation/CMB.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " # # # " " " " + " # # # # " " + " # ] # # " % " + " # # % % # # & & & % "+ " # ] % # 7 % " " + " # # " " # ' 7 % % " " + " # ] " o % % ' % " +" # % % # ' 7 . o % " + " # ] % o 7 1 " + " # " " # ' # # 1 " + " " # " o 7 # " +" * ' % ' 7 " + " @ " % o % % " + " " " % 7 " + " 7 " + " " " " " " " " "
+ initiation/CMB.text view
@@ -0,0 +1,1 @@+Combination lock
+ initiation/COG.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " # # # # [ # # # " " " " + " # # # # [ # S S % " " + " # # # # [ % % " " + " # # # # [ % % % "+ " # \ % % % % % " " + " o - ' % [ . o " " + " # # / . o [ # # ` " +" # # # # \ ` # # [ . o " + " # # ' o - ' [ ` " + " . o / . o % # " + " " ` # ` % # " +" * ' # # # % % % % # " + " @ " # # # % # # # " + " " " # # % % # # # " + " " + " " " " " " " " "
+ initiation/COG.text view
@@ -0,0 +1,1 @@+Cogs
+ initiation/DIV.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " " " " " + " # S S S S S % " " + " O " % " " + " S S & & & o - % % % % % % "+ " & & # # " " + " # # # # # # # " " + " # # # " +" # # # # # # # " + " # # " + " # O " + " " # % # # # # # " +" * ' % % % # " + " @ " O % } % % % o # " + " " " % O % " / # " + " % O # " + " " " " " " " " "
+ initiation/DIV.text view
@@ -0,0 +1,1 @@+Division of labour
+ initiation/END.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " # o - o - & " " " " + " # \ / . o / & " " + " { o - O ` " s s & " " + " & & ' O % " o \ & & & "+ " ' . o O O O O O ` o " " + " o " O ` % ' % $ # ` " " + " ` " # 9 . o % % % D & " +" ] " { # # D & & \ & " + " ] " % $ & o " + " & & # D D D " ` " + " " & " " " " o O " +" * ' & " c c c c % / O " + " @ " & " & % % % " + " " " & & % c c c c # " + " " + " " " " " " " " "
+ initiation/END.text view
@@ -0,0 +1,1 @@+The final challenge
+ initiation/GAP.lock view
@@ -0,0 +1,17 @@+ & & & & & & & & & + & & & & & + & % % & & + & # C C C C % % % & # & + & % # # # &+ & % 7 & & + & $ $ S S S " O O % 7 & & + & # " % % & +& $ S S S S S % " C C C C C D & + & # % % O & + & % Z & + & & % Z & +& * ' # # & + & @ & # # & + & & & & + & & + & & & & & & & & &
+ initiation/GAP.text view
@@ -0,0 +1,1 @@+The jaws that snap...
+ initiation/HLD.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " ~ ~ S S S s s # " " " " + " \ ~ & # " " + " o & & . o - # " " + " ` Z " # # # # "+ " % # # Z " [ # " " + " % # # Z " [ " # " " + " % O # Z " " # # " +" % O O # " S S S S % # " + " % # # # # # . o - " + " % # # O O # " + " " \ # # " +" * ' o # % " + " @ " % 7 % " + " " " % 7 O % " + " % % % % % % % % " + " " " " " " " " "
+ initiation/HLD.text view
@@ -0,0 +1,1 @@+HOLD BALL
+ initiation/ICE.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " [ " " " " + " # . o O [ " " + " [ " " + " [ # S S % % % "+ " # % % % % % % " " + " # % # # # # S S S S & & " " + " # & & " +" & " + " & # # # " # \ # " + " & # \ " " " o " + " " & & & o " " " " +" * ' & ` " 9 " . o - " + " @ " & & O " " 9 " " O # " + " " " # # # " + " # " + " " " " " " " " "
+ initiation/ICE.text view
@@ -0,0 +1,1 @@+Obligatory slippy-slidey ice world
+ initiation/ONE.lock view
@@ -0,0 +1,17 @@+ % % % % % % % % % + % % % % % + % S S S S S S S S " % % + % # # # " " % % + % o \ " " $ $ # %+ % / . o o - % % + % # % # # # . o - . o - % % + % % # % +% " " % C C " % [ # % + % O % % [ % + % # # # # \ % % + % % o - # o . o % +% * ' . o # # o " ` # % + % @ % # # / ` " C C % + % % % # % C C C C " % + % # # % + % % % % % % % % %
+ initiation/ONE.text view
@@ -0,0 +1,1 @@+One ball to block them all
+ initiation/PLG.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " # ( " " " " + " # ( " " + " # # ( " # " + " # # ( # "+ " # ( # " " + " & & % ( # " " + " & & & & Z ( # # " +" # C C & & Z ( # # # " + " & & & & & # 7 " + " & & & & & ] 7 " + " " & & & ] % 7 " +" * ' o \ O # " % 7 " + " @ " ` o # % 7 " + " " " # % # % 7 " + " % % % " + " " " " " " " " "
+ initiation/PLG.text view
@@ -0,0 +1,1 @@+Pull the plug
+ initiation/RAT.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " " " " " + " # " " + " # # " # " + " # # # "+ " # # % O O O " " " # " " + " # % % O O O " " " # " " + " % S S S S S S " # " +" # # # # % % % % % " # # " + " # % % # # # # 7 " + " # # ' % % & # # 7 " + " " # \ . o % % Z Z # % " +" * ' o - ` % Z Z % " + " @ " / # # % % Z Z % " + " " " # # \ O % Z Z " + " o O % % Z " + " " " " " " " " "
+ initiation/RAT.text view
@@ -0,0 +1,1 @@+Ratchet
+ initiation/REP.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " } # " " " " + " & } # # S S % " " + " & } & & % % " " + " & } & % % % "+ " % & } & " " + " [ % $ # & } & " " + " [ & & o " +" # # # # # o - O / ` % " + " % # / O % % " + " % # % O % " + " " % % O % " +" * ' % O % " + " @ " % # # # # O # " + " " " # " + " # " + " " " " " " " " "
+ initiation/REP.text view
@@ -0,0 +1,1 @@+Do the shuffle.
+ initiation/RUN.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " ~ ~ ~ ~ ~ # # " " " " + " ~ ~ ~ ~ # # " " + " ~ ~ ~ ~ ~ # # " # " + " ~ ~ ~ $ " O # # # # # "+ " ~ ~ ~ ~ ~ # # # 7 " " + " ~ ~ ~ ~ ~ 7 " " + " ~ ~ ~ ~ ~ O % D " " " " " +" ~ & & & & & & & & " + " ~ ~ ~ ~ # # # & " + " & " + " " & & & & & & " +" * ' & C C C C C C C C C C " + " @ " % % % % % % % % % % " + " " " % % % % % % % % " + " % % % % % % % % " + " " " " " " " " "
+ initiation/RUN.text view
@@ -0,0 +1,1 @@+Quick!
+ initiation/SOK.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " O # " " " " + " % % % # # " " + " % % # ' " & " + " % # o & & "+ " O % O # # ` & " " + " O % # # # O & " " + " % # # O & " +" % # & " + " # % # # # # # # 7 " + " # % # # 7 " + " " O # # O % " +" * ' # " + " @ " % # " + " " " # O % # " + " O " + " " " " " " " " "
+ initiation/SOK.text view
@@ -0,0 +1,1 @@+Sokoban
+ initiation/initiation.map view
@@ -0,0 +1,3 @@+[["DIV","ICE","CLR","COG","BAL"],+["RUN","HLD","SOK","ONE","END"],+["PLG","REP","CMB","GAP","RAT"]]
intricacy.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: intricacy-version: 0.7.2.3+version: 0.8.0 license: GPL-3 license-file: COPYING maintainer: mbays@sdf.org@@ -8,16 +8,17 @@ homepage: http://mbays.freeshell.org/intricacy synopsis: A game of competitive puzzle-design description:- A networked game with client-server architecture. The core game is a- lockpicking-themed turn-based puzzle game on a hex grid. Players design- puzzles (locks) and solve those designed by others. A metagame encourages- the design of maximally difficult puzzles, within tight size constraints.- The client supports Curses and SDL, with all graphics in SDL mode drawn by- code using SDL-gfx. The network protocol is based on the 'binary' package,- and is intended to be reasonably efficient. TVars are used to give- transparent local caching and background network operations. Also- incorporates an implementation of a graph 5-colouring algorithm (see- GraphColouring.hs).+ A lockpicking-themed turn-based puzzle game on a hex grid. A series of+ preset puzzles serves as an extended single-player introduction, after+ which players enter a multi-player game with a client-server architecture,+ in which players design puzzles (locks) and solve those designed by+ others. A metagame encourages the design of maximally difficult puzzles,+ within tight size constraints. The client supports Curses and SDL, with+ all graphics in SDL mode drawn by code using SDL-gfx. The network protocol+ is based on the 'binary' package, and is intended to be reasonably+ efficient. TVars are used to give transparent local caching and background+ network operations. Also incorporates an implementation of a graph+ 5-colouring algorithm (see GraphColouring.hs). category: Game build-type: Simple@@ -25,6 +26,9 @@ VeraMoBd.ttf tutorial/*.lock tutorial/*.text+ initiation/initiation.map+ initiation/*.lock+ initiation/*.text sounds/*.ogg extra-source-files:@@ -103,6 +107,7 @@ transformers >=0.3.0.0 && <0.6, stm >=2.1 && <2.6, directory >=1.0 && <1.4,+ exceptions >=0.8.3 && <0.11, filepath >=1.0 && <1.5, time >=1.2 && <1.10, bytestring ==0.10.*,@@ -206,6 +211,7 @@ transformers >=0.4 && <0.6, stm >=2.1 && <2.6, directory >=1.0 && <1.4,+ exceptions >=0.8.3 && <0.11, filepath >=1.0 && <1.5, time >=1.5 && <1.10, bytestring ==0.10.*,@@ -225,6 +231,7 @@ email-validate >=1.0 && <2.4, text >=0.1 && < 1.3, text-short ==0.1.*,+ mime-mail >=0.4.4 && < 0.6, smtp-mail >=0.1.4.1 && < 0.4, argon2 ==1.3.*
+ sounds/toolmove-01.ogg view
binary file changed (absent → 5232 bytes)
+ sounds/toolmove-02.ogg view
binary file changed (absent → 5000 bytes)
+ sounds/toolmove-03.ogg view
binary file changed (absent → 5271 bytes)
+ sounds/toolmove-04.ogg view
binary file changed (absent → 5265 bytes)
+ sounds/toolmove-05.ogg view
binary file changed (absent → 5268 bytes)
− tutorial/07-pivots.lock
@@ -1,11 +0,0 @@- " " " " " " - " \ # # " " " - " o - \ ' " # " - " % / " o - # "- " % % " " # # " " - " % % % " O # # " - " " . o - 7 " -" * ' . o - & ` 7 " - " @ " O & & & " - " " " # # & & " - " " " " " "
− tutorial/07-pivots.text
@@ -1,1 +0,0 @@-push arms to rotate them around their pivots
+ tutorial/07-traps.lock view
@@ -0,0 +1,13 @@+ & & & & & & & + & & & & + & % O % S S " & & + & # " " " " &+ & " O " " & & + & " " # # # # # & + & " # & + & " " " # # # & + & & " } # # # & +& * ' % # # # & + & @ & O # & + & & & # # # # & + & & & & & & &
+ tutorial/07-traps.text view
@@ -0,0 +1,1 @@+if you make a mistake, you can undo moves ('X') or reset to the start ('^')
+ tutorial/09-pivots.lock view
@@ -0,0 +1,11 @@+ " " " " " " + " \ # # " " " + " o - \ ' " # " + " % / " o - # "+ " % % " " # # " " + " % % % " O # # " + " " . o - 7 " +" * ' . o - & ` 7 " + " @ " O & & & " + " " " # # & & " + " " " " " "
+ tutorial/09-pivots.text view
@@ -0,0 +1,1 @@+push arms to rotate them around their pivots
− tutorial/09-traps.lock
@@ -1,13 +0,0 @@- & & & & & & & - & & & & - & % O % S S " & & - & # " " " " &- & " O " " & & - & " " # # # # # & - & " # & - & " " " # # # & - & & " } # # # & -& * ' % # # # & - & @ & O # & - & & & # # # # & - & & & & & & &
− tutorial/09-traps.text
@@ -1,1 +0,0 @@-if you make a mistake, you can undo moves ('X') or reset to the start ('^')
− tutorial/10-puzzle.lock
@@ -1,17 +0,0 @@- " " " " " " " " " - " " " " " - " # S S S S S % " " - " O " % " " - " S S & & & o - % % % % % % "- " & & # # " " - " # # # # # # # " " - " # # # " -" # # # # # # # " - " # # " - " # O " - " " # % # # # # # " -" * ' % % % # " - " @ " O % } % % % o # " - " " " % O % " / # " - " % O # " - " " " " " " " " "
− tutorial/10-puzzle.text
@@ -1,1 +0,0 @@-your final test!