{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-}
module Data.Discrimination.Sorting
  ( Sort(..)
  -- * Sorting
  , Sorting(..)
  , Sorting1(..)
  -- * Combinators
  -- $common
  , sort, sortWith, desc
  , sortingCompare
  -- * Container Construction
  , toMap
  , toMapWith
  , toMapWithKey
  , toIntMap
  , toIntMapWith
  , toIntMapWithKey
  , toSet
  , toIntSet
  -- * Internals
  , sortingNat
  , sortingBag
  , sortingSet
  ) where

import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.Bits
import Data.Discrimination.Grouping
import Data.Discrimination.Internal
import Data.Foldable as Foldable hiding (concat)
import Data.Functor.Compose
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Divisible
import Data.Functor.Contravariant.Generic
import Data.Int
import Data.IntMap.Lazy as IntMap
import Data.IntSet as IntSet
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty)
import Data.Map as Map
import Data.Proxy
import Data.Semigroup hiding (Any)
import Data.Set as Set
import Data.Typeable
import Data.Void
import Data.Word
import Numeric.Natural (Natural)
import Prelude hiding (read, concat)
import Data.Functor.Classes (Ord1 (..))

-- $setup
-- >>> import qualified Data.Map as Map
-- >>> import qualified Data.IntMap as IntMap

--------------------------------------------------------------------------------
-- * Common
--------------------------------------------------------------------------------


-- | Stable Ordered Discriminator

-- TODO: use [(a,b)] -> [NonEmpty b] to better indicate safety?
newtype Sort a = Sort { forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort :: forall b. [(a,b)] -> [[b]] }
  deriving Typeable

mkSort :: (forall b. [(a, b)] -> [[b]]) -> Sort a
mkSort :: forall a. (forall b. [(a, b)] -> [[b]]) -> Sort a
mkSort forall b. [(a, b)] -> [[b]]
f = forall a. (forall b. [(a, b)] -> [[b]]) -> Sort a
Sort forall a b. (a -> b) -> a -> b
$ \[(a, b)]
xs -> case [(a, b)]
xs of
  []       -> []
  [(a
_, b
v)] -> [[b
v]]
  [(a, b)]
_        -> forall b. [(a, b)] -> [[b]]
f [(a, b)]
xs

type role Sort representational

instance Contravariant Sort where
  contramap :: forall a' a. (a' -> a) -> Sort a -> Sort a'
contramap a' -> a
f (Sort forall b. [(a, b)] -> [[b]]
g) = forall a. (forall b. [(a, b)] -> [[b]]) -> Sort a
Sort forall a b. (a -> b) -> a -> b
$ forall b. [(a, b)] -> [[b]]
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a' -> a
f)

instance Divisible Sort where
  conquer :: forall a. Sort a
conquer = forall a. (forall b. [(a, b)] -> [[b]]) -> Sort a
mkSort forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd
  divide :: forall a b c. (a -> (b, c)) -> Sort b -> Sort c -> Sort a
divide a -> (b, c)
k (Sort forall b. [(b, b)] -> [[b]]
l) (Sort forall b. [(c, b)] -> [[b]]
r) = forall a. (forall b. [(a, b)] -> [[b]]) -> Sort a
Sort forall a b. (a -> b) -> a -> b
$ \[(a, b)]
xs ->
    forall b. [(b, b)] -> [[b]]
l [ (b
b, (c
c, b
d)) | (a
a,b
d) <- [(a, b)]
xs, let (b
b, c
c) = a -> (b, c)
k a
a] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b. [(c, b)] -> [[b]]
r

instance Decidable Sort where
  lose :: forall a. (a -> Void) -> Sort a
lose a -> Void
k = forall a. (forall b. [(a, b)] -> [[b]]) -> Sort a
Sort forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Void -> a
absurdforall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> Void
kforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> a
fst)
  choose :: forall a b c. (a -> Either b c) -> Sort b -> Sort c -> Sort a
choose a -> Either b c
f (Sort forall b. [(b, b)] -> [[b]]
l) (Sort forall b. [(c, b)] -> [[b]]
r) = forall a. (forall b. [(a, b)] -> [[b]]) -> Sort a
mkSort forall a b. (a -> b) -> a -> b
$ \[(a, b)]
xs -> let
      ys :: [(Either b c, b)]
