intricacy 0.8.1.1 → 0.8.2
raw patch · 11 files changed
+96/−54 lines, 11 filesdep ~bytestringdep ~memorydep ~text
Dependency ranges changed: bytestring, memory, text, vector
Files
- CursesUI.hs +2/−2
- CursesUIMInstance.hs +5/−5
- MainState.hs +4/−2
- Metagame.hs +5/−1
- NEWS +3/−1
- SDLGlyph.hs +20/−6
- SDLRender.hs +6/−0
- SDLUI.hs +8/−7
- SDLUIMInstance.hs +37/−24
- Version.hs +1/−1
- intricacy.cabal +5/−5
CursesUI.hs view
@@ -26,9 +26,9 @@ import qualified UI.HSCurses.Curses as Curses import BoardColouring-import CVec import Command import CursesRender+import CVec import Frame import GameState (stateBoard) import GameStateTypes@@ -109,7 +109,7 @@ bindingsDrawColour col bdgs cmds = mconcat . (stringDraw a0 col "[" :) . (++ [stringDraw a0 col "]"]) . intersperse (stringDraw a0 col ",") $- catMaybes $ (keyDraw <$>) . findBinding bdgs <$> cmds+ mapMaybe ((keyDraw <$>) . findBinding bdgs) cmds where keyDraw = stringDraw bold col . showKeyFriendlyShort
CursesUIMInstance.hs view
@@ -31,11 +31,11 @@ import qualified UI.HSCurses.Curses as Curses import qualified UI.HSCurses.CursesHelper as CursesH -import CVec import Cache import Command import CursesRender import CursesUI+import CVec import Database import Frame import GameStateTypes@@ -109,7 +109,7 @@ sqlen (CVec y x) = (y*(width+1))^2+x^2 na = length locs nd = length draws- drawChar c = \cvec -> lift . drawStr bold white cvec $ ' ':c:" "+ drawChar c cvec = lift . drawStr bold white cvec $ ' ':c:" " draws' = if offset > 0 && length draws > na then drop (max 0 $ na-1 + (na-2)*(offset-1)) draws ++ [drawChar '<']@@ -208,8 +208,8 @@ , let desc = describeCommand cmd , let chs = fst <$> group , let keysStr = showKeys chs- , let pad = max 0 $ minimum [maxkeyslen + 1 - length keysStr,- bdgWidth - length desc - length keysStr - 1 - 1]+ , let pad = max 0 $ min (maxkeyslen + 1 - length keysStr) $+ bdgWidth - length desc - length keysStr - 1 - 1 ] $ (`divMod` (h-3)) <$> [0..] , (x+1)*bdgWidth < w] sequence_ draws@@ -375,7 +375,7 @@ doDrawAt (CVec 0 0) $ alignDraw GravRight w helpDraw doDrawAt (CVec 1 0) $ alignDraw GravLeft leftBdgsWidth lockBdgsDraw <> lockTextDraw <> lockBdgsDraw' - doDrawAt (CVec 2 $ maximum [w`div`3+1, w`div`2 - 13]) $ bindingsDraw bdgs [CmdSelCodename Nothing]+ doDrawAt (CVec 2 $ max (w`div`3+1) (w`div`2 - 13)) $ bindingsDraw bdgs [CmdSelCodename Nothing] maybe (return ()) (drawName True (CVec 2 (w`div`2))) selName void.runMaybeT $ MaybeT (return selName) >>= lift . getUInfoFetched 300 >>=
MainState.hs view
@@ -223,7 +223,7 @@ where stateAfterMoves pms = let (stack,st') = applyMoves st pms in (newPlayState (frame, st') redoPms title tutLevel sub saved) { psGameStateMoveStack = stack }- applyMoves st pms = foldl tick ([],st) pms+ applyMoves st = foldl tick ([],st) tick :: ([(GameState,PlayerMove)],GameState) -> PlayerMove -> ([(GameState,PlayerMove)],GameState) tick (stack,st) pm = ((st,pm):stack,fst . runWriter $ physicsTick pm st) @@ -333,7 +333,7 @@ getUInfoFetched :: UIMonad uiM => Integer -> Codename -> MainStateT uiM FetchedRecord getUInfoFetched staleTime name = do uinfott <- gets (Map.lookup name . userInfoTVs)- ($uinfott) $ maybe set $ \(tvar,time) -> do+ ($ uinfott) $ maybe set $ \(tvar,time) -> do now <- liftIO getCurrentTime if floor (diffUTCTime now time) > staleTime then set@@ -510,6 +510,8 @@ guard $ ourName /= name uinfo <- mgetUInfo name ourUInfo <- mgetUInfo ourName+ -- Note that this is inverted when communicated in the interface: we show+ -- the number accessed rather than the number unaccessed. let (pos,neg) = (countUnaccessedBy ourUInfo name, countUnaccessedBy uinfo ourName) return (pos-neg,(pos,neg)) where
Metagame.hs view
@@ -8,6 +8,8 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/. +{-# LANGUAGE TupleSections #-}+ module Metagame where import Control.Applicative@@ -32,7 +34,9 @@ data UserInfo = UserInfo {codename::Codename, userLocks::Array LockIndex (Maybe LockInfo), notesRead::[NoteInfo]} deriving (Eq, Ord, Show, Read) -initUserInfo name = UserInfo name (array (0,maxLocks-1) $ zip [0..maxLocks-1] (repeat Nothing)) []+_emptylocks = array (0,maxLocks-1) $ map (,Nothing) [0..maxLocks-1]++initUserInfo name = UserInfo name _emptylocks [] data LockInfo = LockInfo {lockSpec::LockSpec, public::Bool, notesSecured::[NoteInfo], lockSolutions::[NoteInfo], accessedBy::[Codename]} deriving (Eq, Ord, Show, Read)
NEWS view
@@ -1,5 +1,8 @@ This is an abbreviated summary; see the git log for gory details. +0.8.2:+ Show esteem with symbols as well as colour (thanks Locria Cyber)+ Fix relative esteem calculation display 0.8.1: Revise tutorial and initiation levels REP and GAP Disallow overextended/compressed springs@@ -9,7 +12,6 @@ Add --datadir option Fix loading partial initiation solutions Fix server locking- 0.8: Add single-player introductory subgame ("initiation"). Improve UI variously.
SDLGlyph.hs view
@@ -49,6 +49,7 @@ | HollowGlyph Pixel | HollowInnerGlyph Pixel | FilledHexGlyph Pixel+ | ScoreGlyph (Maybe Int) | ButtonGlyph Pixel | PathGlyph HexDir Pixel | GateGlyph HexDir Pixel@@ -266,15 +267,28 @@ col = dim purple renderGlyph (HollowGlyph col) =- aaPolygonR corners $ opaquify col- where corners = map corner [0..5]+ aaPolygonR outerCorners $ opaquify col renderGlyph (HollowInnerGlyph col) =- aaPolygonR corners $ opaquify col- where corners = map innerCorner hexDirs+ aaPolygonR innerCorners $ opaquify col renderGlyph (FilledHexGlyph col) =- rimmedPolygonR corners col $ brightish col- where corners = map corner [0..5]+ rimmedPolygonR outerCorners col $ brightish col++renderGlyph (ScoreGlyph relScore) =+ sequence_ $ [ aaLineR from to $ bright white | (from,to) <- case relScore of+ Just 1 -> plus 0+ Just 2 -> plus (-1) <> plus 1+ Just 3 -> plus (-2) <> plus 0 <> plus 2+ Just (-1) -> [horiz 0]+ Just (-2) -> [horiz $ -1, horiz 1]+ Just (-3) -> [horiz $ -2, horiz 0, horiz 2]+ _ -> []+ ]+ where+ vert n = let x = n/5 in (FVec x $ -(4/3)*ylen, FVec x $ -ylen)+ horiz n = let y = -(7/6)*ylen in (FVec (n/5 - 1/9) y, FVec (n/5 + 1/9) y)+ plus n = [vert n, horiz n]+ renderGlyph (ButtonGlyph col) = renderGlyph (TileGlyph (BlockTile []) col)
SDLRender.hs view
@@ -230,6 +230,9 @@ | n < 0 = f (6-n) | otherwise = f (n`mod`6) +outerCorners :: [FVec]+outerCorners = map corner [0..5]+ innerCorner :: HexDir -> FVec innerCorner dir = FVec x y where@@ -241,6 +244,9 @@ | dir == zero = [0,0] | not (isHexDir dir) = error "innerCorner: not a hexdir" | otherwise = map (\z -> -z) $ f $ neg dir++innerCorners :: [FVec]+innerCorners = map innerCorner hexDirs edge :: HexDir -> FVec edge dir = FVec x y
SDLUI.hs view
@@ -535,8 +535,8 @@ -- , 3*ysize size*screenHeightHexes < height] -- where ysize size = round $ fi size / sqrt 3 -- Minimum allowed size is 2 (get segfaults on SDL_FreeSurface with 1).- let size = max 2 $ minimum [ (w-1)`div`(2*screenWidthHexes)- , floor $ sqrt 3 * (0.5 + fi ((h-1)`div`(3*screenHeightHexes)))]+ let size = max 2 $ min ((w-1)`div`(2*screenWidthHexes))+ (floor $ sqrt 3 * (0.5 + fi ((h-1)`div`(3*screenHeightHexes)))) return (scrCentre, size) data DrawArgs = DrawArgs [PieceIdx] Bool [Alert] GameState UIOptions@@ -788,18 +788,18 @@ #ifdef APPLE -- use smaller dimensions than the screen's, to work around a bug -- seen on mac, whereby a resizable window created with- -- (w,h)=(0,0), or even with the (w,h) given by getDimensions+ -- (w,h)=(0,0), or even with the (w,h) given by getHardwareDimensions -- after creating such a window, is reported to be larger than it -- is. do- (w',h') <- getDimensions+ (w',h') <- getHardwareDimensions return (4*w'`div`5,4*h'`div`5) #else- getDimensions+ getHardwareDimensions #endif setVideoMode w' h' 0 $ if fs then [Fullscreen] else [Resizable] - (w',h') <- liftIO getDimensions+ (w',h') <- liftIO getSurfaceDimensions modify $ \ds -> ds { scrWidth = w' } modify $ \ds -> ds { scrHeight = h' }@@ -830,7 +830,8 @@ appendFile "intricacy-warnings.log" text where- getDimensions = (videoInfoWidth &&& videoInfoHeight) <$> getVideoInfo+ getHardwareDimensions = (videoInfoWidth &&& videoInfoHeight) <$> getVideoInfo+ getSurfaceDimensions = (surfaceGetWidth &&& surfaceGetHeight) <$> getVideoSurface initAudio :: UIM ()
SDLUIMInstance.hs view
@@ -97,7 +97,7 @@ Map.insertWith (\ [bdg] bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs) mode [(ch,cmd)] $ uiKeyBindings s } - getUIBinding mode cmd = ($cmd) <$> getBindingStr mode+ getUIBinding mode cmd = ($ cmd) <$> getBindingStr mode initUI = (isJust <$>) . runMaybeT $ do let toInit = [InitVideo]@@ -184,12 +184,14 @@ return $ cmds ++ [CmdRefresh | uiChanged || animFrameReady] where nubMouseMotions evs =- -- drop all but last mouse motion event- let nubMouseMotions' False (mm@MouseMotion {}:evs) = mm:nubMouseMotions' True evs- nubMouseMotions' True (mm@MouseMotion {}:evs) = nubMouseMotions' True evs+ -- drop all but last mouse motion and resize events+ let nubMouseMotions' (False,r) (mm@MouseMotion {}:evs) = mm:nubMouseMotions' (True,r) evs+ nubMouseMotions' (m,False) (vr@(VideoResize _ _):evs) = vr:nubMouseMotions' (m,True) evs+ nubMouseMotions' b (MouseMotion {}:evs) = nubMouseMotions' b evs+ nubMouseMotions' b (VideoResize _ _:evs) = nubMouseMotions' b evs nubMouseMotions' b (ev:evs) = ev:nubMouseMotions' b evs nubMouseMotions' _ [] = []- in reverse $ nubMouseMotions' False $ reverse evs+ in reverse $ nubMouseMotions' (False,False) $ reverse evs setPaintFromCmds cmds = sequence_ [ modify $ \s -> s { paintTileIndex = pti } | (pti,pt) <- zip [0..] paintTiles@@ -587,9 +589,9 @@ [ \pos -> lift (registerSelectable pos 0 (SelUndeclared undecl)) >> drawActiveLock al pos | undecl@(Undeclared _ _ al) <- undecls ] lift $ do- maybe (drawEmptyMiniLock miniLockPos)- (`drawMiniLock` miniLockPos)- (fst<$>mlock)+ maybe+ (drawEmptyMiniLock miniLockPos)+ ((`drawMiniLock` miniLockPos) <$> fst) mlock registerSelectable miniLockPos 1 SelOurLock registerButton (miniLockPos+^3*^neg hw+^2*^hu) CmdEdit 2 [("edit",hu+^neg hw),("lock",hu+^neg hv)]@@ -629,31 +631,36 @@ lift $ sequence_ [ registerSelectable (scoresPos+^v) 0 SelRelScore | v <- [hv, hv+^hu] ] drawRelScore sel scoresPos fillArea (posLeft+^hw) (map (posLeft+^) [zero,hw,neg hv])- [ \pos -> lift (registerSelectable pos 0 (SelScoreLock (Just sel) accessed $ ActiveLock us i)) >>+ [ \pos -> do+ lift $ registerSelectable pos 0 (SelScoreLock (Just sel) accessed $ ActiveLock us i) drawNameWithCharAndCol us white (lockIndexChar i) col pos+ lift $ drawRelScoreGlyph pos relScore | i <- [0..2] , let accessed = head accesses !! i- , let col- | accessed == Just AccessedPub = dim pubColour- | isJust accessed = dim $ scoreColour $ -3- | otherwise = obscure $ scoreColour 3 ]+ , let (col, relScore)+ | accessed == Just AccessedPub = (dim pubColour, Just $ -1)+ | isJust accessed = (dim $ scoreColour $ -3, Just $ -1)+ | otherwise = (obscure $ scoreColour 3, Nothing) ] fillArea (posRight+^hw) (map (posRight+^) [zero,hw,neg hv])- [ \pos -> lift (registerSelectable pos 0 (SelScoreLock Nothing accessed $ ActiveLock sel i)) >>+ [ \pos -> do+ lift $ registerSelectable pos 0 (SelScoreLock Nothing accessed $ ActiveLock sel i) drawNameWithCharAndCol sel white (lockIndexChar i) col pos+ lift $ drawRelScoreGlyph pos relScore | i <- [0..2] , let accessed = accesses !! 1 !! i- , let col- | accessed == Just AccessedPub = obscure pubColour- | isJust accessed = dim $ scoreColour 3- | otherwise = obscure $ scoreColour $ -3 ]+ , let (col, relScore)+ | accessed == Just AccessedPub = (dim pubColour, Just 1)+ | isJust accessed = (dim $ scoreColour 3, Just 1)+ | otherwise = (obscure $ scoreColour $ -3, Nothing) ] (posScore,negScore) <- MaybeT $ (snd<$>) <$> getRelScoreDetails sel+ let (shownPosScore, shownNegScore) = (3 - negScore, 3 - posScore) lift.lift $ sequence_ [ do renderToMain $ renderStrColAt (scoreColour score) (sign:show (abs score)) pos registerSelectable pos 0 SelRelScoreComponent | (sign,score,pos) <-- [ ('-',-negScore,posLeft+^neg hv+^hw)- , ('+',posScore,posRight+^neg hv+^hw) ] ]+ [ ('-',-shownNegScore,posLeft+^neg hv+^hw)+ , ('+',shownPosScore,posRight+^neg hv+^hw) ] ] drawShortMouseHelp mode s = do@@ -680,6 +687,7 @@ [ "LMB: paint; Ctrl+LMB: delete" , "Wheel: set paint type" , "RMB: select piece; drag to move"+ , "RMB+Wheel: tighten/loosen spring, rotate piece" , "RMB+LMB: wait; RMB+MMB: delete piece" , "MMB+Wheel: undo/redo" ]@@ -742,7 +750,7 @@ fillArea centre area draws = do offset <- gets listOffset let na = length area- listButton cmd = \pos -> lift $ registerButton pos cmd 3 []+ listButton cmd pos = lift $ registerButton pos cmd 3 [] draws' = if offset > 0 && length draws > na then listButton CmdPrevPage : drop (max 0 $ na-1 + (na-2)*(offset-1)) draws@@ -766,13 +774,18 @@ drawName,drawNullName :: Codename -> HexVec -> MainStateT UIM ()-drawName name pos = nameCol name >>= lift . drawNameCol name pos+drawName name pos = do+ lift . drawNameCol name pos =<< nameCol name+ lift . drawRelScoreGlyph pos =<< getRelScore name drawNullName name pos = lift . drawNameCol name pos $ invisible white drawNameCol name pos col = renderToMain $ do drawAtRel (playerGlyph col) pos renderStrColAt buttonTextCol name pos +drawRelScoreGlyph pos Nothing = return ()+drawRelScoreGlyph pos relScore = renderToMain . (`drawAtRel` pos) $ ScoreGlyph relScore+ drawRelScore name pos = do col <- nameCol name relScore <- getRelScore name@@ -790,11 +803,11 @@ drawNameWithChar name (if accessed then accColour else white) (lockIndexChar i) pos-drawPublicNote name =- drawNameWithChar name pubColour 'P'+drawPublicNote name = drawNameWithChar name pubColour 'P' drawNameWithChar name charcol char pos = do col <- nameCol name drawNameWithCharAndCol name charcol char col pos+ lift . drawRelScoreGlyph pos =<< getRelScore name drawNameWithCharAndCol :: String -> Pixel -> Char -> Pixel -> HexVec -> MainStateT UIM () drawNameWithCharAndCol name charcol char col pos = do size <- fi.snd <$> lift getGeom
Version.hs view
@@ -11,4 +11,4 @@ module Version where version :: String-version = "0.8.1.1"+version = "0.8.2"
intricacy.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: intricacy-version: 0.8.1.1+version: 0.8.2 license: GPL-3 license-file: COPYING maintainer: mbays@sdf.org@@ -110,14 +110,14 @@ exceptions >=0.8.3 && <0.11, filepath >=1.0 && <1.5, time >=1.2 && <1.14,- bytestring >=0.10 && <0.12,+ bytestring >=0.10 && <0.13, array >=0.3 && <0.6, containers >=0.4 && <0.7,- vector >=0.9 && <0.13,+ vector >=0.9 && <0.14, binary >=0.5 && <0.11, network-simple >=0.3 && <0.5, safe >=0.3.18 && <0.4,- memory >=0.11 && <0.18,+ memory >=0.11 && <0.19, cryptonite >=0.16 && <0.31 if !impl(ghc >=8.0)@@ -223,7 +223,7 @@ feed >=1.1 && <1.4, xml-conduit >=1.0 && <1.10, email-validate >=1.0 && <2.4,- text >=0.1 && <1.3,+ text >=0.1 && <3, text-short ==0.1.*, mime-mail >=0.4.4 && <0.6, smtp-mail >=0.1.4.1 && <0.4,