After hours of trying different versions of it, I give up. I just want to typecheck a proof of the transitivity of equality as stated in the HoTT-Book. I'm new to Agda so it might be just a small flaw or perhaps a bigger one... dont know. I consulted different libs for HoTT in Agda, but the ones I found had (in my eyes) rather complex solutions.
trans : ∀ {ℓ} (A : Type ℓ) (x y : A)
→ (x == y) → (z : A) → (y == z) → (x == z)
trans A x y = pathInd (λ p → (z : A) → (y == z) → (x == z))
(λ x → pathInd (λ x → (z : A) → (x == z) → (x == z))) (λ x → refl x))
Its based on the following implementation of path induction.
pathInd : ∀ {m n} {A : Type m} (P : {x y : A} → (x == y) → Type n) →
(∀ x → P (refl x)) → ∀ {x y} (p : (x == y)) → P p
pathInd P r (refl x) = r _
Thanks for any help.
Related
foldl : ∀ {a b} {A : Set a} (B : ℕ → Set b) {m} →
(∀ {n} → B n → A → B (suc n)) →
B zero →
Vec A m → B m
foldl b _⊕_ n [] = n
foldl b _⊕_ n (x ∷ xs) = foldl (λ n → b (suc n)) _⊕_ (n ⊕ x) xs
When translating the above function to Lean, I was shocked to find out that its true form is actually like...
def foldl : ∀ (P : ℕ → Type a) {n : nat}
(f : ∀ {n}, P n → α → P (n+1)) (s : P 0)
(l : Vec α n), P n
| P 0 f s (nil _) := s
| P (n+1) f s (cons x xs) := foldl (fun n, P (n+1)) (λ n, #f (n+1)) (#f 0 s x) xs
I find it really impressive that Agda is able to infer the implicit argument to f correctly. How is it doing that?
foldl : ∀ {a b} {A : Set a} (B : ℕ → Set b) {m} →
(∀ {n} → B n → A → B (suc n)) →
B zero →
Vec A m → B m
foldl b _⊕_ n [] = n
foldl b _⊕_ n (x ∷ xs) = foldl (λ n → b (suc n)) _⊕_ (_⊕_ {0} n x) xs
If I pass it 0 explicitly as in the Lean version, I get a hint as to the answer. What is going on is that Agda is doing the same thing as in the Lean version, namely wrapping the implicit arg so it is suc'd.
This is surprising as I thought that implicit arguments just means that Agda should provide them on its own. I did not think it would change the function when it is passed as an argument.
This is in continuation of this question, based on this answer. Using the technique explained by Saizan, and factoring my fromList-toList proof a bit to avoid the problematic recursion, I managed to fill in all but one cases of fromList-toList. I think it's easiest if I just show everything I have:
{-# OPTIONS --cubical #-}
module _ where
open import Cubical.Core.Everything
open import Cubical.Foundations.Everything hiding (assoc)
data FreeMonoid {ℓ} (A : Type ℓ) : Type ℓ where
[_] : A → FreeMonoid A
ε : FreeMonoid A
_·_ : FreeMonoid A → FreeMonoid A → FreeMonoid A
εˡ : ∀ x → ε · x ≡ x
εʳ : ∀ x → x · ε ≡ x
assoc : ∀ x y z → (x · y) · z ≡ x · (y · z)
squash : isSet (FreeMonoid A)
infixr 20 _·_
open import Cubical.Data.List hiding ([_])
module ListVsFreeMonoid {ℓ} {A : Type ℓ} (AIsSet : isSet A) where
listIsSet : isSet (List A)
listIsSet = isOfHLevelList 0 AIsSet
toList : FreeMonoid A → List A
toList [ x ] = x ∷ []
toList ε = []
toList (m₁ · m₂) = toList m₁ ++ toList m₂
toList (εˡ m i) = toList m
toList (εʳ m i) = ++-unit-r (toList m) i
toList (assoc m₁ m₂ m₃ i) = ++-assoc (toList m₁) (toList m₂) (toList m₃) i
toList (squash m₁ m₂ p q i j) = listIsSet (toList m₁) (toList m₂) (cong toList p) (cong toList q) i j
fromList : List A → FreeMonoid A
fromList [] = ε
fromList (x ∷ xs) = [ x ] · fromList xs
toList-fromList : ∀ xs → toList (fromList xs) ≡ xs
toList-fromList [] = refl
toList-fromList (x ∷ xs) = cong (x ∷_) (toList-fromList xs)
fromList-homo : ∀ xs ys → fromList xs · fromList ys ≡ fromList (xs ++ ys)
fromList-homo [] ys = εˡ (fromList ys)
fromList-homo (x ∷ xs) ys = assoc [ x ] (fromList xs) (fromList ys) ∙ cong ([ x ] ·_) (fromList-homo xs ys)
fromList-toList-· : ∀ {m₁ m₂ : FreeMonoid A} → fromList (toList m₁) ≡ m₁ → fromList (toList m₂) ≡ m₂ → fromList (toList (m₁ · m₂)) ≡ m₁ · m₂
fromList-toList-· {m₁} {m₂} p q = sym (fromList-homo (toList m₁) (toList m₂)) ∙ cong₂ _·_ p q
fromList-toList : ∀ m → fromList (toList m) ≡ m
fromList-toList [ x ] = εʳ [ x ]
fromList-toList ε = refl
fromList-toList (m₁ · m₂) = fromList-toList-· (fromList-toList m₁) (fromList-toList m₂)
fromList-toList (εˡ m i) = isSet→isSet' squash
(fromList-toList-· refl (fromList-toList m))
(fromList-toList m)
(λ i → fromList (toList (εˡ m i)))
(λ i → εˡ m i)
i
fromList-toList (εʳ m i) = isSet→isSet' squash
(fromList-toList-· (fromList-toList m) refl)
(fromList-toList m)
((λ i → fromList (toList (εʳ m i))))
(λ i → εʳ m i)
i
fromList-toList (assoc m₁ m₂ m₃ i) = isSet→isSet' squash
(fromList-toList-· (fromList-toList-· (fromList-toList m₁) (fromList-toList m₂)) (fromList-toList m₃))
(fromList-toList-· (fromList-toList m₁) (fromList-toList-· (fromList-toList m₂) (fromList-toList m₃)))
(λ i → fromList (toList (assoc m₁ m₂ m₃ i)))
(λ i → assoc m₁ m₂ m₃ i)
i
fromList-toList (squash x y p q i j) = ?
Sets are groupoids so I thought I can try doing exactly the same in that last case as before, just one dimension higher. But this is where I start failing: for some reason, two of the six faces cannot be constructed using the fact that FreeMonoid is a set. In more concrete terms, in the two missing faces in the code below, if I just try to refine by putting isSet→isSet' squash in the hole (with no more arguments specified), I already get "cannot refine".
Here's my code for the four faces that I managed to fill in:
fromList-toList (squash x y p q i j) = isGroupoid→isGroupoid' (hLevelSuc 2 _ squash)
{fromList (toList x)}
{x}
{fromList (toList y)}
{y}
{fromList (toList (p i))}
{p i}
{fromList (toList (q i))}
{q i}
{λ k → fromList (toList (p k))}
{fromList-toList x}
{fromList-toList y}
{p}
{λ k → fromList (toList (squash x y p q k i))}
{fromList-toList (p i)}
{fromList-toList (q i)}
{λ k → squash x y p q k i}
{λ k → fromList (toList (p (i ∧ k)))}
{λ k → p (i ∧ k)}
{λ k → fromList (toList (q (i ∨ ~ k)))}
{λ k → q (i ∨ ~ k)}
?
f2
f3
?
f5
f6
i
j
where
f2 = isSet→isSet' squash
(fromList-toList x) (fromList-toList (p i))
(λ k → fromList (toList (p (i ∧ k)))) (λ k → p (i ∧ k))
f3 = isSet→isSet' squash
(fromList-toList y) (fromList-toList (q i))
(λ k → fromList (toList (q (i ∨ ~ k)))) (λ k → q (i ∨ ~ k))
f5 = isSet→isSet' squash (fromList-toList x) (fromList-toList y)
(λ k → fromList (toList (p k)))
(λ k → p k)
f6 = isSet→isSet' squash (fromList-toList (p i)) (fromList-toList (q i))
(λ k → fromList (toList (squash x y p q k i)))
(λ k → squash x y p q k i)
The reported types of the two missing faces are:
Square
(λ k → fromList (toList (p (i ∧ k))))
(λ k → fromList (toList (p k)))
(λ k → fromList (toList (squash x y p q k i)))
(λ k → fromList (toList (q (i ∨ ~ k))))
and
Square
(λ k → p (i ∧ k))
p
(λ k → squash x y p q k i)
(λ k → q (i ∨ ~ k))
Of course, I make no claims that the existing four faces are correct.
So I guess my question is either, what are the two missing faces, or alternatively, what are the correct 6 faces?
The six faces are not arbitrary ones between the endpoints, they are given by the type and other clauses of fromList-toList.
To find them out we can use the strategy from the other answer but one dimension higher. First we declare a cube define through conging of fromList-toList:
fromList-toList (squash x y p q i j) = { }0
where
r : Cube ? ? ? ? ? ?
r = cong (cong fromList-toList) (squash x y p q)
We can then ask agda to solve the six ?s by C-c C-s and after a little cleanup we get:
r : Cube (λ i j → fromList (toList (squash x y p q i j)))
(λ i j → fromList-toList x j)
(λ i j → fromList-toList y j)
(λ i j → squash x y p q i j)
(λ i j → fromList-toList (p i) j)
(λ i j → fromList-toList (q i) j)
r = cong (cong fromList-toList) (squash x y p q)
in this case we are able to use those faces directly as there's no problem with recursion.
fromList-toList (squash x y p q i j)
= isGroupoid→isGroupoid' (hLevelSuc 2 _ squash)
(λ i j → fromList (toList (squash x y p q i j)))
(λ i j → fromList-toList x j)
(λ i j → fromList-toList y j)
(λ i j → squash x y p q i j)
(λ i j → fromList-toList (p i) j)
(λ i j → fromList-toList (q i) j)
i j
By the way, if you are going to prove more equalities by induction it may pay off to implement a more general function first:
elimIntoProp : (P : FreeMonoid A → Set) → (∀ x → isProp (P x))
→ (∀ x → P [ x ]) → P ε → (∀ x y → P x → P y → P (x · y)) → ∀ x → P x
as paths in FreeMonoid A are a proposition.
I was trying to prove that true ≡ false -> Empty assuming the J axiom. It is defined as:
J : Type
J = forall
{A : Set}
{C : (x y : A) → (x ≡ y) → Set} →
(c : ∀ x → C x x refl) →
(x y : A) →
(p : x ≡ y) →
C x y p
My attempt went like this:
bad : J → true ≡ false -> Empty
bad j e = j Bool (λ { true _ _ => Unit; false _ _ => Empty }) _
Now, to proceed with the proof, I needed a term c : ∀ x -> C x x refl. Since I instantiated C, it becomes c : ∀ x -> (λ { true _ _ => Unit; false _ _ => Empty } x x refl. Then I got stuck. c can't reduce further because we don't know the value of x. I wasn't able to complete this proof. But there is a different version of J:
J' : Type
J' = forall
{A : Set}
{x : A}
{C : (y : A) → (x ≡ y) → Set} →
(c : C x refl) →
(y : A) →
(p : x ≡ y) →
C y p
With this one, this problem is solved, because t can be fixed to be true. This makes the c argument reduce to Unit, which we can provide. My question is: can we convert the former version to the later? That is, can we build a term fix_x : J → J'? Does that hold in general (i.e., can indices be converted to parameters)?
First, regarding true ≡ false -> Empty: this is unprovable if you can only eliminate into Set0 with J, so you need an universe polymorphic or large definition. I write some preliminaries here:
{-# OPTIONS --without-K #-}
open import Relation.Binary.PropositionalEquality
open import Level
data Bool : Set where true false : Bool
data Empty : Set where
record Unit : Set where
constructor tt
JTy : ∀ {i j} → Set _
JTy {i}{j} =
{A : Set i}
(P : (x y : A) → (x ≡ y) → Set j) →
(pr : ∀ x → P x x refl) →
{x y : A} →
(p : x ≡ y) →
P x y p
J : ∀ {i}{j} → JTy {i}{j}
J P pr {x} refl = pr x
J₀ = J {zero}{zero}
Now, transport or subst is the only needed thing for true ≡ false -> Empty:
transp : ∀ {i j}{A : Set i}(P : A → Set j){x y} → x ≡ y → P x → P y
transp P = J (λ x y _ → P x -> P y) (λ _ px → px)
true≢false : true ≡ false → Empty
true≢false e = transp (λ {true → Unit; false → Empty}) e tt
Considering now proving the pointed J' from J, I know about three solutions, and each uses different features from the ambient theory.
The simplest one is to use universes to abstract over the induction motive:
JTy' : ∀ {i j} → Set _
JTy' {i}{j} =
{A : Set i}
{x : A}
(P : ∀ y → x ≡ y → Set j)
(pr : P x refl)
{y : A}
(p : x ≡ y)
→ P y p
JTy→JTy' : (∀ {i j} → JTy {i}{j}) → ∀ {i}{j} → JTy' {i}{j}
JTy→JTy' J {i} {j} {A} {x} P pr {y} e =
J (λ x y e → (P : ∀ y → x ≡ y → Set j) → P x refl → P y e)
(λ x P pr → pr) e P pr
If we only want to use a fixed universe level, then it is a bit more complicated. The following solution, sometimes called "contractible singletons", needs Σ-types, but nothing else:
open import Data.Product
JTy→JTy'withΣ : JTy {zero}{zero} → JTy' {zero}{zero}
JTy→JTy'withΣ J {A} {x} P pr {y} e =
J (λ {(x , r) (y , e) _ → P x r → P y e})
(λ _ px → px)
(J (λ x y e → (x , refl) ≡ (y , e))
(λ _ → refl)
e)
pr
There is a solution which doesn't even need Σ-s, but requires the beta rule for J, which says that J P pr {x} refl = pr x. It doesn't matter whether this rule holds definitionally or just as a propositional equality, but the construction is simpler when it holds definitionally, so let's do that. Note that I don't use any universe other than Set0.
transp₀ = transp {zero}{zero}
transp2 : ∀ {A : Set}{B : A → Set}(C : ∀ a → B a → Set)
{x y : A}(e : x ≡ y){b} → C x b → C y (transp₀ B e b)
transp2 {A}{B} C {x}{y} e {b} cxb =
J₀ (λ x y e → ∀ b → C x b → C y (transp₀ B e b)) (λ _ _ cxb → cxb) e b cxb
JTy→JTy'noΣU : JTy' {zero}{zero}
JTy→JTy'noΣU {A} {x} P pr {y} e =
transp₀ (P y) (J₀ (λ x y e → transp₀ (x ≡_) e refl ≡ e) (λ _ → refl) e)
(transp2 {A} {λ y → x ≡ y} P e pr)
Philosophically, the third version is the most "conservative", since it only assumes J. The addition of the beta rule is not really an extra thing, since it is always assumed to hold (definitionally or propositionally) for _≡_.
can indices be converted to parameters?
If you have propositional equality, then all indices can be converted to parameters, and fixed in constructors using equality proofs.
I found handy a function:
coerce : ∀ {ℓ} {A B : Set ℓ} → A ≡ B → A → B
coerce refl x = x
when defining functions with indexed types. In situations where indexes are not definitionally equal i,e, one have to use lemma, to show the types match.
zipVec : ∀ {a b n m } {A : Set a} {B : Set b} → Vec A n → Vec B m → Vec (A × B) (n ⊓ m)
zipVec [] _ = []
zipVec {n = n} _ [] = coerce (cong (Vec _) (0≡n⊓0 n)) []
zipVec (x ∷ xs) (y ∷ ys) = (x , y) ∷ zipVec xs ys
Note, yet this example is easy to rewrite so one don't need to coerce:
zipVec : ∀ {a b n m } {A : Set a} {B : Set b} → Vec A n → Vec B m → Vec (A × B) (n ⊓ m)
zipVec [] _ = []
zipVec (_ ∷ _) [] = []
zipVec (x ∷ xs) (y ∷ ys) = (x , y) ∷ zipVec xs ys
Sometimes pattern matching doesn't help though.
The question: But I wonder, whether something like that functions is already in agda-stdlib? And is there something like hoogle for Agda, or something like SearchAbout?
I don't think there is exactly your coerce function. However, it's a special case of a more general function - subst (the substitutive property of equality) from Relation.Binary.PropositionalEquality:
subst : ∀ {a p} {A : Set a} (P : A → Set p) {x y : A}
→ x ≡ y → P x → P y
subst P refl p = p
If you choose P = id (from Data.Function, or just write λ x → x), you get:
coerce : ∀ {ℓ} {A B : Set ℓ} → A ≡ B → A → B
coerce = subst id
By the way, the most likely reason you won't find this function predefined, is that Agda deals with coerces like that through rewrite:
postulate
n⊓0≡0 : ∀ n → n ⊓ 0 ≡ 0
zipVec : ∀ {a b n m} {A : Set a} {B : Set b}
→ Vec A n → Vec B m → Vec (A × B) (n ⊓ m)
zipVec [] _ = []
zipVec {n = n} _ [] rewrite n⊓0≡0 n = []
zipVec (x ∷ xs) (y ∷ ys) = (x , y) ∷ zipVec xs ys
This is a syntactic sugar for the more complicated:
zipVec {n = n} _ [] with n ⊓ 0 | n⊓0≡0 n
... | ._ | refl = []
If you are familiar with how with works, try to figure out how rewrite works; it's quite enlightening.
I am new to Agda, and I think I still have a problem to think in that paradigm. Here is my question..
I have a type monoid and a type Group implemented as follows:
record Monoid : Set₁ where
constructor monoid
field Carrier : Set
_⊙_ : Carrier → Carrier → Carrier
e : Carrier
leftId : ∀ {x : Carrier} → (e ⊙ x) ≡ x
rightId : ∀ {x : Carrier} → (x ⊙ e) ≡ x
assoc : ∀ {x y z : Carrier} → (x ⊙ (y ⊙ z)) ≡ ((x ⊙ y) ⊙ z)
record Group : Set₁ where
constructor group
field m : Monoid
inv : Carrier → Carrier
inverse1 : {x y : Carrier} → x ⊙ (inv x) ≡ e
inverse2 : {x y : Carrier} → (inv x) ⊙ x ≡ e
Now, I want to proof the following lemma :
lemma1 : (x y : Carrier) → (inv x) ⊙ (x ⊙ y) ≡ y
lemma1 x y = ?
If I do it on paper, I will apply associativity then left identity.. but I do not know how to tell agda to apply these rules.. I have the problem of translating my thoughts to the Agda paradigm..
Any help is highly appreciated..
When you do the proof on the paper, applying associativity and then left identity uses ony key property of the identity relation - transitivity. That is, when you have a proof of p : x ≡ y and q : y ≡ z you can combine them into a single proof of trans p q : x ≡ z. The trans function is already part of the standard library (Relation.Binary.PropositionalEquality module), but its implementation is fairly simple anyways:
trans : {A : Set} {i j k : A} → i ≡ j → j ≡ k → i ≡ k
trans refl eq = eq
I'm using a bit different presentation of monoids and groups, but you can easily adapt the proof to your scenario.
open import Function
open import Relation.Binary.PropositionalEquality
Op₁ : Set → Set
Op₁ A = A → A
Op₂ : Set → Set
Op₂ A = A → A → A
record IsMonoid {A : Set}
(_∙_ : Op₂ A) (ε : A) : Set where
field
right-id : ∀ x → x ∙ ε ≡ x
left-id : ∀ x → ε ∙ x ≡ x
assoc : ∀ x y z → x ∙ (y ∙ z) ≡ (x ∙ y) ∙ z
record IsGroup {A : Set}
(_∙_ : Op₂ A) (ε : A) (_⁻¹ : Op₁ A) : Set where
field
monoid : IsMonoid _∙_ ε
right-inv : ∀ x → x ∙ x ⁻¹ ≡ ε
left-inv : ∀ x → x ⁻¹ ∙ x ≡ ε
open IsMonoid monoid public
(To keep things simple, indented code is written as part of the IsGroup record). We'd like to prove that:
lemma : ∀ x y → x ⁻¹ ∙ (x ∙ y) ≡ y
lemma x y = ?
The first step is to use associativity, that is assoc (x ⁻¹) x y, this leaves us with a goal (x ⁻¹ ∙ x) ∙ y ≡ y - once we prove that, we can merge these two parts together using trans:
lemma x y =
trans (assoc (x ⁻¹) x y) ?
Now, we need to apply the right inverse property, but the types don't seem to fit. We have left-inv x : x ⁻¹ ∙ x ≡ ε and we need to somehow deal with the extra y. This is when another property of the identity comes into play.
Ordinary functions preserve identity; if we have a function f and a proof p : x ≡ y we can apply f to both x and y and the proof should be still valid, that is cong f p : f x ≡ f y. Again, implementation is already in the standard library, but here it is anyways:
cong : {A : Set} {B : Set}
(f : A → B) {x y} → x ≡ y → f x ≡ f y
cong f refl = refl
What function should we apply? Good candidate seems to be λ z → z ∙ y, which adds the missing y part. So, we have:
cong (λ z → z ∙ y) (left-inv x) : (x ⁻¹ ∙ x) ∙ y ≡ ε ∙ y
Again, we just need to prove that ε ∙ y ≡ y and we can then piece those together using trans. But this last property is easy, it's just left-id y. Putting it all together, we get:
lemma : ∀ x y → x ⁻¹ ∙ (x ∙ y) ≡ y
lemma x y =
trans (assoc (x ⁻¹) x y) $
trans (cong (λ z → z ∙ y) (left-inv x)) $
(left-id y)
Standard library also gives us some nice syntactic sugar for this:
open ≡-Reasoning
lemma′ : ∀ x y → x ⁻¹ ∙ (x ∙ y) ≡ y
lemma′ x y = begin
x ⁻¹ ∙ (x ∙ y) ≡⟨ assoc (x ⁻¹) x y ⟩
(x ⁻¹ ∙ x) ∙ y ≡⟨ cong (λ z → z ∙ y) (left-inv x) ⟩
ε ∙ y ≡⟨ left-id y ⟩
y ∎
Behind the scenes, ≡⟨ ⟩ uses precisely trans to merge those proofs. The types are optional (the proofs themselves carry enough information about them), but they are here for readability.
To get your original Group record, we can do something like:
record Group : Set₁ where
field
Carrier : Set
_∙_ : Op₂ Carrier
ε : Carrier
_⁻¹ : Op₁ Carrier
isGroup : IsGroup _∙_ ε _⁻¹
open IsGroup isGroup public