ys = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a -> Either b c
f) [(a, b)]
xs
    in forall b. [(b, b)] -> [[b]]
l [ (b
k,b
v) | (Left b
k, b
v) <- [(Either b c, b)]
ys]
    forall a. [a] -> [a] -> [a]
++ forall b. [(c, b)] -> [[b]]
r [ (c
k,b
v) | (Right c
k, b
v) <- [(Either b c, b)]
ys]

instance Semigroup (Sort a) where
  Sort forall b. [(a, b)] -> [[b]]
l <> :: Sort a -> Sort a -> Sort a
<> Sort forall b. [(a, b)] -> [[b]]
r = forall a. (forall b. [(a, b)] -> [[b]]) -> Sort a
Sort forall a b. (a -> b) -> a -> b
$ \[(a, b)]
xs -> forall b. [(a, b)] -> [[b]]
l [ (forall a b. (a, b) -> a
fst (a, b)
x, (a, b)
x) | (a, b)
x <- [(a, b)]
xs ] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b. [(a, b)] -> [[b]]
r

instance Monoid (Sort a) where
  mempty :: Sort a
mempty = forall (f :: * -> *) a. Divisible f => f a
conquer
  mappend :: Sort a -> Sort a -> Sort a
mappend = forall a. Semigroup a => a -> a -> a
(<>)

--------------------------------------------------------------------------------
-- * Ordered Discrimination
--------------------------------------------------------------------------------

-- | 'Ord' equipped with a compatible stable, ordered discriminator.
--
-- Law:
--
-- @
-- 'sortingCompare' x y ≡ 'compare' x y
-- @
class (Grouping a, Ord a) => Sorting a where
  -- | For every strictly monotone-increasing function @f@:
  --
  -- @
  -- 'contramap' f 'sorting' ≡ 'sorting'
  -- @
  sorting :: Sort a
  default sorting :: Deciding Sorting a => Sort a
  sorting = forall (q :: * -> Constraint) a (f :: * -> *)
       (p :: (* -> Constraint) -> *).
(Deciding q a, Decidable f) =>
p q -> (forall b. q b => f b) -> f a
deciding (forall {k} (t :: k). Proxy t
Proxy :: Proxy Sorting) forall a. Sorting a => Sort a
sorting

instance Sorting () where
  sorting :: Sort ()
sorting = forall (f :: * -> *) a. Divisible f => f a
conquer

instance Sorting Integer where
  sorting :: Sort Integer
sorting = forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose Integer -> Either (Int, [Word]) (Either Int (Int, [Word]))
integerCases (forall a. Sort a -> Sort a
desc forall a. Sorting a => Sort a
sorting) (forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose forall a. a -> a
id forall a. Sorting a => Sort a
sorting forall a. Sorting a => Sort a
sorting)

instance Sorting Natural where
  sorting :: Sort Natural
sorting = forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose Natural -> Either Word (Int, [Word])
naturalCases forall a. Sorting a => Sort a
sorting forall a. Sorting a => Sort a
sorting

instance Sorting Word8 where
  sorting :: Sort Word8
sorting = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Sort Int
sortingNat Int
256)

instance Sorting Word16 where
  sorting :: Sort Word16
sorting = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Sort Int
sortingNat Int
65536)

instance Sorting Word32 where
  sorting :: Sort Word32
sorting = forall a. (forall b. [(a, b)] -> [[b]]) -> Sort a
Sort (forall a b. Eq a => [(a, b)] -> [[b]]
runs forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort (Int -> Sort Int
sortingNat Int
65536) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort (Int -> Sort Int
sortingNat Int
65536) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {a} {a} {b}.
(Integral a, Bits a, Bits a, Num a, Num a) =>
(a, b) -> (a, (a, (a, b)))
radices) where
    radices :: (a, b) -> (a, (a, (a, b)))
radices (a
x,b
b) = (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x forall a. Bits a => a -> a -> a
.&. a
0xffff, (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bits a => a -> Int -> a
unsafeShiftR a
x Int
16), (a
x,b
b)))


instance Sorting Word64 where
  sorting :: Sort Word64
