-- SPDX-License-Identifier: MPL-2.0

{- | Persistent finite range, queue, heap and streaming structures. Constructors
are opaque. Indices and half-open ranges are checked. Persistent array updates
copy storage; asymptotic logarithmic claims refer to arithmetic/comparisons.
-}
module HMath.DataStructure (
    Fenwick,
    fenwick,
    fenwickAdd,
    fenwickPrefix,
    fenwickRange,
    SegmentTree,
    segmentTree,
    segmentSet,
    segmentRange,
    SparseTable,
    sparseTable,
    sparseMinimum,
    DisjointSparseTable,
    disjointSparseTable,
    disjointRange,
    monotonicMinima,
    nextGreater,
    Heap,
    emptyHeap,
    heapInsert,
    heapPop,
    heapFromList,
    BinaryHeap,
    binaryHeap,
    binaryInsert,
    binaryPop,
    IndexedHeap,
    indexedHeap,
    indexedSet,
    indexedPop,
    UnionFind,
    unionFind,
    findRoot,
    union,
    connected,
    components,
    Bloom,
    bloom,
    bloomInsert,
    bloomMember,
    bloomFalsePositiveBound,
    CountMin,
    countMin,
    countMinAdd,
    countMinEstimate,
    countMinErrorBound,
    HyperLogLog,
    hyperLogLog,
    hllAdd,
    hllEstimate,
    Reservoir,
    reservoir,
    reservoirAdd,
    reservoirValues,
    OnlineQuantiles,
    onlineQuantiles,
    quantileAdd,
    onlineQuantile,
) where

import Data.Array (Array, array, elems, listArray, (!), (//))
import Data.Bits
import qualified Data.Foldable as Foldable (foldl')
import qualified Data.Map.Strict as M
import Data.Word (Word64)
import HMath.Error (MathError (..))

checkSize :: Int -> Either MathError ()
checkSize :: Int -> Either MathError ()
checkSize Int
n
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1048576 = MathError -> Either MathError ()
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"structure size exceeds 1048576")
    | Bool
otherwise = () -> Either MathError ()
forall a b. b -> Either a b
Right ()
checkRange :: Int -> Int -> Int -> Either MathError ()
checkRange :: Int -> Int -> Int -> Either MathError ()
checkRange Int
n Int
lo Int
hi | Int
lo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
hi Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lo Bool -> Bool -> Bool
|| Int
hi Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n = MathError -> Either MathError ()
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"range out of bounds") | Bool
otherwise = () -> Either MathError ()
forall a b. b -> Either a b
Right ()

{- | Persistent exact-Integer prefix-sum tree with zero-based updates and half-open queries.
Construct with fenwick.
-}
data Fenwick = Fenwick Int (Array Int Integer) deriving (Fenwick -> Fenwick -> Bool
(Fenwick -> Fenwick -> Bool)
-> (Fenwick -> Fenwick -> Bool) -> Eq Fenwick
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Fenwick -> Fenwick -> Bool
== :: Fenwick -> Fenwick -> Bool
$c/= :: Fenwick -> Fenwick -> Bool
/= :: Fenwick -> Fenwick -> Bool
Eq, Int -> Fenwick -> ShowS
[Fenwick] -> ShowS
Fenwick -> String
(Int -> Fenwick -> ShowS)
-> (Fenwick -> String) -> ([Fenwick] -> ShowS) -> Show Fenwick
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Fenwick -> ShowS
showsPrec :: Int -> Fenwick -> ShowS
$cshow :: Fenwick -> String
show :: Fenwick -> String
$cshowList :: [Fenwick] -> ShowS
showList :: [Fenwick] -> ShowS
Show)

{- | Build an immutable Fenwick prefix-sum tree from at most 1048576 Integers. Oversized
input fails; indices in public operations are zero based.
-}
fenwick :: [Integer] -> Either MathError Fenwick
fenwick :: [Integer] -> Either MathError Fenwick
fenwick [Integer]
xs = do
    Int -> Either MathError ()
checkSize ([Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
xs)
    (Either MathError Fenwick
 -> (Int, Integer) -> Either MathError Fenwick)
-> Either MathError Fenwick
-> [(Int, Integer)]
-> Either MathError Fenwick
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl'
        (\Either MathError Fenwick
p (Int
i, Integer
x) -> Either MathError Fenwick
p Either MathError Fenwick
-> (Fenwick -> Either MathError Fenwick)
-> Either MathError Fenwick
forall a b.
Either MathError a
-> (a -> Either MathError b) -> Either MathError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Integer -> Fenwick -> Either MathError Fenwick
fenwickAdd Int
i Integer
x)
        (Fenwick -> Either MathError Fenwick
forall a b. b -> Either a b
Right (Int -> Array Int Integer -> Fenwick
Fenwick ([Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
xs) ((Int, Int) -> [Integer] -> Array Int Integer
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
1, [Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
xs) (Int -> Integer -> [Integer]
forall a. Int -> a -> [a]
replicate ([Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
xs) Integer
0))))
        ([Int] -> [Integer] -> [(Int, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Integer]
xs)

{- | Given zero-based index,delta,then Fenwick tree, return a new tree with that value
incremented. Invalid index returns Left InvalidArgument.
-}
fenwickAdd :: Int -> Integer -> Fenwick -> Either MathError Fenwick
fenwickAdd :: Int -> Integer -> Fenwick -> Either MathError Fenwick
fenwickAdd Int
i Integer
delta (Fenwick Int
n Array Int Integer
a)
    | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = MathError -> Either MathError Fenwick
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"Fenwick update index out of bounds")
    | Bool
otherwise =
        Fenwick -> Either MathError Fenwick
forall a b. b -> Either a b
Right
            ( Int -> Array Int Integer -> Fenwick
Fenwick
                Int
n
                (Array Int Integer
a Array Int Integer -> [(Int, Integer)] -> Array Int Integer
forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// [(Int
j, Array Int Integer
a Array Int Integer -> Int -> Integer
forall i e. Ix i => Array i e -> i -> e
! Int
j Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
delta) | Int
j <- (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n) ((Int -> Int) -> Int -> [Int]
forall a. (a -> a) -> a -> [a]
iterate (\Int
k -> Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
k Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. (-Int
k))) (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))])
            )

{- | Given exclusive end then tree, return exact sum over [0,end). Require 0\<=end\<=length;
invalid bounds fail.
-}
fenwickPrefix :: Int -> Fenwick -> Either MathError Integer
fenwickPrefix :: Int -> Fenwick -> Either MathError Integer
fenwickPrefix Int
end (Fenwick Int
n Array Int Integer
a) = do
    Int -> Int -> Int -> Either MathError ()
checkRange Int
n Int
0 Int
end; Integer -> Either MathError Integer
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Array Int Integer
a Array Int Integer -> Int -> Integer
forall i e. Ix i => Array i e -> i -> e
! Int
j | Int
j <- (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) ((Int -> Int) -> Int -> [Int]
forall a. (a -> a) -> a -> [a]
iterate (\Int
k -> Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
k Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. (-Int
k))) Int
end)])

