The PLFA exercise: what if we write the arithmetic more "naturally" in Quantifiers chapter (https://plfa.github.io/Quantifiers/) ?
∃-even′ : ∀ {n : ℕ} → ∃[ m ] ( 2 * m ≡ n) → even n
∃-odd′ : ∀ {n : ℕ} → ∃[ m ] (2 * m + 1 ≡ n) → odd n
I have make the type right. But have got Termination checking failed for the following functions:
dbl≡2* : ∀ n → n + n ≡ 2 * n
dbl≡2* n = cong (n +_) (sym (+-identityʳ n))
+-suc1 : ∀ (m : ℕ) → m + 1 ≡ suc m
+-suc1 m =
begin
m + 1
≡⟨⟩
m + (suc zero)
≡⟨ +-suc m zero ⟩
suc (m + zero)
≡⟨ cong suc (+-identityʳ m) ⟩
suc m
∎
help1 : ∀ m → 2 * m + 1 ≡ suc (m + m)
help1 m =
begin
2 * m + 1
≡⟨ sym ( cong (_+ 1) (dbl≡2* m) ) ⟩
m + m + 1 -- must use every rule
≡⟨ +-assoc m m 1 ⟩
m + (m + 1)
≡⟨ cong (m +_) (+-suc1 m) ⟩
m + suc m
≡⟨ +-suc m m ⟩
suc (m + m)
∎
∃-even′ ⟨ zero , refl ⟩ = even-zero
∃-even′ ⟨ suc m , refl ⟩ rewrite +-identityʳ m
| +-suc m m
= even-suc (∃-odd′ ⟨ (m) , help1 m ⟩)
∃-odd′ ⟨ m , refl ⟩ rewrite +-suc (2 * m) 0
| +-identityʳ m
| +-identityʳ (m + m)
| dbl≡2* m
= odd-suc (∃-even′ ⟨ m , refl ⟩)
For the normal version, the same mutually-recursive define can work fine.
∃-even : ∀ {n : ℕ} → ∃[ m ] ( m * 2 ≡ n) → even n
∃-odd : ∀ {n : ℕ} → ∃[ m ] (1 + m * 2 ≡ n) → odd n
∃-even ⟨ zero , refl ⟩ = even-zero
∃-even ⟨ suc x , refl ⟩ = even-suc (∃-odd ⟨ x , refl ⟩)
∃-odd ⟨ x , refl ⟩ = odd-suc (∃-even ⟨ x , refl ⟩)
∃-even′ ⟨ zero , refl ⟩ = even-zero
∃-even′ ⟨ suc m , refl ⟩ rewrite +-identityʳ m
| +-suc m m
= even-suc (∃-odd′ ⟨ m , help1 m ⟩)
∃-odd′ ⟨ m , refl ⟩ rewrite +-suc (2 * m) 0
| +-identityʳ m
| +-identityʳ (m + m)
| dbl≡2* m
= odd-suc (∃-even′ ⟨ m , refl ⟩)
Your recursive calls are:
∃-even′ ⟨ suc m , refl ⟩ -> ∃-odd′ ⟨ m , help1 m ⟩
∃-odd′ ⟨ m , refl ⟩ -> ∃-even′ ⟨ m , refl ⟩
In the first one, suc m -> m decreases, but refl -> help1 m (on its surface) increases. If you passed refl as the second argument to ∃-odd′, then the termination checker would accept it, since it means the second argument stays the same, while the first one strictly monotonically decreases over a complete chain of two calls.
So how can we change that first recursive call to ∃-odd′ ⟨ m , refl ⟩? By rewriting by sym (help1 m):
∃-even′ ( suc m , refl ) rewrite +-identityʳ m
| +-suc m m
| sym (help1 m)
= even-suc (∃-odd′ (m , refl))
This code is then accepted by the termination checker.
Related
I want to prove that (c * a) / (c * b) = a / b in agda using the division function defined in the standard library. The proofs keep coming back to this thing div-helper that is very difficult to work with and reason about.
open import Data.Nat.DivMod using (_/_)
open import Relation.Binary.PropositionalEquality using (_≡_)
open import Data.Nat using (ℕ; suc; zero)
/-cancelˡ : ∀ c a b {b≢0} {b*c≢0} → ((c * a) / (c * b)) {b*c≢0} ≡ (a / b) {b≢0}
/-cancelˡ (suc c) a (suc b) {b≢0} {b*c≢0} = ?
That hole simplifies to:
div-helper 0 (b + c * suc b) (a + c * a) (b + c * suc b) ≡ div-helper 0 b a b
I could come up with two different proofs.
Proof 1 is completely agnostic of div-helper's structure. It is based on lemmas about division from the standard library. It proves a few additional lemmas about division, which it then uses to prove the property we're after. It's a little involved, but I think that the additional lemmas are useful in their own right.
Proof 2 considers the structure of div-helper and proves two invariants from which the property follows trivially. It's way more concise.
This is the property we're after:
∀ (a b n : ℕ) → divₕ 0 (b + n + b * n) (a + n * a) (b + n + b * n) ≡ divₕ 0 b a b
What makes this look a little weird is that the division helper takes n (as opposed to suc n) for a / suc n. That's where b + n + b * n comes from - suc (b + n + b * n) is equal to suc b * suc n.
Stated in terms of / instead of the division helper, the proof thus says that (a * suc n) / (suc b * suc n) is equal to a / suc b.
This is proof 1:
module Answer where
open import Relation.Binary.PropositionalEquality as P using (_≡_; cong; refl; subst; sym)
open import Data.Nat
open import Data.Nat.DivMod
open import Data.Nat.DivMod.Core
open import Data.Nat.Properties
open import Agda.Builtin.Nat using () renaming (div-helper to divₕ; mod-helper to modₕ)
divₕ′ : ℕ → ℕ → ℕ
divₕ′ a m = divₕ 0 m a m
modₕ′ : ℕ → ℕ → ℕ
modₕ′ a m = modₕ 0 m a m
a<n⇒a[divₕ]n≡0 : ∀ (a n n′ : ℕ) → a ≤ n → divₕ 0 n′ a n ≡ 0
a<n⇒a[divₕ]n≡0 zero _ _ _ = refl
a<n⇒a[divₕ]n≡0 (suc a) (suc n) n′ (s≤s a≤n) = a<n⇒a[divₕ]n≡0 a n n′ a≤n
a*n[modₕ]n≡0 : ∀ (a n : ℕ) → modₕ 0 n (a * suc n) n ≡ 0
a*n[modₕ]n≡0 zero n = refl
a*n[modₕ]n≡0 (suc a) n rewrite +-comm (suc n) (a * suc n) | a+n[modₕ]n≡a[modₕ]n 0 (a * suc n) n = a*n[modₕ]n≡0 a n
a<n⇒a+b*n[divₕ]n≡b : ∀ (a b n : ℕ) → a ≤ n → divₕ 0 n (a + b * suc n) n ≡ b
a<n⇒a+b*n[divₕ]n≡b a b n a≤n =
begin
divₕ′ (a + b * suc n) n
≡⟨ +-distrib-divₕ 0 0 a (b * suc n) n lem₁ ⟩
divₕ′ a n + divₕ′ (b * suc n) n
≡⟨ cong (_+ divₕ′ (b * suc n) n) (a<n⇒a[divₕ]n≡0 a n n a≤n) ⟩
0 + divₕ′ (b * suc n) n
≡⟨ +-identityˡ (divₕ 0 n (b * suc n) n) ⟩
divₕ′ (b * suc n) n
≡⟨ m*n/n≡m b (suc n) ⟩
b
∎
where
open P.≡-Reasoning
≤₁ = a[modₕ]n<n 0 a n
≤₂ = ≤-reflexive (a*n[modₕ]n≡0 b n)
<₃ : n + 0 < suc n
<₃ = s≤s (≤-reflexive (+-identityʳ n))
lem₁ : modₕ′ a n + modₕ′ (b * suc n) n < suc n
lem₁ = <-transʳ (+-mono-≤ ≤₁ ≤₂) <₃
a[divₕ]m*n≡a[divₕ]m[divₕ]n : ∀ (a m n : ℕ) → divₕ 0 (m + n + m * n) a (m + n + m * n) ≡ divₕ 0 n (divₕ 0 m a m) n
a[divₕ]m*n≡a[divₕ]m[divₕ]n a m n =
begin
divₕ′ a mn
≡⟨ cong (λ # → divₕ′ # mn) (div-mod-lemma 0 0 a m) ⟩
divₕ′ (modₕ′ a m + divₕ′ a m * suc m) mn
≡⟨ cong (λ # → divₕ′ (modₕ′ a m + # * suc m) mn) (div-mod-lemma 0 0 (divₕ′ a m) n) ⟩
divₕ′ (modₕ′ a m + (modₕ′ (divₕ′ a m) n + divₕ′ (divₕ′ a m) n * suc n) * suc m) mn
≡⟨ cong (λ # → divₕ′ (modₕ′ a m + #) mn) (*-distribʳ-+ (suc m) (modₕ′ (divₕ′ a m) n) (divₕ′ (divₕ′ a m) n * suc n)) ⟩
divₕ′ (modₕ′ a m + (modₕ′ (divₕ′ a m) n * suc m + divₕ′ (divₕ′ a m) n * suc n * suc m)) mn
≡⟨ cong (λ # → divₕ′ # mn) (sym (+-assoc (modₕ′ a m) (modₕ′ (divₕ′ a m) n * suc m) (divₕ′ (divₕ′ a m) n * suc n * suc m))) ⟩
divₕ′ (modₕ′ a m + modₕ′ (divₕ′ a m) n * suc m + divₕ′ (divₕ′ a m) n * suc n * suc m) mn
≡⟨ cong (λ # → divₕ′ (modₕ′ a m + modₕ′ (divₕ′ a m) n * suc m + #) mn) (*-assoc (divₕ′ (divₕ′ a m) n) (suc n) (suc m))⟩
divₕ′ (modₕ′ a m + modₕ′ (divₕ′ a m) n * suc m + divₕ′ (divₕ′ a m) n * (suc n * suc m)) mn
≡⟨ cong (λ # → divₕ′ (modₕ′ a m + modₕ′ (divₕ′ a m) n * suc m + divₕ′ (divₕ′ a m) n * #) mn) (*-comm (suc n) (suc m)) ⟩
divₕ′ (modₕ′ a m + modₕ′ (divₕ′ a m) n * suc m + divₕ′ (divₕ′ a m) n * (suc m * suc n)) mn
≡⟨ cong (λ # → divₕ′ (modₕ′ a m + modₕ′ (divₕ′ a m) n * suc m + divₕ′ (divₕ′ a m) n * #) mn) lem₁ ⟩
divₕ′ (modₕ′ a m + modₕ′ (divₕ′ a m) n * suc m + divₕ′ (divₕ′ a m) n * suc mn) mn
≡⟨ a<n⇒a+b*n[divₕ]n≡b (modₕ′ a m + modₕ′ (divₕ′ a m) n * suc m) (divₕ′ (divₕ′ a m) n) mn lem₄ ⟩
divₕ 0 n (divₕ′ a m) n
∎
where
open P.≡-Reasoning
mn = m + n + m * n
lem₁ : suc m * suc n ≡ suc mn
lem₁ rewrite +-comm m n | *-comm m (suc n) | *-comm m n | +-assoc n m (n * m) = refl
lem₂ : m + n * suc m ≡ mn
lem₂ rewrite *-comm n (suc m) | +-assoc m n (m * n) = refl
≤₁ = a[modₕ]n<n 0 a m
≤₂ = a[modₕ]n<n 0 (divₕ 0 m a m) n
≤₃ = ≤-refl {suc m}
lem₃ = +-mono-≤ ≤₁ (*-mono-≤ ≤₂ ≤₃)
lem₄ : modₕ′ a m + modₕ′ (divₕ′ a m) n * suc m ≤ mn
lem₄ = subst (λ # → modₕ′ a m + modₕ′ (divₕ′ a m) n * suc m ≤ #) lem₂ lem₃
a*n[divₕ]b*n≡a[divₕ]b : ∀ (a b n : ℕ) → divₕ 0 (b + n + b * n) (a + n * a) (b + n + b * n) ≡ divₕ 0 b a b
a*n[divₕ]b*n≡a[divₕ]b a b n =
begin
divₕ′ na nb
≡⟨ cong (λ # → divₕ′ na #) nb≡bn ⟩
divₕ′ na bn
≡⟨ a[divₕ]m*n≡a[divₕ]m[divₕ]n na n b ⟩
divₕ′ (divₕ′ na n) b
≡⟨ cong (λ # → divₕ′ (divₕ′ # n) b) lem₁ ⟩
divₕ′ (divₕ′ (a * suc n) n) b
≡⟨ cong (λ # → divₕ′ # b) (a*n[divₕ]n≡a 0 a n) ⟩
divₕ 0 b a b
∎
where
open P.≡-Reasoning
na = a + n * a
nb = b + n + b * n
bn = n + b + n * b
nb≡bn : nb ≡ bn
nb≡bn rewrite +-comm n b | *-comm n b = refl
lem₁ : na ≡ a * suc n
lem₁ rewrite *-comm a (suc n) = refl
Now let's look at proof 2. Simply append it to the above code, so that I don't have to repeat the imports:
a*n[divₕ]b*n≡a[divₕ]b′ : ∀ (a b n : ℕ) → divₕ 0 (b + n + b * n) (a + n * a) (b + n + b * n) ≡ divₕ 0 b a b
a*n[divₕ]b*n≡a[divₕ]b′ a b n rewrite +-comm b n | *-comm b n = lem₂ n 0 b a b
where
lem₁ : ∀ (a k m n j : ℕ) → divₕ k m (a + n) (a + j) ≡ divₕ k m n j
lem₁ zero k m n j = refl
lem₁ (suc a) k m n j = lem₁ a k m n j
lem₂ : ∀ (a k m n j : ℕ) → divₕ k (a + m + a * m) (suc a * n) (a + j + a * j) ≡ divₕ k m n j
lem₂ a k m zero j rewrite *-zeroʳ a = refl
lem₂ a k m (suc n) zero
rewrite *-zeroʳ a
| +-identityʳ a
| *-suc a n
| P.sym (+-assoc n a (a * n))
| +-comm n a
| +-assoc a n (a * n)
| P.sym (+-suc a (n + a * n))
| lem₁ a k (a + m + a * m) (suc (n + a * n)) 0
= lem₂ a (suc k) m n m
lem₂ a k m (suc n) (suc j)
rewrite *-suc a n
| P.sym (+-assoc n a (a * n))
| +-comm n a
| +-assoc a n (a * n)
| P.sym (+-suc a (n + a * n))
| +-assoc a (suc j) (a * suc j)
| lem₁ a k (a + m + a * m) (suc (n + a * n)) (suc j + a * suc j)
| *-suc a j
| P.sym (+-assoc j a (a * j))
| +-comm j a
= lem₂ a k m n j
The first lemma is an invariant that says that we can add an identical value a to the last two arguments of div-helper, n and j. It's used by the second lemma, which is the more interesting one.
The second lemma is an invariant that says that you can multiply the last three arguments, m, n, and j, with an identical value a. Its a proof by induction on the last two arguments, n and j. This makes it closely follow the structure of div-helper.
The proof thus covers the same three different cases that show up in the three defining equations of div-helper:
n is zero
n is non-zero, but j is zero
n and j are both non-zero
The property that we're after then follows directly from the second lemma. This is basically the idea outlined in the other response, where the second lemma is the more general version of the property that we're after.
Note that the invariants div-helper respects are spelt out in the builtin file Agda.Builtin.Nat. You should state a more general version of your lemma satisfied by div-helper.
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 ∎
Question
I'm trying to implement a rotate function on Vec, which moves every element n positions to the left, looping around. I could implement that function by using splitAt. Here is a sketch:
open import Data.Nat
open import Data.Nat.DivMod
open import Data.Fin
open import Data.Vec
open import Relation.Nullary.Decidable
open import Relation.Binary.PropositionalEquality
rotateLeft : {A : Set} -> {w : ℕ} -> {w≢0 : False (w ≟ 0)} -> ℕ -> Vec A w -> Vec A w
rotateLeft {A} {w} n vec =
let parts = splitAt (toℕ (n mod w)) {n = ?} vec
in ?
The problem is that splitAt requires two inputs, m and n, such that the size of the vector is m + n. Since the size of the vector here is w, I need to find a k such that k + toℕ (n mod w) = w. I couldn't find any standard function handy for that. What is the best way to proceed?
Some possibilities?
Perhaps it would be helpful if k = n mod w gave me a proof that k < w, that way I could try implementing a function diff : ∀ {k w} -> k < w -> ∃ (λ a : Nat) -> a + k = w. Another possibility would be to just receive a and b as inputs, rather than the bits to shift and size of the vector, but I'm not sure that is the best interface.
Update
I've implemented the following:
add-diff : (a : ℕ) -> (b : Fin (suc a)) -> toℕ b + (a ℕ-ℕ b) ≡ a
add-diff zero zero = refl
add-diff zero (suc ())
add-diff (suc a) zero = refl
add-diff (suc a) (suc b) = cong suc (aaa a b)
Now I just need a proof that ∀ {n m} -> n mod m < m.
Here's what I came up with.
open import Data.Vec
open import Data.Nat
open import Data.Nat.DivMod
open import Data.Fin hiding (_+_)
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Data.Nat.Properties using (+-comm)
difference : ∀ m (n : Fin m) → ∃ λ o → m ≡ toℕ n + o
difference zero ()
difference (suc m) zero = suc m , refl
difference (suc m) (suc n) with difference m n
difference (suc m) (suc n) | o , p1 = o , cong suc p1
rotate-help : ∀ {A : Set} {m} (n : Fin m) → Vec A m → Vec A m
rotate-help {A} {m = m} n vec with difference m n
... | o , p rewrite p with splitAt (toℕ n) vec
... | xs , ys , _ = subst (Vec A) (+-comm o (toℕ n)) (ys ++ xs)
rotate : ∀ {A : Set} {m} (n : ℕ) → Vec A m → Vec A m
rotate {m = zero} n v = v
rotate {m = suc m} n v = rotate-help (n mod suc m) v
After talking with adamse on IRC, I've came up with this:
open import Data.Fin hiding (_+_)
open import Data.Vec
open import Data.Nat
open import Data.Nat.Properties
open import Data.Nat.DivMod
open import Data.Empty
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary.Decidable
diff : {a : ℕ} → {b : Fin a} → ∃ λ c → toℕ b + c ≡ a
diff {zero} {()}
diff {suc a} {zero} = suc a , refl
diff {suc a} {suc b} with diff {a} {b}
... | c , prf = c , cong suc prf
rotateLeft : {A : Set} → {w : ℕ} → {w≢0 : False (w ≟ 0)} → ℕ → Vec A w → Vec A w
rotateLeft {A} {w} {w≢0} n v =
let m = _mod_ n w {w≢0}
d = diff {w} {m}
d₁ = proj₁ d
d₂ = proj₂ d
d₃ = subst (λ x → x ≡ w) (+-comm (toℕ (n mod w)) d₁) d₂
v₁ = subst (λ x → Vec A x) (sym d₂) v
sp = splitAt {A = A} (toℕ m) {n = d₁} v₁
xs = proj₁ (proj₂ sp)
ys = proj₁ sp
in subst (λ x → Vec A x) d₃ (xs ++ ys)
Which is nowhere as elegant as his implementation (partly because I'm still learning Agda's syntax so I opt to just use functions), but works. Now I should return a more refined type, I believe. (Can't thank him enough!)
For your last question to just prove k < w, since k = toℕ (n mod w), you can use bounded from Data.Fin.Properties:
bounded : ∀ {n} (i : Fin n) → toℕ i ℕ< n
I need to define two versions of an operation with a slightly different definition. It is a series of compositions with Nat indices involved.
open import Data.Nat
data Hom : ℕ → ℕ → Set where
id : (m : ℕ) → Hom m m
_∘_ : ∀ {m n k} → Hom n k → Hom m n → Hom m k
p : (n : ℕ) → Hom (suc n) n
p1 : (m n : ℕ) → Hom (m + n) n
p1 zero n = id n
p1 (suc m) n = p1 m n ∘ p (m + n)
p2 : (m n : ℕ) → Hom (m + n) n
p2 zero n = id n
p2 (suc m) n = {!!} -- p n ∘ p2 m (1 + n)
-- Goal: Hom (suc (m + n)) n
-- Have: Hom (m + suc n) n
I would like to define both p1 and p2 and be able to use them interchangeably. Is this doable?
You can define p2 by direct recursion (no subst or rewriting) over _+_ using the trick described here. Looks like this:
record Homable (H : ℕ → ℕ → Set) : Set where
field
id-able : (m : ℕ) → H m m
_∘-able_ : ∀ {m n k} → H n k → H m n → H m k
p-able : (n : ℕ) → H (suc n) n
suc-homable : ∀ {H} → Homable H → Homable (λ m n -> H (suc m) (suc n))
suc-homable homable = record
{ id-able = λ m → id-able (suc m)
; _∘-able_ = _∘-able_
; p-able = λ m → p-able (suc m)
} where open Homable homable
p2-go : ∀ {H} → Homable H → (m : ℕ) → H m 0
p2-go homable zero = id-able 0 where
open Homable homable
p2-go homable (suc m) = p-able 0 ∘-able p2-go (suc-homable homable) m where
open Homable homable
plus-homable-hom : ∀ k → Homable (λ m n → Hom (m + k) (n + k))
plus-homable-hom k = record
{ id-able = λ n → id (n + k)
; _∘-able_ = _∘_
; p-able = λ n → p (n + k)
}
p2 : (m n : ℕ) → Hom (m + n) n
p2 m n = p2-go (plus-homable-hom n) m
The cost is that you need to maintain those Homable records which is somewhat tedious, but to my experience proving things about functions defined this way is simpler than about functions defined in terms of subst or over _+′_ (unless you never want to coerce _+′_ to _+_, of course).
Well, the value you provide has a type that is equal to the type of the hole, but Agda does not see this fact. More formally, the two types are propositionally equal but not judgementally equal. The problem is caused by the index m + suc n, which is propositionally but not judgementally equal to suc m + n because of how addition is defined. One way to solve your problem is to manually explain to Agda that the two types are equal:
open import Data.Nat
open import Data.Nat.Properties
open import Relation.Binary.PropositionalEquality
data Hom : ℕ → ℕ → Set where
id : (m : ℕ) → Hom m m
_∘_ : ∀ {m n k} → Hom n k → Hom m n → Hom m k
p : (n : ℕ) → Hom (suc n) n
p1 : (m n : ℕ) → Hom (m + n) n
p1 zero n = id n
p1 (suc m) n = p1 m n ∘ p (m + n)
p2 : (m n : ℕ) → Hom (m + n) n
p2 zero n = id n
p2 (suc m) n = subst (λ k → Hom k n) (+-suc m n) (p n ∘ p2 m (suc n))
However, this approach is not without downsides, as p2 (suc m) n is now not judgementally equal to your intended definition but to the expression above involving subst.
The problem seems essentially linked to what you're trying to do: IIUC, p1 and p2 are actually provably equal but defined using a different recursion structure. That's fine, but then the indices of your result type should follow the same recursion structure, i.e. you should define p2 using a different version of + that recurses in the appropriate way for p2:
_+′_ : ℕ → ℕ → ℕ
zero +′ n = n
suc m +′ n = m +′ suc n
p2′ : (m n : ℕ) → Hom (m +′ n) n
p2′ zero n = id n
p2′ (suc m) n = p n ∘ p2′ m (suc n)
However, this has another downside that the type of p1 and p2′ are no longer judgementally equal (but still propositionally equal though).
Another thing you can try is to use Agda's rewrite rules to give _+_ satisfy additional judgemental equalities, but this is dangerous as it may break some of Agda's desirable qualities as a logic. In this case, I suspect it's fine, but I'd have to check.
In summary, there are a number of things you can try but none is without downsides. Which is your best option depends on what you're trying to use this for.
I wrote an Agda-function applyPrefix to apply a fixed-size-vector-function to the initial part of a longer vector where the vector-sizes m, n and k may stay implicit. Here's the definition together with a helper-function split:
split : ∀ {A m n} → Vec A (n + m) → (Vec A n) × (Vec A m)
split {_} {_} {zero} xs = ( [] , xs )
split {_} {_} {suc _} (x ∷ xs) with split xs
... | ( ys , zs ) = ( (x ∷ ys) , zs )
applyPrefix : ∀ {A n m k} → (Vec A n → Vec A m) → Vec A (n + k) → Vec A (m + k)
applyPrefix f xs with split xs
... | ( ys , zs ) = f ys ++ zs
I need a symmetric function applyPostfix which applies a fixed-size-vector-function to the tail-part of a longer vector.
applyPostfix ∀ {A n m k} → (Vec A n → Vec A m) → Vec A (k + n) → Vec A (k + m)
applyPostfix {k = k} f xs with split {_} {_} {k} xs
... | ( ys , zs ) = ys ++ (f zs)
As the definition of applyPrefix already shows, the k-Argument cannot stay implicit when applyPostfix is used. For example:
change2 : {A : Set} → Vec A 2 → Vec A 2
change2 ( x ∷ y ∷ [] ) = (y ∷ x ∷ [] )
changeNpre : {A : Set}{n : ℕ} → Vec A (2 + n) → Vec A (2 + n)
changeNpre = applyPrefix change2
changeNpost : {A : Set}{n : ℕ} → Vec A (n + 2) → Vec A (n + 2)
changeNpost = applyPost change2 -- does not work; n has to be provided
Does anyone know a technique, how to implement applyPostfix so that the k-argument may stay implicit when using applyPostfix?
What I did is proofing / programming:
lem-plus-comm : (n m : ℕ) → (n + m) ≡ (m + n)
and use that lemma when defining applyPostfix:
postfixApp2 : ∀ {A}{n m k : ℕ} → (Vec A n → Vec A m) → Vec A (k + n) → Vec A (k + m)
postfixApp2 {A} {n} {m} {k} f xs rewrite lem-plus-comm n k | lem-plus-comm k n | lem-plus-comm k m | lem-plus-comm m k = reverse (drop {n = n} (reverse xs)) ++ f (reverse (take {n = n} (reverse xs)))
Unfortunately, this didnt help, since I use the k-Parameter for calling the lemma :-(
Any better ideas how to avoid k to be explicit? Maybe I should use a snoc-View on Vectors?
What you can do is to give postfixApp2 the same type as applyPrefix.
The source of the problem is that a natural number n can be unified with p + q only if p is known. This is because + is defined via induction on the first argument.
So this one works (I'm using the standard-library version of commutativity on +):
+-comm = comm
where
open IsCommutativeSemiring isCommutativeSemiring
open IsCommutativeMonoid +-isCommutativeMonoid
postfixApp2 : {A : Set} {n m k : ℕ}
→ (Vec A n → Vec A m)
→ Vec A (n + k) → Vec A (m + k)
postfixApp2 {A} {n} {m} {k} f xs rewrite +-comm n k | +-comm m k =
applyPostfix {k = k} f xs
Yes, I'm reusing the original applyPostfix here and just give it a different type by rewriting twice.
And testing:
changeNpost : {A : Set} {n : ℕ} → Vec A (2 + n) → Vec A (2 + n)
changeNpost = postfixApp2 change2
test : changeNpost (1 ∷ 2 ∷ 3 ∷ 4 ∷ []) ≡ 1 ∷ 2 ∷ 4 ∷ 3 ∷ []
test = refl