sorting = forall a. (forall b. [(a, b)] -> [[b]]) -> Sort a
Sort (forall a b. Eq a => [(a, b)] -> [[b]]
runs forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort (Int -> Sort Int
sortingNat Int
65536) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort (Int -> Sort Int
sortingNat Int
65536) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
                         forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort (Int -> Sort Int
sortingNat Int
65536) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort (Int -> Sort Int
sortingNat Int
65536) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {a} {a} {a} {a} {b}.
(Integral a, Bits a, Bits a, Bits a, Bits a, Num a, Num a, Num a,
 Num a) =>
(a, b) -> (a, (a, (a, (a, (a, b)))))
radices)
    where
      radices :: (a, b) -> (a, (a, (a, (a, (a, b)))))
radices (a
x,b
b) = (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x forall a. Bits a => a -> a -> a
.&. a
0xffff, (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bits a => a -> Int -> a
unsafeShiftR a
x Int
16) forall a. Bits a => a -> a -> a
.&. a
0xffff
                    , (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bits a => a -> Int -> a
unsafeShiftR a
x Int
32) forall a. Bits a => a -> a -> a
.&. a
0xffff, (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bits a => a -> Int -> a
unsafeShiftR a
x Int
48)
                    , (a
x,b
b)))))


instance Sorting Word where
  sorting :: Sort Word
sorting
    | (forall a. Bounded a => a
maxBound :: Word) forall a. Eq a => a -> a -> Bool
== Word
4294967295 = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Word -> Word32) forall a. Sorting a => Sort a
sorting
    | Bool
otherwise                        = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Word -> Word64) forall a. Sorting a => Sort a
sorting

instance Sorting Int8 where
  sorting :: Sort Int8
sorting = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (\Int8
x -> forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
x forall a. Num a => a -> a -> a
+ Int
128) (Int -> Sort Int
sortingNat Int
256)

instance Sorting Int16 where
  sorting :: Sort Int16
sorting = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (\Int16
x -> forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
x forall a. Num a => a -> a -> a
+ Int
32768) (Int -> Sort Int
sortingNat Int
65536)

instance Sorting Int32 where
  sorting :: Sort Int32
sorting = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (\Int32
x -> forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
x forall a. Num a => a -> a -> a
- forall a. Bounded a => a
minBound) :: Word32) forall a. Sorting a => Sort a
sorting

instance Sorting Int64 where
  sorting :: Sort Int64
sorting = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (\Int64
x -> forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
x forall a. Num a => a -> a -> a
- forall a. Bounded a => a
minBound) :: Word64) forall a. Sorting a => Sort a
sorting

instance Sorting Int where
  sorting :: Sort Int
sorting = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (\Int
x -> forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
x forall a. Num a => a -> a -> a
- forall a. Bounded a => a
minBound) :: Word) forall a. Sorting a => Sort a
sorting

instance Sorting Char where
  sorting :: Sort Char
sorting = forall a. (forall b. [(a, b)] -> [[b]]) -> Sort a
Sort (forall a b. Eq a => [(a, b)] -> [[b]]
runs forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort (Int -> Sort Int
sortingNat Int
1087) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort (Int -> Sort Int
sortingNat Int
1024) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {b}. Enum a => (a, b) -> (Int, (Int, (Int, b)))
radices) where
    radices :: (a, b) -> (Int, (Int, (Int, b)))
radices (a
c,b
b) = (Int
x forall a. Bits a => a -> a -> a
.&. Int
0x3ff, (forall a. Bits a => a -> Int -> a
unsafeShiftR Int
x Int
10, (Int
x,b
b))) where
      x :: Int
x = forall a. Enum a => a -> Int
fromEnum a
c

instance Sorting Void
instance Sorting Bool
instance Sorting Ordering
instance Sorting a => Sorting [a]
instance Sorting a => Sorting (NonEmpty a)
instance Sorting a => Sorting (Maybe a)
instance (Sorting a, Sorting b) => Sorting (Either a b)
instance (Sorting a, Sorting b) => Sorting (a, b)
instance (Sorting a, Sorting b, Sorting c) => Sorting (a, b, c)
instance (Sorting a, Sorting b, Sorting c, Sorting d) => Sorting (a, b, c, d)
instance (Sorting1 f, Sorting1 g, Sorting a) => Sorting (Compose f g a) where
  sorting :: Sort (Compose f g a)
