intricacy 0.5 → 0.5.5
raw patch · 33 files changed
+740/−446 lines, 33 filesdep +feeddep +xmldep ~time
Dependencies added: feed, xml
Dependency ranges changed: time
Files
- AsciiLock.hs +9/−9
- BUILD +3/−1
- BoardColouring.hs +3/−3
- Cache.hs +1/−1
- CursesUI.hs +9/−3
- CursesUIMInstance.hs +10/−5
- EditGameState.hs +12/−12
- Frame.hs +14/−14
- GameState.hs +22/−21
- Hex.lhs +17/−17
- Init.hs +4/−1
- Interact.hs +75/−27
- InteractUtil.hs +11/−7
- MainState.hs +60/−16
- Metagame.hs +33/−13
- Mundanities.hs +3/−0
- NEWS +20/−0
- Physics.hs +8/−8
- README +8/−7
- SDLRender.hs +20/−13
- SDLUI.hs +144/−118
- SDLUIMInstance.hs +143/−110
- Server.hs +58/−15
- ServerAddr.hs +3/−0
- intricacy.cabal +9/−2
- tutorial/1-winning.text +1/−1
- tutorial/2-tools.lock +4/−4
- tutorial/5-plug.lock +0/−17
- tutorial/5-plug.text +0/−1
- tutorial/5-springs.lock +17/−0
- tutorial/5-springs.text +1/−0
- tutorial/6-plug.lock +17/−0
- tutorial/6-plug.text +1/−0
AsciiLock.hs view
@@ -12,7 +12,7 @@ , readAsciiLockFile, writeAsciiLockFile, monochromeOTileChar) where import Data.Function (on)-import Control.Applicative hiding ((<*>))+import Control.Applicative import Control.Monad import Control.Arrow ((&&&)) import qualified Data.Map as Map@@ -46,7 +46,7 @@ lockOfAscii :: AsciiLock -> Maybe Lock lockOfAscii lines = do board <- asciiToBoard lines- let size = maximum $ map (hx . (<->origin)) $ Map.keys board+ let size = maximum $ map (hx . (-^origin)) $ Map.keys board frame = BasicFrame size st <- asciiBoardState frame board return (frame, st)@@ -54,11 +54,11 @@ boardToAscii :: PieceColouring -> GameBoard -> AsciiLock boardToAscii colouring board = let asciiBoard :: Map CVec Char- asciiBoard = Map.mapKeys (hexVec2CVec . (<->origin))+ 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 (-^CVec miny minx) asciiBoard in [ [ Map.findWithDefault ' ' (CVec y x) asciiBoard' | x <- [0..(maxx-minx)] ] | y <- [0..(maxy-miny)] ]@@ -75,7 +75,7 @@ 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))+ in Map.mapKeys ((+^origin) . cVec2HexVec . (-^centre)) <$> T.mapM monoToOTile asciiBoard asciiBoardState :: Frame -> GameBoard -> Maybe GameState@@ -117,20 +117,20 @@ addAppendages st = foldM addAppendageOT st $ Map.toList $ Map.filter (not.isBaseTile.snd) board addAppendageOT st (pos,(-1,ArmTile dir _)) =- let rpos = (neg dir<+>pos)+ 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)+ 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+ | i <- [1..hexLen (epos-^rpos)-1]+ , let pos' = i*^dir+^rpos , Just (_,SpringTile extn _) <- [ Map.lookup pos' board ] ] extnValue Compressed = 4 extnValue Relaxed = 2
BUILD view
@@ -3,7 +3,7 @@ Dependencies: EITHER- sdl+ sdl version 1.2 sdl-ttf sdl-gfx OR@@ -28,6 +28,8 @@ ~/.cabal/bin/intricacy-server The server runs on port 27001 by default. It writes the game database to a directory 'intricacydb' under the directory from which it is run.++ Run 'intricacy-server -h' for various options. To compile for windows: This should work as above once you have the dependencies installed
BoardColouring.hs view
@@ -10,7 +10,7 @@ module BoardColouring where -import Control.Applicative hiding ((<*>))+import Control.Applicative import Control.Monad import Data.Function (on) import qualified Data.Map as Map@@ -56,7 +56,7 @@ Set.fromList $ nubBy ((==)`on`fst) [ (pos', neg dir) | dir <- hexDirs , pos <- fullFootprint st idx- , let pos' = dir <+> pos+ , let pos' = dir +^ pos , Just True /= do (idx',_) <- Map.lookup pos' board return $ idx == idx'@@ -82,7 +82,7 @@ mNext = listToMaybe [ (pos', rotate (h-2) basedir) | h <- [1..5]- , let pos' = (rotate h basedir)<+>pos+ , let pos' = (rotate h basedir)+^pos , (fst <$> Map.lookup pos' board) /= Just idx ] (path,ns) = case mNext of
Cache.hs view
@@ -96,5 +96,5 @@ withCache :: ServerAddr -> DBM a -> IO a withCache saddr m = do- cachedir <- (++[pathSeparator]++saddrStr saddr) `liftM` confFilePath "cache"+ cachedir <- (++[pathSeparator]++saddrPath saddr) `liftM` confFilePath "cache" runReaderT m cachedir
CursesUI.hs view
@@ -57,6 +57,7 @@ liftIO makeConfDir liftIO $ writeFile path $ show bdgs +getBindings :: InputMode -> UIM [(Char, Command)] getBindings mode = do uibdgs <- Map.findWithDefault [] mode <$> gets uiKeyBindings return $ uibdgs ++ bindings mode@@ -83,8 +84,11 @@ drawAt :: Glyph -> HexPos -> UIM () drawAt gl pos = drawAtWithGeom gl pos =<< getGeom++drawAtWithGeom :: Glyph -> HexPos -> Geom -> UIM () drawAtWithGeom gl pos geom@(scrCentre,centre) =- drawAtCVec gl $ scrCentre <+> (hexVec2CVec $ pos <-> centre)+ drawAtCVec gl $ scrCentre +^ (hexVec2CVec $ pos -^ centre)+ drawAtCVec :: Glyph -> CVec -> UIM () drawAtCVec gl cpos = do cpairs <- gets dispCPairs@@ -96,8 +100,9 @@ liftIO $ Curses.attrSet attr (cpairs!!col) >> mvAddStr v str drawStrGrey :: CVec -> String -> UIM () drawStrGrey = drawStr a0 0+drawStrCentred :: Curses.Attr -> ColPair -> CVec -> [Char] -> UIM () drawStrCentred attr col v str =- drawStr attr col (v <+> CVec 0 (-length str `div` 2)) str+ drawStr attr col (v +^ CVec 0 (-length str `div` 2)) str drawCursorAt :: Maybe HexPos -> UIM () drawCursorAt Nothing =@@ -105,7 +110,7 @@ drawCursorAt (Just pos) = do geom@(scrCentre,centre) <- getGeom liftIO $ Curses.cursSet Curses.CursorVisible- liftIO $ move $ scrCentre <+> (hexVec2CVec $ pos <-> centre)+ liftIO $ move $ scrCentre +^ (hexVec2CVec $ pos -^ centre) drawState :: [PieceIdx] -> Bool -> [Alert] -> GameState -> UIM () drawState reversed colourFixed alerts st = do@@ -113,6 +118,7 @@ colouring <- drawStateWithGeom reversed colourFixed lastCol st =<< getGeom modify $ \ds -> ds { dispLastCol = colouring } +drawStateWithGeom :: [PieceIdx] -> Bool -> PieceColouring -> GameState -> Geom -> UIM PieceColouring drawStateWithGeom reversed colourFixed lastCol st geom = do let colouring = boardColouring st (colouredPieces colourFixed st) lastCol mono <- gets monochrome
CursesUIMInstance.hs view
@@ -8,7 +8,7 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/. -{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} module CursesUIMInstance () where import qualified UI.HSCurses.Curses as Curses@@ -72,8 +72,8 @@ drawNameWithChar :: CVec -> Codename -> ColPair -> Char -> MainStateT UIM () drawNameWithChar pos name charcol char = do- drawName False (pos <+> CVec 0 (-1)) name- lift $ drawStr bold charcol (pos <+> CVec 0 1) [':',char]+ drawName False (pos +^ CVec 0 (-1)) name+ lift $ drawStr bold charcol (pos +^ CVec 0 1) [':',char] drawNote :: CVec -> NoteInfo -> MainStateT UIM () drawNote pos note = case noteBehind note of@@ -102,7 +102,7 @@ [ 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+ dist v = sqlen $ v -^ gravCentre sqlen (CVec y x) = (y*(width+1))^2+x^2 selDraws <- do offset <- gets listOffset@@ -204,7 +204,10 @@ drawMainState' (EditState { esGameStateStack=(st:_), selectedPiece=selPiece, selectedPos=selPos }) = lift $ do drawState (maybeToList selPiece) True [] st drawCursorAt $ if isNothing selPiece then Just selPos else Nothing- drawMainState' (MetaState saddr undecls cOnly auth names _ _ _ rnamestvar _ _ mretired path lock _) = do+ drawMainState' (MetaState {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@@ -357,7 +360,9 @@ Curses.refresh warpPointer _ = return ()+ getUIMousePos = return Nothing setYNButtons = return ()+ onNewMode _ = say "" toggleColourMode = modify $ \s -> s {monochrome = not $ monochrome s}
EditGameState.hs view
@@ -10,7 +10,7 @@ module EditGameState (modTile, mergeTiles) where -import Control.Applicative hiding ((<*>))+import Control.Applicative import Data.Function (on) import qualified Data.Map as Map import Data.Map (Map)@@ -70,7 +70,7 @@ Just (BlockTile _) -> let adjacentBlocks = [ idx | dir <- hexDirs- , Just (idx, BlockTile _) <- [Map.lookup (dir <+> pos) board']+ , Just (idx, BlockTile _) <- [Map.lookup (dir +^ pos) board'] , not $ protectedPiece idx ] addToIdx = if lastOK && lastElem adjacentBlocks then lastMOwner@@ -81,7 +81,7 @@ Just (ArmTile armdir _) -> let adjacentPivots = [ idx | dir <- if armdir == zero then hexDirs else [armdir, neg armdir]- , Just (idx, PivotTile _) <- [Map.lookup (dir <+> pos) board'] ]+ , Just (idx, PivotTile _) <- [Map.lookup (dir +^ pos) board'] ] addToIdx = if lastOK && lastElem adjacentPivots then lastMOwner else nextOfAdjacents adjacentPivots True@@ -91,12 +91,12 @@ Just (SpringTile _ _) -> let possibleSprings = [ Connection root end $ Spring sdir natLen | sdir <- hexDirs- , let epos = sdir <+> pos+ , let epos = sdir +^ pos , Just (eidx, BlockTile _) <- [Map.lookup epos board'] , not $ protectedPiece eidx- , (ridx, rpos) <- maybeToList $ castRay (neg sdir <+> pos) (neg sdir) board'+ , (ridx, rpos) <- maybeToList $ castRay (neg sdir +^ pos) (neg sdir) board' , Just True == (validSpringRootTile `liftM` Map.lookup rpos board')- , let natLen = hexLen (rpos <-> epos) - 1+ , let natLen = hexLen (rpos -^ epos) - 1 , natLen > 0 {- , null [ conn |@@ -105,8 +105,8 @@ , not $ sdir' `elem` [sdir,neg sdir] ] -} , not $ connGraphPathExists st' eidx ridx- , let end = (eidx, epos <-> (placedPos $ getpp st' eidx))- , let root = (ridx, rpos <-> (placedPos $ getpp st' ridx))+ , let end = (eidx, epos -^ (placedPos $ getpp st' eidx))+ , let root = (ridx, rpos -^ (placedPos $ getpp st' ridx)) ] nextSpring = listToMaybe $ fromMaybe possibleSprings $ do (_,SpringTile _ _) <- curOwnedTile -- XXX: therefore the indices of st are still valid@@ -119,7 +119,7 @@ Just (WrenchTile _) -> addPiece $ Wrench zero Just HookTile -> let arm = listToMaybe [ dir | dir <- hexDirs- , isNothing $ Map.lookup (dir <+> pos) board' ]+ , isNothing $ Map.lookup (dir +^ pos) board' ] in case arm of Just armdir -> addPiece $ Hook armdir NullHF _ -> id Just (BallTile) -> addPiece Ball@@ -133,7 +133,7 @@ mergeTiles pos dir mergePiece st = fromMaybe st $ do let board = stateBoard st (idx,tile) <- Map.lookup pos board- (idx',tile') <- Map.lookup (dir<+>pos) board+ (idx',tile') <- Map.lookup (dir+^pos) board guard $ idx /= idx' guard $ all (not . protectedPiece) [idx,idx'] case tile of@@ -142,7 +142,7 @@ let st' = if mergePiece then delPiece idx st else fst $ delPiecePos idx pos st- (idx'',_) <- Map.lookup (dir<+>pos) $ stateBoard st'+ (idx'',_) <- Map.lookup (dir+^pos) $ stateBoard st' return $ if mergePiece then foldr (addBlockPos idx'') st' $ plPieceFootprint $ getpp st idx@@ -150,6 +150,6 @@ ArmTile _ _ -> do PivotTile _ <- Just tile' let st' = fst $ delPiecePos idx pos st- (idx'',_) <- Map.lookup (dir<+>pos) $ stateBoard st'+ (idx'',_) <- Map.lookup (dir+^pos) $ stateBoard st' return $ addPivotArm idx'' pos st' _ -> mzero
Frame.hs view
@@ -24,7 +24,7 @@ frameSize (BasicFrame size) = size bolthole, entrance :: Frame -> HexVec-bolthole (BasicFrame size) = size<*>hu <+> (size`div`2)<*>hv+bolthole (BasicFrame size) = size*^hu +^ (size`div`2)*^hv entrance f = neg $ bolthole f boltWidth :: Frame -> Int@@ -37,26 +37,26 @@ (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])+ 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] ] \\+ 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] initTools f =- [ PlacedPiece (entrance f <+> neg hu <+> origin) $ Wrench zero,- PlacedPiece (entrance f <+> hw <+> origin) $ Hook (neg hw) NullHF ]+ [ PlacedPiece (entrance f +^ neg hu +^ origin) $ Wrench zero,+ PlacedPiece (entrance f +^ hw +^ origin) $ Hook (neg hw) NullHF ] clearToolArea :: Frame -> GameState -> GameState clearToolArea f st = foldr delPieceIn st $ toolsArea f@@ -64,12 +64,12 @@ 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 ] ]+toolsArea f = [entrance f +^ v +^ origin | v <- [ neg hu, hw, zero ] ] inBounds :: Frame -> HexPos -> Bool-inBounds f pos = hexLen (pos <-> origin) < frameSize f+inBounds f pos = hexLen (pos -^ origin) < frameSize f inEditable :: Frame -> HexPos -> Bool inEditable f pos = inBounds f pos || pos `elem` boltArea f ++ [PHS $ bolthole f] ++ toolsArea f checkBounds :: Frame -> HexPos -> HexPos -> HexPos
GameState.hs view
@@ -8,9 +8,10 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/. +{-# LANGUAGE FlexibleContexts #-} module GameState where -import Control.Applicative hiding ((<*>))+import Control.Applicative import Data.Function (on) import qualified Data.Map as Map import Data.Map (Map)@@ -36,10 +37,10 @@ setpp :: PieceIdx -> PlacedPiece -> GameState -> GameState setpp idx pp st@(GameState pps _) =- let displacement = (placedPos $ getpp st idx) <-> placedPos pp+ let displacement = (placedPos $ getpp st idx) -^ placedPos pp updateConn conn@(Connection root@(ridx,rpos) end@(eidx,epos) link)- | ridx == idx = Connection (ridx,rpos<+>displacement) end link- | eidx == idx = Connection root (eidx,epos<+>displacement) link+ | 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 }@@ -57,7 +58,7 @@ | 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' )+ 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)@@ -68,7 +69,7 @@ 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 ]+ sequence_ [ floodfill' (dir+^start) | dir <- hexDirs ] delPiece :: PieceIdx -> GameState -> GameState delPiece idx (GameState pps conns) =@@ -99,18 +100,18 @@ addBlockPos :: PieceIdx -> HexPos -> GameState -> GameState addBlockPos b pos st = let PlacedPiece ppos (Block patt) = getpp st b- in setPiece b (Block (pos <-> ppos:patt)) st+ in setPiece b (Block (pos -^ ppos:patt)) st addPivotArm :: PieceIdx -> HexPos -> GameState -> GameState addPivotArm p pos st = let PlacedPiece ppos (Pivot arms) = getpp st p- in setPiece p (Pivot (pos <-> ppos:arms)) st+ in setPiece p (Pivot (pos -^ ppos:arms)) st locusPos :: GameState -> Locus -> HexPos-locusPos s (idx,v) = v <+> (placedPos $ getpp s idx)+locusPos s (idx,v) = v +^ (placedPos $ getpp s idx) posLocus :: GameState -> HexPos -> Maybe Locus-posLocus st pos = listToMaybe [ (idx,pos<->ppos) |+posLocus st pos = listToMaybe [ (idx,pos-^ppos) | (idx,pp@(PlacedPiece ppos _)) <- enumVec $ placedPieces st , pos `elem` plPieceFootprint pp ] @@ -118,7 +119,7 @@ connectionLength st (Connection root end _) = let rootPos = locusPos st root endPos = locusPos st end- in hexLen (endPos <-> rootPos) - 1+ in hexLen (endPos -^ rootPos) - 1 springsAtIdx,springsEndAtIdx,springsRootAtIdx :: GameState -> PieceIdx -> [Connection] springsAtIdx st idx =@@ -180,7 +181,7 @@ -- 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@@ -194,7 +195,7 @@ in case p of Block patt -> let comps = components $ Set.fromList patt- ppOfComp (v,patt) = PlacedPiece (v<+>ppos) $ Block $ Set.toList patt+ ppOfComp (v,patt) = PlacedPiece (v+^ppos) $ Block $ Set.toList patt in case comps of [] -> (delPiece idx st, Nothing) zeroComp:newComps ->@@ -246,16 +247,16 @@ plPieceMap :: PlacedPiece -> Map HexPos Tile plPieceMap (PlacedPiece pos (Block pattern)) = let pattSet = Set.fromList pattern- in Map.fromList [ (rel <+> pos, BlockTile adjs)+ in Map.fromList [ (rel +^ pos, BlockTile adjs) | rel <- pattern- , let adjs = filter (\dir -> (rel <+> dir) `Set.member` pattSet) hexDirs ]+ , 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 +^ pos, ArmTile rel main) | (rel,main) <- zip arms $ repeat False ] plPieceMap (PlacedPiece pos (Hook arm _)) =- Map.fromList $ (pos, HookTile) : [ (arm <+> pos, ArmTile arm True) ]+ Map.fromList $ (pos, HookTile) : [ (arm +^ pos, ArmTile arm True) ] plPieceMap (PlacedPiece pos (Wrench mom)) = Map.singleton pos $ WrenchTile mom plPieceMap (PlacedPiece pos Ball) = Map.singleton pos BallTile @@ -288,9 +289,9 @@ connectionBoard st (Connection root end@(eidx,_) (Spring dir natLen)) = let rootPos = locusPos st root endPos = locusPos st end- curLen = hexLen (endPos <-> rootPos) - 1+ curLen = hexLen (endPos -^ rootPos) - 1 in Map.fromList $- [ ((d <*> dir) <+> rootPos, (eidx, SpringTile extension dir))+ [ ((d *^ dir) +^ rootPos, (eidx, SpringTile extension dir)) | d <- [1..curLen], let extension | d <= natLen - curLen = Compressed | curLen-d < 2*(curLen - natLen) = Stretched@@ -306,7 +307,7 @@ where castRay' 0 _ = Nothing castRay' n pos = case Map.lookup pos board of- Nothing -> castRay' (n-1) (dir<+>pos)+ Nothing -> castRay' (n-1) (dir+^pos) Just (idx,_) -> Just (idx,pos) validGameState :: GameState -> Bool@@ -317,7 +318,7 @@ | idx <- ppidxs st , idx' <- [0..idx-1] ] , and [ isHexDir dir- && castRay (dir<+>rpos) dir+ && castRay (dir+^rpos) dir (stateBoard $ GameState pps (conns \\ [c])) == Just (eidx, epos) && springExtensionValid st c
Hex.lhs view
@@ -175,37 +175,37 @@ instance (Grp g1, Grp g2) => Grp (g1,g2) where neg (a,b) = (neg a, neg b) -infixl 6 <+>-infixl 6 <->+infixl 6 +^+infixl 6 -^ class Action a b where- (<+>) :: a -> b -> b+ (+^) :: a -> b -> b instance Monoid m => Action m m where- (<+>) = mappend+ (+^) = mappend class Differable a b c where- (<->) :: a -> b -> c+ (-^) :: a -> b -> c instance Grp g => Differable g g g where- x <-> y = x <+> (neg y)+ x -^ y = x +^ (neg y) newtype PHS g = PHS { getPHS :: g } deriving (Eq, Ord, Show, Read) instance Grp g => Action g (PHS g) where- x <+> (PHS y) = PHS (x <+> y)+ x +^ (PHS y) = PHS (x +^ y) instance Grp g => Differable (PHS g) (PHS g) g where- (PHS x) <-> (PHS y) = x <-> y+ (PHS x) -^ (PHS y) = x -^ y -infixl 7 <*>+infixl 7 *^ class MultAction a b where- (<*>) :: a -> b -> b+ (*^) :: a -> b -> b instance (Grp a, Integral n) => MultAction n a where- 0 <*> _ = zero- 1 <*> x = x- n <*> x- | n < 0 = (-n) <*> (neg x)- | even n = (n `div` 2) <*> (x <+> x)- | otherwise = x <+> ((n `div` 2) <*> (x <+> x))+ 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)) \end{code} @@ -238,7 +238,7 @@ a :: PHS HexVec a = PHS zero-test2 = hu <+> a+test2 = hu +^ a -} \end{code} \end{document}
Init.hs view
@@ -27,13 +27,15 @@ import MainState import Interact import Util+import Version -data Opt = LockSize Int | ForceCurses | Help+data Opt = LockSize Int | ForceCurses | Help | Version deriving (Eq, Ord, Show) options = [ Option ['c'] ["curses"] (NoArg ForceCurses) "force curses UI" , Option ['s'] ["locksize"] (ReqArg (LockSize . read) "SIZE") "locksize" , Option ['h'] ["help"] (NoArg Help) "show usage information"+ , Option ['v'] ["version"] (NoArg Version) "show version information" ] usage :: String@@ -51,6 +53,7 @@ argv <- getArgs (opts,args) <- parseArgs argv when (Help `elem` opts) $ putStr usage >> exitSuccess+ when (Version `elem` opts) $ putStrLn version >> exitSuccess let size = fromMaybe 8 $ listToMaybe [ size | LockSize size <- opts ] curDir <- getCurrentDirectory (fromJust <$>) $ runMaybeT $ msum
Interact.hs view
@@ -56,8 +56,10 @@ interactUI :: UIMonad uiM => MainStateT uiM InteractSuccess interactUI = do- lift $ drawMessage ""- (==IMMeta) <$> gets ms2im >>? do+ im <- gets ms2im+ lift $ onNewMode im+ when (im == IMEdit) setSelectedPosFromMouse+ when (im == IMMeta) $ do spawnUnblockerThread -- draw before testing auth, lest a timeout mean a blank screen@@ -68,7 +70,7 @@ tbdg <- lift $ getUIBinding IMMeta CmdTutorials isNothing <$> gets curAuth >>? lift $ drawMessage $ "Welcome. To play the tutorial levels, press '"++tbdg++"'."- setMark startMark+ setMark False startMark interactLoop where@@ -93,6 +95,16 @@ 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++execSubMainState :: UIMonad uiM => MainState -> MainStateT uiM MainState+execSubMainState = (snd <$>) . runSubMainState+ getSomeInput im = do cmds <- getInput im if null cmds then getSomeInput im else return cmds@@ -146,7 +158,7 @@ str <- MaybeT $ lift $ textInput "Mark: " 1 False True Nothing Nothing ch <- liftMaybe $ listToMaybe str guard $ ch `notElem` [startMark, '\'']- lift $ setMark ch+ lift $ setMark True ch processCommand' im CmdJumpMark = void.runMaybeT $ do guard $ im `elem` [IMEdit, IMPlay, IMReplay] str <- MaybeT $ lift $ textInput@@ -188,7 +200,16 @@ modify $ \ms -> ms { curServer = newSaddr } guard.not $ nullSaddr newSaddr msum [ void.MaybeT $ getFreshRecBlocking RecServerInfo- , modify $ \ms -> ms { curServer = saddr } ]+ , 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 processCommand' IMMeta CmdToggleCacheOnly = not <$> gets cacheOnly >>= \c -> modify $ \ms -> ms {cacheOnly = c} @@ -255,7 +276,8 @@ declare undecl , do RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls- soln <- solveLock lock $ Just $+ 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@@ -333,7 +355,7 @@ ls <- lockSpec <$> MaybeT (return $ userLocks uinfo ! idx) RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls RCSolution soln <- MaybeT $ getFreshRecBlocking $ RecNote note- lift.lift $ execStateT interactUI $ newReplayState (snd.reframe$lock) soln $ Just $+ lift $ execSubMainState $ newReplayState (snd.reframe$lock) soln $ Just $ "viewing solution by " ++ noteAuthor note ++ " to " ++ name ++ [':',lockIndexChar idx] processCommand' IMMeta (CmdPlaceLock midx) = void.runMaybeT $ do@@ -383,7 +405,7 @@ ] return (baseLock size, Nothing) path <- lift $ gets curLockPath- newPath <- MaybeT $ lift $ (esPath <$>) $ execStateT interactUI $+ newPath <- MaybeT $ (esPath <$>) $ execSubMainState $ newEditState (reframe lock) msoln (if null path then Nothing else Just path) lift $ setLockPath newPath processCommand' IMMeta CmdTutorials = void.runMaybeT $ do@@ -397,17 +419,17 @@ -- (length (show (length tuts))) False True Nothing Nothing -- i <- liftMaybe $ readMay s -- guard $ 1 <= i && i <= length tuts- let i = 1- let dotut i = do+ 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 []))- solveLock lock $ Just $ "Tutorial " ++ show i ++ ": " ++ text+ 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+ 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@@ -422,7 +444,9 @@ "Tutorial completed! To play on the server, pick a codename ('"++cbdg++ "') and register it ('"++rbdg++"')." else lift $ drawMessage $ "Tutorial completed!"- dotut i+ + (onLevel,msps) <- lift $ gets tutProgress+ dotut onLevel msps processCommand' IMMeta CmdShowRetired = void.runMaybeT $ do name <- mgetCurName newRL <- lift (gets retiredLocks) >>= \rl -> case rl of@@ -448,9 +472,11 @@ ustms <- gets psUndoneStack case ustms of [] -> return ()- ustm:ustms' -> do- pushPState ustm- modify $ \ps -> ps {psUndoneStack = ustms'}+ 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@@ -459,7 +485,7 @@ guard $ case tile of {WrenchTile _ -> True; HookTile -> True; _ -> False} lift $ processCommand' IMPlay $ CmdTile tile ] ++ [ do- tile <- liftMaybe $ snd <$> Map.lookup (d<+>pos) board+ tile <- liftMaybe $ snd <$> Map.lookup (d+^pos) board guard $ tileType tile == if wsel then WrenchTile zero else HookTile lift $ processCommand' IMPlay $ CmdDir WHSSelected $ neg d | d <- hexDirs ]@@ -475,7 +501,7 @@ tile' <- liftMaybe $ snd <$> Map.lookup pos' board' guard $ tileType tile' == if wsel then WrenchTile zero else HookTile lift.lift $ warpPointer $ pos'- | pos' <- map (<+>pos) $ hexDisc 2 ]+ | pos' <- map (+^pos) $ hexDisc 2 ] processCommand' IMPlay cmd = do wsel <- gets wrenchSelected@@ -570,11 +596,10 @@ selPiece <- gets selectedPiece frame <- gets esFrame case selPiece of- Nothing -> modify $ \es -> es {selectedPos = checkEditable frame selPos $ dir <+> selPos}+ Nothing -> modify $ \es -> es {selectedPos = checkEditable frame selPos $ dir +^ selPos} Just p -> doForce $ Push p dir-processCommand' IMEdit (CmdMoveTo newPos) = do- frame <- gets esFrame- modify $ \es -> es {selectedPos = truncateToEditable frame newPos}+processCommand' IMEdit (CmdMoveTo newPos) =+ setSelectedPos newPos processCommand' IMEdit (CmdDrag pos dir) = do board <- stateBoard.head <$> gets esGameStateStack void.runMaybeT $ do@@ -587,7 +612,7 @@ idx' <- liftMaybe $ fst <$> Map.lookup pos' board' guard $ idx' == selIdx lift.lift $ warpPointer $ pos'- | pos' <- [dir<+>pos, pos] ]+ | pos' <- [dir+^pos, pos] ] processCommand' IMEdit (CmdRotate _ dir) = do selPiece <- gets selectedPiece case selPiece of@@ -656,12 +681,35 @@ -- ^ salt password hashPassword name password = hash $ "IY" ++ name ++ password +setSelectedPosFromMouse :: UIMonad uiM => MainStateT uiM ()+setSelectedPosFromMouse = lift getUIMousePos >>= maybe (return ()) setSelectedPos++setSelectedPos :: Monad m => HexPos -> MainStateT m ()+setSelectedPos pos = do+ frame <- gets esFrame+ modify $ \es -> es {selectedPos = truncateToEditable frame pos}+ subPlay :: UIMonad uiM => Lock -> MainStateT uiM () subPlay lock =- pushEState =<< psCurrentState <$> (lift $ execStateT interactUI $ newPlayState lock Nothing True)+ pushEState =<< psCurrentState <$> (execSubMainState $ newPlayState lock Nothing False True) -solveLock :: UIMonad uiM => Lock -> Maybe String -> MaybeT (MainStateT uiM) Solution-solveLock lock title = do- (InteractSuccess solved, ps) <- lift.lift $ runStateT interactUI $ newPlayState (reframe lock) title False+solveLock,solveLockTut :: UIMonad uiM => Lock -> Maybe String -> MaybeT (MainStateT uiM) Solution+solveLock = solveLock' False+solveLockTut = solveLock' True+solveLock' isTut lock title = do+ (InteractSuccess solved, ps) <- lift $ runSubMainState $ newPlayState (reframe lock) title isTut False guard $ solved return $ reverse $ (map snd) $ psGameStateMoveStack ps++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+ 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
InteractUtil.hs view
@@ -63,7 +63,7 @@ modify $ \es -> es {lastModPos = pos} paintTilePath tile from to = if from == to then modify $ \es -> es {lastModPos = to}- else let from' = (hexVec2HexDirOrZero $ to<->from) <+> from+ else let from' = (hexVec2HexDirOrZero $ to-^from) +^ from in drawTile from' tile True >> paintTilePath tile from' to pushEState :: UIMonad uiM => GameState -> MainStateT uiM ()@@ -98,6 +98,7 @@ (\x y -> (if newer then (<) else (>)) x (snd y)) time) <$> (\p -> (,) p <$> getModificationTime p) `mapM` paths +setLockPath :: UIMonad uiM => FilePath -> MainStateT uiM () setLockPath path = do lock <- liftIO $ fullLockPath path >>= readLock modify $ \ms -> ms {curLockPath = path, curLock = lock}@@ -125,7 +126,7 @@ void.runMaybeT $ case ms2im mst of IMEdit -> do st <- liftMaybe $ ch `Map.lookup` esMarks mst- lift $ setMark '\'' >> pushEState st+ lift $ setMark True '\'' >> pushEState st IMPlay -> do mst' <- liftMaybe $ ch `Map.lookup` psMarks mst put mst' { psMarks = Map.insert '\'' mst $ psMarks mst }@@ -134,15 +135,17 @@ put mst' { rsMarks = Map.insert '\'' mst $ rsMarks mst } _ -> return () -setMark :: (Monad m) => Char -> MainStateT m ()-setMark ch = get >>= \mst -> case mst of+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 = Map.insert ch st marks }- PlayState {} -> put $ mst { psMarks = Map.insert ch mst $ psMarks mst }- ReplayState {} -> put $ mst { rsMarks = Map.insert ch mst $ rsMarks mst }+ 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 ()+ where insertMark = Map.insertWith $ \new old -> if overwrite then new else old +askLockIndex :: UIMonad uiM => [Char] -> String -> (Int -> Bool) -> MaybeT (MainStateT uiM) Int askLockIndex prompt failMessage pred = do let ok = filter pred [0,1,2] case length ok of@@ -155,6 +158,7 @@ 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 confirm prompt = do
MainState.hs view
@@ -65,7 +65,9 @@ getDrawImpatience :: m ( Int -> IO () ) toggleColourMode :: m () warpPointer :: HexPos -> m ()+ getUIMousePos :: m (Maybe HexPos) setYNButtons :: m ()+ onNewMode :: InputMode -> m () suspend,redraw :: m () doUI :: m a -> IO (Maybe a)@@ -84,6 +86,7 @@ , psGameStateMoveStack::[(GameState, PlayerMove)] , psUndoneStack::[(GameState, PlayerMove)] , psTitle::Maybe String+ , psIsTut::Bool , psIsSub::Bool , psMarks::Map Char MainState }@@ -110,10 +113,13 @@ | 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]@@ -137,7 +143,7 @@ EditState {} -> IMEdit MetaState {} -> IMMeta -newPlayState (frame,st) title sub = PlayState st frame [] False False [] [] title sub Map.empty+newPlayState (frame,st) title isTut sub = PlayState st frame [] False False [] [] title isTut sub Map.empty newReplayState st soln title = ReplayState st [] soln [] title Map.empty newEditState (frame,st) msoln mpath = EditState [st] [] frame mpath ((\s->(st,s))<$>msoln) (Just (st, isJust msoln)) Nothing (PHS zero) (PHS zero) Map.empty@@ -146,15 +152,49 @@ errtvar <- atomically $ newTVar Nothing invaltvar <- atomically $ newTVar Nothing rnamestvar <- atomically $ newTVar []+ counttvar <- atomically $ newTVar 0 (saddr, auth, path) <- confFilePath "metagame.conf" >>= liftM (fromMaybe (defaultServerAddr, Nothing, "")) . readReadFile let names = maybeToList $ authUser <$> auth- undecls <- if nullSaddr saddr then return [] else- confFilePath ("undeclared" ++ [pathSeparator] ++ saddrStr saddr) >>=- liftM (fromMaybe []) . readReadFile+ (undecls,partials,tut) <- readServerSolns saddr mlock <- fullLockPath path >>= readLock- return $ MetaState saddr undecls False auth names flag errtvar invaltvar rnamestvar Map.empty Map.empty Nothing path mlock 0+ return $ MetaState saddr undecls partials tut False auth names flag counttvar errtvar invaltvar rnamestvar Map.empty Map.empty Nothing path mlock 0 +type PartialSolutions = Map LockSpec SavedPlayState+type TutProgress = (Int,Maybe SavedPlayState)+data SavedPlayState = SavedPlayState [PlayerMove] (Map Char [PlayerMove])+ deriving (Eq, Ord, Show, Read)++savePlayState :: MainState -> SavedPlayState+savePlayState ps = SavedPlayState (getMoves ps) $ Map.map getMoves $ psMarks ps+ where getMoves = reverse . map snd . psGameStateMoveStack++restorePlayState :: SavedPlayState -> Lock -> (Maybe String) -> Bool -> Bool -> MainState+restorePlayState (SavedPlayState pms markPMs) (frame,st) title isTut sub =+ (stateAfterMoves pms) { psMarks = Map.map stateAfterMoves markPMs }+ where+ stateAfterMoves pms = let (stack,st') = applyMoves st pms+ in (newPlayState (frame, st') title isTut sub) { 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+ partials <- confFilePath ("partialSolutions" ++ [pathSeparator] ++ saddrPath saddr) >>=+ liftM (fromMaybe Map.empty) . readReadFile+ tut <- confFilePath "tutProgress" >>=+ liftM (fromMaybe (1,Nothing)) . readReadFile+ return (undecls,partials,tut)++writeServerSolns saddr ms@(MetaState { undeclareds=undecls,+partialSolutions=partials, tutProgress=tut }) = unless (nullSaddr saddr) $ do+ confFilePath ("undeclared" ++ [pathSeparator] ++ saddrPath saddr) >>= flip writeReadFile undecls+ confFilePath ("partialSolutions" ++ [pathSeparator] ++ saddrPath saddr) >>= flip writeReadFile partials+ confFilePath ("tutProgress") >>= flip writeReadFile tut+ readLock :: FilePath -> IO (Maybe (Lock, Maybe Solution)) readLock path = runMaybeT $ msum [ (\l->(l,Nothing)) <$> (MaybeT $ readReadFile path)@@ -165,10 +205,9 @@ -- writeLock :: FilePath -> Lock -> IO () -- writeLock path lock = fullLockPath path >>= flip writeReadFile lock -writeMetaState (MetaState { curServer=saddr, undeclareds=undecls, curAuth=auth, curLockPath=path }) = do+writeMetaState ms@(MetaState { curServer=saddr, curAuth=auth, curLockPath=path }) = do confFilePath "metagame.conf" >>= flip writeReadFile (saddr, auth, path)- unless (nullSaddr saddr) $- confFilePath ("undeclared" ++ [pathSeparator] ++ saddrStr saddr) >>= flip writeReadFile undecls+ writeServerSolns saddr ms getTitle :: UIMonad uiM => MainStateT uiM (Maybe String) getTitle = ms2im <$> get >>= \im -> case im of@@ -305,16 +344,19 @@ saddr <- gets curServer auth <- gets curAuth flag <- gets newAsync+ count <- gets asyncCount errtvar <- gets asyncError 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)) checkAsync :: UIMonad uiM => MainStateT uiM () checkAsync = do@@ -375,17 +417,18 @@ guard $ ourName /= name uinfo <- mgetUInfo name ourUInfo <- mgetUInfo ourName- let (pos,neg) = (countUnaccessedBy ourUInfo name, countUnaccessedBy uinfo ourName)+ let (neg,pos) = (countPoints ourUInfo uinfo, countPoints uinfo ourUInfo) return $ (pos-neg,(pos,neg)) where- countUnaccessedBy ui name = length $ filter isNothing $ getAccessInfo ui name+ 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 ourName <- mgetOurName guard $ ourName /= name uinfo <- mgetUInfo name- guard $ isJust $ getAccessInfo uinfo ourName !! idx+ ourUInfo <- mgetUInfo ourName+ guard $ isJust $ getAccessInfo uinfo ourUInfo !! idx getNotesReadOn :: UIMonad uiM => LockInfo -> MainStateT uiM [NoteInfo] getNotesReadOn lockinfo = (fromMaybe [] <$>) $ runMaybeT $ do@@ -421,10 +464,11 @@ , "If you read three notes on a lock, you will piece together the clues and work out how to solve it." , "" , "Players are judged relative to each of their peers. There are no absolute rankings."- , "Your esteem relative to another player ranges from +3 (best) to -3 (worst), calculated thusly:"- , "Take the number of their locks you can solve, and subtract the number of your locks they can solve."- , "Undeclared solutions don't count. Empty lock slots are considered solved if all actual locks are."- , ""+ , "You win a point of esteem against another player for one of their locks if either:"+ , "you have declared a note on the lock and the lock's owner has not read that note,"+ , "or if you have read three notes on the lock."+ , "Relative esteem ranges from +3 (best) to -3 (worst), and is calculated as"+ , "the number of their locks which win you a point minus the number of your locks which win them one." , "If the secrets to one of your locks become widely disseminated, you may wish to replace it."- , "Once replaced, a lock is \"retired\"; any notes it was securing are read by everyone."+ , "However: once replaced, a lock is \"retired\", and the notes it secured are read by everyone." ]
Metagame.hs view
@@ -16,6 +16,7 @@ import Control.Monad import Data.List (delete) import Data.Char+import Data.Maybe import GameStateTypes import Lock@@ -38,20 +39,41 @@ initLockInfo ls = LockInfo ls False [] [] [] -data AccessedReason = AccessedPrivy | AccessedEmpty | AccessedPub+data NoteInfo = NoteInfo {noteAuthor::Codename, noteBehind::Maybe ActiveLock, noteOn::ActiveLock} deriving (Eq, Ord, Show, Read)-getAccessInfo :: UserInfo -> Codename -> [Maybe AccessedReason]-getAccessInfo ui name =- let mlinfos = elems $ userLocks ui++data ActiveLock = ActiveLock {lockOwner::Codename, lockIndex :: LockIndex}+ deriving (Eq, Ord, Show, Read)++data AccessedReason = AccessedPrivyRead | AccessedPrivySolved {noteReadByOwner::Bool} | AccessedEmpty | AccessedPub+ deriving (Eq, Ord, Show, Read)+winsPoint :: AccessedReason -> Bool+winsPoint (AccessedPrivySolved True) = False+winsPoint _ = True++getAccessInfo :: UserInfo -> UserInfo -> [Maybe AccessedReason]+getAccessInfo accessedUInfo accessorUInfo =+ let accessor = codename accessorUInfo+ mlinfos = elems $ userLocks accessedUInfo accessedSlot = maybe accessedAllExisting accessedLock accessedAllExisting = all (maybe True accessedLock) mlinfos- accessedLock linfo = public linfo || name `elem` accessedBy linfo+ 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 accessedLock linfo then Just AccessedPrivy 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) $ lockSolutions tlock+ data UserInfoDelta = AddRead NoteInfo | DelRead NoteInfo@@ -67,12 +89,6 @@ | SetPublic deriving (Eq, Ord, Show, Read) -data NoteInfo = NoteInfo {noteAuthor::Codename, noteBehind::Maybe ActiveLock, noteOn::ActiveLock}- deriving (Eq, Ord, Show, Read)--data ActiveLock = ActiveLock {lockOwner::Codename, lockIndex :: LockIndex}- deriving (Eq, Ord, Show, Read)- data Undeclared = Undeclared Solution LockSpec ActiveLock deriving (Eq, Ord, Show, Read) @@ -87,7 +103,11 @@ lockIndexChar :: LockIndex -> Char lockIndexChar i = toEnum $ i + fromEnum 'A'+ charLockIndex c = fromEnum (toUpper c) - fromEnum 'A'++alockStr :: ActiveLock -> String+alockStr (ActiveLock name idx) = name ++ [':',lockIndexChar idx] applyDeltas :: UserInfo -> [UserInfoDelta] -> UserInfo applyDeltas = foldr applyDelta
Mundanities.hs view
@@ -26,6 +26,9 @@ catchIO :: IO a -> (IOError -> IO a) -> IO a catchIO = E.catch +catchAll :: IO a -> (E.SomeException -> IO a) -> IO a+catchAll = E.catch+ readReadFile :: (Read a) => FilePath -> IO (Maybe a) readReadFile file = (tryRead . BSC.unpack <$> BS.readFile file)
NEWS view
@@ -1,5 +1,25 @@ This is an abbreviated summary; see the git log for gory details. +0.5.5:+ Save solutions-in-progress of locks and tutorial.+ Indicate when there's a pending request.+ Show alerts on redo in play mode.+0.5.4:+ Fixed some UI bugs involving mode transitions and buttons.+ Hover help on tools in tutorials.+ Actually support ghc-7.10.+0.5.3:+ Change direction of mousewheel movements for undo/redo+ (to agree with English language metaphors with time: up = future).+ Tutorial fiddling, including new level on springs.+ Support ghc-7.10 (hopefully).+0.5.2:+ Fix cache paths on windows.+0.5.1:+ New scoring system - you don't get the point for a solution if the lock+ owner has read your note.+ Server produces RSS feeds.+ Improve handling of switching server. 0.5: Adjustments to graphics, tutorial, and metagame UI, to increase clarity. Concurrency on server; no more freezes while it checks a solution.
Physics.hs view
@@ -184,13 +184,13 @@ collisionsWithForce :: GameState -> Force -> PieceIdx -> [HexPos] collisionsWithForce st (Push idx dir) idx' =- intersect (map (dir<+>) $ footprintAtIgnoring st idx idx') (footprintAtIgnoring st idx' idx)+ intersect (map (dir+^) $ footprintAtIgnoring st idx idx') (footprintAtIgnoring st idx' idx) collisionsWithForce st force idx' = collisions (applyForce force st) (forceIdx force) idx' applyForceTo :: PlacedPiece -> Force -> PlacedPiece applyForceTo (PlacedPiece pos piece) (Push _ dir) =- PlacedPiece (dir <+> pos) piece+ PlacedPiece (dir +^ pos) piece applyForceTo (PlacedPiece pos (Pivot arms)) (Torque _ dir) = PlacedPiece pos (Pivot $ map (rotate dir) arms) applyForceTo (PlacedPiece pos (Hook arm hf)) (Torque _ dir) =@@ -219,10 +219,10 @@ transmittedForce :: GameState -> Source -> HexPos -> HexDir -> Force transmittedForce st idx cpos dir = let pp@(PlacedPiece _ piece) = getpp st idx- rpos = cpos <-> placedPos pp+ rpos = cpos -^ placedPos pp armPush = case- (dir `hexDot` ((rotate 1 rpos) <-> rpos)) `compare`- (dir `hexDot` ((rotate (-1) rpos) <-> rpos)) of+ (dir `hexDot` ((rotate 1 rpos) -^ rpos)) `compare`+ (dir `hexDot` ((rotate (-1) rpos) -^ rpos)) of GT -> Torque idx 1 LT -> Torque idx $ -1 EQ -> Push idx dir@@ -245,9 +245,9 @@ , 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) ]+ 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] |
README view
@@ -68,16 +68,17 @@ the bit with the 3-letter codenames and the three lock slots and notes and so on.) +A player accesses a lock slot when one of the following holds+ (i) the player has read three notes on the lock in the slot;+ (ii) the player has solved the lock in the slot, and declared the solution;+ (iii) there's no lock in the slot, and the player has accessed all the slots+ which do have locks in them.+ Scoring is always relative - each player has a score relative to each other player. That score is the number of the second player's lock slots to which the first player has access, minus the number of the first player's lock slots-to which the second player has access.--A player accesses a lock slot when one of the following holds- * the player has solved the lock in the slot, and declared the solution;- * the player has read three notes on the lock in the slot;- * there's no lock in the slot, and the player has accessed all the slots- which do have locks in them.+to which the second player has access; but a point is not awarded for+case (ii) if the owner of the lock has read the note. A player reads every note in every lock the player accesses. When a lock is replaced ('retired'), each note secured by the lock becomes 'public', and is
SDLRender.hs view
@@ -26,7 +26,7 @@ import Data.List (maximumBy) import Data.Function (on) import GHC.Int (Int16)-import Control.Applicative hiding ((<*>))+import Control.Applicative import System.Random (randomRIO) import Hex@@ -298,7 +298,7 @@ sequence_ [ arc surf (fi x) (fi y) (fi $ n*size `div` 4) a1 a2 col | n <- [8,9] ] where- SVec x y = centre <+> hexVec2SVec size (neg armdir)+ SVec x y = centre +^ hexVec2SVec size (neg armdir) a0 = fi $ -60*hextant armdir a1' = a0 + fi tdir * 10 a2' = a0 + fi tdir * 30@@ -306,7 +306,7 @@ a2 = max a1' a2' renderGlyph (BlockedBlock tile dir col) centre size surf =- renderGlyph (TileGlyph tile col) (shift <+> centre) size surf+ renderGlyph (TileGlyph tile col) (shift +^ centre) size surf where shift = SVec (x'-x) (y'-y) (x,y) = innerCorner centre size dir@@ -515,7 +515,7 @@ displaceRender :: SVec -> RenderM a -> RenderM a displaceRender disp = local displace- where displace rc = rc { renderSCentre = renderSCentre rc <+> disp }+ where displace rc = rc { renderSCentre = renderSCentre rc +^ disp } recentreAt :: HexVec -> RenderM a -> RenderM a recentreAt v m = do@@ -553,12 +553,12 @@ drawAt :: Glyph -> HexPos -> RenderM () drawAt gl pos = do centre <- asks renderHCentre- drawAtRel gl (pos <-> centre)+ drawAtRel gl (pos -^ centre) drawAtRel :: Glyph -> HexVec -> RenderM () drawAtRel gl v = do (surf, scrCentre, size) <- asks $ liftM3 (,,) renderSurf renderSCentre renderSize- let cpos = scrCentre <+> (hexVec2SVec size v)+ let cpos = scrCentre +^ (hexVec2SVec size v) renderGlyphCaching gl cpos size surf messageCol = white@@ -578,17 +578,24 @@ 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) <+>+ 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) void $ liftIO $ blitSurface fsurf Nothing surf (Just $ Rect x y 0 0) +renderStrColAbove = renderStrColVShifted True+renderStrColBelow = renderStrColVShifted False+renderStrColVShifted :: Bool -> Pixel -> String -> HexVec -> RenderM ()+renderStrColVShifted up c str v = do+ size <- asks renderSize+ displaceRender (SVec size 0) $ renderStrColAt c str $ v +^ (if up then hv else hw)+ blankRow v = do (surf, scrCentre, size) <- asks $ liftM3 (,,) renderSurf renderSCentre renderSize- let SVec _ y = scrCentre <+> (hexVec2SVec size v)+ let SVec _ y = scrCentre +^ (hexVec2SVec size v) w = surfaceGetWidth surf h = ceiling $ fi (size * 3 `div` 2) * 2 / sqrt 3 fillRectBG $ Just $ Rect 0 (y-h`div`2) w h@@ -604,7 +611,7 @@ 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) |+ sequence_ [ drawAt (BlockedArm arm dir col) (arm +^ pos) | arm <- arms ] drawBlocked st colouring blocking (Push idx dir) = do let footprint = plPieceFootprint $ getpp st idx@@ -612,7 +619,7 @@ col = bright $ if blocking then purple else orange sequence_ [ drawAt (BlockedPush dir col) pos | pos <- footprint- , (dir<+>pos) `notElem` fullfootprint ]+ , (dir+^pos) `notElem` fullfootprint ] -- drawAt (blockedPush dir $ bright orange) $ placedPos $ getpp st idx drawApplied :: GameState -> PieceColouring -> Force -> RenderM ()@@ -622,7 +629,7 @@ PlacedPiece pos (Hook arm _) -> (pos,[arm]) _ -> (pos,[]) col = dim $ colourOf colouring idx- sequence_ [ drawAt (TurnedArm arm dir col) (arm <+> pos) |+ sequence_ [ drawAt (TurnedArm arm dir col) (arm +^ pos) | arm <- arms ] drawApplied _ _ _ = return () @@ -630,7 +637,7 @@ blitAt :: Surface -> HexVec -> RenderM () blitAt surface v = do (surf, scrCentre, size) <- asks $ liftM3 (,,) renderSurf renderSCentre renderSize- let SVec x y = scrCentre <+> (hexVec2SVec size v)+ let SVec x y = scrCentre +^ (hexVec2SVec size v) w = surfaceGetWidth surface h = surfaceGetHeight surface void $ liftIO $ blitSurface surface Nothing surf $ Just $
SDLUI.hs view
@@ -16,7 +16,7 @@ import qualified Graphics.UI.SDL as SDL import qualified Graphics.UI.SDL.TTF as TTF import Control.Concurrent.STM-import Control.Applicative hiding ((<*>))+import Control.Applicative import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe@@ -58,7 +58,7 @@ , cachedGlyphs::CachedGlyphs , lastDrawArgs::Maybe DrawArgs , miniLocks::Map Lock Surface- , metaSelectables::Map HexVec Selectable+ , registeredSelectables::Map HexVec Selectable , contextButtons::[ButtonGroup] , uiOptions::UIOptions , settingBinding::Maybe Command@@ -71,6 +71,7 @@ , mousePos::(HexVec,Bool) , message::Maybe (Pixel, String) , hoverStr :: Maybe String+ , needHoverUpdate::Bool , dispCentre::HexPos , dispLastCol::PieceColouring , animFrame::Int@@ -84,7 +85,7 @@ type UIM = StateT UIState IO nullUIState = UIState 0 0 Nothing Nothing emptyCachedGlyphs Nothing Map.empty Map.empty [] defaultUIOptions Nothing Map.empty Nothing Nothing 0 0 Nothing Nothing Nothing- (zero,False) Nothing Nothing (PHS zero) Map.empty 0 Nothing 25+ (zero,False) Nothing Nothing False (PHS zero) Map.empty 0 Nothing 25 #ifdef SOUND Map.empty #endif@@ -101,6 +102,8 @@ } deriving (Eq, Ord, Show, Read) defaultUIOptions = UIOptions False ShowBlocksBlocking Nothing True False True True 100++modifyUIOptions :: (UIOptions -> UIOptions) -> UIM () modifyUIOptions f = modify $ \s -> s { uiOptions = f $ uiOptions s } renderToMain :: RenderM a -> UIM a@@ -146,54 +149,54 @@ 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)]+ 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)] ]+ , singleButton (br+^2*^hu) CmdWriteState 2 [("save", hu+^neg hw)] ] ++ whsBGs mwhs mode- ++ [ ([Button (paintButtonStart <+> hu <+> i<*>hv) (paintTileCmds!!i) []+ ++ [ ([Button (paintButtonStart +^ hu +^ i*^hv) (paintTileCmds!!i) [] | i <- take (length paintTiles) [0..] ],(5,0)) ] IMPlay -> [ markGroup ] ++ whsBGs mwhs mode- ++ [ singleButton tr CmdOpen 1 [("open", hu<+>neg hw)] ]+ ++ [ singleButton tr CmdOpen 1 [("open", hu+^neg hw)] ] IMReplay -> [ markGroup ] IMMeta ->- [ singleButton serverPos CmdSetServer 0 [("server",3<*>hw)]- , singleButton (serverPos<+>neg hu) CmdToggleCacheOnly 0 [("cache",hv<+>6<*>neg hu),("only",hw<+>5<*>neg hu)]- , singleButton (codenamePos <+> 2<*>neg hu) (CmdSelCodename Nothing) 2 [("code",hv<+>5<*>neg hu),("name",hw<+>5<*>neg hu)]- , singleButton (serverPos <+> 2<*>neg hv <+> 2<*>hw) CmdTutorials 3 [("play",hu<+>neg hw),("tut",hu<+>neg hv)]+ [ singleButton serverPos CmdSetServer 0 [("server",3*^hw)]+ , singleButton (serverPos+^neg hu) CmdToggleCacheOnly 0 [("cache",hv+^6*^neg hu),("only",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))+ 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 == IMTextInput then [] else- [ singleButton br CmdQuit 0 [("quit",hu<+>neg hw)]- , singleButton (tr <+> 3<*>hv <+> 3<*>hu) CmdHelp 3 [("help",hu<+>neg hw)] ]+ [ 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 [])+ , ( [ 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))+ [ ( [ Button (bl+^((-2)*^hv)) (CmdRotate whs (-1))- [("turn",hu<+>neg hw),("cw",hu<+>neg hv)]- , Button (bl<+>((-2)<*>hw))+ [("turn",hu+^neg hw),("cw",hu+^neg hv)]+ , Button (bl+^((-2)*^hw)) (CmdRotate whs 1)- [("turn",hu<+>neg hw),("ccw",hu<+>neg hv)]+ [("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)]+ [ ( [ 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@@ -206,7 +209,8 @@ | SelLock ActiveLock | SelLockUnset Bool ActiveLock | SelSelectedCodeName Codename- | SelRelScore Int+ | SelRelScore+ | SelRelScoreComponent | SelScoreLock (Maybe Codename) (Maybe AccessedReason) ActiveLock | SelUndeclared Undeclared | SelReadNote NoteInfo@@ -221,57 +225,65 @@ | SelLockPath | SelPrivyHeader | SelNotesHeader+ | SelToolHook+ | SelToolWrench deriving (Eq, Ord, Show) +registerSelectable :: HexVec -> Int -> Selectable -> UIM () registerSelectable v r s =- modify $ \ds -> ds {metaSelectables = foldr- (`Map.insert` s) (metaSelectables ds) $ map (v<+>) $ hexDisc r}+ modify $ \ds -> ds {registeredSelectables = foldr+ (`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 () registerButton pos cmd col helps = registerButtonGroup $ singleButton pos cmd col helps clearSelectables,clearButtons :: UIM ()-clearSelectables = modify $ \ds -> ds {metaSelectables = Map.empty}+clearSelectables = modify $ \ds -> ds {registeredSelectables = Map.empty} clearButtons = modify $ \ds -> ds {contextButtons = []} +registerUndoButtons :: Bool -> Bool -> UIM () registerUndoButtons noUndo noRedo = do- unless noUndo $ registerButton (periphery 2<+>hu) CmdUndo 0 [("undo",hu<+>neg hw)]- unless noRedo $ registerButton (periphery 2<+>hu<+>neg hv) CmdRedo 2 [("redo",hu<+>neg hw)]+ unless noUndo $ registerButton (periphery 2+^hu) CmdUndo 0 [("undo",hu+^neg hw)]+ unless noRedo $ registerButton (periphery 2+^hu+^neg hv) CmdRedo 2 [("redo",hu+^neg hw)] -commandOfSelectable IMMeta SelOurLock _ = CmdEdit-commandOfSelectable IMMeta (SelLock (ActiveLock _ i)) False = CmdSolve (Just i)-commandOfSelectable IMMeta (SelLock (ActiveLock _ i)) True = CmdPlaceLock (Just i)-commandOfSelectable IMMeta (SelScoreLock Nothing _ (ActiveLock _ i)) False = CmdSolve (Just i)-commandOfSelectable IMMeta (SelScoreLock Nothing _ (ActiveLock _ i)) True = CmdPlaceLock (Just i)-commandOfSelectable IMMeta (SelScoreLock (Just _) _ _) _ = CmdHome-commandOfSelectable IMMeta (SelLockUnset True (ActiveLock _ i)) _ = CmdPlaceLock (Just i)-commandOfSelectable IMMeta (SelSelectedCodeName _) False = CmdSelCodename Nothing-commandOfSelectable IMMeta (SelSelectedCodeName _) True = CmdHome-commandOfSelectable IMMeta (SelUndeclared undecl) _ = CmdDeclare $ Just undecl-commandOfSelectable IMMeta (SelReadNote note) False = CmdSelCodename $ Just $ noteAuthor note-commandOfSelectable IMMeta (SelReadNote note) True = CmdViewSolution $ Just note-commandOfSelectable IMMeta (SelSolution note) False = CmdSelCodename $ Just $ noteAuthor note-commandOfSelectable IMMeta (SelSolution note) True = CmdViewSolution $ Just note-commandOfSelectable IMMeta (SelAccessed name) _ = CmdSelCodename $ Just name-commandOfSelectable IMMeta (SelRandom name) _ = CmdSelCodename $ Just name-commandOfSelectable IMMeta (SelSecured note) False = CmdSelCodename $ Just $ lockOwner $ noteOn note-commandOfSelectable IMMeta (SelSecured note) True = CmdViewSolution $ Just note-commandOfSelectable IMMeta (SelOldLock ls) _ = CmdPlayLockSpec $ Just ls-commandOfSelectable IMMeta (SelLockPath) _ = CmdSelectLock-commandOfSelectable IMTextInput (SelLock (ActiveLock _ i)) _ = CmdInputSelLock i-commandOfSelectable IMTextInput (SelScoreLock _ _ (ActiveLock _ i)) _ = CmdInputSelLock i-commandOfSelectable IMTextInput (SelLockUnset _ (ActiveLock _ i)) _ = CmdInputSelLock i-commandOfSelectable IMTextInput (SelReadNote note) _ = CmdInputCodename $ noteAuthor note-commandOfSelectable IMTextInput (SelSolution note) _ = CmdInputCodename $ noteAuthor note-commandOfSelectable IMTextInput (SelSecured note) _ = CmdInputCodename $ lockOwner $ noteOn note-commandOfSelectable IMTextInput (SelRandom name) _ = CmdInputCodename name-commandOfSelectable IMTextInput (SelUndeclared undecl) _ = CmdInputSelUndecl undecl-commandOfSelectable _ _ _ = CmdNone+commandOfSelectable IMMeta SelOurLock _ = Just $ CmdEdit+commandOfSelectable IMMeta (SelLock (ActiveLock _ i)) False = Just $ CmdSolve (Just i)+commandOfSelectable IMMeta (SelLock (ActiveLock _ i)) True = Just $ CmdPlaceLock (Just i)+commandOfSelectable IMMeta (SelScoreLock Nothing _ (ActiveLock _ i)) False = Just $ CmdSolve (Just i)+commandOfSelectable IMMeta (SelScoreLock Nothing _ (ActiveLock _ i)) True = Just $ CmdPlaceLock (Just i)+commandOfSelectable IMMeta (SelScoreLock (Just _) _ _) _ = Just $ CmdHome+commandOfSelectable IMMeta (SelLockUnset True (ActiveLock _ i)) _ = Just $ CmdPlaceLock (Just i)+commandOfSelectable IMMeta (SelSelectedCodeName _) False = Just $ CmdSelCodename Nothing+commandOfSelectable IMMeta (SelSelectedCodeName _) True = Just $ CmdHome+commandOfSelectable IMMeta (SelUndeclared undecl) _ = Just $ CmdDeclare $ Just undecl+commandOfSelectable IMMeta (SelReadNote note) False = Just $ CmdSelCodename $ Just $ noteAuthor note+commandOfSelectable IMMeta (SelReadNote note) True = Just $ CmdViewSolution $ Just note+commandOfSelectable IMMeta (SelSolution note) False = Just $ CmdSelCodename $ Just $ noteAuthor note+commandOfSelectable IMMeta (SelSolution note) True = Just $ CmdViewSolution $ Just note+commandOfSelectable IMMeta (SelAccessed name) _ = Just $ CmdSelCodename $ Just name+commandOfSelectable IMMeta (SelRandom name) _ = Just $ CmdSelCodename $ Just name+commandOfSelectable IMMeta (SelSecured note) False = Just $ CmdSelCodename $ Just $ lockOwner $ noteOn note+commandOfSelectable IMMeta (SelSecured note) True = Just $ CmdViewSolution $ Just note+commandOfSelectable IMMeta (SelOldLock ls) _ = Just $ CmdPlayLockSpec $ Just ls+commandOfSelectable IMMeta (SelLockPath) _ = Just $ CmdSelectLock+commandOfSelectable IMTextInput (SelLock (ActiveLock _ i)) _ = Just $ CmdInputSelLock i+commandOfSelectable IMTextInput (SelScoreLock _ _ (ActiveLock _ i)) _ = Just $ CmdInputSelLock i+commandOfSelectable IMTextInput (SelLockUnset _ (ActiveLock _ i)) _ = Just $ CmdInputSelLock i+commandOfSelectable IMTextInput (SelReadNote note) _ = Just $ CmdInputCodename $ noteAuthor note+commandOfSelectable IMTextInput (SelSolution note) _ = Just $ CmdInputCodename $ noteAuthor note+commandOfSelectable IMTextInput (SelSecured note) _ = Just $ CmdInputCodename $ lockOwner $ noteOn note+commandOfSelectable IMTextInput (SelRandom name) _ = Just $ CmdInputCodename name+commandOfSelectable IMTextInput (SelUndeclared undecl) _ = Just $ CmdInputSelUndecl undecl+commandOfSelectable _ _ _ = Nothing helpOfSelectable SelOurLock = Just "Design a lock." helpOfSelectable (SelSelectedCodeName name) = Just $ "Currently viewing "++name++"."-helpOfSelectable (SelRelScore score) = Just $+helpOfSelectable SelRelScore = Just $ "The extent to which you are held in higher esteem than this fellow guild member."+helpOfSelectable SelRelScoreComponent = Just $+ "Contribution to total relative esteem." helpOfSelectable (SelLock (ActiveLock name i)) = Just $ name++"'s lock "++[lockIndexChar i]++"." helpOfSelectable (SelLockUnset True _) = Just@@ -283,17 +295,25 @@ helpOfSelectable (SelRandom _) = Just "Random set of guild members. Colours show relative esteem, bright red (-3) to bright green (+3)." helpOfSelectable (SelScoreLock (Just name) Nothing _) = Just $- "Your lock, the secrets to which "++name++" is not privy."-helpOfSelectable (SelScoreLock (Just name) (Just AccessedPrivy) _) = Just $- "Your lock, the secrets to which "++name++" is privy: -1 to relative esteem."+ "Your lock, the secrets of which "++name++" is not privy to."+helpOfSelectable (SelScoreLock (Just name) (Just AccessedPrivyRead) _) = Just $+ "Your lock, the secrets of which "++name++" has read three notes on: -1 to relative esteem."+helpOfSelectable (SelScoreLock (Just name) (Just (AccessedPrivySolved False)) _) = Just $+ "Your lock, on which "++name++" has declared a note which you have not read: -1 to relative esteem."+helpOfSelectable (SelScoreLock (Just name) (Just (AccessedPrivySolved True)) _) = Just $+ "Your lock, on which "++name++" has declared a note which you have read." helpOfSelectable (SelScoreLock (Just name) (Just AccessedPub) _) = Just $ "Your lock, the secrets of which have been publically revealed: -1 to relative esteem." helpOfSelectable (SelScoreLock (Just name) (Just AccessedEmpty) _) = Just $ "Your empty lock slot; "++name++" is privy to the secrets of all your locks: -1 to relative esteem." helpOfSelectable (SelScoreLock Nothing Nothing (ActiveLock name _)) = Just $- name++"'s lock, the secrets to which you are not privy."-helpOfSelectable (SelScoreLock Nothing (Just AccessedPrivy) (ActiveLock name _)) = Just $- name++"'s lock, the secrets to which you are privy: +1 to relative esteem."+ name++"'s lock, the secrets of which you are not privy to."+helpOfSelectable (SelScoreLock Nothing (Just AccessedPrivyRead) (ActiveLock name _)) = Just $+ name++"'s lock, the secrets of which you have read three notes on: +1 to relative esteem."+helpOfSelectable (SelScoreLock Nothing (Just (AccessedPrivySolved False)) (ActiveLock name _)) = Just $+ name++"'s lock, on which you have declared a note which "++name++" has not read: +1 to relative esteem."+helpOfSelectable (SelScoreLock Nothing (Just (AccessedPrivySolved True)) (ActiveLock name _)) = Just $+ name++"'s lock, on which you have declared a note which "++name++" has read." helpOfSelectable (SelScoreLock Nothing (Just AccessedPub) (ActiveLock name _)) = Just $ name++"'s lock, the secrets of which have been publically revealed: +1 to relative esteem." helpOfSelectable (SelScoreLock Nothing (Just AccessedEmpty) (ActiveLock name _)) = Just $@@ -323,86 +343,91 @@ helpOfSelectable SelLockPath = Just $ "Select a lock by its name. The names you give your locks are not revealed to others." helpOfSelectable SelPrivyHeader = Just $- "Fellow uild members privy to this lock's secrets, hence able to read its secured notes."+ "Fellow guild members privy to this lock's secrets, hence able to read its secured notes." helpOfSelectable SelNotesHeader = Just $ "Secured notes. Notes are obfuscated sketches of method, proving success but revealing little."+helpOfSelectable SelToolWrench = Just $ "The wrench, one of your lockpicking tools. Click and drag to move."+helpOfSelectable SelToolHook = Just $ "The hook, one of your lockpicking tools. Click and drag to move, use mousewheel to turn." cmdAtMousePos pos@(mPos,central) im selMode = do buttons <- (concat . map fst) <$> getButtons im- sels <- gets metaSelectables+ sels <- gets registeredSelectables return $ listToMaybe $ [ buttonCmd button | button <- buttons, mPos == buttonPos button, central]- ++ maybe [] (\isRight -> [ commandOfSelectable im sel isRight- | Just sel <- [Map.lookup mPos sels] ]) selMode+ ++ maybe [] (\isRight ->+ [ cmd+ | Just sel <- [Map.lookup mPos sels]+ , Just cmd <- [ commandOfSelectable im sel isRight ] ])+ selMode -helpAtMousePos pos@(mPos,_) IMMeta =- join . fmap helpOfSelectable . Map.lookup mPos <$> gets metaSelectables-helpAtMousePos _ _ = return Nothing+helpAtMousePos :: (HexVec, Bool) -> InputMode -> UIM (Maybe [Char])+helpAtMousePos (mPos,_) _ =+ join . fmap helpOfSelectable . Map.lookup mPos <$> gets registeredSelectables data UIOptButton a = UIOptButton { getUIOpt::UIOptions->a, setUIOpt::a->UIOptions->UIOptions, uiOptVals::[a], uiOptPos::HexVec, uiOptGlyph::a->Glyph, uiOptDescr::a->String,- onSet :: Maybe (a -> UIM ()) }+ uiOptModes::[InputMode], onSet :: Maybe (a -> UIM ()) } -- non-uniform type, so can't use a list... uiOB1 = UIOptButton useFiveColouring (\v o -> o {useFiveColouring=v}) [True,False]- (periphery 0 <+> 2 <*> hu) UseFiveColourButton+ (periphery 0 +^ 2 *^ hu) UseFiveColourButton (\v -> if v then "Adjacent pieces get different colours" else "Pieces are coloured according to type")- Nothing+ [IMPlay, IMReplay, IMEdit] Nothing uiOB2 = UIOptButton showBlocks (\v o -> o {showBlocks=v}) [ShowBlocksBlocking,ShowBlocksAll,ShowBlocksNone]- (periphery 0 <+> 2 <*> hu <+> 2 <*> neg hv) ShowBlocksButton+ (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")- Nothing+ [IMPlay, IMReplay] Nothing uiOB3 = UIOptButton whsButtons (\v o -> o {whsButtons=v}) [Nothing, Just WHSSelected, Just WHSWrench, Just WHSHook]- (periphery 3 <+> 3 <*> hv) WhsButtonsButton+ (periphery 3 +^ 3 *^ hv) WhsButtonsButton (\v -> case v of- Nothing -> "Showing mouse controls; click to show keyboard control buttons."+ Nothing -> "Click to show (and rebind) keyboard control buttons." Just whs -> "Showing buttons for controlling " ++ case whs of WHSSelected -> "selected piece" WHSWrench -> "wrench"- WHSHook -> "hook")- Nothing+ WHSHook -> "hook; right-click to rebind")+ [IMPlay, IMEdit] Nothing uiOB4 = UIOptButton showButtonText (\v o -> o {showButtonText=v}) [True,False]- (periphery 0 <+> 2 <*> hu <+> 2 <*> hv) ShowButtonTextButton+ (periphery 0 +^ 2 *^ hu +^ 2 *^ hv) ShowButtonTextButton (\v -> if v then "Help text enabled" else "Help text disabled")- Nothing+ [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 "Fullscreen mode" else- "Windowed mode")- (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+ (periphery 0 +^ 3 *^ hu +^ hv) UseSoundsButton (\v -> if v then "Sound effects enabled" else "Sound effects disabled")- Nothing+ [IMPlay, IMEdit, IMReplay] Nothing drawUIOptionButtons :: InputMode -> UIM () drawUIOptionButtons mode = do- when (mode `elem` [IMPlay, IMEdit, IMReplay]) $ do- drawUIOptionButton uiOB1- drawUIOptionButton uiOB2- unless (mode == IMReplay) $ drawUIOptionButton uiOB3+ drawUIOptionButton mode uiOB1+ drawUIOptionButton mode uiOB2+ drawUIOptionButton mode uiOB3+ drawUIOptionButton mode uiOB4+ drawUIOptionButton mode uiOB5 #ifdef SOUND- drawUIOptionButton uiOB6+ drawUIOptionButton mode uiOB6 #endif- drawUIOptionButton uiOB4- drawUIOptionButton uiOB5-drawUIOptionButton b = do+drawUIOptionButton im b = when (im `elem` uiOptModes b) $ do value <- gets $ (getUIOpt b).uiOptions renderToMain $ mapM_ (\g -> drawAtRel g (uiOptPos b)) [HollowGlyph $ obscure purple, uiOptGlyph b value]+describeUIOptionButton :: UIOptButton a -> MaybeT UIM String describeUIOptionButton b = do value <- gets $ (getUIOpt b).uiOptions return $ uiOptDescr b value -- XXX: hand-hacking lenses...-toggleUIOption (UIOptButton getopt setopt vals _ _ _ monSet) = do+toggleUIOption (UIOptButton getopt setopt vals _ _ _ _ monSet) = do value <- gets $ getopt.uiOptions let value' = head $ drop (1 + (fromMaybe 0 $ elemIndex value vals)) $ cycle vals modifyUIOptions $ setopt value'@@ -438,6 +463,7 @@ liftIO makeConfDir liftIO $ writeFile path $ show bdgs +getBindings :: InputMode -> UIM [(Char, Command)] getBindings mode = do uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings return $ uibdgs ++ bindings mode@@ -462,7 +488,7 @@ else gets paintTileIndex paintButtonStart :: HexVec-paintButtonStart = periphery 0 <+> (- length paintTiles `div` 2)<*>hv+paintButtonStart = periphery 0 +^ (- length paintTiles `div` 2)*^hv drawPaintButtons :: UIM () drawPaintButtons = do@@ -475,16 +501,16 @@ drawAtRel gl pos when selected $ drawAtRel cursorGlyph pos | i <- take (length paintTiles) [0..]- , let pos = paintButtonStart <+> i<*>hv+ , let pos = paintButtonStart +^ i*^hv , let selected = i == pti ] -periphery 0 = ((3*maxlocksize)`div`2)<*>hu <+> ((3*maxlocksize)`div`4)<*>hv+periphery 0 = ((3*maxlocksize)`div`2)*^hu +^ ((3*maxlocksize)`div`4)*^hv periphery n = rotate n $ periphery 0 -- ^ XXX only peripheries 0,2,3,5 are guaranteed to be on-screen!---messageLineStart = (maxlocksize+1)<*>hw-messageLineCentre = ((maxlocksize+1)`div`2)<*>hw <+> ((maxlocksize+1+1)`div`2)<*>neg hv-titlePos = (maxlocksize+1)<*>hv <+> ((maxlocksize+1)`div`2)<*>hu+--messageLineStart = (maxlocksize+1)*^hw+messageLineCentre = ((maxlocksize+1)`div`2)*^hw +^ ((maxlocksize+1+1)`div`2)*^neg hv+titlePos = (maxlocksize+1)*^hv +^ ((maxlocksize+1)`div`2)*^hu screenWidthHexes,screenHeightHexes::Int screenWidthHexes = 32@@ -782,15 +808,15 @@ say = setMsgLine messageCol sayError = setMsgLine errorCol -miniLockPos = (-9)<*>hw <+> hu-lockLinePos = 4<*>hu <+> miniLockPos-serverPos = 12<*>hv <+> 7<*>neg hu-serverWaitPos = serverPos <+> hw <+> neg hu-randomNamesPos = 9<*>hv <+> 2<*> neg hu-codenamePos = (-6)<*>hw <+> 6<*>hv-undeclsPos = 13<*>neg hu-accessedOursPos = 2<*>hw <+> codenamePos-locksPos = hw<+>neg hv-retiredPos = locksPos <+> 11<*>hu <+> neg hv-interactButtonsPos = 9<*>neg hu <+> 8<*>hw-scoresPos = codenamePos <+> 5<*>hu <+> 2<*>neg hv+miniLockPos = (-9)*^hw +^ hu+lockLinePos = 4*^hu +^ miniLockPos+serverPos = 12*^hv +^ 7*^neg hu+serverWaitPos = serverPos +^ hw +^ neg hu+randomNamesPos = 9*^hv +^ 2*^ neg hu+codenamePos = (-6)*^hw +^ 6*^hv+undeclsPos = 13*^neg hu+accessedOursPos = 2*^hw +^ codenamePos+locksPos = hw+^neg hv+retiredPos = locksPos +^ 11*^hu +^ neg hv+interactButtonsPos = 9*^neg hu +^ 8*^hw+scoresPos = codenamePos +^ 5*^hu +^ 2*^neg hv
SDLUIMInstance.hs view
@@ -8,15 +8,15 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/. -{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} {-# OPTIONS_GHC -cpp #-} module SDLUIMInstance () where -import Graphics.UI.SDL hiding (flip)+import Graphics.UI.SDL hiding (flip, name) import qualified Graphics.UI.SDL as SDL import qualified Graphics.UI.SDL.TTF as TTF import Control.Concurrent.STM-import Control.Applicative hiding ((<*>))+import Control.Applicative import System.Timeout import qualified Data.Map as Map import Data.Map (Map)@@ -62,11 +62,14 @@ 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 }) = do+ drawMainState' (PlayState { psCurrentState=st, psLastAlerts=alerts, wrenchSelected=wsel, psIsTut=isTut }) = do canUndo <- null <$> gets psGameStateMoveStack canRedo <- null <$> gets psUndoneStack lift $ do@@ -74,6 +77,17 @@ (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 drawMainState' (ReplayState { rsCurrentState=st, rsLastAlerts=alerts } ) = do canUndo <- null <$> gets rsGameStateMoveStack@@ -88,17 +102,20 @@ 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)]+ [ 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)]+ $ registerButton (periphery 0 +^ d) cmd 2 [("place",hu+^neg hw),(tool,hu+^neg hv)] | (pred,tool,cmd,d) <- [- (isWrench, "wrench", CmdTile $ WrenchTile zero, 3<*>hu <+> hv),- (isHook, "hook", CmdTile $ HookTile, 3<*>hu <+> 2<*>hv)] ]+ (isWrench, "wrench", CmdTile $ WrenchTile zero, (-4)*^hv +^ hw),+ (isHook, "hook", CmdTile $ HookTile, (-3)*^hv +^ hw) ] ] drawPaintButtons- drawMainState' (MetaState saddr undecls cOnly auth names _ _ _ rnamestvar _ _ mretired path mlock offset) = do+ 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@@ -107,53 +124,56 @@ smallFont <- gets dispFontSmall renderToMain $ withFont smallFont $ renderStrColAtLeft messageCol (saddrStr saddr ++ if cOnly then " (cache only)" else "")- $ serverPos <+> hu+ $ serverPos +^ hu when (length names > 1) $ lift $ registerButton- (codenamePos <+> neg hu <+> 2<*>hw) CmdBackCodename 0 [("back",3<*>hw)]+ (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 $ do+ unless ((fresh && not pending) || cOnly) $ do smallFont <- gets dispFontSmall- renderToMain $ withFont smallFont $ renderStrColAtLeft (opaquify $ dim errorCol) "(stale)" $ serverWaitPos+ 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 && isNothing ourName- in registerButton (codenamePos <+> 2<*>hu)+ in registerButton (codenamePos +^ 2*^hu) (if reg then CmdRegister else CmdAuth) (if isNothing ourName then 2 else 0)- [(if reg then "reg" else "auth", 3<*>hw)]+ [(if 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)+ drawRelScore name (codenamePos+^hu) when (isJust muirc) $ lift $- registerButton retiredPos CmdShowRetired 5 [("retired",hu<+>neg hw)]+ 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]])+ (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)]+ lift $ registerButton (retiredPos +^ hv) (CmdPlayLockSpec Nothing) 1 [("play",hu+^neg hw),("no.",hu+^neg hv)] Nothing -> do sequence_ [ drawLockInfo (ActiveLock (codename uinfo) i) mlockinfo | (i,mlockinfo) <- assocs $ userLocks uinfo ] when (isJust $ msum $ elems $ userLocks uinfo) $ lift $ do- registerButton interactButtonsPos (CmdSolve Nothing) 2 [("solve",hu<+>neg hw),("lock",hu<+>neg hv)]- registerButton (interactButtonsPos<+>hw) (CmdViewSolution Nothing) 1 [("view",hu<+>neg hw),("soln",hu<+>neg hv)]+ registerButton interactButtonsPos (CmdSolve Nothing) 2 [("solve",hu+^neg hw),("lock",hu+^neg hv)]+ registerButton (interactButtonsPos+^hw) (CmdViewSolution Nothing) 1 [("view",hu+^neg hw),("soln",hu+^neg hv)] when home $ do lift.renderToMain $ renderStrColAt messageCol- "Home" (codenamePos<+>hw<+>neg hv)+ "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])+ 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@@ -161,63 +181,69 @@ (\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 (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+ 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)]+ [ 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)+ (miniLockPos+^2*^neg hw+^3*^hu) (CmdPlaceLock Nothing) (if tested then 2 else 1)- [("place",hu<+>neg hw),("lock",hu<+>neg hv)]+ [("place",hu+^neg hw),("lock",hu+^neg hv)] rnames <- liftIO $ atomically $ readTVar rnamestvar unless (null rnames) $ fillArea randomNamesPos- (map (randomNamesPos<+>) $ hexDisc 2)+ (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)]+ lift.lift $ registerButton (codenamePos +^ hw +^ neg hv) CmdHome 1 [("home",3*^hw)] sel <- liftMaybe selName us <- liftMaybe ourName ourUInfo <- mgetUInfo us selUInfo <- mgetUInfo sel- let accesses = map (uncurry getAccessInfo) [(ourUInfo,sel),(selUInfo,us)]- let posLeft = scoresPos <+> hw <+> neg hu- let posRight = posLeft <+> 3<*>hu+ 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])+ fillArea (posLeft+^hw) (map (posLeft+^) [zero,hw,neg hv]) [ \pos -> (lift $ registerSelectable pos 0 (SelScoreLock (Just sel) accessed $ ActiveLock us i)) >> drawNameWithCharAndCol us white (lockIndexChar i) col pos | i <- [0..2] , let accessed = accesses !! 0 !! i , let col | accessed == Just AccessedPub = dim pubColour- | isJust accessed = dim $ scoreColour $ -3+ | (maybe False winsPoint) accessed = dim $ scoreColour $ -3 | otherwise = obscure $ scoreColour 3 ]- fillArea (posRight<+>hw) (map (posRight<+>) [zero,hw,neg hv])+ fillArea (posRight+^hw) (map (posRight+^) [zero,hw,neg hv]) [ \pos -> (lift $ registerSelectable pos 0 (SelScoreLock Nothing accessed $ ActiveLock sel i)) >> drawNameWithCharAndCol sel white (lockIndexChar i) col pos | i <- [0..2] , let accessed = accesses !! 1 !! i , let col | accessed == Just AccessedPub = obscure pubColour- | isJust accessed = dim $ scoreColour $ 3+ | (maybe False winsPoint) accessed = dim $ scoreColour $ 3 | otherwise = obscure $ scoreColour $ -3 ]- (usUnacc,selUnacc) <- MaybeT $ (snd<$>) <$> getRelScoreDetails sel- lift.lift.renderToMain $ sequence_ [renderStrColAt (scoreColour score) (sign:show (abs score)) pos- | (sign,score,pos) <-- [ ('-',usUnacc-3,posLeft<+>neg hv<+>hw)- , ('+',3-selUnacc,posRight<+>neg hv<+>hw) ] ]+ (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 () @@ -276,7 +302,7 @@ let pos = serverWaitPos return $ \ticks -> void $ flip runStateT curState $ do when (ticks>2) $ renderToMain $ do- mapM (drawAtRel (FilledHexGlyph $ bright black)) [ pos <+> i<*>hu | i <- [0..3] ]+ mapM (drawAtRel (FilledHexGlyph $ bright black)) [ pos +^ i*^hu | i <- [0..3] ] withFont (dispFontSmall curState) $ renderStrColAtLeft errorCol ("waiting..."++replicate (ticks`mod`3) '.') $ pos refresh@@ -284,17 +310,21 @@ warpPointer pos = do (scrCentre, size) <- getGeom centre <- gets dispCentre- let SVec x y = hexVec2SVec size (pos<->centre) <+> scrCentre+ 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]+ 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 []+ registerButton (periphery 5 +^ hw) (CmdInputChar 'Y') 2 []+ registerButton (periphery 5 +^ neg hv) (CmdInputChar 'N') 0 [] drawButtons IMTextInput refresh @@ -359,25 +389,25 @@ 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+ let dir = hexVec2HexDirOrZero $ mPos -^ fromPos guard $ dir /= zero- return $ CmdDrag (fromPos<+>centre) dir+ 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 [])+ 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+ let dir = hexVec2HexDirOrZero $ to -^ from if dir /= zero- then (CmdDir WHSSelected dir:) <$> mouseFromTo (from <+> dir) to+ then (CmdDir WHSSelected dir:) <$> mouseFromTo (from +^ dir) to else return [] processEvent (MouseButtonDown _ _ ButtonLeft) = do pos@(mPos,central) <- gets mousePos@@ -388,20 +418,20 @@ $ map (\cmd -> return [cmd]) (maybeToList mcmd) ++ [ (modify $ \s -> s {paintTileIndex = i}) >> return [] | i <- take (length paintTiles) [0..]- , mPos == paintButtonStart <+> i<*>hv ]+ , mPos == paintButtonStart +^ i*^hv ] ++ [ toggleUIOption uiOB1 >> updateHoverStr mode >> return []- | mPos == uiOptPos uiOB1 ]+ | mPos == uiOptPos uiOB1 && mode `elem` uiOptModes uiOB1 ] ++ [ toggleUIOption uiOB2 >> updateHoverStr mode >> return []- | mPos == uiOptPos uiOB2 ]+ | mPos == uiOptPos uiOB2 && mode `elem` uiOptModes uiOB2 ] ++ [ toggleUIOption uiOB3 >> updateHoverStr mode >> return []- | mPos == uiOptPos uiOB3 ]+ | mPos == uiOptPos uiOB3 && mode `elem` uiOptModes uiOB3 ] ++ [ toggleUIOption uiOB4 >> updateHoverStr mode >> return []- | mPos == uiOptPos uiOB4 ]+ | mPos == uiOptPos uiOB4 && mode `elem` uiOptModes uiOB4 ] ++ [ toggleUIOption uiOB5 >> updateHoverStr mode >> return []- | mPos == uiOptPos uiOB5 ]+ | mPos == uiOptPos uiOB5 && mode `elem` uiOptModes uiOB5 ] #ifdef SOUND ++ [ toggleUIOption uiOB6 >> updateHoverStr mode >> return []- | mPos == uiOptPos uiOB6 ]+ | mPos == uiOptPos uiOB6 && mode `elem` uiOptModes uiOB6 ] #endif if rb@@ -412,7 +442,7 @@ return $ [ drawCmd (paintTiles!!pti) False ] IMPlay -> do centre <- gets dispCentre- return $ [ CmdManipulateToolAt $ mPos <+> centre ]+ return $ [ CmdManipulateToolAt $ mPos +^ centre ] _ -> return [] processEvent (MouseButtonUp _ _ ButtonLeft) = do modify $ \s -> s { leftButtonDown = Nothing }@@ -461,7 +491,7 @@ mb <- isJust <$> gets middleButtonDown if ((rb || mb || mode == IMReplay) && mode /= IMEdit) || (mb && mode == IMEdit)- then return [ if dw == 1 then CmdUndo else CmdRedo ]+ then return [ if dw == 1 then CmdRedo else CmdUndo ] else if mode /= IMEdit || rb then return [ CmdRotate WHSSelected dw ] else do@@ -477,7 +507,7 @@ getMousePos = do (scrCentre, size) <- getGeom (x,y,_) <- lift getMouseState- let sv = (SVec (fi x) (fi y)) <+> neg scrCentre+ let sv = (SVec (fi x) (fi y)) +^ neg scrCentre let mPos@(HexVec x y z) = sVec2HexVec size sv let (sx,sy,sz) = sVec2dHV size sv let isCentral = all (\(a,b) -> abs ((fi a) - b) < 0.5) $@@ -516,13 +546,13 @@ , "go [H]ome, then [E]dit and [P]lace a lock of your own;" , "you can then [D]eclare your solutions." , "Make other players green by solving their locks and not letting them solve yours."]- renderStrColAt messageCol "Keybindings:" $ (screenHeightHexes`div`4)<*>(hv<+>neg hw)+ renderStrColAt messageCol "Keybindings:" $ (screenHeightHexes`div`4)*^(hv+^neg hw) let keybindingsHeight = screenHeightHexes - (3 + length extraHelpStrs) sequence_ [ with $ renderStrColAtLeft messageCol ( keysStr ++ ": " ++ desc )- $ (x*bdgWidth-(screenWidthHexes-6)`div`2)<*>hu <+> neg hv <+>- (screenHeightHexes`div`4 - y`div`2)<*>(hv<+>neg hw) <+>- (y`mod`2)<*>hw+ $ (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@@ -537,28 +567,30 @@ (map (`divMod` keybindingsHeight) [0..]) , (x+1)*bdgWidth < screenWidthHexes] sequence_ [ renderStrColAt messageCol str- $ (screenHeightHexes`div`4 - y`div`2)<*>(hv<+>neg hw)- <+> hw- <+> (y`mod`2)<*>hw+ $ (screenHeightHexes`div`4 - y`div`2)*^(hv+^neg hw)+ +^ hw+ +^ (y`mod`2)*^hw | (str,y) <- zip extraHelpStrs [keybindingsHeight..] ] refresh return True showHelp IMMeta HelpPageGame = do renderToMain $ do erase- let headPos = (screenHeightHexes`div`4)<*>(hv<+>neg hw)+ let headPos = (screenHeightHexes`div`4)*^(hv+^neg hw) renderStrColAt messageCol "Intricacy" headPos sequence_ [ renderStrColAt messageCol str $ headPos- <+> (y`div`2)<*>(hw<+>neg hv)- <+> (y`mod`2)<*>hw+ +^ (y`div`2)*^(hw+^neg hv)+ +^ (y`mod`2)*^hw | (y,str) <- zip [2..] metagameHelpText ] return True showHelp _ _ = return False + onNewMode mode = modify (\ds -> ds{needHoverUpdate=True}) >> say ""+ drawShortMouseHelp mode = do mwhs <- gets $ whsButtons.uiOptions showBT <- showButtonText <$> gets uiOptions@@ -567,7 +599,7 @@ smallFont <- gets dispFontSmall renderToMain $ withFont smallFont $ sequence_ [ renderStrColAtLeft (dim cyan) help- (periphery 3 <+> neg hu <+> (2-n)<*>hv )+ (periphery 3 +^ neg hu +^ (2-n)*^hv ) | (n,help) <- zip [0..] helps ] where shortMouseHelp IMPlay =@@ -626,14 +658,14 @@ , guard (showBT && mode == IMEdit) >> msum [ return $ "set paint mode: " ++ describeCommand (paintTileCmds!!i) | i <- take (length paintTiles) [0..]- , mPos == paintButtonStart <+> i<*>hv ]- , guard (mPos == uiOptPos uiOB1) >> describeUIOptionButton uiOB1- , guard (mPos == uiOptPos uiOB2) >> describeUIOptionButton uiOB2- , guard (mPos == uiOptPos uiOB3) >> describeUIOptionButton uiOB3- , guard (mPos == uiOptPos uiOB4) >> describeUIOptionButton uiOB4- , guard (mPos == uiOptPos uiOB5) >> describeUIOptionButton uiOB5+ , 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) >> describeUIOptionButton uiOB6+ , guard (mPos == uiOptPos uiOB6 && mode `elem` uiOptModes uiOB6) >> describeUIOptionButton uiOB6 #endif ] modify $ \ds -> ds { hoverStr = hstr }@@ -662,7 +694,7 @@ sequence_ $ map (uncurry ($)) $ zip selDraws $ sortBy (compare `on` hexVec2SVec 37) $ take (length selDraws) $ sortBy- (compare `on` (hexLen . (<->centre)))+ (compare `on` (hexLen . (-^centre))) area drawOldLock ls pos = void.runMaybeT $ msum [ do@@ -686,7 +718,7 @@ lift $ do renderToMain $ renderStrColAt col ((if score > 0 then "+" else "") ++ show score) pos- registerSelectable pos 0 (SelRelScore score)+ registerSelectable pos 0 SelRelScore drawNote note pos = case noteBehind note of Just al -> drawActiveLock al pos@@ -701,6 +733,7 @@ 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 = SVec 0 $ - (ysize size - size`div`2)@@ -732,17 +765,17 @@ (-3) -> 0xff000000 drawLockInfo :: ActiveLock -> Maybe LockInfo -> MainStateT UIM ()-drawLockInfo al@(ActiveLock name i) Nothing = do- let centre = hw<+>neg hv <+> 7*(i-1)<*>hu+drawLockInfo al@(ActiveLock name idx) Nothing = do+ let centre = hw+^neg hv +^ 7*(idx-1)*^hu lift $ drawEmptyMiniLock centre- drawNameWithCharAndCol name white (lockIndexChar i) (invisible white) 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 i) (Just lockinfo) = do- let centre = locksPos <+> 7*(i-1)<*>hu- let accessedByPos = centre <+> 3<*>(hv <+> neg hw)- let accessedPos = centre <+> 2<*>(hw <+> neg hv)- let notesPos = centre <+> 3<*>(hw <+> neg hv)+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@@ -757,9 +790,9 @@ size <- snd <$> lift getGeom lift $ do- renderToMain $ displaceRender (SVec size 0) $ renderStrColAt (brightish white) "PRIVY" $ accessedByPos <+> hv- registerSelectable (accessedByPos <+> hv) 0 SelPrivyHeader- registerSelectable (accessedByPos <+> hv <+> hu) 0 SelPrivyHeader+ renderToMain $ displaceRender (SVec size 0) $ renderStrColAt (brightish white) "PRIVY" $ accessedByPos +^ hv+ registerSelectable (accessedByPos +^ hv) 0 SelPrivyHeader+ registerSelectable (accessedByPos +^ hv +^ hu) 0 SelPrivyHeader if public lockinfo then lift $ do renderToMain $ renderStrColAt pubColour "All" accessedByPos@@ -767,9 +800,9 @@ else if null $ accessedBy lockinfo then lift.renderToMain $ renderStrColAt dimWhiteCol "No-one" accessedByPos else fillArea accessedByPos- [ accessedByPos <+> d | j <- [0..2], i <- [-2..3]+ [ accessedByPos +^ d | j <- [0..2], i <- [-2..3] , i-j > -4, i-j < 3- , let d = j<*>hw <+> i<*>hu ]+ , 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@@ -790,25 +823,25 @@ Nothing -> do read <- take 3 <$> getNotesReadOn lockinfo unless (ourName == Just name) $ do- let readPos = accessedPos <+> (-3)<*>hu+ 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] ]+ fillArea (accessedPos+^neg hu) [ accessedPos +^ i*^hu | i <- [-1..1] ] $ take 3 $ [ \pos -> (lift $ registerSelectable pos 0 (SelReadNote note)) >> drawNote note pos | note <- read ] ++ (repeat $ \pos -> (lift $ registerSelectable pos 0 SelReadNoteSlot >> renderToMain (drawAtRel (HollowGlyph $ dim green) pos))) lift $ do- renderToMain $ displaceRender (SVec size 0) $ renderStrColAt (brightish white) "NOTES" $ notesPos <+> hv- registerSelectable (notesPos <+> hv) 0 SelNotesHeader- registerSelectable (notesPos <+> hv <+> hu) 0 SelNotesHeader+ renderToMain $ displaceRender (SVec size 0) $ renderStrColAt (brightish white) "NOTES" $ notesPos +^ hv+ registerSelectable (notesPos +^ hv) 0 SelNotesHeader+ registerSelectable (notesPos +^ hv +^ hu) 0 SelNotesHeader if null $ notesSecured lockinfo then lift.renderToMain $ renderStrColAt dimWhiteCol "None" notesPos else fillArea notesPos- [ notesPos <+> d | j <- [0..2], i <- [-2..3]+ [ notesPos +^ d | j <- [0..2], i <- [-2..3] , i-j > -4, i-j < 3- , let d = j<*>hw <+> i<*>hu ]+ , let d = j*^hw +^ i*^hu ] [ \pos -> (lift $ registerSelectable pos 0 (SelSecured note)) >> drawActiveLock (noteOn note) pos | note <- notesSecured lockinfo ]
Server.hs view
@@ -28,6 +28,7 @@ import Data.Time.Clock import System.IO import System.FilePath+import System.Directory (renameFile) import qualified Data.ByteString.Lazy as L import qualified Data.Binary as B import Data.Array@@ -38,8 +39,16 @@ import Pipes import qualified Pipes.Prelude as P +import Text.Feed.Import (parseFeedFromFile)+import Text.Feed.Export (xmlFeed)+import Text.Feed.Constructor+import Text.XML.Light.Output (showTopElement)+import Data.Time.Format+import Data.Time.LocalTime+ import System.Environment import System.Console.GetOpt+import System.Exit import Protocol import Metagame@@ -49,10 +58,11 @@ import AsciiLock import Mundanities import Maxlocksize+import Version defaultPort = 27001 -- 27001 == ('i'<<8) + 'y' -data Opt = RequestDelay Int | Daemon | LogFile FilePath | Port Int | DBDir FilePath | ServerLockSize Int+data Opt = RequestDelay Int | Daemon | LogFile FilePath | Port Int | DBDir FilePath | ServerLockSize Int | FeedPath FilePath | Help | Version deriving (Eq, Ord, Show) options = [ Option ['p'] ["port"] (ReqArg (Port . read) "PORT") $ "TCP port to listen on (default: " ++ show defaultPort ++ ")"@@ -61,7 +71,15 @@ , Option ['l'] ["logfile"] (ReqArg LogFile "PATH") "Log to file" , Option ['d'] ["dir"] (ReqArg DBDir "PATH") "directory for server database [default: intricacydb]" , Option ['s'] ["locksize"] (ReqArg (ServerLockSize . read) "SIZE") "size of locks (only takes effect when creating a new database) [default: 8]"+ , Option ['f'] ["feed"] (ReqArg FeedPath "PATH") "write news feed to this path"+ , Option ['h'] ["help"] (NoArg Help) "show usage information"+ , Option ['v'] ["version"] (NoArg Version) "show version information" ]++usage :: String+usage = usageInfo header options+ where header = "Usage: intricacy-server [OPTION...]"+ parseArgs :: [String] -> IO ([Opt],[String]) parseArgs argv = case getOpt Permute options argv of@@ -77,16 +95,19 @@ then void $ forkIO $ main' opts else main' opts -}+ 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 ] withDB dbpath $ setDefaultServerInfo locksize writeFile (lockFilePath dbpath) "" logh <- case listToMaybe [ f | LogFile f <- opts ] of Nothing -> return stdout Just path -> openFile path AppendMode- streamServer serverSpec{address = IPv4 "" port, threading=Threaded} $ handler dbpath delay logh+ streamServer serverSpec{address = IPv4 "" port, threading=Threaded} $ handler dbpath delay logh mfeedPath sleepForever setDefaultServerInfo locksize = do@@ -96,6 +117,7 @@ -- | We lock the whole database during each request, using haskell's native -- file locking, meaning that we have at any time one writer *xor* any number -- of readers.+withDBLock :: MonadIO m => [Char] -> IOMode -> m b -> m b withDBLock dbpath lockMode m = do h <- liftIO $ getDBLock lockMode ret <- m@@ -109,8 +131,8 @@ logit h s = hPutStrLn h s >> hFlush h -handler :: FilePath -> Int -> Handle -> Handle -> Address -> IO ()-handler dbpath delay logh hdl addr = handle ((\e -> return ()) :: SomeException -> IO ()) $+handler :: FilePath -> Int -> Handle -> Maybe FilePath -> Handle -> Address -> IO ()+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@@ -123,7 +145,7 @@ hashedHostname = take 8 $ hash hostname now <- liftIO getCurrentTime logit logh $ show now ++ ": " ++ hashedHostname ++ " >>> " ++ showRequest request- response <- handleRequest dbpath request+ response <- handleRequest dbpath mfeedPath request when (delay > 0) $ threadDelay delay now' <- liftIO getCurrentTime logit logh $ show now' ++ ": " ++ hashedHostname ++ " <<< " ++ showResponse response@@ -146,8 +168,8 @@ showResponse (ServedSolution soln) = "ServedSolution [SOLN]" showResponse resp = show resp -handleRequest :: FilePath -> ClientRequest -> IO ServerResponse-handleRequest dbpath req@(ClientRequest pv auth action) = do+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@@ -191,6 +213,10 @@ "Server only accepts size "++show serverSize++" locks." unless (validLock $ reframe lock) $ throwError "Invalid lock!" unless (not.checkSolved $ reframe lock) $ throwError "Lock not locked!"+ RCLockHashes hashes <- getRecordErrored RecLockHashes+ `catchError` const (return (RCLockHashes []))+ let hashed = hash $ show lock+ when (hashed `elem` hashes) $ throwError "Lock has already been used" unless (checkSolution lock soln) $ throwError "Bad solution" _ -> return () handleRequest' =@@ -198,7 +224,10 @@ Authenticate -> do checkAuth auth return $ ServerMessage $ "Welcome, " ++ authUser (fromJust auth)- Register -> newUser auth >> return ServerAck+ Register -> do+ newUser auth+ doNews $ "New user " ++ authUser (fromJust auth) ++ " registered."+ return ServerAck ResetPassword passwd -> resetPassword auth passwd >> return ServerAck GetServerInfo -> ServedServerInfo <$> getServerInfo GetLock ls -> ServedLock <$> getLock ls@@ -239,6 +268,9 @@ 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 ++ "." return ServerAck SetLock lock@(frame,_) idx soln -> do info <- getUserInfoOfAuth auth@@ -247,10 +279,9 @@ RCLockHashes hashes <- getRecordErrored RecLockHashes `catchError` const (return (RCLockHashes [])) let hashed = hash $ show lock- when (hashed `elem` hashes) $ throwError "Lock has already been used"- ls <- erroredDB $ newLockRecord lock erroredDB $ putRecord RecLockHashes $ RCLockHashes $ hashed:hashes + ls <- erroredDB $ newLockRecord lock let oldLockInfo = userLocks info ! idx execStateT (do when (isJust $ oldLockInfo) $@@ -261,6 +292,7 @@ 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@@ -367,7 +399,7 @@ addReadNote note@(NoteInfo _ _ target) name = do info <- getCurrUserInfo name tlock <- getCurrALock target- unless (name `elem` accessedBy tlock || note `elem` notesRead info) $ do+ unless (note `elem` notesRead info) $ do addDelta name $ AddRead note checkSuffReadNotes target name accessLock name target@(ActiveLock tname ti) tlock = do@@ -399,10 +431,9 @@ checkSuffReadNotes target name = do info <- getCurrUserInfo name tlock <- getCurrALock target- let countRead = fromIntegral $ length $- filter (\n -> isNothing (noteBehind n) || n `elem` notesRead info) $ lockSolutions tlock- when (countRead == notesNeeded && not (public tlock) && name /= lockOwner target) $- accessLock name target tlock+ 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 info <- getCurrUserInfo name let Just lock = userLocks info ! idx@@ -418,3 +449,15 @@ (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
ServerAddr.hs view
@@ -23,6 +23,9 @@ saddrStr (ServerAddr h p) = h ++ if p==defaultPort then "" else ':':show p +-- |windows doesn't like ':' in paths, so use '#' instead+saddrPath (ServerAddr h p) = h ++ if p==defaultPort then "" else '#':show p+ strToSaddr str = case elemIndex ':' str of Nothing -> Just $ ServerAddr str defaultPort
intricacy.cabal view
@@ -1,5 +1,5 @@ name: intricacy-version: 0.5+version: 0.5.5 synopsis: A game of competitive puzzle-design homepage: http://mbays.freeshell.org/intricacy license: GPL-3@@ -69,6 +69,9 @@ if flag(Sound) Extra-Libraries: SDL_mixer ghc-options: -optl-mwindows+ if os(darwin)+ -- I'm told OSX doesn't like static builds+ ghc-options: -dynamic else Buildable: False if flag(Curses)@@ -100,12 +103,16 @@ extensions: DoAndIfThenElse build-depends: base >=4.3, base < 5 , mtl >=2.0, transformers >=0.2, stm >= 2.1- , directory >= 1.0, filepath >= 1.0, time >= 1.2+ , directory >= 1.0, filepath >= 1.0, time >= 1.5 , bytestring >=0.10 , array >=0.3, containers >=0.4, vector >=0.9 , binary >=0.5, network-fancy >= 0.1.5 , cryptohash >= 0.8 , random >= 1.0, pipes >= 4+ , feed >= 0.3.1, xml >= 1.2.6+ if os(darwin)+ -- I'm told OSX doesn't like static builds+ ghc-options: -dynamic else Buildable: False main-is: Server.hs
tutorial/1-winning.text view
@@ -1,1 +1,1 @@-use your tools, the hook and the wrench, to pull the bolt aside; then press 'O'.+drag your tools, the hook and the wrench, to pull the bolt aside; then press 'O'.
tutorial/2-tools.lock view
@@ -1,6 +1,6 @@ " " " " " " " - " S S # " " " - " # # # % " " + " # " " " + " S S # # % " " " % % % % " " o # S S S S % " " " ` # " @@ -8,6 +8,6 @@ " % % " " " % % % # " " * ' % % " - " @ " # % o " - " " " # / % " + " @ " % % o " + " " " % / # " " " " " " " "
− tutorial/5-plug.lock
@@ -1,17 +0,0 @@- " " " " " " " " " - " # ( " " " " - " # ( " " - " # # ( " # " - " # # ( # "- " # ( # " " - " & & % ( # " " - " & & & & Z ( # # " -" # C C & & Z ( # # # " - " & & & & & # 7 " - " & & & & & ] 7 " - " " & & & ] % 7 " -" * ' o \ O # " % 7 " - " @ " ` o # % 7 " - " " " # % # % 7 " - " % % % " - " " " " " " " " "
− tutorial/5-plug.text
@@ -1,1 +0,0 @@-compress the central springs with both tools at once
+ tutorial/5-springs.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " # # # # # # # " " " " + " # # # " " + " # # % % # " # # " + " # # # % S S # # # # "+ " # " " + " & & % % % # # " " + " ] " S S % # " +" ] " # # # # # # " + " ] " ] # # # # 7 " + " ] # " ] # # # 7 " + " " # # # " " # # S S % " +" * ' # Z o - # # # # " + " @ " Z / % C C C C " + " " " Z % % % % " + " Z % % % " + " " " " " " " " "
+ tutorial/5-springs.text view
@@ -0,0 +1,1 @@+A spring's length can double when stretched, and halve when compressed.
+ tutorial/6-plug.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " # ( " " " " + " # ( " " + " # # ( " # " + " # # ( # "+ " # ( # " " + " & & % ( # " " + " & & & & Z ( # # " +" # C C & & Z ( # # # " + " & & & & & # 7 " + " & & & & & ] 7 " + " " & & & ] % 7 " +" * ' o \ O # " % 7 " + " @ " ` o # % 7 " + " " " # % # % 7 " + " % % % " + " " " " " " " " "
+ tutorial/6-plug.text view
@@ -0,0 +1,1 @@+compress the central springs with both tools at once