intricacy 0.4.1 → 0.4.3
raw patch · 37 files changed
+485/−222 lines, 37 filesbinary-added
Files
- BUILD +38/−0
- Command.hs +4/−4
- CursesUI.hs +2/−1
- CursesUIMInstance.hs +5/−1
- Interact.hs +27/−14
- InteractUtil.hs +4/−4
- KeyBindings.hs +1/−1
- MainBoth.hs +22/−0
- MainBoth.hsMainSDL.hsMainCurses.hs +0/−0
- MainCurses.hs +20/−0
- MainSDL.hs +20/−0
- MainState.hs +3/−1
- NEWS +6/−0
- README +6/−40
- SDLRender.hs +53/−11
- SDLUI.hs +72/−39
- SDLUIMInstance.hs +122/−53
- Server.hs +1/−1
- VeraMoBd.ttf binary
- VeraMono.ttf binary
- intricacy.cabal +3/−3
- tutorial-extra/4-hook.lock +11/−0
- tutorial/1-winning.text +1/−1
- tutorial/2-tools.lock +13/−0
- tutorial/2-tools.text +1/−0
- tutorial/2-wrench.lock +0/−17
- tutorial/2-wrench.text +0/−1
- tutorial/3-hook.lock +0/−11
- tutorial/3-hook.text +0/−1
- tutorial/3-puzzle.lock +17/−0
- tutorial/3-puzzle.text +1/−0
- tutorial/4-hook.lock +13/−0
- tutorial/4-hook.text +1/−0
- tutorial/4-plug.lock +0/−17
- tutorial/4-plug.text +0/−1
- tutorial/5-plug.lock +17/−0
- tutorial/5-plug.text +1/−0
+ BUILD view
@@ -0,0 +1,38 @@+Compiling Intricacy+===================++Dependencies:+ EITHER+ sdl+ sdl-ttf+ sdl-gfx+ OR+ curses++To compile the game on *nix with SDL graphics:+ Install ghc, cabal, and development packages for the SDL dependencies+ above, then run+ cabal update && cabal install+ which should result in various haskell packages being compiled and+ installed, probably in ~/.cabal/ . The game can then be run as+ ~/.cabal/bin/intricacy + Running cabal install as root should install it somewhere global.++To compile a curses-only (ascii graphics) build:+ cabal install -f -SDL++To compile the server:+ cabal install -f Server -f -Game++ The server will be installed in+ ~/.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.++To compile for windows:+ This should work as above once you have the dependencies installed+ properly. Good luck with that. The mingw32-compiled libraries in winlibs+ may or may not help.++To compile for OSX, or android or whatever other wacky system:+ No idea, sorry. But please tell me if you manage!
Command.hs view
@@ -43,9 +43,9 @@ | CmdRegister | CmdAuth | CmdNextPage | CmdPrevPage | CmdToggleColourMode- | CmdRedraw | CmdRefresh | CmdSuspend+ | CmdRedraw | CmdRefresh | CmdSuspend | CmdClear | CmdQuit | CmdForceQuit- | CmdHelp | CmdBind+ | CmdHelp | CmdBind (Maybe Command) | CmdNone deriving (Eq, Ord, Show, Read) data WrHoSel = WHSWrench | WHSHook | WHSSelected@@ -74,7 +74,7 @@ describeCommand (CmdReplayBack _) = "rewind replay" describeCommand CmdWriteState = "write lock" describeCommand CmdTutorials = "play tutorial levels"-describeCommand CmdShowRetired = "show retired locks"+describeCommand CmdShowRetired = "toggle showing retired locks" describeCommand CmdSetServer = "set server" describeCommand CmdToggleCacheOnly = "toggle using only cache" describeCommand (CmdSelCodename mname) = "select player"@@ -99,7 +99,7 @@ ++ maybe "" ((' ':).(:"").lockIndexChar) mli describeCommand CmdRegister = "register codename" describeCommand CmdAuth = "authenticate"-describeCommand CmdBind = "bind key"+describeCommand (CmdBind _) = "bind key" describeCommand CmdToggleColourMode = "toggle lock colour mode" describeCommand CmdQuit = "quit" describeCommand CmdHelp = "help"
CursesUI.hs view
@@ -126,7 +126,8 @@ lift $ do (h,w) <- liftIO Curses.scrSize liftIO $ clearLine $ h-1- drawStr attr col (CVec (h-1) 0) $ take (w-1) str+ let str' = take (w-1) str+ drawStr attr col (CVec (h-1) 0) str' setMsgLine attr col str = do modify $ \s -> s { message = Just (attr,col,str) } drawMsgLine
CursesUIMInstance.hs view
@@ -289,9 +289,11 @@ cGlyph = Glyph '!' 0 a0 drawMessage = say+ drawPrompt full s = say s >> (liftIO $ void $ Curses.cursSet Curses.CursorVisible)+ endPrompt = say "" >> (liftIO $ void $ Curses.cursSet Curses.CursorInvisible) drawError = sayError - showHelp mode = do+ showHelp mode 0 = do bdgs <- nub <$> getBindings mode erase (h,w) <- liftIO Curses.scrSize@@ -314,6 +316,8 @@ (map (`divMod` (h-3)) [0..]) , (x+1)*bdgWidth < w] refresh+ return True+ showHelp _ _ = return False getChRaw = (charify<$>) $ liftIO $ CursesH.getKey (return ()) setUIBinding mode cmd ch =
Interact.hs view
@@ -120,22 +120,28 @@ processCommand im cmd = lift $ processCommand' im cmd processCommand' :: UIMonad uiM => InputMode -> Command -> MainStateT uiM ()-processCommand' im CmdHelp = lift $ do- showHelp im- void $ textInput "[press a key or RMB]" 1 False True Nothing Nothing-processCommand' im CmdBind = lift $ (>> drawMessage "") $ runMaybeT $ do- lift $ drawMessage "Command to bind: "- cmd <- msum $ repeat $ do+processCommand' im CmdHelp = lift $+ let showPage n = showHelp im n >>? do+ void $ textInput "[press a key or RMB]" 1 False True Nothing Nothing+ showPage $ n+1+ in showPage 0+processCommand' im (CmdBind mcmd)= lift $ (>> endPrompt) $ runMaybeT $ do+ cmd <- liftMaybe mcmd `mplus` do+ lift $ drawPrompt False "Command to bind: "+ msum $ repeat $ do cmd <- MaybeT $ listToMaybe <$> getInput im guard $ not.null $ describeCommand cmd return cmd- lift $ drawMessage ("key to bind to \"" ++ describeCommand cmd ++ "\" (repeat binding to delete): ")- ch <- MaybeT getChRaw- guard $ ch /= '\ESC'- lift $ setUIBinding im cmd ch+ lift $ drawPrompt False ("key to bind to \"" ++ describeCommand cmd ++ "\" (repeat existing user binding to delete): ")+ ch <- MaybeT getChRaw+ guard $ ch /= '\ESC'+ lift $ setUIBinding im cmd ch processCommand' _ CmdToggleColourMode = lift toggleColourMode processCommand' _ CmdSuspend = lift suspend processCommand' _ CmdRedraw = lift redraw+processCommand' im CmdClear = do+ lift $ drawMessage ""+ when (im == IMMeta) $ modify $ \ms -> ms { retiredLocks = Nothing } processCommand' im CmdMark = void.runMaybeT $ do guard $ im `elem` [IMEdit, IMPlay, IMReplay] str <- MaybeT $ lift $ textInput "Mark: " 1 False True Nothing Nothing@@ -150,10 +156,12 @@ lift $ jumpMark ch processCommand' im CmdReset = jumpMark startMark processCommand' IMMeta (CmdSelCodename mname) = void.runMaybeT $ do+ mauth <- gets curAuth name <- msum [ liftMaybe $ mname , do newCodename <- (map toUpper <$>) $ MaybeT $ lift $- textInput "Codename:" 3 False True Nothing Nothing+ textInput "Select codename:"+ 3 False False Nothing Nothing guard $ length newCodename == 3 return newCodename ]@@ -226,12 +234,13 @@ modify $ \ms -> ms {curAuth = Just $ Auth name passwd} resp <- curServerAction $ Authenticate case resp of- ServerAck -> (lift $ drawMessage "Authenticated.")- ServerMessage msg -> (lift $ drawMessage $ "Server: " ++ msg)+ ServerAck -> lift $ drawMessage "Authenticated."+ ServerMessage msg -> lift $ drawMessage $ "Server: " ++ msg ServerError err -> do lift $ drawError err modify $ \ms -> ms {curAuth = auth} _ -> lift $ drawMessage $ "Bad server response: " ++ show resp+ refreshUInfoUI processCommand' IMMeta (CmdSolve midx) = void.runMaybeT $ do name <- mgetCurName uinfo <- mgetUInfo name@@ -413,7 +422,11 @@ newRL <- lift (gets retiredLocks) >>= \rl -> case rl of Nothing -> do RCLockSpecs lss <- MaybeT $ getFreshRecBlocking $ RecRetiredLocks name- return $ Just lss+ if null lss+ then do+ lift.lift $ drawError "Player has no retired locks."+ return Nothing+ else return $ Just lss Just _ -> return Nothing lift $ modify $ \ms -> ms {retiredLocks = newRL}
InteractUtil.hs view
@@ -158,9 +158,9 @@ confirmOrBail prompt = (guard =<<) $ lift.lift $ confirm prompt confirm :: UIMonad uiM => String -> uiM Bool confirm prompt = do- drawMessage $ prompt ++ " [y/N]"+ drawPrompt False $ prompt ++ " [y/N] " setYNButtons- waitConfirm <* drawMessage ""+ waitConfirm <* endPrompt where waitConfirm = do cmds <- getInput IMTextInput@@ -176,11 +176,11 @@ -- | TODO: draw cursor textInput :: UIMonad uiM => String -> Int -> Bool -> Bool -> Maybe [String] -> Maybe String -> uiM (Maybe String)-textInput prompt maxlen hidden endOnMax mposss init = getText (fromMaybe "" init, Nothing) <* drawMessage ""+textInput prompt maxlen hidden endOnMax mposss init = getText (fromMaybe "" init, Nothing) <* endPrompt where getText :: UIMonad uiM => (String, Maybe String) -> uiM (Maybe String) getText (s,mstem) = do- drawMessage $ prompt ++ " " ++ if hidden then replicate (length s) '*' else s+ drawPrompt (length s == maxlen) $ prompt ++ " " ++ if hidden then replicate (length s) '*' else s if endOnMax && isNothing mstem && maxlen <= length s then return $ Just $ take maxlen s else do
KeyBindings.hs view
@@ -101,7 +101,7 @@ [ ('Q', CmdQuit) , (ctrl 'C', CmdQuit) , ('?', CmdHelp)- , (ctrl 'B', CmdBind)+ , (ctrl 'B', CmdBind Nothing) , (ctrl 'L', CmdRedraw) , (ctrl 'Z', CmdSuspend) , ('%', CmdToggleColourMode)
+ MainBoth.hs view
@@ -0,0 +1,22 @@+-- This file is part of Intricacy+-- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++module Main where++import Init+import qualified SDLUI (UIM)+import SDLUIMInstance ()+import qualified CursesUI (UIM)+import CursesUIMInstance ()+import MainState++main = main'+ (Just (doUI::SDLUI.UIM MainState -> IO (Maybe MainState)))+ (Just (doUI::CursesUI.UIM MainState -> IO (Maybe MainState)))
− MainBoth.hsMainSDL.hsMainCurses.hs
+ MainCurses.hs view
@@ -0,0 +1,20 @@+-- This file is part of Intricacy+-- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++module Main where++import Init+import qualified CursesUI (UIM)+import CursesUIMInstance ()+import MainState++main = main'+ (Nothing :: (Maybe (CursesUI.UIM MainState -> IO (Maybe MainState))))+ (Just (doUI::CursesUI.UIM MainState -> IO (Maybe MainState)))
+ MainSDL.hs view
@@ -0,0 +1,20 @@+-- This file is part of Intricacy+-- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++module Main where++import Init+import qualified SDLUI+import SDLUIMInstance ()+import MainState++main = main'+ (Just (doUI::SDLUI.UIM MainState -> IO (Maybe MainState)))+ (Nothing :: (Maybe (SDLUI.UIM MainState -> IO (Maybe MainState))))
MainState.hs view
@@ -53,8 +53,10 @@ drawMainState :: MainStateT m () reportAlerts :: GameState -> [Alert] -> m () drawMessage :: String -> m ()+ drawPrompt :: Bool -> String -> m ()+ endPrompt :: m () drawError :: String -> m ()- showHelp :: InputMode -> m ()+ showHelp :: InputMode -> Int -> m Bool getInput :: InputMode -> m [ Command ] getChRaw :: m ( Maybe Char ) unblockInput :: m (IO ())
NEWS view
@@ -1,5 +1,11 @@ This is an abbreviated summary; see the git log for gory details. +0.4.3:+ Metagame help page.+ Animation to indicate direction of rotation of pieces.+0.4.2:+ Adjustments to graphics, tutorial, and metagame UI, to increase clarity.+ Fix sound lag on Windows. 0.4.1: Concurrency on server; no more freezes while it checks a solution. Misc minor UI fixes.
README view
@@ -5,45 +5,6 @@ http://mbays.freeshell.org/intricacy/ -Compiling-=========-Dependencies:- EITHER- sdl- sdl-ttf- sdl-gfx- OR- curses--To compile the game on *nix with SDL graphics:- Install ghc, cabal, and development packages for the SDL dependencies- above, then run- cabal update && cabal install- which should result in various haskell packages being compiled and- installed, probably in ~/.cabal/ . The game can then be run as- ~/.cabal/bin/intricacy - Running cabal install as root should install it somewhere global.--To compile a curses-only (ascii graphics) build:- cabal install -f -SDL--To compile the server:- cabal install -f Server -f -Game-- The server will be installed in- ~/.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.--To compile for windows:- This should work as above once you have the dependencies installed- properly. Good luck with that. The mingw32-compiled libraries in winlibs- may or may not help.--To compile for OSX, or android or whatever other wacky system:- No idea, sorry. But please tell me if you manage!-- Playing ======= Press 'T' on the starting screen to play the tutorials, which should lead you@@ -66,7 +27,12 @@ * The lone hex with optional arrow toggles "blockage annotations". These are there to help you figure out what's going on when you can't understand why a piece refuses to move. An orange arrow indicates a- blocked force, and a purple arrow a force which blocked another force.+ blocked force, a purple arrow indicates a force which blocked another+ force.+ * The soundwave icon toggles sound.+ * The narrow hex enscribed within a wide hex toggles between fullscreen+ and windowed mode. The resolution used when switching to fullscreen + is that of the window prior to fullscreening. Config files are saved in ~/.intricacy/ on unixoids, or something like "...\Application Data\intricacy\" on windows. In particular, the locks you
SDLRender.hs view
@@ -70,6 +70,13 @@ (map (uncurry addHalf) [(from,perp),(to,perp),(from,mperp),(to,mperp)]) (dim col) (bright col) +thickLines surf verts thickness col =+ sequence_ [ thickLine surf v v' thickness col |+ (v,v') <- zip (take (length verts - 1) verts) (drop 1 verts) ]++thickPolygon surf verts thickness col =+ thickLines surf (verts ++ take 1 verts) thickness col+ type Glyph = SVec -> Int -> Surface -> IO () ysize :: Int -> Int@@ -125,12 +132,12 @@ ] tileGlyph (SpringTile extn dir) col centre size surf =- aaLines surf points $ brightness col+ thickLines surf points 1 $ brightness col where n = 3*case extn of Stretched -> 1 Relaxed -> 2- Compressed -> 3+ Compressed -> 4 brightness = if extn == Relaxed then dim else bright dir' = if dir == zero then hu else dir (sx,sy) = corner centre size (hextant dir' - 1)@@ -184,13 +191,24 @@ rimmedCircle surf centre rad (faint col) (obscure col) where rad = (7*size)`div`8 -blockedArm :: HexDir -> TorqueDir -> Pixel -> Glyph+blockedArm,turnedArm :: HexDir -> TorqueDir -> Pixel -> Glyph blockedArm armdir tdir col centre size surf = void $ aaLine surf `uncurry` from `uncurry` to $ col where from = innerCorner centre size $ rotate (2*tdir) armdir to = edge centre size $ rotate tdir armdir +turnedArm armdir tdir col centre size surf =+ sequence_ [ arc surf (fromIntegral x) (fromIntegral y) (fromIntegral $ n*size `div` 4)+ a1 a2 col | n <- [8,9] ]+ where+ SVec x y = centre <+> hexVec2SVec size (neg armdir)+ a0 = fromIntegral $ -60*hextant armdir+ a1' = a0 + fromIntegral tdir * 10+ a2' = a0 + fromIntegral tdir * 30+ a1 = min a1' a2'+ a2 = max a1' a2'+ blockedBlock :: Tile -> HexDir -> Pixel -> Glyph blockedBlock tile dir col centre size = tileGlyph tile col (shift <+> centre) size@@ -208,10 +226,10 @@ , innerCorner centre size $ rotate (-1) dir , innerCorner centre size dir ] -}- void $ aaLine surf `uncurry` base `uncurry` tip $ col+ void $ thickLine surf base tip 1 col --void $ aaLine surf `uncurry` from' `uncurry` to' $ col- void $ aaLine surf `uncurry` tip `uncurry` (arms!!0) $ col- void $ aaLine surf `uncurry` tip `uncurry` (arms!!1) $ col+ void $ thickLine surf tip (arms!!0) 1 col+ void $ thickLine surf tip (arms!!1) 1 col where --base@(bx,by) = innerCorner centre size dir SVec bx' by' = centre@@ -261,7 +279,7 @@ showBlocksButton :: ShowBlocks -> Glyph showBlocksButton showing centre size surf = do- tileGlyph (BlockTile []) (dim blue) centre size surf+ tileGlyph (BlockTile []) (dim red) centre size surf when (showing == ShowBlocksAll) $ blockedPush hu (bright orange) centre size surf when (showing /= ShowBlocksNone) $@@ -269,9 +287,9 @@ showButtonTextButton :: Bool -> Glyph showButtonTextButton showing centre@(SVec x y) size surf = do- buttonGlyph (dim cyan) (SVec `uncurry` edge centre (size`div`2) (neg hu)) (size`div`2) surf+ buttonGlyph (dim yellow) (SVec `uncurry` edge centre (size`div`2) (neg hu)) (size`div`2) surf when showing $- sequence_ [ pixel surf (fromIntegral $ x+size`div`3+(i*size`div`4)) (fromIntegral $ y - size`div`4) (bright cyan)+ sequence_ [ pixel surf (fromIntegral $ x+size`div`3+(i*size`div`4)) (fromIntegral $ y - size`div`4) (bright white) | i <- [-1..1] ] useSoundsButton :: Bool -> Glyph@@ -283,7 +301,7 @@ whsButtonsButton :: Maybe WrHoSel -> Glyph whsButtonsButton Nothing centre size surf = buttonGlyph (dim red) centre (size`div`3) surf- >> sequence_ [ buttonGlyph (dim blue)+ >> sequence_ [ buttonGlyph (dim purple) (SVec `uncurry` edge centre (size`div`2) dir) (size`div`3) surf | dir <- hexDirs ] whsButtonsButton (Just whs) centre size surf = do@@ -297,6 +315,18 @@ miniCentre h = SVec `uncurry` corner centre miniSize h col = dim white +fullscreenButton :: Bool -> Glyph+fullscreenButton fs centre size surf = do+ thickPolygon surf corners 1 $ activeCol (not fs)+ thickPolygon surf corners' 1 $ activeCol fs+ where+ activeCol True = opaquify $ dim green+ activeCol False = opaquify $ dim red+ size' = (2*size`div`3)+ corners = [ (if dir `elem` [hu,neg hu] then edge else innerCorner) centre size' dir+ | dir <- hexDirs ]+ corners' = map (corner centre size') [0..5]+ cursor :: Glyph cursor = hollowGlyph $ bright white @@ -475,7 +505,7 @@ liftM3 (,,) renderSurf renderSCentre renderSize let SVec _ y = scrCentre <+> (hexVec2SVec size v) w = surfaceGetWidth surf- h = ceiling $ fromIntegral size * 2 / sqrt 3+ h = ceiling $ fromIntegral (size * 3 `div` 2) * 2 / sqrt 3 fillRectBG $ Just $ Rect 0 (y-h`div`2) w h drawCursorAt :: Maybe HexPos -> RenderM ()@@ -499,6 +529,18 @@ | pos <- footprint , (dir<+>pos) `notElem` fullfootprint ] -- drawAt (blockedPush dir $ bright orange) $ placedPos $ getpp st idx++drawApplied :: GameState -> PieceColouring -> Force -> RenderM ()+drawApplied st colouring (Torque idx dir) = do+ let (pos,arms) = case getpp st idx of+ PlacedPiece pos (Pivot arms) -> (pos,arms)+ PlacedPiece pos (Hook arm _) -> (pos,[arm])+ _ -> (pos,[])+ col = dim $ colourOf colouring idx+ sequence_ [ drawAt (turnedArm arm dir col) (arm <+> pos) |+ arm <- arms ]+drawApplied _ _ _ = return ()+ blitAt :: Surface -> HexVec -> RenderM () blitAt surface v = do
SDLUI.hs view
@@ -93,12 +93,13 @@ , showBlocks::ShowBlocks , whsButtons::Maybe WrHoSel , useBackground::Bool+ , fullscreen::Bool , showButtonText::Bool , useSounds::Bool , uiAnimTime::Word32 } deriving (Eq, Ord, Show, Read)-defaultUIOptions = UIOptions False ShowBlocksBlocking Nothing True True True 50+defaultUIOptions = UIOptions False ShowBlocksBlocking Nothing True False True True 75 modifyUIOptions f = modify $ \s -> s { uiOptions = f $ uiOptions s } renderToMain :: RenderM a -> UIM a@@ -142,7 +143,7 @@ cntxtButtons <- gets contextButtons return $ cntxtButtons ++ global ++ case mode of IMEdit -> [- singleButton (tl<+>hv<+>neg hw) CmdTest 4 [("test", 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)] ]@@ -155,12 +156,10 @@ ++ [ singleButton tr CmdOpen 1 [("open", hu<+>neg hw)] ] IMReplay -> [ markGroup ] IMMeta ->- [ singleButton serverPos CmdSetServer 2 [("set server",2<*>neg hw)]- , singleButton (serverPos<+>neg hu) CmdToggleCacheOnly 0 [("cache only",3<*>hw<+>2<*>neg hu)]- , singleButton lockLinePos CmdSelectLock 4 [("select lock",2<*>neg hw)]- , singleButton (miniLockPos <+> 2<*>hv <+> neg hu) CmdEdit 2 [("edit",hv<+>4<*>neg hu),("lock",hw<+>4<*>neg hu)]- , singleButton (codenamePos <+> neg hu) (CmdSelCodename Nothing) 2 [("code",hv<+>4<*>neg hu),("name",hw<+>4<*>neg hu)]- , singleButton (serverPos <+> 2<*>neg hv <+> 2<*>hw) CmdTutorials 1 [("play",hu<+>neg hw),("tut",hu<+>neg hv)]+ [ 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)] ] _ -> []@@ -178,7 +177,7 @@ in [ ( [ Button bl (if edit then CmdSelect else CmdWait) [] ], (0,0)) , ( [ Button (bl<+>dir) (CmdDir whs dir) (if dir==hu then [("move",hu<+>neg hw),(if edit then "piece" else whsStr whs,hu<+>neg hv)] else [])- | dir <- hexDirs ], (4,0) )+ | dir <- hexDirs ], (5,0) ) ] ++ (if whs == WHSWrench then [] else [ ( [ Button (bl<+>((-2)<*>hv))@@ -187,7 +186,7 @@ , Button (bl<+>((-2)<*>hw)) (CmdRotate whs 1) [("turn",hu<+>neg hw),("ccw",hu<+>neg hv)]- ], (4,0) )+ ], (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)]@@ -281,17 +280,17 @@ helpOfSelectable (SelRandom _) = Just "Random set of guild members. Colours show relative esteem, bright red (-3) to bright green (+3)." helpOfSelectable (SelScoreLock (Just name) Nothing _) = Just $- "Your lock, to the secrets of which "++name++" is not privy."+ "Your lock, the secrets to which "++name++" is not privy." helpOfSelectable (SelScoreLock (Just name) (Just AccessedPrivy) _) = Just $- "Your lock, to the secrets of which "++name++" is privy: -1 to relative esteem."+ "Your lock, the secrets to which "++name++" is privy: -1 to relative esteem." helpOfSelectable (SelScoreLock (Just name) (Just AccessedPub) _) = Just $ "Your lock, the secrets of which have been publically revealed: -1 to relative esteem." helpOfSelectable (SelScoreLock (Just name) (Just AccessedEmpty) _) = Just $ "Your empty lock slot; "++name++" is privy to the secrets of all your locks: -1 to relative esteem." helpOfSelectable (SelScoreLock Nothing Nothing (ActiveLock name _)) = Just $- name++"'s lock, to the secrets of which you are not privy."+ name++"'s lock, the secrets to which you are not privy." helpOfSelectable (SelScoreLock Nothing (Just AccessedPrivy) (ActiveLock name _)) = Just $- name++"'s lock, to the secrets of which you are privy: +1 to relative esteem."+ name++"'s lock, the secrets to which you are privy: +1 to relative esteem." helpOfSelectable (SelScoreLock Nothing (Just AccessedPub) (ActiveLock name _)) = Just $ name++"'s lock, the secrets of which have been publically revealed: +1 to relative esteem." helpOfSelectable (SelScoreLock Nothing (Just AccessedEmpty) (ActiveLock name _)) = Just $@@ -299,7 +298,7 @@ helpOfSelectable (SelReadNote note) = Just $ "You have read "++noteAuthor note++"'s note on this lock." helpOfSelectable SelReadNoteSlot = Just $- "Reading three notes on this lock would let you piece together enough to unriddle its secrets."+ "Reading three notes on this lock would let you unriddle its secrets." helpOfSelectable (SelSecured note) = let ActiveLock owner idx = noteOn note in Just $ "Secured note on "++owner++"'s lock "++[lockIndexChar idx]++"." helpOfSelectable (SelSolution note) = Just $ case noteBehind note of@@ -307,7 +306,7 @@ " has secured their note on this lock behind their lock " ++ [lockIndexChar idx] ++ "." Nothing -> noteAuthor note ++ "'s note on this lock is public knowledge." helpOfSelectable (SelAccessed name) = Just $- name ++ " did not pick this lock, but is privy to its secrets."+ name ++ " did not pick this lock, but by reading three notes became privy its secrets." helpOfSelectable (SelPublicLock) = Just "Notes behind retired or public locks are public; locks with three public notes are public." helpOfSelectable (SelAccessedInfo meth) = Just $ case meth of@@ -321,7 +320,7 @@ helpOfSelectable SelLockPath = Just $ "Select a lock by its name. The names you give your locks are not revealed to others." helpOfSelectable SelPrivyHeader = Just $- "Guild members privy to this lock's secrets, hence able to read its secured notes."+ "Fellow uild 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." @@ -340,19 +339,22 @@ data UIOptButton a = UIOptButton { getUIOpt::UIOptions->a, setUIOpt::a->UIOptions->UIOptions,- uiOptVals::[a], uiOptPos::HexVec, uiOptGlyph::a->Glyph, uiOptDescr::a->String }+ uiOptVals::[a], uiOptPos::HexVec, uiOptGlyph::a->Glyph, uiOptDescr::a->String,+ 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 (\v -> if v then "Adjacent pieces get different colours" else "Pieces are coloured according to type")+ Nothing uiOB2 = UIOptButton showBlocks (\v o -> o {showBlocks=v}) [ShowBlocksBlocking,ShowBlocksAll,ShowBlocksNone]- (periphery 0 <+> 2 <*> hu <+> 1 <*> 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 uiOB3 = UIOptButton whsButtons (\v o -> o {whsButtons=v}) [Nothing, Just WHSSelected, Just WHSWrench, Just WHSHook] (periphery 3 <+> 3 <*> hv) whsButtonsButton (\v -> case v of@@ -361,14 +363,22 @@ WHSSelected -> "selected piece" WHSWrench -> "wrench" WHSHook -> "hook")+ Nothing uiOB4 = UIOptButton showButtonText (\v o -> o {showButtonText=v}) [True,False] (periphery 0 <+> 2 <*> hu <+> 2 <*> hv) showButtonTextButton (\v -> if v then "Help text enabled" else "Help text disabled")-uiOB5 = UIOptButton useSounds (\v o -> o {useSounds=v}) [True,False]- (periphery 0 <+> 2 <*> hu <+> 2 <*> neg hv) useSoundsButton+ 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)+uiOB6 = UIOptButton useSounds (\v o -> o {useSounds=v}) [True,False]+ (periphery 0 <+> 3 <*> hu <+> hv) useSoundsButton (\v -> if v then "Sound effects enabled" else "Sound effects disabled")+ Nothing drawUIOptionButtons :: InputMode -> UIM () drawUIOptionButtons mode = do@@ -377,9 +387,10 @@ drawUIOptionButton uiOB2 unless (mode == IMReplay) $ drawUIOptionButton uiOB3 #ifdef SOUND- drawUIOptionButton uiOB5+ drawUIOptionButton uiOB6 #endif drawUIOptionButton uiOB4+ drawUIOptionButton uiOB5 drawUIOptionButton b = do value <- gets $ (getUIOpt b).uiOptions renderToMain $ mapM_ (\g -> drawAtRel g (uiOptPos b))@@ -388,10 +399,13 @@ value <- gets $ (getUIOpt b).uiOptions return $ uiOptDescr b value -- XXX: hand-hacking lenses...-toggleUIOption (UIOptButton getopt setopt vals _ _ _) = 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'+ case monSet of+ Nothing -> return ()+ Just onSet -> onSet value' readUIConfigFile :: UIM () readUIConfigFile = do@@ -481,7 +495,8 @@ -- and [2*size*screenWidthHexes <= width -- , 3*ysize size*screenHeightHexes <= height] -- where ysize size = round $ fromIntegral size / sqrt 3- let size = max 1 $ minimum [ w`div`(2*screenWidthHexes)+ -- Minimum allowed size is 2 (get segfaults on SDL_FreeSurface with 1).+ let size = max 2 $ minimum [ w`div`(2*screenWidthHexes) , floor $ sqrt 3 * (0.5 + (fromIntegral $ h`div`(3*screenHeightHexes)))] return (scrCentre, size) @@ -516,12 +531,26 @@ else do modify $ \ds -> ds { lastDrawArgs = Just args } - let animSts = [ st | AlertIntermediateState st <- alerts ] ++ [st]- let drawSt = animSts !! animFrameToDraw+ -- split the alerts at intermediate states, and associate alerts+ -- to the right states:+ let (globalAlerts,transitoryAlerts) = partition isGlobalAlert alerts+ splitAlerts frameAs (AlertIntermediateState st' : as) =+ (frameAs,st') : splitAlerts [] as+ splitAlerts frameAs (a:as) =+ splitAlerts (a:frameAs) as+ splitAlerts frameAs [] = [(frameAs,st)]+ isGlobalAlert (AlertAppliedForce _) = False+ isGlobalAlert (AlertIntermediateState _) = False+ isGlobalAlert _ = True+ let animAlertedStates =+ let ass = splitAlerts [] transitoryAlerts+ in if last ass == ([],st) then ass else ass ++ [([],st)]+ let frames = length animAlertedStates+ let (drawAlerts',drawSt) = animAlertedStates !! animFrameToDraw+ let drawAlerts = drawAlerts' ++ globalAlerts -- let drawAlerts = takeWhile (/= AlertIntermediateState drawSt) alerts- let drawAlerts = alerts nextIsSet <- isJust <$> gets nextAnimFrameAt- when (not nextIsSet && length animSts > animFrameToDraw+1) $ do+ when (not nextIsSet && frames > animFrameToDraw+1) $ do time <- uiAnimTime <$> gets uiOptions modify $ \ds -> ds { nextAnimFrameAt = Just $ now + time } @@ -549,6 +578,8 @@ -- AlertResistedForce force <- drawAlerts ] ++ [ drawAt collisionMarker pos | AlertCollision pos <- drawAlerts ]+ ++ [ drawApplied drawSt colouring force+ | AlertAppliedForce force <- drawAlerts ] vidSurf <- liftIO getVideoSurface liftIO $ blitSurface gsSurf Nothing vidSurf Nothing @@ -647,7 +678,7 @@ renderStrColAt buttonTextCol bdg v when showBT $ withFont smallFont $ recentreAt v $ rescaleRender (1/4) $- sequence_ [ renderStrColAtLeft col s dv | (s,dv) <- helps ]+ sequence_ [ renderStrColAtLeft white s dv | (s,dv) <- helps ] | (i,(v,bdg,helps)) <- enumerate $ map (\b->(buttonPos b, bindingStr $ buttonCmd b, buttonHelp b)) $ buttonGroup , let col = dim $ colourWheel (base+inc*i) ] | (buttonGroup,(base,inc)) <- buttons@@ -656,7 +687,8 @@ initVideo :: Int -> Int -> UIM () initVideo w h = do- liftIO $ setVideoMode w h 0 [Resizable]+ fs <- fullscreen <$> gets uiOptions+ liftIO $ setVideoMode w h 0 [if fs then Fullscreen else Resizable] -- see what size we actually got: vinfo <- liftIO $ getVideoInfo@@ -668,7 +700,7 @@ modify $ \ds -> ds { gsSurface = Just gssurf, lastDrawArgs = Nothing } (_,size) <- getGeom- let fontfn = "VeraMono.ttf"+ let fontfn = "VeraMoBd.ttf" fontpath <- liftIO $ getDataPath fontfn font <- liftIO $ TTF.tryOpenFont fontpath size smallFont <- liftIO $ TTF.tryOpenFont fontpath (2*size`div`3)@@ -692,7 +724,7 @@ initAudio :: UIM () #ifdef SOUND initAudio = do- liftIO $ tryOpenAudio defaultFrequency AudioS16LSB 1 4096+ liftIO $ tryOpenAudio defaultFrequency AudioS16Sys 1 1024 -- liftIO $ querySpec >>= print liftIO $ allocateChannels 16 let seqWhileJust (m:ms) = m >>= \ret -> case ret of@@ -748,13 +780,14 @@ sayError = setMsgLine errorCol miniLockPos = (-9)<*>hw <+> hu-lockLinePos = 2<*>(hu <+> neg hw) <+> miniLockPos-serverPos = 12<*>hv <+> 6<*>neg hu+lockLinePos = 4<*>hu <+> miniLockPos+serverPos = 12<*>hv <+> 7<*>neg hu serverWaitPos = serverPos <+> hw <+> neg hu-nextPagePos = serverPos <+> 5<*>neg hv-randomNamesPos = 9<*>hv <+> neg hu-codenamePos = (-4)<*>hw <+> 4<*>hv-undeclsPos = hv <+> neg hw <+> codenamePos+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 <+> 10<*>hu <+> (-4)<*>hv+retiredPos = locksPos <+> 11<*>hu <+> neg hv+interactButtonsPos = 9<*>neg hu <+> 8<*>hw+scoresPos = codenamePos <+> 5<*>hu <+> 2<*>neg hv
SDLUIMInstance.hs view
@@ -9,6 +9,7 @@ -- along with this program. If not, see http://www.gnu.org/licenses/. {-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -cpp #-} module SDLUIMInstance () where import Graphics.UI.SDL hiding (flip)@@ -88,7 +89,7 @@ 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 4 [("merge",hu<+>neg hw)]+ , singleButton (periphery 2 <+> 3<*>hw) CmdMerge 1 [("merge",hu<+>neg hw)] ] sequence_ [ when (null . filter (pred . placedPiece) . Vector.toList $ placedPieces st)@@ -103,25 +104,13 @@ let home = isJust ourName && ourName == selName lift $ renderToMain $ (erase >> drawCursorAt Nothing) lift $ do- maybe (drawEmptyMiniLock miniLockPos)- (\lock -> drawMiniLock lock miniLockPos)- (fst<$>mlock)- registerSelectable miniLockPos 3 SelOurLock- lift $ when (not $ null path) $ do- renderToMain $ renderStrColAtLeft messageCol path $ lockLinePos <+> hu- registerSelectable (lockLinePos <+> 2<*>hu) 1 SelLockPath- sequence_- [ registerButton (miniLockPos <+> 2<*>neg hv <+> hu <+> dv) cmd 4- [(dirText,hu<+>neg hw),("lock",hu<+>neg hv)]- | (dv,cmd,dirText) <- [(zero,CmdPrevLock,"prev"),(neg hw,CmdNextLock,"next")] ]- lift $ do smallFont <- gets dispFontSmall renderToMain $ withFont smallFont $ renderStrColAtLeft messageCol (saddrStr saddr ++ if cOnly then " (cache only)" else "") $ serverPos <+> hu when (length names > 1) $ lift $ registerButton- (codenamePos <+> 2<*>neg hu <+> hw) CmdBackCodename 0 [("back",2<*>hw<+>neg hv<+>neg hu)]+ (codenamePos <+> neg hu <+> 2<*>hw) CmdBackCodename 0 [("back",3<*>hw)] runMaybeT $ do name <- MaybeT (return selName)@@ -132,42 +121,61 @@ smallFont <- gets dispFontSmall renderToMain $ withFont smallFont $ renderStrColAtLeft (opaquify $ dim errorCol) "(stale)" $ serverWaitPos maybe (return ()) (setMsgLineNoRefresh errorCol) err- when (fresh && (isNothing ourName || home || isNothing muirc)) $- let reg = (isNothing muirc && isNothing ourName) || home- in registerButton (codenamePos <+> hw <+> 2<*>hu)- (if reg then CmdRegister else CmdAuth) 2 [(if reg then "reg" else "auth", hu<+>neg hv)]+ when (fresh && (isNothing ourName || isNothing muirc || home)) $+ let reg = isNothing muirc && isNothing ourName+ 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 isJust muirc then drawName else drawNullName) name codenamePos lift $ registerSelectable codenamePos 0 (SelSelectedCodeName name) drawRelScore name (codenamePos<+>hu)+ when (isJust muirc) $ lift $+ registerButton retiredPos CmdShowRetired 5 [("retired",hu<+>neg hw)] for_ muirc $ \(RCUserInfo (_,uinfo)) -> case mretired of Just retired -> do fillArea locksPos (map (locksPos<+>) $ zero:[rotate n $ 4<*>hu<->4<*>hw | n <- [0,2,3,5]]) [ \pos -> (lift $ registerSelectable pos 1 (SelOldLock ls)) >> drawOldLock ls pos | ls <- retired ]- lift $ registerButton retiredPos CmdShowRetired pubWheelAngle [("retired",hu<+>neg hw)]- lift $ registerButton (retiredPos <+> hw) (CmdPlayLockSpec Nothing) 4 [("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 ]- let mmiscpos = (serverPos <+> 2<*>neg hv) when (isJust $ msum $ elems $ userLocks uinfo) $ lift $ do- registerButtonGroup- ([ Button mmiscpos (CmdSolve Nothing) [("solve",hu<+>neg hw),("lock",hu<+>neg hv)]- , Button (mmiscpos<+>neg hv) (CmdViewSolution Nothing) [("view",hu<+>neg hw),("soln",hu<+>neg hv)]], (2,2))- let tested = maybe False (isJust.snd) mlock- when (isJust mlock && home) $ lift $ registerButton- (miniLockPos <+> 3<*>hv) (CmdPlaceLock Nothing) (if tested then 2 else 0) [("place",hv<+>5<*>neg hu),("lock",hw<+>4<*>neg hu)]- lift $ registerButton retiredPos CmdShowRetired pubWheelAngle [("retired",hu<+>neg hw)]+ 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) unless (null undecls) $ do- lift.renderToMain $ renderStrColAtLeft messageCol "Undeclared:" (undeclsPos<+>2<*>hv)- lift $ registerButton (undeclsPos<+>2<*>hv<+>neg hu) (CmdDeclare Nothing) 2 [("decl",hv<+>4<*>neg hu),("soln",hw<+>4<*>neg hu)]+ lift.renderToMain $ renderStrColAtLeft messageCol "Undeclared:" (undeclsPos<+>2<*>hv<+>neg hu)+ lift $ registerButton (undeclsPos<+>hw<+>neg hu) (CmdDeclare Nothing) 2 [("decl",hv<+>4<*>neg hu),("soln",hw<+>4<*>neg hu)] fillArea (undeclsPos<+>hv) (map (undeclsPos<+>) $ hexDisc 1 ++ [hu<+>neg hw, neg hu<+>hv]) [ \pos -> (lift $ registerSelectable pos 0 (SelUndeclared undecl)) >> drawActiveLock al pos | undecl@(Undeclared _ _ al) <- undecls ]+ lift $ do+ maybe (drawEmptyMiniLock miniLockPos)+ (\lock -> drawMiniLock lock miniLockPos)+ (fst<$>mlock)+ registerSelectable miniLockPos 1 SelOurLock+ registerButton (miniLockPos<+>3<*>neg hw<+>2<*>hu) CmdEdit 2+ [("edit",hu<+>neg hw),("lock",hu<+>neg hv)]+ registerButton lockLinePos CmdSelectLock 1 []+ lift $ when (not $ null path) $ do+ renderToMain $ renderStrColAtLeft messageCol (take 16 path) $ lockLinePos <+> hu+ registerSelectable (lockLinePos <+> 2<*>hu) 1 SelLockPath+ sequence_+ [ registerButton (miniLockPos <+> 2<*>neg hv <+> 2<*>hu <+> dv) cmd 1+ [(dirText,hu<+>neg hw),("lock",hu<+>neg hv)]+ | (dv,cmd,dirText) <- [(zero,CmdPrevLock,"prev"),(neg hw,CmdNextLock,"next")] ]+ let tested = maybe False (isJust.snd) mlock+ when (isJust mlock && home) $ lift $ registerButton+ (miniLockPos<+>2<*>neg hw<+>3<*>hu) (CmdPlaceLock Nothing)+ (if tested then 2 else 1)+ [("place",hu<+>neg hw),("lock",hu<+>neg hv)] rnames <- liftIO $ atomically $ readTVar rnamestvar unless (null rnames) $ fillArea randomNamesPos@@ -177,14 +185,17 @@ when (ourName /= selName) $ void $ runMaybeT $ do when (isJust ourName) $- lift.lift $ registerButton (codenamePos <+> neg hu <+> hw) CmdHome 4 [("home",hu<+>neg hv)]+ 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 lift $ do- fillArea (codenamePos<+>3<*>hv<+>hw) (map ((codenamePos<+>3<*>hv)<+>) [zero,hw,neg hv])+ drawRelScore sel scoresPos+ fillArea (posLeft<+>hw) (map (posLeft<+>) [zero,hw,neg hv]) [ \pos -> (lift $ registerSelectable pos 0 (SelScoreLock (Just sel) accessed $ ActiveLock us i)) >> drawNameWithCharAndCol us white (lockIndexChar i) col pos | i <- [0..2]@@ -193,7 +204,7 @@ | accessed == Just AccessedPub = dim pubColour | isJust accessed = dim $ scoreColour $ -3 | otherwise = obscure $ scoreColour 3 ]- fillArea (codenamePos<+>2<*>neg hw) (map ((codenamePos<+>3<*>neg hw)<+>) [zero,hw,neg hv])+ 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]@@ -205,18 +216,23 @@ (usUnacc,selUnacc) <- MaybeT $ (snd<$>) <$> getRelScoreDetails sel lift.lift.renderToMain $ sequence_ [renderStrColAt (scoreColour score) (sign:show (abs score)) pos | (sign,score,pos) <-- [ ('-',usUnacc-3,codenamePos<+>3<*>hv<+>neg hw)- , ('+',3-selUnacc,codenamePos<+>3<*>neg hw<+>hv) ] ]+ [ ('-',usUnacc-3,posLeft<+>neg hv<+>hw)+ , ('+',3-selUnacc,posRight<+>neg hv<+>hw) ] ]+ drawMainState' _ = return () drawMessage = say+ drawPrompt full s = say $ s ++ (if full then "" else "_")+ endPrompt = say "" drawError = sayError reportAlerts = playAlertSounds getChRaw = do events <- liftIO getEvents- maybe getChRaw (return.Just) $ listToMaybe $ [ ch+ if not.null $ [ True | MouseButtonDown _ _ ButtonRight <- events ]+ then return Nothing+ else maybe getChRaw (return.Just) $ listToMaybe $ [ ch | KeyDown (Keysym _ _ ch) <- events , ch /= '\0' ] @@ -384,6 +400,10 @@ | mPos == uiOptPos uiOB4 ] ++ [ toggleUIOption uiOB5 >> updateHoverStr mode >> return [] | mPos == uiOptPos uiOB5 ]+#ifdef SOUND+ ++ [ toggleUIOption uiOB6 >> updateHoverStr mode >> return []+ | mPos == uiOptPos uiOB6 ]+#endif if rb then return [ CmdWait ]@@ -408,14 +428,14 @@ [ do cmd <- MaybeT $ cmdAtMousePos pos mode Nothing guard $ mode /= IMTextInput- modify $ \s -> s { settingBinding = Just cmd }- return []+ -- modify $ \s -> s { settingBinding = Just cmd }+ return [ CmdBind $ Just cmd ] , do cmd <- MaybeT $ cmdAtMousePos pos mode (Just True) return [cmd] , case mode of- IMPlay -> return [ CmdWait ]- _ -> return [ CmdSelect ] ]+ IMPlay -> return [ CmdClear, CmdWait ]+ _ -> return [ CmdClear, CmdSelect ] ] processEvent (MouseButtonUp _ _ ButtonRight) = do modify $ \s -> s { rightButtonDown = Nothing } return [ CmdUnselect ]@@ -470,7 +490,7 @@ modify $ \ds -> ds { mousePos = newPos } updateHoverStr mode - showHelp mode = do+ showHelp mode 0 = do bdgs <- nub <$> getBindings mode smallFont <- gets dispFontSmall renderToMain $ do@@ -478,7 +498,7 @@ let bdgWidth = (screenWidthHexes-6) `div` 3 showKeys chs = intercalate "/" (map showKeyFriendly chs) maxkeyslen = maximum . (0:) $ map (length.showKeys.map fst) $ groupBy ((==) `on` snd) bdgs- mouseHelpStrs = ["Mouse commands:", "Right-click on a button to set a keybinding;"]+ extraHelpStrs = ["Mouse commands:", "Right-click on a button to set a keybinding;"] ++ case mode of IMPlay -> ["Click on tool to select, drag to move;", "Click by tool to move; right-click to wait;", "Scroll wheel to rotate hook;",@@ -488,9 +508,17 @@ "While holding right-click: left-click to advance time, middle-click to delete;", "Scroll wheel to rotate selected piece; scroll wheel while held down to undo/redo."] IMReplay -> ["Scroll wheel with right button held down to undo/redo."]- IMMeta -> ["Left-clicking on something does most obvious thing;",- "Right-clicking does second-most obvious thing."]+ IMMeta -> ["Left-clicking on something does most obvious thing;"+ , "Right-clicking does second-most obvious thing."+ , ""+ , "Basic game instructions:"+ , "Choose [C]odename, then [R]egister it;"+ , "select other players, and [S]olve their locks;"+ , "go [H]ome, then [E]dit and [P]lace a lock of your own;"+ , "you can then [D]eclare your solutions."+ , "Make other players green by solving their locks and not letting them solve yours."] renderStrColAt 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 <+>@@ -507,14 +535,51 @@ then withFont smallFont else id ]- (map (`divMod` (screenHeightHexes-9)) [0..])+ (map (`divMod` keybindingsHeight) [0..]) , (x+1)*bdgWidth < screenWidthHexes] sequence_ [ renderStrColAt messageCol str- $ (3-screenHeightHexes`div`4-y`div`2)<*>(hv<+>neg hw)- <+> hv+ $ (screenHeightHexes`div`4 - y`div`2)<*>(hv<+>neg hw)+ <+> hw <+> (y`mod`2)<*>hw- | (str,y) <- zip mouseHelpStrs [0..] ]+ | (str,y) <- zip extraHelpStrs [keybindingsHeight..] ] refresh+ return True+ showHelp IMMeta 1 = do+ renderToMain $ do+ erase+ 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,str) <- zip [2..]+ [ "By ruthlessly guarded secret arrangement, the Council's agents can pick any lock in the city."+ , "The Guild maintains this by producing apparently secure locks with fatal, but hidden, flaws."+ , "The ritual game known as \"Intricacy\" is played to determine the best designs."+ , "Players attempt to design locks which can be picked only by one who knows the secret,"+ , "and try to discover the secret flaws in the designs of their colleagues."+ , ""+ , "You may put forward up to three prototype locks. They will guard the secrets you discover."+ , "If you pick a colleague's lock, the rules require that you write a note describing your solution."+ , "The composition and deciphering of notes is an art in itself, whose details do not concern us here,"+ , "but a note must prove that the author found a solution, while aiming not to explain it in full."+ , "To declare your success, you must secure your note behind a lock of your own."+ , "If you are able to unlock a lock, you automatically read all the notes it secures."+ , "If you read three notes on a lock, you will piece together the 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."+ , ""+ , "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 secured become \"public\" and are read by all."+ ]+ ]+ return True+ showHelp _ _ = return False drawShortMouseHelp mode = do mwhs <- gets $ whsButtons.uiOptions@@ -578,7 +643,11 @@ , guard (mPos == uiOptPos uiOB2) >> describeUIOptionButton uiOB2 , guard (mPos == uiOptPos uiOB3) >> describeUIOptionButton uiOB3 , guard (mPos == uiOptPos uiOB4) >> describeUIOptionButton uiOB4- , guard (mPos == uiOptPos uiOB5) >> describeUIOptionButton uiOB5 ]+ , guard (mPos == uiOptPos uiOB5) >> describeUIOptionButton uiOB5+#ifdef SOUND+ , guard (mPos == uiOptPos uiOB6) >> describeUIOptionButton uiOB6+#endif+ ] modify $ \ds -> ds { hoverStr = hstr } where describeCommandAndKeys :: Command -> UIM String@@ -594,7 +663,7 @@ fillArea centre area draws = do offset <- gets listOffset let na = length area- listButton cmd = \pos -> lift $ registerButton pos cmd 4 []+ listButton cmd = \pos -> lift $ registerButton pos cmd 3 [] draws' = if offset > 0 && length draws > na then listButton CmdPrevPage : drop (max 0 $ min (length draws - (na-1)) (na-1 + (na-2)*(offset-1))) draws@@ -621,7 +690,7 @@ drawNameCol name pos col = do lift.renderToMain $ do drawAtRel (playerGlyph col) pos- renderStrColAt messageCol name pos+ renderStrColAt buttonTextCol name pos drawRelScore name pos = do col <- nameCol name relScore <- getRelScore name@@ -652,7 +721,7 @@ lift.renderToMain $ do drawAtRel (playerGlyph col) pos displaceRender up $- renderStrColAt messageCol name pos+ renderStrColAt buttonTextCol name pos displaceRender down $ withFont smallFont $ renderStrColAt charcol [char] pos pubWheelAngle = 5@@ -738,7 +807,7 @@ "Read:" $ readPos when (length read == 3) $ lift $ registerSelectable readPos 0 (SelAccessedInfo AccessedReadNotes) fillArea (accessedPos<+>neg hu) [ accessedPos <+> i<*>hu | i <- [-1..1] ]- $ take 3 $ [ \pos -> (lift $ registerSelectable pos 0 (SelReadNote note)) >> drawName (noteAuthor note) pos+ $ take 3 $ [ \pos -> (lift $ registerSelectable pos 0 (SelReadNote note)) >> drawNote note pos | note <- read ] ++ (repeat $ \pos -> (lift $ registerSelectable pos 0 SelReadNoteSlot >> renderToMain (drawAtRel (hollowGlyph $ dim green) pos)))
Server.hs view
@@ -226,7 +226,7 @@ then ServedSolution <$> getSolution note else if case behindMLinfo of Nothing -> True- Just behindInfo -> uname `elem` accessedBy behindInfo+ Just behindInfo -> public behindInfo || uname `elem` accessedBy behindInfo || note `elem` notesRead uinfo then if public onLinfo || uname `elem` accessedBy onLinfo then ServedSolution <$> getSolution note
+ VeraMoBd.ttf view
binary file changed (absent → 49052 bytes)
− VeraMono.ttf
binary file changed (49224 → absent bytes)
intricacy.cabal view
@@ -1,5 +1,5 @@ name: intricacy-version: 0.4.1+version: 0.4.3 synopsis: A game of competitive puzzle-design homepage: http://mbays.freeshell.org/intricacy license: GPL-3@@ -10,8 +10,8 @@ category: Game build-type: Simple cabal-version: >=1.8-data-files: VeraMono.ttf tutorial/*.lock tutorial/*.text sounds/*.ogg-extra-doc-files: README NEWS tutorial-extra/*.lock tutorial-extra/README+data-files: VeraMoBd.ttf tutorial/*.lock tutorial/*.text sounds/*.ogg+extra-doc-files: README BUILD NEWS tutorial-extra/*.lock tutorial-extra/README description: A networked game with client-server architecture. The core game is a
+ tutorial-extra/4-hook.lock view
@@ -0,0 +1,11 @@+ & & & & & & + & S S " " " & & & + & S S " % " & & + & ~ ~ % ' " " " &+ & ~ ~ o & & + & ~ # % ` % % & + & & 7 % % & +& * ' 7 % # # # & + & @ & % # # # & + & & & % C C C C & + & & & & & &
tutorial/1-winning.text view
@@ -1,1 +1,1 @@-use tools to pull bolt, then Open the lock+use your tools, the hook and the wrench, to pull the bolt aside, then Open the lock
+ tutorial/2-tools.lock view
@@ -0,0 +1,13 @@+ " " " " " " " + " S S # " " " + " # # # % " " + " % % % % "+ " o # S S S S % " " + " ` # " + " % % % % % % # # " + " % % " + " " % % % # " +" * ' % % " + " @ " # % o " + " " " # / % " + " " " " " " "
+ tutorial/2-tools.text view
@@ -0,0 +1,1 @@+the wrench can fit where the hook can't, but keeps moving until it hits something
− tutorial/2-wrench.lock
@@ -1,17 +0,0 @@- " " " " " " " " " - " " " " " - " % S S S S S & " " - " O % & " " - " % % % % o - & & & & & & "- " % % " " - " % % % # # # " " - " % # " -" % % % # # # # " - " % % " - " % O " - " " & % % % % % " -" * ' & & & & & \ % " - " @ " & & & o % " - " " " & % " - " & % " - " " " " " " " " "
− tutorial/2-wrench.text
@@ -1,1 +0,0 @@-the wrench moves in a line until it hits something; you can undo ('X') mistakes
− tutorial/3-hook.lock
@@ -1,11 +0,0 @@- & & & & & & - & S S " " " & & & - & S S " % " & & - & ~ ~ % ' " " " &- & ~ ~ o & & - & ~ # % ` % % & - & & 7 % % & -& * ' 7 % # # # & - & @ & % # # # & - & & & % C C C C & - & & & & & &
− tutorial/3-hook.text
@@ -1,1 +0,0 @@-turn hook with mouse wheel to pull springs aside; numpad and vi keys also supported
+ tutorial/3-puzzle.lock view
@@ -0,0 +1,17 @@+ & & & & & & & & & + & & & & & + & # S S S S S " & & + & O % " & & + & S S # # # o - " " " " " " &+ & # # % # & & + & % % # # # # # & & + & % % # & +& % % % # # # # & + & % % & + & % O & + & & " % % % % % & +& * ' " " " " " \ % & + & @ & " " " o % & + & & & " % & + & " % & + & & & & & & & & &
+ tutorial/3-puzzle.text view
@@ -0,0 +1,1 @@+if you make a mistake, you can undo moves ('X') or reset to the start ('^')
+ tutorial/4-hook.lock view
@@ -0,0 +1,13 @@+ & & & & & & & + & # # % & & & + & Z # % & # & + & " " " Z % # &+ & # C C " Z # & & + & % " " " Z # & + & 7 " " " " " # & + & 7 " " " " " % # & + & & " " " " " # # & +& * ' " " " " " " # & + & @ & " " " " " " 7 & + & & & " " " " " 7 & + & & & & & & &
+ tutorial/4-hook.text view
@@ -0,0 +1,1 @@+turn hook with mouse wheel to pull springs aside; numpad and vi keys also supported
− tutorial/4-plug.lock
@@ -1,17 +0,0 @@- " " " " " " " " " - " # ( " " " " - " # ( " " - " # # ( " # " - " # # ( # "- " # ( # " " - " & & % ( # " " - " & & & & Z ( # # " -" # C C & & Z ( # # # " - " & & & & & # 7 " - " & & & & & ] 7 " - " " & & & ] % 7 " -" * ' o \ O # " % 7 " - " @ " ` o # % 7 " - " " " # % # % 7 " - " % % % " - " " " " " " " " "
− tutorial/4-plug.text
@@ -1,1 +0,0 @@-compress the central springs with both tools at once
+ tutorial/5-plug.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " # ( " " " " + " # ( " " + " # # ( " # " + " # # ( # "+ " # ( # " " + " & & % ( # " " + " & & & & Z ( # # " +" # C C & & Z ( # # # " + " & & & & & # 7 " + " & & & & & ] 7 " + " " & & & ] % 7 " +" * ' o \ O # " % 7 " + " @ " ` o # % 7 " + " " " # % # % 7 " + " % % % " + " " " " " " " " "
+ tutorial/5-plug.text view
@@ -0,0 +1,1 @@+compress the central springs with both tools at once