├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── haskell-proofs.cabal ├── package.yaml ├── src ├── Equality.hs ├── Nat.hs ├── Proofs │ ├── Addition.hs │ └── Multiplication.hs └── Vec.hs ├── stack.yaml └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for haskell-proofs 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 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 Author name here 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.md: -------------------------------------------------------------------------------- 1 | # haskell-proofs 2 | 3 | https://alexpeits.github.io/posts/2018-09-27-haskell-proofs.html 4 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /haskell-proofs.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: b5ba9a5f5536a6d765d2ffd43068fd65f763c82df7e1b1051d9bbe0368819e26 8 | 9 | name: haskell-proofs 10 | version: 0.1.0.0 11 | description: Please see the README on GitHub at 12 | homepage: https://github.com/githubuser/haskell-proofs#readme 13 | bug-reports: https://github.com/githubuser/haskell-proofs/issues 14 | author: Author name here 15 | maintainer: example@example.com 16 | copyright: 2018 Author name here 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | ChangeLog.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/githubuser/haskell-proofs 27 | 28 | library 29 | exposed-modules: 30 | Equality 31 | Nat 32 | Proofs.Addition 33 | Proofs.Multiplication 34 | Vec 35 | other-modules: 36 | Paths_haskell_proofs 37 | hs-source-dirs: 38 | src 39 | default-extensions: NoStarIsType 40 | build-depends: 41 | base >=4.7 && <5 42 | default-language: Haskell2010 43 | 44 | test-suite haskell-proofs-test 45 | type: exitcode-stdio-1.0 46 | main-is: Spec.hs 47 | other-modules: 48 | Paths_haskell_proofs 49 | hs-source-dirs: 50 | test 51 | default-extensions: NoStarIsType 52 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 53 | build-depends: 54 | base >=4.7 && <5 55 | , haskell-proofs 56 | default-language: Haskell2010 57 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: haskell-proofs 2 | version: 0.1.0.0 3 | github: "githubuser/haskell-proofs" 4 | license: BSD3 5 | author: "Author name here" 6 | maintainer: "example@example.com" 7 | copyright: "2018 Author name here" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | 25 | library: 26 | source-dirs: src 27 | 28 | default-extensions: 29 | - NoStarIsType 30 | 31 | tests: 32 | haskell-proofs-test: 33 | main: Spec.hs 34 | source-dirs: test 35 | ghc-options: 36 | - -threaded 37 | - -rtsopts 38 | - -with-rtsopts=-N 39 | dependencies: 40 | - haskell-proofs 41 | -------------------------------------------------------------------------------- /src/Equality.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | module Equality where 6 | 7 | import Data.Type.Equality 8 | 9 | -- Transitive property of propositional equality 10 | (==>) :: a :~: b -> b :~: c -> a :~: c 11 | Refl ==> Refl = Refl 12 | 13 | -- Symmetric property of propositional equality 14 | symm :: a :~: b -> b :~: a 15 | symm Refl = Refl 16 | 17 | -- Congruence of propositional equality 18 | cong :: a :~: b -> f a :~: f b 19 | cong Refl = Refl 20 | -------------------------------------------------------------------------------- /src/Nat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | module Nat where 7 | 8 | import Data.Kind 9 | import GHC.TypeLits (TypeError, ErrorMessage(..)) 10 | 11 | data Nat = Z | S Nat 12 | 13 | data SNat :: Nat -> Type where 14 | SZ :: SNat Z 15 | SS :: SNat n -> SNat (S n) 16 | 17 | sNatToInt :: SNat n -> Int 18 | sNatToInt SZ = 0 19 | sNatToInt (SS n) = 1 + sNatToInt n 20 | 21 | instance Show (SNat n) where 22 | show SZ = "0" 23 | show n = show $ sNatToInt n 24 | 25 | type I = S Z 26 | type II = S I 27 | 28 | class IsNat (n :: Nat) where nat :: SNat n 29 | instance IsNat Z where nat = SZ 30 | instance IsNat n => IsNat (S n) where nat = SS nat 31 | 32 | -- get predecessor SNat given a nonzero SNat 33 | spred :: SNat (S n) -> SNat n 34 | spred (SS n) = n 35 | 36 | type family P n where 37 | P Z = Z 38 | P (S n) = n 39 | 40 | type family NonZero n where 41 | NonZero Z = TypeError (Text "`Z` is not non-zero, m8") 42 | NonZero (S n) = True ~ True 43 | 44 | -- 45 | -- Addition 46 | -- 47 | type family a + b where 48 | a + Z = a -- (1) 49 | a + S b = S (a + b) -- (2) 50 | 51 | (!+) :: SNat n -> SNat m -> SNat (n + m) 52 | n !+ SZ = n 53 | n !+ (SS m) = SS (n !+ m) 54 | 55 | -- 56 | -- Subtraction 57 | -- 58 | 59 | type family a - b where 60 | a - Z = a 61 | a - S b = P (a - b) 62 | 63 | -- 64 | -- Multiplication 65 | -- 66 | type family a * b where 67 | a * Z = Z -- (3) 68 | a * S b = (a * b) + a -- (4) 69 | 70 | (!*) :: SNat n -> SNat m -> SNat (n * m) 71 | n !* SZ = SZ 72 | n !* (SS m) = (n !* m) !+ n 73 | 74 | 75 | -- 76 | -- Comparison 77 | -- 78 | 79 | type family Min n m where 80 | Min Z Z = Z 81 | Min (S n) Z = Z 82 | Min Z (S n) = Z 83 | Min (S n) (S m) = S (Min n m) 84 | 85 | type family Max n m where 86 | Max Z Z = Z 87 | Max (S n) Z = S n 88 | Max Z (S n) = S n 89 | Max (S n) (S m) = S (Max n m) 90 | 91 | 92 | -- 93 | -- Finite set 94 | -- 95 | 96 | data Fin :: Nat -> Type where 97 | FZ :: Fin (S n) 98 | FS :: Fin n -> Fin (S n) 99 | -------------------------------------------------------------------------------- /src/Proofs/Addition.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | module Proofs.Addition where 6 | 7 | import Data.Type.Equality 8 | 9 | import Nat 10 | import Equality 11 | 12 | -- Value-level proof of (1) 13 | given1 :: SNat a -> (a + Z) :~: a 14 | given1 _ = Refl 15 | 16 | -- Value-level proof of (2) 17 | given2 :: SNat a -> SNat b -> (a + S b) :~: S (a + b) 18 | given2 _ _ = Refl 19 | 20 | -- Right identity 21 | plusIdenR :: SNat a -> (a + Z) :~: a 22 | plusIdenR = given1 23 | 24 | -- Left identity 25 | plusIdenL :: SNat a -> (Z + a) :~: a 26 | plusIdenL SZ = Refl 27 | plusIdenL (SS a) = gcastWith (plusIdenL a) Refl 28 | 29 | -- Plus Associativity 30 | plusAssoc :: SNat a -> SNat b -> SNat c -> ((a + b) + c) :~: (a + (b + c)) 31 | plusAssoc a b SZ = Refl 32 | plusAssoc a b (SS c) = gcastWith (plusAssoc a b c) Refl 33 | 34 | plusAssoc' :: SNat a -> SNat b -> SNat c -> ((a + b) + c) :~: (a + (b + c)) 35 | plusAssoc' a b SZ = 36 | let proof :: forall x y. SNat x -> SNat y -> ((x + y) + Z) :~: (x + (y + Z)) 37 | proof x y = step1 ==> step2 38 | where 39 | step1 :: ((x + y) + Z) :~: (x + y) 40 | step1 = gcastWith (given1 (x !+ y)) Refl 41 | 42 | step2 :: (x + y) :~: (x + (y + Z)) 43 | step2 = gcastWith (given1 y) Refl 44 | in proof a b 45 | plusAssoc' a b (SS c) = 46 | let proof :: 47 | forall x y z. 48 | SNat x -> SNat y -> SNat z -> 49 | ((x + y) + S z) :~: (x + (y + S z)) 50 | proof x y z = step1 ==> step2 ==> step3 ==> step4 51 | where 52 | step1 :: ((x + y) + S z) :~: S ((x + y) + z) 53 | step1 = gcastWith (given2 (x !+ y) (SS z)) Refl 54 | 55 | step2 :: S ((x + y) + z) :~: S (x + (y + z)) 56 | step2 = gcastWith (plusAssoc' x y z) Refl 57 | 58 | step3 :: S (x + (y + z)) :~: (x + S (y + z)) 59 | step3 = gcastWith (given2 x (y !+ z)) Refl 60 | 61 | step4 :: (x + S (y + z)) :~: (x + (y + S z)) 62 | step4 = gcastWith (given2 y z) Refl 63 | in proof a b c 64 | 65 | -- Plus Commutativity 66 | plusComm :: SNat a -> SNat b -> (a + b) :~: (b + a) 67 | plusComm SZ SZ = Refl 68 | plusComm a SZ = gcastWith (plusIdenL a) Refl 69 | plusComm SZ (SS SZ) = Refl 70 | plusComm (SS a) (SS SZ) = gcastWith (plusComm a (SS SZ)) Refl 71 | plusComm a k@(SS b) = 72 | let proof :: forall a b. SNat a -> SNat b -> (a + S b) :~: (S b + a) 73 | proof x y = p1 ==> p2 ==> p3 ==> p4 ==> p5 ==> p6 ==> p7 74 | where 75 | p1 :: (a + S b) :~: (a + (b + I)) 76 | p1 = gcastWith (given2 y (SS SZ)) Refl 77 | 78 | p2 :: (a + (b + I)) :~: ((a + b) + I) 79 | p2 = gcastWith (plusAssoc x y (SS SZ)) Refl 80 | 81 | p3 :: ((a + b) + I) :~: ((b + a) + I) 82 | p3 = gcastWith (plusComm x y) Refl 83 | 84 | p4 :: ((b + a) + I) :~: (b + (a + I)) 85 | p4 = gcastWith (plusAssoc y x (SS SZ)) Refl 86 | 87 | p5 :: (b + (a + I)) :~: (b + (I + a)) 88 | p5 = gcastWith (plusComm x (SS SZ)) Refl 89 | 90 | p6 :: (b + (I + a)) :~: ((b + I) + a) 91 | p6 = gcastWith (plusAssoc y (SS SZ) x) Refl 92 | 93 | p7 :: ((b + I) + a) :~: (S b + a) 94 | p7 = gcastWith (given2 y (SS SZ)) Refl 95 | 96 | in proof a b 97 | -------------------------------------------------------------------------------- /src/Proofs/Multiplication.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | module Proofs.Multiplication where 6 | 7 | import Data.Type.Equality 8 | 9 | import Nat 10 | import Equality 11 | 12 | import Proofs.Addition 13 | 14 | -- Value-level proof of (3) 15 | given3 :: SNat a -> (a * Z) :~: Z 16 | given3 _ = Refl 17 | 18 | -- Value-level proof of (4) 19 | given4 :: SNat a -> SNat b -> (a * S b) :~: ((a * b) + a) 20 | given4 _ _ = Refl 21 | 22 | -- Right zero property 23 | mulZeroPropR :: SNat a -> (a * Z) :~: Z 24 | mulZeroPropR = given3 25 | 26 | -- Left zero property 27 | mulZeroPropL :: SNat a -> (Z * a) :~: Z 28 | mulZeroPropL SZ = Refl 29 | mulZeroPropL (SS a) = gcastWith (mulZeroPropL a) Refl 30 | 31 | -- Right identity 32 | mulIdenR :: SNat a -> (a * I) :~: a 33 | mulIdenR SZ = Refl 34 | mulIdenR (SS a) = gcastWith (mulIdenR a) Refl 35 | 36 | -- Left identity 37 | mulIdenL :: SNat a -> (I * a) :~: a 38 | mulIdenL SZ = Refl 39 | mulIdenL (SS a) = gcastWith (mulIdenL a) Refl 40 | 41 | -- Proof that multiplication distributes over addition 42 | mulPlusDist :: SNat a -> SNat b -> SNat c -> ((a + b) * c) :~: ((a * c) + (b * c)) 43 | mulPlusDist a b SZ = Refl 44 | mulPlusDist a b k@(SS c) = 45 | let proof :: forall a b c. SNat a -> SNat b -> SNat c -> ((a + b) * S c) :~: ((a * S c) + (b * S c)) 46 | proof x y z = p1 ==> p2 ==> p3 ==> p4 ==> p5 ==> p6 ==> p7 ==> p8 ==> p9 47 | where 48 | p1 :: ((a + b) * S c) :~: (((a + b) * c) + (a + b)) 49 | p1 = Refl -- from (4) 50 | 51 | p2 :: (((a + b) * c) + (a + b)) :~: (((a * c) + (b * c)) + (a + b)) 52 | p2 = gcastWith (mulPlusDist x y z) Refl 53 | 54 | p3 :: (((a * c) + (b * c)) + (a + b)) :~: ((a * c) + ((b * c) + (a + b))) 55 | p3 = gcastWith (plusAssoc (x !* z) (y !* z) (x !+ y)) Refl 56 | 57 | p4 :: ((a * c) + ((b * c) + (a + b))) :~: ((a * c) + ((a + b) + (b * c))) 58 | p4 = gcastWith (plusComm (y !* z) (x !+ y)) Refl 59 | 60 | p5 :: ((a * c) + ((a + b) + (b * c))) :~: (((a * c) + (a + b)) + (b * c)) 61 | p5 = gcastWith (plusAssoc (x !* z) (x !+ y) (y !* z)) Refl 62 | 63 | p6 :: (((a * c) + (a + b)) + (b * c)) :~: ((((a * c) + a) + b) + (b * c)) 64 | p6 = gcastWith (plusAssoc (x !* z) x y) Refl 65 | 66 | p7 :: ((((a * c) + a) + b) + (b * c)) :~: (((a * c) + a) + (b + (b * c))) 67 | p7 = gcastWith (plusAssoc ((x !* z) !+ x) y (y !* z)) Refl 68 | 69 | p8 :: (((a * c) + a) + (b + (b * c))) :~: (((a * c) + a) + ((b * c) + b)) 70 | p8 = gcastWith (plusComm y (y !* z)) Refl 71 | 72 | p9 :: (((a * c) + a) + ((b * c) + b)) :~: ((a * S c) + (b * S c)) 73 | p9 = Refl 74 | 75 | in proof a b c 76 | 77 | 78 | mulComm :: SNat a -> SNat b -> (a * b) :~: (b * a) 79 | mulComm a SZ = gcastWith (mulZeroPropL a) Refl 80 | mulComm a k@(SS b) = 81 | let 82 | proof :: forall a b c. SNat a -> SNat b -> (a * S b) :~: (S b * a) 83 | proof x y = p1 ==> p2 ==> p3 ==> p4 ==> p5 84 | where 85 | p1 :: (a * S b) :~: ((a * b) + a) 86 | p1 = Refl 87 | 88 | p2 :: ((a * b) + a) :~: ((b * a) + a) 89 | p2 = gcastWith (mulComm x y) Refl 90 | 91 | p3 :: ((b * a) + a) :~: ((b * a) + (I * a)) 92 | p3 = gcastWith (mulIdenL x) Refl 93 | 94 | p4 :: ((b * a) + (I * a)) :~: ((b + I) * a) 95 | p4 = gcastWith (mulPlusDist y (SS SZ) x) Refl 96 | 97 | p5 :: ((b + I) * a) :~: (S b * a) 98 | p5 = Refl 99 | 100 | in proof a b 101 | 102 | 103 | mulAssoc :: SNat a -> SNat b -> SNat c -> ((a * b) * c) :~: (a * (b * c)) 104 | mulAssoc a b SZ = Refl 105 | mulAssoc a b k@(SS c) = 106 | let proof :: forall a b c. SNat a -> SNat b -> SNat c -> ((a * b) * S c) :~: (a * (b * S c)) 107 | proof x y z = p1 ==> p2 ==> p3 ==> p4 ==> p5 ==> p6 ==> p7 ==> p8 ==> p9 108 | where 109 | p1 :: ((a * b) * S c) :~: (((a * b) * c) + (a * b)) 110 | p1 = Refl -- from (4) 111 | 112 | p2 :: (((a * b) * c) + (a * b)) :~: ((a * (b * c)) + (a * b)) 113 | p2 = gcastWith (mulAssoc x y z) Refl 114 | 115 | p3 :: ((a * (b * c)) + (a * b)) :~: ((a * b) + (a * (b * c))) 116 | p3 = gcastWith (plusComm (x !* (y !* z)) (x !* y)) Refl 117 | 118 | p4 :: ((a * b) + (a * (b * c))) :~: ((b * a) + (a * (b * c))) 119 | p4 = gcastWith (mulComm x y) Refl 120 | 121 | p5 :: ((b * a) + (a * (b * c))) :~: ((b * a) + ((b * c) * a)) 122 | p5 = gcastWith (mulComm x (y !* z)) Refl 123 | 124 | p6 :: ((b * a) + ((b * c) * a)) :~: ((b + (b * c)) * a) 125 | p6 = gcastWith (mulPlusDist y (y !* z) x) Refl 126 | 127 | p7 :: ((b + (b * c)) * a) :~: (a * (b + (b * c))) 128 | p7 = gcastWith (mulComm x (y !+ (y !* z))) Refl 129 | 130 | p8 :: (a * (b + (b * c))) :~: (a * ((b * c) + b)) 131 | p8 = gcastWith (plusComm y (y !* z)) Refl 132 | 133 | p9 :: (a * ((b * c) + b)) :~: (a * (b * S c)) 134 | p9 = Refl 135 | 136 | in proof a b c 137 | -------------------------------------------------------------------------------- /src/Vec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE EmptyCase #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE InstanceSigs #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | module Vec where 13 | 14 | import Data.Void 15 | import Data.Kind 16 | import Data.Type.Equality 17 | 18 | import Prelude hiding 19 | ( length 20 | , (++) 21 | , head 22 | , last 23 | , tail 24 | , init 25 | , map 26 | , reverse 27 | , intersperse 28 | , concat 29 | , intercalate 30 | , transpose 31 | , subsequences 32 | , permutations 33 | ) 34 | import qualified Data.List as L 35 | 36 | import Nat 37 | import Equality 38 | 39 | import Proofs.Addition 40 | import Proofs.Multiplication 41 | 42 | data Vec :: Type -> Nat -> Type where 43 | V0 :: Vec a Z 44 | (:>) :: a -> Vec a n -> Vec a (S n) 45 | 46 | infixr 5 :> 47 | 48 | instance (Show a) => Show (Vec a n) where 49 | show v = "[" L.++ go v 50 | where go :: (Show a') => Vec a' n' -> String 51 | go v = case v of 52 | V0 -> "]" 53 | (x :> xs) -> show x L.++ sep L.++ go xs 54 | where sep = case xs of 55 | V0 -> "" 56 | _ -> ", " 57 | 58 | x = 1 :> 2 :> 3 :> 4 :> V0 59 | y = 5 :> 6 :> 7 :> 8 :> 9 :> V0 60 | 61 | sumSuccProof :: forall x y. SNat x -> SNat y -> (S x + y) :~: S (x + y) 62 | sumSuccProof x SZ = Refl 63 | sumSuccProof x (SS y) = gcastWith (sumSuccProof x y) Refl 64 | -- ... also: 65 | -- sumSuccProof x y = step1 ==> step2 ==> step3 66 | -- where 67 | -- step1 :: (S x + y) :~: (y + S x) 68 | -- step1 = gcastWith (plusComm (SS x) y) Refl 69 | 70 | -- step2 :: (y + S x) :~: S (y + x) 71 | -- step2 = gcastWith (given2 y (SS x)) Refl 72 | 73 | -- step3 :: S (y + x) :~: S (x + y) 74 | -- step3 = gcastWith (plusComm y x) Refl 75 | 76 | append :: SNat n -> SNat m -> Vec a n -> Vec a m -> Vec a (n + m) 77 | append SZ m V0 ys = gcastWith (plusIdenL m) ys 78 | append n m (x:>xs) ys = gcastWith (sumSuccProof pn m) $ x :> append pn m xs ys 79 | where 80 | pn = spred n -- we know that n !~ SZ from the (x:>xs) pattern match 81 | 82 | -- Implicit version of `append`, thanks to typeclasses 83 | (++) :: forall a n m. (IsNat n, IsNat m) => Vec a n -> Vec a m -> Vec a (n + m) 84 | (++) = append (nat @n) (nat @m) 85 | 86 | head :: Vec a (S n) -> a 87 | head (x:>_) = x 88 | 89 | last :: Vec a (S n) -> a 90 | last (x:>V0) = x 91 | last (_:>xs) = case xs of r@(_:>_) -> last r 92 | 93 | tail :: Vec a (S n) -> Vec a n 94 | tail (_:>V0) = V0 95 | tail (_:>xs) = xs 96 | 97 | init :: Vec a (S n) -> Vec a n 98 | init (x:>xs) = init' x xs 99 | where init' :: a -> Vec a n -> Vec a n 100 | init' _ V0 = V0 101 | init' y (z :> zs) = y :> init' z zs 102 | 103 | uncons :: Vec a (S n) -> (a, Vec a n) 104 | uncons v = (head v, tail v) 105 | 106 | null :: Vec a n -> Bool 107 | null V0 = True 108 | null _ = False 109 | 110 | length :: Vec a n -> Int 111 | length V0 = 0 112 | length (_:>xs) = 1 + length xs 113 | 114 | lengthS :: IsNat n => Vec a n -> SNat n 115 | lengthS _ = nat 116 | 117 | -- instance Foldable (Vec n) where 118 | -- foldr :: (a -> b -> b) -> b -> Vec n a -> b 119 | -- foldr _ a V0 = a 120 | -- foldr f a (x:>xs) = foldr f (f x a) xs 121 | 122 | -- foldMap :: Monoid m => (a -> m) -> Vec n a -> m 123 | -- foldMap _ V0 = mempty 124 | -- foldMap f (x:>xs) = mappend (f x) (foldMap f xs) 125 | 126 | map :: (a -> b) -> Vec a n -> Vec b n 127 | map _ V0 = V0 128 | map f (x:>xs) = f x :> map f xs 129 | 130 | -- reverse :: IsNat n => Vec n a -> Vec n a 131 | -- reverse V0 = V0 132 | -- reverse xs = go xs V0 133 | -- where 134 | -- go :: forall n m a. (IsNat n, IsNat m) => Vec n a -> Vec m a -> Vec (n + m) a 135 | -- go V0 acc = gcastWith (plusIdenL (nat @m)) acc 136 | -- go (y:>ys) acc = gcastWith (sumSuccProof pn (nat @m)) $ go ys (y:>acc) 137 | -- where 138 | -- pn = spred (nat @n) 139 | 140 | reverse' :: SNat n -> Vec a n -> Vec a n 141 | reverse' _ V0 = V0 142 | reverse' n (x:>xs) = go n SZ (x:>xs) V0 143 | where 144 | -- length of n , length of acc 145 | go :: forall n m a. SNat n -> SNat m -> Vec a n -> Vec a m -> Vec a (n + m) 146 | go _ lm V0 acc = gcastWith (plusIdenL lm) acc 147 | go ln lm (y:>ys) acc = gcastWith (sumSuccProof pln lm) $ go pln (SS lm) ys (y:>acc) 148 | where pln = spred ln 149 | 150 | reverse :: forall n a. IsNat n => Vec a n -> Vec a n 151 | reverse = reverse' (nat @n) 152 | 153 | -- succCong :: n :~: m -> S n :~: S m 154 | -- succCong Refl = Refl 155 | 156 | -- predProof :: SNat n -> SNat m -> (m :~: Z -> Void) -> S n :~: m -> n :~: P m 157 | -- predProof n m nonZero eq 158 | -- = case m of 159 | -- SZ -> absurd $ nonZero Refl 160 | -- SS m' -> gcastWith eq Refl 161 | 162 | succPredCancelProof :: SNat n -> (n :~: Z -> Void) -> S (P n) :~: n 163 | succPredCancelProof n nonZero 164 | = case n of 165 | SZ -> absurd $ nonZero Refl 166 | SS n' -> Refl 167 | 168 | natNonZero :: NonZero n => n :~: Z -> Void 169 | natNonZero nonZero = case nonZero of {} 170 | 171 | natNonZero' :: NonZero n => SNat n -> n :~: Z -> Void 172 | natNonZero' _ nonZero = case nonZero of {} 173 | 174 | -- length after intersperse is double minus one: n ~~> 2 * n - 1 175 | intersperse' :: forall n a. SNat n -> a -> Vec a n -> Vec a (P (II * n)) 176 | intersperse' _ _ V0 = V0 177 | intersperse' _ _ l@(_:>V0) = l 178 | intersperse' n a (x:>xs@(_:>_)) -- prove that tail is not V0, in order to know that P n ~ S m 179 | -- = gcastWith (succPredCancelProof pn (natNonZero' pn)) $ x :> a :> intersperse' pn a xs 180 | = gcastWith (succPredCancelProof pn (natNonZero @(P n))) $ x :> a :> intersperse' pn a xs 181 | where pn = spred n 182 | 183 | intersperse :: forall n a. IsNat n => a -> Vec a n -> Vec a (P (II * n)) 184 | intersperse = intersperse' (nat @n) 185 | 186 | -- pr :: a -> ((a, b) -> Void) -> (b -> Void) 187 | -- pr a f b = f (a, b) 188 | 189 | -- doubleNeg :: a -> (a -> Void) -> Void 190 | -- doubleNeg a f = f a 191 | 192 | data Ex :: (k -> Type) -> Type where 193 | Ex :: a i -> Ex a 194 | 195 | concat' :: SNat n -> SNat m -> Vec (Vec a n) m -> Vec a (n * m) 196 | concat' _ _ V0 = V0 197 | concat' n m (x:>xs) = gcastWith (plusComm n len') $ append n len' x $ concat' n pm xs 198 | where pm = spred m 199 | len' = n !* pm 200 | 201 | concat :: forall n m a. (IsNat n, IsNat m) => Vec (Vec a n) m -> Vec a (n * m) 202 | concat = concat' (nat @n) (nat @m) 203 | 204 | intercProof :: SNat n -> (S n + n) :~: S (II * n) 205 | intercProof n 206 | = gcastWith (plusIdenL n) 207 | $ gcastWith (mulComm (SS (SS SZ)) n) 208 | $ gcastWith (plusComm (SS n) n) Refl 209 | 210 | -- let's assume for now the vector of vectors h 211 | intercalate' :: SNat n -> SNat m -> Vec a n -> Vec (Vec a n) m -> Vec a ((n * m) + (n * P m)) 212 | intercalate' _ _ _ V0 = V0 213 | intercalate' n _ _ (x:>V0) = gcastWith (plusIdenL n) x 214 | intercalate' n m V0 v@(_:>_) -- again, we need to tell ghc that mm ~ S x 215 | = gcastWith (mulComm SZ (spred m)) $ concat' n m v 216 | -- *** TODO 217 | -- intercalate' n m l@(x:>xs) r@(y:>ys) 218 | -- = gcastWith (intercProof (spred m)) 219 | -- $ concat' n (m !+ spred m) $ intersperse' m l r 220 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # 16 | # The location of a snapshot can be provided as a file or url. Stack assumes 17 | # a snapshot provided as a file might change, whereas a url resource does not. 18 | # 19 | # resolver: ./custom-snapshot.yaml 20 | # resolver: https://example.com/snapshots/2018-01-01.yaml 21 | #resolver: lts-12.10 22 | resolver: lts-13.0 23 | 24 | # User packages to be built. 25 | # Various formats can be used as shown in the example below. 26 | # 27 | # packages: 28 | # - some-directory 29 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 30 | # - location: 31 | # git: https://github.com/commercialhaskell/stack.git 32 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 33 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 34 | # subdirs: 35 | # - auto-update 36 | # - wai 37 | packages: 38 | - . 39 | # Dependency packages to be pulled from upstream that are not in the resolver 40 | # using the same syntax as the packages field. 41 | # (e.g., acme-missiles-0.3) 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.7" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | --------------------------------------------------------------------------------