{- | Given lo,hi,then tree, return exact half-open sum over [lo,hi). Invalid/reversed bounds
fail; empty range gives zero.
-}
fenwickRange :: Int -> Int -> Fenwick -> Either MathError Integer
fenwickRange :: Int -> Int -> Fenwick -> Either MathError Integer
fenwickRange Int
lo Int
hi t :: Fenwick
t@(Fenwick Int
n Array Int Integer
_) = do Int -> Int -> Int -> Either MathError ()
checkRange Int
n Int
lo Int
hi; (-) (Integer -> Integer -> Integer)
-> Either MathError Integer
-> Either MathError (Integer -> Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Fenwick -> Either MathError Integer
fenwickPrefix Int
hi Fenwick
t Either MathError (Integer -> Integer)
-> Either MathError Integer -> Either MathError Integer
forall a b.
Either MathError (a -> b)
-> Either MathError a -> Either MathError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Fenwick -> Either MathError Integer
fenwickPrefix Int
lo Fenwick
t

{- | Persistent exact-Integer range-sum tree. Construct with segmentTree; segmentSet returns
a new version.
-}
data SegmentTree = SegmentTree Int Int (Array Int Integer) deriving (SegmentTree -> SegmentTree -> Bool
(SegmentTree -> SegmentTree -> Bool)
-> (SegmentTree -> SegmentTree -> Bool) -> Eq SegmentTree
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SegmentTree -> SegmentTree -> Bool
== :: SegmentTree -> SegmentTree -> Bool
$c/= :: SegmentTree -> SegmentTree -> Bool
/= :: SegmentTree -> SegmentTree -> Bool
Eq, Int -> SegmentTree -> ShowS
[SegmentTree] -> ShowS
SegmentTree -> String
(Int -> SegmentTree -> ShowS)
-> (SegmentTree -> String)
-> ([SegmentTree] -> ShowS)
-> Show SegmentTree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SegmentTree -> ShowS
showsPrec :: Int -> SegmentTree -> ShowS
$cshow :: SegmentTree -> String
show :: SegmentTree -> String
$cshowList :: [SegmentTree] -> ShowS
showList :: [SegmentTree] -> ShowS
Show)

powerTwo :: Int -> Int
powerTwo :: Int -> Int
powerTwo Int
n = Int -> Int
go Int
1
  where
    go :: Int -> Int
go Int
p | Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = Int
p | Bool
otherwise = Int -> Int
go (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)

{- | Build an immutable Integer sum segment tree from at most 1048576 values. Invalid size
fails; later queries use half-open bounds.
-}
segmentTree :: [Integer] -> Either MathError SegmentTree
segmentTree :: [Integer] -> Either MathError SegmentTree
segmentTree [Integer]
xs = do
    Int -> Either MathError ()
checkSize ([Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
xs)
    let n :: Int
n = [Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
xs
        size :: Int
size = Int -> Int
powerTwo (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
n)
        a :: Array Int Integer
a = (Int, Int) -> [(Int, Integer)] -> Array Int Integer
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
1, Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [(Int
i, Int -> Integer
value Int
i) | Int
i <- [Int
1 .. Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
        value :: Int -> Integer
value Int
i
            | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
size = if Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n then [Integer]
xs [Integer] -> Int -> Integer
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
size) else Integer
0
            | Bool
otherwise = Array Int Integer
a Array Int Integer -> Int -> Integer
forall i e. Ix i => Array i e -> i -> e
! (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Array Int Integer
a Array Int Integer -> Int -> Integer
forall i e. Ix i => Array i e -> i -> e
! (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    SegmentTree -> Either MathError SegmentTree
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Array Int Integer -> SegmentTree
SegmentTree Int
n Int
size Array Int Integer
a)

{- | Given zero-based index,new Integer,then segment tree, return an updated tree. Invalid
index fails; the original remains unchanged.
-}
segmentSet :: Int -> Integer -> SegmentTree -> Either MathError SegmentTree
segmentSet :: Int -> Integer -> SegmentTree -> Either MathError SegmentTree
segmentSet Int
i Integer
x (SegmentTree Int
n Int
size Array Int Integer
a)
    | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = MathError -> Either MathError SegmentTree
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"segment update index out of bounds")
    | Bool
otherwise = SegmentTree -> Either MathError SegmentTree
forall a b. b -> Either a b
Right (Int -> Int -> Array Int Integer -> SegmentTree
SegmentTree Int
n Int
size (Int -> Array Int Integer -> Array Int Integer
forall {i} {e}.
(Ix i, Integral i, Num e) =>
i -> Array i e -> Array i e
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size) (Array Int Integer
a Array Int Integer -> [(Int, Integer)] -> Array Int Integer
forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// [(Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size, Integer
x)])))
  where
    go :: i -> Array i e -> Array i e
go i
j Array i e
ar
        | i
j i -> i -> Bool
forall a. Ord a => a -> a -> Bool
<= i
1 = Array i e
ar
        | Bool
otherwise = let p :: i
p = i
j i -> i -> i
forall a. Integral a => a -> a -> a
`div` i
2 in i -> Array i e -> Array i e
go i
p (Array i e
ar Array i e -> [(i, e)] -> Array i e
forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// [(i
p, Array i e
ar Array i e -> i -> e
forall i e. Ix i => Array i e -> i -> e
! (i
2 i -> i -> i
forall a. Num a => a -> a -> a
* i
p) e -> e -> e
forall a. Num a => a -> a -> a
+ Array i e
ar Array i e -> i -> e
forall i e. Ix i => Array i e -> i -> e
! (i
2 i -> i -> i
forall a. Num a => a -> a -> a
* i
p i -> i -> i
forall a. Num a => a -> a -> a
+ i
1))])

{- | Given lo,hi,then segment tree, return Integer sum over [lo,hi). Invalid bounds fail; an
empty range gives zero.
-}
segmentRange :: Int -> Int -> SegmentTree -> Either MathError Integer
segmentRange :: Int -> Int -> SegmentTree -> Either MathError Integer
segmentRange Int
lo Int
hi (SegmentTree Int
n Int
size Array Int Integer
a) = do Int -> Int -> Int -> Either MathError ()
checkRange Int
n Int
lo Int
hi; Integer -> Either MathError Integer
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Integer -> Integer
go (Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size) (Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size) Integer
0)
  where
    go :: Int -> Int -> Integer -> Integer
go Int
l Int
r Integer
acc
        | Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
r = Integer
acc
        | Bool
otherwise =
            Int -> Int -> Integer -> Integer
go ((Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) (Int
r Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) (Integer
acc Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ if Int -> Bool
forall a. Integral a => a -> Bool
odd Int
l then Array Int Integer
a Array Int Integer -> Int -> Integer
forall i e. Ix i => Array i e -> i -> e
! Int
l else Integer
0 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
0)
                Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
`addRight` (if Int -> Bool
forall a. Integral a => a -> Bool
odd Int
r then Array Int Integer
a Array Int Integer -> Int -> Integer
forall i e. Ix i => Array i e -> i -> e
! (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) else Integer
0)
    addRight :: a -> a -> a
addRight a
x a
y = a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
y

{- | Immutable precomputed range-minimum table for nonempty half-open queries. Construct
with sparseTable.
-}
data SparseTable = SparseTable Int [Array Int Integer] deriving (SparseTable -> SparseTable -> Bool
(SparseTable -> SparseTable -> Bool)
-> (SparseTable -> SparseTable -> Bool) -> Eq SparseTable
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SparseTable -> SparseTable -> Bool
== :: SparseTable -> SparseTable -> Bool
$c/= :: SparseTable -> SparseTable -> Bool
/= :: SparseTable -> SparseTable -> Bool
Eq, Int -> SparseTable -> ShowS
[SparseTable] -> ShowS
SparseTable -> String
(Int -> SparseTable -> ShowS)
-> (SparseTable -> String)
-> ([SparseTable] -> ShowS)
-> Show SparseTable
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SparseTable -> ShowS
showsPrec :: Int -> SparseTable -> ShowS
$cshow :: SparseTable -> String
show :: SparseTable -> String
$cshowList :: [SparseTable] -> ShowS
showList :: [SparseTable] -> ShowS
Show)

{- | Precompute range minima for at most 1048576 Integers. Return immutable sparse table;
oversized input fails.
-}
sparseTable :: [Integer] -> Either MathError SparseTable
sparseTable :: [Integer] -> Either MathError SparseTable
sparseTable [Integer]
xs = do
    Int -> Either MathError ()
checkSize ([Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
xs)
    let n :: Int
n = [Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
xs
        firstLevel :: Array Int Integer
firstLevel = (Int, Int) -> [Integer] -> Array Int Integer
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Integer]
xs
        build :: Int -> Array Int e -> [Array Int e]
build Int
width Array Int e
previous
            | Int
width Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n = []
            | Bool
otherwise =
                let table :: Array Int e
table =
                        (Int, Int) -> [e] -> Array Int e
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray
                            (Int
0, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
width)
                            [e -> e -> e
forall a. Ord a => a -> a -> a
min (Array Int e
previous Array Int e -> Int -> e
forall i e. Ix i => Array i e -> i -> e
! Int
i) (Array Int e
previous Array Int e -> Int -> e
forall i e. Ix i => Array i e -> i -> e
! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
width Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)) | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
width]]
                 in Array Int e
table Array Int e -> [Array Int e] -> [Array Int e]
forall a. a -> [a] -> [a]
: Int -> Array Int e -> [Array Int e]
build (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) Array Int e
table
    SparseTable -> Either MathError SparseTable
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> [Array Int Integer] -> SparseTable
SparseTable Int
n (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then [] else Array Int Integer
firstLevel Array Int Integer -> [Array Int Integer] -> [Array Int Integer]
forall a. a -> [a] -> [a]
: Int -> Array Int Integer -> [Array Int Integer]
forall {e}. Ord e => Int -> Array Int e -> [Array Int e]
build Int
2 Array Int Integer
firstLevel))

{- | Given lo,hi,then sparse table, return minimum over nonempty [lo,hi).
Out-of-range/reversed or empty bounds fail.
-}
sparseMinimum :: Int -> Int -> SparseTable -> Either MathError Integer
sparseMinimum :: Int -> Int -> SparseTable -> Either MathError Integer
sparseMinimum Int
lo Int
hi (SparseTable Int
n [Array Int Integer]
tables) = do
    Int -> Int -> Int -> Either MathError ()
checkRange Int
n Int
lo Int
hi
    if Int
lo Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
hi
        then MathError -> Either MathError Integer
forall a b. a -> Either a b
Left (String -> MathError
DomainError String
"empty minimum range")
        else
            let k :: Int