sorting = forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` forall (f :: * -> *) a. Sorting1 f => Sort a -> Sort (f a)
sorting1 (forall (f :: * -> *) a. Sorting1 f => Sort a -> Sort (f a)
sorting1 forall a. Sorting a => Sort a
sorting)

class (Grouping1 f, Ord1 f) => Sorting1 f  where
  sorting1 :: Sort a -> Sort (f a)
  default sorting1 :: Deciding1 Sorting f => Sort a -> Sort (f a)
  sorting1 = forall (q :: * -> Constraint) (t :: * -> *) (f :: * -> *)
       (p :: (* -> Constraint) -> *) a.
(Deciding1 q t, Decidable f) =>
p q -> (forall b. q b => f b) -> f a -> f (t a)
deciding1 (forall {k} (t :: k). Proxy t
Proxy :: Proxy Sorting) forall a. Sorting a => Sort a
sorting

instance (Sorting1 f, Sorting1 g) => Sorting1 (Compose f g) where
  sorting1 :: forall a. Sort a -> Sort (Compose f g a)
sorting1 Sort a
f = forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` forall (f :: * -> *) a. Sorting1 f => Sort a -> Sort (f a)
sorting1 (forall (f :: * -> *) a. Sorting1 f => Sort a -> Sort (f a)
sorting1 Sort a
f)

instance Sorting1 []
instance Sorting1 NonEmpty
instance Sorting1 Maybe
instance Sorting a => Sorting1 (Either a)

-- | Valid definition for 'compare' in terms of 'Sorting'.
sortingCompare :: Sorting a => a -> a -> Ordering
sortingCompare :: forall a. Sorting a => a -> a -> Ordering
sortingCompare a
a a
b = case forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort forall a. Sorting a => Sort a
sorting [(a
a,Ordering
LT),(a
b,Ordering
GT)] of
  [Ordering
r]:[[Ordering]]
_ -> Ordering
r
  [[Ordering]]
_     -> Ordering
EQ
{-# INLINE sortingCompare #-}

--------------------------------------------------------------------------------
-- * Utilities
--------------------------------------------------------------------------------

sortingNat :: Int -> Sort Int
sortingNat :: Int -> Sort Int
sortingNat Int
n = forall a. (forall b. [(a, b)] -> [[b]]) -> Sort a
mkSort forall a b. (a -> b) -> a -> b
$ \[(Int, b)]
xs -> forall a. (a -> Bool) -> [a] -> [a]
List.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null) (forall v. Int -> ([v] -> v -> [v]) -> [(Int, v)] -> [[v]]
bdiscNat Int
n forall {a}. [a] -> a -> [a]
upd [(Int, b)]
xs) where
  upd :: [a] -> a -> [a]
