{-# LANGUAGE DerivingVia, GeneralizedNewtypeDeriving, StandaloneDeriving #-}
module Math.ParetoFront (
  Comparison(..),
  Debatable(..),
  Front,
  Strata,
  singleton,
  stratum,
  getStrata,
  getFront,
  quota,
  nestedFold
 ) where

import Data.Foldable
import Data.List (partition, transpose)
import Data.Ord (Down(..))
import Data.Semigroup(Arg(..), Max(..), Min(..))

-- | The outcome of comparing two items by possibly multiple contradicting
-- criteria.
data Comparison =
  -- | Where the second item is preferred by all used criteria
  Dominated |
  -- | Where no item is preferred by any used criterion
  WeakTie |
  -- | Where each item is preferred by at least one criterion
  StrongTie |
  -- | Where the first item is preferred by all used critera
  Dominates
 deriving(Eq Comparison
Eq Comparison
-> (Comparison -> Comparison -> Ordering)
-> (Comparison -> Comparison -> Bool)
-> (Comparison -> Comparison -> Bool)
-> (Comparison -> Comparison -> Bool)
-> (Comparison -> Comparison -> Bool)
-> (Comparison -> Comparison -> Comparison)
-> (Comparison -> Comparison -> Comparison)
-> Ord Comparison
Comparison -> Comparison -> Bool
Comparison -> Comparison -> Ordering
Comparison -> Comparison -> Comparison
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Comparison -> Comparison -> Comparison
$cmin :: Comparison -> Comparison -> Comparison
max :: Comparison -> Comparison -> Comparison
$cmax :: Comparison -> Comparison -> Comparison
>= :: Comparison -> Comparison -> Bool
$c>= :: Comparison -> Comparison -> Bool
> :: Comparison -> Comparison -> Bool
$c> :: Comparison -> Comparison -> Bool
<= :: Comparison -> Comparison -> Bool
$c<= :: Comparison -> Comparison -> Bool
< :: Comparison -> Comparison -> Bool
$c< :: Comparison -> Comparison -> Bool
compare :: Comparison -> Comparison -> Ordering
$ccompare :: Comparison -> Comparison -> Ordering
$cp1Ord :: Eq Comparison
Ord,Comparison -> Comparison -> Bool
(Comparison -> Comparison -> Bool)
-> (Comparison -> Comparison -> Bool) -> Eq Comparison
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Comparison -> Comparison -> Bool
$c/= :: Comparison -> Comparison -> Bool
== :: Comparison -> Comparison -> Bool
$c== :: Comparison -> Comparison -> Bool
Eq,Int -> Comparison -> ShowS
[Comparison] -> ShowS
Comparison -> String
(Int -> Comparison -> ShowS)
-> (Comparison -> String)
-> ([Comparison] -> ShowS)
-> Show Comparison
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Comparison] -> ShowS
$cshowList :: [Comparison] -> ShowS
show :: Comparison -> String
$cshow :: Comparison -> String
showsPrec :: Int -> Comparison -> ShowS
$cshowsPrec :: Int -> Comparison -> ShowS
Show,ReadPrec [Comparison]
ReadPrec Comparison
Int -> ReadS Comparison
ReadS [Comparison]
(Int -> ReadS Comparison)
-> ReadS [Comparison]
-> ReadPrec Comparison
-> ReadPrec [Comparison]
-> Read Comparison
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Comparison]
$creadListPrec :: ReadPrec [Comparison]
readPrec :: ReadPrec Comparison
$creadPrec :: ReadPrec Comparison
readList :: ReadS [Comparison]
$creadList :: ReadS [Comparison]
readsPrec :: Int -> ReadS Comparison
$creadsPrec :: Int -> ReadS Comparison
Read)

instance Semigroup Comparison where
  Comparison
WeakTie <> :: Comparison -> Comparison -> Comparison
<> Comparison
b = Comparison
b
  Comparison
