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

Use function on location to determine laser orientation

Browse Source
This commit is contained in:
justin
2025-06-27 10:42:23 +01:00
parent dd5a747559
commit be6ea59d1e
5 changed files with 478 additions and 324 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/DoubleTree.hs
+177 -129
View File
@@ -1,10 +1,10 @@
module Dodge.DoubleTree where
import Dodge.Data.DoubleTree
import qualified Data.IntMap.Strict as IM
import Control.Lens
import Data.Bifunctor
import qualified Data.IntMap.Strict as IM
import Data.Monoid
import Dodge.Data.DoubleTree
singleDT :: a -> DoubleTree a
singleDT x = DT x [] []
@@ -17,172 +17,203 @@ ldtToDT (LDT x l r) = DT x (map (ldtToDT . snd) l) (map (ldtToDT . snd) r)
-- propagate two functions down the links of an LDT tree
-- which function is chosen depends on whether it is a left or right branch
ldtPropagate :: (c -> b -> c) -> (c -> b -> c)
-> c
-> LDTree b a -> LDTree c a
ldtPropagate ::
(c -> b -> c) ->
(c -> b -> c) ->
c ->
LDTree b a ->
LDTree c a
ldtPropagate lf rf = ildtPropagate (const lf) (const rf)
-- Propgates a value (of type c) down the branches of the LDT.
-- 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 node, the updated value is used to update a final value (of type d).
ldtPropagateFold :: (c -> a -> b -> a -> c)
-> (c -> a -> b -> a -> c)
-> (c -> a -> d -> d)
-> c
-> LDTree b a
-> d
-> d
ldtPropagateFold lf rf up x (LDT v l r) =
alaf Endo foldMap (\(s,y) -> ldtPropagateFold lf rf up (rf x v s (_ldtValue y)) y) r
. alaf Endo foldMap (\(s,y) -> ldtPropagateFold lf rf up (lf x v s (_ldtValue y)) y) l
. up x v
ldtPropagateFold ::
(c -> a -> b -> a -> c) ->
(c -> a -> b -> a -> c) ->
(c -> a -> d -> d) ->
c ->
LDTree b a ->
d ->
d
ldtPropagateFold lf rf up x (LDT v l r) =
alaf Endo foldMap (\(s, y) -> ldtPropagateFold lf rf up (rf x v s (_ldtValue y)) y) r
. alaf Endo foldMap (\(s, y) -> ldtPropagateFold lf rf up (lf x v s (_ldtValue y)) y) l
. up x v
-- Propgates a value (of type c) down the branches of the LDT.
-- 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 node-tree, the updated value is used to update a final value (of type d).
ldtPropagateFoldTree :: (c -> a -> b -> a -> c)
-> (c -> a -> b -> a -> c)
-> (c -> LDTree b a -> d -> d)
-> c
-> LDTree b a
-> d
-> d
ldtPropagateFoldTree lf rf up x t@(LDT v l r) =
alaf Endo foldMap (\(s,y) -> ldtPropagateFoldTree lf rf up (rf x v s (_ldtValue y)) y) r
. alaf Endo foldMap (\(s,y) -> ldtPropagateFoldTree lf rf up (lf x v s (_ldtValue y)) y) l
. up x t
ldtPropagateFoldTree ::
(c -> a -> b -> a -> c) ->
(c -> a -> b -> a -> c) ->
(c -> LDTree b a -> d -> d) ->
c ->
LDTree b a ->
d ->
d
ldtPropagateFoldTree lf rf up x t@(LDT v l r) =
alaf Endo foldMap (\(s, y) -> ldtPropagateFoldTree lf rf up (rf x v s (_ldtValue y)) y) r
. alaf Endo foldMap (\(s, y) -> ldtPropagateFoldTree lf rf up (lf x v s (_ldtValue y)) y) l
. up x t
ildtPropagate :: (Int -> c -> b -> c) -> (Int -> c -> b -> c)
-> c
-> LDTree b a -> LDTree c a
ildtPropagate ::
(Int -> c -> b -> c) ->
(Int -> c -> b -> c) ->
c ->
LDTree b a ->
LDTree c a
ildtPropagate lf rf x (LDT v l r) = LDT v (imap (go lf x) l) (imap (go rf x) r)
where
go f y i (z,t) = (f i y z, ildtPropagate lf rf (f i y z) t)
go f y i (z, t) = (f i y z, ildtPropagate lf rf (f i y z) t)
ldtPropagateIndices :: LDTree b a -> LDTree b (a, [Either Int Int])
ldtPropagateIndices (LDT x l r) = LDT (x,[]) (imap (f Left) l) (imap (f Right) r)
ldtPropagateIndices (LDT x l r) = LDT (x, []) (imap (f Left) l) (imap (f Right) r)
where
f e i (y,t) = (y, 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,
-- conceptually, in a tree growing from left to right,
-- bottom -> top is equated with left -> right.
-- this does not match with thinking of a list as top -> bottom, so take care
doubleTreeToIndentList :: DoubleTree a -> [(a,Int,DoubleTreeNodeType)]
doubleTreeToIndentList :: DoubleTree a -> [(a, Int, DoubleTreeNodeType)]
doubleTreeToIndentList = dtIL DTRootNode
dtIL :: DoubleTreeNodeType -> DoubleTree a -> [(a,Int,DoubleTreeNodeType)]
dtIL nt (DT x l r) = map doindent (concat (headMap (dtIL DTBottomNode) (dtIL DTMidBelowNode) l))
++ [(x,0,nt)]
++ map doindent (concat (lastMap (dtIL DTTopNode) (dtIL DTMidAboveNode) r))
dtIL :: DoubleTreeNodeType -> DoubleTree a -> [(a, Int, DoubleTreeNodeType)]
dtIL nt (DT x l r) =
map doindent (concat (headMap (dtIL DTBottomNode) (dtIL DTMidBelowNode) l))
++ [(x, 0, nt)]
++ map doindent (concat (lastMap (dtIL DTTopNode) (dtIL DTMidAboveNode) r))
where
doindent (a,b,c) = (a,b+1,c)
doindent (a, b, c) = (a, b + 1, c)
dtToAdjacency :: (a -> Int) -> DoubleTree a -> IM.IntMap [Int]
dtToAdjacency f (DT x l r) = IM.insert (f x) (map g l <> map g r)
. IM.unions $ map (dtToAdjacency f) $ l <> r
where
dtToAdjacency f (DT x l r) =
IM.insert (f x) (map g l <> map g r)
. IM.unions
$ map (dtToAdjacency f) $ l <> r
where
g = f . _dtValue
dtToIntMapWithRoot :: (a -> Int) -> DoubleTree a -> IM.IntMap (Maybe Int, DoubleTree a)
dtToIntMapWithRoot f t@(DT x l r) = IM.insert (f x) (Nothing, t) $
foldMap (dtToRootIntMap' (f x) f) $ l <> r
dtToIntMapWithRoot f t@(DT x l r) =
IM.insert (f x) (Nothing, t) $
foldMap (dtToRootIntMap' (f x) f) $ l <> r
dtToRootIntMap' :: Int -> (a -> Int) -> DoubleTree a -> IM.IntMap (Maybe Int, DoubleTree a)
dtToRootIntMap' root f t@(DT x l r) = IM.insert (f x) (Just root, t) $
foldMap (dtToRootIntMap' root f) $ l <> r
dtToRootIntMap' root f t@(DT x l r) =
IM.insert (f x) (Just root, t) $
foldMap (dtToRootIntMap' root f) $ l <> r
dtToUpDownAdj :: (a -> Int) -> DoubleTree a -> IM.IntMap ([Int],[Int])
dtToUpDownAdj f (DT x l r) = IM.insert (f x) (map g l , map g r)
. IM.unions $ map (dtToUpDownAdj f) $ l <> r
where
dtToUpDownAdj :: (a -> Int) -> DoubleTree a -> IM.IntMap ([Int], [Int])
dtToUpDownAdj f (DT x l r) =
IM.insert (f x) (map g l, map g r)
. IM.unions
$ map (dtToUpDownAdj f) $ l <> r
where
g = f . _dtValue
-- returns an adjacency map with oldest ancestor and direct parent if they exist
-- and any left and right children
dtToLRAdj :: (a -> Int) -> DoubleTree a -> IM.IntMap (Maybe (Int,Int),[Int],[Int])
dtToLRAdj f (DT x l r) = IM.insert i (Nothing,map g l , map g r)
. IM.unions $ map (dtToAdjRootParent i i f) $ l <> r
where
dtToLRAdj :: (a -> Int) -> DoubleTree a -> IM.IntMap (Maybe (Int, Int), [Int], [Int])
dtToLRAdj f (DT x l r) =
IM.insert i (Nothing, map g l, map g r)
. IM.unions
$ map (dtToAdjRootParent i i f) $ l <> r
where
i = f x
g = f . _dtValue
-- returns an adjacency map with oldest ancestor and direct parent if they exist
-- and any left and right children
-- allows to propagate failure in the index discovery
dtToLRAdjEither :: (a -> Either String Int) -> DoubleTree a
-> Either String (IM.IntMap (Maybe (Int,Int),[Int],[Int]))
dtToLRAdjEither ::
(a -> Either String Int) ->
DoubleTree a ->
Either String (IM.IntMap (Maybe (Int, Int), [Int], [Int]))
dtToLRAdjEither f (DT x l r) = do
i <- f x
l' <- mapM g l
r' <- mapM g r
childrenasnodes <- mapM (dtToAdjRootParentEither i i f) $ l <> r
return $ IM.insert i (Nothing,l' , r')
$ IM.unions childrenasnodes
where
return $
IM.insert i (Nothing, l', r') $
IM.unions childrenasnodes
where
g = f . _dtValue
dtToAdjRootParent :: Int -> Int -> (a -> Int) -> DoubleTree a -> IM.IntMap (Maybe (Int,Int),[Int],[Int])
dtToAdjRootParent root par f (DT x l r) = IM.insert (f x) (Just (root,par),map g l , map g r)
. IM.unions $ map (dtToAdjRootParent root (f x) f) $ l <> r
where
dtToAdjRootParent :: Int -> Int -> (a -> Int) -> DoubleTree a -> IM.IntMap (Maybe (Int, Int), [Int], [Int])
dtToAdjRootParent root par f (DT x l r) =
IM.insert (f x) (Just (root, par), map g l, map g r)
. IM.unions
$ map (dtToAdjRootParent root (f x) f) $ l <> r
where
g = f . _dtValue
dtToAdjRootParentEither :: Int -> Int
-> (a -> Either String Int) -> DoubleTree a -> Either String (IM.IntMap (Maybe (Int,Int),[Int],[Int]))
dtToAdjRootParentEither ::
Int ->
Int ->
(a -> Either String Int) ->
DoubleTree a ->
Either String (IM.IntMap (Maybe (Int, Int), [Int], [Int]))
dtToAdjRootParentEither root par f (DT x l r) = do
i <- f x
l' <- mapM g l
r' <- mapM g r
childrenasnodes <- mapM (dtToAdjRootParentEither root i f) $ l <> r
return $ IM.insert i (Just (root,par),l' , r') $ IM.unions childrenasnodes
where
return $ IM.insert i (Just (root, par), l', r') $ IM.unions childrenasnodes
where
g = f . _dtValue
ldtToIM :: (a -> Int) -> LDTree b a -> IM.IntMap (LDTree b a)
ldtToIM f t@(LDT x l r) = IM.insert (f x) t $ IM.unions $ map (ldtToIM f . snd) $ l <> r
ldtToIM f t@(LDT x l r) = IM.insert (f x) t $ IM.unions $ map (ldtToIM f . snd) $ l <> r
ldtToIndentList :: LDTree b a -> [(a,Int,LabelDoubleTreeNodeType b)]
ldtToIndentList :: LDTree b a -> [(a, Int, LabelDoubleTreeNodeType b)]
ldtToIndentList = ldtIL LDTRootNode
ldtIL :: LabelDoubleTreeNodeType b -> LDTree b a -> [(a,Int,LabelDoubleTreeNodeType b)]
ldtIL nt (LDT x l r) = map doindent
(concat
(headMap
(\(lab,c) -> ldtIL (LDTBottomNode lab) c)
(\(lab,c) -> ldtIL (LDTMidBelowNode lab) c)
l
)
)
++ [(x,0,nt)]
++ map doindent
(concat
(lastMap
(\(lab,c) -> ldtIL (LDTTopNode lab) c)
(\(lab,c) -> ldtIL (LDTMidAboveNode lab) c)
r
ldtIL :: LabelDoubleTreeNodeType b -> LDTree b a -> [(a, Int, LabelDoubleTreeNodeType b)]
ldtIL nt (LDT x l r) =
map
doindent
( concat
( headMap
(\(lab, c) -> ldtIL (LDTBottomNode lab) c)
(\(lab, c) -> ldtIL (LDTMidBelowNode lab) c)
l
)
)
++ [(x, 0, nt)]
++ map
doindent
( concat
( lastMap
(\(lab, c) -> ldtIL (LDTTopNode lab) c)
(\(lab, c) -> ldtIL (LDTMidAboveNode lab) c)
r
)
)
where
doindent (a,b,c) = (a,b+1,c)
doindent (a, b, c) = (a, b + 1, c)
headMap :: (a -> b) -> (a -> b) -> [a] -> [b]
headMap f g (x:xs) = f x : map g xs
headMap f g (x : xs) = f x : map g xs
headMap _ _ [] = []
lastMap :: (a -> b) -> (a -> b) -> [a] -> [b]
lastMap _ _ [] = []
lastMap f _ [x] = [f x]
lastMap f g (x:xs) = g x : lastMap f g xs
lastMap f g (x : xs) = g x : lastMap f g xs
prettyDT :: (a -> String) -> DoubleTree a -> [String]
prettyDT f (DT x l r) = concatMap (map ('/':) . prettyDT f) r
++ (f x : concatMap (map ('\\':) . prettyDT f) l)
prettyDT f (DT x l r) =
concatMap (map ('/' :) . prettyDT f) r
++ (f x : concatMap (map ('\\' :) . prettyDT f) l)
prettyLDT :: (a -> String) -> LDTree b a -> [String]
prettyLDT f (LDT x l r) = concatMap (map ('/':) . prettyLDT f . snd) r
++ (f x : concatMap (map ('\\':) . prettyLDT f . snd) l)
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
@@ -190,13 +221,20 @@ 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)))
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
--locToTop = fix $ \x -> fromMaybe x $ locUp x
locLeftmost :: LocationLDT b a -> LocationLDT b a
@@ -207,52 +245,62 @@ locRightmost loc = maybe loc locRightmost $ alaf Last foldMap Just $ locGoRight
-- 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]
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]
locGoRight (LocLDT c (LDT v l r)) =
[LocLDT (RightwardLDT c l closel v link closer) t | (closel, (link, t), closer) <- locGoHelp id r]
-- this seems like it might be very inefficient for large lists
-- difference lists?
locGoHelp :: (a -> b) -> [a] -> [([a],b,[a])]
locGoHelp :: (a -> b) -> [a] -> [([a], b, [a])]
locGoHelp f = go []
where
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 _ [] = []
-- 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'))
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
. 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 f x =
foldMap (reduceLocLDT f) (locGoLeft x) <> f x
<> foldMap (reduceLocLDT f) (locGoRight x)