hmt-0.18: Music/Theory/List.hs
-- | List functions.
module Music.Theory.List where
import Data.Either {- base -}
import Data.Function {- base -}
import Data.List {- base -}
import Data.Maybe {- base -}
import qualified Data.IntMap as Map {- containers -}
import qualified Data.List.Ordered as O {- data-ordlist -}
import qualified Data.List.Split as S {- split -}
import qualified Data.Tree as Tree {- containers -}
import qualified Control.Monad.Logic as L {- logict -}
-- | 'Data.Vector.slice', ie. starting index (zero-indexed) and number of elements.
--
-- > slice 4 5 [1..] == [5,6,7,8,9]
slice :: Int -> Int -> [a] -> [a]
slice i n = take n . drop i
-- | Variant of slice with start and end indices (zero-indexed).
--
-- > section 4 8 [1..] == [5,6,7,8,9]
section :: Int -> Int -> [a] -> [a]
section l r = take (r - l + 1) . drop l
-- | Bracket sequence with left and right values.
--
-- > bracket ('<','>') "1,2,3" == "<1,2,3>"
bracket :: (a,a) -> [a] -> [a]
bracket (l,r) x = l : x ++ [r]
-- | Variant where brackets are sequences.
--
-- > bracket_l ("<:",":>") "1,2,3" == "<:1,2,3:>"
bracket_l :: ([a],[a]) -> [a] -> [a]
bracket_l (l,r) s = l ++ s ++ r
-- | The first & middle & last elements of a list.
--
-- > map unbracket_el ["","{12}"] == [(Nothing,"",Nothing),(Just '{',"12",Just '}')]
unbracket_el :: [a] -> (Maybe a,[a],Maybe a)
unbracket_el x =
case x of
[] -> (Nothing,[],Nothing)
l:x' -> let (m,r) = separate_last' x' in (Just l,m,r)
-- | The first & middle & last elements of a list.
--
-- > map unbracket ["","{12}"] == [Nothing,Just ('{',"12",'}')]
unbracket :: [t] -> Maybe (t,[t],t)
unbracket x =
case unbracket_el x of
(Just l,m,Just r) -> Just (l,m,r)
_ -> Nothing
-- | Erroring variant.
unbracket_err :: [t] -> (t,[t],t)
unbracket_err = fromMaybe (error "unbracket") . unbracket
-- * Split
-- | Relative of 'splitOn', but only makes first separation.
--
-- > splitOn "//" "lhs//rhs//rem" == ["lhs","rhs","rem"]
-- > separate_at "//" "lhs//rhs//rem" == Just ("lhs","rhs//rem")
separate_at :: Eq a => [a] -> [a] -> Maybe ([a],[a])
separate_at x =
let n = length x
f lhs rhs =
if null rhs
then Nothing
else if x == take n rhs
then Just (reverse lhs,drop n rhs)
else f (head rhs : lhs) (tail rhs)
in f []
-- | Variant of 'S.splitWhen' that keeps delimiters at left.
--
-- > split_when_keeping_left (== 'r') "rab rcd re rf r" == ["","rab ","rcd ","re ","rf ","r"]
split_when_keeping_left :: (a -> Bool) -> [a] -> [[a]]
split_when_keeping_left = S.split . S.keepDelimsL . S.whenElt
{- | Split before the indicated element, keeping it at the left of the sub-sequence it begins.
'split_when_keeping_left' of '=='
> split_before 'x' "axbcxdefx" == ["a","xbc","xdef","x"]
> split_before 'x' "xa" == ["","xa"]
> map (flip split_before "abcde") "ae_" == [["","abcde"],["abcd","e"],["abcde"]]
> map (flip break "abcde" . (==)) "ae_" == [("","abcde"),("abcd","e"),("abcde","")]
> split_before 'r' "rab rcd re rf r" == ["","rab ","rcd ","re ","rf ","r"]
-}
split_before :: Eq a => a -> [a] -> [[a]]
split_before x = split_when_keeping_left (== x)
-- | Split before any of the indicated set of delimiters.
--
-- > split_before_any ",;" ";a,b,c;d;" == ["",";a",",b",",c",";d",";"]
split_before_any :: Eq a => [a] -> [a] -> [[a]]
split_before_any = S.split . S.keepDelimsL . S.oneOf
-- | Singleton variant of 'S.splitOn'.
--
-- > split_on_1 ":" "graph:layout" == Just ("graph","layout")
split_on_1 :: Eq t => [t] -> [t] -> Maybe ([t],[t])
split_on_1 e l =
case S.splitOn e l of
[p,q] -> Just (p,q)
_ -> Nothing
-- | Erroring variant.
split_on_1_err :: Eq t => [t] -> [t] -> ([t],[t])
split_on_1_err e = fromMaybe (error "split_on_1") . split_on_1 e
-- | Split function that splits only once, ie. a variant of 'break'.
--
-- > split1 ' ' "three word sentence" == Just ("three","word sentence")
split1 :: Eq a => a -> [a] -> Maybe ([a],[a])
split1 c l =
case break (== c) l of
(lhs,_:rhs) -> Just (lhs,rhs)
_ -> Nothing
-- | Erroring variant.
split1_err :: (Eq a, Show a) => a -> [a] -> ([a], [a])
split1_err e s = fromMaybe (error (show ("split1",e,s))) (split1 e s)
-- * Rotate
-- | Generic form of 'rotate_left'.
genericRotate_left :: Integral i => i -> [a] -> [a]
genericRotate_left n =
let f (p,q) = q ++ p
in f . genericSplitAt n
-- | Left rotation.
--
-- > rotate_left 1 [1..3] == [2,3,1]
-- > rotate_left 3 [1..5] == [4,5,1,2,3]
rotate_left :: Int -> [a] -> [a]
rotate_left = genericRotate_left
-- | Generic form of 'rotate_right'.
genericRotate_right :: Integral n => n -> [a] -> [a]
genericRotate_right n = reverse . genericRotate_left n . reverse
-- | Right rotation.
--
-- > rotate_right 1 [1..3] == [3,1,2]
rotate_right :: Int -> [a] -> [a]
rotate_right = genericRotate_right
-- | Rotate left by /n/ 'mod' /#p/ places.
--
-- > rotate 1 [1..3] == [2,3,1]
-- > rotate 8 [1..5] == [4,5,1,2,3]
rotate :: (Integral n) => n -> [a] -> [a]
rotate n p =
let m = n `mod` genericLength p
in genericRotate_left m p
-- | Rotate right by /n/ places.
--
-- > rotate_r 8 [1..5] == [3,4,5,1,2]
rotate_r :: (Integral n) => n -> [a] -> [a]
rotate_r = rotate . negate
-- | All rotations.
--
-- > rotations [0,1,3] == [[0,1,3],[1,3,0],[3,0,1]]
rotations :: [a] -> [[a]]
rotations p = map (`rotate_left` p) [0 .. length p - 1]
-- | Rotate list so that is starts at indicated element.
--
-- > rotate_starting_from 'c' "abcde" == Just "cdeab"
-- > rotate_starting_from '_' "abc" == Nothing
rotate_starting_from :: Eq a => a -> [a] -> Maybe [a]
rotate_starting_from x l =
case break (== x) l of
(_,[]) -> Nothing
(lhs,rhs) -> Just (rhs ++ lhs)
-- | Erroring variant.
rotate_starting_from_err :: Eq a => a -> [a] -> [a]
rotate_starting_from_err x =
fromMaybe (error "rotate_starting_from: non-element") .
rotate_starting_from x
-- | Sequence of /n/ adjacent elements, moving forward by /k/ places.
-- The last element may have fewer than /n/ places, but will reach the
-- end of the input sequence.
--
-- > adj 3 2 "adjacent" == ["adj","jac","cen","nt"]
adj :: Int -> Int -> [a] -> [[a]]
adj n k l =
case take n l of
[] -> []
r -> r : adj n k (drop k l)
-- | Variant of 'adj' where the last element has /n/ places but may
-- not reach the end of the input sequence.
--
-- > adj_trunc 4 1 "adjacent" == ["adja","djac","jace","acen","cent"]
-- > adj_trunc 3 2 "adjacent" == ["adj","jac","cen"]
adj_trunc :: Int -> Int -> [a] -> [[a]]
adj_trunc n k l =
let r = take n l
in if length r == n then r : adj_trunc n k (drop k l) else []
-- | 'adj_trunc' of 'close' by /n/-1.
--
-- > adj_cyclic_trunc 3 1 "adjacent" == ["adj","dja","jac","ace","cen","ent","nta","tad"]
adj_cyclic_trunc :: Int -> Int -> [a] -> [[a]]
adj_cyclic_trunc n k = adj_trunc n k . close (n - 1)
-- | Generic form of 'adj2'.
genericAdj2 :: (Integral n) => n -> [t] -> [(t,t)]
genericAdj2 n l =
case l of
p:q:_ -> (p,q) : genericAdj2 n (genericDrop n l)
_ -> []
-- | Adjacent elements of list, at indicated distance, as pairs.
--
-- > adj2 1 [1..5] == [(1,2),(2,3),(3,4),(4,5)]
-- > let l = [1..5] in zip l (tail l) == adj2 1 l
-- > adj2 2 [1..4] == [(1,2),(3,4)]
-- > adj2 3 [1..5] == [(1,2),(4,5)]
adj2 :: Int -> [t] -> [(t,t)]
adj2 = genericAdj2
-- | Append first /n/-elements to end of list.
--
-- > close 1 [1..3] == [1,2,3,1]
close :: Int -> [a] -> [a]
close k x = x ++ take k x
-- | 'adj2' '.' 'close' 1.
--
-- > adj2_cyclic 1 [1..3] == [(1,2),(2,3),(3,1)]
adj2_cyclic :: Int -> [t] -> [(t,t)]
adj2_cyclic n = adj2 n . close 1
-- | Adjacent triples.
--
-- > adj3 3 [1..6] == [(1,2,3),(4,5,6)]
adj3 :: Int -> [t] -> [(t,t,t)]
adj3 n l =
case l of
p:q:r:_ -> (p,q,r) : adj3 n (drop n l)
_ -> []
-- | 'adj3' '.' 'close' 2.
--
-- > adj3_cyclic 1 [1..4] == [(1,2,3),(2,3,4),(3,4,1),(4,1,2)]
adj3_cyclic :: Int -> [t] -> [(t,t,t)]
adj3_cyclic n = adj3 n . close 2
{- | Adjacent quadruples.
> adj4 2 [1..8] == [(1,2,3,4),(3,4,5,6),(5,6,7,8)]
> adj4 4 [1..8] == [(1,2,3,4),(5,6,7,8)]
-}
adj4 :: Int -> [t] -> [(t,t,t,t)]
adj4 n l =
case l of
p:q:r:s:_ -> (p,q,r,s) : adj4 n (drop n l)
_ -> []
-- | Interleave elements of /p/ and /q/.
--
-- > interleave [1..3] [4..6] == [1,4,2,5,3,6]
-- > interleave ".+-" "abc" == ".a+b-c"
-- > interleave [1..3] [] == []
interleave :: [a] -> [a] -> [a]
interleave p q =
let u (i,j) = [i,j]
in concatMap u (zip p q)
-- | Interleave list of lists. Allows lists to be of non-equal lenghts.
--
-- > interleave_set ["abcd","efgh","ijkl"] == "aeibfjcgkdhl"
-- > interleave_set ["abc","defg","hijkl"] == "adhbeicfjgkl"
interleave_set :: [[a]] -> [a]
interleave_set = concat . transpose
{-
import Safe {- safe -}
interleave_set l =
case mapMaybe headMay l of
[] -> []
r -> r ++ interleave_set (mapMaybe tailMay l)
-}
-- | De-interleave /n/ lists.
--
-- > deinterleave 2 ".a+b-c" == [".+-","abc"]
-- > deinterleave 3 "aeibfjcgkdhl" == ["abcd","efgh","ijkl"]
deinterleave :: Int -> [a] -> [[a]]
deinterleave n = transpose . S.chunksOf n
-- | Special case for two-part deinterleaving.
--
-- > deinterleave2 ".a+b-c" == (".+-","abc")
deinterleave2 :: [t] -> ([t], [t])
deinterleave2 =
let f l =
case l of
p:q:l' -> (p,q) : f l'
_ -> []
in unzip . f
{-
deinterleave2 =
let f p q l =
case l of
[] -> (reverse p,reverse q)
[a] -> (reverse (a:p),reverse q)
a:b:l' -> rec (a:p) (b:q) l'
in f [] []
-}
-- | Variant that continues with the longer input.
--
-- > interleave_continue ".+-" "abc" == ".a+b-c"
-- > interleave_continue [1..3] [] == [1..3]
-- > interleave_continue [] [1..3] == [1..3]
interleave_continue :: [a] -> [a] -> [a]
interleave_continue p q =
case (p,q) of
([],_) -> q
(_,[]) -> p
(i:p',j:q') -> i : j : interleave_continue p' q'
-- | 'interleave' of 'rotate_left' by /i/ and /j/.
--
-- > interleave_rotations 9 3 [1..13] == [10,4,11,5,12,6,13,7,1,8,2,9,3,10,4,11,5,12,6,13,7,1,8,2,9,3]
interleave_rotations :: Int -> Int -> [b] -> [b]
interleave_rotations i j s = interleave (rotate_left i s) (rotate_left j s)
-- | 'unzip', apply /f1/ and /f2/ and 'zip'.
rezip :: ([t] -> [u]) -> ([v] -> [w]) -> [(t,v)] -> [(u,w)]
rezip f1 f2 l = let (p,q) = unzip l in zip (f1 p) (f2 q)
-- | Generalised histogram, with equality function for grouping and comparison function for sorting.
generic_histogram_by :: Integral i => (a->a->Bool) -> (Maybe (a->a->Ordering)) -> [a] -> [(a,i)]
generic_histogram_by eq_f cmp_f x =
let g = groupBy eq_f (maybe x (\f -> sortBy f x) cmp_f)
in zip (map head g) (map genericLength g)
-- | Type specialised 'generic_histogram_by'.
histogram_by :: (a->a->Bool) -> (Maybe (a->a->Ordering)) -> [a] -> [(a,Int)]
histogram_by = generic_histogram_by
-- | Count occurences of elements in list, 'histogram_by' of '==' and 'compare'.
generic_histogram :: (Ord a,Integral i) => [a] -> [(a,i)]
generic_histogram = generic_histogram_by (==) (Just compare)
-- | Type specialised 'generic_histogram'. Elements will be in ascending order.
--
-- > map histogram ["","hohoh","yxx"] == [[],[('h',3),('o',2)],[('x',2),('y',1)]]
histogram :: Ord a => [a] -> [(a,Int)]
histogram = generic_histogram
-- | Join two histograms, which must be sorted.
--
-- > histogram_join (zip "ab" [1,1]) (zip "bc" [1,1]) == zip "abc" [1,2,1]
histogram_join :: Ord a => [(a,Int)] -> [(a,Int)] -> [(a,Int)]
histogram_join p q =
let f (e1,n1) (e2,n2) = if e1 == e2 then Just (e1,n1 + n2) else Nothing
in case (p,q) of
(_,[]) -> p
([],_) -> q
(p1:p',q1:q') -> case f p1 q1 of
Just r -> r : histogram_join p' q'
Nothing -> if p1 < q1
then p1 : histogram_join p' q
else q1 : histogram_join p q'
-- | 'foldr' of 'histogram_join'.
--
-- > let f x = zip x (repeat 1) in histogram_merge (map f ["ab","bcd","de"]) == zip "abcde" [1,2,1,2,1]
histogram_merge :: Ord a => [[(a,Int)]] -> [(a,Int)]
histogram_merge = foldr histogram_join []
-- | Given (k,#) histogram where k is enumerable generate filled histogram with 0 for empty k.
--
-- > histogram_fill (histogram "histogram") == zip ['a'..'t'] [1,0,0,0,0,0,1,1,1,0,0,0,1,0,1,0,0,1,1,1]
histogram_fill :: (Ord a, Enum a) => [(a,Int)] -> [(a,Int)]
histogram_fill h =
let k = map fst h
e = [minimum k .. maximum k]
f x = fromMaybe 0 (lookup x h)
in zip e (map f e)
{- | Given two histograms p & q (sorted by key) make composite
histogram giving for all keys the counts for (p,q).
> r = zip "ABCDE" (zip [4,3,2,1,0] [2,3,4,0,5])
> histogram_composite (zip "ABCD" [4,3,2,1]) (zip "ABCE" [2,3,4,5]) == r
-}
histogram_composite :: Ord a => [(a,Int)] -> [(a,Int)] -> [(a,(Int,Int))]
histogram_composite p q =
case (p,q) of
([],_) -> map (\(k,n) -> (k,(0,n))) q
(_,[]) -> map (\(k,n) -> (k,(n,0))) p
((k1,n1):p',(k2,n2):q') -> case compare k1 k2 of
LT -> (k1,(n1,0)) : histogram_composite p' q
EQ -> (k1,(n1,n2)) : histogram_composite p' q'
GT -> (k2,(0,n2)) : histogram_composite p q'
{- | Apply '-' at count of 'histogram_composite', ie. 0 indicates
equal number at p and q, negative indicates more elements at p than
q and positive more elements at q than p.
> histogram_diff (zip "ABCD" [4,3,2,1]) (zip "ABCE" [2,3,4,5]) == zip "ABCDE" [-2,0,2,-1,5]
-}
histogram_diff :: Ord a => [(a,Int)] -> [(a,Int)] -> [(a,Int)]
histogram_diff p = map (\(k,(n,m)) -> (k,m - n)) . histogram_composite p
-- | Elements that appear more than once in the input given equality predicate.
duplicates_by :: Ord a => (a -> a -> Bool) -> [a] -> [a]
duplicates_by f = map fst . filter (\(_,n) -> n > 1) . histogram_by f (Just compare)
-- | 'duplicates_by' of '=='.
--
-- > map duplicates ["duplicates","redundant"] == ["","dn"]
duplicates :: Ord a => [a] -> [a]
duplicates = duplicates_by (==)
-- | List segments of length /i/ at distance /j/.
--
-- > segments 2 1 [1..5] == [[1,2],[2,3],[3,4],[4,5]]
-- > segments 2 2 [1..5] == [[1,2],[3,4]]
segments :: Int -> Int -> [a] -> [[a]]
segments i j p =
let q = take i p
p' = drop j p
in if length q /= i then [] else q : segments i j p'
-- | 'foldl1' 'intersect'.
--
-- > intersect_l [[1,2],[1,2,3],[1,2,3,4]] == [1,2]
intersect_l :: Eq a => [[a]] -> [a]
intersect_l = foldl1 intersect
-- | 'foldl1' 'union'.
--
-- > sort (union_l [[1,3],[2,3],[3]]) == [1,2,3]
union_l :: Eq a => [[a]] -> [a]
union_l = foldl1 union
-- | Intersection of adjacent elements of list at distance /n/.
--
-- > adj_intersect 1 [[1,2],[1,2,3],[1,2,3,4]] == [[1,2],[1,2,3]]
adj_intersect :: Eq a => Int -> [[a]] -> [[a]]
adj_intersect n = map intersect_l . segments 2 n
-- | List of cycles at distance /n/.
--
-- > cycles 2 [1..6] == [[1,3,5],[2,4,6]]
-- > cycles 3 [1..9] == [[1,4,7],[2,5,8],[3,6,9]]
-- > cycles 4 [1..8] == [[1,5],[2,6],[3,7],[4,8]]
cycles :: Int -> [a] -> [[a]]
cycles n = transpose . S.chunksOf n
-- | Variant of 'filter' that has a predicate to halt processing,
-- ie. 'filter' of 'takeWhile'.
--
-- > filter_halt (even . fst) ((< 5) . snd) (zip [1..] [0..])
filter_halt :: (a -> Bool) -> (a -> Bool) -> [a] -> [a]
filter_halt sel end = filter sel . takeWhile end
-- | Variant of 'Data.List.filter' that retains 'Nothing' as a
-- placeholder for removed elements.
--
-- > filter_maybe even [1..4] == [Nothing,Just 2,Nothing,Just 4]
filter_maybe :: (a -> Bool) -> [a] -> [Maybe a]
filter_maybe f = map (\e -> if f e then Just e else Nothing)
-- | Replace all /p/ with /q/ in /s/.
--
-- > replace "_x_" "-X-" "an _x_ string" == "an -X- string"
-- > replace "ab" "cd" "ab ab cd ab" == "cd cd cd cd"
replace :: Eq a => [a] -> [a] -> [a] -> [a]
replace p q s =
let n = length p
in case s of
[] -> []
c:s' -> if p `isPrefixOf` s
then q ++ replace p q (drop n s)
else c : replace p q s'
-- | Replace the /i/th value at /ns/ with /x/.
--
-- > replace_at "test" 2 'n' == "tent"
replace_at :: Integral i => [a] -> i -> a -> [a]
replace_at ns i x =
let f j y = if i == j then x else y
in zipWith f [0..] ns
-- * Association lists
-- | Equivalent to 'groupBy' /eq/ 'on' /f/.
--
-- > group_by_on (==) snd (zip [0..] "abbc") == [[(0,'a')],[(1,'b'),(2,'b')],[(3,'c')]]
group_by_on :: (x -> x -> Bool) -> (t -> x) -> [t] -> [[t]]
group_by_on eq f = groupBy (eq `on` f)
-- | 'group_by_on' of '=='.
--
-- > r = [[(1,'a'),(1,'b')],[(2,'c')],[(3,'d'),(3,'e')],[(4,'f')]]
-- > group_on fst (zip [1,1,2,3,3,4] "abcdef") == r
group_on :: Eq x => (a -> x) -> [a] -> [[a]]
group_on = group_by_on (==)
-- | Given an equality predicate and accesors for /key/ and /value/ collate adjacent values.
collate_by_on_adjacent :: (k -> k -> Bool) -> (a -> k) -> (a -> v) -> [a] -> [(k,[v])]
collate_by_on_adjacent eq f g =
let h l = case l of
[] -> error "collate_by_on_adjacent"
l0:_ -> (f l0,map g l)
in map h . group_by_on eq f
-- | 'collate_by_on_adjacent' of '=='
collate_on_adjacent :: Eq k => (a -> k) -> (a -> v) -> [a] -> [(k,[v])]
collate_on_adjacent = collate_by_on_adjacent (==)
-- | 'collate_on_adjacent' of 'fst' and 'snd'.
--
-- > collate_adjacent (zip "TDD" "xyz") == [('T',"x"),('D',"yz")]
collate_adjacent :: Eq a => [(a,b)] -> [(a,[b])]
collate_adjacent = collate_on_adjacent fst snd
-- | 'sortOn' prior to 'collate_on_adjacent'.
--
-- > r = [('A',"a"),('B',"bd"),('C',"ce"),('D',"f")]
-- > collate_on fst snd (zip "ABCBCD" "abcdef") == r
collate_on :: Ord k => (a -> k) -> (a -> v) -> [a] -> [(k,[v])]
collate_on f g = collate_on_adjacent f g . sortOn f
-- | 'collate_on' of 'fst' and 'snd'.
--
-- > collate (zip "TDD" "xyz") == [('D',"yz"),('T',"x")]
-- > collate (zip [1,2,1] "abc") == [(1,"ac"),(2,"b")]
collate :: Ord a => [(a,b)] -> [(a,[b])]
collate = collate_on fst snd
-- | Reverse of 'collate', inverse if order is not considered.
--
-- > uncollate [(1,"ac"),(2,"b")] == zip [1,1,2] "acb"
uncollate :: [(k,[v])] -> [(k,v)]
uncollate = concatMap (\(k,v) -> zip (repeat k) v)
-- | Make /assoc/ list with given /key/.
--
-- > with_key 'a' [1..3] == [('a',1),('a',2),('a',3)]
with_key :: k -> [v] -> [(k,v)]
with_key h = zip (repeat h)
-- | Left biased merge of association lists /p/ and /q/.
--
-- > assoc_merge [(5,"a"),(3,"b")] [(5,"A"),(7,"C")] == [(5,"a"),(3,"b"),(7,"C")]
assoc_merge :: Eq k => [(k,v)] -> [(k,v)] -> [(k,v)]
assoc_merge p q =
let p_k = map fst p
q' = filter ((`notElem` p_k) . fst) q
in p ++ q'
-- | Keys are in ascending order, the entry retrieved is the rightmose with
-- a key less than or equal to the key requested.
-- If the key requested is less than the initial key, or the list is empty, returns 'Nothing'.
--
-- > let m = [(1,'a'),(4,'x'),(4,'b'),(5,'c')]
-- > mapMaybe (ord_map_locate m) [1 .. 6] == [(1,'a'),(1,'a'),(1,'a'),(4,'b'),(5,'c'),(5,'c')]
-- > ord_map_locate m 0 == Nothing
ord_map_locate :: Ord k => [(k,v)] -> k -> Maybe (k,v)
ord_map_locate mp i =
let f (k0,v0) xs =
case xs of
[] -> if i >= k0 then Just (k0,v0) else error "ord_map_locate?"
((k1,v1):xs') -> if i >= k0 && i < k1 then Just (k0,v0) else f (k1,v1) xs'
in case mp of
[] -> Nothing
(k0,v0):mp' -> if i < k0 then Nothing else f (k0,v0) mp'
-- * Δ
-- | Intervals to values, zero is /n/.
--
-- > dx_d 5 [1,2,3] == [5,6,8,11]
dx_d :: (Num a) => a -> [a] -> [a]
dx_d = scanl (+)
-- | Variant that takes initial value and separates final value. This
-- is an appropriate function for 'mapAccumL'.
--
-- > dx_d' 5 [1,2,3] == (11,[5,6,8])
-- > dx_d' 0 [1,1,1] == (3,[0,1,2])
dx_d' :: Num t => t -> [t] -> (t,[t])
dx_d' n l =
case reverse (scanl (+) n l) of
e:r -> (e,reverse r)
_ -> error "dx_d'"
-- | Integration with /f/, ie. apply flip of /f/ between elements of /l/.
--
-- > d_dx_by (,) "abcd" == [('b','a'),('c','b'),('d','c')]
-- > d_dx_by (-) [0,2,4,1,0] == [2,2,-3,-1]
-- > d_dx_by (-) [2,3,0,4,1] == [1,-3,4,-3]
d_dx_by :: (t -> t -> u) -> [t] -> [u]
d_dx_by f l = if null l then [] else zipWith f (tail l) l
-- | Integrate, 'd_dx_by' '-', ie. pitch class segment to interval sequence.
--
-- > d_dx [5,6,8,11] == [1,2,3]
-- > d_dx [] == []
d_dx :: (Num a) => [a] -> [a]
d_dx = d_dx_by (-)
-- | Elements of /p/ not in /q/.
--
-- > [1,2,3] `difference` [1,2] == [3]
difference :: Eq a => [a] -> [a] -> [a]
difference p q = filter (`notElem` q) p
-- | Is /p/ a subset of /q/, ie. is 'intersect' of /p/ and /q/ '==' /p/.
--
-- > is_subset [1,2] [1,2,3] == True
is_subset :: Eq a => [a] -> [a] -> Bool
is_subset p q = p `intersect` q == p
-- | Is /p/ a superset of /q/, ie. 'flip' 'is_subset'.
--
-- > is_superset [1,2,3] [1,2] == True
is_superset :: Eq a => [a] -> [a] -> Bool
is_superset = flip is_subset
-- | Is /p/ a subsequence of /q/, ie. synonym for 'isInfixOf'.
--
-- > subsequence [1,2] [1,2,3] == True
subsequence :: Eq a => [a] -> [a] -> Bool
subsequence = isInfixOf
-- | Erroring variant of 'findIndex'.
findIndex_err :: (a -> Bool) -> [a] -> Int
findIndex_err f = fromMaybe (error "findIndex?") . findIndex f
-- | Erroring variant of 'elemIndex'.
elemIndex_err :: Eq a => a -> [a] -> Int
elemIndex_err x = fromMaybe (error "ix_of") . elemIndex x
-- | Variant of 'elemIndices' that requires /e/ to be unique in /p/.
--
-- > elem_index_unique 'a' "abcda" == undefined
elem_index_unique :: Eq a => a -> [a] -> Int
elem_index_unique e p =
case elemIndices e p of
[i] -> i
_ -> error "elem_index_unique"
-- | Lookup that errors and prints message and key.
lookup_err_msg :: (Eq k,Show k) => String -> k -> [(k,v)] -> v
lookup_err_msg err k = fromMaybe (error (err ++ ": " ++ show k)) . lookup k
-- | Error variant.
lookup_err :: Eq k => k -> [(k,v)] -> v
lookup_err n = fromMaybe (error "lookup") . lookup n
-- | 'lookup' variant with default value.
lookup_def :: Eq k => k -> v -> [(k,v)] -> v
lookup_def k d = fromMaybe d . lookup k
-- | If /l/ is empty 'Nothing', else 'Just' /l/.
non_empty :: [t] -> Maybe [t]
non_empty l = if null l then Nothing else Just l
-- | Variant on 'filter' that selects all matches.
--
-- > lookup_set 1 (zip [1,2,3,4,1] "abcde") == Just "ae"
lookup_set :: Eq k => k -> [(k,v)] -> Maybe [v]
lookup_set k = non_empty . map snd . filter ((== k) . fst)
-- | Erroring variant.
lookup_set_err :: Eq k => k -> [(k,v)] -> [v]
lookup_set_err k = fromMaybe (error "lookup_set?") . lookup_set k
-- | Reverse lookup.
--
-- > reverse_lookup 'c' [] == Nothing
-- > reverse_lookup 'b' (zip [1..] ['a'..]) == Just 2
-- > lookup 2 (zip [1..] ['a'..]) == Just 'b'
reverse_lookup :: Eq v => v -> [(k,v)] -> Maybe k
reverse_lookup k = fmap fst . find ((== k) . snd)
-- | Erroring variant.
reverse_lookup_err :: Eq v => v -> [(k,v)] -> k
reverse_lookup_err k = fromMaybe (error "reverse_lookup") . reverse_lookup k
{-
reverse_lookup :: Eq b => b -> [(a,b)] -> Maybe a
reverse_lookup key ls =
case ls of
[] -> Nothing
(x,y):ls' -> if key == y then Just x else reverse_lookup key ls'
-}
-- | Erroring variant of 'find'.
find_err :: (t -> Bool) -> [t] -> t
find_err f = fromMaybe (error "find") . find f
-- | Basis of 'find_bounds_scl', indicates if /x/ is to the left or
-- right of the list, and if to the right whether equal or not.
-- 'Right' values will be correct if the list is not ascending,
-- however 'Left' values only make sense for ascending ranges.
--
-- > map (find_bounds_cmp compare [(0,1),(1,2)]) [-1,0,1,2,3]
find_bounds_cmp :: (t -> s -> Ordering) -> [(t,t)] -> s -> Either ((t,t),Ordering) (t,t)
find_bounds_cmp f l x =
let g (p,q) = f p x /= GT && f q x == GT
in case l of
[] -> error "find_bounds_cmp: nil"
[(p,q)] -> if g (p,q) then Right (p,q) else Left ((p,q),f q x)
(p,q):l' -> if f p x == GT
then Left ((p,q),GT)
else if g (p,q) then Right (p,q) else find_bounds_cmp f l' x
decide_nearest_f :: Ord o => Bool -> (p -> o) -> (p,p) -> ((x,x) -> x)
decide_nearest_f bias_left f (p,q) =
case compare (f p) (f q) of
LT -> fst
EQ -> if bias_left then fst else snd
GT -> snd
-- | Decide if value is nearer the left or right value of a range, return 'fst' or 'snd'.
--
-- > (decide_nearest True 2 (1,3)) ("left","right") == "left"
decide_nearest :: (Num o,Ord o) => Bool -> o -> (o,o) -> ((x,x) -> x)
decide_nearest bias_left x = decide_nearest_f bias_left (abs . (x -))
-- | /sel_f/ gets comparison key from /t/.
find_nearest_by :: (Ord n,Num n) => (t -> n) -> Bool -> [t] -> n -> t
find_nearest_by sel_f bias_left l x =
let cmp_f i j = compare (sel_f i) j
in case find_bounds_cmp cmp_f (adj2 1 l) x of
Left ((p,_),GT) -> p
Left ((_,q),_) -> q
Right (p,q) -> (decide_nearest bias_left x (sel_f p,sel_f q)) (p,q)
-- | Find the number that is nearest the requested value in an
-- ascending list of numbers.
--
-- > map (find_nearest_err True [0,3.5,4,7]) [-1,1,3,5,7,9] == [0,0,3.5,4,7,7]
find_nearest_err :: (Num n,Ord n) => Bool -> [n] -> n -> n
find_nearest_err = find_nearest_by id
find_nearest :: (Num n,Ord n) => Bool -> [n] -> n -> Maybe n
find_nearest bias_left l x = if null l then Nothing else Just (find_nearest_err bias_left l x)
-- | Basis of 'find_bounds'. There is an option to consider the last
-- element specially, and if equal to the last span is given.
--
-- scl=special-case-last
find_bounds_scl :: Bool -> (t -> s -> Ordering) -> [(t,t)] -> s -> Maybe (t,t)
find_bounds_scl scl f l x =
case find_bounds_cmp f l x of
Right r -> Just r
Left (r,EQ) -> if scl then Just r else Nothing
_ -> Nothing
-- | Find adjacent elements of list that bound element under given comparator.
--
-- > let {f = find_bounds True compare [1..5]
-- > ;r = [Nothing,Just (1,2),Just (3,4),Just (4,5)]}
-- > in map f [0,1,3.5,5] == r
find_bounds :: Bool -> (t -> s -> Ordering) -> [t] -> s -> Maybe (t,t)
find_bounds scl f l = find_bounds_scl scl f (adj2 1 l)
-- | Special case of 'dropRight'.
--
-- > map drop_last ["","?","remove"] == ["","","remov"]
drop_last :: [t] -> [t]
drop_last l =
case l of
[] -> []
[_] -> []
e:l' -> e : drop_last l'
-- | Variant of 'drop' from right of list.
--
-- > dropRight 1 [1..9] == [1..8]
dropRight :: Int -> [a] -> [a]
dropRight n = reverse . drop n . reverse
-- | Variant of 'dropWhile' from right of list.
--
-- > dropWhileRight Data.Char.isDigit "A440" == "A"
dropWhileRight :: (a -> Bool) -> [a] -> [a]
dropWhileRight p = reverse . dropWhile p . reverse
-- | 'take' from right.
--
-- > take_right 3 "taking" == "ing"
take_right :: Int -> [a] -> [a]
take_right n = reverse . take n . reverse
-- | 'takeWhile' from right.
--
-- > take_while_right Data.Char.isDigit "A440" == "440"
take_while_right :: (a -> Bool) -> [a] -> [a]
take_while_right p = reverse . takeWhile p . reverse
-- | Variant of 'take' that allows 'Nothing' to indicate the complete list.
--
-- > maybe_take (Just 5) [1 .. ] == [1 .. 5]
-- > maybe_take Nothing [1 .. 9] == [1 .. 9]
maybe_take :: Maybe Int -> [a] -> [a]
maybe_take n l = maybe l (flip take l) n
{- | Take until /f/ is true. This is not the same as 'not' at
'takeWhile' because it keeps the last element. It is an error
if the predicate never succeeds.
> take_until (== 'd') "tender" == "tend"
> takeWhile (not . (== 'd')) "tend" == "ten"
> take_until (== 'd') "seven" == undefined
-}
take_until :: (a -> Bool) -> [a] -> [a]
take_until f l =
case l of
[] -> error "take_until?"
e:l' -> if f e then [e] else e : take_until f l'
-- | Apply /f/ at first element, and /g/ at all other elements.
--
-- > at_head negate id [1..5] == [-1,2,3,4,5]
at_head :: (a -> b) -> (a -> b) -> [a] -> [b]
at_head f g x =
case x of
[] -> []
e:x' -> f e : map g x'
-- | Apply /f/ at all but last element, and /g/ at last element.
--
-- > at_last (* 2) negate [1..4] == [2,4,6,-4]
at_last :: (a -> b) -> (a -> b) -> [a] -> [b]
at_last f g x =
case x of
[] -> []
[i] -> [g i]
i:x' -> f i : at_last f g x'
-- | Separate list into an initial list and perhaps the last element tuple.
--
-- > separate_last' [] == ([],Nothing)
separate_last' :: [a] -> ([a],Maybe a)
separate_last' x =
case reverse x of
[] -> ([],Nothing)
e:x' -> (reverse x',Just e)
-- | Error on null input.
--
-- > separate_last [1..5] == ([1..4],5)
separate_last :: [a] -> ([a],a)
separate_last = fmap (fromMaybe (error "separate_last")) . separate_last'
-- | Replace directly repeated elements with 'Nothing'.
--
-- > indicate_repetitions "abba" == [Just 'a',Just 'b',Nothing,Just 'a']
indicate_repetitions :: Eq a => [a] -> [Maybe a]
indicate_repetitions =
let f l = case l of
[] -> []
e:l' -> Just e : map (const Nothing) l'
in concatMap f . group
-- | 'zipWith' of list and it's own tail.
--
-- > zip_with_adj (,) "abcde" == [('a','b'),('b','c'),('c','d'),('d','e')]
zip_with_adj :: (a -> a -> b) -> [a] -> [b]
zip_with_adj f xs = zipWith f xs (tail xs)
-- | Type-specialised 'zip_with_adj'.
compare_adjacent_by :: (a -> a -> Ordering) -> [a] -> [Ordering]
compare_adjacent_by = zip_with_adj
-- | 'compare_adjacent_by' of 'compare'.
--
-- > compare_adjacent [0,1,3,2] == [LT,LT,GT]
compare_adjacent :: Ord a => [a] -> [Ordering]
compare_adjacent = compare_adjacent_by compare
-- | 'Data.List.groupBy' does not make adjacent comparisons, it
-- compares each new element to the start of the group. This function
-- is the adjacent variant.
--
-- > groupBy (<) [1,2,3,2,4,1,5,9] == [[1,2,3,2,4],[1,5,9]]
-- > adjacent_groupBy (<) [1,2,3,2,4,1,5,9] == [[1,2,3],[2,4],[1,5,9]]
adjacent_groupBy :: (a -> a -> Bool) -> [a] -> [[a]]
adjacent_groupBy f p =
case p of
[] -> []
[x] -> [[x]]
x:y:p' -> let r = adjacent_groupBy f (y:p')
r0:r' = r
in if f x y
then (x:r0) : r'
else [x] : r
-- | Reduce sequences of consecutive values to ranges.
--
-- > group_ranges [-1,0,3,4,5,8,9,12] == [(-1,0),(3,5),(8,9),(12,12)]
-- > group_ranges [3,2,3,4,3] == [(3,3),(2,4),(3,3)]
group_ranges :: (Num t, Eq t) => [t] -> [(t,t)]
group_ranges =
let f l = (head l,last l)
in map f . adjacent_groupBy (\p q -> p + 1 == q)
-- | 'groupBy' on /structure/ of 'Maybe', ie. all 'Just' compare equal.
--
-- > let r = [[Just 1],[Nothing,Nothing],[Just 4,Just 5]]
-- > in group_just [Just 1,Nothing,Nothing,Just 4,Just 5] == r
group_just :: [Maybe a] -> [[Maybe a]]
group_just = group_on isJust
-- | Predicate to determine if all elements of the list are '=='.
--
-- > all_equal "aaa" == True
all_equal :: Eq a => [a] -> Bool
all_equal l =
case l of
[] -> True
[_] -> True
x:xs -> all id (map (== x) xs)
-- | Variant using 'nub'.
all_eq :: Eq n => [n] -> Bool
all_eq = (== 1) . length . nub
-- | 'nubBy' '==' 'on' /f/.
--
-- > nub_on snd (zip "ABCD" "xxyy") == [('A','x'),('C','y')]
nub_on :: Eq b => (a -> b) -> [a] -> [a]
nub_on f = nubBy ((==) `on` f)
-- | 'group_on' of 'sortOn'.
--
-- > let r = [[('1','a'),('1','c')],[('2','d')],[('3','b'),('3','e')]]
-- > in sort_group_on fst (zip "13123" "abcde") == r
sort_group_on :: Ord b => (a -> b) -> [a] -> [[a]]
sort_group_on f = group_on f . sortOn f
-- | Maybe cons element onto list.
--
-- > Nothing `mcons` "something" == "something"
-- > Just 's' `mcons` "omething" == "something"
mcons :: Maybe a -> [a] -> [a]
mcons e l = maybe l (:l) e
-- | Cons onto end of list.
--
-- > snoc 4 [1,2,3] == [1,2,3,4]
snoc :: a -> [a] -> [a]
snoc e l = l ++ [e]
-- * Ordering
-- | Comparison function type.
type Compare_F a = a -> a -> Ordering
-- | If /f/ compares 'EQ', defer to /g/.
two_stage_compare :: Compare_F a -> Compare_F a -> Compare_F a
two_stage_compare f g p q =
case f p q of
EQ -> g p q
r -> r
-- | 'compare' 'on' of 'two_stage_compare'
two_stage_compare_on :: (Ord i, Ord j) => (t -> i) -> (t -> j) -> t -> t -> Ordering
two_stage_compare_on f g = two_stage_compare (compare `on` f) (compare `on` g)
-- | Sequence of comparison functions, continue comparing until not EQ.
--
-- > compare (1,0) (0,1) == GT
-- > n_stage_compare [compare `on` snd,compare `on` fst] (1,0) (0,1) == LT
n_stage_compare :: [Compare_F a] -> Compare_F a
n_stage_compare l p q =
case l of
[] -> EQ
f:l' -> case f p q of
EQ -> n_stage_compare l' p q
r -> r
-- | 'compare' 'on' of 'two_stage_compare'
n_stage_compare_on :: Ord i => [t -> i] -> t -> t -> Ordering
n_stage_compare_on l = n_stage_compare (map (compare `on`) l)
-- | Sort sequence /a/ based on ordering of sequence /b/.
--
-- > sort_to "abc" [1,3,2] == "acb"
-- > sort_to "adbce" [1,4,2,3,5] == "abcde"
sort_to :: Ord i => [e] -> [i] -> [e]
sort_to e = map fst . sortOn snd . zip e
-- | 'flip' of 'sort_to'.
--
-- > sort_to_rev [1,4,2,3,5] "adbce" == "abcde"
sort_to_rev :: Ord i => [i] -> [e] -> [e]
sort_to_rev = flip sort_to
-- | 'sortBy' of 'two_stage_compare'.
sort_by_two_stage :: Compare_F a -> Compare_F a -> [a] -> [a]
sort_by_two_stage f g = sortBy (two_stage_compare f g)
-- | 'sortBy' of 'n_stage_compare'.
sort_by_n_stage :: [Compare_F a] -> [a] -> [a]
sort_by_n_stage f = sortBy (n_stage_compare f)
-- | 'sortBy' of 'two_stage_compare_on'.
sort_by_two_stage_on :: (Ord b,Ord c) => (a -> b) -> (a -> c) -> [a] -> [a]
sort_by_two_stage_on f g = sortBy (two_stage_compare_on f g)
-- | 'sortBy' of 'n_stage_compare_on'.
sort_by_n_stage_on :: Ord b => [a -> b] -> [a] -> [a]
sort_by_n_stage_on f = sortBy (n_stage_compare_on f)
-- | Given a comparison function, merge two ascending lists.
--
-- > mergeBy compare [1,3,5] [2,4] == [1..5]
merge_by :: Compare_F a -> [a] -> [a] -> [a]
merge_by = O.mergeBy
-- | 'merge_by' 'compare' 'on'.
merge_on :: Ord x => (a -> x) -> [a] -> [a] -> [a]
merge_on f = merge_by (compare `on` f)
-- | 'O.mergeBy' of 'two_stage_compare'.
merge_by_two_stage :: Ord b => (a -> b) -> Compare_F c -> (a -> c) -> [a] -> [a] -> [a]
merge_by_two_stage f cmp g = O.mergeBy (two_stage_compare (compare `on` f) (cmp `on` g))
-- | 'mergeBy' 'compare'.
merge :: Ord a => [a] -> [a] -> [a]
merge = O.merge
-- | Merge list of sorted lists given comparison function. Note that
-- this is not equal to 'O.mergeAll'.
merge_set_by :: (a -> a -> Ordering) -> [[a]] -> [a]
merge_set_by f = foldr (merge_by f) []
-- | 'merge_set_by' of 'compare'.
--
-- > merge_set [[1,3,5,7,9],[2,4,6,8],[10]] == [1..10]
merge_set :: Ord a => [[a]] -> [a]
merge_set = merge_set_by compare
{-| 'merge_by' variant that joins (resolves) equal elements.
> let {left p _ = p
> ;right _ q = q
> ;cmp = compare `on` fst
> ;p = zip [1,3,5] "abc"
> ;q = zip [1,2,3] "ABC"
> ;left_r = [(1,'a'),(2,'B'),(3,'b'),(5,'c')]
> ;right_r = [(1,'A'),(2,'B'),(3,'C'),(5,'c')]}
> in merge_by_resolve left cmp p q == left_r &&
> merge_by_resolve right cmp p q == right_r
> merge_by_resolve (\x _ -> x) (compare `on` fst) [(0,'A'),(1,'B'),(4,'E')] (zip [1..] "bcd")
-}
merge_by_resolve :: (a -> a -> a) -> Compare_F a -> [a] -> [a] -> [a]
merge_by_resolve jn cmp =
let recur p q =
case (p,q) of
([],_) -> q
(_,[]) -> p
(l:p',r:q') -> case cmp l r of
LT -> l : recur p' q
EQ -> jn l r : recur p' q'
GT -> r : recur p q'
in recur
-- | Merge two sorted (ascending) sequences.
-- Where elements compare equal, select element from left input.
--
-- > asc_seq_left_biased_merge_by (compare `on` fst) [(0,'A'),(1,'B'),(4,'E')] (zip [1..] "bcd")
asc_seq_left_biased_merge_by :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
asc_seq_left_biased_merge_by = merge_by_resolve (\x _ -> x)
-- | Find the first two adjacent elements for which /f/ is True.
--
-- > find_adj (>) [1,2,3,3,2,1] == Just (3,2)
-- > find_adj (>=) [1,2,3,3,2,1] == Just (3,3)
find_adj :: (a -> a -> Bool) -> [a] -> Maybe (a,a)
find_adj f xs =
case xs of
p:q:xs' -> if f p q then Just (p,q) else find_adj f (q:xs')
_ -> Nothing
-- | 'find_adj' of '>='
--
-- > filter is_ascending (words "A AA AB ABB ABC ABA") == words "A AB ABC"
is_ascending :: Ord a => [a] -> Bool
is_ascending = isNothing . find_adj (>=)
-- | 'find_adj' of '>'
--
-- > filter is_non_descending (words "A AA AB ABB ABC ABA") == ["A","AA","AB","ABB","ABC"]
is_non_descending :: Ord a => [a] -> Bool
is_non_descending = isNothing . find_adj (>)
-- | Variant of `elem` that operates on a sorted list, halting.
-- This is 'O.member'.
--
-- > 16 `elem_ordered` [1,3 ..] == False
-- > 16 `elem` [1,3 ..] == undefined
elem_ordered :: Ord t => t -> [t] -> Bool
elem_ordered = O.member
-- | Variant of `elemIndex` that operates on a sorted list, halting.
--
-- > 16 `elemIndex_ordered` [1,3 ..] == Nothing
-- > 16 `elemIndex_ordered` [0,1,4,9,16,25,36,49,64,81,100] == Just 4
elemIndex_ordered :: Ord t => t -> [t] -> Maybe Int
elemIndex_ordered e =
let recur k l =
case l of
[] -> Nothing
x:l' -> if e == x
then Just k
else if x > e
then Nothing
else recur (k + 1) l'
in recur 0
-- | 'zipWith' variant that extends shorter side using given value.
zip_with_ext :: t -> u -> (t -> u -> v) -> [t] -> [u] -> [v]
zip_with_ext i j f p q =
case (p,q) of
([],_) -> zipWith f (repeat i) q
(_,[]) -> zipWith f p (repeat j)
(x:p',y:q') -> f x y : zip_with_ext i j f p' q'
{- | 'zip_with_ext' of ','
> let f = zip_ext 'i' 'j'
> f "" "" == []
> f "p" "" == zip "p" "j"
> f "" "q" == zip "i" "q"
> f "pp" "q" == zip "pp" "qj"
> f "p" "qq" == zip "pi" "qq"
-}
zip_ext :: t -> u -> [t] -> [u] -> [(t,u)]
zip_ext i j = zip_with_ext i j (,)
-- | Keep right variant of 'zipWith', where unused rhs values are returned.
--
-- > zip_with_kr (,) [1..3] ['a'..'e'] == ([(1,'a'),(2,'b'),(3,'c')],"de")
zip_with_kr :: (a -> b -> c) -> [a] -> [b] -> ([c],[b])
zip_with_kr f =
let go r p q =
case (p,q) of
(i:p',j:q') -> go (f i j : r) p' q'
_ -> (reverse r,q)
in go []
-- | A 'zipWith' variant that always consumes an element from the left
-- hand side (lhs), but only consumes an element from the right hand
-- side (rhs) if the zip function is 'Right' and not if 'Left'.
-- There's also a secondary function to continue if the rhs ends
-- before the lhs.
zip_with_perhaps_rhs :: (a -> b -> Either c c) -> (a -> c) -> [a] -> [b] -> [c]
zip_with_perhaps_rhs f g lhs rhs =
case (lhs,rhs) of
([],_) -> []
(_,[]) -> map g lhs
(p:lhs',q:rhs') -> case f p q of
Left r -> r : zip_with_perhaps_rhs f g lhs' rhs
Right r -> r : zip_with_perhaps_rhs f g lhs' rhs'
-- | Fill gaps in a sorted association list, range is inclusive at both ends.
--
-- > let r = [(1,'a'),(2,'x'),(3,'x'),(4,'x'),(5,'b'),(6,'x'),(7,'c'),(8,'x'),(9,'x')]
-- > in fill_gaps_ascending' 'x' (1,9) (zip [1,5,7] "abc") == r
fill_gaps_ascending :: (Enum n, Ord n) => t -> (n,n) -> [(n,t)] -> [(n,t)]
fill_gaps_ascending def_e (l,r) =
let f i (j,e) = if j > i then Left (i,def_e) else Right (j,e)
g i = (i,def_e)
in zip_with_perhaps_rhs f g [l .. r]
-- | Direct definition.
fill_gaps_ascending' :: (Num n,Enum n, Ord n) => t -> (n,n) -> [(n,t)] -> [(n,t)]
fill_gaps_ascending' def (l,r) =
let recur n x =
if n > r
then []
else case x of
[] -> zip [n .. r] (repeat def)
(m,e):x' -> if n < m
then (n,def) : recur (n + 1) x
else (m,e) : recur (n + 1) x'
in recur l
-- | Variant with default value for empty input list case.
minimumBy_or :: t -> (t -> t -> Ordering) -> [t] -> t
minimumBy_or p f q = if null q then p else minimumBy f q
-- | 'minimum' and 'maximum' in one pass.
--
-- > minmax "minmax" == ('a','x')
minmax :: Ord t => [t] -> (t,t)
minmax inp =
case inp of
[] -> error "minmax: null"
x:xs -> let mm p (l,r) = (min p l,max p r) in foldr mm (x,x) xs
-- | Append /k/ to the right of /l/ until result has /n/ places.
-- Truncates long input lists.
--
-- > map (pad_right '0' 2 . return) ['0' .. '9']
-- > pad_right '0' 12 "1101" == "110100000000"
-- > map (pad_right ' '3) ["S","E-L"] == ["S ","E-L"]
-- > pad_right '!' 3 "truncate" == "tru"
pad_right :: a -> Int -> [a] -> [a]
pad_right k n l = take n (l ++ repeat k)
-- | Variant that errors if the input list has more than /n/ places.
--
-- > map (pad_right_err '!' 3) ["x","xy","xyz","xyz!"]
pad_right_err :: t -> Int -> [t] -> [t]
pad_right_err k n l = if length l > n then error "pad_right_err?" else pad_right k n l
-- > pad_right_no_truncate '!' 3 "truncate" == "truncate"
pad_right_no_truncate :: a -> Int -> [a] -> [a]
pad_right_no_truncate k n l = if length l > n then l else pad_right k n l
-- | Append /k/ to the left of /l/ until result has /n/ places.
--
-- > map (pad_left '0' 2 . return) ['0' .. '9']
pad_left :: a -> Int -> [a] -> [a]
pad_left k n l = replicate (n - length l) k ++ l
-- * Embedding
-- | Locate first (leftmost) embedding of /q/ in /p/.
-- Return partial indices for failure at 'Left'.
--
-- > embedding ("embedding","ming") == Right [1,6,7,8]
-- > embedding ("embedding","mind") == Left [1,6,7]
embedding :: Eq t => ([t],[t]) -> Either [Int] [Int]
embedding =
let recur n r (p,q) =
case (p,q) of
(_,[]) -> Right (reverse r)
([],_) -> Left (reverse r)
(x:p',y:q') ->
let n' = n + 1
r' = if x == y then n : r else r
in recur n' r' (p',if x == y then q' else q)
in recur 0 []
embedding_err :: Eq t => ([t],[t]) -> [Int]
embedding_err = either (error "embedding_err") id . embedding
-- | Does /q/ occur in sequence, though not necessarily adjacently, in /p/.
--
-- > is_embedding [1 .. 9] [1,3,7] == True
-- > is_embedding "embedding" "ming" == True
-- > is_embedding "embedding" "mind" == False
is_embedding :: Eq t => [t] -> [t] -> Bool
is_embedding p q = isRight (embedding (p,q))
all_embeddings_m :: (Eq t,L.MonadLogic m) => [t] -> [t] -> m [Int]
all_embeddings_m p q =
let q_n = length q
recur p' q' n k = -- n = length k
if n == q_n
then return (reverse k)
else do (m,c) <- L.msum (map return p')
let k0:_ = k
c':_ = q'
L.guard (c == c' && (null k || m > k0))
let _:p'' = p'
_:q'' = q'
recur p'' q'' (n + 1) (m : k)
in recur (zip [0..] p) q 0 []
-- | Enumerate indices for all embeddings of /q/ in /p/.
--
-- > all_embeddings "all_embeddings" "leg" == [[1,4,12],[1,7,12],[2,4,12],[2,7,12]]
all_embeddings :: Eq t => [t] -> [t] -> [[Int]]
all_embeddings p = L.observeAll . all_embeddings_m p
-- * Un-list
-- | Unpack one element list.
unlist1 :: [t] -> Maybe t
unlist1 l =
case l of
[e] -> Just e
_ -> Nothing
-- | Erroring variant.
unlist1_err :: [t] -> t
unlist1_err = fromMaybe (error "unlist1") . unlist1
-- * Traversable
-- | Replace elements at 'Traversable' with result of joining with elements from list.
--
-- > let t = Node 0 [Node 1 [Node 2 [],Node 3 []],Node 4 []]
-- > putStrLn $ drawTree (fmap show t)
-- > let (_,u) = adopt_shape (\_ x -> x) "abcde" t
-- > putStrLn $ drawTree (fmap return u)
adopt_shape :: Traversable t => (a -> b -> c) -> [b] -> t a -> ([b],t c)
adopt_shape jn l =
let f (i:j) k = (j,jn k i)
f [] _ = error "adopt_shape: rhs ends"
in mapAccumL f 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 jn l = mapAccumL (adopt_shape jn) l
-- | Two-level variant of 'zip' [1..]
--
-- > list_number_2 ["number","list","2"]
list_number_2 :: [[x]] -> [[(Int,x)]]
list_number_2 = snd . adopt_shape_2 (flip (,)) [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 jn l =
let f (i:j) k = case k of
Nothing -> (i:j,Nothing)
Just k' -> (j,Just (jn k' i))
f [] _ = error "adopt_shape_m: rhs ends"
in mapAccumL f l
-- * Tree
{- | Given an 'Ordering' predicate where 'LT' opens a group, 'GT'
closes a group, and 'EQ' continues current group, construct tree
from list.
> let l = "a {b {c d} e f} g h i"
> let t = group_tree ((==) '{',(==) '}') l
> catMaybes (flatten t) == l
> let {d = putStrLn . drawTree . fmap show}
> in d (group_tree ((==) '(',(==) ')') "a(b(cd)ef)ghi")
-}
group_tree :: (a -> Bool,a -> Bool) -> [a] -> Tree.Tree (Maybe a)
group_tree (open_f,close_f) =
let unit e = Tree.Node (Just e) []
nil = Tree.Node Nothing []
insert_e (Tree.Node t l) e = Tree.Node t (e:l)
reverse_n (Tree.Node t l) = Tree.Node t (reverse l)
do_push (r,z) e =
case z of
h:z' -> (r,insert_e h (unit e) : z')
[] -> (unit e : r,[])
do_open (r,z) = (r,nil:z)
do_close (r,z) =
case z of
h0:h1:z' -> (r,insert_e h1 (reverse_n h0) : z')
h:z' -> (reverse_n h : r,z')
[] -> (r,z)
go st x =
case x of
[] -> Tree.Node Nothing (reverse (fst st))
e:x' -> if open_f e
then go (do_push (do_open st) e) x'
else if close_f e
then go (do_close (do_push st e)) x'
else go (do_push st e) x'
in go ([],[])
-- * Indexing
-- | Remove element at index.
--
-- > remove_ix 5 "remove" == "remov"
-- > remove_ix 5 "short" == undefined
remove_ix :: Int -> [a] -> [a]
remove_ix k l = let (p,q) = splitAt k l in p ++ tail q
-- | Select or remove elements at set of indices.
operate_ixs :: Bool -> [Int] -> [a] -> [a]
operate_ixs mode k =
let sel = if mode then notElem else elem
f (n,e) = if n `sel` k then Nothing else Just e
in mapMaybe f . zip [0..]
-- | Select elements at set of indices.
--
-- > select_ixs [1,3] "select" == "ee"
select_ixs :: [Int] -> [a] -> [a]
select_ixs = operate_ixs True
-- | Remove elements at set of indices.
--
-- > remove_ixs [1,3,5] "remove" == "rmv"
remove_ixs :: [Int] -> [a] -> [a]
remove_ixs = operate_ixs False
-- | Replace element at /i/ in /p/ by application of /f/.
--
-- > replace_ix negate 1 [1..3] == [1,-2,3]
replace_ix :: (a -> a) -> Int -> [a] -> [a]
replace_ix f i p =
let (q,r:s) = splitAt i p
in q ++ (f r : s)
-- | List equality, ignoring indicated indices.
--
-- > list_eq_ignoring_indices [3,5] "abcdefg" "abc.e.g" == True
list_eq_ignoring_indices :: (Eq t,Integral i) => [i] -> [t] -> [t] -> Bool
list_eq_ignoring_indices x =
let f n p q =
case (p,q) of
([],[]) -> True
([],_) -> False
(_,[]) -> False
(p1:p',q1:q') -> if n `elem` x || p1 == q1
then f (n + 1) p' q'
else False
in f 0
-- | Edit list to have /v/ at indices /k/.
-- Replacement assoc-list must be ascending.
-- All replacements must be in range.
--
-- > list_set_indices [(2,'C'),(4,'E')] "abcdefg" == "abCdEfg"
-- > list_set_indices [] "abcdefg" == "abcdefg"
-- > list_set_indices [(9,'I')] "abcdefg" == undefined
list_set_indices :: (Eq ix, Num ix) => [(ix,t)] -> [t] -> [t]
list_set_indices =
let f n r l =
case (r,l) of
([],_) -> l
(_,[]) -> error "list_set_indices: out of range?"
((k,v):r',l0:l') -> if n == k
then v : f (n + 1) r' l'
else l0 : f (n + 1) r l'
in f 0
-- | Variant of 'list_set_indices' with one replacement.
list_set_ix :: (Eq t, Num t) => t -> a -> [a] -> [a]
list_set_ix k v = list_set_indices [(k,v)]
-- | Cyclic indexing function.
--
-- > map (at_cyclic "cycle") [0..9] == "cyclecycle"
at_cyclic :: [a] -> Int -> a
at_cyclic l n =
let m = Map.fromList (zip [0..] l)
k = Map.size m
n' = n `mod` k
in fromMaybe (error "cyc_at") (Map.lookup n' m)