a <> Comparison
WeakTie = Comparison
a
  Comparison
Dominates <> Comparison
Dominates = Comparison
Dominates
  Comparison
Dominated <> Comparison
Dominated = Comparison
Dominated
  Comparison
_ <> Comparison
_ = Comparison
StrongTie

instance Monoid Comparison where
  mempty :: Comparison
mempty = Comparison
WeakTie

-- | Items which can be compared by possibly multiple criteria contradicting
-- criteria
class Debatable a where
  weigh :: a -> a -> Comparison

instance Ord a => Debatable (Min a) where
  weigh :: Min a -> Min a -> Comparison
weigh (Min a
a) (Min a
b) = case a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b of
    Ordering
LT -> Comparison
Dominates
    Ordering
GT -> Comparison
Dominated
    Ordering
EQ -> Comparison
WeakTie

deriving via Min Int instance Debatable Int
deriving via Min Integer instance Debatable Integer
deriving via Min Double instance Debatable Double
deriving via Min Float instance Debatable Float
deriving via Min (Down a) instance Ord a => Debatable (Max a)

instance Debatable a => Debatable (Down a) where
  weigh :: Down a -> Down a -> Comparison
weigh (Down a
a) (Down a
b) = case a -> a -> Comparison
forall a. Debatable a => a -> a -> Comparison
weigh a
a a
b of
    Comparison
Dominates -> Comparison
Dominated
    Comparison
Dominated -> Comparison
Dominates
    Comparison
r -> Comparison
r

instance Debatable a => Debatable (Arg a b) where
  weigh :: Arg a b -> Arg a b -> Comparison
weigh (Arg a
a b
_) (Arg a
b b
_) = a -> a -> Comparison
forall a. Debatable a => a -> a -> Comparison
weigh a
a a
b

instance (Debatable a, Debatable b) => Debatable (a,b) where
  weigh :: (a, b) -> (a, b) -> Comparison
weigh ~(a
a1,b
a2) ~(a
b1,b
b2) = a -> a -> Comparison
forall a. Debatable a => a -> a -> Comparison
weigh a
a1 a
b1 Comparison -> Comparison -> Comparison
forall a. Semigroup a => a -> a -> a
<> b -> b -> Comparison
forall a. Debatable a => a -> a -> Comparison
weigh b
a2 b
b2

instance (Debatable a, Debatable b, Debatable c) => Debatable (a,b,c) where
  weigh :: (a, b, c) -> (a, b, c) -> Comparison
weigh ~(a
a1,b
a2,c
a3) ~(a
b1,b
b2,c
b3) = a -> a -> Comparison
forall a. Debatable a => a -> a -> Comparison
weigh a
a1 a
b1 Comparison -> Comparison -> Comparison
forall a. Semigroup a => a -> a -> a
<> b -> b -> Comparison
forall a. Debatable a => a -> a -> Comparison
weigh b
a2 b
b2 Comparison -> Comparison -> Comparison
forall a. Semigroup a => a -> a -> a
<> c -> c -> Comparison
forall a. Debatable a => a -> a -> Comparison
weigh c
a3 c
b3

instance (Debatable a, Debatable b, Debatable c, Debatable d) =>
  Debatable (a,b,c,d) where
  weigh :: (a, b, c, d) -> (a, b, c, d) -> Comparison
weigh ~(a
a1,b
a2,c
a3,d
a4) ~(a
b1,b
b2,c
b3,d
b4) = a -> a -> Comparison
forall a. Debatable a => a -> a -> Comparison
weigh a
a1 a
b1 Comparison -> Comparison -> Comparison
forall a. Semigroup a => a -> a -> a
<>
    b -> b -> Comparison
forall a. Debatable a => a -> a -> Comparison
weigh b
a2 b
b2 Comparison -> Comparison -> Comparison
forall a. Semigroup a => a -> a -> a
<>
    c -> c -> Comparison
