intricacy 0.3.1 → 0.3.3

raw patch · 13 files changed

+84/−44 lines, 13 files

Files

• Cache.hs +5/−1
• CursesUIMInstance.hs +2/−1
• Frame.hs +10/−7
• Interact.hs +6/−5
• InteractUtil.hs +7/−1
• KeyBindings.hs +3/−1
• MainState.hs +6/−0
• NEWS +4/−0
• README +1/−1
• SDLUI.hs +10/−11
• SDLUIMInstance.hs +28/−14
• ServerAddr.hs +1/−1
• intricacy.cabal +1/−1

@@ -36,6 +36,8 @@   getRecordCached :: ServerAddr -> Maybe Auth -> Maybe (TVar Bool) -> Bool -> Record -> IO (TVar FetchedRecord)+getRecordCached saddr _ _ _ _ | nullSaddr saddr = do+    atomically $ newTVar $ FetchedRecord True (Just "No server set.") Nothing getRecordCached saddr auth mflag cOnly rec = do     fromCache <- withCache saddr $ getRecord rec     let fresh = isJust fromCache && invariantRecord rec@@ -73,6 +75,8 @@ waitFetchedFresh tvar = atomically $ readTVar tvar >>= check.fresh  makeRequest :: ServerAddr -> ClientRequest -> IO ServerResponse+makeRequest saddr _ | nullSaddr saddr =+    return $ ServerError "No server set." makeRequest saddr@(ServerAddr host port) request =     handle (return . ServerError . (show::SomeException -> String)) $ 	withStream (IP host port) makeRequest'@@ -87,7 +91,7 @@ knownServers = flip catchIO (const $ return []) $ do     cachedir <- confFilePath "cache"     saddrstrs <- getDirectoryContents cachedir >>= filterM (\dir ->-	doesDirectoryExist $ cachedir++[pathSeparator]++dir++[pathSeparator]++"intricacydb"++[pathSeparator])+	doesFileExist $ cachedir++[pathSeparator]++dir++[pathSeparator]++"serverInfo")     return $ concat $ map (maybeToList . strToSaddr) saddrstrs  withCache :: ServerAddr -> DBM a -> IO a

@@ -300,7 +300,7 @@     getChRaw = (charify<$>) $ liftIO $ CursesH.getKey (return ())     setUIBinding mode cmd ch = 	modify $ \s -> s { uiKeyBindings =-		Map.insertWith (\[bdg] -> \bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdgs ++ [bdg])+		Map.insertWith (\[bdg] -> \bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs) 		    mode [(ch,cmd)] $ uiKeyBindings s }      initUI = @@ -325,6 +325,7 @@ 	Curses.refresh      warpPointer _ = return ()+    setYNButtons = return ()      getDrawImpatience = return $ \_ -> return () 

