diff --git a/src/Dodge/Data/DoubleTree.hs b/src/Dodge/Data/DoubleTree.hs index 764600aaf..eabb9c3dd 100644 --- a/src/Dodge/Data/DoubleTree.hs +++ b/src/Dodge/Data/DoubleTree.hs @@ -36,30 +36,30 @@ data LDTree b a = LDT -- LabelDoubleTree } deriving (Eq, Ord, Show, Read) --- I am not sure about the double use of records here -data ContextLDT b a - = TopLDT - | LeftwardLDT - { _cldtUp :: ContextLDT b a - , _cldtCloseLeft :: [(b, LDTree b a)] - , _cldtParent :: a - , _cldtLink :: b - , _cldtCloseRight :: [(b, LDTree b a)] - , _cldtFarRight :: [(b, LDTree b a)] - } - | RightwardLDT - { _cldtUp :: ContextLDT b a - , _cldtFarLeft :: [(b, LDTree b a)] - , _cldtCloseLeft :: [(b, LDTree b a)] - , _cldtParent :: a - , _cldtLink :: b - , _cldtCloseRight :: [(b, LDTree b a)] - } +---- I am not sure about the double use of records here +--data ContextLDT b a +-- = TopLDT +-- | LeftwardLDT +-- { _cldtUp :: ContextLDT b a +-- , _cldtCloseLeft :: [(b, LDTree b a)] +-- , _cldtParent :: a +-- , _cldtLink :: b +-- , _cldtCloseRight :: [(b, LDTree b a)] +-- , _cldtFarRight :: [(b, LDTree b a)] +-- } +-- | RightwardLDT +-- { _cldtUp :: ContextLDT b a +-- , _cldtFarLeft :: [(b, LDTree b a)] +-- , _cldtCloseLeft :: [(b, LDTree b a)] +-- , _cldtParent :: a +-- , _cldtLink :: b +-- , _cldtCloseRight :: [(b, LDTree b a)] +-- } -data LocationLDT b a = LocLDT - { _locLdtContext :: ContextLDT b a - , _locLDT :: LDTree b a - } +--data LocationLDT b a = LocLDT +-- { _locLdtContext :: ContextLDT b a +-- , _locLDT :: LDTree b a +-- } instance Functor DTree where 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 ''LDTree -makeLenses ''LocationLDT -makeLenses ''ContextLDT +--makeLenses ''LDTree +--makeLenses ''LocationLDT +--makeLenses ''ContextLDT makeLenses ''LocationDT makeLenses ''ContextDT -instance Functor (LocationLDT b) where - fmap f (LocLDT c t) = LocLDT (fmap f c) (fmap f t) +--instance Functor (LocationLDT b) where +-- fmap f (LocLDT c t) = LocLDT (fmap f c) (fmap f t) instance Functor LocationDT where fmap f (LocDT c t) = LocDT (fmap f c) (fmap f t) -instance Functor (ContextLDT b) where - fmap f = \case - TopLDT -> TopLDT - LeftwardLDT u cl p l cr fr -> LeftwardLDT - (fmap f u) - (fmap (fmap (fmap f)) cl) - (f p) - l - (fmap (fmap (fmap f)) cr) - (fmap (fmap (fmap f)) fr) - RightwardLDT u fl cl p l cr -> RightwardLDT (fmap f u) - (fmap (fmap (fmap f)) fl) - (fmap (fmap (fmap f)) cl) - (f p) - l - (fmap (fmap (fmap f)) cr) +--instance Functor (ContextLDT b) where +-- fmap f = \case +-- TopLDT -> TopLDT +-- LeftwardLDT u cl p l cr fr -> LeftwardLDT +-- (fmap f u) +-- (fmap (fmap (fmap f)) cl) +-- (f p) +-- l +-- (fmap (fmap (fmap f)) cr) +-- (fmap (fmap (fmap f)) fr) +-- RightwardLDT u fl cl p l cr -> RightwardLDT (fmap f u) +-- (fmap (fmap (fmap f)) fl) +-- (fmap (fmap (fmap f)) cl) +-- (f p) +-- l +-- (fmap (fmap (fmap f)) cr) instance Functor ContextDT where fmap f = \case diff --git a/src/Dodge/DoubleTree.hs b/src/Dodge/DoubleTree.hs index aa1ab6e49..4be3ec3c2 100644 --- a/src/Dodge/DoubleTree.hs +++ b/src/Dodge/DoubleTree.hs @@ -16,24 +16,24 @@ singleLDT x = LDT x [] [] ldtToDT :: LDTree b a -> DTree a ldtToDT (LDT x l r) = DT x (map (ldtToDT . snd) l) (map (ldtToDT . snd) r) -locLDTToLocDT :: LocationLDT b a -> LocationDT a -locLDTToLocDT (LocLDT con t) = LocDT (conLDTToConDT con) (ldtToDT t) +--locLDTToLocDT :: LocationLDT b a -> LocationDT a +--locLDTToLocDT (LocLDT con t) = LocDT (conLDTToConDT con) (ldtToDT t) -conLDTToConDT :: ContextLDT b a -> ContextDT a -conLDTToConDT = \case - TopLDT -> TopDT - LeftwardLDT u cl p _ cr fr -> LeftwardDT - (conLDTToConDT u) - (map (ldtToDT . snd) cl) - p - (map (ldtToDT . snd) cr) - (map (ldtToDT . snd) fr) - RightwardLDT u fl cl p _ cr -> RightwardDT - (conLDTToConDT u) - (map (ldtToDT . snd) fl) - (map (ldtToDT . snd) cl) - p - (map (ldtToDT . snd) cr) +--conLDTToConDT :: ContextLDT b a -> ContextDT a +--conLDTToConDT = \case +-- TopLDT -> TopDT +-- LeftwardLDT u cl p _ cr fr -> LeftwardDT +-- (conLDTToConDT u) +-- (map (ldtToDT . snd) cl) +-- p +-- (map (ldtToDT . snd) cr) +-- (map (ldtToDT . snd) fr) +-- RightwardLDT u fl cl p _ cr -> RightwardDT +-- (conLDTToConDT u) +-- (map (ldtToDT . snd) fl) +-- (map (ldtToDT . snd) cl) +-- p +-- (map (ldtToDT . snd) cr) dtStartPropagate :: (a -> c) -> (c -> a -> c) -> DTree a -> DTree c 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 ++ (f x : concatMap (map ('\\' :) . prettyLDT f . snd) l) -ldtToLoc :: LDTree b a -> LocationLDT b a -ldtToLoc = LocLDT TopLDT +--ldtToLoc :: LDTree b a -> LocationLDT b a +--ldtToLoc = LocLDT TopLDT --- should probably do tests for these -locUp :: LocationLDT b a -> Maybe (LocationLDT b a) -locUp (LocLDT TopLDT _) = Nothing -locUp (LocLDT c@LeftwardLDT{} t) = - Just $ - LocLDT - (_cldtUp c) - (LDT (_cldtParent c) (_cldtCloseLeft c ++ ((_cldtLink c, t) : _cldtCloseRight c)) (_cldtFarRight c)) -locUp (LocLDT c@RightwardLDT{} t) = - Just $ - LocLDT - (_cldtUp c) - (LDT (_cldtParent c) (_cldtFarLeft c) (_cldtCloseLeft c ++ ((_cldtLink c, t) : _cldtCloseRight c))) +---- should probably do tests for these +--locUp :: LocationLDT b a -> Maybe (LocationLDT b a) +--locUp (LocLDT TopLDT _) = Nothing +--locUp (LocLDT c@LeftwardLDT{} t) = +-- Just $ +-- LocLDT +-- (_cldtUp c) +-- (LDT (_cldtParent c) (_cldtCloseLeft c ++ ((_cldtLink c, t) : _cldtCloseRight c)) (_cldtFarRight c)) +--locUp (LocLDT c@RightwardLDT{} t) = +-- Just $ +-- LocLDT +-- (_cldtUp c) +-- (LDT (_cldtParent c) (_cldtFarLeft c) (_cldtCloseLeft c ++ ((_cldtLink c, t) : _cldtCloseRight c))) --locToTop :: LocationLDT b a -> LocationLDT b a --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 -locLeftmost :: LocationLDT b a -> LocationLDT b a -locLeftmost loc = maybe loc locLeftmost $ alaf First foldMap Just $ locGoLeft loc +--locLeftmost :: LocationLDT b a -> LocationLDT b a +--locLeftmost loc = maybe loc locLeftmost $ alaf First foldMap Just $ locGoLeft loc -locRightmost :: LocationLDT b a -> LocationLDT b a -locRightmost loc = maybe loc locRightmost $ alaf Last foldMap Just $ locGoRight loc +--locRightmost :: LocationLDT b a -> LocationLDT b a +--locRightmost loc = maybe loc locRightmost $ alaf Last foldMap Just $ locGoRight loc locDTLeftmost :: LocationDT a -> LocationDT a 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 loc = maybe loc locDTRightmost $ alaf Last foldMap Just $ locDTGoRight loc --- should probably do tests for these -locGoLeft :: LocationLDT b a -> [LocationLDT b a] -locGoLeft (LocLDT c (LDT v l r)) = - [LocLDT (LeftwardLDT c closel v link closer r) t | (closel, (link, t), closer) <- locGoHelp id l] +---- should probably do tests for these +--locGoLeft :: LocationLDT b a -> [LocationLDT b a] +--locGoLeft (LocLDT c (LDT v l r)) = +-- [LocLDT (LeftwardLDT c closel v link closer r) t | (closel, (link, t), closer) <- locGoHelp id l] --- should probably do tests for these -locGoRight :: LocationLDT b a -> [LocationLDT b a] -locGoRight (LocLDT c (LDT v l r)) = - [LocLDT (RightwardLDT c l closel v link closer) t | (closel, (link, t), closer) <- locGoHelp id r] +---- should probably do tests for these +--locGoRight :: LocationLDT b a -> [LocationLDT b a] +--locGoRight (LocLDT c (LDT v l r)) = +-- [LocLDT (RightwardLDT c l closel v link closer) t | (closel, (link, t), closer) <- locGoHelp id r] -- should probably do tests for these 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 _ [] = [] --- 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), --- 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). -cldtPropagateFold :: - (c -> a -> b -> a -> c) -> - (c -> a -> b -> a -> c) -> - (c -> LocationLDT b a -> d -> d) -> - c -> - LocationLDT b a -> - d -> - d -cldtPropagateFold lf rf up x loc = - alaf - Endo - foldMap - ( \(LocLDT con' t') -> - cldtPropagateFold - lf - rf - up - (lf x (_cldtParent con') (_cldtLink con') (_ldtValue t')) - (LocLDT con' t') - ) - (locGoLeft loc) - . alaf - Endo - foldMap - ( \(LocLDT con' t') -> - cldtPropagateFold - lf - rf - up - (rf x (_cldtParent con') (_cldtLink con') (_ldtValue t')) - (LocLDT con' t') - ) - (locGoRight loc) - . up x loc +---- 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), +---- 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). +--cldtPropagateFold :: +-- (c -> a -> b -> a -> c) -> +-- (c -> a -> b -> a -> c) -> +-- (c -> LocationLDT b a -> d -> d) -> +-- c -> +-- LocationLDT b a -> +-- d -> +-- d +--cldtPropagateFold lf rf up x loc = +-- alaf +-- Endo +-- foldMap +-- ( \(LocLDT con' t') -> +-- cldtPropagateFold +-- lf +-- rf +-- up +-- (lf x (_cldtParent con') (_cldtLink con') (_ldtValue t')) +-- (LocLDT con' t') +-- ) +-- (locGoLeft loc) +-- . alaf +-- Endo +-- foldMap +-- ( \(LocLDT con' t') -> +-- cldtPropagateFold +-- lf +-- rf +-- up +-- (rf x (_cldtParent con') (_cldtLink con') (_ldtValue t')) +-- (LocLDT con' t') +-- ) +-- (locGoRight loc) +-- . up x loc -reduceLocLDT :: Monoid m => (LocationLDT b a -> m) -> LocationLDT b a -> m -reduceLocLDT f x = - foldMap (reduceLocLDT f) (locGoLeft x) <> f x - <> foldMap (reduceLocLDT f) (locGoRight x) +--reduceLocLDT :: Monoid m => (LocationLDT b a -> m) -> LocationLDT b a -> m +--reduceLocLDT f x = +-- foldMap (reduceLocLDT f) (locGoLeft x) <> f x +-- <> foldMap (reduceLocLDT f) (locGoRight x) reduceLocDT :: Monoid m => (LocationDT a -> m) -> LocationDT a -> m reduceLocDT f x = diff --git a/src/Dodge/HeldUse.hs b/src/Dodge/HeldUse.hs index 51bd9b677..dc606fbe2 100644 --- a/src/Dodge/HeldUse.hs +++ b/src/Dodge/HeldUse.hs @@ -256,7 +256,8 @@ heldItemMuzzles loc = \case 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)] 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 FLAMETHROWER -> flameMuzzles FLAMESPITTER -> flameMuzzles & ix 0 . mzEffect . nzPressure .~ UniRandFloat 3 4