diff --git a/CursesUI.hs b/CursesUI.hs --- a/CursesUI.hs +++ b/CursesUI.hs @@ -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 diff --git a/CursesUIMInstance.hs b/CursesUIMInstance.hs --- a/CursesUIMInstance.hs +++ b/CursesUIMInstance.hs @@ -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 >>= diff --git a/MainState.hs b/MainState.hs --- a/MainState.hs +++ b/MainState.hs @@ -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 diff --git a/Metagame.hs b/Metagame.hs --- a/Metagame.hs +++ b/Metagame.hs @@ -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) diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -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. diff --git a/SDLGlyph.hs b/SDLGlyph.hs --- a/SDLGlyph.hs +++ b/SDLGlyph.hs @@ -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) diff --git a/SDLRender.hs b/SDLRender.hs --- a/SDLRender.hs +++ b/SDLRender.hs @@ -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 diff --git a/SDLUI.hs b/SDLUI.hs --- a/SDLUI.hs +++ b/SDLUI.hs @@ -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 () diff --git a/SDLUIMInstance.hs b/SDLUIMInstance.hs --- a/SDLUIMInstance.hs +++ b/SDLUIMInstance.hs @@ -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 diff --git a/Version.hs b/Version.hs --- a/Version.hs +++ b/Version.hs @@ -11,4 +11,4 @@ module Version where version :: String -version = "0.8.1.1" +version = "0.8.2" diff --git a/intricacy.cabal b/intricacy.cabal --- a/intricacy.cabal +++ b/intricacy.cabal @@ -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,