upd [a]
vs a
v = a
v forall a. a -> [a] -> [a]
: [a]
vs
{-# INLINE sortingNat #-}

--------------------------------------------------------------------------------
-- * Collections
--------------------------------------------------------------------------------

-- | Construct a stable ordered discriminator that sorts a list as multisets of elements from another stable ordered discriminator.
--
-- The resulting discriminator only cares about the set of keys and their multiplicity, and is sorted as if we'd
-- sorted each key in turn before comparing.
sortingBag :: Foldable f => Sort k -> Sort (f k)
sortingBag :: forall (f :: * -> *) k. Foldable f => Sort k -> Sort (f k)
sortingBag = forall (f :: * -> *) k.
Foldable f =>
([Int] -> Int -> [Int]) -> Sort k -> Sort (f k)
sortingColl [Int] -> Int -> [Int]
updateBag

-- | Construct a stable ordered discriminator that sorts a list as sets of elements from another stable ordered discriminator.
--
-- The resulting discriminator only cares about the set of keys, and is sorted as if we'd
-- sorted each key in turn before comparing.
sortingSet :: Foldable f => Sort k -> Sort (f k)
sortingSet :: forall (f :: * -> *) k. Foldable f => Sort k -> Sort (f k)
sortingSet = forall (f :: * -> *) k.
Foldable f =>
([Int] -> Int -> [Int]) -> Sort k -> Sort (f k)
sortingColl [Int] -> Int -> [Int]
updateSet

sortingColl :: Foldable f => ([Int] -> Int -> [Int]) -> Sort k -> Sort (f k)
sortingColl :: forall (f :: * -> *) k.
Foldable f =>
([Int] -> Int -> [Int]) -> Sort k -> Sort (f k)
sortingColl [Int] -> Int -> [Int]
upd Sort k
r = forall a. (forall b. [(a, b)] -> [[b]]) -> Sort a
Sort forall a b. (a -> b) -> a -> b
$ \[(f k, b)]
xss -> let
    ([f k]
kss, [b]
vs)           = forall a b. [(a, b)] -> ([a], [b])
unzip [(f k, b)]
xss
    elemKeyNumAssocs :: [(k, Int)]
elemKeyNumAssocs    = forall k. [[k]] -> [(k, Int)]
groupNum (forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [f k]
kss)
    keyNumBlocks :: [[Int]]
keyNumBlocks        = forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort Sort k
r [(k, Int)]
elemKeyNumAssocs
    keyNumElemNumAssocs :: [(Int, Int)]
keyNumElemNumAssocs = forall k. [[k]] -> [(k, Int)]
groupNum [[Int]]
keyNumBlocks
    sigs :: [[Int]]
sigs                = forall v. Int -> ([v] -> v -> [v]) -> [(Int, v)] -> [[v]]
bdiscNat (forall (t :: * -> *) a. Foldable t => t a -> Int
length [f k]
kss) [Int] -> Int -> [Int]
upd [(Int, Int)]
keyNumElemNumAssocs
    yss :: [([Int], b)]
yss                 = forall a b. [a] -> [b] -> [(a, b)]
zip [[Int]]
sigs [b]
vs
  in forall a. (a -> Bool) -> [a] -> [a]
List.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Sorting1 f => Sort a -> Sort (f a)
sorting1 (Int -> Sort Int
sortingNat (forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
keyNumBlocks)) forall a. Sort a -> forall b. [(a, b)] -> [[b]]
`runSort` [([Int], b)]
yss

--------------------------------------------------------------------------------
-- * Combinators
--------------------------------------------------------------------------------

desc :: Sort a -> Sort a
desc :: forall a. Sort a -> Sort a
desc (Sort forall b. [(a, b)] -> [[b]]
l) = forall a. (forall b. [(a, b)] -> [[b]]) -> Sort a
Sort (forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. [(a, b)] -> [[b]]
l)

-- $common
-- Useful combinators.

-- | / O(n)/. Sort a list using discrimination.
--
-- @
-- 'sort' = 'sortWith' 'id'
-- @
sort :: Sorting a => [a] -> [a]
sort :: forall a. Sorting a => [a] -> [a]
sort [a]
as = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
List.concat forall a b. (a -> b) -> a -> b
$ forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort forall a. Sorting a => Sort a
sorting [ (a
a,a
a) | a
a <- [a]
as ]

-- | /O(n)/. Sort a list with a Schwartzian transformation by using discrimination.
--
-- This linear time replacement for 'GHC.Exts.sortWith' and 'Data.List.sortOn' uses discrimination.
sortWith :: Sorting b => (a -> b) -> [a] -> [a]
sortWith :: forall b a. Sorting b => (a -> b) -> [a] -> [a]
sortWith a -> b
f [a]
as = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
List.concat forall a b. (a -> b) -> a -> b
$ forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort forall a. Sorting a => Sort a
sorting [ (a -> b
f a
a, a
a) | a
a <- [a]
as ]

--------------------------------------------------------------------------------
-- * Containers
--------------------------------------------------------------------------------

-- | /O(n)/. Construct a 'Map'.
--
-- This is an asymptotically faster version of 'Data.Map.fromList', which exploits ordered discrimination.
--
-- >>> toMap []
-- fromList []
--
-- >>> toMap [(5,"a"), (3 :: Int,"b"), (5, "c")]
-- fromList [(3,"b"),(5,"c")]
--
-- >>> Map.fromList [(5,"a"), (3 :: Int,"b"), (5, "c")]
-- fromList [(3,"b"),(5,"c")]
--
-- >>> toMap [(5,"c"), (3,"b"), (5 :: Int, "a")]
-- fromList [(3,"b"),(5,"a")]
--
-- >>> Map.fromList [(5,"c"), (3,"b"), (5 :: Int, "a")]
-- fromList [(3,"b"),(5,"a")]
--
toMap :: Sorting k => [(k, v)] -> Map k v
toMap :: forall k v. Sorting k => [(k, v)] -> Map k v
toMap [(k, v)]
kvs = forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort forall a. Sorting a => Sort a
sorting [ (forall a b. (a, b) -> a
fst (k, v)
kv, (k, v)
kv) | (k, v)
kv <- [(k, v)]
kvs ]

-- | /O(n)/. Construct a 'Map', combining values.
--
-- This is an asymptotically faster version of 'Data.Map.fromListWith', which exploits ordered discrimination.
--
-- (Note: values combine in anti-stable order for compatibility with 'Data.Map.fromListWith')
--
-- >>> toMapWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5 :: Int,"c")]
-- fromList [(3,"ab"),(5,"cba")]
--
-- >>> Map.fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5 :: Int,"c")]
-- fromList [(3,"ab"),(5,"cba")]
--
-- >>> toMapWith (++) []
-- fromList []
toMapWith :: Sorting k => (v -> v -> v) -> [(k, v)] -> Map k v
toMapWith :: forall k v. Sorting k => (v -> v -> v) -> [(k, v)] -> Map k v
toMapWith v -> v -> v
f [(k, v)]
kvs0 = forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList forall a b. (a -> b) -> a -> b
$ [(k, v)] -> (k, v)
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort forall a. Sorting a => Sort a
sorting [ (forall a b. (a, b) -> a
fst (k, v)
kv, (k, v)
kv) | (k, v)
kv <- [(k, v)]
kvs0 ] where
  go :: [(k, v)] -> (k, v)
