├── .gitignore ├── ChangeLog.md ├── LICENSE ├── Laws.md ├── README.md ├── Setup.hs ├── benchmarks └── Main.hs ├── sort-traversable.cabal └── src └── Data └── Traversable └── Sort ├── PairingHeap.hs └── PairingHeap ├── BasicNat.hs └── IndexedPairingHeap.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for sort-traversable 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, David Feuer 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /Laws.md: -------------------------------------------------------------------------------- 1 | It is not immediately obvious that `Sort` is a lawful `Applicative` at all. 2 | Let's see if we can figure it out! The indices just get in the way here, so 3 | let's clean up the `Applicative` instance a bit. It won't compile like this, 4 | but that doesn't matter. 5 | 6 | ```haskell 7 | pure x = Sort (\_ h -> (h, x)) empty 8 | 9 | (<*>) :: forall a b . Sort x (a -> b) -> Sort x a -> Sort x b 10 | Sort f xs <*> Sort g ys = 11 | Sort h (merge xs ys) 12 | where 13 | h :: forall o. Proxy o -> Heap ((m + n) + o) x -> (Heap o x, b) 14 | h p v = case f Proxy v of { (v', a) -> 15 | case g Proxy v' of { (v'', b) -> 16 | (v'', a b)}} 17 | ``` 18 | 19 | As ["paf31" noted](https://www.reddit.com/r/haskell/comments/63a4ea/fast_total_sorting_of_arbitrary_traversable/dfu4uar/), `Sort a` is (indices, proxies, and strictness annotation aside) the 20 | [`Product`](https://hackage.haskell.org/package/base-4.9.1.0/docs/Data-Functor-Product.html) 21 | of two applicative functors: 22 | 23 | ```haskell 24 | Sort a ~= Product (State (Heap a)) (Const (Heap a)) 25 | ``` 26 | 27 | with precisely the `Applicative` instance that suggests. 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Will Fancher recently wrote a [blog post](http://elvishjerricco.github.io/2017/03/23/applicative-sorting.html) 2 | (see also the [Reddit thread](https://www.reddit.com/r/haskell/comments/610sa1/applicative_sorting/)) 3 | about sorting arbitrary `Traversable` containers without any of the ugly incomplete pattern matches that 4 | accompany the well-known technique of dumping all the entries into a list and then sucking them back out 5 | in `State`. Fancher used a custom applicative based on the usual 6 | [free applicative](https://hackage.haskell.org/package/free-4.12.4/docs/Control-Applicative-Free.html). 7 | Unfortunately, this type is rather hard to work with, and Fancher was not immediately able to find a 8 | way to use anything better than insertion sort. This repository demonstrates an asymptotically optimal heap 9 | sort using a heap-merging applicative. 10 | 11 | The three modules: 12 | 13 | * `BasicNat`: unary natural numbers, singletons, and properties 14 | * `IndexedPairingHeap`: size-indexed pairing heaps 15 | * `HSTrav`: the big payoff: heap-sorting anything 16 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /benchmarks/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Data.Traversable.Sort.PairingHeap (sortTraversable) 3 | import Criterion.Main 4 | import Data.List (sort) 5 | import qualified Data.Sequence as Seq 6 | import System.Random 7 | import Data.Foldable 8 | 9 | main = do 10 | g <- getStdGen 11 | let million = take 1000000 $ randoms g :: [Int] 12 | million' = Seq.fromList million 13 | hundredthousand = take 100000 million 14 | hundredthousand' = Seq.fromList hundredthousand 15 | tenthousand = take 10000 million 16 | tenthousand' = Seq.fromList tenthousand 17 | thousand = take 1000 million 18 | thousand' = Seq.fromList thousand 19 | print $ sum $ map length 20 | [million, hundredthousand,tenthousand,thousand] 21 | print $ sum $ map (length . toList) 22 | [million', thousand',hundredthousand',tenthousand',thousand'] 23 | print $ length $ toList hundredthousand 24 | defaultMain [ 25 | bgroup "1000" 26 | [ bgroup "list" 27 | [ bench "Data.List" $ nf sort thousand 28 | , bench "HSTrav" $ nf sortTraversable thousand 29 | ] 30 | , bgroup "sequence" 31 | [ bench "sort" $ nf Seq.sort thousand' 32 | , bench "unstableSort" $ nf Seq.unstableSort thousand' 33 | , bench "HSTrav" $ nf sortTraversable thousand' 34 | ] 35 | ] 36 | , bgroup "10000" 37 | [ bgroup "list" 38 | [ bench "Data.List" $ nf sort tenthousand 39 | , bench "HSTrav" $ nf sortTraversable tenthousand 40 | ] 41 | , bgroup "sequence" 42 | [ bench "sort" $ nf Seq.sort tenthousand' 43 | , bench "unstableSort" $ nf Seq.unstableSort tenthousand' 44 | , bench "HSTrav" $ nf sortTraversable tenthousand' 45 | ] 46 | ] 47 | , bgroup "100000" 48 | [ bgroup "list" 49 | [ bench "Data.List" $ nf sort hundredthousand 50 | , bench "HSTrav" $ nf sortTraversable hundredthousand 51 | ] 52 | , bgroup "sequence" 53 | [ bench "sort" $ nf Seq.sort hundredthousand' 54 | , bench "unstableSort" $ nf Seq.unstableSort hundredthousand' 55 | , bench "HSTrav" $ nf sortTraversable hundredthousand' 56 | ] 57 | ] 58 | , bgroup "1000000" 59 | [ bgroup "list" 60 | [ bench "Data.List" $ nf sort million 61 | , bench "HSTrav" $ nf sortTraversable million 62 | ] 63 | , bgroup "sequence" 64 | [ bench "sort" $ nf Seq.sort million' 65 | , bench "unstableSort" $ nf Seq.unstableSort million' 66 | , bench "HSTrav" $ nf sortTraversable million' 67 | ] 68 | ] 69 | ] 70 | 71 | -------------------------------------------------------------------------------- /sort-traversable.cabal: -------------------------------------------------------------------------------- 1 | name: sort-traversable 2 | 3 | version: 0.1.0.0 4 | 5 | -- A short (one-line) description of the package. 6 | synopsis: Sort arbitrary Traversable containers 7 | 8 | -- A longer description of the package. 9 | -- description: 10 | 11 | -- URL for the project homepage or repository. 12 | homepage: https://github.com/treeowl/sort-traversable 13 | 14 | -- The license under which the package is released. 15 | license: BSD2 16 | 17 | -- The file containing the license text. 18 | license-file: LICENSE 19 | 20 | -- The package author(s). 21 | author: David Feuer 22 | 23 | -- An email address to which users can send suggestions, bug reports, and 24 | -- patches. 25 | maintainer: DavidFeuer at the google mail domain 26 | 27 | -- A copyright notice. 28 | -- copyright: 29 | 30 | category: Data 31 | 32 | build-type: Simple 33 | 34 | -- Extra files to be distributed with the package, such as examples or a 35 | -- README. 36 | extra-source-files: 37 | ChangeLog.md 38 | , README.md 39 | , Laws.md 40 | 41 | -- Constraint on the version of Cabal needed to build this package. 42 | cabal-version: >=1.10 43 | 44 | 45 | library 46 | exposed-modules: 47 | Data.Traversable.Sort.PairingHeap 48 | Data.Traversable.Sort.PairingHeap.BasicNat 49 | Data.Traversable.Sort.PairingHeap.IndexedPairingHeap 50 | 51 | -- Modules included in this library but not exported. 52 | -- other-modules: 53 | 54 | -- LANGUAGE extensions used by modules in this package. 55 | other-extensions: 56 | GADTs 57 | , DataKinds 58 | , TypeFamilies 59 | , TypeOperators 60 | , ScopedTypeVariables 61 | , RankNTypes 62 | , InstanceSigs 63 | , BangPatterns 64 | , RoleAnnotations 65 | 66 | -- Other library packages from which modules are imported. 67 | build-depends: base >=4.8 && <4.10 68 | 69 | -- Directories containing source files. 70 | hs-source-dirs: src, benchmarks 71 | 72 | -- Base language which the package is written in. 73 | default-language: Haskell2010 74 | 75 | benchmark bench 76 | Default-Language: Haskell2010 77 | Type: exitcode-stdio-1.0 78 | HS-Source-Dirs: benchmarks 79 | Main-Is: Main.hs 80 | GHC-Options: -O2 81 | 82 | Build-Depends: 83 | base >= 4.4 && < 5 84 | , criterion >= 1.1.1.0 && < 1.2 85 | , containers >=0.5 && <0.6 86 | , random 87 | , sort-traversable 88 | -------------------------------------------------------------------------------- /src/Data/Traversable/Sort/PairingHeap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, GADTs, TypeOperators, 2 | RankNTypes, InstanceSigs, DataKinds #-} 3 | module Data.Traversable.Sort.PairingHeap where 4 | import Data.Traversable.Sort.PairingHeap.IndexedPairingHeap ( 5 | Heap 6 | , Sized (..) 7 | , empty 8 | , singleton 9 | , merge 10 | , minView 11 | ) 12 | import Data.Proxy 13 | import Data.Type.Equality ((:~:) (..)) 14 | import Data.Traversable.Sort.PairingHeap.BasicNat 15 | (type (+), Nat (..), plusAssoc, plusZero) 16 | 17 | -- | A heap of some size whose element have type @a@ and a 18 | -- function that, applied to any heap at least that large, 19 | -- will produce a result and the rest of the heap. 20 | data Sort a r where 21 | Sort :: (forall n. Proxy n -> Heap (m + n) a -> (Heap n a, r)) 22 | -> !(Heap m a) 23 | -> Sort a r 24 | 25 | instance Functor (Sort x) where 26 | fmap f (Sort g h) = 27 | Sort (\p h' -> case g p h' of (remn, r) -> (remn, f r)) h 28 | {-# INLINE fmap #-} 29 | 30 | instance Ord x => Applicative (Sort x) where 31 | pure x = Sort (\_ h -> (h, x)) empty 32 | {-# INLINE pure #-} 33 | 34 | -- Combine two 'Sort's by merging their heaps and composing 35 | -- their functions. 36 | (<*>) :: forall a b . Sort x (a -> b) -> Sort x a -> Sort x b 37 | Sort f (xs :: Heap m x) <*> Sort g (ys :: Heap n x) = 38 | Sort h (merge xs ys) 39 | where 40 | h :: forall o . Proxy o -> Heap ((m + n) + o) x -> (Heap o x, b) 41 | h p v = case plusAssoc (size xs) (size ys) p of 42 | Refl -> case f (Proxy :: Proxy (n + o)) v of { (v', a) -> 43 | case g (Proxy :: Proxy o) v' of { (v'', b) -> 44 | (v'', a b)}} 45 | {-# INLINABLE (<*>) #-} 46 | 47 | -- Produce a 'Sort' with a singleton heap and a function that will 48 | -- produce the smallest element of a heap. 49 | liftSort :: Ord x => x -> Sort x x 50 | liftSort a = Sort (\_ h -> case minView h of (x, h') -> (h', x)) (singleton a) 51 | {-# INLINABLE liftSort #-} 52 | 53 | -- Apply the function in a 'Sort' to the heap within, producing a 54 | -- result. 55 | runSort :: forall x a . Sort x a -> a 56 | runSort (Sort f xs) = case plusZero (size xs) of 57 | Refl -> snd $ f (Proxy :: Proxy 'Z) xs 58 | 59 | -- | Sort an arbitrary 'Traversable' container using a heap. 60 | sortTraversable :: (Ord a, Traversable t) => t a -> t a 61 | sortTraversable = runSort . traverse liftSort 62 | {-# INLINABLE sortTraversable #-} 63 | 64 | -- | Sort an arbitrary container using a 'Traversal' (in the 65 | -- 'lens' sense). 66 | sortTraversal :: Ord a => ((a -> Sort a a) -> t -> Sort a t) -> t -> t 67 | sortTraversal trav = runSort . trav liftSort 68 | {-# INLINABLE sortTraversal #-} 69 | -------------------------------------------------------------------------------- /src/Data/Traversable/Sort/PairingHeap/BasicNat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, TypeFamilies, TypeOperators, GADTs, 2 | ScopedTypeVariables, TypeOperators #-} 3 | 4 | -- | Type-level natural numbers and singletons, with proofs of 5 | -- a few basic properties. 6 | 7 | module Data.Traversable.Sort.PairingHeap.BasicNat ( 8 | -- | Type-level natural numbers 9 | Nat (..) 10 | , type (+) 11 | 12 | -- | Natural number singletons 13 | , Natty (..) 14 | , plus 15 | 16 | -- | Basic properties 17 | , plusCommutative 18 | , plusZero 19 | , plusSucc 20 | , plusAssoc 21 | ) where 22 | import Data.Type.Equality ((:~:)(..)) 23 | import Unsafe.Coerce 24 | 25 | -- | Type-level natural numbers 26 | data Nat = Z | S Nat 27 | 28 | -- | Type-level natural number addition 29 | type family (+) m n where 30 | 'Z + n = n 31 | ('S m) + n = 'S (m + n) 32 | 33 | -- | Singletons for natural numbers 34 | data Natty n where 35 | Zy :: Natty 'Z 36 | Sy :: Natty n -> Natty ('S n) 37 | 38 | -- | Singleton addition 39 | plus :: Natty m -> Natty n -> Natty (m + n) 40 | plus Zy n = n 41 | plus (Sy m) n = Sy (plus m n) 42 | 43 | 44 | ---------------------------------------------------------- 45 | -- Proofs of basic arithmetic 46 | -- 47 | -- The legitimate proofs are accompanied by rewrite rules that 48 | -- effectively assert termination. These rules prevent us from 49 | -- actually having to run the proof code, which would be slow. 50 | 51 | plusCommutative :: Natty m -> Natty n -> (m + n) :~: (n + m) 52 | plusCommutative Zy n = case plusZero n of Refl -> Refl 53 | plusCommutative (Sy m) n = 54 | case plusCommutative m n of { Refl -> 55 | case plusSucc n m of Refl -> Refl } 56 | {-# NOINLINE plusCommutative #-} 57 | 58 | plusZero :: Natty m -> (m + 'Z) :~: m 59 | plusZero Zy = Refl 60 | plusZero (Sy n) = case plusZero n of Refl -> Refl 61 | {-# NOINLINE plusZero #-} 62 | 63 | plusSucc :: Natty m -> proxy n -> (m + 'S n) :~: ('S (m + n)) 64 | plusSucc Zy _ = Refl 65 | plusSucc (Sy n) p = case plusSucc n p of Refl -> Refl 66 | {-# NOINLINE plusSucc #-} 67 | 68 | plusAssoc :: Natty m -> p1 n -> p2 o -> (m + (n + o)) :~: ((m + n) + o) 69 | plusAssoc Zy _ _ = Refl 70 | plusAssoc (Sy m) p1 p2 = case plusAssoc m p1 p2 of Refl -> Refl 71 | {-# NOINLINE plusAssoc #-} 72 | 73 | {-# RULES 74 | "plusCommutative" forall m n. plusCommutative m n = unsafeCoerce (Refl :: 'Z :~: 'Z) 75 | "plusZero" forall m . plusZero m = unsafeCoerce (Refl :: 'Z :~: 'Z) 76 | "plusSucc" forall m n. plusSucc m n = unsafeCoerce (Refl :: 'Z :~: 'Z) 77 | "plusAssoc" forall m p1 p2. plusAssoc m p1 p2 = unsafeCoerce (Refl :: 'Z :~: 'Z) 78 | #-} 79 | -------------------------------------------------------------------------------- /src/Data/Traversable/Sort/PairingHeap/IndexedPairingHeap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators, GADTs, RoleAnnotations #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | module Data.Traversable.Sort.PairingHeap.IndexedPairingHeap ( 4 | Heap 5 | , Sized (..) 6 | , empty 7 | , singleton 8 | , insert 9 | , merge 10 | , minView 11 | ) where 12 | import Data.Traversable.Sort.PairingHeap.BasicNat 13 | import Data.Type.Equality ((:~:)(..)) 14 | import Data.Coerce 15 | import Data.Type.Coercion 16 | 17 | -- | Okasaki's simple representation of a pairing heap, but with 18 | -- a size index. 19 | data Heap n a where 20 | E :: Heap 'Z a 21 | T :: a -> HVec n a -> Heap ('S n) a 22 | 23 | -- Coercing a heap could destroy the heap property, so we declare both 24 | -- type parameters nominal. 25 | type role Heap nominal nominal 26 | 27 | -- | A vector of heaps whose sizes sum to the index. 28 | data HVec n a where 29 | HNil :: HVec 'Z a 30 | HCons :: Heap m a -> HVec n a -> HVec (m + n) a 31 | 32 | class Sized h where 33 | -- | Calculate the size of a structure 34 | size :: h n a -> Natty n 35 | 36 | instance Sized Heap where 37 | size E = Zy 38 | size (T _ xs) = Sy (size xs) 39 | 40 | instance Sized HVec where 41 | size HNil = Zy 42 | size (HCons h hs) = size h `plus` size hs 43 | 44 | -- Produce an empty heap 45 | empty :: Heap 'Z a 46 | empty = E 47 | 48 | -- Produce a heap with one element 49 | singleton :: a -> Heap ('S 'Z) a 50 | singleton a = T a HNil 51 | 52 | -- Insert an element into a heap 53 | insert :: Ord a => a -> Heap n a -> Heap ('S n) a 54 | insert x xs = merge (singleton x) xs 55 | {-# INLINABLE insert #-} 56 | 57 | -- Merge two heaps 58 | merge :: Ord a => Heap m a -> Heap n a -> Heap (m + n) a 59 | merge E ys = ys 60 | merge xs E = case plusZero (size xs) of Refl -> xs 61 | merge h1@(T x xs) h2@(T y ys) 62 | | x <= y = case plusCommutative (size h2) (size xs) of Refl -> T x (HCons h2 xs) 63 | | otherwise = case plusSucc (size xs) (size ys) of Refl -> T y (HCons h1 ys) 64 | {-# INLINABLE merge #-} 65 | 66 | -- Get the smallest element of a non-empty heap, and the rest of 67 | -- the heap 68 | minView :: Ord a => Heap ('S n) a -> (a, Heap n a) 69 | minView (T x hs) = (x, mergePairs hs) 70 | {-# INLINABLE minView #-} 71 | 72 | mergePairs :: Ord a => HVec n a -> Heap n a 73 | mergePairs HNil = E 74 | mergePairs (HCons h HNil) = case plusZero (size h) of Refl -> h 75 | mergePairs (HCons h1 (HCons h2 hs)) = 76 | case plusAssoc (size h1) (size h2) (size hs) of 77 | Refl -> merge (merge h1 h2) (mergePairs hs) 78 | {-# INLINABLE mergePairs #-} 79 | --------------------------------------------------------------------------------