@@ -59,18 +59,19 @@     PlacedPiece (entrance f <+> hw <+> origin) $ Hook (neg hw) NullHF ]  clearToolArea :: Frame -> GameState -> GameState-clearToolArea f st = foldr delPieceIn st [entrance f <+> v <+> origin-	    | v <- [ neg hu, hw, zero ] ]+clearToolArea f st = foldr delPieceIn st $ toolsArea f -boltArea :: Frame -> [HexPos]++boltArea,toolsArea :: Frame -> [HexPos] boltArea f = map PHS 	[ bolthole f <+> bw<*>hu <+> i<*>hw <+> n<*>hv | i <- [1..bw-1], n <- [1..bw+i-1] ]     where bw = boltWidth f+toolsArea f = [entrance f <+> v <+> origin | v <- [ neg hu, hw, zero ] ]  inBounds :: Frame -> HexPos -> Bool inBounds f pos = hexLen (pos <-> origin) < frameSize f inEditable :: Frame -> HexPos -> Bool-inEditable f pos = inBounds f pos || pos `elem` boltArea f ++ [PHS $ bolthole f]+inEditable f pos = inBounds f pos || pos `elem` boltArea f ++ [PHS $ bolthole f] ++ toolsArea f checkBounds :: Frame -> HexPos -> HexPos -> HexPos checkBounds f def pos = if inBounds f pos then pos else def checkEditable :: Frame -> HexPos -> HexPos -> HexPos@@ -79,6 +80,8 @@ truncateToBounds f pos@(PHS v) = PHS $ truncateToLength (frameSize f - 1) v truncateToEditable f pos@(PHS v) = if inBounds f pos     then pos-    else let pos' = PHS $ truncateToLength (frameSize f + boltWidth f - 1) v-	in if inEditable f pos'-	    then pos' else truncateToBounds f pos'+    else head+	$ [ pos'+	    | n <- reverse [0..boltWidth f]+	    , let pos' = PHS $ truncateToLength (frameSize f - 1 + n) v+	    , inEditable f pos' ]

@@ -375,10 +375,11 @@     when (null tuts) $ do 	lift.lift $ drawError "No tutorial levels found" 	mzero-    s <- MaybeT $ lift $ textInput ("Play which tutorial level [1-"++show (length tuts)++"]")-	    (length (show (length tuts))) False True Nothing Nothing-    i <- MaybeT $ return $ fst <$> (listToMaybe $ (reads :: ReadS Int) s)-    guard $ 1 <= i && i <= length tuts+    -- s <- MaybeT $ lift $ textInput ("Play which tutorial level? [1-"++show (length tuts)++"]")+	    -- (length (show (length tuts))) False True Nothing Nothing+    -- i <- MaybeT $ return $ fst <$> (listToMaybe $ (reads :: ReadS Int) s)+    -- guard $ 1 <= i && i <= length tuts+    let i = 1     let dotut i = do 	let name = tuts !! (i-1) 	let pref = tutdir ++ [pathSeparator] ++ name@@ -442,7 +443,7 @@ 		tile' <- MaybeT $ return $ snd <$> Map.lookup pos' board' 		guard $ tileType tile' == if wsel then WrenchTile zero else HookTile 		lift.lift $ warpPointer $ pos'-	    | pos' <- [dir<+>pos, pos] ]+	    | pos' <- map (<+>pos) $ hexDisc 2 ]  processCommand' IMPlay cmd = do     wsel <- gets wrenchSelected

@@ -112,7 +112,10 @@     guard $ isJust $ userLocks ourUInfo ! idx     lift $ do 	curServerActionAsync $ DeclareSolution soln ls al idx-	mapM_ invalidateUInfo [lockOwner al, ourName]+	-- rather than recurse through the tree to find what scores may have+	-- changed as a result of this declaration, or leave it to timeouts+	-- and explicit refreshes to reveal it, we just invalidate all UInfos.+	invalidateAllUInfo 	refreshUInfoUI  jumpMark :: UIMonad uiM => Char -> StateT MainState uiM ()@@ -155,6 +158,7 @@ confirm :: UIMonad uiM => String -> uiM Bool confirm prompt = do     drawMessage $ prompt ++ " [y/N]"+    setYNButtons     waitConfirm <* drawMessage ""     where 	waitConfirm = do@@ -166,6 +170,7 @@ 	ansOfCmd (CmdInputChar 'Y') = Just True 	ansOfCmd CmdRedraw = Nothing 	ansOfCmd CmdRefresh = Nothing+	ansOfCmd CmdUnselect = Nothing 	ansOfCmd _ = Just False  -- | TODO: draw cursor@@ -221,5 +226,6 @@ 		    Right $ (name, Nothing) 		applyCmd x CmdRedraw = Right x 		applyCmd x CmdRefresh = Right x+		applyCmd x CmdUnselect = Right x 		applyCmd _ _ = Left False 	completes s s' = take (length s) s' == s

