intricacy 0.7.1 → 0.7.1.1
raw patch · 33 files changed
+3241/−3226 lines, 33 filesdep +xml-conduitdep −xmldep ~feed
Dependencies added: xml-conduit
Dependencies removed: xml
Dependency ranges changed: feed
Files
- AsciiLock.hs +105/−105
- BinaryInstances.hs +37/−37
- BoardColouring.hs +47/−47
- Cache.hs +32/−32
- Command.hs +7/−7
- CursesRender.hs +17/−17
- CursesUI.hs +7/−7
- CursesUIMInstance.hs +186/−186
- Database.hs +45/−36
- EditGameState.hs +112/−112
- Frame.hs +17/−17
- GameState.hs +102/−102
- GameStateTypes.hs +12/−12
- GraphColouring.hs +11/−11
- Hex.lhs +26/−26
- Init.hs +25/−25
- Interact.hs +344/−344
- InteractUtil.hs +99/−99
- Lock.hs +17/−17
- MainState.hs +149/−149
- Metagame.hs +31/−31
- Mundanities.hs +1/−1
- NEWS +3/−0
- Physics.hs +136/−136
- Protocol.hs +32/−32
- SDLGlyph.hs +139/−139
- SDLRender.hs +58/−58
- SDLUI.hs +286/−286
- SDLUIMInstance.hs +811/−811
- Server.hs +333/−329
- ServerAddr.hs +5/−5
- Version.hs +1/−1
- intricacy.cabal +8/−9
AsciiLock.hs view
@@ -47,109 +47,109 @@ 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 []+ 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+ 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 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 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]
BinaryInstances.hs view
@@ -24,14 +24,14 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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
BoardColouring.hs view
@@ -32,61 +32,61 @@ 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)
Cache.hs view
@@ -45,31 +45,31 @@ 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 @@ 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
Command.hs view
@@ -54,7 +54,7 @@ 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 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 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"
CursesRender.hs view
@@ -28,17 +28,17 @@ 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 @@ | 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 @@ 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 ()
CursesUI.hs view
@@ -67,7 +67,7 @@ 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 @@ 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
CursesUIMInstance.hs view
@@ -54,23 +54,23 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ [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 @@ (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 @@ 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 @@ 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
Database.hs view
@@ -12,6 +12,7 @@ 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 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 @@ 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 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 = 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"+ 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]+ 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.+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')
EditGameState.hs view
@@ -26,103 +26,103 @@ 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 @@ 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
Frame.hs view
@@ -33,23 +33,23 @@ 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 @@ 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 @@ 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' ]
GameState.hs view
@@ -38,12 +38,12 @@ 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 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 @@ 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 @@ 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 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 @@ 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 @@ -- 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 @@ 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 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 @@ -- 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 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 @@ [ 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
GameStateTypes.hs view
@@ -15,7 +15,7 @@ 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 @@ 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 @@ 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 @@ -- |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)
GraphColouring.hs view
@@ -32,8 +32,8 @@ -- 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' 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 @@ 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' =
Hex.lhs view
@@ -73,15 +73,15 @@ 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 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 @@ | 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 @@ 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 @@ 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}
Init.hs view
@@ -45,8 +45,8 @@ 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 @@ 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 ]
Interact.hs view
@@ -67,47 +67,47 @@ 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)+ 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+ -- | 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 @@ 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 @@ 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 @@ 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' 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 @@ 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 @@ 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 @@ ] 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ , 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 @@ 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 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 @@ 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 @@ 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 @@ 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 @@ 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
InteractUtil.hs view
@@ -44,12 +44,12 @@ 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 @@ 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 @@ 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 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 @@ [ 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 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 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 @@ 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)
Lock.hs view
@@ -50,8 +50,8 @@ 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 = 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 @@ -- 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]
MainState.hs view
@@ -72,65 +72,65 @@ 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 @@ 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 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 @@ 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 @@ 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 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 =
Metagame.hs view
@@ -54,27 +54,27 @@ 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 @@ 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 @@ 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
Mundanities.hs view
@@ -33,7 +33,7 @@ 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
NEWS view
@@ -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.
Physics.hs view
@@ -31,7 +31,7 @@ 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 @@ , 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 @@ 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 @@ 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 @@ 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 @@ 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 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 @@ 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"
Protocol.hs view
@@ -100,22 +100,22 @@ 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 @@ 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
SDLGlyph.hs view
@@ -72,8 +72,8 @@ 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 @@ 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 (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 @@ 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 (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 @@ | 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 @@ 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 @@ 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 ()
SDLRender.hs view
@@ -68,22 +68,22 @@ 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 @@ 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 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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)
SDLUI.hs view
@@ -136,7 +136,7 @@ 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 @@ 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)]- ]+ 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+ _ -> []+ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ -- 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 @@ 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 @@ 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 @@ 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 = 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 @@ 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' 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 }+ 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) <$>+ -- 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 }+ 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 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 @@ applyAlerts = flip (foldr applyAlert) drawAlerts - erase- sequence_ [ drawAt glyph pos |- (pos,glyph) <- Map.toList $ applyAlerts tileGlyphs- ]+ 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+ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ -- 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 @@ 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) }
SDLUIMInstance.hs view
@@ -54,817 +54,817 @@ 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- drawMainState' (PlayState { psCurrentState=st, psLastAlerts=alerts,- wrenchSelected=wsel, psIsTut=isTut, psSolved=solved }) = do- canUndo <- null <$> gets psGameStateMoveStack- canRedo <- null <$> gets psUndoneStack- lift $ do- let selTools = [ idx |- (idx, PlacedPiece pos p) <- enumVec $ placedPieces st- , or [wsel && isWrench p, not wsel && isHook p] ]- drawMainGameState selTools False alerts st- lb <- isJust <$> gets leftButtonDown- rb <- isJust <$> gets leftButtonDown- when isTut $ do- centre <- gets dispCentre- sequence_- [ registerSelectable (pos -^ centre) 0 $- if isWrench p then SelToolWrench else SelToolHook- | PlacedPiece pos p <- Vector.toList $ placedPieces st- , not $ lb || rb- , isTool p- ]- registerUndoButtons canUndo canRedo- registerButton (periphery 0) CmdOpen (if solved then 2 else 0) $- [("open", hu+^neg hw)] ++ if solved && isTut- then [("Click-->",9*^neg hu)]- else []- drawMainState' (ReplayState { rsCurrentState=st, rsLastAlerts=alerts } ) = do- canUndo <- null <$> gets rsGameStateMoveStack- canRedo <- null <$> gets rsMoveStack- lift $ do- drawMainGameState [] False alerts st- registerUndoButtons canUndo canRedo- renderToMain $ drawCursorAt Nothing- drawMainState' (EditState { 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 ()-- drawMessage = say- drawPrompt full s = say $ s ++ (if full then "" else "_")- endPrompt = say ""- drawError = sayError-- reportAlerts = playAlertSounds-- getChRaw = resetMouseButtons >> getChRaw'- where- resetMouseButtons = modify $ \s -> s- { leftButtonDown = Nothing- , middleButtonDown = Nothing- , rightButtonDown = Nothing- }- getChRaw' = do- events <- liftIO getEvents- if not.null $ [ True | MouseButtonDown _ _ ButtonRight <- events ]- then return Nothing- else maybe getChRaw' (return.Just) $ listToMaybe $ [ ch- | KeyDown (Keysym _ _ ch) <- events- , ch /= '\0' ]-- setUIBinding mode cmd ch =- modify $ \s -> s { uiKeyBindings =- Map.insertWith (\[bdg] -> \bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs)- mode [(ch,cmd)] $ uiKeyBindings s }-- getUIBinding mode cmd = ($cmd) <$> getBindingStr mode-- initUI = liftM isJust (runMaybeT $ do- catchIOErrorMT $ SDL.init-#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)-- endUI = do- 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-- 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'}-- getUIMousePos = do- 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-- 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 ]-#ifdef SOUND- ++ [ 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-- 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- showHelp IMMeta HelpPageGame = do- renderToMain $ drawBasicHelpPage ("INTRICACY",red) (metagameHelpText,purple)- return True- showHelp IMMeta (HelpPageInitiated n) = do- renderToMain $ drawBasicHelpPage ("Initiation complete",purple) (initiationHelpText n,red)- return True- showHelp IMEdit HelpPageFirstEdit = do- renderToMain $ drawBasicHelpPage ("Your first lock:",purple) (firstEditHelpText,green)- return True- showHelp _ _ = return False-- onNewMode mode = modify (\ds -> ds{needHoverUpdate=True}) >> say ""-- withNoBG m = do- bg <- gets bgSurface- modify $ \uiState -> uiState{bgSurface=Nothing}- m- isNothing <$> gets bgSurface >>?- modify (\uiState -> uiState{bgSurface=bg})---drawShortMouseHelp mode = do- mwhs <- gets $ whsButtons.uiOptions- showBT <- showButtonText <$> gets uiOptions- when (showBT && isNothing mwhs) $ do- let helps = shortMouseHelp mode- smallFont <- gets dispFontSmall- renderToMain $ withFont smallFont $ sequence_- [ renderStrColAtLeft (dim cyan) help- (periphery 3 +^ neg hu +^ (2-n)*^hv )- | (n,help) <- zip [0..] helps ]- where- shortMouseHelp IMPlay =- [ "LMB: select/move tool"- , "LMB+drag: move tool"- , "Wheel: turn hook"- , "RMB: wait a turn"- , "RMB+Wheel: undo/redo"- ]- shortMouseHelp IMEdit =- [ "LMB: paint; Ctrl+LMB: delete"- , "Wheel: set paint type"- , "RMB: select piece; drag to move"- , "RMB+LMB: wait; RMB+MMB: delete piece"- , "MMB+Wheel: undo/redo"- ]- shortMouseHelp IMReplay =- [ "Wheel: advance/regress time" ]- shortMouseHelp _ = []---- waitEvent' : copy of SDL.Events.waitEvent, with the timeout increased--- drastically to reduce CPU load when idling.-waitEvent' :: IO Event-waitEvent' = loop- where loop = do pumpEvents- event <- pollEvent- case event of- NoEvent -> threadDelay 10000 >> loop- _ -> return event--getEvents = do- e <- waitEvent'- es <- pollEvents- return $ e:es--getEventsTimeout us = do- es <- maybeToList <$> timeout us waitEvent'- es' <- pollEvents- return $ es++es'--updateHoverStr :: InputMode -> UIM ()-updateHoverStr mode = do- p@(mPos,isCentral) <- gets mousePos- showBT <- showButtonText <$> gets uiOptions- hstr <- runMaybeT $ msum- [ MaybeT ( cmdAtMousePos p mode Nothing ) >>= lift . describeCommandAndKeys- , guard showBT >> MaybeT (helpAtMousePos p mode)- , guard (showBT && mode == IMEdit) >> msum- [ return $ "set paint mode: " ++ describeCommand (paintTileCmds!!i)- | i <- take (length paintTiles) [0..]- , mPos == paintButtonStart +^ i*^hv ]- , guard (mPos == uiOptPos uiOB1 && 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-#endif- ]- modify $ \ds -> ds { hoverStr = hstr }- where- describeCommandAndKeys :: Command -> UIM String- describeCommandAndKeys cmd = do- uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings- return $ describeCommand cmd ++ " ["- ++ concat (intersperse ","- (map showKeyFriendly $ findBindings (uibdgs ++ bindings mode) cmd))- ++ "]"---fillArea :: HexVec -> [HexVec] -> [HexVec -> MainStateT UIM ()] -> MainStateT UIM ()-fillArea centre area draws = do- offset <- gets listOffset- let na = length area- listButton cmd = \pos -> lift $ registerButton pos cmd 3 []- draws' = if offset > 0 && length draws > na- then listButton CmdPrevPage :- drop (max 0 $ min (length draws - (na-1)) (na-1 + (na-2)*(offset-1))) draws- else draws- selDraws = if length draws' > na- then take (na-1) draws' ++ [listButton CmdNextPage]- else take na draws'- sequence_ $ map (uncurry ($)) $- zip selDraws $ sortBy (compare `on` hexVec2SVec 37) $- take (length selDraws) $ sortBy- (compare `on` (hexLen . (-^centre)))- area--drawOldLock ls pos = void.runMaybeT $ msum [ do- lock <- mgetLock ls- lift.lift $ drawMiniLock lock pos- , lift.lift.renderToMain $- renderStrColAt messageCol (show ls) pos- ]---drawName name pos = nameCol name >>= drawNameCol name pos-drawNullName name pos = drawNameCol name pos $ invisible white-drawNameCol name pos col = do- lift.renderToMain $ do- drawAtRel (playerGlyph col) pos- renderStrColAt buttonTextCol name pos-drawRelScore name pos = do- col <- nameCol name- relScore <- getRelScore name- flip (maybe (return ())) relScore $ \score ->- lift $ do- renderToMain $ renderStrColAt col- ((if score > 0 then "+" else "") ++ show score) pos- registerSelectable pos 0 SelRelScore--drawNote note pos = case noteBehind note of- Just al -> drawActiveLock al pos- Nothing -> drawPublicNote (noteAuthor note) pos-drawActiveLock al@(ActiveLock name i) pos = do- accessed <- accessedAL al- drawNameWithChar name- (if accessed then accColour else white)- (lockIndexChar i) pos-drawPublicNote name =- drawNameWithChar name pubColour 'P'-drawNameWithChar name charcol char pos = do- col <- nameCol name- drawNameWithCharAndCol name charcol char col pos-drawNameWithCharAndCol :: String -> Pixel -> Char -> Pixel -> HexVec -> MainStateT UIM ()-drawNameWithCharAndCol name charcol char col pos = do- size <- fi.snd <$> lift getGeom- let up = FVec 0 $ 1/2 - ylen- 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-pubWheelAngle = 5-pubColour = colourWheel pubWheelAngle -- ==purple-accColour = cyan-nameCol name = do- ourName <- (authUser <$>) <$> gets curAuth- relScore <- getRelScore name- return $ dim $ case relScore of- Nothing -> Pixel $ if ourName == Just name then 0xc0c0c000 else 0x80808000- Just score -> scoreColour score-scoreColour :: Int -> Pixel-scoreColour score = Pixel $ case score of- 0 -> 0x80800000- 1 -> 0x70a00000- 2 -> 0x40c00000- 3 -> 0x00ff0000- (-1) -> 0xa0700000- (-2) -> 0xc0400000- (-3) -> 0xff000000--drawLockInfo :: ActiveLock -> Maybe LockInfo -> MainStateT UIM ()-drawLockInfo al@(ActiveLock name idx) Nothing = do- let centre = hw+^neg hv +^ 7*(idx-1)*^hu- lift $ drawEmptyMiniLock centre- drawNameWithCharAndCol name white (lockIndexChar idx) (invisible white) centre- ourName <- (authUser <$>) <$> gets curAuth- lift $ registerSelectable centre 3 $ SelLockUnset (ourName == Just name) al-drawLockInfo al@(ActiveLock name idx) (Just lockinfo) = do- let centre = locksPos +^ 7*(idx-1)*^hu- let accessedByPos = centre +^ 3*^(hv +^ neg hw)- let accessedPos = centre +^ 2*^(hw +^ neg hv)- let notesPos = centre +^ 3*^(hw +^ neg hv)- ourName <- (authUser <$>) <$> gets curAuth- runMaybeT $ msum [- do- lock <- mgetLock $ lockSpec lockinfo- lift.lift $ do- drawMiniLock lock centre- registerSelectable centre 3 $ SelLock al- , lift $ do- drawActiveLock al centre- lift $ registerSelectable centre 3 $ SelLock al- ]-- size <- snd <$> lift getGeom- lift $ do- renderToMain $ displaceRender (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- else if null $ accessedBy lockinfo- then lift.renderToMain $ renderStrColAt dimWhiteCol "No-one" accessedByPos- else fillArea accessedByPos- [ accessedByPos +^ d | j <- [0..2], i <- [-2..3]- , i-j > -4, i-j < 3- , let d = j*^hw +^ i*^hu ]- $ [ \pos -> (lift $ registerSelectable pos 0 (SelSolution note)) >> drawNote note pos- | note <- lockSolutions lockinfo ] ++- [ \pos -> (lift $ registerSelectable pos 0 (SelAccessed name)) >> drawName name pos- | name <- accessedBy lockinfo \\ map noteAuthor (lockSolutions lockinfo) ]-- undecls <- gets undeclareds- case if isJust $ guard . (|| public lockinfo) . (`elem` map noteAuthor (lockSolutions lockinfo)) =<< ourName- then if public lockinfo- then Just (pubColour,"Accessed!",AccessedPublic)- else Just (accColour, "Solved!",AccessedSolved)- else if any (\(Undeclared _ ls _) -> ls == lockSpec lockinfo) undecls- then Just (yellow, "Undeclared",AccessedUndeclared)- else Nothing- of- Just (col,str,selstr) -> lift $ do- renderToMain $ renderStrColAt col str accessedPos- registerSelectable accessedPos 1 (SelAccessedInfo selstr)- Nothing -> do- read <- take 3 <$> getNotesReadOn lockinfo- unless (ourName == Just name) $ do- let readPos = accessedPos +^ (-3)*^hu- lift.renderToMain $ renderStrColAt (if length read == 3 then accColour else dimWhiteCol)- "Read:" $ readPos- when (length read == 3) $ lift $ registerSelectable readPos 0 (SelAccessedInfo AccessedReadNotes)- fillArea (accessedPos+^neg hu) [ accessedPos +^ i*^hu | i <- [-1..1] ]- $ take 3 $ [ \pos -> (lift $ registerSelectable pos 0 (SelReadNote note)) >> drawNote note pos- | note <- read ] ++ (repeat $ \pos -> (lift $ registerSelectable pos 0 SelReadNoteSlot >>- renderToMain (drawAtRel (HollowGlyph $ dim green) pos)))-- lift $ do- renderToMain $ displaceRender (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 ]+ 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+ 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)]+ 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 ()++ drawMessage = say+ drawPrompt full s = say $ s ++ (if full then "" else "_")+ endPrompt = say ""+ drawError = sayError++ reportAlerts = playAlertSounds++ getChRaw = resetMouseButtons >> getChRaw'+ where+ resetMouseButtons = modify $ \s -> s+ { leftButtonDown = Nothing+ , middleButtonDown = Nothing+ , rightButtonDown = Nothing+ }+ getChRaw' = do+ events <- liftIO getEvents+ if not.null $ [ True | MouseButtonDown _ _ ButtonRight <- events ]+ then return Nothing+ else maybe getChRaw' (return.Just) $ listToMaybe $ [ ch+ | KeyDown (Keysym _ _ ch) <- events+ , ch /= '\0' ]++ setUIBinding mode cmd ch =+ modify $ \s -> s { uiKeyBindings =+ Map.insertWith (\[bdg] -> \bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs)+ mode [(ch,cmd)] $ uiKeyBindings s }++ getUIBinding mode cmd = ($cmd) <$> getBindingStr mode++ initUI = liftM isJust (runMaybeT $ do+ catchIOErrorMT $ SDL.init+#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)++ endUI = do+ 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++ 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'}++ getUIMousePos = do+ 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++ 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 ]+#ifdef SOUND+ ++ [ 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++ 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+ showHelp IMMeta HelpPageGame = do+ renderToMain $ drawBasicHelpPage ("INTRICACY",red) (metagameHelpText,purple)+ return True+ showHelp IMMeta (HelpPageInitiated n) = do+ renderToMain $ drawBasicHelpPage ("Initiation complete",purple) (initiationHelpText n,red)+ return True+ showHelp IMEdit HelpPageFirstEdit = do+ renderToMain $ drawBasicHelpPage ("Your first lock:",purple) (firstEditHelpText,green)+ return True+ showHelp _ _ = return False++ onNewMode mode = modify (\ds -> ds{needHoverUpdate=True}) >> say ""++ withNoBG m = do+ bg <- gets bgSurface+ modify $ \uiState -> uiState{bgSurface=Nothing}+ m+ isNothing <$> gets bgSurface >>?+ modify (\uiState -> uiState{bgSurface=bg})+++drawShortMouseHelp mode = do+ mwhs <- gets $ whsButtons.uiOptions+ showBT <- showButtonText <$> gets uiOptions+ when (showBT && isNothing mwhs) $ do+ let helps = shortMouseHelp mode+ smallFont <- gets dispFontSmall+ renderToMain $ withFont smallFont $ sequence_+ [ renderStrColAtLeft (dim cyan) help+ (periphery 3 +^ neg hu +^ (2-n)*^hv )+ | (n,help) <- zip [0..] helps ]+ where+ shortMouseHelp IMPlay =+ [ "LMB: select/move tool"+ , "LMB+drag: move tool"+ , "Wheel: turn hook"+ , "RMB: wait a turn"+ , "RMB+Wheel: undo/redo"+ ]+ shortMouseHelp IMEdit =+ [ "LMB: paint; Ctrl+LMB: delete"+ , "Wheel: set paint type"+ , "RMB: select piece; drag to move"+ , "RMB+LMB: wait; RMB+MMB: delete piece"+ , "MMB+Wheel: undo/redo"+ ]+ shortMouseHelp IMReplay =+ [ "Wheel: advance/regress time" ]+ shortMouseHelp _ = []++-- waitEvent' : copy of SDL.Events.waitEvent, with the timeout increased+-- drastically to reduce CPU load when idling.+waitEvent' :: IO Event+waitEvent' = loop+ where loop = do pumpEvents+ event <- pollEvent+ case event of+ NoEvent -> threadDelay 10000 >> loop+ _ -> return event++getEvents = do+ e <- waitEvent'+ es <- pollEvents+ return $ e:es++getEventsTimeout us = do+ es <- maybeToList <$> timeout us waitEvent'+ es' <- pollEvents+ return $ es++es'++updateHoverStr :: InputMode -> UIM ()+updateHoverStr mode = do+ p@(mPos,isCentral) <- gets mousePos+ showBT <- showButtonText <$> gets uiOptions+ hstr <- runMaybeT $ msum+ [ MaybeT ( cmdAtMousePos p mode Nothing ) >>= lift . describeCommandAndKeys+ , guard showBT >> MaybeT (helpAtMousePos p mode)+ , guard (showBT && mode == IMEdit) >> msum+ [ return $ "set paint mode: " ++ describeCommand (paintTileCmds!!i)+ | i <- take (length paintTiles) [0..]+ , mPos == paintButtonStart +^ i*^hv ]+ , guard (mPos == uiOptPos uiOB1 && 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+#endif+ ]+ modify $ \ds -> ds { hoverStr = hstr }+ where+ describeCommandAndKeys :: Command -> UIM String+ describeCommandAndKeys cmd = do+ uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings+ return $ describeCommand cmd ++ " ["+ ++ concat (intersperse ","+ (map showKeyFriendly $ findBindings (uibdgs ++ bindings mode) cmd))+ ++ "]"+++fillArea :: HexVec -> [HexVec] -> [HexVec -> MainStateT UIM ()] -> MainStateT UIM ()+fillArea centre area draws = do+ offset <- gets listOffset+ let na = length area+ listButton cmd = \pos -> lift $ registerButton pos cmd 3 []+ draws' = if offset > 0 && length draws > na+ then listButton CmdPrevPage :+ drop (max 0 $ min (length draws - (na-1)) (na-1 + (na-2)*(offset-1))) draws+ else draws+ selDraws = if length draws' > na+ then take (na-1) draws' ++ [listButton CmdNextPage]+ else take na draws'+ sequence_ $ map (uncurry ($)) $+ zip selDraws $ sortBy (compare `on` hexVec2SVec 37) $+ take (length selDraws) $ sortBy+ (compare `on` (hexLen . (-^centre)))+ area++drawOldLock ls pos = void.runMaybeT $ msum [ do+ lock <- mgetLock ls+ lift.lift $ drawMiniLock lock pos+ , lift.lift.renderToMain $+ renderStrColAt messageCol (show ls) pos+ ]+++drawName name pos = nameCol name >>= drawNameCol name pos+drawNullName name pos = drawNameCol name pos $ invisible white+drawNameCol name pos col = do+ lift.renderToMain $ do+ drawAtRel (playerGlyph col) pos+ renderStrColAt buttonTextCol name pos+drawRelScore name pos = do+ col <- nameCol name+ relScore <- getRelScore name+ flip (maybe (return ())) relScore $ \score ->+ lift $ do+ renderToMain $ renderStrColAt col+ ((if score > 0 then "+" else "") ++ show score) pos+ registerSelectable pos 0 SelRelScore++drawNote note pos = case noteBehind note of+ Just al -> drawActiveLock al pos+ Nothing -> drawPublicNote (noteAuthor note) pos+drawActiveLock al@(ActiveLock name i) pos = do+ accessed <- accessedAL al+ drawNameWithChar name+ (if accessed then accColour else white)+ (lockIndexChar i) pos+drawPublicNote name =+ drawNameWithChar name pubColour 'P'+drawNameWithChar name charcol char pos = do+ col <- nameCol name+ drawNameWithCharAndCol name charcol char col pos+drawNameWithCharAndCol :: String -> Pixel -> Char -> Pixel -> HexVec -> MainStateT UIM ()+drawNameWithCharAndCol name charcol char col pos = do+ size <- fi.snd <$> lift getGeom+ let up = FVec 0 $ 1/2 - ylen+ 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+pubWheelAngle = 5+pubColour = colourWheel pubWheelAngle -- ==purple+accColour = cyan+nameCol name = do+ ourName <- (authUser <$>) <$> gets curAuth+ relScore <- getRelScore name+ return $ dim $ case relScore of+ Nothing -> Pixel $ if ourName == Just name then 0xc0c0c000 else 0x80808000+ Just score -> scoreColour score+scoreColour :: Int -> Pixel+scoreColour score = Pixel $ case score of+ 0 -> 0x80800000+ 1 -> 0x70a00000+ 2 -> 0x40c00000+ 3 -> 0x00ff0000+ (-1) -> 0xa0700000+ (-2) -> 0xc0400000+ (-3) -> 0xff000000++drawLockInfo :: ActiveLock -> Maybe LockInfo -> MainStateT UIM ()+drawLockInfo al@(ActiveLock name idx) Nothing = do+ let centre = hw+^neg hv +^ 7*(idx-1)*^hu+ lift $ drawEmptyMiniLock centre+ drawNameWithCharAndCol name white (lockIndexChar idx) (invisible white) centre+ ourName <- (authUser <$>) <$> gets curAuth+ lift $ registerSelectable centre 3 $ SelLockUnset (ourName == Just name) al+drawLockInfo al@(ActiveLock name idx) (Just lockinfo) = do+ let centre = locksPos +^ 7*(idx-1)*^hu+ let accessedByPos = centre +^ 3*^(hv +^ neg hw)+ let accessedPos = centre +^ 2*^(hw +^ neg hv)+ let notesPos = centre +^ 3*^(hw +^ neg hv)+ ourName <- (authUser <$>) <$> gets curAuth+ runMaybeT $ msum [+ do+ lock <- mgetLock $ lockSpec lockinfo+ lift.lift $ do+ drawMiniLock lock centre+ registerSelectable centre 3 $ SelLock al+ , lift $ do+ drawActiveLock al centre+ lift $ registerSelectable centre 3 $ SelLock al+ ]++ size <- snd <$> lift getGeom+ lift $ do+ renderToMain $ displaceRender (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+ else if null $ accessedBy lockinfo+ then lift.renderToMain $ renderStrColAt dimWhiteCol "No-one" accessedByPos+ else fillArea accessedByPos+ [ accessedByPos +^ d | j <- [0..2], i <- [-2..3]+ , i-j > -4, i-j < 3+ , let d = j*^hw +^ i*^hu ]+ $ [ \pos -> (lift $ registerSelectable pos 0 (SelSolution note)) >> drawNote note pos+ | note <- lockSolutions lockinfo ] +++ [ \pos -> (lift $ registerSelectable pos 0 (SelAccessed name)) >> drawName name pos+ | name <- accessedBy lockinfo \\ map noteAuthor (lockSolutions lockinfo) ]++ undecls <- gets undeclareds+ case if isJust $ guard . (|| public lockinfo) . (`elem` map noteAuthor (lockSolutions lockinfo)) =<< ourName+ then if public lockinfo+ then Just (pubColour,"Accessed!",AccessedPublic)+ else Just (accColour, "Solved!",AccessedSolved)+ else if any (\(Undeclared _ ls _) -> ls == lockSpec lockinfo) undecls+ then Just (yellow, "Undeclared",AccessedUndeclared)+ else Nothing+ of+ Just (col,str,selstr) -> lift $ do+ renderToMain $ renderStrColAt col str accessedPos+ registerSelectable accessedPos 1 (SelAccessedInfo selstr)+ Nothing -> do+ read <- take 3 <$> getNotesReadOn lockinfo+ unless (ourName == Just name) $ do+ let readPos = accessedPos +^ (-3)*^hu+ lift.renderToMain $ renderStrColAt (if length read == 3 then accColour else dimWhiteCol)+ "Read:" $ readPos+ when (length read == 3) $ lift $ registerSelectable readPos 0 (SelAccessedInfo AccessedReadNotes)+ fillArea (accessedPos+^neg hu) [ accessedPos +^ i*^hu | i <- [-1..1] ]+ $ take 3 $ [ \pos -> (lift $ registerSelectable pos 0 (SelReadNote note)) >> drawNote note pos+ | note <- read ] ++ (repeat $ \pos -> (lift $ registerSelectable pos 0 SelReadNoteSlot >>+ renderToMain (drawAtRel (HollowGlyph $ dim green) pos)))++ lift $ do+ renderToMain $ displaceRender (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 ] drawBasicHelpPage :: (String,Pixel) -> ([String],Pixel) -> RenderM () drawBasicHelpPage (title,titleCol) (body,bodyCol) = do
Server.hs view
@@ -47,7 +47,7 @@ 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 @@ 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 @@ 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 @@ 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 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 @@ 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 @@ 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\"." ]
ServerAddr.hs view
@@ -33,8 +33,8 @@ 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
Version.hs view
@@ -11,4 +11,4 @@ module Version where version :: String-version = "0.7.1"+version = "0.7.1.1"
intricacy.cabal view
@@ -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 @@ -- 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 @@ 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 @@ 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-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 @@ , 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