k = Int -> Int
integerLog (Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lo); width :: Int
width = Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
k
             in Integer -> Either MathError Integer
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min (([Array Int Integer]
tables [Array Int Integer] -> Int -> Array Int Integer
forall a. HasCallStack => [a] -> Int -> a
!! Int
k) Array Int Integer -> Int -> Integer
forall i e. Ix i => Array i e -> i -> e
! Int
lo) (([Array Int Integer]
tables [Array Int Integer] -> Int -> Array Int Integer
forall a. HasCallStack => [a] -> Int -> a
!! Int
k) Array Int Integer -> Int -> Integer
forall i e. Ix i => Array i e -> i -> e
! (Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
width)))

integerLog :: Int -> Int
integerLog :: Int -> Int
integerLog Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 = Int
0 | Bool
otherwise = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
integerLog (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)

{- | Immutable disjoint range-sum table supporting constant-query arithmetic. Construct with
disjointSparseTable.
-}
data DisjointSparseTable = DisjointSparseTable [Integer] [Array Int Integer] deriving (DisjointSparseTable -> DisjointSparseTable -> Bool
(DisjointSparseTable -> DisjointSparseTable -> Bool)
-> (DisjointSparseTable -> DisjointSparseTable -> Bool)
-> Eq DisjointSparseTable
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DisjointSparseTable -> DisjointSparseTable -> Bool
== :: DisjointSparseTable -> DisjointSparseTable -> Bool
$c/= :: DisjointSparseTable -> DisjointSparseTable -> Bool
/= :: DisjointSparseTable -> DisjointSparseTable -> Bool
Eq, Int -> DisjointSparseTable -> ShowS
[DisjointSparseTable] -> ShowS
DisjointSparseTable -> String
(Int -> DisjointSparseTable -> ShowS)
-> (DisjointSparseTable -> String)
-> ([DisjointSparseTable] -> ShowS)
-> Show DisjointSparseTable
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DisjointSparseTable -> ShowS
showsPrec :: Int -> DisjointSparseTable -> ShowS
$cshow :: DisjointSparseTable -> String
show :: DisjointSparseTable -> String
$cshowList :: [DisjointSparseTable] -> ShowS
showList :: [DisjointSparseTable] -> ShowS
Show)

{- | Suffix/prefix blocks for associative integer addition, O(n log n) build and
O(1) arithmetic for nonempty queries. Also handles an empty range as zero.
-}
disjointSparseTable :: [Integer] -> Either MathError DisjointSparseTable
disjointSparseTable :: [Integer] -> Either MathError DisjointSparseTable
disjointSparseTable [Integer]
xs = do
    Int -> Either MathError ()
checkSize ([Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
xs)
    let n :: Int
n = [Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
xs
        level :: b -> Array Int Integer
level b
k =
            (Int, Int) -> [Integer] -> Array Int Integer
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray
                (Int
0, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                ([[Integer]] -> [Integer]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Integer] -> Int -> [Integer]
forall {a}. Num a => [a] -> Int -> [a]
block (Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
take (Int
2 Int -> b -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (b
k b -> b -> b
forall a. Num a => a -> a -> a
+ b
1)) (Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
drop Int
start [Integer]
xs)) (Int
2 Int -> b -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ b
k) | Int
start <- [Int
0, Int
2 Int -> b -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (b
k b -> b -> b
forall a. Num a => a -> a -> a
+ b
1) .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]])
        block :: [a] -> Int -> [a]
block [a]
ys Int
half = let ([a]
a, [a]
b) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
half [a]
ys in [a] -> [a]
forall {a}. Num a => [a] -> [a]
scanr1Safe [a]
a [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (a -> a -> a) -> [a] -> [a]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 a -> a -> a
forall a. Num a => a -> a -> a
(+) [a]
b
        scanr1Safe :: [a] -> [a]
scanr1Safe [] = []; scanr1Safe [a]
ys = (a -> a -> a) -> [a] -> [a]
forall a. (a -> a -> a) -> [a] -> [a]
scanr1 a -> a -> a
forall a. Num a => a -> a -> a
(+) [a]
ys
    DisjointSparseTable -> Either MathError DisjointSparseTable
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Integer] -> [Array Int Integer] -> DisjointSparseTable
DisjointSparseTable [Integer]
xs [Int -> Array Int Integer
forall {b}. Integral b => b -> Array Int Integer
level Int
k | Int
k <- [Int
0 .. Int -> Int
integerLog (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
n)]])

{- | Given lo,hi,then disjoint sparse sum table, return exact sum over [lo,hi). Invalid
bounds fail; empty range yields zero.
-}
disjointRange :: Int -> Int -> DisjointSparseTable -> Either MathError Integer
disjointRange :: Int -> Int -> DisjointSparseTable -> Either MathError Integer
disjointRange Int
lo Int
hi (DisjointSparseTable [Integer]
xs [Array Int Integer]
tables) = do
    Int -> Int -> Int -> Either MathError ()
checkRange ([Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
xs) Int
lo Int
hi
    if Int
lo Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
hi
        then Integer -> Either MathError Integer
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
0
        else
            if Int
hi Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                then Integer -> Either MathError Integer
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Integer]
xs [Integer] -> Int -> Integer
forall a. HasCallStack => [a] -> Int -> a
!! Int
lo)
                else let k :: Int
