diff --git a/.hlint.yaml b/.hlint.yaml index 0ca01dfbb..41dc14deb 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -44,16 +44,16 @@ # Turn on hints that are off by default # # Ban "module X(module X) where", to require a real export list -- warn: {name: Use explicit module export list} +#- warn: {name: Use explicit module export list} # TODO uncomment # # Replace a $ b $ c with a . b $ c -- group: {name: dollar, enabled: true} +#- group: {name: dollar, enabled: true} # TODO uncomment # # Generalise map to fmap, ++ to <> -- group: {name: generalise, enabled: true} +#- group: {name: generalise, enabled: true} # TODO uncomment # # Warn on use of partial functions -# - group: {name: partial, enabled: true} +# - group: {name: partial, enabled: true} # possibly uncomment - group: {name: use-lens, enabled: true} diff --git a/src/Color.hs b/src/Color.hs index 757ee588f..e91f3d012 100644 --- a/src/Color.hs +++ b/src/Color.hs @@ -1,11 +1,38 @@ module Color ( - module Color, + withAlpha, + red, + green, + blue, + yellow, + cyan, + magenta, + rose, + violet, + azure, + aquamarine, + chartreuse, + orange, + white, + black, + greyN, + mixColors, + brightX, + mixColorsLinear, + mixColorsFrac, + dim, + bright, + light, + dark, + paletteToColor, + lightx4, + toColor8, + normalizeColor, module Color.Data, ) where import Color.Data -import Geometry import Control.Lens +import Geometry withAlpha :: Float -> RGBA -> RGBA {-# INLINE withAlpha #-} @@ -81,7 +108,7 @@ normalizeColor (V4 r g b a) = V4 (f r) (f g) (f b) (f a) mixColorsFrac :: Color -> Color -> Float -> Color {-# INLINE mixColorsFrac #-} -mixColorsFrac c1 c2 x = mixColors x (1-x) c1 c2 +mixColorsFrac c1 c2 x = mixColors x (1 - x) c1 c2 mixColors :: Float -> Float -> Color -> Color -> Color {-# INLINE mixColors #-} @@ -107,7 +134,7 @@ light (V4 r g b a) = V4 (r + 0.2) (g + 0.2) (b + 0.2) a dark :: Color -> Color {-# INLINE dark #-} -dark (V4 r g b a) = V4 (r -0.2) (g -0.2) (b -0.2) a +dark (V4 r g b a) = V4 (r - 0.2) (g - 0.2) (b - 0.2) a dim :: Color -> Color {-# INLINE dim #-} @@ -125,23 +152,6 @@ greyN :: Float -> Color {-# INLINE greyN #-} greyN x = toV4 (x, x, x, 1) -numColor :: Int -> Color -{-# INLINE numColor #-} -numColor 0 = toV4 (1, 0, 0, 1) -numColor 1 = toV4 (0, 1, 0, 1) -numColor 2 = toV4 (0, 0, 1, 1) -numColor 3 = toV4 (1, 1, 0, 1) -numColor 4 = toV4 (0, 1, 1, 1) -numColor 5 = toV4 (1, 0, 1, 1) -numColor 6 = toV4 (1, 0, 0.5, 1) -numColor 7 = toV4 (0.5, 0, 1, 1) -numColor 8 = toV4 (0, 0.5, 1, 1) -numColor 9 = toV4 (0, 1, 0.5, 1) -numColor 10 = toV4 (0.5, 1, 0, 1) -numColor 11 = toV4 (1, 0.5, 0, 1) -numColor 12 = toV4 (1, 1, 1, 1) -numColor _ = toV4 (1, 1, 1, 1) - lightx4 :: Color -> Color lightx4 = light . light . light . light diff --git a/src/Dodge/Data/SelectionList.hs b/src/Dodge/Data/SelectionList.hs index 586e2c3d3..28714b27e 100644 --- a/src/Dodge/Data/SelectionList.hs +++ b/src/Dodge/Data/SelectionList.hs @@ -14,6 +14,7 @@ data ListDisplayParams = ListDisplayParams { _ldpPos :: ScreenPos , _ldpScale :: Float , _ldpVerticalGap :: Float + , _ldpBorder :: Maybe (Int,Int) -- the Ints give height and width for a border } data CursorDisplay diff --git a/src/Dodge/HeldUse.hs b/src/Dodge/HeldUse.hs index 5c2fb5af2..d8073525d 100644 --- a/src/Dodge/HeldUse.hs +++ b/src/Dodge/HeldUse.hs @@ -717,13 +717,8 @@ basicMuzFlare pos dir = isAmmoIntLink :: Int -> ItemSF -> Bool isAmmoIntLink i sf = Just i == sf ^? amsfLink -useLoadedAmmo :: - LocationDT OItem -> - Creature -> - Muzzle -> - Maybe (Int, DTree OItem) -> - World -> - World +useLoadedAmmo + :: LocationDT OItem -> Creature -> Muzzle -> Maybe (Int, DTree OItem) -> World -> World useLoadedAmmo loc cr mz m w = makeMuzzleFlare pq loc (mz ^. mzFlareType) $ case _mzEffect mz of MuzzleShootBullet -> shootBullets loc cr (mz, x, magtree) w @@ -905,7 +900,8 @@ shootPulseBall (p, q) w = i = IM.newKey $ w ^. cWorld . lWorld . pulseBalls removeAmmoFromMag :: Int -> Int -> World -> World -removeAmmoFromMag x magid = cWorld . lWorld . items . ix magid . itConsumables . _Just -~ x +removeAmmoFromMag x magid + = cWorld . lWorld . items . ix magid . itConsumables . _Just -~ x getBulletType :: DTree OItem -> Maybe Bullet getBulletType magtree = @@ -960,12 +956,8 @@ magAmmoParams itm = case itm ^. itType of -- Just x | x /= 0 -> fst . randomR (- x, x) $ _randGen w -- _ -> 0 -shootBullets :: - LocationDT OItem -> - Creature -> - (Muzzle, Int, DTree OItem) -> - World -> - World +shootBullets + :: LocationDT OItem -> Creature -> (Muzzle, Int, DTree OItem) -> World -> World shootBullets loc cr (mz, x, magtree) w = fromMaybe w $ do thebullet <- getBulletType magtree return $ foldl' (&) w (replicate x (shootBullet thebullet loc cr mz)) diff --git a/src/Dodge/ListDisplayParams.hs b/src/Dodge/ListDisplayParams.hs index 114135efc..b7a31a0a2 100644 --- a/src/Dodge/ListDisplayParams.hs +++ b/src/Dodge/ListDisplayParams.hs @@ -26,13 +26,11 @@ defaultListDisplayParams = { _spScreenOff = V2 (-0.5) 0.5 -- top left , _spPixelOff = 0 } + , _ldpBorder = Nothing } invDP :: ListDisplayParams -invDP = - defaultListDisplayParams --- & ldpPos . spPixelOff .~ V2 6 (-1) - & ldpPos . spPixelOff .~ V2 6 0 +invDP = defaultListDisplayParams & ldpPos . spPixelOff .~ V2 6 0 invCursorParams :: World -> CursorDisplay invCursorParams w = BoundaryCursor $ case w ^? hud . subInventory of @@ -43,7 +41,9 @@ invCursorParams w = BoundaryCursor $ case w ^? hud . subInventory of secondColumnLDP :: ListDisplayParams --secondColumnLDP = defaultListDisplayParams & ldpPos . spPixelOff .~ V2 subInvX (-20) -secondColumnLDP = defaultListDisplayParams & ldpPos . spPixelOff .~ V2 subInvX 0 +secondColumnLDP = defaultListDisplayParams + & ldpPos . spPixelOff .~ V2 subInvX (-16) + & ldpBorder ?~ (49, 16) subInvX :: Float subInvX = 10 * fromIntegral topInvW + 170 diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index d344311a5..e6ad46054 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -2,21 +2,18 @@ module Dodge.Render.HUD (drawHUD) where -import Linear -import Dodge.Clock -import qualified Data.Vector as V -import Dodge.Terminal -import Dodge.Inventory.CheckSlots import Control.Applicative import Control.Lens import Control.Monad import qualified Data.IntSet as IS import qualified Data.Map.Strict as M import Data.Maybe ---import qualified Data.Vector as V +import qualified Data.Vector as V +-- import qualified Data.Vector as V import Dodge.Base import Dodge.CharacterEnums ---import Dodge.Clock +import Dodge.Clock +-- import Dodge.Clock import Dodge.Creature.Info import Dodge.Creature.Test import Dodge.Data.CardinalPoint @@ -30,6 +27,7 @@ import Dodge.Data.World import Dodge.DoubleTree import Dodge.Equipment.Text import Dodge.Inventory +import Dodge.Inventory.CheckSlots import Dodge.Item.Display import Dodge.Item.Grammar import Dodge.Item.Info @@ -41,10 +39,12 @@ import Dodge.Render.List import Dodge.ScreenPos import Dodge.SelectionSections import Dodge.SelectionSections.Draw +import Dodge.Terminal import Dodge.Terminal.Type import Geometry import qualified IntMapHelp as IM import Justify +import Linear import NewInt import Picture import SDL (MouseButton (..)) @@ -52,18 +52,19 @@ import SDL (MouseButton (..)) drawHUD :: Config -> World -> Picture drawHUD cfig w = case w ^. hud of -- DisplayCarte -> drawCarte cfig w - HUD {_diSections = sections, _subInventory = subinv} -> + HUD{_diSections = sections, _subInventory = subinv} -> drawInventory sections w cfig subinv <> drawSubInventory subinv cfig w drawInventory :: IM.IntMap (SelSection ()) -> World -> Config -> SubInventory -> Picture -drawInventory sss w cfig = \case --- DisplayTerminal {} -> mempty - _ -> drawSelectionSections sss invDP cfig - <> drawSSCursor sss invDP curs cfig (f $ w ^? hud . diSelection . _Just) - <> drawRootCursor w sss (f $ w ^? hud . diSelection . _Just) invDP cfig - <> itemconnections - <> drawMouseOver cfig w +drawInventory sss w cfig = \case + -- DisplayTerminal {} -> mempty + _ -> + drawSelectionSections sss invDP cfig + <> drawSSCursor sss invDP curs cfig (f $ w ^? hud . diSelection . _Just) + <> drawRootCursor w sss (f $ w ^? hud . diSelection . _Just) invDP cfig + <> itemconnections + <> drawMouseOver cfig w where f = fmap (\(Sel x y _) -> (x, y)) curs = invCursorParams w @@ -118,8 +119,9 @@ drawMouseOver cfig w = w ^? input . mouseContext . mcoInvSelect <|> w ^? input . mouseContext . mcoInvFilt sss <- w ^? hud . diSections - return . translateScreenPos cfig (invDP ^. ldpPos) - . color (0.3*^white) + return + . translateScreenPos cfig (invDP ^. ldpPos) + . color (0.3 *^ white) -- . color white $ selSecDrawCursorAt invDP curs sss (j, i) -- curs = BoundaryCursor [West] @@ -130,8 +132,9 @@ drawMouseOver cfig w = <|> (w ^? input . mouseContext . mcoCombCombine) sss <- w ^? hud . subInventory . ciSections let idp = secondColumnLDP - return . translateScreenPos cfig (idp ^. ldpPos) - . color (0.3*white) + return + . translateScreenPos cfig (idp ^. ldpPos) + . color (0.3 * white) $ selSecDrawCursorAt idp curs sss (j, i) drawDragSelected :: Config -> World -> Maybe Picture @@ -146,8 +149,9 @@ drawDragSelected cfig w = do Sel i _ _ <- w ^? hud . diSelection . _Just sss <- w ^? hud . diSections let f x = (selSecDrawCursorAt invDP BackdropCursor sss (i, x) <>) - return . translateScreenPos cfig (invDP ^. ldpPos) - . color (0.2*^white) + return + . translateScreenPos cfig (invDP ^. ldpPos) + . color (0.2 *^ white) . IS.foldr f mempty $ ys @@ -156,8 +160,9 @@ drawDragSelecting cfig w = do OverInvDragSelect (Just (i, j)) (Just b) <- w ^? input . mouseContext sss <- w ^? hud . diSections let f x = selSecDrawCursorAt invDP BackdropCursor sss (i, x) - return . translateScreenPos cfig (invDP ^. ldpPos) - . color (0.2*^white) + return + . translateScreenPos cfig (invDP ^. ldpPos) + . color (0.2 *^ white) . foldMap f $ [min j b .. max j b] @@ -166,8 +171,10 @@ drawSubInventory subinv cfig w = case subinv of -- LockedInventory -> mempty -- topInvCursor col cursPos cfig w NoSubInventory{} -> drawRBOptions cfig w ExamineInventory -> drawExamineInventory cfig w - DisplayTerminal tid -> foldMap (drawTerminalDisplay (w ^.cWorld.lWorld) cfig) - (w ^? cWorld . lWorld . terminals . ix tid) + DisplayTerminal tid -> + foldMap + (drawTerminalDisplay (w ^. cWorld . lWorld) cfig) + (w ^? cWorld . lWorld . terminals . ix tid) CombineInventory{_ciSections = sss} -> drawCombineInventory cfig sss w MapperInventory _ _ itid -> drawMapperInventory itid w @@ -180,21 +187,16 @@ drawMapperInventory itid w = fold $ do where f = worldPosToScreen (w ^. wCam) -drawCombineInventory :: - Config -> - IM.IntMap (SelSection CombItem) -> - World -> - Picture +drawCombineInventory :: Config -> IM.IntMap (SelSection CombItem) -> World -> Picture drawCombineInventory cfig sss w = --- invHead cfig "COMBINE" - drawSelectionSections sss secondColumnLDP cfig + drawSelectionSections sss secondColumnLDP cfig <> drawSSCursor sss secondColumnLDP curs cfig msel <> combineInventoryExtra sss msel cfig w where curs = BoundaryCursor [North, South, West] msel = - fmap (\(Sel x y _) -> (x, y)) $ - w ^? hud . subInventory . ciSelection . _Just + (\(Sel x y _) -> (x, y)) <$> + (w ^? hud . subInventory . ciSelection . _Just) drawExamineInventory :: Config -> World -> Picture drawExamineInventory cfig w = @@ -336,12 +338,8 @@ drawItemChildrenConnect sss cfig i is = fromMaybe mempty $ do where snum = selNumPos cfig invDP sss 0 -combineInventoryExtra :: - IM.IntMap (SelSection CombItem) -> - Maybe (Int, Int) -> - Config -> - World -> - Picture +combineInventoryExtra + :: IM.IntMap (SelSection CombItem) -> Maybe (Int, Int) -> Config -> World -> Picture combineInventoryExtra sss msel cfig w = fold $ do (i, j) <- msel si <- sss ^? ix i . ssItems . ix j @@ -360,31 +358,32 @@ combineInventoryExtra sss msel cfig w = fold $ do (Just (0, i)) drawTerminalDisplay :: LWorld -> Config -> Terminal -> Picture -drawTerminalDisplay lw cfig tm = - drawSelectionList secondColumnLDP cfig f --- <> invHead cfig ("TERMINAL-" ++ show tid) --- <> color --- (withAlpha 0.5 green) -- consider integrating termScreenColor somehow --- (drawSelectionListBackground secondColumnLDP cfig tsize) --- <> color (dark $ _tmExternalColor tm) (drawTitleBackground cfig) +drawTerminalDisplay lw cfig tm = drawSelectionList secondColumnLDP cfig f where + -- <> invHead cfig ("TERMINAL-" ++ show tid) + -- <> color + -- (withAlpha 0.5 green) -- consider integrating termScreenColor somehow + -- (drawSelectionListBackground secondColumnLDP cfig tsize) + -- <> color (dark $ _tmExternalColor tm) (drawTitleBackground cfig) + tid = tm ^. tmID --- tsize = getMaxLinesTM + 1 + -- tsize = getMaxLinesTM + 1 toselitm (str, col) = SelItem [str] 1 55 True col 0 Nothing NoSIDisplayMod -- not sure if the width (55) is correct here - f = toselitm ("TERMINAL " ++ show tid,white) : - (map (toselitm . (_1 %~ (" "<>))) . displayTermInput - . reverse - $ _tmDisplayedLines tm) + f = + toselitm ("TERMINAL " ++ show tid, white) + : ( map (toselitm . (_1 %~ (" " <>))) + . displayTermInput + . reverse + $ _tmDisplayedLines tm + ) displayTermInput = case _tmStatus tm of TerminalOff -> id TerminalDeactivated -> id - TerminalLineRead -> (++ [(spincurs,termTextColor)]) - TerminalTextInput s -> - (++ [(getPromptTM ++ s ++ [cFilledRect], white)]) - TerminalPressTo s -> - (++ [(s, white)]) - spincurs = clockCycle 4 (V.fromList ["/","-","\\","|"]) lw + TerminalLineRead -> (++ [(spincurs, termTextColor)]) + TerminalTextInput s -> (++ [(getPromptTM ++ s ++ [cFilledRect], white)]) + TerminalPressTo s -> (++ [(s, white)]) + spincurs = clockCycle 4 (V.fromList ["/", "-", "\\", "|"]) lw lnkMidPosInvSelsCol :: Config -> World -> Int -> Color -> [Int] -> Picture lnkMidPosInvSelsCol cfig w i col = fromMaybe mempty . foldMap f @@ -404,19 +403,19 @@ invHead cfig = . scale 0.4 0.4 . textJustifyLeft ---locPoss = map (cartePosToScreen cfig (w ^. hud) . ($ w) . doWorldPos . fst) . IM.elems . _seenLocations . _lWorld $ _cWorld w ---locTexts = map fst locs +-- locPoss = map (cartePosToScreen cfig (w ^. hud) . ($ w) . doWorldPos . fst) . IM.elems . _seenLocations . _lWorld $ _cWorld w +-- locTexts = map fst locs ---displayListEndCoords :: Config -> [String] -> [Point2] ---displayListEndCoords cfig ss = map (doWindowScale cfig) $ zipWith h ss $ map f [1 ..] +-- displayListEndCoords :: Config -> [String] -> [Point2] +-- displayListEndCoords cfig ss = map (doWindowScale cfig) $ zipWith h ss $ map f [1 ..] -- where -- f :: Int -> Point2 -- f i = V2 (15 - halfWidth cfig) (2.5 + halfHeight cfig - (20 * fromIntegral i)) -- h :: String -> Point2 -> Point2 -- h s (V2 x y) = V2 (x + 9 * fromIntegral (length s)) y ---closeObjectTexts :: Config -> World -> Picture ---closeObjectTexts cfig w = pictures $ +-- closeObjectTexts :: Config -> World -> Picture +-- closeObjectTexts cfig w = pictures $ -- renderListAt pushout (negate 20 * fromIntegral invPos) cfig (map colAndText $ _closeObjects w) -- : maybeToList maybeLine -- where @@ -442,8 +441,8 @@ invHead cfig = -- ( halfHeight cfig - 20* (fromIntegral invPos +1) + 2.5) -- return . winScale cfig . color col $ lConnect p itScreenPos ---textSelItems :: [String] -> [SelectionItem ()] ---textSelItems = map (picsToSelectable . (: [])) +-- textSelItems :: [String] -> [SelectionItem ()] +-- textSelItems = map (picsToSelectable . (: [])) -- would be nice to add parameter to orient this with NSEW, cf cursor selNumPos :: @@ -455,7 +454,7 @@ selNumPos :: Maybe Point2 selNumPos = selNumPosCardinal West8 ---selNumPos cfig ldp sss i j = do +-- selNumPos cfig ldp sss i j = do -- ipos <- selSecYint i j sss -- size <- selSecSelSize i j sss -- indent <- sss ^? sssSections . ix i . ssItems . ix j . siOffX diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs index cfdf75222..c8ac6108e 100644 --- a/src/Dodge/Render/List.hs +++ b/src/Dodge/Render/List.hs @@ -41,6 +41,9 @@ drawSelectionList ldps cfig sl = (ldps ^. ldpScale) 0 (makeSelectionListPictures sl) + <> foldMap (color white . polygonWire . f) (ldps ^. ldpBorder) + where + f (x,y) = rectNSWE 5 (negate $ 20 * fromIntegral y + 5) (-5) (10 * fromIntegral x) drawTitleBackground :: Config -> Picture drawTitleBackground cfig = diff --git a/src/Loop.hs b/src/Loop.hs index 709d0d724..a3713ec52 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -209,19 +209,22 @@ setupConLoop' :: (world -> Event -> world) -> IO () setupConLoop' spf title winconfig paramCleanup ioStartWorld coneffs sideEffects eventFn = do - initializeAll - themvar <- newEmptyMVar - bracket - (createWindow title winconfig) - destroyWindow - $ \window -> bracket - (glCreateContext window) - (\con -> glFinish >> glDeleteContext con) - $ \_ -> - bracket - ioStartWorld - paramCleanup - (doConLoop' themvar spf window coneffs sideEffects eventFn) + bracket_ + initializeAll + (putStrLn "Quit SDL" >> quit) + $ do + themvar <- newEmptyMVar + bracket + (createWindow title winconfig) + destroyWindow + $ \window -> bracket + (glCreateContext window) + (\con -> glFinish >> glDeleteContext con) + $ \_ -> + bracket + ioStartWorld + paramCleanup + (doConLoop' themvar spf window coneffs sideEffects eventFn) -- | The internal loop. doConLoop' :: diff --git a/src/Picture/Base.hs b/src/Picture/Base.hs index a51947840..71c91d20b 100644 --- a/src/Picture/Base.hs +++ b/src/Picture/Base.hs @@ -63,7 +63,7 @@ blank = mempty polygonWire :: [Point2] -> Picture {-# INLINE polygonWire #-} -polygonWire ps = line (ps ++ [head ps]) +polygonWire ps = line (ps <> [head ps]) picMap :: (Verx -> Verx) -> Picture -> Picture {-# INLINE picMap #-}