@@ -192,7 +192,9 @@ bindings _ = []  findBindings :: KeyBindings -> Command -> [Char]-findBindings bdgs cmd = nub [ ch | (ch,cmd') <- bdgs, cmd'==cmd ]+findBindings bdgs cmd = nub+    $ [ ch | (ch,cmd') <- bdgs, cmd'==cmd ]+    ++ [ ch | CmdInputChar ch <- [cmd] ]  findBinding :: KeyBindings -> Command -> Maybe Char findBinding = (listToMaybe.) . findBindings

@@ -59,6 +59,7 @@     setUIBinding :: InputMode -> Command -> Char -> m ()     getDrawImpatience :: m ( Int -> IO () )     warpPointer :: HexPos -> m ()+    setYNButtons :: m ()     suspend,redraw :: m ()      doUI :: m a -> IO (Maybe a)@@ -224,6 +225,10 @@ invalidateUInfo name =      modify $ \ms -> ms {userInfos = Map.delete name $ userInfos ms} +invalidateAllUInfo :: UIMonad uiM => StateT MainState uiM ()+invalidateAllUInfo =+    modify $ \ms -> ms {userInfos = Map.empty}+ mgetLock :: UIMonad uiM => LockSpec -> MaybeT (StateT MainState uiM) Lock mgetLock ls = do     tvar <- msum [ MaybeT $ (Map.lookup ls) <$> gets indexedLocks @@ -243,6 +248,7 @@     where 	getRandomNames = do 	    rnamestvar <- gets randomCodenames+	    liftIO $ atomically $ writeTVar rnamestvar [] 	    flag <- gets newAsync 	    saddr <- gets curServer 	    void $ liftIO $ forkIO $ do

@@ -1,3 +1,7 @@+0.3.3:+    Misc minor UI improvements.+0.3.2:+    Misc minor UI improvements. 0.3.1:     Misc minor UI improvements;     Help screens in SDL mode.

@@ -40,7 +40,7 @@     properly. Good luck with that. The mingw32-compiled libraries in winlibs     may or may not help. -To compile for OSX, or android or whatever else wacky system:+To compile for OSX, or android or whatever other wacky system:     No idea, sorry. But please tell me if you manage!  

@@ -121,7 +121,7 @@ 	    singleButton (tl<+>hv) CmdTest 4 	    , singleButton (tl<+>(neg hw)) CmdPlay 2 	    , markGroup-	    , ([quitButton, Button (br<+>2<*>hu) CmdWriteState],(0,2))+	    , singleButton (br<+>2<*>hu) CmdWriteState 2 	    , ( [ Button (bl<+>dir) (CmdDir WHSSelected dir) | dir <- hexDirs ] ++ 		[ Button (bl<+>((-2)<*>hv)) (CmdRotate (-1)) 		, Button (bl<+>((-2)<*>hw)) (CmdRotate 1) ], (4,0) )@@ -130,8 +130,7 @@ 		| i <- take (length paintTiles) [0..] ],(5,0)) 	    ] 	IMPlay -> -	    [ ([quitButton],(0,2))-	    , markGroup+	    [ markGroup 	    , ( [ Button bl CmdWait ], (0,0)) 	    , ( [ Button (bl<+>dir) (CmdDir whs dir) | dir <- hexDirs ], (4,0) ) 	    ] ++@@ -146,11 +145,9 @@ 		    ], (2,0) ) 	    ]) ++ 	    [ singleButton tr CmdOpen 1 ]-	IMReplay -> [ ([quitButton],(0,2))-	    , markGroup ]+	IMReplay -> [ markGroup ] 	IMMeta ->-	    [ ([quitButton],(0,2))-	    , singleButton serverPos CmdSetServer 2+	    [ singleButton serverPos CmdSetServer 2 	    , singleButton (serverPos<+>neg hu) CmdToggleCacheOnly 0 	    , singleButton lockLinePos CmdSelectLock 4 	    , singleButton (miniLockPos <+> 2<*>hv <+> neg hu <+> hw) CmdEdit 2@@ -160,9 +157,10 @@ 		 	_ -> [] 	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 ]+	    global = if mode == IMTextInput then [] else+		[ singleButton br CmdQuit 0+		, singleButton (tr <+> 3<*>hv <+> 3<*>hu) CmdHelp 3 ] 	    tr = periphery 0 	    tl = periphery 2 	    bl = periphery 3@@ -186,13 +184,14 @@     modify $ \ds -> ds {metaSelectables = foldr 	(`Map.insert` s) (metaSelectables ds) $ map (v<+>) $ hexDisc r} registerButtonGroup g = modify $ \ds -> ds {contextButtons = g:contextButtons ds}+registerButton pos cmd col = registerButtonGroup $ singleButton pos cmd col clearSelectables,clearButtons :: UIM () clearSelectables = modify $ \ds -> ds {metaSelectables = Map.empty} clearButtons = modify $ \ds -> ds {contextButtons = []}  registerUndoButtons noUndo noRedo = do-    unless noUndo $ registerButtonGroup $ singleButton (periphery 2) CmdUndo 0-    unless noRedo $ registerButtonGroup $ singleButton (periphery 2<+>neg hu) CmdRedo 2+    unless noUndo $ registerButton (periphery 2) CmdUndo 0+    unless noRedo $ registerButton (periphery 2<+>neg hu) CmdRedo 2  commandOfSelectable IMMeta SelOurLock _ = CmdEdit commandOfSelectable IMMeta (SelLock (ActiveLock _ i)) False = CmdSolve (Just i)

@@ -18,6 +18,7 @@ import Control.Applicative hiding ((<*>)) import qualified Data.Map as Map import Data.Map (Map)+import qualified Data.Vector as Vector import Data.Maybe import Control.Concurrent (threadDelay) import Control.Monad.State@@ -87,6 +88,12 @@ 		[ singleButton (periphery 2 <+> 3<*>hw<+>hu) CmdDelete 0 		, singleButton (periphery 2 <+> 3<*>hw) CmdMerge 4 		]+	    sequence_+		[ when (null . filter (pred . placedPiece) . Vector.toList $ placedPieces st)+		    $ registerButton (periphery 0 <+> d) cmd 2+		| (pred,cmd,d) <- [+		    (isWrench, CmdTile $ WrenchTile zero, 3<*>hu),+		    (isHook, CmdTile $ HookTile, 3<*>hu <+> hv)] ] 	    drawPaintButtons 	drawMainState' (MetaState saddr undecls cOnly auth names _ _ rnamestvar _ _ mretired path mlock offset) = do 	    let ourName = authUser <$> auth@@ -97,8 +104,8 @@ 		(\lock -> do 		    drawMiniLock lock miniLockPos 		    registerSelectable miniLockPos 3 SelOurLock-		    registerButtonGroup $ singleButton (miniLockPos <+> 2<*>neg hv <+> hu) CmdPrevLock 4-		    registerButtonGroup $ singleButton (miniLockPos <+> 2<*>neg hv <+> hu <+> neg hw) CmdNextLock 4+		    registerButton (miniLockPos <+> 2<*>neg hv <+> hu) CmdPrevLock 4+		    registerButton (miniLockPos <+> 2<*>neg hv <+> hu <+> neg hw) CmdNextLock 4 		    ) 		(fst<$>mlock) 	    lift $ do@@ -108,9 +115,9 @@ 		    $ serverPos <+> hu 		renderToMain $ renderStrColAtLeft messageCol path $ lockLinePos <+> hu 		when (offset>0) $-		    registerButtonGroup $ singleButton (nextPagePos<+>neg hu) CmdPrevPage 4+		    registerButton (nextPagePos<+>neg hu) CmdPrevPage 4 -	    when (length names > 1) $ lift $ registerButtonGroup $ singleButton+	    when (length names > 1) $ lift $ registerButton 		(codenamePos <+> 2<*>neg hu <+> hw) CmdBackCodename 0  	    runMaybeT $ do@@ -123,7 +130,7 @@ 			    renderToMain $ withFont smallFont $ renderStrColAtLeft (opaquify $ dim errorCol) "(stale)" $ serverWaitPos 			maybe (return ()) (setMsgLineNoRefresh errorCol) err 			when (fresh && (isNothing ourName || home || isNothing muirc)) $-			    registerButtonGroup $ singleButton (codenamePos <+> 2<*>hu)+			    registerButton (codenamePos <+> 2<*>hu) 				(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@@ -134,8 +141,8 @@ 				    (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 $ registerButtonGroup $ singleButton retiredPos CmdShowRetired pubWheelAngle-				lift $ registerButtonGroup $ singleButton (retiredPos <+> hw) (CmdPlayLockSpec Nothing) 4+				lift $ registerButton retiredPos CmdShowRetired pubWheelAngle+				lift $ registerButton (retiredPos <+> hw) (CmdPlayLockSpec Nothing) 4 			    Nothing -> do 				sequence_ [ drawLockInfo (ActiveLock (codename uinfo) i) mlockinfo | 				    (i,mlockinfo) <- assocs $ userLocks uinfo ]@@ -144,14 +151,14 @@ 				    registerButtonGroup 					([ Button mmiscpos (CmdSolve Nothing), Button (mmiscpos<+>hu) (CmdViewSolution Nothing)], (2,2)) 				let tested = maybe False (isJust.snd) mlock-				when (isJust mlock && home) $ lift $ registerButtonGroup $-					singleButton (miniLockPos <+> 2<*>hv <+> neg hu) (CmdPlaceLock Nothing) $ if tested then 2 else 0-				lift $ registerButtonGroup $ singleButton retiredPos CmdShowRetired pubWheelAngle+				when (isJust mlock && home) $ lift $ registerButton+				    (miniLockPos <+> 2<*>hv <+> neg hu) (CmdPlaceLock Nothing) $ if tested then 2 else 0+				lift $ registerButton retiredPos CmdShowRetired pubWheelAngle  	    when home $ do 		unless (null undecls) $ do 		    lift.renderToMain $ renderStrColAtLeft messageCol "Undeclared:" (undeclsPos<+>2<*>hv)-		    lift $ registerButtonGroup $ singleButton (undeclsPos<+>2<*>hv<+>neg hu) (CmdDeclare Nothing) 2+		    lift $ registerButton (undeclsPos<+>2<*>hv<+>neg hu) (CmdDeclare Nothing) 2 		    fillArea (undeclsPos<+>hv) 			(map (undeclsPos<+>) $ hexDisc 1 ++ [hu<+>neg hw, neg hu<+>hv]) 			[ \pos -> (lift $ registerSelectable pos 0 (SelUndeclared undecl)) >> drawActiveLock al pos@@ -165,7 +172,7 @@  	    when (ourName /= selName) $ void $ runMaybeT $ do 		when (isJust ourName) $-		    lift.lift $ registerButtonGroup $ singleButton (codenamePos <+> neg hu <+> hw) CmdHome 4+		    lift.lift $ registerButton (codenamePos <+> neg hu <+> hw) CmdHome 4 		sel <- MaybeT $ return selName 		us <- MaybeT $ return ourName 		ourUInfo <- mgetUInfo us@@ -205,7 +212,7 @@      setUIBinding mode cmd ch = 	modify $ \s -> s { uiKeyBindings =-		Map.insertWith (\[bdg] -> \bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdgs ++ [bdg])+		Map.insertWith (\[bdg] -> \bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs) 		    mode [(ch,cmd)] $ uiKeyBindings s }      initUI = liftM isJust (runMaybeT $ do@@ -255,6 +262,13 @@ 	let [lbp',rbp'] = fmap (fmap (\_ -> (pos<->centre))) [lbp,rbp] 	modify $ \s -> s {leftButtonDown = lbp', rightButtonDown = rbp'} +    setYNButtons = do+	clearButtons+	registerButton (periphery 5 <+> hw) (CmdInputChar 'Y') 2+	registerButton (periphery 5 <+> neg hv) (CmdInputChar 'N') 0+	drawButtons IMTextInput+	refresh+     getInput mode = do 	events <- liftIO $ getEvents 	oldUIState <- get@@ -500,7 +514,7 @@ 	    let na = length area 		nd = length draws 	    when (nd > (na*(offset+1))) $ lift $-		registerButtonGroup $ singleButton nextPagePos CmdNextPage 4+		registerButton nextPagePos CmdNextPage 4 	    return $ drop (max 0 $ min (nd - na) (na*offset)) $ draws     sequence_ $ map (uncurry ($)) $ 	zip selDraws $ sortBy

@@ -19,7 +19,7 @@ nullSaddr (ServerAddr host _) = null host  defaultPort=27001 -- == ('i'<<8) + 'y'-defaultServerAddr = ServerAddr "mbays.mdns.org" defaultPort+defaultServerAddr = ServerAddr "thegonz.net" defaultPort  saddrStr (ServerAddr h p) = h ++ if p==defaultPort then "" else ':':show p 

@@ -1,5 +1,5 @@ name:                intricacy-version:             0.3.1+version:             0.3.3 synopsis:            A game of competitive puzzle-design homepage:            http://mbays.freeshell.org/intricacy license:             GPL-3