go ((k
k,v
v):[(k, v)]
kvs) = (k
k, forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Prelude.foldl (forall a b c. (a -> b -> c) -> b -> a -> c
flip (v -> v -> v
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)) v
v [(k, v)]
kvs)
  go []          = forall a. HasCallStack => [Char] -> a
error [Char]
"bad sort"

-- | /O(n)/. Construct a 'Map', combining values with access to the key.
--
-- This is an asymptotically faster version of 'Data.Map.fromListWithKey', which exploits ordered discrimination.
--
-- (Note: the values combine in anti-stable order for compatibility with 'Data.Map.fromListWithKey')
--
-- >>> let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value
-- >>> toMapWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5 :: Int,"c")]
-- fromList [(3,"3:a|b"),(5,"5:c|5:b|a")]
--
-- >>> toMapWithKey f []
-- fromList []
toMapWithKey :: Sorting k => (k -> v -> v -> v) -> [(k, v)] -> Map k v
toMapWithKey :: forall k v. Sorting k => (k -> v -> v -> v) -> [(k, v)] -> Map k v
toMapWithKey k -> v -> v -> v
f [(k, v)]
kvs0 = forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList forall a b. (a -> b) -> a -> b
$ [(k, v)] -> (k, v)
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort forall a. Sorting a => Sort a
sorting [ (forall a b. (a, b) -> a
fst (k, v)
kv, (k, v)
kv) | (k, v)
kv <- [(k, v)]
kvs0 ] where
  go :: [(k, v)] -> (k, v)
go ((k
k,v
v):[(k, v)]
kvs) = (k
k, forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Prelude.foldl (forall a b c. (a -> b -> c) -> b -> a -> c
flip (k -> v -> v -> v
f k
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)) v
v [(k, v)]
kvs)
  go []          = forall a. HasCallStack => [Char] -> a
error [Char]
"bad sort"

-- | /O(n)/. Construct an 'IntMap'.
--
-- >>> toIntMap []
-- fromList []
--
-- >>> toIntMap [(5,"a"), (3,"b"), (5, "c")]
-- fromList [(3,"b"),(5,"c")]
--
-- >>> IntMap.fromList [(5,"a"), (3,"b"), (5, "c")]
-- fromList [(3,"b"),(5,"c")]
--
-- >>> toIntMap [(5,"c"), (3,"b"), (5, "a")]
-- fromList [(3,"b"),(5,"a")]
--
-- >>> IntMap.fromList [(5,"c"), (3,"b"), (5, "a")]
-- fromList [(3,"b"),(5,"a")]
--
toIntMap :: [(Int, v)] -> IntMap v
toIntMap :: forall v. [(Int, v)] -> IntMap v
toIntMap [(Int, v)]
kvs = forall v. [(Int, v)] -> IntMap v
IntMap.fromDistinctAscList forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort forall a. Sorting a => Sort a
sorting [ (forall a b. (a, b) -> a
fst (Int, v)
kv, (Int, v)
kv) | (Int, v)
kv <- [(Int, v)]
kvs ]