forall a. Debatable a => a -> a -> Comparison
weigh c
a3 c
b3 Comparison -> Comparison -> Comparison
forall a. Semigroup a => a -> a -> a
<>
    d -> d -> Comparison
forall a. Debatable a => a -> a -> Comparison
weigh d
a4 d
b4

-- | A collection of items where no item is preferred by all criteria.
newtype Front a = Front [a] deriving (a -> Front a -> Bool
Front m -> m
Front a -> [a]
Front a -> Bool
Front a -> Int
Front a -> a
Front a -> a
Front a -> a
Front a -> a
(a -> m) -> Front a -> m
(a -> m) -> Front a -> m
(a -> b -> b) -> b -> Front a -> b
(a -> b -> b) -> b -> Front a -> b
(b -> a -> b) -> b -> Front a -> b
(b -> a -> b) -> b -> Front a -> b
(a -> a -> a) -> Front a -> a
(a -> a -> a) -> Front a -> a
(forall m. Monoid m => Front m -> m)
-> (forall m a. Monoid m => (a -> m) -> Front a -> m)
-> (forall m a. Monoid m => (a -> m) -> Front a -> m)
-> (forall a b. (a -> b -> b) -> b -> Front a -> b)
-> (forall a b. (a -> b -> b) -> b -> Front a -> b)
-> (forall b a. (b -> a -> b) -> b -> Front a -> b)
-> (forall b a. (b -> a -> b) -> b -> Front a -> b)
-> (forall a. (a -> a -> a) -> Front a -> a)
-> (forall a. (a -> a -> a) -> Front a -> a)
-> (forall a. Front a -> [a])
-> (forall a. Front a -> Bool)
-> (forall a. Front a -> Int)
-> (forall a. Eq a => a -> Front a -> Bool)
-> (forall a. Ord a => Front a -> a)
-> (forall a. Ord a => Front a -> a)
-> (forall a. Num a => Front a -> a)
-> (forall a. Num a => Front a -> a)
-> Foldable Front
forall a. Eq a => a -> Front a -> Bool
forall a. Num a => Front a -> a
forall a. Ord a => Front a -> a
forall m. Monoid m => Front m -> m
forall a. Front a -> Bool
forall a. Front a -> Int
forall a. Front a -> [a]
forall a. (a -> a -> a) -> Front a -> a
forall m a. Monoid m => (a -> m) -> Front a -> m
forall b a. (b -> a -> b) -> b -> Front a -> b
forall a b. (a -> b -> b) -> b -> Front a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: Front a -> a
$cproduct :: forall a. Num a => Front a -> a
sum :: Front a -> a
$csum :: forall a. Num a => Front a -> a
minimum :: Front a -> a
$cminimum :: forall a. Ord a => Front a -> a
maximum :: Front a -> a
$cmaximum :: forall a. Ord a => Front a -> a
elem :: a -> Front a -> Bool
$celem :: forall a. Eq a => a -> Front a -> Bool
length :: Front a -> Int
$clength :: forall a. Front a -> Int
null :: Front a -> Bool
$cnull :: forall a. Front a -> Bool
toList :: Front a -> [a]
$ctoList :: forall a. Front a -> [a]
foldl1 :: (a -> a -> a) -> Front a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Front a -> a
foldr1 :: (a -> a -> a) -> Front a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Front a -> a
foldl' :: (b -> a -> b) -> b -> Front a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Front a -> b
foldl :: (b -> a -> b) -> b -> Front a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Front a -> b
foldr' :: (a -> b -> b) -> b -> Front a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Front a -> b
foldr :: (a -> b -> b) -> b -> Front a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Front a -> b
foldMap' :: (a -> m) -> Front a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Front a -> m
foldMap :: (a -> m) -> Front a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Front a -> m
fold :: Front m -> m
$cfold :: forall m. Monoid m => Front m -> m
Foldable, Int -> Front a -> ShowS
[Front a] -> ShowS
Front a -> String
(Int -> Front a -> ShowS)
-> (Front a -> String) -> ([Front a] -> ShowS) -> Show (Front a)
forall a. Show a => Int -> Front a -> ShowS
forall a. Show a => [Front a] -> ShowS
forall a. Show a => Front a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Front a] -> ShowS
$cshowList :: forall a. Show a => [Front a] -> ShowS
show :: Front a -> String
$cshow :: forall a. Show a => Front a -> String
showsPrec :: Int -> Front a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Front a -> ShowS
Show)

