I'm trying to construct solutions in Agda to the exercises given in this introduction to Type Theory & Homotopy Type Theory.
Given the dependent eliminators for equality E= (aka J) and K that I've defined in Agda like so:
J : {A : Set}
→ (C : (x y : A) → x ≡ y → Set)
→ ((x : A) → C x x refl)
→ (x y : A) → (p : x ≡ y) → C x y p
J C f x .x refl = f x
K : {A : Set}
→ (C : (x : A) → x ≡ x → Set)
→ ((x : A) → C x refl)
→ (x : A) → (p : x ≡ x) → (C x p)
K P f x refl = f x
Exercise 16 (page 13) is to derive the Uniqueness of Equality/Identity Proofs (UEP) using only the eliminators.
I know that UEP is provable in Agda via pattern matching thanks to axiom K like so:
uep : {A : Set}
→ (x y : A)
→ (p q : x ≡ y)
→ (p ≡ q)
uep x .x refl refl = refl
but the article seems to imply that it should be possible to derive a proof without pattern matching just like sym , trans, and resp can be proved using only the recursor R= :
R⁼ : {A : Set} (C : A → A → Set)
→ (∀ x → C x x)
→ ∀ {x y : A} → x ≡ y → C x y
R⁼ _ f {x} refl = f x
sym : ∀ {A : Set} → {x y : A} → x ≡ y → y ≡ x
sym {A} = R⁼ {A} ((λ x y → y ≡ x)) (λ x → refl)
trans : ∀ {A : Set} → (x y z : A) → x ≡ y → y ≡ z → x ≡ z
trans {A} x y z = R⁼ {A} (λ a b → (b ≡ z → a ≡ z)) (λ x₁ → id)
resp : {A B : Set} → (f : A → B) → {m n : A} → m ≡ n → f m ≡ f n
resp {A} {B} f = R⁼ {A} (λ a b → f a ≡ f b) (λ x → refl)
Given that UEP is a direct consequence of K my intuition is this should surely be possible but I've not been successful so far. Is the following provable with some combination of J and K? :
uep : {A : Set}
→ (x y : A)
→ (p q : x ≡ y)
→ (p ≡ q)
uep x y p q = {!!}
If you write
uep : {A : Set}
→ (x y : A)
→ (p q : x ≡ y)
→ (p ≡ q)
uep = J (λ _ _ p → ∀ q → p ≡ q) {!!}
and look into the hole, you'll see its type is
(x : A) (q : x ≡ x) → refl ≡ q
So J allows to turn the x ≡ y arguments into an x ≡ x one and from there K can handle the rest.
Full definition:
uep : {A : Set}
→ (x y : A)
→ (p q : x ≡ y)
→ (p ≡ q)
uep = J (λ _ _ p → ∀ q → p ≡ q) (K (λ _ q → refl ≡ q) (λ _ → refl))
Related
I'm writing a function to test propositional equality of Nat, and it typechecks in Idris 1.
sameNat : (n : Nat) -> (m : Nat) -> Maybe (n = m)
sameNat Z Z = Just Refl
sameNat (S n) (S m) = case sameNat n m of
Just e => Just (cong e)
Nothing => Nothing
sameNat _ _ = Nothing
But it doesn't typecheck in Idris 2 (0.4.0) and I got this error.
Error: While processing right hand side of sameNat. When
unifying n = m and Nat m e -> :: ?x ?xs n m e.
Mismatch between: n = m and Nat m e -> :: ?x ?xs n m e.
It typechecks when I write a specific version of cong and use it.
cong' : n = m -> S n = S m
cong' Refl = Refl
Why doesn't this typecheck and how can I make it typecheck?
The type signature of cong changed:
Idris 1:
cong : (a = b) -> f a = f b
Idris 2:
Prelude.cong : (0 f : (t -> u)) -> a = b -> f a = f b
This compiles:
data ThreeEq : a -> b -> c -> Type where
Same3 : (x : a) -> ThreeEq x x x
allSameS : (x, y, z : Nat) -> ThreeEq x y z -> ThreeEq (S x) (S y) (S z)
allSameS k k k (Same3 k) = Same3 (S k)
But with one small change to Same3, it no longer compiles. Can anyone explain why?
data ThreeEq : a -> b -> c -> Type where
Same3 : x -> ThreeEq x x x
allSameS : (x, y, z : Nat) -> ThreeEq x y z -> ThreeEq (S x) (S y) (S z)
allSameS k k k (Same3 k) = Same3 (S k)
Here's the error message:
- + Errors (1)
`-- Amy2.idr line 5 col 0:
When checking left hand side of allSameS:
When checking an application of Main.allSameS:
Type mismatch between
ThreeEq x x x (Type of Same3 _)
and
ThreeEq k y z (Expected type)
Specifically:
Type mismatch between
Type
and
Nat
Here is the difference
data ThreeEq : a -> b -> c -> Type where
Same3 : (x : a) -> ThreeEq x x x
^ ^
| |
| Type
Value
Here, Same3 Z builds a value of type Three Z Z Z.
data ThreeEq : a -> b -> c -> Type where
Same3 : x -> ThreeEq x x x
^
|
Type
And now, Same3 Z builds a value of type Three Nat Nat Nat.
Testing out an "easy" example of identity types, mod equality, but transitivity proof wont type check, even from the template. More than a fix, I want to know why?
Here's a snippet of the minimal problem
data ModEq : (n:Nat) -> (x:Nat) -> (y:Nat) -> Type where
{- 3 constructors
reflexive: x == x (mod n),
left-induct: x == y (mod n) => (x+n) == y (mod n)
right-induct: x == y (mod n) => x == (y+n) (mod n)
-}
Reflex : (x:Nat) -> ModEq n x x --- Needs syntatic sugar, for now prefix
LInd : (ModEq n x y) -> ModEq n (x+n) y
RInd : (ModEq n x y) -> ModEq n x (y+n)
{----- Proof of transitive property. -----}
total
isTrans : (ModEq n x y) -> (ModEq n y z) -> (ModEq n x z)
{- x=x & x=y => x=y -}
isTrans (Reflex x) v = v
isTrans u (Reflex y) = u
{- ((x=y=>(x+n)=y) & y=z) => x=y & y=z => x=z (induct) => (x+n)=z -}
isTrans (LInd u) v = LInd (isTrans u v)
isTrans u (RInd v) = RInd (isTrans u v)
{- (x=y=>x=(y+n)) & (y=z=>(y+n)=z) => x=y & y=z => x=z (induct) -}
isTrans (RInd u) (LInd v) = isTrans u v
The type mismatch is in the last line, even though from the comment line I really cannot tell why logically its wrong. Here's the error:
48 | isTrans (RInd u) (LInd v) = isTrans u v
| ~~~~~~~
When checking left hand side of isTrans:
When checking an application of Main.isTrans:
Type mismatch between
ModEq n (x + n) z (Type of LInd v)
and
ModEq n (y + n) z (Expected type)
Specifically:
Type mismatch between
plus x n
and
plus y n
Not only am I confused by how LInd v got assigned the (wrong seeming) type ModEq n (x+n) z, but I point out that when I simply try the "type-define-refine" approach with the built in template I get:
isTrans : (ModEq n x y) -> (ModEq n y z) -> (ModEq n x z)
isTrans (RInd _) (LInd _) = ?isTrans_rhs_1
And even this wont type-check, it complains:
40 | isTrans (RInd _) (LInd _) = ?isTrans_rhs_1
| ~~~~~~~
When checking left hand side of isTrans:
When checking an application of Main.isTrans:
Type mismatch between
ModEq n (x + n) z (Type of LInd _)
and
ModEq n (y + n) z (Expected type)
Specifically:
Type mismatch between
plus x n
and
plus y n
The issue is that the compiler isn't able to deduce in your last case that y = {x + n}. You can give it this hint, though:
isTrans : (ModEq n x y) -> (ModEq n y z) -> (ModEq n x z)
isTrans (Reflex _) v = v
isTrans u (Reflex _) = u
isTrans (LInd u) v = LInd $ isTrans u v
isTrans u (RInd v) = RInd $ isTrans u v
isTrans (RInd u) (LInd v) {n} {x} {y = x + n} = ?isTrans_rhs
Which gives you the following goal for isTrans_rhs:
x : Nat
n : Nat
u : ModEq n x x
z : Nat
v : ModEq n x z
--------------------------------------
isTrans_rhs : ModEq n x z
and thus, you can conclude with isTrans (RInd u) (LInd v) {n} {x} {y = x + n} = v
I was trying to write a proof in Idris regarding the following subtraction-based mod operator:
mod : (x, y : Nat) -> Not (y = Z) -> Nat
mod x Z p = void (p Refl)
mod x (S k) _ = if lt x (S k) then x else helper x (minus x (S k)) (S k)
where total
helper : Nat -> Nat -> Nat -> Nat
helper Z x y = x
helper (S k) x y = if lt x y then x else helper k (minus x y) y
The theorem I wanted to prove is that the remainder as produced by "mod" above is always smaller than the divider. Namely,
mod_prop : (x, y : Nat) -> (p : Not (y=0))-> LT (mod x y p) y
I constructed a proof but was stuck by a final hole. My full code is pasted below
mod : (x, y : Nat) -> Not (y = Z) -> Nat
mod x Z p = void (p Refl)
mod x (S k) _ = if lt x (S k) then x else helper x (minus x (S k)) (S k)
where total
helper : Nat -> Nat -> Nat -> Nat
helper Z x y = x
helper (S k) x y = if lt x y then x else helper k (minus x y) y
lteZK : LTE Z k
lteZK {k = Z} = LTEZero
lteZK {k = (S k)} = let ih = lteZK {k=k} in
lteSuccRight {n=Z} {m=k} ih
lte2LTE_True : True = lte a b -> LTE a b
lte2LTE_True {a = Z} prf = lteZK
lte2LTE_True {a = (S _)} {b = Z} Refl impossible
lte2LTE_True {a = (S k)} {b = (S j)} prf =
let ih = lte2LTE_True {a=k} {b=j} prf in LTESucc ih
lte2LTE_False : False = lte a b -> GT a b
lte2LTE_False {a = Z} Refl impossible
lte2LTE_False {a = (S k)} {b = Z} prf = LTESucc lteZK
lte2LTE_False {a = (S k)} {b = (S j)} prf =
let ih = lte2LTE_False {a=k} {b=j} prf in (LTESucc ih)
total
mod_prop : (x, y : Nat) -> (p : Not (y=0))-> LT (mod x y p) y
mod_prop x Z p = void (p Refl)
mod_prop x (S k) p with (lte x k) proof lxk
mod_prop x (S k) p | True = LTESucc (lte2LTE_True lxk)
mod_prop Z (S k) p | False = LTESucc lteZK
mod_prop (S x) (S k) p | False with (lte (minus x k) k) proof lxk'
mod_prop (S x) (S k) p | False | True = LTESucc (lte2LTE_True lxk')
mod_prop (S x) (S Z) p | False | False = LTESucc ?hole
Once I run the type checker, the hole is described as follows:
- + Main.hole [P]
`-- x : Nat
p : (1 = 0) -> Void
lxk : False = lte (S x) 0
lxk' : False = lte (minus x 0) 0
--------------------------------------------------------------------------
Main.hole : LTE (Main.mod, helper (S x) 0 p x (minus (minus x 0) 1) 1) 0
I am not familiar with the syntax of Main.mod, helper (S x) 0 p x (minus (minus x 0) 1) 1 given in the idris-holes window. I guess (S x) 0 p are the three parameters of "mod" while (minus (minus x 0) 1) 1 are the three parameters of the local "helper" function of "mod"?
It seems that it's time to leverage an induction hypothesis. But how can I finish up the proof using induction?
(Main.mod, helper (S x) 0 p x (minus (minus x 0) 1) 1)
can be read as
Main.mod, helper - a qualified name for helper function, which is defined in the where clause of the mod function (Main is a module name);
Arguments of mod which are also passed to helper - (S x), 0 and p (see docs):
Any names which are visible in the outer scope are also visible in the
where clause (unless they have been redefined, such as xs here). A
name which appears only in the type will be in scope in the where
clause if it is a parameter to one of the types, i.e. it is fixed
across the entire structure.
Arguments of helper itself - x, (minus (minus x 0) 1) and 1.
Also below is another implementation of mod which uses Fin n type for the remainder in division by n. It turns out to be easier to reason about, since any value of Fin n is always less than n:
import Data.Fin
%default total
mod' : (x, y : Nat) -> {auto ok: GT y Z} -> Fin y
mod' Z (S _) = FZ
mod' (S x) (S y) with (strengthen $ mod' x (S y))
| Left _ = FZ
| Right rem = FS rem
mod : (x, y : Nat) -> {auto ok: GT y Z} -> Nat
mod x y = finToNat $ mod' x y
finLessThanBound : (f : Fin n) -> LT (finToNat f) n
finLessThanBound FZ = LTESucc LTEZero
finLessThanBound (FS f) = LTESucc (finLessThanBound f)
mod_prop : (x, y : Nat) -> {auto ok: GT y Z} -> LT (mod x y) y
mod_prop x y = finLessThanBound (mod' x y)
Here for convenience I used auto implicits for proofs that y > 0.
Lets say I have the following
data Expr : Type -> Type where
Lift : a -> Expr a
Add : Num a => Expr a -> Expr a -> Expr a
Cnst : Expr a -> Expr b -> Expr a
data Context : Type -> Type where
Root : Context ()
L : Expr w -> Context x -> Expr y -> Expr z -> Context w
R : Expr w -> Context x -> Expr y -> Expr z -> Context w
M : Expr w -> Context x -> Expr y -> Expr z -> Context w
data Zipper : Type -> Type -> Type where
Z : Expr f -> Context g -> Zipper f g
E : String -> Context g -> Zipper String ()
I would like to write a function to rebuild a Zipper if I'm going up one level in the expression tree. Something like:
total
ZipUp : Zipper focus parent -> Type
ZipUp (Z e (R (Cnst {a} e1 e2) {x} c t u)) = Zipper a x
ZipUp (Z {f} e (L (Cnst l r) {x} c t u)) = Zipper f x
ZipUp (Z e (R (Add {a} e1 e2) {x} c t u)) = Zipper a x
ZipUp (Z {f} e (L (Add e1 e2) {x} c t u)) = Zipper f x
ZipUp _ = Zipper String ()
the problem comes when I want to write the function to return a ZipUp
up : (x : Zipper focus parent) -> ZipUp x
up (Z e (R (Cnst l r) c x y)) = Z (Cnst l e) c
up (Z e (L (Cnst l r) c x y)) = Z (Cnst e r) c
up (Z e (R (Add l r) c x y)) = Z (Add l e) c
up (Z e (L (Add l r) c x y)) = Z (Add e r) c
up (Z e (R (Lift x) c l r)) = E "Some error" c
up (Z e (L (Lift x) c l r)) = E "Some error" c
up (E s c) = E s c
This fails to typecheck on the Add case, because it can't infer that focus (type of e) matches with parent (expected type)
So my question has two parts then.
What can I do to express this relationship?
(that if the Zipper is an R constructed, e has the same type as r, or that e has the same type as l in the L constructed case. I've tried using {e = l} and other variants of this, but to no avail.)
The the code typechecks and runs if I comment out the last for lines of up to finish with:
up : (x : Zipper focus parent) -> ZipUp x
up (Z e (R (Cnst l r) c x y)) = Z (Cnst l e) c
up (Z e (L (Cnst l r) c x y)) = Z (Cnst e r) c
but the actual manipulation of the types should be the same in the Add case, yet this fails to typecheck, why is that?
Thanks for taking the time to read and/or answer!
This fails to typecheck on the Add case, because it can't infer that focus (type of e) matches with parent (expected type)
Because this is not always the case, e.g.
*main> :t Z (Lift "a") (R (Add (Lift 1) (Lift 2)) Root (Lift 4) (Lift 8))
Z (Lift "a") (R (Add (Lift 1) (Lift 2)) Root (Lift 4) (Lift 8)) : Zipper String Integer
And Add (Lift 1) (Lift "a") doesn't work because of the Num a constraint.
What can I do to express this relationship?
If you want to express the relationship within up: You have e : Expr f and can say that the same f should be used in the Add case:
up (Z {f} e (R (Add l r {a=f}) c x y)) = Z (Add l e) c
up (Z {f} e (L (Add l r {a=f}) c x y)) = Z (Add e r) c
up (Z e (R (Add l r) c x y)) = ?whattodo_1
up (Z e (L (Add l r) c x y)) = ?whattodo_2
Now you have a non total function because of the cases where a != f. I don't quite what you want to do, so I can't offer an option. :-)
If you want to express the relationship in Zipper you could do (very roughly) something like:
data Context : Bool -> Type -> Type where
Root : Context False ()
L : Expr w -> Context b x -> Expr y -> Expr z -> Context False w
R : Expr w -> Context b x -> Expr y -> Expr z -> Context True w
M : Expr w -> Context b x -> Expr y -> Expr z -> Context False w
data Zipper : Type -> Type -> Type where
Z : Expr f -> Context False g -> Zipper f g
ZR : Expr f -> Context True f -> Zipper f f
E : String -> Context b g -> Zipper String ()
Now you construct a proof when building up a zipper that f = g in a R-Context. Again, I cannot be specific, but I hope it helps in some way.