k = Int -> Int
integerLog (Int
lo Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` (Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)); a :: Array Int Integer
a = [Array Int Integer]
tables [Array Int Integer] -> Int -> Array Int Integer
forall a. HasCallStack => [a] -> Int -> a
!! Int
k in Integer -> Either MathError Integer
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Array Int Integer
a Array Int Integer -> Int -> Integer
forall i e. Ix i => Array i e -> i -> e
! Int
lo Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Array Int Integer
a Array Int Integer -> Int -> Integer
forall i e. Ix i => Array i e -> i -> e
! (Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))

{- | Sliding minima using an increasing deque of indices; output windows are
complete only. This list-backed reference deque has O(n*w) worst-case moves.
-}
monotonicMinima :: (Ord a) => Int -> [a] -> Either MathError [a]
monotonicMinima :: forall a. Ord a => Int -> [a] -> Either MathError [a]
monotonicMinima Int
width [a]
xs
    | Int
width Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = MathError -> Either MathError [a]
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"window width must be positive")
    | Bool
otherwise = [a] -> Either MathError [a]
forall a b. b -> Either a b
Right ([(Int, a)] -> [(Int, a)] -> [a]
forall {a}. Ord a => [(Int, a)] -> [(Int, a)] -> [a]
go [] ([Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [a]
xs))
  where
    go :: [(Int, a)] -> [(Int, a)] -> [a]
go [(Int, a)]
_ [] = []
    go [(Int, a)]
queue ((Int
i, a
x) : [(Int, a)]
rest) =
        let q :: [(Int, a)]
q = ((Int, a) -> Bool) -> [(Int, a)] -> [(Int, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
width) (Int -> Bool) -> ((Int, a) -> Int) -> (Int, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, a) -> Int
forall a b. (a, b) -> a
fst) [(Int, a)]
queue
            q' :: [(Int, a)]
q' = [(Int, a)] -> [(Int, a)]
forall a. [a] -> [a]
reverse (((Int, a) -> Bool) -> [(Int, a)] -> [(Int, a)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
x) (a -> Bool) -> ((Int, a) -> a) -> (Int, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, a) -> a
forall a b. (a, b) -> b
snd) ([(Int, a)] -> [(Int, a)]
forall a. [a] -> [a]
reverse [(Int, a)]
q)) [(Int, a)] -> [(Int, a)] -> [(Int, a)]
forall a. [a] -> [a] -> [a]
++ [(Int
i, a
x)]
         in (if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 then [(Int, a) -> a
forall a b. (a, b) -> b
snd ([(Int, a)]
q' [(Int, a)] -> Int -> (Int, a)
forall a. HasCallStack => [a] -> Int -> a
!! Int
0)] else []) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [(Int, a)] -> [(Int, a)] -> [a]
go [(Int, a)]
q' [(Int, a)]
rest

{- | For each list position, return Maybe index of its first strictly greater element to the
right, using a monotone stack. Preserve input length; absent successors yield Nothing.
-}
nextGreater :: (Ord a) => [a] -> [Maybe Int]
nextGreater :: forall a. Ord a => [a] -> [Maybe Int]
nextGreater [a]
xs = (Int -> Maybe Int) -> [Int] -> [Maybe Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
i Map Int Int
result) [Int
0 .. [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  where
    ([(Int, a)]
_, Map Int Int
result) = (([(Int, a)], Map Int Int)
 -> (Int, a) -> ([(Int, a)], Map Int Int))
-> ([(Int, a)], Map Int Int)
-> [(Int, a)]
-> ([(Int, a)], Map Int Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' ([(Int, a)], Map Int Int) -> (Int, a) -> ([(Int, a)], Map Int Int)
forall {k} {b}.
(Ord k, Ord b) =>
([(k, b)], Map k k) -> (k, b) -> ([(k, b)], Map k k)
step ([], Map Int Int
forall k a. Map k a
M.empty) ([Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [a]
xs)
    step :: ([(k, b)], Map k k) -> (k, b) -> ([(k, b)], Map k k)
step ([(k, b)]
stack, Map k k
out) (k
i, b
x) =
        let ([(k, b)]
popped, [(k, b)]
keep) = ((k, b) -> Bool) -> [(k, b)] -> ([(k, b)], [(k, b)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((b -> b -> Bool
forall a. Ord a => a -> a -> Bool
< b
x) (b -> Bool) -> ((k, b) -> b) -> (k, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k, b) -> b
forall a b. (a, b) -> b
snd) [(k, b)]
stack
         in ((k
i, b
x) (k, b) -> [(k, b)] -> [(k, b)]
forall a. a -> [a] -> [a]
: [(k, b)]
keep, (Map k k -> (k, b) -> Map k k) -> Map k k -> [(k, b)] -> Map k k
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (\Map k k
m (k
j, b
_) -> k -> k -> Map k k -> Map k k
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
j k
i Map k k
m) Map k k
out [(k, b)]
popped)

-- | Leftist binary min heap, O(log n) merge/insert/delete-min comparisons.
data Heap a = Empty | Node Int a (Heap a) (Heap a) deriving (Heap a -> Heap a -> Bool
(Heap a -> Heap a -> Bool)
-> (Heap a -> Heap a -> Bool) -> Eq (Heap a)
forall a. Eq a => Heap a -> Heap a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Heap a -> Heap a -> Bool
== :: Heap a -> Heap a -> Bool
$c/= :: forall a. Eq a => Heap a -> Heap a -> Bool
/= :: Heap a -> Heap a -> Bool
Eq, Int -> Heap a -> ShowS
[Heap a] -> ShowS
Heap a -> String
(Int -> Heap a -> ShowS)
-> (Heap a -> String) -> ([Heap a] -> ShowS) -> Show (Heap a)
forall a. Show a => Int -> Heap a -> ShowS
forall a. Show a => [Heap a] -> ShowS
forall a. Show a => Heap a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Heap a -> ShowS
showsPrec :: Int -> Heap a -> ShowS
$cshow :: forall a. Show a => Heap a -> String
show :: Heap a -> String
$cshowList :: forall a. Show a => [Heap a] -> ShowS
showList :: [Heap a] -> ShowS
Show)

{- | Construct an empty persistent leftist min-heap. heapPop returns Nothing until values
are inserted.
-}
emptyHeap :: Heap a
emptyHeap :: forall a. Heap a
emptyHeap = Heap a
forall a. Heap a
Empty

rank :: Heap a -> Int
rank :: forall a. Heap a -> Int
rank Heap a
Empty = Int
0; rank (Node Int
r a
_ Heap a
_ Heap a
_) = Int
r
mergeHeap :: (Ord a) => Heap a -> Heap a -> Heap a
mergeHeap :: forall a. Ord a => Heap a -> Heap a -> Heap a
mergeHeap Heap a
Empty Heap a
b = Heap a
b
mergeHeap Heap a
a Heap a
Empty = Heap a
a
mergeHeap a :: Heap a
a@(Node Int
_ a
x Heap a
l Heap a
r) b :: Heap a
b@(Node Int
_ a
y Heap a
_ Heap a
_)
    | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
y = Heap a -> Heap a -> Heap a
forall a. Ord a => Heap a -> Heap a -> Heap a
mergeHeap Heap a
b Heap a
a
    | Heap a -> Int
forall a. Heap a -> Int
rank Heap a
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Heap a -> Int
forall a. Heap a -> Int
rank Heap a
z = Int -> a -> Heap a -> Heap a -> Heap a
forall a. Int -> a -> Heap a -> Heap a -> Heap a
Node (Heap a -> Int
forall a. Heap a -> Int
rank Heap a
z Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) a
x Heap a
l Heap a
z
    | Bool
otherwise = Int -> a -> Heap a -> Heap a -> Heap a
forall a. Int -> a -> Heap a -> Heap a -> Heap a
Node (Heap a -> Int
forall a. Heap a -> Int
rank Heap a
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) a
x Heap a
z Heap a
l
  where
    z :: Heap a
z = Heap a -> Heap a -> Heap a
forall a. Ord a => Heap a -> Heap a -> Heap a
mergeHeap Heap a
r Heap a
b

{- | Given value then persistent min-heap, return a new heap containing it. Duplicate values
are retained; original heap remains valid.
-}
heapInsert :: (Ord a) => a -> Heap a -> Heap a
heapInsert :: forall a. Ord a => a -> Heap a -> Heap a
heapInsert a
x = Heap a -> Heap a -> Heap a
forall a. Ord a => Heap a -> Heap a -> Heap a
mergeHeap (Int -> a -> Heap a -> Heap a -> Heap a
forall a. Int -> a -> Heap a -> Heap a -> Heap a
Node Int
1 a
x Heap a
forall a. Heap a
Empty Heap a
forall a. Heap a
Empty)

{- | Return Nothing for empty heap, otherwise Just (smallest value,remaining heap). Ties
follow lawful Ord without discarding duplicates.
-}
heapPop :: (Ord a) => Heap a -> Maybe (a, Heap a)
heapPop :: forall a. Ord a => Heap a -> Maybe (a, Heap a)
heapPop Heap a
Empty = Maybe (a, Heap a)
forall a. Maybe a
Nothing
heapPop (Node Int
_ a
x Heap a
l Heap a
r) = (a, Heap a) -> Maybe (a, Heap a)
forall a. a -> Maybe a
Just (a
x, Heap a -> Heap a -> Heap a
forall a. Ord a => Heap a -> Heap a -> Heap a
mergeHeap Heap a
l Heap a
r)

{- | Build a persistent min-heap from a finite list, retaining all elements including
duplicates.
-}
heapFromList :: (Ord a) => [a] -> Heap a
heapFromList :: forall a. Ord a => [a] -> Heap a
heapFromList = (Heap a -> a -> Heap a) -> Heap a -> [a] -> Heap a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' ((a -> Heap a -> Heap a) -> Heap a -> a -> Heap a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Heap a -> Heap a
forall a. Ord a => a -> Heap a -> Heap a
heapInsert) Heap a
forall a. Heap a
Empty

{- | Complete binary min heap in an array. Persistence copies the backing
array; sift operations make O(log n) comparisons.
-}
newtype BinaryHeap = BinaryHeap (Array Int Integer) deriving (BinaryHeap -> BinaryHeap -> Bool
(BinaryHeap -> BinaryHeap -> Bool)
-> (BinaryHeap -> BinaryHeap -> Bool) -> Eq BinaryHeap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BinaryHeap -> BinaryHeap -> Bool
== :: BinaryHeap -> BinaryHeap -> Bool
$c/= :: BinaryHeap -> BinaryHeap -> Bool
/= :: BinaryHeap -> BinaryHeap -> Bool
Eq, Int -> BinaryHeap -> ShowS
[BinaryHeap] -> ShowS
BinaryHeap -> String
(Int -> BinaryHeap -> ShowS)
-> (BinaryHeap -> String)
-> ([BinaryHeap] -> ShowS)
-> Show BinaryHeap
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BinaryHeap -> ShowS
showsPrec :: Int -> BinaryHeap -> ShowS
$cshow :: BinaryHeap -> String
show :: BinaryHeap -> String
$cshowList :: [BinaryHeap] -> ShowS
showList :: [BinaryHeap] -> ShowS
Show)

{- | Build an array-backed Integer min-heap from at most 1048576 values. Oversized input
fails.
-}
binaryHeap :: [Integer] -> Either MathError BinaryHeap
binaryHeap :: [Integer] -> Either MathError BinaryHeap
binaryHeap [Integer]
xs = do
    Int -> Either MathError ()
checkSize ([Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
xs)
    BinaryHeap -> Either MathError BinaryHeap
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((BinaryHeap -> Integer -> BinaryHeap)
-> BinaryHeap -> [Integer] -> BinaryHeap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' ((Integer -> BinaryHeap -> BinaryHeap)
-> BinaryHeap -> Integer -> BinaryHeap
forall a b c. (a -> b -> c) -> b -> a -> c
flip Integer -> BinaryHeap -> BinaryHeap
binaryInsert) (Array Int Integer -> BinaryHeap
BinaryHeap ((Int, Int) -> [Integer] -> Array Int Integer
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, -Int
1) [])) [Integer]
xs)

{- | Given Integer then binary heap, return a persistent updated min-heap. The insert
operation itself has no Either size check.
-}
binaryInsert :: Integer -> BinaryHeap -> BinaryHeap
binaryInsert :: Integer -> BinaryHeap -> BinaryHeap
binaryInsert Integer
value (BinaryHeap Array Int Integer
old) = Array Int Integer -> BinaryHeap
BinaryHeap (Int -> Array Int Integer -> Array Int Integer
forall {i} {e}.
(Ix i, Integral i, Ord e) =>
i -> Array i e -> Array i e
bubble ([Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
values) ((Int, Int) -> [Integer] -> Array Int Integer
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, [Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
values) ([Integer]
values [Integer] -> [Integer] -> [Integer]
forall a. [a] -> [a] -> [a]
++ [Integer
value])))
  where
    values :: [Integer]
values = Array Int Integer -> [Integer]
forall i e. Array i e -> [e]
elems Array Int Integer
old
    bubble :: i -> Array i e -> Array i e
bubble i
i Array i e
a
        | i
i i -> i -> Bool
forall a. Eq a => a -> a -> Bool
== i
0 = Array i e
a
        | Array i e
a Array i e -> i -> e
forall i e. Ix i => Array i e -> i -> e
! i
parent e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= Array i e
a Array i e -> i -> e
forall i e. Ix i => Array i e -> i -> e
! i
i = Array i e
a
        | Bool
otherwise = i -> Array i e -> Array i e
bubble i
parent (Array i e
a Array i e -> [(i, e)] -> Array i e
forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// [(i
parent, Array i e
a Array i e -> i -> e
forall i e. Ix i => Array i e -> i -> e
! i
i), (i
i, Array i e
a Array i e -> i -> e
forall i e. Ix i => Array i e -> i -> e
! i
parent)])
      where
        parent :: i
parent = (i
i i -> i -> i
forall a. Num a => a -> a -> a
- i
1) i -> i -> i
forall a. Integral a => a -> a -> a
`div` i
2

{- | Return Nothing if empty, otherwise the smallest Integer and a new binary heap
containing the remaining values.
-}
binaryPop :: BinaryHeap -> Maybe (Integer, BinaryHeap)
binaryPop :: BinaryHeap -> Maybe (Integer, BinaryHeap)
binaryPop (BinaryHeap Array Int Integer
old) = case Array Int Integer -> [Integer]
forall i e. Array i e -> [e]
elems Array Int Integer
old of
    [] -> Maybe (Integer, BinaryHeap)
forall a. Maybe a
Nothing
    [Integer
x] -> (Integer, BinaryHeap) -> Maybe (Integer, BinaryHeap)
forall a. a -> Maybe a
Just (Integer
x, Array Int Integer -> BinaryHeap
BinaryHeap ((Int, Int) -> [Integer] -> Array Int Integer
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, -Int
1) []))
    values :: [Integer]
values@(Integer
x : [Integer]
_) ->
        let n :: Int
n = [Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
values Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
            initialArray :: Array Int Integer
initialArray = (Int, Int) -> [Integer] -> Array Int Integer
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([Integer] -> Integer
forall a. HasCallStack => [a] -> a
last [Integer]
values Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
: Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
drop Int
1 [Integer]
values))
            sift :: Int -> Array Int e -> Array Int e
sift Int
i Array Int e
a
                | Int
left Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = Array Int e
a
                | Array Int e
a Array Int e -> Int -> e
forall i e. Ix i => Array i e -> i -> e
! Int
i e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= Array Int e
a Array Int e -> Int -> e
forall i e. Ix i => Array i e -> i -> e
! Int
child = Array Int e
a
                | Bool
otherwise = Int -> Array Int e -> Array Int e
sift Int
child (Array Int e
a Array Int e -> [(Int, e)] -> Array Int e
forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// [(Int
i, Array Int e
a Array Int e -> Int -> e
forall i e. Ix i => Array i e -> i -> e
! Int
child), (Int
child, Array Int e
a Array Int e -> Int -> e
forall i e. Ix i => Array i e -> i -> e
! Int
i)])
              where
                left :: Int
left = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                right :: Int
right = Int
left Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                child :: Int
child = if Int
right Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n Bool -> Bool -> Bool
&& Array Int e
a Array Int e -> Int -> e
forall i e. Ix i => Array i e -> i -> e
! Int
right e -> e -> Bool
forall a. Ord a => a -> a -> Bool
< Array Int e
a Array Int e -> Int -> e
forall i e. Ix i => Array i e -> i -> e
! Int
left then Int
right else Int
left
         in (Integer, BinaryHeap) -> Maybe (Integer, BinaryHeap)
forall a. a -> Maybe a
Just (Integer
x, Array Int Integer -> BinaryHeap
BinaryHeap (Int -> Array Int Integer -> Array Int Integer
forall {e}. Ord e => Int -> Array Int e -> Array Int e
sift Int
0 Array Int Integer
initialArray))

{- | An indexed priority queue backed by an ordered map and a binary heap.
Updates lazily invalidate old heap entries; pop discards stale entries.
-}
data IndexedHeap = IndexedHeap (M.Map Int Integer) (Heap (Integer, Int)) deriving (IndexedHeap -> IndexedHeap -> Bool
(IndexedHeap -> IndexedHeap -> Bool)
-> (IndexedHeap -> IndexedHeap -> Bool) -> Eq IndexedHeap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IndexedHeap -> IndexedHeap -> Bool
== :: IndexedHeap -> IndexedHeap -> Bool
$c/= :: IndexedHeap -> IndexedHeap -> Bool
/= :: IndexedHeap -> IndexedHeap -> Bool
Eq, Int -> IndexedHeap -> ShowS
[IndexedHeap] -> ShowS
IndexedHeap -> String
(Int -> IndexedHeap -> ShowS)
-> (IndexedHeap -> String)
-> ([IndexedHeap] -> ShowS)
-> Show IndexedHeap
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IndexedHeap -> ShowS
showsPrec :: Int -> IndexedHeap -> ShowS
$cshow :: IndexedHeap -> String
show :: IndexedHeap -> String
$cshowList :: [IndexedHeap] -> ShowS
showList :: [IndexedHeap] -> ShowS
Show)

{- | Construct an empty indexed priority queue. Each Int key has at most one Integer
priority.
-}
indexedHeap :: IndexedHeap
indexedHeap :: IndexedHeap
indexedHeap = Map Int Integer -> Heap (Integer, Int) -> IndexedHeap
IndexedHeap Map Int Integer
forall k a. Map k a
M.empty Heap (Integer, Int)
forall a. Heap a
Empty

{- | Given Int key,Integer priority,then indexed heap, set or replace that key's priority.
Return a new queue; an existing key is updated, not duplicated.
-}
indexedSet :: Int -> Integer -> IndexedHeap -> IndexedHeap
indexedSet :: Int -> Integer -> IndexedHeap -> IndexedHeap
indexedSet Int
key Integer
value (IndexedHeap Map Int Integer
entries Heap (Integer, Int)
h) = Map Int Integer -> Heap (Integer, Int) -> IndexedHeap
IndexedHeap (Int -> Integer -> Map Int Integer -> Map Int Integer
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
key Integer
value Map Int Integer
entries) ((Integer, Int) -> Heap (Integer, Int) -> Heap (Integer, Int)
forall a. Ord a => a -> Heap a -> Heap a
heapInsert (Integer
value, Int
key) Heap (Integer, Int)
h)

{- | Return Just ((key,priority),remaining queue) for the minimum (priority,key) pair, or
Nothing if empty.
-}
indexedPop :: IndexedHeap -> Maybe ((Int, Integer), IndexedHeap)
indexedPop :: IndexedHeap -> Maybe ((Int, Integer), IndexedHeap)
indexedPop (IndexedHeap Map Int Integer
entries Heap (Integer, Int)
h) = case Heap (Integer, Int) -> Maybe ((Integer, Int), Heap (Integer, Int))
forall a. Ord a => Heap a -> Maybe (a, Heap a)
heapPop Heap (Integer, Int)
h of
    Maybe ((Integer, Int), Heap (Integer, Int))
Nothing -> Maybe ((Int, Integer), IndexedHeap)
forall a. Maybe a
Nothing
    Just ((Integer
v, Int
k), Heap (Integer, Int)
rest)
        | Int -> Map Int Integer -> Maybe Integer
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
k Map Int Integer
entries Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
v -> ((Int, Integer), IndexedHeap)
-> Maybe ((Int, Integer), IndexedHeap)
forall a. a -> Maybe a
Just ((Int
k, Integer
v), Map Int Integer -> Heap (Integer, Int) -> IndexedHeap
IndexedHeap (Int -> Map Int Integer -> Map Int Integer
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Int
k Map Int Integer
entries) Heap (Integer, Int)
rest)
        | Bool
otherwise -> IndexedHeap -> Maybe ((Int, Integer), IndexedHeap)
indexedPop (Map Int Integer -> Heap (Integer, Int) -> IndexedHeap
IndexedHeap Map Int Integer
entries Heap (Integer, Int)
rest)

{- | Persistent disjoint-set partition of zero-based indices, constructed with unionFind and
updated by union.
-}
data UnionFind = UnionFind (Array Int Int) (Array Int Int) deriving (UnionFind -> UnionFind -> Bool
(UnionFind -> UnionFind -> Bool)
-> (UnionFind -> UnionFind -> Bool) -> Eq UnionFind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnionFind -> UnionFind -> Bool
== :: UnionFind -> UnionFind -> Bool
$c/= :: UnionFind -> UnionFind -> Bool
/= :: UnionFind -> UnionFind -> Bool
Eq, Int -> UnionFind -> ShowS
[UnionFind] -> ShowS
UnionFind -> String
(Int -> UnionFind -> ShowS)
-> (UnionFind -> String)
-> ([UnionFind] -> ShowS)
-> Show UnionFind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnionFind -> ShowS
showsPrec :: Int -> UnionFind -> ShowS
$cshow :: UnionFind -> String
show :: UnionFind -> String
$cshowList :: [UnionFind] -> ShowS
showList :: [UnionFind] -> ShowS
Show)

{- | Construct disjoint singleton sets for n zero-based elements, requiring n in
[0,1048576]. Invalid size fails.
-}
unionFind :: Int -> Either MathError UnionFind
unionFind :: Int -> Either MathError UnionFind
unionFind Int
n = do
    Int -> Either MathError ()
checkSize Int
n
    UnionFind -> Either MathError UnionFind
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Array Int Int -> Array Int Int -> UnionFind
UnionFind ((Int, Int) -> [Int] -> Array Int Int
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]) ((Int, Int) -> [Int] -> Array Int Int
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate Int
n Int
1)))

{- | Given element index then union-find structure, return representative root. Invalid
index fails; this pure query does not mutate/compress the stored structure.
-}
findRoot :: Int -> UnionFind -> Either MathError Int
findRoot :: Int -> UnionFind -> Either MathError Int
findRoot Int
i (UnionFind Array Int Int
parent Array Int Int
_)
    | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Array Int Int -> [Int]
forall i e. Array i e -> [e]
elems Array Int Int
parent) = MathError -> Either MathError Int
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"union-find index out of bounds")
    | Bool
otherwise = Int -> Either MathError Int
forall a b. b -> Either a b
Right (Int -> Int
go Int
i)
  where
    go :: Int -> Int
go Int
j | Array Int Int
parent Array Int Int -> Int -> Int
forall i e. Ix i => Array i e -> i -> e
! Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j = Int
j | Bool
otherwise = Int -> Int
go (Array Int Int
parent Array Int Int -> Int -> Int
forall i e. Ix i => Array i e -> i -> e
! Int
j)

{- | Given two valid indices then union-find, return a new structure merging their
components by size. Invalid indices fail; already connected inputs leave connectivity
unchanged.
-}
union :: Int -> Int -> UnionFind -> Either MathError UnionFind
union :: Int -> Int -> UnionFind -> Either MathError UnionFind
union Int
a Int
b uf :: UnionFind
uf@(UnionFind Array Int Int
parent Array Int Int
sizes) = do
    u <- Int -> UnionFind -> Either MathError Int
findRoot Int
a UnionFind
uf
    v <- findRoot b uf
    let (small, large) = if sizes ! u <= sizes ! v then (u, v) else (v, u)
    pure
        ( if u == v
            then uf
            else UnionFind (parent // [(small, large)]) (sizes // [(large, sizes ! large + sizes ! small)])
        )

{- | Given two indices then union-find, return whether their roots match. Invalid indices
return Left InvalidArgument.
-}
connected :: Int -> Int -> UnionFind -> Either MathError Bool
connected :: Int -> Int -> UnionFind -> Either MathError Bool
connected Int
a Int
b UnionFind
uf = Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Int -> Int -> Bool)
-> Either MathError Int -> Either MathError (Int -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> UnionFind -> Either MathError Int
findRoot Int
a UnionFind
uf Either MathError (Int -> Bool)
-> Either MathError Int -> Either MathError Bool
forall a b.
Either MathError (a -> b)
-> Either MathError a -> Either MathError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> UnionFind -> Either MathError Int
findRoot Int
b UnionFind
uf

{- | Return all disjoint components as lists of zero-based element indices, including
singleton sets.
-}
components :: UnionFind -> [[Int]]
components :: UnionFind -> [[Int]]
components uf :: UnionFind
uf@(UnionFind Array Int Int
parent Array Int Int
_) =
    Map Int [Int] -> [[Int]]
forall k a. Map k a -> [a]
M.elems
        ( ([Int] -> [Int] -> [Int]) -> [(Int, [Int])] -> Map Int [Int]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith
            [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
(++)
            [(Int
root, [Int
i]) | Int
i <- [Int
0 .. [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Array Int Int -> [Int]
forall i e. Array i e -> [e]
elems Array Int Int
parent) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1], Right Int
root <- [Int -> UnionFind -> Either MathError Int
findRoot Int
i UnionFind
uf]]
        )

-- SplitMix64 finalizer supplies reproducible noncryptographic hashes. Sketch
-- probability/error formulas assume uniform independent hashes and are not
-- adversarial guarantees for this deterministic hash family.
mix :: Word64 -> Word64
mix :: Word64 -> Word64
mix Word64
x =
    let a :: Word64
a = (Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftR Word64
x Int
30) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
0xbf58476d1ce4e5b9; b :: Word64
b = (Word64
a Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftR Word64
a Int
27) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
0x94d049bb133111eb
     in Word64
b Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftR Word64
b Int
31
hashes :: Int -> Int -> Word64 -> [Int]
hashes :: Int -> Int -> Word64 -> [Int]
hashes Int
k Int
m Word64
x =
    [Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word64
mix (Word64
x Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
0x9e3779b97f4a7c15) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m) | Int
i <- [Int
1 .. Int
k]]

{- | Immutable probabilistic membership filter; False is definitive and True may be a false
positive. Construct with bloom.
-}
data Bloom = Bloom Int Int Integer Integer deriving (Bloom -> Bloom -> Bool
(Bloom -> Bloom -> Bool) -> (Bloom -> Bloom -> Bool) -> Eq Bloom
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Bloom -> Bloom -> Bool
== :: Bloom -> Bloom -> Bool
$c/= :: Bloom -> Bloom -> Bool
/= :: Bloom -> Bloom -> Bool
Eq, Int -> Bloom -> ShowS
[Bloom] -> ShowS
Bloom -> String
(Int -> Bloom -> ShowS)
-> (Bloom -> String) -> ([Bloom] -> ShowS) -> Show Bloom
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Bloom -> ShowS
showsPrec :: Int -> Bloom -> ShowS
$cshow :: Bloom -> String
show :: Bloom -> String
$cshowList :: [Bloom] -> ShowS
showList :: [Bloom] -> ShowS
Show)

{- | Given bit count m in [1,1048576] then hash count k in [1,64], construct an empty Bloom
filter. Invalid dimensions fail.
-}
bloom :: Int -> Int -> Either MathError Bloom
bloom :: Int -> Int -> Either MathError Bloom
bloom Int
m Int
k
    | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1048576 Bool -> Bool -> Bool
|| Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
64 = MathError -> Either MathError Bloom
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"invalid Bloom dimensions")
    | Bool
otherwise = Bloom -> Either MathError Bloom
forall a b. b -> Either a b
Right (Int -> Int -> Integer -> Integer -> Bloom
Bloom Int
m Int
k Integer
0 Integer
0)

{- | Given Word64 key then Bloom filter, set its k hash positions and return updated filter.
Reinsertions are permitted; false positives remain possible.
-}
bloomInsert :: Word64 -> Bloom -> Bloom
bloomInsert :: Word64 -> Bloom -> Bloom
bloomInsert Word64
x (Bloom Int
m Int
k Integer
bits Integer
count) = Int -> Int -> Integer -> Integer -> Bloom
Bloom Int
m Int
k ((Integer -> Int -> Integer) -> Integer -> [Int] -> Integer
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
setBit Integer
bits (Int -> Int -> Word64 -> [Int]
hashes Int
k Int
m Word64
x)) (Integer
count Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)

{- | Test a Word64 key against all Bloom hash positions. False means definitely absent; True
may be a false positive under the documented hash model.
-}
bloomMember :: Word64 -> Bloom -> Bool
bloomMember :: Word64 -> Bloom -> Bool
bloomMember Word64
x (Bloom Int
m Int
k Integer
bits Integer
_) = (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Integer
bits) (Int -> Int -> Word64 -> [Int]
hashes Int
k Int
m Word64
x)

{- | Conservative union bound @min(1,k*n/m)^k@ under independent uniform
query hashes, since at most k*n bits can be occupied. This is a bound rather
than the common exponential occupancy approximation.
-}
bloomFalsePositiveBound :: Bloom -> Double
bloomFalsePositiveBound :: Bloom -> Double
bloomFalsePositiveBound (Bloom Int
m Int
k Integer
_ Integer
count) = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
1 (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
k Double -> Double -> Double
forall a. Num a => a -> a -> a
* Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
count Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m) Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
k

{- | Immutable frequency sketch with nonnegative updates and possible collision
overestimation. Construct with countMin.
-}
data CountMin = CountMin Int Int (M.Map (Int, Int) Integer) Integer deriving (CountMin -> CountMin -> Bool
(CountMin -> CountMin -> Bool)
-> (CountMin -> CountMin -> Bool) -> Eq CountMin
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CountMin -> CountMin -> Bool
== :: CountMin -> CountMin -> Bool
$c/= :: CountMin -> CountMin -> Bool
/= :: CountMin -> CountMin -> Bool
Eq, Int -> CountMin -> ShowS
[CountMin] -> ShowS
CountMin -> String
(Int -> CountMin -> ShowS)
-> (CountMin -> String) -> ([CountMin] -> ShowS) -> Show CountMin
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CountMin -> ShowS
showsPrec :: Int -> CountMin -> ShowS
$cshow :: CountMin -> String
show :: CountMin -> String
$cshowList :: [CountMin] -> ShowS
showList :: [CountMin] -> ShowS
Show)

{- | Given positive width and depth with product\<=1048576, construct an empty count-min
sketch. Invalid dimensions fail.
-}
countMin :: Int -> Int -> Either MathError CountMin
countMin :: Int -> Int -> Either MathError CountMin
countMin Int
width Int
depth
    | Int
width Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
width Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
depth Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
1048576 =
        MathError -> Either MathError CountMin
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"invalid sketch dimensions")
    | Bool
otherwise = CountMin -> Either MathError CountMin
forall a b. b -> Either a b
Right (Int -> Int -> Map (Int, Int) Integer -> Integer -> CountMin
CountMin Int
width Int
depth Map (Int, Int) Integer
forall k a. Map k a
M.empty Integer
0)

{- | Given Word64 key,nonnegative Integer increment,then sketch, increment its hash
counters. Negative updates fail; return a persistent updated sketch.
-}
countMinAdd :: Word64 -> Integer -> CountMin -> Either MathError CountMin
countMinAdd :: Word64 -> Integer -> CountMin -> Either MathError CountMin
countMinAdd Word64
x Integer
delta (CountMin Int
w Int
d Map (Int, Int) Integer
counts Integer
total)
    | Integer
delta Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 = MathError -> Either MathError CountMin
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"count-min requires nonnegative updates")
    | Bool
otherwise =
        CountMin -> Either MathError CountMin
forall a b. b -> Either a b
Right
            ( Int -> Int -> Map (Int, Int) Integer -> Integer -> CountMin
CountMin
                Int
w
                Int
d
                ((Map (Int, Int) Integer -> (Int, Int) -> Map (Int, Int) Integer)
-> Map (Int, Int) Integer -> [(Int, Int)] -> Map (Int, Int) Integer
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (\Map (Int, Int) Integer
m (Int, Int)
key -> (Integer -> Integer -> Integer)
-> (Int, Int)
-> Integer
-> Map (Int, Int) Integer
-> Map (Int, Int) Integer
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+) (Int, Int)
key Integer
delta Map (Int, Int) Integer
m) Map (Int, Int) Integer
counts ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] (Int -> Int -> Word64 -> [Int]
hashes Int
d Int
w Word64
x)))
                (Integer
total Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
delta)
            )

{- | Given Word64 key then sketch, return minimum associated counter as an Integer frequency
estimate. It may overestimate through collisions; use countMinErrorBound for the
documented model.
-}
countMinEstimate :: Word64 -> CountMin -> Integer
countMinEstimate :: Word64 -> CountMin -> Integer
countMinEstimate Word64
x (CountMin Int
w Int
d Map (Int, Int) Integer
counts Integer
_) = [Integer] -> Integer
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Integer -> (Int, Int) -> Map (Int, Int) Integer -> Integer
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Integer
0 (Int
i, Int
j) Map (Int, Int) Integer
counts | (Int
i, Int
j) <- [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] (Int -> Int -> Word64 -> [Int]
hashes Int
d Int
w Word64
x)]

-- | @(additive error, failure probability)@ under the uniform-hash model.
countMinErrorBound :: CountMin -> (Double, Double)
countMinErrorBound :: CountMin -> (Double, Double)
countMinErrorBound (CountMin Int
w Int
d Map (Int, Int) Integer
_ Integer
total) = (Double -> Double
forall a. Floating a => a -> a
exp Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
total Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w, Double -> Double
forall a. Floating a => a -> a
exp (-Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
d))

-- | Immutable probabilistic distinct-cardinality sketch, constructed with hyperLogLog.
data HyperLogLog = HyperLogLog Int (M.Map Int Int) deriving (HyperLogLog -> HyperLogLog -> Bool
(HyperLogLog -> HyperLogLog -> Bool)
-> (HyperLogLog -> HyperLogLog -> Bool) -> Eq HyperLogLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HyperLogLog -> HyperLogLog -> Bool
== :: HyperLogLog -> HyperLogLog -> Bool
$c/= :: HyperLogLog -> HyperLogLog -> Bool
/= :: HyperLogLog -> HyperLogLog -> Bool
Eq, Int -> HyperLogLog -> ShowS
[HyperLogLog] -> ShowS
HyperLogLog -> String
(Int -> HyperLogLog -> ShowS)
-> (HyperLogLog -> String)
-> ([HyperLogLog] -> ShowS)
-> Show HyperLogLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HyperLogLog -> ShowS
showsPrec :: Int -> HyperLogLog -> ShowS
$cshow :: HyperLogLog -> String
show :: HyperLogLog -> String
$cshowList :: [HyperLogLog] -> ShowS
showList :: [HyperLogLog] -> ShowS
Show)

{- | Construct an empty cardinality sketch from precision p in [4,16], using 2^p registers.
Invalid precision fails; hllEstimate returns its probabilistic estimate.
-}
hyperLogLog :: Int -> Either MathError HyperLogLog
hyperLogLog :: Int -> Either MathError HyperLogLog
hyperLogLog Int
precision
    | Int
precision Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4 Bool -> Bool -> Bool
|| Int
precision Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
16 = MathError -> Either MathError HyperLogLog
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"HLL precision must be in [4,16]")
    | Bool
otherwise = HyperLogLog -> Either MathError HyperLogLog
forall a b. b -> Either a b
Right (Int -> Map Int Int -> HyperLogLog
HyperLogLog Int
precision Map Int Int
forall k a. Map k a
M.empty)

{- | Given Word64 item then HyperLogLog sketch, hash and update its register maximum. Return
persistent updated sketch; repeated items do not add a new exact count.
-}
hllAdd :: Word64 -> HyperLogLog -> HyperLogLog
hllAdd :: Word64 -> HyperLogLog -> HyperLogLog
hllAdd Word64
x (HyperLogLog Int
p Map Int Int
registers) = Int -> Map Int Int -> HyperLogLog
HyperLogLog Int
p ((Int -> Int -> Int) -> Int -> Int -> Map Int Int -> Map Int Int
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
bucket Int
rho Map Int Int
registers)
  where
    h :: Word64
h = Word64 -> Word64
mix Word64
x
    bucket :: Int
bucket = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftR Word64
h (Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
p))
    remainder :: Word64
remainder = Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftL Word64
h Int
p
    rho :: Int
rho = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
65 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
p) (Word64 -> Int
forall b. FiniteBits b => b -> Int
countLeadingZeros Word64
remainder Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

{- | HyperLogLog with linear-counting small-range correction. Typical relative
standard error is approximately @1.04/sqrt(2^p)@ under uniform hashing.
-}
hllEstimate :: HyperLogLog -> Double
hllEstimate :: HyperLogLog -> Double
hllEstimate (HyperLogLog Int
p Map Int Int
registers)
    | Double
raw Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
2.5 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
m Bool -> Bool -> Bool
&& Int
zeros Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Double
m Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
log (Double
m Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
zeros)
    | Bool
otherwise = Double
raw
  where
    count :: Int
count = Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
p
    m :: Double
m = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
count
    alpha :: Double
alpha = case Int
p of Int
4 -> Double
0.673; Int
5 -> Double
0.697; Int
6 -> Double
0.709; Int
_ -> Double
0.7213 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
1.079 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
m)
    zeros :: Int
zeros = Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Map Int Int -> Int
forall k a. Map k a -> Int
M.size Map Int Int
registers
    raw :: Double
raw = Double
alpha Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
m Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
m Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
zeros Double -> Double -> Double
forall a. Num a => a -> a -> a
+ [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double
2 Double -> Double -> Double
forall a. Floating a => a -> a -> a
** (-Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r) | Int
r <- Map Int Int -> [Int]
forall k a. Map k a -> [a]
M.elems Map Int Int
registers])

{- | Seeded bounded Algorithm-R stream sample state. Construct with reservoir and update
with reservoirAdd.
-}
data Reservoir a = Reservoir Int Integer Word64 [a] deriving (Reservoir a -> Reservoir a -> Bool
(Reservoir a -> Reservoir a -> Bool)
-> (Reservoir a -> Reservoir a -> Bool) -> Eq (Reservoir a)
forall a. Eq a => Reservoir a -> Reservoir a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Reservoir a -> Reservoir a -> Bool
== :: Reservoir a -> Reservoir a -> Bool
$c/= :: forall a. Eq a => Reservoir a -> Reservoir a -> Bool
/= :: Reservoir a -> Reservoir a -> Bool
Eq, Int -> Reservoir a -> ShowS
[Reservoir a] -> ShowS
Reservoir a -> String
(Int -> Reservoir a -> ShowS)
-> (Reservoir a -> String)
-> ([Reservoir a] -> ShowS)
-> Show (Reservoir a)
forall a. Show a => Int -> Reservoir a -> ShowS
forall a. Show a => [Reservoir a] -> ShowS
forall a. Show a => Reservoir a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Reservoir a -> ShowS
showsPrec :: Int -> Reservoir a -> ShowS
$cshow :: forall a. Show a => Reservoir a -> String
show :: Reservoir a -> String
$cshowList :: forall a. Show a => [Reservoir a] -> ShowS
showList :: [Reservoir a] -> ShowS
Show)

{- | Given sample capacity in [0,1048576] then Word64 seed, construct an empty deterministic
Algorithm-R reservoir. Invalid capacity fails.
-}
reservoir :: Int -> Word64 -> Either MathError (Reservoir a)
reservoir :: forall a. Int -> Word64 -> Either MathError (Reservoir a)
reservoir Int
k Word64
seed
    | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1048576 = MathError -> Either MathError (Reservoir a)
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"invalid reservoir size")
    | Bool
otherwise = Reservoir a -> Either MathError (Reservoir a)
forall a b. b -> Either a b
Right (Int -> Integer -> Word64 -> [a] -> Reservoir a
forall a. Int -> Integer -> Word64 -> [a] -> Reservoir a
Reservoir Int
k Integer
0 Word64
seed [])

{- | Algorithm R with rejection sampling (no modulo bias). The 64-bit stream
index is bounded; uniform sampling assumes the pseudorandom stream model.
-}
reservoirAdd :: a -> Reservoir a -> Either MathError (Reservoir a)
reservoirAdd :: forall a. a -> Reservoir a -> Either MathError (Reservoir a)
reservoirAdd a
x (Reservoir Int
k Integer
count Word64
seed [a]
values)
    | Integer
count Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
2 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
64 :: Int) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1 = MathError -> Either MathError (Reservoir a)
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"reservoir stream exceeds 64-bit counter")
    | [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
values Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
k = Reservoir a -> Either MathError (Reservoir a)
forall a b. b -> Either a b
Right (Int -> Integer -> Word64 -> [a] -> Reservoir a
forall a. Int -> Integer -> Word64 -> [a] -> Reservoir a
Reservoir Int
k (Integer
count Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Word64
seed ([a]
values [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
x]))
    | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Reservoir a -> Either MathError (Reservoir a)
forall a b. b -> Either a b
Right (Int -> Integer -> Word64 -> [a] -> Reservoir a
forall a. Int -> Integer -> Word64 -> [a] -> Reservoir a
Reservoir Int
k (Integer
count Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Word64
seed [a]
values)
    | Bool
otherwise =
        let (Integer
j, Word64
s) = Integer -> Word64 -> (Integer, Word64)
draw (Integer
count Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Word64
seed
         in Reservoir a -> Either MathError (Reservoir a)
forall a b. b -> Either a b
Right
                ( Int -> Integer -> Word64 -> [a] -> Reservoir a
forall a. Int -> Integer -> Word64 -> [a] -> Reservoir a
Reservoir
                    Int
k
                    (Integer
count Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)
                    Word64
s
                    ( if Integer
j Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
k
                        then Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
j) [a]
values [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
x] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [a]
values
                        else [a]
values
                    )
                )
  where
    draw :: Integer -> Word64 -> (Integer, Word64)
draw Integer
bound Word64
state =
        let next :: Word64
next = Word64
state Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
0x9e3779b97f4a7c15
            r :: Integer
r = Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64 -> Word64
mix Word64
next)
            limit :: Integer
limit = Integer
2 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
64 :: Int) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- (Integer
2 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
64 :: Int) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
bound)
         in if Integer
r Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
limit then (Integer
r Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
bound, Word64
next) else Integer -> Word64 -> (Integer, Word64)
draw Integer
bound Word64
next

{- | Return retained reservoir sample values. Their count never exceeds capacity; output
order is storage order, not a sorted or arrival-order guarantee.
-}
reservoirValues :: Reservoir a -> [a]
reservoirValues :: forall a. Reservoir a -> [a]
reservoirValues (Reservoir Int
_ Integer
_ Word64
_ [a]
xs) = [a]
xs

{- | Exact online order statistics with an explicit memory cap. This deliberately
trades bounded-memory approximate quantiles for exact results; inserts are
O(n), queries O(1) after insertion. Exceeding the cap fails without eviction.
-}
data OnlineQuantiles = OnlineQuantiles Int [Double] deriving (OnlineQuantiles -> OnlineQuantiles -> Bool
(OnlineQuantiles -> OnlineQuantiles -> Bool)
-> (OnlineQuantiles -> OnlineQuantiles -> Bool)
-> Eq OnlineQuantiles
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OnlineQuantiles -> OnlineQuantiles -> Bool
== :: OnlineQuantiles -> OnlineQuantiles -> Bool
$c/= :: OnlineQuantiles -> OnlineQuantiles -> Bool
/= :: OnlineQuantiles -> OnlineQuantiles -> Bool
Eq, Int -> OnlineQuantiles -> ShowS
[OnlineQuantiles] -> ShowS
OnlineQuantiles -> String
(Int -> OnlineQuantiles -> ShowS)
-> (OnlineQuantiles -> String)
-> ([OnlineQuantiles] -> ShowS)
-> Show OnlineQuantiles
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OnlineQuantiles -> ShowS
showsPrec :: Int -> OnlineQuantiles -> ShowS
$cshow :: OnlineQuantiles -> String
show :: OnlineQuantiles -> String
$cshowList :: [OnlineQuantiles] -> ShowS
showList :: [OnlineQuantiles] -> ShowS
Show)

{- | Given exact-storage cap in [0,1048576], create an empty online order-statistics
container. Invalid capacity fails; this retains exact values rather than a
bounded-memory approximate sketch.
-}
onlineQuantiles :: Int -> Either MathError OnlineQuantiles
onlineQuantiles :: Int -> Either MathError OnlineQuantiles
onlineQuantiles Int
cap = do Int -> Either MathError ()
checkSize Int
cap; OnlineQuantiles -> Either MathError OnlineQuantiles
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> [Double] -> OnlineQuantiles
OnlineQuantiles Int
cap [])

{- | Given finite Double then quantile container, insert in sorted order. Non-finite values
or a full cap fail without eviction; original container is unchanged.
-}
quantileAdd :: Double -> OnlineQuantiles -> Either MathError OnlineQuantiles
quantileAdd :: Double -> OnlineQuantiles -> Either MathError OnlineQuantiles
quantileAdd Double
x (OnlineQuantiles Int
cap [Double]
xs)
    | Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
x Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
x = MathError -> Either MathError OnlineQuantiles
forall a b. a -> Either a b
Left MathError
NonFiniteResult
    | [Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
cap = MathError -> Either MathError OnlineQuantiles
forall a b. a -> Either a b
Left (String -> Int -> MathError
NonConvergence String
"online quantile memory" Int
cap)
    | Bool
otherwise = let ([Double]
a, [Double]
b) = (Double -> Bool) -> [Double] -> ([Double], [Double])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
x) [Double]
xs in OnlineQuantiles -> Either MathError OnlineQuantiles
forall a b. b -> Either a b
Right (Int -> [Double] -> OnlineQuantiles
OnlineQuantiles Int
cap ([Double]
a [Double] -> [Double] -> [Double]
forall a. [a] -> [a] -> [a]
++ [Double
x] [Double] -> [Double] -> [Double]
forall a. [a] -> [a] -> [a]
++ [Double]
b))

{- | Given finite q in [0,1] then nonempty quantile container, linearly interpolate order
statistics at q*(n-1). Invalid q or empty state returns Left InvalidArgument.
-}
onlineQuantile :: Double -> OnlineQuantiles -> Either MathError Double
onlineQuantile :: Double -> OnlineQuantiles -> Either MathError Double
onlineQuantile Double
q (OnlineQuantiles Int
_ [Double]
xs)
    | [Double] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Double]
xs Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
q Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
q Bool -> Bool -> Bool
|| Double
q Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 Bool -> Bool -> Bool
|| Double
q Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1 =
        MathError -> Either MathError Double
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"invalid online quantile")
    | Bool
otherwise =
        let p :: Double
p = Double
q Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1); lo :: Int
lo = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
p; hi :: Int
hi = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Double
p; t :: Double
t = Double
p Double -> Double -> Double
forall a. Num a => a -> a -> a
- Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lo
         in Double -> Either MathError Double
forall a b. b -> Either a b
Right ((Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
t) Double -> Double -> Double
forall a. Num a => a -> a -> a
* ([Double]
xs [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
lo) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
t Double -> Double -> Double
forall a. Num a => a -> a -> a
* ([Double]
xs [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
hi))