-- | A series of 'Front's such that each subsequent 'Front' consists of
-- items for which some item in the previous front is preferable by all
-- criteria.
newtype Strata a = Strata  [Front a] deriving (Int -> Strata a -> ShowS
[Strata a] -> ShowS
Strata a -> String
(Int -> Strata a -> ShowS)
-> (Strata a -> String) -> ([Strata a] -> ShowS) -> Show (Strata a)
forall a. Show a => Int -> Strata a -> ShowS
forall a. Show a => [Strata a] -> ShowS
forall a. Show a => Strata a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Strata a] -> ShowS
$cshowList :: forall a. Show a => [Strata a] -> ShowS
show :: Strata a -> String
$cshow :: forall a. Show a => Strata a -> String
showsPrec :: Int -> Strata a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Strata a -> ShowS
Show)

instance Foldable Strata where
  foldMap :: (a -> m) -> Strata a -> m
foldMap a -> m
f (Strata [Front a]
l) = (Front a -> m) -> [Front a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> m) -> Front a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) [Front a]
l

singleton :: a -> Front a
singleton :: a -> Front a
singleton a
a = [a] -> Front a
forall a. [a] -> Front a
Front [a
a]

stratum :: a -> Strata a
stratum :: a -> Strata a
stratum a
a = [Front a] -> Strata a
forall a. [Front a] -> Strata a
Strata [a -> Front a
forall a. a -> Front a
singleton a
a]

fuse :: Debatable a => Front a -> Front a -> (Front a, Front a, Front a)
fuse :: Front a -> Front a -> (Front a, Front a, Front a)
fuse (Front [a]
a) (Front [a]
b) = let
  m :: [[Comparison]]
m = (a -> [Comparison]) -> [a] -> [[Comparison]]
forall a b. (a -> b) -> [a] -> [b]
map (((a -> Comparison) -> [a] -> [Comparison])
-> [a] -> (a -> Comparison) -> [Comparison]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> Comparison) -> [a] -> [Comparison]
forall a b. (a -> b) -> [a] -> [b]
map [a]
b ((a -> Comparison) -> [Comparison])
-> (a -> a -> Comparison) -> a -> [Comparison]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> Comparison
forall a. Debatable a => a -> a -> Comparison
weigh) [a]
a
  m' :: [[Comparison]]
m' = [[Comparison]] -> [[Comparison]]
forall a. [[a]] -> [[a]]
transpose [[Comparison]]
m
  s :: [Bool]
s = ([Comparison] -> Bool) -> [[Comparison]] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Bool
not (Bool -> Bool) -> ([Comparison] -> Bool) -> [Comparison] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Comparison -> Bool) -> [Comparison] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Comparison -> Comparison -> Bool
forall a. Eq a => a -> a -> Bool
== Comparison
Dominated)) [[Comparison]]
m
  s' :: [Bool]
