-- | Traversable functions.
module Music.Theory.Traversable where

import Data.List {- base -}

-- | Replace elements at 'Traversable' with result of joining with elements from list.
--
-- > let t = Tree.Node 0 [Tree.Node 1 [Tree.Node 2 [],Tree.Node 3 []],Tree.Node 4 []]
-- > putStrLn $ Tree.drawTree (fmap show t)
-- > let (_,u) = adopt_shape (\_ x -> x) "abcde" t
-- > putStrLn $ Tree.drawTree (fmap return u)
adopt_shape :: Traversable t => (a -> b -> c) -> [b] -> t a -> ([b],t c)
adopt_shape :: forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> c) -> [b] -> t a -> ([b], t c)
adopt_shape a -> b -> c
jn [b]
l =
    let f :: [b] -> a -> ([b], c)
f (b
i:[b]
j) a
k = ([b]
j,a -> b -> c
jn a
k b
i)
        f [] a
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"adopt_shape: rhs ends"
    in forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL [b] -> a -> ([b], c)
f [b]
l

-- | Two-level variant of 'adopt_shape'.
--
-- > adopt_shape_2 (,) [0..4] (words "a bc d") == ([4],[[('a',0)],[('b',1),('c',2)],[('d',3)]])
adopt_shape_2 :: (Traversable t,Traversable u) => (a -> b -> c) -> [b] -> t (u a) -> ([b],t (u c))
adopt_shape_2 :: forall (t :: * -> *) (u :: * -> *) a b c.
(Traversable t, Traversable u) =>
(a -> b -> c) -> [b] -> t (u a) -> ([b], t (u c))
adopt_shape_2 a -> b -> c
jn = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> c) -> [b] -> t a -> ([b], t c)
adopt_shape a -> b -> c
jn)

{- | Adopt stream to shape of traversable and zip elements.

> adopt_shape_2_zip_stream [1..] ["a", "list", "of", "strings"]
-}
adopt_shape_2_zip_stream :: (Traversable t, Traversable u) => [c] -> t (u a) -> t (u (c, a))
adopt_shape_2_zip_stream :: forall (t :: * -> *) (u :: * -> *) c a.
(Traversable t, Traversable u) =>
[c] -> t (u a) -> t (u (c, a))
adopt_shape_2_zip_stream [c]
s t (u a)
l = forall a b. (a, b) -> b
snd (forall (t :: * -> *) (u :: * -> *) a b c.
(Traversable t, Traversable u) =>
(a -> b -> c) -> [b] -> t (u a) -> ([b], t (u c))
adopt_shape_2 (forall a b c. (a -> b -> c) -> b -> a -> c
flip (,)) [c]
s t (u a)
l)

-- | Two-level variant of 'zip' [1..]
--
-- > list_number_2 ["number","list","two"] == [[(1,'n'),(2,'u'),(3,'m'),(4,'b'),(5,'e'),(6,'r')],[(7,'l'),(8,'i'),(9,'s'),(10,'t')],[(11,'t'),(12,'w'),(13,'o')]]
list_number_2 :: [[x]] -> [[(Int,x)]]
list_number_2 :: forall x. [[x]] -> [[(Int, x)]]
list_number_2 = forall (t :: * -> *) (u :: * -> *) c a.
(Traversable t, Traversable u) =>
[c] -> t (u a) -> t (u (c, a))
adopt_shape_2_zip_stream [Int
1..]

{- | Variant of 'adopt_shape' that considers only 'Just' elements at 'Traversable'.

> let s = "a(b(cd)ef)ghi"
> let t = group_tree (begin_end_cmp_eq '(' ')') s
> adopt_shape_m (,) [1..13] t
-}
adopt_shape_m :: Traversable t => (a -> b-> c) -> [b] -> t (Maybe a) -> ([b],t (Maybe c))
adopt_shape_m :: forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> c) -> [b] -> t (Maybe a) -> ([b], t (Maybe c))
adopt_shape_m a -> b -> c
jn [b]
l =
    let f :: [b] -> Maybe a -> ([b], Maybe c)
f (b
i:[b]
j) Maybe a
k = case Maybe a
k of
                      Maybe a
Nothing -> (b
iforall a. a -> [a] -> [a]
:[b]
j,forall a. Maybe a
Nothing)
                      Just a
k' -> ([b]
j,forall a. a -> Maybe a
Just (a -> b -> c
jn a
k' b
i))
        f [] Maybe a
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"adopt_shape_m: rhs ends"
    in forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL [b] -> Maybe a -> ([b], Maybe c)
f [b]
l