-- | /O(n)/. Construct an 'IntMap', combining values.
--
-- This is an asymptotically faster version of 'Data.IntMap.Lazy.fromListWith', which exploits ordered discrimination.
--
-- (Note: values combine in anti-stable order for compatibility with 'Data.IntMap.Lazy.fromListWith')
--
-- >>> toIntMapWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")]
-- fromList [(3,"ab"),(5,"cba")]
--
-- >>> IntMap.fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")]
-- fromList [(3,"ab"),(5,"cba")]
--
-- >>> toIntMapWith (++) []
-- fromList []
toIntMapWith :: (v -> v -> v) -> [(Int, v)] -> IntMap v
toIntMapWith :: forall v. (v -> v -> v) -> [(Int, v)] -> IntMap v
toIntMapWith v -> v -> v
f [(Int, v)]
kvs0 = forall v. [(Int, v)] -> IntMap v
IntMap.fromDistinctAscList forall a b. (a -> b) -> a -> b
$ [(Int, v)] -> (Int, v)
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort forall a. Sorting a => Sort a
sorting [ (forall a b. (a, b) -> a
fst (Int, v)
kv, (Int, v)
kv) | (Int, v)
kv <- [(Int, v)]
kvs0 ] where
  go :: [(Int, v)] -> (Int, v)
go ((Int
k,v
v):[(Int, v)]
kvs) = (Int
k, forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Prelude.foldl (forall a b c. (a -> b -> c) -> b -> a -> c
flip (v -> v -> v
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)) v
v [(Int, v)]
kvs)
  go []          = forall a. HasCallStack => [Char] -> a
error [Char]
"bad sort"

-- | /O(n)/. Construct a 'Map', combining values with access to the key.
--
-- This is an asymptotically faster version of 'Data.IntMap.Lazy.fromListWithKey', which exploits ordered discrimination.
--
-- (Note: the values combine in anti-stable order for compatibility with 'Data.IntMap.Lazy.fromListWithKey')
--
-- >>> let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value
-- >>> toIntMapWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")]
-- fromList [(3,"3:a|b"),(5,"5:c|5:b|a")]
--
-- >>> IntMap.fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")]
-- fromList [(3,"3:a|b"),(5,"5:c|5:b|a")]
--
-- >>> toIntMapWithKey f []
-- fromList []
toIntMapWithKey :: (Int -> v -> v -> v) -> [(Int, v)] -> IntMap v
toIntMapWithKey :: forall v. (Int -> v -> v -> v) -> [(Int, v)] -> IntMap v
toIntMapWithKey Int -> v -> v -> v
f [(Int, v)]
kvs0 = forall v. [(Int, v)] -> IntMap v
IntMap.fromDistinctAscList forall a b. (a -> b) -> a -> b
$ [(Int, v)] -> (Int, v)
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort forall a. Sorting a => Sort a
sorting [ (forall a b. (a, b) -> a
fst (Int, v)
kv, (Int, v)
kv) | (Int, v)
kv <- [(Int, v)]
kvs0 ] where
  go :: [(Int, v)] -> (Int, v)
go ((Int
k,v
v):[(Int, v)]
kvs) = (Int
k, forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Prelude.foldl (forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> v -> v -> v
f Int
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)) v
v [(Int, v)]
kvs)
  go []          = forall a. HasCallStack => [Char] -> a
error [Char]
"bad sort"

-- | /O(n)/. Construct a 'Set' in linear time.
--
-- This is an asymptotically faster version of 'Data.Set.fromList', which exploits ordered discrimination.
toSet :: Sorting k => [k] -> Set k
toSet :: forall k. Sorting k => [k] -> Set k
toSet [k]
kvs = forall a. [a] -> Set a
Set.fromDistinctAscList forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort forall a. Sorting a => Sort a
sorting [ (k
kv, k
kv) | k
kv <- [k]
kvs ]

-- | /O(n)/. Construct an 'IntSet' in linear time.
--
-- This is an asymptotically faster version of 'Data.IntSet.fromList', which exploits ordered discrimination.
toIntSet :: [Int] -> IntSet
toIntSet :: [Int] -> IntSet
toIntSet [Int]
kvs = [Int] -> IntSet
IntSet.fromDistinctAscList forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Sort a -> forall b. [(a, b)] -> [[b]]
runSort forall a. Sorting a => Sort a
sorting [ (Int
kv, Int
kv) | Int
kv <- [Int]
kvs ]