justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Add border to terminal display

Browse Source
This commit is contained in:
justin
2025-12-23 15:43:56 +00:00
parent 183bb16fca
commit 238d6b8799
9 changed files with 133 additions and 125 deletions
Download Patch File Download Diff File Expand all files Collapse all files
.hlint.yaml
+4 -4
View File
@@ -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
+31 -21
View File
@@ -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
+1
View File
@@ -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
+6 -14
View File
@@ -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))
src/Dodge/ListDisplayParams.hs
+5 -5
View File
@@ -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
src/Dodge/Render/HUD.hs
+66 -67
View File
@@ -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
src/Dodge/Render/List.hs
+3
View File
@@ -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
+16 -13
View File
@@ -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' ::
src/Picture/Base.hs
+1 -1
View File
@@ -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 #-}