I'm a beginner with Agda and im stuck with a hole in my proof here:
import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; cong; sym; subst; trans)
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; step-≡; _∎)
data Tile : Set where
-- 90° rotation
postulate cw : Tile → Tile
-- -90° rotation
postulate ccw : Tile → Tile
postulate cw/cw/cw/cw : ∀ (t : Tile) → cw (cw (cw (cw t))) ≡ t
postulate ccw/cw : ∀ (t : Tile) → ccw (cw t) ≡ t
postulate cw/ccw : ∀ (t : Tile) → cw (ccw t) ≡ t
cw/cw/cw/ccw : ∀ (t : Tile) → ccw t ≡ cw (cw (cw t))
cw/cw/cw/ccw t =
begin
ccw t
≡⟨ cong ccw ( sym (cw/cw/cw/cw t)) ⟩
ccw ( cw ( cw ( cw ( cw t))))
≡⟨ {!!} ⟩
cw (cw (cw t))
∎
I simply need to show that given the ccw/cw postulation,
ccw (cw (cw (cw (cw t)))) ≡ cw (cw (cw t))
Found it: I needed to put this in the hole: (ccw/cw ( cw ( cw ( cw t))))
which produces this: ccw (cw ( cw ( cw ( cw t)))) ≡ ( cw ( cw ( cw t))),
essentially replacing t with ( cw ( cw ( cw t)))
Related
I need to break this long line:
postulate flipH/cw/cw/flipH : ∀ (t : Tile) -> flipH (cw (cw (flipH t))) ≡ cw (cw t)
Agda won't accept any of these:
postulate flipH/cw/cw/flipH
: ∀ (t : Tile) -> flipH (cw (cw (flipH t))) ≡ cw (cw t)
postulate flipH/cw/cw/flipH : ∀ (t : Tile) ->
flipH (cw (cw (flipH t))) ≡ cw (cw t)
but it does accept this which is not very ideal, since it does not give me much space to work with before it gets long again:
postulate flipH/cw/cw/flipH : ∀ (t : Tile) ->
flipH (cw (cw (flipH t))) ≡ cw (cw t)
Is there a way to break line similar to the way we do it in Haskell?
postulate is a block keyword, meaning that it's set up to parse multiple postulates under a single occurrence of postulate. For example:
postulate
A : Set
B : Set → Set
That means you'll have better luck when you put flipH/cw/cw/flipH on a new line. For example, you might want to write:
postulate
flipH/cw/cw/flipH : ∀ (t : Tile) ->
flipH (cw (cw (flipH t))) ≡ cw (cw t)
I'm trying to replicate the main lemma in the HoTT book (page 70) for proving the Eckmann Hilton Theorem, only using J (no pattern matching).
It says "But, in general, the two ways of defining horizontal composition agree, α ⋆ β = α ⋆' β, as we can see by induction on α and β and then on the two remaining 1-paths, to reduce everything to reflexivity..."
I'm quite confused as to if the E type signature is correct - should r' and s have different paths? d won't refine, so I assume there's something wrong with E? I also don't really understand which two paths I'm supposed to induct upon to complete the proof, are they r' and s? If so, I don't understand what these final motives should be? Doesn't reducing 'β' down to r eliminate the need for further induction on 1-paths?
Any answers/solutions, and more imporatntly, ways of thinking about the problem are welcome.
_⋆≡⋆'_ : {A : Set} → {a b c : A} {p q : a ≡ b} {r' s : b ≡ c} (α : p ≡ q) (β : r' ≡ s) → (α ⋆ β) ≡ (α ⋆' β)
_⋆≡⋆'_ {A} {a} {b} {c} {p} {q} {r'} {s} α β = J D d p q α c r' s β
where
D : (p q : a ≡ b) → p ≡ q → Set
D p q α = (c : A) (r' s : b ≡ c) (β : r' ≡ s) → (α ⋆ β) ≡ (α ⋆' β)
E : (r' s : b ≡ c) → r' ≡ s → Set
-- E p q β = (r ⋆ β) ≡ (r ⋆' β)
E r' s β = (_⋆_ {A} {b = b} {c} {r} {r} {r' = r'} {s = s} r β) ≡ (r ⋆' β)
e : ((s : b ≡ c) → E s s r)
e r = r --this is for testing purposes
d : ((p : a ≡ b) → D p p r)
d p c r' s β = {!J E e !}
Below is the rest of the code to get here.
module q where
data _≡_ {A : Set} (a : A) : A → Set where
r : a ≡ a
infix 20 _≡_
J : {A : Set}
→ (D : (x y : A) → (x ≡ y) → Set)
-- → (d : (a : A) → (D a a r ))
→ ((a : A) → (D a a r ))
→ (x y : A)
→ (p : x ≡ y)
------------------------------------
→ D x y p
J D d x .x r = d x
_∙_ : {A : Set} → {x y : A} → (p : x ≡ y) → {z : A} → (q : y ≡ z) → x ≡ z
_∙_ {A} {x} {y} p {z} q = J D d x y p z q
where
D : (x₁ y₁ : A) → x₁ ≡ y₁ → Set
D x y p = (z : A) → (q : y ≡ z) → x ≡ z
d : (z₁ : A) → D z₁ z₁ r
d = λ v z q → q
infixl 40 _∙_
_⁻¹ : {A : Set} {x y : A} → x ≡ y → y ≡ x
-- _⁻¹ {A = A} {x} {y} p = J2 D d x y p
_⁻¹ {A} {x} {y} p = J D d x y p
where
D : (x y : A) → x ≡ y → Set
D x y p = y ≡ x
d : (a : A) → D a a r
d a = r
infixr 50 _⁻¹
iₗ : {A : Set} {x y : A} (p : x ≡ y) → p ≡ r ∙ p
iₗ {A} {x} {y} p = J D d x y p
where
D : (x y : A) → x ≡ y → Set
D x y p = p ≡ r ∙ p
d : (a : A) → D a a r
d a = r
iᵣ : {A : Set} {x y : A} (p : x ≡ y) → p ≡ p ∙ r
iᵣ {A} {x} {y} p = J D d x y p
where
D : (x y : A) → x ≡ y → Set
D x y p = p ≡ p ∙ r
d : (a : A) → D a a r
d a = r
_∙ᵣ_ : {A : Set} → {b c : A} {a : A} {p q : a ≡ b} (α : p ≡ q) (r' : b ≡ c) → p ∙ r' ≡ q ∙ r'
_∙ᵣ_ {A} {b} {c} {a} {p} {q} α r' = J D d b c r' a α
where
D : (b c : A) → b ≡ c → Set
D b c r' = (a : A) {p q : a ≡ b} (α : p ≡ q) → p ∙ r' ≡ q ∙ r'
d : (a : A) → D a a r
d a a' {p} {q} α = iᵣ p ⁻¹ ∙ α ∙ iᵣ q
-- iᵣ == ruₚ in the book
_∙ₗ_ : {A : Set} → {a b : A} (q : a ≡ b) {c : A} {r' s : b ≡ c} (β : r' ≡ s) → q ∙ r' ≡ q ∙ s
_∙ₗ_ {A} {a} {b} q {c} {r'} {s} β = J D d a b q c β
where
D : (a b : A) → a ≡ b → Set
D a b q = (c : A) {r' s : b ≡ c} (β : r' ≡ s) → q ∙ r' ≡ q ∙ s
d : (a : A) → D a a r
d a a' {r'} {s} β = iₗ r' ⁻¹ ∙ β ∙ iₗ s
_⋆_ : {A : Set} → {a b c : A} {p q : a ≡ b} {r' s : b ≡ c} (α : p ≡ q) (β : r' ≡ s) → p ∙ r' ≡ q ∙ s
_⋆_ {A} {q = q} {r' = r'} α β = (α ∙ᵣ r') ∙ (q ∙ₗ β)
_⋆'_ : {A : Set} → {a b c : A} {p q : a ≡ b} {r' s : b ≡ c} (α : p ≡ q) (β : r' ≡ s) → p ∙ r' ≡ q ∙ s
_⋆'_ {A} {p = p} {s = s} α β = (p ∙ₗ β) ∙ (α ∙ᵣ s)
In formalization, based path induction is far more convenient than the two-sided version. With based J, we essentially rewrite in the goal type the right endpoint of a path to the left one and the path itself to reflexivity. With non-based J, we rewrite both endpoints to a "fresh" opaque variable, hence we lose the "connection" of the left endpoint to other constructions in scope (since the left endpoint may occur in other types in scope).
I haven't looked at the exact issue with your definition, but I note that with based J it's almost trivial.
data _≡_ {A : Set} (a : A) : A → Set where
r : a ≡ a
infix 20 _≡_
J : {A : Set}{x : A}(P : ∀ y → x ≡ y → Set) → P x r → ∀ {y} p → P y p
J {A} {x} P pr r = pr
tr : {A : Set}(P : A → Set){x y : A} → x ≡ y → P x → P y
tr P p px = J (λ y _ → P y) px p
_∙_ : {A : Set} → {x y z : A} → (p : x ≡ y) → (q : y ≡ z) → x ≡ z
_∙_ {A} {x} {y} {z} p q = tr (x ≡_) q p
ap : {A B : Set}(f : A → B){x y : A} → x ≡ y → f x ≡ f y
ap f {x} {y} p = tr (λ y → f x ≡ f y) p r
infixl 40 _∙_
_∙ᵣ_ : {A : Set} → {b c : A} {a : A} {p q : a ≡ b} (α : p ≡ q) (r' : b ≡ c) → p ∙ r' ≡ q ∙ r'
α ∙ᵣ r' = ap (_∙ r') α
_∙ₗ_ : {A : Set} → {a b : A} (q : a ≡ b) {c : A} {r' s : b ≡ c} (β : r' ≡ s) → q ∙ r' ≡ q ∙ s
q ∙ₗ β = ap (q ∙_) β
_⋆_ : {A : Set} → {a b c : A} {p q : a ≡ b} {r' s : b ≡ c} (α : p ≡ q) (β : r' ≡ s) → p ∙ r' ≡ q ∙ s
_⋆_ {q = q} {r'} α β = (α ∙ᵣ r') ∙ (q ∙ₗ β)
_⋆'_ : {A : Set} → {a b c : A} {p q : a ≡ b} {r' s : b ≡ c} (α : p ≡ q) (β : r' ≡ s) → p ∙ r' ≡ q ∙ s
_⋆'_ {A} {p = p} {s = s} α β = (p ∙ₗ β) ∙ (α ∙ᵣ s)
_⋆≡⋆'_ : {A : Set} → {a b c : A} {p q : a ≡ b} {r' s : b ≡ c} (α : p ≡ q) (β : r' ≡ s) → (α ⋆ β) ≡ (α ⋆' β)
_⋆≡⋆'_ {A} {a} {b} {c} {p} {q} {r'} {s} α β =
J (λ s β → (α ⋆ β) ≡ (α ⋆' β))
(J (λ q α → (α ⋆ r) ≡ (α ⋆' r))
r
α) -- induction on α
β -- induction on β
Is the univalence axiom invertible (modulo paths)? Is it possible to prove, using Agda's Cubical library, to prove the following:
open import Cubical.Core.Glue
uaInj : ∀ {ℓ} {A B : Set ℓ} {f g : A ≃ B} →
ua f ≡ ua g → equivFun f ≡ equivFun g
I suspect the above should hold, because in example 3.19 of the HoTT book, there is a step in the proof where an equivalence between two equivalences is used to prove the equivalence between their functions:
[...] so f is an
equivalence. Hence, by univalence, f gives rise to a path p : A ≡ A.
If p were equal to refl A, then (again by univalence) f would equal the
identity function of A.
Sure, ua is an equivalence, so it's injective. In the HoTT book, the inverse of ua is idtoeqv, so by congruence idtoeqv (ua f) ≡ idtoeqv (ua g) and then by inverses f ≡ g. I'm not familiar with the contents of cubical Agda prelude but this should be provable since it follows directly from the statement of univalence.
To put András's answer into code, we can prove injectivity of equivalency functions in general:
equivInj : ∀ {ℓ₁ ℓ₂} {A : Set ℓ₁} {B : Set ℓ₂} (f : A ≃ B) →
∀ x x′ → equivFun f x ≡ equivFun f x′ → x ≡ x′
equivInj f x x′ p = cong fst $ begin
x , refl ≡⟨ sym (equivCtrPath f (equivFun f x) (x , refl)) ⟩
equivCtr f (equivFun f x) ≡⟨ equivCtrPath f (equivFun f x) (x′ , p) ⟩
x′ , p ∎
and then given
univalence : ∀ {ℓ} {A B : Set ℓ} → (A ≡ B) ≃ (A ≃ B)
we get
uaInj : ∀ {ℓ} {A B : Set ℓ} {f g : A ≃ B} → ua f ≡ ua g → equivFun f ≡ equivFun g
uaInj {f = f} {g = g} = cong equivFun ∘ equivInj (invEquiv univalence) f g
The only problem is, univalence is not readily available in the Cubical library. Hopefully that is getting sorted out shortly.
UPDATE: In reaction to the above bug ticket, proof of univalence is now available in the Cubical library.
Suppose I have, using the cubical-demo library, the following things in scope:
i : I
p0 : x ≡ y
p1 : x' ≡ y'
q0 : x ≡ x'
q1 : y ≡ y'
How do I then construct
q' : p0 i ≡ p1 i
?
One way is by contracting singleton pairs with J, there might be simpler proofs though.
open import Cubical.PathPrelude
q' : ∀ {A : Set} (i : I) (x : A)
x' (q0 : x ≡ x')
y (p0 : x ≡ y)
y' (p1 : x' ≡ y')
(q1 : y ≡ y') → p0 i ≡ p1 i
q' i x = pathJ _ (pathJ _ (pathJ _ (\ q1 → q1)))
Another one I've come up with is I think closer to the spirit of the original problem instead of going around:
slidingLid : ∀ (p₀ : a ≡ b) (p₁ : c ≡ d) (q : a ≡ c) → ∀ i → p₀ i ≡ p₁ i
slidingLid p₀ p₁ q i j = comp (λ _ → A)
(λ{ k (i = i0) → q j
; k (j = i0) → p₀ (i ∧ k)
; k (j = i1) → p₁ (i ∧ k)
})
(inc (q j))
This one has the very nice property that it degenerates to q at i = i0 definitionally:
slidingLid₀ : ∀ p₀ p₁ q → slidingLid p₀ p₁ q i0 ≡ q
slidingLid₀ p₀ p₁ q = refl
I've found another solution to this, which is more explicit that it is gluing together a prefix of p0 (flipped), q0, and a prefix of p1:
open import Cubical.PathPrelude
module _ {ℓ} {A : Set ℓ} where
midPath : ∀ {a b c d : A} (p₀ : a ≡ b) (p₁ : c ≡ d) → (a ≡ c) → ∀ i → p₀ i ≡ p₁ i
midPath {a = a} {c = c} p₀ p₁ q i = begin
p₀ i ≡⟨ transp (λ j → p₀ (i ∧ j) ≡ a) refl ⟩
a ≡⟨ q ⟩
c ≡⟨ transp (λ j → c ≡ p₁ (i ∧ j)) refl ⟩
p₁ i ∎
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