+copyright: Preetham Gujjula
+license: BSD-3-Clause
+build-type: Simple
+tested-with:
+ GHC == {9.2.8, 9.4.8, 9.6.4}
+extra-doc-files:
+ README.md
+ ChangeLog.md
+ docs/ALGORITHM.md
+
+source-repository head
+ type: git
+ location: https://github.com/pgujjula/apply-merge
+
+library
+ exposed-modules:
+ Data.List.ApplyMerge
+ other-modules:
+ Data.List.ApplyMerge.IntSet
+ hs-source-dirs:
+ src
+ ghc-options: -Wall -Wunused-packages
+ build-depends:
+ base >=4.16 && <4.17 || >=4.17 && <4.18 || >=4.18 && <4.19 || >=4.19 && <4.20
+ , containers ==0.6.*
+ , pqueue >=1.4 && <1.5 || >=1.5 && <1.6
+ default-language: GHC2021
+
+test-suite apply-merge-tests
+ type: exitcode-stdio-1.0
+ main-is: Main.hs
+ other-modules:
+ Data.DoublyLinkedList.STRef
+ Data.List.ApplyMerge
+ Data.List.ApplyMerge.DoublyLinkedList
+ Data.List.ApplyMerge.IntMap
+ Data.List.ApplyMerge.IntSet
+ Data.PQueue.Prio.Min.Mutable
+ Test.Data.DoublyLinkedList.STRef
+ Test.Data.List.ApplyMerge.Common
+ Test.Data.List.ApplyMerge.DoublyLinkedList
+ Test.Data.List.ApplyMerge.IntMap
+ Test.Data.List.ApplyMerge.IntSet
+ Test.Data.PQueue.Prio.Min.Mutable
+ hs-source-dirs:
+ src
+ test
+ ghc-options: -Wall -Wunused-packages
+ build-depends:
+ base >=4.16 && <4.17 || >=4.17 && <4.18 || >=4.18 && <4.19 || >=4.19 && <4.20
+ , containers ==0.6.*
+ , falsify ==0.2.*
+ , pqueue >=1.4 && <1.5 || >=1.5 && <1.6
+ , tasty >=1.4 && <1.5 || >=1.5 && <1.6
+ , tasty-expected-failure ==0.12.*
+ , tasty-hunit ==0.10.*
+ , transformers >=0.5 && <0.6 || >=0.6 && <0.7
+ , vector >=0.12 && <0.13 || >=0.13 && <0.14
+ default-language: GHC2021
+
+benchmark apply-merge-benchmarks
+ type: exitcode-stdio-1.0
+ main-is: Main.hs
+ other-modules:
+ Data.DoublyLinkedList.STRef
+ Data.List.ApplyMerge
+ Data.List.ApplyMerge.DoublyLinkedList
+ Data.List.ApplyMerge.IntMap
+ Data.List.ApplyMerge.IntSet
+ Data.PQueue.Prio.Min.Mutable
+ Bench.Data.DoublyLinkedList.STRef
+ Bench.PriorityQueue.MinPQueue
+ Bench.PriorityQueue.MinPQueue.Mutable
+ hs-source-dirs:
+ src
+ bench
+ ghc-options: -Wall -Wunused-packages
+ build-depends:
+ base >=4.16 && <4.17 || >=4.17 && <4.18 || >=4.18 && <4.19 || >=4.19 && <4.20
+ , containers ==0.6.*
+ , pqueue >=1.4 && <1.5 || >=1.5 && <1.6
+ , tasty-bench ==0.3.*
+ , transformers >=0.5 && <0.6 || >=0.6 && <0.7
+ , vector >=0.12 && <0.13 || >=0.13 && <0.14
+ default-language: GHC2021
diff --git a/bench/Bench/Data/DoublyLinkedList/STRef.hs b/bench/Bench/Data/DoublyLinkedList/STRef.hs
new file mode 100644
--- /dev/null
+++ b/bench/Bench/Data/DoublyLinkedList/STRef.hs
@@ -0,0 +1,172 @@
+-- SPDX-FileCopyrightText: Copyright Preetham Gujjula
+-- SPDX-License-Identifier: BSD-3-Clause
+
+module Bench.Data.DoublyLinkedList.STRef (benchmarks) where
+
+import Control.Monad (forM_, void)
+import Control.Monad.ST (runST)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
+import Data.DoublyLinkedList.STRef
+ ( cons,
+ delete,
+ empty,
+ head,
+ insertAfter,
+ prev,
+ snoc,
+ value,
+ )
+import Data.Map (Map)
+import Data.Map qualified as Map
+import Data.Maybe (fromMaybe)
+import Test.Tasty.Bench (Benchmark, bench, bgroup, nf)
+import Prelude hiding (head, last, null)
+
+superscript :: Char -> Char
+superscript c = fromMaybe c (Map.lookup c superscriptMap)
+
+superscriptMap :: Map Char Char
+superscriptMap =
+ Map.fromList
+ [ ('0', '⁰'),
+ ('1', '¹'),
+ ('2', '²'),
+ ('3', '³'),
+ ('4', '⁴'),
+ ('5', '⁵'),
+ ('6', '⁶'),
+ ('7', '⁷'),
+ ('8', '⁸'),
+ ('9', '⁹')
+ ]
+
+benchmarks :: Benchmark
+benchmarks =
+ bgroup
+ "Data.DoublyLinkedList.STRef"
+ [ constructionBenchmarks,
+ traversalBenchmarks,
+ queryBenchmarks,
+ insertionBenchmarks,
+ deletionBenchmarks,
+ listConversionBenchmarks
+ ]
+
+-- * Construction
+
+constructionBenchmarks :: Benchmark
+constructionBenchmarks =
+ bgroup
+ "Construction"
+ [ emptyBenchmarks,
+ fromListBenchmarks
+ ]
+
+emptyBenchmarks :: Benchmark
+emptyBenchmarks = bgroup "empty" []
+
+fromListBenchmarks :: Benchmark
+fromListBenchmarks = bgroup "fromList" []
+
+-- * Traversal
+
+traversalBenchmarks :: Benchmark
+traversalBenchmarks =
+ bgroup
+ "Traversal"
+ [ headBenchmarks,
+ lastBenchmarks,
+ nextBenchmarks,
+ prevBenchmarks
+ ]
+
+headBenchmarks :: Benchmark
+headBenchmarks = bgroup "head" []
+
+lastBenchmarks :: Benchmark
+lastBenchmarks = bgroup "last" []
+
+nextBenchmarks :: Benchmark
+nextBenchmarks = bgroup "next" []
+
+prevBenchmarks :: Benchmark
+prevBenchmarks = bgroup "prev" []
+
+-- * Query
+
+queryBenchmarks :: Benchmark
+queryBenchmarks = bgroup "Query" [nullBenchmarks, valueBenchmarks]
+
+nullBenchmarks :: Benchmark
+nullBenchmarks = bgroup "null" []
+
+valueBenchmarks :: Benchmark
+valueBenchmarks = bgroup "value" []
+
+-- * Insertion
+
+insertionBenchmarks :: Benchmark
+insertionBenchmarks =
+ bgroup
+ "Insertion"
+ [ consBenchmarks,
+ snocBenchmarks,
+ insertAfterBenchmarks,
+ insertBeforeBenchmarks
+ ]
+
+consBenchmarks :: Benchmark
+consBenchmarks = bgroup "cons" $
+ flip map [(1 :: Int) .. 6] $ \i ->
+ bench ("cons 10" ++ map superscript (show i) ++ " times") $
+ flip nf ((10 :: Int) ^ i) $ \n -> runST $ do
+ list <- empty
+ forM_ [1 .. n] (cons list)
+ firstNode <- head list
+ let firstValue = value <$> firstNode
+ pure firstValue
+
+snocBenchmarks :: Benchmark
+snocBenchmarks = bgroup "snoc" $
+ flip map [(1 :: Int) .. 6] $ \i ->
+ bench ("snoc 10" ++ map superscript (show i) ++ " times") $
+ flip nf ((10 :: Int) ^ i) $ \n -> runST $ do
+ list <- empty
+ forM_ [1 .. n] (snoc list)
+ firstNode <- head list
+ let firstValue = value <$> firstNode
+ pure firstValue
+
+insertBeforeBenchmarks :: Benchmark
+insertBeforeBenchmarks = bgroup "insertBefore" []
+
+insertAfterBenchmarks :: Benchmark
+insertAfterBenchmarks = bgroup "insertAfter" []
+
+-- * Deletion
+
+deletionBenchmarks :: Benchmark
+deletionBenchmarks = bgroup "Deletion" [deleteBenchmarks]
+
+deleteBenchmarks :: Benchmark
+deleteBenchmarks = bgroup "delete (uses insertAfter and prev)" $
+ flip map [(1 :: Int) .. 6] $ \i ->
+ bench ("delete 10" ++ map superscript (show i) ++ " times") $
+ flip nf ((10 :: Int) ^ i) $ \n -> runST $ runMaybeT $ do
+ list <- lift empty
+ node1 <- lift (cons list (1 :: Int))
+ node2 <- lift (insertAfter node1 2)
+ node3 <- lift (insertAfter node2 3)
+ forM_ [1 .. n] $ \j -> do
+ lift (void (insertAfter node1 j))
+ prevNode <- MaybeT (prev node3)
+ lift (delete prevNode)
+
+-- * List conversion
+
+listConversionBenchmarks :: Benchmark
+listConversionBenchmarks = bgroup "List conversion" [toListBenchmarks]
+
+toListBenchmarks :: Benchmark
+toListBenchmarks = bgroup "toList" []
diff --git a/bench/Bench/PriorityQueue/MinPQueue.hs b/bench/Bench/PriorityQueue/MinPQueue.hs
new file mode 100644
--- /dev/null
+++ b/bench/Bench/PriorityQueue/MinPQueue.hs
@@ -0,0 +1,34 @@
+-- SPDX-FileCopyrightText: Copyright Preetham Gujjula
+-- SPDX-License-Identifier: BSD-3-Clause
+module Bench.PriorityQueue.MinPQueue (benchmarks) where
+
+import Data.List (foldl')
+import Data.PQueue.Prio.Min (deleteMin, fromAscList, getMin, insert)
+import Test.Tasty.Bench (Benchmark, bench, bgroup, nf)
+
+generate :: Int -> [Int]
+generate = iterate (\x -> 6364136223846793005 * x + 1442695040888963407)
+
+insertDeleteBenchmark :: Benchmark
+insertDeleteBenchmark = bgroup "insert/delete" (map mkBench [1 .. 6])
+ where
+ mkBench :: Int -> Benchmark
+ mkBench i =
+ let quantity :: String
+ quantity = "10^" ++ show i
+ message :: String
+ message =
+ quantity
+ ++ " inserts and deletes on a priority queue of size "
+ ++ quantity
+ in bench message $ flip nf ((10 :: Int) ^ i) $ \n ->
+ let initialQueue = fromAscList (map (\x -> (x, x)) [1 .. n])
+ finalQueue =
+ foldl'
+ (\pq (x :: Int) -> deleteMin (insert x x pq))
+ initialQueue
+ (take n (generate n))
+ in getMin finalQueue
+
+benchmarks :: Benchmark
+benchmarks = bgroup "Bench.PriorityQueue.MinPQueue" [insertDeleteBenchmark]
diff --git a/bench/Bench/PriorityQueue/MinPQueue/Mutable.hs b/bench/Bench/PriorityQueue/MinPQueue/Mutable.hs
new file mode 100644
--- /dev/null
+++ b/bench/Bench/PriorityQueue/MinPQueue/Mutable.hs
@@ -0,0 +1,37 @@
+-- SPDX-FileCopyrightText: Copyright Preetham Gujjula
+-- SPDX-License-Identifier: BSD-3-Clause
+module Bench.PriorityQueue.MinPQueue.Mutable (benchmarks) where
+
+import Control.Monad (forM_)
+import Control.Monad.ST (runST)
+import Data.PQueue.Prio.Min.Mutable (deleteMin, fromAscList, insert)
+import Test.Tasty.Bench (Benchmark, bench, bgroup, nf)
+
+generate :: Int -> [Int]
+generate = iterate (\x -> 6364136223846793005 * x + 1442695040888963407)
+
+insertDeleteBenchmark :: Benchmark
+insertDeleteBenchmark = bgroup "insert/delete" (map mkBench [1 .. 6])
+ where
+ mkBench :: Int -> Benchmark
+ mkBench i =
+ let quantity :: String
+ quantity = "10^" ++ show i
+ message :: String
+ message =
+ quantity
+ ++ " inserts and deletes on a priority queue of size "
+ ++ quantity
+ in bench message $ flip nf ((10 :: Int) ^ i) $ \n -> runST $ do
+ queue <- fromAscList (map (\x -> (x, x)) [1 .. n])
+ forM_ (take n (generate n)) $ \x -> do
+ insert x x queue
+ deleteMin queue
+
+ deleteMin queue
+
+benchmarks :: Benchmark
+benchmarks =
+ bgroup
+ "Bench.PriorityQueue.MinPQueue.Mutable"
+ [insertDeleteBenchmark]
diff --git a/bench/Main.hs b/bench/Main.hs
new file mode 100644
--- /dev/null
+++ b/bench/Main.hs
@@ -0,0 +1,47 @@
+-- SPDX-FileCopyrightText: Copyright Preetham Gujjula
+-- SPDX-License-Identifier: BSD-3-Clause
+
+module Main (main) where
+
+import Bench.Data.DoublyLinkedList.STRef qualified
+import Bench.PriorityQueue.MinPQueue qualified
+import Bench.PriorityQueue.MinPQueue.Mutable qualified
+import Data.Function ((&))
+import Data.List.ApplyMerge.DoublyLinkedList qualified
+import Data.List.ApplyMerge.IntMap qualified
+import Data.List.ApplyMerge.IntSet qualified
+import Test.Tasty.Bench (Benchmark, bench, bgroup, defaultMain, nf)
+
+main :: IO ()
+main =
+ defaultMain
+ [ benchCommon
+ "DoublyLinkedList"
+ Data.List.ApplyMerge.DoublyLinkedList.applyMerge,
+ benchCommon "IntMap" Data.List.ApplyMerge.IntMap.applyMerge,
+ benchCommon "IntSet" Data.List.ApplyMerge.IntSet.applyMerge,
+ Bench.Data.DoublyLinkedList.STRef.benchmarks,
+ Bench.PriorityQueue.MinPQueue.benchmarks,
+ Bench.PriorityQueue.MinPQueue.Mutable.benchmarks
+ ]
+
+benchCommon ::
+ String ->
+ (forall a b c. (Ord c) => (a -> b -> c) -> [a] -> [b] -> [c]) ->
+ Benchmark
+benchCommon name applyMerge =
+ bgroup name [benchmarkSymmetric]
+ where
+ benchmarkSymmetric :: Benchmark
+ benchmarkSymmetric =
+ bgroup "benchmarkSymmetric" (fmap mkBench [1 .. (6 :: Int)])
+ where
+ mkBench :: Int -> Benchmark
+ mkBench i = bench (show i) (nf collapse (10 ^ i))
+ where
+ collapse :: Int -> Int
+ collapse n =
+ let start = (n `quot` maxBound) + 1
+ in applyMerge (*) [start ..] [start ..]
+ & take n
+ & sum
diff --git a/docs/ALGORITHM.md b/docs/ALGORITHM.md
new file mode 100644
--- /dev/null
+++ b/docs/ALGORITHM.md
@@ -0,0 +1,259 @@
+
+
+# Motivation
+
+## The problem
+Say that we want to compute the [3-smooth numbers](https://en.wikipedia.org/wiki/Smooth_number),
+i.e., the integers that can be written in the form $2^{i} 3^{j}$, where $i$ and
+$j$ are non-negative integers.
+
+It's easy enough to compute the powers of 2 and 3:
+
+```haskell
+powersOf2 :: [Integer]
+powersOf2 = iterate (*2) 1
+
+powersOf3 :: [Integer]
+powersOf3 = iterate (*3) 1
+```
+
+But how do we implement the following?
+
+```haskell
+-- take 10 smooth3 == [1, 2, 3, 4, 6, 9, 12, 16, 18, 24]
+smooth3 :: [Integer]
+smooth3 = ..
+```
+
+If we limited `powersOf2` and `powersOf3`, say to the first 10 elements, we
+could write:
+
+```haskell
+powersOf2Bounded :: [Integer]
+powersOf2Bounded = take 10 (iterate (*2) 1)
+
+powersOf3Bounded :: [Integer]
+powersOf3Bounded = take 10 (iterate (*3) 1)
+
+smooth3Bounded :: [Integer]
+smooth3Bounded = sort (liftA2 (*) powersOf2Bounded powersOf3Bounded)
+```
+
+And `smooth3Bounded` would consist of $\\{2^{i} 3^{j} \mid 0 \le i, j < 10\\}$.
+But this doesn't work when `powersOf2` and `powersOf3` are infinite. We need a
+way to lazily generate `smooth3` given `powersOf2` and `powersOf3`.
+
+## A closer look
+Let's lay out the elements of `smooth3` in a 2D grid:
+
+
+ | 1 2 4 8 ..
+ ---------------------------------
+ 1 | 1 2 4 8 ..
+ |
+ 3 | 3 6 12 24 ..
+ |
+ 9 | 9 18 36 72 ..
+ |
+ 27 | 27 54 108 216 ..
+ |
+ : | : : : : ॱ.
+
+
+Since `(*)` is monotonically increasing in both arguments, each element in the
+grid is ≥ its neighbors above and to the left. Therefore, when an element
+appears in `smooth3`, its up- and left-neighbors must already have appeared.
+
+Let's think about `smooth3` after 3 elements have been produced:
+
+
+ | 1 2 4 8 ..
+ ---------------------------------
+ 1 | 1 2 4 8 ..
+ |
+ 3 | 3 6 12 24 ..
+ |
+ 9 | 9 18 36 72 ..
+ |
+ 27 | 27 54 108 216 ..
+ |
+ : | : : : : ॱ.
+
+
+After producing `1, 2, 3`, the next element in `smooth3` can only be one of
+`{4, 6, 9}`. We know this without performing any comparisons, just by the
+positions of these elements in the grid, as these are the only elements whose
+up- and left-neighbors have already been produced.
+
+After producing the next element, `4`, our grid becomes
+
+
+ | 1 2 4 8 ..
+ ---------------------------------
+ 1 | 1 2 4 8 ..
+ |
+ 3 | 3 6 12 24 ..
+ |
+ 9 | 9 18 36 72 ..
+ |
+ 27 | 27 54 108 216 ..
+ |
+ : | : : : : ॱ.
+
+
+Now, the "frontier" of possible next elements is `{6, 8, 9}`. We added `8` to
+the frontier as it is no longer "blocked" by `4`. Note that we cannot yet add
+`12` to the frontier even though it's no longer blocked by `4`, as it's still
+blocked by `6`.
+
+After producing the next element, `6`, our grid becomes
+
+
+ | 1 2 4 8 ..
+ ---------------------------------
+ 1 | 1 2 4 8 ..
+ |
+ 3 | 3 6 12 24 ..
+ |
+ 9 | 9 18 36 72 ..
+ |
+ 27 | 27 54 108 216 ..
+ |
+ : | : : : : ॱ.
+
+
+Now, the frontier consists of `{8, 9, 12}`. We added `12` as it is now unblocked
+by `4` and `6`. We cannot yet add `18`, as it is still blocked by `9`.
+
+This investigation suggests the following algorithm for producing `smooth3`:
+
+```
+1. Initialize a "frontier" with the top left element
+2. Delete the smallest element z from the frontier and yield it as the next element of smooth3.
+3. If the down- or right-neighbors of z are unblocked, add them to the frontier.
+4. Go to step 2.
+```
+
+# The `applyMerge` function
+
+The idea in the algorithm above is quite general, and instead of using it on
+`(*)`, `powersOf2`, and `powersOf3`, we can apply it to any binary function `f`
+that is non-decreasing in both arguments, and any (potentially infinite) ordered
+lists `xs` and `ys`. Then we can define a general
+
+```haskell
+applyMerge :: (Ord c) => (a -> b -> c) -> [a] -> [b] -> [c]
+```
+
+where `applyMerge f xs ys` is an ordered list of all `f x y`, for each `x` in `xs`
+and `y` in `ys`. In particular, `smooth3 = applyMerge (*) powersOf2 powersOf3`.
+
+## Implementation and complexity
+
+We can use a priority queue to maintain the frontier of elements. To determine
+in step 3 whether a down- or right-neighbor is unblocked, we maintain two
+`IntSet`s, for the `x`- and `y`- indices of all elements in the frontier. Then
+in step 3, if the `x`- and `y`-index of a neighbor are not in the respective
+`IntSet`s, the neighbor is unblocked and can be added to the frontier.
+
+After producing $n$ elements, the size of the frontier is at most $O(\sqrt{n})$
+elements. (TODO: add a proof of this) Manipulating the priority queue and
+the `IntSet`s to produce the next element takes
+$O(\text{log } \sqrt{n}) = O(\text{log } n)$ time. Therefore, producing $n$
+elements of `applyMerge f xs ys` takes $O(n \log n)$ time and $O(\sqrt{n})$
+auxiliary space, assuming that `f` and `compare` take $O(1)$ time.
+
+### Note about memory usage
+Note that `applyMerge` retains the input lists in memory, which could cause
+unexpected memory usage when the input lists are lazily generated. For example,
+```
+sum (take n (applyMerge const [1 :: Int ..] [1 :: Int ..]))
+```
+requires retaining the first $n$ elements of the second list, and so uses $O(n)$
+space. Constrast this with
+```
+sum (take n (applyMerge (+) [1 :: Int ..] [1 :: Int ..]))
+```
+which requires retaining the first $O(\sqrt{n})$ elements of each list, and uses
+$O(\sqrt{n})$ space.
+
+## More examples
+
+With `applyMerge`, we can implement a variety of complex algorithms succinctly.
+For example, the Sieve of Erastosthenes[^1] to generate prime numbers:
+
+```haskell
+primes :: [Int]
+primes = 2 : ([3..] `minus` composites) -- `minus` from data-ordlist
+
+composites :: [Int]
+composites = applyMerge (*) primes [2..]
+```
+
+Gaussian integers, ordered by norm ([Wikipedia](https://en.wikipedia.org/wiki/Gaussian_integer)):
+
+```haskell
+zs :: [Integer]
+zs = 0 : concatMap (\i -> [i, -i]) [1..]
+
+gaussianIntegers :: [GaussianInteger] -- `GaussianInteger` from arithmoi
+gaussianIntegers = map snd (applyMerge (\x y -> (norm (x :+ y), x :+ y)) zs zs)
+```
+
+Square-free integers ([Wikipedia](https://en.wikipedia.org/wiki/Square-free_integer)):
+
+```haskell
+squarefrees :: [Int]
+squarefrees = [1..] `minus` applyMerge (*) (map (^2) primes) [1..]
+```
+
+# Prior work
+
+## mergeAll from data-ordlist
+
+In [data-ordlist](https://www.stackage.org/lts/package/data-ordlist),
+there is [mergeAll](https://www.stackage.org/haddock/lts/data-ordlist/Data-List-Ordered.html#v:mergeAll) :: Ord a => [[a]] -> [a],
+which merges a potentially infinite list of ordered lists, where the heads of
+the inner lists are sorted. This is more general than `applyMerge`, in the sense
+that we can implement `applyMerge` in terms of `mergeAll`:
+
+```haskell
+applyMerge :: (Ord c) => (a -> b -> c) -> [a] -> [b] -> [c]
+applyMerge f xs ys =
+ mergeAll (map (\y -> map (\x -> f x y) xs) ys)
+```
+
+However, `mergeAll` uses $O(n)$ auxiliary space in the worst case, while our
+implementation of `applyMerge` uses just $O(\sqrt{n})$ auxiliary space.
+
+## Skiena's algorithm
+
+In [The Algorithm Design Manual](https://doi.org/10.1007%2F978-1-84800-070-4_4),
+Steven Skiena describes an algorithm for minimizing the sum of two airline
+ticket fares:
+
+> “Got it!,” I said. “We will keep track of index pairs in a priority queue,
+> with the sum of the fare costs as the key for the pair. Initially we put only
+> pair (1, 1) on the queue. If it proves it is not feasible, we put its two
+> successors on—namely (1, 2) and (2, 1). In general, we enqueue pairs
+> (i + 1, j) and (i, j + 1) after evaluating/rejecting pair (i, j). We will get
+> through all the pairs in the right order if we do so.”
+>
+> The gang caught on quickly. “Sure. But what about duplicates? We will
+> construct pair (x, y) two different ways, both when expanding (x − 1, y) and
+> (x, y −1).”
+>
+> “You are right. We need an extra data structure to guard against duplicates.
+> The simplest might be a hash table to tell us whether a given pair exists in
+> the priority queue before we insert a duplicate. In fact, we will never have
+> more than n active pairs in our data structure, since there can only be one
+> pair for each distinct value of the first coordinate.”
+
+This is similar to the `applyMerge` algorithm, except that `applyMerge` has an
+optimization to check that we don’t add (x, y) to the priority queue when there
+is already an (x′, y) with x < x′ or (x, y′) with y < y′ in the queue.
+
+[^1]: Note that this is really the Sieve of Erastosthenes, as defined in the classic [The Genuine Sieve of Eratosthenes](https://www.cs.hmc.edu/~oneill/papers/Sieve-JFP.pdf). Constrast this to other simple prime generation implementations, such as primes = sieve [2..] where sieve (p : xs) = p : sieve [x | x <- xs, x \`rem\` p > 0]
which is actually trial division and not a faithful implementation of the Sieve of Erastosthenes.
diff --git a/src/Data/DoublyLinkedList/STRef.hs b/src/Data/DoublyLinkedList/STRef.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/DoublyLinkedList/STRef.hs
@@ -0,0 +1,253 @@
+-- SPDX-FileCopyrightText: Copyright Preetham Gujjula
+-- SPDX-License-Identifier: BSD-3-Clause
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Data.DoublyLinkedList.STRef
+ ( -- * Types
+ DoublyLinkedList,
+ DoublyLinkedNode,
+
+ -- * Construction
+ empty,
+ fromList,
+
+ -- * Traversal
+ head,
+ last,
+ next,
+ prev,
+
+ -- * Query
+ null,
+ value,
+
+ -- * Insertion
+ cons,
+ snoc,
+ insertBefore,
+ insertAfter,
+
+ -- * Deletion
+ delete,
+
+ -- * List conversion
+ toList,
+ )
+where
+
+import Control.Arrow ((>>>))
+import Control.Monad (forM_)
+import Control.Monad.ST (ST)
+import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef)
+import Prelude hiding (head, last, null)
+
+data DoublyLinkedList s a = DoublyLinkedList
+ { firstNode :: FirstNode s a,
+ lastNode :: LastNode s a
+ }
+
+-- | The sentinel node at the beginning of the list.
+newtype FirstNode s a = FirstNode {nextRef :: STRef s (NextNode s a)}
+
+data DoublyLinkedNode s a = DoublyLinkedNode
+ { _value :: a,
+ nextRef :: STRef s (NextNode s a),
+ prevRef :: STRef s (PrevNode s a)
+ }
+
+-- | The sentinel node at the end of the list.
+newtype LastNode s a = LastNode
+ { prevRef :: STRef s (PrevNode s a)
+ }
+
+-- | Type for nodes that are after other nodes.
+newtype NextNode s a = NextNode
+ { unNextNode :: Either (DoublyLinkedNode s a) (LastNode s a)
+ }
+
+nextNodeToDoublyLinkedNode :: NextNode s a -> Maybe (DoublyLinkedNode s a)
+nextNodeToDoublyLinkedNode (NextNode (Left v)) = Just v
+nextNodeToDoublyLinkedNode _ = Nothing
+
+-- | Type for nodes that are before other nodes.
+newtype PrevNode s a = PrevNode
+ { unPrevNode :: Either (FirstNode s a) (DoublyLinkedNode s a)
+ }
+
+class HasNext node where
+ next1 :: node s a -> ST s (NextNode s a)
+ next1 = let x = x in x
+
+ setNext1 :: (HasPrev next_node) => node s a -> next_node s a -> ST s ()
+ setNext1 = let x = x in x
+
+ toPrev1 :: node s a -> PrevNode s a
+ toPrev1 = let x = x in x
+
+ -- Abuse the MINIMAL pragma to not include hidden functions in Haddocks
+ {-# MINIMAL #-}
+
+instance HasNext FirstNode where
+ next1 (FirstNode nextRef) = readSTRef nextRef
+ {-# INLINE next1 #-}
+ setNext1 (FirstNode nextRef) nextNode = writeSTRef nextRef (toNext1 nextNode)
+ {-# INLINE setNext1 #-}
+ toPrev1 = PrevNode . Left
+ {-# INLINE toPrev1 #-}
+
+instance HasNext DoublyLinkedNode where
+ next1 valueNode = readSTRef valueNode.nextRef
+ {-# INLINE next1 #-}
+ setNext1 valueNode nextNode = writeSTRef valueNode.nextRef (toNext1 nextNode)
+ {-# INLINE setNext1 #-}
+ toPrev1 = PrevNode . Right
+ {-# INLINE toPrev1 #-}
+
+instance HasNext PrevNode where
+ next1 = either next1 next1 . unPrevNode
+ {-# INLINE next1 #-}
+ setNext1 prevNode nextNode =
+ either (`setNext1` nextNode) (`setNext1` nextNode) (unPrevNode prevNode)
+ {-# INLINE setNext1 #-}
+ toPrev1 = id
+ {-# INLINE toPrev1 #-}
+
+class HasPrev node where
+ prev1 :: node s a -> ST s (PrevNode s a)
+ prev1 = let x = x in x
+
+ setPrev1 :: (HasNext prev_node) => node s a -> prev_node s a -> ST s ()
+ setPrev1 = let x = x in x
+
+ toNext1 :: node s a -> NextNode s a
+ toNext1 = let x = x in x
+
+ -- Abuse the MINIMAL pragma to not include hidden functions in Haddocks
+ {-# MINIMAL #-}
+
+instance HasPrev DoublyLinkedNode where
+ prev1 valueNode = readSTRef valueNode.prevRef
+ {-# INLINE prev1 #-}
+ setPrev1 valueNode prevNode = writeSTRef valueNode.prevRef (toPrev1 prevNode)
+ {-# INLINE setPrev1 #-}
+ toNext1 = NextNode . Left
+ {-# INLINE toNext1 #-}
+
+instance HasPrev LastNode where
+ prev1 (LastNode prevRef) = readSTRef prevRef
+ {-# INLINE prev1 #-}
+ setPrev1 (LastNode prevRef) prevNode = writeSTRef prevRef (toPrev1 prevNode)
+ {-# INLINE setPrev1 #-}
+ toNext1 = NextNode . Right
+ {-# INLINE toNext1 #-}
+
+instance HasPrev NextNode where
+ prev1 = either prev1 prev1 . unNextNode
+ {-# INLINE prev1 #-}
+ setPrev1 nextNode prevNode =
+ either (`setPrev1` prevNode) (`setPrev1` prevNode) (unNextNode nextNode)
+ {-# INLINE setPrev1 #-}
+ toNext1 = id
+ {-# INLINE toNext1 #-}
+
+null :: DoublyLinkedList s a -> ST s Bool
+null list = do
+ nextNode <- readSTRef list.firstNode.nextRef
+ case nextNode of
+ NextNode (Left _) -> pure False
+ _ -> pure True
+{-# INLINE null #-}
+
+value :: DoublyLinkedNode s a -> a
+value = _value
+{-# INLINE value #-}
+
+head :: DoublyLinkedList s a -> ST s (Maybe (DoublyLinkedNode s a))
+head list =
+ readSTRef list.firstNode.nextRef >>= \case
+ NextNode (Left doublyLinkedNode) -> pure (Just doublyLinkedNode)
+ _ -> pure Nothing
+
+last :: DoublyLinkedList s a -> ST s (Maybe (DoublyLinkedNode s a))
+last list =
+ readSTRef list.lastNode.prevRef >>= \case
+ PrevNode (Right doublyLinkedNode) -> pure (Just doublyLinkedNode)
+ _ -> pure Nothing
+
+next :: DoublyLinkedNode s a -> ST s (Maybe (DoublyLinkedNode s a))
+next valueNode = do
+ nextNode <- readSTRef valueNode.nextRef
+ pure $ case nextNode of
+ NextNode (Left valueNode') -> Just valueNode'
+ _ -> Nothing
+
+prev :: DoublyLinkedNode s a -> ST s (Maybe (DoublyLinkedNode s a))
+prev valueNode = do
+ prevNode <- readSTRef valueNode.prevRef
+ pure $ case prevNode of
+ PrevNode (Right valueNode') -> Just valueNode'
+ _ -> Nothing
+
+empty :: ST s (DoublyLinkedList s a)
+empty = do
+ firstNode <- FirstNode <$> newSTRef undefined
+ lastNode <- LastNode <$> newSTRef undefined
+ writeSTRef firstNode.nextRef (NextNode (Right lastNode))
+ writeSTRef lastNode.prevRef (PrevNode (Left firstNode))
+ pure (DoublyLinkedList firstNode lastNode)
+
+insertAfter1 :: (HasNext node) => node s a -> a -> ST s (DoublyLinkedNode s a)
+insertAfter1 nodeA x = do
+ nodeC <- next1 nodeA
+ nodeB <- DoublyLinkedNode x <$> newSTRef nodeC <*> newSTRef (toPrev1 nodeA)
+ setNext1 nodeA nodeB
+ setPrev1 nodeC nodeB
+ pure nodeB
+
+insertBefore1 :: (HasPrev node) => node s a -> a -> ST s (DoublyLinkedNode s a)
+insertBefore1 nodeC x = do
+ nodeA <- prev1 nodeC
+ nodeB <- DoublyLinkedNode x <$> newSTRef (toNext1 nodeC) <*> newSTRef nodeA
+ setNext1 nodeA nodeB
+ setPrev1 nodeC nodeB
+ pure nodeB
+
+insertBefore :: DoublyLinkedNode s a -> a -> ST s (DoublyLinkedNode s a)
+insertBefore = insertBefore1
+
+insertAfter :: DoublyLinkedNode s a -> a -> ST s (DoublyLinkedNode s a)
+insertAfter = insertAfter1
+
+cons :: DoublyLinkedList s a -> a -> ST s (DoublyLinkedNode s a)
+cons list = insertAfter1 list.firstNode
+{-# INLINE cons #-}
+
+snoc :: DoublyLinkedList s a -> a -> ST s (DoublyLinkedNode s a)
+snoc list = insertBefore1 list.lastNode
+{-# INLINE snoc #-}
+
+delete :: DoublyLinkedNode s a -> ST s ()
+delete nodeB = do
+ nodeA <- prev1 nodeB
+ nodeC <- next1 nodeB
+ setNext1 nodeA nodeC
+ setPrev1 nodeC nodeA
+
+fromList :: [a] -> ST s (DoublyLinkedList s a)
+fromList xs = do
+ list <- empty
+ forM_ xs $ \x ->
+ snoc list x
+ pure list
+
+toList :: DoublyLinkedList s a -> ST s [a]
+toList list = next1 list.firstNode >>= go
+ where
+ go :: NextNode s a -> ST s [a]
+ go =
+ nextNodeToDoublyLinkedNode >>> \case
+ Nothing -> pure []
+ Just valueNode -> (valueNode._value :) <$> (next1 valueNode >>= go)
diff --git a/src/Data/List/ApplyMerge.hs b/src/Data/List/ApplyMerge.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/List/ApplyMerge.hs
@@ -0,0 +1,31 @@
+-- SPDX-FileCopyrightText: Copyright Preetham Gujjula
+-- SPDX-License-Identifier: BSD-3-Clause
+
+-- |
+-- Module: Data.List.ApplyMerge
+-- License: BSD-3-Clause
+-- Maintainer: Preetham Gujjula
+-- Stability: experimental
+module Data.List.ApplyMerge (applyMerge) where
+
+import Data.List.ApplyMerge.IntSet qualified
+
+-- | If given a binary function @f@ that is non-decreasing in both arguments,
+-- and two (potentially infinite) ordered lists @xs@ and @ys@, then
+-- @'applyMerge' f xs ys@ is a sorted list of all @f x y@, for each @x@ in
+-- @xs@ and @y@ in @ys@.
+--
+-- Producing \(n\) elements of @'applyMerge' f xs ys@ takes \(O(n \log n)\)
+-- time and \(O(\sqrt{n})\) auxiliary space, assuming that @f@ and @compare@
+-- take \(O(1)\) time.
+--
+-- For example, to generate the 3-smooth numbers
+-- ([Wikipedia](https://en.wikipedia.org/wiki/Smooth_number)):
+--
+-- > smooth3 :: [Integer]
+-- > smooth3 = applyMerge (*) (iterate (*2) 1) (iterate (*3) 1)
+--
+-- For more examples, see
+-- [README#examples](https://github.com/pgujjula/apply-merge/#examples).
+applyMerge :: (Ord c) => (a -> b -> c) -> [a] -> [b] -> [c]
+applyMerge = Data.List.ApplyMerge.IntSet.applyMerge
diff --git a/src/Data/List/ApplyMerge/DoublyLinkedList.hs b/src/Data/List/ApplyMerge/DoublyLinkedList.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/List/ApplyMerge/DoublyLinkedList.hs
@@ -0,0 +1,149 @@
+-- SPDX-FileCopyrightText: Copyright Preetham Gujjula
+-- SPDX-License-Identifier: BSD-3-Clause
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE NoFieldSelectors #-}
+
+module Data.List.ApplyMerge.DoublyLinkedList (applyMerge) where
+
+import Control.Monad (guard)
+import Control.Monad.ST qualified as Strict
+import Control.Monad.ST.Lazy qualified as Lazy
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
+import Data.DoublyLinkedList.STRef qualified as DoublyLinked
+import Data.List.NonEmpty (NonEmpty, nonEmpty)
+import Data.List.NonEmpty qualified as NonEmpty
+import Data.Maybe (fromMaybe)
+import Data.PQueue.Prio.Min (MinPQueue)
+import Data.PQueue.Prio.Min qualified as MinPQueue
+
+data Node s a b c = Node
+ { position :: DoublyLinked.DoublyLinkedNode s (Int, Int),
+ value :: c,
+ as :: NonEmpty a,
+ bs :: NonEmpty b
+ }
+
+newtype Frontier s a b c = Frontier
+ { queue :: MinPQueue c (Node s a b c)
+ }
+
+applyMerge :: (Ord c) => (a -> b -> c) -> [a] -> [b] -> [c]
+applyMerge f as bs =
+ fromMaybe [] $
+ applyMergeNonEmpty f <$> nonEmpty as <*> nonEmpty bs
+
+applyMergeNonEmpty ::
+ (Ord c) => (a -> b -> c) -> NonEmpty a -> NonEmpty b -> [c]
+applyMergeNonEmpty f as bs = Lazy.runST $ do
+ frontier <- Lazy.strictToLazyST (initialFrontier f as bs)
+ unfoldrM (Lazy.strictToLazyST . step f) frontier
+
+unfoldrM :: (Monad m) => (b -> m (Maybe (a, b))) -> b -> m [a]
+unfoldrM f seed = do
+ result <- f seed
+ case result of
+ Nothing -> pure []
+ Just (x, newSeed) -> (x :) <$> unfoldrM f newSeed
+
+initialFrontier ::
+ (a -> b -> c) -> NonEmpty a -> NonEmpty b -> Strict.ST s (Frontier s a b c)
+initialFrontier f as bs = do
+ list <- DoublyLinked.empty
+ position <- DoublyLinked.cons list (0 :: Int, 0 :: Int)
+ let c = f (NonEmpty.head as) (NonEmpty.head bs)
+ node =
+ Node
+ { position = position,
+ value = c,
+ as = as,
+ bs = bs
+ }
+ pure $ Frontier $ MinPQueue.singleton c node
+
+step ::
+ (Ord c) =>
+ (a -> b -> c) ->
+ Frontier s a b c ->
+ Strict.ST s (Maybe (c, Frontier s a b c))
+step f frontier = runMaybeT $ do
+ (node, frontier') <- MaybeT (deleteMinNode frontier)
+ frontier'' <- lift $ insertChildA f node frontier'
+ frontier''' <- lift $ insertChildB f node frontier''
+ lift (DoublyLinked.delete node.position)
+ pure (node.value, frontier''')
+
+deleteMinNode ::
+ (Ord c) => Frontier s a b c -> Strict.ST s (Maybe (Node s a b c, Frontier s a b c))
+deleteMinNode frontier = runMaybeT $ do
+ (node, queue') <- hoistMaybe (MinPQueue.minView frontier.queue)
+ let frontier' = Frontier queue'
+ pure (node, frontier')
+
+nextNodeValue :: DoublyLinked.DoublyLinkedNode s a -> Strict.ST s (Maybe a)
+nextNodeValue valueNode = runMaybeT $ do
+ valueNode' <- MaybeT $ DoublyLinked.next valueNode
+ pure (DoublyLinked.value valueNode')
+
+prevNodeValue :: DoublyLinked.DoublyLinkedNode s a -> Strict.ST s (Maybe a)
+prevNodeValue valueNode = runMaybeT $ do
+ valueNode' <- MaybeT $ DoublyLinked.prev valueNode
+ pure (DoublyLinked.value valueNode')
+
+insertChildA ::
+ (Ord c) =>
+ (a -> b -> c) ->
+ Node s a b c ->
+ Frontier s a b c ->
+ Strict.ST s (Frontier s a b c)
+insertChildA f node frontier = fmap (fromMaybe frontier) $ runMaybeT $ do
+ let (ia, ib) = DoublyLinked.value node.position
+ nextPosition <- lift $ nextNodeValue node.position
+ guard (fmap fst nextPosition /= Just (ia + 1))
+ as' <- hoistMaybe (nonEmpty (NonEmpty.tail node.as))
+ let bs' = node.bs
+ position' <- lift (DoublyLinked.insertAfter node.position (ia + 1, ib))
+ let value' = f (NonEmpty.head as') (NonEmpty.head bs')
+ let node' =
+ Node
+ { position = position',
+ value = value',
+ as = as',
+ bs = bs'
+ }
+ pure $ Frontier $ MinPQueue.insert value' node' frontier.queue
+
+insertChildB ::
+ (Ord c) =>
+ (a -> b -> c) ->
+ Node s a b c ->
+ Frontier s a b c ->
+ Strict.ST s (Frontier s a b c)
+insertChildB f node frontier = fmap (fromMaybe frontier) $ runMaybeT $ do
+ let (ia, ib) = DoublyLinked.value node.position
+ prevPosition <- lift $ prevNodeValue node.position
+ guard (fmap snd prevPosition /= Just (ib + 1))
+ bs' <- hoistMaybe (nonEmpty (NonEmpty.tail node.bs))
+ let as' = node.as
+ position' <- lift (DoublyLinked.insertBefore node.position (ia, ib + 1))
+ let value' = f (NonEmpty.head as') (NonEmpty.head bs')
+ let node' = mkNode f position' as' bs'
+ pure $ Frontier $ MinPQueue.insert value' node' frontier.queue
+
+mkNode ::
+ (a -> b -> c) ->
+ DoublyLinked.DoublyLinkedNode s (Int, Int) ->
+ NonEmpty a ->
+ NonEmpty b ->
+ Node s a b c
+mkNode f position as bs =
+ Node
+ { position = position,
+ value = f (NonEmpty.head as) (NonEmpty.head bs),
+ as = as,
+ bs = bs
+ }
+
+-- Remove this once we allow transformers-0.6
+hoistMaybe :: (Applicative m) => Maybe b -> MaybeT m b
+hoistMaybe = MaybeT . pure
diff --git a/src/Data/List/ApplyMerge/IntMap.hs b/src/Data/List/ApplyMerge/IntMap.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/List/ApplyMerge/IntMap.hs
@@ -0,0 +1,98 @@
+-- SPDX-FileCopyrightText: Copyright Preetham Gujjula
+-- SPDX-License-Identifier: BSD-3-Clause
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE NoFieldSelectors #-}
+
+module Data.List.ApplyMerge.IntMap (applyMerge) where
+
+import Control.Monad (guard)
+import Data.Function ((&))
+import Data.IntMap.Strict (IntMap)
+import Data.IntMap.Strict qualified as IntMap
+import Data.List (unfoldr)
+import Data.List.NonEmpty (NonEmpty, nonEmpty)
+import Data.List.NonEmpty qualified as NonEmpty
+import Data.Maybe (fromMaybe)
+import Data.PQueue.Prio.Min (MinPQueue)
+import Data.PQueue.Prio.Min qualified as MinPQueue
+
+data Node a b c = Node
+ { position :: (Int, Int),
+ value :: c,
+ as :: NonEmpty a,
+ bs :: NonEmpty b
+ }
+
+data Frontier a b c = Frontier
+ { queue :: MinPQueue c (Node a b c),
+ indexMap :: IntMap Int
+ }
+
+applyMerge :: (Ord c) => (a -> b -> c) -> [a] -> [b] -> [c]
+applyMerge f as bs = fromMaybe [] $ do
+ as' <- nonEmpty as
+ bs' <- nonEmpty bs
+ pure (unfoldr (step f) (initialFrontier f as' bs'))
+
+initialFrontier :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> Frontier a b c
+initialFrontier f as bs =
+ let node = mkNode f (0, 0) as bs
+ in Frontier
+ { queue = MinPQueue.singleton node.value node,
+ indexMap = IntMap.singleton 0 0
+ }
+
+step :: (Ord c) => (a -> b -> c) -> Frontier a b c -> Maybe (c, Frontier a b c)
+step f frontier = do
+ (node, frontier') <- deleteMinNode frontier
+ let frontier'' =
+ frontier'
+ & insertChildA f node
+ & insertChildB f node
+ pure (node.value, frontier'')
+
+deleteMinNode :: (Ord c) => Frontier a b c -> Maybe (Node a b c, Frontier a b c)
+deleteMinNode frontier = do
+ (node, queue') <- MinPQueue.minView frontier.queue
+ let (ia, _) = node.position
+ frontier' =
+ Frontier
+ { queue = queue',
+ indexMap = IntMap.delete ia frontier.indexMap
+ }
+ pure (node, frontier')
+
+insertChildA ::
+ (Ord c) => (a -> b -> c) -> Node a b c -> Frontier a b c -> Frontier a b c
+insertChildA f (Node (ia, ib) _ as bs) frontier = fromMaybe frontier $ do
+ let iaNext = fmap fst . IntMap.lookupGT ia $ frontier.indexMap
+ guard $ iaNext /= Just (ia + 1)
+ as' <- nonEmpty (NonEmpty.tail as)
+ let childA = mkNode f (ia + 1, ib) as' bs
+ pure $ insertNode childA frontier
+
+insertChildB ::
+ (Ord c) => (a -> b -> c) -> Node a b c -> Frontier a b c -> Frontier a b c
+insertChildB f (Node (ia, ib) _ as bs) frontier = fromMaybe frontier $ do
+ let ibNext = fmap snd . IntMap.lookupLT ia $ frontier.indexMap
+ guard $ ibNext /= Just (ib + 1)
+ bs' <- nonEmpty (NonEmpty.tail bs)
+ let childB = mkNode f (ia, ib + 1) as bs'
+ pure $ insertNode childB frontier
+
+insertNode :: (Ord c) => Node a b c -> Frontier a b c -> Frontier a b c
+insertNode node frontier =
+ let (ia, ib) = node.position
+ in Frontier
+ { queue = MinPQueue.insert node.value node frontier.queue,
+ indexMap = IntMap.insert ia ib frontier.indexMap
+ }
+
+mkNode :: (a -> b -> c) -> (Int, Int) -> NonEmpty a -> NonEmpty b -> Node a b c
+mkNode f (ia, ib) as bs =
+ Node
+ { position = (ia, ib),
+ value = f (NonEmpty.head as) (NonEmpty.head bs),
+ as = as,
+ bs = bs
+ }
diff --git a/src/Data/List/ApplyMerge/IntSet.hs b/src/Data/List/ApplyMerge/IntSet.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/List/ApplyMerge/IntSet.hs
@@ -0,0 +1,100 @@
+-- SPDX-FileCopyrightText: Copyright Preetham Gujjula
+-- SPDX-License-Identifier: BSD-3-Clause
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE NoFieldSelectors #-}
+
+module Data.List.ApplyMerge.IntSet (applyMerge) where
+
+import Control.Monad (guard)
+import Data.Function ((&))
+import Data.IntSet (IntSet)
+import Data.IntSet qualified as IntSet
+import Data.List (unfoldr)
+import Data.List.NonEmpty (NonEmpty, nonEmpty)
+import Data.List.NonEmpty qualified as NonEmpty
+import Data.Maybe (fromMaybe)
+import Data.PQueue.Prio.Min (MinPQueue)
+import Data.PQueue.Prio.Min qualified as MinPQueue
+
+data Node a b c = Node
+ { position :: (Int, Int),
+ value :: c,
+ as :: NonEmpty a,
+ bs :: NonEmpty b
+ }
+
+data Frontier a b c = Frontier
+ { queue :: MinPQueue c (Node a b c),
+ indexSetA :: IntSet,
+ indexSetB :: IntSet
+ }
+
+applyMerge :: (Ord c) => (a -> b -> c) -> [a] -> [b] -> [c]
+applyMerge f as bs = fromMaybe [] $ do
+ as' <- nonEmpty as
+ bs' <- nonEmpty bs
+ pure (unfoldr (step f) (initialFrontier f as' bs'))
+
+initialFrontier :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> Frontier a b c
+initialFrontier f as bs =
+ let node = mkNode f (0, 0) as bs
+ in Frontier
+ { queue = MinPQueue.singleton node.value node,
+ indexSetA = IntSet.singleton 0,
+ indexSetB = IntSet.singleton 0
+ }
+
+step :: (Ord c) => (a -> b -> c) -> Frontier a b c -> Maybe (c, Frontier a b c)
+step f frontier = do
+ (node, frontier') <- deleteMinNode frontier
+ let frontier'' =
+ frontier'
+ & insertChildA f node
+ & insertChildB f node
+ pure (node.value, frontier'')
+
+deleteMinNode :: (Ord c) => Frontier a b c -> Maybe (Node a b c, Frontier a b c)
+deleteMinNode frontier = do
+ (node, queue') <- MinPQueue.minView frontier.queue
+ let (ia, ib) = node.position
+ frontier' =
+ Frontier
+ { queue = queue',
+ indexSetA = IntSet.delete ia frontier.indexSetA,
+ indexSetB = IntSet.delete ib frontier.indexSetB
+ }
+ pure (node, frontier')
+
+insertChildA ::
+ (Ord c) => (a -> b -> c) -> Node a b c -> Frontier a b c -> Frontier a b c
+insertChildA f (Node (ia, ib) _ as bs) frontier = fromMaybe frontier $ do
+ guard (not (IntSet.member (ia + 1) frontier.indexSetA))
+ as' <- nonEmpty (NonEmpty.tail as)
+ let childA = mkNode f (ia + 1, ib) as' bs
+ pure $ insertNode childA frontier
+
+insertChildB ::
+ (Ord c) => (a -> b -> c) -> Node a b c -> Frontier a b c -> Frontier a b c
+insertChildB f (Node (ia, ib) _ as bs) frontier = fromMaybe frontier $ do
+ guard (not (IntSet.member (ib + 1) frontier.indexSetB))
+ bs' <- nonEmpty (NonEmpty.tail bs)
+ let childB = mkNode f (ia, ib + 1) as bs'
+ pure $ insertNode childB frontier
+
+insertNode :: (Ord c) => Node a b c -> Frontier a b c -> Frontier a b c
+insertNode node frontier =
+ let (ia, ib) = node.position
+ in Frontier
+ { queue = MinPQueue.insert node.value node frontier.queue,
+ indexSetA = IntSet.insert ia frontier.indexSetA,
+ indexSetB = IntSet.insert ib frontier.indexSetB
+ }
+
+mkNode :: (a -> b -> c) -> (Int, Int) -> NonEmpty a -> NonEmpty b -> Node a b c
+mkNode f (ia, ib) as bs =
+ Node
+ { position = (ia, ib),
+ value = f (NonEmpty.head as) (NonEmpty.head bs),
+ as = as,
+ bs = bs
+ }
diff --git a/src/Data/PQueue/Prio/Min/Mutable.hs b/src/Data/PQueue/Prio/Min/Mutable.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/PQueue/Prio/Min/Mutable.hs
@@ -0,0 +1,140 @@
+-- SPDX-FileCopyrightText: Copyright Preetham Gujjula
+-- SPDX-License-Identifier: BSD-3-Clause
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE NoFieldSelectors #-}
+
+module Data.PQueue.Prio.Min.Mutable
+ ( -- * Documentation
+ MMinPQueue,
+
+ -- * Construction
+ empty,
+ singleton,
+ insert,
+
+ -- * Query
+ deleteMin,
+
+ -- * List conversion
+ fromAscList,
+ )
+where
+
+import Control.Monad (when)
+import Control.Monad.ST (ST)
+import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef)
+import Data.Vector qualified as Vector
+import Data.Vector.Mutable (MVector)
+import Data.Vector.Mutable qualified as MVector
+
+data MMinPQueue s k a
+ = MMinPQueue
+ { vectorRef :: STRef s (MVector s (k, a)),
+ sizeRef :: STRef s Int
+ }
+
+empty :: ST s (MMinPQueue s k a)
+empty = do
+ vec <- MVector.unsafeNew 1
+ vecRef <- newSTRef vec
+ sizeRef <- newSTRef 0
+ pure $
+ MMinPQueue
+ { vectorRef = vecRef,
+ sizeRef = sizeRef
+ }
+
+singleton :: k -> a -> ST s (MMinPQueue s k a)
+singleton k v = do
+ vec <- MVector.replicate 1 (k, v)
+ vecRef <- newSTRef vec
+ sizeRef <- newSTRef 1
+ pure $
+ MMinPQueue
+ { vectorRef = vecRef,
+ sizeRef = sizeRef
+ }
+
+resizeIfNeeded :: MMinPQueue s k a -> ST s ()
+resizeIfNeeded pqueue = do
+ vec <- readSTRef pqueue.vectorRef
+ size <- readSTRef pqueue.sizeRef
+ when (MVector.length vec == size) $ do
+ vec' <- MVector.unsafeGrow vec size
+ writeSTRef pqueue.vectorRef vec'
+
+insert :: (Ord k) => k -> a -> MMinPQueue s k a -> ST s ()
+insert k v pqueue = do
+ resizeIfNeeded pqueue
+
+ n <- readSTRef pqueue.sizeRef
+ vec <- readSTRef pqueue.vectorRef
+ MVector.unsafeWrite vec n (k, v)
+ writeSTRef pqueue.sizeRef (n + 1)
+
+ bubbleUp vec n
+
+bubbleUp :: (Ord k) => MVector s (k, a) -> Int -> ST s ()
+bubbleUp vector = go
+ where
+ go i =
+ if i == 0
+ then pure ()
+ else do
+ let parentIndex = (i - 1) `quot` 2
+ parentVal <- MVector.unsafeRead vector parentIndex
+ currentVal <- MVector.unsafeRead vector i
+ when (fst parentVal > fst currentVal) $ do
+ MVector.unsafeSwap vector parentIndex i
+ go parentIndex
+
+deleteMin :: (Ord k) => MMinPQueue s k a -> ST s (Maybe (k, a))
+deleteMin pqueue = do
+ n <- readSTRef pqueue.sizeRef
+ if n == 0
+ then pure Nothing
+ else do
+ vector <- readSTRef pqueue.vectorRef
+ minNode <- MVector.unsafeRead vector 0
+ MVector.unsafeSwap vector 0 (n - 1)
+ writeSTRef pqueue.sizeRef (n - 1)
+ bubbleDown vector 0 (n - 1)
+ pure (Just minNode)
+
+bubbleDown :: (Ord k) => MVector s (k, a) -> Int -> Int -> ST s ()
+bubbleDown vector i n = go i
+ where
+ go j = do
+ case compare n (2 * j + 2) of
+ LT -> pure ()
+ EQ -> do
+ x <- MVector.unsafeRead vector j
+ x' <- MVector.unsafeRead vector (2 * j + 1)
+ let j' = 2 * j + 1
+ when (fst x > fst x') $ do
+ MVector.unsafeWrite vector j' x
+ MVector.unsafeWrite vector j x'
+ go j'
+ GT -> do
+ x <- MVector.unsafeRead vector j
+ xleft <- MVector.unsafeRead vector (2 * j + 1)
+ xright <- MVector.unsafeRead vector (2 * j + 2)
+ let (x', j') =
+ if fst xleft <= fst xright
+ then (xleft, 2 * j + 1)
+ else (xright, 2 * j + 2)
+ when (fst x > fst x') $ do
+ MVector.unsafeWrite vector j' x
+ MVector.unsafeWrite vector j x'
+ go j'
+
+fromAscList :: forall s k a. [(k, a)] -> ST s (MMinPQueue s k a)
+fromAscList xs = do
+ vector <- Vector.thaw (Vector.fromList xs)
+ vectorRef <- newSTRef vector
+ sizeRef <- newSTRef (length xs)
+ pure $
+ MMinPQueue
+ { vectorRef = vectorRef,
+ sizeRef = sizeRef
+ }
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/Main.hs
@@ -0,0 +1,25 @@
+-- SPDX-FileCopyrightText: Copyright Preetham Gujjula
+-- SPDX-License-Identifier: BSD-3-Clause
+
+module Main (main) where
+
+import Test.Data.DoublyLinkedList.STRef qualified (tests)
+import Test.Data.List.ApplyMerge.DoublyLinkedList qualified (tests)
+import Test.Data.List.ApplyMerge.IntMap qualified (tests)
+import Test.Data.List.ApplyMerge.IntSet qualified (tests)
+import Test.Data.PQueue.Prio.Min.Mutable qualified (tests)
+import Test.Tasty (TestTree, defaultMain, testGroup)
+
+main :: IO ()
+main = defaultMain tests
+
+tests :: TestTree
+tests =
+ testGroup
+ ""
+ [ Test.Data.DoublyLinkedList.STRef.tests,
+ Test.Data.List.ApplyMerge.DoublyLinkedList.tests,
+ Test.Data.List.ApplyMerge.IntMap.tests,
+ Test.Data.List.ApplyMerge.IntSet.tests,
+ Test.Data.PQueue.Prio.Min.Mutable.tests
+ ]
diff --git a/test/Test/Data/DoublyLinkedList/STRef.hs b/test/Test/Data/DoublyLinkedList/STRef.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Data/DoublyLinkedList/STRef.hs
@@ -0,0 +1,331 @@
+-- SPDX-FileCopyrightText: Copyright Preetham Gujjula
+-- SPDX-License-Identifier: BSD-3-Clause
+
+module Test.Data.DoublyLinkedList.STRef (tests) where
+
+import Control.Monad (void)
+import Control.Monad.ST (runST)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
+import Data.DoublyLinkedList.STRef
+ ( cons,
+ delete,
+ empty,
+ fromList,
+ head,
+ last,
+ next,
+ null,
+ toList,
+ value,
+ )
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.ExpectedFailure (ignoreTest)
+import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=))
+import Prelude hiding (head, last, null)
+
+tests :: TestTree
+tests =
+ testGroup
+ "Data.DoublyLinkedList.STRef"
+ [ constructionTests,
+ traversalTests,
+ queryTests,
+ insertionTests,
+ deletionTests,
+ listConversionTests,
+ integrationTests
+ ]
+
+unimplemented :: Assertion
+unimplemented = assertFailure "unimplemented"
+
+-- Construction
+constructionTests :: TestTree
+constructionTests =
+ testGroup
+ "Construction"
+ [ emptyTests,
+ fromListTests
+ ]
+
+emptyTests :: TestTree
+emptyTests = testCase "empty" (pure ())
+
+fromListTests :: TestTree
+fromListTests = testCase "fromList" (pure ())
+
+-- Traversal
+traversalTests :: TestTree
+traversalTests =
+ testGroup "Traversal" [headTests, lastTests, nextTests, prevTests]
+
+headTests :: TestTree
+headTests =
+ testGroup
+ "head"
+ [ testCase "head of empty list" $ do
+ -- Construct empty list using empty
+ let firstNodeValue1 :: Maybe Int
+ firstNodeValue1 = runST $ do
+ list <- empty
+ firstNode <- head list
+ pure (value <$> firstNode)
+ firstNodeValue1 @?= Nothing
+
+ -- Construct empty list using fromList
+ let firstNodeValue2 :: Maybe Int
+ firstNodeValue2 = runST $ do
+ list <- fromList []
+ firstNode <- head list
+ pure (value <$> firstNode)
+ firstNodeValue2 @?= Nothing,
+ testCase "head of non-empty lists" $ do
+ let firstNodeValue1 :: Maybe Int
+ firstNodeValue1 = runST $ do
+ list <- fromList [1]
+ firstNode <- head list
+ pure (value <$> firstNode)
+ firstNodeValue1 @?= Just 1
+ let firstNodeValue2 :: Maybe Int
+ firstNodeValue2 = runST $ do
+ list <- fromList [2, 1]
+ firstNode <- head list
+ pure (value <$> firstNode)
+ firstNodeValue2 @?= Just 2
+ let firstNodeValue3 :: Maybe Int
+ firstNodeValue3 = runST $ do
+ list <- fromList [3, 2, 1]
+ firstNode <- head list
+ pure (value <$> firstNode)
+ firstNodeValue3 @?= Just 3
+ ]
+
+lastTests :: TestTree
+lastTests =
+ testGroup
+ "last"
+ [ testCase "last of empty list" $ do
+ -- Construct empty list using empty
+ let lastNodeValue1 :: Maybe Int
+ lastNodeValue1 = runST $ do
+ list <- empty
+ lastNode <- last list
+ pure (value <$> lastNode)
+ lastNodeValue1 @?= Nothing
+
+ -- Construct empty list using fromList
+ let lastNodeValue2 :: Maybe Int
+ lastNodeValue2 = runST $ do
+ list <- fromList []
+ lastNode <- last list
+ pure (value <$> lastNode)
+ lastNodeValue2 @?= Nothing,
+ testCase "last of non-empty lists" $ do
+ let lastNodeValue1 :: Maybe Int
+ lastNodeValue1 = runST $ do
+ list <- fromList [1]
+ lastNode <- last list
+ pure (value <$> lastNode)
+ lastNodeValue1 @?= Just 1
+ let lastNodeValue2 :: Maybe Int
+ lastNodeValue2 = runST $ do
+ list <- fromList [1, 2]
+ lastNode <- last list
+ pure (value <$> lastNode)
+ lastNodeValue2 @?= Just 2
+ let lastNodeValue3 :: Maybe Int
+ lastNodeValue3 = runST $ do
+ list <- fromList [1, 2, 3]
+ lastNode <- last list
+ pure (value <$> lastNode)
+ lastNodeValue3 @?= Just 3
+ ]
+
+nextTests :: TestTree
+nextTests =
+ ignoreTest $
+ testGroup
+ "next"
+ [ testCase "next on empty list" unimplemented,
+ testCase "next on [1]" unimplemented,
+ testCase "next on [3, 2, 1]" unimplemented,
+ testCase "next on [1, 1, 1, 1, 1]" unimplemented
+ ]
+
+prevTests :: TestTree
+prevTests =
+ ignoreTest $
+ testGroup
+ "prev"
+ [ testCase "prev on empty list" unimplemented,
+ testCase "prev on [1]" unimplemented,
+ testCase "prev on [3, 2, 1]" unimplemented,
+ testCase "prev on [1, 1, 1, 1, 1]" unimplemented
+ ]
+
+-- Query
+queryTests :: TestTree
+queryTests = testGroup "Query" [nullTests, valueTests]
+
+nullTests :: TestTree
+nullTests =
+ testGroup
+ "null"
+ [ testCase "null of empty list" $ do
+ -- Construct empty list using empty
+ let isNull1 :: Bool
+ isNull1 = runST (empty >>= null)
+ assertBool "empty list is null" isNull1
+
+ -- Construct empty list using fromList
+ let isNull2 :: Bool
+ isNull2 = runST (fromList [] >>= null)
+ assertBool "empty list is null" isNull2,
+ testCase "null of non-empty list" $ do
+ let isNull1 :: Bool
+ isNull1 = runST (fromList [1 :: Int] >>= null)
+ assertBool "non-empty list is not null" (not isNull1)
+ let isNull2 :: Bool
+ isNull2 = runST (fromList [1 :: Int, 2] >>= null)
+ assertBool "non-empty list is not null" (not isNull2)
+ let isNull3 :: Bool
+ isNull3 = runST (fromList [1 :: Int, 2, 3] >>= null)
+ assertBool "non-empty list is not null" (not isNull3)
+ ]
+
+valueTests :: TestTree
+valueTests = testCase "value" (pure ())
+
+-- Insertion
+insertionTests :: TestTree
+insertionTests =
+ testGroup
+ "Insertion"
+ [ consTests,
+ snocTests,
+ insertBeforeTests,
+ insertAfterTests,
+ insertBeforeAfterTests
+ ]
+
+consTests :: TestTree
+consTests =
+ testGroup
+ "cons"
+ [ testCase "Create [1] with cons" $
+ let xs :: [Int]
+ xs = runST $ do
+ ys <- empty
+ void (cons ys 1)
+ toList ys
+ in xs @?= [1],
+ testCase "Create [1, 2] with cons" $
+ let xs :: [Int]
+ xs = runST $ do
+ ys <- empty
+ void (cons ys 2)
+ void (cons ys 1)
+ toList ys
+ in xs @?= [1, 2],
+ testCase "Create [1, 2, 3] with cons" $
+ let xs :: [Int]
+ xs = runST $ do
+ ys <- empty
+ void (cons ys 3)
+ void (cons ys 2)
+ void (cons ys 1)
+ toList ys
+ in xs @?= [1, 2, 3]
+ ]
+
+snocTests :: TestTree
+snocTests =
+ testGroup
+ "snoc"
+ [ ignoreTest $ testCase "Create [1] with snoc" unimplemented,
+ ignoreTest $ testCase "Create [1, 2] with snoc" unimplemented,
+ ignoreTest $ testCase "Create [1, 2, 3] with snoc" unimplemented
+ ]
+
+insertBeforeTests :: TestTree
+insertBeforeTests =
+ testGroup
+ "insertBefore"
+ [ ignoreTest $ testCase "Create [1, 0] with insertBefore" unimplemented,
+ ignoreTest $ testCase "Create [1, 2, 0] with insertBefore" unimplemented,
+ ignoreTest $
+ testCase "Create [1, 2, 3, 0] with insertBefore" unimplemented
+ ]
+
+insertAfterTests :: TestTree
+insertAfterTests =
+ testGroup
+ "insertAfter"
+ [ ignoreTest $ testCase "Create [0, 1] with insertAfter" unimplemented,
+ ignoreTest $ testCase "Create [0, 1, 2] with insertAfter" unimplemented,
+ ignoreTest $ testCase "Create [0, 1, 2, 3] with insertAfter" unimplemented
+ ]
+
+insertBeforeAfterTests :: TestTree
+insertBeforeAfterTests =
+ testGroup
+ "insertBefore and insertAfter"
+ [ ignoreTest $
+ testCase
+ "Create [-1, 0, 1] with insertBefore and insertAfter"
+ unimplemented,
+ ignoreTest $
+ testCase
+ "Create [-2, -1, 0, 1, 2] with insertBefore and insertAfter"
+ unimplemented,
+ ignoreTest $
+ testCase
+ "Create [-3, -2, -1, 0, 1, 2, 3] with insertBefore and insertAfter"
+ unimplemented
+ ]
+
+-- Deletion
+deletionTests :: TestTree
+deletionTests = testGroup "Deletion" [deleteTests]
+
+deleteTests :: TestTree
+deleteTests =
+ testGroup
+ "delete"
+ [ testCase "Turn [-2, -1, 0, 1, 2] -> [-2, -1, 1, 2] using delete" $ do
+ let xs :: Maybe [Int]
+ xs = runST $ runMaybeT $ do
+ dllist <- lift $ fromList [-2 .. 2]
+ node1 <- MaybeT $ head dllist
+ node2 <- MaybeT $ next node1
+ node3 <- MaybeT $ next node2
+ lift (delete node3)
+ lift (toList dllist)
+ in xs @?= Just [-2, -1, 1, 2],
+ testCase "Turn [1, 2, 3, 4, 5, 6] -> [2, 4, 6] using delete" $
+ let xs :: Maybe [Int]
+ xs = runST $ runMaybeT $ do
+ dlist <- lift $ fromList [1 .. 6]
+ node1 <- MaybeT (head dlist)
+ lift (delete node1)
+ node2 <- MaybeT (next node1)
+ node3 <- MaybeT (next node2)
+ node4 <- MaybeT (next node3)
+ lift (delete node3)
+ node5 <- MaybeT (next node4)
+ lift (delete node5)
+ lift (toList dlist)
+ in xs @?= Just [2, 4, 6]
+ ]
+
+-- List conversion
+listConversionTests :: TestTree
+listConversionTests = testGroup "List conversion" [toListTests]
+
+toListTests :: TestTree
+toListTests = testCase "toList" (pure ())
+
+-- Integration
+integrationTests :: TestTree
+integrationTests = ignoreTest $ testCase "Integration" unimplemented
diff --git a/test/Test/Data/List/ApplyMerge/Common.hs b/test/Test/Data/List/ApplyMerge/Common.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Data/List/ApplyMerge/Common.hs
@@ -0,0 +1,110 @@
+-- SPDX-FileCopyrightText: Copyright Preetham Gujjula
+-- SPDX-License-Identifier: BSD-3-Clause
+{-# LANGUAGE Rank2Types #-}
+
+module Test.Data.List.ApplyMerge.Common
+ ( basicTest,
+ skewedTest,
+ blockTest,
+ maxTest,
+ )
+where
+
+import Data.List (sort)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (testCase, (@?=))
+
+type ApplyMerge = forall a b c. (Ord c) => (a -> b -> c) -> [a] -> [b] -> [c]
+
+basicTest :: ApplyMerge -> TestTree
+basicTest applyMerge =
+ testGroup
+ "basic tests"
+ [ testCase "applyMerge (+) [] [] == []" $
+ applyMerge (undefined :: Int -> Int -> Int) [] [] @?= [],
+ testCase "applyMerge (+) [0 ..] [] == []" $
+ applyMerge (+) ([0 ..] :: [Int]) [] @?= [],
+ testCase "applyMerge (+) [] [0 ..] == []" $
+ applyMerge (+) ([] :: [Int]) [0 ..] @?= [],
+ testCase "applyMerge (+) [0 .. 10] [0 .. 10] is correct" $
+ let xs :: [Int]
+ xs = [0 .. 10]
+ expected = sort $ (+) <$> xs <*> xs
+ in applyMerge (+) xs xs @?= expected,
+ testCase "applyMerge (+) [0 .. 10] (replicate 10 1) is correct" $
+ let xs :: [Int]
+ xs = [0 .. 10]
+ ys :: [Int]
+ ys = replicate 10 1
+ expected = sort $ (+) <$> xs <*> ys
+ in applyMerge (+) xs ys @?= expected,
+ testCase "applyMerge (+) (replicate 10 1) [0 .. 10] is correct" $
+ let xs :: [Int]
+ xs = [0 .. 10]
+ ys :: [Int]
+ ys = replicate 10 1
+ expected = sort $ (+) <$> ys <*> xs
+ in applyMerge (+) ys xs @?= expected,
+ testCase "applyMerge (+) (replicate 10 1) (replicate 10 1) is correct" $
+ let ys :: [Int]
+ ys = replicate 10 1
+ expected = sort $ (+) <$> ys <*> ys
+ in applyMerge (+) ys ys @?= expected,
+ testCase "applyMerge (+) [0..] [0..] is correct in the first 100 elems" $
+ let xs :: [Int]
+ xs = [0 ..]
+ expected :: [Int]
+ expected = take 100 $ sort $ (+) <$> take 100 xs <*> take 100 xs
+ in take 100 (applyMerge (+) xs xs) @?= expected
+ ]
+
+skewedTest :: ApplyMerge -> TestTree
+skewedTest applyMerge =
+ testGroup
+ "skewed tests"
+ [ testCase "applyMerge (^) [2..] [1..] is correct in the first 100 elems" $
+ let bases :: [Integer]
+ bases = [2 ..]
+ exps :: [Int]
+ exps = [1 ..]
+ expected :: [Integer]
+ expected = take 100 $ sort $ (^) <$> take 100 bases <*> take 100 exps
+ in take 100 (applyMerge (^) bases exps) @?= expected,
+ testCase "applyMerge (flip (^)) [2..] [1..] is correct in the first 100 elems" $
+ let bases :: [Integer]
+ bases = [2 ..]
+ exps :: [Int]
+ exps = [1 ..]
+ expected :: [Integer]
+ expected = take 100 $ sort $ flip (^) <$> take 100 exps <*> take 100 bases
+ in take 100 (applyMerge (flip (^)) exps bases) @?= expected
+ ]
+
+blockTest :: ApplyMerge -> TestTree
+blockTest applyMerge =
+ testGroup
+ "block tests"
+ [ testCase
+ ( "applyMerge (\\x y -> (x `quot` 3) + (y `quot` 3)) [0..] [0..] is correct in the "
+ ++ "first 100 elems"
+ )
+ $ let xs :: [Int]
+ xs = [0 ..]
+ f :: Int -> Int -> Int
+ f x y = (x `quot` 3) + (y `quot` 3)
+ expected :: [Int]
+ expected = take 100 $ sort $ f <$> take 100 xs <*> take 100 xs
+ in take 100 (applyMerge f xs xs) @?= expected
+ ]
+
+maxTest :: ApplyMerge -> TestTree
+maxTest applyMerge =
+ testGroup
+ "max tests"
+ [ testCase "applyMerge max [0..] [0..] is correct in the first 100 elems" $
+ let xs :: [Int]
+ xs = [0 ..]
+ expected :: [Int]
+ expected = take 100 $ sort $ max <$> take 100 xs <*> take 100 xs
+ in take 100 (applyMerge max xs xs) @?= expected
+ ]
diff --git a/test/Test/Data/List/ApplyMerge/DoublyLinkedList.hs b/test/Test/Data/List/ApplyMerge/DoublyLinkedList.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Data/List/ApplyMerge/DoublyLinkedList.hs
@@ -0,0 +1,25 @@
+-- SPDX-FileCopyrightText: Copyright Preetham Gujjula
+-- SPDX-License-Identifier: BSD-3-Clause
+module Test.Data.List.ApplyMerge.DoublyLinkedList
+ ( tests,
+ )
+where
+
+import Data.List.ApplyMerge.DoublyLinkedList (applyMerge)
+import Test.Data.List.ApplyMerge.Common
+ ( basicTest,
+ blockTest,
+ maxTest,
+ skewedTest,
+ )
+import Test.Tasty (TestTree, testGroup)
+
+tests :: TestTree
+tests =
+ testGroup
+ "Data.List.ApplyMerge.DoublyLinkedList"
+ [ basicTest applyMerge,
+ skewedTest applyMerge,
+ blockTest applyMerge,
+ maxTest applyMerge
+ ]
diff --git a/test/Test/Data/List/ApplyMerge/IntMap.hs b/test/Test/Data/List/ApplyMerge/IntMap.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Data/List/ApplyMerge/IntMap.hs
@@ -0,0 +1,26 @@
+-- SPDX-FileCopyrightText: Copyright Preetham Gujjula
+-- SPDX-License-Identifier: BSD-3-Clause
+
+module Test.Data.List.ApplyMerge.IntMap
+ ( tests,
+ )
+where
+
+import Data.List.ApplyMerge.IntMap (applyMerge)
+import Test.Data.List.ApplyMerge.Common
+ ( basicTest,
+ blockTest,
+ maxTest,
+ skewedTest,
+ )
+import Test.Tasty (TestTree, testGroup)
+
+tests :: TestTree
+tests =
+ testGroup
+ "Data.List.ApplyMerge.IntMap"
+ [ basicTest applyMerge,
+ skewedTest applyMerge,
+ blockTest applyMerge,
+ maxTest applyMerge
+ ]
diff --git a/test/Test/Data/List/ApplyMerge/IntSet.hs b/test/Test/Data/List/ApplyMerge/IntSet.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Data/List/ApplyMerge/IntSet.hs
@@ -0,0 +1,25 @@
+-- SPDX-FileCopyrightText: Copyright Preetham Gujjula
+-- SPDX-License-Identifier: BSD-3-Clause
+module Test.Data.List.ApplyMerge.IntSet
+ ( tests,
+ )
+where
+
+import Data.List.ApplyMerge.IntSet (applyMerge)
+import Test.Data.List.ApplyMerge.Common
+ ( basicTest,
+ blockTest,
+ maxTest,
+ skewedTest,
+ )
+import Test.Tasty (TestTree, testGroup)
+
+tests :: TestTree
+tests =
+ testGroup
+ "Data.List.ApplyMerge.IntSet"
+ [ basicTest applyMerge,
+ skewedTest applyMerge,
+ blockTest applyMerge,
+ maxTest applyMerge
+ ]
diff --git a/test/Test/Data/PQueue/Prio/Min/Mutable.hs b/test/Test/Data/PQueue/Prio/Min/Mutable.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Data/PQueue/Prio/Min/Mutable.hs
@@ -0,0 +1,37 @@
+-- SPDX-FileCopyrightText: Copyright Preetham Gujjula
+-- SPDX-License-Identifier: BSD-3-Clause
+
+module Test.Data.PQueue.Prio.Min.Mutable (tests) where
+
+import Control.Monad (forM_, replicateM)
+import Control.Monad.ST (runST)
+import Data.List (sort)
+import Data.Maybe (catMaybes)
+import Data.PQueue.Prio.Min.Mutable
+import Test.Falsify.Generator (int, list)
+import Test.Falsify.Predicate (eq, (.$))
+import Test.Falsify.Property (Property, assert, gen, info)
+import Test.Falsify.Range (between)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Falsify (testProperty)
+
+tests :: TestTree
+tests =
+ testGroup
+ "Data.PQueue.Prio.Min.Mutable"
+ [ testProperty "priority queue sorts a list" prop_sorts_list
+ ]
+
+prop_sorts_list :: Property ()
+prop_sorts_list = do
+ xs <- gen $ list (between (1, 20)) (int (between (0, 100)))
+ info ("xs == " ++ show xs)
+ let actual = pqueueSort xs
+ let expected = sort xs
+ assert (eq .$ ("expected", expected) .$ ("actual", actual))
+
+pqueueSort :: (Ord a) => [a] -> [a]
+pqueueSort xs = runST $ do
+ queue <- empty
+ forM_ xs $ \x -> insert x () queue
+ map fst . catMaybes <$> replicateM (length xs) (deleteMin queue)