Vervis/src/Data/List/Local.hs
2020-02-19 10:59:38 +00:00

125 lines
4.3 KiB
Haskell

{- This file is part of Vervis.
-
- Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
module Data.List.Local
( -- groupByFst
groupJusts
, groupEithers
, groupPairs
, groupMap
, groupMapBy
, groupMapBy1
, lookupSorted
, sortAlign
)
where
import Data.Bifunctor
import Data.Function (on)
import Data.List.NonEmpty (NonEmpty (..), (<|), toList)
import Data.These
import qualified Data.List.Ordered as LO
-- | Takes a list of pairs and groups them by consecutive ranges with equal
-- first element. Returns a list of pairs, where each pair corresponds to one
-- such range.
--groupByFst :: Eq a => [(a, b)] -> [(a, [b])]
--groupByFst [] = []
--groupByFst ((x, y):ps) =
-- let (same, rest) = span ((== x) . fst) ps
-- in (x, y : map snd same) : groupByFst rest
-- | Group together sublists of Just items, and drop the Nothing items.
--
-- >>> groupJusts [Nothing, Nothing, Just 1, Just 4, Nothing, Just 2]
-- [[1, 4], [2]]
groupJusts :: Foldable f => f (Maybe a) -> [NonEmpty a]
groupJusts maybes = prepend $ foldr go (Nothing, []) maybes
where
prepend (Nothing, l) = l
prepend (Just x , l) = x : l
go Nothing (Nothing, ls) = (Nothing , ls)
go Nothing (Just l , ls) = (Nothing , l : ls)
go (Just x) (Nothing, ls) = (Just $ x :| [], ls)
go (Just x) (Just l , ls) = (Just $ x <| l , ls)
groupEithers :: Foldable f => f (Either a b) -> ([b], [(NonEmpty a, NonEmpty b)], [a])
groupEithers = foldr go ([], [], [])
where
go (Left x) ([] , [] , as) = ([], [] , x : as)
go (Left x) ([] , (xs, ys):ps, as) = ([], (x <| xs, ys) : ps , as)
go (Left x) (b:bs, ps , as) = ([], (x :| [], b :| bs) : ps, as)
go (Right y) (bs, ps, as) = (y : bs, ps, as)
groupPairs
:: Foldable f => f ([a], [b]) -> ([b], [(NonEmpty a, NonEmpty b)], [a])
groupPairs = groupEithers . foldr go []
where
go (xs, ys) es = map Left xs ++ map Right ys ++ es
-- | @groupMap f g l@ groups elements like 'group', except it compares them by
-- applying @f@ to elements and comparing these values using the 'Eq' instance.
-- It then maps the elements in each such equality group using @g@.
--
-- >>> groupMap fst snd [(1, 5), (1, 6), (2, 7), (2, 8), (2, 9)]
-- [(1, [5, 6]), (2, [7, 8, 9])]
groupMap :: Eq b => (a -> b) -> (a -> c) -> [a] -> [(b, NonEmpty c)]
groupMap f = groupMapBy ((==) `on` f) f
-- | Like 'groupMap', except it uses a comparison predicate instead of an 'Eq'
-- instance.
groupMapBy
:: (a -> a -> Bool) -> (a -> b) -> (a -> c) -> [a] -> [(b, NonEmpty c)]
groupMapBy _ _ _ [] = []
groupMapBy eq f g (x:xs) = toList $ groupMapBy1 eq f g $ x :| xs
-- | Like 'groupMapBy1', but takes and returns a 'NonEmpty'.
groupMapBy1
:: (a -> a -> Bool)
-> (a -> b)
-> (a -> c)
-> NonEmpty a
-> NonEmpty (b, NonEmpty c)
groupMapBy1 eq f g = go
where
go (x :| xs) =
let (ys, zs) = span (eq x) xs
rest = case zs of
[] -> []
z:l -> toList $ go $ z :| l
in (f x, g x :| map g ys) :| rest
lookupSorted :: Ord a => a -> [(a, b)] -> Maybe b
lookupSorted _ [] = Nothing
lookupSorted x ((y, z) : l) =
case compare x y of
LT -> lookupSorted x l
EQ -> Just z
GT -> Nothing
sortAlign :: Ord a => [(a, b)] -> [(a, b)] -> [(a, These b b)]
sortAlign xs ys = orderedAlign (prepare xs) (prepare ys)
where
prepare = LO.nubSortOn' fst
orderedAlign :: Ord a => [(a, b)] -> [(a, b)] -> [(a, These b b)]
orderedAlign [] ys = map (second That) ys
orderedAlign xs [] = map (second This) xs
orderedAlign xs@((u, w) : us) ys@((v, z) : vs) =
case compare u v of
LT -> (u, This w) : orderedAlign us ys
EQ -> (u, These w z) : orderedAlign us vs
GT -> (v, That z) : orderedAlign xs vs