├── .gitignore ├── LICENSE ├── README.md ├── data.ipkg └── src ├── Data ├── BinarySearchTree.idr ├── LazyPairingHeap.idr ├── LeftistHeap.idr ├── MergeList.idr ├── OrderedVect.idr ├── Queue.idr ├── RandomAccessList.idr └── VectRankedElem.idr ├── Decidable └── IntOrder.idr └── Test └── Main.idr /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | .vscode 3 | *.ibc 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2017, Jonas De Vuyst 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | * Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Data Structures for Idris 1 2 | 3 | Experiments in implementing data structures in the dependently typed programming language [Idris](https://www.idris-lang.org). 4 | 5 | Notably missing: 6 | 7 | - Instances of `Eq`, `Ord`, `Functor`, `Applicative`, `Monad`, `Traversable`, `Show`, `DecEq` 8 | - Efficient dictionaries (these are a generalization of sets) 9 | - Benchmarks 10 | 11 | For now these are left as a proverbial 'exercise for the reader'. 12 | 13 | The code in this repository requires Idris 1.3.x (last tested on Idris 1.3.1). Given the experimental nature of this project, an Idris 2 port is not planned for. 14 | 15 | # Table of Contents 16 | 17 | * [Data Structures for Idris](#data-structures-for-idris) 18 | * [Dependently Typed Lists](#dependently-typed-lists) 19 | * [OrderedVect](#orderedvect) 20 | * [VectRankedElem](#vectrankedelem) 21 | * [Okasaki's Purely Functional Data Structures](#okasakis-purely-functional-data-structures) 22 | * [LeftistHeap](#leftistheap) 23 | * [MergeList](#mergelist) 24 | * [LazyPairingHeap](#lazypairingheap) 25 | * [Queue](#queue) 26 | * [BinarySearchTree](#binarysearchtree) 27 | * [RandomAccessList](#randomaccesslist) 28 | 29 | # Dependently Typed Lists 30 | 31 | ## OrderedVect 32 | 33 | `OrderedVect` is a linked list type that is always sorted. The element count and order criteria are embedded in the type. There's also a `merge` operation that will merge two `OrderedVect`s. 34 | 35 | Available operations: `merge`, `head`, `tail`, `orderedVectToList` 36 | 37 | ## VectRankedElem 38 | 39 | In Idris, `Elem 2 [1, 2, 3, 4]` is satisfied by a proof that `2` is an element of `[1, 2, 3, 4]`. There is only one such proof: 40 | 41 | ``` 42 | Idris> the (Elem 2 [1,2,3,4]) (There Here) 43 | There Here : Elem 2 [1, 2, 3, 4] 44 | ``` 45 | 46 | The module `VectRankedElem` contains a type `RankedElem` that is similar but also encodes the index where the element is found: 47 | 48 | ``` 49 | Idris> the (RankedElem 2 [1,2,3,4] 1) (There Here) 50 | There Here : RankedElem 2 [1, 2, 3, 4] 1 51 | ``` 52 | 53 | The module also contains a few functions that use `RankedElem` to prove interesting properties: 54 | 55 | - `cons_ x xs` returns `(x::xs)` as well as a proof that for every `RankedElem el xs i` there is a `RankedElem el (x::xs) (S i)` and a proof of `RankedElem x (x::xs) Z` 56 | - `concat_ xs ys` returns `xs ++ ys` as well as a proof that for every `RankedElem el xs i` there is a `RankedElem el (xs ++ ys) i` and a proof that for every `RankedElem el ys i` there is a `RankedElem el (length xs + i) i` 57 | - `rev_ xs` returns `reverse xs` as well as a proof that for every `RankedElem el xs i` there is a `RankedElem el (reverse xs) (length xs - i)` 58 | 59 | The module also contains functions `cons`, `concat`, `rev` that call their `_` counterpart and return only data. These functions behave entirely like `::`, `++`, `reverse`. 60 | 61 | The proofs returned by `cons_`, `concat_`, `rev_` can be composed to prove properties on more complicated data structures. 62 | 63 | # Okasaki's Purely Functional Data Structures 64 | 65 | The data structures in this section are inspired by Chris Okasaki's book [Purely Functional Data Structures](https://books.google.com.sg/books/about/Purely_Functional_Data_Structures.html?id=SxPzSTcTalAC&redir_esc=y). This book is based on Okasaki's PhD Thesis, which is available as a free [PDF](https://www.cs.cmu.edu/~rwh/theses/okasaki.pdf). 66 | 67 | ## LeftistHeap 68 | 69 | Using dependent types I was able to prove the following: 70 | 71 | - `LeftistHeap` is always sorted 72 | - `LeftistHeap` respects the 'leftist property' 73 | - The result of merging a `LeftistHeap` of length `m` and a heap of length `n` is a heap of length `m + n` 74 | - `insert` and `deleteMin` yield a `LeftistHeap` that has one element more or less (respectively) than the input heap 75 | 76 | Available operations: `findMin`, `merge`, `insert`, `deleteMin`. 77 | 78 | A supplementary `CountedLeftistHeap` data structure is also available. 79 | 80 | ## MergeList 81 | 82 | `MergeList` is a dependently typed 'bottom up merge sort' data structure. A merge list is a linked list of `OrderedVect`s, strictly ordered by size, and where each `OrderedVect` has a size expressible as 2ⁿ. For example, `[[10], [3, 6, 9, 12]]` and `[[10], [5, 8], [3, 6, 9, 12]]` are valid `MergeList`s. 83 | 84 | Available operations: `insert`, `mergeListToOrderedVect` 85 | 86 | By using dependent types we get the following guarantees: 87 | 88 | - The `OrderedVect`s have sizes that are expresible as 2ⁿ and are strictly ordered by size 89 | - A `MergeList` of a given size can be flattened into an `OrderedVect` of the same size 90 | - When inserting `n` elements, the resulting merge list has `n` elements more than the input merge list 91 | 92 | ## LazyPairingHeap 93 | 94 | `LazyPairingHeap` is another ordered list data structure. We have the following guarantees: 95 | 96 | - Elements are ordered 97 | - Inserting and removing elements changes the size of the heap as expected 98 | 99 | Available operations: `findMin`, `merge`, `insert`, `deleteMin` 100 | 101 | ## Queue 102 | 103 | The type `Queue` is a functional queue data struture. It consist of a 'front list' `f` and a 'reverse list' `r` that together represent the logical list `f ++ reverse r`. Moreover, for reasons of efficiency, it is an invariant that `r` is never larger than `f`. 104 | 105 | Available operations: `head`, `snoc_`, `snoc`, `tail_`, `tail` 106 | 107 | Similar to what was done in `VectRankedElem` (see above), `snoc_` and `tail_` return functions that map proofs about the original queue onto proofs about the new queue. 108 | 109 | We have proofs for the following properties: 110 | 111 | - The reverse list is never larger than the front list 112 | - `snoc_` preserves the existence and the index of all elements and it adds the new element to the end of the queue 113 | - `tail_` drops the first element and shifts the indices of the remaining elements by 1 114 | 115 | `snoc` and `tail` are simple wrappers around `snoc_` and `tail_` that return the new queue, but not the proofs. 116 | 117 | ## BinarySearchTree 118 | 119 | `BinarySearchTree` is an implementation of functional binary trees. 120 | 121 | Available operations: `decElem`, `elem`, `insert` 122 | 123 | The above operations are based on a higher order function named `find`. `find` takes a needle and a function for arguments. `find` efficiently recurses over the tree trying to find the needle. At every step it returns the result of calling `f` with (a) contextual information about the search process and (b) the result of the previous step. The search context includes a verified upper and lower bound for the current node, by which `find` can prove to `f` that it's traversing the tree correctly. 124 | 125 | ## RandomAccessList 126 | 127 | `RandomAccessList` is a list structure that provides efficient prepend and access to element at arbitrary indices. Informally you can think of it as a persistent array. 128 | 129 | The namespace `Data.RandomAccessList` contains `RandomAccessList` and `CountedRandomAccessList` types. They allow the following operations: 130 | 131 | - `cons` for prepending an element 132 | - `tail` for removing the first element 133 | - `index` for accessing an element at a specific index 134 | - `update` for updating an element at a specific index 135 | 136 | These operations take O(logn) time. See Okasaki's book for techniques to reduce the time complexity to constant time. 137 | 138 | By construction all accesses and updates to a `RandomAccessList` are proved to be safe. 139 | 140 | Usually arrays allow efficient append and prepend is expensive. In `RandomAccessList`, prepend is cheap and append is expensive. The performance of these operations can be swapped by translating all indices. That is, `cons` can be interpreted as an append and access to indices can be translated as follows: `realIndex(virtualIndex) = size - 1 - virtualIndex`. 141 | -------------------------------------------------------------------------------- /data.ipkg: -------------------------------------------------------------------------------- 1 | package data 2 | 3 | sourceloc = https://github.com/jdevuyst/idris-data 4 | 5 | opts = "--warnreach -p contrib" 6 | 7 | sourcedir = src 8 | modules = Decidable.IntOrder 9 | , Data.LeftistHeap 10 | , Data.OrderedVect 11 | , Data.MergeList 12 | , Data.LazyPairingHeap 13 | , Data.VectRankedElem 14 | , Data.Queue 15 | , Data.BinarySearchTree 16 | , Data.RandomAccessList 17 | , Test.Main 18 | tests = Test.Main.mainTests 19 | , Test.Main.randomAccessListTests 20 | -------------------------------------------------------------------------------- /src/Data/BinarySearchTree.idr: -------------------------------------------------------------------------------- 1 | module Data.BinarySearchTree 2 | 3 | import Decidable.Order 4 | 5 | %default total 6 | 7 | contraSym : ((lhs = rhs) -> Void) -> (rhs = lhs) -> Void 8 | contraSym contra eq = contra $ sym eq 9 | 10 | strictRel : Ordered ty rel => {lhs : ty} -> {rhs : ty} -> 11 | lhs `rel` rhs -> (lhs = rhs -> Void ) -> (rhs `rel` lhs -> Void) 12 | strictRel {lhs} {rhs} smaller notEq assumption = 13 | notEq $ antisymmetric lhs rhs smaller assumption 14 | 15 | revStrictRel : {auto constraint : Ordered ty rel} -> {lhs : ty} -> {rhs : ty} -> 16 | (lhs `rel` rhs -> Void) -> (rhs `rel` lhs) 17 | revStrictRel {rel} {lhs} {rhs} gt = 18 | case order {to = rel} lhs rhs of 19 | Left lte => absurd $ gt lte 20 | Right gte => gte 21 | 22 | using (constraint : Ordered ty rel) 23 | export 24 | data Bounded : Ordered ty rel -> Maybe ty -> ty -> Maybe ty -> Type where 25 | WithinBounds : {lbound, ubound : Maybe ty} -> {pivot : ty} -> 26 | (gt : (x ** (lbound = Just x, rel pivot x)) -> Void) -> 27 | (lt : (x ** (ubound = Just x, rel x pivot)) -> Void) -> 28 | Bounded constraint lbound pivot ubound 29 | 30 | GTNothing : {auto constraint : Ordered ty rel} -> {value: ty} -> Type 31 | GTNothing {ty} {rel} {value} = (x : ty ** (Nothing = Just x, rel value x)) 32 | 33 | anythingGTNothing : {auto constraint : Ordered ty rel} -> GTNothing -> Void 34 | anythingGTNothing (_ ** (Refl, _)) impossible 35 | 36 | LTNothing : {auto constraint : Ordered ty rel} -> {value: ty} -> Type 37 | LTNothing {ty} {rel} {value} = (x : ty ** (Nothing = Just x, rel x value)) 38 | 39 | anythingLTNothing : {auto constraint : Ordered ty rel} -> LTNothing -> Void 40 | anythingLTNothing (_ ** (Refl, _)) impossible 41 | 42 | export 43 | WithinUnconstrainedBounds : {pivot : ty} -> Bounded _ Nothing pivot Nothing 44 | WithinUnconstrainedBounds {pivot} = 45 | WithinBounds {pivot} anythingGTNothing anythingLTNothing 46 | 47 | export 48 | changeLbound : Bounded constraint _ pivot ubound -> (rel pivot v -> Void) -> 49 | Bounded constraint (Just v) pivot ubound 50 | changeLbound {v} (WithinBounds _ lt) gt = WithinBounds {pivot} gt' lt 51 | where gt' : (x ** (Just v = Just x, rel pivot x)) -> Void 52 | gt' (x ** (prf, gte)) = gt $ rewrite justInjective prf in gte 53 | 54 | export 55 | changeUbound : Bounded constraint lbound pivot _ -> (rel v pivot -> Void) -> 56 | Bounded constraint lbound pivot (Just v) 57 | changeUbound {v} (WithinBounds gt _) lt = WithinBounds {pivot} gt lt' 58 | where lt' : (x ** (Just v = Just x, rel x pivot)) -> Void 59 | lt' (x ** (prf, lte)) = lt $ rewrite justInjective prf in lte 60 | 61 | public export 62 | data BinarySearchTree_ : Ordered ty rel -> Maybe ty -> Maybe ty -> Nat -> Type where 63 | Empty : BinarySearchTree_ _ _ _ Z 64 | Node : (v : ty) -> 65 | .{bounded : Bounded constraint lbound v ubound} -> 66 | {leftCount, rightCount : Nat} -> 67 | (left : BinarySearchTree_ constraint lbound (Just v) leftCount) -> 68 | (right : BinarySearchTree_ constraint (Just v) ubound rightCount) -> 69 | BinarySearchTree_ constraint lbound ubound (S $ leftCount + rightCount) 70 | 71 | value : BinarySearchTree_ constraint _ _ (S _) -> ty 72 | value (Node v _ _) = v 73 | 74 | leftCount : BinarySearchTree_ constraint _ _ (S _) -> Nat 75 | leftCount (Node {leftCount = len} _ _ _) = len 76 | 77 | left : {constraint : Ordered ty rel} -> 78 | (orig : BinarySearchTree_ constraint lbound _ (S _)) -> 79 | BinarySearchTree_ constraint lbound (Just (value orig)) (leftCount orig) 80 | left (Node _ l _) = l 81 | 82 | rightCount : BinarySearchTree_ constraint _ _ (S _) -> Nat 83 | rightCount (Node {rightCount = len} _ _ _) = len 84 | 85 | right : {constraint : Ordered ty rel} -> 86 | (orig : BinarySearchTree_ constraint _ ubound (S _)) -> 87 | BinarySearchTree_ constraint (Just (value orig)) ubound (rightCount orig) 88 | right (Node _ _ r) = r 89 | 90 | export 91 | data Elem : ty -> BinarySearchTree_ constraint _ _ _ -> Type where 92 | Here : Elem v (Node {constraint} v _ _) 93 | Left : Elem v l -> Elem v (Node _ l _) 94 | Right : Elem v r -> Elem v (Node _ _ r) 95 | 96 | export 97 | noEmptyElem : Elem _ Empty -> Void 98 | noEmptyElem _ impossible 99 | 100 | export 101 | lboundRespected : 102 | {lbound : ty} -> {tree : BinarySearchTree_ constraint (Just lbound) _ _} -> 103 | Elem pivot tree -> rel pivot lbound -> Void 104 | lboundRespected {rel} {lbound} {tree} elem {pivot} prf = 105 | let Node {bounded = WithinBounds gt _} v _ _ = tree in 106 | case elem of 107 | Here => gt (lbound ** (Refl, prf)) 108 | Left elemL => lboundRespected elemL prf 109 | Right elemR => case order {to = rel} lbound v of 110 | Left lte => let prf' = transitive pivot _ _ prf lte in 111 | lboundRespected elemR prf' 112 | Right gte => gt (lbound ** (Refl, gte)) 113 | 114 | export 115 | uboundRespected : 116 | {ubound : ty} -> {tree : BinarySearchTree_ constraint _ (Just ubound) _} -> 117 | Elem pivot tree -> rel ubound pivot -> Void 118 | uboundRespected {rel} {ubound} {tree} elem {pivot} prf = 119 | let Node {bounded = WithinBounds _ lt} v _ _ = tree in 120 | case elem of 121 | Here => lt (ubound ** (Refl, prf)) 122 | Left elemL => case order {to = rel} v ubound of 123 | Left lte => let prf' = transitive v _ _ lte prf in 124 | uboundRespected elemL prf' 125 | Right gte => lt (ubound ** (Refl, gte)) 126 | Right elemR => uboundRespected elemR prf 127 | 128 | data SearchSpace : Type where 129 | MkSearchSpace : Bounded constraint lbound pivot ubound -> 130 | BinarySearchTree_ constraint lbound ubound len -> SearchSpace 131 | 132 | data Finding : SearchSpace -> (SearchSpace -> Type) -> Type where 133 | GoLeft : .{retCalc : SearchSpace -> Type} -> 134 | .{bounded : Bounded constraint lbound pivot ubound} -> 135 | {orig : BinarySearchTree_ constraint lbound ubound (S _)} -> 136 | {leftBounded : Bounded constraint lbound pivot (Just (value orig))} -> 137 | (rel (value orig) pivot -> Void) -> 138 | retCalc (MkSearchSpace leftBounded (left orig)) -> 139 | Finding (MkSearchSpace bounded orig) retCalc 140 | GoRight : .{retCalc : SearchSpace -> Type} -> 141 | .{bounded : Bounded constraint lbound pivot ubound} -> 142 | {orig : BinarySearchTree_ constraint lbound ubound (S _)} -> 143 | {rightBounded : Bounded constraint (Just (value orig)) pivot ubound} -> 144 | (rel pivot (value orig) -> Void) -> 145 | retCalc (MkSearchSpace rightBounded (right orig)) -> 146 | Finding (MkSearchSpace bounded orig) retCalc 147 | Found : .{bounded : Bounded constraint lbound pivot ubound} -> 148 | {orig : BinarySearchTree_ constraint lbound ubound (S _)} -> 149 | (pivot = value orig) -> Finding (MkSearchSpace bounded orig) _ 150 | DeadEnd : .{bounded : Bounded constraint lbound pivot ubound} -> 151 | {orig : BinarySearchTree_ constraint lbound ubound Z} -> 152 | Finding (MkSearchSpace bounded orig) _ 153 | 154 | FindingTransform : Ordered ty _ -> ty -> (SearchSpace -> Type) -> Type 155 | FindingTransform {ty} constraint pivot retCalc = 156 | (lbound', ubound': Maybe ty) -> 157 | (bounded' : Bounded constraint lbound' pivot ubound') -> 158 | {len' : Nat} -> 159 | (tree' : BinarySearchTree_ constraint lbound' ubound' len') -> 160 | Finding (MkSearchSpace bounded' tree') retCalc -> 161 | retCalc (MkSearchSpace bounded' tree') 162 | 163 | find_ : DecEq ty => (pivot : ty) -> 164 | {lbound, ubound : Maybe ty} -> {len : Nat} -> 165 | (tree : BinarySearchTree_ constraint lbound ubound len) -> 166 | (bounded : Bounded constraint lbound pivot ubound) -> 167 | FindingTransform constraint pivot retCalc -> 168 | Finding (MkSearchSpace bounded tree) retCalc 169 | find_ _ Empty _ _ = DeadEnd 170 | find_ {rel} {len = S _} pivot (Node v l r) pivotBounded extract = 171 | case decEq pivot v of 172 | Yes Refl => Found Refl 173 | No contra => case order {to = rel} pivot v of 174 | Left prf => let lt = strictRel prf contra 175 | bounded = changeUbound pivotBounded lt 176 | finding = find_ pivot l bounded extract 177 | ret = extract _ _ _ _ finding in 178 | GoLeft lt ret 179 | Right prf => let gt = strictRel prf (contraSym contra) 180 | bounded = changeLbound pivotBounded gt 181 | finding = find_ pivot r bounded extract 182 | ret = extract _ _ _ _ finding in 183 | GoRight gt ret 184 | 185 | public export 186 | BinarySearchTree : Ordered ty rel -> Nat -> Type 187 | BinarySearchTree constraint len = 188 | BinarySearchTree_ constraint Nothing Nothing len 189 | 190 | public export 191 | CountedBinarySearchTree : Ordered ty rel -> Type 192 | CountedBinarySearchTree constraint = 193 | (len : Nat ** BinarySearchTree constraint len) 194 | 195 | find : DecEq ty => (pivot : ty) -> 196 | (ct : CountedBinarySearchTree constraint) -> 197 | FindingTransform constraint pivot retCalc -> 198 | retCalc $ MkSearchSpace (WithinUnconstrainedBounds {pivot}) (snd ct) 199 | find pivot (_ ** tree) transform = 200 | transform _ _ _ _ $ find_ pivot tree _ transform 201 | 202 | export 203 | decElem : DecEq ty => (v : ty) -> 204 | (ct : CountedBinarySearchTree constraint) -> 205 | Dec (Elem v (snd ct)) 206 | decElem {constraint} value ct = find value ct transform 207 | where retCalc : SearchSpace -> Type 208 | retCalc (MkSearchSpace (WithinBounds {pivot} _ _) tree') = 209 | Dec (Elem pivot tree') 210 | transform : FindingTransform constraint value retCalc 211 | transform lbound' ubound' (WithinBounds {pivot = value} _ _) len tree' finding = 212 | case finding of 213 | GoLeft {orig = Node _ _ _} {leftBounded} contra prev => 214 | let WithinBounds _ _ = leftBounded in 215 | case prev of 216 | Yes prf => Yes $ Left prf 217 | No contra' => No $ \prop => case prop of 218 | Here => contra $ reflexive value 219 | Left elem => contra' elem 220 | Right elem => lboundRespected elem (revStrictRel contra) 221 | GoRight {orig = Node _ _ _} {rightBounded} contra prev => 222 | let WithinBounds _ _ = rightBounded in 223 | case prev of 224 | Yes prf => Yes $ Right prf 225 | No contra' => No $ \prop => case prop of 226 | Here => contra $ reflexive value 227 | Left elem => uboundRespected elem (revStrictRel contra) 228 | Right elem => contra' elem 229 | Found {orig = Node _ _ _} Refl => Yes Here 230 | DeadEnd {orig = Empty} => No noEmptyElem 231 | 232 | export 233 | elem : DecEq ty => ty -> CountedBinarySearchTree constraint -> Bool 234 | elem v ct = decAsBool $ decElem v ct 235 | 236 | export 237 | insert : DecEq ty => CountedBinarySearchTree constraint -> ty -> 238 | CountedBinarySearchTree constraint 239 | insert {constraint} ct value = find value ct transform 240 | where retCalc : SearchSpace -> Type 241 | retCalc (MkSearchSpace {constraint} (WithinBounds {pivot} {lbound} {ubound} _ _) tree') = 242 | (len : Nat ** BinarySearchTree_ constraint lbound ubound len) 243 | transform : FindingTransform constraint value retCalc 244 | transform lbound' ubound' (WithinBounds {pivot = value} gt lt) len tree' finding = 245 | case finding of 246 | GoLeft {orig} {leftBounded} _ prev => 247 | let Node {bounded} v _ r = orig 248 | WithinBounds _ _ = leftBounded 249 | (_ ** l') = prev in 250 | (_ ** Node {bounded} v l' r) 251 | GoRight {orig} {rightBounded} _ prev => 252 | let Node {bounded} v l _ = orig 253 | WithinBounds _ _ = rightBounded 254 | (_ ** r') = prev in 255 | (_ ** Node {bounded} v l r') 256 | Found {orig} Refl => (_ ** orig) 257 | DeadEnd {orig = Empty} => 258 | let bounded = WithinBounds gt lt in 259 | (_ ** Node {bounded} value Empty Empty) -------------------------------------------------------------------------------- /src/Data/LazyPairingHeap.idr: -------------------------------------------------------------------------------- 1 | module Data.LazyPairingHeap 2 | 3 | import Decidable.Order 4 | 5 | %default total 6 | 7 | mutual 8 | public export 9 | data LazyPairingHeap : Nat -> Ordered ty to -> Type where 10 | Empty : .{auto constraint : Ordered ty to} -> LazyPairingHeap Z constraint 11 | Tree : .{constraint : Ordered ty to} 12 | -> (x : ty) 13 | -> {leftCnt : Nat} 14 | -> (l : LazyPairingHeap leftCnt constraint) 15 | -> .{auto leftFits : Fits x l} 16 | -> {rightCnt : Nat} 17 | -> (r : Lazy $ LazyPairingHeap rightCnt constraint) 18 | -> .{auto rightFits : Fits x r} 19 | -> LazyPairingHeap (S (leftCnt + rightCnt)) constraint 20 | 21 | export 22 | findMin : {constraint : Ordered ty _} -> LazyPairingHeap (S _) constraint -> ty 23 | findMin (Tree x l r) = x 24 | 25 | export 26 | Fits : {constraint : Ordered ty to} -> ty -> LazyPairingHeap cnt constraint -> Type 27 | Fits {cnt = Z} _ _ = () 28 | Fits {cnt = S _} {to} x h = to x (findMin h) 29 | 30 | mutual 31 | link : .{constraint : Ordered ty to} 32 | -> .{cnt1 : Nat} -> (h1 : LazyPairingHeap (S cnt1) constraint) 33 | -> .{cnt2 : Nat} -> (h2 : LazyPairingHeap (S cnt2) constraint) 34 | -> .{ltePrf : to (findMin h1) (findMin h2)} 35 | -> (ret : LazyPairingHeap ((S cnt1) + (S cnt2)) constraint ** findMin ret = findMin h1) 36 | link {cnt1} {cnt2} {ltePrf} h1@(Tree x Empty r) h2 37 | = rewrite plusCommutative cnt1 (S cnt2) in 38 | (Tree (findMin h1) h2 r ** Refl) 39 | link {constraint} {ltePrf} h1 {cnt2} h2 with (h1) 40 | | Tree {leftFits} {rightFits} {leftCnt} {rightCnt} x l r 41 | = rewrite sym $ plusAssociative leftCnt rightCnt (S cnt2) in 42 | rewrite plusCommutative rightCnt (S cnt2) in 43 | rewrite plusAssociative leftCnt (S cnt2) rightCnt in 44 | rewrite plusCommutative leftCnt (S cnt2) in 45 | rewrite sym $ xFindMin in 46 | let (merged ** fitsPrf) = merge' {lbound = findMin h1} 47 | {fits1 = rewrite xFindMin in ltePrf} 48 | h2 49 | {fits2 = rewrite xFindMin in leftFits} 50 | l 51 | (merged' ** fitsPrf') = merge' {lbound = findMin h1} 52 | {fits1 = fitsPrf} 53 | merged 54 | {fits2 = rewrite xFindMin in rightFits} 55 | r 56 | ret = Tree (findMin h1) Empty merged' in 57 | (ret ** Refl) 58 | where xFindMin : findMin h1 = x 59 | xFindMin = really_believe_me () 60 | 61 | merge' : .{constraint : Ordered ty to} 62 | -> {cnt1 : Nat} -> (h1 : LazyPairingHeap cnt1 constraint) 63 | -> {cnt2 : Nat} -> (h2 : LazyPairingHeap cnt2 constraint) 64 | -> .{lbound : ty} -> .{fits1 : Fits lbound h1} -> .{fits2 : Fits lbound h2} 65 | -> (ret : LazyPairingHeap (cnt1 + cnt2) constraint ** Fits lbound ret) 66 | merge' {fits2} Empty h = (h ** fits2) 67 | merge' {cnt1} {fits1} h Empty = rewrite plusZeroRightNeutral cnt1 in (h ** fits1) 68 | merge' {to} {fits1} {fits2} {cnt1 = S n} {cnt2 = S m} h1 h2 with (order {to} (findMin h1) (findMin h2)) 69 | | Left ltePrf = let (ret ** eqPrf) = assert_total $ link {ltePrf} h1 h2 in 70 | (ret ** rewrite eqPrf in fits1) 71 | | Right ltePrf = rewrite plusCommutative n (S m) in 72 | rewrite plusSuccRightSucc m n in 73 | let (ret ** eqPrf) = assert_total $ link {ltePrf} h2 h1 in 74 | (ret ** rewrite eqPrf in fits2) 75 | 76 | export 77 | merge : .{constraint : Ordered ty to} 78 | -> {cnt1 : Nat} -> LazyPairingHeap cnt1 constraint 79 | -> {cnt2 : Nat} -> LazyPairingHeap cnt2 constraint 80 | -> LazyPairingHeap (cnt1 + cnt2) constraint 81 | merge Empty h = h 82 | merge {cnt1} h Empty = rewrite plusZeroRightNeutral cnt1 in h 83 | merge {constraint} {ty} {to} {cnt1 = S n} {cnt2 = S m} h1 h2 84 | = let (lbound ** (fits1, fits2)) = proofs in 85 | fst $ merge' {lbound} {fits1} {fits2} h1 h2 86 | where proofs : (lbound : ty ** (Fits lbound h1, Fits lbound h2)) 87 | proofs with (order {to} (findMin h1) (findMin h2)) 88 | | Left ltePrf = let x = findMin h1 in 89 | (x ** (reflexive x, ltePrf)) 90 | | Right ltePrf = let x = findMin h2 in 91 | (x ** (ltePrf, reflexive x)) 92 | 93 | export 94 | deleteMin : .{constraint : Ordered ty to} -> LazyPairingHeap (S cnt) constraint -> LazyPairingHeap cnt constraint 95 | deleteMin (Tree _ l r) = merge l r 96 | 97 | singleton : {ty : Type} -> {constraint : Ordered ty to} -> ty -> LazyPairingHeap 1 constraint 98 | singleton x = Tree x Empty Empty 99 | 100 | export 101 | insert : .{constraint : Ordered ty to} -> {cnt : Nat} -> LazyPairingHeap cnt constraint -> ty -> LazyPairingHeap (S cnt) constraint 102 | insert {cnt} h x = rewrite sym $ plusZeroRightNeutral cnt in 103 | rewrite plusSuccRightSucc cnt Z in 104 | merge h (singleton x) 105 | 106 | namespace CountedPairingHeap 107 | public export 108 | CountedPairingHeap : (constraint : Ordered ty to) -> Type 109 | CountedPairingHeap constraint = (cnt : Nat ** LazyPairingHeap cnt constraint) 110 | 111 | export 112 | empty : CountedPairingHeap _ 113 | empty = (Z ** Empty) 114 | 115 | export 116 | findMin : .{constraint : Ordered ty to} -> CountedPairingHeap constraint -> Maybe ty 117 | findMin (Z ** _) = Nothing 118 | findMin (S _ ** (Tree x _ _)) = Just x 119 | 120 | export 121 | deleteMin : CountedPairingHeap constraint -> CountedPairingHeap constraint 122 | deleteMin (Z ** h) = (Z ** h) 123 | deleteMin (S cnt ** h) = (cnt ** deleteMin h) 124 | 125 | export 126 | insert : .{constraint : Ordered ty to} -> CountedPairingHeap constraint -> ty -> CountedPairingHeap constraint 127 | insert (cnt ** h) x = ((S cnt) ** insert h x) 128 | -------------------------------------------------------------------------------- /src/Data/LeftistHeap.idr: -------------------------------------------------------------------------------- 1 | module Data.LeftistHeap 2 | 3 | import Decidable.Order 4 | 5 | %default total 6 | 7 | mutual 8 | export 9 | data Heap : .(constraint : Ordered a rel) -> .(count : Nat) -> Type where 10 | Empty : Heap _ Z 11 | Node : (n : Nat) 12 | -> (value : a) 13 | -> {countLeft : Nat} 14 | -> (left : Heap constraint countLeft) 15 | -> {countRight : Nat} 16 | -> (right : Heap constraint countRight) 17 | -> .{auto fitsLeft : Fits value left} 18 | -> .{auto fitsRight : Fits value right} 19 | -> .{auto leftistPrf : LTE (rank right) (rank left)} 20 | -> .{auto rankPrf : n = S $ rank right} 21 | -> Heap constraint (S $ countLeft + countRight) 22 | 23 | Fits : {constraint : Ordered a rel} -> a -> Heap constraint cnt -> Type 24 | Fits {cnt = Z} _ _ = () 25 | Fits {cnt = S _} x h = rel x (findMin h) 26 | 27 | rank : Heap _ _ -> Nat 28 | rank Empty = Z 29 | rank (Node _ _ _ right) = S $ rank right 30 | 31 | export 32 | findMin : .{constraint : Ordered a _} -> Heap constraint (S _) -> a 33 | findMin (Node _ value _ _) = value 34 | 35 | export 36 | empty : Heap _ Z 37 | empty = Empty 38 | 39 | makeFit : .{constraint : Ordered a rel} 40 | -> .(fitsValue : a) 41 | -> (value : a) 42 | -> {count1 : Nat} 43 | -> {count2 : Nat} 44 | -> (h1 : Heap constraint count1) 45 | -> (h2 : Heap constraint count2) 46 | -> .{auto fits1 : Fits value h1} 47 | -> .{auto fits2 : Fits value h2} 48 | -> .{auto relPrf : rel fitsValue value} 49 | -> Subset (Heap constraint (S $ count1 + count2)) (Fits fitsValue) 50 | makeFit {count1} {count2} {relPrf} fitsValue value h1 h2 with (order {to = LTE} (rank h1) (rank h2)) 51 | | (Left _) = rewrite plusCommutative count1 count2 in 52 | Element (Node _ value h2 h1) relPrf 53 | | (Right _) = Element (Node _ value h1 h2) relPrf 54 | 55 | covering 56 | mergeHelper : .{constraint : Ordered a rel} 57 | -> .{value : a} 58 | -> {count1 : Nat} 59 | -> {count2 : Nat} 60 | -> (h1 : Heap constraint count1) 61 | -> (h2 : Heap constraint count2) 62 | -> .{auto fits1 : Fits value h1} 63 | -> .{auto fits2 : Fits value h2} 64 | -> Subset (Heap constraint (count1 + count2)) (Fits value) 65 | mergeHelper Empty Empty = Element Empty () 66 | mergeHelper {fits1} h@(Node {countLeft} {countRight} n _ _ _) Empty = rewrite plusZeroRightNeutral (countLeft + countRight) in Element h fits1 67 | mergeHelper {fits2} Empty h@(Node {countLeft} {countRight} n _ _ _) = Element h fits2 68 | mergeHelper {value} {rel} 69 | (Node {countLeft = countLeft1} {countRight = countRight1} _ value1 left1 right1) 70 | (Node {countLeft = countLeft2} {countRight = countRight2} _ value2 left2 right2) 71 | = case order {to = rel} value1 value2 of 72 | Left orderPrf => rewrite sym $ plusAssociative countLeft1 countRight1 (S $ countLeft2 + countRight2) in 73 | let (Element mergedHeap fitsMergedHeap) = mergeHelper {value = value1} right1 (Node _ value2 left2 right2) in 74 | makeFit value value1 left1 mergedHeap 75 | Right orderPrf => rewrite sym $ plusSuccRightSucc (countLeft1 + countRight1) (countLeft2 + countRight2) in 76 | rewrite plusCommutative countLeft2 countRight2 in 77 | rewrite plusAssociative (countLeft1 + countRight1) countRight2 countLeft2 in 78 | let (Element mergedHeap fitsMergedHeap) = mergeHelper {value = value2} (Node _ value1 left1 right1) right2 in 79 | makeFit value value2 mergedHeap left2 80 | 81 | export 82 | merge : .{constraint : Ordered a rel} 83 | -> {count1 : Nat} -> {count2 : Nat} 84 | -> (h1 : Heap constraint count1) -> (h2 : Heap constraint count2) 85 | -> Heap constraint (count1 + count2) 86 | merge Empty Empty = Empty 87 | merge {count1} h Empty = rewrite plusZeroRightNeutral count1 in h 88 | merge Empty h = h 89 | merge h1@(Node _ _ _ _) h2@(Node _ _ _ _) 90 | = assert_total $ case order {to = rel} (findMin h1) (findMin h2) of 91 | Left orderPrf => case mergeHelper {value = (findMin h1)} h1 h2 {fits1 = reflexive (findMin h1)} of 92 | Element h _ => h 93 | Right orderPrf => case mergeHelper {value = (findMin h2)} h1 h2 {fits2 = reflexive (findMin h2)} of 94 | Element h _ => h 95 | 96 | export 97 | insert : .{constraint : Ordered a _} -> .{n : Nat} -> a -> Heap constraint n -> Heap constraint (S n) 98 | insert value heap = merge (Node 1 value Empty Empty) heap 99 | 100 | export 101 | deleteMin : .{constraint : Ordered a _} -> {n : Nat} -> Heap constraint (S n) -> Heap constraint n 102 | deleteMin (Node _ _ left right) = merge left right 103 | 104 | namespace OrderedLeftistHeap 105 | export 106 | data CountedHeap : .(constraint : Ordered a rel) -> Type where 107 | MkCountedHeap : (n : Nat) -> (Heap constraint n) -> CountedHeap constraint 108 | 109 | export 110 | empty : CountedHeap _ 111 | empty = MkCountedHeap Z empty 112 | 113 | export 114 | count : CountedHeap _ -> Nat 115 | count (MkCountedHeap n _) = n 116 | 117 | export 118 | findMin : .{constraint : Ordered ty _} -> CountedHeap constraint -> Maybe ty 119 | findMin (MkCountedHeap Z _) = Nothing 120 | findMin (MkCountedHeap (S _) h) = Just $ findMin h 121 | 122 | export 123 | merge : .{constraint : Ordered _ _} -> CountedHeap constraint -> CountedHeap constraint -> CountedHeap constraint 124 | merge (MkCountedHeap count1 h1) (MkCountedHeap count2 h2) = MkCountedHeap (count1 + count2) (merge h1 h2) 125 | 126 | export 127 | insert : .{constraint : Ordered ty _} -> ty -> CountedHeap constraint -> CountedHeap constraint 128 | insert a (MkCountedHeap n h) = MkCountedHeap (S n) (insert a h) 129 | 130 | export 131 | deleteMin : .{constraint : Ordered ty _} -> CountedHeap constraint -> CountedHeap constraint 132 | deleteMin orig@(MkCountedHeap Z h) = orig 133 | deleteMin (MkCountedHeap (S n) h) = MkCountedHeap n (deleteMin h) 134 | -------------------------------------------------------------------------------- /src/Data/MergeList.idr: -------------------------------------------------------------------------------- 1 | module Data.MergeList 2 | 3 | import Decidable.Order 4 | import Data.OrderedVect 5 | 6 | %default total 7 | 8 | export 9 | data MergeList : (rank : Nat) -> (cnt : Nat) -> (constraint : Ordered ty to) -> Type where 10 | Nil : MergeList _ Z _ 11 | Skip : (next : MergeList (n + n) cnt constraint) 12 | -> MergeList n cnt constraint 13 | (::) : OrderedVect n constraint 14 | -> .{cnt : Nat} 15 | -> (next : MergeList (n + n) cnt constraint) 16 | -> MergeList n (n + cnt) constraint 17 | 18 | %name MergeList xs,ys,zs 19 | 20 | insertVect : {constraint : Ordered ty to} 21 | -> {n : Nat} 22 | -> {cnt : Nat} 23 | -> MergeList n cnt constraint 24 | -> OrderedVect n constraint 25 | -> MergeList n (cnt + n) constraint 26 | insertVect {n} {constraint} {cnt=Z} Nil v 27 | = rewrite rewriteType in v :: Nil 28 | where rewriteType : MergeList n n constraint = MergeList n (n + 0) constraint 29 | rewriteType = rewrite sym $ plusZeroRightNeutral n in Refl 30 | insertVect {n} {cnt} (Skip next) v = rewrite plusCommutative cnt n in 31 | v :: next 32 | insertVect {n} ((::) v next {cnt}) v' 33 | = rewrite sym $ plusCommutative cnt n in 34 | rewrite sym $ plusAssociative cnt n n in 35 | Skip $ insertVect next (merge n v n v') 36 | 37 | export 38 | empty : .{auto constraint : Ordered ty to} -> MergeList 1 0 constraint 39 | empty = [] 40 | 41 | export 42 | insert : .{constraint : Ordered ty to} 43 | -> {cnt : Nat} 44 | -> MergeList 1 cnt constraint 45 | -> ty 46 | -> MergeList 1 (cnt + 1) constraint 47 | insert l x = insertVect l [x] 48 | 49 | export 50 | mergeListToOrderedVect : .{constraint : Ordered ty _} 51 | -> (n : Nat) 52 | -> (cnt : Nat) 53 | -> MergeList n cnt constraint 54 | -> OrderedVect cnt constraint 55 | mergeListToOrderedVect _ _ Nil = [] 56 | mergeListToOrderedVect n cnt (Skip next) = mergeListToOrderedVect (n + n) cnt next 57 | mergeListToOrderedVect n (n + nextCnt) (v :: next) 58 | = merge n v nextCnt $ mergeListToOrderedVect (n + n) nextCnt next 59 | 60 | namespace CountedMergeList 61 | public export 62 | CountedMergeList : (n : Nat) -> (constraint: Ordered to rel) -> Type 63 | CountedMergeList n constraint = (cnt : Nat ** Lazy $ MergeList n cnt constraint) 64 | 65 | export 66 | empty : CountedMergeList 1 constraint 67 | empty = (Z ** empty) 68 | 69 | export 70 | insert : .{constraint : Ordered ty to} -> CountedMergeList 1 constraint -> ty -> CountedMergeList 1 constraint 71 | insert (cnt ** xs) x = (cnt + 1 ** insert xs x) -------------------------------------------------------------------------------- /src/Data/OrderedVect.idr: -------------------------------------------------------------------------------- 1 | module Data.OrderedVect 2 | 3 | import Decidable.Order 4 | 5 | %default total 6 | 7 | mutual 8 | public export 9 | data OrderedVect : Nat -> (constraint : Ordered ty to) -> Type where 10 | Nil : .{auto constraint : Ordered ty to} 11 | -> OrderedVect Z constraint 12 | (::) : .{constraint : Ordered ty to} 13 | -> (x : ty) 14 | -> (v : OrderedVect n constraint) 15 | -> .{auto prf : Fits x v} 16 | -> OrderedVect (S n) constraint 17 | 18 | public export 19 | Fits : {constraint : Ordered ty to} -> ty -> OrderedVect n constraint -> Type 20 | Fits _ Nil = () 21 | Fits n (m :: _) = to n m 22 | 23 | %name OrderedVect xs,ys,zs 24 | 25 | export 26 | head : .{constraint : Ordered ty to} -> OrderedVect (S _) constraint -> ty 27 | head (x :: _) = x 28 | 29 | fitsTrans : (Fits {constraint} x ys) -> Fits {constraint} (head ys) zs -> Fits {constraint} x zs 30 | fitsTrans {zs = []} _ _ = () 31 | fitsTrans {x} {ys = y' :: _} {zs = z' :: _} rel1 rel2 = transitive x y' z' rel1 rel2 32 | 33 | mutual 34 | merge' : .{constraint : Ordered ty to} 35 | -> {n : Nat} 36 | -> (v1 : OrderedVect (S n) constraint) 37 | -> {m : Nat} 38 | -> (v2 : OrderedVect (S m) constraint) 39 | -> (ret : OrderedVect ((S n) + (S m)) constraint ** Either (Fits (head v1) ret) (Fits (head v2) ret)) 40 | merge' [] _ impossible 41 | merge' _ [] impossible 42 | merge' {to} [x] [y] = case order {to} x y of 43 | Left prf => ([x, y] ** Left (reflexive x)) 44 | Right prf => ([y, x] ** Right (reflexive y)) 45 | merge' {m} [x] (y :: ys) = rewrite sym $ plusZeroRightNeutral m in 46 | rewrite plusSuccRightSucc m Z in 47 | case assert_total $ merge' (y :: ys) [x] of 48 | (ref ** Left prf) => (ref ** Right prf) 49 | (ref ** Right prf) => (ref ** Left prf) 50 | merge' {n = S cntX} (x :: xs) [y] 51 | = case order {to} x y of 52 | Left prf => case mergeHelper xs [y] x of 53 | (zs ** fitsPrf) => (zs ** Left fitsPrf) 54 | Right prf => rewrite sym $ plusSuccRightSucc cntX Z in 55 | rewrite plusZeroRightNeutral cntX in 56 | ((y :: x :: xs) ** Right (reflexive y)) 57 | merge' ((::) {n = S cntX} x (x' :: xs')) 58 | ((::) {n = S cntY} y (y' :: ys')) 59 | = case order {to} x y of 60 | Left prf => case mergeHelper (x' :: xs') (y :: y' :: ys') x of 61 | (zs ** fitsPrf) => (zs ** Left fitsPrf) 62 | Right prf => case mergeHelper (y' :: ys') (x :: x' :: xs') y of 63 | (zs ** fitsPrf) => rewrite plusCommutative cntX (S $ S $ cntY) in 64 | rewrite plusSuccRightSucc (S $ S cntY) cntX in 65 | rewrite plusSuccRightSucc (S cntY) (S cntX) in 66 | (zs ** Right fitsPrf) 67 | mergeHelper : .{constraint : Ordered ty to} 68 | -> {n : Nat} 69 | -> (xs : OrderedVect (S n) constraint) 70 | -> {m : Nat} 71 | -> (ys : OrderedVect (S m) constraint) 72 | -> (x : ty) 73 | -> .{auto prfXs : Fits x xs} 74 | -> .{auto prfYs : Fits x ys} 75 | -> (ret : OrderedVect (S $ (S n) + (S m)) constraint ** Fits x ret) 76 | mergeHelper xs ys x {prfXs} {prfYs} 77 | = case assert_total $ merge' xs ys of 78 | (zs ** Left fitsPrf) => let _ = fitsTrans prfXs fitsPrf in 79 | (x :: zs ** reflexive x) 80 | (zs ** Right fitsPrf) => let _ = fitsTrans prfYs fitsPrf in 81 | (x :: zs ** reflexive x) 82 | 83 | export 84 | merge : {constraint : Ordered ty to} 85 | -> (n : Nat) 86 | -> OrderedVect n constraint 87 | -> (m : Nat) 88 | -> OrderedVect m constraint 89 | -> OrderedVect (n + m) constraint 90 | merge Z [] Z [] = Nil 91 | merge n v1 Z [] = rewrite plusZeroRightNeutral n in v1 92 | merge Z [] _ v2 = v2 93 | merge (S _) v1 (S _) v2 = fst $ merge' v1 v2 94 | 95 | export 96 | tail : OrderedVect (S n) constraint -> OrderedVect n constraint 97 | tail (_ :: v) = v 98 | 99 | export 100 | orderedVectToList : .{constraint : Ordered ty _} -> OrderedVect n constraint -> List ty 101 | orderedVectToList [] = [] 102 | orderedVectToList {n = S _} (x :: xs) = x :: (orderedVectToList xs) 103 | -------------------------------------------------------------------------------- /src/Data/Queue.idr: -------------------------------------------------------------------------------- 1 | module Data.Queue 2 | 3 | import Data.Vect 4 | import Data.VectRankedElem 5 | import Decidable.Order 6 | 7 | %default total 8 | 9 | export 10 | data Queue : (size : Nat) -> (ty : Type) -> Type where 11 | MkQueue : {n : Nat} 12 | -> (f : Vect n ty) 13 | -> {m : Nat} 14 | -> (r : Vect m ty) 15 | -> .{auto invariant : LTE m n} 16 | -> Queue (n + m) ty 17 | 18 | queues : {ty : Type} -> Queue _ ty -> ((size1 : Nat ** Vect size1 ty), 19 | (size2 : Nat ** Vect size2 ty)) 20 | queues (MkQueue {n} f {m} r) = ((n ** f), (m ** r)) 21 | 22 | export 23 | data RankedElem : ty -> Queue size ty -> (idx : Nat) -> Type where 24 | FrontElem : {q : Queue size ty} 25 | -> {idx : Nat} 26 | -> RankedElem x (snd $ fst $ queues q) idx 27 | -> RankedElem x q idx 28 | BackElem : {q : Queue size ty} 29 | -> {idx : Nat} 30 | -> RankedElem x (snd $ snd $ queues q) idx 31 | -> RankedElem x q (size `minus` S idx) 32 | 33 | export 34 | empty : Queue Z _ 35 | empty = MkQueue [] [] 36 | 37 | lteAddRightLemma : LTE r c -> LTE r (l + c) 38 | lteAddRightLemma {l} {r} {c} smaller 39 | = lteTransitive smaller cLTElc 40 | where cLTElc : LTE c (l + c) 41 | cLTElc = rewrite plusCommutative l c in 42 | lteAddRight {m = l} c 43 | 44 | minusPlusEqualsPlusMinus : (l, c, r: Nat) -> LTE r c -> LTE r (l + c) -> (l + c) - r = l + (c - r) 45 | minusPlusEqualsPlusMinus Z _ _ _ _ = Refl 46 | minusPlusEqualsPlusMinus (S _) Z Z _ _ = Refl 47 | minusPlusEqualsPlusMinus (S _) (S _) Z _ _ = Refl 48 | minusPlusEqualsPlusMinus _ Z (S _) _ _ impossible 49 | minusPlusEqualsPlusMinus l (S c) (S r) smaller _ 50 | = let smaller' = fromLteSucc smaller in 51 | rewrite sym $ plusSuccRightSucc l c in 52 | minusPlusEqualsPlusMinus l c r smaller' (lteAddRightLemma smaller') 53 | 54 | make_ : {n : Nat} 55 | -> (f : Vect n ty) 56 | -> {m : Nat} 57 | -> (r : Vect m ty) 58 | -> (ret : Queue (n + m) ty 59 | ** ({x : ty} -> {idx : Nat} -> RankedElem x f idx -> RankedElem x ret idx, 60 | {x : ty} -> {idx : Nat} -> RankedElem x r idx -> RankedElem x ret (n + m `minus` S idx))) 61 | make_ {n} f {m} r with (order {to = LTE} m n) 62 | | Left _ = (MkQueue f r ** (FrontElem, BackElem)) 63 | | Right _ = let (reversed ** rProj) = rev_ r 64 | (f' ** (fProj, reversedProj)) = f `concat_` reversed in 65 | rewrite sym $ plusZeroRightNeutral (n + m) in 66 | (MkQueue f' [] ** (FrontElem . fProj, 67 | rewrite plusZeroRightNeutral (n + m) in 68 | FrontElem . (proj $ reversedProj . rProj))) 69 | where proj : {f' : Vect (n + m) ty} 70 | -> (trans : {x : ty} -> {idx : Nat} -> RankedElem x r idx -> RankedElem x f' (n + (m `minus` S idx))) 71 | -> {x : ty} -> {idx' : Nat} -> RankedElem x r idx' 72 | -> RankedElem x f' (n + m `minus` S idx') 73 | proj {f'} trans {idx'} elem = let smaller = indexSmallerThanSize elem 74 | elem' = trans elem in 75 | rewrite assert_total $ 76 | minusPlusEqualsPlusMinus n m (S idx') smaller (lteAddRightLemma smaller) in 77 | elem' 78 | 79 | export 80 | snoc_ : (q : Queue size ty) -> (x : ty) 81 | -> (ret : Queue (S size) ty 82 | ** ({x : ty} -> {idx : Nat} -> RankedElem x q idx -> RankedElem x ret idx, 83 | RankedElem x ret size)) 84 | snoc_ (MkQueue {n} f {m} r) x = rewrite plusSuccRightSucc n m in 85 | let (ret ** (fProj, rProj)) = make_ f (x::r) in 86 | (ret ** ((\el => case el of 87 | (FrontElem el) => fProj el 88 | (BackElem el {idx}) => rewrite sym $ lemma n m (S idx) in 89 | rProj $ There el), 90 | rewrite sym $ minusZeroRight (n + m) in 91 | rewrite sym $ lemma n m Z in 92 | rProj Here)) 93 | where lemma : (l, c, r : Nat) -> l + S c `minus` S r = l + c `minus` r 94 | lemma Z Z _ = Refl 95 | lemma Z (S _) _ = Refl 96 | lemma (S l) c r = rewrite plusSuccRightSucc l c in Refl 97 | 98 | export 99 | snoc : Queue size ty -> ty -> Queue (S size) ty 100 | snoc q x = fst $ snoc_ q x 101 | 102 | export 103 | head_ : (q : Queue (S _) ty) -> (x : ty ** RankedElem x q Z) 104 | head_ (MkQueue (x :: xs) ys) = (x ** FrontElem Here) 105 | 106 | export 107 | head : Queue (S _) ty -> ty 108 | head q = fst $ head_ q 109 | 110 | export 111 | tail_ : (q : Queue (S size) ty) 112 | -> (ret : Queue size ty 113 | ** {x : ty} -> {idx : Nat} -> RankedElem x q (S idx) -> RankedElem x ret idx) 114 | tail_ (MkQueue (_::fs) r) 115 | = let (ret ** (fProj, rProj)) = make_ fs r in 116 | (ret ** \el => 117 | case toPattern el of 118 | (Z ** (_, Refl)) impossible 119 | (S _ ** (FrontElem (There x), Refl)) => fProj x 120 | (_ ** (BackElem x, prf)) => rewrite toMinusSuccPredEq prf in rProj x) 121 | where toPattern : {q : Queue (S _) ty} 122 | -> {i : Nat} 123 | -> RankedElem x q (S i) 124 | -> (i' ** (RankedElem x q i', S i = i')) 125 | toPattern {i} el = (S i ** (el, Refl)) 126 | toMinusSuccPredEq : S c = x + y `minus` z -> c = x + y `minus` S z 127 | toMinusSuccPredEq {x} {y} {z} prf = rewrite minusSuccPred (x + y) z in cong {f = Nat.pred} prf 128 | 129 | export 130 | tail : Queue (S size) ty -> Queue size ty 131 | tail q = fst $ tail_ q 132 | -------------------------------------------------------------------------------- /src/Data/RandomAccessList.idr: -------------------------------------------------------------------------------- 1 | module Data.RandomAccessList 2 | 3 | import Data.Fin 4 | 5 | %default total 6 | 7 | -- TODO: Use idris-quickcheck to verify that the chosen implementation matches the 8 | -- behavior of an implementation that uses induction (see comments) 9 | select : (size1 : Nat) -> {size2 : Nat} -> Fin (size1 + size2) -> Either (Fin size1) (Fin size2) 10 | -- select Z {size2} idx = Right idx 11 | -- select (S size1) FZ = Left FZ 12 | -- select (S size1) {size2} (FS idx) 13 | -- = case select size1 idx of 14 | -- Left n => Left $ FS n 15 | -- Right n => Right n 16 | select size1 {size2 = Z} idx = Left $ rewrite sym $ plusZeroRightNeutral size1 in idx 17 | select size1 {size2 = S _} idx 18 | = let idxInt = finToInteger idx in 19 | case integerToFin idxInt size1 of 20 | Just idx' => Left idx' 21 | Nothing => Right $ restrict _ (idxInt - cast size1) 22 | 23 | data Tree : (size : Nat) -> (ty : Type) -> Type where 24 | Singleton : (value : ty) -> Tree (S Z) ty 25 | Merged : .{halfSize : Nat} -> (left : Tree halfSize ty) -> (right : Tree halfSize ty) -> Tree (halfSize + halfSize) ty 26 | 27 | treeLookup : {size : Nat} -> Fin size -> Tree size ty -> ty 28 | treeLookup FZ (Singleton x) = x 29 | treeLookup {size = halfSize + halfSize} idx (Merged left right) with (select halfSize idx) 30 | | (Left idx') = treeLookup idx' left 31 | | (Right idx') = treeLookup idx' right 32 | 33 | treeUpdate : {size : Nat} -> Fin size -> Tree size ty -> (ty -> ty) -> Tree size ty 34 | treeUpdate FZ (Singleton x) f = Singleton $ f x 35 | treeUpdate {size = halfSize + halfSize} idx (Merged left right) f with (select halfSize idx) 36 | | (Left idx') = Merged (treeUpdate idx' left f) right 37 | | (Right idx') = Merged left (treeUpdate idx' right f) 38 | 39 | pow2 : Nat -> Nat 40 | pow2 n = power 2 n 41 | 42 | data TreeList : (pos : Nat) -> (size : Nat) -> (ty : Type) -> Type where 43 | Nil : TreeList _ Z _ 44 | (::) : {nextPos : Nat} -> .{auto posPrf : LT pos nextPos} 45 | -> .{size : Nat} -> .{auto smaller : LTE (pow2 pos) size} 46 | -> Tree (pow2 pos) ty -> TreeList nextPos (size - (pow2 pos)) ty 47 | -> TreeList pos size ty 48 | 49 | minusLeftPlusRight : {x, y, z : Nat} -> {auto smaller : LTE y x} 50 | -> x - y = z -> x = y + z 51 | minusLeftPlusRight {x} {y = Z} {z} prf = rewrite sym $ minusZeroRight x in prf 52 | minusLeftPlusRight {x = Z} {y = S _} _ impossible 53 | minusLeftPlusRight {x = S x'} {y = S y'} {z} {smaller} prf 54 | = let smaller' = fromLteSucc smaller 55 | prf' = replace {P = \var => var = z} (minusSuccSucc x' y') prf 56 | ind = minusLeftPlusRight prf' in 57 | cong {f = S} ind 58 | 59 | treeSizeComponents : (pos, size : Nat) -> {auto smaller : LTE (pow2 pos) size} 60 | -> size = pow2 pos + (size - pow2 pos) 61 | treeSizeComponents pos size {smaller} = minusLeftPlusRight Refl 62 | 63 | treeListLookup : {pos, size : Nat} -> Fin size -> TreeList pos size ty -> ty 64 | treeListLookup {pos} {size} idx (t :: ts) 65 | with (let eqPrf = treeSizeComponents pos size 66 | idx' = (replace {P = \x => Fin x} eqPrf idx) in 67 | select (pow2 pos) idx') 68 | | (Left idx') = treeLookup idx' t 69 | | (Right idx') = treeListLookup idx' ts 70 | 71 | treeListUpdate : {pos, size : Nat} -> Fin size -> TreeList pos size ty -> (ty -> ty) -> TreeList pos size ty 72 | treeListUpdate {pos} {size} idx (t :: ts) f 73 | with (let eqPrf = treeSizeComponents pos size 74 | idx' = (replace {P = \x => Fin x} eqPrf idx) in 75 | select (pow2 pos) idx') 76 | | (Left idx') = treeUpdate idx' t f :: ts 77 | | (Right idx') = t :: treeListUpdate idx' ts f 78 | 79 | pow2Lemma : (x : Nat) -> (pow2 x + pow2 x) = pow2 (S x) 80 | pow2Lemma Z = Refl 81 | pow2Lemma (S x) 82 | = let hyp = pow2Lemma x in 83 | rewrite sym hyp in 84 | rewrite plusZeroRightNeutral (pow2 x + pow2 x) in 85 | Refl 86 | 87 | lteAddLeft : (m, n : Nat) -> LTE n (m + n) 88 | lteAddLeft m n = rewrite plusCommutative m n in lteAddRight {m} n 89 | 90 | ltAddRight : (n : Nat) -> {m : Nat} -> LT n (n + (S m)) 91 | ltAddRight n {m} = rewrite sym $ plusSuccRightSucc n m in lteAddRight {m} (S n) 92 | 93 | lteAddBoth : {x, y, x', y' : Nat} -> LTE x y -> LTE x' y' -> LTE (x + x') (y + y') 94 | lteAddBoth {x' = S _} {y' = Z} _ _ impossible 95 | lteAddBoth {x} {y} {x' = Z} {y'} smaller _ 96 | = rewrite plusZeroRightNeutral x in 97 | lteTransitive smaller (lteAddRight y) 98 | lteAddBoth {x} {y} {x' = S x''} {y' = S y''} smaller smaller' 99 | = let ind = lteAddBoth smaller (fromLteSucc smaller') in 100 | rewrite sym $ plusSuccRightSucc x x'' in 101 | rewrite sym $ plusSuccRightSucc y y'' in 102 | LTESucc ind 103 | 104 | pow2Monotone : {n, m : Nat} -> LTE n m -> LTE (pow2 n) (pow2 m) 105 | pow2Monotone {n = Z} {m = Z} _ = LTESucc LTEZero 106 | pow2Monotone {n = Z} {m = S m'} _ 107 | = let prf = pow2Monotone {n = Z} {m = m'} LTEZero in 108 | lteTransitive prf (lteAddRight (pow2 m') {m = (pow2 m' + 0)}) 109 | pow2Monotone {n = S _} {m = Z} _ impossible 110 | pow2Monotone {n = S n'} {m = S m'} smaller 111 | = let prf = pow2Monotone {n = n'} {m = m'} (fromLteSucc smaller) 112 | prf' = lteAddBoth prf (lteRefl {n = Z}) in 113 | lteAddBoth prf prf' 114 | 115 | minusPlusNeutral : (x, y : Nat) -> LTE y x -> (x - y) + y = x 116 | minusPlusNeutral x Z _ 117 | = replace {P = \var => var = x} 118 | (sym $ plusZeroRightNeutral (x `minus` Z)) 119 | (minusZeroRight x) 120 | minusPlusNeutral Z (S _) _ impossible 121 | minusPlusNeutral (S x) (S y) prf 122 | = let ind = minusPlusNeutral x y (fromLteSucc prf) 123 | succPrf = plusSuccRightSucc (x `minus` y) y in 124 | rewrite sym succPrf in 125 | cong {f = S} ind 126 | 127 | plusMinusAssociative : (a, b, c : Nat) -> {auto smaller : LTE c b} -> a + (b `minus` c) = (a + b) `minus` c 128 | plusMinusAssociative a b Z 129 | = rewrite minusZeroRight b in 130 | rewrite minusZeroRight (a + b) in 131 | Refl 132 | plusMinusAssociative a Z (S _) impossible 133 | plusMinusAssociative a (S b) (S c) {smaller} 134 | = let ind = plusMinusAssociative {smaller = fromLteSucc smaller} a b c 135 | succPrf = sym $ minusSuccSucc (a + b) c 136 | p = \x => (a + b) `minus` c = x `minus` (S c) 137 | succPrf' = replace {P = p} (plusSuccRightSucc a b) succPrf in 138 | replace {P = \x => a + (b `minus` c) = x} succPrf' ind 139 | 140 | lteReflAddLeftContra : LTE (x + S y) x -> Void 141 | lteReflAddLeftContra {x = S _} LTEZero impossible 142 | lteReflAddLeftContra (LTESucc {left = Z + S y} {right = Z} prf) impossible 143 | lteReflAddLeftContra (LTESucc {left = S x + S y} {right = S x} prf) = absurd $ lteReflAddLeftContra prf 144 | 145 | treeListCons : {tPos, pos : Nat} -> Tree (pow2 tPos) ty -> TreeList pos size ty -> .{auto fits : LTE tPos pos} 146 | -> (newPos : Nat ** TreeList newPos (size + (pow2 tPos)) ty) 147 | treeListCons {ty} {tPos} t Nil = rewrite plusCommutative Z (pow2 tPos) in 148 | rewrite plusZeroRightNeutral (pow2 tPos) in 149 | let nil = replace {P = \x => TreeList (S tPos) x ty} 150 | (minusZeroN (pow2 tPos)) 151 | RandomAccessList.Nil 152 | ts' = (::) {nextPos = S tPos} {posPrf = lteRefl} {smaller = lteRefl} t nil in 153 | (tPos ** ts') 154 | treeListCons {tPos} {pos} {size} t' ((::) {smaller} t ts) {fits} {ty} 155 | = case cmp tPos pos of 156 | CmpEQ => let merged = Merged t' t 157 | merged' = replace {P = \x => Tree x ty} (pow2Lemma tPos) merged 158 | (newPos ** ts') = treeListCons {tPos = S tPos} merged' ts in 159 | rewrite sym $ plusZeroRightNeutral (pow2 tPos) in 160 | rewrite sym $ minusPlusNeutral size (pow2 tPos) $ 161 | lteTransitive (pow2Monotone fits) smaller in 162 | rewrite sym $ plusAssociative (size `minus` pow2 tPos) (pow2 tPos) (pow2 tPos + Z) in 163 | (newPos ** ts') 164 | CmpLT diff => let p = plusZeroRightNeutral size 165 | p' = minusZeroN $ pow2 tPos 166 | p'' = replace {P = \x => size + x = size} p' p 167 | p''' = replace {P = \x => x = size} (plusMinusAssociative {smaller = lteRefl} size (pow2 tPos) (pow2 tPos)) p'' 168 | ts' = (::) {smaller} t ts 169 | ts'' = replace {P = \s => TreeList (tPos + (S diff)) s ty} (sym p''') ts' 170 | ts''' = RandomAccessList.(::) {posPrf = ltAddRight tPos} {smaller = lteAddLeft size (pow2 tPos)} t' ts'' in 171 | (tPos ** ts''') 172 | CmpGT diff => absurd $ lteReflAddLeftContra fits 173 | 174 | pow2StrictlyPositive : (n : Nat) -> LTE 1 (pow2 n) 175 | pow2StrictlyPositive Z = lteRefl 176 | pow2StrictlyPositive (S n) 177 | = let ind = pow2StrictlyPositive n in 178 | lteTransitive ind (lteAddRight {m = pow2 n + Z} (pow2 n)) 179 | 180 | equalsNotLT : {n, m : Nat} -> n = m -> LT n m -> Void 181 | equalsNotLT {n = Z} {m = Z} _ lt impossible 182 | equalsNotLT {n = Z} {m = S _} Refl _ impossible 183 | equalsNotLT {n = S _} {m = Z} Refl _ impossible 184 | equalsNotLT {n = S n'} {m = S m'} eq (LTESucc lt') 185 | = equalsNotLT (cong {f = Nat.pred} eq) lt' 186 | 187 | treeListTailHelper : {tPos, tsPos, size : Nat} 188 | -> Tree (pow2 tPos) ty 189 | -> TreeList tsPos size ty 190 | -> {posPrf : LTE tPos tsPos} 191 | -> let smaller = lteTransitive (pow2StrictlyPositive tPos) 192 | (lteAddRight {m = size} (pow2 tPos)) in 193 | (pos' ** TreeList pos' ((-) {smaller} (pow2 tPos + size) (S Z)) ty) 194 | treeListTailHelper {size} {tPos = Z} _ ts = rewrite minusZeroRight size in (_ ** ts) 195 | treeListTailHelper {ty} {size} {tPos = S pos'} t {tsPos} {posPrf} ts 196 | = let (_ ** (t', eqPrf)) = eraseSize t in 197 | case t' of 198 | Singleton _ => void $ notSingleton eqPrf 199 | Merged {halfSize} l r => 200 | let eqPrf' = replace {P = \y => halfSize + halfSize = pow2 pos' + y} (plusZeroRightNeutral $ pow2 pos') eqPrf 201 | l' = replace {P = \x => Tree x ty} (halve eqPrf') l 202 | r' = replace {P = \x => Tree x ty} (halve eqPrf') r 203 | p = plusZeroRightNeutral size 204 | p' = minusZeroN $ pow2 pos' 205 | p'' = replace {P = \x => size + x = size} p' p 206 | p''' = replace {P = \x => x = size} (plusMinusAssociative {smaller = lteRefl} size (pow2 pos') (pow2 pos')) p'' 207 | ts' = replace {P = \x => TreeList tsPos x ty} (sym p''') ts 208 | ts'' = RandomAccessList.(::) {posPrf} {smaller = lteAddLeft size (pow2 pos')} r' ts' in 209 | rewrite plusZeroRightNeutral (pow2 pos') in 210 | rewrite sym $ plusAssociative (pow2 pos') (pow2 pos') size in 211 | rewrite plusCommutative (pow2 pos') size in 212 | treeListTailHelper {posPrf = lteRefl} l' ts'' 213 | where eraseSize : {n : Nat} -> Tree n ty -> (n' : Nat ** (Tree n' ty, n' = n)) 214 | eraseSize t = (_ ** (t, Refl)) 215 | halve : {x, y : Nat} -> x + x = y + y -> x = y 216 | halve {x = Z} {y = S _} Refl impossible 217 | halve {x = S _} {y = Z} Refl impossible 218 | halve {x = Z} {y = Z} _ = Refl 219 | halve {x = S x'} {y = S y'} prf = cong {f = S} $ halve prev 220 | where prev : x' + x' = y' + y' 221 | prev = let prf' = replace {P = \var => var = S (S y' + y')} 222 | (sym $ plusSuccRightSucc (S x') x') $ 223 | replace {P = \var => S x' + S x' = var} 224 | (sym $ plusSuccRightSucc (S y') y') 225 | prf in 226 | cong {f = Nat.pred . Nat.pred} prf' 227 | notSingleton : {n : Nat} -> 1 = (pow2 n) + (pow2 n + Z) -> Void 228 | notSingleton {n} eq 229 | = let eq' = replace {P = \var => 1 = pow2 n + var} 230 | (plusZeroRightNeutral $ pow2 n) 231 | eq 232 | lte = pow2StrictlyPositive n 233 | lte' = lteAddBoth lte lte in 234 | void $ equalsNotLT eq' lte' 235 | 236 | treeListTail : {pos, size : Nat} -> TreeList pos (S size) ty -> (newPos : Nat ** TreeList newPos size ty) 237 | treeListTail {ty} {pos} {size} ((::) {posPrf} t ts) 238 | = let (newPos ** newList) = treeListTailHelper {posPrf = lteSuccLeft posPrf} t ts 239 | p = plusMinusAssociative (pow2 pos) (S size) (pow2 pos) 240 | newList' = replace {P = \x => TreeList newPos (x `minus` 1) ty} p newList 241 | p' = plusCommutative (pow2 pos) (S size) 242 | newList'' = replace {P = \x => TreeList newPos ((x `minus` pow2 pos) `minus` 1) ty} p' newList' 243 | p'' = sym $ plusMinusAssociative {smaller = lteRefl} (S size) (pow2 pos) (pow2 pos) 244 | newList''' = replace {P = \x => TreeList newPos (x `minus` 1) ty} p'' newList'' in 245 | rewrite sym $ plusZeroRightNeutral size in 246 | rewrite minusZeroN $ pow2 pos in 247 | rewrite sym $ minusZeroRight (size + (pow2 pos `minus` pow2 pos)) in 248 | (newPos ** newList''') 249 | 250 | namespace RandomAccessList 251 | export 252 | RandomAccessList : Nat -> Type -> Type 253 | RandomAccessList size ty = (pos : Nat ** TreeList pos size ty) 254 | 255 | export 256 | empty : RandomAccessList Z ty 257 | empty = (Z ** Nil) 258 | 259 | export 260 | cons : ty -> RandomAccessList size ty -> RandomAccessList (S size) ty 261 | cons {size} x (pos ** l) 262 | = let (pos' ** l') = treeListCons (Singleton x) l in 263 | rewrite plusCommutative (S Z) size in 264 | (pos' ** l') 265 | 266 | export 267 | tail : {size : Nat} -> RandomAccessList (S size) ty -> RandomAccessList size ty 268 | tail (pos ** l) = treeListTail l 269 | 270 | export 271 | index : {size : Nat} -> Fin size -> RandomAccessList size ty -> ty 272 | index idx (pos ** l) = treeListLookup idx l 273 | 274 | export 275 | update : {size : Nat} -> Fin size -> RandomAccessList size ty -> (ty -> ty) -> RandomAccessList size ty 276 | update idx (pos ** l) f = (pos ** treeListUpdate idx l f) 277 | 278 | namespace CountedRandomAccessList 279 | export 280 | CountedRandomAccessList : Type -> Type 281 | CountedRandomAccessList ty = (len : Nat ** RandomAccessList len ty) 282 | 283 | export 284 | empty : CountedRandomAccessList ty 285 | empty = (Z ** RandomAccessList.empty) 286 | 287 | export 288 | cons : ty -> CountedRandomAccessList ty -> CountedRandomAccessList ty 289 | cons x (size ** arr) = (S size ** cons x arr) 290 | 291 | export 292 | tail : CountedRandomAccessList ty -> CountedRandomAccessList ty 293 | tail (Z ** arr) = (Z ** arr) 294 | tail (S size ** arr) = (size ** tail arr) 295 | 296 | export 297 | size : CountedRandomAccessList ty -> Nat 298 | size (size ** _) = size 299 | 300 | export 301 | index : (idx : Nat) -> (carr : CountedRandomAccessList ty) -> Maybe ty 302 | index idx (size ** arr) 303 | = do finIdx <- natToFin idx size 304 | pure $ index finIdx arr 305 | 306 | export 307 | update : (idx : Nat) -> (carr : CountedRandomAccessList ty) -> (ty -> ty) -> CountedRandomAccessList ty 308 | update idx (size ** arr) f 309 | = maybe (size ** arr) 310 | (\finIdx => (size ** update finIdx arr f)) 311 | (natToFin idx size) 312 | -------------------------------------------------------------------------------- /src/Data/VectRankedElem.idr: -------------------------------------------------------------------------------- 1 | module VectRankedElem 2 | 3 | import Data.Vect 4 | import Decidable.Order 5 | 6 | %default total 7 | 8 | public export 9 | data RankedElem : ty -> Vect _ ty -> (idx : Nat) -> Type where 10 | Here : {v : Vect (S _) ty} -> RankedElem (head v) v Z 11 | There : RankedElem a xs idx -> RankedElem a (x::xs) (S idx) 12 | 13 | export 14 | indexSmallerThanSize : {v : Vect size ty} -> {idx : Nat} -> RankedElem x v idx -> LT idx size 15 | indexSmallerThanSize {size = Z} _ impossible 16 | indexSmallerThanSize {size = S len} Here = shift Z len zeroAlwaysSmaller 17 | indexSmallerThanSize {size = S len} {v = (x::xs)} {idx = S n} (There elem) 18 | = shift (S n) len $ indexSmallerThanSize elem 19 | 20 | export 21 | Uninhabited (RankedElem _ [] _) where 22 | uninhabited _ impossible 23 | 24 | export 25 | cons_ : (x : ty) -> (v : Vect size ty) 26 | -> (ret : Vect (S size) ty 27 | ** ({a : ty} -> {n : Nat} -> RankedElem a v n -> RankedElem a ret (S n), 28 | RankedElem x ret Z)) 29 | cons_ x [] = ([x] ** (absurd, Here)) 30 | cons_ x (y::ys) = (x::y::ys ** (f, Here)) 31 | where f : {a : ty} -> {n : Nat} -> RankedElem a (y::ys) n -> RankedElem a (x::y::ys) (S n) 32 | f elem = There elem 33 | 34 | export 35 | cons : ty -> Vect size ty -> Vect (S size) ty 36 | cons x v = fst $ cons_ x v 37 | 38 | export 39 | concat_ : {size1, size2 : Nat} 40 | -> (v1 : Vect size1 ty) -> (v2 : Vect size2 ty) 41 | -> (ret : Vect (size1 + size2) ty 42 | ** ({a : ty} -> {n : Nat} -> RankedElem a v1 n -> RankedElem a ret n, 43 | {a : ty} -> {n : Nat} -> RankedElem a v2 n -> RankedElem a ret (size1 + n))) 44 | concat_ [] ys = (ys ** (absurd, id)) 45 | concat_ {size1} xs [] = rewrite plusZeroRightNeutral size1 in 46 | (xs ** (id, absurd)) 47 | concat_ (x::xs) (y::ys) = let (ret ** (f, g)) = xs `concat_` (y::ys) in 48 | (x :: ret ** (ff f, gg g)) 49 | where ff : {ret : Vect (size1 + size2) ty} 50 | -> ({a : ty} -> {n : Nat} -> RankedElem a xs n -> RankedElem a ret n) 51 | -> {a : ty} -> {n : Nat} -> (RankedElem a (x::xs) n -> RankedElem a (x::ret) n) 52 | ff f Here = Here 53 | ff f (There elem) = There $ f elem 54 | gg : {ret : Vect (size1 + size2) ty} 55 | -> ({a : ty} -> {n : Nat} -> RankedElem a (y::ys) n -> RankedElem a ret (size1 + n)) 56 | -> {a : ty} -> {n : Nat} -> (RankedElem a (y::ys) n -> RankedElem a (x::ret) (S $ size1 + n)) 57 | gg g elem = There $ g elem 58 | 59 | export 60 | concat : {size1, size2 : Nat} -> Vect size1 ty -> Vect size2 ty -> Vect (size1 + size2) ty 61 | concat v1 v2 = fst $ concat_ v1 v2 62 | 63 | export 64 | rev_ : {size : Nat} -> (orig : Vect size ty) 65 | -> (ret : Vect size ty ** {a : ty} -> {n : Nat} -> RankedElem a orig n -> RankedElem a ret (size `minus` (S n))) 66 | rev_ [] = ([] ** absurd) 67 | rev_ ((::) {len} x xs) = rewrite plusCommutative 1 len in 68 | let (sx ** h) = rev_ xs 69 | (ret ** (f, g)) = sx `concat_` [x] in 70 | (ret ** fgh f g h) 71 | where fgh : ({a : ty} -> {n : Nat} -> RankedElem a sx n -> RankedElem a ret n) 72 | -> ({a : ty} -> {n : Nat} -> RankedElem a [x] n -> RankedElem a ret (len + n)) 73 | -> ({a : ty} -> {n : Nat} -> RankedElem a xs n -> RankedElem a sx (len `minus` (S n))) 74 | -> {a : ty} -> {n : Nat} -> RankedElem a (x::xs) n -> RankedElem a ret (len `minus` n) 75 | fgh f g h Here = rewrite minusZeroRight len in 76 | rewrite sym $ plusZeroRightNeutral len in 77 | g Here 78 | fgh f g h (There elem) = f $ h elem 79 | 80 | export 81 | rev : {size : Nat} -> Vect size ty -> Vect size ty 82 | rev v = fst $ rev_ v -------------------------------------------------------------------------------- /src/Decidable/IntOrder.idr: -------------------------------------------------------------------------------- 1 | module Decidable.IntOrder 2 | 3 | import Decidable.Order 4 | 5 | %default total 6 | 7 | public export 8 | data LTE : Int -> Int -> Type where 9 | Compare : (a : Int) -> (b : Int) -> { auto prf : a <= b = True} -> LTE a b 10 | Reflexive : (a : Int) -> LTE a a 11 | Transitive : (a : Int) -> (b : Int) -> (c : Int) -> (ab : LTE a b) -> (bc : LTE b c) -> LTE a c 12 | Ordered : (a : Int) -> (b : Int) -> { auto contra : (a <= b = True) -> Void } -> LTE b a 13 | 14 | export 15 | implementation Preorder Int LTE where 16 | transitive = Transitive 17 | reflexive = Reflexive 18 | 19 | export 20 | implementation Poset Int LTE where 21 | antisymmetric x _ _ _ = really_believe_me $ Refl {x} 22 | 23 | export 24 | implementation Ordered Int LTE where 25 | order a b = case decEq (a <= b) True of 26 | Yes prf => Left $ Compare {prf} a b 27 | No contra => Right $ Ordered {contra} a b -------------------------------------------------------------------------------- /src/Test/Main.idr: -------------------------------------------------------------------------------- 1 | module Test.Main 2 | 3 | -- contrib 4 | import Decidable.Order 5 | import Test.Unit 6 | 7 | -- Fast really_believe_me implementation of Ordered for Int 8 | import Decidable.IntOrder 9 | 10 | -- data structures 11 | import Data.Vect 12 | import Data.LeftistHeap 13 | import Data.OrderedVect 14 | import Data.MergeList 15 | import Data.LazyPairingHeap 16 | import Data.VectRankedElem 17 | import Data.Queue 18 | import Data.BinarySearchTree 19 | import Data.RandomAccessList 20 | 21 | %default total 22 | 23 | -- taken from the Type-Driven Development book 24 | randoms : Int -> Stream Int 25 | randoms seed = let seed' = 1664525 * seed + 1013904223 in 26 | (seed' `shiftR` 2) :: randoms seed' 27 | 28 | namespace CountedOrderedVect 29 | toVect : {constraint : Ordered Int LTE} -> (cnt : Nat ** Lazy $ MergeList 1 cnt constraint) -> (cnt ** OrderedVect cnt constraint) 30 | toVect (cnt ** xs) = (cnt ** mergeListToOrderedVect 1 cnt xs) 31 | head : {constraint : Ordered Int LTE} -> (cnt ** OrderedVect cnt constraint) -> Maybe Int 32 | head (Z ** Nil) = Nothing 33 | head (_ ** x::xs) = Just x 34 | tail : {constraint : Ordered Int LTE} -> (cnt ** OrderedVect cnt constraint) -> (cnt ** OrderedVect cnt constraint) 35 | tail (Z ** Nil) = (Z ** []) 36 | tail (S cnt ** x::xs) = (cnt ** xs) 37 | 38 | ||| Showcase basic operations on the various data structures in this module 39 | ||| and verify that proofs are erased as expected: 40 | ||| 41 | ||| idris --warnreach --testpkg data.ipkg 42 | export 43 | mainTests : IO () 44 | mainTests 45 | = do putStrLn "Start" 46 | let l = take 10000 $ randoms 42 47 | let leftistHeap = foldl (flip insert) emptyHeap l 48 | let mergeList = foldl CountedMergeList.insert emptyMergeList l 49 | let pairingHeap = foldl CountedPairingHeap.insert emptyPairingHeap l 50 | let binaryTree = foldl BinarySearchTree.insert emptyBinaryTree l 51 | let countedRandomAccessList = foldl (flip CountedRandomAccessList.cons) CountedRandomAccessList.empty l 52 | putStrLn "Results: " 53 | putStrLn $ show $ findMin $ deleteMin leftistHeap 54 | putStrLn $ show $ count $ leftistHeap 55 | 56 | -- putStrLn $ show $ CountedOrderedVect.head $ tail $ toVect mergeList 57 | -- ^ broken on Idris 1.3.1, works on 1.3.0 58 | -- A more modest alternative: 59 | let mergeList' = foldl CountedMergeList.insert emptyMergeList $ take 1000 l 60 | putStrLn $ show $ CountedOrderedVect.head $ tail $ toVect mergeList' 61 | 62 | putStrLn $ show $ CountedPairingHeap.findMin $ deleteMin pairingHeap 63 | putStrLn $ show $ head $ VectRankedElem.cons 0 $ rev $ [1, 2, 3] `concat` [4, 5] 64 | putStrLn $ show $ Queue.head $ tail queue 65 | 66 | -- putStrLn $ show $ 1 `elem` binaryTree 67 | -- ^ broken on Idris 1.3.0, works on 1.3.1 68 | -- See https://github.com/idris-lang/Idris-dev/issues/4090 69 | -- Nat.LTE alternative: 70 | let emptyNatTree = emptyBinaryTree {ty = Nat} {rel = Nat.LTE} 71 | let natTree = foldl BinarySearchTree.insert emptyNatTree (the (List Nat) [0, 1, 2]) 72 | putStrLn $ show $ 1 `elem` natTree 73 | 74 | putStrLn $ show $ the (Maybe Int) $ CountedRandomAccessList.index 2 $ CountedRandomAccessList.tail $ CountedRandomAccessList.update 2 countedRandomAccessList (const (the Int 42)) 75 | putStrLn "End" 76 | pure () 77 | where 78 | emptyHeap : {auto constraint : Ordered Int LTE} -> CountedHeap constraint 79 | emptyHeap = empty 80 | emptyMergeList : {auto constraint : Ordered Int LTE} -> CountedMergeList 1 constraint 81 | emptyMergeList = empty 82 | emptyPairingHeap : {auto constraint : Ordered Int LTE} -> CountedPairingHeap constraint 83 | emptyPairingHeap = CountedPairingHeap.empty 84 | queue : Queue 4 Int 85 | queue = snoc (snoc (snoc (snoc empty 1) 2) 3) 4 86 | emptyBinaryTree : {default Int ty : Type} -> {default LTE rel : ty -> ty -> Type} -> 87 | {auto constraint : Ordered ty rel} -> (len : Nat ** BinarySearchTree constraint len) 88 | emptyBinaryTree = (Z ** Empty) 89 | 90 | export 91 | randomAccessListTests : IO () 92 | randomAccessListTests 93 | = do runTests $ 94 | [ assertEquals (at (n + 1)) Nothing ] ++ 95 | (flip map) range (\i => assertEquals (at i) $ Just (n `minus` i)) 96 | where n : Nat 97 | n = 6 98 | range : List Nat 99 | range = [0..n] 100 | ral : CountedRandomAccessList Nat 101 | ral = foldl (flip cons) CountedRandomAccessList.empty range 102 | at : Nat -> Maybe Nat 103 | at = (`index` ral) 104 | --------------------------------------------------------------------------------