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

Comment out LDTs

Browse Source
This commit is contained in:
justin
2026-03-17 15:31:24 +00:00
parent 4cacb45252
commit 96c2fb00e1
3 changed files with 132 additions and 131 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/DoubleTree.hs
+44 -44
View File
@@ -36,30 +36,30 @@ data LDTree b a = LDT -- LabelDoubleTree
} }
deriving (Eq, Ord, Show, Read) deriving (Eq, Ord, Show, Read)
-- I am not sure about the double use of records here ---- I am not sure about the double use of records here
data ContextLDT b a --data ContextLDT b a
= TopLDT -- = TopLDT
| LeftwardLDT -- | LeftwardLDT
{ _cldtUp :: ContextLDT b a -- { _cldtUp :: ContextLDT b a
, _cldtCloseLeft :: [(b, LDTree b a)] -- , _cldtCloseLeft :: [(b, LDTree b a)]
, _cldtParent :: a -- , _cldtParent :: a
, _cldtLink :: b -- , _cldtLink :: b
, _cldtCloseRight :: [(b, LDTree b a)] -- , _cldtCloseRight :: [(b, LDTree b a)]
, _cldtFarRight :: [(b, LDTree b a)] -- , _cldtFarRight :: [(b, LDTree b a)]
} -- }
| RightwardLDT -- | RightwardLDT
{ _cldtUp :: ContextLDT b a -- { _cldtUp :: ContextLDT b a
, _cldtFarLeft :: [(b, LDTree b a)] -- , _cldtFarLeft :: [(b, LDTree b a)]
, _cldtCloseLeft :: [(b, LDTree b a)] -- , _cldtCloseLeft :: [(b, LDTree b a)]
, _cldtParent :: a -- , _cldtParent :: a
, _cldtLink :: b -- , _cldtLink :: b
, _cldtCloseRight :: [(b, LDTree b a)] -- , _cldtCloseRight :: [(b, LDTree b a)]
} -- }
data LocationLDT b a = LocLDT --data LocationLDT b a = LocLDT
{ _locLdtContext :: ContextLDT b a -- { _locLdtContext :: ContextLDT b a
, _locLDT :: LDTree b a -- , _locLDT :: LDTree b a
} -- }
instance Functor DTree where instance Functor DTree where
fmap f (DT x l r) = DT (f x) (fmap (fmap f) l) (fmap (fmap f) r) fmap f (DT x l r) = DT (f x) (fmap (fmap f) l) (fmap (fmap f) r)
@@ -102,34 +102,34 @@ data LocationDT a = LocDT
} }
makeLenses ''DTree makeLenses ''DTree
makeLenses ''LDTree --makeLenses ''LDTree
makeLenses ''LocationLDT --makeLenses ''LocationLDT
makeLenses ''ContextLDT --makeLenses ''ContextLDT
makeLenses ''LocationDT makeLenses ''LocationDT
makeLenses ''ContextDT makeLenses ''ContextDT
instance Functor (LocationLDT b) where --instance Functor (LocationLDT b) where
fmap f (LocLDT c t) = LocLDT (fmap f c) (fmap f t) -- fmap f (LocLDT c t) = LocLDT (fmap f c) (fmap f t)
instance Functor LocationDT where instance Functor LocationDT where
fmap f (LocDT c t) = LocDT (fmap f c) (fmap f t) fmap f (LocDT c t) = LocDT (fmap f c) (fmap f t)
instance Functor (ContextLDT b) where --instance Functor (ContextLDT b) where
fmap f = \case -- fmap f = \case
TopLDT -> TopLDT -- TopLDT -> TopLDT
LeftwardLDT u cl p l cr fr -> LeftwardLDT -- LeftwardLDT u cl p l cr fr -> LeftwardLDT
(fmap f u) -- (fmap f u)
(fmap (fmap (fmap f)) cl) -- (fmap (fmap (fmap f)) cl)
(f p) -- (f p)
l -- l
(fmap (fmap (fmap f)) cr) -- (fmap (fmap (fmap f)) cr)
(fmap (fmap (fmap f)) fr) -- (fmap (fmap (fmap f)) fr)
RightwardLDT u fl cl p l cr -> RightwardLDT (fmap f u) -- RightwardLDT u fl cl p l cr -> RightwardLDT (fmap f u)
(fmap (fmap (fmap f)) fl) -- (fmap (fmap (fmap f)) fl)
(fmap (fmap (fmap f)) cl) -- (fmap (fmap (fmap f)) cl)
(f p) -- (f p)
l -- l
(fmap (fmap (fmap f)) cr) -- (fmap (fmap (fmap f)) cr)
instance Functor ContextDT where instance Functor ContextDT where
fmap f = \case fmap f = \case
src/Dodge/DoubleTree.hs
+86 -86
View File
@@ -16,24 +16,24 @@ singleLDT x = LDT x [] []
ldtToDT :: LDTree b a -> DTree a ldtToDT :: LDTree b a -> DTree a
ldtToDT (LDT x l r) = DT x (map (ldtToDT . snd) l) (map (ldtToDT . snd) r) ldtToDT (LDT x l r) = DT x (map (ldtToDT . snd) l) (map (ldtToDT . snd) r)
locLDTToLocDT :: LocationLDT b a -> LocationDT a --locLDTToLocDT :: LocationLDT b a -> LocationDT a
locLDTToLocDT (LocLDT con t) = LocDT (conLDTToConDT con) (ldtToDT t) --locLDTToLocDT (LocLDT con t) = LocDT (conLDTToConDT con) (ldtToDT t)
conLDTToConDT :: ContextLDT b a -> ContextDT a --conLDTToConDT :: ContextLDT b a -> ContextDT a
conLDTToConDT = \case --conLDTToConDT = \case
TopLDT -> TopDT -- TopLDT -> TopDT
LeftwardLDT u cl p _ cr fr -> LeftwardDT -- LeftwardLDT u cl p _ cr fr -> LeftwardDT
(conLDTToConDT u) -- (conLDTToConDT u)
(map (ldtToDT . snd) cl) -- (map (ldtToDT . snd) cl)
p -- p
(map (ldtToDT . snd) cr) -- (map (ldtToDT . snd) cr)
(map (ldtToDT . snd) fr) -- (map (ldtToDT . snd) fr)
RightwardLDT u fl cl p _ cr -> RightwardDT -- RightwardLDT u fl cl p _ cr -> RightwardDT
(conLDTToConDT u) -- (conLDTToConDT u)
(map (ldtToDT . snd) fl) -- (map (ldtToDT . snd) fl)
(map (ldtToDT . snd) cl) -- (map (ldtToDT . snd) cl)
p -- p
(map (ldtToDT . snd) cr) -- (map (ldtToDT . snd) cr)
dtStartPropagate :: (a -> c) -> (c -> a -> c) -> DTree a -> DTree c dtStartPropagate :: (a -> c) -> (c -> a -> c) -> DTree a -> DTree c
dtStartPropagate g f (DT x l r) = DT z dtStartPropagate g f (DT x l r) = DT z
@@ -265,22 +265,22 @@ prettyLDT f (LDT x l r) =
concatMap (map ('/' :) . prettyLDT f . snd) r concatMap (map ('/' :) . prettyLDT f . snd) r
++ (f x : concatMap (map ('\\' :) . prettyLDT f . snd) l) ++ (f x : concatMap (map ('\\' :) . prettyLDT f . snd) l)
ldtToLoc :: LDTree b a -> LocationLDT b a --ldtToLoc :: LDTree b a -> LocationLDT b a
ldtToLoc = LocLDT TopLDT --ldtToLoc = LocLDT TopLDT
-- should probably do tests for these ---- should probably do tests for these
locUp :: LocationLDT b a -> Maybe (LocationLDT b a) --locUp :: LocationLDT b a -> Maybe (LocationLDT b a)
locUp (LocLDT TopLDT _) = Nothing --locUp (LocLDT TopLDT _) = Nothing
locUp (LocLDT c@LeftwardLDT{} t) = --locUp (LocLDT c@LeftwardLDT{} t) =
Just $ -- Just $
LocLDT -- LocLDT
(_cldtUp c) -- (_cldtUp c)
(LDT (_cldtParent c) (_cldtCloseLeft c ++ ((_cldtLink c, t) : _cldtCloseRight c)) (_cldtFarRight c)) -- (LDT (_cldtParent c) (_cldtCloseLeft c ++ ((_cldtLink c, t) : _cldtCloseRight c)) (_cldtFarRight c))
locUp (LocLDT c@RightwardLDT{} t) = --locUp (LocLDT c@RightwardLDT{} t) =
Just $ -- Just $
LocLDT -- LocLDT
(_cldtUp c) -- (_cldtUp c)
(LDT (_cldtParent c) (_cldtFarLeft c) (_cldtCloseLeft c ++ ((_cldtLink c, t) : _cldtCloseRight c))) -- (LDT (_cldtParent c) (_cldtFarLeft c) (_cldtCloseLeft c ++ ((_cldtLink c, t) : _cldtCloseRight c)))
--locToTop :: LocationLDT b a -> LocationLDT b a --locToTop :: LocationLDT b a -> LocationLDT b a
--locToTop loc = maybe loc locToTop $ locUp loc --locToTop loc = maybe loc locToTop $ locUp loc
@@ -303,11 +303,11 @@ locToTop loc = maybe loc locToTop $ locUp' loc
--locToTop = fix $ \x -> fromMaybe x $ locUp x --locToTop = fix $ \x -> fromMaybe x $ locUp x
locLeftmost :: LocationLDT b a -> LocationLDT b a --locLeftmost :: LocationLDT b a -> LocationLDT b a
locLeftmost loc = maybe loc locLeftmost $ alaf First foldMap Just $ locGoLeft loc --locLeftmost loc = maybe loc locLeftmost $ alaf First foldMap Just $ locGoLeft loc
locRightmost :: LocationLDT b a -> LocationLDT b a --locRightmost :: LocationLDT b a -> LocationLDT b a
locRightmost loc = maybe loc locRightmost $ alaf Last foldMap Just $ locGoRight loc --locRightmost loc = maybe loc locRightmost $ alaf Last foldMap Just $ locGoRight loc
locDTLeftmost :: LocationDT a -> LocationDT a locDTLeftmost :: LocationDT a -> LocationDT a
locDTLeftmost loc = maybe loc locDTLeftmost $ alaf First foldMap Just $ locDTGoLeft loc locDTLeftmost loc = maybe loc locDTLeftmost $ alaf First foldMap Just $ locDTGoLeft loc
@@ -315,15 +315,15 @@ locDTLeftmost loc = maybe loc locDTLeftmost $ alaf First foldMap Just $ locDTGoL
locDTRightmost :: LocationDT a -> LocationDT a locDTRightmost :: LocationDT a -> LocationDT a
locDTRightmost loc = maybe loc locDTRightmost $ alaf Last foldMap Just $ locDTGoRight loc locDTRightmost loc = maybe loc locDTRightmost $ alaf Last foldMap Just $ locDTGoRight loc
-- should probably do tests for these ---- should probably do tests for these
locGoLeft :: LocationLDT b a -> [LocationLDT b a] --locGoLeft :: LocationLDT b a -> [LocationLDT b a]
locGoLeft (LocLDT c (LDT v l r)) = --locGoLeft (LocLDT c (LDT v l r)) =
[LocLDT (LeftwardLDT c closel v link closer r) t | (closel, (link, t), closer) <- locGoHelp id l] -- [LocLDT (LeftwardLDT c closel v link closer r) t | (closel, (link, t), closer) <- locGoHelp id l]
-- should probably do tests for these ---- should probably do tests for these
locGoRight :: LocationLDT b a -> [LocationLDT b a] --locGoRight :: LocationLDT b a -> [LocationLDT b a]
locGoRight (LocLDT c (LDT v l r)) = --locGoRight (LocLDT c (LDT v l r)) =
[LocLDT (RightwardLDT c l closel v link closer) t | (closel, (link, t), closer) <- locGoHelp id r] -- [LocLDT (RightwardLDT c l closel v link closer) t | (closel, (link, t), closer) <- locGoHelp id r]
-- should probably do tests for these -- should probably do tests for these
locDTGoLeft :: LocationDT a -> [LocationDT a] locDTGoLeft :: LocationDT a -> [LocationDT a]
@@ -351,49 +351,49 @@ locDTGoHelp f = go []
go cleft (y : ys) = (cleft, f y, ys) : go (cleft <> [y]) ys go cleft (y : ys) = (cleft, f y, ys) : go (cleft <> [y]) ys
go _ [] = [] go _ [] = []
-- Propgates a value (of type c) down the branches of the ContextLDT. ---- Propgates a value (of type c) down the branches of the ContextLDT.
-- The value is updated according a "left" or "right" function (lf or rf), ---- The value is updated according a "left" or "right" function (lf or rf),
-- that acts on the parent value, the link, and the child value. ---- that acts on the parent value, the link, and the child value.
-- For each context node, the updated value is used to update a final value (of type d). ---- For each context node, the updated value is used to update a final value (of type d).
cldtPropagateFold :: --cldtPropagateFold ::
(c -> a -> b -> a -> c) -> -- (c -> a -> b -> a -> c) ->
(c -> a -> b -> a -> c) -> -- (c -> a -> b -> a -> c) ->
(c -> LocationLDT b a -> d -> d) -> -- (c -> LocationLDT b a -> d -> d) ->
c -> -- c ->
LocationLDT b a -> -- LocationLDT b a ->
d -> -- d ->
d -- d
cldtPropagateFold lf rf up x loc = --cldtPropagateFold lf rf up x loc =
alaf -- alaf
Endo -- Endo
foldMap -- foldMap
( \(LocLDT con' t') -> -- ( \(LocLDT con' t') ->
cldtPropagateFold -- cldtPropagateFold
lf -- lf
rf -- rf
up -- up
(lf x (_cldtParent con') (_cldtLink con') (_ldtValue t')) -- (lf x (_cldtParent con') (_cldtLink con') (_ldtValue t'))
(LocLDT con' t') -- (LocLDT con' t')
) -- )
(locGoLeft loc) -- (locGoLeft loc)
. alaf -- . alaf
Endo -- Endo
foldMap -- foldMap
( \(LocLDT con' t') -> -- ( \(LocLDT con' t') ->
cldtPropagateFold -- cldtPropagateFold
lf -- lf
rf -- rf
up -- up
(rf x (_cldtParent con') (_cldtLink con') (_ldtValue t')) -- (rf x (_cldtParent con') (_cldtLink con') (_ldtValue t'))
(LocLDT con' t') -- (LocLDT con' t')
) -- )
(locGoRight loc) -- (locGoRight loc)
. up x loc -- . up x loc
reduceLocLDT :: Monoid m => (LocationLDT b a -> m) -> LocationLDT b a -> m --reduceLocLDT :: Monoid m => (LocationLDT b a -> m) -> LocationLDT b a -> m
reduceLocLDT f x = --reduceLocLDT f x =
foldMap (reduceLocLDT f) (locGoLeft x) <> f x -- foldMap (reduceLocLDT f) (locGoLeft x) <> f x
<> foldMap (reduceLocLDT f) (locGoRight x) -- <> foldMap (reduceLocLDT f) (locGoRight x)
reduceLocDT :: Monoid m => (LocationDT a -> m) -> LocationDT a -> m reduceLocDT :: Monoid m => (LocationDT a -> m) -> LocationDT a -> m
reduceLocDT f x = reduceLocDT f x =
src/Dodge/HeldUse.hs
+2 -1
View File
@@ -256,7 +256,8 @@ heldItemMuzzles loc = \case
BLUNDERBUSS -> [Muzzle (V2 30 0) 0 0.5 magupto15 BasicFlare MuzzleShootBullet 12] BLUNDERBUSS -> [Muzzle (V2 30 0) 0 0.5 magupto15 BasicFlare MuzzleShootBullet 12]
GRAPECANNON i -> [Muzzle (V2 30 0) 0 0.5 magupto15 BasicFlare MuzzleShootBullet (12 + 4 * fromIntegral i)] GRAPECANNON i -> [Muzzle (V2 30 0) 0 0.5 magupto15 BasicFlare MuzzleShootBullet (12 + 4 * fromIntegral i)]
LED -> dbwMuzzles & ix 0 . mzPos .~ V2 10 0 LED -> dbwMuzzles & ix 0 . mzPos .~ V2 10 0
FLAMETHROWER | Just PumpSF <- loc ^? locDT. dtRight . ix 0 . dtValue ._2 -- don't care where the pump is, but possibly should know this
FLAMETHROWER | any (\dt -> Just PumpSF == dt ^? dtValue . _2) (loc ^. locDT . dtRight)
-> flameMuzzles & ix 0 . mzEffect . nzPressure .~ UniRandFloat 2 8 -> flameMuzzles & ix 0 . mzEffect . nzPressure .~ UniRandFloat 2 8
FLAMETHROWER -> flameMuzzles FLAMETHROWER -> flameMuzzles
FLAMESPITTER -> flameMuzzles & ix 0 . mzEffect . nzPressure .~ UniRandFloat 3 4 FLAMESPITTER -> flameMuzzles & ix 0 . mzEffect . nzPressure .~ UniRandFloat 3 4