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

Cleanup

Browse Source
This commit is contained in:
justin
2024-10-25 21:05:32 +01:00
parent 6424899afd
commit f6c136cfd6
25 changed files with 334 additions and 333 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/State.hs
+1 -1
View File
@@ -258,7 +258,7 @@ shineTorch cr itmtree (p, q) = fromMaybe id $ do
x = 10
isammolink AmmoInLink{} = True
isammolink _ = False
pos = (_crPos cr `v2z` 0 + rotate3 cdir p)
pos = _crPos cr `v2z` 0 + rotate3 cdir p
pos'' = pos + rotate3 d (V3 8 0 1.5)
cdir = _crDir cr
d = _crDir cr + argV (Q.qToV2 q)
src/Dodge/Data/SelectionList.hs
+6 -10
View File
@@ -22,20 +22,17 @@ data ListDisplayParams = ListDisplayParams
, _ldpWidth :: SelectionWidth
}
data CursorDisplay = CursorDisplay
{ _cursSides :: [CardinalPoint]
}
data CursorDisplay
= BoundaryCursor
{ _cursSides :: [CardinalPoint]
}
| BackdropCursor
data SelectionList a = SelectionList
{ _slItems :: [SelectionItem a]
, _slSelPos :: Maybe Int
, _slRegex :: String
, _slRegexInput :: Bool
, _slRegexList :: [(SelectionItem a, Maybe Int)]
}
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
data SelectionSections a = SelectionSections
{ _sssSections :: IntMap (SelectionSection a)
, _sssExtra :: SSSExtra
@@ -44,7 +41,7 @@ data SelectionSections a = SelectionSections
-- note that filters are arbitrary: the sssFilters point to the lower of
-- a pair of ints (i,i+1) such that the lower is the regex section, the higher
-- is the items section.
data SSSExtra = SSSExtra
newtype SSSExtra = SSSExtra
{ _sssFilters :: IntMap (Maybe String)
}
@@ -64,7 +61,6 @@ data SelectionSection a = SelectionSection
, _ssDescriptor :: String
}
data SelectionWidth
= FixedSelectionWidth Int
| VariableSelectionWidth (Int -> Int)
src/Dodge/Debug.hs
+3 -2
View File
@@ -13,6 +13,7 @@ import Dodge.Debug.Picture
import Dodge.WorldEvent.ThingsHit
import Geometry.Vector
import qualified SDL
import Data.Ord
debugEvents :: Universe -> Universe
debugEvents u = case dbools ^. at Enable_debug of
@@ -90,8 +91,8 @@ clickGetCreature u
closestCreatureID :: Universe -> Maybe Int
closestCreatureID u =
fmap (_crID . snd) . listToMaybe . reverse
. sortOn (dist mwp . fst)
fmap (_crID . snd) . listToMaybe
. sortOn (Down . dist mwp . fst)
. crsHitRadial mwp 100
$ _uvWorld u
where
src/Dodge/Default/SelectionList.hs
-4
View File
@@ -6,8 +6,4 @@ defaultSelectionList :: SelectionList a
defaultSelectionList = SelectionList
{_slItems = mempty
, _slSelPos = Nothing
-- , _slLength = 0
, _slRegex = ""
, _slRegexInput = False
, _slRegexList = []
}
src/Dodge/DisplayInventory.hs
+3
View File
@@ -280,3 +280,6 @@ enterCombineInv cfig w = w & hud . hudElement . subInventory .~ CombineInventory
, _ssIndent = 0
, _ssDescriptor = "COMBINATIONS"
}
regexList :: String -> [String] -> Bool
regexList x = any (isInfixOf x)
src/Dodge/DoubleTree.hs
+1 -1
View File
@@ -64,7 +64,7 @@ ildtPropagate lf rf x (LDT v l r) = LDT v (imap (go lf x) l) (imap (go rf x) r)
ldtPropagateIndices :: LabelDoubleTree b a -> LabelDoubleTree b (a, [Either Int Int])
ldtPropagateIndices (LDT x l r) = LDT (x,[]) (imap (f Left) l) (imap (f Right) r)
where
f e i (y,t) = (y, fmap (second (e i:)) $ ldtPropagateIndices t)
f e i (y,t) = (y, second (e i:) <$> ldtPropagateIndices t)
-- conceptually, in a tree growing from left to right,
-- bottom -> top is equated with left -> right.
src/Dodge/EnergyBall/Draw.hs
+2 -1
View File
@@ -62,7 +62,8 @@ drawFlamelet pt =
. rotate (negate (rot + 0.2 * fromIntegral time))
. scale s2 s2
. polygon
$ (rectNSWE siz2 (- siz2) (- siz2) siz2)
. reverse
$ rectNSWE siz2 (- siz2) (- siz2) siz2
pic =
setDepth (z + 20)
. uncurryV translate ep
src/Dodge/HeldUse.hs
+1 -1
View File
@@ -371,7 +371,7 @@ shootBullet ::
World
shootBullet itmtree cr (mz, x, magtree) w = fromMaybe w $ do
thebullet <- getBulletType itmtree magtree mz cr w
return $ flip (foldl' (&)) (replicate x (makeBullet thebullet (itmtree ^. ldtValue) cr mz)) w
return $ foldl' (&) w (replicate x (makeBullet thebullet (itmtree ^. ldtValue) cr mz))
-- & makeMuzzleSmoke mz itm cr
src/Dodge/Inventory.hs
+1 -1
View File
@@ -217,7 +217,7 @@ changeSwapWith f w = case w ^? hud . hudElement . diSelection . _Just of
augInvDirectSelect :: (Int, Int) -> World -> World
augInvDirectSelect (i, j) w =
w
& hud . hudElement . diSelection .~ Just (i, j)
& hud . hudElement . diSelection ?~ (i, j)
& worldEventFlags . at InventoryChange ?~ ()
& setInvPosFromSS
& cWorld . lWorld %~ crUpdateItemLocations 0
src/Dodge/Item/Grammar.hs
+2 -1
View File
@@ -103,7 +103,8 @@ laserLinkTest :: Item -> LinkTest
laserLinkTest itm = LTest (llleft itm) (llright itm)
llleft :: Item -> PartiallyComposedItem -> Maybe LinkUpdate
llleft itm pci = _tryLeftLink (uncurry useBreakL $ itemToBreakLists (CItem itm WeaponTargetingSF)) pci
llleft itm = _tryLeftLink
. uncurry useBreakL . itemToBreakLists $ CItem itm WeaponTargetingSF
llright :: Item -> PartiallyComposedItem -> Maybe LinkUpdate
llright itm pci = case pci ^. _1 . itType of
src/Dodge/Item/HeldOffset.hs
+2 -2
View File
@@ -30,7 +30,7 @@ heldItemRelativeOrient itm cr (p,q)
| isTwoHandFlat =
( V3 (_crRad cr) 0 handD
+ rotate3 (twoFlatHRot cr) (transToHandle itm p)
, (Q.axisAngle (V3 0 0 1) (twoFlatHRot cr)) * q
, Q.axisAngle (V3 0 0 1) (twoFlatHRot cr) * q
)
| isOneHand =
( V3 (_crRad cr * 0.7 + handPos) (_crRad cr * negate 0.7) handD
@@ -40,7 +40,7 @@ heldItemRelativeOrient itm cr (p,q)
| otherwise =
( V3 (_crRad cr) 0 handD
+ rotate3 (strideRot cr + 1.2) (V3 (-8) 0 0 + transToHandle itm p)
, (Q.axisAngle (V3 0 0 1) (strideRot cr + 1.2)) * q
, Q.axisAngle (V3 0 0 1) (strideRot cr + 1.2) * q
)
where
handD = 15
src/Dodge/Item/InventoryColor.hs
+11 -11
View File
@@ -1,12 +1,12 @@
{-# LANGUAGE LambdaCase#-}
module Dodge.Item.InventoryColor
( itemInvColor
) where
module Dodge.Item.InventoryColor (
itemInvColor,
) where
--import Dodge.Data.Item.Use.Consumption.Ammo
import Dodge.Data.ComposedItem
import Color
import Control.Lens
import Dodge.Data.ComposedItem
itemInvColor :: ComposedItem -> Color
itemInvColor ci = case ci ^. cItemFunction of
@@ -14,13 +14,13 @@ itemInvColor ci = case ci ^. cItemFunction of
WeaponScopeSF -> chartreuse
WeaponTargetingSF -> green
AugmentedHUDSF -> rose
AmmoMagSF {} -> red
AmmoMagSF{} -> red
RemoteScreenSF -> azure
UncomposableIsolateSF -> greyN 0.5
AmmoModifierSF {} -> orange
AmmoTargetingSF {} -> green
AmmoPayloadSF {} -> violet
AmmoEffectSF {} -> aquamarine
AmmoModifierSF{} -> orange
AmmoTargetingSF{} -> green
AmmoPayloadSF{} -> violet
AmmoEffectSF{} -> aquamarine
FunctionChangeSF -> yellow
--ammoTypeColor :: AmmoType -> Color
@@ -30,7 +30,7 @@ itemInvColor ci = case ci ^. cItemFunction of
-- BeltBulletAmmo -> orange
-- ElectricalAmmo -> blue
-- GasAmmo -> green
-- HELD {} -> white
-- LEFT {} -> cyan
-- EQUIP {} -> yellow
src/Dodge/Item/Scope.hs
+1 -3
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Item.Scope (
zoomScope,
targetingScope,
@@ -21,8 +20,7 @@ zoomScope = defaultHeldItem
& itUse .~ UseScope OpticScope{_opticPos = 0, _opticZoom = 1, _opticDefaultZoom = 0.5}
targetingScope :: TargetingType -> Item
targetingScope tt= case tt of
_ -> defaultHeldItem
targetingScope tt = defaultHeldItem
& itType .~ TARGETING tt
& itUse .~ UseCraft
& itTargeting .~ ItTargeting
src/Dodge/ListDisplayParams.hs
+23 -28
View File
@@ -1,55 +1,51 @@
module Dodge.ListDisplayParams
( invDisplayParams
, invCursorParams
, secondColumnParams
, subInvX
, defaultListDisplayParams
, optionListDisplayParams
) where
module Dodge.ListDisplayParams (
invDisplayParams,
invCursorParams,
secondColumnParams,
subInvX,
defaultListDisplayParams,
optionListDisplayParams,
) where
import Dodge.Data.ScreenPos
import Control.Lens
import qualified Data.Map.Strict as M
import Dodge.Data.CardinalPoint
import SDL (MouseButton (..))
import Dodge.Data.ScreenPos
import Dodge.Data.SelectionList
import Dodge.Data.World
import qualified Data.Map.Strict as M
import Control.Lens
import Linear
import SDL (MouseButton (..))
defaultListDisplayParams :: ListDisplayParams
defaultListDisplayParams =
ListDisplayParams
{ _ldpVerticalGap = 0
, _ldpScale = 1
, _ldpPos = ScreenPos {_spScreenOff = V2 (-0.5) 0.5 -- top left
, _spPixelOff = 0}
, _ldpPos =
ScreenPos
{ _spScreenOff = V2 (-0.5) 0.5 -- top left
, _spPixelOff = 0
}
, _ldpWidth = FixedSelectionWidth 15
}
invDisplayParams :: World -> ListDisplayParams
invDisplayParams w =
defaultListDisplayParams
-- & ldpCursorSides .~ selcursortype
& ldpWidth .~ FixedSelectionWidth (determineInvSelCursorWidth w)
& ldpPos . spPixelOff .~ V2 6 (-1)
-- where
-- selcursortype = case w ^? hud . hudElement . subInventory of
-- _ | ButtonRight `M.member` _mouseButtons (_input w) -> [North, South, East, West]
-- Just ExamineInventory{} -> [North, South, East, West]
-- Just CombineInventory{} -> []
-- _ -> [North, South, West]
invCursorParams :: World -> CursorDisplay
invCursorParams w = CursorDisplay $ case w ^? hud . hudElement . subInventory of
_ | ButtonRight `M.member` _mouseButtons (_input w) -> [North, South, East, West]
Just ExamineInventory{} -> [North, South, East, West]
Just CombineInventory{} -> []
_ -> [North, South, West]
invCursorParams w = BoundaryCursor $ case w ^? hud . hudElement . subInventory of
_ | ButtonRight `M.member` _mouseButtons (_input w) -> [North, South, East, West]
Just ExamineInventory{} -> [North, South, East, West]
Just CombineInventory{} -> []
_ -> [North, South, West]
secondColumnParams :: ListDisplayParams
secondColumnParams =
defaultListDisplayParams
& ldpPos . spPixelOff .~ V2 subInvX (-81)
-- & ldpCursorSides .~ [North, South, West]
subInvX :: Float
subInvX = 10 * fromIntegral topInvW + 70
@@ -77,4 +73,3 @@ optionListDisplayParams =
& ldpScale .~ 2
& ldpVerticalGap .~ 0
& ldpWidth .~ FixedSelectionWidth 50
-- & ldpCursorSides .~ [North, South, West]
src/Dodge/Render/HUD.hs
+32 -13
View File
@@ -59,7 +59,7 @@ drawHP cfig =
drawInventory :: SelectionSections () -> World -> Configuration -> Picture
drawInventory sss w cfig =
drawSelectionSections sss ldp cfig
<> drawSSCursor sss (w ^? hud . hudElement . diSelection . _Just) ldp curs cfig
<> drawSSCursor sss (w ^? hud . hudElement . diSelection . _Just) ldp curs cfig
<> iextra
<> translateScreenPos
cfig
@@ -82,9 +82,9 @@ drawDIMouseOver w = fromMaybe mempty $ do
(_, i) <- w ^? hud . hudElement . subInventory . nsMouseOver . _Just
sss <- w ^? hud . hudElement . diSections
let idp = invDisplayParams w
return . color (withAlpha 0.5 white) $ selSecDrawCursorAt (0, i) 10 idp curs sss
return . color (withAlpha 0.5 white) $ selSecDrawCursorAt 10 idp curs sss (0, i)
where
curs = CursorDisplay [North,South]
curs = BoundaryCursor [North, South]
getMouseInvSel :: World -> Maybe ((Int, Int), (Int, Int))
getMouseInvSel w = case w ^? hud . hudElement . subInventory . nsSelected of
@@ -130,7 +130,7 @@ drawCombineInventory cfig sss w =
<> drawSSCursor sss msel secondColumnParams curs cfig
<> combineInventoryExtra sss msel cfig w
where
curs = CursorDisplay [North,South,West]
curs = BoundaryCursor [North, South, West]
msel = w ^? hud . hudElement . subInventory . ciSelection . _Just
drawExamineInventory :: Configuration -> World -> Picture
@@ -185,7 +185,9 @@ drawRBOptions :: Configuration -> World -> Picture
drawRBOptions cfig w = fromMaybe mempty $ do
guard $ ButtonRight `M.member` _mouseButtons (_input w)
invid <- you w ^? crManipulation . manObject . imSelectedItem
eslist <- fmap equipSiteToPositions $ you w ^? crInv . ix invid . itUse . uequipEffect . eeSite
eslist <-
fmap equipSiteToPositions $
you w ^? crInv . ix invid . itUse . uequipEffect . eeSite
i <- w ^? rbOptions . opSel
let ae = getEquipmentAllocation w
sss <- w ^? hud . hudElement . diSections
@@ -202,23 +204,36 @@ drawRBOptions cfig w = fromMaybe mempty $ do
return $
toTopLeft cfig $
translate 290 (-1) (ytext midstr)
<> translate 160 (-1) (listCursorChooseBorderScale 0 1 [North, South] curpos 0 white 21 1)
<> translate
160
(-1)
( listCursorChooseBorderScale
0
1
(BoundaryCursor [North, South])
curpos
0
white
21
1
)
<> translate
380
(-1)
( drawListYoff (curpos - i) (map (text . eqPosText) eslist)
<> listCursorChooseBorderScale 0 1 [East] (curpos - i) 0 white 7 (length eslist)
<> listCursorChooseBorderScale 0 1 [West] (curpos + 1) 0 white 7 (length eslist - (i + 1))
<> listCursorChooseBorderScale 0 1 [West] (curpos - i) 0 white 7 i
<> listCursorChooseBorderScale 0 1 (bc East) (curpos - i) 0 white 7 (length eslist)
<> listCursorChooseBorderScale 0 1 (bc West) (curpos + 1) 0 white 7 (length eslist - (i + 1))
<> listCursorChooseBorderScale 0 1 (bc West) (curpos - i) 0 white 7 i
<> maybetopborder i curpos
<> maybebottomborder i (length eslist) curpos
)
<> translate 460 (-1) (ytext extrastr)
where
maybetopborder 0 curpos = listCursorChooseBorderScale 0 1 [North] curpos 0 white 7 1
bc x = BoundaryCursor [x]
maybetopborder 0 curpos = listCursorChooseBorderScale 0 1 (bc North) curpos 0 white 7 1
maybetopborder _ _ = mempty
maybebottomborder a b curpos
| a == b - 1 = listCursorChooseBorderScale 0 1 [South] curpos 0 white 7 1
| a == b - 1 = listCursorChooseBorderScale 0 1 (bc South) curpos 0 white 7 1
| otherwise = mempty
otheritem j = fromMaybe "" $ do
itm <- you w ^? crInv . ix j
@@ -282,8 +297,12 @@ combineInventoryExtra sss msel cfig w = fromMaybe mempty $ do
let idp = invDisplayParams w
return $
translateScreenPos cfig (idp ^. ldpPos) $
selSecDrawCursor 17 idp (CursorDisplay [North, South, East, West])
sss' (Just (0, i))
selSecDrawCursor
17
idp
(BoundaryCursor [North, South, East, West])
sss'
(Just (0, i))
displayTerminal :: Int -> Configuration -> LWorld -> Picture
displayTerminal tid cfig w = fromMaybe mempty $ do
src/Dodge/Render/InfoBox.hs
+27 -7
View File
@@ -1,22 +1,42 @@
module Dodge.Render.InfoBox
( renderInfoListAt
, renderInfoListsAt
) where
module Dodge.Render.InfoBox (
renderInfoListAt,
renderInfoListsAt,
) where
import Dodge.Data.CardinalPoint -- this should be imported implicitly
-- this should be imported implicitly
import Dodge.Base
import Dodge.Data.Camera
import Dodge.Data.CardinalPoint
import Dodge.Data.Config
import Dodge.Data.SelectionList
import Dodge.Render.Connectors
import Dodge.Render.List
import Geometry
import Picture
renderInfoListAt :: Float -> Float -> Configuration -> Camera -> (Point2, [String]) -> Picture
renderInfoListAt ::
Float ->
Float ->
Configuration ->
Camera ->
(Point2, [String]) ->
Picture
renderInfoListAt x y cfig cam (p, ss) =
toTopLeft cfig (renderListAt x y (zip ss (repeat white)))
<> color white (lConnect (V2 (x - hw) (hh -25 - y)) (worldPosToScreen cam p))
<> toTopLeft cfig (translate x (-y) $ listCursorChooseBorderScale 0 1 [North,South] 0 0 white 19 (length ss))
<> toTopLeft
cfig
( translate x (- y) $
listCursorChooseBorderScale
0
1
(BoundaryCursor [North, South])
0
0
white
19
(length ss)
)
where
hw = halfWidth cfig
hh = halfHeight cfig
src/Dodge/Render/List.hs
+47 -53
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Render.List (
renderListAt,
drawList,
@@ -13,14 +14,13 @@ module Dodge.Render.List (
selSecDrawCursorAt,
) where
import Dodge.SelectionSections
import Data.Maybe
import Dodge.Base.Window
import Dodge.Data.CardinalPoint
import Dodge.Data.Config
import Dodge.Data.SelectionList
import Dodge.ScreenPos
import Dodge.SelectionList
import Dodge.SelectionSections
import Geometry
import LensHelp
import ListHelp
@@ -28,38 +28,29 @@ import Picture
drawSelectionList :: ListDisplayParams -> Configuration -> SelectionList a -> Picture
drawSelectionList ldps cfig sl =
translateScreenPos
cfig
(ldps ^. ldpPos)
$ drawListYgapScaleYoff
(_ldpVerticalGap ldps)
(_ldpScale ldps)
translateScreenPos cfig (ldps ^. ldpPos) $
drawListYgapScaleYoff
(ldps ^. ldpVerticalGap)
(ldps ^. ldpScale)
0
(makeSelectionListPictures sl)
<> drawSelectionCursor sl ldps (CursorDisplay [North,West,South])
drawSelectionCursor :: SelectionList a
-> ListDisplayParams
-> CursorDisplay
-> Picture
drawSelectionCursor sl = drawCursorAt (f $ sl ^. slSelPos) (getShownItems sl)
where
-- the following is quite hacky
f = case sl ^. slRegex of
_ | sl ^. slRegexInput -> const (Just 0)
"" | not (sl ^. slRegexInput) -> id
_ -> fmap (+ 1)
<> drawCursorAt
(sl ^. slSelPos)
(sl ^. slItems)
ldps
(BoundaryCursor [North, South])
makeSelectionListPictures :: SelectionList a -> [Picture]
makeSelectionListPictures = concatMap f . getShownItems
makeSelectionListPictures = concatMap f . _slItems
where
f si = map (color (_siColor si) . text) $ _siPictures si
--f si = map ((flip inverseText) ((_siColor si))) $ _siPictures si
drawCursorAt :: Maybe Int -> [SelectionItem a]
-> ListDisplayParams
-> CursorDisplay
-> Picture
drawCursorAt ::
Maybe Int ->
[SelectionItem a] ->
ListDisplayParams ->
CursorDisplay ->
Picture
drawCursorAt mi lis ldps curs = fromMaybe mempty $ do
i <- mi
selit <- lis !? i
@@ -67,7 +58,7 @@ drawCursorAt mi lis ldps curs = fromMaybe mempty $ do
listCursorChooseBorderScale
(_ldpVerticalGap ldps)
(_ldpScale ldps)
(curs ^. cursSides)
curs
(sum . map _siHeight $ take i lis)
(_siOffX selit)
(_siColor selit)
@@ -76,8 +67,8 @@ drawCursorAt mi lis ldps curs = fromMaybe mempty $ do
getLDPWidth :: ListDisplayParams -> Int
getLDPWidth ldps = case _ldpWidth ldps of
FixedSelectionWidth x -> x
_ -> 1
FixedSelectionWidth x -> x
_ -> 1
drawListYoff :: Int -> [Picture] -> Picture
drawListYoff = drawListYgapScaleYoff 0 1
@@ -91,14 +82,14 @@ stackPicturesAt = stackPicturesAtOff 0
stackPicturesAtOff :: Int -> [Picture] -> Picture
stackPicturesAtOff i = mconcat . zipWith (drawListElement 10 1 0) [i, i -1 ..]
selSecDrawCursorAt
:: (Int,Int)
-> Int
-> ListDisplayParams
-> CursorDisplay
-> SelectionSections a
-> Picture
selSecDrawCursorAt (i,j) xsize ldp curs sss = fromMaybe mempty $ do
selSecDrawCursorAt ::
Int ->
ListDisplayParams ->
CursorDisplay ->
SelectionSections a ->
(Int, Int) ->
Picture
selSecDrawCursorAt xsize ldp curs sss (i, j) = fromMaybe mempty $ do
yint <- selSecYint i j sss
xint <- sss ^? sssSections . ix i . ssIndent
si <- sss ^? sssSections . ix i . ssItems . ix j
@@ -106,45 +97,48 @@ selSecDrawCursorAt (i,j) xsize ldp curs sss = fromMaybe mempty $ do
listCursorChooseBorderScale
(ldp ^. ldpVerticalGap)
(ldp ^. ldpScale)
(curs ^. cursSides)
curs
yint
(xint + _siOffX si)
(_siColor si)
xsize
(_siHeight si)
selSecDrawCursor :: Int -> ListDisplayParams
-> CursorDisplay
-> SelectionSections a ->
Maybe (Int,Int) -> Picture
selSecDrawCursor xsize ldp curs sss msel = maybe mempty
(\x -> selSecDrawCursorAt x xsize ldp curs sss)
msel
selSecDrawCursor ::
Int ->
ListDisplayParams ->
CursorDisplay ->
SelectionSections a ->
Maybe (Int, Int) ->
Picture
selSecDrawCursor xsize ldp curs = maybe mempty . selSecDrawCursorAt xsize ldp curs
-- displays a cursor that should match up to list text pictures
listCursorChooseBorderScale ::
Float ->
Float ->
[CardinalPoint] ->
CursorDisplay ->
Int ->
Int ->
Color ->
Int ->
Int ->
Picture
listCursorChooseBorderScale ygap s borders yint xint col cursxsize cursysize =
listCursorChooseBorderScale ygap s curs yint xint col cursxsize cursysize =
translate
((10 * fromIntegral xint - 5) * s)
(- (ygap + (s * 20 + ygap) * fromIntegral yint ))
(- (ygap + (s * 20 + ygap) * fromIntegral yint))
. color col
$ chooseCursorBorders (s * wth) (s * hgt) borders
$ chooseCursorBorders (s * wth) (s * hgt) curs
where
wth = 10 * (fromIntegral cursxsize + 1)
hgt = 20 * fromIntegral cursysize + ygap * (fromIntegral cursysize - 1)
-- note we cannot simply scale lines because they are drawn as solid rectangles
chooseCursorBorders :: Float -> Float -> [CardinalPoint] -> Picture
chooseCursorBorders w h = foldMap (line . toLine)
chooseCursorBorders :: Float -> Float -> CursorDisplay -> Picture
chooseCursorBorders w h = \case
BoundaryCursor ps -> foldMap (line . toLine) ps
BackdropCursor -> polygon . reverse $ rectNSWE 0 h' 0 w
where
h' = negate h
toLine North = [V2 0 0, V2 w 0]
@@ -181,7 +175,7 @@ renderListAt :: Float -> Float -> [(String, Color)] -> Picture
renderListAt tx ty = translate tx (- ty) . drawList . map (\(str, col) -> color col $ text str)
--inverseText :: String -> Color -> Picture
--inverseText str col =
--inverseText str col =
-- translate3 (V3 0 0 (0.5))
-- (color (V4 0 1 0 0.1) ( text str))
-- <>
src/Dodge/SelectionList.hs
-6
View File
@@ -1,5 +1,4 @@
module Dodge.SelectionList (
getShownItems,
getAvailableListLines,
) where
@@ -17,8 +16,3 @@ getAvailableListLines ldps cfig = floor ((dToBot - vgap) / itmHeight)
dToBot =
winy / 2 + winy * (ldps ^. ldpPos . spScreenOff . _y)
+ (ldps ^. ldpPos . spPixelOff . _y)
getShownItems :: SelectionList a -> [SelectionItem a]
getShownItems sl = case sl ^. slRegexList of
[] -> sl ^. slItems
xs -> fmap fst xs
src/Dodge/SelectionSections.hs
+19 -21
View File
@@ -3,7 +3,7 @@ module Dodge.SelectionSections (
ssLookupDown,
ssLookupGT,
ssSetCursor,
-- setFirstPosSelectionSections,
-- setFirstPosSelectionSections,
selSecYint,
selSecSelSize,
inverseSelSecYint,
@@ -23,13 +23,17 @@ import Dodge.Data.Config
import Dodge.Data.SelectionList
import Dodge.ScreenPos
import Geometry.Data
import Data.Foldable
scrollSelectionSections :: Int -> SelectionSections a -> Maybe (Int,Int)
-> Maybe (Int,Int)
scrollSelectionSections ::
Int ->
SelectionSections a ->
Maybe (Int, Int) ->
Maybe (Int, Int)
scrollSelectionSections yi sss msel
| yi == 0 = msel
| yi > 0 = foldr ($) msel $ replicate yi (ssScrollUsing ssLookupUp sss)
| otherwise = foldr ($) msel $ replicate (negate yi) (ssScrollUsing ssLookupDown sss)
| yi > 0 = foldl' (&) msel $ replicate yi (ssScrollUsing ssLookupUp sss)
| otherwise = foldl' (&) msel $ replicate (negate yi) (ssScrollUsing ssLookupDown sss)
--setFirstPosSelectionSections :: SelectionSections a -> SelectionSections a
--setFirstPosSelectionSections sss = fromMaybe sss $ do
@@ -39,21 +43,15 @@ scrollSelectionSections yi sss msel
ssScrollUsing ::
(Int -> Int -> SelectionSections a -> Maybe (Int, Int, SelectionItem a)) ->
SelectionSections a ->
Maybe (Int,Int) ->
Maybe (Int,Int)
ssScrollUsing g sss msel =
( ssScrollMinOnFail
g
(sss & sssSections %~ fmap (ssItems %~ IM.filter _siIsSelectable))
msel
)
Maybe (Int, Int) ->
Maybe (Int, Int)
ssScrollUsing g =
ssScrollMinOnFail
g
. (sssSections %~ fmap (ssItems %~ IM.filter _siIsSelectable))
ssScrollMinOnFail ::
( Int ->
Int ->
SelectionSections a ->
Maybe (Int, Int, SelectionItem a)
) ->
(Int -> Int -> SelectionSections a -> Maybe (Int, Int, SelectionItem a)) ->
SelectionSections a ->
Maybe (Int, Int) ->
Maybe (Int, Int)
@@ -66,8 +64,8 @@ ssScrollMinOnFail f sss msel = fmap (\(i, j, _) -> (i, j)) $ l <|> ssLookupMin s
ssSetCursor ::
(SelectionSections a -> Maybe (Int, Int, SelectionItem a)) ->
SelectionSections a ->
Maybe (Int,Int) ->
Maybe (Int,Int)
Maybe (Int, Int) ->
Maybe (Int, Int)
ssSetCursor f sss msel = fromMaybe msel $ do
(i, j, _) <- f sss
return $ Just (i, j)
@@ -205,7 +203,7 @@ inverseSelBoundaryUp cfig ldp sss (V2 _ y) = do
let mselup = inverseSelSecYint (posSelSecYint cfig ldp y - 1) sss
if Just sel == mselup
then return $ sel & _2 +~ 1
else return $ sel
else return sel
inverseSelBoundaryDown ::
Configuration ->
src/Dodge/Update.hs
+2 -2
View File
@@ -363,7 +363,7 @@ shiftInvItemsUp :: (Int, Int) -> Int -> World -> World
shiftInvItemsUp (_, i) x w = foldl' f w [i .. i + x]
where
f w' i' = swapInvItems g i' w'
g i' m = fmap fst $ IM.lookupLT i' m
g i' m = fst <$> IM.lookupLT i' m
shiftInvItemsDown :: (Int, Int) -> Int -> World -> World
shiftInvItemsDown (_, i) x w = fromMaybe w $ do
@@ -372,7 +372,7 @@ shiftInvItemsDown (_, i) x w = fromMaybe w $ do
return $ foldl' f w $ reverse [i .. i + x]
where
f w' i' = swapInvItems g i' w'
g i' m = fmap fst $ IM.lookupGT i' m
g i' m = fst <$> IM.lookupGT i' m
updateMouseOverInventory :: Configuration -> World -> World
updateMouseOverInventory cfig w = fromMaybe w $ do
src/Dodge/Update/Input/InGame.hs
+2 -4
View File
@@ -2,6 +2,7 @@ module Dodge.Update.Input.InGame (
updateUseInputInGame,
) where
import Control.Applicative
import qualified Data.IntMap.Strict as IM
import Data.List (sort)
import qualified Data.Map.Strict as M
@@ -236,10 +237,7 @@ updateEnterRegex w = case w ^? hud . hudElement . subInventory of
secfocus a b = fromMaybe False $ do
i <- di ^? diSelection . _Just . _1
return $ i == a || i == b
enterregex x sss =
sss & sssExtra . sssFilters . ix x %~ f
f Nothing = Just ""
f x = x
enterregex x = sssExtra . sssFilters . ix x %~ (<|> Just "")
pauseGame :: Universe -> Universe
pauseGame u = u & uvScreenLayers .~ [pauseMenu u]
src/IntMapHelp.hs
+2 -4
View File
@@ -15,10 +15,8 @@ module IntMapHelp
unsafeSwapKeys,
safeSwapKeys,
findIndex,
cycleGT,
cycleLT,
invertIntMap,
) where
@@ -99,7 +97,7 @@ cycleLT :: Int -> IntMap a -> Maybe (Int, a)
cycleLT i m = lookupLT i m <|> lookupMax m
invertIntMap :: Ord a => IntMap a -> M.Map a [Int]
invertIntMap = foldrWithKey
invertIntMap =
foldrWithKey
(\k xs -> M.insertWith (++) xs [k])
mempty
src/Regex.hs
-8
View File
@@ -1,8 +0,0 @@
module Regex where
import Data.List
regexIn :: String -> String -> Bool
regexIn = isInfixOf
regexList :: String -> [String] -> Bool
regexList x = any (isInfixOf x)