summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authormbays <>2018-01-14 09:26:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-01-14 09:26:00 (GMT)
commit705707758ebd6564226274abfeb27d1876cc5a9b (patch)
tree3dffa52453036d76cb7198364086060416a16a54
parenteb1bff1b15e165a2eed9566763b2eab9640c0e18 (diff)
version 0.7.1.10.7.1.1
-rw-r--r--AsciiLock.hs212
-rw-r--r--BinaryInstances.hs74
-rw-r--r--BoardColouring.hs94
-rw-r--r--Cache.hs64
-rw-r--r--Command.hs14
-rw-r--r--CursesRender.hs34
-rw-r--r--CursesUI.hs14
-rw-r--r--CursesUIMInstance.hs372
-rw-r--r--Database.hs85
-rw-r--r--EditGameState.hs224
-rw-r--r--Frame.hs34
-rw-r--r--GameState.hs204
-rw-r--r--GameStateTypes.hs24
-rw-r--r--GraphColouring.hs22
-rw-r--r--Hex.lhs52
-rw-r--r--Init.hs50
-rw-r--r--Interact.hs692
-rw-r--r--InteractUtil.hs198
-rw-r--r--Lock.hs34
-rw-r--r--MainState.hs298
-rw-r--r--Metagame.hs62
-rw-r--r--Mundanities.hs2
-rw-r--r--NEWS3
-rw-r--r--Physics.hs272
-rw-r--r--Protocol.hs64
-rw-r--r--SDLGlyph.hs278
-rw-r--r--SDLRender.hs116
-rw-r--r--SDLUI.hs580
-rw-r--r--SDLUIMInstance.hs1226
-rw-r--r--Server.hs662
-rw-r--r--ServerAddr.hs10
-rw-r--r--Version.hs2
-rw-r--r--intricacy.cabal17
33 files changed, 3052 insertions, 3037 deletions
diff --git a/AsciiLock.hs b/AsciiLock.hs
index 29d7550..4be6000 100644
--- a/AsciiLock.hs
+++ b/AsciiLock.hs
@@ -47,109 +47,109 @@ lockOfAscii :: AsciiLock -> Maybe Lock
lockOfAscii lines = do
board <- asciiToBoard lines
let size = maximum $ map (hx . (-^origin)) $ Map.keys board
- frame = BasicFrame size
+ frame = BasicFrame size
st <- asciiBoardState frame board
return (frame, st)
boardToAscii :: PieceColouring -> GameBoard -> AsciiLock
boardToAscii colouring board =
let asciiBoard :: Map CVec Char
- asciiBoard = Map.mapKeys (hexVec2CVec . (-^origin))
- $ fmap (monochromeOTileChar colouring) board
- (miny,maxy) = minmax $ map cy $ Map.keys asciiBoard
- (minx,maxx) = minmax $ map cx $ Map.keys asciiBoard
- asciiBoard' = Map.mapKeys (-^CVec miny minx) asciiBoard
+ asciiBoard = Map.mapKeys (hexVec2CVec . (-^origin))
+ $ fmap (monochromeOTileChar colouring) board
+ (miny,maxy) = minmax $ map cy $ Map.keys asciiBoard
+ (minx,maxx) = minmax $ map cx $ Map.keys asciiBoard
+ asciiBoard' = Map.mapKeys (-^CVec miny minx) asciiBoard
in [ [ Map.findWithDefault ' ' (CVec y x) asciiBoard'
- | x <- [0..(maxx-minx)] ]
- | y <- [0..(maxy-miny)] ]
+ | x <- [0..(maxx-minx)] ]
+ | y <- [0..(maxy-miny)] ]
asciiToBoard :: AsciiLock -> Maybe GameBoard
asciiToBoard lines =
let asciiBoard :: Map CVec Char
- asciiBoard = Map.fromList [(CVec y x,ch)
- | (line,y) <- zip lines [0..]
- , (ch,x) <- zip line [0..]
- , ch `notElem` "\t\r\n "]
- (miny,maxy) = minmax $ map cy $ Map.keys asciiBoard
- midy = miny+(maxy-miny)`div`2
- midline = filter ((==midy).cy) $ Map.keys asciiBoard
- (minx,maxx) = minmax $ map cx $ midline
- centre = CVec midy (minx+(maxx-minx)`div`2)
+ asciiBoard = Map.fromList [(CVec y x,ch)
+ | (line,y) <- zip lines [0..]
+ , (ch,x) <- zip line [0..]
+ , ch `notElem` "\t\r\n "]
+ (miny,maxy) = minmax $ map cy $ Map.keys asciiBoard
+ midy = miny+(maxy-miny)`div`2
+ midline = filter ((==midy).cy) $ Map.keys asciiBoard
+ (minx,maxx) = minmax $ map cx $ midline
+ centre = CVec midy (minx+(maxx-minx)`div`2)
in Map.mapKeys ((+^origin) . cVec2HexVec . (-^centre))
- <$> T.mapM monoToOTile asciiBoard
+ <$> T.mapM monoToOTile asciiBoard
asciiBoardState :: Frame -> GameBoard -> Maybe GameState
asciiBoardState frame board =
let addPreBase st = foldr addpp st (replicate 6 $ PlacedPiece origin $ Block [])
- addBase st = foldr addBaseOT st $ Map.toList $
- Map.filter (isBaseTile.snd) board
- isBaseTile (BlockTile _) = True
- isBaseTile (PivotTile _) = True
- isBaseTile HookTile = True
- isBaseTile (WrenchTile _) = True
- isBaseTile (BallTile) = True
- isBaseTile _ = False
- addBaseOT :: (HexPos,(PieceIdx,Tile)) -> GameState -> GameState
- addBaseOT (pos,(o,BlockTile [])) = addBlockPos o pos
- addBaseOT (pos,(-1,t)) = addpp $ PlacedPiece pos $ basePieceOfTile t
- 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 $ map fst $ sortBy (flip compare `on` snd)
- [ ((idx,pp),length vs)
- | (idx,pp) <- enumVec $ placedPieces st
- , Block vs <- [placedPiece pp]
- , let fp = plPieceFootprint pp
- , not $ null fp
- , all (not.inBounds frame) fp
- ]
- return $ delPiece idx $ setpp 0 pp st
- 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 _)) =
- 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 _ dir)) =
- let rpos = (neg dir+^pos)
- in case Map.lookup rpos baseBoard of
- Just (_,SpringTile _ _) -> Just st
- Just _ -> do
- (_,epos) <- castRay pos dir baseBoard
- let twiceNatLen = sum [ extnValue extn
- | i <- [1..hexLen (epos-^rpos)-1]
- , let pos' = i*^dir+^rpos
- , Just (_,SpringTile extn _) <- [ Map.lookup pos' board ] ]
- extnValue Compressed = 4
- extnValue Relaxed = 2
- extnValue Stretched = 1
- Just root = posLocus baseSt rpos
- Just end = posLocus baseSt epos
- Just $ flip addConn st $ Connection root end $ Spring dir $ twiceNatLen`div`2
- _ -> Just st
- addAppendageOT _ _ = Nothing
+ addBase st = foldr addBaseOT st $ Map.toList $
+ Map.filter (isBaseTile.snd) board
+ isBaseTile (BlockTile _) = True
+ isBaseTile (PivotTile _) = True
+ isBaseTile HookTile = True
+ isBaseTile (WrenchTile _) = True
+ isBaseTile (BallTile) = True
+ isBaseTile _ = False
+ addBaseOT :: (HexPos,(PieceIdx,Tile)) -> GameState -> GameState
+ addBaseOT (pos,(o,BlockTile [])) = addBlockPos o pos
+ addBaseOT (pos,(-1,t)) = addpp $ PlacedPiece pos $ basePieceOfTile t
+ 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 $ map fst $ sortBy (flip compare `on` snd)
+ [ ((idx,pp),length vs)
+ | (idx,pp) <- enumVec $ placedPieces st
+ , Block vs <- [placedPiece pp]
+ , let fp = plPieceFootprint pp
+ , not $ null fp
+ , all (not.inBounds frame) fp
+ ]
+ return $ delPiece idx $ setpp 0 pp st
+ 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 _)) =
+ 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 _ dir)) =
+ let rpos = (neg dir+^pos)
+ in case Map.lookup rpos baseBoard of
+ Just (_,SpringTile _ _) -> Just st
+ Just _ -> do
+ (_,epos) <- castRay pos dir baseBoard
+ let twiceNatLen = sum [ extnValue extn
+ | i <- [1..hexLen (epos-^rpos)-1]
+ , let pos' = i*^dir+^rpos
+ , Just (_,SpringTile extn _) <- [ Map.lookup pos' board ] ]
+ extnValue Compressed = 4
+ extnValue Relaxed = 2
+ extnValue Stretched = 1
+ Just root = posLocus baseSt rpos
+ Just end = posLocus baseSt epos
+ Just $ flip addConn st $ Connection root end $ Spring dir $ twiceNatLen`div`2
+ _ -> Just st
+ addAppendageOT _ _ = Nothing
in addAppendages baseSt
monochromeOTileChar :: PieceColouring -> OwnedTile -> Char
monochromeOTileChar colouring (idx,BlockTile _) =
case Map.lookup idx colouring of
- Just 1 -> '%'
- Just 2 -> '"'
- Just 3 -> '&'
- Just 4 -> '~'
- _ -> '#'
+ Just 1 -> '%'
+ Just 2 -> '"'
+ Just 3 -> '&'
+ Just 4 -> '~'
+ _ -> '#'
monochromeOTileChar _ (_,t) = monochromeTileChar t
monochromeTileChar :: Tile -> Char
monochromeTileChar (PivotTile _) = 'o'
@@ -165,29 +165,29 @@ monochromeTileChar (WrenchTile _) = '*'
monochromeTileChar BallTile = 'O'
monochromeTileChar (SpringTile extn dir)
| dir == hu = case extn of
- Stretched -> 's'
- Relaxed -> 'S'
- Compressed -> '$'
+ Stretched -> 's'
+ Relaxed -> 'S'
+ Compressed -> '$'
| dir == hv = case extn of
- Stretched -> 'z'
- Relaxed -> 'Z'
- Compressed -> '5'
+ Stretched -> 'z'
+ Relaxed -> 'Z'
+ Compressed -> '5'
| dir == hw = case extn of
- Stretched -> '('
- Relaxed -> '['
- Compressed -> '{'
+ Stretched -> '('
+ Relaxed -> '['
+ Compressed -> '{'
| dir == neg hu = case extn of
- Stretched -> 'c'
- Relaxed -> 'C'
- Compressed -> 'D'
+ Stretched -> 'c'
+ Relaxed -> 'C'
+ Compressed -> 'D'
| dir == neg hv = case extn of
- Stretched -> ')'
- Relaxed -> ']'
- Compressed -> '}'
+ Stretched -> ')'
+ Relaxed -> ']'
+ Compressed -> '}'
| dir == neg hw = case extn of
- Stretched -> '1'
- Relaxed -> '7'
- Compressed -> '9'
+ Stretched -> '1'
+ Relaxed -> '7'
+ Compressed -> '9'
monochromeTileChar _ = '?'
monoToOTile :: Char -> Maybe OwnedTile
monoToOTile '#' = Just $ (1,BlockTile [])
@@ -234,13 +234,13 @@ readAsciiLockFile :: FilePath -> IO (Maybe Lock, Maybe Solution)
readAsciiLockFile path = flip catchIO (const $ return (Nothing,Nothing)) $ do
lines <- readStrings path
return $ fromMaybe (lockOfAscii lines, Nothing) $ do
- guard $ length lines > 2
- let (locklines, [header,solnLine]) = splitAt (length lines - 2) lines
- guard $ isPrefixOf "Solution:" header
- return (lockOfAscii locklines, tryRead solnLine)
+ guard $ length lines > 2
+ let (locklines, [header,solnLine]) = splitAt (length lines - 2) lines
+ guard $ isPrefixOf "Solution:" header
+ return (lockOfAscii locklines, tryRead solnLine)
writeAsciiLockFile :: FilePath -> Maybe Solution -> Lock -> IO ()
writeAsciiLockFile path msoln lock = do
writeStrings path $ lockToAscii lock ++ case msoln of
- Nothing -> []
- Just soln -> ["Solution:", show soln]
+ Nothing -> []
+ Just soln -> ["Solution:", show soln]
diff --git a/BinaryInstances.hs b/BinaryInstances.hs
index 41f053b..0bc6d09 100644
--- a/BinaryInstances.hs
+++ b/BinaryInstances.hs
@@ -24,14 +24,14 @@ newtype SmallNat = SmallNat {fromSmallNat :: Int}
instance Binary SmallNat where
put (SmallNat n) = if n < 255 then putWord8 (fromIntegral n) else putWord8 255 >> put n
get = do
- n' <- get :: Get Word8
- if n' == 255 then liftM SmallNat get else return $ SmallNat $ fromIntegral n'
+ n' <- get :: Get Word8
+ if n' == 255 then liftM SmallNat get else return $ SmallNat $ fromIntegral n'
instance Binary SmallInt where
put (SmallInt n) = if abs n < 127 then put ((fromIntegral n)::Int8) else put (127::Int8) >> put n
get = do
- n' <- get :: Get Int8
- if n' == 127 then liftM SmallInt get else return $ SmallInt $ fromIntegral n'
+ n' <- get :: Get Int8
+ if n' == 127 then liftM SmallInt get else return $ SmallInt $ fromIntegral n'
putPackedNat,putPackedInt :: Int -> Put
putPackedNat n = put $ SmallNat n
@@ -44,8 +44,8 @@ newtype ShortList a = ShortList {fromShortList :: [a]}
instance Binary a => Binary (ShortList a) where
put (ShortList as) = putPackedNat (length as) >> mapM_ put as
get = do
- n <- getPackedNat
- ShortList `liftM` getMany n
+ n <- getPackedNat
+ ShortList `liftM` getMany n
-- | 'getMany n' get 'n' elements in order, without blowing the stack.
-- [ copied from source of package 'binary' by Lennart Kolmodin ]
@@ -62,9 +62,9 @@ getMany = go []
instance Binary HexVec where
put (HexVec x y _) = putPackedInt x >> putPackedInt y
get = do
- x <- getPackedInt
- y <- getPackedInt
- return $ tupxy2hv (x,y)
+ x <- getPackedInt
+ y <- getPackedInt
+ return $ tupxy2hv (x,y)
instance Binary g => Binary (PHS g) where
put (PHS v) = put v
get = liftM PHS get
@@ -81,40 +81,40 @@ instance Binary Piece where
put (Wrench mom) = put (3::Word8) >> put mom
put Ball = put (4::Word8)
get = do
- tag <- get :: Get Word8
- case tag of
- 0 -> liftM (Block . fromShortList) get
- 1 -> liftM (Pivot . fromShortList) get
- 2 -> liftM2 Hook get get
- 3 -> liftM Wrench get
- 4 -> return Ball
+ tag <- get :: Get Word8
+ case tag of
+ 0 -> liftM (Block . fromShortList) get
+ 1 -> liftM (Pivot . fromShortList) get
+ 2 -> liftM2 Hook get get
+ 3 -> liftM Wrench get
+ 4 -> return Ball
instance Binary Connection where
put (Connection (ri,rp) (ei,ep) l) = putPackedInt ri >> put rp >> putPackedInt ei >> put ep >> put l
get = do
- ri <- getPackedInt
- rp <- get
- ei <- getPackedInt
- ep <- get
- l <- get
- return $ Connection (ri,rp) (ei,ep) l
+ ri <- getPackedInt
+ rp <- get
+ ei <- getPackedInt
+ ep <- get
+ l <- get
+ return $ Connection (ri,rp) (ei,ep) l
instance Binary Link where
put (Free p) = put (0::Word8) >> put p
put (Spring d l) = put (1::Word8) >> put d >> putPackedInt l
get = do
- tag <- get :: Get Word8
- case tag of
- 0 -> liftM Free get
- 1 -> liftM2 Spring get getPackedInt
+ tag <- get :: Get Word8
+ case tag of
+ 0 -> liftM Free get
+ 1 -> liftM2 Spring get getPackedInt
instance Binary HookForce where
put NullHF = put (0::Word8)
put (TorqueHF dir) = put (1::Word8) >> putPackedInt dir
put (PushHF v) = put (2::Word8) >> put v
get = do
- tag <- get :: Get Word8
- case tag of
- 0 -> return NullHF
- 1 -> liftM TorqueHF getPackedInt
- 2 -> liftM PushHF get
+ tag <- get :: Get Word8
+ case tag of
+ 0 -> return NullHF
+ 1 -> liftM TorqueHF getPackedInt
+ 2 -> liftM PushHF get
instance Binary Frame where
put (BasicFrame s) = putPackedInt s
get = liftM BasicFrame getPackedInt
@@ -125,9 +125,9 @@ instance Binary PlayerMove where
put (HookTorque dir) = put (2::Word8) >> putPackedInt dir
put (WrenchPush v) = put (3::Word8) >> put v
get = do
- tag <- get :: Get Word8
- case tag of
- 0 -> return NullPM
- 1 -> liftM HookPush get
- 2 -> liftM HookTorque getPackedInt
- 3 -> liftM WrenchPush get
+ tag <- get :: Get Word8
+ case tag of
+ 0 -> return NullPM
+ 1 -> liftM HookPush get
+ 2 -> liftM HookTorque getPackedInt
+ 3 -> liftM WrenchPush get
diff --git a/BoardColouring.hs b/BoardColouring.hs
index e4efe8b..babc225 100644
--- a/BoardColouring.hs
+++ b/BoardColouring.hs
@@ -32,61 +32,61 @@ colouredPieces :: Bool -> GameState -> [PieceIdx]
colouredPieces colourFixed st = [ idx |
(idx, PlacedPiece _ p) <- enumVec $ placedPieces st
, isPivot p ||
- and [ isBlock p, idx > 0
- , or [ colourFixed, not $ null $ springsEndAtIdx st idx ] ] ]
+ and [ isBlock p, idx > 0
+ , or [ colourFixed, not $ null $ springsEndAtIdx st idx ] ] ]
pieceTypeColouring :: GameState -> [PieceIdx] -> PieceColouring
pieceTypeColouring st coloured = Map.fromList
[ (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 ]
+ , 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
where
- board = stateBoard st
- graph = Map.fromList [ (idx, nub $ neighbours idx)
- | idx <- coloured ]
- neighbours idx =
- neighbours' idx (perim idx) []
- perim :: PieceIdx -> Set (HexPos,HexDir)
- perim idx =
- Set.fromList $ nubBy ((==)`on`fst) [ (pos', neg dir)
- | dir <- hexDirs
- , pos <- fullFootprint st idx
- , let pos' = dir +^ pos
- , Just True /= do
- (idx',_) <- Map.lookup pos' board
- return $ idx == idx'
- ]
- neighbours' :: PieceIdx -> Set (HexPos,HexDir) -> [PieceIdx] -> [PieceIdx]
- neighbours' idx as ns
- | Set.null as = ns
- | otherwise =
- let a = head $ Set.elems as
- (path, ns') = march idx (fst a) a True
- in neighbours' idx
- (Set.filter (\(pos,_) -> pos `notElem` path) as)
- (ns++ns')
- -- |march around the piece's boundary, returning positions visited and
- -- neighbouring pieces met (in order)
- march idx startPos (pos,basedir) init
- | not init && pos == startPos = ([],[])
- | otherwise =
- let mn = do
- (idx',_) <- Map.lookup pos board
- guard $ idx' `elem` coloured
- return idx'
- mNext = listToMaybe
- [ (pos', rotate (h-2) basedir)
- | 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 mn)++ns)
+ board = stateBoard st
+ graph = Map.fromList [ (idx, nub $ neighbours idx)
+ | idx <- coloured ]
+ neighbours idx =
+ neighbours' idx (perim idx) []
+ perim :: PieceIdx -> Set (HexPos,HexDir)
+ perim idx =
+ Set.fromList $ nubBy ((==)`on`fst) [ (pos', neg dir)
+ | dir <- hexDirs
+ , pos <- fullFootprint st idx
+ , let pos' = dir +^ pos
+ , Just True /= do
+ (idx',_) <- Map.lookup pos' board
+ return $ idx == idx'
+ ]
+ neighbours' :: PieceIdx -> Set (HexPos,HexDir) -> [PieceIdx] -> [PieceIdx]
+ neighbours' idx as ns
+ | Set.null as = ns
+ | otherwise =
+ let a = head $ Set.elems as
+ (path, ns') = march idx (fst a) a True
+ in neighbours' idx
+ (Set.filter (\(pos,_) -> pos `notElem` path) as)
+ (ns++ns')
+ -- |march around the piece's boundary, returning positions visited and
+ -- neighbouring pieces met (in order)
+ march idx startPos (pos,basedir) init
+ | not init && pos == startPos = ([],[])
+ | otherwise =
+ let mn = do
+ (idx',_) <- Map.lookup pos board
+ guard $ idx' `elem` coloured
+ return idx'
+ mNext = listToMaybe
+ [ (pos', rotate (h-2) basedir)
+ | 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 mn)++ns)
diff --git a/Cache.hs b/Cache.hs
index 196ac5e..b582ca7 100644
--- a/Cache.hs
+++ b/Cache.hs
@@ -45,31 +45,31 @@ getRecordCached saddr auth mflag cOnly rec = do
unless (cOnly || fresh) $ void $ forkIO $ getRecordFromServer fromCache tvar
return tvar
where
- getRecordFromServer fromCache tvar = do
- let action = case rec of
- RecUserInfo name ->
- let curVersion = (\(RCUserInfo (v,_)) -> v) <$> fromCache
- in GetUserInfo name curVersion
- _ -> askForRecord rec
- resp <- makeRequest saddr (ClientRequest
- protocolVersion (if needsAuth action then auth else Nothing) action)
- case resp of
- ServerError err -> tellRec $ FetchedRecord True (Just err) fromCache
- ServerCodenameFree -> tellRec $ FetchedRecord True Nothing Nothing
- ServerFresh -> tellRec $ FetchedRecord True Nothing fromCache
- ServedUserInfoDeltas deltas -> do
- let Just (RCUserInfo (v,info)) = fromCache
- let rc = RCUserInfo (v+length deltas, applyDeltas info deltas)
- withCache saddr $ putRecord rec rc
- tellRec $ FetchedRecord True Nothing (Just rc)
- _ -> do
- let rc = rcOfServerResp resp
- withCache saddr $ putRecord rec rc
- tellRec $ FetchedRecord True Nothing (Just rc)
- where
- tellRec fr = atomically $ do
- writeTVar tvar fr
- case mflag of {Just flag -> writeTVar flag True; _ -> return ()}
+ getRecordFromServer fromCache tvar = do
+ let action = case rec of
+ RecUserInfo name ->
+ let curVersion = (\(RCUserInfo (v,_)) -> v) <$> fromCache
+ in GetUserInfo name curVersion
+ _ -> askForRecord rec
+ resp <- makeRequest saddr (ClientRequest
+ protocolVersion (if needsAuth action then auth else Nothing) action)
+ case resp of
+ ServerError err -> tellRec $ FetchedRecord True (Just err) fromCache
+ ServerCodenameFree -> tellRec $ FetchedRecord True Nothing Nothing
+ ServerFresh -> tellRec $ FetchedRecord True Nothing fromCache
+ ServedUserInfoDeltas deltas -> do
+ let Just (RCUserInfo (v,info)) = fromCache
+ let rc = RCUserInfo (v+length deltas, applyDeltas info deltas)
+ withCache saddr $ putRecord rec rc
+ tellRec $ FetchedRecord True Nothing (Just rc)
+ _ -> do
+ let rc = rcOfServerResp resp
+ withCache saddr $ putRecord rec rc
+ tellRec $ FetchedRecord True Nothing (Just rc)
+ where
+ tellRec fr = atomically $ do
+ writeTVar tvar fr
+ case mflag of {Just flag -> writeTVar flag True; _ -> return ()}
waitFetchedFresh :: TVar FetchedRecord -> IO ()
waitFetchedFresh tvar = atomically $ readTVar tvar >>= check.fresh
@@ -79,19 +79,19 @@ makeRequest saddr _ | nullSaddr saddr =
return $ ServerError "No server set."
makeRequest saddr@(ServerAddr host port) request =
handle (return . ServerError . (show::SomeException -> String)) $
- withStream (IP host port) makeRequest'
- `catchIO` (const $ return $ ServerError $ "Cannot connect to "++saddrStr saddr++"!")
+ withStream (IP host port) makeRequest'
+ `catchIO` (const $ return $ ServerError $ "Cannot connect to "++saddrStr saddr++"!")
where
- makeRequest' hdl = do
- BS.hPut hdl $ BL.toStrict $ encode request
- hFlush hdl
- (decode . BL.fromStrict) `liftM` BS.hGetContents hdl
+ makeRequest' hdl = do
+ BS.hPut hdl $ BL.toStrict $ encode request
+ hFlush hdl
+ (decode . BL.fromStrict) `liftM` BS.hGetContents hdl
knownServers :: IO [ServerAddr]
knownServers = flip catchIO (const $ return []) $ do
cachedir <- confFilePath "cache"
saddrstrs <- getDirectoryContents cachedir >>= filterM (\dir ->
- doesFileExist $ cachedir++[pathSeparator]++dir++[pathSeparator]++"serverInfo")
+ doesFileExist $ cachedir++[pathSeparator]++dir++[pathSeparator]++"serverInfo")
return $ concat $ map (maybeToList . strToSaddr) saddrstrs
withCache :: ServerAddr -> DBM a -> IO a
diff --git a/Command.hs b/Command.hs
index 8db7bd2..624d717 100644
--- a/Command.hs
+++ b/Command.hs
@@ -54,7 +54,7 @@ data WrHoSel = WHSWrench | WHSHook | WHSSelected
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"
+ ++ " " ++ (if dir == 1 then "counter" else "") ++ "clockwise"
describeCommand CmdWait = "nothing"
describeCommand CmdToggle = "toggle tool"
describeCommand CmdOpen = "open lock"
@@ -78,17 +78,17 @@ describeCommand CmdShowRetired = "toggle showing retired locks"
describeCommand CmdSetServer = "set server"
describeCommand CmdToggleCacheOnly = "toggle offline mode"
describeCommand (CmdSelCodename mname) = "select player"
- ++ maybe "" (' ':) mname
+ ++ maybe "" (' ':) mname
describeCommand CmdBackCodename = "select last player"
describeCommand CmdHome = "select self"
describeCommand (CmdSolve mli) = "solve lock"
- ++ maybe "" ((' ':).(:"").lockIndexChar) mli
+ ++ maybe "" ((' ':).(:"").lockIndexChar) mli
describeCommand (CmdPlayLockSpec mls) = "find lock by number"
- ++ maybe "" ((' ':).show) mls
+ ++ maybe "" ((' ':).show) mls
describeCommand (CmdDeclare mundecl) = "declare solution"
- ++ maybe "" (\_->" [specified solution]") mundecl
+ ++ maybe "" (\_->" [specified solution]") mundecl
describeCommand (CmdViewSolution mnote) = "view lock solution"
- ++ maybe "" (\_->" [specified solution]") mnote
+ ++ maybe "" (\_->" [specified solution]") mnote
describeCommand CmdSelectLock = "choose lock by name"
describeCommand CmdNextLock = "next lock"
describeCommand CmdPrevLock = "previous lock"
@@ -96,7 +96,7 @@ describeCommand CmdNextPage = "page forward through lists"
describeCommand CmdPrevPage = "page back through lists"
describeCommand CmdEdit = "edit lock"
describeCommand (CmdPlaceLock mli) = "place lock"
- ++ maybe "" ((' ':).(:"").lockIndexChar) mli
+ ++ maybe "" ((' ':).(:"").lockIndexChar) mli
describeCommand (CmdRegister False) = "register codename"
describeCommand (CmdRegister True) = "adjust registration details"
describeCommand CmdAuth = "authenticate"
diff --git a/CursesRender.hs b/CursesRender.hs
index 3e7bf76..74e048d 100644
--- a/CursesRender.hs
+++ b/CursesRender.hs
@@ -28,17 +28,17 @@ colorsToPairs :: [(Curses.Color, Curses.Color)] -> IO [Curses.Pair]
colorsToPairs cs = do
p <- Curses.colorPairs
let nColors = length cs
- blackWhite = p < nColors
+ 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
+ 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
+ let p = Curses.Pair n
+ Curses.initPair p fg bg
+ return p
type AttrChar = (Char, Curses.Attr)
type ColPair = Int
@@ -63,11 +63,11 @@ tileChar (PivotTile dir)
| 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
+ 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)
@@ -82,10 +82,10 @@ 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
- Just n -> n+1
- rev = owner `elem` reversed
+ pair = case Map.lookup owner colouring of
+ Nothing -> 0
+ Just n -> n+1
+ rev = owner `elem` reversed
in Glyph ch pair (Curses.setReverse attr rev)
addCh :: Char -> IO ()
diff --git a/CursesUI.hs b/CursesUI.hs
index 6482f06..5984dcb 100644
--- a/CursesUI.hs
+++ b/CursesUI.hs
@@ -67,7 +67,7 @@ bindingsStr :: InputMode -> [Command] -> UIM String
bindingsStr mode cmds = do
bdgs <- getBindings mode
return $ (("["++).(++"]")) $ intercalate "," $
- map (maybe "" showKey . findBinding bdgs) cmds
+ map (maybe "" showKey . findBinding bdgs) cmds
data Gravity = GravUp | GravLeft | GravRight | GravDown | GravCentre
@@ -266,17 +266,17 @@ drawStateWithGeom reversed colourFixed lastCol st geom = do
let colouring = boardColouring st (colouredPieces colourFixed st) lastCol
mono <- gets monochrome
sequence_ [ drawAtWithGeom glyph pos geom |
- (pos,glyph) <- Map.toList $ fmap (ownedTileGlyph mono colouring reversed) $ stateBoard st
- ]
+ (pos,glyph) <- Map.toList $ fmap (ownedTileGlyph mono colouring reversed) $ stateBoard st
+ ]
return colouring
drawMsgLine = void.runMaybeT $ do
(attr,col,str) <- MaybeT $ gets message
lift $ do
- (h,w) <- liftIO Curses.scrSize
- liftIO $ clearLine $ h-1
- let str' = take (w-1) str
- drawStr attr col (CVec (h-1) 0) str'
+ (h,w) <- liftIO Curses.scrSize
+ liftIO $ clearLine $ h-1
+ let str' = take (w-1) str
+ drawStr attr col (CVec (h-1) 0) str'
setMsgLine attr col str = do
modify $ \s -> s { message = Just (attr,col,str) }
drawMsgLine
diff --git a/CursesUIMInstance.hs b/CursesUIMInstance.hs
index e63d80c..128a46b 100644
--- a/CursesUIMInstance.hs
+++ b/CursesUIMInstance.hs
@@ -54,23 +54,23 @@ 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,magenta)
- Just (-2) -> (a0,red)
- Just (-3) -> (bold,red)
- _ -> if ourName == Just name then (bold,white) else (a0,white)
+ Just 0 -> (a0,yellow)
+ Just 1 -> (bold,cyan)
+ Just 2 -> (a0,green)
+ Just 3 -> (bold,green)
+ Just (-1) -> (bold,magenta)
+ Just (-2) -> (a0,red)
+ Just (-3) -> (bold,red)
+ _ -> if ourName == Just name then (bold,white) else (a0,white)
lift $ drawStrCentred attr col pos
- (name ++ if showScore then " " ++ maybe "" show relScore else "")
+ (name ++ if showScore then " " ++ maybe "" show relScore else "")
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)
+ (if accessed then green else white)
+ (lockIndexChar i)
drawNameWithChar :: CVec -> Codename -> ColPair -> Char -> MainStateT UIM ()
drawNameWithChar pos name charcol char = do
@@ -89,26 +89,26 @@ drawNote pos note = case noteBehind note of
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)
- cv = (b+t)`div`2
- ch = (l+r)`div`2
- gravCentre = case grav of
- GravDown -> CVec b ch
- GravUp -> CVec t ch
- GravLeft -> CVec cv l
- GravRight -> CVec cv r
- GravCentre -> CVec cv ch
- locs = sortBy (compare `on` dist) $ concat
- [ map (CVec j) [ l+margin + (width+1)*i | i <- [0..(r-l-(2*margin))`div`(width+1)] ]
- | j <- [t..b]
- , let margin = if (j-starty)`mod`2 == 0 then half else width ]
- dist v = sqlen $ v -^ gravCentre
- sqlen (CVec y x) = (y*(width+1))^2+x^2
+ starty = (if grav == GravDown then b else t)
+ cv = (b+t)`div`2
+ ch = (l+r)`div`2
+ gravCentre = case grav of
+ GravDown -> CVec b ch
+ GravUp -> CVec t ch
+ GravLeft -> CVec cv l
+ GravRight -> CVec cv r
+ GravCentre -> CVec cv ch
+ locs = sortBy (compare `on` dist) $ concat
+ [ map (CVec j) [ l+margin + (width+1)*i | i <- [0..(r-l-(2*margin))`div`(width+1)] ]
+ | j <- [t..b]
+ , let margin = if (j-starty)`mod`2 == 0 then half else width ]
+ dist v = sqlen $ v -^ gravCentre
+ sqlen (CVec y x) = (y*(width+1))^2+x^2
selDraws <- do
- offset <- gets listOffset
- let na = length locs
- nd = length draws
- return $ drop (max 0 $ min (nd - na) (na*offset)) $ draws
+ offset <- gets listOffset
+ let na = length locs
+ nd = length draws
+ return $ drop (max 0 $ min (nd - na) (na*offset)) $ draws
let zipped = zip locs selDraws
sequence_ $ map (uncurry ($)) $ zip selDraws locs
return $ (if grav==GravDown then (minimum.(b:)) else (maximum.(t:))) [ y | (CVec y x,_) <- zipped ]
@@ -121,29 +121,29 @@ drawLockInfo al@(ActiveLock name i) lockinfo = do
ourName <- (authUser <$>) <$> gets curAuth
(lockTop, lockBottom) <- (fromJust<$>)$ runMaybeT $ msum
- [ do
- lock <- mgetLock $ lockSpec lockinfo
- let size = frameSize $ fst lock
- guard $ bottom - top >= 5 + 2*size+1 + 1 + 5 && right-left >= 4*size+1
- lift.lift $ drawStateWithGeom [] False Map.empty (snd lock) (CVec hcentre vcentre,origin)
- return (hcentre - size - 1, hcentre + size + 1)
- , lift $ do
- drawActiveLock (CVec hcentre vcentre) al
- return (hcentre - 1, hcentre + 1)
- ]
+ [ do
+ lock <- mgetLock $ lockSpec lockinfo
+ let size = frameSize $ fst lock
+ guard $ bottom - top >= 5 + 2*size+1 + 1 + 5 && right-left >= 4*size+1
+ lift.lift $ drawStateWithGeom [] False Map.empty (snd lock) (CVec hcentre vcentre,origin)
+ return (hcentre - size - 1, hcentre + size + 1)
+ , lift $ do
+ drawActiveLock (CVec hcentre vcentre) al
+ return (hcentre - 1, hcentre + 1)
+ ]
startOn <-
- 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)) 5 GravDown $
+ 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)) 5 GravDown $
[ \pos -> drawNote pos note | note <- lockSolutions lockinfo ] ++
[ \pos -> drawName False pos name
- | name <- accessedBy lockinfo \\ map noteAuthor (lockSolutions lockinfo) ]
+ | name <- accessedBy lockinfo \\ map noteAuthor (lockSolutions lockinfo) ]
lift $ drawStrCentred a0 white (CVec (startOn-1) vcentre) "Accessed by:"
undecls <- gets undeclareds
@@ -152,21 +152,21 @@ drawLockInfo al@(ActiveLock name i) lockinfo = do
else if any (\(Undeclared _ ls _) -> ls == lockSpec lockinfo) undecls
then lift $ drawStrCentred a0 yellow (CVec (lockBottom+1) vcentre) "Undeclared solution!"
else do
- read <- take 3 <$> getNotesReadOn lockinfo
- unless (null read || ourName == Just name) $ do
- let rntext = if right-left > 30 then "Read notes by:" else "Notes:"
- s = vcentre - (length rntext+(3+1)*3)`div`2
- lift $ drawStr a0 white (CVec (lockBottom+1) s) rntext
- void $ fillBox (CVec (lockBottom+1) (s+length rntext+1)) (CVec (lockBottom+1) right) 3 GravLeft
- [ \pos -> drawName False pos name | name <- map noteAuthor read ]
+ read <- take 3 <$> getNotesReadOn lockinfo
+ unless (null read || ourName == Just name) $ do
+ let rntext = if right-left > 30 then "Read notes by:" else "Notes:"
+ s = vcentre - (length rntext+(3+1)*3)`div`2
+ lift $ drawStr a0 white (CVec (lockBottom+1) s) rntext
+ void $ fillBox (CVec (lockBottom+1) (s+length rntext+1)) (CVec (lockBottom+1) right) 3 GravLeft
+ [ \pos -> drawName False pos name | name <- map noteAuthor read ]
lift $ drawStrCentred a0 white (CVec (lockBottom+2) vcentre) "Notes held:"
if null $ notesSecured lockinfo
- then lift $
- drawStrCentred a0 white (CVec (lockBottom+3) vcentre) "None"
- else
- void $ fillBox (CVec (lockBottom+3) (left+1)) (CVec bottom (right-1)) 5 GravUp
- [ (`drawActiveLock` al) | al <- map noteOn $ notesSecured lockinfo ]
+ then lift $
+ drawStrCentred a0 white (CVec (lockBottom+3) vcentre) "None"
+ else
+ void $ fillBox (CVec (lockBottom+3) (left+1)) (CVec bottom (right-1)) 5 GravUp
+ [ (`drawActiveLock` al) | al <- map noteOn $ notesSecured lockinfo ]
data HelpReturn = HelpNone | HelpDone | HelpContinue Int
@@ -272,46 +272,46 @@ instance UIMonad (StateT UIState IO) where
runUI m = evalStateT m nullUIState
drawMainState = do
- lift erase
- s <- get
- lift . drawTitle =<< getTitle
- lift drawMsgLine
- drawMainState' s
- lift refresh
- where
- drawMainState' (PlayState { psCurrentState=st, psLastAlerts=alerts,
+ lift erase
+ s <- get
+ lift . drawTitle =<< getTitle
+ lift drawMsgLine
+ drawMainState' s
+ lift refresh
+ where
+ drawMainState' (PlayState { psCurrentState=st, psLastAlerts=alerts,
wrenchSelected=wsel, psFrame=frame }) = lift $ do
- drawState [] False alerts st
+ drawState [] False alerts st
drawBindingsTables IMPlay frame
- drawCursorAt $ listToMaybe [ pos |
- (_, PlacedPiece pos p) <- enumVec $ placedPieces st
- , or [wsel && isWrench p, not wsel && isHook p] ]
- drawMainState' (ReplayState {}) = do
- lift . drawState [] False [] =<< gets rsCurrentState
- lift $ drawCursorAt Nothing
- drawMainState' (EditState { esGameStateStack=(st:_), selectedPiece=selPiece,
+ drawCursorAt $ listToMaybe [ pos |
+ (_, PlacedPiece pos p) <- enumVec $ placedPieces st
+ , or [wsel && isWrench p, not wsel && isHook p] ]
+ drawMainState' (ReplayState {}) = do
+ lift . drawState [] False [] =<< gets rsCurrentState
+ lift $ drawCursorAt Nothing
+ drawMainState' (EditState { esGameStateStack=(st:_), selectedPiece=selPiece,
selectedPos=selPos, esFrame=frame }) = lift $ do
- drawState (maybeToList selPiece) True [] st
+ drawState (maybeToList selPiece) True [] st
drawBindingsTables IMEdit frame
- drawCursorAt $ if isNothing selPiece then Just selPos else Nothing
- drawMainState' (MetaState {curServer=saddr, undeclareds=undecls,
- cacheOnly=cOnly, curAuth=auth, codenameStack=names,
- randomCodenames=rnamestvar, retiredLocks=mretired, curLockPath=path,
- curLock=lock}) = do
- let ourName = liftM authUser auth
- let selName = listToMaybe names
- let home = isJust ourName && ourName == selName
- (h,w) <- liftIO Curses.scrSize
- when (h<20 || w<40) $ liftIO CursesH.end >> error "Terminal too small!"
+ drawCursorAt $ if isNothing selPiece then Just selPos else Nothing
+ drawMainState' (MetaState {curServer=saddr, undeclareds=undecls,
+ cacheOnly=cOnly, curAuth=auth, codenameStack=names,
+ randomCodenames=rnamestvar, retiredLocks=mretired, curLockPath=path,
+ curLock=lock}) = do
+ let ourName = liftM authUser auth
+ let selName = listToMaybe names
+ let home = isJust ourName && ourName == selName
+ (h,w) <- liftIO Curses.scrSize
+ when (h<20 || w<40) $ liftIO CursesH.end >> error "Terminal too small!"
bdgs <- lift $ getBindings IMMeta
- lift $ do
- drawCursorAt Nothing
- let serverBdgsDraw = bindingsDraw bdgs
+ lift $ do
+ drawCursorAt Nothing
+ let serverBdgsDraw = bindingsDraw bdgs
[CmdSetServer, CmdToggleCacheOnly]
lockBdgsDraw = bindingsDraw bdgs $
[CmdEdit] ++ if path == "" then [] else [CmdPlaceLock Nothing]
leftBdgsWidth = (+3) . maximum $ map drawWidth [serverBdgsDraw, lockBdgsDraw]
- helpDraw = bindingsDraw bdgs [CmdTutorials] <> greyDraw " tutorial " <>
+ helpDraw = bindingsDraw bdgs [CmdTutorials] <> greyDraw " tutorial " <>
bindingsDraw bdgs [CmdHelp] <> greyDraw " help"
serverTextDraw = greyDraw . take (w - leftBdgsWidth - drawWidth helpDraw - 1) $
" Server: " ++ saddrStr saddr ++ (if cOnly then " (offline mode) " else "")
@@ -319,46 +319,46 @@ instance UIMonad (StateT UIState IO) where
[CmdSelectLock] ++ if path == "" then [] else [CmdNextLock, CmdPrevLock]
lockTextDraw = greyDraw . take (w - leftBdgsWidth - drawWidth lockBdgsDraw' - 1) $
" Lock: " ++ path ++ replicate 5 ' '
- doDrawAt (CVec 0 0) $ alignDraw GravLeft leftBdgsWidth serverBdgsDraw <> serverTextDraw
+ doDrawAt (CVec 0 0) $ alignDraw GravLeft leftBdgsWidth serverBdgsDraw <> serverTextDraw
doDrawAt (CVec 0 0) $ alignDraw GravRight w helpDraw
- doDrawAt (CVec 1 0) $ alignDraw GravLeft leftBdgsWidth lockBdgsDraw <> lockTextDraw <> lockBdgsDraw'
+ doDrawAt (CVec 1 0) $ alignDraw GravLeft leftBdgsWidth lockBdgsDraw <> lockTextDraw <> lockBdgsDraw'
doDrawAt (CVec 2 $ maximum [w`div`3+1, w`div`2 - 13]) $ bindingsDraw bdgs [CmdSelCodename Nothing]
- maybe (return ()) (drawName True (CVec 2 (w`div`2))) selName
- void.runMaybeT $ MaybeT (return selName) >>= lift . getUInfoFetched 300 >>=
- \(FetchedRecord fresh err muirc) -> lift $ do
- lift $ do
- unless fresh $ drawAtCVec (Glyph '*' red bold) $ CVec 2 (w`div`2+7)
- maybe (return ()) sayError err
- when (fresh && (isNothing ourName || home || isNothing muirc)) $
- doDrawAt (CVec 2 (w`div`2+1+9)) $
- bindingsDraw bdgs $
- if (isNothing muirc && isNothing ourName) || home
+ maybe (return ()) (drawName True (CVec 2 (w`div`2))) selName
+ void.runMaybeT $ MaybeT (return selName) >>= lift . getUInfoFetched 300 >>=
+ \(FetchedRecord fresh err muirc) -> lift $ do
+ lift $ do
+ unless fresh $ drawAtCVec (Glyph '*' red bold) $ CVec 2 (w`div`2+7)
+ maybe (return ()) sayError err
+ when (fresh && (isNothing ourName || home || isNothing muirc)) $
+ doDrawAt (CVec 2 (w`div`2+1+9)) $
+ bindingsDraw bdgs $
+ if (isNothing muirc && isNothing ourName) || home
then [CmdRegister $ isJust ourName] else [CmdAuth]
- for_ muirc $ \(RCUserInfo (_,uinfo)) -> case mretired of
- Just retired -> do
- (h,w) <- liftIO Curses.scrSize
- void $ fillBox (CVec 6 2) (CVec (h-1) (w-2)) 5 GravCentre
- [ \pos -> lift $ drawStrGrey pos $ show ls | ls <- retired ]
- lift $ doDrawAt (CVec 5 (w`div`3)) $ bindingsDraw bdgs $
- [CmdShowRetired] ++ if null retired
+ for_ muirc $ \(RCUserInfo (_,uinfo)) -> case mretired of
+ Just retired -> do
+ (h,w) <- liftIO Curses.scrSize
+ void $ fillBox (CVec 6 2) (CVec (h-1) (w-2)) 5 GravCentre
+ [ \pos -> lift $ drawStrGrey pos $ show ls | ls <- retired ]
+ lift $ doDrawAt (CVec 5 (w`div`3)) $ bindingsDraw bdgs $
+ [CmdShowRetired] ++ if null retired
then [] else [CmdPlayLockSpec Nothing]
- Nothing -> do
- sequence_ [ drawLockInfo (ActiveLock (codename uinfo) i) lockinfo |
- (i,Just lockinfo) <- assocs $ userLocks uinfo ]
- unless (null $ elems $ userLocks uinfo) $ lift $
- doDrawAt (CVec 5 (w`div`3)) $ bindingsDraw bdgs $
+ Nothing -> do
+ sequence_ [ drawLockInfo (ActiveLock (codename uinfo) i) lockinfo |
+ (i,Just lockinfo) <- assocs $ userLocks uinfo ]
+ unless (null $ elems $ userLocks uinfo) $ lift $
+ doDrawAt (CVec 5 (w`div`3)) $ bindingsDraw bdgs $
[CmdSolve Nothing] ++ if isJust ourName then [CmdViewSolution Nothing] else []
- when (isJust ourName && ourName == selName) $ do
- rnames <- liftIO $ atomically $ readTVar rnamestvar
- unless (null rnames) $
- void $ fillBox (CVec 2 0) (CVec 5 (w`div`3)) 3 GravCentre
- [ \pos -> drawName False pos name | name <- rnames ]
- unless (null undecls) $
+ when (isJust ourName && ourName == selName) $ do
+ rnames <- liftIO $ atomically $ readTVar rnamestvar
+ unless (null rnames) $
+ void $ fillBox (CVec 2 0) (CVec 5 (w`div`3)) 3 GravCentre
+ [ \pos -> drawName False pos name | name <- rnames ]
+ unless (null undecls) $
let declareBdgDraw = bindingsDraw bdgs [CmdDeclare Nothing]
declareText = " Undeclared solutions:"
- y = 4
+ y = 4
leftBound = w`div`3 + 1
undeclsWidth = 1 + 6 * length undecls
declareDraw =
@@ -374,33 +374,33 @@ instance UIMonad (StateT UIState IO) where
(CVec y (w-1)) 5 GravLeft
[ (`drawActiveLock` al) | Undeclared _ _ al <- undecls ]
- when (ourName /= selName) $ void $ runMaybeT $ do
- sel <- liftMaybe selName
- us <- liftMaybe ourName
- ourUInfo <- mgetUInfo us
- let accessed = [ ActiveLock us i
- | i<-[0..2]
- , Just lock <- [ userLocks ourUInfo ! i ]
- , public lock || selName `elem` map Just (accessedBy lock) ]
- guard $ not $ null accessed
- let str = "has accessed:"
- let s = (w-(4 + length str + 6*(length accessed)))`div`2
- let y = 4
- lift $ do
- drawName False (CVec y (s+1)) sel
- lift $ drawStrGrey (CVec y $ s+4) str
- void $ fillBox (CVec y (s+4+length str+1)) (CVec y (w-1)) 5 GravLeft $
- [ (`drawActiveLock` al) | al <- accessed]
+ when (ourName /= selName) $ void $ runMaybeT $ do
+ sel <- liftMaybe selName
+ us <- liftMaybe ourName
+ ourUInfo <- mgetUInfo us
+ let accessed = [ ActiveLock us i
+ | i<-[0..2]
+ , Just lock <- [ userLocks ourUInfo ! i ]
+ , public lock || selName `elem` map Just (accessedBy lock) ]
+ guard $ not $ null accessed
+ let str = "has accessed:"
+ let s = (w-(4 + length str + 6*(length accessed)))`div`2
+ let y = 4
+ lift $ do
+ drawName False (CVec y (s+1)) sel
+ lift $ drawStrGrey (CVec y $ s+4) str
+ void $ fillBox (CVec y (s+4+length str+1)) (CVec y (w-1)) 5 GravLeft $
+ [ (`drawActiveLock` al) | al <- accessed]
reportAlerts _ alerts =
- do mapM_ drawAlert alerts
- unless (null alerts)
- $ do refresh
- liftIO $ threadDelay $ 5*10^4
- where
- drawAlert (AlertCollision pos) = drawAt cGlyph pos
- drawAlert _ = return ()
- cGlyph = Glyph '!' 0 a0
+ do mapM_ drawAlert alerts
+ unless (null alerts)
+ $ do refresh
+ liftIO $ threadDelay $ 5*10^4
+ where
+ drawAlert (AlertCollision pos) = drawAt cGlyph pos
+ drawAlert _ = return ()
+ cGlyph = Glyph '!' 0 a0
drawMessage = say
drawPrompt full s = say s >> (liftIO $ void $ Curses.cursSet Curses.CursorVisible)
@@ -411,34 +411,34 @@ instance UIMonad (StateT UIState IO) where
getChRaw = (charify<$>) $ liftIO $ CursesH.getKey (return ()) >>= handleEsc
setUIBinding mode cmd ch =
- modify $ \s -> s { uiKeyBindings =
- Map.insertWith (\[bdg] -> \bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs)
- mode [(ch,cmd)] $ uiKeyBindings s }
+ modify $ \s -> s { uiKeyBindings =
+ Map.insertWith (\[bdg] -> \bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs)
+ mode [(ch,cmd)] $ uiKeyBindings s }
getUIBinding mode cmd = do
- bdgs <- getBindings mode
- return $ maybe "" showKey $ findBinding bdgs cmd
+ 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
+ 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
- liftIO CursesH.end
+ writeBindings
+ liftIO CursesH.end
unblockInput = return $ Curses.ungetCh 0
suspend = do
- liftIO $ do
- CursesH.suspend
- Curses.resetParams
- redraw
+ liftIO $ do
+ CursesH.suspend
+ Curses.resetParams
+ redraw
redraw = liftIO $ do
- Curses.endWin
- Curses.refresh
+ Curses.endWin
+ Curses.refresh
warpPointer _ = return ()
getUIMousePos = return Nothing
@@ -449,24 +449,24 @@ instance UIMonad (StateT UIState IO) where
toggleColourMode = modify $ \s -> s {monochrome = not $ monochrome s}
impatience ticks = do
- when (ticks>20) $ say "Waiting for server (^C to abort)..."
- unblock <- unblockInput
- liftIO $ forkIO $ threadDelay 50000 >> unblock
- cmds <- getInput IMImpatience
- return $ CmdQuit `elem` cmds
+ when (ticks>20) $ say "Waiting for server (^C to abort)..."
+ unblock <- unblockInput
+ liftIO $ forkIO $ threadDelay 50000 >> unblock
+ cmds <- getInput IMImpatience
+ return $ CmdQuit `elem` cmds
getInput mode = do
- let userResizeCode = 1337 -- XXX: chosen not to conflict with HSCurses codes
- key <- liftIO $ CursesH.getKey (Curses.ungetCh userResizeCode) >>=
+ let userResizeCode = 1337 -- XXX: chosen not to conflict with HSCurses codes
+ key <- liftIO $ CursesH.getKey (Curses.ungetCh userResizeCode) >>=
handleEsc
- if key == Curses.KeyUnknown userResizeCode
- then do
- liftIO Curses.scrSize
- return [CmdRedraw]
- else do
- let mch = charify key
- unblockBinding = (toEnum 0, CmdRefresh) -- c.f. unblockInput above
- flip (maybe $ return []) mch $ \ch ->
- if mode == IMTextInput
- then return $ [ CmdInputChar ch `fromMaybe` lookup ch [unblockBinding] ]
- else (maybeToList . lookup ch . (unblockBinding:)) <$> getBindings mode
+ if key == Curses.KeyUnknown userResizeCode
+ then do
+ liftIO Curses.scrSize
+ return [CmdRedraw]
+ else do
+ let mch = charify key
+ unblockBinding = (toEnum 0, CmdRefresh) -- c.f. unblockInput above
+ flip (maybe $ return []) mch $ \ch ->
+ if mode == IMTextInput
+ then return $ [ CmdInputChar ch `fromMaybe` lookup ch [unblockBinding] ]
+ else (maybeToList . lookup ch . (unblockBinding:)) <$> getBindings mode
diff --git a/Database.hs b/Database.hs
index 2ed54f1..7a3a858 100644
--- a/Database.hs
+++ b/Database.hs
@@ -12,6 +12,7 @@ module Database where
import Data.Maybe
import Data.Tuple (swap)
+import Data.Char (toUpper)
import Control.Applicative
import Control.Monad
import System.IO
@@ -99,8 +100,8 @@ getRecord :: Record -> DBM (Maybe RecordContents)
getRecord rec = do
path <- recordPath rec
liftIO $ flip catchIO (const $ return Nothing) $ do
- h <- openFile path ReadMode
- getRecordh rec h <* hClose h
+ h <- openFile path ReadMode
+ getRecordh rec h <* hClose h
getRecordh (RecPassword _) h = ((RCPassword <$>) . tryRead) <$> hGetStrict h
getRecordh (RecEmail _) h = ((RCEmail <$>) . tryRead) <$> hGetStrict h
getRecordh (RecUserInfo _) h = ((RCUserInfo <$>) . tryRead) <$> hGetStrict h
@@ -116,19 +117,19 @@ getRecordh RecSecretKey h = ((RCSecretKey <$>) . tryRead) <$> hGetStrict h
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`) <$> concatMWhileNonempty ms
+ bs <- m
+ if CS.null bs
+ then return bs
+ 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
- putRecordh rc h
- hClose h
+ mkdirhierto path
+ h <- openFile path WriteMode
+ putRecordh rc h
+ hClose h
putRecordh (RCPassword hpw) h = hPutStr h $ show hpw
putRecordh (RCEmail addr) h = hPutStr h $ show addr
putRecordh (RCUserInfo info) h = hPutStr h $ show info
@@ -145,11 +146,11 @@ modifyRecord :: Record -> (RecordContents -> RecordContents) -> DBM ()
modifyRecord rec f = do
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
- hClose h
+ Just rc <- getRecordh rec h
+ hSeek h AbsoluteSeek 0
+ putRecordh (f rc) h
+ hTell h >>= hSetFileSize h
+ hClose h
delRecord :: Record -> DBM ()
delRecord rec = recordPath rec >>= liftIO . removeFile
@@ -171,39 +172,47 @@ listUsers :: DBM [Codename]
listUsers = do
dbpath <- ask
liftIO $ (map unpathifyName . filter ((==3).length)) <$>
- getDirectoryContents (dbpath++[pathSeparator]++"users")
+ getDirectoryContents (dbpath++[pathSeparator]++"users")
recordPath :: Record -> DBM FilePath
recordPath rec =
(++ ([pathSeparator] ++ recordPath' rec)) <$> ask
where
- recordPath' (RecPassword name) = userDir name ++ "passwd"
- recordPath' (RecEmail name) = userDir name ++ "email"
- 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' (RecRetiredLocks name) = userDir name ++ "retired"
- recordPath' RecLockHashes = "lockHashes"
- recordPath' RecServerInfo = "serverInfo"
- recordPath' RecServerEmail = "serverEmail"
- recordPath' RecPublicKey = "publicKey"
- recordPath' RecSecretKey = "secretKey"
-
- userDir name = "users" ++ [pathSeparator] ++ pathifyName name ++ [pathSeparator]
- alockFN (ActiveLock name idx) = pathifyName name ++":"++ show idx
- locksDir = "locks"++[pathSeparator]
-
--- Dummy out characters which are disallowed on unix or dos.
+ recordPath' (RecPassword name) = userDir name ++ "passwd"
+ recordPath' (RecEmail name) = userDir name ++ "email"
+ 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' (RecRetiredLocks name) = userDir name ++ "retired"
+ recordPath' RecLockHashes = "lockHashes"
+ recordPath' RecServerInfo = "serverInfo"
+ recordPath' RecServerEmail = "serverEmail"
+ recordPath' RecPublicKey = "publicKey"
+ recordPath' RecSecretKey = "secretKey"
+
+ userDir name = "users" ++ [pathSeparator] ++ pathifyName name ++ [pathSeparator]
+ alockFN (ActiveLock name idx) = pathifyName name ++":"++ show idx
+ locksDir = "locks"++[pathSeparator]
+
+pathifyName = winSux . dummyPunctuation
+
+-- | Hilariously, "CON", "PRN", "AUX", and "NUL" are reserved on DOS, and
+-- Windows apparently crashes rather than write a directory with that name!
+winSux name = if map toUpper name `elem` ["CON","PRN", "AUX","NUL"]
+ then '_':name
+ else name
+
+-- | 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 ->
+dummyPunctuation = concatMap $ \c ->
fromMaybe [c] (('_':) . pure <$> lookup c pathifyAssocs)
unpathifyName = concatMap $ \c -> case c of
- '_' -> ""
- _ -> pure $ fromMaybe c (lookup c $ map swap pathifyAssocs)
+ '_' -> ""
+ _ -> pure $ fromMaybe c (lookup c $ map swap pathifyAssocs)
pathifyAssocs =
[ ('/','s')
, ('.','d')
diff --git a/EditGameState.hs b/EditGameState.hs
index 652e2f6..8e652e8 100644
--- a/EditGameState.hs
+++ b/EditGameState.hs
@@ -26,103 +26,103 @@ import GameStateTypes
modTile :: Maybe Tile -> HexPos -> HexPos -> Bool -> GameState -> GameState
modTile tile pos lastPos painting st =
let board = stateBoard st
- curOwnedTile = Map.lookup pos board
- (st',mowner) = case curOwnedTile of
- Nothing -> (st,Nothing)
- Just (owner,SpringTile _ _) -> (delConnectionsIn pos st, Just owner)
- Just (owner,_) -> delPiecePos owner pos st -- XXX may invalidate board's indices to st
- board' = stateBoard st'
- addPiece p = addpp $ PlacedPiece pos p
- lastMOwner = do
- (o,_) <- Map.lookup lastPos board
- return o
- {-
- same = isJust $ do
- t <- tile
- (_,t') <- curOwnedTile
- guard $ ((==) `on` tileType) t t'
- return $ Just ()
- -}
- lastElem os = isJust $ do
- lastOwner <- lastMOwner
- guard $ lastOwner `elem` os
- lastWasDiff = isNothing $ do
- lastOwner <- lastMOwner
- owner <- mowner
- guard $ owner == lastOwner
- lastOK = painting || lastWasDiff
- validSpringRootTile ot = case snd ot of
- BlockTile _ -> True
- PivotTile _ -> True
- _ -> False
- -- |Find next adjacent, skipping over current entity.
- nextOfAdjacents adjs loop = listToMaybe $ fromMaybe adjs $ do
- owner <- mowner
- i <- elemIndex owner adjs
- return $ (dropWhile (== owner) $ drop i adjs) ++
- if loop && i > 0 then adjs else []
+ curOwnedTile = Map.lookup pos board
+ (st',mowner) = case curOwnedTile of
+ Nothing -> (st,Nothing)
+ Just (owner,SpringTile _ _) -> (delConnectionsIn pos st, Just owner)
+ Just (owner,_) -> delPiecePos owner pos st -- XXX may invalidate board's indices to st
+ board' = stateBoard st'
+ addPiece p = addpp $ PlacedPiece pos p
+ lastMOwner = do
+ (o,_) <- Map.lookup lastPos board
+ return o
+ {-
+ same = isJust $ do
+ t <- tile
+ (_,t') <- curOwnedTile
+ guard $ ((==) `on` tileType) t t'
+ return $ Just ()
+ -}
+ lastElem os = isJust $ do
+ lastOwner <- lastMOwner
+ guard $ lastOwner `elem` os
+ lastWasDiff = isNothing $ do
+ lastOwner <- lastMOwner
+ owner <- mowner
+ guard $ owner == lastOwner
+ lastOK = painting || lastWasDiff
+ validSpringRootTile ot = case snd ot of
+ BlockTile _ -> True
+ PivotTile _ -> True
+ _ -> False
+ -- |Find next adjacent, skipping over current entity.
+ nextOfAdjacents adjs loop = listToMaybe $ fromMaybe adjs $ do
+ owner <- mowner
+ i <- elemIndex owner adjs
+ return $ (dropWhile (== owner) $ drop i adjs) ++
+ if loop && i > 0 then adjs else []
in case mowner of
- Just o | protectedPiece o -> st
- _ -> (case tile of
- -- _ | same && (pos /= lastPos) -> id
- Just (BlockTile _) ->
- let adjacentBlocks = nub [ idx |
- dir <- hexDirs
- , Just (idx, BlockTile _) <- [Map.lookup (dir +^ pos) board']
- , not $ protectedPiece idx ]
- addToIdx = if lastOK && lastElem adjacentBlocks
- then lastMOwner
- else nextOfAdjacents adjacentBlocks False
- in case addToIdx of
- Nothing -> addPiece $ Block [zero]
- Just b -> addBlockPos b pos
- Just (ArmTile armdir _) ->
- let adjacentPivots = [ idx |
- dir <- if armdir == zero then hexDirs else [armdir, neg armdir]
- , Just (idx, PivotTile _) <- [Map.lookup (dir +^ pos) board'] ]
- addToIdx = if lastOK && lastElem adjacentPivots
- then lastMOwner
- else nextOfAdjacents adjacentPivots True
- in case addToIdx of
- Nothing -> id
- Just p -> addPivotArm p pos
- Just (SpringTile _ _) ->
- let possibleSprings = [ Connection root end $ Spring sdir natLen |
- sdir <- hexDirs
- , let epos = sdir +^ pos
- , Just (eidx, BlockTile _) <- [Map.lookup epos board']
- , not $ protectedPiece eidx
- , (ridx, rpos) <- maybeToList $ castRay (neg sdir +^ pos) (neg sdir) board'
- , Just True == (validSpringRootTile `liftM` Map.lookup rpos board')
- , let natLen = hexLen (rpos -^ epos) - 1
- , natLen > 0
- {-
- , null [ conn |
- conn@(Connection _ _ (Spring sdir' _)) <-
- springsAtIdx st' eidx ++ springsEndAtIdx st' ridx
- , not $ sdir' `elem` [sdir,neg sdir] ]
- -}
- , not $ connGraphPathExists st' eidx ridx
- , let end = (eidx, epos -^ (placedPos $ getpp st' eidx))
- , let root = (ridx, rpos -^ (placedPos $ getpp st' ridx))
- ]
- nextSpring = listToMaybe $ fromMaybe possibleSprings $ do
- (_,SpringTile _ _) <- curOwnedTile -- XXX: therefore the indices of st are still valid
- i <- findIndex (`elem` connections st) possibleSprings
- return $ drop (i+1) possibleSprings
- in case nextSpring of
- Nothing -> id
- Just conn -> addConn conn
- Just (PivotTile _) -> addPiece $ Pivot []
- Just (WrenchTile _) -> addPiece $ Wrench zero
- Just HookTile -> let arm = listToMaybe [ dir |
- dir <- hexDirs
- , isNothing $ Map.lookup (dir +^ pos) board' ]
- in case arm of Just armdir -> addPiece $ Hook armdir NullHF
- _ -> id
- Just (BallTile) -> addPiece Ball
- _ -> id
- ) st'
+ Just o | protectedPiece o -> st
+ _ -> (case tile of
+ -- _ | same && (pos /= lastPos) -> id
+ Just (BlockTile _) ->
+ let adjacentBlocks = nub [ idx |
+ dir <- hexDirs
+ , Just (idx, BlockTile _) <- [Map.lookup (dir +^ pos) board']
+ , not $ protectedPiece idx ]
+ addToIdx = if lastOK && lastElem adjacentBlocks
+ then lastMOwner
+ else nextOfAdjacents adjacentBlocks False
+ in case addToIdx of
+ Nothing -> addPiece $ Block [zero]
+ Just b -> addBlockPos b pos
+ Just (ArmTile armdir _) ->
+ let adjacentPivots = [ idx |
+ dir <- if armdir == zero then hexDirs else [armdir, neg armdir]
+ , Just (idx, PivotTile _) <- [Map.lookup (dir +^ pos) board'] ]
+ addToIdx = if lastOK && lastElem adjacentPivots
+ then lastMOwner
+ else nextOfAdjacents adjacentPivots True
+ in case addToIdx of
+ Nothing -> id
+ Just p -> addPivotArm p pos
+ Just (SpringTile _ _) ->
+ let possibleSprings = [ Connection root end $ Spring sdir natLen |
+ sdir <- hexDirs
+ , let epos = sdir +^ pos
+ , Just (eidx, BlockTile _) <- [Map.lookup epos board']
+ , not $ protectedPiece eidx
+ , (ridx, rpos) <- maybeToList $ castRay (neg sdir +^ pos) (neg sdir) board'
+ , Just True == (validSpringRootTile `liftM` Map.lookup rpos board')
+ , let natLen = hexLen (rpos -^ epos) - 1
+ , natLen > 0
+ {-
+ , null [ conn |
+ conn@(Connection _ _ (Spring sdir' _)) <-
+ springsAtIdx st' eidx ++ springsEndAtIdx st' ridx
+ , not $ sdir' `elem` [sdir,neg sdir] ]
+ -}
+ , not $ connGraphPathExists st' eidx ridx
+ , let end = (eidx, epos -^ (placedPos $ getpp st' eidx))
+ , let root = (ridx, rpos -^ (placedPos $ getpp st' ridx))
+ ]
+ nextSpring = listToMaybe $ fromMaybe possibleSprings $ do
+ (_,SpringTile _ _) <- curOwnedTile -- XXX: therefore the indices of st are still valid
+ i <- findIndex (`elem` connections st) possibleSprings
+ return $ drop (i+1) possibleSprings
+ in case nextSpring of
+ Nothing -> id
+ Just conn -> addConn conn
+ Just (PivotTile _) -> addPiece $ Pivot []
+ Just (WrenchTile _) -> addPiece $ Wrench zero
+ Just HookTile -> let arm = listToMaybe [ dir |
+ dir <- hexDirs
+ , isNothing $ Map.lookup (dir +^ pos) board' ]
+ in case arm of Just armdir -> addPiece $ Hook armdir NullHF
+ _ -> id
+ Just (BallTile) -> addPiece Ball
+ _ -> id
+ ) st'
-- | merge tile/piece with a neighbouring piece. If we merge a piece with
-- connections, the connections are deleted: otherwise we'd need some fiddly
@@ -135,19 +135,19 @@ mergeTiles pos dir mergePiece st = fromMaybe st $ do
guard $ idx /= idx'
guard $ all (not . protectedPiece) [idx,idx']
case tile of
- BlockTile _ -> do
- BlockTile _ <- Just tile'
- let st' = if mergePiece
- then delPiece idx st
- else fst $ delPiecePos idx pos st
- (idx'',_) <- Map.lookup (dir+^pos) $ stateBoard st'
- return $ if mergePiece
- then foldr (addBlockPos idx'') st'
- $ plPieceFootprint $ getpp st idx
- else addBlockPos idx'' pos st'
- ArmTile _ _ -> do
- PivotTile _ <- Just tile'
- let st' = fst $ delPiecePos idx pos st
- (idx'',_) <- Map.lookup (dir+^pos) $ stateBoard st'
- return $ addPivotArm idx'' pos st'
- _ -> mzero
+ BlockTile _ -> do
+ BlockTile _ <- Just tile'
+ let st' = if mergePiece
+ then delPiece idx st
+ else fst $ delPiecePos idx pos st
+ (idx'',_) <- Map.lookup (dir+^pos) $ stateBoard st'
+ return $ if mergePiece
+ then foldr (addBlockPos idx'') st'
+ $ plPieceFootprint $ getpp st idx
+ else addBlockPos idx'' pos st'
+ ArmTile _ _ -> do
+ PivotTile _ <- Just tile'
+ let st' = fst $ delPiecePos idx pos st
+ (idx'',_) <- Map.lookup (dir+^pos) $ stateBoard st'
+ return $ addPivotArm idx'' pos st'
+ _ -> mzero
diff --git a/Frame.hs b/Frame.hs
index 174d030..de05ee7 100644
--- a/Frame.hs
+++ b/Frame.hs
@@ -33,23 +33,23 @@ boltWidth (BasicFrame size) = size`div`4+1
baseState :: Frame -> GameState
baseState f =
GameState
- (Vector.fromList $ [ framePiece f, bolt ] ++ (initTools f))
- []
+ (Vector.fromList $ [ framePiece f, bolt ] ++ (initTools f))
+ []
where
- bolt = PlacedPiece (bolthole f +^ origin) $ Block $
- [ n*^hu | n <- [-1..boltWidth f - 1] ] -- ++ [(-2)*^hu+^neg hv]
+ bolt = PlacedPiece (bolthole f +^ origin) $ Block $
+ [ n*^hu | n <- [-1..boltWidth f - 1] ] -- ++ [(-2)*^hu+^neg hv]
framePiece :: Frame -> PlacedPiece
framePiece f@(BasicFrame size) =
PlacedPiece origin $ Block $
- map (bolthole f +^) (
- [ bw*^hu +^ n*^hv | n <- [0..bw] ]
- ++ [ bw*^hu +^ i*^hw +^ n*^hv | i <- [1..bw-1], n <- [0,bw+i] ])
- ++ (map (entrance f +^) [neg hu +^ hv, 2 *^ neg hu, neg hu +^ hw,
- 2 *^ hw, neg hv +^ hw])
- ++ (concat [
- map (rotate r) [ (n*^hu) +^ (size*^hw) | n <- [0..size-1] ] | r <- [0..5] ] \\
- [bolthole f, entrance f])
+ map (bolthole f +^) (
+ [ bw*^hu +^ n*^hv | n <- [0..bw] ]
+ ++ [ bw*^hu +^ i*^hw +^ n*^hv | i <- [1..bw-1], n <- [0,bw+i] ])
+ ++ (map (entrance f +^) [neg hu +^ hv, 2 *^ neg hu, neg hu +^ hw,
+ 2 *^ hw, neg hv +^ hw])
+ ++ (concat [
+ map (rotate r) [ (n*^hu) +^ (size*^hw) | n <- [0..size-1] ] | r <- [0..5] ] \\
+ [bolthole f, entrance f])
where bw = boltWidth f
initTools :: Frame -> [PlacedPiece]
@@ -63,7 +63,7 @@ clearToolArea f st = foldr delPieceIn st $ toolsArea f
boltArea,toolsArea :: Frame -> [HexPos]
boltArea f = map PHS
- [ bolthole f +^ bw*^hu +^ i*^hw +^ n*^hv | i <- [1..bw-1], n <- [1..bw+i-1] ]
+ [ bolthole f +^ bw*^hu +^ i*^hw +^ n*^hv | i <- [1..bw-1], n <- [1..bw+i-1] ]
where bw = boltWidth f
toolsArea f = [entrance f +^ v +^ origin | v <- [ neg hu, hw, zero ] ]
@@ -80,7 +80,7 @@ truncateToBounds f pos@(PHS v) = PHS $ truncateToLength (frameSize f - 1) v
truncateToEditable f pos@(PHS v) = if inBounds f pos
then pos
else head
- $ [ pos'
- | n <- reverse [0..boltWidth f]
- , let pos' = PHS $ truncateToLength (frameSize f - 1 + n) v
- , inEditable f pos' ]
+ $ [ pos'
+ | n <- reverse [0..boltWidth f]
+ , let pos' = PHS $ truncateToLength (frameSize f - 1 + n) v
+ , inEditable f pos' ]
diff --git a/GameState.hs b/GameState.hs
index ab3920d..60e16c2 100644
--- a/GameState.hs
+++ b/GameState.hs
@@ -38,12 +38,12 @@ getpp st idx = (placedPieces st) ! idx
setpp :: PieceIdx -> PlacedPiece -> GameState -> GameState
setpp idx pp st@(GameState pps _) =
let displacement = (placedPos $ getpp st idx) -^ placedPos pp
- updateConn conn@(Connection root@(ridx,rpos) end@(eidx,epos) link)
- | ridx == idx = Connection (ridx,rpos+^displacement) end link
- | eidx == idx = Connection root (eidx,epos+^displacement) link
- | otherwise = conn
+ updateConn conn@(Connection root@(ridx,rpos) end@(eidx,epos) link)
+ | ridx == idx = Connection (ridx,rpos+^displacement) end link
+ | eidx == idx = Connection root (eidx,epos+^displacement) link
+ | otherwise = conn
in st {placedPieces = pps // [(idx, pp)]
- , connections = map updateConn $ connections st }
+ , connections = map updateConn $ connections st }
addpp :: PlacedPiece -> GameState -> GameState
addpp pp st@(GameState pps _) = st {placedPieces = Vector.snoc pps pp}
@@ -56,36 +56,36 @@ components :: Set HexVec -> [Component]
components patt
| Set.null patt = []
| otherwise =
- let c = if zero `Set.member` patt then zero else head $ Set.toList patt
- (patt',comp) = floodfill c patt
- in ( (c, Set.map (+^ neg c) comp) : components patt' )
+ let c = if zero `Set.member` patt then zero else head $ Set.toList patt
+ (patt',comp) = floodfill c patt
+ in ( (c, Set.map (+^ neg c) comp) : components patt' )
floodfill :: HexVec -> Set HexVec -> (Set HexVec, Set HexVec)
floodfill start patt = floodfill' start `execState` (patt, Set.empty)
where
- floodfill' :: HexVec -> State (Set HexVec, Set HexVec) ()
- floodfill' start = do
- (patt, dels) <- get
- let patt' = Set.delete start patt
- unless (Set.size patt' == Set.size patt) $ do
- put (patt', Set.insert start dels)
- sequence_ [ floodfill' (dir+^start) | dir <- hexDirs ]
+ floodfill' :: HexVec -> State (Set HexVec, Set HexVec) ()
+ floodfill' start = do
+ (patt, dels) <- get
+ let patt' = Set.delete start patt
+ unless (Set.size patt' == Set.size patt) $ do
+ put (patt', Set.insert start dels)
+ sequence_ [ floodfill' (dir+^start) | dir <- hexDirs ]
delPiece :: PieceIdx -> GameState -> GameState
delPiece idx (GameState pps conns) =
GameState (Vector.concat [Vector.take idx pps, Vector.drop (idx+1) pps])
- [ Connection (ridx',rv) (eidx',ev) link |
- Connection (ridx,rv) (eidx,ev) link <- conns
- , ridx /= idx
- , eidx /= idx
- , let ridx' = if ridx > idx then ridx-1 else ridx
- , let eidx' = if eidx > idx then eidx-1 else eidx ]
+ [ Connection (ridx',rv) (eidx',ev) link |
+ Connection (ridx,rv) (eidx,ev) link <- conns
+ , ridx /= idx
+ , eidx /= idx
+ , let ridx' = if ridx > idx then ridx-1 else ridx
+ , let eidx' = if eidx > idx then eidx-1 else eidx ]
delPieceIn :: HexPos -> GameState -> GameState
delPieceIn pos st =
case liftM fst $ Map.lookup pos $ stateBoard st of
- Just idx -> delPiece idx st
- _ -> st
+ Just idx -> delPiece idx st
+ _ -> st
setPiece :: PieceIdx -> Piece -> GameState -> GameState
setPiece idx p st =
@@ -94,7 +94,7 @@ setPiece idx p st =
adjustPieces :: (Piece -> Piece) -> GameState -> GameState
adjustPieces f st =
st { placedPieces = fmap
- (\pp -> pp { placedPiece = f $ placedPiece pp })
+ (\pp -> pp { placedPiece = f $ placedPiece pp })
$ placedPieces st }
addBlockPos :: PieceIdx -> HexPos -> GameState -> GameState
@@ -118,7 +118,7 @@ posLocus st pos = listToMaybe [ (idx,pos-^ppos) |
connectionLength :: GameState -> Connection -> Int
connectionLength st (Connection root end _) =
let rootPos = locusPos st root
- endPos = locusPos st end
+ endPos = locusPos st end
in hexLen (endPos -^ rootPos) - 1
springsAtIdx,springsEndAtIdx,springsRootAtIdx :: GameState -> PieceIdx -> [Connection]
@@ -138,14 +138,14 @@ 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 = (==) `on` (\(x,y) -> Set.fromList [x,y])
+ connIsBetween conn =
+ isPerm (idx,idx') (fst $ connectionRoot conn, fst $ connectionEnd conn)
+ isPerm = (==) `on` (\(x,y) -> Set.fromList [x,y])
connGraphPathExists :: GameState -> PieceIdx -> PieceIdx -> Bool
connGraphPathExists st ridx eidx = (ridx == eidx) ||
- any ((connGraphPathExists st `flip` eidx) . fst . connectionEnd)
- (springsRootAtIdx st ridx)
+ any ((connGraphPathExists st `flip` eidx) . fst . connectionEnd)
+ (springsRootAtIdx st ridx)
connGraphHeight :: GameState -> PieceIdx -> Int
connGraphHeight st idx =
@@ -155,25 +155,25 @@ 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 :: 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
+ leaves dg = map fst $ filter (Set.null . snd) $ Map.toList dg
+ checkDigraphAcyclic :: Ord a => Digraph a -> Bool
+ checkDigraphAcyclic dg = case listToMaybe $ leaves dg of
+ Nothing -> Map.null dg
+ Just leaf -> checkDigraphAcyclic $ Map.delete leaf $ fmap (Set.delete leaf) dg
in checkDigraphAcyclic $ Map.fromList
- [ (idx, Set.fromList $ map (fst.connectionRoot) $ springsEndAtIdx st idx) | idx <- idxs ]
+ [ (idx, Set.fromList $ map (fst.connectionRoot) $ springsEndAtIdx st idx) | idx <- idxs ]
repossessConns :: GameState -> GameState -> GameState
repossessConns st st' =
st' {connections = [ Connection root' end' link |
- Connection root end link <- connections st
- , root' <- maybeToList $ posLocus st' $ locusPos st root
- , end' <- maybeToList $ posLocus st' $ locusPos st end ] }
+ Connection root end link <- connections st
+ , root' <- maybeToList $ posLocus st' $ locusPos st root
+ , end' <- maybeToList $ posLocus st' $ locusPos st end ] }
delConnectionsIn :: HexPos -> GameState -> GameState
delConnectionsIn pos st =
st {connections = filter
- ((pos `notElem`) . connectionFootPrint st)
+ ((pos `notElem`) . connectionFootPrint st)
$ connections st}
delPiecePos :: PieceIdx -> HexPos -> GameState -> (GameState, Maybe PieceIdx)
@@ -181,27 +181,27 @@ delPiecePos :: PieceIdx -> HexPos -> GameState -> (GameState, Maybe PieceIdx)
-- anything
delPiecePos idx pos st =
let PlacedPiece ppos p = getpp st idx
- v = pos -^ ppos
+ v = pos -^ ppos
in case p of
Block patt ->
- let (st',midx) = componentify idx $ setpp idx (PlacedPiece ppos $ Block $ patt \\ [v]) st
- in (repossessConns st st', midx)
+ let (st',midx) = componentify idx $ setpp idx (PlacedPiece ppos $ Block $ patt \\ [v]) st
+ in (repossessConns st st', midx)
Pivot arms -> if v == zero
- then (delPiece idx st, Nothing)
- else ((setPiece idx $ Pivot $ arms \\ [v]) st, Just idx)
+ then (delPiece idx st, Nothing)
+ else ((setPiece idx $ Pivot $ arms \\ [v]) st, Just idx)
_ -> (delPiece idx st, Nothing)
componentify :: PieceIdx -> GameState -> (GameState, Maybe PieceIdx)
componentify idx st = let PlacedPiece ppos p = getpp st idx
in case p of
Block patt ->
- let comps = components $ Set.fromList patt
- ppOfComp (v,patt) = PlacedPiece (v+^ppos) $ Block $ Set.toList patt
- in case comps of
- [] -> (delPiece idx st, Nothing)
- zeroComp:newComps ->
- (setpp idx (ppOfComp zeroComp)
- $ foldr (addpp . ppOfComp) st newComps, Just idx)
- _ -> (st,Nothing)
+ let comps = components $ Set.fromList patt
+ ppOfComp (v,patt) = PlacedPiece (v+^ppos) $ Block $ Set.toList patt
+ in case comps of
+ [] -> (delPiece idx st, Nothing)
+ zeroComp:newComps ->
+ (setpp idx (ppOfComp zeroComp)
+ $ foldr (addpp . ppOfComp) st newComps, Just idx)
+ _ -> (st,Nothing)
springExtended,springCompressed,springFullyExtended
,springFullyCompressed :: GameState -> Connection -> Bool
@@ -225,21 +225,21 @@ springExtensionValid _ _ = True
stateBoard :: GameState -> GameBoard
stateBoard st@(GameState plPieces conns) =
addConnAdjs st conns $
- (Map.unions $ map plPieceBoard $ enumVec plPieces) `Map.union`
- (Map.unions $ map (connectionBoard st) conns)
+ (Map.unions $ map plPieceBoard $ enumVec plPieces) `Map.union`
+ (Map.unions $ map (connectionBoard st) conns)
addConnAdjs :: GameState -> [Connection] -> GameBoard -> GameBoard
addConnAdjs st = flip $ foldr addConnAdj
where
- addConnAdj (Connection root end (Spring dir _)) board =
- addAdj (locusPos st root) dir $
- addAdj (locusPos st end) (neg dir) board
- addConnAdj _ board = board
- addAdj pos d =
- Map.adjust (\(o,tile) -> (o,case tile of
- BlockTile adjs -> BlockTile (d:adjs)
- _ -> tile))
- pos
+ addConnAdj (Connection root end (Spring dir _)) board =
+ addAdj (locusPos st root) dir $
+ addAdj (locusPos st end) (neg dir) board
+ addConnAdj _ board = board
+ addAdj pos d =
+ Map.adjust (\(o,tile) -> (o,case tile of
+ BlockTile adjs -> BlockTile (d:adjs)
+ _ -> tile))
+ pos
plPieceBoard :: (PieceIdx,PlacedPiece) -> GameBoard
plPieceBoard (idx,pp) = fmap (\x -> (idx,x)) $ plPieceMap pp
@@ -248,13 +248,13 @@ plPieceMap :: PlacedPiece -> Map HexPos Tile
plPieceMap (PlacedPiece pos (Block pattern)) =
let pattSet = Set.fromList pattern
in Map.fromList [ (rel +^ pos, BlockTile adjs)
- | rel <- pattern
- , let adjs = filter (\dir -> (rel +^ dir) `Set.member` pattSet) hexDirs ]
+ | rel <- pattern
+ , let adjs = filter (\dir -> (rel +^ dir) `Set.member` pattSet) hexDirs ]
plPieceMap (PlacedPiece pos (Pivot arms)) =
let overarmed = length arms > 2 in
Map.fromList $ (pos, PivotTile $ if overarmed then (head arms) else zero ) :
- [ (rel +^ pos, ArmTile rel main)
- | (rel,main) <- zip arms $ repeat False ]
+ [ (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
@@ -283,19 +283,19 @@ collisions :: GameState -> PieceIdx -> PieceIdx -> [HexPos]
-- the connections which connect the two pieces
collisions st idx idx' =
intersect (footprintAt st idx) (footprintAt st idx') \\
- (concat $ map (connectionFootPrint st) $ connectionsBetween st idx idx')
+ (concat $ map (connectionFootPrint st) $ connectionsBetween st idx idx')
connectionBoard :: GameState -> Connection -> GameBoard
connectionBoard st (Connection root end@(eidx,_) (Spring dir natLen)) =
let rootPos = locusPos st root
- endPos = locusPos st end
- curLen = hexLen (endPos -^ rootPos) - 1
+ endPos = locusPos st end
+ curLen = hexLen (endPos -^ rootPos) - 1
in Map.fromList $
- [ ((d *^ dir) +^ rootPos, (eidx, SpringTile extension dir))
- | d <- [1..curLen],
- let extension | d <= natLen - curLen = Compressed
- | curLen-d < 2*(curLen - natLen) = Stretched
- | otherwise = Relaxed ]
+ [ ((d *^ dir) +^ rootPos, (eidx, SpringTile extension dir))
+ | d <- [1..curLen],
+ let extension | d <= natLen - curLen = Compressed
+ | curLen-d < 2*(curLen - natLen) = Stretched
+ | otherwise = Relaxed ]
connectionBoard _ _ = Map.empty
connectionFootPrint :: GameState -> Connection -> [HexPos]
@@ -305,29 +305,29 @@ castRay :: HexPos -> HexDir -> GameBoard -> Maybe (PieceIdx, HexPos)
castRay start dir board =
castRay' 30 start
where castRay' 0 _ = Nothing
- castRay' n pos =
- case Map.lookup pos board of
- Nothing -> castRay' (n-1) (dir+^pos)
- Just (idx,_) -> Just (idx,pos)
+ castRay' n pos =
+ case Map.lookup pos board of
+ Nothing -> castRay' (n-1) (dir+^pos)
+ Just (idx,_) -> Just (idx,pos)
validGameState :: GameState -> Bool
validGameState st@(GameState pps conns) = and
[ checkValidHex st
, checkConnGraphAcyclic st
, and [ null $ collisions st idx idx'
- | idx <- ppidxs st
- , idx' <- [0..idx-1] ]
+ | idx <- ppidxs st
+ , idx' <- [0..idx-1] ]
, and [ isHexDir dir
- && castRay (dir+^rpos) dir
- (stateBoard $ GameState pps (conns \\ [c]))
- == Just (eidx, epos)
- && springExtensionValid st c
- && (validRoot st root)
- && (validEnd st end)
- | c@(Connection root@(ridx,_) end@(eidx,_) (Spring dir _)) <- conns
- , let [rpos,epos] = map (locusPos st) [root,end] ]
+ && castRay (dir+^rpos) dir
+ (stateBoard $ GameState pps (conns \\ [c]))
+ == Just (eidx, epos)
+ && springExtensionValid st c
+ && (validRoot st root)
+ && (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)
- | Block patt <- map placedPiece $ Vector.toList pps ]
+ | Block patt <- map placedPiece $ Vector.toList pps ]
]
validRoot st (idx,v) = case placedPiece $ getpp st idx of
@@ -342,17 +342,17 @@ checkValidHex (GameState pps conns) = and
[ all validPP $ Vector.toList pps
, all validConn conns ]
where
- validVec (HexVec x y z) = x+y+z==0
- validPos (PHS v) = validVec v
- validDir v = validVec v && isHexDir v
- validPP (PlacedPiece pos piece) = validPos pos && validPiece piece
- validPiece (Block patt) = all validVec patt
- validPiece (Pivot arms) = all validDir arms
- validPiece (Hook dir _) = validDir dir
- validPiece _ = True
- validConn (Connection (_,rv) (_,ev) link) = all validVec [rv,ev] && validLink link
- validLink (Free v) = validVec v
- validLink (Spring dir _) = validDir dir
+ validVec (HexVec x y z) = x+y+z==0
+ validPos (PHS v) = validVec v
+ validDir v = validVec v && isHexDir v
+ validPP (PlacedPiece pos piece) = validPos pos && validPiece piece
+ validPiece (Block patt) = all validVec patt
+ validPiece (Pivot arms) = all validDir arms
+ validPiece (Hook dir _) = validDir dir
+ validPiece _ = True
+ validConn (Connection (_,rv) (_,ev) link) = all validVec [rv,ev] && validLink link
+ validLink (Free v) = validVec v
+ validLink (Spring dir _) = validDir dir
protectedPiece :: PieceIdx -> Bool
protectedPiece = isFrame
diff --git a/GameStateTypes.hs b/GameStateTypes.hs
index 700978a..415d097 100644
--- a/GameStateTypes.hs
+++ b/GameStateTypes.hs
@@ -15,7 +15,7 @@ import Data.Vector (Vector)
import Hex
data GameState = GameState { placedPieces :: Vector PlacedPiece,
- connections :: [Connection] }
+ connections :: [Connection] }
deriving (Eq, Ord, Show, Read)
data PlacedPiece = PlacedPiece { placedPos :: HexPos, placedPiece :: Piece }
@@ -24,10 +24,10 @@ data PlacedPiece = PlacedPiece { placedPos :: HexPos, placedPiece :: Piece }
type PieceIdx = Int
data Piece = Block { blockPattern :: [HexVec] }
- | Pivot { pivotArms :: [HexDir] }
- | Hook { hookArm :: HexDir, hookForce :: HookForce}
- | Wrench { wrenchMomentum :: HexDir }
- | Ball
+ | Pivot { pivotArms :: [HexDir] }
+ | Hook { hookArm :: HexDir, hookForce :: HookForce}
+ | Wrench { wrenchMomentum :: HexDir }
+ | Ball
deriving (Eq, Ord, Show, Read)
data HookForce = NullHF | PushHF HexDir | TorqueHF Int
@@ -42,20 +42,20 @@ isTool p = isWrench p || isHook p
isBall p = case p of Ball -> True; _ -> False
data Connection = Connection { connectionRoot :: Locus
- , connectionEnd :: Locus, connectionLink :: Link }
+ , connectionEnd :: Locus, connectionLink :: Link }
deriving (Eq, Ord, Show, Read)
type Locus = (PieceIdx, HexVec)
data Link = Free { freePos :: HexVec }
- | Spring { springDir :: HexDir, springNatLength :: Int }
+ | Spring { springDir :: HexDir, springNatLength :: Int }
deriving (Eq, Ord, Show, Read)
data SpringExtension = Relaxed | Compressed | Stretched
deriving (Eq, Ord, Show, Read)
data Tile = BlockTile [HexDir] | PivotTile HexDir | ArmTile HexDir Bool | HookTile | WrenchTile HexDir
- | BallTile | SpringTile SpringExtension HexDir
+ | BallTile | SpringTile SpringExtension HexDir
deriving (Eq, Ord, Show, Read)
tileType :: Tile -> Tile
@@ -80,8 +80,8 @@ data Force = Push PieceIdx HexDir | Torque PieceIdx TorqueDir
-- |Alert: for passing information about physics processing to the UI
data Alert = AlertCollision HexPos | AlertBlockingForce Force
- | AlertResistedForce Force | AlertBlockedForce Force
- | AlertAppliedForce Force | AlertDivertedWrench PieceIdx
- | AlertUnlocked
- | AlertIntermediateState GameState
+ | AlertResistedForce Force | AlertBlockedForce Force
+ | AlertAppliedForce Force | AlertDivertedWrench PieceIdx
+ | AlertUnlocked
+ | AlertIntermediateState GameState
deriving (Eq, Ord, Show)
diff --git a/GraphColouring.hs b/GraphColouring.hs
index 96790a5..5e01d02 100644
--- a/GraphColouring.hs
+++ b/GraphColouring.hs
@@ -32,8 +32,8 @@ fiveColour :: Ord a => PlanarGraph a -> Colouring a -> Colouring a
-- Aims to minimise changes from given (partial) colouring lastCol.
fiveColour g lastCol =
if Map.keysSet lastCol == Map.keysSet g && isColouring g lastCol
- then lastCol
- else fiveColour' lastCol g
+ then lastCol
+ else fiveColour' lastCol g
isColouring :: Ord a => PlanarGraph a -> Colouring a -> Bool
isColouring g mapping = and
@@ -45,17 +45,17 @@ 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
+ 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
+ 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
@@ -66,7 +66,7 @@ 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
+ $ Map.adjust (concatAdjsOver v $ g Map.! v'') v' g
concatAdjsOver :: Ord a => a -> [a] -> [a] -> [a]
concatAdjsOver v adjs adjs' =
diff --git a/Hex.lhs b/Hex.lhs
index b010924..c4eb061 100644
--- a/Hex.lhs
+++ b/Hex.lhs
@@ -73,15 +73,15 @@ hexDot (HexVec x y z) (HexVec x' y' z') = x*x'+y*y'+z*z'
hexDisc :: Int -> [HexVec]
hexDisc r = [ HexVec x y z | x <- [-r..r], y <- [-r..r],
- let z = -x-y, abs z <= r ]
+ let z = -x-y, abs z <= r ]
hextant :: HexVec -> Int
-- ^undefined at zero
--- ` 1 '
--- 2` '0
--- --*--
--- 3' `5
--- ' 4 `
+-- ` 1 '
+-- 2` '0
+-- --*--
+-- 3' `5
+-- ' 4 `
hextant (HexVec x y z)
| x > 0 && y >= 0 = 0
| -z > 0 && -x >= 0 = 1
@@ -99,8 +99,8 @@ rotate (-2) (HexVec x y z) = HexVec y z x
rotate 1 v = neg $ rotate (-2) v
rotate (-1) v = neg $ rotate 2 v
rotate n v | n < 0 = rotate (n+6) v
- | n > 6 = rotate (n-6) v
- | otherwise = rotate (n-2) (rotate 2 v)
+ | n > 6 = rotate (n-6) v
+ | otherwise = rotate (n-2) (rotate 2 v)
cmpAngles :: HexVec -> HexVec -> Ordering
-- ^ordered by angle, taking cut along u
@@ -108,18 +108,18 @@ cmpAngles v@(HexVec x y _) v'@(HexVec x' y' _)
| v == zero && v' == zero = EQ
| v == zero = LT
| compare (hextant v) (hextant v') /= EQ =
- compare (hextant v) (hextant v')
+ compare (hextant v) (hextant v')
| hextant v /= 0 =
- cmpAngles (rotate (-(hextant v)) v) (rotate (-(hextant v)) v')
+ cmpAngles (rotate (-(hextant v)) v) (rotate (-(hextant v)) v')
| otherwise = compare (y%x) (y'%x')
instance Ix HexVec where
range (h,h') =
- [ tupxy2hv (x,y) | (x,y) <- range (hv2tupxy h, hv2tupxy h') ]
+ [ tupxy2hv (x,y) | (x,y) <- range (hv2tupxy h, hv2tupxy h') ]
inRange (h,h') h'' =
- inRange (hv2tupxy h, hv2tupxy h') (hv2tupxy h'')
+ inRange (hv2tupxy h, hv2tupxy h') (hv2tupxy h'')
index (h,h') h'' =
- index (hv2tupxy h , hv2tupxy h') (hv2tupxy h'')
+ index (hv2tupxy h , hv2tupxy h') (hv2tupxy h'')
-- HexDirs are intended to be HexVecs of length <= 1
type HexDir = HexVec
@@ -144,20 +144,20 @@ hexVec2HexDirOrZero v
canonDir :: HexDir -> HexDir
canonDir dir | dir `elem` [ hu, hv, hw ] = dir
- | isHexDir dir = canonDir $ neg dir
- | dir == zero = zero
- | otherwise = undefined
+ | isHexDir dir = canonDir $ neg dir
+ | dir == zero = zero
+ | otherwise = undefined
scaleToLength :: Int -> HexVec -> HexVec
scaleToLength n v@(HexVec x y z) =
let
- l = hexLen v
- lv' = map ((`div`l).(n*)) [x,y,z]
- minI = fst $ minimumBy (compare `on` snd) $
- zip [0..] $ map abs lv'
- [x'',y'',z''] = zipWith (-) lv' [ d
- | i <- [0..2]
- , let d = if i == minI then sum lv' else 0 ]
+ l = hexLen v
+ lv' = map ((`div`l).(n*)) [x,y,z]
+ minI = fst $ minimumBy (compare `on` snd) $
+ zip [0..] $ map abs lv'
+ [x'',y'',z''] = zipWith (-) lv' [ d
+ | i <- [0..2]
+ , let d = if i == minI then sum lv' else 0 ]
in HexVec x'' y'' z''
truncateToLength :: Int -> HexVec -> HexVec
truncateToLength n v = if hexLen v <= n then v else scaleToLength n v
@@ -203,9 +203,9 @@ instance (Grp a, Integral n) => MultAction n a where
0 *^ _ = zero
1 *^ x = x
n *^ x
- | n < 0 = (-n) *^ (neg x)
- | even n = (n `div` 2) *^ (x +^ x)
- | otherwise = x +^ ((n `div` 2) *^ (x +^ x))
+ | n < 0 = (-n) *^ (neg x)
+ | even n = (n `div` 2) *^ (x +^ x)
+ | otherwise = x +^ ((n `div` 2) *^ (x +^ x))
\end{code}
diff --git a/Init.hs b/Init.hs
index f430817..c01bfbb 100644
--- a/Init.hs
+++ b/Init.hs
@@ -45,8 +45,8 @@ usage = usageInfo header options
parseArgs :: [String] -> IO ([Opt],[String])
parseArgs argv =
case getOpt Permute options argv of
- (o,n,[]) -> return (o,n)
- (_,_,errs) -> ioError (userError (concat errs ++ usage))
+ (o,n,[]) -> return (o,n)
+ (_,_,errs) -> ioError (userError (concat errs ++ usage))
setup :: IO (Maybe Lock,[Opt],Maybe String)
setup = do
@@ -57,32 +57,32 @@ setup = do
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) ]
+ [ 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) =>
- Maybe (s MainState -> IO (Maybe MainState)) ->
- Maybe (c MainState -> IO (Maybe MainState)) -> IO ()
+ Maybe (s MainState -> IO (Maybe MainState)) ->
+ Maybe (c MainState -> IO (Maybe MainState)) -> IO ()
main' msdlUI mcursesUI = do
(mlock,opts,mpath) <- setup
initMState <- case mlock of
- Nothing -> initMetaState
- Just lock -> return $ newEditState lock Nothing mpath
+ Nothing -> initMetaState
+ Just lock -> return $ newEditState lock Nothing mpath
void $ runMaybeT $ msum [ do
- finalState <- msum
- [ do
- guard $ ForceCurses `notElem` opts
- sdlUI <- liftMaybe $ msdlUI
- MaybeT $ sdlUI $ interactUI `execStateT` initMState
- , do
- cursesUI <- liftMaybe $ mcursesUI
- MaybeT $ cursesUI $ interactUI `execStateT` initMState
- ]
- when (isNothing mlock) $ lift $ writeMetaState finalState
- lift $ exitSuccess
- , lift exitFailure ]
+ finalState <- msum
+ [ do
+ guard $ ForceCurses `notElem` opts
+ sdlUI <- liftMaybe $ msdlUI
+ MaybeT $ sdlUI $ interactUI `execStateT` initMState
+ , do
+ cursesUI <- liftMaybe $ mcursesUI
+ MaybeT $ cursesUI $ interactUI `execStateT` initMState
+ ]
+ when (isNothing mlock) $ lift $ writeMetaState finalState
+ lift $ exitSuccess
+ , lift exitFailure ]
diff --git a/Interact.hs b/Interact.hs
index 034bb80..f1fbab7 100644
--- a/Interact.hs
+++ b/Interact.hs
@@ -67,47 +67,47 @@ interactUI = do
lift $ onNewMode im
when (im == IMEdit) setSelectedPosFromMouse
when (im == IMMeta) $ do
- spawnUnblockerThread
+ spawnUnblockerThread
- -- draw before testing auth, lest a timeout mean a blank screen
- drawMainState
+ -- draw before testing auth, lest a timeout mean a blank screen
+ drawMainState
- testAuth
- refreshUInfoUI
- tbdg <- lift $ getUIBinding IMMeta CmdTutorials
- isNothing <$> gets curAuth >>?
- lift $ drawMessage $ "Welcome. To play the tutorial levels, press '"++tbdg++"'."
+ testAuth
+ refreshUInfoUI
+ tbdg <- lift $ getUIBinding IMMeta CmdTutorials
+ isNothing <$> gets curAuth >>?
+ lift $ drawMessage $ "Welcome. To play the tutorial levels, press '"++tbdg++"'."
setMark False startMark
interactLoop
where
- interactLoop = do
- mainSt <- get
- let im = ms2im mainSt
- when (im == IMPlay) checkWon
- when (im == IMMeta) $ (checkAsync >>) $ void.runMaybeT $
- mourNameSelected >>? lift purgeInvalidUndecls
- drawMainState
- cmds <- lift $ getSomeInput im
- runExceptT (mapM_ (processCommand im) cmds) >>=
- either
- ((lift (drawMessage "") >>) . return)
- (const interactLoop)
-
- -- | 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
+ interactLoop = do
+ mainSt <- get
+ let im = ms2im mainSt
+ when (im == IMPlay) checkWon
+ when (im == IMMeta) $ (checkAsync >>) $ void.runMaybeT $
+ mourNameSelected >>? lift purgeInvalidUndecls
+ drawMainState
+ cmds <- lift $ getSomeInput im
+ runExceptT (mapM_ (processCommand im) cmds) >>=
+ either
+ ((lift (drawMessage "") >>) . return)
+ (const interactLoop)
+
+ -- | 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
runSubMainState :: UIMonad uiM => MainState -> MainStateT uiM (InteractSuccess,MainState)
runSubMainState mSt = lift (runStateT interactUI mSt) <* cleanOnPop
where cleanOnPop = do
- im <- gets ms2im
- lift $ onNewMode im
- when (im == IMEdit) setSelectedPosFromMouse
+ im <- gets ms2im
+ lift $ onNewMode im
+ when (im == IMEdit) setSelectedPosFromMouse
execSubMainState :: UIMonad uiM => MainState -> MainStateT uiM MainState
execSubMainState = (snd <$>) . runSubMainState
@@ -119,23 +119,23 @@ getSomeInput im = do
processCommand :: UIMonad uiM => InputMode -> Command -> ExceptT InteractSuccess (MainStateT uiM) ()
processCommand im CmdQuit = do
case im of
- IMReplay -> throwE $ InteractSuccess False
- IMPlay -> lift (or <$> sequence [gets psIsSub, gets psSaved, null <$> gets psGameStateMoveStack])
- >>? throwE $ InteractSuccess False
- IMEdit -> lift editStateUnsaved >>! throwE $ InteractSuccess True
- _ -> return ()
+ IMReplay -> throwE $ InteractSuccess False
+ IMPlay -> lift (or <$> sequence [gets psIsSub, gets psSaved, null <$> gets psGameStateMoveStack])
+ >>? throwE $ InteractSuccess False
+ IMEdit -> lift editStateUnsaved >>! throwE $ InteractSuccess True
+ _ -> return ()
title <- lift $ getTitle
(lift . lift . confirm) ("Really quit"
- ++ (if im == IMEdit then " without saving" else "")
- ++ maybe "" (" from "++) title ++ "?")
- >>? throwE $ InteractSuccess False
+ ++ (if im == IMEdit then " without saving" else "")
+ ++ maybe "" (" from "++) title ++ "?")
+ >>? throwE $ InteractSuccess False
processCommand im CmdForceQuit = throwE $ InteractSuccess False
processCommand IMPlay CmdOpen = do
st <- gets psCurrentState
frame <- gets psFrame
if checkSolved (frame,st)
- then throwE $ InteractSuccess True
- else lift.lift $ drawError "Locked!"
+ then throwE $ InteractSuccess True
+ else lift.lift $ drawError "Locked!"
processCommand im cmd = lift $ processCommand' im cmd
processCommand' :: UIMonad uiM => InputMode -> Command -> MainStateT uiM ()
@@ -147,15 +147,15 @@ processCommand' im CmdHelp = lift $ do
return $ [HelpPageInput] ++ if first then [HelpPageFirstEdit] else []
_ -> return [HelpPageInput]
let showPage p = withNoBG $ showHelp im p >>? do
- void $ textInput "[press a key or RMB]" 1 False True Nothing Nothing
+ void $ textInput "[press a key or RMB]" 1 False True Nothing Nothing
sequence_ $ map showPage helpPages
processCommand' im (CmdBind mcmd)= lift $ (>> endPrompt) $ runMaybeT $ do
cmd <- liftMaybe mcmd `mplus` do
- lift $ drawPrompt False "Command to bind: "
- msum $ repeat $ do
- cmd <- MaybeT $ listToMaybe <$> getInput im
- guard $ not.null $ describeCommand cmd
- return cmd
+ lift $ drawPrompt False "Command to bind: "
+ msum $ repeat $ do
+ cmd <- MaybeT $ listToMaybe <$> getInput im
+ guard $ not.null $ describeCommand cmd
+ return cmd
lift $ drawPrompt False ("key to bind to \"" ++ describeCommand cmd ++ "\" (repeat existing user binding to delete): ")
ch <- MaybeT getChRaw
guard $ ch /= '\ESC'
@@ -177,7 +177,7 @@ processCommand' im CmdJumpMark = void.runMaybeT $ do
guard $ im `elem` [IMEdit, IMPlay, IMReplay]
marks <- lift marksSet
str <- MaybeT $ lift $ textInput
- ("Jump to mark [" ++ intersperse ',' marks ++ "]: ")
+ ("Jump to mark [" ++ intersperse ',' marks ++ "]: ")
1 False True (Just $ map (:[]) marks) Nothing
ch <- liftMaybe $ listToMaybe str
lift $ jumpMark ch
@@ -185,47 +185,47 @@ processCommand' im CmdReset = jumpMark startMark
processCommand' IMMeta (CmdSelCodename mname) = void.runMaybeT $ do
mauth <- gets curAuth
name <- msum [ liftMaybe $ mname
- , do
- newCodename <- (map toUpper <$>) $ MaybeT $ lift $
- textInput "Select codename:"
- 3 False False Nothing Nothing
- guard $ length newCodename == 3
- return newCodename
- ]
+ , do
+ newCodename <- (map toUpper <$>) $ MaybeT $ lift $
+ textInput "Select codename:"
+ 3 False False Nothing Nothing
+ guard $ length newCodename == 3
+ return newCodename
+ ]
guard $ validCodeName name
lift $ do
- modify $ \ms -> ms { codenameStack = (name:codenameStack ms) }
- invalidateUInfo name
- refreshUInfoUI
+ modify $ \ms -> ms { codenameStack = (name:codenameStack ms) }
+ invalidateUInfo name
+ refreshUInfoUI
processCommand' IMMeta CmdHome = void.runMaybeT $ do
ourName <- mgetOurName
lift $ do
- modify $ \ms -> ms { codenameStack = (ourName:codenameStack ms) }
- refreshUInfoUI
+ modify $ \ms -> ms { codenameStack = (ourName:codenameStack ms) }
+ refreshUInfoUI
processCommand' IMMeta CmdBackCodename = do
stack <- gets codenameStack
when (length stack > 1) $ do
- modify $ \ms -> ms { codenameStack = tail stack }
- refreshUInfoUI
+ modify $ \ms -> ms { codenameStack = tail stack }
+ refreshUInfoUI
processCommand' IMMeta CmdSetServer = void.runMaybeT $ do
saddr <- gets curServer
saddrs <- liftIO $ knownServers
newSaddr' <- MaybeT $ ((>>= strToSaddr) <$>) $
- lift $ textInput "Set server:" 256 False False
- (Just $ map saddrStr saddrs) (Just $ saddrStr saddr)
+ lift $ textInput "Set server:" 256 False False
+ (Just $ map saddrStr saddrs) (Just $ saddrStr saddr)
let newSaddr = if nullSaddr newSaddr' then defaultServerAddr else newSaddr'
modify $ \ms -> ms { curServer = newSaddr }
msum [ void.MaybeT $ getFreshRecBlocking RecServerInfo
- , modify (\ms -> ms { curServer = saddr }) >> mzero ]
+ , modify (\ms -> ms { curServer = saddr }) >> mzero ]
lift $ do
- modify $ \ms -> ms {curAuth = Nothing}
- get >>= liftIO . writeServerSolns saddr
- (undecls,partials,_) <- liftIO (readServerSolns newSaddr)
- modify $ \ms -> ms { undeclareds=undecls, partialSolutions=partials }
- rnamestvar <- gets randomCodenames
- liftIO $ atomically $ writeTVar rnamestvar []
- invalidateAllUInfo
- refreshUInfoUI
+ modify $ \ms -> ms {curAuth = Nothing}
+ get >>= liftIO . writeServerSolns saddr
+ (undecls,partials,_) <- liftIO (readServerSolns newSaddr)
+ modify $ \ms -> ms { undeclareds=undecls, partialSolutions=partials }
+ rnamestvar <- gets randomCodenames
+ liftIO $ atomically $ writeTVar rnamestvar []
+ invalidateAllUInfo
+ refreshUInfoUI
processCommand' IMMeta CmdToggleCacheOnly = do
newCOnly <- gets $ not . cacheOnly
modify $ \ms -> ms {cacheOnly = newCOnly}
@@ -237,11 +237,11 @@ processCommand' IMMeta (CmdRegister _) = void.runMaybeT $ do
mauth <- gets curAuth
let isUs = maybe False ((==regName).authUser) mauth
if isUs
- then msum [ do
- confirmOrBail "Log out?"
- modify $ \ms -> ms {curAuth = Nothing}
- , do
- confirmOrBail "Reset password?"
+ then msum [ do
+ confirmOrBail "Log out?"
+ modify $ \ms -> ms {curAuth = Nothing}
+ , do
+ confirmOrBail "Reset password?"
void.lift.runMaybeT $ do
passwd <- inputPassword regName True "Enter new password:"
lift $ do
@@ -252,11 +252,11 @@ processCommand' IMMeta (CmdRegister _) = void.runMaybeT $ do
modify $ \ms -> ms {curAuth = Just $ Auth regName passwd}
ServerError err -> lift $ drawError err
_ -> lift $ drawMessage $ "Bad server response: " ++ show resp
- , do
- confirmOrBail "Configure email notifications?"
- setNotifications
- ]
- else msum [ do
+ , do
+ confirmOrBail "Configure email notifications?"
+ setNotifications
+ ]
+ else msum [ do
mgetUInfo regName
lift.lift $ drawError "Sorry, this codename is already taken."
, do
@@ -278,69 +278,69 @@ processCommand' IMMeta (CmdRegister _) = void.runMaybeT $ do
]
where setNotifications = do
- address <- MaybeT $ lift $ textInput "Enter address, or leave blank to disable notifications:" 128 False False Nothing Nothing
- lift $ do
- resp <- curServerAction $ SetEmail address
- case resp of
- ServerAck -> lift $ drawMessage $ if null address then "Notifications disabled." else "Address set."
- ServerError err -> lift $ drawError err
- _ -> lift $ drawMessage $ "Bad server response: " ++ show resp
-
-
+ address <- MaybeT $ lift $ textInput "Enter address, or leave blank to disable notifications:" 128 False False Nothing Nothing
+ lift $ do
+ resp <- curServerAction $ SetEmail address
+ case resp of
+ ServerAck -> lift $ drawMessage $ if null address then "Notifications disabled." else "Address set."
+ ServerError err -> lift $ drawError err
+ _ -> lift $ drawMessage $ "Bad server response: " ++ show resp
+
+
processCommand' IMMeta CmdAuth = void.runMaybeT $ do
auth <- lift $ gets curAuth
if isJust auth then do
- confirmOrBail "Log out?"
- modify $ \ms -> ms {curAuth = Nothing}
+ confirmOrBail "Log out?"
+ modify $ \ms -> ms {curAuth = Nothing}
else do
- name <- mgetCurName
- passwd <- inputPassword name False $ "Enter password for "++name++":"
- lift $ do
- modify $ \ms -> ms {curAuth = Just $ Auth name passwd}
- resp <- curServerAction $ Authenticate
- case resp of
- ServerAck -> lift $ drawMessage "Authenticated."
- ServerMessage msg -> lift $ drawMessage $ "Server: " ++ msg
- ServerError err -> do
- lift $ drawError err
- modify $ \ms -> ms {curAuth = auth}
- _ -> lift $ drawMessage $ "Bad server response: " ++ show resp
- refreshUInfoUI
+ name <- mgetCurName
+ passwd <- inputPassword name False $ "Enter password for "++name++":"
+ lift $ do
+ modify $ \ms -> ms {curAuth = Just $ Auth name passwd}
+ resp <- curServerAction $ Authenticate
+ case resp of
+ ServerAck -> lift $ drawMessage "Authenticated."
+ ServerMessage msg -> lift $ drawMessage $ "Server: " ++ msg
+ ServerError err -> do
+ lift $ drawError err
+ modify $ \ms -> ms {curAuth = auth}
+ _ -> lift $ drawMessage $ "Bad server response: " ++ show resp
+ refreshUInfoUI
processCommand' IMMeta (CmdSolve midx) = void.runMaybeT $ do
name <- mgetCurName
uinfo <- mgetUInfo name
idx <- msum [ liftMaybe midx
- , askLockIndex "Solve which lock?" "No lock to solve!" (\i -> isJust $ userLocks uinfo ! i) ]
+ , askLockIndex "Solve which lock?" "No lock to solve!" (\i -> isJust $ userLocks uinfo ! i) ]
ls <- liftMaybe $ lockSpec <$> userLocks uinfo ! idx
undecls <- lift (gets undeclareds)
msum [ do
- undecl <- liftMaybe $ find (\(Undeclared _ ls' _) -> ls == ls') undecls
- MaybeT $ gets curAuth
- confirmOrBail "Declare existing solution?"
- void.lift.runMaybeT $ -- ignores MaybeT failures
- declare undecl
- , do
- RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls
- mpartial <- Map.lookup ls <$> gets partialSolutions
- soln <- solveLockSaving ls mpartial False lock $ Just $
- "solving " ++ name ++ ":" ++ [lockIndexChar idx] ++ " (#" ++ show ls ++")"
- mourName <- lift $ (authUser <$>) <$> gets curAuth
- guard $ mourName /= Just name
- let undecl = Undeclared soln ls (ActiveLock name idx)
- msum [ do
- MaybeT $ gets curAuth
- confirmOrBail "Declare solution?"
- declare undecl
- , unless (any (\(Undeclared _ ls' _) -> ls == ls') undecls) $
- modify $ \ms -> ms { undeclareds = (undecl : undeclareds ms) }
- ]
- ]
+ undecl <- liftMaybe $ find (\(Undeclared _ ls' _) -> ls == ls') undecls
+ MaybeT $ gets curAuth
+ confirmOrBail "Declare existing solution?"
+ void.lift.runMaybeT $ -- ignores MaybeT failures
+ declare undecl
+ , do
+ RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls
+ mpartial <- Map.lookup ls <$> gets partialSolutions
+ soln <- solveLockSaving ls mpartial False lock $ Just $
+ "solving " ++ name ++ ":" ++ [lockIndexChar idx] ++ " (#" ++ show ls ++")"
+ mourName <- lift $ (authUser <$>) <$> gets curAuth
+ guard $ mourName /= Just name
+ let undecl = Undeclared soln ls (ActiveLock name idx)
+ msum [ do
+ MaybeT $ gets curAuth
+ confirmOrBail "Declare solution?"
+ declare undecl
+ , unless (any (\(Undeclared _ ls' _) -> ls == ls') undecls) $
+ modify $ \ms -> ms { undeclareds = (undecl : undeclareds ms) }
+ ]
+ ]
processCommand' IMMeta (CmdPlayLockSpec mls) = void.runMaybeT $ do
ls <- msum [ liftMaybe mls
- , do
- tls <- MaybeT . lift $ textInput "Lock number:" 16 False False Nothing Nothing
- liftMaybe $ readMay tls
- ]
+ , do
+ tls <- MaybeT . lift $ textInput "Lock number:" 16 False False Nothing Nothing
+ liftMaybe $ readMay tls
+ ]
RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls
solveLock lock $ Just $ "solving " ++ show ls
@@ -350,76 +350,76 @@ processCommand' IMMeta (CmdDeclare mundecl) = void.runMaybeT $ do
undecls <- lift $ gets undeclareds
guard $ not $ null undecls
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
- liftMaybe $ msum
- [ do
- i <- readMay which
- guard $ 0 < i && i <= length undecls
- return $ undecls !! (i-1)
- , listToMaybe $
- [ undecl
- | undecl@(Undeclared _ _ (ActiveLock name' i)) <- undecls
- , or
- [ take (length which) (name' ++ ":" ++ [lockIndexChar i]) ==
- map toUpper which
- , name'==name && [lockIndexChar i] == which
- ]
- ]
- ]
- ]
+ , if length undecls == 1
+ then return $ head undecls
+ else do
+ which <- MaybeT $ lift $ textInput
+ ("Declare which solution?")
+ 5 False True Nothing Nothing
+ liftMaybe $ msum
+ [ do
+ i <- readMay which
+ guard $ 0 < i && i <= length undecls
+ return $ undecls !! (i-1)
+ , listToMaybe $
+ [ undecl
+ | undecl@(Undeclared _ _ (ActiveLock name' i)) <- undecls
+ , or
+ [ take (length which) (name' ++ ":" ++ [lockIndexChar i]) ==
+ map toUpper which
+ , name'==name && [lockIndexChar i] == which
+ ]
+ ]
+ ]
+ ]
processCommand' IMMeta (CmdViewSolution mnote) = void.runMaybeT $ do
note <- liftMaybe mnote `mplus` do
- ourName <- mgetOurName
- name <- mgetCurName
- uinfo <- mgetUInfo name
- noteses <- lift $ sequence
- [ case mlockinfo of
- Nothing -> return []
- Just lockinfo -> (++lockSolutions lockinfo) <$> do
- 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
- 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
- liftMaybe $ find ((==author).noteAuthor) notes
+ ourName <- mgetOurName
+ name <- mgetCurName
+ uinfo <- mgetUInfo name
+ noteses <- lift $ sequence
+ [ case mlockinfo of
+ Nothing -> return []
+ Just lockinfo -> (++lockSolutions lockinfo) <$> do
+ 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
+ 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
+ liftMaybe $ find ((==author).noteAuthor) notes
let ActiveLock name idx = noteOn note
uinfo <- mgetUInfo name
ls <- lockSpec <$> MaybeT (return $ userLocks uinfo ! idx)
RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls
RCSolution soln <- MaybeT $ getFreshRecBlocking $ RecNote note
lift $ execSubMainState $ newReplayState (snd.reframe$lock) soln $ Just $
- "viewing solution by " ++ noteAuthor note ++ " to " ++ name ++ [':',lockIndexChar idx]
+ "viewing solution by " ++ noteAuthor note ++ " to " ++ name ++ [':',lockIndexChar idx]
processCommand' IMMeta (CmdPlaceLock midx) = void.runMaybeT $ do
guard =<< mourNameSelected
ourName <- mgetOurName
(lock,msoln) <- MaybeT (gets curLock) `mplus` do
- ebdg <- lift.lift $ getUIBinding IMMeta CmdEdit
- lift.lift $ drawError $ "No lock selected; '"++ebdg++"' to edit one."
- mzero
+ 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 <- (liftMaybe midx `mplus`) $
- askLockIndex ("Place " ++ show lockpath ++ " in which slot?") "bug" $ const True
+ askLockIndex ("Place " ++ show lockpath ++ " in which slot?") "bug" $ const True
when (isJust $ userLocks ourUInfo ! idx) $
- confirmOrBail "Really retire existing lock?"
+ confirmOrBail "Really retire existing lock?"
soln <- (liftMaybe msoln `mplus`) $ solveLock lock $ Just $ "testing lock"
lift $ curServerActionAsyncThenInvalidate
- (SetLock lock idx soln)
- (Just (SomeCodenames [ourName]))
+ (SetLock lock idx soln)
+ (Just (SomeCodenames [ourName]))
processCommand' IMMeta CmdSelectLock = void.runMaybeT $ do
lockdir <- liftIO $ confFilePath "locks"
@@ -436,19 +436,19 @@ processCommand' IMMeta CmdPrevPage =
modify $ \ms -> ms { listOffset = max 0 $ listOffset ms - 1 }
processCommand' IMMeta CmdEdit = void.runMaybeT $ do
(lock, msoln) <- (MaybeT $ gets curLock) `mplus` do
- 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)
+ 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)
not <$> liftIO hasLocks >>? do
lift.lift $ withNoBG $ showHelp IMEdit HelpPageFirstEdit >>? do
void $ textInput
@@ -456,59 +456,59 @@ processCommand' IMMeta CmdEdit = void.runMaybeT $ do
1 False True Nothing Nothing
path <- lift $ gets curLockPath
newPath <- MaybeT $ (esPath <$>) $ execSubMainState $
- newEditState (reframe lock) msoln (if null path then Nothing else Just path)
+ newEditState (reframe lock) msoln (if null path then Nothing else Just path)
lift $ setLockPath newPath
processCommand' IMMeta CmdTutorials = void.runMaybeT $ do
tutdir <- liftIO $ getDataPath "tutorial"
tuts <- liftIO $ (sort . map (takeWhile (/='.')) . filter (isSuffixOf ".lock")) <$>
- getDirectoryContents tutdir `catchIO` (const $ return [])
+ getDirectoryContents tutdir `catchIO` (const $ return [])
when (null tuts) $ do
- lift.lift $ drawError "No tutorial levels found"
- mzero
+ lift.lift $ drawError "No tutorial levels found"
+ mzero
-- s <- MaybeT $ lift $ textInput ("Play which tutorial level? [1-"++show (length tuts)++"]")
- -- (length (show (length tuts))) False True Nothing Nothing
+ -- (length (show (length tuts))) False True Nothing Nothing
-- i <- liftMaybe $ readMay s
-- guard $ 1 <= i && i <= length tuts
let dotut i msps = do
- let name = tuts !! (i-1)
- let pref = tutdir ++ [pathSeparator] ++ name
- (lock,_) <- MaybeT $ liftIO $ readLock (pref ++ ".lock")
- text <- liftIO $ (fromMaybe "" . listToMaybe) <$> (readStrings (pref ++ ".text") `catchIO` const (return []))
- solveLockSaving i msps True lock $ Just $ "Tutorial " ++ show i ++ ": " ++ text
- if i+1 <= length tuts then do
- -- confirmOrBail $ "Tutorial level completed! Play next tutorial level (" ++ show (i+1) ++ ")?"
- dotut (i+1) Nothing
- else lift $ do
- modify $ \ms -> ms {tutProgress = (1,Nothing)}
- mauth <- gets curAuth
- cbdg <- lift $ getUIBinding IMMeta $ CmdSelCodename Nothing
- rbdg <- lift $ getUIBinding IMMeta (CmdRegister False)
- if isNothing mauth
- then do
- let showPage p prompt = lift $ withNoBG $ showHelp IMMeta p >>? do
- void $ textInput prompt 1 False True Nothing Nothing
- showPage (HelpPageInitiated 1) "[Tutorial complete! Press a key or RMB to continue]"
- showPage (HelpPageInitiated 2) "[Press a key or RMB to continue]"
- showPage (HelpPageInitiated 3) "[Press a key or RMB to continue]"
- --showPage HelpPageGame "[Press a key or RMB to continue; you can review this information later with '?']"
- lift $ drawMessage $
- "To join the game: pick a codename ('"++cbdg++
- "') and register it ('"++rbdg++"')."
- else lift $ drawMessage $ "Tutorial completed!"
-
+ let name = tuts !! (i-1)
+ let pref = tutdir ++ [pathSeparator] ++ name
+ (lock,_) <- MaybeT $ liftIO $ readLock (pref ++ ".lock")
+ text <- liftIO $ (fromMaybe "" . listToMaybe) <$> (readStrings (pref ++ ".text") `catchIO` const (return []))
+ solveLockSaving i msps True lock $ Just $ "Tutorial " ++ show i ++ ": " ++ text
+ if i+1 <= length tuts then do
+ -- confirmOrBail $ "Tutorial level completed! Play next tutorial level (" ++ show (i+1) ++ ")?"
+ dotut (i+1) Nothing
+ else lift $ do
+ modify $ \ms -> ms {tutProgress = (1,Nothing)}
+ mauth <- gets curAuth
+ cbdg <- lift $ getUIBinding IMMeta $ CmdSelCodename Nothing
+ rbdg <- lift $ getUIBinding IMMeta (CmdRegister False)
+ if isNothing mauth
+ then do
+ let showPage p prompt = lift $ withNoBG $ showHelp IMMeta p >>? do
+ void $ textInput prompt 1 False True Nothing Nothing
+ showPage (HelpPageInitiated 1) "[Tutorial complete! Press a key or RMB to continue]"
+ showPage (HelpPageInitiated 2) "[Press a key or RMB to continue]"
+ showPage (HelpPageInitiated 3) "[Press a key or RMB to continue]"
+ --showPage HelpPageGame "[Press a key or RMB to continue; you can review this information later with '?']"
+ lift $ drawMessage $
+ "To join the game: pick a codename ('"++cbdg++
+ "') and register it ('"++rbdg++"')."
+ else lift $ drawMessage $ "Tutorial completed!"
+
(onLevel,msps) <- lift $ gets tutProgress
dotut onLevel msps
processCommand' IMMeta CmdShowRetired = void.runMaybeT $ do
name <- mgetCurName
newRL <- lift (gets retiredLocks) >>= \rl -> case rl of
- Nothing -> do
- RCLockSpecs lss <- MaybeT $ getFreshRecBlocking $ RecRetiredLocks name
- if null lss
- then do
- lift.lift $ drawError "Player has no retired locks."
- return Nothing
- else return $ Just lss
- Just _ -> return Nothing
+ Nothing -> do
+ RCLockSpecs lss <- MaybeT $ getFreshRecBlocking $ RecRetiredLocks name
+ if null lss
+ then do
+ lift.lift $ drawError "Player has no retired locks."
+ return Nothing
+ else return $ Just lss
+ Just _ -> return Nothing
lift $ modify $ \ms -> ms {retiredLocks = newRL}
processCommand' IMPlay CmdUndo = do
@@ -516,35 +516,35 @@ processCommand' IMPlay CmdUndo = do
stack <- gets psGameStateMoveStack
ustms <- gets psUndoneStack
unless (null stack) $ do
- let (st',pm) = head stack
- modify $ \ps -> ps {psCurrentState=st', psGameStateMoveStack = tail stack,
- psLastAlerts = [], psUndoneStack = (st,pm):ustms}
+ let (st',pm) = head stack
+ modify $ \ps -> ps {psCurrentState=st', psGameStateMoveStack = tail stack,
+ psLastAlerts = [], psUndoneStack = (st,pm):ustms}
processCommand' IMPlay CmdRedo = do
ustms <- gets psUndoneStack
case ustms of
- [] -> return ()
- ustm@(_,pm):ustms' -> do
- st <- gets psCurrentState
- (st',alerts) <- lift $ doPhysicsTick pm st
- pushPState (st',pm)
- modify $ \ps -> ps {psLastAlerts = alerts, psUndoneStack = ustms'}
+ [] -> return ()
+ ustm@(_,pm):ustms' -> do
+ st <- gets psCurrentState
+ (st',alerts) <- lift $ doPhysicsTick pm st
+ pushPState (st',pm)
+ modify $ \ps -> ps {psLastAlerts = alerts, psUndoneStack = ustms'}
processCommand' IMPlay (CmdManipulateToolAt pos) = do
board <- stateBoard <$> gets psCurrentState
wsel <- gets wrenchSelected
void.runMaybeT $ msum $ [ do
- tile <- liftMaybe $ snd <$> Map.lookup pos board
- guard $ case tile of {WrenchTile _ -> True; HookTile -> True; _ -> False}
- lift $ processCommand' IMPlay $ CmdTile tile
- ] ++ [ do
- 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 ]
+ tile <- liftMaybe $ snd <$> Map.lookup pos board
+ guard $ case tile of {WrenchTile _ -> True; HookTile -> True; _ -> False}
+ lift $ processCommand' IMPlay $ CmdTile tile
+ ] ++ [ do
+ tile <- liftMaybe $ snd <$> Map.lookup (d+^pos) board
+ guard $ tileType tile == if wsel then WrenchTile zero else HookTile
+ lift $ processCommand' IMPlay $ CmdDir WHSSelected $ neg d
+ | d <- hexDirs ]
processCommand' IMPlay (CmdDrag pos dir) = do
board <- stateBoard <$> gets psCurrentState
wsel <- gets wrenchSelected
void.runMaybeT $ do
- tp <- liftMaybe $ tileType . snd <$> Map.lookup pos board
+ tp <- liftMaybe $ tileType . snd <$> Map.lookup pos board
msum [ guard $ tp == HookTile
, do
guard $ tp == WrenchTile zero
@@ -556,62 +556,62 @@ processCommand' IMPlay (CmdDrag pos dir) = do
, let pos' = d *^ dir +^ pos ]
++ [ (lift.lift $ warpPointer pos) >> mzero ]
]
- lift $ processCommand' IMPlay $ CmdDir WHSSelected $ dir
- board' <- stateBoard <$> gets psCurrentState
- msum [ do
- tp' <- liftMaybe $ tileType . snd <$> Map.lookup pos' board'
- guard $ tp' == if wsel then WrenchTile zero else HookTile
- lift.lift $ warpPointer pos'
- | pos' <- map (+^pos) $ hexDisc 2 ]
+ lift $ processCommand' IMPlay $ CmdDir WHSSelected $ dir
+ board' <- stateBoard <$> gets psCurrentState
+ msum [ do
+ tp' <- liftMaybe $ tileType . snd <$> Map.lookup pos' board'
+ guard $ tp' == if wsel then WrenchTile zero else HookTile
+ lift.lift $ warpPointer pos'
+ | pos' <- map (+^pos) $ hexDisc 2 ]
processCommand' IMPlay cmd = do
wsel <- gets wrenchSelected
st <- gets psCurrentState
let push whs dir
- | whs == WHSWrench || (whs == WHSSelected && wsel) =
- Just $ WrenchPush dir
- | otherwise = Just $ HookPush dir
- torque whs dir
- {- | whs == WHSHook || (whs == WHSSelected && not wsel)=
- Just $ HookTorque dir
- | otherwise = Nothing -}
- = Just $ HookTorque dir
- (wsel', pm) =
- case cmd of
- CmdTile (WrenchTile _) -> (True, Nothing)
- CmdTile HookTile -> (False, Nothing)
- CmdTile (ArmTile _ _) -> (False, Nothing)
- CmdToggle -> (not wsel, Nothing)
- CmdDir whs dir -> (wsel, push whs dir)
- CmdRotate whs dir -> (wsel, torque whs dir)
- CmdWait -> (wsel, Just NullPM)
- CmdSelect -> (wsel, Just NullPM)
- _ -> (wsel, Nothing)
+ | whs == WHSWrench || (whs == WHSSelected && wsel) =
+ Just $ WrenchPush dir
+ | otherwise = Just $ HookPush dir
+ torque whs dir
+ {- | whs == WHSHook || (whs == WHSSelected && not wsel)=
+ Just $ HookTorque dir
+ | otherwise = Nothing -}
+ = Just $ HookTorque dir
+ (wsel', pm) =
+ case cmd of
+ CmdTile (WrenchTile _) -> (True, Nothing)
+ CmdTile HookTile -> (False, Nothing)
+ CmdTile (ArmTile _ _) -> (False, Nothing)
+ CmdToggle -> (not wsel, Nothing)
+ CmdDir whs dir -> (wsel, push whs dir)
+ CmdRotate whs dir -> (wsel, torque whs dir)
+ CmdWait -> (wsel, Just NullPM)
+ CmdSelect -> (wsel, Just NullPM)
+ _ -> (wsel, Nothing)
modify $ \ps -> ps {wrenchSelected = wsel'}
case pm of
- Nothing -> return ()
- Just pm' -> do
- (st',alerts) <- lift $ doPhysicsTick pm' st
- modify $ \ps -> ps {psLastAlerts = alerts}
- pushPState (st',pm')
+ Nothing -> return ()
+ Just pm' -> do
+ (st',alerts) <- lift $ doPhysicsTick pm' st
+ modify $ \ps -> ps {psLastAlerts = alerts}
+ pushPState (st',pm')
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}
+ , rsLastAlerts = []
+ , rsGameStateMoveStack = tail $ rsGameStateMoveStack rs
+ , rsMoveStack = pm:rsMoveStack rs}
processCommand' IMReplay (CmdReplayBack n) = replicateM_ n $
processCommand' IMReplay (CmdReplayBack 1)
processCommand' IMReplay (CmdReplayForward 1) = void.runMaybeT $ do
pm <- MaybeT $ listToMaybe <$> gets rsMoveStack
lift $ do
- st <- gets rsCurrentState
- (st',alerts) <- lift $ doPhysicsTick pm st
- modify $ \rs -> rs {rsCurrentState = st'
- , rsLastAlerts = alerts
- , rsGameStateMoveStack = (st,pm):rsGameStateMoveStack rs
- , rsMoveStack = tail $ rsMoveStack rs}
+ st <- gets rsCurrentState
+ (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 $
processCommand' IMReplay (CmdReplayForward 1)
processCommand' IMReplay CmdUndo = processCommand' IMReplay (CmdReplayBack 1)
@@ -629,8 +629,8 @@ processCommand' IMEdit CmdTest = do
mpath <- gets esPath
st <- gets $ head.esGameStateStack
void.runMaybeT $ do
- soln <- solveLock (frame,st) $ Just $ "testing " ++ fromMaybe "[unnamed lock]" mpath
- lift $ modify $ \es -> es { esTested = Just (st, soln) }
+ soln <- solveLock (frame,st) $ Just $ "testing " ++ fromMaybe "[unnamed lock]" mpath
+ lift $ modify $ \es -> es { esTested = Just (st, soln) }
processCommand' IMEdit CmdUndo = do
st:sts <- gets esGameStateStack
usts <- gets esUndoneStack
@@ -638,10 +638,10 @@ processCommand' IMEdit CmdUndo = do
processCommand' IMEdit CmdRedo = do
usts <- gets esUndoneStack
case usts of
- [] -> return ()
- ust:usts' -> do
- pushEState ust
- modify $ \es -> es {esUndoneStack = usts'}
+ [] -> return ()
+ ust:usts' -> do
+ pushEState ust
+ modify $ \es -> es {esUndoneStack = usts'}
processCommand' IMEdit CmdUnselect =
modify $ \es -> es {selectedPiece = Nothing}
processCommand' IMEdit CmdSelect = do
@@ -649,37 +649,37 @@ processCommand' IMEdit CmdSelect = do
selPos <- gets selectedPos
st:_ <- gets esGameStateStack
let selPiece' =
- if isJust selPiece
- then Nothing
- else liftM fst $ Map.lookup selPos $ stateBoard st
+ if isJust selPiece
+ then Nothing
+ else liftM fst $ Map.lookup selPos $ stateBoard st
modify $ \es -> es {selectedPiece = selPiece'}
processCommand' IMEdit (CmdDir _ dir) = do
selPos <- gets selectedPos
selPiece <- gets selectedPiece
frame <- gets esFrame
case selPiece of
- Nothing -> modify $ \es -> es {selectedPos = checkEditable frame selPos $ dir +^ selPos}
- Just p -> doForce $ Push p dir
+ Nothing -> modify $ \es -> es {selectedPos = checkEditable frame selPos $ dir +^ selPos}
+ Just p -> doForce $ Push p dir
processCommand' IMEdit (CmdMoveTo newPos) =
setSelectedPos newPos
processCommand' IMEdit (CmdDrag pos dir) = do
board <- stateBoard.head <$> gets esGameStateStack
void.runMaybeT $ do
- selIdx <- MaybeT $ gets selectedPiece
- idx <- liftMaybe $ fst <$> Map.lookup pos board
- guard $ idx == selIdx
- lift $ processCommand' IMEdit $ CmdDir WHSSelected $ dir
- board' <- stateBoard.head <$> gets esGameStateStack
- msum [ do
- idx' <- liftMaybe $ fst <$> Map.lookup pos' board'
- guard $ idx' == selIdx
- lift.lift $ warpPointer $ pos'
- | pos' <- [dir+^pos, pos] ]
+ selIdx <- MaybeT $ gets selectedPiece
+ idx <- liftMaybe $ fst <$> Map.lookup pos board
+ guard $ idx == selIdx
+ lift $ processCommand' IMEdit $ CmdDir WHSSelected $ dir
+ board' <- stateBoard.head <$> gets esGameStateStack
+ msum [ do
+ idx' <- liftMaybe $ fst <$> Map.lookup pos' board'
+ guard $ idx' == selIdx
+ lift.lift $ warpPointer $ pos'
+ | pos' <- [dir+^pos, pos] ]
processCommand' IMEdit (CmdRotate _ dir) = do
selPiece <- gets selectedPiece
case selPiece of
- Nothing -> return ()
- Just p -> doForce $ Torque p dir
+ Nothing -> return ()
+ Just p -> doForce $ Torque p dir
processCommand' IMEdit (CmdTile tile) = do
selPos <- gets selectedPos
drawTile selPos (Just tile) False
@@ -694,16 +694,16 @@ processCommand' IMEdit CmdMerge = do
st:_ <- gets esGameStateStack
lift $ drawMessage "Merge in which direction?"
let getDir = do
- cmd <- lift $ head <$> getSomeInput IMEdit
- case cmd of
- CmdDir _ mergeDir -> return $ Just mergeDir
- CmdDrag _ mergeDir -> return $ Just mergeDir
- CmdMoveTo _ -> getDir
- _ -> return $ Nothing
+ cmd <- lift $ head <$> getSomeInput IMEdit
+ case cmd of
+ CmdDir _ mergeDir -> return $ Just mergeDir
+ CmdDrag _ mergeDir -> return $ Just mergeDir
+ CmdMoveTo _ -> getDir
+ _ -> return $ Nothing
mergeDir <- getDir
case mergeDir of
- Just mergeDir -> modifyEState $ mergeTiles selPos mergeDir True
- _ -> return ()
+ Just mergeDir -> modifyEState $ mergeTiles selPos mergeDir True
+ _ -> return ()
-- XXX: merging might invalidate selectedPiece
modify $ \es -> es {selectedPiece = Nothing}
lift $ drawMessage ""
@@ -717,26 +717,26 @@ processCommand' IMEdit CmdDelete = do
selPiece <- gets selectedPiece
st:_ <- gets esGameStateStack
case selPiece of
- Nothing -> drawTile selPos Nothing False
- Just p -> do modify $ \es -> es {selectedPiece = Nothing}
- modifyEState $ delPiece p
+ Nothing -> drawTile selPos Nothing False
+ Just p -> do modify $ \es -> es {selectedPiece = Nothing}
+ modifyEState $ delPiece p
processCommand' IMEdit CmdWriteState = void.runMaybeT $ do
path <- lift $ gets esPath
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)) >>?
- confirmOrBail $ "Really overwrite '"++fullPath++"'?"
+ confirmOrBail $ "Really overwrite '"++fullPath++"'?"
lift $ do
- st <- gets $ head.esGameStateStack
- frame <- gets esFrame
- msoln <- getCurTestSoln
- merr <- liftIO $ ((writeAsciiLockFile fullPath msoln $ canonify (frame, st)) >> return Nothing)
- `catchIO` (return . Just . show)
- modify $ \es -> es {lastSavedState = Just (st,isJust msoln)}
- case merr of
- Nothing -> modify $ \es -> es {esPath = Just newPath}
- Just err -> lift $ drawError $ "Write failed: "++err
+ st <- gets $ head.esGameStateStack
+ frame <- gets esFrame
+ msoln <- getCurTestSoln
+ merr <- liftIO $ ((writeAsciiLockFile fullPath msoln $ canonify (frame, st)) >> return Nothing)
+ `catchIO` (return . Just . show)
+ modify $ \es -> es {lastSavedState = Just (st,isJust msoln)}
+ case merr of
+ Nothing -> modify $ \es -> es {esPath = Just newPath}
+ Just err -> lift $ drawError $ "Write failed: "++err
processCommand' _ _ = return ()
inputPassword :: UIMonad uiM => Codename -> Bool -> String -> MaybeT (MainStateT uiM) String
@@ -794,12 +794,12 @@ solveLock' isTut lock title = do
solveLockSaving :: UIMonad uiM => LockSpec -> Maybe SavedPlayState -> Bool -> Lock -> Maybe String -> MaybeT (MainStateT uiM) Solution
solveLockSaving ls msps isTut lock title = do
(InteractSuccess solved, ps) <- lift $ runSubMainState $
- ((maybe newPlayState restorePlayState) msps) (reframe lock) title isTut False True
+ ((maybe newPlayState restorePlayState) msps) (reframe lock) title isTut False True
if solved
- then do
- unless isTut $ lift $ modify $ \ms -> ms { partialSolutions = Map.delete ls $ partialSolutions ms }
- return $ reverse $ (map snd) $ psGameStateMoveStack ps
- else do
- lift $ modify $ \ms -> if isTut then ms { tutProgress = (ls,Just $ savePlayState ps) }
- else ms { partialSolutions = Map.insert ls (savePlayState ps) $ partialSolutions ms }
- mzero
+ then do
+ unless isTut $ lift $ modify $ \ms -> ms { partialSolutions = Map.delete ls $ partialSolutions ms }
+ return $ reverse $ (map snd) $ psGameStateMoveStack ps
+ else do
+ lift $ modify $ \ms -> if isTut then ms { tutProgress = (ls,Just $ savePlayState ps) }
+ else ms { partialSolutions = Map.insert ls (savePlayState ps) $ partialSolutions ms }
+ mzero
diff --git a/InteractUtil.hs b/InteractUtil.hs
index 18518c7..1334000 100644
--- a/InteractUtil.hs
+++ b/InteractUtil.hs
@@ -44,12 +44,12 @@ checkWon = do
wasSolved <- gets psSolved
let solved = checkSolved (frame,st)
when (solved /= wasSolved) $ do
- modify $ \ps -> ps {psSolved = solved}
- obdg <- lift $ getUIBinding IMPlay CmdOpen
- lift $ if solved then do
- drawMessage $ "Unlocked! '"++obdg++"' to open."
- reportAlerts st [AlertUnlocked]
- else drawMessage ""
+ modify $ \ps -> ps {psSolved = solved}
+ obdg <- lift $ getUIBinding IMPlay CmdOpen
+ lift $ if solved then do
+ drawMessage $ "Unlocked! '"++obdg++"' to open."
+ reportAlerts st [AlertUnlocked]
+ else drawMessage ""
doForce force = do
st:_ <- gets esGameStateStack
@@ -64,7 +64,7 @@ paintTilePath frame tile from to = if from == to
then modify $ \es -> es {lastModPos = to}
else do
let from' = (hexVec2HexDirOrZero $ to-^from) +^ from
- when (inEditable frame from') $ drawTile from' tile True
+ when (inEditable frame from') $ drawTile from' tile True
paintTilePath frame tile from' to
pushEState :: UIMonad uiM => GameState -> MainStateT uiM ()
@@ -76,7 +76,7 @@ pushPState (st,pm) = do
st' <- gets psCurrentState
stms <- gets psGameStateMoveStack
when (st' /= st) $ modify $ \ps -> ps {psCurrentState = st,
- psGameStateMoveStack = (st',pm):stms, psUndoneStack = []}
+ psGameStateMoveStack = (st',pm):stms, psUndoneStack = []}
modifyEState :: UIMonad uiM => (GameState -> GameState) -> MainStateT uiM ()
modifyEState f = do
st:_ <- gets esGameStateStack
@@ -91,13 +91,13 @@ nextLock :: Bool -> FilePath -> IO FilePath
nextLock newer path = do
lockdir <- confFilePath "locks"
time <- (Just <$> (fullLockPath path >>= getModificationTime))
- `catchIO` const (return Nothing)
+ `catchIO` const (return Nothing)
paths <- getDirContentsRec lockdir
maybe path (drop (length lockdir + 1) . fst) . listToMaybe .
- (if newer then id else reverse) . sortBy (compare `on` snd) .
- filter (maybe (const True)
- (\x y -> (if newer then (<) else (>)) x (snd y)) time) <$>
- (\p -> (,) p <$> getModificationTime p) `mapM` paths
+ (if newer then id else reverse) . sortBy (compare `on` snd) .
+ filter (maybe (const True)
+ (\x y -> (if newer then (<) else (>)) x (snd y)) time) <$>
+ (\p -> (,) p <$> getModificationTime p) `mapM` paths
hasLocks :: IO Bool
hasLocks = do
@@ -116,17 +116,17 @@ declare undecl@(Undeclared soln ls al) = do
[ CmdPlaceLock Nothing, CmdEdit, CmdHome ]
haveLock <- isJust <$> gets curLock
idx <- askLockIndex "Secure behind which lock?"
- (if haveLock
+ (if haveLock
then "First you must place ('"++pbdg++"') a lock to secure your solution behind, while at home ('"++hbdg++"')."
else "First design a lock in the editor ('"++ebdg++"'), behind which to secure your solution.")
- (\i -> isJust $ userLocks ourUInfo ! i)
+ (\i -> isJust $ userLocks ourUInfo ! i)
guard $ isJust $ userLocks ourUInfo ! 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.
- (Just AllCodenames)
+ (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.
+ (Just AllCodenames)
startMark = '^'
@@ -143,22 +143,22 @@ jumpMark :: UIMonad uiM => Char -> MainStateT uiM ()
jumpMark ch = do
mst <- get
void.runMaybeT $ case ms2im mst of
- IMEdit -> do
- st <- liftMaybe $ ch `Map.lookup` esMarks mst
- lift $ setMark True '\'' >> pushEState st
- IMPlay -> do
- mst' <- liftMaybe $ ch `Map.lookup` psMarks mst
- put mst' { psMarks = Map.insert '\'' mst $ psMarks mst }
- IMReplay -> do
- mst' <- liftMaybe $ ch `Map.lookup` rsMarks mst
- put mst' { rsMarks = Map.insert '\'' mst $ rsMarks mst }
- _ -> return ()
+ IMEdit -> do
+ st <- liftMaybe $ ch `Map.lookup` esMarks mst
+ lift $ setMark True '\'' >> pushEState st
+ IMPlay -> do
+ mst' <- liftMaybe $ ch `Map.lookup` psMarks mst
+ put mst' { psMarks = Map.insert '\'' mst $ psMarks mst }
+ IMReplay -> do
+ mst' <- liftMaybe $ ch `Map.lookup` rsMarks mst
+ put mst' { rsMarks = Map.insert '\'' mst $ rsMarks mst }
+ _ -> return ()
setMark :: (Monad m) => Bool -> Char -> MainStateT m ()
setMark overwrite ch = get >>= \mst -> case mst of
-- ugh... remind me why I'm not using lens?
EditState { esMarks = marks, esGameStateStack = (st:_) } ->
- put $ mst { esMarks = insertMark ch st marks }
+ put $ mst { esMarks = insertMark ch st marks }
PlayState {} -> put $ mst { psMarks = insertMark ch mst $ psMarks mst }
ReplayState {} -> put $ mst { rsMarks = insertMark ch mst $ rsMarks mst }
_ -> return ()
@@ -168,15 +168,15 @@ askLockIndex :: UIMonad uiM => [Char] -> String -> (Int -> Bool) -> MaybeT (Main
askLockIndex prompt failMessage pred = do
let ok = filter pred [0,1,2]
case length ok of
- 0 -> (lift.lift) (drawError failMessage) >> mzero
- 1 -> return $ head ok
- _ -> ask ok
+ 0 -> (lift.lift) (drawError failMessage) >> mzero
+ 1 -> return $ head ok
+ _ -> ask ok
where
- ask ok = do
- let prompt' = prompt ++ " [" ++ intersperse ',' (map lockIndexChar ok) ++ "]"
- idx <- MaybeT $ lift $ join . (((charLockIndex<$>).listToMaybe)<$>) <$>
- textInput prompt' 1 False True Nothing Nothing
- if idx `elem` ok then return idx else ask ok
+ ask ok = do
+ let prompt' = prompt ++ " [" ++ intersperse ',' (map lockIndexChar ok) ++ "]"
+ idx <- MaybeT $ lift $ join . (((charLockIndex<$>).listToMaybe)<$>) <$>
+ textInput prompt' 1 False True Nothing Nothing
+ if idx `elem` ok then return idx else ask ok
confirmOrBail :: UIMonad uiM => String -> MaybeT (MainStateT uiM) ()
confirmOrBail prompt = (guard =<<) $ lift.lift $ confirm prompt
confirm :: UIMonad uiM => String -> uiM Bool
@@ -185,72 +185,72 @@ confirm prompt = do
setYNButtons
waitConfirm <* endPrompt
where
- waitConfirm = do
- cmds <- getInput IMTextInput
- case msum $ map ansOfCmd cmds of
- Just answer -> return answer
- Nothing -> waitConfirm
- ansOfCmd (CmdInputChar 'y') = Just True
- ansOfCmd (CmdInputChar 'Y') = Just True
- ansOfCmd (CmdInputChar c) = if isPrint c then Just False else Nothing
- ansOfCmd CmdRedraw = Just False
- ansOfCmd CmdRefresh = Nothing
- ansOfCmd CmdUnselect = Nothing
- ansOfCmd _ = Just False
+ waitConfirm = do
+ cmds <- getInput IMTextInput
+ case msum $ map ansOfCmd cmds of
+ Just answer -> return answer
+ Nothing -> waitConfirm
+ ansOfCmd (CmdInputChar 'y') = Just True
+ ansOfCmd (CmdInputChar 'Y') = Just True
+ ansOfCmd (CmdInputChar c) = if isPrint c then Just False else Nothing
+ ansOfCmd CmdRedraw = Just False
+ ansOfCmd CmdRefresh = Nothing
+ ansOfCmd CmdUnselect = Nothing
+ ansOfCmd _ = Just False
-- | TODO: draw cursor
textInput :: UIMonad uiM => String -> Int -> Bool -> Bool -> Maybe [String] -> Maybe String -> uiM (Maybe String)
textInput prompt maxlen hidden endOnMax mposss init = getText (fromMaybe "" init, Nothing) <* endPrompt
where
- getText :: UIMonad uiM => (String, Maybe String) -> uiM (Maybe String)
- getText (s,mstem) = do
- drawPrompt (length s == maxlen) $ prompt ++ " " ++ if hidden then replicate (length s) '*' else s
- if endOnMax && isNothing mstem && maxlen <= length s
- then return $ Just $ take maxlen s
- else do
- cmds <- getInput IMTextInput
- case foldM applyCmd (s,mstem) cmds of
- Left False -> return Nothing
- Left True -> return $ Just s
- Right (s',mstem') -> getText (s',mstem')
- where
- applyCmd (s,mstem) (CmdInputChar c) = case c of
- '\ESC' -> Left False
- '\a' -> Left False -- ^G
- '\ETX' -> Left False -- ^C
- '\n' -> Left True
- '\r' -> Left True
- '\NAK' -> Right ("",Nothing) -- ^U
- '\b' -> Right $ (take (length s - 1) s, Nothing)
- '\DEL' -> Right $ (take (length s - 1) s, Nothing)
- '\t' -> case mposss of
- Nothing -> Right (s,mstem)
- Just possibilities -> case mstem of
- Nothing -> let
- completions = filter (completes s) possibilities
- pref = if null completions then s else
- let c = head completions
- in head [ c' | n <- reverse [0..length c],
- let c'=take n c, all (completes c') completions ]
- in Right (pref,Just pref)
- Just stem -> let
- completions = filter (completes stem) possibilities
- later = filter (>s) completions
- s' | null completions = s
- | null later = head completions
- | otherwise = minimum later
- in Right (s',mstem)
- _ -> Right $ if isPrint c
- then ((if length s >= maxlen then id else (++[c])) s, Nothing)
- else (s,mstem)
- applyCmd x (CmdInputSelLock idx) =
+ getText :: UIMonad uiM => (String, Maybe String) -> uiM (Maybe String)
+ getText (s,mstem) = do
+ drawPrompt (length s == maxlen) $ prompt ++ " " ++ if hidden then replicate (length s) '*' else s
+ if endOnMax && isNothing mstem && maxlen <= length s
+ then return $ Just $ take maxlen s
+ else do
+ cmds <- getInput IMTextInput
+ case foldM applyCmd (s,mstem) cmds of
+ Left False -> return Nothing
+ Left True -> return $ Just s
+ Right (s',mstem') -> getText (s',mstem')
+ where
+ applyCmd (s,mstem) (CmdInputChar c) = case c of
+ '\ESC' -> Left False
+ '\a' -> Left False -- ^G
+ '\ETX' -> Left False -- ^C
+ '\n' -> Left True
+ '\r' -> Left True
+ '\NAK' -> Right ("",Nothing) -- ^U
+ '\b' -> Right $ (take (length s - 1) s, Nothing)
+ '\DEL' -> Right $ (take (length s - 1) s, Nothing)
+ '\t' -> case mposss of
+ Nothing -> Right (s,mstem)
+ Just possibilities -> case mstem of
+ Nothing -> let
+ completions = filter (completes s) possibilities
+ pref = if null completions then s else
+ let c = head completions
+ in head [ c' | n <- reverse [0..length c],
+ let c'=take n c, all (completes c') completions ]
+ in Right (pref,Just pref)
+ Just stem -> let
+ completions = filter (completes stem) possibilities
+ later = filter (>s) completions
+ s' | null completions = s
+ | null later = head completions
+ | otherwise = minimum later
+ in Right (s',mstem)
+ _ -> Right $ if isPrint c
+ then ((if length s >= maxlen then id else (++[c])) s, Nothing)
+ else (s,mstem)
+ applyCmd x (CmdInputSelLock idx) =
setTextOrSubmit x $ [lockIndexChar idx]
- applyCmd x (CmdInputSelUndecl (Undeclared _ _ (ActiveLock name idx))) =
+ applyCmd x (CmdInputSelUndecl (Undeclared _ _ (ActiveLock name idx))) =
setTextOrSubmit x $ name++[':',lockIndexChar idx]
- applyCmd x (CmdInputCodename name) =
+ applyCmd x (CmdInputCodename name) =
setTextOrSubmit x $ name
- applyCmd x CmdRefresh = Right x
- applyCmd x CmdUnselect = Right x
- applyCmd _ _ = Left False
- completes s s' = take (length s) s' == s
+ applyCmd x CmdRefresh = Right x
+ applyCmd x CmdUnselect = Right x
+ applyCmd _ _ = Left False
+ completes s s' = take (length s) s' == s
setTextOrSubmit (s,_) t = if s == t then Left True else Right (t,Nothing)
diff --git a/Lock.hs b/Lock.hs
index b20da17..4ab29c9 100644
--- a/Lock.hs
+++ b/Lock.hs
@@ -50,8 +50,8 @@ type Solution = [PlayerMove]
checkSolution :: Lock -> Solution -> Bool
checkSolution lock pms =
let (frame,st) = reframe lock
- tick :: GameState -> PlayerMove -> GameState
- tick st pm = fst . runWriter $ physicsTick pm st
+ 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
@@ -63,12 +63,12 @@ canonify :: Lock -> Lock
canonify = addTools . stabilise . delTools . delOOB
delTools :: Lock -> Lock
delTools = liftLock delTools' where
- delTools' :: GameState -> GameState
- delTools' st =
- fromMaybe st $ listToMaybe
- [ delTools' $ delPiece idx st
- | (idx,pp) <- enumVec $ placedPieces st
- , isTool $ placedPiece pp ]
+ delTools' :: GameState -> GameState
+ delTools' 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
@@ -79,16 +79,16 @@ addTools (f,st) =
-- to being of natural length, and none get further from it.
stabilise :: Lock -> Lock
stabilise = liftLock stabilise' where
- stabilise' :: GameState -> GameState
- stabilise' st =
- let st' = stepPhysics st
- in if st == st' then st else stabilise' st'
+ 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) =
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]
+ [ delOOB $ liftLock (delPiece idx) l
+ | (idx,_) <- enumVec $ placedPieces st
+ , not $ isFrame idx
+ , all (not.inBounds f) $ fullFootprint st idx
+ , null $ springsEndAtIdx st idx]
diff --git a/MainState.hs b/MainState.hs
index ddea46a..aa18e06 100644
--- a/MainState.hs
+++ b/MainState.hs
@@ -72,65 +72,65 @@ class (Applicative m, MonadIO m) => UIMonad m where
doUI :: m a -> IO (Maybe a)
doUI m = runUI $ do
- ok <- initUI
- if ok then m >>= (endUI >>).return.Just else return Nothing
+ ok <- initUI
+ if ok then m >>= (endUI >>).return.Just else return Nothing
-- | this could be neatened using GADTs
data MainState
= PlayState
- { psCurrentState::GameState
- , psFrame::Frame
- , psLastAlerts::[Alert]
- , wrenchSelected::Bool
- , psSolved::Bool
- , psGameStateMoveStack::[(GameState, PlayerMove)]
- , psUndoneStack::[(GameState, PlayerMove)]
- , psTitle::Maybe String
- , psIsTut::Bool
- , psIsSub::Bool
- , psSaved::Bool
- , psMarks::Map Char MainState
- }
+ { psCurrentState::GameState
+ , psFrame::Frame
+ , psLastAlerts::[Alert]
+ , wrenchSelected::Bool
+ , psSolved::Bool
+ , psGameStateMoveStack::[(GameState, PlayerMove)]
+ , psUndoneStack::[(GameState, PlayerMove)]
+ , psTitle::Maybe String
+ , psIsTut::Bool
+ , psIsSub::Bool
+ , psSaved::Bool
+ , psMarks::Map Char MainState
+ }
| ReplayState
- { rsCurrentState::GameState
- , rsLastAlerts::[Alert]
- , rsMoveStack::[PlayerMove]
- , rsGameStateMoveStack::[(GameState, PlayerMove)]
- , rsTitle::Maybe String
- , rsMarks::Map Char MainState
- }
+ { rsCurrentState::GameState
+ , rsLastAlerts::[Alert]
+ , rsMoveStack::[PlayerMove]
+ , rsGameStateMoveStack::[(GameState, PlayerMove)]
+ , rsTitle::Maybe String
+ , rsMarks::Map Char MainState
+ }
| EditState
- { esGameStateStack::[GameState]
- , esUndoneStack::[GameState]
- , esFrame::Frame
- , esPath::Maybe FilePath
- , esTested::Maybe (GameState,Solution)
- , lastSavedState::Maybe (GameState, Bool)
- , selectedPiece::Maybe PieceIdx
- , selectedPos::HexPos
- , lastModPos::HexPos
- , esMarks::Map Char GameState
- }
+ { esGameStateStack::[GameState]
+ , esUndoneStack::[GameState]
+ , esFrame::Frame
+ , esPath::Maybe FilePath
+ , esTested::Maybe (GameState,Solution)
+ , lastSavedState::Maybe (GameState, Bool)
+ , selectedPiece::Maybe PieceIdx
+ , selectedPos::HexPos
+ , lastModPos::HexPos
+ , esMarks::Map Char GameState
+ }
| MetaState
- { curServer :: ServerAddr
- , undeclareds :: [Undeclared]
- , partialSolutions :: PartialSolutions
- , tutProgress :: TutProgress
- , cacheOnly :: Bool
- , curAuth :: Maybe Auth
- , codenameStack :: [Codename]
- , newAsync :: TVar Bool
- , asyncCount :: TVar Int
- , asyncError :: TVar (Maybe String)
- , asyncInvalidate :: TVar (Maybe Codenames)
- , randomCodenames :: TVar [Codename]
- , userInfoTVs :: Map Codename (TVar FetchedRecord, UTCTime)
- , indexedLocks :: Map LockSpec (TVar FetchedRecord)
- , retiredLocks :: Maybe [LockSpec]
- , curLockPath :: FilePath
- , curLock :: Maybe (Lock,Maybe Solution)
- , listOffset :: Int
- }
+ { curServer :: ServerAddr
+ , undeclareds :: [Undeclared]
+ , partialSolutions :: PartialSolutions
+ , tutProgress :: TutProgress
+ , cacheOnly :: Bool
+ , curAuth :: Maybe Auth
+ , codenameStack :: [Codename]
+ , newAsync :: TVar Bool
+ , asyncCount :: TVar Int
+ , asyncError :: TVar (Maybe String)
+ , asyncInvalidate :: TVar (Maybe Codenames)
+ , randomCodenames :: TVar [Codename]
+ , userInfoTVs :: Map Codename (TVar FetchedRecord, UTCTime)
+ , indexedLocks :: Map LockSpec (TVar FetchedRecord)
+ , retiredLocks :: Maybe [LockSpec]
+ , curLockPath :: FilePath
+ , curLock :: Maybe (Lock,Maybe Solution)
+ , listOffset :: Int
+ }
type MainStateT = StateT MainState
@@ -155,7 +155,7 @@ initMetaState = do
rnamestvar <- atomically $ newTVar []
counttvar <- atomically $ newTVar 0
(saddr', auth, path) <- confFilePath "metagame.conf" >>=
- liftM (fromMaybe (defaultServerAddr, Nothing, "")) . readReadFile
+ liftM (fromMaybe (defaultServerAddr, Nothing, "")) . readReadFile
let saddr = updateDefaultSAddr saddr'
let names = maybeToList $ authUser <$> auth
(undecls,partials,tut) <- readServerSolns saddr
@@ -175,20 +175,20 @@ restorePlayState :: SavedPlayState -> Lock -> (Maybe String) -> Bool -> Bool ->
restorePlayState (SavedPlayState pms markPMs) (frame,st) title isTut sub saved =
(stateAfterMoves pms) { psMarks = Map.map stateAfterMoves markPMs }
where
- stateAfterMoves pms = let (stack,st') = applyMoves st pms
- in (newPlayState (frame, st') title isTut sub saved) { psGameStateMoveStack = stack }
- applyMoves st pms = foldl tick ([],st) pms
- tick :: ([(GameState,PlayerMove)],GameState) -> PlayerMove -> ([(GameState,PlayerMove)],GameState)
- tick (stack,st) pm = ((st,pm):stack,fst . runWriter $ physicsTick pm st)
+ stateAfterMoves pms = let (stack,st') = applyMoves st pms
+ in (newPlayState (frame, st') title isTut sub saved) { psGameStateMoveStack = stack }
+ applyMoves st pms = foldl tick ([],st) pms
+ tick :: ([(GameState,PlayerMove)],GameState) -> PlayerMove -> ([(GameState,PlayerMove)],GameState)
+ tick (stack,st) pm = ((st,pm):stack,fst . runWriter $ physicsTick pm st)
readServerSolns :: ServerAddr -> IO ([Undeclared],PartialSolutions,TutProgress)
readServerSolns saddr = if nullSaddr saddr then return ([],Map.empty,(1,Nothing)) else do
undecls <- confFilePath ("undeclared" ++ [pathSeparator] ++ saddrPath saddr) >>=
- liftM (fromMaybe []) . readReadFile
+ liftM (fromMaybe []) . readReadFile
partials <- confFilePath ("partialSolutions" ++ [pathSeparator] ++ saddrPath saddr) >>=
- liftM (fromMaybe Map.empty) . readReadFile
+ liftM (fromMaybe Map.empty) . readReadFile
tut <- confFilePath "tutProgress" >>=
- liftM (fromMaybe (1,Nothing)) . readReadFile
+ liftM (fromMaybe (1,Nothing)) . readReadFile
return (undecls,partials,tut)
writeServerSolns saddr ms@(MetaState { undeclareds=undecls,
@@ -199,11 +199,11 @@ partialSolutions=partials, tutProgress=tut }) = unless (nullSaddr saddr) $ do
readLock :: FilePath -> IO (Maybe (Lock, Maybe Solution))
readLock path = runMaybeT $ msum
- [ (\l->(l,Nothing)) <$> (MaybeT $ readReadFile path)
- , do
- (mlock,msoln) <- lift $ readAsciiLockFile path
- lock <- liftMaybe mlock
- return $ (lock,msoln) ]
+ [ (\l->(l,Nothing)) <$> (MaybeT $ readReadFile path)
+ , do
+ (mlock,msoln) <- lift $ readAsciiLockFile path
+ lock <- liftMaybe mlock
+ return $ (lock,msoln) ]
-- writeLock :: FilePath -> Lock -> IO ()
-- writeLock path lock = fullLockPath path >>= flip writeReadFile lock
@@ -214,12 +214,12 @@ writeMetaState ms@(MetaState { curServer=saddr, curAuth=auth, curLockPath=path }
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 ++
- (if isTested then " (Tested)" else "") ++
- (if unsaved then " [+]" else " ")
+ mpath <- gets esPath
+ unsaved <- editStateUnsaved
+ isTested <- isJust <$> getCurTestSoln
+ return $ Just $ "editing " ++ fromMaybe "[unnamed lock]" mpath ++
+ (if isTested then " (Tested)" else "") ++
+ (if unsaved then " [+]" else " ")
IMPlay -> gets psTitle
IMReplay -> gets rsTitle
_ -> return Nothing
@@ -248,16 +248,16 @@ getUInfoFetched :: UIMonad uiM => Integer -> Codename -> MainStateT uiM FetchedR
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
+ 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
+ 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 (MainStateT uiM) UserInfo
mgetUInfo name = do
@@ -284,10 +284,10 @@ 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
- , lift $ do
- tvar <- getRecordCachedFromCur True $ RecLock ls
- modify $ \ms -> ms { indexedLocks = Map.insert ls tvar $ indexedLocks ms }
- return tvar ]
+ , lift $ do
+ tvar <- getRecordCachedFromCur True $ RecLock ls
+ modify $ \ms -> ms { indexedLocks = Map.insert ls tvar $ indexedLocks ms }
+ return tvar ]
RCLock lock <- MaybeT $ (fetchedRC<$>) $ liftIO $ atomically $ readTVar tvar
return $ reframe lock
@@ -302,19 +302,19 @@ refreshUInfoUI = void.runMaybeT $ do
lift $ modify $ \ms -> ms {retiredLocks = Nothing}
--lift.lift $ drawMessage ""
where
- getRandomNames = do
- rnamestvar <- gets randomCodenames
- liftIO $ atomically $ writeTVar rnamestvar []
- flag <- gets newAsync
- saddr <- gets curServer
- void $ liftIO $ forkIO $ do
- resp <- makeRequest saddr $
- ClientRequest protocolVersion Nothing $ GetRandomNames 19
- case resp of
- ServedRandomNames names -> atomically $ do
- writeTVar rnamestvar names
- writeTVar flag True
- _ -> return ()
+ getRandomNames = do
+ rnamestvar <- gets randomCodenames
+ liftIO $ atomically $ writeTVar rnamestvar []
+ flag <- gets newAsync
+ saddr <- gets curServer
+ void $ liftIO $ forkIO $ do
+ resp <- makeRequest saddr $
+ ClientRequest protocolVersion Nothing $ GetRandomNames 19
+ case resp of
+ ServedRandomNames names -> atomically $ do
+ writeTVar rnamestvar names
+ writeTVar flag True
+ _ -> return ()
mourNameSelected :: (UIMonad uiM) => MaybeT (MainStateT uiM) Bool
mourNameSelected = liftM2 (==) mgetCurName mgetOurName
@@ -324,15 +324,15 @@ purgeInvalidUndecls = do
undecls' <- gets undeclareds >>= filterM ((not<$>).invalid)
modify $ \ms -> ms { undeclareds = undecls' }
where
- invalid (Undeclared _ ls (ActiveLock name idx)) =
- (fromMaybe False <$>) $ runMaybeT $ do
- uinfo <- mgetUInfo name
- ourName <- mgetOurName
- (`mplus` return True) $ do
- linfo <- liftMaybe $ userLocks uinfo ! idx
- return $ public linfo
- || ourName `elem` accessedBy linfo
- || lockSpec linfo /= ls
+ invalid (Undeclared _ ls (ActiveLock name idx)) =
+ (fromMaybe False <$>) $ runMaybeT $ do
+ uinfo <- mgetUInfo name
+ ourName <- mgetOurName
+ (`mplus` return True) $ do
+ linfo <- liftMaybe $ userLocks uinfo ! idx
+ return $ public linfo
+ || ourName `elem` accessedBy linfo
+ || lockSpec linfo /= ls
curServerAction :: UIMonad uiM => Protocol.Action -> MainStateT uiM ServerResponse
@@ -341,8 +341,8 @@ curServerAction act = do
auth <- gets curAuth
cOnly <- gets cacheOnly
if cOnly then return $ ServerError "Can't contact server in cache-only mode"
- else (fromMaybe (ServerError "Request aborted") <$>) $
- lift $ withImpatience $ makeRequest saddr $ ClientRequest protocolVersion auth act
+ else (fromMaybe (ServerError "Request aborted") <$>) $
+ lift $ withImpatience $ makeRequest saddr $ ClientRequest protocolVersion auth act
curServerActionAsyncThenInvalidate :: UIMonad uiM => Protocol.Action -> Maybe Codenames -> MainStateT uiM ()
curServerActionAsyncThenInvalidate act names = do
@@ -354,27 +354,27 @@ curServerActionAsyncThenInvalidate act names = do
invaltvar <- gets asyncInvalidate
cOnly <- gets cacheOnly
void $ liftIO $ forkIO $ do
- atomically $ modifyTVar count (+1)
- 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
- _ -> atomically $ writeTVar invaltvar names
- atomically $ writeTVar flag True
- atomically $ modifyTVar count (+(-1))
+ atomically $ modifyTVar count (+1)
+ 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
+ _ -> atomically $ writeTVar invaltvar names
+ atomically $ writeTVar flag True
+ atomically $ modifyTVar count (+(-1))
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
+ 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
+ invaltvar <- lift $ gets asyncInvalidate
+ names <- MaybeT $ liftIO $ atomically $
+ readTVar invaltvar <* writeTVar invaltvar Nothing
+ lift $ invalidateUInfos names >> refreshUInfoUI
getRecordCachedFromCur :: UIMonad uiM => Bool -> Record -> MainStateT uiM (TVar FetchedRecord)
getRecordCachedFromCur flagIt rec = do
@@ -383,22 +383,22 @@ getRecordCachedFromCur flagIt rec = do
cOnly <- gets cacheOnly
flag <- gets newAsync
liftIO $ getRecordCached saddr auth
- (if flagIt then Just flag else Nothing) cOnly rec
+ (if flagIt then Just flag else Nothing) cOnly rec
getFreshRecBlocking :: UIMonad uiM => Record -> MainStateT uiM (Maybe RecordContents)
getFreshRecBlocking rec = do
tvar <- getRecordCachedFromCur False rec
cOnly <- gets cacheOnly
mfetched <- lift $ withImpatience $ atomically $ do
- fetched@(FetchedRecord fresh _ _) <- readTVar tvar
- check $ fresh || cOnly
- return fetched
+ fetched@(FetchedRecord fresh _ _) <- readTVar tvar
+ check $ fresh || cOnly
+ return fetched
case mfetched of
- Nothing -> lift (drawError "Request aborted") >> return Nothing
- Just fetched ->
- case fetchError fetched of
- Nothing -> return $ fetchedRC fetched
- Just err -> lift (drawError err) >> return Nothing
+ Nothing -> lift (drawError "Request aborted") >> return Nothing
+ Just fetched ->
+ case fetchError fetched of
+ Nothing -> return $ fetchedRC fetched
+ Just err -> lift (drawError err) >> return Nothing
-- |indicate waiting for server, and allow cancellation
withImpatience :: UIMonad uiM => IO a -> uiM (Maybe a)
@@ -406,14 +406,14 @@ withImpatience m = do
finishedTV <- liftIO $ atomically $ newTVar Nothing
id <- liftIO $ forkIO $ m >>= atomically . writeTVar finishedTV . Just
let waitImpatiently ticks = do
- finished <- liftIO $ atomically $ readTVar finishedTV
- if isJust finished
- then return finished
- else do
- abort <- impatience ticks
- if abort
- then liftIO $ killThread id >> return Nothing
- else waitImpatiently $ ticks+1
+ finished <- liftIO $ atomically $ readTVar finishedTV
+ if isJust finished
+ then return finished
+ else do
+ abort <- impatience ticks
+ if abort
+ then liftIO $ killThread id >> return Nothing
+ else waitImpatiently $ ticks+1
waitImpatiently 0
@@ -427,7 +427,7 @@ getRelScoreDetails name = runMaybeT $ do
let (neg,pos) = (countPoints ourUInfo uinfo, countPoints uinfo ourUInfo)
return $ (pos-neg,(pos,neg))
where
- countPoints mugu masta = length $ filter (maybe False winsPoint) $ getAccessInfo mugu masta
+ countPoints mugu masta = length $ filter (maybe False winsPoint) $ getAccessInfo mugu masta
accessedAL :: (UIMonad uiM) => ActiveLock -> MainStateT uiM Bool
accessedAL (ActiveLock name idx) = (isJust <$>) $ runMaybeT $ do
@@ -442,17 +442,17 @@ getNotesReadOn lockinfo = (fromMaybe [] <$>) $ runMaybeT $ do
ourName <- mgetOurName
ourUInfo <- mgetUInfo ourName
return $ filter (\n -> isNothing (noteBehind n)
- || n `elem` notesRead ourUInfo) $ lockSolutions lockinfo
+ || n `elem` notesRead ourUInfo) $ lockSolutions lockinfo
testAuth :: UIMonad uiM => MainStateT uiM ()
testAuth = isJust <$> gets curAuth >>? do
resp <- curServerAction $ Authenticate
case resp of
- ServerMessage msg -> (lift $ drawMessage $ "Server: " ++ msg)
- ServerError err -> do
- lift $ drawMessage err
- modify $ \ms -> ms {curAuth = Nothing}
- _ -> return ()
+ ServerMessage msg -> (lift $ drawMessage $ "Server: " ++ msg)
+ ServerError err -> do
+ lift $ drawMessage err
+ modify $ \ms -> ms {curAuth = Nothing}
+ _ -> return ()
metagameHelpText :: [String]
metagameHelpText =
diff --git a/Metagame.hs b/Metagame.hs
index 79cedac..de0b35f 100644
--- a/Metagame.hs
+++ b/Metagame.hs
@@ -54,27 +54,27 @@ winsPoint _ = True
getAccessInfo :: UserInfo -> UserInfo -> [Maybe AccessedReason]
getAccessInfo accessedUInfo accessorUInfo =
let accessor = codename accessorUInfo
- mlinfos = elems $ userLocks accessedUInfo
- accessedSlot = maybe accessedAllExisting accessedLock
- accessedAllExisting = all (maybe True accessedLock) mlinfos
- accessedLock linfo = public linfo || accessor `elem` accessedBy linfo
+ mlinfos = elems $ userLocks accessedUInfo
+ accessedSlot = maybe accessedAllExisting accessedLock
+ accessedAllExisting = all (maybe True accessedLock) mlinfos
+ accessedLock linfo = public linfo || accessor `elem` accessedBy linfo
in map (maybe
- (if accessedAllExisting then Just AccessedEmpty else Nothing)
- (\linfo -> if public linfo then Just AccessedPub else
- if not $ accessedLock linfo then Nothing else Just $
- if countRead accessorUInfo linfo >= notesNeeded then AccessedPrivyRead
- else AccessedPrivySolved $ not.null $
- [ n
- | n <- lockSolutions linfo
- , noteAuthor n == accessor
- , noteBehind n == Nothing || n `elem` notesRead accessedUInfo ]))
- mlinfos
+ (if accessedAllExisting then Just AccessedEmpty else Nothing)
+ (\linfo -> if public linfo then Just AccessedPub else
+ if not $ accessedLock linfo then Nothing else Just $
+ if countRead accessorUInfo linfo >= notesNeeded then AccessedPrivyRead
+ else AccessedPrivySolved $ not.null $
+ [ n
+ | n <- lockSolutions linfo
+ , noteAuthor n == accessor
+ , noteBehind n == Nothing || n `elem` notesRead accessedUInfo ]))
+ mlinfos
countRead :: UserInfo -> LockInfo -> Int
countRead reader tlock = fromIntegral $ length
- $ filter (\n -> (isNothing (noteBehind n) || n `elem` notesRead reader)
- && noteAuthor n /= codename reader)
- $ lockSolutions tlock
+ $ filter (\n -> (isNothing (noteBehind n) || n `elem` notesRead reader)
+ && noteAuthor n /= codename reader)
+ $ lockSolutions tlock
data UserInfoDelta
= AddRead NoteInfo
@@ -138,12 +138,12 @@ instance Binary UserInfoDelta where
put (PutLock ls li) = put (2::Word8) >> put ls >> put li
put (LockDelta li ld) = put (3::Word8) >> put li >> put ld
get = do
- tag <- get :: Get Word8
- case tag of
- 0 -> AddRead <$> get
- 1 -> DelRead <$> get
- 2 -> PutLock <$> get <*> get
- 3 -> LockDelta <$> get <*> get
+ tag <- get :: Get Word8
+ case tag of
+ 0 -> AddRead <$> get
+ 1 -> DelRead <$> get
+ 2 -> PutLock <$> get <*> get
+ 3 -> LockDelta <$> get <*> get
instance Binary LockDelta where
put (SetPubNote note) = put (0::Word8) >> put note
@@ -153,14 +153,14 @@ instance Binary LockDelta where
put (AddAccessed name) = put (4::Word8) >> put name
put SetPublic = put (5::Word8)
get = do
- tag <- get :: Get Word8
- case tag of
- 0 -> SetPubNote <$> get
- 1 -> AddSecured <$> get
- 2 -> DelSecured <$> get
- 3 -> AddSolution <$> get
- 4 -> AddAccessed <$> get
- 5 -> return SetPublic
+ tag <- get :: Get Word8
+ case tag of
+ 0 -> SetPubNote <$> get
+ 1 -> AddSecured <$> get
+ 2 -> DelSecured <$> get
+ 3 -> AddSolution <$> get
+ 4 -> AddAccessed <$> get
+ 5 -> return SetPublic
instance Binary LockInfo where
put (LockInfo spec pk notes solved accessed) = put spec >> put pk >> put notes >> put solved >> put accessed
diff --git a/Mundanities.hs b/Mundanities.hs
index 64b9ff9..f172f0f 100644
--- a/Mundanities.hs
+++ b/Mundanities.hs
@@ -33,7 +33,7 @@ catchAll = E.catch
readReadFile :: (Read a) => FilePath -> IO (Maybe a)
readReadFile file =
(tryRead . BSC.unpack <$> BS.readFile file)
- `catchIO` (const $ return Nothing)
+ `catchIO` (const $ return Nothing)
tryRead :: (Read a) => String -> Maybe a
tryRead = (fst <$>) . listToMaybe . reads
diff --git a/NEWS b/NEWS
index 83b5586..ff15ba2 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,8 @@
This is an abbreviated summary; see the git log for gory details.
+0.7.1.1:
+ Make server compatible with feed-1.0.0
+ Avoid DOS-reserved codenames
0.7.1:
Rework tutorial and intro.
Animate movement.
diff --git a/Physics.hs b/Physics.hs
index 1ab703c..3e534d7 100644
--- a/Physics.hs
+++ b/Physics.hs
@@ -31,7 +31,7 @@ type ForceChoices = Vector.Vector ForceChoice
forceIdx :: Force -> PieceIdx
forceIdx force = case force of (Push idx _) -> idx
- (Torque idx _) -> idx
+ (Torque idx _) -> idx
isPush,isTorque,forceIsNull :: Force -> Bool
isPush (Push _ _) = True
@@ -55,12 +55,12 @@ toolForces st pm = Vector.fromList $
, let wmove = case pm of {WrenchPush v -> [Push widx v]; _ -> []}
, not $ null (wmom++wmove)
] ++ case pm of
- HookTorque ht -> [ ForceChoice [Torque hidx ht] | hidx <- hidxs ]
- HookPush hp -> [ ForceChoice [Push hidx hp] | hidx <- hidxs ]
- _ -> []
+ HookTorque ht -> [ ForceChoice [Torque hidx ht] | hidx <- hidxs ]
+ HookPush hp -> [ ForceChoice [Push hidx hp] | hidx <- hidxs ]
+ _ -> []
where
- epps = enumVec $ placedPieces st
- hidxs = [ hidx | (hidx, PlacedPiece _ (Hook _ _)) <- epps ]
+ epps = enumVec $ placedPieces st
+ hidxs = [ hidx | (hidx, PlacedPiece _ (Hook _ _)) <- epps ]
-- |Dominance: a propagand of a source force F can not block any progagand of
-- a source force which dominates F.
@@ -73,36 +73,36 @@ type Dominance = Int -> Int -> Bool
envForces :: GameState -> (ForceChoices, Dominance)
envForces st@(GameState _ conns) =
let rootedForces :: Vector (Maybe PieceIdx, Force)
- rootedForces = Vector.fromList [ (Just rootIdx, Push endIdx dir)
- | c@(Connection (rootIdx,_) (endIdx,_) (Spring outDir natLen)) <- conns
- , let curLen = connectionLength st c
- , natLen /= curLen
- , let dir = if natLen > curLen then outDir else neg outDir ]
+ rootedForces = Vector.fromList [ (Just rootIdx, Push endIdx dir)
+ | c@(Connection (rootIdx,_) (endIdx,_) (Spring outDir natLen)) <- conns
+ , let curLen = connectionLength st c
+ , natLen /= curLen
+ , let dir = if natLen > curLen then outDir else neg outDir ]
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 )
+ \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
- HookTorque dir -> TorqueHF dir
- HookPush v -> PushHF v
- _ -> NullHF
+ HookTorque dir -> TorqueHF dir
+ HookPush v -> PushHF v
+ _ -> NullHF
in adjustPieces (\p -> case p of
- Hook arm _ -> Hook arm hf
- _ -> p) st
+ Hook arm _ -> Hook arm hf
+ _ -> p) st
physicsTick :: PlayerMove -> GameState -> Writer [Alert] GameState
physicsTick pm st =
let tfs = toolForces st pm
- (efs, dominates) = envForces st
+ (efs, dominates) = envForces st
in do
- st' <- resolveForces tfs Vector.empty (\_ _->False) $ setTools pm st
- tell $ [AlertIntermediateState st']
- resolveForces Vector.empty efs dominates $ setTools NullPM st'
+ st' <- resolveForces tfs Vector.empty (\_ _->False) $ setTools pm st
+ tell $ [AlertIntermediateState st']
+ resolveForces Vector.empty efs dominates $ setTools NullPM st'
stepPhysics :: GameState -> GameState
stepPhysics = fst.runWriter.physicsTick NullPM
@@ -113,61 +113,61 @@ data SourcedForce = SForce Source Force Bool Bool
resolveForces :: ForceChoices -> ForceChoices -> Dominance -> GameState -> Writer [Alert] GameState
resolveForces plForces eForces eDominates st =
let pln = Vector.length plForces
- dominates i j = case map (< pln) [i,j] of
- [True,False] -> True
- [False,False] -> eDominates (i-pln) (j-pln)
- _ -> False
- initGrps = fmap (propagate st True) plForces Vector.++
- 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 =
- let st' = foldr applyForce st $ nub $ concat fss
- (inconsistencies,cols) = runWriter $ sequence
- [ tell cols >> return [f,f']
- | [f,f'] <- sequence fss
- , (True,cols) <- [
- if forceIdx f == forceIdx f'
- then (f /= f',[])
- else let cols = collisions st' (forceIdx f) (forceIdx f')
- in (not $ null cols, cols) ]]
- in do
- tell $ map AlertBlockingForce $ concat inconsistencies
- tell $ map AlertCollision cols
- return $ if null inconsistencies then []
- else if i==j then [i]
- else if dominates i j then [j]
- else if dominates j i then [i]
- else [i,j]
+ dominates i j = case map (< pln) [i,j] of
+ [True,False] -> True
+ [False,False] -> eDominates (i-pln) (j-pln)
+ _ -> False
+ initGrps = fmap (propagate st True) plForces Vector.++
+ 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 =
+ let st' = foldr applyForce st $ nub $ concat fss
+ (inconsistencies,cols) = runWriter $ sequence
+ [ tell cols >> return [f,f']
+ | [f,f'] <- sequence fss
+ , (True,cols) <- [
+ if forceIdx f == forceIdx f'
+ then (f /= f',[])
+ else let cols = collisions st' (forceIdx f) (forceIdx f')
+ in (not $ null cols, cols) ]]
+ in do
+ tell $ map AlertBlockingForce $ concat inconsistencies
+ tell $ map AlertCollision cols
+ return $ if null inconsistencies then []
+ else if i==j then [i]
+ else if dominates i j then [j]
+ else if dominates j i then [i]
+ else [i,j]
- stopWrench idx = setPiece idx (Wrench zero)
- stopBlockedWrenches blocked unblocked st' = foldr stopWrench st' $
+ stopWrench idx = setPiece idx (Wrench zero)
+ stopBlockedWrenches blocked unblocked st' = foldr stopWrench st' $
forcedWrenches blocked \\ forcedWrenches unblocked
where forcedWrenches fs = [ forceIdx f
| f <- fs, isWrench.placedPiece $ getForcedpp st' f ]
- divertedWrenches fs = [ idx
- | Push idx dir <- fs
- , Wrench mom <- [placedPiece $ getpp st idx]
- , mom `notElem` [zero,dir] ]
+ divertedWrenches fs = [ idx
+ | Push idx dir <- fs
+ , Wrench mom <- [placedPiece $ getpp st idx]
+ , mom `notElem` [zero,dir] ]
in do
- let unresisted = [ s | (s, (_, Any False)) <- enumVec $ fmap runWriter initGrps ]
+ let unresisted = [ s | (s, (_, Any False)) <- enumVec $ fmap runWriter initGrps ]
- -- check for inconsistencies within, and between pairs of, forcegroups
- grps <- sequence [ blockInconsistent i j
- | [i,j] <- sequence [unresisted,unresisted]
- , i <= j ]
- `execStateT` initGrps
+ -- check for inconsistencies within, and between pairs of, forcegroups
+ grps <- sequence [ blockInconsistent i j
+ | [i,j] <- sequence [unresisted,unresisted]
+ , i <= j ]
+ `execStateT` initGrps
- let [blocked, unblocked] = map (nub.concat.(map (fst.runWriter)).Vector.toList) $
- (\(x,y) -> [x,y]) $ Vector.partition (getAny.snd.runWriter) grps
- tell $ map AlertBlockedForce blocked
- tell $ map AlertAppliedForce unblocked
- tell $ map AlertDivertedWrench $ divertedWrenches unblocked
- return $ stopBlockedWrenches blocked unblocked $ foldr applyForce st unblocked
+ let [blocked, unblocked] = map (nub.concat.(map (fst.runWriter)).Vector.toList) $
+ (\(x,y) -> [x,y]) $ Vector.partition (getAny.snd.runWriter) grps
+ tell $ map AlertBlockedForce blocked
+ tell $ map AlertAppliedForce unblocked
+ tell $ map AlertDivertedWrench $ divertedWrenches unblocked
+ return $ stopBlockedWrenches blocked unblocked $ foldr applyForce st unblocked
resolveSinglePlForce :: Force -> GameState -> Writer [Alert] GameState
resolveSinglePlForce force st = resolveForces
@@ -177,12 +177,12 @@ resolveSinglePlForce force st = resolveForces
applyForce :: Force -> GameState -> GameState
applyForce f s =
let idx = forceIdx f
- pp' = applyForceTo (getpp s idx) f
- pp'' = case (placedPiece pp',f) of
- ( Wrench _ , Push _ dir ) -> pp' {placedPiece = Wrench dir}
- _ -> pp'
- in
- s { placedPieces = (placedPieces s) // [(idx, pp'')] }
+ pp' = applyForceTo (getpp s idx) f
+ pp'' = case (placedPiece pp',f) of
+ ( Wrench _ , Push _ dir ) -> pp' {placedPiece = Wrench dir}
+ _ -> pp'
+ in
+ s { placedPieces = (placedPieces s) // [(idx, pp'')] }
collisionsWithForce :: GameState -> Force -> PieceIdx -> [HexPos]
collisionsWithForce st (Push idx dir) idx' =
@@ -203,35 +203,35 @@ applyForceTo pp _ = pp
pieceResists :: GameState -> Force -> Bool
pieceResists st force =
let idx = forceIdx force
- PlacedPiece _ piece = getpp st idx
+ PlacedPiece _ piece = getpp st idx
springs = springsEndAtIdx st idx
- fixed = case piece of
- (Pivot _) -> isPush force
- (Block _) -> null springs
- (Wrench mom) -> case force of
- Push _ v -> v /= mom
- _ -> True
- (Hook _ hf) -> case force of
- Push _ v -> hf /= PushHF v
- Torque _ dir -> hf /= TorqueHF dir
- _ -> False
+ fixed = case piece of
+ (Pivot _) -> isPush force
+ (Block _) -> null springs
+ (Wrench mom) -> case force of
+ Push _ v -> v /= mom
+ _ -> True
+ (Hook _ hf) -> case force of
+ Push _ v -> hf /= PushHF v
+ Torque _ dir -> hf /= TorqueHF dir
+ _ -> False
in fixed
-- |transmittedForce: convert pushes into torques as appropriate
transmittedForce :: GameState -> Source -> HexPos -> HexDir -> Force
transmittedForce st idx cpos dir =
let pp@(PlacedPiece _ piece) = getpp st idx
- rpos = cpos -^ placedPos pp
- armPush = case
- (dir `hexDot` ((rotate 1 rpos) -^ rpos)) `compare`
- (dir `hexDot` ((rotate (-1) rpos) -^ rpos)) of
- GT -> Torque idx 1
- LT -> Torque idx $ -1
- EQ -> Push idx dir
+ rpos = cpos -^ placedPos pp
+ armPush = case
+ (dir `hexDot` ((rotate 1 rpos) -^ rpos)) `compare`
+ (dir `hexDot` ((rotate (-1) rpos) -^ rpos)) of
+ GT -> Torque idx 1
+ LT -> Torque idx $ -1
+ EQ -> Push idx dir
in case piece of
- Pivot _ -> armPush
- Hook _ (TorqueHF _) -> armPush
- _ -> (Push idx dir)
+ Pivot _ -> armPush
+ Hook _ (TorqueHF _) -> armPush
+ _ -> (Push idx dir)
-- |propagateForce: return forces a force causes via bumps and fully
-- compressed/extended springs
@@ -239,31 +239,31 @@ propagateForce :: GameState -> Bool -> Force -> [ForceChoice]
propagateForce st@(GameState _ conns) isPlSource force =
bumps ++ springTransmissions
where
- idx = forceIdx force
- bumps = [ ForceChoice $ map (transmittedForce st idx' cpos) dirs |
- idx' <- ppidxs st
- , idx' /= idx
- , cpos <- collisionsWithForce st force idx'
- , let dirs = case force of
- Push _ dir -> [dir]
- Torque _ dir -> [push,claw]
- where push = arm -^ rotate (-dir) arm
- claw = rotate dir arm -^ arm
- arm = cpos -^ placedPos (getpp st idx) ]
- springTransmissions =
- case force of
- Push _ dir -> [ ForceChoice [Push idx' dir] |
- c@(Connection (ridx,_) (eidx,_) (Spring sdir _)) <- conns
- , let root = idx == ridx
- , let end = idx == eidx
- , root || end
- , let idx' = if root then eidx else ridx
- , let pull = (root && dir == neg sdir) || (end && dir == sdir)
- , let push = (root && dir == sdir) || (end && dir == neg sdir)
- , (push && if isPlSource then springFullyCompressed st c else not $ springExtended st c) ||
- (pull && if isPlSource then springFullyExtended st c else not $ springCompressed st c) ||
- (not push && not pull) ]
- _ -> []
+ idx = forceIdx force
+ bumps = [ ForceChoice $ map (transmittedForce st idx' cpos) dirs |
+ idx' <- ppidxs st
+ , idx' /= idx
+ , cpos <- collisionsWithForce st force idx'
+ , let dirs = case force of
+ Push _ dir -> [dir]
+ Torque _ dir -> [push,claw]
+ where push = arm -^ rotate (-dir) arm
+ claw = rotate dir arm -^ arm
+ arm = cpos -^ placedPos (getpp st idx) ]
+ springTransmissions =
+ case force of
+ Push _ dir -> [ ForceChoice [Push idx' dir] |
+ c@(Connection (ridx,_) (eidx,_) (Spring sdir _)) <- conns
+ , let root = idx == ridx
+ , let end = idx == eidx
+ , root || end
+ , let idx' = if root then eidx else ridx
+ , let pull = (root && dir == neg sdir) || (end && dir == sdir)
+ , let push = (root && dir == sdir) || (end && dir == neg sdir)
+ , (push && if isPlSource then springFullyCompressed st c else not $ springExtended st c) ||
+ (pull && if isPlSource then springFullyExtended st c else not $ springCompressed st c) ||
+ (not push && not pull) ]
+ _ -> []
-- |propagate: find forcegroup generated by a forcechoice, and note if the
-- group is blocked due to resistance. If there are multiple forces in a
@@ -272,17 +272,17 @@ propagateForce st@(GameState _ conns) isPlSource force =
propagate :: GameState -> Bool -> ForceChoice -> Writer Any [Force]
propagate st isPlSource fch = Set.toList `liftM` propagate' isPlSource Set.empty fch where
propagate' isPlForce ps (ForceChoice (f:backups)) =
- if f `Set.member` ps then return ps
- else
- let (ps', failed) = if pieceResists st f && (not isPlForce)
- then (ps, Any True)
- else runWriter $ foldrM
- (flip $ propagate' False)
- (f `Set.insert` ps)
- $ propagateForce st isPlSource f
- in if getAny failed
- then if null backups
- then tell (Any True) >> return ps'
- else propagate' isPlForce ps $ ForceChoice backups
- else return ps'
+ if f `Set.member` ps then return ps
+ else
+ let (ps', failed) = if pieceResists st f && (not isPlForce)
+ then (ps, Any True)
+ else runWriter $ foldrM
+ (flip $ propagate' False)
+ (f `Set.insert` ps)
+ $ propagateForce st isPlSource f
+ in if getAny failed
+ then if null backups
+ then tell (Any True) >> return ps'
+ else propagate' isPlForce ps $ ForceChoice backups
+ else return ps'
propagate' _ _ (ForceChoice []) = error "null ForceChoice"
diff --git a/Protocol.hs b/Protocol.hs
index c57a85f..4aebf01 100644
--- a/Protocol.hs
+++ b/Protocol.hs
@@ -100,22 +100,22 @@ instance Binary Action where
put (SetEmail address) = put (12::Word8) >> put address
put GetPublicKey = put (13::Word8)
get = do
- tag <- get :: Get Word8
- case tag of
- 0 -> return Authenticate
- 1 -> return Register
- 2 -> return GetServerInfo
- 3 -> liftM GetLock get
- 4 -> liftM2 GetUserInfo get get
- 5 -> liftM GetHint get
- 6 -> liftM GetSolution get
- 7 -> liftM4 DeclareSolution get get get get
- 8 -> liftM3 SetLock get get get
- 9 -> liftM GetRandomNames get
- 10 -> liftM ResetPassword get
- 11 -> liftM GetRetired get
- 12 -> liftM SetEmail get
- 13 -> return GetPublicKey
+ tag <- get :: Get Word8
+ case tag of
+ 0 -> return Authenticate
+ 1 -> return Register
+ 2 -> return GetServerInfo
+ 3 -> liftM GetLock get
+ 4 -> liftM2 GetUserInfo get get
+ 5 -> liftM GetHint get
+ 6 -> liftM GetSolution get
+ 7 -> liftM4 DeclareSolution get get get get
+ 8 -> liftM3 SetLock get get get
+ 9 -> liftM GetRandomNames get
+ 10 -> liftM ResetPassword get
+ 11 -> liftM GetRetired get
+ 12 -> liftM SetEmail get
+ 13 -> return GetPublicKey
_ -> return UndefinedAction
instance Binary Auth where
@@ -138,22 +138,22 @@ instance Binary ServerResponse where
put (ServedRetired lss) = put (12::Word8) >> put lss
put (ServedPublicKey publicKey) = put (13::Word8) >> put (show publicKey)
get = do
- tag <- get :: Get Word8
- case tag of
- 0 -> return ServerAck
- 1 -> liftM ServerMessage get
- 2 -> liftM ServerError get
- 3 -> liftM ServedServerInfo get
- 4 -> liftM ServedLock get
- 5 -> liftM ServedUserInfo get
- 6 -> liftM ServedUserInfoDeltas get
- 7 -> liftM ServedSolution get
- 8 -> liftM ServedHint get
- 9 -> liftM ServedRandomNames get
- 10 -> return ServerCodenameFree
- 11 -> return ServerFresh
- 12 -> liftM ServedRetired get
- 13 -> liftM (ServedPublicKey . read) get
+ tag <- get :: Get Word8
+ case tag of
+ 0 -> return ServerAck
+ 1 -> liftM ServerMessage get
+ 2 -> liftM ServerError get
+ 3 -> liftM ServedServerInfo get
+ 4 -> liftM ServedLock get
+ 5 -> liftM ServedUserInfo get
+ 6 -> liftM ServedUserInfoDeltas get
+ 7 -> liftM ServedSolution get
+ 8 -> liftM ServedHint get
+ 9 -> liftM ServedRandomNames get
+ 10 -> return ServerCodenameFree
+ 11 -> return ServerFresh
+ 12 -> liftM ServedRetired get
+ 13 -> liftM (ServedPublicKey . read) get
_ -> return ServerUndefinedResponse
instance Binary ServerInfo where
put (ServerInfo sz str) = put sz >> put str
diff --git a/SDLGlyph.hs b/SDLGlyph.hs
index 3bd7dad..01a3a53 100644
--- a/SDLGlyph.hs
+++ b/SDLGlyph.hs
@@ -72,8 +72,8 @@ runRenderM m cgs rc = runStateT (runReaderT m rc) cgs
drawAt :: Glyph -> HexPos -> RenderM ()
drawAt gl pos = do
- centre <- asks renderHCentre
- drawAtRel gl (pos -^ centre)
+ centre <- asks renderHCentre
+ drawAtRel gl (pos -^ centre)
drawAtRel :: Glyph -> HexVec -> RenderM ()
drawAtRel gl v = do
@@ -89,80 +89,80 @@ renderGlyphCaching gl = do
CachedGlyphs cmap clist <- lift get
size <- asks renderSize
let sgl = (gl,size)
- w = size*2 + 1
- h = ysize size*4 + 1
- newGlyphSurf = do
- -- csurf <- liftIO $ createRGBSurface [] w h 32 0xff000000 0x00ff0000 0x0000ff00 0x000000ff
- csurf <- liftIO $ createRGBSurface [] w h 16 0 0 0 0
- liftIO $ setColorKey csurf [SrcColorKey,RLEAccel] $ Pixel 0
- return csurf
- renderOnCache csurf =
+ w = size*2 + 1
+ h = ysize size*4 + 1
+ newGlyphSurf = do
+ -- csurf <- liftIO $ createRGBSurface [] w h 32 0xff000000 0x00ff0000 0x0000ff00 0x000000ff
+ csurf <- liftIO $ createRGBSurface [] w h 16 0 0 0 0
+ liftIO $ setColorKey csurf [SrcColorKey,RLEAccel] $ Pixel 0
+ return csurf
+ renderOnCache csurf =
let ccxt rc = rc { renderSurf = csurf, renderSCentre = SVec (w`div`2) (h`div`2) }
- in local ccxt $ renderGlyph gl
- addToCache cacheFull csurf = do
- CachedGlyphs cmap clist <- lift get
- let cmap' = Map.insert sgl csurf cmap
- lift $ put $ if cacheFull
- then CachedGlyphs (Map.delete (last clist) cmap') (sgl:List.init clist)
- else CachedGlyphs cmap' (sgl:clist)
- promote = do
- CachedGlyphs cmap clist <- lift get
- lift $ put $ CachedGlyphs cmap (sgl:List.delete sgl clist)
- blitGlyph csurf = do
+ in local ccxt $ renderGlyph gl
+ addToCache cacheFull csurf = do
+ CachedGlyphs cmap clist <- lift get
+ let cmap' = Map.insert sgl csurf cmap
+ lift $ put $ if cacheFull
+ then CachedGlyphs (Map.delete (last clist) cmap') (sgl:List.init clist)
+ else CachedGlyphs cmap' (sgl:clist)
+ promote = do
+ CachedGlyphs cmap clist <- lift get
+ lift $ put $ CachedGlyphs cmap (sgl:List.delete sgl clist)
+ blitGlyph csurf = do
surf <- asks renderSurf
- (x,y) <- renderPos zero
- void $ liftIO $ blitSurface csurf Nothing surf $ Just $
- Rect (x-w`div`2) (y-h`div`2) (w+1) (h+1)
+ (x,y) <- renderPos zero
+ void $ liftIO $ blitSurface csurf Nothing surf $ Just $
+ Rect (x-w`div`2) (y-h`div`2) (w+1) (h+1)
let cacheFull = Map.size cmap >= maxCachedGlyphs
let mcsurf = Map.lookup sgl cmap
-- with probability 1 in (maxCachedGlyphs`div`2), we put this glyph at the
-- head of the cached list, throwing away the tail to make room if needed.
cacheIt <- (((cacheable &&) . (not cacheFull ||)) <$>) $
- liftIO $ (==0) <$> randomRIO (0::Int,maxCachedGlyphs`div`2)
+ liftIO $ (==0) <$> randomRIO (0::Int,maxCachedGlyphs`div`2)
case mcsurf of
- Nothing -> if cacheIt
- then do
- csurf <- newGlyphSurf
- renderOnCache csurf
- addToCache cacheFull csurf
- blitGlyph csurf
- else
- renderGlyph gl
- Just csurf -> do
- when cacheIt promote
- blitGlyph csurf
+ Nothing -> if cacheIt
+ then do
+ csurf <- newGlyphSurf
+ renderOnCache csurf
+ addToCache cacheFull csurf
+ blitGlyph csurf
+ else
+ renderGlyph gl
+ Just csurf -> do
+ when cacheIt promote
+ blitGlyph csurf
where
- cacheable = case gl of
- -- some glyphs need to be drawn with blending - those involving
- -- anti-aliasing which bleed over the edge of the hex or which
- -- may be drawn on top of an existing glyph.
- -- TODO: we should find a way to deal with at least some of these;
- -- springs in particular are common and expensive to draw.
- -- Maybe we could truncate the spring glyphs to a hex?
- TileGlyph (BlockTile adjs) _ -> null adjs
- TileGlyph (SpringTile extn dir) _ -> False
+ cacheable = case gl of
+ -- some glyphs need to be drawn with blending - those involving
+ -- anti-aliasing which bleed over the edge of the hex or which
+ -- may be drawn on top of an existing glyph.
+ -- TODO: we should find a way to deal with at least some of these;
+ -- springs in particular are common and expensive to draw.
+ -- Maybe we could truncate the spring glyphs to a hex?
+ TileGlyph (BlockTile adjs) _ -> null adjs
+ TileGlyph (SpringTile extn dir) _ -> False
SpringGlyph _ _ _ _ _ -> False
- FilledHexGlyph _ -> False
- HollowGlyph _ -> False
- BlockedBlock _ _ _ -> False
- BlockedPush _ _ -> False
- CollisionMarker -> False
+ FilledHexGlyph _ -> False
+ HollowGlyph _ -> False
+ BlockedBlock _ _ _ -> False
+ BlockedPush _ _ -> False
+ CollisionMarker -> False
DisplacedGlyph _ _ -> False
- _ -> True
+ _ -> True
renderGlyph :: Glyph -> RenderM ()
renderGlyph (TileGlyph (BlockTile adjs) col) =
rimmedPolygonR corners col $ bright col
- where
- corners = concat [
- if or $ map adjAt [0,1]
- then [corner $ hextant dir]
- else if adjAt $ -1
- then []
- else [innerCorner dir]
- | dir <- hexDirs
- , let adjAt r = rotate r dir `elem` adjs
- ]
+ where
+ corners = concat [
+ if or $ map adjAt [0,1]
+ then [corner $ hextant dir]
+ else if adjAt $ -1
+ then []
+ else [innerCorner dir]
+ | dir <- hexDirs
+ , let adjAt r = rotate r dir `elem` adjs
+ ]
renderGlyph (TileGlyph (SpringTile extn dir) col) =
renderGlyph $ SpringGlyph zero zero extn dir col
@@ -179,85 +179,85 @@ renderGlyph (TileGlyph HookTile col) =
renderGlyph (TileGlyph (WrenchTile mom) col) = do
rimmedCircleR zero (1/3) col $ bright col
when (mom /= zero) $
- let
- from = innerCorner $ neg mom
- to = edge $ neg mom
- shifts = [ (1/2) **^ (b -^ a)
- | rot <- [-1,0,1]
- , let a = innerCorner $ neg mom
- , let b = innerCorner $ rotate rot $ neg mom
- ]
- in sequence_
- [ aaLineR (from+^shift) (to+^shift) $ col
- | shift <- shifts ]
+ let
+ from = innerCorner $ neg mom
+ to = edge $ neg mom
+ shifts = [ (1/2) **^ (b -^ a)
+ | rot <- [-1,0,1]
+ , let a = innerCorner $ neg mom
+ , let b = innerCorner $ rotate rot $ neg mom
+ ]
+ in sequence_
+ [ aaLineR (from+^shift) (to+^shift) $ col
+ | shift <- shifts ]
renderGlyph (TileGlyph BallTile col) =
rimmedCircleR zero (7/8) (faint col) (obscure col)
renderGlyph (SpringGlyph rootDisp endDisp extn dir col) =
thickLinesR points 1 $ brightness col
- where
+ where
n :: Int
- n = 3*case extn of
- Stretched -> 1
- Relaxed -> 2
- Compressed -> 4
- brightness = if extn == Relaxed then dim else bright
- dir' = if dir == zero then hu else dir
- s = corner (hextant dir' - 1) +^ innerCorner endDisp
- off = corner (hextant dir') +^ innerCorner endDisp
- e = corner (hextant dir' - 3) +^ innerCorner rootDisp
- points = [ b +^ (fi i / fi n) **^ (e -^ s)
- | i <- [0..n]
- , i`mod`3 /= 1
- , let b = if i`mod`3==0 then s else off ]
+ n = 3*case extn of
+ Stretched -> 1
+ Relaxed -> 2
+ Compressed -> 4
+ brightness = if extn == Relaxed then dim else bright
+ dir' = if dir == zero then hu else dir
+ s = corner (hextant dir' - 1) +^ innerCorner endDisp
+ off = corner (hextant dir') +^ innerCorner endDisp
+ e = corner (hextant dir' - 3) +^ innerCorner rootDisp
+ points = [ b +^ (fi i / fi n) **^ (e -^ s)
+ | i <- [0..n]
+ , i`mod`3 /= 1
+ , let b = if i`mod`3==0 then s else off ]
renderGlyph (PivotGlyph rot dir col) = do
rimmedCircleR zero (7/8) col $ bright col
when (dir /= zero)
- $ aaLineR from to $ bright col
+ $ aaLineR from to $ bright col
return ()
- where
- from = rotFVec th c $ (7/8) **^ edge (neg dir)
- to = rotFVec th c $ (7/8) **^ edge dir
+ where
+ from = rotFVec th c $ (7/8) **^ edge (neg dir)
+ to = rotFVec th c $ (7/8) **^ edge dir
c = FVec 0 0
th = - fi rot * pi / 12
renderGlyph (ArmGlyph rot dir col) =
thickLineR from to 1 col
- where
- dir' = if dir == zero then hu else dir
- from = rotFVec th c $ edge $ neg dir'
- to = rotFVec th c $ innerCorner dir'
+ where
+ dir' = if dir == zero then hu else dir
+ from = rotFVec th c $ edge $ neg dir'
+ to = rotFVec th c $ innerCorner dir'
c = (2 **^ edge (neg dir'))
th = - fi rot * pi / 12
renderGlyph (BlockedArm armdir tdir col) =
aaLineR from to col
- where
- from = innerCorner $ rotate (2*tdir) armdir
- to = edge $ rotate tdir armdir
+ where
+ from = innerCorner $ rotate (2*tdir) armdir
+ to = edge $ rotate tdir armdir
renderGlyph (TurnedArm armdir tdir col) =
sequence_ [ arcR c r a1 a2 col | r <- [8/4,9/4] ]
where
- c = hexVec2FVec $ neg armdir
- a0 = fi $ -60*hextant armdir
- a1' = a0 + fi tdir * 10
- a2' = a0 + fi tdir * 30
- a1 = min a1' a2'
- a2 = max a1' a2'
+ c = hexVec2FVec $ neg armdir
+ a0 = fi $ -60*hextant armdir
+ a1' = a0 + fi tdir * 10
+ a2' = a0 + fi tdir * 30
+ a1 = min a1' a2'
+ a2 = max a1' a2'
renderGlyph (BlockedBlock tile dir col) =
displaceRender shift $ renderGlyph (TileGlyph tile col)
- where shift = innerCorner dir -^ edge dir
+ where shift = innerCorner dir -^ edge dir
renderGlyph (BlockedPush dir col) = do
thickLineR zero tip 1 col
thickLineR tip (arms!!0) 1 col
thickLineR tip (arms!!1) 1 col
where
- tip@(FVec tx ty) = edge dir
+ tip@(FVec tx ty) = edge dir
arms = [ FVec ((tx/2) + d*ty/4) (ty/2 - d*tx/4) | d <- [-1,1] ]
renderGlyph CollisionMarker = do
@@ -265,9 +265,9 @@ renderGlyph CollisionMarker = do
aaLineR start end $ col
aaCircleR zero rad col
where
- [start,end] = map (((1/2)**^) . corner) [0,3]
- rad = ylen
- col = dim purple
+ [start,end] = map (((1/2)**^) . corner) [0,3]
+ rad = ylen
+ col = dim purple
renderGlyph (HollowGlyph col) =
aaPolygonR corners $ opaquify col
@@ -293,15 +293,15 @@ renderGlyph (UseFiveColourButton using) =
renderGlyph (ShowBlocksButton showing) = do
renderGlyph (TileGlyph (BlockTile []) (dim red))
when (showing == ShowBlocksAll) $
- renderGlyph (BlockedPush hu (bright orange))
+ renderGlyph (BlockedPush hu (bright orange))
when (showing /= ShowBlocksNone) $
- renderGlyph (BlockedPush hw (bright purple))
+ renderGlyph (BlockedPush hw (bright purple))
renderGlyph (ShowButtonTextButton showing) = do
rescaleRender (1/2) $ displaceRender (edge (neg hu)) $
renderGlyph (ButtonGlyph (dim yellow))
when showing $
- sequence_ [ pixelR (FVec (1/3 + i/4) (-1/4)) (bright white) | i <- [-1..1] ]
+ sequence_ [ pixelR (FVec (1/3 + i/4) (-1/4)) (bright white) | i <- [-1..1] ]
renderGlyph (UseSoundsButton use) = do
sequence [ arcR (FVec (-2/3) 0) r (-20) 20
@@ -317,22 +317,22 @@ renderGlyph (WhsButtonsButton Nothing) = rescaleRender (1/3) $ do
| dir <- hexDirs ]
renderGlyph (WhsButtonsButton (Just whs)) = rescaleRender (1/2) $ do
when (whs /= WHSHook) $
- displaceRender (corner 0) $ renderGlyph (TileGlyph (WrenchTile zero) col)
+ displaceRender (corner 0) $ renderGlyph (TileGlyph (WrenchTile zero) col)
when (whs /= WHSWrench) $ do
- displaceRender (corner 4) $ renderGlyph (TileGlyph HookTile col)
- displaceRender (corner 2) $ renderGlyph (TileGlyph (ArmTile hv False) col)
+ displaceRender (corner 4) $ renderGlyph (TileGlyph HookTile col)
+ displaceRender (corner 2) $ renderGlyph (TileGlyph (ArmTile hv False) col)
where
- col = dim white
+ col = dim white
renderGlyph (FullscreenButton fs) = do
thickPolygonR corners 1 $ activeCol (not fs)
thickPolygonR corners' 1 $ activeCol fs
where
- activeCol True = opaquify $ dim green
- activeCol False = opaquify $ dim red
- corners = [ (2/3) **^ (if dir `elem` [hu,neg hu] then edge else innerCorner) dir
- | dir <- hexDirs ]
- corners' = map (((2/3)**^) . corner) [0..5]
+ activeCol True = opaquify $ dim green
+ activeCol False = opaquify $ dim red
+ corners = [ (2/3) **^ (if dir `elem` [hu,neg hu] then edge else innerCorner) dir
+ | dir <- hexDirs ]
+ corners' = map (((2/3)**^) . corner) [0..5]
renderGlyph (DisplacedGlyph dir glyph) =
displaceRender (innerCorner dir) $ renderGlyph glyph
@@ -341,7 +341,7 @@ renderGlyph (UnfreshGlyph) = do
let col = bright red
renderGlyph (HollowInnerGlyph col)
sequence_ [pixelR (FVec (i/4) 0) col
- | i <- [-1..1] ]
+ | i <- [-1..1] ]
playerGlyph col = FilledHexGlyph col
@@ -358,36 +358,36 @@ drawCursorAt _ = return ()
drawBasicBG :: Int -> RenderM ()
drawBasicBG maxR = sequence_ [ drawAtRel (HollowGlyph $ colAt v) v | v <- hexDisc maxR ]
where
- colAt v@(HexVec hx hy hz) = let
- [r,g,b] = map (\h -> fi $ ((0xff*)$ 5 + abs h)`div`maxR) [hx,hy,hz]
- a = fi $ (0x70 * (maxR - abs (hexLen v)))`div`maxR
- in rgbaToPixel (r,g,b,a)
+ colAt v@(HexVec hx hy hz) = let
+ [r,g,b] = map (\h -> fi $ ((0xff*)$ 5 + abs h)`div`maxR) [hx,hy,hz]
+ a = fi $ (0x70 * (maxR - abs (hexLen v)))`div`maxR
+ in rgbaToPixel (r,g,b,a)
drawBlocked :: GameState -> PieceColouring -> Bool -> Force -> RenderM ()
drawBlocked st colouring blocking (Torque idx dir) = do
let (pos,arms) = case getpp st idx of
- PlacedPiece pos (Pivot arms) -> (pos,arms)
- PlacedPiece pos (Hook arm _) -> (pos,[arm])
- _ -> (pos,[])
- col = if blocking then bright $ purple else dim $ colourOf colouring idx
+ PlacedPiece pos (Pivot arms) -> (pos,arms)
+ PlacedPiece pos (Hook arm _) -> (pos,[arm])
+ _ -> (pos,[])
+ col = if blocking then bright $ purple else dim $ colourOf colouring idx
sequence_ [ drawAt (BlockedArm arm dir col) (arm +^ pos) |
- arm <- arms ]
+ arm <- arms ]
drawBlocked st colouring blocking (Push idx dir) = do
let footprint = plPieceFootprint $ getpp st idx
- fullfootprint = fullFootprint st idx
- col = bright $ if blocking then purple else orange
+ fullfootprint = fullFootprint st idx
+ col = bright $ if blocking then purple else orange
sequence_ [ drawAt (BlockedPush dir col) pos
- | pos <- footprint
- , (dir+^pos) `notElem` fullfootprint ]
+ | pos <- footprint
+ , (dir+^pos) `notElem` fullfootprint ]
-- drawAt (blockedPush dir $ bright orange) $ placedPos $ getpp st idx
drawApplied :: GameState -> PieceColouring -> Force -> RenderM ()
drawApplied st colouring (Torque idx dir) = do
let (pos,arms) = case getpp st idx of
- PlacedPiece pos (Pivot arms) -> (pos,arms)
- PlacedPiece pos (Hook arm _) -> (pos,[arm])
- _ -> (pos,[])
- col = dim $ colourOf colouring idx
+ PlacedPiece pos (Pivot arms) -> (pos,arms)
+ PlacedPiece pos (Hook arm _) -> (pos,[arm])
+ _ -> (pos,[])
+ col = dim $ colourOf colouring idx
sequence_ [ drawAt (TurnedArm arm dir col) (arm +^ pos) |
- arm <- arms ]
+ arm <- arms ]
drawApplied _ _ _ = return ()
diff --git a/SDLRender.hs b/SDLRender.hs
index 0f242d7..796fd50 100644
--- a/SDLRender.hs
+++ b/SDLRender.hs
@@ -68,22 +68,22 @@ hexVec2FVec (HexVec x y z) =
sVec2dHV :: Int -> SVec -> (Double,Double,Double)
sVec2dHV size (SVec sx sy) =
let sx',sy',size' :: Double
- [sx',sy',size',ysize'] = map fi [sx,sy,size,ysize size]
- y' = -sy' / ysize' / 3
- x' = ((sx' / size') - y') / 2
- z' = -((sx' / size') + y') / 2
+ [sx',sy',size',ysize'] = map fi [sx,sy,size,ysize size]
+ y' = -sy' / ysize' / 3
+ x' = ((sx' / size') - y') / 2
+ z' = -((sx' / size') + y') / 2
in (x',y',z')
sVec2HexVec :: Int -> SVec -> HexVec
sVec2HexVec size sv =
let (x',y',z') = sVec2dHV size sv
- unrounded = Map.fromList [(1,x'),(2,y'),(3,z')]
- rounded = Map.map round unrounded
- maxdiff = fst $ maximumBy (compare `on` snd) $
- [ (i, abs $ c'-c) | i <- [1..3],
- let c' = unrounded Map.! i, let c = fi $ rounded Map.! i]
- [x,y,z] = map snd $ Map.toList $
- Map.adjust (\x -> x - (sum $ Map.elems rounded)) maxdiff rounded
+ unrounded = Map.fromList [(1,x'),(2,y'),(3,z')]
+ rounded = Map.map round unrounded
+ maxdiff = fst $ maximumBy (compare `on` snd) $
+ [ (i, abs $ c'-c) | i <- [1..3],
+ let c' = unrounded Map.! i, let c = fi $ rounded Map.! i]
+ [x,y,z] = map snd $ Map.toList $
+ Map.adjust (\x -> x - (sum $ Map.elems rounded)) maxdiff rounded
in HexVec x y z
@@ -177,7 +177,7 @@ aaCircleR v rad col = do
aaLinesR verts col =
sequence_ [ aaLineR v v' col |
- (v,v') <- zip (take (length verts - 1) verts) (drop 1 verts) ]
+ (v,v') <- zip (take (length verts - 1) verts) (drop 1 verts) ]
rimmedPolygonR verts fillCol rimCol = do
filledPolygonR verts fillCol
@@ -192,16 +192,16 @@ thickLineR :: (Functor m, MonadIO m) => FVec -> FVec -> Float -> Pixel -> Render
thickLineR from to thickness col =
let FVec dx dy = to -^ from
baseThickness = (1/16)
- s = baseThickness * thickness / (sqrt $ dx^2 + dy^2)
- perp = (s/2) **^ FVec dy (-dx)
+ s = baseThickness * thickness / (sqrt $ dx^2 + dy^2)
+ perp = (s/2) **^ FVec dy (-dx)
in rimmedPolygonR
[ from +^ perp, to +^ perp
, to +^ neg perp, from +^ neg perp]
- (dim col) (bright col)
+ (dim col) (bright col)
thickLinesR verts thickness col =
sequence_ [ thickLineR v v' thickness col |
- (v,v') <- zip (take (length verts - 1) verts) (drop 1 verts) ]
+ (v,v') <- zip (take (length verts - 1) verts) (drop 1 verts) ]
thickPolygonR verts thickness col =
thickLinesR (verts ++ take 1 verts) thickness col
@@ -214,36 +214,36 @@ ysize = (map (\size -> round $ fi size * ylen) [0..] !!)
corner :: Int -> FVec
corner hextant = FVec x y
where
- [x,y] = f hextant
- f 0 = [1, -ylen]
- f 1 = [0, -2*ylen]
- f 2 = [-1, -ylen]
- f n | n < 6 = let [x,y] = f (5-n) in [x,-y]
- | n < 0 = f (6-n)
- | otherwise = f (n`mod`6)
+ [x,y] = f hextant
+ f 0 = [1, -ylen]
+ f 1 = [0, -2*ylen]
+ f 2 = [-1, -ylen]
+ f n | n < 6 = let [x,y] = f (5-n) in [x,-y]
+ | n < 0 = f (6-n)
+ | otherwise = f (n`mod`6)
innerCorner :: HexDir -> FVec
innerCorner dir = FVec x y
where
- [x,y] = f dir
- f dir
- | dir == hu = [2/3, 0]
- | dir == hv = [-1/3, -ylen]
- | dir == hw = [-1/3, ylen]
+ [x,y] = f dir
+ f dir
+ | dir == hu = [2/3, 0]
+ | dir == hv = [-1/3, -ylen]
+ | dir == hw = [-1/3, ylen]
| dir == zero = [0,0]
- | not (isHexDir dir) = error "innerCorner: not a hexdir"
- | otherwise = map (\z -> -z) $ f $ neg dir
+ | not (isHexDir dir) = error "innerCorner: not a hexdir"
+ | otherwise = map (\z -> -z) $ f $ neg dir
edge :: HexDir -> FVec
edge dir = FVec x y
where
- [x,y] = f dir
- f dir
- | dir == hu = [1, 0]
- | dir == hv = [-1/2, -3*ylen/2]
- | dir == hw = [-1/2, 3*ylen/2]
- | not (isHexDir dir) = error "edge: not a hexdir"
- | otherwise = map (\z -> -z) $ f $ neg dir
+ [x,y] = f dir
+ f dir
+ | dir == hu = [1, 0]
+ | dir == hv = [-1/2, -3*ylen/2]
+ | dir == hw = [-1/2, 3*ylen/2]
+ | not (isHexDir dir) = error "edge: not a hexdir"
+ | otherwise = map (\z -> -z) $ f $ neg dir
rotFVec :: Float -> FVec -> FVec -> FVec
rotFVec th (FVec cx cy) v@(FVec x y)
@@ -262,10 +262,10 @@ orange = Pixel 0xff7f0000
colourWheel :: Int -> Pixel
colourWheel n = Pixel $ (((((r * 0x100) + g) * 0x100) + b) * 0x100) + a
where [r,g,b] = map (\on -> if on then 0xff else 0) $ colourWheel' n
- a = 0x00
- colourWheel' 0 = [True, False, False]
- colourWheel' 1 = [True, True, False]
- colourWheel' n = let [a,b,c] = colourWheel' $ n-2 in [c,a,b]
+ a = 0x00
+ colourWheel' 0 = [True, False, False]
+ colourWheel' 1 = [True, True, False]
+ colourWheel' n = let [a,b,c] = colourWheel' $ n-2 in [c,a,b]
red = colourWheel 0
yellow = colourWheel 1
@@ -277,8 +277,8 @@ purple = colourWheel 5
colourOf :: Ord i => Map i Int -> i -> Pixel
colourOf colouring idx =
case Map.lookup idx colouring of
- Nothing -> white
- Just n -> colourWheel n
+ Nothing -> white
+ Just n -> colourWheel n
setPixelAlpha alpha (Pixel v) = Pixel $ v `div` 0x100 * 0x100 + alpha
bright = setPixelAlpha 0xff
@@ -290,13 +290,13 @@ invisible = setPixelAlpha 0x00
pixelToRGBA (Pixel v) =
let (r,v') = divMod v 0x1000000
- (g,v'') = divMod v' 0x10000
- (b,a) = divMod v'' 0x100
+ (g,v'') = divMod v' 0x10000
+ (b,a) = divMod v'' 0x100
in (r,g,b,a)
rgbaToPixel (r,g,b,a) = Pixel $ a+0x100*(b+0x100*(g+0x100*r))
opaquify p =
let (r,g,b,a) = pixelToRGBA p
- [r',g',b'] = map (\v -> (v*a)`div`0xff) [r,g,b]
+ [r',g',b'] = map (\v -> (v*a)`div`0xff) [r,g,b]
in rgbaToPixel (r',g',b',0xff)
messageCol = white
@@ -318,10 +318,10 @@ renderStrColAt' centred c str v = void $ runMaybeT $ do
fsurf <- MaybeT $ liftIO $ TTF.tryRenderTextBlended font str $ pixelToColor c
(surf, scrCentre, size) <- lift $ asks $ liftM3 (,,) renderSurf renderSCentre renderSize
let SVec x y = scrCentre +^ (hexVec2SVec size v)
- +^ neg (SVec 0 ((surfaceGetHeight fsurf-1)`div`2) +^
- if centred
- then SVec ((surfaceGetWidth fsurf)`div`2) 0
- else SVec 0 0)
+ +^ neg (SVec 0 ((surfaceGetHeight fsurf-1)`div`2) +^
+ if centred
+ then SVec ((surfaceGetWidth fsurf)`div`2) 0
+ else SVec 0 0)
void $ liftIO $ blitSurface fsurf Nothing surf (Just $ Rect x y 0 0)
renderStrColAbove,renderStrColBelow :: (Functor m, MonadIO m) => Pixel -> String -> HexVec -> RenderT m ()
@@ -339,22 +339,22 @@ fillRectBG mrect = do
surf <- asks renderSurf
mbgsurf <- asks renderBGSurf
void $ liftIO $ maybe
- (fillRect surf mrect black)
- (\bgsurf -> blitSurface bgsurf mrect surf mrect)
- mbgsurf
+ (fillRect surf mrect black)
+ (\bgsurf -> blitSurface bgsurf mrect surf mrect)
+ mbgsurf
blankRow v = do
(surf, scrCentre, size) <- asks $ liftM3 (,,) renderSurf renderSCentre renderSize
let SVec _ y = scrCentre +^ (hexVec2SVec size v)
- w = surfaceGetWidth surf
- h = ceiling $ fi (size * 3 `div` 2) * 2 / sqrt 3
+ w = surfaceGetWidth surf
+ h = ceiling $ fi (size * 3 `div` 2) * 2 / sqrt 3
fillRectBG $ Just $ Rect 0 (y-h`div`2) w h
blitAt :: (Functor m, MonadIO m) => Surface -> HexVec -> RenderT m ()
blitAt surface v = do
(surf, scrCentre, size) <- asks $ liftM3 (,,) renderSurf renderSCentre renderSize
let SVec x y = scrCentre +^ (hexVec2SVec size v)
- w = surfaceGetWidth surface
- h = surfaceGetHeight surface
+ w = surfaceGetWidth surface
+ h = surfaceGetHeight surface
void $ liftIO $ blitSurface surface Nothing surf $ Just $
- Rect (x-w`div`2) (y-h`div`2) (w+1) (h+1)
+ Rect (x-w`div`2) (y-h`div`2) (w+1) (h+1)
diff --git a/SDLUI.hs b/SDLUI.hs
index 156e938..ca7c55c 100644
--- a/SDLUI.hs
+++ b/SDLUI.hs
@@ -136,7 +136,7 @@ waitFrame = do
now <- liftIO getTicks
-- liftIO $ print now
when (now < next) $
- liftIO $ delay (next - now)
+ liftIO $ delay (next - now)
modify $ \ds -> ds { lastFrameTicks = now }
@@ -151,59 +151,59 @@ getButtons mode = do
mwhs <- gets $ whsButtons.uiOptions
cntxtButtons <- gets contextButtons
return $ cntxtButtons ++ global ++ case mode of
- IMEdit -> [
- singleButton (tl+^hv+^neg hw) CmdTest 1 [("test", hu+^neg hw)]
- , singleButton (tl+^(neg hw)) CmdPlay 2 [("play", hu+^neg hw)]
- , markGroup
- , singleButton (br+^2*^hu) CmdWriteState 2 [("save", hu+^neg hw)] ]
- ++ whsBGs mwhs mode
- ++ [ ([Button (paintButtonStart +^ hu +^ i*^hv) (paintTileCmds!!i) []
- | i <- take (length paintTiles) [0..] ],(5,0)) ]
- IMPlay ->
- [ markGroup ]
- ++ whsBGs mwhs mode
- IMReplay -> [ markGroup ]
- IMMeta ->
- [ singleButton serverPos CmdSetServer 0 [("server",7*^neg hu)]
- , singleButton (serverPos+^hw) CmdToggleCacheOnly 0 [("offline",hv+^7*^neg hu),("mode",hw+^5*^neg hu)]
- , singleButton (codenamePos +^ 2*^neg hu) (CmdSelCodename Nothing) 2 [("code",hv+^5*^neg hu),("name",hw+^5*^neg hu)]
- , singleButton (serverPos +^ 2*^neg hv +^ 2*^hw) CmdTutorials 3 [("play",hu+^neg hw),("tut",hu+^neg hv)]
- ]
-
- _ -> []
- where
- markGroup = ([Button (tl+^hw) CmdMark [("set",hu+^neg hw),("mark",hu+^neg hv)]
- , Button (tl+^hw+^hv) CmdJumpMark [("jump",hu+^neg hw),("mark",hu+^neg hv)]
- , Button (tl+^hw+^2*^hv) CmdReset [("jump",hu+^neg hw),("start",hu+^neg hv)]],(0,1))
- global = if mode `elem` [IMTextInput,IMImpatience] then [] else
- [ singleButton br CmdQuit 0 [("quit",hu+^neg hw)]
- , singleButton (tr +^ 3*^hv +^ 3*^hu) CmdHelp 3 [("help",hu+^neg hw)] ]
- 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 ], (5,0) )
- ] ++
- (if whs == WHSWrench then [] else
- [ ( [ Button (bl+^((-2)*^hv))
- (CmdRotate whs (-1))
- [("turn",hu+^neg hw),("cw",hu+^neg hv)]
- , Button (bl+^((-2)*^hw))
- (CmdRotate whs 1)
- [("turn",hu+^neg hw),("ccw",hu+^neg hv)]
- ], (5,0) )
- ]) ++
- (if whs /= WHSSelected || mode == IMEdit then [] else
- [ ( [ Button (bl+^(2*^hv)+^hw+^neg hu) (CmdTile $ HookTile) [("select",hu+^neg hw),("hook",hu+^neg hv)]
- , Button (bl+^(2*^hv)+^neg hu) (CmdTile $ WrenchTile zero) [("select",hu+^neg hw),("wrench",hu+^neg hv)]
- ], (2,0) ) ])
- tr = periphery 0
- tl = periphery 2
- bl = periphery 3
- br = periphery 5
+ IMEdit -> [
+ singleButton (tl+^hv+^neg hw) CmdTest 1 [("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)] ]
+ ++ whsBGs mwhs mode
+ ++ [ ([Button (paintButtonStart +^ hu +^ i*^hv) (paintTileCmds!!i) []
+ | i <- take (length paintTiles) [0..] ],(5,0)) ]
+ IMPlay ->
+ [ markGroup ]
+ ++ whsBGs mwhs mode
+ IMReplay -> [ markGroup ]
+ IMMeta ->
+ [ singleButton serverPos CmdSetServer 0 [("server",7*^neg hu)]
+ , singleButton (serverPos+^hw) CmdToggleCacheOnly 0 [("offline",hv+^7*^neg hu),("mode",hw+^5*^neg hu)]
+ , singleButton (codenamePos +^ 2*^neg hu) (CmdSelCodename Nothing) 2 [("code",hv+^5*^neg hu),("name",hw+^5*^neg hu)]
+ , singleButton (serverPos +^ 2*^neg hv +^ 2*^hw) CmdTutorials 3 [("play",hu+^neg hw),("tut",hu+^neg hv)]
+ ]
+
+ _ -> []
+ where
+ markGroup = ([Button (tl+^hw) CmdMark [("set",hu+^neg hw),("mark",hu+^neg hv)]
+ , Button (tl+^hw+^hv) CmdJumpMark [("jump",hu+^neg hw),("mark",hu+^neg hv)]
+ , Button (tl+^hw+^2*^hv) CmdReset [("jump",hu+^neg hw),("start",hu+^neg hv)]],(0,1))
+ global = if mode `elem` [IMTextInput,IMImpatience] then [] else
+ [ singleButton br CmdQuit 0 [("quit",hu+^neg hw)]
+ , singleButton (tr +^ 3*^hv +^ 3*^hu) CmdHelp 3 [("help",hu+^neg hw)] ]
+ 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 ], (5,0) )
+ ] ++
+ (if whs == WHSWrench then [] else
+ [ ( [ Button (bl+^((-2)*^hv))
+ (CmdRotate whs (-1))
+ [("turn",hu+^neg hw),("cw",hu+^neg hv)]
+ , Button (bl+^((-2)*^hw))
+ (CmdRotate whs 1)
+ [("turn",hu+^neg hw),("ccw",hu+^neg hv)]
+ ], (5,0) )
+ ]) ++
+ (if whs /= WHSSelected || mode == IMEdit then [] else
+ [ ( [ Button (bl+^(2*^hv)+^hw+^neg hu) (CmdTile $ HookTile) [("select",hu+^neg hw),("hook",hu+^neg hv)]
+ , Button (bl+^(2*^hv)+^neg hu) (CmdTile $ WrenchTile zero) [("select",hu+^neg hw),("wrench",hu+^neg hv)]
+ ], (2,0) ) ])
+ tr = periphery 0
+ tl = periphery 2
+ bl = periphery 3
+ br = periphery 5
data AccessedInfo = AccessedSolved | AccessedPublic | AccessedReadNotes | AccessedUndeclared
deriving (Eq, Ord, Show)
@@ -234,7 +234,7 @@ data Selectable = SelOurLock
registerSelectable :: HexVec -> Int -> Selectable -> UIM ()
registerSelectable v r s =
modify $ \ds -> ds {registeredSelectables = foldr
- (`Map.insert` s) (registeredSelectables ds) $ map (v+^) $ hexDisc r}
+ (`Map.insert` s) (registeredSelectables ds) $ map (v+^) $ hexDisc r}
registerButtonGroup :: ButtonGroup -> UIM ()
registerButtonGroup g = modify $ \ds -> ds {contextButtons = g:contextButtons ds}
registerButton :: HexVec -> Command -> Int -> [ButtonHelp] -> UIM ()
@@ -328,7 +328,7 @@ helpOfSelectable (SelSecured note) = let ActiveLock owner idx = noteOn note in
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] ++ "."
+ " 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 ++ " did not pick this lock, but learnt how to unlock it by reading three notes on it."
@@ -339,7 +339,7 @@ helpOfSelectable (SelAccessedInfo meth) = Just $ case meth of
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."
+ "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 $
@@ -355,13 +355,13 @@ cmdAtMousePos pos@(mPos,central) im selMode = do
buttons <- (concat . map fst) <$> getButtons im
sels <- gets registeredSelectables
return $ listToMaybe $
- [ buttonCmd button
- | button <- buttons, mPos == buttonPos button, central]
- ++ maybe [] (\isRight ->
- [ cmd
- | Just sel <- [Map.lookup mPos sels]
- , Just cmd <- [ commandOfSelectable im sel isRight ] ])
- selMode
+ [ buttonCmd button
+ | button <- buttons, mPos == buttonPos button, central]
+ ++ maybe [] (\isRight ->
+ [ cmd
+ | Just sel <- [Map.lookup mPos sels]
+ , Just cmd <- [ commandOfSelectable im sel isRight ] ])
+ selMode
helpAtMousePos :: (HexVec, Bool) -> InputMode -> UIM (Maybe [Char])
helpAtMousePos (mPos,_) _ =
@@ -374,41 +374,41 @@ data UIOptButton a = UIOptButton { getUIOpt::UIOptions->a, setUIOpt::a->UIOption
-- non-uniform type, so can't use a list...
uiOB1 = UIOptButton useFiveColouring (\v o -> o {useFiveColouring=v}) [True,False]
- (periphery 0 +^ 2 *^ hu) UseFiveColourButton
- (\v -> if v then "Adjacent pieces get different colours" else
- "Pieces are coloured according to type")
- [IMPlay, IMReplay, IMEdit] Nothing
+ (periphery 0 +^ 2 *^ hu) UseFiveColourButton
+ (\v -> if v then "Adjacent pieces get different colours" else
+ "Pieces are coloured according to type")
+ [IMPlay, IMReplay, IMEdit] Nothing
uiOB2 = UIOptButton showBlocks (\v o -> o {showBlocks=v}) [ShowBlocksBlocking,ShowBlocksAll,ShowBlocksNone]
- (periphery 0 +^ 2 *^ hu +^ 2 *^ neg hv) ShowBlocksButton
- (\v -> case v of
- ShowBlocksBlocking -> "Blocking forces are annotated"
- ShowBlocksAll -> "Blocked and blocking forces are annotated"
- ShowBlocksNone -> "Blockage annotations disabled")
- [IMPlay, IMReplay] Nothing
+ (periphery 0 +^ 2 *^ hu +^ 2 *^ neg hv) ShowBlocksButton
+ (\v -> case v of
+ ShowBlocksBlocking -> "Blocking forces are annotated"
+ ShowBlocksAll -> "Blocked and blocking forces are annotated"
+ ShowBlocksNone -> "Blockage annotations disabled")
+ [IMPlay, IMReplay] Nothing
uiOB3 = UIOptButton whsButtons (\v o -> o {whsButtons=v}) [Nothing, Just WHSSelected, Just WHSWrench, Just WHSHook]
- (periphery 3 +^ 3 *^ hv) WhsButtonsButton
- (\v -> case v of
- Nothing -> "Click to show (and rebind) keyboard control buttons."
- Just whs -> "Showing buttons for controlling " ++ case whs of
- WHSSelected -> "selected piece; right-click to rebind"
- WHSWrench -> "wrench; right-click to rebind"
- WHSHook -> "hook; right-click to rebind")
- [IMPlay, IMEdit] Nothing
+ (periphery 3 +^ 3 *^ hv) WhsButtonsButton
+ (\v -> case v of
+ Nothing -> "Click to show (and rebind) keyboard control buttons."
+ Just whs -> "Showing buttons for controlling " ++ case whs of
+ WHSSelected -> "selected piece; right-click to rebind"
+ WHSWrench -> "wrench; right-click to rebind"
+ WHSHook -> "hook; right-click to rebind")
+ [IMPlay, IMEdit] Nothing
uiOB4 = UIOptButton showButtonText (\v o -> o {showButtonText=v}) [True,False]
- (periphery 0 +^ 2 *^ hu +^ 2 *^ hv) ShowButtonTextButton
- (\v -> if v then "Help text enabled" else
- "Help text disabled")
- [IMPlay, IMEdit, IMReplay, IMMeta] Nothing
+ (periphery 0 +^ 2 *^ hu +^ 2 *^ hv) ShowButtonTextButton
+ (\v -> if v then "Help text enabled" else
+ "Help text disabled")
+ [IMPlay, IMEdit, IMReplay, IMMeta] Nothing
uiOB5 = UIOptButton fullscreen (\v o -> o {fullscreen=v}) [True,False]
- (periphery 0 +^ 4 *^ hu +^ 2 *^ hv) FullscreenButton
- (\v -> if v then "Currently in fullscreen mode; click to toggle" else
- "Currently in windowed mode; click to toggle")
- [IMPlay, IMEdit, IMReplay, IMMeta] (Just $ const $ initVideo 0 0)
+ (periphery 0 +^ 4 *^ hu +^ 2 *^ hv) FullscreenButton
+ (\v -> if v then "Currently in fullscreen mode; click to toggle" else
+ "Currently in windowed mode; click to toggle")
+ [IMPlay, IMEdit, IMReplay, IMMeta] (Just $ const $ initVideo 0 0)
uiOB6 = UIOptButton useSounds (\v o -> o {useSounds=v}) [True,False]
- (periphery 0 +^ 3 *^ hu +^ hv) UseSoundsButton
- (\v -> if v then "Sound effects enabled" else
- "Sound effects disabled")
- [IMPlay, IMEdit, IMReplay] Nothing
+ (periphery 0 +^ 3 *^ hu +^ hv) UseSoundsButton
+ (\v -> if v then "Sound effects enabled" else
+ "Sound effects disabled")
+ [IMPlay, IMEdit, IMReplay] Nothing
drawUIOptionButtons :: InputMode -> UIM ()
drawUIOptionButtons mode = do
@@ -423,7 +423,7 @@ drawUIOptionButtons mode = do
drawUIOptionButton im b = when (im `elem` uiOptModes b) $ do
value <- gets $ (getUIOpt b).uiOptions
renderToMain $ mapM_ (\g -> drawAtRel g (uiOptPos b))
- [HollowGlyph $ obscure purple, uiOptGlyph b value]
+ [HollowGlyph $ obscure purple, uiOptGlyph b value]
describeUIOptionButton :: UIOptButton a -> MaybeT UIM String
describeUIOptionButton b = do
value <- gets $ (getUIOpt b).uiOptions
@@ -434,16 +434,16 @@ toggleUIOption (UIOptButton getopt setopt vals _ _ _ _ monSet) = do
let value' = head $ drop (1 + (fromMaybe 0 $ elemIndex value vals)) $ cycle vals
modifyUIOptions $ setopt value'
case monSet of
- Nothing -> return ()
- Just onSet -> onSet value'
+ Nothing -> return ()
+ Just onSet -> onSet value'
readUIConfigFile :: UIM ()
readUIConfigFile = do
path <- liftIO $ confFilePath "SDLUI.conf"
mOpts <- liftIO $ readReadFile path
case mOpts of
- Just opts -> modify $ \s -> s {uiOptions = opts}
- Nothing -> return ()
+ Just opts -> modify $ \s -> s {uiOptions = opts}
+ Nothing -> return ()
writeUIConfigFile :: UIM ()
writeUIConfigFile = do
path <- liftIO $ confFilePath "SDLUI.conf"
@@ -456,8 +456,8 @@ readBindings = do
path <- liftIO $ confFilePath "bindings"
mbdgs <- liftIO $ readReadFile path
case mbdgs of
- Just bdgs -> modify $ \s -> s {uiKeyBindings = bdgs}
- Nothing -> return ()
+ Just bdgs -> modify $ \s -> s {uiKeyBindings = bdgs}
+ Nothing -> return ()
writeBindings :: UIM ()
writeBindings = do
path <- liftIO $ confFilePath "bindings"
@@ -496,16 +496,16 @@ drawPaintButtons :: UIM ()
drawPaintButtons = do
pti <- getEffPaintTileIndex
renderToMain $ sequence_ [
- do
- let gl = case paintTiles!!i of
- Nothing -> HollowInnerGlyph $ dim purple
- Just t -> TileGlyph t $ dim purple
- drawAtRel gl pos
- when selected $ drawAtRel cursorGlyph pos
- | i <- take (length paintTiles) [0..]
- , let pos = paintButtonStart +^ i*^hv
- , let selected = i == pti
- ]
+ do
+ let gl = case paintTiles!!i of
+ Nothing -> HollowInnerGlyph $ dim purple
+ Just t -> TileGlyph t $ dim purple
+ drawAtRel gl pos
+ when selected $ drawAtRel cursorGlyph pos
+ | i <- take (length paintTiles) [0..]
+ , let pos = paintButtonStart +^ i*^hv
+ , let selected = i == pti
+ ]
periphery 0 = ((3*maxlocksize)`div`2)*^hu +^ ((3*maxlocksize)`div`4)*^hv
periphery n = rotate n $ periphery 0
@@ -524,11 +524,11 @@ getGeom = do
let scrCentre = SVec (w`div`2) (h`div`2)
-- |size is the greatest integer such that
-- and [2*size*screenWidthHexes <= width
- -- , 3*ysize size*screenHeightHexes <= height]
- -- where ysize size = round $ fi size / sqrt 3
+ -- , 3*ysize size*screenHeightHexes <= height]
+ -- where ysize size = round $ fi size / sqrt 3
-- Minimum allowed size is 2 (get segfaults on SDL_FreeSurface with 1).
let size = max 2 $ minimum [ w`div`(2*screenWidthHexes)
- , floor $ sqrt 3 * (0.5 + (fi $ h`div`(3*screenHeightHexes)))]
+ , floor $ sqrt 3 * (0.5 + (fi $ h`div`(3*screenHeightHexes)))]
return (scrCentre, size)
data DrawArgs = DrawArgs [PieceIdx] Bool [Alert] GameState UIOptions
@@ -543,58 +543,58 @@ drawMainGameState' :: DrawArgs -> UIM ()
drawMainGameState' args@(DrawArgs highlight colourFixed alerts st uiopts) = do
lastArgs <- gets lastDrawArgs
when (case lastArgs of
- Nothing -> True
- Just (DrawArgs _ _ lastAlerts lastSt _) ->
- lastAlerts /= alerts || lastSt /= st) $
- modify $ \ds -> ds { animFrame = 0, nextAnimFrameAt = Nothing }
+ Nothing -> True
+ Just (DrawArgs _ _ lastAlerts lastSt _) ->
+ lastAlerts /= alerts || lastSt /= st) $
+ modify $ \ds -> ds { animFrame = 0, nextAnimFrameAt = Nothing }
lastAnimFrame <- gets animFrame
now <- liftIO getTicks
anim <- maybe False (<now) <$> gets nextAnimFrameAt
when anim $
- modify $ \ds -> ds { animFrame = lastAnimFrame+1, nextAnimFrameAt = Nothing }
+ modify $ \ds -> ds { animFrame = lastAnimFrame+1, nextAnimFrameAt = Nothing }
animFrameToDraw <- gets animFrame
void $ if (lastArgs == Just args && lastAnimFrame == animFrameToDraw)
- then do
- vidSurf <- liftIO getVideoSurface
- gsSurf <- liftM fromJust $ gets gsSurface
- liftIO $ blitSurface gsSurf Nothing vidSurf Nothing
- else do
- modify $ \ds -> ds { lastDrawArgs = Just args }
-
- -- split the alerts at intermediate states, and associate alerts
- -- to the right states:
- let (globalAlerts,transitoryAlerts) = partition isGlobalAlert alerts
- splitAlerts frameAs (AlertIntermediateState st' : as) =
- (frameAs,st',True) : splitAlerts [] as
- splitAlerts frameAs (a:as) =
- splitAlerts (a:frameAs) as
- splitAlerts frameAs [] = [(frameAs,st,False)]
- isGlobalAlert (AlertAppliedForce _) = False
- isGlobalAlert (AlertIntermediateState _) = False
- isGlobalAlert _ = True
- let animAlertedStates = nub $
- let ass = splitAlerts [] transitoryAlerts
- in if last ass == ([],st,False) then ass else ass ++ [([],st,False)]
- let frames = length animAlertedStates
- let (drawAlerts',drawSt,isIntermediate) = animAlertedStates !! animFrameToDraw
- let drawAlerts = drawAlerts' ++ globalAlerts
- -- let drawAlerts = takeWhile (/= AlertIntermediateState drawSt) alerts
- nextIsSet <- isJust <$> gets nextAnimFrameAt
- when (not nextIsSet && frames > animFrameToDraw+1) $ do
- time <- (if isIntermediate then uiAnimTime else shortUiAnimTime) <$>
+ then do
+ vidSurf <- liftIO getVideoSurface
+ gsSurf <- liftM fromJust $ gets gsSurface
+ liftIO $ blitSurface gsSurf Nothing vidSurf Nothing
+ else do
+ modify $ \ds -> ds { lastDrawArgs = Just args }
+
+ -- split the alerts at intermediate states, and associate alerts
+ -- to the right states:
+ let (globalAlerts,transitoryAlerts) = partition isGlobalAlert alerts
+ splitAlerts frameAs (AlertIntermediateState st' : as) =
+ (frameAs,st',True) : splitAlerts [] as
+ splitAlerts frameAs (a:as) =
+ splitAlerts (a:frameAs) as
+ splitAlerts frameAs [] = [(frameAs,st,False)]
+ isGlobalAlert (AlertAppliedForce _) = False
+ isGlobalAlert (AlertIntermediateState _) = False
+ isGlobalAlert _ = True
+ let animAlertedStates = nub $
+ let ass = splitAlerts [] transitoryAlerts
+ in if last ass == ([],st,False) then ass else ass ++ [([],st,False)]
+ let frames = length animAlertedStates
+ let (drawAlerts',drawSt,isIntermediate) = animAlertedStates !! animFrameToDraw
+ let drawAlerts = drawAlerts' ++ globalAlerts
+ -- let drawAlerts = takeWhile (/= AlertIntermediateState drawSt) alerts
+ nextIsSet <- isJust <$> gets nextAnimFrameAt
+ when (not nextIsSet && frames > animFrameToDraw+1) $ do
+ time <- (if isIntermediate then uiAnimTime else shortUiAnimTime) <$>
gets uiOptions
- modify $ \ds -> ds { nextAnimFrameAt = Just $ now + time }
-
- let board = stateBoard drawSt
- lastCol <- gets dispLastCol
- let coloured = colouredPieces colourFixed drawSt
- let colouring = if useFiveColouring uiopts
- then boardColouring drawSt coloured lastCol
- else pieceTypeColouring drawSt coloured
- modify $ \ds -> ds { dispLastCol = colouring }
- gsSurf <- liftM fromJust $ gets gsSurface
- renderToMainWithSurf gsSurf $ do
+ modify $ \ds -> ds { nextAnimFrameAt = Just $ now + time }
+
+ let board = stateBoard drawSt
+ lastCol <- gets dispLastCol
+ let coloured = colouredPieces colourFixed drawSt
+ let colouring = if useFiveColouring uiopts
+ then boardColouring drawSt coloured lastCol
+ else pieceTypeColouring drawSt coloured
+ modify $ \ds -> ds { dispLastCol = colouring }
+ gsSurf <- liftM fromJust $ gets gsSurface
+ renderToMainWithSurf gsSurf $ do
let tileGlyphs = fmap (ownedTileGlyph colouring highlight) board
applyAlert (AlertAppliedForce f@(Torque idx tdir)) =
@@ -640,25 +640,25 @@ drawMainGameState' args@(DrawArgs highlight colourFixed alerts st uiopts) = do
applyAlerts = flip (foldr applyAlert) drawAlerts
- erase
- sequence_ [ drawAt glyph pos |
- (pos,glyph) <- Map.toList $ applyAlerts tileGlyphs
- ]
-
- when (showBlocks uiopts /= ShowBlocksNone) $ sequence_
- $ [ drawBlocked drawSt colouring False force
- | AlertBlockedForce force <- drawAlerts
- , showBlocks uiopts == ShowBlocksAll ]
- ++ [ drawBlocked drawSt colouring True force
- | AlertBlockingForce force <- drawAlerts ]
- -- ++ [ drawBlocked drawSt colouring True force |
- -- AlertResistedForce force <- drawAlerts ]
- ++ [ drawAt CollisionMarker pos
- | AlertCollision pos <- drawAlerts ]
- -- ++ [ drawApplied drawSt colouring force
- -- | AlertAppliedForce force <- drawAlerts ]
- vidSurf <- liftIO getVideoSurface
- liftIO $ blitSurface gsSurf Nothing vidSurf Nothing
+ erase
+ sequence_ [ drawAt glyph pos |
+ (pos,glyph) <- Map.toList $ applyAlerts tileGlyphs
+ ]
+
+ when (showBlocks uiopts /= ShowBlocksNone) $ sequence_
+ $ [ drawBlocked drawSt colouring False force
+ | AlertBlockedForce force <- drawAlerts
+ , showBlocks uiopts == ShowBlocksAll ]
+ ++ [ drawBlocked drawSt colouring True force
+ | AlertBlockingForce force <- drawAlerts ]
+ -- ++ [ drawBlocked drawSt colouring True force |
+ -- AlertResistedForce force <- drawAlerts ]
+ ++ [ drawAt CollisionMarker pos
+ | AlertCollision pos <- drawAlerts ]
+ -- ++ [ drawApplied drawSt colouring force
+ -- | AlertAppliedForce force <- drawAlerts ]
+ vidSurf <- liftIO getVideoSurface
+ liftIO $ blitSurface gsSurf Nothing vidSurf Nothing
playAlertSounds :: GameState -> [Alert] -> UIM ()
#ifdef SOUND
@@ -666,36 +666,36 @@ playAlertSounds st alerts = do
use <- useSounds <$> gets uiOptions
when use $ mapM_ (maybe (return ()) playSound . alertSound) alerts
where
- alertSound (AlertBlockedForce force) =
- let PlacedPiece _ piece = getpp st $ forceIdx force
- in case piece of
- Wrench _ -> Just "wrenchblocked"
- Hook _ _ -> if isPush force then Just "hookblocked" else Just "hookarmblocked"
- _ -> Nothing
- alertSound (AlertDivertedWrench _) = Just "wrenchscrape"
- alertSound (AlertAppliedForce (Torque idx _))
- | isPivot.placedPiece.getpp st $ idx = Just "pivot"
- alertSound (AlertAppliedForce (Push idx dir))
- | isBall.placedPiece.getpp st $ idx = Just "ballmove"
- alertSound (AlertAppliedForce (Push idx dir)) = do
- (align,newLen) <- listToMaybe [(align,newLen)
- | c@(Connection (startIdx,_) (endIdx,_) (Spring outDir natLen)) <- connections st
- , let align = (if outDir == dir then 1 else if outDir == neg dir then -1 else 0)
- * (if idx == startIdx then 1 else if idx == endIdx then -1 else 0)
- , align /= 0
- , let newLen = connectionLength st c ]
- return $ "spring" ++ (if align == 1 then "contract" else "extend")
- ++ show (min newLen 12)
- alertSound AlertUnlocked = Just "unlocked"
- alertSound _ = Nothing
- playSound :: String -> UIM ()
- playSound sound = void.runMaybeT $ do
- ss <- MaybeT $ Map.lookup sound <$> gets sounds
- guard.not.null $ ss
- liftIO $ randFromList ss >>= \(Just s) -> void $ tryPlayChannel (-1) s 0
- randFromList :: [a] -> IO (Maybe a)
- randFromList [] = return Nothing
- randFromList as = (Just.(as!!)) <$> randomRIO (0,length as - 1)
+ alertSound (AlertBlockedForce force) =
+ let PlacedPiece _ piece = getpp st $ forceIdx force
+ in case piece of
+ Wrench _ -> Just "wrenchblocked"
+ Hook _ _ -> if isPush force then Just "hookblocked" else Just "hookarmblocked"
+ _ -> Nothing
+ alertSound (AlertDivertedWrench _) = Just "wrenchscrape"
+ alertSound (AlertAppliedForce (Torque idx _))
+ | isPivot.placedPiece.getpp st $ idx = Just "pivot"
+ alertSound (AlertAppliedForce (Push idx dir))
+ | isBall.placedPiece.getpp st $ idx = Just "ballmove"
+ alertSound (AlertAppliedForce (Push idx dir)) = do
+ (align,newLen) <- listToMaybe [(align,newLen)
+ | c@(Connection (startIdx,_) (endIdx,_) (Spring outDir natLen)) <- connections st
+ , let align = (if outDir == dir then 1 else if outDir == neg dir then -1 else 0)
+ * (if idx == startIdx then 1 else if idx == endIdx then -1 else 0)
+ , align /= 0
+ , let newLen = connectionLength st c ]
+ return $ "spring" ++ (if align == 1 then "contract" else "extend")
+ ++ show (min newLen 12)
+ alertSound AlertUnlocked = Just "unlocked"
+ alertSound _ = Nothing
+ playSound :: String -> UIM ()
+ playSound sound = void.runMaybeT $ do
+ ss <- MaybeT $ Map.lookup sound <$> gets sounds
+ guard.not.null $ ss
+ liftIO $ randFromList ss >>= \(Just s) -> void $ tryPlayChannel (-1) s 0
+ randFromList :: [a] -> IO (Maybe a)
+ randFromList [] = return Nothing
+ randFromList as = (Just.(as!!)) <$> randomRIO (0,length as - 1)
#else
playAlertSounds _ _ = return ()
#endif
@@ -706,27 +706,27 @@ drawMiniLock lock v = do
surface <- Map.lookup lock <$> gets miniLocks >>= maybe new return
renderToMain $ blitAt surface v
where
- miniLocksize = 3
- new = do
- (_, size) <- getGeom
- let minisize = size `div` (ceiling $ lockSize lock % miniLocksize)
- let width = size*2*(miniLocksize*2+1)
- let height = ceiling $ fi size * sqrt 3 * fi (miniLocksize*2+1+1)
- surf <- liftIO $ createRGBSurface [] width height 16 0 0 0 0
- liftIO $ setColorKey surf [SrcColorKey,RLEAccel] $ Pixel 0
- uiopts <- gets uiOptions
- let st = snd $ reframe lock
- coloured = colouredPieces False st
- colouring = if useFiveColouring uiopts
- then boardColouring st coloured Map.empty
- else pieceTypeColouring st coloured
- draw = sequence_ [ drawAt glyph pos |
- (pos,glyph) <- Map.toList $ fmap (ownedTileGlyph colouring []) $ stateBoard st ]
- liftIO $ runRenderM draw emptyCachedGlyphs $
- RenderContext surf Nothing (PHS zero) (SVec (width`div`2) (height`div`2)) minisize Nothing
- clearOldMiniLocks
- modify $ \ds -> ds { miniLocks = Map.insert lock surf $ miniLocks ds }
- return surf
+ miniLocksize = 3
+ new = do
+ (_, size) <- getGeom
+ let minisize = size `div` (ceiling $ lockSize lock % miniLocksize)
+ let width = size*2*(miniLocksize*2+1)
+ let height = ceiling $ fi size * sqrt 3 * fi (miniLocksize*2+1+1)
+ surf <- liftIO $ createRGBSurface [] width height 16 0 0 0 0
+ liftIO $ setColorKey surf [SrcColorKey,RLEAccel] $ Pixel 0
+ uiopts <- gets uiOptions
+ let st = snd $ reframe lock
+ coloured = colouredPieces False st
+ colouring = if useFiveColouring uiopts
+ then boardColouring st coloured Map.empty
+ else pieceTypeColouring st coloured
+ draw = sequence_ [ drawAt glyph pos |
+ (pos,glyph) <- Map.toList $ fmap (ownedTileGlyph colouring []) $ stateBoard st ]
+ liftIO $ runRenderM draw emptyCachedGlyphs $
+ RenderContext surf Nothing (PHS zero) (SVec (width`div`2) (height`div`2)) minisize Nothing
+ clearOldMiniLocks
+ modify $ \ds -> ds { miniLocks = Map.insert lock surf $ miniLocks ds }
+ return surf
-- | TODO: do this more cleverly
clearOldMiniLocks =
@@ -741,8 +741,8 @@ getBindingStr mode = do
setting <- gets settingBinding
uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings
return (\cmd ->
- if Just cmd == setting then "??"
- else maybe "" showKey $ findBinding (uibdgs ++ bindings mode) cmd)
+ if Just cmd == setting then "??"
+ else maybe "" showKey $ findBinding (uibdgs ++ bindings mode) cmd)
drawButtons :: InputMode -> UIM ()
drawButtons mode = do
@@ -751,16 +751,16 @@ drawButtons mode = do
showBT <- showButtonText <$> gets uiOptions
smallFont <- gets dispFontSmall
renderToMain $ sequence_ $ concat [ [ do
- drawAtRel (ButtonGlyph col) v
- (if length bdg > 2 then withFont smallFont else id) $
+ drawAtRel (ButtonGlyph col) v
+ (if length bdg > 2 then withFont smallFont else id) $
renderStrColAt buttonTextCol bdg v
- when showBT $
- withFont smallFont $ recentreAt v $ rescaleRender (1/4) $
- sequence_ [ renderStrColAtLeft white s dv | (s,dv) <- helps ]
- | (i,(v,bdg,helps)) <- enumerate $ map (\b->(buttonPos b, bindingStr $ buttonCmd b, buttonHelp b)) $ buttonGroup
- , let col = dim $ colourWheel (base+inc*i) ]
- | (buttonGroup,(base,inc)) <- buttons
- ]
+ when showBT $
+ withFont smallFont $ recentreAt v $ rescaleRender (1/4) $
+ sequence_ [ renderStrColAtLeft white s dv | (s,dv) <- helps ]
+ | (i,(v,bdg,helps)) <- enumerate $ map (\b->(buttonPos b, bindingStr $ buttonCmd b, buttonHelp b)) $ buttonGroup
+ , let col = dim $ colourWheel (base+inc*i) ]
+ | (buttonGroup,(base,inc)) <- buttons
+ ]
where enumerate = zip [0..]
initMisc :: IO ()
@@ -769,21 +769,21 @@ initMisc = void $ enableUnicode True >> enableKeyRepeat 250 30 >> setCaption "in
initVideo :: Int -> Int -> UIM ()
initVideo w h = do
liftIO $ (((w,h)==(0,0) &&) . (InitVideo `elem`) <$> wasInit [InitVideo]) >>?
- -- reset video so that passing (0,0) to setVideoMode sets to
- -- current screen res rather than current window size
- (quitSubSystem [InitVideo] >> initSubSystem [InitVideo] >> initMisc)
+ -- reset video so that passing (0,0) to setVideoMode sets to
+ -- current screen res rather than current window size
+ (quitSubSystem [InitVideo] >> initSubSystem [InitVideo] >> initMisc)
fs <- fullscreen <$> gets uiOptions
liftIO $ do
- (w',h') <- if (fs || (w,h)/=(0,0)) then return (w,h) else do
- -- use smaller dimensions than the screen's, to work around a bug
- -- seen on mac, whereby a resizable window created with
- -- (w,h)=(0,0), or even with the (w,h) given by getDimensions
- -- after creating such a window, is reported to be larger than it
- -- is.
- (w',h') <- getDimensions
- return $ (4*w'`div`5,4*h'`div`5)
- setVideoMode w' h' 0 $ if fs then [Fullscreen] else [Resizable]
+ (w',h') <- if (fs || (w,h)/=(0,0)) then return (w,h) else do
+ -- use smaller dimensions than the screen's, to work around a bug
+ -- seen on mac, whereby a resizable window created with
+ -- (w,h)=(0,0), or even with the (w,h) given by getDimensions
+ -- after creating such a window, is reported to be larger than it
+ -- is.
+ (w',h') <- getDimensions
+ return $ (4*w'`div`5,4*h'`div`5)
+ setVideoMode w' h' 0 $ if fs then [Fullscreen] else [Resizable]
(w',h') <- liftIO getDimensions
@@ -801,21 +801,21 @@ initVideo w h = do
useBG <- gets $ useBackground.uiOptions
mbg <- if useBG then do
- bgsurf <- liftIO $ createRGBSurface [] w' h' 16 0 0 0 0
- renderToMainWithSurf bgsurf $ drawBasicBG $ 2*(max screenWidthHexes screenHeightHexes)`div`3
- return $ Just bgsurf
- else return Nothing
+ bgsurf <- liftIO $ createRGBSurface [] w' h' 16 0 0 0 0
+ renderToMainWithSurf bgsurf $ drawBasicBG $ 2*(max screenWidthHexes screenHeightHexes)`div`3
+ return $ Just bgsurf
+ else return Nothing
modify $ \ds -> ds { bgSurface = mbg }
clearMiniLocks
when (isNothing font) $ lift $ do
- let text = "Warning: font file not found at "++fontpath++".\n"
- putStr text
- writeFile "error.log" text
+ let text = "Warning: font file not found at "++fontpath++".\n"
+ putStr text
+ writeFile "error.log" text
where
- getDimensions = (videoInfoWidth &&& videoInfoHeight) <$> getVideoInfo
+ getDimensions = (videoInfoWidth &&& videoInfoHeight) <$> getVideoInfo
initAudio :: UIM ()
@@ -825,27 +825,27 @@ initAudio = do
-- liftIO $ querySpec >>= print
liftIO $ allocateChannels 16
let seqWhileJust (m:ms) = m >>= \ret -> case ret of
- Nothing -> return []
- Just a -> (a:) <$> seqWhileJust ms
+ Nothing -> return []
+ Just a -> (a:) <$> seqWhileJust ms
soundsdir <- liftIO $ getDataPath "sounds"
sounds <- sequence [ do
- chunks <- liftIO $ seqWhileJust
- [ runMaybeT $ do
- chunk <- msum $ map (MaybeT . tryLoadWAV) paths
- liftIO $ volumeChunk chunk vol
- return chunk
- | n <- [1..]
- , let paths = [soundsdir ++ [pathSeparator] ++ sound ++
- "-" ++ (if n < 10 then ('0':) else id) (show n) ++ ext
- | ext <- [".ogg", ".wav"] ]
- , let vol = case sound of
- "pivot" -> 64
- "wrenchscrape" -> 64
- _ -> 128
- ]
- return (sound,chunks)
- | sound <- ["hookblocked","hookarmblocked","wrenchblocked","wrenchscrape","pivot","unlocked","ballmove"]
- ++ ["spring" ++ d ++ show l | d <- ["extend","contract"], l <- [1..12]] ]
+ chunks <- liftIO $ seqWhileJust
+ [ runMaybeT $ do
+ chunk <- msum $ map (MaybeT . tryLoadWAV) paths
+ liftIO $ volumeChunk chunk vol
+ return chunk
+ | n <- [1..]
+ , let paths = [soundsdir ++ [pathSeparator] ++ sound ++
+ "-" ++ (if n < 10 then ('0':) else id) (show n) ++ ext
+ | ext <- [".ogg", ".wav"] ]
+ , let vol = case sound of
+ "pivot" -> 64
+ "wrenchscrape" -> 64
+ _ -> 128
+ ]
+ return (sound,chunks)
+ | sound <- ["hookblocked","hookarmblocked","wrenchblocked","wrenchscrape","pivot","unlocked","ballmove"]
+ ++ ["spring" ++ d ++ show l | d <- ["extend","contract"], l <- [1..12]] ]
-- liftIO $ print sounds
modify $ \s -> s { sounds = Map.fromList sounds }
#else
@@ -855,22 +855,22 @@ initAudio = return ()
pollEvents = do
e <- pollEvent
case e of
- NoEvent -> return []
- _ -> do
- es <- pollEvents
- return $ e:es
+ NoEvent -> return []
+ _ -> do
+ es <- pollEvents
+ return $ e:es
drawMsgLine = void.runMaybeT $ do
(col,str) <- msum
- [ ((,) dimWhiteCol) <$> MaybeT (gets hoverStr)
- , MaybeT $ gets message
- ]
+ [ ((,) dimWhiteCol) <$> MaybeT (gets hoverStr)
+ , MaybeT $ gets message
+ ]
lift $ do
- renderToMain $ blankRow messageLineCentre
- smallFont <- gets dispFontSmall
- renderToMain $
- (if length str > screenWidthHexes * 3 then withFont smallFont else id) $
- renderStrColAt col str messageLineCentre
+ renderToMain $ blankRow messageLineCentre
+ smallFont <- gets dispFontSmall
+ renderToMain $
+ (if length str > screenWidthHexes * 3 then withFont smallFont else id) $
+ renderStrColAt col str messageLineCentre
setMsgLineNoRefresh col str = do
modify $ \s -> s { message = Just (col,str) }
diff --git a/SDLUIMInstance.hs b/SDLUIMInstance.hs
index 50ffd78..8b45497 100644
--- a/SDLUIMInstance.hs
+++ b/SDLUIMInstance.hs
@@ -54,205 +54,205 @@ import SDLUI
instance UIMonad (StateT UIState IO) where
runUI m = evalStateT m nullUIState
drawMainState = do
- lift $ clearButtons >> clearSelectables
- s <- get
- let mode = ms2im s
- lift $ waitFrame
- drawMainState' s
- lift . drawTitle =<< getTitle
- lift $ do
- drawButtons mode
- drawUIOptionButtons mode
- gets needHoverUpdate >>? do
- updateHoverStr mode
- modify (\ds -> ds {needHoverUpdate=False})
- drawMsgLine
- drawShortMouseHelp mode
- refresh
- where
+ lift $ clearButtons >> clearSelectables
+ s <- get
+ let mode = ms2im s
+ lift $ waitFrame
+ drawMainState' s
+ lift . drawTitle =<< getTitle
+ lift $ do
+ drawButtons mode
+ drawUIOptionButtons mode
+ gets needHoverUpdate >>? do
+ updateHoverStr mode
+ modify (\ds -> ds {needHoverUpdate=False})
+ drawMsgLine
+ drawShortMouseHelp mode
+ refresh
+ where
drawMainState' (PlayState { psCurrentState=st, psLastAlerts=alerts,
wrenchSelected=wsel, psIsTut=isTut, psSolved=solved }) = do
- canUndo <- null <$> gets psGameStateMoveStack
- canRedo <- null <$> gets psUndoneStack
- lift $ do
- let selTools = [ idx |
- (idx, PlacedPiece pos p) <- enumVec $ placedPieces st
- , or [wsel && isWrench p, not wsel && isHook p] ]
- drawMainGameState selTools False alerts st
- lb <- isJust <$> gets leftButtonDown
- rb <- isJust <$> gets leftButtonDown
- when isTut $ do
- centre <- gets dispCentre
- sequence_
- [ registerSelectable (pos -^ centre) 0 $
- if isWrench p then SelToolWrench else SelToolHook
- | PlacedPiece pos p <- Vector.toList $ placedPieces st
- , not $ lb || rb
- , isTool p
- ]
- registerUndoButtons canUndo canRedo
+ canUndo <- null <$> gets psGameStateMoveStack
+ canRedo <- null <$> gets psUndoneStack
+ lift $ do
+ let selTools = [ idx |
+ (idx, PlacedPiece pos p) <- enumVec $ placedPieces st
+ , or [wsel && isWrench p, not wsel && isHook p] ]
+ drawMainGameState selTools False alerts st
+ lb <- isJust <$> gets leftButtonDown
+ rb <- isJust <$> gets leftButtonDown
+ when isTut $ do
+ centre <- gets dispCentre
+ sequence_
+ [ registerSelectable (pos -^ centre) 0 $
+ if isWrench p then SelToolWrench else SelToolHook
+ | PlacedPiece pos p <- Vector.toList $ placedPieces st
+ , not $ lb || rb
+ , isTool p
+ ]
+ registerUndoButtons canUndo canRedo
registerButton (periphery 0) CmdOpen (if solved then 2 else 0) $
[("open", hu+^neg hw)] ++ if solved && isTut
then [("Click-->",9*^neg hu)]
else []
- drawMainState' (ReplayState { rsCurrentState=st, rsLastAlerts=alerts } ) = do
- canUndo <- null <$> gets rsGameStateMoveStack
- canRedo <- null <$> gets rsMoveStack
- lift $ do
- drawMainGameState [] False alerts st
- registerUndoButtons canUndo canRedo
- renderToMain $ drawCursorAt Nothing
- drawMainState' (EditState { esGameStateStack=(st:sts), esUndoneStack=undostack,
- selectedPiece=selPiece, selectedPos=selPos }) = lift $ do
- drawMainGameState (maybeToList selPiece) True [] st
- renderToMain $ drawCursorAt $ if isNothing selPiece then Just selPos else Nothing
- registerUndoButtons (null sts) (null undostack)
- when (isJust selPiece) $ mapM_ registerButtonGroup
- [ singleButton (periphery 2 +^ 3*^hw+^hv) CmdDelete 0 [("delete",hu+^neg hw)]
- , singleButton (periphery 2 +^ 3*^hw) CmdMerge 1 [("merge",hu+^neg hw)]
- ]
- sequence_
- [ when (null . filter (pred . placedPiece) . Vector.toList $ placedPieces st)
- $ registerButton (periphery 0 +^ d) cmd 2 [("place",hu+^neg hw),(tool,hu+^neg hv)]
- | (pred,tool,cmd,d) <- [
- (isWrench, "wrench", CmdTile $ WrenchTile zero, (-4)*^hv +^ hw),
- (isHook, "hook", CmdTile $ HookTile, (-3)*^hv +^ hw) ] ]
- drawPaintButtons
- drawMainState' (MetaState {curServer=saddr, undeclareds=undecls,
- cacheOnly=cOnly, curAuth=auth, codenameStack=names,
- randomCodenames=rnamestvar, retiredLocks=mretired, curLockPath=path,
- curLock=mlock, listOffset=offset, asyncCount=count}) = do
- let ourName = authUser <$> auth
- let selName = listToMaybe names
- let home = isJust ourName && ourName == selName
- lift $ renderToMain $ (erase >> drawCursorAt Nothing)
- lift $ do
- smallFont <- gets dispFontSmall
- renderToMain $ withFont smallFont $ renderStrColAtLeft purple
- (saddrStr saddr ++ if cOnly then " (offline mode)" else "")
- $ serverPos +^ hu
-
- when (length names > 1) $ lift $ registerButton
- (codenamePos +^ neg hu +^ 2*^hw) CmdBackCodename 0 [("back",3*^hw)]
-
- runMaybeT $ do
- name <- MaybeT (return selName)
- FetchedRecord fresh err muirc <- lift $ getUInfoFetched 300 name
- pending <- ((>0) <$>) $ liftIO $ atomically $ readTVar count
- lift $ do
- lift $ do
- unless ((fresh && not pending) || cOnly) $ do
- smallFont <- gets dispFontSmall
- let str = if pending then "(response pending)" else "(updating)"
- renderToMain $ withFont smallFont $
- renderStrColBelow (opaquify $ dim errorCol) str $ codenamePos
- maybe (return ()) (setMsgLineNoRefresh errorCol) err
- when (fresh && (isNothing ourName || isNothing muirc || home)) $
- let reg = isNothing muirc || isJust ourName
- in registerButton (codenamePos +^ 2*^hu)
- (if reg then CmdRegister $ isJust ourName else CmdAuth)
- (if isNothing ourName then 2 else 0)
- [(if reg then "reg" else "auth", 3*^hw)]
- (if isJust muirc then drawName else drawNullName) name codenamePos
- lift $ registerSelectable codenamePos 0 (SelSelectedCodeName name)
- drawRelScore name (codenamePos+^hu)
- when (isJust muirc) $ lift $
- registerButton retiredPos CmdShowRetired 5 [("retired",hu+^neg hw)]
- for_ muirc $ \(RCUserInfo (_,uinfo)) -> case mretired of
- Just retired -> do
- fillArea locksPos
- (map (locksPos+^) $ zero:[rotate n $ 4*^hu-^4*^hw | n <- [0,2,3,5]])
- [ \pos -> (lift $ registerSelectable pos 1 (SelOldLock ls)) >> drawOldLock ls pos
- | ls <- retired ]
- lift $ registerButton (retiredPos +^ hv) (CmdPlayLockSpec Nothing) 1 [("play",hu+^neg hw),("no.",hu+^neg hv)]
- Nothing -> do
- sequence_ [ drawLockInfo (ActiveLock (codename uinfo) i) mlockinfo |
- (i,mlockinfo) <- assocs $ userLocks uinfo ]
- when (isJust $ msum $ elems $ userLocks uinfo) $ lift $ do
- registerButton interactButtonsPos (CmdSolve Nothing) 2 [("solve",hu+^neg hw),("lock",hu+^neg hv)]
+ drawMainState' (ReplayState { rsCurrentState=st, rsLastAlerts=alerts } ) = do
+ canUndo <- null <$> gets rsGameStateMoveStack
+ canRedo <- null <$> gets rsMoveStack
+ lift $ do
+ drawMainGameState [] False alerts st
+ registerUndoButtons canUndo canRedo
+ renderToMain $ drawCursorAt Nothing
+ drawMainState' (EditState { esGameStateStack=(st:sts), esUndoneStack=undostack,
+ selectedPiece=selPiece, selectedPos=selPos }) = lift $ do
+ drawMainGameState (maybeToList selPiece) True [] st
+ renderToMain $ drawCursorAt $ if isNothing selPiece then Just selPos else Nothing
+ registerUndoButtons (null sts) (null undostack)
+ when (isJust selPiece) $ mapM_ registerButtonGroup
+ [ singleButton (periphery 2 +^ 3*^hw+^hv) CmdDelete 0 [("delete",hu+^neg hw)]
+ , singleButton (periphery 2 +^ 3*^hw) CmdMerge 1 [("merge",hu+^neg hw)]
+ ]
+ sequence_
+ [ when (null . filter (pred . placedPiece) . Vector.toList $ placedPieces st)
+ $ registerButton (periphery 0 +^ d) cmd 2 [("place",hu+^neg hw),(tool,hu+^neg hv)]
+ | (pred,tool,cmd,d) <- [
+ (isWrench, "wrench", CmdTile $ WrenchTile zero, (-4)*^hv +^ hw),
+ (isHook, "hook", CmdTile $ HookTile, (-3)*^hv +^ hw) ] ]
+ drawPaintButtons
+ drawMainState' (MetaState {curServer=saddr, undeclareds=undecls,
+ cacheOnly=cOnly, curAuth=auth, codenameStack=names,
+ randomCodenames=rnamestvar, retiredLocks=mretired, curLockPath=path,
+ curLock=mlock, listOffset=offset, asyncCount=count}) = do
+ let ourName = authUser <$> auth
+ let selName = listToMaybe names
+ let home = isJust ourName && ourName == selName
+ lift $ renderToMain $ (erase >> drawCursorAt Nothing)
+ lift $ do
+ smallFont <- gets dispFontSmall
+ renderToMain $ withFont smallFont $ renderStrColAtLeft purple
+ (saddrStr saddr ++ if cOnly then " (offline mode)" else "")
+ $ serverPos +^ hu
+
+ when (length names > 1) $ lift $ registerButton
+ (codenamePos +^ neg hu +^ 2*^hw) CmdBackCodename 0 [("back",3*^hw)]
+
+ runMaybeT $ do
+ name <- MaybeT (return selName)
+ FetchedRecord fresh err muirc <- lift $ getUInfoFetched 300 name
+ pending <- ((>0) <$>) $ liftIO $ atomically $ readTVar count
+ lift $ do
+ lift $ do
+ unless ((fresh && not pending) || cOnly) $ do
+ smallFont <- gets dispFontSmall
+ let str = if pending then "(response pending)" else "(updating)"
+ renderToMain $ withFont smallFont $
+ renderStrColBelow (opaquify $ dim errorCol) str $ codenamePos
+ maybe (return ()) (setMsgLineNoRefresh errorCol) err
+ when (fresh && (isNothing ourName || isNothing muirc || home)) $
+ let reg = isNothing muirc || isJust ourName
+ in registerButton (codenamePos +^ 2*^hu)
+ (if reg then CmdRegister $ isJust ourName else CmdAuth)
+ (if isNothing ourName then 2 else 0)
+ [(if reg then "reg" else "auth", 3*^hw)]
+ (if isJust muirc then drawName else drawNullName) name codenamePos
+ lift $ registerSelectable codenamePos 0 (SelSelectedCodeName name)
+ drawRelScore name (codenamePos+^hu)
+ when (isJust muirc) $ lift $
+ registerButton retiredPos CmdShowRetired 5 [("retired",hu+^neg hw)]
+ for_ muirc $ \(RCUserInfo (_,uinfo)) -> case mretired of
+ Just retired -> do
+ fillArea locksPos
+ (map (locksPos+^) $ zero:[rotate n $ 4*^hu-^4*^hw | n <- [0,2,3,5]])
+ [ \pos -> (lift $ registerSelectable pos 1 (SelOldLock ls)) >> drawOldLock ls pos
+ | ls <- retired ]
+ lift $ registerButton (retiredPos +^ hv) (CmdPlayLockSpec Nothing) 1 [("play",hu+^neg hw),("no.",hu+^neg hv)]
+ Nothing -> do
+ sequence_ [ drawLockInfo (ActiveLock (codename uinfo) i) mlockinfo |
+ (i,mlockinfo) <- assocs $ userLocks uinfo ]
+ when (isJust $ msum $ elems $ userLocks uinfo) $ lift $ do
+ registerButton interactButtonsPos (CmdSolve Nothing) 2 [("solve",hu+^neg hw),("lock",hu+^neg hv)]
when (isJust ourName) $
registerButton (interactButtonsPos+^hw) (CmdViewSolution Nothing) 1 [("view",hu+^neg hw),("soln",hu+^neg hv)]
- when home $ do
- lift.renderToMain $ renderStrColAt messageCol
- "Home" (codenamePos+^hw+^neg hv)
- unless (null undecls) $ do
- lift.renderToMain $ renderStrColAtLeft messageCol "Undeclared:" (undeclsPos+^2*^hv+^neg hu)
- lift $ registerButton (undeclsPos+^hw+^neg hu) (CmdDeclare Nothing) 2 [("decl",hv+^4*^neg hu),("soln",hw+^4*^neg hu)]
- fillArea (undeclsPos+^hv)
- (map (undeclsPos+^) $ hexDisc 1 ++ [hu+^neg hw, neg hu+^hv])
- [ \pos -> (lift $ registerSelectable pos 0 (SelUndeclared undecl)) >> drawActiveLock al pos
- | undecl@(Undeclared _ _ al) <- undecls ]
- lift $ do
- maybe (drawEmptyMiniLock miniLockPos)
- (\lock -> drawMiniLock lock miniLockPos)
- (fst<$>mlock)
- registerSelectable miniLockPos 1 SelOurLock
- registerButton (miniLockPos+^3*^neg hw+^2*^hu) CmdEdit 2
- [("edit",hu+^neg hw),("lock",hu+^neg hv)]
- registerButton lockLinePos CmdSelectLock 1 []
- lift $ when (not $ null path) $ do
- renderToMain $ renderStrColAtLeft messageCol (take 16 path) $ lockLinePos +^ hu
- registerSelectable (lockLinePos +^ 2*^hu) 1 SelLockPath
- sequence_
- [ registerButton (miniLockPos +^ 2*^neg hv +^ 2*^hu +^ dv) cmd 1
- [(dirText,hu+^neg hw),("lock",hu+^neg hv)]
- | (dv,cmd,dirText) <- [(zero,CmdPrevLock,"prev"),(neg hw,CmdNextLock,"next")] ]
- let tested = maybe False (isJust.snd) mlock
- when (isJust mlock && home) $ lift $ registerButton
- (miniLockPos+^2*^neg hw+^3*^hu) (CmdPlaceLock Nothing)
- (if tested then 2 else 1)
- [("place",hu+^neg hw),("lock",hu+^neg hv)]
- rnames <- liftIO $ atomically $ readTVar rnamestvar
- unless (null rnames) $
- fillArea randomNamesPos
- (map (randomNamesPos+^) $ hexDisc 2)
- [ \pos -> (lift $ registerSelectable pos 0 (SelRandom name)) >> drawName name pos
- | name <- rnames ]
-
- when (ourName /= selName) $ void $ runMaybeT $ do
- when (isJust ourName) $
- lift.lift $ registerButton (codenamePos +^ hw +^ neg hv) CmdHome 1 [("home",3*^hw)]
- sel <- liftMaybe selName
- us <- liftMaybe ourName
- ourUInfo <- mgetUInfo us
- selUInfo <- mgetUInfo sel
- let accesses = map (uncurry getAccessInfo) [(ourUInfo,selUInfo),(selUInfo,ourUInfo)]
- let posLeft = scoresPos +^ hw +^ neg hu
- let posRight = posLeft +^ 3*^hu
- size <- snd <$> (lift.lift) getGeom
- lift $ do
- lift.renderToMain $ renderStrColAbove (brightish white) "ESTEEM" $ scoresPos
- lift $ sequence_ [ registerSelectable (scoresPos+^v) 0 SelRelScore | v <- [hv, hv+^hu] ]
- drawRelScore sel scoresPos
- fillArea (posLeft+^hw) (map (posLeft+^) [zero,hw,neg hv])
- [ \pos -> (lift $ registerSelectable pos 0 (SelScoreLock (Just sel) accessed $ ActiveLock us i)) >>
- drawNameWithCharAndCol us white (lockIndexChar i) col pos
- | i <- [0..2]
- , let accessed = accesses !! 0 !! i
- , let col
- | accessed == Just AccessedPub = dim pubColour
- | (maybe False winsPoint) accessed = dim $ scoreColour $ -3
- | otherwise = obscure $ scoreColour 3 ]
- fillArea (posRight+^hw) (map (posRight+^) [zero,hw,neg hv])
- [ \pos -> (lift $ registerSelectable pos 0 (SelScoreLock Nothing accessed $ ActiveLock sel i)) >>
- drawNameWithCharAndCol sel white (lockIndexChar i) col pos
- | i <- [0..2]
- , let accessed = accesses !! 1 !! i
- , let col
- | accessed == Just AccessedPub = obscure pubColour
- | (maybe False winsPoint) accessed = dim $ scoreColour $ 3
- | otherwise = obscure $ scoreColour $ -3 ]
- (posScore,negScore) <- MaybeT $ (snd<$>) <$> getRelScoreDetails sel
- lift.lift $ sequence_
- [ do
- renderToMain $ renderStrColAt (scoreColour score) (sign:show (abs score)) pos
- registerSelectable pos 0 SelRelScoreComponent
- | (sign,score,pos) <-
- [ ('-',-negScore,posLeft+^neg hv+^hw)
- , ('+',posScore,posRight+^neg hv+^hw) ] ]
-
- drawMainState' _ = return ()
+ when home $ do
+ lift.renderToMain $ renderStrColAt messageCol
+ "Home" (codenamePos+^hw+^neg hv)
+ unless (null undecls) $ do
+ lift.renderToMain $ renderStrColAtLeft messageCol "Undeclared:" (undeclsPos+^2*^hv+^neg hu)
+ lift $ registerButton (undeclsPos+^hw+^neg hu) (CmdDeclare Nothing) 2 [("decl",hv+^4*^neg hu),("soln",hw+^4*^neg hu)]
+ fillArea (undeclsPos+^hv)
+ (map (undeclsPos+^) $ hexDisc 1 ++ [hu+^neg hw, neg hu+^hv])
+ [ \pos -> (lift $ registerSelectable pos 0 (SelUndeclared undecl)) >> drawActiveLock al pos
+ | undecl@(Undeclared _ _ al) <- undecls ]
+ lift $ do
+ maybe (drawEmptyMiniLock miniLockPos)
+ (\lock -> drawMiniLock lock miniLockPos)
+ (fst<$>mlock)
+ registerSelectable miniLockPos 1 SelOurLock
+ registerButton (miniLockPos+^3*^neg hw+^2*^hu) CmdEdit 2
+ [("edit",hu+^neg hw),("lock",hu+^neg hv)]
+ registerButton lockLinePos CmdSelectLock 1 []
+ lift $ when (not $ null path) $ do
+ renderToMain $ renderStrColAtLeft messageCol (take 16 path) $ lockLinePos +^ hu
+ registerSelectable (lockLinePos +^ 2*^hu) 1 SelLockPath
+ sequence_
+ [ registerButton (miniLockPos +^ 2*^neg hv +^ 2*^hu +^ dv) cmd 1
+ [(dirText,hu+^neg hw),("lock",hu+^neg hv)]
+ | (dv,cmd,dirText) <- [(zero,CmdPrevLock,"prev"),(neg hw,CmdNextLock,"next")] ]
+ let tested = maybe False (isJust.snd) mlock
+ when (isJust mlock && home) $ lift $ registerButton
+ (miniLockPos+^2*^neg hw+^3*^hu) (CmdPlaceLock Nothing)
+ (if tested then 2 else 1)
+ [("place",hu+^neg hw),("lock",hu+^neg hv)]
+ rnames <- liftIO $ atomically $ readTVar rnamestvar
+ unless (null rnames) $
+ fillArea randomNamesPos
+ (map (randomNamesPos+^) $ hexDisc 2)
+ [ \pos -> (lift $ registerSelectable pos 0 (SelRandom name)) >> drawName name pos
+ | name <- rnames ]
+
+ when (ourName /= selName) $ void $ runMaybeT $ do
+ when (isJust ourName) $
+ lift.lift $ registerButton (codenamePos +^ hw +^ neg hv) CmdHome 1 [("home",3*^hw)]
+ sel <- liftMaybe selName
+ us <- liftMaybe ourName
+ ourUInfo <- mgetUInfo us
+ selUInfo <- mgetUInfo sel
+ let accesses = map (uncurry getAccessInfo) [(ourUInfo,selUInfo),(selUInfo,ourUInfo)]
+ let posLeft = scoresPos +^ hw +^ neg hu
+ let posRight = posLeft +^ 3*^hu
+ size <- snd <$> (lift.lift) getGeom
+ lift $ do
+ lift.renderToMain $ renderStrColAbove (brightish white) "ESTEEM" $ scoresPos
+ lift $ sequence_ [ registerSelectable (scoresPos+^v) 0 SelRelScore | v <- [hv, hv+^hu] ]
+ drawRelScore sel scoresPos
+ fillArea (posLeft+^hw) (map (posLeft+^) [zero,hw,neg hv])
+ [ \pos -> (lift $ registerSelectable pos 0 (SelScoreLock (Just sel) accessed $ ActiveLock us i)) >>
+ drawNameWithCharAndCol us white (lockIndexChar i) col pos
+ | i <- [0..2]
+ , let accessed = accesses !! 0 !! i
+ , let col
+ | accessed == Just AccessedPub = dim pubColour
+ | (maybe False winsPoint) accessed = dim $ scoreColour $ -3
+ | otherwise = obscure $ scoreColour 3 ]
+ fillArea (posRight+^hw) (map (posRight+^) [zero,hw,neg hv])
+ [ \pos -> (lift $ registerSelectable pos 0 (SelScoreLock Nothing accessed $ ActiveLock sel i)) >>
+ drawNameWithCharAndCol sel white (lockIndexChar i) col pos
+ | i <- [0..2]
+ , let accessed = accesses !! 1 !! i
+ , let col
+ | accessed == Just AccessedPub = obscure pubColour
+ | (maybe False winsPoint) accessed = dim $ scoreColour $ 3
+ | otherwise = obscure $ scoreColour $ -3 ]
+ (posScore,negScore) <- MaybeT $ (snd<$>) <$> getRelScoreDetails sel
+ lift.lift $ sequence_
+ [ do
+ renderToMain $ renderStrColAt (scoreColour score) (sign:show (abs score)) pos
+ registerSelectable pos 0 SelRelScoreComponent
+ | (sign,score,pos) <-
+ [ ('-',-negScore,posLeft+^neg hv+^hw)
+ , ('+',posScore,posRight+^neg hv+^hw) ] ]
+
+ drawMainState' _ = return ()
drawMessage = say
drawPrompt full s = say $ s ++ (if full then "" else "_")
@@ -277,328 +277,328 @@ instance UIMonad (StateT UIState IO) where
, ch /= '\0' ]
setUIBinding mode cmd ch =
- modify $ \s -> s { uiKeyBindings =
- Map.insertWith (\[bdg] -> \bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs)
- mode [(ch,cmd)] $ uiKeyBindings s }
+ modify $ \s -> s { uiKeyBindings =
+ Map.insertWith (\[bdg] -> \bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs)
+ mode [(ch,cmd)] $ uiKeyBindings s }
getUIBinding mode cmd = ($cmd) <$> getBindingStr mode
initUI = liftM isJust (runMaybeT $ do
- catchIOErrorMT $ SDL.init
+ catchIOErrorMT $ SDL.init
#ifdef SOUND
[InitVideo,InitAudio]
#else
[InitVideo]
#endif
- catchIOErrorMT TTF.init
- lift $ do
- readUIConfigFile
- initVideo 0 0
- liftIO $ initMisc
- w <- gets scrWidth
- h <- gets scrHeight
- liftIO $ warpMouse (fi $ w`div`2) (fi $ h`div`2)
- renderToMain $ erase
- initAudio
- readBindings
- )
- where
- catchIOErrorMT m = MaybeT $ liftIO $ catchIO (m >> return (Just ())) (\_ -> return Nothing)
+ catchIOErrorMT TTF.init
+ lift $ do
+ readUIConfigFile
+ initVideo 0 0
+ liftIO $ initMisc
+ w <- gets scrWidth
+ h <- gets scrHeight
+ liftIO $ warpMouse (fi $ w`div`2) (fi $ h`div`2)
+ renderToMain $ erase
+ initAudio
+ readBindings
+ )
+ where
+ catchIOErrorMT m = MaybeT $ liftIO $ catchIO (m >> return (Just ())) (\_ -> return Nothing)
endUI = do
- writeUIConfigFile
- writeBindings
- liftIO $ quit
+ writeUIConfigFile
+ writeBindings
+ liftIO $ quit
unblockInput = return $ pushEvent VideoExpose
suspend = return ()
redraw = return ()
impatience ticks = do
- liftIO $ threadDelay 50000
- if (ticks>20) then do
- let pos = serverWaitPos
- smallFont <- gets dispFontSmall
- renderToMain $ do
- mapM (drawAtRel (FilledHexGlyph $ bright black)) [ pos +^ i*^hu | i <- [0..3] ]
- withFont smallFont $
- renderStrColAtLeft errorCol ("waiting..."++replicate ((ticks`div`5)`mod`3) '.') $ pos
- clearButtons
- registerButton (pos +^ neg hv) CmdQuit 0 [("abort",hu+^neg hw)]
- drawButtons IMImpatience
- refresh
- cmds <- getInput IMImpatience
- return $ CmdQuit `elem` cmds
- else return False
+ liftIO $ threadDelay 50000
+ if (ticks>20) then do
+ let pos = serverWaitPos
+ smallFont <- gets dispFontSmall
+ renderToMain $ do
+ mapM (drawAtRel (FilledHexGlyph $ bright black)) [ pos +^ i*^hu | i <- [0..3] ]
+ withFont smallFont $
+ renderStrColAtLeft errorCol ("waiting..."++replicate ((ticks`div`5)`mod`3) '.') $ pos
+ clearButtons
+ registerButton (pos +^ neg hv) CmdQuit 0 [("abort",hu+^neg hw)]
+ drawButtons IMImpatience
+ refresh
+ cmds <- getInput IMImpatience
+ return $ CmdQuit `elem` cmds
+ else return False
warpPointer pos = do
- (scrCentre, size) <- getGeom
- centre <- gets dispCentre
- let SVec x y = hexVec2SVec size (pos-^centre) +^ scrCentre
- liftIO $ warpMouse (fi x) (fi y)
- lbp <- gets leftButtonDown
- rbp <- gets rightButtonDown
- let [lbp',rbp'] = fmap (fmap (\_ -> (pos-^centre))) [lbp,rbp]
- modify $ \s -> s {leftButtonDown = lbp', rightButtonDown = rbp'}
+ (scrCentre, size) <- getGeom
+ centre <- gets dispCentre
+ let SVec x y = hexVec2SVec size (pos-^centre) +^ scrCentre
+ liftIO $ warpMouse (fi x) (fi y)
+ lbp <- gets leftButtonDown
+ rbp <- gets rightButtonDown
+ let [lbp',rbp'] = fmap (fmap (\_ -> (pos-^centre))) [lbp,rbp]
+ modify $ \s -> s {leftButtonDown = lbp', rightButtonDown = rbp'}
getUIMousePos = do
- centre <- gets dispCentre
- (Just.(+^centre).fst) <$> gets mousePos
+ centre <- gets dispCentre
+ (Just.(+^centre).fst) <$> gets mousePos
setYNButtons = do
- clearButtons
- registerButton (periphery 5 +^ hw) (CmdInputChar 'Y') 2 []
- registerButton (periphery 5 +^ neg hv) (CmdInputChar 'N') 0 []
- drawButtons IMTextInput
- refresh
+ clearButtons
+ registerButton (periphery 5 +^ hw) (CmdInputChar 'Y') 2 []
+ registerButton (periphery 5 +^ neg hv) (CmdInputChar 'N') 0 []
+ drawButtons IMTextInput
+ refresh
toggleColourMode = modify $ \s -> s {uiOptions = (uiOptions s){
useFiveColouring = not $ useFiveColouring $ uiOptions s}}
getInput mode = do
- fps <- gets fps
- events <- liftIO $ nubMouseMotions <$> getEventsTimeout (10^6`div`fps)
- (cmds,uiChanged) <- if null events then return ([],False) else do
- oldUIState <- get
- cmds <- concat <$> mapM processEvent events
- setPaintFromCmds cmds
- newUIState <- get
- return (cmds,uistatesMayVisiblyDiffer oldUIState newUIState)
- now <- liftIO getTicks
- animFrameReady <- maybe False (<now) <$> gets nextAnimFrameAt
- return $ cmds ++ if uiChanged || animFrameReady then [CmdRefresh] else []
- where
- nubMouseMotions evs =
- -- drop all but last mouse motion event
- let nubMouseMotions' False (mm@(MouseMotion {}):evs) = mm:(nubMouseMotions' True evs)
- nubMouseMotions' True (mm@(MouseMotion {}):evs) = nubMouseMotions' True evs
- nubMouseMotions' b (ev:evs) = ev:(nubMouseMotions' b evs)
- nubMouseMotions' _ [] = []
- in reverse $ nubMouseMotions' False $ reverse evs
- setPaintFromCmds cmds = sequence_
- [ modify $ \s -> s { paintTileIndex = pti }
- | (pti,pt) <- zip [0..] paintTiles
- , cmd <- cmds
- , (isNothing pt && cmd == CmdDelete) ||
- (isJust $ do
- pt' <- pt
- CmdTile t <- Just cmd
- guard $ ((==)`on`tileType) t pt') ]
-
- uistatesMayVisiblyDiffer uis1 uis2 =
- uis1 { mousePos = (zero,False), lastFrameTicks=0 }
- /= uis2 {mousePos = (zero,False), lastFrameTicks=0 }
- processEvent (KeyDown (Keysym _ _ ch)) = case mode of
- IMTextInput -> return [CmdInputChar ch]
- _ -> do
- setting <- gets settingBinding
- if isJust setting && ch /= '\0'
- then do
- modify $ \s -> s {settingBinding = Nothing}
- when (ch /= '\ESC') $ setUIBinding mode (fromJust setting) ch
- return []
- else do
- uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings
- let mCmd = lookup ch $ uibdgs ++ bindings mode
- return $ maybeToList mCmd
- processEvent (MouseMotion {}) = do
- (oldMPos,_) <- gets mousePos
- (pos@(mPos,_),(sx,sy,sz)) <- getMousePos
- updateMousePos mode pos
- lbp <- gets leftButtonDown
- rbp <- gets rightButtonDown
- centre <- gets dispCentre
- let drag :: Maybe HexVec -> Maybe Command
- drag bp = do
- fromPos@(HexVec x y z) <- bp
- -- check we've dragged at least a full hex's distance:
- guard $ not.all (\(a,b) -> abs ((fi a) - b) < 1.0) $ [(x,sx),(y,sy),(z,sz)]
- let dir = hexVec2HexDirOrZero $ mPos -^ fromPos
- guard $ dir /= zero
- return $ CmdDrag (fromPos+^centre) dir
- case mode of
- IMEdit -> case drag rbp of
- Just cmd -> return [cmd]
- Nothing -> if mPos /= oldMPos
- then do
- pti <- getEffPaintTileIndex
- return $ [ CmdMoveTo $ mPos +^ centre ] ++
- (if isJust lbp then [ CmdPaintFromTo (paintTiles!!pti) (oldMPos+^centre) (mPos+^centre) ] else [])
- else return []
- IMPlay -> return $ maybeToList $ msum $ map drag [lbp, rbp]
- _ -> return []
- where
- mouseFromTo from to = do
- let dir = hexVec2HexDirOrZero $ to -^ from
- if dir /= zero
- then (CmdDir WHSSelected dir:) <$> mouseFromTo (from +^ dir) to
- else return []
- processEvent (MouseButtonDown _ _ ButtonLeft) = do
- pos@(mPos,central) <- gets mousePos
- modify $ \s -> s { leftButtonDown = Just mPos }
- rb <- isJust <$> gets rightButtonDown
- mcmd <- cmdAtMousePos pos mode (Just False)
- let hotspotAction = listToMaybe
- $ map (\cmd -> return [cmd]) (maybeToList mcmd)
- ++ [ (modify $ \s -> s {paintTileIndex = i}) >> return []
- | i <- take (length paintTiles) [0..]
- , mPos == paintButtonStart +^ i*^hv ]
- ++ [ toggleUIOption uiOB1 >> updateHoverStr mode >> return []
- | mPos == uiOptPos uiOB1 && mode `elem` uiOptModes uiOB1 ]
- ++ [ toggleUIOption uiOB2 >> updateHoverStr mode >> return []
- | mPos == uiOptPos uiOB2 && mode `elem` uiOptModes uiOB2 ]
- ++ [ toggleUIOption uiOB3 >> updateHoverStr mode >> return []
- | mPos == uiOptPos uiOB3 && mode `elem` uiOptModes uiOB3 ]
- ++ [ toggleUIOption uiOB4 >> updateHoverStr mode >> return []
- | mPos == uiOptPos uiOB4 && mode `elem` uiOptModes uiOB4 ]
- ++ [ toggleUIOption uiOB5 >> updateHoverStr mode >> return []
- | mPos == uiOptPos uiOB5 && mode `elem` uiOptModes uiOB5 ]
+ fps <- gets fps
+ events <- liftIO $ nubMouseMotions <$> getEventsTimeout (10^6`div`fps)
+ (cmds,uiChanged) <- if null events then return ([],False) else do
+ oldUIState <- get
+ cmds <- concat <$> mapM processEvent events
+ setPaintFromCmds cmds
+ newUIState <- get
+ return (cmds,uistatesMayVisiblyDiffer oldUIState newUIState)
+ now <- liftIO getTicks
+ animFrameReady <- maybe False (<now) <$> gets nextAnimFrameAt
+ return $ cmds ++ if uiChanged || animFrameReady then [CmdRefresh] else []
+ where
+ nubMouseMotions evs =
+ -- drop all but last mouse motion event
+ let nubMouseMotions' False (mm@(MouseMotion {}):evs) = mm:(nubMouseMotions' True evs)
+ nubMouseMotions' True (mm@(MouseMotion {}):evs) = nubMouseMotions' True evs
+ nubMouseMotions' b (ev:evs) = ev:(nubMouseMotions' b evs)
+ nubMouseMotions' _ [] = []
+ in reverse $ nubMouseMotions' False $ reverse evs
+ setPaintFromCmds cmds = sequence_
+ [ modify $ \s -> s { paintTileIndex = pti }
+ | (pti,pt) <- zip [0..] paintTiles
+ , cmd <- cmds
+ , (isNothing pt && cmd == CmdDelete) ||
+ (isJust $ do
+ pt' <- pt
+ CmdTile t <- Just cmd
+ guard $ ((==)`on`tileType) t pt') ]
+
+ uistatesMayVisiblyDiffer uis1 uis2 =
+ uis1 { mousePos = (zero,False), lastFrameTicks=0 }
+ /= uis2 {mousePos = (zero,False), lastFrameTicks=0 }
+ processEvent (KeyDown (Keysym _ _ ch)) = case mode of
+ IMTextInput -> return [CmdInputChar ch]
+ _ -> do
+ setting <- gets settingBinding
+ if isJust setting && ch /= '\0'
+ then do
+ modify $ \s -> s {settingBinding = Nothing}
+ when (ch /= '\ESC') $ setUIBinding mode (fromJust setting) ch
+ return []
+ else do
+ uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings
+ let mCmd = lookup ch $ uibdgs ++ bindings mode
+ return $ maybeToList mCmd
+ processEvent (MouseMotion {}) = do
+ (oldMPos,_) <- gets mousePos
+ (pos@(mPos,_),(sx,sy,sz)) <- getMousePos
+ updateMousePos mode pos
+ lbp <- gets leftButtonDown
+ rbp <- gets rightButtonDown
+ centre <- gets dispCentre
+ let drag :: Maybe HexVec -> Maybe Command
+ drag bp = do
+ fromPos@(HexVec x y z) <- bp
+ -- check we've dragged at least a full hex's distance:
+ guard $ not.all (\(a,b) -> abs ((fi a) - b) < 1.0) $ [(x,sx),(y,sy),(z,sz)]
+ let dir = hexVec2HexDirOrZero $ mPos -^ fromPos
+ guard $ dir /= zero
+ return $ CmdDrag (fromPos+^centre) dir
+ case mode of
+ IMEdit -> case drag rbp of
+ Just cmd -> return [cmd]
+ Nothing -> if mPos /= oldMPos
+ then do
+ pti <- getEffPaintTileIndex
+ return $ [ CmdMoveTo $ mPos +^ centre ] ++
+ (if isJust lbp then [ CmdPaintFromTo (paintTiles!!pti) (oldMPos+^centre) (mPos+^centre) ] else [])
+ else return []
+ IMPlay -> return $ maybeToList $ msum $ map drag [lbp, rbp]
+ _ -> return []
+ where
+ mouseFromTo from to = do
+ let dir = hexVec2HexDirOrZero $ to -^ from
+ if dir /= zero
+ then (CmdDir WHSSelected dir:) <$> mouseFromTo (from +^ dir) to
+ else return []
+ processEvent (MouseButtonDown _ _ ButtonLeft) = do
+ pos@(mPos,central) <- gets mousePos
+ modify $ \s -> s { leftButtonDown = Just mPos }
+ rb <- isJust <$> gets rightButtonDown
+ mcmd <- cmdAtMousePos pos mode (Just False)
+ let hotspotAction = listToMaybe
+ $ map (\cmd -> return [cmd]) (maybeToList mcmd)
+ ++ [ (modify $ \s -> s {paintTileIndex = i}) >> return []
+ | i <- take (length paintTiles) [0..]
+ , mPos == paintButtonStart +^ i*^hv ]
+ ++ [ toggleUIOption uiOB1 >> updateHoverStr mode >> return []
+ | mPos == uiOptPos uiOB1 && mode `elem` uiOptModes uiOB1 ]
+ ++ [ toggleUIOption uiOB2 >> updateHoverStr mode >> return []
+ | mPos == uiOptPos uiOB2 && mode `elem` uiOptModes uiOB2 ]
+ ++ [ toggleUIOption uiOB3 >> updateHoverStr mode >> return []
+ | mPos == uiOptPos uiOB3 && mode `elem` uiOptModes uiOB3 ]
+ ++ [ toggleUIOption uiOB4 >> updateHoverStr mode >> return []
+ | mPos == uiOptPos uiOB4 && mode `elem` uiOptModes uiOB4 ]
+ ++ [ toggleUIOption uiOB5 >> updateHoverStr mode >> return []
+ | mPos == uiOptPos uiOB5 && mode `elem` uiOptModes uiOB5 ]
#ifdef SOUND
- ++ [ toggleUIOption uiOB6 >> updateHoverStr mode >> return []
- | mPos == uiOptPos uiOB6 && mode `elem` uiOptModes uiOB6 ]
+ ++ [ toggleUIOption uiOB6 >> updateHoverStr mode >> return []
+ | mPos == uiOptPos uiOB6 && mode `elem` uiOptModes uiOB6 ]
#endif
- if rb
- then return [ CmdWait ]
- else flip fromMaybe hotspotAction $ case mode of
- IMEdit -> do
- pti <- getEffPaintTileIndex
- return $ [ drawCmd (paintTiles!!pti) False ]
- IMPlay -> do
- centre <- gets dispCentre
- return $ [ CmdManipulateToolAt $ mPos +^ centre ]
- _ -> return []
- processEvent (MouseButtonUp _ _ ButtonLeft) = do
- modify $ \s -> s { leftButtonDown = Nothing }
- return []
- processEvent (MouseButtonDown _ _ ButtonRight) = do
- pos@(mPos,_) <- gets mousePos
- modify $ \s -> s { rightButtonDown = Just mPos }
- lb <- isJust <$> gets leftButtonDown
- if lb
- then return [ CmdWait ]
- else (fromMaybe [] <$>) $ runMaybeT $ msum
- [ do
- cmd <- MaybeT $ cmdAtMousePos pos mode Nothing
- guard $ mode /= IMTextInput
- -- modify $ \s -> s { settingBinding = Just cmd }
- return [ CmdBind $ Just cmd ]
- , do
- cmd <- MaybeT $ cmdAtMousePos pos mode (Just True)
- return [cmd]
- , case mode of
- IMPlay -> return [ CmdClear, CmdWait ]
- _ -> return [ CmdClear, CmdSelect ] ]
- processEvent (MouseButtonUp _ _ ButtonRight) = do
- modify $ \s -> s { rightButtonDown = Nothing }
- return [ CmdUnselect ]
- processEvent (MouseButtonDown _ _ ButtonWheelUp) = doWheel 1
- processEvent (MouseButtonDown _ _ ButtonWheelDown) = doWheel $ -1
- processEvent (MouseButtonDown _ _ ButtonMiddle) = do
- (mPos,_) <- gets mousePos
- modify $ \s -> s { middleButtonDown = Just mPos }
- rb <- isJust <$> gets rightButtonDown
- return $ if rb then [ CmdDelete ] else []
- processEvent (MouseButtonUp _ _ ButtonMiddle) = do
- modify $ \s -> s { middleButtonDown = Nothing }
- return []
- processEvent (VideoResize w h) = do
- initVideo w h
- return [ CmdRedraw ]
- processEvent VideoExpose = return [ CmdRefresh ]
- processEvent Quit = return [ CmdForceQuit ]
-
- processEvent _ = return []
-
- doWheel dw = do
- rb <- isJust <$> gets rightButtonDown
- mb <- isJust <$> gets middleButtonDown
- if ((rb || mb || mode == IMReplay) && mode /= IMEdit)
- || (mb && mode == IMEdit)
- then return [ if dw == 1 then CmdRedo else CmdUndo ]
- else if mode /= IMEdit || rb
- then return [ CmdRotate WHSSelected dw ]
- else do
- modify $ \s -> s { paintTileIndex = (paintTileIndex s + dw) `mod` (length paintTiles) }
- return []
-
-
- drawCmd mt True = CmdPaint mt
- drawCmd (Just t) False = CmdTile t
- drawCmd Nothing _ = CmdDelete
-
- getMousePos :: UIM ((HexVec,Bool),(Double,Double,Double))
- getMousePos = do
- (scrCentre, size) <- getGeom
- (x,y,_) <- lift getMouseState
- let sv = (SVec (fi x) (fi y)) +^ neg scrCentre
- let mPos@(HexVec x y z) = sVec2HexVec size sv
- let (sx,sy,sz) = sVec2dHV size sv
- let isCentral = all (\(a,b) -> abs ((fi a) - b) < 0.5) $
- [(x,sx),(y,sy),(z,sz)]
- return ((mPos,isCentral),(sx,sy,sz))
- updateMousePos mode newPos = do
- oldPos <- gets mousePos
- when (newPos /= oldPos) $ do
- modify $ \ds -> ds { mousePos = newPos }
- updateHoverStr mode
+ if rb
+ then return [ CmdWait ]
+ else flip fromMaybe hotspotAction $ case mode of
+ IMEdit -> do
+ pti <- getEffPaintTileIndex
+ return $ [ drawCmd (paintTiles!!pti) False ]
+ IMPlay -> do
+ centre <- gets dispCentre
+ return $ [ CmdManipulateToolAt $ mPos +^ centre ]
+ _ -> return []
+ processEvent (MouseButtonUp _ _ ButtonLeft) = do
+ modify $ \s -> s { leftButtonDown = Nothing }
+ return []
+ processEvent (MouseButtonDown _ _ ButtonRight) = do
+ pos@(mPos,_) <- gets mousePos
+ modify $ \s -> s { rightButtonDown = Just mPos }
+ lb <- isJust <$> gets leftButtonDown
+ if lb
+ then return [ CmdWait ]
+ else (fromMaybe [] <$>) $ runMaybeT $ msum
+ [ do
+ cmd <- MaybeT $ cmdAtMousePos pos mode Nothing
+ guard $ mode /= IMTextInput
+ -- modify $ \s -> s { settingBinding = Just cmd }
+ return [ CmdBind $ Just cmd ]
+ , do
+ cmd <- MaybeT $ cmdAtMousePos pos mode (Just True)
+ return [cmd]
+ , case mode of
+ IMPlay -> return [ CmdClear, CmdWait ]
+ _ -> return [ CmdClear, CmdSelect ] ]
+ processEvent (MouseButtonUp _ _ ButtonRight) = do
+ modify $ \s -> s { rightButtonDown = Nothing }
+ return [ CmdUnselect ]
+ processEvent (MouseButtonDown _ _ ButtonWheelUp) = doWheel 1
+ processEvent (MouseButtonDown _ _ ButtonWheelDown) = doWheel $ -1
+ processEvent (MouseButtonDown _ _ ButtonMiddle) = do
+ (mPos,_) <- gets mousePos
+ modify $ \s -> s { middleButtonDown = Just mPos }
+ rb <- isJust <$> gets rightButtonDown
+ return $ if rb then [ CmdDelete ] else []
+ processEvent (MouseButtonUp _ _ ButtonMiddle) = do
+ modify $ \s -> s { middleButtonDown = Nothing }
+ return []
+ processEvent (VideoResize w h) = do
+ initVideo w h
+ return [ CmdRedraw ]
+ processEvent VideoExpose = return [ CmdRefresh ]
+ processEvent Quit = return [ CmdForceQuit ]
+
+ processEvent _ = return []
+
+ doWheel dw = do
+ rb <- isJust <$> gets rightButtonDown
+ mb <- isJust <$> gets middleButtonDown
+ if ((rb || mb || mode == IMReplay) && mode /= IMEdit)
+ || (mb && mode == IMEdit)
+ then return [ if dw == 1 then CmdRedo else CmdUndo ]
+ else if mode /= IMEdit || rb
+ then return [ CmdRotate WHSSelected dw ]
+ else do
+ modify $ \s -> s { paintTileIndex = (paintTileIndex s + dw) `mod` (length paintTiles) }
+ return []
+
+
+ drawCmd mt True = CmdPaint mt
+ drawCmd (Just t) False = CmdTile t
+ drawCmd Nothing _ = CmdDelete
+
+ getMousePos :: UIM ((HexVec,Bool),(Double,Double,Double))
+ getMousePos = do
+ (scrCentre, size) <- getGeom
+ (x,y,_) <- lift getMouseState
+ let sv = (SVec (fi x) (fi y)) +^ neg scrCentre
+ let mPos@(HexVec x y z) = sVec2HexVec size sv
+ let (sx,sy,sz) = sVec2dHV size sv
+ let isCentral = all (\(a,b) -> abs ((fi a) - b) < 0.5) $
+ [(x,sx),(y,sy),(z,sz)]
+ return ((mPos,isCentral),(sx,sy,sz))
+ updateMousePos mode newPos = do
+ oldPos <- gets mousePos
+ when (newPos /= oldPos) $ do
+ modify $ \ds -> ds { mousePos = newPos }
+ updateHoverStr mode
showHelp mode HelpPageInput = do
- bdgs <- nub <$> getBindings mode
- smallFont <- gets dispFontSmall
- renderToMain $ do
- erase
- let bdgWidth = (screenWidthHexes-6) `div` 3
- showKeys chs = intercalate "/" (map showKeyFriendly chs)
- maxkeyslen = maximum . (0:) $ map (length.showKeys.map fst) $ groupBy ((==) `on` snd) bdgs
- extraHelpStrs = [["Mouse commands:", "Right-click on a button to set a keybinding;"]
- ++ case mode of
- IMPlay -> ["Click on tool to select, drag to move;",
- "Click by tool to move; right-click to wait;", "Scroll wheel to rotate hook;",
- "Scroll wheel with right button held down to undo/redo."]
- IMEdit -> ["Left-click to draw selected; scroll to change selection;",
- "Right-click on piece to select, drag to move;",
- "While holding right-click: left-click to advance time, middle-click to delete;",
- "Scroll wheel to rotate selected piece; scroll wheel while held down to undo/redo."]
- IMReplay -> ["Scroll wheel with right button held down to undo/redo."]
- IMMeta -> ["Left-clicking on something does most obvious thing;"
- , "Right-clicking does second-most obvious thing."]]
- ++ case mode of
- IMMeta -> [[
- "Basic game instructions:"
- , "Choose [C]odename, then [R]egister it;"
- , "select other players, and [S]olve their locks;"
- , "go [H]ome, then [E]dit and [P]lace a lock of your own;"
- , "you can then [D]eclare your solutions."
- , "Make other players green by solving their locks and not letting them solve yours."]]
- _ -> []
- renderStrColAt cyan "Keybindings:" $ (screenHeightHexes`div`4)*^(hv+^neg hw)
- let keybindingsHeight = screenHeightHexes - (3 + length extraHelpStrs + sum (map length extraHelpStrs))
- sequence_ [ with $ renderStrColAtLeft messageCol
- ( keysStr ++ ": " ++ desc )
- $ (x*bdgWidth-(screenWidthHexes-6)`div`2)*^hu +^ neg hv +^
- (screenHeightHexes`div`4 - y`div`2)*^(hv+^neg hw) +^
- (y`mod`2)*^hw
- | ((keysStr,with,desc),(x,y)) <- zip [(keysStr,with,desc)
- | group <- groupBy ((==) `on` snd) $ sortBy (compare `on` snd) bdgs
- , let cmd = snd $ head group
- , let desc = describeCommand cmd
- , not $ null desc
- , let chs = map fst group
- , let keysStr = showKeys chs
- , let with = if True -- 3*(bdgWidth-1) < length desc + length keysStr + 1
- then withFont smallFont
- else id
- ]
- (map (`divMod` keybindingsHeight) [0..])
- , (x+1)*bdgWidth < screenWidthHexes]
- sequence_ [ renderStrColAt (if firstLine then cyan else messageCol) str
- $ (screenHeightHexes`div`4 - y`div`2)*^(hv+^neg hw)
- +^ hw
- +^ (y`mod`2)*^hw
- | ((str,firstLine),y) <- (intercalate [("",False)] $ (map (`zip` (True:repeat False)) extraHelpStrs)) `zip` [(keybindingsHeight+1)..] ]
- refresh
- return True
+ bdgs <- nub <$> getBindings mode
+ smallFont <- gets dispFontSmall
+ renderToMain $ do
+ erase
+ let bdgWidth = (screenWidthHexes-6) `div` 3
+ showKeys chs = intercalate "/" (map showKeyFriendly chs)
+ maxkeyslen = maximum . (0:) $ map (length.showKeys.map fst) $ groupBy ((==) `on` snd) bdgs
+ extraHelpStrs = [["Mouse commands:", "Right-click on a button to set a keybinding;"]
+ ++ case mode of
+ IMPlay -> ["Click on tool to select, drag to move;",
+ "Click by tool to move; right-click to wait;", "Scroll wheel to rotate hook;",
+ "Scroll wheel with right button held down to undo/redo."]
+ IMEdit -> ["Left-click to draw selected; scroll to change selection;",
+ "Right-click on piece to select, drag to move;",
+ "While holding right-click: left-click to advance time, middle-click to delete;",
+ "Scroll wheel to rotate selected piece; scroll wheel while held down to undo/redo."]
+ IMReplay -> ["Scroll wheel with right button held down to undo/redo."]
+ IMMeta -> ["Left-clicking on something does most obvious thing;"
+ , "Right-clicking does second-most obvious thing."]]
+ ++ case mode of
+ IMMeta -> [[
+ "Basic game instructions:"
+ , "Choose [C]odename, then [R]egister it;"
+ , "select other players, and [S]olve their locks;"
+ , "go [H]ome, then [E]dit and [P]lace a lock of your own;"
+ , "you can then [D]eclare your solutions."
+ , "Make other players green by solving their locks and not letting them solve yours."]]
+ _ -> []
+ renderStrColAt cyan "Keybindings:" $ (screenHeightHexes`div`4)*^(hv+^neg hw)
+ let keybindingsHeight = screenHeightHexes - (3 + length extraHelpStrs + sum (map length extraHelpStrs))
+ sequence_ [ with $ renderStrColAtLeft messageCol
+ ( keysStr ++ ": " ++ desc )
+ $ (x*bdgWidth-(screenWidthHexes-6)`div`2)*^hu +^ neg hv +^
+ (screenHeightHexes`div`4 - y`div`2)*^(hv+^neg hw) +^
+ (y`mod`2)*^hw
+ | ((keysStr,with,desc),(x,y)) <- zip [(keysStr,with,desc)
+ | group <- groupBy ((==) `on` snd) $ sortBy (compare `on` snd) bdgs
+ , let cmd = snd $ head group
+ , let desc = describeCommand cmd
+ , not $ null desc
+ , let chs = map fst group
+ , let keysStr = showKeys chs
+ , let with = if True -- 3*(bdgWidth-1) < length desc + length keysStr + 1
+ then withFont smallFont
+ else id
+ ]
+ (map (`divMod` keybindingsHeight) [0..])
+ , (x+1)*bdgWidth < screenWidthHexes]
+ sequence_ [ renderStrColAt (if firstLine then cyan else messageCol) str
+ $ (screenHeightHexes`div`4 - y`div`2)*^(hv+^neg hw)
+ +^ hw
+ +^ (y`mod`2)*^hw
+ | ((str,firstLine),y) <- (intercalate [("",False)] $ (map (`zip` (True:repeat False)) extraHelpStrs)) `zip` [(keybindingsHeight+1)..] ]
+ refresh
+ return True
showHelp IMMeta HelpPageGame = do
renderToMain $ drawBasicHelpPage ("INTRICACY",red) (metagameHelpText,purple)
return True
@@ -624,30 +624,30 @@ 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 ]
+ 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 _ = []
+ shortMouseHelp IMPlay =
+ [ "LMB: select/move tool"
+ , "LMB+drag: move tool"
+ , "Wheel: turn hook"
+ , "RMB: wait a turn"
+ , "RMB+Wheel: undo/redo"
+ ]
+ shortMouseHelp IMEdit =
+ [ "LMB: paint; Ctrl+LMB: delete"
+ , "Wheel: set paint type"
+ , "RMB: select piece; drag to move"
+ , "RMB+LMB: wait; RMB+MMB: delete piece"
+ , "MMB+Wheel: undo/redo"
+ ]
+ shortMouseHelp IMReplay =
+ [ "Wheel: advance/regress time" ]
+ shortMouseHelp _ = []
-- waitEvent' : copy of SDL.Events.waitEvent, with the timeout increased
-- drastically to reduce CPU load when idling.
@@ -674,55 +674,55 @@ updateHoverStr mode = do
p@(mPos,isCentral) <- gets mousePos
showBT <- showButtonText <$> gets uiOptions
hstr <- runMaybeT $ msum
- [ MaybeT ( cmdAtMousePos p mode Nothing ) >>= lift . describeCommandAndKeys
- , guard showBT >> MaybeT (helpAtMousePos p mode)
- , guard (showBT && mode == IMEdit) >> msum
- [ return $ "set paint mode: " ++ describeCommand (paintTileCmds!!i)
- | i <- take (length paintTiles) [0..]
- , mPos == paintButtonStart +^ i*^hv ]
- , guard (mPos == uiOptPos uiOB1 && mode `elem` uiOptModes uiOB1) >> describeUIOptionButton uiOB1
- , guard (mPos == uiOptPos uiOB2 && mode `elem` uiOptModes uiOB2) >> describeUIOptionButton uiOB2
- , guard (mPos == uiOptPos uiOB3 && mode `elem` uiOptModes uiOB3) >> describeUIOptionButton uiOB3
- , guard (mPos == uiOptPos uiOB4 && mode `elem` uiOptModes uiOB4) >> describeUIOptionButton uiOB4
- , guard (mPos == uiOptPos uiOB5 && mode `elem` uiOptModes uiOB5) >> describeUIOptionButton uiOB5
+ [ MaybeT ( cmdAtMousePos p mode Nothing ) >>= lift . describeCommandAndKeys
+ , guard showBT >> MaybeT (helpAtMousePos p mode)
+ , guard (showBT && mode == IMEdit) >> msum
+ [ return $ "set paint mode: " ++ describeCommand (paintTileCmds!!i)
+ | i <- take (length paintTiles) [0..]
+ , mPos == paintButtonStart +^ i*^hv ]
+ , guard (mPos == uiOptPos uiOB1 && mode `elem` uiOptModes uiOB1) >> describeUIOptionButton uiOB1
+ , guard (mPos == uiOptPos uiOB2 && mode `elem` uiOptModes uiOB2) >> describeUIOptionButton uiOB2
+ , guard (mPos == uiOptPos uiOB3 && mode `elem` uiOptModes uiOB3) >> describeUIOptionButton uiOB3
+ , guard (mPos == uiOptPos uiOB4 && mode `elem` uiOptModes uiOB4) >> describeUIOptionButton uiOB4
+ , guard (mPos == uiOptPos uiOB5 && mode `elem` uiOptModes uiOB5) >> describeUIOptionButton uiOB5
#ifdef SOUND
- , guard (mPos == uiOptPos uiOB6 && mode `elem` uiOptModes uiOB6) >> describeUIOptionButton uiOB6
+ , guard (mPos == uiOptPos uiOB6 && mode `elem` uiOptModes uiOB6) >> describeUIOptionButton uiOB6
#endif
- ]
+ ]
modify $ \ds -> ds { hoverStr = hstr }
where
- describeCommandAndKeys :: Command -> UIM String
- describeCommandAndKeys cmd = do
- uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings
- return $ describeCommand cmd ++ " ["
- ++ concat (intersperse ","
- (map showKeyFriendly $ findBindings (uibdgs ++ bindings mode) cmd))
- ++ "]"
+ describeCommandAndKeys :: Command -> UIM String
+ describeCommandAndKeys cmd = do
+ uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings
+ return $ describeCommand cmd ++ " ["
+ ++ concat (intersperse ","
+ (map showKeyFriendly $ findBindings (uibdgs ++ bindings mode) cmd))
+ ++ "]"
fillArea :: HexVec -> [HexVec] -> [HexVec -> MainStateT UIM ()] -> MainStateT UIM ()
fillArea centre area draws = do
offset <- gets listOffset
let na = length area
- listButton cmd = \pos -> lift $ registerButton pos cmd 3 []
- draws' = if offset > 0 && length draws > na
- then listButton CmdPrevPage :
- drop (max 0 $ min (length draws - (na-1)) (na-1 + (na-2)*(offset-1))) draws
- else draws
- selDraws = if length draws' > na
- then take (na-1) draws' ++ [listButton CmdNextPage]
- else take na draws'
+ listButton cmd = \pos -> lift $ registerButton pos cmd 3 []
+ draws' = if offset > 0 && length draws > na
+ then listButton CmdPrevPage :
+ drop (max 0 $ min (length draws - (na-1)) (na-1 + (na-2)*(offset-1))) draws
+ else draws
+ selDraws = if length draws' > na
+ then take (na-1) draws' ++ [listButton CmdNextPage]
+ else take na draws'
sequence_ $ map (uncurry ($)) $
- zip selDraws $ sortBy (compare `on` hexVec2SVec 37) $
- take (length selDraws) $ sortBy
- (compare `on` (hexLen . (-^centre)))
- area
+ zip selDraws $ sortBy (compare `on` hexVec2SVec 37) $
+ take (length selDraws) $ sortBy
+ (compare `on` (hexLen . (-^centre)))
+ area
drawOldLock ls pos = void.runMaybeT $ msum [ do
- lock <- mgetLock ls
- lift.lift $ drawMiniLock lock pos
+ lock <- mgetLock ls
+ lift.lift $ drawMiniLock lock pos
, lift.lift.renderToMain $
- renderStrColAt messageCol (show ls) pos
+ renderStrColAt messageCol (show ls) pos
]
@@ -730,16 +730,16 @@ drawName name pos = nameCol name >>= drawNameCol name pos
drawNullName name pos = drawNameCol name pos $ invisible white
drawNameCol name pos col = do
lift.renderToMain $ do
- drawAtRel (playerGlyph col) pos
- renderStrColAt buttonTextCol name pos
+ drawAtRel (playerGlyph col) pos
+ renderStrColAt buttonTextCol name pos
drawRelScore name pos = do
col <- nameCol name
relScore <- getRelScore name
flip (maybe (return ())) relScore $ \score ->
- lift $ do
- renderToMain $ renderStrColAt col
- ((if score > 0 then "+" else "") ++ show score) pos
- registerSelectable pos 0 SelRelScore
+ lift $ do
+ renderToMain $ renderStrColAt col
+ ((if score > 0 then "+" else "") ++ show score) pos
+ registerSelectable pos 0 SelRelScore
drawNote note pos = case noteBehind note of
Just al -> drawActiveLock al pos
@@ -747,8 +747,8 @@ drawNote note pos = case noteBehind note of
drawActiveLock al@(ActiveLock name i) pos = do
accessed <- accessedAL al
drawNameWithChar name
- (if accessed then accColour else white)
- (lockIndexChar i) pos
+ (if accessed then accColour else white)
+ (lockIndexChar i) pos
drawPublicNote name =
drawNameWithChar name pubColour 'P'
drawNameWithChar name charcol char pos = do
@@ -761,11 +761,11 @@ drawNameWithCharAndCol name charcol char col pos = do
let down = FVec 0 $ ylen
smallFont <- lift $ gets dispFontSmall
lift.renderToMain $ do
- drawAtRel (playerGlyph col) pos
- displaceRender up $
- renderStrColAt buttonTextCol name pos
- displaceRender down $ withFont smallFont $
- renderStrColAt charcol [char] pos
+ drawAtRel (playerGlyph col) pos
+ displaceRender up $
+ renderStrColAt buttonTextCol name pos
+ displaceRender down $ withFont smallFont $
+ renderStrColAt charcol [char] pos
pubWheelAngle = 5
pubColour = colourWheel pubWheelAngle -- ==purple
accColour = cyan
@@ -773,17 +773,17 @@ nameCol name = do
ourName <- (authUser <$>) <$> gets curAuth
relScore <- getRelScore name
return $ dim $ case relScore of
- Nothing -> Pixel $ if ourName == Just name then 0xc0c0c000 else 0x80808000
- Just score -> scoreColour score
+ Nothing -> Pixel $ if ourName == Just name then 0xc0c0c000 else 0x80808000
+ Just score -> scoreColour score
scoreColour :: Int -> Pixel
scoreColour score = Pixel $ case score of
- 0 -> 0x80800000
- 1 -> 0x70a00000
- 2 -> 0x40c00000
- 3 -> 0x00ff0000
- (-1) -> 0xa0700000
- (-2) -> 0xc0400000
- (-3) -> 0xff000000
+ 0 -> 0x80800000
+ 1 -> 0x70a00000
+ 2 -> 0x40c00000
+ 3 -> 0x00ff0000
+ (-1) -> 0xa0700000
+ (-2) -> 0xc0400000
+ (-3) -> 0xff000000
drawLockInfo :: ActiveLock -> Maybe LockInfo -> MainStateT UIM ()
drawLockInfo al@(ActiveLock name idx) Nothing = do
@@ -799,72 +799,72 @@ drawLockInfo al@(ActiveLock name idx) (Just lockinfo) = do
let notesPos = centre +^ 3*^(hw +^ neg hv)
ourName <- (authUser <$>) <$> gets curAuth
runMaybeT $ msum [
- do
- lock <- mgetLock $ lockSpec lockinfo
- lift.lift $ do
- drawMiniLock lock centre
- registerSelectable centre 3 $ SelLock al
- , lift $ do
- drawActiveLock al centre
- lift $ registerSelectable centre 3 $ SelLock al
- ]
+ do
+ lock <- mgetLock $ lockSpec lockinfo
+ lift.lift $ do
+ drawMiniLock lock centre
+ registerSelectable centre 3 $ SelLock al
+ , lift $ do
+ drawActiveLock al centre
+ lift $ registerSelectable centre 3 $ SelLock al
+ ]
size <- snd <$> lift getGeom
lift $ do
- renderToMain $ displaceRender (FVec 1 0) $ renderStrColAt (brightish white) "UNLOCKED BY" $ accessedByPos +^ hv
- registerSelectable (accessedByPos +^ hv) 0 SelPrivyHeader
- registerSelectable (accessedByPos +^ hv +^ hu) 0 SelPrivyHeader
+ renderToMain $ displaceRender (FVec 1 0) $ renderStrColAt (brightish white) "UNLOCKED BY" $ accessedByPos +^ hv
+ registerSelectable (accessedByPos +^ hv) 0 SelPrivyHeader
+ registerSelectable (accessedByPos +^ hv +^ hu) 0 SelPrivyHeader
if public lockinfo
then lift $ do
- renderToMain $ renderStrColAt pubColour "All" accessedByPos
- registerSelectable accessedByPos 1 SelPublicLock
+ renderToMain $ renderStrColAt pubColour "All" accessedByPos
+ registerSelectable accessedByPos 1 SelPublicLock
else if null $ accessedBy lockinfo
- then lift.renderToMain $ renderStrColAt dimWhiteCol "No-one" accessedByPos
- else fillArea accessedByPos
- [ accessedByPos +^ d | j <- [0..2], i <- [-2..3]
- , i-j > -4, i-j < 3
- , let d = j*^hw +^ i*^hu ]
- $ [ \pos -> (lift $ registerSelectable pos 0 (SelSolution note)) >> drawNote note pos
- | note <- lockSolutions lockinfo ] ++
- [ \pos -> (lift $ registerSelectable pos 0 (SelAccessed name)) >> drawName name pos
- | name <- accessedBy lockinfo \\ map noteAuthor (lockSolutions lockinfo) ]
+ then lift.renderToMain $ renderStrColAt dimWhiteCol "No-one" accessedByPos
+ else fillArea accessedByPos
+ [ accessedByPos +^ d | j <- [0..2], i <- [-2..3]
+ , i-j > -4, i-j < 3
+ , let d = j*^hw +^ i*^hu ]
+ $ [ \pos -> (lift $ registerSelectable pos 0 (SelSolution note)) >> drawNote note pos
+ | note <- lockSolutions lockinfo ] ++
+ [ \pos -> (lift $ registerSelectable pos 0 (SelAccessed name)) >> drawName name pos
+ | name <- accessedBy lockinfo \\ map noteAuthor (lockSolutions lockinfo) ]
undecls <- gets undeclareds
case if isJust $ guard . (|| public lockinfo) . (`elem` map noteAuthor (lockSolutions lockinfo)) =<< ourName
- then if public lockinfo
- then Just (pubColour,"Accessed!",AccessedPublic)
- else Just (accColour, "Solved!",AccessedSolved)
- else if any (\(Undeclared _ ls _) -> ls == lockSpec lockinfo) undecls
- then Just (yellow, "Undeclared",AccessedUndeclared)
- else Nothing
- of
- Just (col,str,selstr) -> lift $ do
- renderToMain $ renderStrColAt col str accessedPos
- registerSelectable accessedPos 1 (SelAccessedInfo selstr)
- Nothing -> do
- read <- take 3 <$> getNotesReadOn lockinfo
- unless (ourName == Just name) $ do
- let readPos = accessedPos +^ (-3)*^hu
- lift.renderToMain $ renderStrColAt (if length read == 3 then accColour else dimWhiteCol)
- "Read:" $ readPos
- when (length read == 3) $ lift $ registerSelectable readPos 0 (SelAccessedInfo AccessedReadNotes)
- fillArea (accessedPos+^neg hu) [ accessedPos +^ i*^hu | i <- [-1..1] ]
- $ take 3 $ [ \pos -> (lift $ registerSelectable pos 0 (SelReadNote note)) >> drawNote note pos
- | note <- read ] ++ (repeat $ \pos -> (lift $ registerSelectable pos 0 SelReadNoteSlot >>
- renderToMain (drawAtRel (HollowGlyph $ dim green) pos)))
+ then if public lockinfo
+ then Just (pubColour,"Accessed!",AccessedPublic)
+ else Just (accColour, "Solved!",AccessedSolved)
+ else if any (\(Undeclared _ ls _) -> ls == lockSpec lockinfo) undecls
+ then Just (yellow, "Undeclared",AccessedUndeclared)
+ else Nothing
+ of
+ Just (col,str,selstr) -> lift $ do
+ renderToMain $ renderStrColAt col str accessedPos
+ registerSelectable accessedPos 1 (SelAccessedInfo selstr)
+ Nothing -> do
+ read <- take 3 <$> getNotesReadOn lockinfo
+ unless (ourName == Just name) $ do
+ let readPos = accessedPos +^ (-3)*^hu
+ lift.renderToMain $ renderStrColAt (if length read == 3 then accColour else dimWhiteCol)
+ "Read:" $ readPos
+ when (length read == 3) $ lift $ registerSelectable readPos 0 (SelAccessedInfo AccessedReadNotes)
+ fillArea (accessedPos+^neg hu) [ accessedPos +^ i*^hu | i <- [-1..1] ]
+ $ take 3 $ [ \pos -> (lift $ registerSelectable pos 0 (SelReadNote note)) >> drawNote note pos
+ | note <- read ] ++ (repeat $ \pos -> (lift $ registerSelectable pos 0 SelReadNoteSlot >>
+ renderToMain (drawAtRel (HollowGlyph $ dim green) pos)))
lift $ do
- renderToMain $ displaceRender (FVec 1 0) $ renderStrColAt (brightish white) "SECURING" $ notesPos +^ hv
- registerSelectable (notesPos +^ hv) 0 SelNotesHeader
- registerSelectable (notesPos +^ hv +^ hu) 0 SelNotesHeader
+ renderToMain $ displaceRender (FVec 1 0) $ renderStrColAt (brightish white) "SECURING" $ notesPos +^ hv
+ registerSelectable (notesPos +^ hv) 0 SelNotesHeader
+ registerSelectable (notesPos +^ hv +^ hu) 0 SelNotesHeader
if null $ notesSecured lockinfo
- then lift.renderToMain $ renderStrColAt dimWhiteCol "None" notesPos
- else fillArea notesPos
- [ notesPos +^ d | j <- [0..2], i <- [-2..3]
- , i-j > -4, i-j < 3
- , let d = j*^hw +^ i*^hu ]
- [ \pos -> (lift $ registerSelectable pos 0 (SelSecured note)) >> drawActiveLock (noteOn note) pos
- | note <- notesSecured lockinfo ]
+ then lift.renderToMain $ renderStrColAt dimWhiteCol "None" notesPos
+ else fillArea notesPos
+ [ notesPos +^ d | j <- [0..2], i <- [-2..3]
+ , i-j > -4, i-j < 3
+ , let d = j*^hw +^ i*^hu ]
+ [ \pos -> (lift $ registerSelectable pos 0 (SelSecured note)) >> drawActiveLock (noteOn note) pos
+ | note <- notesSecured lockinfo ]
drawBasicHelpPage :: (String,Pixel) -> ([String],Pixel) -> RenderM ()
drawBasicHelpPage (title,titleCol) (body,bodyCol) = do
diff --git a/Server.hs b/Server.hs
index cac0c9e..af62483 100644
--- a/Server.hs
+++ b/Server.hs
@@ -47,7 +47,7 @@ import qualified Pipes.Prelude as P
import Text.Feed.Import (parseFeedFromFile)
import Text.Feed.Export (xmlFeed)
import Text.Feed.Constructor
-import Text.XML.Light.Output (showTopElement)
+import qualified Text.XML as XML
import Data.Time.Format
import Data.Time.LocalTime
@@ -95,8 +95,8 @@ usage = usageInfo header options
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))
+ (o,n,[]) -> return (o,n)
+ (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
where header = "Usage: intricacy-server [OPTION...]"
main = do
@@ -110,15 +110,15 @@ main = do
when (Help `elem` opts) $ putStr usage >> exitSuccess
when (Version `elem` opts) $ putStrLn version >> exitSuccess
let delay = fromMaybe 0 $ listToMaybe [ d | RequestDelay d <- opts ]
- port = fromMaybe defaultPort $ listToMaybe [ p | Port p <- opts ]
- dbpath = fromMaybe "intricacydb" $ listToMaybe [ p | DBDir p <- opts ]
- mfeedPath = listToMaybe [ p | FeedPath p <- opts ]
- locksize = min maxlocksize $ fromMaybe 8 $ listToMaybe [ s | ServerLockSize s <- opts ]
+ port = fromMaybe defaultPort $ listToMaybe [ p | Port p <- opts ]
+ dbpath = fromMaybe "intricacydb" $ listToMaybe [ p | DBDir p <- opts ]
+ mfeedPath = listToMaybe [ p | FeedPath p <- opts ]
+ locksize = min maxlocksize $ fromMaybe 8 $ listToMaybe [ s | ServerLockSize s <- opts ]
withDB dbpath $ setDefaultServerInfo locksize >> setKeyPair
writeFile (lockFilePath dbpath) ""
logh <- case listToMaybe [ f | LogFile f <- opts ] of
- Nothing -> return stdout
- Just path -> openFile path AppendMode
+ Nothing -> return stdout
+ Just path -> openFile path AppendMode
streamServer serverSpec{address = IPv4 "" port, threading=Threaded} $ handler dbpath delay logh mfeedPath
sleepForever
@@ -147,8 +147,8 @@ withDBLock dbpath lockMode m = do
liftIO $ hClose h
return ret
where
- getDBLock lockMode =
- catchIO (openFile (lockFilePath dbpath) lockMode) (\_ -> threadDelay (50*10^3) >> getDBLock lockMode)
+ getDBLock lockMode =
+ catchIO (openFile (lockFilePath dbpath) lockMode) (\_ -> threadDelay (50*10^3) >> getDBLock lockMode)
lockFilePath dbpath = dbpath ++ [pathSeparator] ++ "lockfile"
@@ -158,22 +158,22 @@ handler :: FilePath -> Int -> Handle -> Maybe FilePath -> Handle -> Address -> I
handler dbpath delay logh mfeedPath 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 <$> BL.hGetContents hdl
- let hostname = case addr of
- IP n _ -> n
- IPv4 n _ -> n
- IPv6 n _ -> n
- Unix path -> path
- hashedHostname = take 8 $ hash hostname
- now <- liftIO getCurrentTime
- logit logh $ show now ++ ": " ++ hashedHostname ++ " >>> " ++ showRequest request
- response <- handleRequest dbpath mfeedPath request
- when (delay > 0) $ threadDelay delay
- now' <- liftIO getCurrentTime
- logit logh $ show now' ++ ": " ++ hashedHostname ++ " <<< " ++ showResponse response
- return response
- BL.hPut hdl $ B.encode response
+ response <- handle (\e -> return $ ServerError $ show (e::SomeException)) $ do
+ request <- B.decode <$> BL.hGetContents hdl
+ let hostname = case addr of
+ IP n _ -> n
+ IPv4 n _ -> n
+ IPv6 n _ -> n
+ Unix path -> path
+ hashedHostname = take 8 $ hash hostname
+ now <- liftIO getCurrentTime
+ logit logh $ show now ++ ": " ++ hashedHostname ++ " >>> " ++ showRequest request
+ response <- handleRequest dbpath mfeedPath request
+ when (delay > 0) $ threadDelay delay
+ now' <- liftIO getCurrentTime
+ logit logh $ show now' ++ ": " ++ hashedHostname ++ " <<< " ++ showResponse response
+ return response
+ BL.hPut hdl $ B.encode response
showRequest :: ClientRequest -> String
showRequest (ClientRequest ver mauth act) = show ver ++ " "
@@ -194,194 +194,194 @@ showResponse resp = show resp
handleRequest :: FilePath -> Maybe FilePath -> ClientRequest -> IO ServerResponse
handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
let lockMode = case action of
- Authenticate -> ReadMode
- GetServerInfo -> ReadMode
- GetPublicKey -> ReadMode
- GetLock _ -> ReadMode
- GetUserInfo _ _ -> ReadMode
- GetRetired _ -> ReadMode
- GetSolution _ -> ReadMode
- GetRandomNames _ -> ReadMode
- _ -> ReadWriteMode
+ Authenticate -> ReadMode
+ GetServerInfo -> ReadMode
+ GetPublicKey -> ReadMode
+ GetLock _ -> ReadMode
+ GetUserInfo _ _ -> ReadMode
+ GetRetired _ -> ReadMode
+ GetSolution _ -> ReadMode
+ GetRandomNames _ -> ReadMode
+ _ -> ReadWriteMode
-- check solutions prior to write-locking database:
(withDBLock dbpath ReadMode $ runExceptT checkRequest) >>=
- either (return . ServerError) (const $
- withDBLock dbpath lockMode $ runExceptT handleRequest' >>=
- either (return . ServerError) return)
+ either (return . ServerError) (const $
+ withDBLock dbpath lockMode $ runExceptT handleRequest' >>=
+ either (return . ServerError) return)
where
- checkRequest = do
- when (pv /= protocolVersion) $ throwE "Bad protocol version"
- case action of
- DeclareSolution soln ls target idx -> do
- info <- getUserInfoOfAuth auth
- lock <- getLock ls
- tinfo <- getALock target
- when (ls /= lockSpec tinfo) $ throwE "Lock no longer in use!"
- when (public tinfo) $ throwE "Lock solution already public knowledge!"
- let name = codename info
- let behind = ActiveLock name idx
- when (name `elem` map noteAuthor (lockSolutions tinfo)) $
- throwE "Note already taken on that lock!"
- when (name == lockOwner target) $
- throwE "That's your lock!"
- behindLock <- getALock behind
- when (public behindLock) $ throwE "Your lock is cracked!"
- unless (checkSolution lock soln) $ throwE "Bad solution"
- SetLock lock@(frame,_) idx soln -> do
- ServerInfo serverSize _ <- getServerInfo
- when (frame /= BasicFrame serverSize) $ throwE $
- "Server only accepts size "++show serverSize++" locks."
- unless (validLock $ reframe lock) $ throwE "Invalid lock!"
- unless (not.checkSolved $ reframe lock) $ throwE "Lock not locked!"
- RCLockHashes hashes <- getRecordErrored RecLockHashes
- `catchE` const (return (RCLockHashes []))
- let hashed = hash $ show lock
- when (hashed `elem` hashes) $ throwE "Lock has already been used"
- unless (checkSolution lock soln) $ throwE "Bad solution"
- _ -> return ()
- handleRequest' =
- case action of
+ checkRequest = do
+ when (pv /= protocolVersion) $ throwE "Bad protocol version"
+ case action of
+ DeclareSolution soln ls target idx -> do
+ info <- getUserInfoOfAuth auth
+ lock <- getLock ls
+ tinfo <- getALock target
+ when (ls /= lockSpec tinfo) $ throwE "Lock no longer in use!"
+ when (public tinfo) $ throwE "Lock solution already public knowledge!"
+ let name = codename info
+ let behind = ActiveLock name idx
+ when (name `elem` map noteAuthor (lockSolutions tinfo)) $
+ throwE "Note already taken on that lock!"
+ when (name == lockOwner target) $
+ throwE "That's your lock!"
+ behindLock <- getALock behind
+ when (public behindLock) $ throwE "Your lock is cracked!"
+ unless (checkSolution lock soln) $ throwE "Bad solution"
+ SetLock lock@(frame,_) idx soln -> do
+ ServerInfo serverSize _ <- getServerInfo
+ when (frame /= BasicFrame serverSize) $ throwE $
+ "Server only accepts size "++show serverSize++" locks."
+ unless (validLock $ reframe lock) $ throwE "Invalid lock!"
+ unless (not.checkSolved $ reframe lock) $ throwE "Lock not locked!"
+ RCLockHashes hashes <- getRecordErrored RecLockHashes
+ `catchE` const (return (RCLockHashes []))
+ let hashed = hash $ show lock
+ when (hashed `elem` hashes) $ throwE "Lock has already been used"
+ unless (checkSolution lock soln) $ throwE "Bad solution"
+ _ -> return ()
+ handleRequest' =
+ case action of
UndefinedAction -> throwE "Request not recognised by this server"
- Authenticate -> do
- checkAuth auth
- return $ ServerMessage $ "Welcome, " ++ authUser (fromJust auth)
- Register -> do
- newUser auth
- doNews $ "New user " ++ authUser (fromJust auth) ++ " registered."
- return ServerAck
- ResetPassword passwd -> resetPassword auth passwd >> return ServerAck
- SetEmail address -> setEmail auth address >> return ServerAck
- GetServerInfo -> ServedServerInfo <$> getServerInfo
- GetPublicKey -> ServedPublicKey <$> getPublicKey
- GetLock ls -> ServedLock <$> getLock ls
- GetRetired name -> ServedRetired <$> getRetired name
- GetUserInfo name mversion -> (do
- RCUserInfo (curV,info) <- getRecordErrored $ RecUserInfo name
- (fromJust<$>)$ runMaybeT $ msum [ do
- v <- MaybeT $ return mversion
- msum [ guard (v >= curV) >> return ServerFresh
- , do
- guard (v >= curV - 10)
- RCUserInfoDeltas deltas <- lift $ getRecordErrored $ RecUserInfoLog name
- return $ ServedUserInfoDeltas $ take (curV-v) deltas
- ]
- , return $ ServedUserInfo (curV,info)
- ]
- ) `catchE` \_ -> return ServerCodenameFree
- GetSolution note -> do
- uinfo <- getUserInfoOfAuth auth
- let uname = codename uinfo
- onLinfo <- getALock $ noteOn note
- behindMLinfo <- maybe (return Nothing) ((Just<$>).getALock) $ noteBehind note
- if uname == lockOwner (noteOn note)
- || uname == noteAuthor note
- then ServedSolution <$> getSolution note
- else if case behindMLinfo of
- Nothing -> True
- Just behindInfo -> public behindInfo || uname `elem` accessedBy behindInfo
- || note `elem` notesRead uinfo
- then if public onLinfo || uname `elem` accessedBy onLinfo
- then ServedSolution <$> getSolution note
- else throwE "You can't wholly decipher this note - you would need more notes on the same lock."
- else throwE "This note is secured behind a lock you have not opened."
- DeclareSolution soln ls target idx -> do
- info <- getUserInfoOfAuth auth
- let name = codename info
- let behind = ActiveLock name idx
- let note = NoteInfo name (Just behind) target
- erroredDB $ putRecord (RecNote note) (RCSolution soln)
- execStateT (declareNote note behind) [] >>= applyDeltasToRecords
- doNews $ name ++ " declares solution to "
- ++ alockStr target ++ ", securing their note behind "
- ++ alockStr behind ++ "."
- mailDeclaration target behind
- return ServerAck
- SetLock lock@(frame,_) idx soln -> do
- info <- getUserInfoOfAuth auth
- let name = codename info
- let al = ActiveLock name idx
- RCLockHashes hashes <- getRecordErrored RecLockHashes
- `catchE` const (return (RCLockHashes []))
- let hashed = hash $ show lock
- erroredDB $ putRecord RecLockHashes $ RCLockHashes $ hashed:hashes
+ Authenticate -> do
+ checkAuth auth
+ return $ ServerMessage $ "Welcome, " ++ authUser (fromJust auth)
+ Register -> do
+ newUser auth
+ doNews $ "New user " ++ authUser (fromJust auth) ++ " registered."
+ return ServerAck
+ ResetPassword passwd -> resetPassword auth passwd >> return ServerAck
+ SetEmail address -> setEmail auth address >> return ServerAck
+ GetServerInfo -> ServedServerInfo <$> getServerInfo
+ GetPublicKey -> ServedPublicKey <$> getPublicKey
+ GetLock ls -> ServedLock <$> getLock ls
+ GetRetired name -> ServedRetired <$> getRetired name
+ GetUserInfo name mversion -> (do
+ RCUserInfo (curV,info) <- getRecordErrored $ RecUserInfo name
+ (fromJust<$>)$ runMaybeT $ msum [ do
+ v <- MaybeT $ return mversion
+ msum [ guard (v >= curV) >> return ServerFresh
+ , do
+ guard (v >= curV - 10)
+ RCUserInfoDeltas deltas <- lift $ getRecordErrored $ RecUserInfoLog name
+ return $ ServedUserInfoDeltas $ take (curV-v) deltas
+ ]
+ , return $ ServedUserInfo (curV,info)
+ ]
+ ) `catchE` \_ -> return ServerCodenameFree
+ GetSolution note -> do
+ uinfo <- getUserInfoOfAuth auth
+ let uname = codename uinfo
+ onLinfo <- getALock $ noteOn note
+ behindMLinfo <- maybe (return Nothing) ((Just<$>).getALock) $ noteBehind note
+ if uname == lockOwner (noteOn note)
+ || uname == noteAuthor note
+ then ServedSolution <$> getSolution note
+ else if case behindMLinfo of
+ Nothing -> True
+ Just behindInfo -> public behindInfo || uname `elem` accessedBy behindInfo
+ || note `elem` notesRead uinfo
+ then if public onLinfo || uname `elem` accessedBy onLinfo
+ then ServedSolution <$> getSolution note
+ else throwE "You can't wholly decipher this note - you would need more notes on the same lock."
+ else throwE "This note is secured behind a lock you have not opened."
+ DeclareSolution soln ls target idx -> do
+ info <- getUserInfoOfAuth auth
+ let name = codename info
+ let behind = ActiveLock name idx
+ let note = NoteInfo name (Just behind) target
+ erroredDB $ putRecord (RecNote note) (RCSolution soln)
+ execStateT (declareNote note behind) [] >>= applyDeltasToRecords
+ doNews $ name ++ " declares solution to "
+ ++ alockStr target ++ ", securing their note behind "
+ ++ alockStr behind ++ "."
+ mailDeclaration target behind
+ return ServerAck
+ SetLock lock@(frame,_) idx soln -> do
+ info <- getUserInfoOfAuth auth
+ let name = codename info
+ let al = ActiveLock name idx
+ RCLockHashes hashes <- getRecordErrored RecLockHashes
+ `catchE` const (return (RCLockHashes []))
+ let hashed = hash $ show lock
+ erroredDB $ putRecord RecLockHashes $ RCLockHashes $ hashed:hashes
- ls <- erroredDB $ newLockRecord lock
- let oldLockInfo = userLocks info ! idx
- execStateT (do
- when (isJust $ oldLockInfo) $
- lift (getALock al) >>= retireLock
- addDelta name $ PutLock ls idx
- ) [] >>= applyDeltasToRecords
+ ls <- erroredDB $ newLockRecord lock
+ let oldLockInfo = userLocks info ! idx
+ execStateT (do
+ when (isJust $ oldLockInfo) $
+ lift (getALock al) >>= retireLock
+ addDelta name $ PutLock ls idx
+ ) [] >>= applyDeltasToRecords
- for_ oldLockInfo $ \oldui -> do
- lss <- getRetired name
- erroredDB $ putRecord (RecRetiredLocks name) $ RCLockSpecs $ (lockSpec oldui):lss
- doNews $ "New lock " ++ alockStr al ++ "."
- return ServerAck
- GetRandomNames n -> do
- names <- erroredDB $ listUsers
- gen <- erroredIO $ getStdGen
- let l = length names
- namesArray = listArray (0,l-1) names
- negligible name = do
- uinfo <- getUserInfo name
- return $ all (maybe True public . (userLocks uinfo !)) [0..2]
+ for_ oldLockInfo $ \oldui -> do
+ lss <- getRetired name
+ erroredDB $ putRecord (RecRetiredLocks name) $ RCLockSpecs $ (lockSpec oldui):lss
+ doNews $ "New lock " ++ alockStr al ++ "."
+ return ServerAck
+ GetRandomNames n -> do
+ names <- erroredDB $ listUsers
+ gen <- erroredIO $ getStdGen
+ let l = length names
+ namesArray = listArray (0,l-1) names
+ negligible name = do
+ uinfo <- getUserInfo name
+ return $ all (maybe True public . (userLocks uinfo !)) [0..2]
- -- huzzah for pipes!
- shuffled <- P.toListM $
- mapM_ Pipes.yield (nub $ randomRs (0,l-1) gen)
- >-> P.take l -- give up once we've permuted all of [0..l-1]
- >-> P.map (namesArray !)
- >-> P.filterM ((not <$>) . negligible) -- throw away negligibles
- >-> P.take n -- try to take as many as we were asked for
- liftIO newStdGen
- return $ ServedRandomNames shuffled
- _ -> throwE "BUG: bad request"
- erroredIO :: IO a -> ExceptT String IO a
- erroredIO c = do
- ret <- liftIO $ catchIO (Right <$> c) (return.Left)
- case ret of
- Left e -> throwE $ "Server IO error: " ++ show e
- Right x -> return x
- erroredDB :: DBM a -> ExceptT String IO a
- erroredDB = erroredIO . withDB dbpath
- getRecordErrored :: Record -> ExceptT String IO RecordContents
- getRecordErrored rec = do
- mrc <- lift $ withDB dbpath $ getRecord rec
- case mrc of
- Just rc -> return rc
- Nothing -> throwE $ "Bad record on server! Record was: " ++ show rec
- getLock ls = do
- RCLock lock <- getRecordErrored $ RecLock ls
- return lock
- getSolution note = do
- RCSolution soln <- getRecordErrored $ RecNote note
- return soln
- getServerInfo = do
- RCServerInfo sinfo <- getRecordErrored $ RecServerInfo
- return sinfo
- getPublicKey = do
- RCPublicKey publicKey <- getRecordErrored $ RecPublicKey
- return publicKey
- getRetired name = do
- RCLockSpecs lss <- fromMaybe (RCLockSpecs []) <$> (erroredDB $ getRecord $ RecRetiredLocks name)
- return lss
- getALock (ActiveLock name idx) = do
- info <- getUserInfo name
- checkValidLockIndex idx
- case ((!idx).userLocks) info of
- Nothing -> throwE "Lock not set"
- Just lockinfo -> return lockinfo
- checkValidLockIndex idx =
- unless (0<=idx && idx < maxLocks) $ throwE "Bad lock index"
- getUserInfo name = do
- RCUserInfo (version,info) <- getRecordErrored $ RecUserInfo name
- return info
- getUserInfoOfAuth auth = do
- checkAuth auth
- let Just (Auth name _) = auth
- getUserInfo name
+ -- huzzah for pipes!
+ shuffled <- P.toListM $
+ mapM_ Pipes.yield (nub $ randomRs (0,l-1) gen)
+ >-> P.take l -- give up once we've permuted all of [0..l-1]
+ >-> P.map (namesArray !)
+ >-> P.filterM ((not <$>) . negligible) -- throw away negligibles
+ >-> P.take n -- try to take as many as we were asked for
+ liftIO newStdGen
+ return $ ServedRandomNames shuffled
+ _ -> throwE "BUG: bad request"
+ erroredIO :: IO a -> ExceptT String IO a
+ erroredIO c = do
+ ret <- liftIO $ catchIO (Right <$> c) (return.Left)
+ case ret of
+ Left e -> throwE $ "Server IO error: " ++ show e
+ Right x -> return x
+ erroredDB :: DBM a -> ExceptT String IO a
+ erroredDB = erroredIO . withDB dbpath
+ getRecordErrored :: Record -> ExceptT String IO RecordContents
+ getRecordErrored rec = do
+ mrc <- lift $ withDB dbpath $ getRecord rec
+ case mrc of
+ Just rc -> return rc
+ Nothing -> throwE $ "Bad record on server! Record was: " ++ show rec
+ getLock ls = do
+ RCLock lock <- getRecordErrored $ RecLock ls
+ return lock
+ getSolution note = do
+ RCSolution soln <- getRecordErrored $ RecNote note
+ return soln
+ getServerInfo = do
+ RCServerInfo sinfo <- getRecordErrored $ RecServerInfo
+ return sinfo
+ getPublicKey = do
+ RCPublicKey publicKey <- getRecordErrored $ RecPublicKey
+ return publicKey
+ getRetired name = do
+ RCLockSpecs lss <- fromMaybe (RCLockSpecs []) <$> (erroredDB $ getRecord $ RecRetiredLocks name)
+ return lss
+ getALock (ActiveLock name idx) = do
+ info <- getUserInfo name
+ checkValidLockIndex idx
+ case ((!idx).userLocks) info of
+ Nothing -> throwE "Lock not set"
+ Just lockinfo -> return lockinfo
+ checkValidLockIndex idx =
+ unless (0<=idx && idx < maxLocks) $ throwE "Bad lock index"
+ getUserInfo name = do
+ RCUserInfo (version,info) <- getRecordErrored $ RecUserInfo name
+ return info
+ getUserInfoOfAuth auth = do
+ checkAuth auth
+ let Just (Auth name _) = auth
+ getUserInfo name
decryptPassword :: String -> ExceptT String IO String
decryptPassword pw = do
@@ -390,135 +390,139 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
decrypt secretKey . BL.fromStrict . CS.pack $ pw)
-- <=intricacy-0.6.2 sends the hashed password unencrypted
`catch` \(e :: RSAError) -> return pw
- checkAuth :: Maybe Auth -> ExceptT String IO ()
- checkAuth Nothing = throwE "Authentication required"
- checkAuth (Just (Auth name pw)) = do
- exists <- checkCodeName name
- unless exists $ throwE "No such user"
- RCPassword correctPw <- getRecordErrored (RecPassword name)
+ checkAuth :: Maybe Auth -> ExceptT String IO ()
+ checkAuth Nothing = throwE "Authentication required"
+ checkAuth (Just (Auth name pw)) = do
+ exists <- checkCodeName name
+ unless exists $ throwE "No such user"
+ RCPassword correctPw <- getRecordErrored (RecPassword name)
pw' <- decryptPassword pw
when (pw' /= correctPw) $ throwE "Wrong password"
- newUser :: Maybe Auth -> ExceptT String IO ()
- newUser Nothing = throwE "Require authentication"
- newUser (Just (Auth name pw)) = do
- exists <- checkCodeName name
- when exists $ throwE "Codename taken"
+ newUser :: Maybe Auth -> ExceptT String IO ()
+ newUser Nothing = throwE "Require authentication"
+ newUser (Just (Auth name pw)) = do
+ exists <- checkCodeName name
+ when exists $ throwE "Codename taken"
pw' <- decryptPassword pw
- erroredDB $ putRecord (RecPassword name) (RCPassword pw')
- erroredDB $ putRecord (RecUserInfo name) (RCUserInfo $ (1,initUserInfo name))
- erroredDB $ putRecord (RecUserInfoLog name) (RCUserInfoDeltas [])
- resetPassword Nothing _ = throwE "Authentication required"
- resetPassword auth@(Just (Auth name _)) newpw = do
- checkAuth auth
+ erroredDB $ putRecord (RecPassword name) (RCPassword pw')
+ erroredDB $ putRecord (RecUserInfo name) (RCUserInfo $ (1,initUserInfo name))
+ erroredDB $ putRecord (RecUserInfoLog name) (RCUserInfoDeltas [])
+ resetPassword Nothing _ = throwE "Authentication required"
+ resetPassword auth@(Just (Auth name _)) newpw = do
+ checkAuth auth
newpw' <- decryptPassword newpw
- erroredDB $ putRecord (RecPassword name) (RCPassword newpw')
- setEmail Nothing _ = throwE "Authentication required"
- setEmail auth@(Just (Auth name _)) addressStr = do
- checkAuth auth
- serverAddr <- erroredDB $ getRecord RecServerEmail
- when (isNothing serverAddr) $ throwE "This server is not configured to support email notifications."
- let addr = CS.pack addressStr
- when (not $ CS.null addr || Text.Email.Validate.isValid addr) $ throwE "Invalid email address"
- erroredDB $ putRecord (RecEmail name) (RCEmail addr)
- checkCodeName :: Codename -> ExceptT String IO Bool
- checkCodeName name = do
- unless (validCodeName name) $ throwE "Invalid codename"
- liftIO $ withDB dbpath $ recordExists $ RecPassword name
- --- | TODO: journalling so we can survive death during database writes?
- applyDeltasToRecords :: [(Codename, UserInfoDelta)] -> ExceptT String IO ()
- applyDeltasToRecords nds = sequence_ $ [applyDeltasToRecord name deltas
- | group <- groupBy ((==) `on` fst) nds
- , let name = fst $ head group
- , let deltas = map snd group ]
- applyDeltasToRecord name deltas = do
- erroredDB $ modifyRecord (RecUserInfoLog name) $
- \(RCUserInfoDeltas deltas') -> RCUserInfoDeltas $ deltas ++ deltas'
- erroredDB $ modifyRecord (RecUserInfo name) $
- \(RCUserInfo (v,info)) -> RCUserInfo $
- (v+length deltas, applyDeltas info deltas)
- declareNote note@(NoteInfo _ _ target) behind@(ActiveLock name idx) = do
- accessLock name target =<< getCurrALock target
- addDelta (lockOwner target) $ LockDelta (lockIndex target) $ AddSolution note
- addDelta name $ LockDelta idx $ AddSecured note
- accessed <- accessedBy <$> getCurrALock behind
- mapM_ (addReadNote note) (name:accessed)
- addReadNote note@(NoteInfo _ _ target) name = do
- info <- getCurrUserInfo name
- tlock <- getCurrALock target
- unless (note `elem` notesRead info) $ do
- addDelta name $ AddRead note
- checkSuffReadNotes target name
- accessLock name target@(ActiveLock tname ti) tlock = do
- addDelta tname $ LockDelta ti $ AddAccessed name
- mapM_ (`addReadNote` name) $ notesSecured tlock
- publiciseLock al@(ActiveLock name idx) lock = do
- addDelta name $ LockDelta idx SetPublic
- retireLock lock
- retireLock lock = do
- mapM_ scrapNote $ lockSolutions lock
- mapM_ publiciseNote $ notesSecured lock
- scrapNote note@(NoteInfo _ (Just al@(ActiveLock name idx)) _) = do
- addDelta name $ LockDelta idx (DelSecured note)
- unreadNote note
- scrapNote _ = return ()
- unreadNote note@(NoteInfo name (Just al) _) = do
- lock <- getCurrALock al
- mapM_ (\name' -> addDelta name' (DelRead note)) $ name:(accessedBy lock)
- publiciseNote note@(NoteInfo _ _ al@(ActiveLock name idx)) = do
- unreadNote note
- addDelta name $ LockDelta idx $ SetPubNote note
- publified <- checkSuffPubNotes al
- unless publified $ do
+ erroredDB $ putRecord (RecPassword name) (RCPassword newpw')
+ setEmail Nothing _ = throwE "Authentication required"
+ setEmail auth@(Just (Auth name _)) addressStr = do
+ checkAuth auth
+ serverAddr <- erroredDB $ getRecord RecServerEmail
+ when (isNothing serverAddr) $ throwE "This server is not configured to support email notifications."
+ let addr = CS.pack addressStr
+ when (not $ CS.null addr || Text.Email.Validate.isValid addr) $ throwE "Invalid email address"
+ erroredDB $ putRecord (RecEmail name) (RCEmail addr)
+ checkCodeName :: Codename -> ExceptT String IO Bool
+ checkCodeName name = do
+ unless (validCodeName name) $ throwE "Invalid codename"
+ liftIO $ withDB dbpath $ recordExists $ RecPassword name
+ --- | TODO: journalling so we can survive death during database writes?
+ applyDeltasToRecords :: [(Codename, UserInfoDelta)] -> ExceptT String IO ()
+ applyDeltasToRecords nds = sequence_ $ [applyDeltasToRecord name deltas
+ | group <- groupBy ((==) `on` fst) nds
+ , let name = fst $ head group
+ , let deltas = map snd group ]
+ applyDeltasToRecord name deltas = do
+ erroredDB $ modifyRecord (RecUserInfoLog name) $
+ \(RCUserInfoDeltas deltas') -> RCUserInfoDeltas $ deltas ++ deltas'
+ erroredDB $ modifyRecord (RecUserInfo name) $
+ \(RCUserInfo (v,info)) -> RCUserInfo $
+ (v+length deltas, applyDeltas info deltas)
+ declareNote note@(NoteInfo _ _ target) behind@(ActiveLock name idx) = do
+ accessLock name target =<< getCurrALock target
+ addDelta (lockOwner target) $ LockDelta (lockIndex target) $ AddSolution note
+ addDelta name $ LockDelta idx $ AddSecured note
+ accessed <- accessedBy <$> getCurrALock behind
+ mapM_ (addReadNote note) (name:accessed)
+ addReadNote note@(NoteInfo _ _ target) name = do
+ info <- getCurrUserInfo name
+ tlock <- getCurrALock target
+ unless (note `elem` notesRead info) $ do
+ addDelta name $ AddRead note
+ checkSuffReadNotes target name
+ accessLock name target@(ActiveLock tname ti) tlock = do
+ addDelta tname $ LockDelta ti $ AddAccessed name
+ mapM_ (`addReadNote` name) $ notesSecured tlock
+ publiciseLock al@(ActiveLock name idx) lock = do
+ addDelta name $ LockDelta idx SetPublic
+ retireLock lock
+ retireLock lock = do
+ mapM_ scrapNote $ lockSolutions lock
+ mapM_ publiciseNote $ notesSecured lock
+ scrapNote note@(NoteInfo _ (Just al@(ActiveLock name idx)) _) = do
+ addDelta name $ LockDelta idx (DelSecured note)
+ unreadNote note
+ scrapNote _ = return ()
+ unreadNote note@(NoteInfo name (Just al) _) = do
+ lock <- getCurrALock al
+ mapM_ (\name' -> addDelta name' (DelRead note)) $ name:(accessedBy lock)
+ publiciseNote note@(NoteInfo _ _ al@(ActiveLock name idx)) = do
+ unreadNote note
+ addDelta name $ LockDelta idx $ SetPubNote note
+ publified <- checkSuffPubNotes al
+ unless publified $ do
lock <- getCurrALock al
accessorsOfNotesOnLock <- ((++ map noteAuthor (lockSolutions lock)).concat)
<$> (sequence
[ accessedBy <$> getCurrALock behind | NoteInfo _ (Just behind) _ <- lockSolutions lock ] )
forM_ accessorsOfNotesOnLock $ checkSuffReadNotes al
- checkSuffReadNotes target name = do
- info <- getCurrUserInfo name
- tlock <- getCurrALock target
- unless (name `elem` accessedBy tlock || public tlock || name == lockOwner target) $ do
- when (countRead info tlock == notesNeeded) $
- accessLock name target tlock
- checkSuffPubNotes al@(ActiveLock name idx) = do
+ checkSuffReadNotes target name = do
+ info <- getCurrUserInfo name
+ tlock <- getCurrALock target
+ unless (name `elem` accessedBy tlock || public tlock || name == lockOwner target) $ do
+ when (countRead info tlock == notesNeeded) $
+ accessLock name target tlock
+ checkSuffPubNotes al@(ActiveLock name idx) = do
lock <- getCurrALock al
- let countPub = fromIntegral $ length $
- filter (isNothing.noteBehind) $ lockSolutions lock
- if (countPub == notesNeeded)
- then publiciseLock al lock >> return True
- else return False
- -- | XXX we apply deltas right-to-left, so in the order of adding
- addDelta name delta = modify ((name,delta):)
- getCurrUserInfo name = do
- info <- lift $ getUserInfo name
- (applyDeltas info . map snd . filter ((==name).fst)) <$> get
- getCurrALock al@(ActiveLock name idx) =
- (fromJust.(!idx).userLocks) <$> getCurrUserInfo name
- doNews news = case mfeedPath of
- Nothing -> return ()
- Just feedPath -> lift $ void $ forkIO $ do
- let baseFeed = withFeedTitle "Intricacy updates" $ newFeed $ RSSKind Nothing
- feed <- (parseFeedFromFile feedPath) `catchAll`
- (const $ return baseFeed)
- time <- formatTime defaultTimeLocale rfc822DateFormat <$> getZonedTime
- let item = withItemTitle news $ withItemDescription news $
- withItemPubDate time $ newItem $ RSSKind Nothing
- -- TODO: purge old entries
- writeFile feedPath $ showTopElement $ xmlFeed $
- withFeedLastUpdate time $ addItem item feed
- mailDeclaration target@(ActiveLock name _) behind@(ActiveLock solverName _) = runMaybeT $ do
- let makeAddr :: CS.ByteString -> SMTP.Address
- makeAddr bs = SMTP.Address Nothing $ TS.pack $ CS.unpack bs
- RCEmail serverAddr <- MaybeT $ erroredDB $ getRecord RecServerEmail
- RCEmail playerAddr <- MaybeT $ erroredDB $ getRecord $ RecEmail name
- guard $ not $ CS.null playerAddr
- lift.lift $ SMTP.sendMail "localhost" $ SMTP.simpleMail (makeAddr serverAddr)
- [makeAddr playerAddr] [] []
- (TS.pack $ "[Intricacy] " ++ alockStr target ++" solved by " ++ solverName)
- [SMTP.plainTextPart $ TL.pack $ "A solution to your lock " ++ alockStr target ++ " has been declared by " ++ solverName ++
- " and secured behind " ++ alockStr behind ++ "." ++
- "\n\n-----\n\nYou received this email from the game Intricacy" ++
- "\n\thttp://sdf.org/~mbays/intricacy ." ++
- "\nYou can disable notifications in-game by pressing 'R' on your home" ++
- "\nscreen and setting an empty address." ++
- "\nAlternatively, just reply to this email with the phrase \"stop bugging me\"." ]
+ let countPub = fromIntegral $ length $
+ filter (isNothing.noteBehind) $ lockSolutions lock
+ if (countPub == notesNeeded)
+ then publiciseLock al lock >> return True
+ else return False
+ -- | XXX we apply deltas right-to-left, so in the order of adding
+ addDelta name delta = modify ((name,delta):)
+ getCurrUserInfo name = do
+ info <- lift $ getUserInfo name
+ (applyDeltas info . map snd . filter ((==name).fst)) <$> get
+ getCurrALock al@(ActiveLock name idx) =
+ (fromJust.(!idx).userLocks) <$> getCurrUserInfo name
+ doNews :: String -> ExceptT String IO ()
+ doNews news = case mfeedPath of
+ Nothing -> return ()
+ Just feedPath -> lift $ void $ forkIO $ do
+ let baseFeed = withFeedTitle (TS.pack "Intricacy updates") $ newFeed $ RSSKind Nothing
+ feed <- (parseFeedFromFile feedPath) `catchAll`
+ (const $ return baseFeed)
+ time <- formatTime defaultTimeLocale rfc822DateFormat <$> getZonedTime
+ let newsText = TS.pack news
+ timeText = TS.pack time
+ item = withItemTitle newsText $ withItemDescription newsText $
+ withItemPubDate timeText $ newItem $ RSSKind Nothing
+ -- TODO: purge old entries
+ let Right element = XML.fromXMLElement $ xmlFeed $ withFeedLastUpdate timeText $ addItem item feed
+ document = XML.Document (XML.Prologue [] Nothing []) element []
+ writeFile feedPath $ TL.unpack $ XML.renderText XML.def document
+ mailDeclaration target@(ActiveLock name _) behind@(ActiveLock solverName _) = runMaybeT $ do
+ let makeAddr :: CS.ByteString -> SMTP.Address
+ makeAddr bs = SMTP.Address Nothing $ TS.pack $ CS.unpack bs
+ RCEmail serverAddr <- MaybeT $ erroredDB $ getRecord RecServerEmail
+ RCEmail playerAddr <- MaybeT $ erroredDB $ getRecord $ RecEmail name
+ guard $ not $ CS.null playerAddr
+ lift.lift $ SMTP.sendMail "localhost" $ SMTP.simpleMail (makeAddr serverAddr)
+ [makeAddr playerAddr] [] []
+ (TS.pack $ "[Intricacy] " ++ alockStr target ++" solved by " ++ solverName)
+ [SMTP.plainTextPart $ TL.pack $ "A solution to your lock " ++ alockStr target ++ " has been declared by " ++ solverName ++
+ " and secured behind " ++ alockStr behind ++ "." ++
+ "\n\n-----\n\nYou received this email from the game Intricacy" ++
+ "\n\thttp://sdf.org/~mbays/intricacy ." ++
+ "\nYou can disable notifications in-game by pressing 'R' on your home" ++
+ "\nscreen and setting an empty address." ++
+ "\nAlternatively, just reply to this email with the phrase \"stop bugging me\"." ]
diff --git a/ServerAddr.hs b/ServerAddr.hs
index 1840b7a..32358b7 100644
--- a/ServerAddr.hs
+++ b/ServerAddr.hs
@@ -33,8 +33,8 @@ saddrPath (ServerAddr h p) = h ++ if p==defaultPort then "" else '#':show p
strToSaddr str =
case elemIndex ':' str of
- Nothing -> Just $ ServerAddr str defaultPort
- Just idx -> do
- let (addr,portstr) = splitAt idx str
- port <- fst <$> listToMaybe (reads (drop 1 portstr))
- return $ ServerAddr addr port
+ Nothing -> Just $ ServerAddr str defaultPort
+ Just idx -> do
+ let (addr,portstr) = splitAt idx str
+ port <- fst <$> listToMaybe (reads (drop 1 portstr))
+ return $ ServerAddr addr port
diff --git a/Version.hs b/Version.hs
index e795d1c..01bf39b 100644
--- a/Version.hs
+++ b/Version.hs
@@ -11,4 +11,4 @@
module Version where
version :: String
-version = "0.7.1"
+version = "0.7.1.1"
diff --git a/intricacy.cabal b/intricacy.cabal
index d5a9190..52fa513 100644
--- a/intricacy.cabal
+++ b/intricacy.cabal
@@ -1,5 +1,5 @@
name: intricacy
-version: 0.7.1
+version: 0.7.1.1
synopsis: A game of competitive puzzle-design
homepage: http://mbays.freeshell.org/intricacy
license: GPL-3
@@ -9,10 +9,9 @@ maintainer: mbays@sdf.org
-- copyright:
category: Game
build-type: Simple
-cabal-version: >=1.18
+cabal-version: >=1.10
data-files: VeraMoBd.ttf tutorial/*.lock tutorial/*.text sounds/*.ogg
-extra-doc-files: README BUILD NEWS tutorial-extra/*.lock tutorial-extra/README
-extra-source-files: Main_stub.h
+extra-source-files: Main_stub.h README BUILD NEWS tutorial-extra/*.lock tutorial-extra/README
description:
A networked game with client-server architecture. The core game is a
@@ -50,7 +49,7 @@ Flag Server
executable intricacy
if flag(Game)
- extensions: DoAndIfThenElse
+ default-extensions: DoAndIfThenElse
build-depends: base >=4.3, base < 5
, mtl >=2.2, transformers >=0.4, stm >= 2.1
, directory >= 1.0, filepath >= 1.0, time >= 1.2
@@ -99,7 +98,7 @@ executable intricacy
main-is: MainBoth.hs
Buildable: False
- ghc-options: -fno-warn-tabs
+ default-language: Haskell2010
other-modules: AsciiLock, BinaryInstances, BoardColouring, Cache, Command,
CursesRender, CursesUI, CursesUIMInstance, CVec, Database,
EditGameState, Frame, GameState, GameStateTypes, GraphColouring, Hex, Init,
@@ -109,7 +108,7 @@ executable intricacy
executable intricacy-server
if flag(Server)
- extensions: DoAndIfThenElse
+ default-extensions: DoAndIfThenElse
build-depends: base >=4.3, base < 5
, mtl >=2.2, transformers >=0.4, stm >= 2.1
, directory >= 1.0, filepath >= 1.0, time >= 1.5
@@ -119,12 +118,12 @@ executable intricacy-server
, cryptohash >= 0.8
, RSA >= 2.0, crypto-pubkey-types >= 0.2, crypto-api >= 0.10
, random >= 1.0, pipes >= 4
- , feed >= 0.3.1, xml >= 1.2.6
+ , feed >= 1.0.0, xml-conduit >= 1.0.0
, email-validate >= 1.0.0, text, smtp-mail >= 0.1.4.1
else
Buildable: False
main-is: Server.hs
- ghc-options: -fno-warn-tabs
+ default-language: Haskell2010
other-modules: AsciiLock, BinaryInstances, BoardColouring, CVec, Database,
Frame, GameState, GameStateTypes, GraphColouring, Hex, Lock,
Maxlocksize, Metagame, Mundanities, Physics, Protocol, Util, Version