diff --git a/BUILD b/BUILD new file mode 100644 --- /dev/null +++ b/BUILD @@ -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! diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -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" diff --git a/CursesUI.hs b/CursesUI.hs --- a/CursesUI.hs +++ b/CursesUI.hs @@ -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 diff --git a/CursesUIMInstance.hs b/CursesUIMInstance.hs --- a/CursesUIMInstance.hs +++ b/CursesUIMInstance.hs @@ -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 = diff --git a/Interact.hs b/Interact.hs --- a/Interact.hs +++ b/Interact.hs @@ -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} diff --git a/InteractUtil.hs b/InteractUtil.hs --- a/InteractUtil.hs +++ b/InteractUtil.hs @@ -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 diff --git a/KeyBindings.hs b/KeyBindings.hs --- a/KeyBindings.hs +++ b/KeyBindings.hs @@ -101,7 +101,7 @@ [ ('Q', CmdQuit) , (ctrl 'C', CmdQuit) , ('?', CmdHelp) - , (ctrl 'B', CmdBind) + , (ctrl 'B', CmdBind Nothing) , (ctrl 'L', CmdRedraw) , (ctrl 'Z', CmdSuspend) , ('%', CmdToggleColourMode) diff --git a/MainBoth.hs b/MainBoth.hs new file mode 100644 --- /dev/null +++ b/MainBoth.hs @@ -0,0 +1,22 @@ +-- This file is part of Intricacy +-- Copyright (C) 2013 Martin Bays +-- +-- 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))) diff --git a/MainBoth.hsMainSDL.hsMainCurses.hs b/MainBoth.hsMainSDL.hsMainCurses.hs deleted file mode 100644 --- a/MainBoth.hsMainSDL.hsMainCurses.hs +++ /dev/null diff --git a/MainCurses.hs b/MainCurses.hs new file mode 100644 --- /dev/null +++ b/MainCurses.hs @@ -0,0 +1,20 @@ +-- This file is part of Intricacy +-- Copyright (C) 2013 Martin Bays +-- +-- 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))) diff --git a/MainSDL.hs b/MainSDL.hs new file mode 100644 --- /dev/null +++ b/MainSDL.hs @@ -0,0 +1,20 @@ +-- This file is part of Intricacy +-- Copyright (C) 2013 Martin Bays +-- +-- 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)))) diff --git a/MainState.hs b/MainState.hs --- a/MainState.hs +++ b/MainState.hs @@ -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 ()) diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -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. diff --git a/README b/README --- a/README +++ b/README @@ -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 diff --git a/SDLRender.hs b/SDLRender.hs --- a/SDLRender.hs +++ b/SDLRender.hs @@ -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 diff --git a/SDLUI.hs b/SDLUI.hs --- a/SDLUI.hs +++ b/SDLUI.hs @@ -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 diff --git a/SDLUIMInstance.hs b/SDLUIMInstance.hs --- a/SDLUIMInstance.hs +++ b/SDLUIMInstance.hs @@ -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))) diff --git a/Server.hs b/Server.hs --- a/Server.hs +++ b/Server.hs @@ -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 diff --git a/VeraMoBd.ttf b/VeraMoBd.ttf new file mode 100644 Binary files /dev/null and b/VeraMoBd.ttf differ diff --git a/VeraMono.ttf b/VeraMono.ttf deleted file mode 100644 Binary files a/VeraMono.ttf and /dev/null differ diff --git a/intricacy.cabal b/intricacy.cabal --- a/intricacy.cabal +++ b/intricacy.cabal @@ -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 diff --git a/tutorial-extra/4-hook.lock b/tutorial-extra/4-hook.lock new file mode 100644 --- /dev/null +++ b/tutorial-extra/4-hook.lock @@ -0,0 +1,11 @@ + & & & & & & + & S S " " " & & & + & S S " % " & & + & ~ ~ % ' " " " & + & ~ ~ o & & + & ~ # % ` % % & + & & 7 % % & +& * ' 7 % # # # & + & @ & % # # # & + & & & % C C C C & + & & & & & & diff --git a/tutorial/1-winning.text b/tutorial/1-winning.text --- a/tutorial/1-winning.text +++ b/tutorial/1-winning.text @@ -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 diff --git a/tutorial/2-tools.lock b/tutorial/2-tools.lock new file mode 100644 --- /dev/null +++ b/tutorial/2-tools.lock @@ -0,0 +1,13 @@ + " " " " " " " + " S S # " " " + " # # # % " " + " % % % % " + " o # S S S S % " " + " ` # " + " % % % % % % # # " + " % % " + " " % % % # " +" * ' % % " + " @ " # % o " + " " " # / % " + " " " " " " " diff --git a/tutorial/2-tools.text b/tutorial/2-tools.text new file mode 100644 --- /dev/null +++ b/tutorial/2-tools.text @@ -0,0 +1,1 @@ +the wrench can fit where the hook can't, but keeps moving until it hits something diff --git a/tutorial/2-wrench.lock b/tutorial/2-wrench.lock deleted file mode 100644 --- a/tutorial/2-wrench.lock +++ /dev/null @@ -1,17 +0,0 @@ - " " " " " " " " " - " " " " " - " % S S S S S & " " - " O % & " " - " % % % % o - & & & & & & " - " % % " " - " % % % # # # " " - " % # " -" % % % # # # # " - " % % " - " % O " - " " & % % % % % " -" * ' & & & & & \ % " - " @ " & & & o % " - " " " & % " - " & % " - " " " " " " " " " diff --git a/tutorial/2-wrench.text b/tutorial/2-wrench.text deleted file mode 100644 --- a/tutorial/2-wrench.text +++ /dev/null @@ -1,1 +0,0 @@ -the wrench moves in a line until it hits something; you can undo ('X') mistakes diff --git a/tutorial/3-hook.lock b/tutorial/3-hook.lock deleted file mode 100644 --- a/tutorial/3-hook.lock +++ /dev/null @@ -1,11 +0,0 @@ - & & & & & & - & S S " " " & & & - & S S " % " & & - & ~ ~ % ' " " " & - & ~ ~ o & & - & ~ # % ` % % & - & & 7 % % & -& * ' 7 % # # # & - & @ & % # # # & - & & & % C C C C & - & & & & & & diff --git a/tutorial/3-hook.text b/tutorial/3-hook.text deleted file mode 100644 --- a/tutorial/3-hook.text +++ /dev/null @@ -1,1 +0,0 @@ -turn hook with mouse wheel to pull springs aside; numpad and vi keys also supported diff --git a/tutorial/3-puzzle.lock b/tutorial/3-puzzle.lock new file mode 100644 --- /dev/null +++ b/tutorial/3-puzzle.lock @@ -0,0 +1,17 @@ + & & & & & & & & & + & & & & & + & # S S S S S " & & + & O % " & & + & S S # # # o - " " " " " " & + & # # % # & & + & % % # # # # # & & + & % % # & +& % % % # # # # & + & % % & + & % O & + & & " % % % % % & +& * ' " " " " " \ % & + & @ & " " " o % & + & & & " % & + & " % & + & & & & & & & & & diff --git a/tutorial/3-puzzle.text b/tutorial/3-puzzle.text new file mode 100644 --- /dev/null +++ b/tutorial/3-puzzle.text @@ -0,0 +1,1 @@ +if you make a mistake, you can undo moves ('X') or reset to the start ('^') diff --git a/tutorial/4-hook.lock b/tutorial/4-hook.lock new file mode 100644 --- /dev/null +++ b/tutorial/4-hook.lock @@ -0,0 +1,13 @@ + & & & & & & & + & # # % & & & + & Z # % & # & + & " " " Z % # & + & # C C " Z # & & + & % " " " Z # & + & 7 " " " " " # & + & 7 " " " " " % # & + & & " " " " " # # & +& * ' " " " " " " # & + & @ & " " " " " " 7 & + & & & " " " " " 7 & + & & & & & & & diff --git a/tutorial/4-hook.text b/tutorial/4-hook.text new file mode 100644 --- /dev/null +++ b/tutorial/4-hook.text @@ -0,0 +1,1 @@ +turn hook with mouse wheel to pull springs aside; numpad and vi keys also supported diff --git a/tutorial/4-plug.lock b/tutorial/4-plug.lock deleted file mode 100644 --- a/tutorial/4-plug.lock +++ /dev/null @@ -1,17 +0,0 @@ - " " " " " " " " " - " # ( " " " " - " # ( " " - " # # ( " # " - " # # ( # " - " # ( # " " - " & & % ( # " " - " & & & & Z ( # # " -" # C C & & Z ( # # # " - " & & & & & # 7 " - " & & & & & ] 7 " - " " & & & ] % 7 " -" * ' o \ O # " % 7 " - " @ " ` o # % 7 " - " " " # % # % 7 " - " % % % " - " " " " " " " " " diff --git a/tutorial/4-plug.text b/tutorial/4-plug.text deleted file mode 100644 --- a/tutorial/4-plug.text +++ /dev/null @@ -1,1 +0,0 @@ -compress the central springs with both tools at once diff --git a/tutorial/5-plug.lock b/tutorial/5-plug.lock new file mode 100644 --- /dev/null +++ b/tutorial/5-plug.lock @@ -0,0 +1,17 @@ + " " " " " " " " " + " # ( " " " " + " # ( " " + " # # ( " # " + " # # ( # " + " # ( # " " + " & & % ( # " " + " & & & & Z ( # # " +" # C C & & Z ( # # # " + " & & & & & # 7 " + " & & & & & ] 7 " + " " & & & ] % 7 " +" * ' o \ O # " % 7 " + " @ " ` o # % 7 " + " " " # % # % 7 " + " % % % " + " " " " " " " " " diff --git a/tutorial/5-plug.text b/tutorial/5-plug.text new file mode 100644 --- /dev/null +++ b/tutorial/5-plug.text @@ -0,0 +1,1 @@ +compress the central springs with both tools at once