apply-merge (empty) → 0.1.0.0
raw patch · 21 files changed
+2106/−0 lines, 21 filesdep +basedep +containersdep +falsify
Dependencies added: base, containers, falsify, pqueue, tasty, tasty-bench, tasty-expected-failure, tasty-hunit, transformers, vector
Files
- ChangeLog.md +19/−0
- README.md +87/−0
- apply-merge.cabal +101/−0
- bench/Bench/Data/DoublyLinkedList/STRef.hs +172/−0
- bench/Bench/PriorityQueue/MinPQueue.hs +34/−0
- bench/Bench/PriorityQueue/MinPQueue/Mutable.hs +37/−0
- bench/Main.hs +47/−0
- docs/ALGORITHM.md +259/−0
- src/Data/DoublyLinkedList/STRef.hs +253/−0
- src/Data/List/ApplyMerge.hs +31/−0
- src/Data/List/ApplyMerge/DoublyLinkedList.hs +149/−0
- src/Data/List/ApplyMerge/IntMap.hs +98/−0
- src/Data/List/ApplyMerge/IntSet.hs +100/−0
- src/Data/PQueue/Prio/Min/Mutable.hs +140/−0
- test/Main.hs +25/−0
- test/Test/Data/DoublyLinkedList/STRef.hs +331/−0
- test/Test/Data/List/ApplyMerge/Common.hs +110/−0
- test/Test/Data/List/ApplyMerge/DoublyLinkedList.hs +25/−0
- test/Test/Data/List/ApplyMerge/IntMap.hs +26/−0
- test/Test/Data/List/ApplyMerge/IntSet.hs +25/−0
- test/Test/Data/PQueue/Prio/Min/Mutable.hs +37/−0
+ ChangeLog.md view
@@ -0,0 +1,19 @@+<!--+SPDX-FileCopyrightText: Copyright Preetham Gujjula+SPDX-License-Identifier: BSD-3-Clause+-->++# Changelog for apply-merge++## 0.1.0.0++### Added+* Implementation of `applyMerge`.+* A tasty-based test suite for `applyMerge`.+* A tasty-bench benchmark suite for `applyMerge`.+* Haddock documentation for `applyMerge`.+* Support for GHC 9.2, 9.4, 9.6, 9.8.+* CI testing for GHC 9.2.8, 9.4.8, 9.6.4.+* Documentation of the library in `README.md` and `docs/ALGORITHM.md`, with+ feedback from _meeeow_ on Haskell Discourse+ ([link](https://discourse.haskell.org/t/apply-merge-lift-a-binary-increasing-function-onto-ordered-lists-and-produce-ordered-output/9269/4)).
+ README.md view
@@ -0,0 +1,87 @@+<!--+SPDX-FileCopyrightText: Copyright Preetham Gujjula+SPDX-License-Identifier: BSD-3-Clause+-->++# apply-merge++[](https://github.com/pgujjula/apply-merge/actions/workflows/ci.yml)+[](https://api.reuse.software/info/github.com/pgujjula/apply-merge)++Lift a binary, non-decreasing function onto ordered lists and order the output++## Overview++This library provides a function++```haskell+applyMerge :: Ord c => (a -> b -> c) -> [a] -> [b] -> [c]+```++If `f` is a binary function that is non-decreasing in both arguments, and `xs`+and `ys` are (potentially infinite) ordered lists, then `applyMerge f xs ys` is+an ordered 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.+See+[docs/ALGORITHM.md#note-about-memory-usage](docs/ALGORITHM.md#note-about-memory-usage)+for caveats.++## 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..]+```++3-smooth numbers ([Wikipedia](https://en.wikipedia.org/wiki/Smooth_number)):++```haskell+smooth3 :: [Integer]+smooth3 = applyMerge (*) (iterate (*2) 1) (iterate (*3) 1)+```++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..]+```++## Naming++The name `applyMerge` comes from the idea of applying `f` to each `x` and `y`,+and merging the results into one sorted output. I'm still thinking of the ideal+name for this function. Other options include `sortedLiftA2`/`orderedLiftA2`,+from the idea that this function is equivalent to `sort (liftA2 f xs ys)` when+`xs` and `ys` are finite. If you have any ideas on the naming, let me know!++## Further reading++See [docs/ALGORITHM.md](docs/ALGORITHM.md) for a full exposition of the+`applyMerge` function and its implementation.++## Licensing++This project licensed under BSD-3-Clause (except for `.gitignore`, which is+under CC0-1.0), and follows [REUSE](https://reuse.software) licensing+principles.++[^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 <pre> primes = sieve [2..] where sieve (p : xs) = p : sieve [x | x <- xs, x \`rem\` p > 0]</pre> which is actually trial division and not a faithful implementation of the Sieve of Erastosthenes.
+ apply-merge.cabal view
@@ -0,0 +1,101 @@+cabal-version: 3.6++-- This file has been generated from package.yaml by hpack version 0.36.0.+--+-- see: https://github.com/sol/hpack++name: apply-merge+version: 0.1.0.0+synopsis: Lift a binary, non-decreasing function onto ordered lists and order the output+description: Please see the README on GitHub at <https://github.com/pgujjula/apply-merge#readme>+category: Data+stability: experimental+homepage: https://github.com/pgujjula/apply-merge#readme+bug-reports: https://github.com/pgujjula/apply-merge/issues+author: Preetham Gujjula+maintainer: Preetham Gujjula <libraries@mail.preetham.io>+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
+ bench/Bench/Data/DoublyLinkedList/STRef.hs view
@@ -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" []
+ bench/Bench/PriorityQueue/MinPQueue.hs view
@@ -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]
+ bench/Bench/PriorityQueue/MinPQueue/Mutable.hs view
@@ -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]
+ bench/Main.hs view
@@ -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
+ docs/ALGORITHM.md view
@@ -0,0 +1,259 @@+<!--+SPDX-FileCopyrightText: Copyright Preetham Gujjula+SPDX-License-Identifier: BSD-3-Clause+-->++# 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:++<pre>+ | 1 2 4 8 ..+ ---------------------------------+ 1 | 1 2 4 8 ..+ |+ 3 | 3 6 12 24 ..+ |+ 9 | 9 18 36 72 ..+ |+ 27 | 27 54 108 216 ..+ |+ : | : : : : ॱ.+</pre>++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:++<pre>+ | 1 2 4 8 ..+ ---------------------------------+ 1 | <del>1</del> <del>2</del> <b>4</b> 8 ..+ |+ 3 | <del>3</del> <b>6</b> 12 24 ..+ |+ 9 | <b>9</b> 18 36 72 ..+ |+ 27 | 27 54 108 216 ..+ |+ : | : : : : ॱ.+</pre>++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++<pre>+ | 1 2 4 8 ..+ ---------------------------------+ 1 | <del>1</del> <del>2</del> <del>4</del> <b>8</b> ..+ |+ 3 | <del>3</del> <b>6</b> 12 24 ..+ |+ 9 | <b>9</b> 18 36 72 ..+ |+ 27 | 27 54 108 216 ..+ |+ : | : : : : ॱ.+</pre>++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++<pre>+ | 1 2 4 8 ..+ ---------------------------------+ 1 | <del>1</del> <del>2</del> <del>4</del> <b>8</b> ..+ |+ 3 | <del>3</del> <del>6</del> <b>12</b> 24 ..+ |+ 9 | <b>9</b> 18 36 72 ..+ |+ 27 | 27 54 108 216 ..+ |+ : | : : : : ॱ.+</pre>++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. <i>(TODO: add a proof of this)</i> 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 <code>[data-ordlist](https://www.stackage.org/lts/package/data-ordlist)</code>,+there is <code>[mergeAll](https://www.stackage.org/haddock/lts/data-ordlist/Data-List-Ordered.html#v:mergeAll) :: Ord a => [[a]] -> [a]</code>,+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 <pre> primes = sieve [2..] where sieve (p : xs) = p : sieve [x | x <- xs, x \`rem\` p > 0]</pre> which is actually trial division and not a faithful implementation of the Sieve of Erastosthenes.
+ src/Data/DoublyLinkedList/STRef.hs view
@@ -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)
+ src/Data/List/ApplyMerge.hs view
@@ -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 <libraries@mail.preetham.io>+-- 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
+ src/Data/List/ApplyMerge/DoublyLinkedList.hs view
@@ -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
+ src/Data/List/ApplyMerge/IntMap.hs view
@@ -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+ }
+ src/Data/List/ApplyMerge/IntSet.hs view
@@ -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+ }
+ src/Data/PQueue/Prio/Min/Mutable.hs view
@@ -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+ }
+ test/Main.hs view
@@ -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+ ]
+ test/Test/Data/DoublyLinkedList/STRef.hs view
@@ -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
+ test/Test/Data/List/ApplyMerge/Common.hs view
@@ -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+ ]
+ test/Test/Data/List/ApplyMerge/DoublyLinkedList.hs view
@@ -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+ ]
+ test/Test/Data/List/ApplyMerge/IntMap.hs view
@@ -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+ ]
+ test/Test/Data/List/ApplyMerge/IntSet.hs view
@@ -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+ ]
+ test/Test/Data/PQueue/Prio/Min/Mutable.hs view
@@ -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)