├── .github └── workflows │ ├── haskell-ci.yml │ └── hlint.yml ├── .gitignore ├── .hlint.yaml ├── .vim.custom ├── CHANGELOG.markdown ├── LICENSE ├── README.markdown ├── cabal.haskell-ci ├── cabal.project ├── heaps.cabal ├── src └── Data │ └── Heap.hs └── tests └── doctests.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20241202 12 | # 13 | # REGENDATA ("0.19.20241202",["github","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-20.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.12.0.20241128 32 | compilerKind: ghc 33 | compilerVersion: 9.12.0.20241128 34 | setup-method: ghcup-prerelease 35 | allow-failure: false 36 | - compiler: ghc-9.10.1 37 | compilerKind: ghc 38 | compilerVersion: 9.10.1 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.8.4 42 | compilerKind: ghc 43 | compilerVersion: 9.8.4 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.6.6 47 | compilerKind: ghc 48 | compilerVersion: 9.6.6 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.4.8 52 | compilerKind: ghc 53 | compilerVersion: 9.4.8 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-9.2.8 57 | compilerKind: ghc 58 | compilerVersion: 9.2.8 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-9.0.2 62 | compilerKind: ghc 63 | compilerVersion: 9.0.2 64 | setup-method: ghcup 65 | allow-failure: false 66 | - compiler: ghc-8.10.4 67 | compilerKind: ghc 68 | compilerVersion: 8.10.4 69 | setup-method: ghcup 70 | allow-failure: false 71 | - compiler: ghc-8.8.4 72 | compilerKind: ghc 73 | compilerVersion: 8.8.4 74 | setup-method: ghcup 75 | allow-failure: false 76 | - compiler: ghc-8.6.5 77 | compilerKind: ghc 78 | compilerVersion: 8.6.5 79 | setup-method: ghcup 80 | allow-failure: false 81 | - compiler: ghc-8.4.4 82 | compilerKind: ghc 83 | compilerVersion: 8.4.4 84 | setup-method: ghcup 85 | allow-failure: false 86 | - compiler: ghc-8.2.2 87 | compilerKind: ghc 88 | compilerVersion: 8.2.2 89 | setup-method: ghcup 90 | allow-failure: false 91 | - compiler: ghc-8.0.2 92 | compilerKind: ghc 93 | compilerVersion: 8.0.2 94 | setup-method: ghcup 95 | allow-failure: false 96 | fail-fast: false 97 | steps: 98 | - name: apt-get install 99 | run: | 100 | apt-get update 101 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 102 | - name: Install GHCup 103 | run: | 104 | mkdir -p "$HOME/.ghcup/bin" 105 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 106 | chmod a+x "$HOME/.ghcup/bin/ghcup" 107 | - name: Install cabal-install 108 | run: | 109 | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 110 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 111 | - name: Install GHC (GHCup) 112 | if: matrix.setup-method == 'ghcup' 113 | run: | 114 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 115 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 116 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 117 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 118 | echo "HC=$HC" >> "$GITHUB_ENV" 119 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 120 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 121 | env: 122 | HCKIND: ${{ matrix.compilerKind }} 123 | HCNAME: ${{ matrix.compiler }} 124 | HCVER: ${{ matrix.compilerVersion }} 125 | - name: Install GHC (GHCup prerelease) 126 | if: matrix.setup-method == 'ghcup-prerelease' 127 | run: | 128 | "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml; 129 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 130 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 131 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 132 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 133 | echo "HC=$HC" >> "$GITHUB_ENV" 134 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 135 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 136 | env: 137 | HCKIND: ${{ matrix.compilerKind }} 138 | HCNAME: ${{ matrix.compiler }} 139 | HCVER: ${{ matrix.compilerVersion }} 140 | - name: Set PATH and environment variables 141 | run: | 142 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 143 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 144 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 145 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 146 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 147 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 148 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 149 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 150 | if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi 151 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 152 | env: 153 | HCKIND: ${{ matrix.compilerKind }} 154 | HCNAME: ${{ matrix.compiler }} 155 | HCVER: ${{ matrix.compilerVersion }} 156 | - name: env 157 | run: | 158 | env 159 | - name: write cabal config 160 | run: | 161 | mkdir -p $CABAL_DIR 162 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 207 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 208 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 209 | rm -f cabal-plan.xz 210 | chmod a+x $HOME/.cabal/bin/cabal-plan 211 | cabal-plan --version 212 | - name: install cabal-docspec 213 | run: | 214 | mkdir -p $HOME/.cabal/bin 215 | curl -sL https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20240703/cabal-docspec-0.0.0.20240703-x86_64-linux.xz > cabal-docspec.xz 216 | echo '48bf3b7fd2f7f0caa6162afee57a755be8523e7f467b694900eb420f5f9a7b76 cabal-docspec.xz' | sha256sum -c - 217 | xz -d < cabal-docspec.xz > $HOME/.cabal/bin/cabal-docspec 218 | rm -f cabal-docspec.xz 219 | chmod a+x $HOME/.cabal/bin/cabal-docspec 220 | cabal-docspec --version 221 | - name: checkout 222 | uses: actions/checkout@v4 223 | with: 224 | path: source 225 | - name: initial cabal.project for sdist 226 | run: | 227 | touch cabal.project 228 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 229 | cat cabal.project 230 | - name: sdist 231 | run: | 232 | mkdir -p sdist 233 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 234 | - name: unpack 235 | run: | 236 | mkdir -p unpacked 237 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 238 | - name: generate cabal.project 239 | run: | 240 | PKGDIR_heaps="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/heaps-[0-9.]*')" 241 | echo "PKGDIR_heaps=${PKGDIR_heaps}" >> "$GITHUB_ENV" 242 | rm -f cabal.project cabal.project.local 243 | touch cabal.project 244 | touch cabal.project.local 245 | echo "packages: ${PKGDIR_heaps}" >> cabal.project 246 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package heaps" >> cabal.project ; fi 247 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi 248 | cat >> cabal.project <> cabal.project 252 | fi 253 | $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(heaps)$/; }' >> cabal.project.local 254 | cat cabal.project 255 | cat cabal.project.local 256 | - name: dump install plan 257 | run: | 258 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 259 | cabal-plan 260 | - name: restore cache 261 | uses: actions/cache/restore@v4 262 | with: 263 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 264 | path: ~/.cabal/store 265 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 266 | - name: install dependencies 267 | run: | 268 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 269 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 270 | - name: build 271 | run: | 272 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 273 | - name: docspec 274 | run: | 275 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all 276 | cabal-docspec $ARG_COMPILER 277 | - name: cabal check 278 | run: | 279 | cd ${PKGDIR_heaps} || false 280 | ${CABAL} -vnormal check 281 | - name: haddock 282 | run: | 283 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 284 | - name: save cache 285 | if: always() 286 | uses: actions/cache/save@v4 287 | with: 288 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 289 | path: ~/.cabal/store 290 | -------------------------------------------------------------------------------- /.github/workflows/hlint.yml: -------------------------------------------------------------------------------- 1 | name: HLint 2 | on: 3 | - push 4 | - pull_request 5 | jobs: 6 | hlint: 7 | runs-on: ubuntu-latest 8 | 9 | steps: 10 | - name: Checkout repository 11 | uses: actions/checkout@v4 12 | 13 | - name: 'Set up HLint' 14 | uses: haskell-actions/hlint-setup@v2 15 | with: 16 | version: '3.8' 17 | 18 | - name: 'Run HLint' 19 | uses: haskell-actions/hlint-run@v2 20 | with: 21 | path: src/ 22 | fail-on: suggestion 23 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | docs 4 | wiki 5 | TAGS 6 | tags 7 | wip 8 | .DS_Store 9 | .*.swp 10 | .*.swo 11 | *.o 12 | *.hi 13 | *~ 14 | *# 15 | .stack-work/ 16 | cabal-dev 17 | *.chi 18 | *.chs.h 19 | *.dyn_o 20 | *.dyn_hi 21 | .hpc 22 | .hsenv 23 | .cabal-sandbox/ 24 | cabal.sandbox.config 25 | *.prof 26 | *.aux 27 | *.hp 28 | *.eventlog 29 | cabal.project.local 30 | cabal.project.local~ 31 | .HTF/ 32 | .ghc.environment.* 33 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - arguments: [-XCPP, --cpp-define=HLINT, --cpp-ansi] 2 | 3 | - ignore: {name: Use infix} 4 | - ignore: {name: Use fmap} 5 | -------------------------------------------------------------------------------- /.vim.custom: -------------------------------------------------------------------------------- 1 | " Add the following to your .vimrc to automatically load this on startup 2 | 3 | " if filereadable(".vim.custom") 4 | " so .vim.custom 5 | " endif 6 | 7 | function StripTrailingWhitespace() 8 | let myline=line(".") 9 | let mycolumn = col(".") 10 | silent %s/ *$// 11 | call cursor(myline, mycolumn) 12 | endfunction 13 | 14 | " enable syntax highlighting 15 | syntax on 16 | 17 | " search for the tags file anywhere between here and / 18 | set tags=TAGS;/ 19 | 20 | " highlight tabs and trailing spaces 21 | set listchars=tab:‗‗,trail:‗ 22 | set list 23 | 24 | " f2 runs hasktags 25 | map :exec ":!hasktags -x -c --ignore src" 26 | 27 | " strip trailing whitespace before saving 28 | " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() 29 | 30 | " rebuild hasktags after saving 31 | au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" 32 | -------------------------------------------------------------------------------- /CHANGELOG.markdown: -------------------------------------------------------------------------------- 1 | 0.4.1 [2024.12.04] 2 | ------------------ 3 | * Drop support for pre-8.0 versions of GHC. 4 | 5 | 0.4 [2021.02.17] 6 | ---------------- 7 | * `heaps` now always exports a `null` function that is specialized to `Heap`, 8 | i.e., 9 | 10 | ```haskell 11 | null :: Heap a -> Bool 12 | ``` 13 | 14 | Previously, this specialized versions of `null` was only exported with GHC 15 | 7.8 or older, and for more recent GHCs, the `Data.Foldable` version was 16 | exported instead. The exported API is now uniform across all supported 17 | versions of GHC. 18 | * Export `adjustMin`. 19 | 20 | 0.3.6.1 [2019.02.05] 21 | -------------------- 22 | * Change to `build-type: Simple`, and drop the `doctests` test suite. This was 23 | done in an effort to make `heaps`' dependency footprint as minimal as 24 | possible, since `heaps` is used to bootstrap `shake`. 25 | * Fix the Haddocks for `span`. 26 | 27 | 0.3.6 [2018.01.18] 28 | ------------------ 29 | * Add `Semigroup` instance for `Heap`. 30 | 31 | 0.3.5 32 | ----- 33 | * Support `doctest-0.12` 34 | 35 | 0.3.4.1 36 | ------- 37 | * Fix a typo in the `doctests` for `mapMonotonic` 38 | 39 | 0.3.4 40 | ----- 41 | * Add `Bifunctor Entry` instance 42 | * Revamp `Setup.hs` to use `cabal-doctest`. This makes it build 43 | with `Cabal-2.0`, and makes the `doctest`s work with `cabal new-build` and 44 | sandboxes. 45 | 46 | 0.3.3 47 | ----- 48 | * Remove redundant constraints 49 | * Build warning-free on GHC 8.0-rc1 50 | 51 | 0.3.2.1 52 | ------- 53 | * Haddock fix 54 | 55 | 0.3.2 56 | ----- 57 | * Build without warnings on GHC 7.10 58 | * Overload Foldable `null` and `length` on GHC 7.10+ 59 | 60 | 0.3.1 61 | ----- 62 | * Explicit nominal role annotation 63 | 64 | 0.3.0.1 65 | ------- 66 | * Nicer formatting of the haddocks 67 | 68 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010-2015, Edward Kmett 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 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Edward Kmett nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | heaps 2 | ====== 3 | 4 | [![Hackage](https://img.shields.io/hackage/v/heaps.svg)](https://hackage.haskell.org/package/heaps) [![Build Status](https://github.com/ekmett/heaps/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/heaps/actions?query=workflow%3AHaskell-CI) 5 | 6 | This package provides Brodal/Okasaki heaps. These are asymptotically optimal purely functional heaps. 7 | 8 | Contact Information 9 | ------------------- 10 | 11 | Contributions and bug reports are welcome! 12 | 13 | Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. 14 | 15 | -Edward Kmett 16 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | no-tests-no-benchmarks: False 2 | unconstrained: False 3 | docspec: True 4 | -- irc-channels: irc.freenode.org#haskell-lens 5 | irc-if-in-origin-repo: True 6 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /heaps.cabal: -------------------------------------------------------------------------------- 1 | name: heaps 2 | version: 0.4.1 3 | license: BSD3 4 | license-file: LICENSE 5 | author: Edward A. Kmett 6 | maintainer: Edward A. Kmett 7 | stability: experimental 8 | homepage: http://github.com/ekmett/heaps/ 9 | bug-reports: http://github.com/ekmett/heaps/issues 10 | category: Data Structures 11 | synopsis: Asymptotically optimal Brodal/Okasaki heaps. 12 | description: Asymptotically optimal Brodal\/Okasaki bootstrapped skew-binomial heaps from the paper , extended with a 'Foldable' interface. 13 | copyright: (c) 2010-2015 Edward A. Kmett 14 | tested-with: GHC == 8.0.2 15 | , GHC == 8.2.2 16 | , GHC == 8.4.4 17 | , GHC == 8.6.5 18 | , GHC == 8.8.4 19 | , GHC == 8.10.4 20 | , GHC == 9.0.2 21 | , GHC == 9.2.8 22 | , GHC == 9.4.8 23 | , GHC == 9.6.6 24 | , GHC == 9.8.4 25 | , GHC == 9.10.1 26 | , GHC == 9.12.1 27 | build-type: Simple 28 | cabal-version: >=1.10 29 | extra-source-files: 30 | .gitignore 31 | .hlint.yaml 32 | CHANGELOG.markdown 33 | README.markdown 34 | 35 | source-repository head 36 | type: git 37 | location: git://github.com/ekmett/heaps.git 38 | 39 | library 40 | exposed-modules: Data.Heap 41 | build-depends: 42 | base >= 4.9 && < 6 43 | hs-source-dirs: src 44 | ghc-options: -O2 -Wall 45 | default-language: Haskell2010 46 | -------------------------------------------------------------------------------- /src/Data/Heap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE RoleAnnotations #-} 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Copyright : (c) Edward Kmett 2010-2015 7 | -- License : BSD-style 8 | -- Maintainer : ekmett@gmail.com 9 | -- Stability : experimental 10 | -- Portability : portable 11 | -- 12 | -- An efficient, asymptotically optimal, implementation of a priority queues 13 | -- extended with support for efficient size, and `Data.Foldable` 14 | -- 15 | -- /Note/: Since many function names (but not the type name) clash with 16 | -- "Prelude" names, this module is usually imported @qualified@, e.g. 17 | -- 18 | -- > import Data.Heap (Heap) 19 | -- > import qualified Data.Heap as Heap 20 | -- 21 | -- The implementation of 'Heap' is based on /bootstrapped skew binomial heaps/ 22 | -- as described by: 23 | -- 24 | -- * G. Brodal and C. Okasaki , , 25 | -- /Journal of Functional Programming/ 6:839-857 (1996) 26 | -- 27 | -- All time bounds are worst-case. 28 | ----------------------------------------------------------------------------- 29 | 30 | module Data.Heap 31 | ( 32 | -- * Heap Type 33 | Heap -- instance Eq,Ord,Show,Read,Data 34 | -- * Entry type 35 | , Entry(..) -- instance Eq,Ord,Show,Read,Data 36 | -- * Basic functions 37 | , empty -- O(1) :: Heap a 38 | , null -- O(1) :: Heap a -> Bool 39 | , size -- O(1) :: Heap a -> Int 40 | , singleton -- O(1) :: Ord a => a -> Heap a 41 | , insert -- O(1) :: Ord a => a -> Heap a -> Heap a 42 | , minimum -- O(1) (/partial/) :: Ord a => Heap a -> a 43 | , deleteMin -- O(log n) :: Heap a -> Heap a 44 | , adjustMin -- O(log n) :: (a -> a) -> Heap a -> Heap a 45 | , union -- O(1) :: Heap a -> Heap a -> Heap a 46 | , uncons, viewMin -- O(1)\/O(log n) :: Heap a -> Maybe (a, Heap a) 47 | -- * Transformations 48 | , mapMonotonic -- O(n) :: Ord b => (a -> b) -> Heap a -> Heap b 49 | , map -- O(n) :: Ord b => (a -> b) -> Heap a -> Heap b 50 | -- * To/From Lists 51 | , toUnsortedList -- O(n) :: Heap a -> [a] 52 | , fromList -- O(n) :: Ord a => [a] -> Heap a 53 | , sort -- O(n log n) :: Ord a => [a] -> [a] 54 | , traverse -- O(n log n) :: (Applicative t, Ord b) => (a -> t b) -> Heap a -> t (Heap b) 55 | , mapM -- O(n log n) :: (Monad m, Ord b) => (a -> m b) -> Heap a -> m (Heap b) 56 | , concatMap -- O(n) :: Ord b => Heap a -> (a -> Heap b) -> Heap b 57 | -- * Filtering 58 | , filter -- O(n) :: (a -> Bool) -> Heap a -> Heap a 59 | , partition -- O(n) :: (a -> Bool) -> Heap a -> (Heap a, Heap a) 60 | , split -- O(n) :: a -> Heap a -> (Heap a, Heap a, Heap a) 61 | , break -- O(n log n) :: (a -> Bool) -> Heap a -> (Heap a, Heap a) 62 | , span -- O(n log n) :: (a -> Bool) -> Heap a -> (Heap a, Heap a) 63 | , take -- O(n log n) :: Int -> Heap a -> Heap a 64 | , drop -- O(n log n) :: Int -> Heap a -> Heap a 65 | , splitAt -- O(n log n) :: Int -> Heap a -> (Heap a, Heap a) 66 | , takeWhile -- O(n log n) :: (a -> Bool) -> Heap a -> Heap a 67 | , dropWhile -- O(n log n) :: (a -> Bool) -> Heap a -> Heap a 68 | -- * Grouping 69 | , group -- O(n log n) :: Heap a -> Heap (Heap a) 70 | , groupBy -- O(n log n) :: (a -> a -> Bool) -> Heap a -> Heap (Heap a) 71 | , nub -- O(n log n) :: Heap a -> Heap a 72 | -- * Intersection 73 | , intersect -- O(n log n + m log m) :: Heap a -> Heap a -> Heap a 74 | , intersectWith -- O(n log n + m log m) :: Ord b => (a -> a -> b) -> Heap a -> Heap a -> Heap b 75 | -- * Duplication 76 | , replicate -- O(log n) :: Ord a => a -> Int -> Heap a 77 | ) where 78 | 79 | import Prelude hiding 80 | ( map 81 | , span, dropWhile, takeWhile, break, filter, take, drop, splitAt 82 | , foldr, minimum, replicate, mapM 83 | , concatMap, null 84 | , traverse 85 | ) 86 | import Control.Monad (liftM) 87 | import Data.Bifunctor 88 | import Data.Data (DataType, Constr, mkConstr, mkDataType, Fixity(Prefix), Data(..), constrIndex) 89 | import qualified Data.Foldable as F 90 | import Data.Function (on) 91 | import qualified Data.List as L 92 | import qualified Data.Traversable as T 93 | import Text.Read 94 | 95 | #if !(MIN_VERSION_base(4,11,0)) 96 | import Data.Semigroup (Semigroup(..)) 97 | #endif 98 | 99 | -- $setup 100 | -- >>> let break = Data.Heap.break 101 | -- >>> let concatMap = Data.Heap.concatMap 102 | -- >>> let dropWhile = Data.Heap.dropWhile 103 | -- >>> let filter = Data.Heap.filter 104 | -- >>> let minimum = Data.Heap.minimum 105 | -- >>> let null = Data.Heap.null 106 | -- >>> let span = Data.Heap.span 107 | -- >>> let take = Data.Heap.take 108 | -- >>> let takeWhile = Data.Heap.takeWhile 109 | -- 110 | -- -- GHC 7.0 and 7.2 will default the `Ord` constraints to () in the types of 111 | -- -- the following functions unless we give them explicit type signatures. 112 | -- >>> let { map :: Ord b => (a -> b) -> Heap a -> Heap b; map = Data.Heap.map } 113 | -- >>> let { replicate :: Ord a => a -> Int -> Heap a ; replicate = Data.Heap.replicate } 114 | 115 | -- The implementation of 'Heap' must internally hold onto the dictionary entry for ('<='), 116 | -- so that it can be made 'Foldable'. Confluence in the absence of incoherent instances 117 | -- is provided by the fact that we only ever build these from instances of 'Ord' a (except in the case of 'groupBy') 118 | 119 | 120 | -- | A min-heap of values of type @a@. 121 | data Heap a 122 | = Empty 123 | | Heap {-# UNPACK #-} !Int (a -> a -> Bool) !(Tree a) 124 | type role Heap nominal 125 | 126 | instance Show a => Show (Heap a) where 127 | showsPrec _ Empty = showString "fromList []" 128 | showsPrec d (Heap _ _ t) = showParen (d > 10) $ 129 | showString "fromList " . showsPrec 11 (F.toList t) 130 | 131 | instance (Ord a, Read a) => Read (Heap a) where 132 | readPrec = parens $ prec 10 $ do 133 | Ident "fromList" <- lexP 134 | fromList `fmap` step readPrec 135 | 136 | instance (Ord a, Data a) => Data (Heap a) where 137 | gfoldl k z h = z fromList `k` toUnsortedList h 138 | toConstr _ = fromListConstr 139 | dataTypeOf _ = heapDataType 140 | gunfold k z c = case constrIndex c of 141 | 1 -> k (z fromList) 142 | _ -> error "gunfold" 143 | 144 | heapDataType :: DataType 145 | heapDataType = mkDataType "Data.Heap.Heap" [fromListConstr] 146 | 147 | fromListConstr :: Constr 148 | fromListConstr = mkConstr heapDataType "fromList" [] Prefix 149 | 150 | instance Eq (Heap a) where 151 | Empty == Empty = True 152 | Empty == Heap{} = False 153 | Heap{} == Empty = False 154 | a@(Heap s1 leq _) == b@(Heap s2 _ _) = s1 == s2 && go leq (F.toList a) (F.toList b) 155 | where 156 | go f (x:xs) (y:ys) = f x y && f y x && go f xs ys 157 | go _ [] [] = True 158 | go _ _ _ = False 159 | 160 | instance Ord (Heap a) where 161 | Empty `compare` Empty = EQ 162 | Empty `compare` Heap{} = LT 163 | Heap{} `compare` Empty = GT 164 | a@(Heap _ leq _) `compare` b = go leq (F.toList a) (F.toList b) 165 | where 166 | go f (x:xs) (y:ys) = 167 | if f x y 168 | then if f y x 169 | then go f xs ys 170 | else LT 171 | else GT 172 | go _ [] [] = EQ 173 | go _ [] (_:_) = LT 174 | go _ (_:_) [] = GT 175 | 176 | 177 | 178 | -- | /O(1)/. The empty heap 179 | -- 180 | -- @'empty' ≡ 'fromList' []@ 181 | -- 182 | -- >>> size empty 183 | -- 0 184 | empty :: Heap a 185 | empty = Empty 186 | {-# INLINE empty #-} 187 | 188 | -- | /O(1)/. A heap with a single element 189 | -- 190 | -- @ 191 | -- 'singleton' x ≡ 'fromList' [x] 192 | -- 'singleton' x ≡ 'insert' x 'empty' 193 | -- @ 194 | -- 195 | -- >>> size (singleton "hello") 196 | -- 1 197 | singleton :: Ord a => a -> Heap a 198 | singleton = singletonWith (<=) 199 | {-# INLINE singleton #-} 200 | 201 | singletonWith :: (a -> a -> Bool) -> a -> Heap a 202 | singletonWith f a = Heap 1 f (Node 0 a Nil) 203 | {-# INLINE singletonWith #-} 204 | 205 | -- | /O(1)/. Insert a new value into the heap. 206 | -- 207 | -- >>> insert 2 (fromList [1,3]) 208 | -- fromList [1,2,3] 209 | -- 210 | -- @ 211 | -- 'insert' x 'empty' ≡ 'singleton' x 212 | -- 'size' ('insert' x xs) ≡ 1 + 'size' xs 213 | -- @ 214 | insert :: Ord a => a -> Heap a -> Heap a 215 | insert = insertWith (<=) 216 | {-# INLINE insert #-} 217 | 218 | insertWith :: (a -> a -> Bool) -> a -> Heap a -> Heap a 219 | insertWith leq x Empty = singletonWith leq x 220 | insertWith leq x (Heap s _ t@(Node _ y f)) 221 | | leq x y = Heap (s+1) leq (Node 0 x (t `Cons` Nil)) 222 | | otherwise = Heap (s+1) leq (Node 0 y (skewInsert leq (Node 0 x Nil) f)) 223 | {-# INLINE insertWith #-} 224 | 225 | -- | /O(1)/. Meld the values from two heaps into one heap. 226 | -- 227 | -- >>> union (fromList [1,3,5]) (fromList [6,4,2]) 228 | -- fromList [1,2,6,4,3,5] 229 | -- >>> union (fromList [1,1,1]) (fromList [1,2,1]) 230 | -- fromList [1,1,1,2,1,1] 231 | union :: Heap a -> Heap a -> Heap a 232 | union Empty q = q 233 | union q Empty = q 234 | union (Heap s1 leq t1@(Node _ x1 f1)) (Heap s2 _ t2@(Node _ x2 f2)) 235 | | leq x1 x2 = Heap (s1 + s2) leq (Node 0 x1 (skewInsert leq t2 f1)) 236 | | otherwise = Heap (s1 + s2) leq (Node 0 x2 (skewInsert leq t1 f2)) 237 | {-# INLINE union #-} 238 | 239 | -- | /O(log n)/. Create a heap consisting of multiple copies of the same value. 240 | -- 241 | -- >>> replicate 'a' 10 242 | -- fromList "aaaaaaaaaa" 243 | replicate :: Ord a => a -> Int -> Heap a 244 | replicate x0 y0 245 | | y0 < 0 = error "Heap.replicate: negative length" 246 | | y0 == 0 = mempty 247 | | otherwise = f (singleton x0) y0 248 | where 249 | f x y 250 | | even y = f (union x x) (quot y 2) 251 | | y == 1 = x 252 | | otherwise = g (union x x) (quot (y - 1) 2) x 253 | g x y z 254 | | even y = g (union x x) (quot y 2) z 255 | | y == 1 = union x z 256 | | otherwise = g (union x x) (quot (y - 1) 2) (union x z) 257 | {-# INLINE replicate #-} 258 | 259 | -- | Provides both /O(1)/ access to the minimum element and /O(log n)/ access to the remainder of the heap. 260 | -- This is the same operation as 'viewMin' 261 | -- 262 | -- >>> uncons (fromList [2,1,3]) 263 | -- Just (1,fromList [2,3]) 264 | uncons :: Heap a -> Maybe (a, Heap a) 265 | uncons Empty = Nothing 266 | uncons l@(Heap _ _ t) = Just (root t, deleteMin l) 267 | {-# INLINE uncons #-} 268 | 269 | -- | Same as 'uncons' 270 | viewMin :: Heap a -> Maybe (a, Heap a) 271 | viewMin = uncons 272 | {-# INLINE viewMin #-} 273 | 274 | -- | /O(1)/. Assumes the argument is a non-'null' heap. 275 | -- 276 | -- >>> minimum (fromList [3,1,2]) 277 | -- 1 278 | minimum :: Heap a -> a 279 | minimum Empty = error "Heap.minimum: empty heap" 280 | minimum (Heap _ _ t) = root t 281 | {-# INLINE minimum #-} 282 | 283 | trees :: Forest a -> [Tree a] 284 | trees (a `Cons` as) = a : trees as 285 | trees Nil = [] 286 | 287 | -- | /O(log n)/. Delete the minimum key from the heap and return the resulting heap. 288 | -- 289 | -- >>> deleteMin (fromList [3,1,2]) 290 | -- fromList [2,3] 291 | deleteMin :: Heap a -> Heap a 292 | deleteMin Empty = Empty 293 | deleteMin (Heap _ _ (Node _ _ Nil)) = Empty 294 | deleteMin (Heap s leq (Node _ _ f0)) = Heap (s - 1) leq (Node 0 x f3) 295 | where 296 | (Node r x cf, ts2) = getMin leq f0 297 | (zs, ts1, f1) = splitForest r Nil Nil cf 298 | f2 = skewMeld leq (skewMeld leq ts1 ts2) f1 299 | f3 = F.foldr (skewInsert leq) f2 (trees zs) 300 | {-# INLINE deleteMin #-} 301 | 302 | -- | /O(log n)/. Adjust the minimum key in the heap and return the resulting heap. 303 | -- 304 | -- >>> adjustMin (+1) (fromList [1,2,3]) 305 | -- fromList [2,2,3] 306 | adjustMin :: (a -> a) -> Heap a -> Heap a 307 | adjustMin _ Empty = Empty 308 | adjustMin f (Heap s leq (Node r x xs)) = Heap s leq (heapify leq (Node r (f x) xs)) 309 | {-# INLINE adjustMin #-} 310 | 311 | type ForestZipper a = (Forest a, Forest a) 312 | 313 | zipper :: Forest a -> ForestZipper a 314 | zipper xs = (Nil, xs) 315 | {-# INLINE zipper #-} 316 | 317 | emptyZ :: ForestZipper a 318 | emptyZ = (Nil, Nil) 319 | {-# INLINE emptyZ #-} 320 | 321 | -- leftZ :: ForestZipper a -> ForestZipper a 322 | -- leftZ (x :> path, xs) = (path, x :> xs) 323 | 324 | rightZ :: ForestZipper a -> ForestZipper a 325 | rightZ (path, x `Cons` xs) = (x `Cons` path, xs) 326 | rightZ _ = error "Heap.rightZ: empty zipper" 327 | {-# INLINE rightZ #-} 328 | 329 | -- adjustZ :: (Tree a -> Tree a) -> ForestZipper a -> ForestZipper a 330 | -- adjustZ f (path, x `Cons` xs) = (path, f x `Cons` xs) 331 | -- adjustZ _ z = z 332 | -- {-# INLINE adjustZ #-} 333 | 334 | rezip :: ForestZipper a -> Forest a 335 | rezip (Nil, xs) = xs 336 | rezip (x `Cons` path, xs) = rezip (path, x `Cons` xs) 337 | 338 | -- assumes non-empty zipper 339 | rootZ :: ForestZipper a -> a 340 | rootZ (_ , x `Cons` _) = root x 341 | rootZ _ = error "Heap.rootZ: empty zipper" 342 | {-# INLINE rootZ #-} 343 | 344 | minZ :: (a -> a -> Bool) -> Forest a -> ForestZipper a 345 | minZ _ Nil = emptyZ 346 | minZ f xs = minZ' f z z 347 | where z = zipper xs 348 | {-# INLINE minZ #-} 349 | 350 | minZ' :: (a -> a -> Bool) -> ForestZipper a -> ForestZipper a -> ForestZipper a 351 | minZ' _ lo (_, Nil) = lo 352 | minZ' leq lo z = minZ' leq (if leq (rootZ lo) (rootZ z) then lo else z) (rightZ z) 353 | 354 | heapify :: (a -> a -> Bool) -> Tree a -> Tree a 355 | heapify _ n@(Node _ _ Nil) = n 356 | heapify leq n@(Node r a as) 357 | | leq a a' = n 358 | | otherwise = Node r a' (rezip (left, heapify leq (Node r' a as') `Cons` right)) 359 | where 360 | -- (left, Node r' a' as' `Cons` right) = minZ leq as 361 | (left, r', a', as', right) = case minZ leq as of 362 | (left', Node r'' a'' as'' `Cons` right') -> (left', r'', a'', as'', right') 363 | _ -> error "Heap.heapify: empty zipper" 364 | 365 | 366 | -- | /O(n)/. Build a heap from a list of values. 367 | -- 368 | -- @ 369 | -- 'fromList' '.' 'toList' ≡ 'id' 370 | -- 'toList' '.' 'fromList' ≡ 'sort' 371 | -- @ 372 | 373 | -- >>> size (fromList [1,5,3]) 374 | -- 3 375 | fromList :: Ord a => [a] -> Heap a 376 | fromList = F.foldr insert mempty 377 | {-# INLINE fromList #-} 378 | 379 | fromListWith :: (a -> a -> Bool) -> [a] -> Heap a 380 | fromListWith f = F.foldr (insertWith f) mempty 381 | {-# INLINE fromListWith #-} 382 | 383 | -- | /O(n log n)/. Perform a heap sort 384 | sort :: Ord a => [a] -> [a] 385 | sort = F.toList . fromList 386 | {-# INLINE sort #-} 387 | 388 | instance Semigroup (Heap a) where 389 | (<>) = union 390 | {-# INLINE (<>) #-} 391 | 392 | instance Monoid (Heap a) where 393 | mempty = empty 394 | {-# INLINE mempty #-} 395 | #if !(MIN_VERSION_base(4,11,0)) 396 | mappend = union 397 | {-# INLINE mappend #-} 398 | #endif 399 | 400 | -- | /O(n)/. Returns the elements in the heap in some arbitrary, very likely unsorted, order. 401 | -- 402 | -- >>> toUnsortedList (fromList [3,1,2]) 403 | -- [1,3,2] 404 | -- 405 | -- @'fromList' '.' 'toUnsortedList' ≡ 'id'@ 406 | toUnsortedList :: Heap a -> [a] 407 | toUnsortedList Empty = [] 408 | toUnsortedList (Heap _ _ t) = F.foldMap return t 409 | {-# INLINE toUnsortedList #-} 410 | 411 | instance Foldable Heap where 412 | foldMap _ Empty = mempty 413 | foldMap f l@(Heap _ _ t) = f (root t) `mappend` F.foldMap f (deleteMin l) 414 | null = null 415 | length = size 416 | 417 | -- | /O(1)/. Is the heap empty? 418 | -- 419 | -- >>> null empty 420 | -- True 421 | -- 422 | -- >>> null (singleton "hello") 423 | -- False 424 | null :: Heap a -> Bool 425 | null Empty = True 426 | null _ = False 427 | {-# INLINE null #-} 428 | 429 | -- | /O(1)/. The number of elements in the heap. 430 | -- 431 | -- >>> size empty 432 | -- 0 433 | -- >>> size (singleton "hello") 434 | -- 1 435 | -- >>> size (fromList [4,1,2]) 436 | -- 3 437 | size :: Heap a -> Int 438 | size Empty = 0 439 | size (Heap s _ _) = s 440 | {-# INLINE size #-} 441 | 442 | -- | /O(n)/. Map a function over the heap, returning a new heap ordered appropriately for its fresh contents 443 | -- 444 | -- >>> map negate (fromList [3,1,2]) 445 | -- fromList [-3,-1,-2] 446 | map :: Ord b => (a -> b) -> Heap a -> Heap b 447 | map _ Empty = Empty 448 | map f (Heap _ _ t) = F.foldMap (singleton . f) t 449 | {-# INLINE map #-} 450 | 451 | -- | /O(n)/. Map a monotone increasing function over the heap. 452 | -- Provides a better constant factor for performance than 'map', but no checking is performed that the function provided is monotone increasing. Misuse of this function can cause a Heap to violate the heap property. 453 | -- 454 | -- >>> mapMonotonic (+1) (fromList [1,2,3]) 455 | -- fromList [2,3,4] 456 | -- >>> mapMonotonic (*2) (fromList [1,2,3]) 457 | -- fromList [2,4,6] 458 | mapMonotonic :: Ord b => (a -> b) -> Heap a -> Heap b 459 | mapMonotonic _ Empty = Empty 460 | mapMonotonic f (Heap s _ t) = Heap s (<=) (fmap f t) 461 | {-# INLINE mapMonotonic #-} 462 | 463 | -- * Filter 464 | 465 | -- | /O(n)/. Filter the heap, retaining only values that satisfy the predicate. 466 | -- 467 | -- >>> filter (>'a') (fromList "ab") 468 | -- fromList "b" 469 | -- >>> filter (>'x') (fromList "ab") 470 | -- fromList [] 471 | -- >>> filter (<'a') (fromList "ab") 472 | -- fromList [] 473 | filter :: (a -> Bool) -> Heap a -> Heap a 474 | filter _ Empty = Empty 475 | filter p (Heap _ leq t) = F.foldMap f t 476 | where 477 | f x | p x = singletonWith leq x 478 | | otherwise = Empty 479 | {-# INLINE filter #-} 480 | 481 | -- | /O(n)/. Partition the heap according to a predicate. The first heap contains all elements that satisfy the predicate, the second all elements that fail the predicate. See also 'split'. 482 | -- 483 | -- >>> partition (>'a') (fromList "ab") 484 | -- (fromList "b",fromList "a") 485 | partition :: (a -> Bool) -> Heap a -> (Heap a, Heap a) 486 | partition _ Empty = (Empty, Empty) 487 | partition p (Heap _ leq t) = F.foldMap f t 488 | where 489 | f x | p x = (singletonWith leq x, mempty) 490 | | otherwise = (mempty, singletonWith leq x) 491 | {-# INLINE partition #-} 492 | 493 | -- | /O(n)/. Partition the heap into heaps of the elements that are less than, equal to, and greater than a given value. 494 | -- 495 | -- >>> split 'h' (fromList "hello") 496 | -- (fromList "e",fromList "h",fromList "llo") 497 | split :: a -> Heap a -> (Heap a, Heap a, Heap a) 498 | split _ Empty = (Empty, Empty, Empty) 499 | split a (Heap _ leq t) = F.foldMap f t 500 | where 501 | f x = if leq x a 502 | then if leq a x 503 | then (mempty, singletonWith leq x, mempty) 504 | else (singletonWith leq x, mempty, mempty) 505 | else (mempty, mempty, singletonWith leq x) 506 | {-# INLINE split #-} 507 | 508 | -- * Subranges 509 | 510 | -- | /O(n log n)/. Return a heap consisting of the least @n@ elements of a given heap. 511 | -- 512 | -- >>> take 3 (fromList [10,2,4,1,9,8,2]) 513 | -- fromList [1,2,2] 514 | take :: Int -> Heap a -> Heap a 515 | take = withList . L.take 516 | {-# INLINE take #-} 517 | 518 | -- | /O(n log n)/. Return a heap consisting of all members of given heap except for the @n@ least elements. 519 | drop :: Int -> Heap a -> Heap a 520 | drop = withList . L.drop 521 | {-# INLINE drop #-} 522 | 523 | -- | /O(n log n)/. Split a heap into two heaps, the first containing the @n@ least elements, the latter consisting of all members of the heap except for those elements. 524 | splitAt :: Int -> Heap a -> (Heap a, Heap a) 525 | splitAt = splitWithList . L.splitAt 526 | {-# INLINE splitAt #-} 527 | 528 | -- | /O(n log n)/. 'break' applied to a predicate @p@ and a heap @xs@ returns a tuple where the first element is a heap consisting of the 529 | -- longest prefix the least elements of @xs@ that /do not satisfy/ p and the second element is the remainder of the elements in the heap. 530 | -- 531 | -- >>> break (\x -> x `mod` 4 == 0) (fromList [3,5,7,12,13,16]) 532 | -- (fromList [3,5,7],fromList [12,13,16]) 533 | -- 534 | -- 'break' @p@ is equivalent to @'span' ('not' . p)@. 535 | break :: (a -> Bool) -> Heap a -> (Heap a, Heap a) 536 | break = splitWithList . L.break 537 | {-# INLINE break #-} 538 | 539 | -- | /O(n log n)/. 'span' applied to a predicate @p@ and a heap @xs@ returns a tuple where the first element is a heap consisting of the 540 | -- longest prefix the least elements of xs that satisfy @p@ and the second element is the remainder of the elements in the heap. 541 | -- 542 | -- >>> span (\x -> x `mod` 4 == 0) (fromList [4,8,12,14,16]) 543 | -- (fromList [4,8,12],fromList [14,16]) 544 | -- 545 | -- 'span' @p xs@ is equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@ 546 | 547 | span :: (a -> Bool) -> Heap a -> (Heap a, Heap a) 548 | span = splitWithList . L.span 549 | {-# INLINE span #-} 550 | 551 | -- | /O(n log n)/. 'takeWhile' applied to a predicate @p@ and a heap @xs@ returns a heap consisting of the 552 | -- longest prefix the least elements of @xs@ that satisfy @p@. 553 | -- 554 | -- >>> takeWhile (\x -> x `mod` 4 == 0) (fromList [4,8,12,14,16]) 555 | -- fromList [4,8,12] 556 | takeWhile :: (a -> Bool) -> Heap a -> Heap a 557 | takeWhile = withList . L.takeWhile 558 | {-# INLINE takeWhile #-} 559 | 560 | -- | /O(n log n)/. 'dropWhile' @p xs@ returns the suffix of the heap remaining after 'takeWhile' @p xs@. 561 | -- 562 | -- >>> dropWhile (\x -> x `mod` 4 == 0) (fromList [4,8,12,14,16]) 563 | -- fromList [14,16] 564 | dropWhile :: (a -> Bool) -> Heap a -> Heap a 565 | dropWhile = withList . L.dropWhile 566 | {-# INLINE dropWhile #-} 567 | 568 | -- | /O(n log n)/. Remove duplicate entries from the heap. 569 | -- 570 | -- >>> nub (fromList [1,1,2,6,6]) 571 | -- fromList [1,2,6] 572 | nub :: Heap a -> Heap a 573 | nub Empty = Empty 574 | nub h@(Heap _ leq t) = insertWith leq x (nub zs) 575 | where 576 | x = root t 577 | xs = deleteMin h 578 | zs = dropWhile (`leq` x) xs 579 | {-# INLINE nub #-} 580 | 581 | -- | /O(n)/. Construct heaps from each element in another heap, and union them together. 582 | -- 583 | -- >>> concatMap (\a -> fromList [a,a+1]) (fromList [1,4]) 584 | -- fromList [1,4,5,2] 585 | concatMap :: (a -> Heap b) -> Heap a -> Heap b 586 | concatMap _ Empty = Empty 587 | concatMap f (Heap _ _ t) = F.foldMap f t 588 | {-# INLINE concatMap #-} 589 | 590 | -- | /O(n log n)/. Group a heap into a heap of heaps, by unioning together duplicates. 591 | -- 592 | -- >>> group (fromList "hello") 593 | -- fromList [fromList "e",fromList "h",fromList "ll",fromList "o"] 594 | group :: Heap a -> Heap (Heap a) 595 | group Empty = Empty 596 | group h@(Heap _ leq _) = groupBy (flip leq) h 597 | {-# INLINE group #-} 598 | 599 | -- | /O(n log n)/. Group using a user supplied function. 600 | groupBy :: (a -> a -> Bool) -> Heap a -> Heap (Heap a) 601 | groupBy _ Empty = Empty 602 | groupBy f h@(Heap _ leq t) = insert (insertWith leq x ys) (groupBy f zs) 603 | where 604 | x = root t 605 | xs = deleteMin h 606 | (ys,zs) = span (f x) xs 607 | {-# INLINE groupBy #-} 608 | 609 | -- | /O(n log n + m log m)/. Intersect the values in two heaps, returning the value in the left heap that compares as equal 610 | intersect :: Heap a -> Heap a -> Heap a 611 | intersect Empty _ = Empty 612 | intersect _ Empty = Empty 613 | intersect a@(Heap _ leq _) b = go leq (F.toList a) (F.toList b) 614 | where 615 | go leq' xxs@(x:xs) yys@(y:ys) = 616 | if leq' x y 617 | then if leq' y x 618 | then insertWith leq' x (go leq' xs ys) 619 | else go leq' xs yys 620 | else go leq' xxs ys 621 | go _ [] _ = empty 622 | go _ _ [] = empty 623 | {-# INLINE intersect #-} 624 | 625 | -- | /O(n log n + m log m)/. Intersect the values in two heaps using a function to generate the elements in the right heap. 626 | intersectWith :: Ord b => (a -> a -> b) -> Heap a -> Heap a -> Heap b 627 | intersectWith _ Empty _ = Empty 628 | intersectWith _ _ Empty = Empty 629 | intersectWith f a@(Heap _ leq _) b = go leq f (F.toList a) (F.toList b) 630 | where 631 | go :: Ord b => (a -> a -> Bool) -> (a -> a -> b) -> [a] -> [a] -> Heap b 632 | go leq' f' xxs@(x:xs) yys@(y:ys) 633 | | leq' x y = 634 | if leq' y x 635 | then insert (f' x y) (go leq' f' xs ys) 636 | else go leq' f' xs yys 637 | | otherwise = go leq' f' xxs ys 638 | go _ _ [] _ = empty 639 | go _ _ _ [] = empty 640 | {-# INLINE intersectWith #-} 641 | 642 | -- | /O(n log n)/. Traverse the elements of the heap in sorted order and produce a new heap using 'Applicative' side-effects. 643 | traverse :: (Applicative t, Ord b) => (a -> t b) -> Heap a -> t (Heap b) 644 | traverse f = fmap fromList . T.traverse f . F.toList 645 | {-# INLINE traverse #-} 646 | 647 | -- | /O(n log n)/. Traverse the elements of the heap in sorted order and produce a new heap using 'Monad'ic side-effects. 648 | mapM :: (Monad m, Ord b) => (a -> m b) -> Heap a -> m (Heap b) 649 | mapM f = liftM fromList . T.mapM f . F.toList 650 | {-# INLINE mapM #-} 651 | 652 | both :: (a -> b) -> (a, a) -> (b, b) 653 | both f (a,b) = (f a, f b) 654 | {-# INLINE both #-} 655 | 656 | -- we hold onto the children counts in the nodes for /O(1)/ 'size' 657 | data Tree a = Node 658 | { rank :: {-# UNPACK #-} !Int 659 | , root :: a 660 | , _forest :: !(Forest a) 661 | } deriving (Show,Read) 662 | 663 | data Forest a = !(Tree a) `Cons` !(Forest a) | Nil 664 | deriving (Show,Read) 665 | infixr 5 `Cons` 666 | 667 | instance Functor Tree where 668 | fmap f (Node r a as) = Node r (f a) (fmap f as) 669 | 670 | instance Functor Forest where 671 | fmap f (a `Cons` as) = fmap f a `Cons` fmap f as 672 | fmap _ Nil = Nil 673 | 674 | -- internal foldable instances that should only be used over commutative monoids 675 | instance Foldable Tree where 676 | foldMap f (Node _ a as) = f a `mappend` F.foldMap f as 677 | 678 | -- internal foldable instances that should only be used over commutative monoids 679 | instance Foldable Forest where 680 | foldMap f (a `Cons` as) = F.foldMap f a `mappend` F.foldMap f as 681 | foldMap _ Nil = mempty 682 | 683 | link :: (a -> a -> Bool) -> Tree a -> Tree a -> Tree a 684 | link f t1@(Node r1 x1 cf1) t2@(Node r2 x2 cf2) -- assumes r1 == r2 685 | | f x1 x2 = Node (r1+1) x1 (t2 `Cons` cf1) 686 | | otherwise = Node (r2+1) x2 (t1 `Cons` cf2) 687 | 688 | skewLink :: (a -> a -> Bool) -> Tree a -> Tree a -> Tree a -> Tree a 689 | skewLink f t0@(Node _ x0 cf0) t1@(Node r1 x1 cf1) t2@(Node r2 x2 cf2) 690 | | f x1 x0 && f x1 x2 = Node (r1+1) x1 (t0 `Cons` t2 `Cons` cf1) 691 | | f x2 x0 && f x2 x1 = Node (r2+1) x2 (t0 `Cons` t1 `Cons` cf2) 692 | | otherwise = Node (r1+1) x0 (t1 `Cons` t2 `Cons` cf0) 693 | 694 | ins :: (a -> a -> Bool) -> Tree a -> Forest a -> Forest a 695 | ins _ t Nil = t `Cons` Nil 696 | ins f t (t' `Cons` ts) -- assumes rank t <= rank t' 697 | | rank t < rank t' = t `Cons` t' `Cons` ts 698 | | otherwise = ins f (link f t t') ts 699 | 700 | uniqify :: (a -> a -> Bool) -> Forest a -> Forest a 701 | uniqify _ Nil = Nil 702 | uniqify f (t `Cons` ts) = ins f t ts 703 | 704 | unionUniq :: (a -> a -> Bool) -> Forest a -> Forest a -> Forest a 705 | unionUniq _ Nil ts = ts 706 | unionUniq _ ts Nil = ts 707 | unionUniq f tts1@(t1 `Cons` ts1) tts2@(t2 `Cons` ts2) = case compare (rank t1) (rank t2) of 708 | LT -> t1 `Cons` unionUniq f ts1 tts2 709 | EQ -> ins f (link f t1 t2) (unionUniq f ts1 ts2) 710 | GT -> t2 `Cons` unionUniq f tts1 ts2 711 | 712 | skewInsert :: (a -> a -> Bool) -> Tree a -> Forest a -> Forest a 713 | skewInsert f t ts@(t1 `Cons` t2 `Cons`rest) 714 | | rank t1 == rank t2 = skewLink f t t1 t2 `Cons` rest 715 | | otherwise = t `Cons` ts 716 | skewInsert _ t ts = t `Cons` ts 717 | {-# INLINE skewInsert #-} 718 | 719 | skewMeld :: (a -> a -> Bool) -> Forest a -> Forest a -> Forest a 720 | skewMeld f ts ts' = unionUniq f (uniqify f ts) (uniqify f ts') 721 | {-# INLINE skewMeld #-} 722 | 723 | getMin :: (a -> a -> Bool) -> Forest a -> (Tree a, Forest a) 724 | getMin _ (t `Cons` Nil) = (t, Nil) 725 | getMin f (t `Cons` ts) 726 | | f (root t) (root t') = (t, ts) 727 | | otherwise = (t', t `Cons` ts') 728 | where (t',ts') = getMin f ts 729 | getMin _ Nil = error "Heap.getMin: empty forest" 730 | 731 | splitForest :: Int -> Forest a -> Forest a -> Forest a -> (Forest a, Forest a, Forest a) 732 | splitForest a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined 733 | splitForest 0 zs ts f = (zs, ts, f) 734 | splitForest 1 zs ts (t `Cons` Nil) = (zs, t `Cons` ts, Nil) 735 | splitForest 1 zs ts (t1 `Cons` t2 `Cons` f) 736 | -- rank t1 == 0 737 | | rank t2 == 0 = (t1 `Cons` zs, t2 `Cons` ts, f) 738 | | otherwise = (zs, t1 `Cons` ts, t2 `Cons` f) 739 | splitForest r zs ts (t1 `Cons` t2 `Cons` cf) 740 | -- r1 = r - 1 or r1 == 0 741 | | r1 == r2 = (zs, t1 `Cons` t2 `Cons` ts, cf) 742 | | r1 == 0 = splitForest (r-1) (t1 `Cons` zs) (t2 `Cons` ts) cf 743 | | otherwise = splitForest (r-1) zs (t1 `Cons` ts) (t2 `Cons` cf) 744 | where 745 | r1 = rank t1 746 | r2 = rank t2 747 | splitForest _ _ _ _ = error "Heap.splitForest: invalid arguments" 748 | 749 | withList :: ([a] -> [a]) -> Heap a -> Heap a 750 | withList _ Empty = Empty 751 | withList f hp@(Heap _ leq _) = fromListWith leq (f (F.toList hp)) 752 | {-# INLINE withList #-} 753 | 754 | splitWithList :: ([a] -> ([a],[a])) -> Heap a -> (Heap a, Heap a) 755 | splitWithList _ Empty = (Empty, Empty) 756 | splitWithList f hp@(Heap _ leq _) = both (fromListWith leq) (f (F.toList hp)) 757 | {-# INLINE splitWithList #-} 758 | 759 | -- | Explicit priority/payload tuples. Useful to build a priority queue using 760 | -- a 'Heap', since the payload is ignored in the Eq/Ord instances. 761 | -- 762 | -- @ 763 | -- myHeap = 'fromList' ['Entry' 2 \"World", 'Entry' 1 \"Hello", 'Entry' 3 "!"] 764 | -- 765 | -- ==> 'foldMap' 'payload' myHeap ≡ "HelloWorld!" 766 | -- @ 767 | data Entry p a = Entry { priority :: p, payload :: a } 768 | deriving (Read,Show,Data) 769 | 770 | instance Functor (Entry p) where 771 | fmap f (Entry p a) = Entry p (f a) 772 | {-# INLINE fmap #-} 773 | 774 | instance Bifunctor Entry where 775 | bimap f g (Entry p a) = Entry (f p) (g a) 776 | 777 | instance Foldable (Entry p) where 778 | foldMap f (Entry _ a) = f a 779 | {-# INLINE foldMap #-} 780 | 781 | instance Traversable (Entry p) where 782 | traverse f (Entry p a) = Entry p `fmap` f a 783 | {-# INLINE traverse #-} 784 | 785 | -- instance Comonad (Entry p) where 786 | -- extract (Entry _ a) = a 787 | -- extend f pa@(Entry p _) Entry p (f pa) 788 | 789 | instance Eq p => Eq (Entry p a) where 790 | (==) = (==) `on` priority 791 | {-# INLINE (==) #-} 792 | 793 | instance Ord p => Ord (Entry p a) where 794 | compare = compare `on` priority 795 | {-# INLINE compare #-} 796 | -------------------------------------------------------------------------------- /tests/doctests.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Main (doctests) 4 | -- Copyright : (C) 2012-14 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- Maintainer : Edward Kmett 7 | -- Stability : provisional 8 | -- Portability : portable 9 | -- 10 | -- This module provides doctests for a project based on the actual versions 11 | -- of the packages it was built with. It requires a corresponding Setup.lhs 12 | -- to be added to the project 13 | ----------------------------------------------------------------------------- 14 | module Main where 15 | 16 | import Build_doctests (flags, pkgs, module_sources) 17 | import Data.Foldable (traverse_) 18 | import Test.DocTest 19 | 20 | main :: IO () 21 | main = do 22 | traverse_ putStrLn args 23 | doctest args 24 | where 25 | args = flags ++ pkgs ++ module_sources 26 | --------------------------------------------------------------------------------