intricacy 0.3 → 0.3.1
raw patch · 8 files changed
+102/−32 lines, 8 files
Files
- CursesUIMInstance.hs +4/−3
- EditGameState.hs +1/−0
- Interact.hs +21/−15
- KeyBindings.hs +13/−3
- NEWS +3/−0
- SDLUI.hs +7/−2
- SDLUIMInstance.hs +52/−8
- intricacy.cabal +1/−1
CursesUIMInstance.hs view
@@ -189,6 +189,7 @@ drawMainState' (MetaState saddr undecls cOnly auth names _ _ rnamestvar _ _ mretired path lock _) = do let ourName = liftM authUser auth let selName = listToMaybe names+ let home = isJust ourName && ourName == selName (h,w) <- liftIO Curses.scrSize when (h<20 || w<40) $ liftIO CursesH.end >> error "Terminal too small!" lift $ do@@ -213,9 +214,10 @@ lift $ do unless fresh $ drawAtCVec (Glyph '*' red bold) $ CVec 2 (w`div`2+7) maybe (return ()) sayError err- when (fresh && isNothing ourName) $+ when (fresh && (isNothing ourName || home || isNothing muirc)) $ drawStrGrey (CVec 2 (w`div`2+1+9)) =<<- (bindingsStr IMMeta $ if isNothing muirc then [CmdRegister] else [CmdAuth])+ (bindingsStr IMMeta $+ if (isNothing muirc && isNothing ourName) || home then [CmdRegister] else [CmdAuth]) for_ muirc $ \(RCUserInfo (_,uinfo)) -> case mretired of Just retired -> do (h,w) <- liftIO Curses.scrSize@@ -294,7 +296,6 @@ (map (`divMod` (h-3)) [0..]) , (x+1)*bdgWidth < w] refresh- void $ getInput mode getChRaw = (charify<$>) $ liftIO $ CursesH.getKey (return ()) setUIBinding mode cmd ch =
EditGameState.hs view
@@ -153,3 +153,4 @@ (idx'',_) <- Map.lookup (dir<+>pos) $ stateBoard st' return $ addPivotArm idx'' pos st' + _ -> mzero
Interact.hs view
@@ -113,7 +113,9 @@ processCommand im cmd = lift $ processCommand' im cmd processCommand' :: UIMonad uiM => InputMode -> Command -> StateT MainState uiM ()-processCommand' im CmdHelp = lift $ showHelp im+processCommand' im CmdHelp = lift $ do+ showHelp im+ void $ textInput "[press a key]" 1 False True Nothing Nothing processCommand' im CmdBind = lift $ flip (>>) (drawMessage "") $ void $ runMaybeT $ do lift $ drawMessage "Command to bind: " cmd <- msum $ repeat $ do@@ -566,27 +568,31 @@ selPos <- gets selectedPos st:_ <- gets esGameStateStack lift $ drawMessage "Merge in which direction?"- cmd <- lift $ head <$> getSomeInput IMEdit- lift $ drawMessage ""- case cmd of- CmdDir _ mergeDir -> do- modifyEState $ mergeTiles selPos mergeDir True- -- XXX: merging might invalidate selectedPiece- modify $ \es -> es {selectedPiece = Nothing}+ let getDir = do+ cmd <- lift $ head <$> getSomeInput IMEdit+ case cmd of+ CmdDir _ mergeDir -> return $ Just mergeDir+ CmdDrag _ mergeDir -> return $ Just mergeDir+ CmdMoveTo _ -> getDir+ _ -> return $ Nothing+ mergeDir <- getDir+ case mergeDir of+ Just mergeDir -> modifyEState $ mergeTiles selPos mergeDir True _ -> return ()+ -- XXX: merging might invalidate selectedPiece+ modify $ \es -> es {selectedPiece = Nothing}+ lift $ drawMessage "" processCommand' IMEdit CmdWait = do- selPos <- gets selectedPos- selPiece <- gets selectedPiece st:_ <- gets esGameStateStack- case selPiece of- Nothing -> drawTile selPos Nothing False- Just _ -> do (st',_) <- lift $ doPhysicsTick NullPM st- pushEState st'+ (st',_) <- lift $ doPhysicsTick NullPM st+ pushEState st'+ processCommand' IMEdit CmdDelete = do+ selPos <- gets selectedPos selPiece <- gets selectedPiece st:_ <- gets esGameStateStack case selPiece of- Nothing -> return ()+ Nothing -> drawTile selPos Nothing False Just p -> do modify $ \es -> es {selectedPiece = Nothing} modifyEState $ delPiece p processCommand' IMEdit CmdWriteState = void.runMaybeT $ do
KeyBindings.hs view
@@ -8,7 +8,7 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/. -module KeyBindings (KeyBindings, bindings, findBindings, findBinding, showKey) where+module KeyBindings (KeyBindings, bindings, findBindings, findBinding, showKey, showKeyFriendly) where import Data.Maybe import Data.Char@@ -128,7 +128,10 @@ , ('T', CmdTest) , ('W', CmdWriteState) , (ctrl 'S', CmdWriteState)+ , ('=', CmdMerge)+ , ('+', CmdMerge) , ('&', CmdMerge)+ , ('0', CmdDelete) , ('E', CmdDelete) ] tilesPaintRow = lowerToo@@ -137,7 +140,7 @@ , ('D', CmdTile $ PivotTile zero) , ('S', CmdTile $ SpringTile Relaxed zero) , ('A', CmdTile $ BlockTile [])- , ('Z', CmdWait)+ , ('Z', CmdDelete) ] tilesAscii = [ ('o', CmdTile $ PivotTile zero)@@ -153,7 +156,7 @@ , ('*', CmdTile $ WrenchTile zero) , ('#', CmdTile $ BlockTile []) ]-editOnly = editMisc ++ tilesPaintRow ++ tilesAscii+editOnly = tilesPaintRow ++ editMisc ++ tilesAscii playBindings = playOnly ++ lockGlobal replayBindings = replayOnly ++ lockGlobal@@ -197,3 +200,10 @@ showKey ch | isPrint ch = [ch] showKey ch | isPrint (unctrl ch) = ('^':[unctrl ch]) showKey _ = "[?]"++showKeyFriendly ' ' = "space"+showKeyFriendly '\r' = "return"+showKeyFriendly '\n' = "newline"+showKeyFriendly '\t' = "tab"+showKeyFriendly '\b' = "bksp"+showKeyFriendly ch = showKey ch
NEWS view
@@ -1,3 +1,6 @@+0.3.1:+ Misc minor UI improvements;+ Help screens in SDL mode. 0.3: Minor fixes; first version uploaded to hackage 0.2.8:
SDLUI.hs view
@@ -116,7 +116,7 @@ getButtons mode = do whs <- gets $ whsButtons.uiOptions cntxtButtons <- gets contextButtons- return $ cntxtButtons ++ case mode of + return $ cntxtButtons ++ global ++ case mode of IMEdit -> [ singleButton (tl<+>hv) CmdTest 4 , singleButton (tl<+>(neg hw)) CmdPlay 2@@ -162,6 +162,7 @@ where quitButton = Button br CmdQuit markGroup = ([Button (tl<+>hw) CmdMark, Button (tl<+>hw<+>neg hu) CmdJumpMark],(0,0))+ global = [ singleButton (tr <+> 4<*>hv <+> 3<*>hu) CmdHelp 3 ] tr = periphery 0 tl = periphery 2 bl = periphery 3@@ -293,6 +294,10 @@ liftIO makeConfDir liftIO $ writeFile path $ show bdgs +getBindings mode = do+ uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings+ return $ uibdgs ++ bindings mode+ paintTiles :: [ Maybe Tile ] paintTiles = [ Just BallTile@@ -303,7 +308,7 @@ , Nothing ] -paintTileCmds = map (maybe CmdWait CmdTile) paintTiles+paintTileCmds = map (maybe CmdDelete CmdTile) paintTiles getEffPaintTileIndex :: UIM Int getEffPaintTileIndex = do
SDLUIMInstance.hs view
@@ -85,7 +85,7 @@ registerUndoButtons (null sts) (null undostack) when (isJust selPiece) $ mapM_ registerButtonGroup [ singleButton (periphery 2 <+> 3<*>hw<+>hu) CmdDelete 0- -- , singleButton (periphery 2 <+> 3<*>hw) CmdMerge 4+ , singleButton (periphery 2 <+> 3<*>hw) CmdMerge 4 ] drawPaintButtons drawMainState' (MetaState saddr undecls cOnly auth names _ _ rnamestvar _ _ mretired path mlock offset) = do@@ -122,9 +122,9 @@ smallFont <- gets dispFontSmall renderToMain $ withFont smallFont $ renderStrColAtLeft (opaquify $ dim errorCol) "(stale)" $ serverWaitPos maybe (return ()) (setMsgLineNoRefresh errorCol) err- when (fresh && (isNothing ourName || home)) $+ when (fresh && (isNothing ourName || home || isNothing muirc)) $ registerButtonGroup $ singleButton (codenamePos <+> 2<*>hu)- (if isNothing muirc || home then CmdRegister else CmdAuth) 2+ (if (isNothing muirc && isNothing ourName) || home then CmdRegister else CmdAuth) 2 (if isJust muirc then drawName else drawNullName) name codenamePos lift $ registerSelectable codenamePos 0 SelSelectedCodeName drawRelScore name (codenamePos<+>hu)@@ -197,8 +197,6 @@ drawAlerts alerts = return () - showHelp _ = return ()- getChRaw = do events <- liftIO getEvents case listToMaybe $ [ key | KeyDown key <- events ] of@@ -282,7 +280,7 @@ sequence_ [ modify $ \s -> s { paintTileIndex = pti } | (pti,pt) <- zip [0..] paintTiles- , (isNothing pt && mCmd == Just CmdWait) ||+ , (isNothing pt && mCmd == Just CmdDelete) || (isJust $ do pt' <- pt CmdTile t <- mCmd@@ -401,7 +399,7 @@ drawCmd mt True = CmdPaint mt drawCmd (Just t) False = CmdTile t- drawCmd Nothing _ = CmdWait+ drawCmd Nothing _ = CmdDelete getMousePos :: UIM ((HexVec,Bool),(Double,Double,Double)) getMousePos = do@@ -432,8 +430,54 @@ uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings return $ describeCommand cmd ++ " [" ++ concat (intersperse ","- (map showKey $ findBindings (uibdgs ++ bindings mode) cmd))+ (map showKeyFriendly $ findBindings (uibdgs ++ bindings mode) cmd)) ++ "]"++ showHelp mode = do+ bdgs <- nub <$> getBindings mode+ smallFont <- gets dispFontSmall+ renderToMain $ do + erase+ let bdgWidth = (screenWidthHexes-6) `div` 3+ showKeys chs = intercalate "/" (map showKeyFriendly chs)+ maxkeyslen = maximum $ map (length.showKeys.map fst) $ groupBy ((==) `on` snd) bdgs+ mouseHelpStrs = ["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;", "Scroll wheel to rotate hook;",+ "Scroll wheel while held down to undo/redo."]+ IMEdit -> ["Left-click to draw selected; scroll to change selection;",+ "Right-click on piece to select, drag to move;",+ "While holding right-click: left-click to advance time, middle-click to delete;",+ "Scroll wheel to rotate selected piece; scroll wheel while held down to undo/redo."]+ IMReplay -> ["Scroll wheel while held down to undo/redo."]+ IMMeta -> ["Left-clicking on something does most obvious thing;",+ "Right-clicking does second-most obvious thing."]++ renderStrColAt messageCol "Keybindings:" $ (screenHeightHexes`div`4)<*>(hv<+>neg hw)+ sequence_ [ with $ renderStrColAtLeft messageCol+ ( keysStr ++ ": " ++ desc )+ $ (x*bdgWidth-(screenWidthHexes-6)`div`2)<*>hu <+> neg hv <+>+ (screenHeightHexes`div`4 - y`div`2)<*>(hv<+>neg hw) <+>+ (y`mod`2)<*>hw+ | ((keysStr,with,desc),(x,y)) <- zip [(keysStr,with,desc)+ | group <- groupBy ((==) `on` snd) $ sortBy (compare `on` snd) bdgs+ , let cmd = snd $ head group+ , let desc = describeCommand cmd+ , not $ null desc+ , let chs = map fst group+ , let keysStr = showKeys chs+ , let with = if True -- 3*(bdgWidth-1) < length desc + length keysStr + 1+ then withFont smallFont+ else id+ ]+ (map (`divMod` (screenHeightHexes-9)) [0..])+ , (x+1)*bdgWidth < screenWidthHexes]+ sequence_ [ renderStrColAt messageCol str+ $ (3-screenHeightHexes`div`4-y`div`2)<*>(hv<+>neg hw)+ <+> hv+ <+> (y`mod`2)<*>hw+ | (str,y) <- zip mouseHelpStrs [0..] ]+ refresh getEvents = do e <- waitEvent
intricacy.cabal view
@@ -1,5 +1,5 @@ name: intricacy-version: 0.3+version: 0.3.1 synopsis: A game of competitive puzzle-design homepage: http://mbays.freeshell.org/intricacy license: GPL-3