Add border to terminal display

.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}
 

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
 

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

src/Dodge/HeldUse.hs

@@ -717,13 +717,8 @@ basicMuzFlare pos dir =
 isAmmoIntLink :: Int -> ItemSF -> Bool
 isAmmoIntLink i sf = Just i == sf ^? amsfLink
 
-useLoadedAmmo ::
+useLoadedAmmo 
-    LocationDT OItem ->
+    :: LocationDT OItem -> Creature -> Muzzle -> Maybe (Int, DTree OItem) -> World -> World
-    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 ::
+shootBullets 
-    LocationDT OItem ->
+    :: LocationDT OItem -> Creature -> (Muzzle, Int, DTree OItem) -> World -> World
-    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))

src/Dodge/ListDisplayParams.hs

@@ -26,13 +26,11 @@ defaultListDisplayParams =
                 { _spScreenOff = V2 (-0.5) 0.5 -- top left
                 , _spPixelOff = 0
                 }
+        , _ldpBorder = Nothing
         }
 
 invDP :: ListDisplayParams
-invDP =
+invDP = defaultListDisplayParams & ldpPos . spPixelOff .~ V2 6 0
-    defaultListDisplayParams
---        & ldpPos . spPixelOff .~ V2 6 (-1)
-        & 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

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 
+drawInventory sss w cfig = \case
---    DisplayTerminal {} -> mempty
+    --    DisplayTerminal {} -> mempty
-    _ -> drawSelectionSections sss invDP cfig
+    _ ->
-        <> drawSSCursor sss invDP curs cfig (f $ w ^? hud . diSelection . _Just)
+        drawSelectionSections sss invDP cfig
-        <> drawRootCursor w sss (f $ w ^? hud . diSelection . _Just) invDP cfig
+            <> drawSSCursor sss invDP curs cfig (f $ w ^? hud . diSelection . _Just)
-        <> itemconnections
+            <> drawRootCursor w sss (f $ w ^? hud . diSelection . _Just) invDP cfig
-        <> drawMouseOver cfig w
+            <> 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)
+        return
-            . color (0.3*^white)
+            . 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)
+        return
-            . color (0.3*white)
+            . 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)
+    return
-        . color (0.2*^white)
+        . 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)
+    return
-        . color (0.2*^white)
+        . 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) 
+    DisplayTerminal tid ->
-        (w ^? cWorld . lWorld . terminals . ix 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 ::
+drawCombineInventory :: Config -> IM.IntMap (SelSection CombItem) -> World -> Picture
-    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)) $
+        (\(Sel x y _) -> (x, y)) <$>
-            w ^? hud . subInventory . ciSelection . _Just
+            (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 ::
+combineInventoryExtra 
-    IM.IntMap (SelSection CombItem) ->
+    :: IM.IntMap (SelSection CombItem) -> Maybe (Int, Int) -> Config -> World -> Picture
-    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 =
+drawTerminalDisplay lw cfig tm = drawSelectionList secondColumnLDP cfig f
-        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)
   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) :
+    f =
-        (map (toselitm . (_1 %~ ("  "<>))) . displayTermInput
+        toselitm ("TERMINAL " ++ show tid, white)
-            . reverse
+            : ( map (toselitm . (_1 %~ ("  " <>)))
-            $ _tmDisplayedLines tm)
+                    . displayTermInput
+                    . reverse
+                    $ _tmDisplayedLines tm
+              )
     displayTermInput = case _tmStatus tm of
         TerminalOff -> id
         TerminalDeactivated -> id
-        TerminalLineRead -> (++ [(spincurs,termTextColor)])
+        TerminalLineRead -> (++ [(spincurs, termTextColor)])
-        TerminalTextInput s ->
+        TerminalTextInput s -> (++ [(getPromptTM ++ s ++ [cFilledRect], white)])
-            (++ [(getPromptTM ++ s ++ [cFilledRect], white)])
+        TerminalPressTo s -> (++ [(s, white)])
-        TerminalPressTo s ->
+    spincurs = clockCycle 4 (V.fromList ["/", "-", "\\", "|"]) lw
-            (++ [(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
+-- locPoss = map (cartePosToScreen cfig (w ^. hud) . ($ w) . doWorldPos . fst) . IM.elems . _seenLocations . _lWorld $ _cWorld w
---locTexts = map fst locs
+-- locTexts = map fst locs
 
---displayListEndCoords :: Config -> [String] -> [Point2]
+-- displayListEndCoords :: Config -> [String] -> [Point2]
---displayListEndCoords cfig ss = map (doWindowScale cfig) $ zipWith h ss $ map f [1 ..]
+-- 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 :: Config -> World -> Picture
---closeObjectTexts cfig w = pictures $
+-- 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 :: [String] -> [SelectionItem ()]
---textSelItems = map (picsToSelectable . (: []))
+-- 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

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 =

src/Loop.hs

@@ -209,19 +209,22 @@ setupConLoop' ::
     (world -> Event ->  world) ->
     IO ()
 setupConLoop' spf title winconfig paramCleanup ioStartWorld coneffs sideEffects eventFn = do
-    initializeAll
+    bracket_
-    themvar <- newEmptyMVar
+        initializeAll
-    bracket
+        (putStrLn "Quit SDL" >> quit)
-        (createWindow title winconfig)
+        $ do
-        destroyWindow
+            themvar <- newEmptyMVar
-        $ \window -> bracket
+            bracket
-            (glCreateContext window)
+                (createWindow title winconfig)
-            (\con -> glFinish >> glDeleteContext con)
+                destroyWindow
-            $ \_ ->
+                $ \window -> bracket
-                bracket
+                    (glCreateContext window)
-                    ioStartWorld
+                    (\con -> glFinish >> glDeleteContext con)
-                    paramCleanup
+                    $ \_ ->
-                    (doConLoop' themvar spf window coneffs sideEffects eventFn)
+                        bracket
+                            ioStartWorld
+                            paramCleanup
+                            (doConLoop' themvar spf window coneffs sideEffects eventFn)
 
 -- | The internal loop.
 doConLoop' ::

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 #-}