├── .gitignore ├── InsertionSort.idr ├── LICENSE ├── Makefile └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | # OS X 2 | .DS_Store 3 | 4 | # Idris 5 | *.ibc 6 | 7 | # Build outputs 8 | InsertionSort 9 | -------------------------------------------------------------------------------- /InsertionSort.idr: -------------------------------------------------------------------------------- 1 | import Data.So 2 | import Data.Vect 3 | 4 | -------------------------------------------------------------------------------- 5 | -- Utility 6 | 7 | -- Makes a best effort to return an error message. 8 | -- Use this only on code paths that you can deduce should be unreachable. 9 | unsafeError : String -> a 10 | unsafeError message = believe_me message 11 | 12 | -- Unwraps a `Just a` to a plain `a`. 13 | -- Useful for command-line debugging but unsafe for general program usage. 14 | unsafeUnwrapJust : (Maybe a) -> a 15 | unsafeUnwrapJust (Just x) = 16 | x 17 | unsafeUnwrapJust (Nothing) = 18 | unsafeError "The specified Maybe was not a Just." 19 | 20 | -------------------------------------------------------------------------------- 21 | -- IsLte 22 | 23 | -- Proof that `x <= y`. 24 | IsLte : Ord e => (x:e) -> (y:e) -> Type 25 | IsLte x y = So (x <= y) 26 | 27 | mkIsLte : Ord e => (x:e) -> (y:e) -> Maybe (IsLte x y) 28 | mkIsLte x y = 29 | case choose (x <= y) of 30 | Left proofXLteY => 31 | Just proofXLteY 32 | Right proofNotXLteY => 33 | Nothing 34 | 35 | -- Given an `x` and a `y`, returns a proof that either `x <= y` or `y <= x`. 36 | chooseLte : 37 | Ord e => 38 | (x:e) -> (y:e) -> 39 | Either (IsLte x y) (IsLte y x) 40 | chooseLte x y = 41 | case choose (x <= y) of 42 | Left proofXLteY => 43 | Left proofXLteY 44 | Right proofNotXLteY => 45 | -- Given: not (x <= y) 46 | -- Derive: x > y 47 | -- Derive: y < x 48 | -- Derive: y <= x 49 | -- 50 | -- Unfortunately Ord doesn't guarantee the preceding 51 | -- even though any sane implementation will conform 52 | -- to those rules. 53 | case choose (y <= x) of 54 | Left proofYLteX => 55 | Right proofYLteX 56 | Right proofNotYLteX => 57 | unsafeError "Impossible with a sane Ord implementation." 58 | 59 | -------------------------------------------------------------------------------- 60 | -- IsSorted 61 | 62 | -- Proof that `xs` is sorted. 63 | data IsSorted : (xs:Vect n e) -> Type where 64 | IsSortedZero : 65 | IsSorted Nil 66 | IsSortedOne : 67 | Ord e => 68 | (x:e) -> 69 | IsSorted (x::Nil) 70 | IsSortedMany : 71 | Ord e => 72 | (x:e) -> (y:e) -> (ys:Vect n'' e) -> -- (n'' == (n - 2)) 73 | (IsLte x y) -> IsSorted (y::ys) -> 74 | IsSorted (x::(y::ys)) 75 | 76 | mkIsSorted : Ord e => (xs:Vect n e) -> Maybe (IsSorted xs) 77 | mkIsSorted Nil = 78 | Just IsSortedZero 79 | mkIsSorted (x::Nil) = 80 | Just (IsSortedOne x) 81 | mkIsSorted (x::(y::ys)) = 82 | case (mkIsLte x y) of 83 | Just proofXLteY => 84 | case (mkIsSorted (y::ys)) of 85 | Just proofYYsIsSorted => 86 | Just (IsSortedMany x y ys proofXLteY proofYYsIsSorted) 87 | Nothing => 88 | Nothing 89 | Nothing => 90 | Nothing 91 | 92 | -------------------------------------------------------------------------------- 93 | -- ElemsAreSame 94 | 95 | -- Proof that set `xs` and set `ys` contain the same elements. 96 | data ElemsAreSame : (xs:Vect n e) -> (ys:Vect n e) -> Type where 97 | NilIsNil : 98 | ElemsAreSame Nil Nil 99 | PrependXIsPrependX : 100 | (x:e) -> ElemsAreSame zs zs' -> 101 | ElemsAreSame (x::zs) (x::zs') 102 | PrependXYIsPrependYX : 103 | (x:e) -> (y:e) -> ElemsAreSame zs zs' -> 104 | ElemsAreSame (x::(y::zs)) (y::(x::(zs'))) 105 | -- NOTE: Probably could derive this last axiom from the prior ones 106 | SamenessIsTransitive : 107 | ElemsAreSame xs zs -> ElemsAreSame zs ys -> 108 | ElemsAreSame xs ys 109 | 110 | XsIsXs : (xs:Vect n e) -> ElemsAreSame xs xs 111 | XsIsXs Nil = 112 | NilIsNil 113 | XsIsXs (x::ys) = 114 | PrependXIsPrependX x (XsIsXs ys) 115 | 116 | flip : ElemsAreSame xs ys -> ElemsAreSame ys xs 117 | flip NilIsNil = 118 | NilIsNil 119 | flip (PrependXIsPrependX x proofXsTailIsYsTail) = 120 | PrependXIsPrependX x (flip proofXsTailIsYsTail) 121 | flip (PrependXYIsPrependYX x y proofXsLongtailIsYsLongtail) = 122 | PrependXYIsPrependYX y x (flip proofXsLongtailIsYsLongtail) 123 | flip (SamenessIsTransitive proofXsIsZs proofZsIsYs) = 124 | let proofYsIsZs = flip proofZsIsYs in 125 | let proofZsIsXs = flip proofXsIsZs in 126 | let proofYsIsXs = SamenessIsTransitive proofYsIsZs proofZsIsXs in 127 | proofYsIsXs 128 | 129 | -- NOTE: Needed to explicitly pull out the {x}, {y}, {zs}, {us} implicit parameters. 130 | swapFirstAndSecondOfLeft : ElemsAreSame (x::(y::zs)) us -> ElemsAreSame (y::(x::zs)) us 131 | swapFirstAndSecondOfLeft {x} {y} {zs} {us} proofXYZsIsUs = 132 | let proofYXZsIsXYZs = PrependXYIsPrependYX y x (XsIsXs zs) in 133 | let proofYZZsIsUs = SamenessIsTransitive proofYXZsIsXYZs proofXYZsIsUs in 134 | proofYZZsIsUs 135 | 136 | -------------------------------------------------------------------------------- 137 | -- HeadIs, HeadIsEither 138 | 139 | -- Proof that the specified vector has the specified head. 140 | data HeadIs : Vect n e -> e -> Type where 141 | MkHeadIs : HeadIs (x::xs) x 142 | 143 | -- Proof that the specified vector has one of the two specified heads. 144 | -- 145 | -- NOTE: Could implement this as an `Either (HeadIs xs x) (HeadIs xs y)`, 146 | -- but an explicit formulation feels cleaner. 147 | data HeadIsEither : Vect n e -> (x:e) -> (y:e) -> Type where 148 | HeadIsLeft : HeadIsEither (x::xs) x y 149 | HeadIsRight : HeadIsEither (x::xs) y x 150 | 151 | -------------------------------------------------------------------------------- 152 | -- Insertion Sort 153 | 154 | -- Inserts an element into a non-empty sorted vector, returning a new 155 | -- sorted vector containing the new element plus the original elements. 156 | insert' : 157 | Ord e => 158 | (xs:Vect (S n) e) -> (y:e) -> (IsSorted xs) -> (HeadIs xs x) -> 159 | (xs':(Vect (S (S n)) e) ** ((IsSorted xs'), (HeadIsEither xs' x y), (ElemsAreSame (y::xs) xs'))) 160 | insert' (x::Nil) y (IsSortedOne x) MkHeadIs = 161 | case (chooseLte x y) of 162 | Left proofXLteY => 163 | let yXNilSameXYNil = PrependXYIsPrependYX y x (XsIsXs Nil) in 164 | (x::(y::Nil) ** 165 | (IsSortedMany x y Nil proofXLteY (IsSortedOne y), 166 | HeadIsLeft, 167 | yXNilSameXYNil)) 168 | Right proofYLteX => 169 | let yXNilSameYXNil = XsIsXs (y::(x::Nil)) in 170 | (y::(x::Nil) ** 171 | (IsSortedMany y x Nil proofYLteX (IsSortedOne x), 172 | HeadIsRight, 173 | yXNilSameYXNil)) 174 | insert' (x::(y::ys)) z proofXYYsIsSorted MkHeadIs = 175 | case proofXYYsIsSorted of 176 | (IsSortedMany x y ys proofXLteY proofYYsIsSorted) => 177 | case (chooseLte x z) of 178 | Left proofXLteZ => 179 | -- x::(insert' (y::ys) z) 180 | let proofHeadYYsIsY = the (HeadIs (y::ys) y) MkHeadIs in 181 | case (insert' (y::ys) z proofYYsIsSorted proofHeadYYsIsY) of 182 | -- rest == (_::tailOfRest) 183 | ((y::tailOfRest) ** (proofRestIsSorted, HeadIsLeft, proofZYYsSameRest)) => 184 | let proofXZYYsIsXRest = PrependXIsPrependX x proofZYYsSameRest in 185 | let proofZXYYsIsXRest = swapFirstAndSecondOfLeft proofXZYYsIsXRest in 186 | (x::(y::tailOfRest) ** 187 | (IsSortedMany x y tailOfRest proofXLteY proofRestIsSorted, 188 | HeadIsLeft, 189 | proofZXYYsIsXRest)) 190 | ((z::tailOfRest) ** (proofRestIsSorted, HeadIsRight, proofZYYsSameRest)) => 191 | let proofXZYYsIsXRest = PrependXIsPrependX x proofZYYsSameRest in 192 | let proofZXYYsIsXRest = swapFirstAndSecondOfLeft proofXZYYsIsXRest in 193 | (x::(z::tailOfRest) ** 194 | (IsSortedMany x z tailOfRest proofXLteZ proofRestIsSorted, 195 | HeadIsLeft, 196 | proofZXYYsIsXRest)) 197 | Right proofZLteX => 198 | -- z::(x::(y::ys)) 199 | let proofZXYYsIsZXYYs = XsIsXs (z::(x::(y::ys))) in 200 | (z::(x::(y::ys)) ** 201 | (IsSortedMany z x (y::ys) proofZLteX proofXYYsIsSorted, 202 | HeadIsRight, 203 | proofZXYYsIsZXYYs)) 204 | 205 | -- Inserts an element into a sorted vector, returning a new 206 | -- sorted vector containing the new element plus the original elements. 207 | insert : 208 | Ord e => 209 | (xs:Vect n e) -> (y:e) -> (IsSorted xs) -> 210 | (xs':(Vect (S n) e) ** ((IsSorted xs'), (ElemsAreSame (y::xs) xs'))) 211 | insert Nil y IsSortedZero = 212 | ([y] ** (IsSortedOne y, XsIsXs [y])) 213 | insert (x::xs) y proofXXsIsSorted = 214 | let proofHeadOfXXsIsX = the (HeadIs (x::xs) x) MkHeadIs in 215 | case (insert' (x::xs) y proofXXsIsSorted proofHeadOfXXsIsX) of 216 | (xs' ** (proofXsNewIsSorted, proofHeadXsNewIsXOrY, proofYXXsIsXsNew)) => 217 | (xs' ** (proofXsNewIsSorted, proofYXXsIsXsNew)) 218 | 219 | -- Sorts the specified vector, 220 | -- returning a new sorted vector with the same elements. 221 | insertionSort : 222 | Ord e => 223 | (xs:Vect n e) -> 224 | (xs':Vect n e ** (IsSorted xs', ElemsAreSame xs xs')) 225 | insertionSort Nil = 226 | (Nil ** (IsSortedZero, NilIsNil)) 227 | insertionSort (x::ys) = 228 | case (insertionSort ys) of 229 | (ysNew ** (proofYsNewIsSorted, proofYsIsYsNew)) => 230 | case (insert ysNew x proofYsNewIsSorted) of 231 | (result ** (proofResultIsSorted, proofXYsNewIsResult)) => 232 | let proofXYsIsXYsNew = PrependXIsPrependX x proofYsIsYsNew in 233 | let proofXYsIsResult = SamenessIsTransitive proofXYsIsXYsNew proofXYsNewIsResult in 234 | (result ** (proofResultIsSorted, proofXYsIsResult)) 235 | 236 | -------------------------------------------------------------------------------- 237 | -- Main 238 | 239 | -- Parses an integer from a string, returning 0 if there is an error. 240 | parseInt : String -> Integer 241 | parseInt s = 242 | the Integer (cast s) 243 | 244 | -- Joins a list of elements with the provided separator, 245 | -- returning a separator-separated string. 246 | intercalate : Show e => (xs:Vect n e) -> (sep:String) -> String 247 | intercalate Nil sep = 248 | "" 249 | intercalate (x::Nil) sep = 250 | show x 251 | intercalate (x::(y::zs)) sep = 252 | (show x) ++ sep ++ (intercalate (y::zs) sep) 253 | 254 | main : IO () 255 | main = do 256 | putStrLn "Please type a space-separated list of integers: " 257 | csv <- getLine 258 | let numbers = map parseInt (words csv) 259 | let (sortedNumbers ** (_, _)) = insertionSort (fromList numbers) 260 | putStrLn "After sorting, the integers are: " 261 | putStrLn (intercalate sortedNumbers " ") 262 | 263 | -------------------------------------------------------------------------------- 264 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2015 David Foster 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | compile: 2 | idris -o InsertionSort InsertionSort.idr 3 | 4 | run: compile 5 | ./InsertionSort 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # idris-insertion-sort 2 | 3 | This is a provably correct implementation of insertion sort in Idris. 4 | 5 | Specifically, it is an implementation of the following function definition: 6 | 7 | ``` 8 | insertionSort : 9 | Ord e => 10 | (xs:Vect n e) -> 11 | (xs':Vect n e ** (IsSorted xs', ElemsAreSame xs xs')) 12 | ``` 13 | 14 | Given a list of elements, this function will return: 15 | 16 | 1. an output list, 17 | 2. an `IsSorted` proof that the output list is sorted, and 18 | 3. an `ElemsAreSame` proof that the input list and output lists contain 19 | the same elements. 20 | 21 | This program makes heavy use of proof terms, a special facility only available 22 | in dependently-typed programming languages like Idris. 23 | 24 | ## Prerequisites 25 | 26 | * Idris 1.3.1 or later 27 | - Probably any Idris 1.x will work. 28 | * Make 29 | 30 | ## How to Run 31 | 32 | ``` 33 | make run 34 | ``` 35 | 36 | ## Example Output 37 | 38 | ``` 39 | $ make run 40 | idris -o InsertionSort InsertionSort.idr 41 | ./InsertionSort 42 | Please type a space-separated list of integers: 43 | 3 2 1 44 | After sorting, the integers are: 45 | 1 2 3 46 | ``` 47 | 48 | ## See the Proof Term! 49 | 50 | Another way to run the program is to run it directly using the Idris 51 | interpreter. The advantage here is that you can see not just the resulting 52 | sorted output list but also the resulting proof terms of the algorithm. 53 | 54 | ``` 55 | $ idris --nobanner InsertionSort.idr 56 | *InsertionSort> insertionSort [2,1] 57 | MkSigma [1, 2] 58 | (IsSortedMany 1 2 [] Oh (IsSortedOne 2), 59 | SamenessIsTransitive (PrependXIsPrependX 2 60 | (SamenessIsTransitive (PrependXIsPrependX 1 61 | NilIsNil) 62 | (PrependXIsPrependX 1 63 | NilIsNil))) 64 | (PrependXYIsPrependYX 2 65 | 1 66 | NilIsNil)) : Sigma (Vect 2 67 | Integer) 68 | (\xs' => 69 | (IsSorted xs', 70 | ElemsAreSame [2, 71 | 1] 72 | xs')) 73 | ``` 74 | 75 | ## License 76 | 77 | Copyright (c) 2015 by David Foster 78 | --------------------------------------------------------------------------------