intricacy 0.3.8 → 0.4.1
raw patch · 42 files changed
+1043/−935 lines, 42 filesdep +safesetup-changed
Dependencies added: safe
Files
- AsciiLock.hs +17/−16
- BinaryInstances.hs +2/−3
- BoardColouring.hs +8/−9
- CVec.hs +3/−4
- Cache.hs +3/−3
- Command.hs +53/−41
- CursesRender.hs +30/−25
- CursesUI.hs +21/−20
- CursesUIMInstance.hs +48/−27
- Database.hs +45/−44
- Debug.hs +1/−2
- EditGameState.hs +4/−5
- Frame.hs +4/−4
- GameState.hs +33/−27
- GameStateTypes.hs +1/−1
- GraphColouring.hs +50/−60
- Init.hs +25/−22
- InputMode.hs +1/−1
- Interact.hs +128/−122
- InteractUtil.hs +17/−26
- KeyBindings.hs +2/−1
- Lock.hs +26/−22
- MainBoth.hs +0/−22
- MainBoth.hsMainSDL.hsMainCurses.hs +0/−0
- MainCurses.hs +0/−20
- MainSDL.hs +0/−20
- MainState.hs +98/−84
- Maxlocksize.hs +1/−1
- Metagame.hs +13/−8
- Mundanities.hs +5/−1
- NEWS +28/−63
- Physics.hs +18/−10
- Protocol.hs +2/−2
- SDLRender.hs +21/−8
- SDLUI.hs +117/−76
- SDLUIMInstance.hs +99/−58
- Server.hs +98/−72
- ServerAddr.hs +1/−1
- Setup.hs +1/−1
- Util.hs +16/−1
- intricacy.cabal +2/−1
- tutorial/1-winning.text +1/−1
AsciiLock.hs view
@@ -3,23 +3,21 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/. module AsciiLock (lockToAscii, lockOfAscii, stateToAscii- , readAsciiLockFile, writeAsciiLockFile) where+ , readAsciiLockFile, writeAsciiLockFile, monochromeOTileChar) where import Data.Function (on) import Control.Applicative hiding ((<*>)) import Control.Monad import Control.Arrow ((&&&))-import System.IO import qualified Data.Map as Map import Data.Map (Map) import qualified Data.Vector as Vector-import Data.Vector (Vector, (!), (//)) import Data.Maybe import Data.Traversable as T import Data.List@@ -38,7 +36,7 @@ type AsciiLock = [String] lockToAscii :: Lock -> AsciiLock-lockToAscii (_,st) = stateToAscii st+lockToAscii = stateToAscii . snd stateToAscii :: GameState -> AsciiLock stateToAscii st =@@ -48,7 +46,7 @@ lockOfAscii :: AsciiLock -> Maybe Lock lockOfAscii lines = do board <- asciiToBoard lines- let size = maximum $ map (hx . (<->origin))$ Map.keys board+ let size = maximum $ map (hx . (<->origin)) $ Map.keys board frame = BasicFrame size st <- asciiBoardState frame board return (frame, st)@@ -61,7 +59,7 @@ (miny,maxy) = minmax $ map cy $ Map.keys asciiBoard (minx,maxx) = minmax $ map cx $ Map.keys asciiBoard asciiBoard' = Map.mapKeys (<->CVec miny minx) asciiBoard- in [ [ Map.findWithDefault ' ' (CVec y x) asciiBoard' + in [ [ Map.findWithDefault ' ' (CVec y x) asciiBoard' | x <- [0..(maxx-minx)] ] | y <- [0..(maxy-miny)] ] @@ -94,40 +92,41 @@ addBaseOT :: (HexPos,(PieceIdx,Tile)) -> GameState -> GameState addBaseOT (pos,(o,BlockTile [])) = addBlockPos o pos addBaseOT (pos,(-1,t)) = addpp $ PlacedPiece pos $ basePieceOfTile t+ addBaseOT _ = error "owned non-block tile in AsciiLock.asciiBoardState" basePieceOfTile (PivotTile _) = Pivot [] basePieceOfTile HookTile = Hook hu NullHF basePieceOfTile (WrenchTile _) = Wrench zero basePieceOfTile BallTile = Ball+ basePieceOfTile _ = error "Unexpected tile in AsciiLock.asciiBoardState" 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 $ sortBy (flip compare `on` blockSize . placedPiece . snd)- [ (idx,pp)+ (idx,pp) <- listToMaybe $ map fst $ sortBy (flip compare `on` snd)+ [ ((idx,pp),length vs) | (idx,pp) <- enumVec $ placedPieces st- , isBlock . placedPiece $ pp+ , Block vs <- [placedPiece pp] , let fp = plPieceFootprint pp , not $ null fp , all (not.inBounds frame) fp ] return $ delPiece idx $ setpp 0 pp st- blockSize (Block vs) = length vs baseSt = setFrame . componentifyNew . addBase . addPreBase $ GameState Vector.empty [] baseBoard = stateBoard baseSt addAppendages :: GameState -> Maybe GameState addAppendages st = foldM addAppendageOT st $ Map.toList $ Map.filter (not.isBaseTile.snd) board- addAppendageOT st (pos,(-1,ArmTile dir _)) = + addAppendageOT st (pos,(-1,ArmTile dir _)) = let rpos = (neg dir<+>pos) in case Map.lookup rpos baseBoard of Just (idx,PivotTile _) -> Just $ addPivotArm idx pos st Just (idx,HookTile) -> Just $ setpp idx (PlacedPiece rpos (Hook dir NullHF)) st _ -> Nothing- addAppendageOT st (pos,(-1,SpringTile extn dir)) =+ addAppendageOT st (pos,(-1,SpringTile _ dir)) = let rpos = (neg dir<+>pos) in case Map.lookup rpos baseBoard of Just (_,SpringTile _ _) -> Just st- Just (ridx,tile) -> do+ Just _ -> do (_,epos) <- castRay pos dir baseBoard let twiceNatLen = sum [ extnValue extn | i <- [1..hexLen (epos<->rpos)-1]@@ -152,8 +151,9 @@ Just 4 -> '~' _ -> '#' monochromeOTileChar _ (_,t) = monochromeTileChar t+monochromeTileChar :: Tile -> Char monochromeTileChar (PivotTile _) = 'o'-monochromeTileChar (ArmTile dir _) +monochromeTileChar (ArmTile dir _) | dir == hu = '-' | dir == hv = '\\' | dir == hw = '/'@@ -188,6 +188,7 @@ Stretched -> '1' Relaxed -> '7' Compressed -> '9'+monochromeTileChar _ = '?' monoToOTile :: Char -> Maybe OwnedTile monoToOTile '#' = Just $ (1,BlockTile []) monoToOTile '%' = Just $ (2,BlockTile [])@@ -195,6 +196,7 @@ 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 '\\' = Just $ ArmTile hv False@@ -242,4 +244,3 @@ writeStrings path $ lockToAscii lock ++ case msoln of Nothing -> [] Just soln -> ["Solution:", show soln]-
BinaryInstances.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -61,7 +61,7 @@ instance Binary HexVec where put (HexVec x y _) = putPackedInt x >> putPackedInt y- get = do + get = do x <- getPackedInt y <- getPackedInt return $ tupxy2hv (x,y)@@ -131,4 +131,3 @@ 1 -> liftM HookPush get 2 -> liftM HookTorque getPackedInt 3 -> liftM WrenchPush get-
BoardColouring.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -17,7 +17,6 @@ import Data.Map (Map) import qualified Data.Set as Set import Data.Set (Set)-import qualified Data.Vector as Vector import Data.List import Data.Maybe @@ -41,8 +40,8 @@ [ (idx, col) | (idx, PlacedPiece _ p) <- enumVec $ placedPieces st , idx `elem` coloured , let col = if isBlock p then 1+((connGraphHeight st idx - 1) `mod` 5) else 0 ]- + boardColouring :: GameState -> [PieceIdx] -> PieceColouring -> PieceColouring boardColouring st coloured lastCol = fiveColour graph lastCol@@ -50,7 +49,7 @@ board = stateBoard st graph = Map.fromList [ (idx, nub $ neighbours idx) | idx <- coloured ]- neighbours idx = + neighbours idx = neighbours' idx (perim idx) [] perim :: PieceIdx -> Set (HexPos,HexDir) perim idx =@@ -63,7 +62,7 @@ return $ idx == idx' ] neighbours' :: PieceIdx -> Set (HexPos,HexDir) -> [PieceIdx] -> [PieceIdx]- neighbours' idx as ns + neighbours' idx as ns | Set.null as = ns | otherwise = let a = head $ Set.elems as@@ -76,18 +75,18 @@ march idx startPos (pos,basedir) init | not init && pos == startPos = ([],[]) | otherwise =- let n = do + let mn = do (idx',_) <- Map.lookup pos board guard $ idx' `elem` coloured return idx'- mNext = listToMaybe + mNext = listToMaybe [ (pos', rotate (h-2) basedir)- | h <- [1..5] + | h <- [1..5] , let pos' = (rotate h basedir)<+>pos , (fst <$> Map.lookup pos' board) /= Just idx ] (path,ns) = case mNext of Nothing -> ([],[]) Just next -> march idx startPos next False- in (pos:path, (maybeToList n)++ns)+ in (pos:path, (maybeToList mn)++ns)
CVec.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -19,11 +19,10 @@ mempty = CVec 0 0 mappend (CVec y x) (CVec y' x') = CVec (y+y') (x+x') instance Grp CVec where- neg (CVec y x) = CVec (-y) (-x) + neg (CVec y x) = CVec (-y) (-x) type CCoord = PHS CVec hexVec2CVec :: HexVec -> CVec-hexVec2CVec (HexVec x y z) = CVec (-y) (x-z) +hexVec2CVec (HexVec x y z) = CVec (-y) (x-z) cVec2HexVec :: CVec -> HexVec cVec2HexVec (CVec y x) = HexVec ((x+y)`div`2) (-y) ((y-x)`div`2)-
Cache.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -49,7 +49,7 @@ let action = case rec of RecUserInfo name -> let curVersion = (\(RCUserInfo (v,_)) -> v) <$> fromCache- in GetUserInfo name curVersion + in GetUserInfo name curVersion _ -> askForRecord rec resp <- makeRequest saddr (ClientRequest protocolVersion (if needsAuth action then auth else Nothing) action)@@ -83,7 +83,7 @@ `catchIO` (const $ return $ ServerError $ "Cannot connect to "++saddrStr saddr++"!") where makeRequest' hdl = do- BS.hPut hdl $ BL.toStrict $ encode request + BS.hPut hdl $ BL.toStrict $ encode request hFlush hdl (decode . BL.fromStrict) `liftM` BS.hGetContents hdl
Command.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -13,52 +13,57 @@ import GameStateTypes import Metagame -data Command = CmdDir WrHoSel HexDir | CmdRotate WrHoSel TorqueDir | CmdWait- | CmdMoveTo HexPos | CmdManipulateToolAt HexPos- | CmdDrag HexPos HexDir- | CmdToggle- | CmdOpen- | CmdTile Tile | CmdPaint (Maybe Tile)- | CmdPaintFromTo (Maybe Tile) HexPos HexPos- | CmdSelect | CmdUnselect- | CmdDelete | CmdMerge- | CmdMark | CmdJumpMark | CmdReset- | CmdPlay | CmdTest- | CmdUndo | CmdRedo- | CmdReplayForward Int | CmdReplayBack Int- | CmdInputChar Char- | CmdInputSelLock LockIndex | CmdInputCodename Codename | CmdInputSelUndecl Undeclared- | CmdWriteState- | CmdTutorials- | CmdShowRetired | CmdPlayLockSpec (Maybe LockSpec)- | CmdSetServer | CmdToggleCacheOnly- | CmdSelCodename (Maybe Codename) | CmdBackCodename | CmdHome- | CmdSolve (Maybe LockIndex) | CmdDeclare (Maybe Undeclared)- | CmdViewSolution (Maybe NoteInfo)- | CmdSelectLock | CmdNextLock | CmdPrevLock- | CmdEdit | CmdPlaceLock (Maybe LockIndex)- | CmdRegister | CmdAuth- | CmdNextPage | CmdPrevPage- | CmdRedraw | CmdRefresh | CmdSuspend- | CmdQuit | CmdForceQuit- | CmdHelp | CmdBind- | CmdNone+data Command+ = CmdDir WrHoSel HexDir | CmdRotate WrHoSel TorqueDir | CmdWait+ | CmdMoveTo HexPos | CmdManipulateToolAt HexPos+ | CmdDrag HexPos HexDir+ | CmdToggle+ | CmdOpen+ | CmdTile Tile | CmdPaint (Maybe Tile)+ | CmdPaintFromTo (Maybe Tile) HexPos HexPos+ | CmdSelect | CmdUnselect+ | CmdDelete | CmdMerge+ | CmdMark | CmdJumpMark | CmdReset+ | CmdPlay | CmdTest+ | CmdUndo | CmdRedo+ | CmdReplayForward Int | CmdReplayBack Int+ | CmdInputChar Char+ | CmdInputSelLock LockIndex+ | CmdInputCodename Codename+ | CmdInputSelUndecl Undeclared+ | CmdWriteState+ | CmdTutorials+ | CmdShowRetired | CmdPlayLockSpec (Maybe LockSpec)+ | CmdSetServer | CmdToggleCacheOnly+ | CmdSelCodename (Maybe Codename) | CmdBackCodename | CmdHome+ | CmdSolve (Maybe LockIndex) | CmdDeclare (Maybe Undeclared)+ | CmdViewSolution (Maybe NoteInfo)+ | CmdSelectLock | CmdNextLock | CmdPrevLock+ | CmdEdit | CmdPlaceLock (Maybe LockIndex)+ | CmdRegister | CmdAuth+ | CmdNextPage | CmdPrevPage+ | CmdToggleColourMode+ | CmdRedraw | CmdRefresh | CmdSuspend+ | CmdQuit | CmdForceQuit+ | CmdHelp | CmdBind+ | CmdNone deriving (Eq, Ord, Show, Read) data WrHoSel = WHSWrench | WHSHook | WHSSelected deriving (Eq, Ord, Show, Read)- + describeCommand :: Command -> String describeCommand (CmdDir whs dir) = "move " ++ whsStr whs ++ " " ++ dirStr dir-describeCommand (CmdRotate whs dir) = "rotate " ++ whsStr whs ++ " " ++ (if dir == 1 then "counter" else "") ++ "clockwise"+describeCommand (CmdRotate whs dir) = "rotate " ++ whsStr whs+ ++ " " ++ (if dir == 1 then "counter" else "") ++ "clockwise" describeCommand CmdWait = "nothing" describeCommand CmdToggle = "toggle tool" describeCommand CmdOpen = "open lock" describeCommand (CmdTile tile) = tileStr tile-describeCommand CmdMerge = "merge with adjacent piece" +describeCommand CmdMerge = "merge with adjacent piece" describeCommand CmdMark = "mark state" describeCommand CmdJumpMark = "jump to marked state" describeCommand CmdReset = "jump to initial state"-describeCommand CmdSelect = "select piece" +describeCommand CmdSelect = "select piece" describeCommand CmdUnselect = "unselect piece" describeCommand CmdDelete = "delete piece" describeCommand CmdPlay = "play lock"@@ -72,23 +77,30 @@ describeCommand CmdShowRetired = "show retired locks" describeCommand CmdSetServer = "set server" describeCommand CmdToggleCacheOnly = "toggle using only cache"-describeCommand (CmdSelCodename mname) = "select player" ++ maybe "" (' ':) mname+describeCommand (CmdSelCodename mname) = "select player"+ ++ maybe "" (' ':) mname describeCommand CmdBackCodename = "select last player" describeCommand CmdHome = "select self"-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-describeCommand (CmdViewSolution mnote) = "view lock solution" ++ maybe "" (\_->" [specified solution]") mnote+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+describeCommand (CmdViewSolution mnote) = "view lock solution"+ ++ maybe "" (\_->" [specified solution]") mnote describeCommand CmdSelectLock = "choose lock by name" describeCommand CmdNextLock = "next lock" describeCommand CmdPrevLock = "previous lock" describeCommand CmdNextPage = "page forward through lists" describeCommand CmdPrevPage = "page back through lists" describeCommand CmdEdit = "edit lock"-describeCommand (CmdPlaceLock mli) = "place lock" ++ maybe "" ((' ':).(:"").lockIndexChar) mli+describeCommand (CmdPlaceLock mli) = "place lock"+ ++ maybe "" ((' ':).(:"").lockIndexChar) mli describeCommand CmdRegister = "register codename" describeCommand CmdAuth = "authenticate" describeCommand CmdBind = "bind key"+describeCommand CmdToggleColourMode = "toggle lock colour mode" describeCommand CmdQuit = "quit" describeCommand CmdHelp = "help" describeCommand _ = ""
CursesRender.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -19,25 +19,26 @@ import CVec import GameStateTypes import BoardColouring (PieceColouring)+import AsciiLock -- From Curses.CursesHelper: -- | Converts a list of 'Curses.Color' pairs (foreground color and -- background color) into the curses representation 'Curses.Pair'. colorsToPairs :: [(Curses.Color, Curses.Color)] -> IO [Curses.Pair]-colorsToPairs cs =- do p <- Curses.colorPairs- let nColors = length cs- blackWhite = p < nColors- if blackWhite then do- print ("Terminal does not support enough colors. Number of " ++- " colors requested: " ++ show nColors ++- ". Number of colors supported: " ++ show p)- return $ replicate nColors $ Curses.Pair 0- else mapM toPairs (zip [1..] cs)- where toPairs (n, (fg, bg)) =- let p = Curses.Pair n- in do Curses.initPair p fg bg- return p+colorsToPairs cs = do+ p <- Curses.colorPairs+ let nColors = length cs+ blackWhite = p < nColors+ if blackWhite then do+ print ("Terminal does not support enough colors. Number of " +++ " colors requested: " ++ show nColors +++ ". Number of colors supported: " ++ show p)+ return $ replicate nColors $ Curses.Pair 0+ else mapM toPairs (zip [1..] cs)+ where toPairs (n, (fg, bg)) = do+ let p = Curses.Pair n+ Curses.initPair p fg bg+ return p type AttrChar = (Char, Curses.Attr) type ColPair = Int@@ -52,19 +53,21 @@ data Glyph = Glyph Char ColPair Curses.Attr a0 = Curses.attr0 bold = Curses.setBold a0 True+ tileChar :: Tile -> AttrChar tileChar (BlockTile _) = ('#',a0)-tileChar (PivotTile dir) | dir == zero = ('o',bold)+tileChar (PivotTile dir)+ | dir == zero = ('o',bold) | canonDir dir == hu = ('-',bold) | canonDir dir == hv = ('\\',bold) | canonDir dir == hw = ('/',bold)-tileChar (ArmTile dir principal) = let- cdir = canonDir dir- c | cdir == hu = '-'- | cdir == hv = '\\'- | cdir == hw = '/'- | otherwise = '?'- a = if principal then bold else a0+tileChar (ArmTile dir principal) =+ let cdir = canonDir dir+ c | cdir == hu = '-'+ | cdir == hv = '\\'+ | cdir == hw = '/'+ | otherwise = '?'+ a = if principal then bold else a0 in (c,a) tileChar HookTile = ('@',bold) tileChar (WrenchTile mom) = ('*',if mom /= zero then bold else a0)@@ -74,8 +77,10 @@ tileChar (SpringTile Stretched _) = ('s',bold) tileChar _ = ('?',bold) -ownedTileGlyph :: PieceColouring -> [PieceIdx] -> OwnedTile -> Glyph-ownedTileGlyph colouring reversed (owner,t) =+ownedTileGlyph :: Bool -> PieceColouring -> [PieceIdx] -> OwnedTile -> Glyph+ownedTileGlyph mono@True colouring reversed ot =+ Glyph (monochromeOTileChar colouring ot) white a0+ownedTileGlyph mono@False colouring reversed (owner,t) = let (ch,attr) = tileChar t pair = case Map.lookup owner colouring of Nothing -> 0
CursesUI.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -35,19 +35,21 @@ import CursesRender import CVec -data UIState = UIState { dispCPairs::[Curses.Pair], dispCentre::HexPos- , dispLastCol::PieceColouring, uiKeyBindings :: Map InputMode KeyBindings+data UIState = UIState+ { dispCPairs::[Curses.Pair]+ , dispCentre::HexPos+ , dispLastCol::PieceColouring+ , uiKeyBindings :: Map InputMode KeyBindings+ , monochrome::Bool , message::Maybe (Curses.Attr, ColPair, String)} type UIM = StateT UIState IO-nullUIState = UIState [] (PHS zero) Map.empty Map.empty Nothing+nullUIState = UIState [] (PHS zero) Map.empty Map.empty False Nothing readBindings :: UIM ()-readBindings = do +readBindings = void.runMaybeT $ do path <- liftIO $ confFilePath "bindings"- mbdgs <- liftIO $ readReadFile path- case mbdgs of- Just bdgs -> modify $ \s -> s {uiKeyBindings = bdgs}- Nothing -> return ()+ bdgs <- MaybeT $ liftIO $ readReadFile path+ lift $ modify $ \s -> s {uiKeyBindings = bdgs} writeBindings :: UIM () writeBindings = do path <- liftIO $ confFilePath "bindings"@@ -56,15 +58,14 @@ liftIO $ writeFile path $ show bdgs getBindings mode = do- uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings+ uibdgs <- Map.findWithDefault [] mode <$> gets uiKeyBindings return $ uibdgs ++ bindings mode bindingsStr :: InputMode -> [Command] -> UIM String bindingsStr mode cmds = do- uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings- return $ (\x -> "["++x++"]") $ intercalate "," $- [ maybe "" showKey $ findBinding (uibdgs ++ bindings mode) cmd- | cmd <- cmds ]+ bdgs <- getBindings mode+ return $ (("["++).(++"]")) $ intercalate "," $+ map (maybe "" showKey . findBinding bdgs) cmds erase :: UIM ()@@ -74,7 +75,7 @@ type Geom = (CVec, HexPos) getGeom :: UIM Geom-getGeom = do +getGeom = do (h,w) <- liftIO Curses.scrSize centre <- gets dispCentre return (CVec (h`div`2) (w`div`2), centre)@@ -101,7 +102,7 @@ drawCursorAt :: Maybe HexPos -> UIM () drawCursorAt Nothing = void $ liftIO $ Curses.cursSet Curses.CursorInvisible-drawCursorAt (Just pos) = do +drawCursorAt (Just pos) = do geom@(scrCentre,centre) <- getGeom liftIO $ Curses.cursSet Curses.CursorVisible liftIO $ move $ scrCentre <+> (hexVec2CVec $ pos <-> centre)@@ -112,11 +113,11 @@ colouring <- drawStateWithGeom reversed colourFixed lastCol st =<< getGeom modify $ \ds -> ds { dispLastCol = colouring } --- TODO: monochrome mode drawStateWithGeom reversed colourFixed lastCol st geom = do let colouring = boardColouring st (colouredPieces colourFixed st) lastCol- sequence_ [ drawAtWithGeom glyph pos geom | - (pos,glyph) <- Map.toList $ fmap (ownedTileGlyph colouring reversed) $ stateBoard st+ mono <- gets monochrome+ sequence_ [ drawAtWithGeom glyph pos geom |+ (pos,glyph) <- Map.toList $ fmap (ownedTileGlyph mono colouring reversed) $ stateBoard st ] return colouring @@ -135,6 +136,6 @@ (h,w) <- liftIO Curses.scrSize drawStrCentred a0 white (CVec 0 (w`div`2)) title drawTitle Nothing = return ()- + say = setMsgLine bold white sayError = setMsgLine bold red
CursesUIMInstance.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -47,15 +47,15 @@ import CVec -drawName :: Bool -> CVec -> Codename -> StateT MainState UIM ()+drawName :: Bool -> CVec -> Codename -> MainStateT UIM () drawName showScore pos name = do ourName <- (authUser <$>) <$> gets curAuth relScore <- getRelScore name let (attr,col) = case relScore of Just 0 -> (a0,yellow)- Just 1 -> (bold,cyan) - Just 2 -> (a0,green) - Just 3 -> (bold,green) + Just 1 -> (bold,cyan)+ Just 2 -> (a0,green)+ Just 3 -> (bold,green) Just (-1) -> (bold,magenta) Just (-2) -> (a0,red) Just (-3) -> (bold,red)@@ -63,14 +63,30 @@ lift $ drawStrCentred attr col pos (name ++ if showScore then " " ++ maybe "" show relScore else "") -drawActiveLock :: CVec -> ActiveLock -> StateT MainState UIM ()-drawActiveLock pos (ActiveLock name i) = do+drawActiveLock :: CVec -> ActiveLock -> MainStateT UIM ()+drawActiveLock pos al@(ActiveLock name i) = do+ accessed <- accessedAL al+ drawNameWithChar pos name+ (if accessed then green else white)+ (lockIndexChar i)++drawNameWithChar :: CVec -> Codename -> ColPair -> Char -> MainStateT UIM ()+drawNameWithChar pos name charcol char = do drawName False (pos <+> CVec 0 (-1)) name- lift $ drawStr bold white (pos <+> CVec 0 1) [':',lockIndexChar i]+ lift $ drawStr bold charcol (pos <+> CVec 0 1) [':',char] +drawNote :: CVec -> NoteInfo -> MainStateT UIM ()+drawNote pos note = case noteBehind note of+ Just al -> drawActiveLock pos al+ Nothing -> drawPublicNote pos (noteAuthor note)+ where+ drawPublicNote pos name =+ drawNameWithChar pos name magenta 'P'++ data Gravity = GravUp | GravLeft | GravRight | GravDown | GravCentre deriving (Eq, Ord, Show, Enum)-fillBox :: CVec -> CVec -> Int -> Gravity -> [CVec -> StateT MainState UIM ()] -> StateT MainState UIM Int+fillBox :: CVec -> CVec -> Int -> Gravity -> [CVec -> MainStateT UIM ()] -> MainStateT UIM Int fillBox (CVec t l) (CVec b r) width grav draws = do let half = width`div`2 starty = (if grav == GravDown then b else t)@@ -117,17 +133,19 @@ ] startOn <-- if (public lockinfo) + if (public lockinfo) then lift $ drawStrCentred bold white (CVec (lockTop-1) vcentre) "Everyone!" >> return (lockTop-1) else if null $ accessedBy lockinfo then lift $ drawStrCentred a0 white (CVec (lockTop-1) vcentre) "No-one" >> return (lockTop-1) else- fillBox (CVec (top+1) (left+1)) (CVec (lockTop-1) (right-1)) 3 GravDown $- [ \pos -> drawName False pos name | name <- accessedBy lockinfo ]+ 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:"- + undecls <- gets undeclareds if isJust $ guard . (|| public lockinfo) . (`elem` accessedBy lockinfo) =<< ourName then lift $ drawStrCentred a0 green (CVec (lockBottom+1) vcentre) "Accessed!"@@ -186,7 +204,7 @@ drawMainState' (EditState { esGameStateStack=(st:_), selectedPiece=selPiece, selectedPos=selPos }) = lift $ do drawState (maybeToList selPiece) True [] st drawCursorAt $ if isNothing selPiece then Just selPos else Nothing- drawMainState' (MetaState saddr undecls cOnly auth names _ _ rnamestvar _ _ mretired path lock _) = do+ drawMainState' (MetaState saddr undecls cOnly auth names _ _ _ rnamestvar _ _ mretired path lock _) = do let ourName = liftM authUser auth let selName = listToMaybe names let home = isJust ourName && ourName == selName@@ -243,10 +261,10 @@ void $ fillBox (CVec 2 5) (CVec 5 (w`div`3)) 3 GravCentre [ \pos -> drawName False pos name | name <- rnames ] when (ourName /= selName) $ void $ runMaybeT $ do- sel <- MaybeT $ return selName- us <- MaybeT $ return ourName+ sel <- liftMaybe selName+ us <- liftMaybe ourName ourUInfo <- mgetUInfo us- let accessed = [ ActiveLock us i + let accessed = [ ActiveLock us i | i<-[0..2] , Just lock <- [ userLocks ourUInfo ! i ] , public lock || selName `elem` map Just (accessedBy lock) ]@@ -262,7 +280,7 @@ reportAlerts _ alerts = do mapM_ drawAlert alerts- unless (null alerts) + unless (null alerts) $ do refresh liftIO $ threadDelay $ 5*10^4 where@@ -306,13 +324,14 @@ bdgs <- getBindings mode return $ maybe "" showKey $ findBinding bdgs cmd - initUI = - do liftIO CursesH.start - cpairs <- liftIO $ colorsToPairs [ (f, CursesH.black) | f <-- [ CursesH.white, CursesH.red, CursesH.green, CursesH.yellow, CursesH.blue, CursesH.magenta, CursesH.cyan] ] - modify $ \s -> s {dispCPairs = cpairs}- readBindings- return True+ initUI = do+ liftIO CursesH.start+ cpairs <- liftIO $ colorsToPairs [ (f, CursesH.black)+ | f <- [ CursesH.white, CursesH.red, CursesH.green, CursesH.yellow+ , CursesH.blue, CursesH.magenta, CursesH.cyan] ]+ modify $ \s -> s {dispCPairs = cpairs}+ readBindings+ return True endUI = do writeBindings@@ -320,8 +339,8 @@ unblockInput = return $ Curses.ungetCh 0 suspend = do liftIO $ do- CursesH.suspend - Curses.resetParams + CursesH.suspend+ Curses.resetParams redraw redraw = liftIO $ do Curses.endWin@@ -329,6 +348,8 @@ warpPointer _ = return () setYNButtons = return ()++ toggleColourMode = modify $ \s -> s {monochrome = not $ monochrome s} getDrawImpatience = return $ \_ -> return ()
Database.hs view
@@ -3,15 +3,15 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/. module Database where --- TODO: use ByteString everywhere-+import Data.Maybe+import Data.Tuple (swap) import Control.Applicative import Control.Monad import System.IO@@ -22,10 +22,6 @@ import qualified Data.ByteString.Lazy.Char8 as CL import qualified Data.ByteString.Char8 as CS ---import OpenSSL.Digest (MessageDigest(SHA1), toHex)---import OpenSSL.Digest.ByteString.Lazy (digest)---import Data.Digest.Pure.SHA (sha1, showDigest)---see also OpenSSL.EVP.Digest from HsOpenSSL import Crypto.Hash (hashlazy, Digest, SHA1, digestToHexByteString) import Protocol@@ -33,8 +29,6 @@ import Lock import Mundanities ---hash :: String -> IO String---hash str = fmap (>>=toHex) $ digest SHA1 $ CL.pack $ str sha1 :: CL.ByteString -> Digest SHA1 sha1 = hashlazy hash :: String -> String@@ -84,7 +78,9 @@ askForRecord _ = error "no corresponding request" type DBM = ReaderT FilePath IO- +withDB :: FilePath -> DBM a -> IO a+withDB = flip runReaderT+ recordExists :: Record -> DBM Bool recordExists rec = recordPath rec >>= liftIO . doesFileExist @@ -103,19 +99,19 @@ getRecordh (RecRetiredLocks name) h = ((RCLockSpecs <$>) . tryRead) <$> hGetStrict h getRecordh RecServerInfo h = ((RCServerInfo <$>) . tryRead) <$> hGetStrict h -hGetStrict h = CS.unpack `liftM` concatMWhileNonempty (repeat $ CS.hGet h 1024)+hGetStrict h = CS.unpack <$> concatMWhileNonempty (repeat $ CS.hGet h 1024) where concatMWhileNonempty (m:ms) = do bs <- m if CS.null bs then return bs- else (bs `CS.append`) `liftM` concatMWhileNonempty ms+ else (bs `CS.append`) <$> concatMWhileNonempty ms putRecord :: Record -> RecordContents -> DBM () putRecord rec rc = do path <- recordPath rec liftIO $ do- mkdirhierto path - h <- openFile path WriteMode + mkdirhierto path+ h <- openFile path WriteMode putRecordh rc h hClose h putRecordh (RCPassword hpw) h = hPutStr h $ show hpw@@ -129,12 +125,12 @@ modifyRecord :: Record -> (RecordContents -> RecordContents) -> DBM () modifyRecord rec f = do- h <- recordPath rec >>= liftIO . flip openFile ReadWriteMode + h <- recordPath rec >>= liftIO . flip openFile ReadWriteMode liftIO $ do Just rc <- getRecordh rec h hSeek h AbsoluteSeek 0 putRecordh (f rc) h- hTell h >>= hSetFileSize h + hTell h >>= hSetFileSize h hClose h delRecord :: Record -> DBM ()@@ -156,18 +152,19 @@ listUsers :: DBM [Codename] listUsers = do dbpath <- ask- liftIO $ (map unpathifyName . filter ((==3).length)) <$> getDirectoryContents (dbpath++[pathSeparator]++"users")+ liftIO $ (map unpathifyName . filter ((==3).length)) <$>+ getDirectoryContents (dbpath++[pathSeparator]++"users") recordPath :: Record -> DBM FilePath-recordPath rec = do- dbpath <- ask- return $ dbpath ++ [pathSeparator] ++ recordPath' rec+recordPath rec =+ (++ ([pathSeparator] ++ recordPath' rec)) <$> ask where recordPath' (RecPassword name) = userDir name ++ "passwd" recordPath' (RecUserInfo name) = userDir name ++ "info" recordPath' (RecUserInfoLog name) = userDir name ++ "log" recordPath' (RecLock ls) = locksDir ++ show ls- recordPath' (RecNote (NoteInfo name _ alock)) = userDir name ++ "notes" ++ [pathSeparator] ++ alockFN alock+ recordPath' (RecNote (NoteInfo name _ alock)) =+ userDir name ++ "notes" ++ [pathSeparator] ++ alockFN alock recordPath' (RecRetiredLocks name) = userDir name ++ "retired" recordPath' RecLockHashes = "lockHashes" recordPath' RecServerInfo = "serverInfo"@@ -176,26 +173,30 @@ alockFN (ActiveLock name idx) = pathifyName name ++":"++ show idx locksDir = "locks"++[pathSeparator] --- dummy out characters which are disallowed on unix or windows:-pathifyName = map $ \c -> case c of - '/'->'s'- '.'->'d'- '\\'->'b'- '<'->'l'- '>'->'g'- ':'->'c'- '|'->'p'- '?'->'q'- '*'->'a'- _ -> c-unpathifyName = map $ \c -> case c of - 's'->'/'- 'd'->'.'- 'b'->'\\'- 'l'->'<'- 'g'->'>'- 'c'->':'- 'p'->'|'- 'q'->'?'- 'a'->'*'- _ -> c +-- Dummy out characters which are disallowed on unix or dos.+-- We use lowercase characters as dummies.+-- To avoid collisions on case-insensitive filesystems, we use '_' as an+-- escape character.+pathifyName = concatMap $ \c ->+ fromMaybe [c] (('_':) . pure <$> lookup c pathifyAssocs)+unpathifyName = concatMap $ \c -> case c of+ '_' -> ""+ _ -> pure $ fromMaybe c (lookup c $ map swap pathifyAssocs)+pathifyAssocs =+ [ ('/','s')+ , ('.','d')+ , ('\\','b')+ , ('<','l')+ , ('>','g')+ , (':','c')+ , ('|','p')+ , ('?','q')+ , ('*','a')+ , ('+','t')+ , (',','m')+ , (';','i')+ , ('=','e')+ , ('[','k')+ , (']','j')+ , ('_','u')+ ]
Debug.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -17,4 +17,3 @@ prettyTrace = Trace.trace . ppShow prettyTraceVal :: Show a => a -> a prettyTraceVal x = prettyTrace x x-
EditGameState.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -22,7 +22,7 @@ import GameState import GameStateTypes --import Debug- + modTile :: Maybe Tile -> HexPos -> HexPos -> Bool -> GameState -> GameState modTile tile pos lastPos painting st = let board = stateBoard st@@ -78,7 +78,7 @@ in case addToIdx of Nothing -> addPiece $ Block [zero] Just b -> addBlockPos b pos- Just (ArmTile armdir _) -> + Just (ArmTile armdir _) -> let adjacentPivots = [ idx | dir <- if armdir == zero then hexDirs else [armdir, neg armdir] , Just (idx, PivotTile _) <- [Map.lookup (dir <+> pos) board'] ]@@ -117,7 +117,7 @@ Just conn -> addConn conn Just (PivotTile _) -> addPiece $ Pivot [] Just (WrenchTile _) -> addPiece $ Wrench zero- Just HookTile -> let arm = listToMaybe [ dir | + Just HookTile -> let arm = listToMaybe [ dir | dir <- hexDirs , isNothing $ Map.lookup (dir <+> pos) board' ] in case arm of Just armdir -> addPiece $ Hook armdir NullHF@@ -152,5 +152,4 @@ let st' = fst $ delPiecePos idx pos st (idx'',_) <- Map.lookup (dir<+>pos) $ stateBoard st' return $ addPivotArm idx'' pos st'- _ -> mzero
Frame.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -22,7 +22,7 @@ frameSize :: Frame -> Int frameSize (BasicFrame size) = size- + bolthole, entrance :: Frame -> HexVec bolthole (BasicFrame size) = size<*>hu <+> (size`div`2)<*>hv entrance f = neg $ bolthole f@@ -33,7 +33,7 @@ baseState :: Frame -> GameState baseState f =- GameState + GameState (Vector.fromList $ [ framePiece f, bolt ] ++ (initTools f)) [] where@@ -49,7 +49,7 @@ ++ (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] ] \\ + map (rotate r) [ (n<*>hu) <+> (size<*>hw) | n <- [0..size-1] ] | r <- [0..5] ] \\ [bolthole f, entrance f]) where bw = boltWidth f
GameState.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -35,7 +35,7 @@ getpp st idx = (placedPieces st) ! idx setpp :: PieceIdx -> PlacedPiece -> GameState -> GameState-setpp idx pp st@(GameState pps _) = +setpp idx pp st@(GameState pps _) = 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@@ -61,7 +61,7 @@ floodfill :: HexVec -> Set HexVec -> (Set HexVec, Set HexVec) floodfill start patt = floodfill' start `execState` (patt, Set.empty)- where + where floodfill' :: HexVec -> State (Set HexVec, Set HexVec) () floodfill' start = do (patt, dels) <- get@@ -87,7 +87,7 @@ _ -> st setPiece :: PieceIdx -> Piece -> GameState -> GameState-setPiece idx p st = +setPiece idx p st = setpp idx (PlacedPiece (placedPos $ getpp st idx) p) st adjustPieces :: (Piece -> Piece) -> GameState -> GameState@@ -123,23 +123,23 @@ springsAtIdx,springsEndAtIdx,springsRootAtIdx :: GameState -> PieceIdx -> [Connection] springsAtIdx st idx = [ c | c@(Connection (ridx,_) (eidx, _) (Spring _ _)) <- connections st- , idx `elem` [ridx,eidx] ]+ , idx `elem` [ridx,eidx] ] springsAtIdxIgnoring st idx idx' = [ c | c@(Connection (ridx,_) (eidx, _) (Spring _ _)) <- connections st- , idx `elem` [ridx,eidx], idx' `notElem` [ridx,eidx] ]+ , idx `elem` [ridx,eidx], idx' `notElem` [ridx,eidx] ] springsEndAtIdx st idx = [ c | c@(Connection _ (eidx, _) (Spring _ _)) <- connections st- , eidx==idx ]+ , eidx==idx ] springsRootAtIdx st idx = [ c | c@(Connection (ridx, _) _ (Spring _ _)) <- connections st- , ridx==idx ]+ , ridx==idx ] connectionsBetween :: GameState -> PieceIdx -> PieceIdx -> [Connection] connectionsBetween st idx idx' = filter connIsBetween $ connections st where connIsBetween conn = isPerm (idx,idx') (fst $ connectionRoot conn, fst $ connectionEnd conn)- isPerm (x,y) (x',y') = (x==x'&&y==y')||(x==y'&&y==x')+ isPerm = (==) `on` (\(x,y) -> Set.fromList [x,y]) connGraphPathExists :: GameState -> PieceIdx -> PieceIdx -> Bool connGraphPathExists st ridx eidx = (ridx == eidx) ||@@ -150,15 +150,16 @@ connGraphHeight st idx = maximum (0 : map ((+1) . connGraphHeight st . fst . connectionRoot) (springsEndAtIdx st idx)) -type DiGraph a = Map a (Set a)+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- checkDiGraphAcyclic dg = case listToMaybe $ leaves dg of+ 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- in checkDiGraphAcyclic $ Map.fromList + Just leaf -> checkDigraphAcyclic $ Map.delete leaf $ fmap (Set.delete leaf) dg+ in checkDigraphAcyclic $ Map.fromList [ (idx, Set.fromList $ map (fst.connectionRoot) $ springsEndAtIdx st idx) | idx <- idxs ] repossessConns :: GameState -> GameState -> GameState@@ -201,17 +202,23 @@ $ foldr (addpp . ppOfComp) st newComps, Just idx) _ -> (st,Nothing) -springExtended,springCompressed,springFullyExtended,springFullyCompressed :: GameState -> Connection -> Bool-springExtended st c@(Connection _ _ (Spring _ natLen)) = connectionLength st c > natLen+springExtended,springCompressed,springFullyExtended+ ,springFullyCompressed :: GameState -> Connection -> Bool+springExtended st c@(Connection _ _ (Spring _ natLen)) =+ connectionLength st c > natLen springExtended _ _ = False-springCompressed st c@(Connection _ _ (Spring _ natLen)) = connectionLength st c < natLen+springCompressed st c@(Connection _ _ (Spring _ natLen)) =+ connectionLength st c < natLen springCompressed _ _ = False-springFullyExtended st c@(Connection _ _ (Spring _ natLen)) = connectionLength st c >= 2*natLen+springFullyExtended st c@(Connection _ _ (Spring _ natLen)) =+ connectionLength st c >= 2*natLen springFullyExtended _ _ = False-springFullyCompressed st c@(Connection _ _ (Spring _ natLen)) = connectionLength st c <= (natLen+1)`div`2+springFullyCompressed st c@(Connection _ _ (Spring _ natLen)) =+ connectionLength st c <= (natLen+1)`div`2 springFullyCompressed _ _ = False-springExtensionValid st c@(Connection _ _ (Spring _ natLen)) = let l = connectionLength st c in - l >= (natLen+1)`div`2 && l <= 2*natLen+springExtensionValid st c@(Connection _ _ (Spring _ natLen)) =+ let l = connectionLength st c+ in l >= (natLen+1)`div`2 && l <= 2*natLen springExtensionValid _ _ = True stateBoard :: GameState -> GameBoard@@ -238,15 +245,14 @@ plPieceMap :: PlacedPiece -> Map HexPos Tile plPieceMap (PlacedPiece pos (Block pattern)) =- Map.fromList [ (rel <+> pos, BlockTile adjs) |- rel <- pattern+ Map.fromList [ (rel <+> pos, BlockTile adjs)+ | rel <- pattern , let adjs = filter (\dir -> rel <+> dir `elem` pattern) hexDirs ] plPieceMap (PlacedPiece pos (Pivot arms)) = let overarmed = length arms > 2 in- Map.fromList $ (pos, PivotTile $ if overarmed then (head arms) else zero ) : - [ (rel <+> pos, ArmTile rel main) |- (rel,main) <- zip arms $ repeat False -- overarmed:$repeat False- ]+ 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 _)) = Map.fromList $ (pos, HookTile) : [ (arm <+> pos, ArmTile arm True) ] plPieceMap (PlacedPiece pos (Wrench mom)) = Map.singleton pos $ WrenchTile mom@@ -318,7 +324,7 @@ && (validEnd st end) | c@(Connection root@(ridx,_) end@(eidx,_) (Spring dir _)) <- conns , let [rpos,epos] = map (locusPos st) [root,end] ]- , and [ 1 == length (components $ Set.fromList patt) + , and [ 1 == length (components $ Set.fromList patt) | Block patt <- map placedPiece $ Vector.toList pps ] ]
GameStateTypes.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.
GraphColouring.hs view
@@ -3,12 +3,12 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/. -module GraphColouring where+module GraphColouring (fiveColour) where import qualified Data.Map as Map import Data.Map (Map)@@ -22,71 +22,61 @@ type Graph a = (Set a, Set (Set a)) type PlanarGraph a = Map a [a] -fourColour :: Ord a => Graph a -> Colouring a -> Colouring a-fourColour (nodes,edges) lastCol =- -- bruteforce - if Map.keysSet lastCol == nodes && isColouring lastCol- then lastCol- else head $ filter isColouring colourings- where - isColouring mapping = and [- Map.lookup s mapping /= Map.lookup e mapping |- edge <- Set.toList edges- , [s,e] <- [Set.toList edge] ]- colourings = colourings' $ Set.toList nodes- colourings' [] = [ Map.empty ]- colourings' (n:ns) = [ Map.insert n c m |- m <- colourings' ns- , c <- [0..3] ]- fiveColour :: Ord a => PlanarGraph a -> Colouring a -> Colouring a -- ^algorithm based on that presented in--- http://people.math.gatech.edu/~thomas/PAP/fcstoc.pdf +-- http://people.math.gatech.edu/~thomas/PAP/fcstoc.pdf -- Key point: a planar graph can't have all vertices of degree >= 6 -- (Proof: suppose it does, so |E| >= 3|V|; WLOG the graph is triangulated, -- so then |F| <= 2/3 |E|. So \xi = |V|-|E|+|F| <= (1/3 - 1 + 2/3)|E| = 0. -- But a planar graph has Euler characteristic 1.)+-- Aims to minimise changes from given (partial) colouring lastCol. fiveColour g lastCol =- if Map.keysSet lastCol == Map.keysSet g && isColouring lastCol+ if Map.keysSet lastCol == Map.keysSet g && isColouring g lastCol then lastCol- else fiveColour' g- where- isColouring mapping = and [- Map.lookup s mapping /= Map.lookup e mapping |- s <- Map.keys g- , e <- g Map.! s ]- --fiveColour' :: PlanarGraph a -> Colouring a- fiveColour' g- | g == Map.empty = Map.empty- | otherwise =- let - adjsOf v = (nub $ g Map.! v) \\ [v]- v = head $ filter ((<=5) . length . adjsOf) $ Map.keys g- adjs = adjsOf v- addTo c = let vc = head $ possCols v \\ map (c Map.!) adjs- in Map.insert v vc c- in if length adjs < 5- then addTo $ fiveColour' $ deleteNode v g- else let (v',v'') = if adjs!!2 `elem` (g Map.! (adjs!!0))- then (adjs!!1,adjs!!3)- else (adjs!!0,adjs!!2)- in addTo $ demerge v' v'' $ fiveColour' $ merge v v' v'' g- --possCols :: a -> [Int]- possCols v = maybe [0..4] (\lvc -> lvc:([0..4] \\ [lvc])) $ Map.lookup v lastCol- --demerge :: a -> a -> Colouring a -> Colouring a- demerge v v' c = Map.insert v' (c Map.! v) c- --merge :: a -> a -> a -> PlanarGraph a -> PlanarGraph a- merge v v' v'' g =- deleteNode v $ contractNodes v' v''- $ Map.adjust (concatAdjsOver v $ g Map.! v'') v' g- --concatAdjsOver :: a -> [a] -> [a] -> [a]- concatAdjsOver v adjs adjs' =- let (s,_:e) = splitAt (fromJust $ elemIndex v adjs) adjs- in s ++ adjs' ++ e- deleteNode v =- fmap (filter (/= v)) . Map.delete v- contractNodes v v' =- fmap (map (\v'' -> if v'' == v' then v else v'')) . Map.delete v'- + else fiveColour' lastCol g +isColouring :: Ord a => PlanarGraph a -> Colouring a -> Bool+isColouring g mapping = and+ [ Map.lookup s mapping /= Map.lookup e mapping+ | s <- Map.keys g+ , e <- g Map.! s ] +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]+ v0 = head $ filter ((<=5) . length . adjsOf) $ Map.keys g+ adjs = adjsOf v0+ addTo c =+ let vc = head $ possCols pref v0 \\ map (c Map.!) adjs+ 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))+ then (adjs!!1,adjs!!3)+ else (adjs!!0,adjs!!2)+ in addTo $ demerge v' v'' $ fiveColour' pref $ merge v0 v' v'' g++possCols :: Ord a => Colouring a -> a -> [Int]+possCols pref v = maybe [0..4] (\lvc -> lvc:([0..4] \\ [lvc])) $ Map.lookup v pref++demerge :: Ord a => a -> a -> Colouring a -> Colouring a+demerge v v' c = Map.insert v' (c Map.! v) c++merge :: Ord a => a -> a -> a -> PlanarGraph a -> PlanarGraph a+merge v v' v'' g =+ deleteNode v $ contractNodes v' v''+ $ Map.adjust (concatAdjsOver v $ g Map.! v'') v' g++concatAdjsOver :: Ord a => a -> [a] -> [a] -> [a]+concatAdjsOver v adjs adjs' =+ let (s,_:e) = splitAt (fromJust $ elemIndex v adjs) adjs+ in s ++ adjs' ++ e++deleteNode :: Ord a => a -> PlanarGraph a -> PlanarGraph a+deleteNode v =+ fmap (filter (/= v)) . Map.delete v++contractNodes :: Ord a => a -> a -> PlanarGraph a -> PlanarGraph a+contractNodes v v' =+ fmap (map (\v'' -> if v'' == v' then v else v'')) . Map.delete v'
Init.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -20,43 +20,46 @@ import System.Exit import System.Environment import System.Directory+import System.FilePath import System.Console.GetOpt -import Mundanities-import AsciiLock import Lock import MainState import Interact+import Util -data Opt = LockSize Int | ForceCurses+data Opt = LockSize Int | ForceCurses | Help deriving (Eq, Ord, Show) options = [ Option ['c'] ["curses"] (NoArg ForceCurses) "force curses UI"- -- , Option ['s'] ["locksize"] (ReqArg (LockSize . read) "SIZE") "locksize"+ , Option ['s'] ["locksize"] (ReqArg (LockSize . read) "SIZE") "locksize"+ , Option ['h'] ["help"] (NoArg Help) "show usage information" ]++usage :: String+usage = usageInfo header options+ where header = "Usage: intricacy [OPTION...] [file]"+ parseArgs :: [String] -> IO ([Opt],[String]) parseArgs argv = case getOpt Permute options argv of (o,n,[]) -> return (o,n)- (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))- where header = "Usage: intricacy [OPTION...] [file]"+ (_,_,errs) -> ioError (userError (concat errs ++ usage)) setup :: IO (Maybe Lock,[Opt],Maybe String) setup = do argv <- getArgs (opts,args) <- parseArgs argv- --let frameSize = fromMaybe 8 $ listToMaybe [ size | LockSize size <- opts ]- (fromJust <$>) $ runMaybeT $ msum [ do- rpath <- MaybeT $ return $ listToMaybe args- msum [ do- path <- MaybeT $ (Just <$> canonicalizePath rpath)- `catchIO` (const $ return Nothing)- lock <- reframe.fst <$> MaybeT (readLock path)- return (Just lock,opts,Just path)- , do- lift $ putStrLn $ "Failed to open lock file: "++rpath- lift $ exitFailure- mzero ]+ when (Help `elem` opts) $ putStr usage >> exitSuccess+ let size = fromMaybe 8 $ listToMaybe [ size | LockSize size <- opts ]+ curDir <- getCurrentDirectory+ (fromJust <$>) $ runMaybeT $ msum+ [ do+ path <- liftMaybe ((curDir </>) <$> listToMaybe args)+ msum [ do+ lock <- reframe.fst <$> MaybeT (readLock path)+ return (Just lock,opts,Just path)+ , return (Just $ baseLock size, opts, Just path) ] , return (Nothing,opts,Nothing) ] main' :: (UIMonad s, UIMonad c) =>@@ -68,13 +71,13 @@ Nothing -> initMetaState Just lock -> return $ newEditState lock Nothing mpath void $ runMaybeT $ msum [ do- finalState <- msum + finalState <- msum [ do guard $ ForceCurses `notElem` opts- sdlUI <- MaybeT . return $ msdlUI+ sdlUI <- liftMaybe $ msdlUI MaybeT $ sdlUI $ interactUI `execStateT` initMState , do- cursesUI <- MaybeT . return $ mcursesUI+ cursesUI <- liftMaybe $ mcursesUI MaybeT $ cursesUI $ interactUI `execStateT` initMState ] when (isNothing mlock) $ lift $ writeMetaState finalState
InputMode.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.
Interact.hs view
@@ -3,12 +3,12 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/. -module Interact (interactUI) where +module Interact (interactUI) where import Control.Monad.State import Control.Applicative@@ -27,6 +27,7 @@ import System.FilePath import Data.Array import Data.Function (on)+import Safe (readMay) import Hex import Command@@ -47,16 +48,17 @@ import InputMode import Maxlocksize import InteractUtil+import Util -interactUI :: UIMonad uiM => StateT MainState uiM InteractSuccess+newtype InteractSuccess = InteractSuccess Bool+instance Error InteractSuccess where+ noMsg = InteractSuccess False++interactUI :: UIMonad uiM => MainStateT uiM InteractSuccess interactUI = do lift $ drawMessage ""- (IMMeta==) . ms2im <$> get >>= flip when (void $ do- flag <- gets newAsync- unblock <- lift unblockInput- _ <- liftIO $ forkIO $ forever $ do- atomically $ readTVar flag >>= check >> writeTVar flag False- unblock+ (==IMMeta) <$> gets ms2im >>? do+ spawnUnblockerThread -- draw before testing auth, lest a timeout mean a blank screen drawMainState@@ -64,60 +66,64 @@ testAuth refreshUInfoUI tbdg <- lift $ getUIBinding IMMeta CmdTutorials- (isNothing <$> gets curAuth >>=) $ flip when $+ isNothing <$> gets curAuth >>? lift $ drawMessage $ "Welcome. To play the tutorial levels, press '"++tbdg++"'."- ) setMark startMark- loop+ interactLoop where- loop = do+ interactLoop = do mainSt <- get let im = ms2im mainSt when (im == IMPlay) checkWon- when (im == IMMeta) $ (checkAsyncErrors >>) $ void.runMaybeT $ - mourNameSelected >>=- flip when (lift purgeInvalidUndecls)+ when (im == IMMeta) $ (checkAsync >>) $ void.runMaybeT $+ mourNameSelected >>? lift purgeInvalidUndecls drawMainState cmds <- lift $ getSomeInput im- runErrorT (mapM_ (processCommand im) cmds) >>= \x -> case x of- Left ret -> do- lift $ drawMessage ""- return ret- Right _ -> loop+ runErrorT (mapM_ (processCommand im) cmds) >>=+ either+ ((lift (drawMessage "") >>) . return)+ (const interactLoop) --- | TODO: neater would be to use a stream (see package 'pipes') for--- input?+ -- | unblock input whenever the newAsync TVar is set to True+ spawnUnblockerThread = do+ flag <- gets newAsync+ unblock <- lift unblockInput+ liftIO $ forkIO $ forever $ do+ atomically $ readTVar flag >>= check >> writeTVar flag False+ unblock+ getSomeInput im = do cmds <- getInput im if null cmds then getSomeInput im else return cmds -newtype InteractSuccess = InteractSuccess Bool-instance Error InteractSuccess where- noMsg = InteractSuccess False--processCommand :: UIMonad uiM => InputMode -> Command -> ErrorT InteractSuccess (StateT MainState uiM) ()+processCommand :: UIMonad uiM => InputMode -> Command -> ErrorT InteractSuccess (MainStateT uiM) () processCommand im CmdQuit = do case im of IMReplay -> throwError $ InteractSuccess False- IMPlay -> lift (gets psIsSub) >>= flip when (throwError $ InteractSuccess False)- IMEdit -> lift editStateUnsaved >>= flip unless (throwError $ InteractSuccess True)+ IMPlay -> lift (or <$> sequence [gets psIsSub, null <$> gets psGameStateMoveStack])+ >>? throwError $ InteractSuccess False+ IMEdit -> lift editStateUnsaved >>! throwError $ InteractSuccess True _ -> return () title <- lift $ getTitle- really <- lift $ lift $ confirm $ "Really quit" ++ maybe "" (" from "++) title ++ "?"- when really $ throwError $ InteractSuccess False+ (lift . lift . confirm) ("Really quit"+ ++ (if im == IMEdit then " without saving" else "")+ ++ maybe "" (" from "++) title ++ "?")+ >>? throwError $ InteractSuccess False processCommand im CmdForceQuit = throwError $ InteractSuccess False processCommand IMPlay CmdOpen = do st <- gets psCurrentState frame <- gets psFrame- if checkSolved (frame,st) then throwError $ InteractSuccess True else lift.lift $ drawError "Locked!"+ if checkSolved (frame,st)+ then throwError $ InteractSuccess True+ else lift.lift $ drawError "Locked!" processCommand im cmd = lift $ processCommand' im cmd -processCommand' :: UIMonad uiM => InputMode -> Command -> StateT MainState uiM ()+processCommand' :: UIMonad uiM => InputMode -> Command -> MainStateT uiM () processCommand' im CmdHelp = lift $ do showHelp im void $ textInput "[press a key or RMB]" 1 False True Nothing Nothing-processCommand' im CmdBind = lift $ flip (>>) (drawMessage "") $ void $ runMaybeT $ do+processCommand' im CmdBind = lift $ (>> drawMessage "") $ runMaybeT $ do lift $ drawMessage "Command to bind: " cmd <- msum $ repeat $ do cmd <- MaybeT $ listToMaybe <$> getInput im@@ -127,26 +133,27 @@ ch <- MaybeT getChRaw guard $ ch /= '\ESC' lift $ setUIBinding im cmd ch--processCommand' _ CmdSuspend = lift $ suspend-processCommand' _ CmdRedraw = lift $ redraw+processCommand' _ CmdToggleColourMode = lift toggleColourMode+processCommand' _ CmdSuspend = lift suspend+processCommand' _ CmdRedraw = lift redraw processCommand' im CmdMark = void.runMaybeT $ do guard $ im `elem` [IMEdit, IMPlay, IMReplay] str <- MaybeT $ lift $ textInput "Mark: " 1 False True Nothing Nothing- ch <- MaybeT $ return $ listToMaybe str+ ch <- liftMaybe $ listToMaybe str guard $ ch `notElem` [startMark, '\''] lift $ setMark ch processCommand' im CmdJumpMark = void.runMaybeT $ do guard $ im `elem` [IMEdit, IMPlay, IMReplay] str <- MaybeT $ lift $ textInput "Jump to mark (\"'\" to unjump): " 1 False True Nothing Nothing- ch <- MaybeT $ return $ listToMaybe str+ ch <- liftMaybe $ listToMaybe str lift $ jumpMark ch processCommand' im CmdReset = jumpMark startMark processCommand' IMMeta (CmdSelCodename mname) = void.runMaybeT $ do- name <- msum [ MaybeT $ return $ mname+ name <- msum [ liftMaybe $ mname , do- newCodename <- (map toUpper <$>) $ MaybeT $ lift $ textInput "Codename:" 3 False True Nothing Nothing+ newCodename <- (map toUpper <$>) $ MaybeT $ lift $+ textInput "Codename:" 3 False True Nothing Nothing guard $ length newCodename == 3 return newCodename ]@@ -168,14 +175,13 @@ processCommand' IMMeta CmdSetServer = void.runMaybeT $ do saddr <- gets curServer saddrs <- liftIO $ knownServers- newSaddrstr <- MaybeT $ lift $ textInput "Set server:" 256 False False+ newSaddr <- MaybeT $ ((>>= strToSaddr) <$>) $+ lift $ textInput "Set server:" 256 False False (Just $ map saddrStr saddrs) (Just $ saddrStr saddr)- newSaddr <- MaybeT $ return $ strToSaddr newSaddrstr modify $ \ms -> ms { curServer = newSaddr }- unless (nullSaddr newSaddr) $- msum [ void $ MaybeT $ getFreshRecBlocking RecServerInfo- , modify $ \ms -> ms { curServer = saddr }- ]+ guard.not $ nullSaddr newSaddr+ msum [ void.MaybeT $ getFreshRecBlocking RecServerInfo+ , modify $ \ms -> ms { curServer = saddr } ] processCommand' IMMeta CmdToggleCacheOnly = not <$> gets cacheOnly >>= \c -> modify $ \ms -> ms {cacheOnly = c} @@ -186,7 +192,8 @@ confirmOrBail $ if isUs then "Really reset password?" else "Register codename "++newName++"?" passwd <- (hashPassword newName <$>) $ MaybeT $ lift $ textInput "Enter new password:" 64 True False Nothing Nothing- lift $ if isUs then do+ lift $ if isUs+ then do resp <- curServerAction $ ResetPassword passwd case resp of ServerAck -> do@@ -228,13 +235,13 @@ processCommand' IMMeta (CmdSolve midx) = void.runMaybeT $ do name <- mgetCurName uinfo <- mgetUInfo name- idx <- msum [ MaybeT $ return midx+ idx <- msum [ liftMaybe midx , askLockIndex "Solve which lock?" "No lock to solve!" (\i -> isJust $ userLocks uinfo ! i) ]- ls <- MaybeT $ return $ lockSpec <$> userLocks uinfo ! idx+ ls <- liftMaybe $ lockSpec <$> userLocks uinfo ! idx undecls <- lift (gets undeclareds) msum [ do- undecl <- MaybeT $ return $ find (\(Undeclared _ ls' _) -> ls == ls') undecls- _ <- MaybeT $ gets curAuth+ undecl <- liftMaybe $ find (\(Undeclared _ ls' _) -> ls == ls') undecls+ MaybeT $ gets curAuth confirmOrBail "Declare existing solution?" void.lift.runMaybeT $ -- ignores MaybeT failures declare undecl@@ -244,9 +251,9 @@ "solving " ++ name ++ ":" ++ [lockIndexChar idx] ++ " (#" ++ show ls ++")" mourName <- lift $ (authUser <$>) <$> gets curAuth guard $ mourName /= Just name- let undecl = Undeclared soln ls (ActiveLock name idx) + let undecl = Undeclared soln ls (ActiveLock name idx) msum [ do- _ <- MaybeT $ gets curAuth+ MaybeT $ gets curAuth confirmOrBail "Declare solution?" declare undecl , unless (any (\(Undeclared _ ls' _) -> ls == ls') undecls) $@@ -254,41 +261,44 @@ ] ] processCommand' IMMeta (CmdPlayLockSpec mls) = void.runMaybeT $ do- ls <- msum [ MaybeT $ return mls- , do + ls <- msum [ liftMaybe mls+ , do tls <- MaybeT . lift $ textInput "Lock number:" 16 False False Nothing Nothing- MaybeT . return $ fst <$> (listToMaybe $ (reads :: ReadS Int) tls)+ liftMaybe $ readMay tls ] RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls solveLock lock $ Just $ "solving " ++ show ls- + processCommand' IMMeta (CmdDeclare mundecl) = void.runMaybeT $ do- mourNameSelected >>= guard+ guard =<< mourNameSelected name <- mgetCurName undecls <- lift $ gets undeclareds guard $ not $ null undecls- declare =<< msum [ MaybeT $ return mundecl+ declare =<< msum [ liftMaybe mundecl , if length undecls == 1 then return $ head undecls else do which <- MaybeT $ lift $ textInput ("Declare which solution?") 5 False True Nothing Nothing- MaybeT $ return $ msum+ liftMaybe $ msum [ do- i <- fst <$> (listToMaybe $ (reads :: ReadS Int) which)+ i <- readMay which guard $ 0 < i && i <= length undecls return $ undecls !! (i-1)- , listToMaybe $ [ undecl+ , listToMaybe $+ [ undecl | undecl@(Undeclared _ _ (ActiveLock name' i)) <- undecls- , or [ take (length which) (name' ++ ":" ++ [lockIndexChar i]) ==- map toUpper which + , or+ [ take (length which) (name' ++ ":" ++ [lockIndexChar i]) ==+ map toUpper which , name'==name && [lockIndexChar i] == which- ] ]+ ]+ ] ] ] processCommand' IMMeta (CmdViewSolution mnote) = void.runMaybeT $ do- note <- msum [ MaybeT $ return mnote, do+ note <- liftMaybe mnote `mplus` do ourName <- mgetOurName name <- mgetCurName uinfo <- mgetUInfo name@@ -296,21 +306,20 @@ [ case mlockinfo of Nothing -> return [] Just lockinfo -> (++lockSolutions lockinfo) <$> do- ns <- getNotesReadOn lockinfo + ns <- getNotesReadOn lockinfo return $ if length ns < 3 then [] else ns | 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 author <- if length notes == 1- then return $ noteAuthor $ head notes + 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- MaybeT $ return $ find ((==author).noteAuthor) notes- ]+ liftMaybe $ find ((==author).noteAuthor) notes let ActiveLock name idx = noteOn note uinfo <- mgetUInfo name ls <- lockSpec <$> MaybeT (return $ userLocks uinfo ! idx)@@ -320,26 +329,22 @@ "viewing solution by " ++ noteAuthor note ++ " to " ++ name ++ [':',lockIndexChar idx] processCommand' IMMeta (CmdPlaceLock midx) = void.runMaybeT $ do- mourNameSelected >>= guard+ guard =<< mourNameSelected ourName <- mgetOurName- (lock,msoln) <- msum [MaybeT $ gets curLock- , do- ebdg <- lift.lift $ getUIBinding IMMeta CmdEdit- lift.lift $ drawError $ "No lock selected; '"++ebdg++"' to edit one."- mzero]+ (lock,msoln) <- MaybeT (gets curLock) `mplus` do+ ebdg <- lift.lift $ getUIBinding IMMeta CmdEdit+ lift.lift $ drawError $ "No lock selected; '"++ebdg++"' to edit one."+ mzero lockpath <- lift $ gets curLockPath ourUInfo <- mgetUInfo ourName- idx <- msum [ MaybeT $ return midx- , askLockIndex ("Place " ++ show lockpath ++ " in which slot?") "bug" $ const True- ]+ idx <- (liftMaybe midx `mplus`) $+ askLockIndex ("Place " ++ show lockpath ++ " in which slot?") "bug" $ const True when (isJust $ userLocks ourUInfo ! idx) $ confirmOrBail "Really retire existing lock?"- soln <- msum [ MaybeT $ return msoln,- solveLock lock $ Just $ "testing lock" ]- lift $ do - curServerActionAsync $ SetLock lock idx soln- invalidateUInfo ourName- refreshUInfoUI+ soln <- (liftMaybe msoln `mplus`) $ solveLock lock $ Just $ "testing lock"+ lift $ curServerActionAsyncThenInvalidate+ (SetLock lock idx soln)+ (Just (SomeCodenames [ourName])) processCommand' IMMeta CmdSelectLock = void.runMaybeT $ do lockdir <- liftIO $ confFilePath "locks"@@ -355,24 +360,23 @@ processCommand' IMMeta CmdPrevPage = modify $ \ms -> ms { listOffset = max 0 $ listOffset ms - 1 } processCommand' IMMeta CmdEdit = void.runMaybeT $ do- (lock, msoln) <- msum [ MaybeT $ gets curLock- , do- frame <- BasicFrame <$> msum [ do- _ <- gets curServer- RCServerInfo (ServerInfo size _) <- MaybeT $ getFreshRecBlocking RecServerInfo- return size- , do- sizet <- MaybeT $ lift $ textInput- ("Lock size: [3-" ++ show maxlocksize ++ "]") 2 False False Nothing Nothing- size <- MaybeT $ return $ fst <$> (listToMaybe $ (reads :: ReadS Int) sizet)- guard $ 3 <= size && size <= maxlocksize- return size- ]- return ((frame, baseState frame), Nothing)- ]+ (lock, msoln) <- (MaybeT $ gets curLock) `mplus` do+ size <- msum+ [ do+ gets curServer+ RCServerInfo (ServerInfo size _) <- MaybeT $ getFreshRecBlocking RecServerInfo+ return size+ , do+ sizet <- MaybeT $ lift $ textInput+ ("Lock size: [3-" ++ show maxlocksize ++ "]") 2 False False Nothing Nothing+ size <- liftMaybe $ readMay sizet+ guard $ 3 <= size && size <= maxlocksize+ return size+ ]+ return (baseLock size, Nothing) path <- lift $ gets curLockPath- newPath <- MaybeT $ lift $ (esPath <$>) $ execStateT interactUI $ newEditState (reframe lock)- msoln (if null path then Nothing else Just path)+ newPath <- MaybeT $ lift $ (esPath <$>) $ execStateT interactUI $+ 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"@@ -383,7 +387,7 @@ mzero -- s <- MaybeT $ lift $ textInput ("Play which tutorial level? [1-"++show (length tuts)++"]") -- (length (show (length tuts))) False True Nothing Nothing- -- i <- MaybeT $ return $ fst <$> (listToMaybe $ (reads :: ReadS Int) s)+ -- i <- liftMaybe $ readMay s -- guard $ 1 <= i && i <= length tuts let i = 1 let dotut i = do@@ -391,11 +395,11 @@ let pref = tutdir ++ [pathSeparator] ++ name (lock,_) <- MaybeT $ liftIO $ readLock (pref ++ ".lock") text <- liftIO $ (fromMaybe "" . listToMaybe) <$> (readStrings (pref ++ ".text") `catchIO` const (return []))- _ <- solveLock lock $ Just $ "Tutorial " ++ show i ++ ": " ++ text+ solveLock 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- else lift $ do + else lift $ do mauth <- gets curAuth cbdg <- lift $ getUIBinding IMMeta $ CmdSelCodename Nothing rbdg <- lift $ getUIBinding IMMeta CmdRegister@@ -412,7 +416,7 @@ return $ Just lss Just _ -> return Nothing lift $ modify $ \ms -> ms {retiredLocks = newRL}- + processCommand' IMPlay CmdUndo = do st <- gets psCurrentState stack <- gets psGameStateMoveStack@@ -423,7 +427,7 @@ psLastAlerts = [], psUndoneStack = (st,pm):ustms} processCommand' IMPlay CmdRedo = do ustms <- gets psUndoneStack- case ustms of + case ustms of [] -> return () ustm:ustms' -> do pushPState ustm@@ -432,11 +436,11 @@ board <- stateBoard <$> gets psCurrentState wsel <- gets wrenchSelected void.runMaybeT $ msum $ [ do- tile <- MaybeT $ return $ snd <$> Map.lookup pos board+ tile <- liftMaybe $ snd <$> Map.lookup pos board guard $ case tile of {WrenchTile _ -> True; HookTile -> True; _ -> False} lift $ processCommand' IMPlay $ CmdTile tile ] ++ [ do- tile <- MaybeT $ return $ snd <$> Map.lookup (d<+>pos) board+ 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 ]@@ -444,12 +448,12 @@ board <- stateBoard <$> gets psCurrentState wsel <- gets wrenchSelected void.runMaybeT $ do- tile <- MaybeT $ return $ snd <$> Map.lookup pos board+ tile <- liftMaybe $ snd <$> Map.lookup pos board guard $ case tile of {WrenchTile _ -> True; HookTile -> True; _ -> False} lift $ processCommand' IMPlay $ CmdDir WHSSelected $ dir board' <- stateBoard <$> gets psCurrentState msum [ do- tile' <- MaybeT $ return $ snd <$> Map.lookup pos' board'+ tile' <- liftMaybe $ snd <$> Map.lookup pos' board' guard $ tileType tile' == if wsel then WrenchTile zero else HookTile lift.lift $ warpPointer $ pos' | pos' <- map (<+>pos) $ hexDisc 2 ]@@ -457,11 +461,11 @@ processCommand' IMPlay cmd = do wsel <- gets wrenchSelected st <- gets psCurrentState- let push whs dir + let push whs dir | whs == WHSWrench || (whs == WHSSelected && wsel) = Just $ WrenchPush dir | otherwise = Just $ HookPush dir- torque whs dir + torque whs dir | whs == WHSHook || (whs == WHSSelected && not wsel)= Just $ HookTorque dir | otherwise = Nothing@@ -487,6 +491,7 @@ processCommand' IMReplay (CmdReplayBack 1) = void.runMaybeT $ do (st',pm) <- MaybeT $ listToMaybe <$> gets rsGameStateMoveStack lift $ modify $ \rs -> rs {rsCurrentState=st'+ , rsLastAlerts = [] , rsGameStateMoveStack = tail $ rsGameStateMoveStack rs , rsMoveStack = pm:rsMoveStack rs} processCommand' IMReplay (CmdReplayBack n) = replicateM_ n $@@ -495,8 +500,9 @@ pm <- MaybeT $ listToMaybe <$> gets rsMoveStack lift $ do st <- gets rsCurrentState- (st',_) <- lift $ doPhysicsTick pm st+ (st',alerts) <- lift $ doPhysicsTick pm st modify $ \rs -> rs {rsCurrentState = st'+ , rsLastAlerts = alerts , rsGameStateMoveStack = (st,pm):rsGameStateMoveStack rs , rsMoveStack = tail $ rsMoveStack rs} processCommand' IMReplay (CmdReplayForward n) = replicateM_ n $@@ -524,7 +530,7 @@ unless (null sts) $ modify $ \es -> es {esGameStateStack = sts, esUndoneStack = st:usts} processCommand' IMEdit CmdRedo = do usts <- gets esUndoneStack- case usts of + case usts of [] -> return () ust:usts' -> do pushEState ust@@ -554,12 +560,12 @@ board <- stateBoard.head <$> gets esGameStateStack void.runMaybeT $ do selIdx <- MaybeT $ gets selectedPiece- idx <- MaybeT $ return $ fst <$> Map.lookup pos board+ idx <- liftMaybe $ fst <$> Map.lookup pos board guard $ idx == selIdx lift $ processCommand' IMEdit $ CmdDir WHSSelected $ dir board' <- stateBoard.head <$> gets esGameStateStack msum [ do- idx' <- MaybeT $ return $ fst <$> Map.lookup pos' board'+ idx' <- liftMaybe $ fst <$> Map.lookup pos' board' guard $ idx' == selIdx lift.lift $ warpPointer $ pos' | pos' <- [dir<+>pos, pos] ]@@ -613,7 +619,7 @@ 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)) >>=) $ flip when $+ liftIO (doesFileExist fullPath `catchIO` const (return True)) >>? confirmOrBail $ "Really overwrite '"++fullPath++"'?" lift $ do st <- gets $ head.esGameStateStack@@ -631,11 +637,11 @@ -- ^ salt password hashPassword name password = hash $ "IY" ++ name ++ password -subPlay :: UIMonad uiM => Lock -> StateT MainState uiM ()+subPlay :: UIMonad uiM => Lock -> MainStateT uiM () subPlay lock = pushEState =<< psCurrentState <$> (lift $ execStateT interactUI $ newPlayState lock Nothing True) -solveLock :: UIMonad uiM => Lock -> Maybe String -> MaybeT (StateT MainState uiM) Solution+solveLock :: UIMonad uiM => Lock -> Maybe String -> MaybeT (MainStateT uiM) Solution solveLock lock title = do (InteractSuccess solved, ps) <- lift.lift $ runStateT interactUI $ newPlayState (reframe lock) title False guard $ solved
InteractUtil.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -12,7 +12,6 @@ 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@@ -37,8 +36,9 @@ import Metagame import MainState import InputMode+import Util -checkWon :: UIMonad uiM => StateT MainState uiM ()+checkWon :: UIMonad uiM => MainStateT uiM () checkWon = do st <- gets psCurrentState frame <- gets psFrame@@ -50,19 +50,11 @@ lift $ if solved then do drawMessage $ "Unlocked! '"++obdg++"' to open." reportAlerts st [AlertUnlocked]- else do- drawMessage ""- {-- pms <- (reverse.(map snd)) `liftM` gets psGameStateMoveStack- let wfname = fromMaybe "unnamed.lock" fname - liftIO $ writeFile (wfname++".solution") $ show pms- liftIO $ B.writeFile (wfname++".solution.bin") $ Bin.encode $ pms- -}+ else drawMessage ""+ doForce force = do st:_ <- gets esGameStateStack- let (st',alerts) = runWriter $ resolveForces- (Vector.singleton (ForceChoice [force])) Vector.empty- (\_ _->False) st+ let (st',alerts) = runWriter $ resolveSinglePlForce force st lift (reportAlerts st' alerts) >> pushEState st' drawTile pos tile painting = do modify $ \es -> es {selectedPiece = Nothing}@@ -74,17 +66,17 @@ else let from' = (hexVec2HexDirOrZero $ to<->from) <+> from in drawTile from' tile True >> paintTilePath tile from' to -pushEState :: UIMonad uiM => GameState -> StateT MainState uiM ()+pushEState :: UIMonad uiM => GameState -> MainStateT uiM () pushEState st = do st':sts <- gets esGameStateStack when (st' /= st) $ modify $ \es -> es {esGameStateStack = st:st':sts, esUndoneStack = []}-pushPState :: UIMonad uiM => (GameState,PlayerMove) -> StateT MainState uiM ()+pushPState :: UIMonad uiM => (GameState,PlayerMove) -> MainStateT uiM () pushPState (st,pm) = do st' <- gets psCurrentState stms <- gets psGameStateMoveStack when (st' /= st) $ modify $ \ps -> ps {psCurrentState = st, psGameStateMoveStack = (st',pm):stms, psUndoneStack = []}-modifyEState :: UIMonad uiM => (GameState -> GameState) -> StateT MainState uiM ()+modifyEState :: UIMonad uiM => (GameState -> GameState) -> MainStateT uiM () modifyEState f = do st:_ <- gets esGameStateStack pushEState $ f st@@ -118,32 +110,31 @@ ("You first need to place ('"++pbdg++"') a lock to secure your solution behind.") (\i -> isJust $ userLocks ourUInfo ! i) guard $ isJust $ userLocks ourUInfo ! idx- lift $ do- curServerActionAsync $ DeclareSolution soln ls al idx+ lift $ curServerActionAsyncThenInvalidate+ (DeclareSolution soln ls al idx) -- rather than recurse through the tree to find what scores may have -- changed as a result of this declaration, or leave it to timeouts -- and explicit refreshes to reveal it, we just invalidate all UInfos.- invalidateAllUInfo- refreshUInfoUI+ (Just AllCodenames) startMark = '^' -jumpMark :: UIMonad uiM => Char -> StateT MainState uiM ()+jumpMark :: UIMonad uiM => Char -> MainStateT uiM () jumpMark ch = do mst <- get void.runMaybeT $ case ms2im mst of IMEdit -> do- st <- MaybeT $ return $ ch `Map.lookup` esMarks mst+ st <- liftMaybe $ ch `Map.lookup` esMarks mst lift $ setMark '\'' >> pushEState st IMPlay -> do- mst' <- MaybeT $ return $ ch `Map.lookup` psMarks mst+ mst' <- liftMaybe $ ch `Map.lookup` psMarks mst put mst' { psMarks = Map.insert '\'' mst $ psMarks mst } IMReplay -> do- mst' <- MaybeT $ return $ ch `Map.lookup` rsMarks mst+ mst' <- liftMaybe $ ch `Map.lookup` rsMarks mst put mst' { rsMarks = Map.insert '\'' mst $ rsMarks mst } _ -> return () -setMark :: (Monad m) => Char -> StateT MainState m ()+setMark :: (Monad m) => Char -> MainStateT m () setMark ch = get >>= \mst -> case mst of -- ugh... remind me why I'm not using lens? EditState { esMarks = marks, esGameStateStack = (st:_) } ->
KeyBindings.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -104,6 +104,7 @@ , (ctrl 'B', CmdBind) , (ctrl 'L', CmdRedraw) , (ctrl 'Z', CmdSuspend)+ , ('%', CmdToggleColourMode) ] lockGlobal = keypadHex ++ qwertyViHex ++ miscGlobal ++ miscLockGlobal
Lock.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -26,6 +26,11 @@ lockSize (f,_) = frameSize f +baseLock :: Int -> Lock+baseLock size =+ let frame = BasicFrame size+ in (frame, baseState frame)+ deframe :: Lock -> Lock deframe = delTools . liftLock (setpp 0 nullpp) nullpp = PlacedPiece (PHS zero) (Block [])@@ -37,54 +42,53 @@ validLock lock@(f,st) = and [ st == stepPhysics st , lock == reframe lock- , validGameState st + , validGameState st ] -stepPhysics :: GameState -> GameState-stepPhysics = fst.runWriter.physicsTick NullPM- type Solution = [PlayerMove] checkSolution :: Lock -> Solution -> Bool checkSolution lock pms = let (frame,st) = reframe lock- in any (\st' -> checkSolved (frame,st')) $- scanl (((fst.runWriter).).flip physicsTick) st pms+ tick :: GameState -> PlayerMove -> GameState+ tick st pm = fst . runWriter $ physicsTick pm st+ in any (\st' -> checkSolved (frame,st')) $ scanl tick st pms checkSolved :: Lock -> Bool checkSolved (f,st) =- let b = stateBoard st in- and [ isNothing $ Map.lookup p b | p <- boltArea f ]+ and [ isNothing $ Map.lookup p (stateBoard st) | p <- boltArea f ] canonify :: Lock -> Lock canonify = addTools . stabilise . delTools . delOOB delTools :: Lock -> Lock-delTools = liftLock delTools'- where+delTools = liftLock delTools' where delTools' :: GameState -> GameState delTools' st =- case listToMaybe [ idx | (idx,pp) <- enumVec $ placedPieces st- , isTool $ placedPiece pp ] of- Nothing -> st- Just idx -> delTools' $ delPiece idx st+ fromMaybe st $ listToMaybe + [ delTools' $ delPiece idx st+ | (idx,pp) <- enumVec $ placedPieces st+ , isTool $ placedPiece pp ] addTools :: Lock -> Lock addTools (f,st) = let st' = clearToolArea f st in (f, foldr addpp st' $ initTools f)++-- |An important property of the game physics is that any state stabilises in+-- finite time. Proof: in any spontaneous state change some spring gets closer+-- to being of natural length, and none get further from it. stabilise :: Lock -> Lock-stabilise = liftLock stabilise'- where+stabilise = liftLock stabilise' where stabilise' :: GameState -> GameState stabilise' st = let st' = stepPhysics st in if st == st' then st else stabilise' st' delOOB :: Lock -> Lock-delOOB l@(f,st) = case listToMaybe [ idx |- (idx,_) <- enumVec $ placedPieces st+delOOB l@(f,st) =+ fromMaybe l $ listToMaybe+ [ delOOB $ liftLock (delPiece idx) l+ | (idx,_) <- enumVec $ placedPieces st , not $ isFrame idx , all (not.inBounds f) $ fullFootprint st idx- , null $ springsEndAtIdx st idx] of- Nothing -> l- Just idx -> delOOB $ liftLock (delPiece idx) l+ , null $ springsEndAtIdx st idx]
− MainBoth.hs
@@ -1,22 +0,0 @@--- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>------ This program is free software: you can redistribute it and/or modify--- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.------ You should have received a copy of the GNU General Public License--- along with this program. If not, see http://www.gnu.org/licenses/.--module Main where--import Init-import qualified SDLUI (UIM)-import SDLUIMInstance ()-import qualified CursesUI (UIM)-import CursesUIMInstance ()-import MainState--main = main' - (Just (doUI::SDLUI.UIM MainState -> IO (Maybe MainState)))- (Just (doUI::CursesUI.UIM MainState -> IO (Maybe MainState)))
+ MainBoth.hsMainSDL.hsMainCurses.hs view
− MainCurses.hs
@@ -1,20 +0,0 @@--- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>------ This program is free software: you can redistribute it and/or modify--- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.------ You should have received a copy of the GNU General Public License--- along with this program. If not, see http://www.gnu.org/licenses/.--module Main where--import Init-import qualified CursesUI (UIM)-import CursesUIMInstance ()-import MainState--main = main' - (Nothing :: (Maybe (CursesUI.UIM MainState -> IO (Maybe MainState))))- (Just (doUI::CursesUI.UIM MainState -> IO (Maybe MainState)))
− MainSDL.hs
@@ -1,20 +0,0 @@--- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>------ This program is free software: you can redistribute it and/or modify--- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.------ You should have received a copy of the GNU General Public License--- along with this program. If not, see http://www.gnu.org/licenses/.--module Main where--import Init-import qualified SDLUI-import SDLUIMInstance ()-import MainState--main = main' - (Just (doUI::SDLUI.UIM MainState -> IO (Maybe MainState)))- (Nothing :: (Maybe (SDLUI.UIM MainState -> IO (Maybe MainState))))
MainState.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -28,6 +28,7 @@ import Data.Time.Clock import Data.Array import Data.Function (on)+import Safe import Hex import Mundanities@@ -43,12 +44,13 @@ import Metagame import ServerAddr import InputMode+import Util class (Applicative m, MonadIO m) => UIMonad m where runUI :: m a -> IO a initUI :: m Bool endUI :: m ()- drawMainState :: StateT MainState m ()+ drawMainState :: MainStateT m () reportAlerts :: GameState -> [Alert] -> m () drawMessage :: String -> m () drawError :: String -> m ()@@ -59,6 +61,7 @@ setUIBinding :: InputMode -> Command -> Char -> m () getUIBinding :: InputMode -> Command -> m String getDrawImpatience :: m ( Int -> IO () )+ toggleColourMode :: m () warpPointer :: HexPos -> m () setYNButtons :: m () suspend,redraw :: m ()@@ -69,7 +72,7 @@ if ok then m >>= (endUI >>).return.Just else return Nothing -- | this could be neatened using GADTs-data MainState +data MainState = PlayState { psCurrentState::GameState , psFrame::Frame@@ -84,6 +87,7 @@ } | ReplayState { rsCurrentState::GameState+ , rsLastAlerts::[Alert] , rsMoveStack::[PlayerMove] , rsGameStateMoveStack::[(GameState, PlayerMove)] , rsTitle::Maybe String@@ -109,8 +113,9 @@ , codenameStack :: [Codename] , newAsync :: TVar Bool , asyncError :: TVar (Maybe String)+ , asyncInvalidate :: TVar (Maybe Codenames) , randomCodenames :: TVar [Codename]- , userInfos :: Map Codename (TVar FetchedRecord, UTCTime)+ , userInfoTVs :: Map Codename (TVar FetchedRecord, UTCTime) , indexedLocks :: Map LockSpec (TVar FetchedRecord) , retiredLocks :: Maybe [LockSpec] , curLockPath :: FilePath@@ -118,13 +123,23 @@ , listOffset :: Int } +type MainStateT = StateT MainState++ms2im :: MainState -> InputMode+ms2im mainSt = case mainSt of+ PlayState {} -> IMPlay+ ReplayState {} -> IMReplay+ EditState {} -> IMEdit+ MetaState {} -> IMMeta+ newPlayState (frame,st) title sub = PlayState st frame [] False False [] [] title sub Map.empty-newReplayState st soln title = ReplayState st soln [] title 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 initMetaState = do flag <- atomically $ newTVar False errtvar <- atomically $ newTVar Nothing+ invaltvar <- atomically $ newTVar Nothing rnamestvar <- atomically $ newTVar [] (saddr, auth, path) <- confFilePath "metagame.conf" >>= liftM (fromMaybe (defaultServerAddr, Nothing, "")) . readReadFile@@ -133,117 +148,109 @@ confFilePath ("undeclared" ++ [pathSeparator] ++ saddrStr saddr) >>= liftM (fromMaybe []) . readReadFile mlock <- fullLockPath path >>= readLock- return $ MetaState saddr undecls False auth names flag errtvar rnamestvar Map.empty Map.empty Nothing path mlock 0+ return $ MetaState saddr undecls False auth names flag errtvar invaltvar rnamestvar Map.empty Map.empty Nothing path mlock 0 readLock :: FilePath -> IO (Maybe (Lock, Maybe Solution)) readLock path = runMaybeT $ msum [ (\l->(l,Nothing)) <$> (MaybeT $ readReadFile path) , do (mlock,msoln) <- lift $ readAsciiLockFile path- lock <- MaybeT $ return mlock+ lock <- liftMaybe mlock return $ (lock,msoln) ] -- writeLock :: FilePath -> Lock -> IO () -- writeLock path lock = fullLockPath path >>= flip writeReadFile lock-fullLockPath path = if isAbsolute path- then return path- else (++(pathSeparator:path)) <$> confFilePath "locks" writeMetaState (MetaState { curServer=saddr, undeclareds=undecls, curAuth=auth, curLockPath=path }) = do confFilePath "metagame.conf" >>= flip writeReadFile (saddr, auth, path) unless (nullSaddr saddr) $ confFilePath ("undeclared" ++ [pathSeparator] ++ saddrStr saddr) >>= flip writeReadFile undecls -ms2im :: MainState -> InputMode-ms2im mainSt = case mainSt of- PlayState {} -> IMPlay- ReplayState {} -> IMReplay- EditState {} -> IMEdit- MetaState {} -> IMMeta--getTitle :: UIMonad uiM => StateT MainState uiM (Maybe String)+getTitle :: UIMonad uiM => MainStateT uiM (Maybe String) getTitle = ms2im <$> get >>= \im -> case im of IMEdit -> do mpath <- gets esPath unsaved <- editStateUnsaved isTested <- isJust <$> getCurTestSoln- return $ Just $ "editing " ++ fromMaybe "[unnamed lock]" mpath ++ + return $ Just $ "editing " ++ fromMaybe "[unnamed lock]" mpath ++ (if isTested then " (Tested)" else "") ++ (if unsaved then " [+]" else " ") IMPlay -> gets psTitle IMReplay -> gets rsTitle _ -> return Nothing -editStateUnsaved :: UIMonad uiM => StateT MainState uiM Bool+editStateUnsaved :: UIMonad uiM => MainStateT uiM Bool editStateUnsaved = (isNothing <$>) $ runMaybeT $ do (sst,tested) <- MaybeT $ gets lastSavedState- st <- lift $ gets $ head.esGameStateStack+ st <- MaybeT $ gets $ headMay.esGameStateStack guard $ sst == st nowTested <- isJust <$> lift getCurTestSoln guard $ tested == nowTested -getCurTestSoln :: UIMonad uiM => StateT MainState uiM (Maybe Solution)+getCurTestSoln :: UIMonad uiM => MainStateT uiM (Maybe Solution) getCurTestSoln = runMaybeT $ do (st',soln) <- MaybeT $ gets esTested- st <- lift $ gets $ head.esGameStateStack+ st <- MaybeT $ gets $ headMay.esGameStateStack guard $ st == st' return soln instance Error () where noMsg = () -mgetOurName :: (UIMonad uiM) => MaybeT (StateT MainState uiM) Codename+mgetOurName :: (UIMonad uiM) => MaybeT (MainStateT uiM) Codename mgetOurName = MaybeT $ (authUser <$>) <$> gets curAuth-mgetCurName :: (UIMonad uiM) => MaybeT (StateT MainState uiM) Codename-mgetCurName = MaybeT $ listToMaybe <$> gets codenameStack +mgetCurName :: (UIMonad uiM) => MaybeT (MainStateT uiM) Codename+mgetCurName = MaybeT $ listToMaybe <$> gets codenameStack -getUInfoFetched :: UIMonad uiM => Integer -> Codename -> StateT MainState uiM FetchedRecord-getUInfoFetched staleTime name =- gets ((Map.lookup name) . userInfos) >>=- \x -> case x of- Nothing -> set- Just (tvar, time) -> do- now <- liftIO getCurrentTime- if floor (diffUTCTime now time) > staleTime- then set- else liftIO $ atomically $ readTVar tvar- where set = do- tvar <- setUInfoTVar name+getUInfoFetched :: UIMonad uiM => Integer -> Codename -> MainStateT uiM FetchedRecord+getUInfoFetched staleTime name = do+ uinfott <- gets (Map.lookup name . userInfoTVs)+ ($uinfott) $ maybe set $ \(tvar,time) -> do+ now <- liftIO getCurrentTime+ if floor (diffUTCTime now time) > staleTime+ then set+ else liftIO $ atomically $ readTVar 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 -mgetUInfo :: UIMonad uiM => Codename -> MaybeT (StateT MainState uiM) UserInfo+mgetUInfo :: UIMonad uiM => Codename -> MaybeT (MainStateT uiM) UserInfo mgetUInfo name = do RCUserInfo (_,uinfo) <- MaybeT $ (fetchedRC <$>) $ getUInfoFetched defaultStaleTime name return uinfo where defaultStaleTime = 300 -setUInfoTVar :: UIMonad uiM => Codename -> StateT MainState uiM (TVar FetchedRecord)-setUInfoTVar name = do- now <- liftIO getCurrentTime- tvar <- getRecordCachedFromCur True $ RecUserInfo name- modify $ \ms -> ms {userInfos = Map.insert name (tvar, now) $ userInfos ms}- return tvar -invalidateUInfo :: UIMonad uiM => Codename -> StateT MainState uiM ()-invalidateUInfo name = - modify $ \ms -> ms {userInfos = Map.delete name $ userInfos ms}+invalidateUInfo :: UIMonad uiM => Codename -> MainStateT uiM ()+invalidateUInfo name =+ modify $ \ms -> ms {userInfoTVs = Map.delete name $ userInfoTVs ms} -invalidateAllUInfo :: UIMonad uiM => StateT MainState uiM ()+invalidateAllUInfo :: UIMonad uiM => MainStateT uiM () invalidateAllUInfo =- modify $ \ms -> ms {userInfos = Map.empty}+ modify $ \ms -> ms {userInfoTVs = Map.empty} -mgetLock :: UIMonad uiM => LockSpec -> MaybeT (StateT MainState uiM) Lock+data Codenames = AllCodenames | SomeCodenames [Codename]++invalidateUInfos :: UIMonad uiM => Codenames -> MainStateT uiM ()+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 $ (Map.lookup ls) <$> gets indexedLocks , lift $ do- tvar <- getRecordCachedFromCur True $ RecLock ls + 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 return $ reframe lock -refreshUInfoUI :: (UIMonad uiM) => StateT MainState uiM ()+refreshUInfoUI :: (UIMonad uiM) => MainStateT uiM () refreshUInfoUI = void.runMaybeT $ do modify $ \ms -> ms { listOffset = 0 }- mourNameSelected >>= flip when getRandomNames+ mourNameSelected >>? getRandomNames lift $ modify $ \ms -> ms {retiredLocks = Nothing} lift.lift $ drawMessage "" where@@ -256,15 +263,15 @@ resp <- makeRequest saddr $ ClientRequest protocolVersion Nothing $ GetRandomNames 19 case resp of- ServedRandomNames names -> atomically $ do + ServedRandomNames names -> atomically $ do writeTVar rnamestvar names writeTVar flag True _ -> return () -mourNameSelected :: (UIMonad uiM) => MaybeT (StateT MainState uiM) Bool+mourNameSelected :: (UIMonad uiM) => MaybeT (MainStateT uiM) Bool mourNameSelected = liftM2 (==) mgetCurName mgetOurName -purgeInvalidUndecls :: (UIMonad uiM) => StateT MainState uiM ()+purgeInvalidUndecls :: (UIMonad uiM) => MainStateT uiM () purgeInvalidUndecls = do undecls' <- gets undeclareds >>= filterM ((not<$>).invalid) modify $ \ms -> ms { undeclareds = undecls' }@@ -273,15 +280,14 @@ (fromMaybe False <$>) $ runMaybeT $ do uinfo <- mgetUInfo name ourName <- mgetOurName- msum [ do- linfo <- MaybeT $ return $ userLocks uinfo ! idx- return $ public linfo - || ourName `elem` accessedBy linfo - || lockSpec linfo /= ls- , return True- ]+ (`mplus` return True) $ do+ linfo <- liftMaybe $ userLocks uinfo ! idx+ return $ public linfo+ || ourName `elem` accessedBy linfo+ || lockSpec linfo /= ls -curServerAction :: UIMonad uiM => Protocol.Action -> StateT MainState uiM ServerResponse++curServerAction :: UIMonad uiM => Protocol.Action -> MainStateT uiM ServerResponse curServerAction act = do saddr <- gets curServer auth <- gets curAuth@@ -289,29 +295,36 @@ if cOnly then return $ ServerError "Can't contact server in cache-only mode" else lift $ withImpatience $ liftIO $ makeRequest saddr $ ClientRequest protocolVersion auth act -curServerActionAsync :: UIMonad uiM => Protocol.Action -> StateT MainState uiM ()-curServerActionAsync act = do+curServerActionAsyncThenInvalidate :: UIMonad uiM => Protocol.Action -> Maybe Codenames -> MainStateT uiM ()+curServerActionAsyncThenInvalidate act names = do saddr <- gets curServer auth <- gets curAuth flag <- gets newAsync errtvar <- gets asyncError+ invaltvar <- gets asyncInvalidate cOnly <- gets cacheOnly void $ liftIO $ forkIO $ do resp <- if cOnly then return $ ServerError "Can't contact server in cache-only mode" else makeRequest saddr $ ClientRequest protocolVersion auth act case resp of ServerError err -> atomically $ writeTVar errtvar $ Just err- _ -> return ()+ _ -> atomically $ writeTVar invaltvar names atomically $ writeTVar flag True -checkAsyncErrors :: UIMonad uiM => StateT MainState uiM ()-checkAsyncErrors = void.runMaybeT $ do- errtvar <- lift $ gets asyncError- err <- MaybeT $ liftIO $ atomically $ readTVar errtvar- lift.lift $ drawError err- liftIO $ atomically $ writeTVar errtvar Nothing+checkAsync :: UIMonad uiM => MainStateT uiM ()+checkAsync = do+ void.runMaybeT $ do+ errtvar <- lift $ gets asyncError+ err <- MaybeT $ liftIO $ atomically $+ readTVar errtvar <* writeTVar errtvar Nothing+ lift.lift $ drawError err+ void.runMaybeT $ do+ invaltvar <- lift $ gets asyncInvalidate+ names <- MaybeT $ liftIO $ atomically $+ readTVar invaltvar <* writeTVar invaltvar Nothing+ lift $ invalidateUInfos names >> refreshUInfoUI -getRecordCachedFromCur :: UIMonad uiM => Bool -> Record -> StateT MainState uiM (TVar FetchedRecord)+getRecordCachedFromCur :: UIMonad uiM => Bool -> Record -> MainStateT uiM (TVar FetchedRecord) getRecordCachedFromCur flagIt rec = do saddr <- gets curServer auth <- gets curAuth@@ -320,7 +333,7 @@ liftIO $ getRecordCached saddr auth (if flagIt then Just flag else Nothing) cOnly rec -getFreshRecBlocking :: UIMonad uiM => Record -> StateT MainState uiM (Maybe RecordContents)+getFreshRecBlocking :: UIMonad uiM => Record -> MainStateT uiM (Maybe RecordContents) getFreshRecBlocking rec = do tvar <- getRecordCachedFromCur False rec cOnly <- gets cacheOnly@@ -349,7 +362,8 @@ liftIO $ forkIO $ waitImpatiently 0 m <* (liftIO $ atomically $ writeTVar finishedTV True) -getRelScore :: (UIMonad uiM) => Codename -> StateT MainState uiM (Maybe Int)++getRelScore :: (UIMonad uiM) => Codename -> MainStateT uiM (Maybe Int) getRelScore name = (fst<$>) <$> getRelScoreDetails name getRelScoreDetails name = runMaybeT $ do ourName <- mgetOurName@@ -359,24 +373,24 @@ let (pos,neg) = (countUnaccessedBy ourUInfo name, countUnaccessedBy uinfo ourName) return $ (pos-neg,(pos,neg)) where- countUnaccessedBy ui name = length $ filter (not.snd) $ getAccessInfo ui name + countUnaccessedBy ui name = length $ filter isNothing $ getAccessInfo ui name -accessedAL :: (UIMonad uiM) => ActiveLock -> StateT MainState uiM Bool+accessedAL :: (UIMonad uiM) => ActiveLock -> MainStateT uiM Bool accessedAL (ActiveLock name idx) = (isJust <$>) $ runMaybeT $ do ourName <- mgetOurName guard $ ourName /= name uinfo <- mgetUInfo name- guard $ snd $ getAccessInfo uinfo ourName !! idx+ guard $ isJust $ getAccessInfo uinfo ourName !! idx -getNotesReadOn :: UIMonad uiM => LockInfo -> StateT MainState uiM [NoteInfo]+getNotesReadOn :: UIMonad uiM => LockInfo -> MainStateT uiM [NoteInfo] getNotesReadOn lockinfo = (fromMaybe [] <$>) $ runMaybeT $ do ourName <- mgetOurName ourUInfo <- mgetUInfo ourName return $ filter (\n -> isNothing (noteBehind n) || n `elem` notesRead ourUInfo) $ lockSolutions lockinfo -testAuth :: UIMonad uiM => StateT MainState uiM ()-testAuth = (isJust <$> gets curAuth >>=) $ flip when $ do+testAuth :: UIMonad uiM => MainStateT uiM ()+testAuth = isJust <$> gets curAuth >>? do resp <- curServerAction $ Authenticate case resp of ServerMessage msg -> (lift $ drawMessage $ "Server: " ++ msg)
Maxlocksize.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.
Metagame.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -38,14 +38,19 @@ initLockInfo ls = LockInfo ls False [] [] [] -getAccessInfo :: UserInfo -> Codename -> [(Bool,Bool)]--- | getAccessInfo ui name = [(ith lock is public, ith lock is accessed by name) | i]+data AccessedReason = AccessedPrivy | AccessedEmpty | AccessedPub+ deriving (Eq, Ord, Show, Read)+getAccessInfo :: UserInfo -> Codename -> [Maybe AccessedReason] getAccessInfo ui name = let mlinfos = elems $ userLocks ui accessedSlot = maybe accessedAllExisting accessedLock accessedAllExisting = all (maybe True accessedLock) mlinfos- accessedLock linfo = public linfo || name `elem` accessedBy linfo - in map (\mlinfo -> (maybe False public mlinfo, accessedSlot mlinfo)) mlinfos+ accessedLock linfo = public linfo || name `elem` accessedBy linfo+ in map (maybe+ (if accessedAllExisting then Just AccessedEmpty else Nothing)+ (\linfo -> if public linfo then Just AccessedPub+ else if accessedLock linfo then Just AccessedPrivy else Nothing))+ mlinfos data UserInfoDelta = AddRead NoteInfo@@ -62,7 +67,7 @@ | SetPublic deriving (Eq, Ord, Show, Read) -data NoteInfo = NoteInfo {noteAuthor::Codename, noteBehind::Maybe ActiveLock, noteOn::ActiveLock} +data NoteInfo = NoteInfo {noteAuthor::Codename, noteBehind::Maybe ActiveLock, noteOn::ActiveLock} deriving (Eq, Ord, Show, Read) data ActiveLock = ActiveLock {lockOwner::Codename, lockIndex :: LockIndex}@@ -81,7 +86,7 @@ type Hint = GameState lockIndexChar :: LockIndex -> Char-lockIndexChar i = toEnum $ i + fromEnum 'A' +lockIndexChar i = toEnum $ i + fromEnum 'A' charLockIndex c = fromEnum (toUpper c) - fromEnum 'A' applyDeltas :: UserInfo -> [UserInfoDelta] -> UserInfo@@ -137,7 +142,7 @@ instance Binary LockInfo where put (LockInfo spec pk notes solved accessed) = put spec >> put pk >> put notes >> put solved >> put accessed- get = liftM5 LockInfo get get get get get + get = liftM5 LockInfo get get get get get instance Binary NoteInfo where put (NoteInfo author behind on) = put author >> put behind >> put on
Mundanities.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -70,3 +70,7 @@ 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"
NEWS view
@@ -1,73 +1,38 @@-0.3.8:- Animate to show the two physics phases in each turn (thanks dormir)-0.3.7.1:- Minor UI improvements (thanks dormir)-0.3.7:- Metagame help text-0.3.6:- Sound effects.-0.3.5:- Button help text.-0.3.4:- Tutorial tweaks.- Yet more misc minor UI improvements.-0.3.3:- Misc minor UI improvements.-0.3.2:- Misc minor UI improvements.-0.3.1:- Misc minor UI improvements;- Help screens in SDL mode.+This is an abbreviated summary; see the git log for gory details.++0.4.1:+ Concurrency on server; no more freezes while it checks a solution.+ Misc minor UI fixes.+ +0.4:+ Sound effects (thanks linley).+ Animate to show the two physics phases (thanks dormir).+ Help screens.+ Help text for buttons and metagame.+ Deneutralised metagame terminology.+ Tutorial tweaked.+ Various UI improvements (thanks Quicksand-S and dormir)+ 0.3:- Minor fixes; first version uploaded to hackage-0.2.8:- Implemented click-and-drag movement in play and edit modes.-0.2.7:+ Mouse control. Improvements to curses UI - handle resizing; show keys; allow rebinding.- Fixed some bugs with viewing notes.-0.2.6.3:- Update default server address-0.2.6.2:- Fix silly crash bug introduced by 0.2.6.1-0.2.6.1:- Add mouse control of tools-0.2.6:- Minor UI tweaks.-0.2.5: Shortened tutorial drastically. Other levels now in 'tutorial-extra/'.- Improved video setup handling.- Fixed bug with text disappearing on resize.-0.2.4: Improve handling inaccessible servers. Added background.- Fixed bug with prompts being quickly dismissed when using the mouse.-0.2.3:- Minor graphical improvements.-0.2.2:- Visible changes:- scoring tweak: empty slots are accessed iff all non-empty slots are;- 'q'uit confirmation now reminds you what you're quitting from;- we now consider testedness when deciding if a lock is modified;- added detailed game info to the README;- added hover text for UI buttons.- Bugs fixed:+ First version uploaded to hackage.+ Scoring tweak: empty slots are accessed iff all non-empty slots are.+ Detailed game info in README.+ Hover text for UI buttons.+ Marks.+ Lock testing in edit mode.+ Significant bugs fixed: editor, lockfile reader, and validity checker were not in accordance- on what is allowed as the root of a spring;- SDL UI was redrawing the screen on every mouse movement;+ on what is allowed as the root of a spring.+ SDL UI was redrawing the screen on every mouse movement. curses UI wasn't refreshing properly on async flag.-0.2.1:- New features:- The "reset tools" command has become a "test lock" command. Successful- tests are saved along with the lock, meaning you can then place the- lock without having to test it again.-- You can now use marks in 'play' mode, and there's a default mark for the- initial state, effectively giving a "reset" command.-- Bugs fixed: - stale notes weren't getting refreshed- retired display got stuck on changing codename- you couldn't move into the bolthole with keyboard commands+ stale notes weren't getting refreshed.+ retired display got stuck on changing codename.+ you couldn't move into the bolthole with keyboard commands. 0.2: First public release
Physics.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -79,12 +79,12 @@ , natLen /= curLen , let dir = if natLen > curLen then outDir else neg outDir ] - in ( Vector.map (ForceChoice . replicate 1 . snd) rootedForces, + in ( Vector.map (ForceChoice . replicate 1 . snd) rootedForces, \f1 f2 -> Just True == do rootIdx <- fst $ rootedForces!f2 return $ connGraphPathExists st (forceIdx.snd $ rootedForces!f1) rootIdx )- + setTools :: PlayerMove -> GameState -> GameState setTools pm st = let hf = case pm of@@ -104,6 +104,9 @@ tell $ [AlertIntermediateState st'] resolveForces Vector.empty efs dominates $ setTools NullPM st' +stepPhysics :: GameState -> GameState+stepPhysics = fst.runWriter.physicsTick NullPM+ type Source = Int data SourcedForce = SForce Source Force Bool Bool deriving (Eq, Ord, Show)@@ -115,14 +118,14 @@ [False,False] -> eDominates (i-pln) (j-pln) _ -> False initGrps = fmap (propagate st True) plForces Vector.++- fmap (propagate st False) eForces + fmap (propagate st False) eForces blockInconsistent :: Int -> Int -> StateT (Vector (Writer Any [Force])) (Writer [Alert]) () blockInconsistent i j = do grps <- mapM gets [(!i),(!j)] blocks <- lift $ checkInconsistent i j $ map (fst.runWriter) grps modify $ Vector.imap (\k -> if k `elem` blocks then (tell (Any True) >>) else id) checkInconsistent :: Int -> Int -> [[Force]] -> Writer [Alert] [Int]- checkInconsistent i j fss = + checkInconsistent i j fss = let st' = foldr applyForce st $ nub $ concat fss (inconsistencies,cols) = runWriter $ sequence [ tell cols >> return [f,f']@@ -148,7 +151,7 @@ | Push idx dir <- fs , Wrench mom <- [placedPiece $ getpp st idx] , mom `notElem` [zero,dir] ]- in do + in do let unresisted = [ s | (s, (_, Any False)) <- enumVec $ fmap runWriter initGrps ] -- check for inconsistencies within, and between pairs of, forcegroups@@ -163,7 +166,12 @@ tell $ map AlertAppliedForce unblocked tell $ map AlertDivertedWrench $ divertedWrenches unblocked return $ stopBlockedWrenches blocked $ foldr applyForce st unblocked- ++resolveSinglePlForce :: Force -> GameState -> Writer [Alert] GameState+resolveSinglePlForce force st = resolveForces+ (Vector.singleton (ForceChoice [force])) Vector.empty+ (\_ _->False) st+ applyForce :: Force -> GameState -> GameState applyForce f s = let idx = forceIdx f@@ -171,7 +179,7 @@ pp'' = case (placedPiece pp',f) of ( Wrench _ , Push _ dir ) -> pp' {placedPiece = Wrench dir} _ -> pp'- in + in s { placedPieces = (placedPieces s) // [(idx, pp'')] } collisionsWithForce :: GameState -> Force -> PieceIdx -> [HexPos]@@ -190,7 +198,7 @@ applyForceTo pp _ = pp -- A force on a piece which resists it is immediately blocked-pieceResists :: GameState -> Force -> Bool +pieceResists :: GameState -> Force -> Bool pieceResists st force = let idx = forceIdx force PlacedPiece _ piece = getpp st idx@@ -201,7 +209,7 @@ (Wrench mom) -> case force of Push _ v -> v /= mom _ -> True- (Hook _ hf) -> case force of + (Hook _ hf) -> case force of Push _ v -> hf /= PushHF v Torque _ dir -> hf /= TorqueHF dir _ -> False
Protocol.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -70,7 +70,7 @@ data ServerInfo = ServerInfo {serverLockSize :: Int, serverInfoString::String} deriving (Eq, Ord, Show, Read)-defaultServerInfo = ServerInfo 8 ""+defaultServerInfo locksize = ServerInfo locksize "" instance Binary ClientRequest where put (ClientRequest pv mauth act) = putPackedInt pv >> put mauth >> put act
SDLRender.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -22,6 +22,7 @@ import qualified Data.Map as Map import Data.List (maximumBy) import Data.Function (on)+import GHC.Int (Int16) import Hex import GameState@@ -57,6 +58,18 @@ filledCircleAt surf centre rad fillCol circleAt surf centre rad $ opaquify rimCol +thickLine :: Surface -> (Int16,Int16) -> (Int16,Int16) -> Float -> Pixel -> IO ()+thickLine surf from@(x,y) to@(x',y') thickness col = do+ let (dx,dy) = (x'-x,y'-y)+ [rdx,rdy] = map fromIntegral [dx,dy]+ s = thickness / (sqrt $ rdx^2 + rdy^2)+ perp@(px,py) = (round $ s*rdy, round $ s*(-rdx))+ mperp = (-px,-py)+ addHalf (a,b) (c,d) = ( (2*a + c) `div` 2, (2*b + d) `div` 2 )+ rimmedPolygon surf+ (map (uncurry addHalf) [(from,perp),(to,perp),(from,mperp),(to,mperp)])+ (dim col) (bright col)+ type Glyph = SVec -> Int -> Surface -> IO () ysize :: Int -> Int@@ -100,7 +113,7 @@ tileGlyph (BlockTile adjs) col centre size surf = rimmedPolygon surf corners col $ bright col- where + where corners = concat [ if or $ map adjAt [0,1] then [corner centre size $ hextant dir]@@ -140,7 +153,7 @@ to = edge centre rad dir tileGlyph (ArmTile dir _) col centre size surf =- void $ aaLine surf `uncurry` from `uncurry` to $ bright col+ void $ thickLine surf from to 1 col where dir' = if dir == zero then hu else dir from = edge centre size $ neg dir'@@ -154,7 +167,7 @@ tileGlyph (WrenchTile mom) col centre size surf = do rimmedCircle surf centre (size`div`3) col $ bright col when (mom /= zero) $- let + let (fx,fy) = innerCorner centre size $ neg mom (tx,ty) = edge centre size $ neg mom shifts = map (map (`div` 2)) $@@ -209,7 +222,7 @@ --from' = corner centre size $ hextant dir --to' = corner centre size $ (hextant dir) - 1- + collisionMarker :: Glyph collisionMarker centre@(SVec x y) size surf = void $ do -- rimmedCircle surf centre (size`div`3) (bright purple) $ bright purple@@ -333,7 +346,7 @@ blue = colourWheel 4 purple = colourWheel 5 -colourOf colouring idx = +colourOf colouring idx = case Map.lookup idx colouring of Nothing -> white Just n -> colourWheel n@@ -347,7 +360,7 @@ deriving (Eq, Ord, Show) instance Monoid SVec where mempty = SVec 0 0- mappend (SVec x y) (SVec x' y') = SVec (x+x') (y+y') + mappend (SVec x y) (SVec x' y') = SVec (x+x') (y+y') instance Grp SVec where neg (SVec x y) = SVec (-x) (-y) type CCoord = PHS SVec@@ -462,7 +475,7 @@ liftM3 (,,) renderSurf renderSCentre renderSize let SVec _ y = scrCentre <+> (hexVec2SVec size v) w = surfaceGetWidth surf- h = ceiling $ fromIntegral size * 2 * sqrt 3+ h = ceiling $ fromIntegral size * 2 / sqrt 3 fillRectBG $ Just $ Rect 0 (y-h`div`2) w h drawCursorAt :: Maybe HexPos -> RenderM ()
SDLUI.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -50,6 +50,7 @@ import SDLRender import InputMode import Maxlocksize+import Util data UIState = UIState { scrHeight::Int, scrWidth::Int , gsSurface::Maybe Surface@@ -114,7 +115,7 @@ refresh :: UIM ()-refresh = do +refresh = do surface <- liftIO getVideoSurface liftIO $ SDL.flip surface @@ -139,38 +140,18 @@ getButtons mode = do mwhs <- gets $ whsButtons.uiOptions cntxtButtons <- gets contextButtons- return $ cntxtButtons ++ global ++ case mode of + return $ cntxtButtons ++ global ++ case mode of IMEdit -> [ singleButton (tl<+>hv<+>neg hw) CmdTest 4 [("test", hu<+>neg hw)] , singleButton (tl<+>(neg hw)) CmdPlay 2 [("play", hu<+>neg hw)] , markGroup- , singleButton (br<+>2<*>hu) CmdWriteState 2 [("save", hu<+>neg hw)]- , ( [ Button (bl<+>dir) (CmdDir WHSSelected dir) [] | dir <- hexDirs ] ++- [ Button (bl<+>((-2)<*>hv)) (CmdRotate WHSSelected (-1)) []- , Button (bl<+>((-2)<*>hw)) (CmdRotate WHSSelected 1) [] ], (4,0) )- , ( [ Button bl CmdSelect [] ], (0,0))- , ([Button (paintButtonStart <+> hu <+> i<*>hv) (paintTileCmds!!i) []- | i <- take (length paintTiles) [0..] ],(5,0))- ]- IMPlay -> + , 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 ]- ++ case mwhs of- Nothing -> []- Just whs -> - [ ( [ Button bl CmdWait [] ], (0,0))- , ( [ Button (bl<+>dir) (CmdDir whs dir) - (if dir==hu then [("move",hu<+>neg hw),(whsStr whs,hu<+>neg hv)] else [])- | dir <- hexDirs ], (4,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)]- ], (4,0) )- ]) ++- (if whs /= WHSSelected 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) ) ])+ ++ whsBGs mwhs mode ++ [ singleButton tr CmdOpen 1 [("open", hu<+>neg hw)] ] IMReplay -> [ markGroup ] IMMeta ->@@ -181,7 +162,7 @@ , singleButton (codenamePos <+> neg hu) (CmdSelCodename Nothing) 2 [("code",hv<+>4<*>neg hu),("name",hw<+>4<*>neg hu)] , singleButton (serverPos <+> 2<*>neg hv <+> 2<*>hw) CmdTutorials 1 [("play",hu<+>neg hw),("tut",hu<+>neg hv)] ]- + _ -> [] where markGroup = ([Button (tl<+>hw) CmdMark [("set",hu<+>neg hw),("mark",hu<+>neg hv)]@@ -190,19 +171,41 @@ global = if mode == IMTextInput then [] else [ singleButton br CmdQuit 0 [("quit",hu<+>neg hw)] , singleButton (tr <+> 3<*>hv <+> 3<*>hu) CmdHelp 3 [("help",hu<+>neg hw)] ]+ whsBGs :: Maybe WrHoSel -> InputMode -> [ ButtonGroup ]+ whsBGs Nothing _ = []+ 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)+ (if dir==hu then [("move",hu<+>neg hw),(if edit then "piece" else whsStr whs,hu<+>neg hv)] else [])+ | dir <- hexDirs ], (4,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)]+ ], (4,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) ) ]) tr = periphery 0 tl = periphery 2 bl = periphery 3 br = periphery 5 -data AccessedMethod = AccessedSolved | AccessedPublic | AccessedReadNotes | AccessedUndeclared+data AccessedInfo = AccessedSolved | AccessedPublic | AccessedReadNotes | AccessedUndeclared deriving (Eq, Ord, Show) data Selectable = SelOurLock | SelLock ActiveLock | SelLockUnset Bool ActiveLock | SelSelectedCodeName Codename | SelRelScore Int- | SelScoreLock (Maybe Codename) Bool ActiveLock+ | SelScoreLock (Maybe Codename) (Maybe AccessedReason) ActiveLock | SelUndeclared Undeclared | SelReadNote NoteInfo | SelReadNoteSlot@@ -212,7 +215,10 @@ | SelSecured NoteInfo | SelOldLock LockSpec | SelPublicLock- | SelAccessedMethod AccessedMethod+ | SelAccessedInfo AccessedInfo+ | SelLockPath+ | SelPrivyHeader+ | SelNotesHeader deriving (Eq, Ord, Show) registerSelectable v r s =@@ -247,6 +253,7 @@ commandOfSelectable IMMeta (SelSecured note) False = CmdSelCodename $ Just $ lockOwner $ noteOn note commandOfSelectable IMMeta (SelSecured note) True = CmdViewSolution $ Just note commandOfSelectable IMMeta (SelOldLock ls) _ = CmdPlayLockSpec $ Just ls+commandOfSelectable IMMeta (SelLockPath) _ = CmdSelectLock commandOfSelectable IMTextInput (SelLock (ActiveLock _ i)) _ = CmdInputSelLock i commandOfSelectable IMTextInput (SelScoreLock _ _ (ActiveLock _ i)) _ = CmdInputSelLock i commandOfSelectable IMTextInput (SelLockUnset _ (ActiveLock _ i)) _ = CmdInputSelLock i@@ -257,34 +264,66 @@ commandOfSelectable IMTextInput (SelUndeclared undecl) _ = CmdInputSelUndecl undecl commandOfSelectable _ _ _ = CmdNone -helpOfSelectable SelOurLock = Just "Design locks."-helpOfSelectable (SelSelectedCodeName name) = Just $ "Currently viewing "++name++"."-helpOfSelectable (SelRelScore score) = Just $ "Your score against this player is "++show score++". Higher is better."-helpOfSelectable (SelLock (ActiveLock name i)) = Just $ name++"'s lock "++[lockIndexChar i]++"."-helpOfSelectable (SelLockUnset True _) = Just "Place a lock."-helpOfSelectable (SelLockUnset False _) = Just "You access all empty lock slots once you access all filled slots."-helpOfSelectable (SelUndeclared _) = Just "Declare solution, putting your note behind one of your locks, to access the solved lock."-helpOfSelectable (SelRandom _) = Just "Random set of players. Colours show relative scores, bright red (-3) to bright green (+3)."-helpOfSelectable (SelScoreLock (Just name) False _) = Just $ "Your lock, not accessed by "++name++"."-helpOfSelectable (SelScoreLock (Just name) True _) = Just $ "Your lock, accessed by "++name++": -1 to relative score."-helpOfSelectable (SelScoreLock Nothing False (ActiveLock name _)) = Just $ name++"'s lock, not accessed by you."-helpOfSelectable (SelScoreLock Nothing True (ActiveLock name _)) = Just $ name++"'s lock, accessed by you: +1 to relative score."-helpOfSelectable (SelReadNote note) = Just $ "You have read "++noteAuthor note++"'s note on this lock."-helpOfSelectable SelReadNoteSlot = Just $ "If you read three notes on this lock, you can access it without having to solve it yourself."+helpOfSelectable SelOurLock = Just+ "Design a lock."+helpOfSelectable (SelSelectedCodeName name) = Just $+ "Currently viewing "++name++"."+helpOfSelectable (SelRelScore score) = Just $+ "The extent to which you are held in higher esteem than this fellow guild member."+helpOfSelectable (SelLock (ActiveLock name i)) = Just $+ name++"'s lock "++[lockIndexChar i]++"."+helpOfSelectable (SelLockUnset True _) = Just+ "Place a lock."+helpOfSelectable (SelLockUnset False _) = Just+ "An empty lock slot."+helpOfSelectable (SelUndeclared _) = Just+ "Declare yourself privy to a lock's secrets 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)."+helpOfSelectable (SelScoreLock (Just name) Nothing _) = Just $+ "Your lock, to the secrets of which "++name++" is not privy."+helpOfSelectable (SelScoreLock (Just name) (Just AccessedPrivy) _) = Just $+ "Your lock, to the secrets of which "++name++" is privy: -1 to relative esteem."+helpOfSelectable (SelScoreLock (Just name) (Just AccessedPub) _) = Just $+ "Your lock, the secrets of which have been publically revealed: -1 to relative esteem."+helpOfSelectable (SelScoreLock (Just name) (Just AccessedEmpty) _) = Just $+ "Your empty lock slot; "++name++" is privy to the secrets of all your locks: -1 to relative esteem."+helpOfSelectable (SelScoreLock Nothing Nothing (ActiveLock name _)) = Just $+ name++"'s lock, to the secrets of which you are not privy."+helpOfSelectable (SelScoreLock Nothing (Just AccessedPrivy) (ActiveLock name _)) = Just $+ name++"'s lock, to the secrets of which you are privy: +1 to relative esteem."+helpOfSelectable (SelScoreLock Nothing (Just AccessedPub) (ActiveLock name _)) = Just $+ name++"'s lock, the secrets of which have been publically revealed: +1 to relative esteem."+helpOfSelectable (SelScoreLock Nothing (Just AccessedEmpty) (ActiveLock name _)) = Just $+ name++"'s empty lock slot; you are privy to the secrets of 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 $+ "Reading three notes on this lock would let you piece together enough to unriddle its secrets." helpOfSelectable (SelSecured note) = let ActiveLock owner idx = noteOn note in- Just $ "Secured note on "++owner++"'s lock "++[lockIndexChar idx]++"; notes are read by accessing the lock holding them."+ Just $ "Secured note on "++owner++"'s lock "++[lockIndexChar idx]++"." helpOfSelectable (SelSolution note) = Just $ case noteBehind note of Just (ActiveLock owner idx) -> owner ++ " has secured their note on this lock behind their lock " ++ [lockIndexChar idx] ++ "." Nothing -> noteAuthor note ++ "'s note on this lock is public knowledge."-helpOfSelectable (SelAccessed name) = Just $ name ++ " has accessed this lock without solving 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 (SelAccessedMethod meth) = Just $ case meth of- AccessedSolved -> "You solved this lock, so have access to it and any notes it holds."- AccessedPublic -> "The solution to this lock is public knowledge."- AccessedUndeclared -> "You have solved this lock, but need to declare your solution to access the lock."- AccessedReadNotes -> "You have read three notes on others' solutions to this lock, so have access to it."-helpOfSelectable _ = Nothing+helpOfSelectable (SelAccessed name) = Just $+ name ++ " did not pick this lock, but is privy to its secrets."+helpOfSelectable (SelPublicLock) = Just+ "Notes behind retired or public locks are public; locks with three public notes are 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."+ AccessedUndeclared -> "You have picked this lock, but are yet to declare your solution."+ 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 $+ "Select a lock by its name. The names you give your locks are not revealed to others."+helpOfSelectable SelPrivyHeader = Just $+ "Guild members privy to this lock's secrets, hence able to read its secured notes."+helpOfSelectable SelNotesHeader = Just $+ "Secured notes. Notes are obfuscated sketches of method, proving success but revealing little." cmdAtMousePos pos@(mPos,central) im selMode = do buttons <- (concat . map fst) <$> getButtons im@@ -298,8 +337,8 @@ helpAtMousePos pos@(mPos,_) IMMeta = join . fmap helpOfSelectable . Map.lookup mPos <$> gets metaSelectables helpAtMousePos _ _ = return Nothing- + data UIOptButton a = UIOptButton { getUIOpt::UIOptions->a, setUIOpt::a->UIOptions->UIOptions, uiOptVals::[a], uiOptPos::HexVec, uiOptGlyph::a->Glyph, uiOptDescr::a->String } @@ -317,9 +356,9 @@ uiOB3 = UIOptButton whsButtons (\v o -> o {whsButtons=v}) [Nothing, Just WHSSelected, Just WHSWrench, Just WHSHook] (periphery 3 <+> 3 <*> hv) whsButtonsButton (\v -> case v of- Nothing -> "Click to show keyboard control buttons for tools."+ Nothing -> "Showing mouse controls; click to show keyboard control buttons." Just whs -> "Showing buttons for controlling " ++ case whs of- WHSSelected -> "selected tool"+ WHSSelected -> "selected piece" WHSWrench -> "wrench" WHSHook -> "hook") uiOB4 = UIOptButton showButtonText (\v o -> o {showButtonText=v}) [True,False]@@ -333,14 +372,13 @@ drawUIOptionButtons :: InputMode -> UIM () drawUIOptionButtons mode = do- when (mode `elem` [IMPlay, IMEdit]) $ do+ when (mode `elem` [IMPlay, IMEdit, IMReplay]) $ do drawUIOptionButton uiOB1 drawUIOptionButton uiOB2+ unless (mode == IMReplay) $ drawUIOptionButton uiOB3 #ifdef SOUND drawUIOptionButton uiOB5 #endif- when (mode == IMPlay) $- drawUIOptionButton uiOB3 drawUIOptionButton uiOB4 drawUIOptionButton b = do value <- gets $ (getUIOpt b).uiOptions@@ -356,7 +394,7 @@ modifyUIOptions $ setopt value' readUIConfigFile :: UIM ()-readUIConfigFile = do +readUIConfigFile = do path <- liftIO $ confFilePath "SDLUI.conf" mOpts <- liftIO $ readReadFile path case mOpts of@@ -370,7 +408,7 @@ liftIO $ writeFile path $ show opts readBindings :: UIM ()-readBindings = do +readBindings = do path <- liftIO $ confFilePath "bindings" mbdgs <- liftIO $ readReadFile path case mbdgs of@@ -412,7 +450,7 @@ drawPaintButtons :: UIM () drawPaintButtons = do pti <- getEffPaintTileIndex- renderToMain $ sequence_ [ + renderToMain $ sequence_ [ do let gl = case paintTiles!!i of Nothing -> hollowInnerGlyph $ dim purple@@ -435,8 +473,8 @@ screenWidthHexes = 32 screenHeightHexes = 25 getGeom :: UIM (SVec, Int)-getGeom = do - h <- gets scrHeight +getGeom = do+ h <- gets scrHeight w <- gets scrWidth let scrCentre = SVec (w`div`2) (h`div`2) -- |size is the greatest integer such that@@ -458,7 +496,10 @@ drawMainGameState' :: DrawArgs -> UIM () drawMainGameState' args@(DrawArgs highlight colourFixed alerts st uiopts) = do lastArgs <- gets lastDrawArgs- when (lastArgs /= Just args) $+ when (case lastArgs of+ Nothing -> True+ Just (DrawArgs _ _ lastAlerts lastSt _) ->+ lastAlerts /= alerts || lastSt /= st) $ modify $ \ds -> ds { animFrame = 0, nextAnimFrameAt = Nothing } lastAnimFrame <- gets animFrame@@ -494,7 +535,7 @@ gsSurf <- liftM fromJust $ gets gsSurface renderToMainWithSurf gsSurf $ do erase- sequence_ [ drawAt glyph pos | + sequence_ [ drawAt glyph pos | (pos,glyph) <- Map.toList $ fmap (ownedTileGlyph colouring highlight) board ] @@ -571,7 +612,7 @@ colouring = if useFiveColouring uiopts then boardColouring st coloured Map.empty else pieceTypeColouring st coloured- draw = sequence_ [ drawAt glyph pos | + draw = sequence_ [ drawAt glyph pos | (pos,glyph) <- Map.toList $ fmap (ownedTileGlyph colouring []) $ stateBoard st ] liftIO $ runReaderT draw $ RenderContext surf Nothing (PHS zero) (SVec (width`div`2) (height`div`2)) minisize Nothing@@ -581,7 +622,7 @@ -- | TODO: do this more cleverly clearOldMiniLocks =- (>=50).Map.size <$> gets miniLocks >>= flip when clearMiniLocks+ (>=50).Map.size <$> gets miniLocks >>? clearMiniLocks clearMiniLocks = modify $ \ds -> ds { miniLocks = Map.empty} drawEmptyMiniLock v =@@ -602,7 +643,7 @@ showBT <- showButtonText <$> gets uiOptions smallFont <- gets dispFontSmall renderToMain $ sequence_ $ concat [ [ do- drawAtRel (buttonGlyph col) v + drawAtRel (buttonGlyph col) v renderStrColAt buttonTextCol bdg v when showBT $ withFont smallFont $ recentreAt v $ rescaleRender (1/4) $@@ -616,7 +657,7 @@ initVideo :: Int -> Int -> UIM () initVideo w h = do liftIO $ setVideoMode w h 0 [Resizable]- + -- see what size we actually got: vinfo <- liftIO $ getVideoInfo let [w',h'] = map ($vinfo) [videoInfoWidth,videoInfoHeight]@@ -646,7 +687,7 @@ when (isNothing font) $ lift $ do let text = "Warning: font file not found at "++fontpath++".\n" putStr text- writeFile "error.log" text + writeFile "error.log" text initAudio :: UIM () #ifdef SOUND@@ -697,12 +738,12 @@ setMsgLineNoRefresh col str = do modify $ \s -> s { message = Just (col,str) } unless (null str) $ modify $ \s -> s { hoverStr = Nothing }- drawMsgLine + drawMsgLine setMsgLine col str = setMsgLineNoRefresh col str >> refresh drawTitle (Just title) = renderToMain $ renderStrColAt messageCol title titlePos drawTitle Nothing = return ()- + say = setMsgLine messageCol sayError = setMsgLine errorCol
SDLUIMInstance.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -62,6 +62,7 @@ drawButtons mode drawUIOptionButtons mode drawMsgLine+ drawShortMouseHelp mode refresh where drawMainState' (PlayState { psCurrentState=st, psLastAlerts=alerts, wrenchSelected=wsel }) = do@@ -73,11 +74,11 @@ , or [wsel && isWrench p, not wsel && isHook p] ] drawMainGameState selTools False alerts st registerUndoButtons canUndo canRedo- drawMainState' (ReplayState { rsCurrentState=st } ) = do+ drawMainState' (ReplayState { rsCurrentState=st, rsLastAlerts=alerts } ) = do canUndo <- null <$> gets rsGameStateMoveStack canRedo <- null <$> gets rsMoveStack lift $ do- drawMainGameState [] False [] st+ drawMainGameState [] False alerts st registerUndoButtons canUndo canRedo renderToMain $ drawCursorAt Nothing drawMainState' (EditState { esGameStateStack=(st:sts), esUndoneStack=undostack,@@ -96,19 +97,19 @@ (isWrench, "wrench", CmdTile $ WrenchTile zero, 3<*>hu <+> hv), (isHook, "hook", CmdTile $ HookTile, 3<*>hu <+> 2<*>hv)] ] drawPaintButtons- drawMainState' (MetaState saddr undecls cOnly auth names _ _ rnamestvar _ _ mretired path mlock offset) = do+ drawMainState' (MetaState saddr undecls cOnly auth names _ _ _ rnamestvar _ _ mretired path mlock offset) = do let ourName = authUser <$> auth let selName = listToMaybe names let home = isJust ourName && ourName == selName lift $ renderToMain $ (erase >> drawCursorAt Nothing)- lift $ maybe (drawEmptyMiniLock miniLockPos)- (\lock -> do- drawMiniLock lock miniLockPos- registerSelectable miniLockPos 3 SelOurLock- )- (fst<$>mlock)+ lift $ do+ maybe (drawEmptyMiniLock miniLockPos)+ (\lock -> drawMiniLock lock miniLockPos)+ (fst<$>mlock)+ registerSelectable miniLockPos 3 SelOurLock lift $ when (not $ null path) $ do renderToMain $ renderStrColAtLeft messageCol path $ lockLinePos <+> hu+ registerSelectable (lockLinePos <+> 2<*>hu) 1 SelLockPath sequence_ [ registerButton (miniLockPos <+> 2<*>neg hv <+> hu <+> dv) cmd 4 [(dirText,hu<+>neg hw),("lock",hu<+>neg hv)]@@ -132,13 +133,13 @@ renderToMain $ withFont smallFont $ renderStrColAtLeft (opaquify $ dim errorCol) "(stale)" $ serverWaitPos maybe (return ()) (setMsgLineNoRefresh errorCol) err when (fresh && (isNothing ourName || home || isNothing muirc)) $- let reg = (isNothing muirc && isNothing ourName) || home + let reg = (isNothing muirc && isNothing ourName) || home in registerButton (codenamePos <+> hw <+> 2<*>hu) (if reg then CmdRegister else CmdAuth) 2 [(if reg then "reg" else "auth", hu<+>neg hv)] (if isJust muirc then drawName else drawNullName) name codenamePos lift $ registerSelectable codenamePos 0 (SelSelectedCodeName name) drawRelScore name (codenamePos<+>hu)- for_ muirc $ \(RCUserInfo (_,uinfo)) -> case mretired of + 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]])@@ -177,29 +178,29 @@ when (ourName /= selName) $ void $ runMaybeT $ do when (isJust ourName) $ lift.lift $ registerButton (codenamePos <+> neg hu <+> hw) CmdHome 4 [("home",hu<+>neg hv)]- sel <- MaybeT $ return selName- us <- MaybeT $ return ourName+ sel <- liftMaybe selName+ us <- liftMaybe ourName ourUInfo <- mgetUInfo us selUInfo <- mgetUInfo sel let accesses = map (uncurry getAccessInfo) [(ourUInfo,sel),(selUInfo,us)]- lift $ do + lift $ do fillArea (codenamePos<+>3<*>hv<+>hw) (map ((codenamePos<+>3<*>hv)<+>) [zero,hw,neg hv])- [ \pos -> (lift $ registerSelectable pos 0 (SelScoreLock (Just sel) access $ ActiveLock us i)) >>+ [ \pos -> (lift $ registerSelectable pos 0 (SelScoreLock (Just sel) accessed $ ActiveLock us i)) >> drawNameWithCharAndCol us white (lockIndexChar i) col pos | i <- [0..2]- , let (pub,access) = accesses !! 0 !! i+ , let accessed = accesses !! 0 !! i , let col- | pub = dim pubColour - | access = dim $ scoreColour $ -3 + | accessed == Just AccessedPub = dim pubColour+ | isJust accessed = dim $ scoreColour $ -3 | otherwise = obscure $ scoreColour 3 ] fillArea (codenamePos<+>2<*>neg hw) (map ((codenamePos<+>3<*>neg hw)<+>) [zero,hw,neg hv])- [ \pos -> (lift $ registerSelectable pos 0 (SelScoreLock Nothing access $ ActiveLock sel i)) >>+ [ \pos -> (lift $ registerSelectable pos 0 (SelScoreLock Nothing accessed $ ActiveLock sel i)) >> drawNameWithCharAndCol sel white (lockIndexChar i) col pos | i <- [0..2]- , let (pub,access) = accesses !! 1 !! i+ , let accessed = accesses !! 1 !! i , let col- | pub = obscure pubColour - | access = dim $ scoreColour $ 3 + | accessed == Just AccessedPub = obscure pubColour+ | isJust accessed = dim $ scoreColour $ 3 | otherwise = obscure $ scoreColour $ -3 ] (usUnacc,selUnacc) <- MaybeT $ (snd<$>) <$> getRelScoreDetails sel lift.lift.renderToMain $ sequence_ [renderStrColAt (scoreColour score) (sign:show (abs score)) pos@@ -215,9 +216,9 @@ getChRaw = do events <- liftIO getEvents- case listToMaybe $ [ key | KeyDown key <- events ] of- Nothing -> getChRaw- Just (Keysym _ _ ch) -> return $ Just ch+ maybe getChRaw (return.Just) $ listToMaybe $ [ ch+ | KeyDown (Keysym _ _ ch) <- events+ , ch /= '\0' ] setUIBinding mode cmd ch = modify $ \s -> s { uiKeyBindings =@@ -257,7 +258,7 @@ getDrawImpatience = do curState <- get let pos = serverWaitPos- return $ \ticks -> void $ flip runStateT curState $ do + return $ \ticks -> void $ flip runStateT curState $ do when (ticks>2) $ renderToMain $ do mapM (drawAtRel (filledHexGlyph $ bright black)) [ pos <+> i<*>hu | i <- [0..3] ] withFont (dispFontSmall curState) $@@ -281,6 +282,9 @@ drawButtons IMTextInput refresh + toggleColourMode = modify $ \s -> s {uiOptions = (uiOptions s){+ useFiveColouring = not $ useFiveColouring $ uiOptions s}}+ getInput mode = do fps <- gets fps events <- liftIO $ nubMouseMotions <$> getEventsTimeout (10^6`div`fps)@@ -430,21 +434,22 @@ return [ CmdRedraw ] processEvent VideoExpose = return [ CmdRedraw ] processEvent Quit = return [ CmdForceQuit ]- + processEvent _ = return [] doWheel dw = do rb <- isJust <$> gets rightButtonDown mb <- isJust <$> gets middleButtonDown- if ((rb||mb) && mode /= IMEdit) || (mb && mode == IMEdit)+ if ((rb || mb || mode == IMReplay) && mode /= IMEdit)+ || (mb && mode == IMEdit) then return [ if dw == 1 then CmdUndo else CmdRedo ] else if mode /= IMEdit || rb then return [ CmdRotate WHSSelected dw ] else do modify $ \s -> s { paintTileIndex = (paintTileIndex s + dw) `mod` (length paintTiles) } return []- + drawCmd mt True = CmdPaint mt drawCmd (Just t) False = CmdTile t drawCmd Nothing _ = CmdDelete@@ -468,23 +473,23 @@ showHelp mode = do bdgs <- nub <$> getBindings mode smallFont <- gets dispFontSmall- renderToMain $ do + 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- mouseHelpStrs = ["Mouse commands:", "Right-click on a button to set a keybinding;"] ++ case mode of- IMPlay -> ["Click on tool to select, drag to move;",- "Click by tool to move; right-click to wait;", "Scroll wheel to rotate hook;",- "Scroll wheel with right button held down to undo/redo."]- IMEdit -> ["Left-click to draw selected; scroll to change selection;",- "Right-click on piece to select, drag to move;",- "While holding right-click: left-click to advance time, middle-click to delete;",- "Scroll wheel to rotate selected piece; scroll wheel while held down to undo/redo."]- IMReplay -> ["Scroll wheel with right button held down to undo/redo."]- IMMeta -> ["Left-clicking on something does most obvious thing;",- "Right-clicking does second-most obvious thing."]-+ mouseHelpStrs = ["Mouse commands:", "Right-click on a button to set a keybinding;"]+ ++ case mode of+ IMPlay -> ["Click on tool to select, drag to move;",+ "Click by tool to move; right-click to wait;", "Scroll wheel to rotate hook;",+ "Scroll wheel with right button held down to undo/redo."]+ IMEdit -> ["Left-click to draw selected; scroll to change selection;",+ "Right-click on piece to select, drag to move;",+ "While holding right-click: left-click to advance time, middle-click to delete;",+ "Scroll wheel to rotate selected piece; scroll wheel while held down to undo/redo."]+ IMReplay -> ["Scroll wheel with right button held down to undo/redo."]+ IMMeta -> ["Left-clicking on something does most obvious thing;",+ "Right-clicking does second-most obvious thing."] renderStrColAt messageCol "Keybindings:" $ (screenHeightHexes`div`4)<*>(hv<+>neg hw) sequence_ [ with $ renderStrColAtLeft messageCol ( keysStr ++ ": " ++ desc )@@ -511,6 +516,35 @@ | (str,y) <- zip mouseHelpStrs [0..] ] refresh +drawShortMouseHelp mode = do+ mwhs <- gets $ whsButtons.uiOptions+ showBT <- showButtonText <$> gets uiOptions+ when (showBT && isNothing mwhs) $ do+ let helps = shortMouseHelp mode+ smallFont <- gets dispFontSmall+ renderToMain $ withFont smallFont $ sequence_+ [ renderStrColAtLeft (dim cyan) help+ (periphery 3 <+> neg hu <+> (2-n)<*>hv )+ | (n,help) <- zip [0..] helps ]+ where+ shortMouseHelp IMPlay =+ [ "LMB: select/move tool"+ , "LMB+drag: move tool"+ , "Wheel: turn hook"+ , "RMB: wait a turn"+ , "RMB+Wheel: undo/redo"+ ]+ shortMouseHelp IMEdit =+ [ "LMB: paint; Ctrl+LMB: delete"+ , "Wheel: set paint type"+ , "RMB: select piece; drag to move"+ , "RMB+LMB: wait; RMB+MMB: delete piece"+ , "MMB+Wheel: undo/redo"+ ]+ shortMouseHelp IMReplay =+ [ "Wheel: advance/regress time" ]+ shortMouseHelp _ = []+ getEvents = do e <- waitEvent es <- pollEvents@@ -556,7 +590,7 @@ ++ "]" -fillArea :: HexVec -> [HexVec] -> [HexVec -> StateT MainState UIM ()] -> StateT MainState UIM () +fillArea :: HexVec -> [HexVec] -> [HexVec -> MainStateT UIM ()] -> MainStateT UIM () fillArea centre area draws = do offset <- gets listOffset let na = length area@@ -580,12 +614,12 @@ , lift.lift.renderToMain $ renderStrColAt messageCol (show ls) pos ]- + drawName name pos = nameCol name >>= drawNameCol name pos drawNullName name pos = drawNameCol name pos $ invisible white drawNameCol name pos col = do- lift.renderToMain $ do + lift.renderToMain $ do drawAtRel (playerGlyph col) pos renderStrColAt messageCol name pos drawRelScore name pos = do@@ -617,7 +651,7 @@ smallFont <- lift $ gets dispFontSmall lift.renderToMain $ do drawAtRel (playerGlyph col) pos- displaceRender up $ + displaceRender up $ renderStrColAt messageCol name pos displaceRender down $ withFont smallFont $ renderStrColAt charcol [char] pos@@ -633,14 +667,14 @@ scoreColour :: Int -> Pixel scoreColour score = Pixel $ case score of 0 -> 0x80800000- 1 -> 0x70a00000 + 1 -> 0x70a00000 2 -> 0x40c00000 3 -> 0x00ff0000- (-1) -> 0xa0700000 + (-1) -> 0xa0700000 (-2) -> 0xc0400000 (-3) -> 0xff000000 -drawLockInfo :: ActiveLock -> Maybe LockInfo -> StateT MainState UIM ()+drawLockInfo :: ActiveLock -> Maybe LockInfo -> MainStateT UIM () drawLockInfo al@(ActiveLock name i) Nothing = do let centre = hw<+>neg hv <+> 7*(i-1)<*>hu lift $ drawEmptyMiniLock centre@@ -664,13 +698,17 @@ lift $ registerSelectable centre 3 $ SelLock al ] - lift.renderToMain $ renderStrColAt dimWhiteCol "Accessed by:" $ accessedByPos <+> hv+ size <- snd <$> lift getGeom+ lift $ do+ renderToMain $ displaceRender (SVec size 0) $ renderStrColAt (brightish white) "PRIVY" $ accessedByPos <+> hv+ registerSelectable (accessedByPos <+> hv) 0 SelPrivyHeader+ registerSelectable (accessedByPos <+> hv <+> hu) 0 SelPrivyHeader if public lockinfo then lift $ do- renderToMain $ renderStrColAt pubColour "Everyone!" accessedByPos+ renderToMain $ renderStrColAt pubColour "All" accessedByPos registerSelectable accessedByPos 1 SelPublicLock else if null $ accessedBy lockinfo- then lift.renderToMain $ renderStrColAt messageCol "No-one" accessedByPos+ then lift.renderToMain $ renderStrColAt dimWhiteCol "No-one" accessedByPos else fillArea accessedByPos [ accessedByPos <+> d | j <- [0..2], i <- [-2..3] , i-j > -4, i-j < 3@@ -679,7 +717,7 @@ | note <- lockSolutions lockinfo ] ++ [ \pos -> (lift $ registerSelectable pos 0 (SelAccessed name)) >> drawName name pos | name <- accessedBy lockinfo \\ map noteAuthor (lockSolutions lockinfo) ]- + undecls <- gets undeclareds case if isJust $ guard . (|| public lockinfo) . (`elem` map noteAuthor (lockSolutions lockinfo)) =<< ourName then if public lockinfo@@ -691,22 +729,25 @@ of Just (col,str,selstr) -> lift $ do renderToMain $ renderStrColAt col str accessedPos- registerSelectable accessedPos 1 (SelAccessedMethod selstr)+ registerSelectable accessedPos 1 (SelAccessedInfo selstr) Nothing -> do read <- take 3 <$> getNotesReadOn lockinfo unless (ourName == Just name) $ do let readPos = accessedPos <+> (-3)<*>hu lift.renderToMain $ renderStrColAt (if length read == 3 then accColour else dimWhiteCol) "Read:" $ readPos- when (length read == 3) $ lift $ registerSelectable readPos 0 (SelAccessedMethod AccessedReadNotes)+ 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)) >> drawName (noteAuthor note) pos | note <- read ] ++ (repeat $ \pos -> (lift $ registerSelectable pos 0 SelReadNoteSlot >> renderToMain (drawAtRel (hollowGlyph $ dim green) pos))) - lift.renderToMain $ renderStrColAt dimWhiteCol "Holds notes:" $ notesPos <+> hv+ lift $ do+ renderToMain $ displaceRender (SVec size 0) $ renderStrColAt (brightish white) "NOTES" $ notesPos <+> hv+ registerSelectable (notesPos <+> hv) 0 SelNotesHeader+ registerSelectable (notesPos <+> hv <+> hu) 0 SelNotesHeader if null $ notesSecured lockinfo- then lift.renderToMain $ renderStrColAt messageCol "None" notesPos+ then lift.renderToMain $ renderStrColAt dimWhiteCol "None" notesPos else fillArea notesPos [ notesPos <+> d | j <- [0..2], i <- [-2..3] , i-j > -4, i-j < 3
Server.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -12,7 +12,7 @@ import Network.Fancy -import Control.Concurrent (threadDelay)+import Control.Concurrent (threadDelay,forkIO) import Control.Applicative import Control.Monad import Control.Monad.Trans.State@@ -48,14 +48,19 @@ import Database import AsciiLock import Mundanities+import Maxlocksize -port = 27001 -- 27001 == ('i'<<8) + 'y'+defaultPort = 27001 -- 27001 == ('i'<<8) + 'y' -data Opt = RequestDelay Int+data Opt = RequestDelay Int | Daemon | LogFile FilePath | Port Int | DBDir FilePath | ServerLockSize Int deriving (Eq, Ord, Show) options =- [ Option ['d'] ["delay"] (ReqArg (RequestDelay . read) "MICROSECS") "delay before sending response (for testing) (default: 0)"- --, Option ['d'] ["dir"] (ReqArg (DBDir . read)) "directory for server database [default: intricacydb]"+ [ Option ['p'] ["port"] (ReqArg (Port . read) "PORT") $ "TCP port to listen on (default: " ++ show defaultPort ++ ")"+ , Option ['P'] ["delay"] (ReqArg (RequestDelay . read) "MICROSECS") "delay before sending response (for testing) (default: 0)"+ -- , Option ['d'] ["daemon"] (NoArg Daemon) "Run as daemon"+ , Option ['l'] ["logfile"] (ReqArg LogFile "PATH") "Log to file"+ , Option ['d'] ["dir"] (ReqArg DBDir "PATH") "directory for server database [default: intricacydb]"+ , Option ['s'] ["locksize"] (ReqArg (ServerLockSize . read) "SIZE") "size of locks (only takes effect when creating a new database) [default: 8]" ] parseArgs :: [String] -> IO ([Opt],[String]) parseArgs argv =@@ -64,31 +69,52 @@ (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) where header = "Usage: intricacy-server [OPTION...]" -main = do +main = do argv <- getArgs (opts,_) <- parseArgs argv+ {- FIXME: doesn't work+ if Daemon `elem` opts+ then void $ forkIO $ main' opts+ else main' opts+ -} let delay = fromMaybe 0 $ listToMaybe [ d | RequestDelay d <- opts ]- withDB setDefaultServerInfo- writeFile lockFilePath ""- streamServer serverSpec{address = IPv4 "" port, threading=Inline} $ handler delay+ port = fromMaybe defaultPort $ listToMaybe [ p | Port p <- opts ]+ dbpath = fromMaybe "intricacydb" $ listToMaybe [ p | DBDir p <- opts ]+ locksize = min maxlocksize $ fromMaybe 8 $ listToMaybe [ s | ServerLockSize s <- opts ]+ withDB dbpath $ setDefaultServerInfo locksize+ writeFile (lockFilePath dbpath) ""+ logh <- case listToMaybe [ f | LogFile f <- opts ] of+ Nothing -> return stdout+ Just path -> openFile path AppendMode+ streamServer serverSpec{address = IPv4 "" port, threading=Threaded} $ handler dbpath delay logh sleepForever --- database path is relative to current directory: ./intricacydb/-dbpath = "intricacydb"-withDB = flip runReaderT dbpath--setDefaultServerInfo = do+setDefaultServerInfo locksize = do alreadySet <- recordExists RecServerInfo- unless alreadySet $ putRecord RecServerInfo (RCServerInfo defaultServerInfo)+ unless alreadySet $ putRecord RecServerInfo (RCServerInfo $ defaultServerInfo locksize) -logit = putStrLn+-- | We lock the whole database during each request, using haskell's native+-- file locking, meaning that we have at any time one writer *xor* any number+-- of readers.+withDBLock dbpath lockMode m = do+ h <- liftIO $ getDBLock lockMode+ ret <- m+ liftIO $ hClose h+ return ret+ where+ getDBLock lockMode =+ catchIO (openFile (lockFilePath dbpath) lockMode) (\_ -> threadDelay (50*10^3) >> getDBLock lockMode) -handler :: Int -> Handle -> Address -> IO ()-handler delay hdl addr = handle ((\e -> return ()) :: SomeException -> IO ()) $+lockFilePath dbpath = dbpath ++ [pathSeparator] ++ "lockfile"++logit h s = hPutStrLn h s >> hFlush h++handler :: FilePath -> Int -> Handle -> Handle -> Address -> IO ()+handler dbpath delay logh hdl addr = handle ((\e -> return ()) :: SomeException -> IO ()) $ handler' hdl addr where handler' hdl addr = do response <- handle (\e -> return $ ServerError $ show (e::SomeException)) $ do- request <- B.decode <$> L.hGetContents hdl + request <- B.decode <$> L.hGetContents hdl let hostname = case addr of IP n _ -> n IPv4 n _ -> n@@ -96,11 +122,11 @@ Unix path -> path hashedHostname = take 8 $ hash hostname now <- liftIO getCurrentTime- logit $ show now ++ ": " ++ hashedHostname ++ " >>> " ++ showRequest request- response <- handleRequest request+ logit logh $ show now ++ ": " ++ hashedHostname ++ " >>> " ++ showRequest request+ response <- handleRequest dbpath request when (delay > 0) $ threadDelay delay now' <- liftIO getCurrentTime- logit $ show now' ++ ": " ++ hashedHostname ++ " <<< " ++ showResponse response+ logit logh $ show now' ++ ": " ++ hashedHostname ++ " <<< " ++ showResponse response return response L.hPut hdl $ B.encode response @@ -120,20 +146,8 @@ showResponse (ServedSolution soln) = "ServedSolution [SOLN]" showResponse resp = show resp --- | We lock the whole database during each request, using haskell's native--- file locking, meaning that we have at any time one writer *xor* any number--- of readers.-withDBLock lockMode m = do- h <- getDBLock lockMode- ret <- m- hClose h- return ret- where getDBLock lockMode =- catchIO (openFile lockFilePath lockMode) (\_ -> threadDelay (50*10^3) >> getDBLock lockMode)-lockFilePath = dbpath ++ [pathSeparator] ++ "lockfile"--handleRequest :: ClientRequest -> IO ServerResponse-handleRequest req@(ClientRequest pv auth action) = do+handleRequest :: FilePath -> ClientRequest -> IO ServerResponse+handleRequest dbpath req@(ClientRequest pv auth action) = do let lockMode = case action of Authenticate -> ReadMode GetServerInfo -> ReadMode@@ -143,16 +157,46 @@ GetSolution _ -> ReadMode GetRandomNames _ -> ReadMode _ -> ReadWriteMode- eresp <- withDBLock lockMode $ runErrorT handleRequest'++ -- check solutions prior to write-locking database:+ eresp <- runErrorT $ do+ withDBLock dbpath ReadMode $ checkRequest+ withDBLock dbpath lockMode $ handleRequest' case eresp of Left error -> return $ ServerError error Right resp -> return resp+ where- handleRequest' = do+ checkRequest = do when (pv /= protocolVersion) $ throwError "Bad protocol version" case action of- Authenticate -> do - checkAuth auth + DeclareSolution soln ls target idx -> do+ info <- getUserInfoOfAuth auth+ lock <- getLock ls+ tinfo <- getALock target+ when (ls /= lockSpec tinfo) $ throwError "Lock no longer in use!"+ when (public tinfo) $ throwError "Lock solution already public knowledge!"+ let name = codename info+ let behind = ActiveLock name idx+ when (name `elem` map noteAuthor (lockSolutions tinfo)) $+ throwError "Note already taken on that lock!"+ when (name == lockOwner target) $+ throwError "That's your lock!"+ behindLock <- getALock behind+ when (public behindLock) $ throwError "Your lock is cracked!"+ unless (checkSolution lock soln) $ throwError "Bad solution"+ SetLock lock@(frame,_) idx soln -> do+ ServerInfo serverSize _ <- getServerInfo+ when (frame /= BasicFrame serverSize) $ throwError $+ "Server only accepts size "++show serverSize++" locks."+ unless (validLock $ reframe lock) $ throwError "Invalid lock!"+ unless (not.checkSolved $ reframe lock) $ throwError "Lock not locked!"+ unless (checkSolution lock soln) $ throwError "Bad solution"+ _ -> return ()+ handleRequest' =+ case action of+ Authenticate -> do+ checkAuth auth return $ ServerMessage $ "Welcome, " ++ authUser (fromJust auth) Register -> newUser auth >> return ServerAck ResetPassword passwd -> resetPassword auth passwd >> return ServerAck@@ -164,15 +208,15 @@ (fromJust<$>)$ runMaybeT $ msum [ do v <- MaybeT $ return mversion msum [ guard (v >= curV) >> return ServerFresh- , do - guard (v >= curV - 10) + , do+ guard (v >= curV - 10) RCUserInfoDeltas deltas <- lift $ getRecordErrored $ RecUserInfoLog name return $ ServedUserInfoDeltas $ take (curV-v) deltas ] , return $ ServedUserInfo (curV,info) ] ) `catchError` \_ -> return ServerCodenameFree- GetSolution note -> do + GetSolution note -> do uinfo <- getUserInfoOfAuth auth let uname = codename uinfo onLinfo <- getALock $ noteOn note@@ -190,20 +234,9 @@ else throwError "You don't have access to that note." DeclareSolution soln ls target idx -> do info <- getUserInfoOfAuth auth- lock <- getLock ls- tinfo <- getALock target- when (ls /= lockSpec tinfo) $ throwError "Lock no longer in use!"- when (public tinfo) $ throwError "Lock solution already public knowledge!" let name = codename info let behind = ActiveLock name idx let note = NoteInfo name (Just behind) target- when (name `elem` map noteAuthor (lockSolutions tinfo)) $- throwError "Note already taken on that lock!"- when (name == lockOwner target) $- throwError "That's your lock!"- behindLock <- getALock behind- when (public behindLock) $ throwError "Your lock is cracked!"- unless (checkSolution lock soln) $ throwError "Bad solution" erroredDB $ putRecord (RecNote note) (RCSolution soln) execStateT (declareNote note behind) [] >>= applyDeltasToRecords return ServerAck@@ -211,13 +244,6 @@ info <- getUserInfoOfAuth auth let name = codename info let al = ActiveLock name idx- ServerInfo serverSize _ <- getServerInfo- when (frame /= BasicFrame serverSize) $ throwError $- "Server only accepts size "++show serverSize++" locks."- unless (validLock $ reframe lock) $ throwError "Invalid lock!"- unless (not.checkSolved $ reframe lock) $ throwError "Lock not locked!"- unless (checkSolution lock soln) $ throwError "Bad solution"- RCLockHashes hashes <- getRecordErrored RecLockHashes `catchError` const (return (RCLockHashes [])) let hashed = hash $ show lock@@ -262,17 +288,17 @@ Left e -> throwError $ "Server IO error: " ++ show e Right x -> return x erroredDB :: DBM a -> ErrorT String IO a- erroredDB = erroredIO . withDB+ erroredDB = erroredIO . withDB dbpath getRecordErrored :: Record -> ErrorT String IO RecordContents getRecordErrored rec = do- mrc <- lift $ withDB $ getRecord rec + mrc <- lift $ withDB dbpath $ getRecord rec case mrc of Just rc -> return rc Nothing -> throwError $ "Bad record on server! Record was: " ++ show rec- getLock ls = do + getLock ls = do RCLock lock <- getRecordErrored $ RecLock ls return lock- getSolution note = do + getSolution note = do RCSolution soln <- getRecordErrored $ RecNote note return soln getServerInfo = do@@ -289,14 +315,14 @@ Just lockinfo -> return lockinfo checkValidLockIndex idx = unless (0<=idx && idx < maxLocks) $ throwError "Bad lock index"- getUserInfo name = do + getUserInfo name = do RCUserInfo (version,info) <- getRecordErrored $ RecUserInfo name return info- getUserInfoOfAuth auth = do + getUserInfoOfAuth auth = do checkAuth auth let Just (Auth name _) = auth getUserInfo name- + checkAuth :: Maybe Auth -> ErrorT String IO () checkAuth Nothing = throwError "Authentication required" checkAuth (Just (Auth name pw)) = do@@ -319,11 +345,11 @@ checkCodeName :: Codename -> ErrorT String IO Bool checkCodeName name = do unless (validCodeName name) $ throwError "Invalid codename"- liftIO $ withDB $ recordExists $ RecPassword name+ liftIO $ withDB dbpath $ recordExists $ RecPassword name --- | TODO: journalling so we can survive death during database writes? applyDeltasToRecords :: [(Codename, UserInfoDelta)] -> ErrorT String IO () applyDeltasToRecords nds = sequence_ $ [applyDeltasToRecord name deltas- | group <- groupBy ((==) `on` fst) nds + | group <- groupBy ((==) `on` fst) nds , let name = fst $ head group , let deltas = map snd group ] applyDeltasToRecord name deltas = do@@ -367,7 +393,7 @@ unless publified $ do lock <- getCurrALock al accessorsOfNotesOnLock <- ((++ map noteAuthor (lockSolutions lock)).concat)- <$> (sequence + <$> (sequence [ accessedBy <$> getCurrALock behind | NoteInfo _ (Just behind) _ <- lockSolutions lock ] ) forM_ accessorsOfNotesOnLock $ checkSuffReadNotes al checkSuffReadNotes target name = do
ServerAddr.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.
Setup.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.
Util.hs view
@@ -3,7 +3,7 @@ -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as--- published by the Free Software Foundation.+-- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/.@@ -11,6 +11,21 @@ module Util where import qualified Data.Vector as Vector import Data.Vector (Vector)+import Control.Monad+import Control.Monad.Trans.Maybe enumVec :: Vector a -> [(Int,a)] enumVec = Vector.toList . Vector.indexed++liftMaybe :: Monad m => Maybe a -> MaybeT m a+liftMaybe = MaybeT . return++-- nice tip from one joeyh:+whenM,unlessM,(>>?),(>>!) :: Monad m => m Bool -> m () -> m ()+whenM c a = c >>= flip when a+unlessM c a = c >>= flip unless a+(>>?) = whenM+(>>!) = unlessM+-- same precedence as ($), allowing e.g. foo bar >>! error $ "failed " ++ meep+infixr 0 >>?+infixr 0 >>!
intricacy.cabal view
@@ -1,5 +1,5 @@ name: intricacy-version: 0.3.8+version: 0.4.1 synopsis: A game of competitive puzzle-design homepage: http://mbays.freeshell.org/intricacy license: GPL-3@@ -57,6 +57,7 @@ , array >=0.3, containers >=0.4, vector >=0.9 , binary >=0.5, network-fancy >= 0.1.5 , cryptohash >= 0.8+ , safe >= 0.2 if flag(SDL) build-depends: SDL >=0.6.5, SDL-ttf >=0.6, SDL-gfx >=0.6 if flag(Sound)
tutorial/1-winning.text view
@@ -1,1 +1,1 @@-click and drag tools to pull bolt, then Open the lock+use tools to pull bolt, then Open the lock