s' = ([Comparison] -> Bool) -> [[Comparison]] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Bool
not (Bool -> Bool) -> ([Comparison] -> Bool) -> [Comparison] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Comparison -> Bool) -> [Comparison] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Comparison -> Comparison -> Bool
forall a. Eq a => a -> a -> Bool
== Comparison
Dominates)) [[Comparison]]
m'
  ([(a, Bool)]
f1, [(a, Bool)]
t1) = ((a, Bool) -> Bool) -> [(a, Bool)] -> ([(a, Bool)], [(a, Bool)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (a, Bool) -> Bool
forall a b. (a, b) -> b
snd ([(a, Bool)] -> ([(a, Bool)], [(a, Bool)]))
-> [(a, Bool)] -> ([(a, Bool)], [(a, Bool)])
forall a b. (a -> b) -> a -> b
$ [a] -> [Bool] -> [(a, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
a [Bool]
s
  ([(a, Bool)]
f2, [(a, Bool)]
t2) = ((a, Bool) -> Bool) -> [(a, Bool)] -> ([(a, Bool)], [(a, Bool)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (a, Bool) -> Bool
forall a b. (a, b) -> b
snd ([(a, Bool)] -> ([(a, Bool)], [(a, Bool)]))
-> [(a, Bool)] -> ([(a, Bool)], [(a, Bool)])
forall a b. (a -> b) -> a -> b
$ [a] -> [Bool] -> [(a, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
b [Bool]
s'
  in ([a] -> Front a
forall a. [a] -> Front a
Front ([a] -> Front a) -> [a] -> Front a
forall a b. (a -> b) -> a -> b
$ ((a, Bool) -> a) -> [(a, Bool)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Bool) -> a
forall a b. (a, b) -> a
fst ([(a, Bool)]
f1 [(a, Bool)] -> [(a, Bool)] -> [(a, Bool)]
forall a. [a] -> [a] -> [a]
++ [(a, Bool)]
f2), [a] -> Front a
forall a. [a] -> Front a
Front ([a] -> Front a) -> [a] -> Front a
forall a b. (a -> b) -> a -> b
$ ((a, Bool) -> a) -> [(a, Bool)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Bool) -> a
forall a b. (a, b) -> a
fst [(a, Bool)]
t1, [a] -> Front a
forall a. [a] -> Front a
Front ([a] -> Front a) -> [a] -> Front a
forall a b. (a -> b) -> a -> b
$ ((a, Bool) -> a) -> [(a, Bool)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Bool) -> a
forall a b. (a, b) -> a
fst [(a, Bool)]
t2)

-- | Where two 'Front's are combined, all items are retained except those for
-- which at least one other item is preferred by all criteria.
instance Debatable a => Semigroup (Front a) where
  Front a
a <> :: Front a -> Front a -> Front a
<> Front a
b = let
    (Front a
r, Front a
_, Front a
_) = Front a -> Front a -> (Front a, Front a, Front a)
forall a.
Debatable a =>
Front a -> Front a -> (Front a, Front a, Front a)
fuse Front a
a Front a
b
    in Front a
r

instance Debatable a => Monoid (Front a) where
  mempty :: Front a
mempty = [a] -> Front a
forall a. [a] -> Front a
Front []

instance Debatable a => Semigroup (Strata a) where
  Strata a
a <> :: Strata a -> Strata a -> Strata a
<> Strata a
b = [Strata a] -> Strata a
forall a. Monoid a => [a] -> a
mconcat [Strata a
a,Strata a
b]
  
instance Debatable a => Monoid (Strata a) where
  mempty :: Strata a
mempty = [Front a] -> Strata a
forall a. [Front a] -> Strata a
Strata []
  mconcat :: [Strata a] -> Strata a
mconcat = [Front a] -> Strata a
forall a. [Front a] -> Strata a
Strata ([Front a] -> Strata a)
-> ([Strata a] -> [Front a]) -> [Strata a] -> Strata a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Front a]] -> [Front a]
forall a. Debatable a => [[Front a]] -> [Front a]
rebuild ([[Front a]] -> [Front a])
-> ([Strata a] -> [[Front a]]) -> [Strata a] -> [Front a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Front a]] -> [[Front a]]
forall a. [[a]] -> [[a]]
transpose ([[Front a]] -> [[Front a]])
-> ([Strata a] -> [[Front a]]) -> [Strata a] -> [[Front a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Strata a -> [Front a]) -> [Strata a] -> [[Front a]]
forall a b. (a -> b) -> [a] -> [b]
map Strata a -> [Front a]
forall a. Strata a -> [Front a]
getStrata where
    rebuild :: [[Front a]] -> [Front a]
rebuild [] = []
    rebuild ([] : [[Front a]]
r) = [[Front a]] -> [Front a]
rebuild [[Front a]]
r
    rebuild ([Front a
x] : [[Front a]]
r) = Front a
x Front a -> [Front a] -> [Front a]
forall a. a -> [a] -> [a]
: [[Front a]] -> [Front a]
rebuild [[Front a]]
r
    rebuild ((Front a
x : Front a
y : [Front a]
s) : [[Front a]]
r) = let
      (Front a
f, Front a
p, Front a
q) = Front a -> Front a -> (Front a, Front a, Front a)
forall a.
Debatable a =>
Front a -> Front a -> (Front a, Front a, Front a)
fuse Front a
x Front a
y
      r' :: [[Front a]]
r' = Front a -> [[Front a]] -> [[Front a]]
forall a. Front a -> [[Front a]] -> [[Front a]]
push Front a
p ([[Front a]] -> [[Front a]]) -> [[Front a]] -> [[Front a]]
forall a b. (a -> b) -> a -> b
$ Front a -> [[Front a]] -> [[Front a]]
forall a. Front a -> [[Front a]] -> [[Front a]]
push Front a
q [[Front a]]
r
      in [[Front a]] -> [Front a]
rebuild ((Front a
fFront a -> [Front a] -> [Front a]
forall a. a -> [a] -> [a]
: [Front a]
s)[Front a] -> [[Front a]] -> [[Front a]]
forall a. a -> [a] -> [a]
: [[Front a]]
r')
    push :: Front a -> [[Front a]] -> [[Front a]]
push (Front []) [[Front a]]
r = [[Front a]]
r
    push Front a
q [] = [[Front a
q]]
    push Front a
q ([Front a]
s : [[Front a]]
r) = ((Front a
qFront a -> [Front a] -> [Front a]
forall a. a -> [a] -> [a]
:[Front a]
s) [Front a] -> [[Front a]] -> [[Front a]]
forall a. a -> [a] -> [a]
: [[Front a]]
r)


getFront :: Front a -> [a]
getFront :: Front a -> [a]
getFront (Front [a]
l) = [a]
l

getStrata :: Strata a -> [Front a]
getStrata :: Strata a -> [Front a]
getStrata (Strata [Front a]
l) = [Front a]
l

-- | Drop fronts after those accounting for the first n items.
quota :: Int -> Strata a -> Strata a
quota :: Int -> Strata a -> Strata a
quota Int
_ (Strata []) = [Front a] -> Strata a
forall a. [Front a] -> Strata a
Strata []
quota Int
n (Strata (Front a
a:[Front a]
r))
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = let
    Strata [Front a]
r' = Int -> Strata a -> Strata a
forall a. Int -> Strata a -> Strata a
quota (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Front a -> [a]
forall a. Front a -> [a]
getFront Front a
a)) ([Front a] -> Strata a
forall a. [Front a] -> Strata a
Strata [Front a]
r)
    in [Front a] -> Strata a
forall a. [Front a] -> Strata a
Strata (Front a
a Front a -> [Front a] -> [Front a]
forall a. a -> [a] -> [a]
: [Front a]
r')
  | Bool
otherwise = [Front a] -> Strata a
forall a. [Front a] -> Strata a
Strata []

-- | 'foldMap' each front separately with one function, then 'foldMap' the
-- results.
nestedFold :: (Monoid m, Monoid n) => (a -> m) -> (m -> n) -> Strata a -> n
nestedFold :: (a -> m) -> (m -> n) -> Strata a -> n
nestedFold a -> m
f m -> n
g (Strata [Front a]
l) = (Front a -> n) -> [Front a] -> n
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (m -> n
g (m -> n) -> (Front a -> m) -> Front a -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m) -> Front a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) [Front a]
l