Skip to content

Instantly share code, notes, and snippets.

@shhyou
Last active August 20, 2023 20:06
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save shhyou/e0f4768bcd7a30dc40534ffa729f657b to your computer and use it in GitHub Desktop.
Save shhyou/e0f4768bcd7a30dc40534ffa729f657b to your computer and use it in GitHub Desktop.

This pull request adds a set of combinators for equational reasoning about vector equality of the form cast eq xs ≡ ys and a few properties demonstrating its application. In particular, the new combinators deal with the threading of index equality proofs, greatly reducing the boilerplate that manipulates casts to make writing equational proofs about vectors more or less feasible.

(Sorry for the piles of PR and the mess of the commit history. I promise this is the last one I have in hand. The first commit is the content of #2041 and #2045. After these two PRs get in, I'll rebase to remove the first commit. To see the code of this PR, please check https://github.com/agda/agda-stdlib/commit/f8971193dce2620cdabf4c7f1d8319c2aa8fb0ed.)

Motivation

Index arithmetic is notably troublesome when it comes to proving vector properties (#942). Existing solutions include stating and proving cast-equality by induction, proving pointwise equality (#1668, #1621), or turning to heterogeneous equality with K. However, sometimes even an inductive proof can benefit from equational reasoning as seen in reverse-++, and that one really wants to convert back to propositional equality at the end to facilitate type casting. Therefore, the goal of this PR is to design a set of combinators that interoperates with _≡_ while reducing explicit index castings in the proofs to an tolerable level.

@JacquesCarette pointed me to @Taneb's nice PR on displayed categories and equational reasoning over some base equality in agda/agda-categories#382. It seems to me that the core combinators in this PR can be seen as a instance of displayed setoid, but I am not sure if I understand it correctly.

Standard combinators

In this PR, the new combinators directly operate on equality of the form cast eq xs ≡ ys. Fortunately, this type of equality is 'reflexive', 'symmetric' and 'transitive', therefore cast eq xs ≡ ys admits the standard equational reasoning combinators. The combinators can hide casts in the terms from the user to reduce redundancy. Index equality is inferred from the proof in each step and automatically threaded throughout the process. In addition, since the underlying type is just cast eq xs ≡ ys, the combinators automatically work with _≡_.

Let xs ≈[ n≡m ] ys denote cast n≡m xs ≡ ys, the standard combinators are:

begin_ :  .{m≡n} {xs : Vec A m} {ys}  xs ≈[ m≡n ] ys  cast m≡n xs ≡ ys
begin xs≈ys = xs≈ys

_∎ :  xs  cast refl xs ≡ xs
_∎ xs = ≈-reflexive refl

step-≈ :  .{m≡n} .{m≡o} (xs : Vec A m) {ys zs} 
         (ys ≈[ trans (sym m≡n) m≡o ] zs)  (xs ≈[ m≡n ] ys)  (xs ≈[ m≡o ] zs)
step-≈ xs ys≈zs xs≈ys = ≈-trans xs≈ys ys≈zs

syntax step-≈  xs ys≈zs xs≈ys  = xs ≈⟨  xs≈ys ⟩ ys≈zs

Example

As an example, the PR proves the property ∷-ʳ++ : cast eq ((a ∷ xs) ʳ++ ys) ≡ xs ʳ++ (a ∷ ys). The third step in the proof changes the index from (suc m) + n to m + suc n, so in principle the first two steps are implicitly wrapped in a cast. The other steps do not change the index, so they use the operator xs ≂⟨ xs≡ys ⟩ ys≈zs to inject ordinary propositional equality _≡_ into _≈[_]_.

{-
  unfold-ʳ++  : xs ʳ++ ys ≡ reverse xs ++ ys
  reverse-∷  : reverse (x ∷ xs) ≡ reverse xs ∷ʳ x
  ∷ʳ-++      : cast eq ((xs ∷ʳ a) ++ ys) ≡ xs ++ (a ∷ ys)
-}

∷-ʳ++ :  .(eq : (suc m) + n ≡ m + suc n) a (xs : Vec A m) {ys} 
        cast eq ((a ∷ xs) ʳ++ ys) ≡ xs ʳ++ (a ∷ ys)
∷-ʳ++ eq a xs {ys} = begin
  (a ∷ xs) ʳ++ ys         ≂⟨ unfold-ʳ++ (a ∷ xs) ys ⟩
  reverse (a ∷ xs) ++ ys  ≂⟨ cong (_++ ys) (reverse-∷ a xs) ⟩
  (reverse xs ∷ʳ a) ++ ys ≈⟨ ∷ʳ-++ eq a (reverse xs) ⟩
  reverse xs ++ (a ∷ ys)  ≂˘⟨ unfold-ʳ++ xs (a ∷ ys) ⟩
  xs ʳ++ (a ∷ ys)         ∎

Additional combinators

Very often casts occur deep inside a term instead of at the outermost position. It then become necessary to cong over existing proofs for better reuse (or just to apply the induction hypothesis). Nonetheless, pushing casts into the term also takes one equational reasoning step, so the PR provides xs≈fys ≈cong[ f ] ys≈zs to push the cast inside and conging f, producing xs≈fzs.

For example, consider the proof of cast eq (reverse ((xs ∷ʳ a) ++ ys)) ≡ reverse ((xs ++ [ a ]) ++ ys) that re-uses unfold-∷ʳ from the standard library. In order to apply unfold-∷ʳ, the proof must first push cast into reverse and then push the inner cast into (_++ ys). Therefore we chain two ≈congs together:

{-
  cast-++ˡ   : cast ... (xs ++ ys) ≡ cast eq xs ++ ys
  unfold-∷ʳ : cast eq (xs ∷ʳ x) ≡ xs ++ [ x ]
-}

example :  .eq a xs ys  cast eq (reverse ((xs ∷ʳ a) ++ ys)) ≡ reverse ((xs ++ [ a ]) ++ ys)
example {m = m} {n} eq a xs ys = begin
  reverse ((xs ∷ʳ a) ++ ys)     ≈⟨ cast-reverse (cong (_+ n) (+-comm 1 m)) ((xs ∷ʳ a) ++ ys)
                                   ≈cong[ reverse ] cast-++ˡ (+-comm 1 m) (xs ∷ʳ a)
                                                    ≈cong[ (_++ ys) ] unfold-∷ʳ _ a xs ⟩
  reverse ((xs ++ [ a ]) ++ ys) ∎

To interoperate with _≡_, the PR includes two more operators for injecting _≡_ into _≈[_]_ and escaping _≈[_]_ back to _≡_. That is, the cast equational reasoning can stop at any point using xs ≃⟨ xs≈ys ⟩ ys≡zs and switch back to plain equational reasoning. However, from the proofs in this PR, xs ≂⟨ xs≡ys ⟩ ys≈zs is commonly used but xs ≃⟨ xs≈ys ⟩ ys≡zs isn't, assuming the availability of xs≈fys ≈cong[ f ] ys≈zs.

-- composition of the equality type on the right-hand side of _≈[_]_, or escaping to ordinary _≡_
step-≃ :  xs  (ys ≡ zs)  (xs ≈[ m≡n ] ys)  (xs ≈[ m≡n ] zs)
step-≃ xs ys≡zs xs≈ys = ≈-trans xs≈ys (≈-reflexive ys≡zs)
syntax step-≃  xs ys≡zs xs≈ys  = xs ≃⟨  xs≈ys ⟩ ys≡zs

-- composition of the equality type on the left-hand side of _≈[_]_
step-≂ :  xs  (ys ≈[ m≡n ] zs)  (xs ≡ ys)  (xs ≈[ m≡n ] zs)
step-≂ xs ys≈zs xs≡ys = ≈-trans (≈-reflexive xs≡ys) ys≈zs
syntax step-≂  xs ys≈zs xs≡ys  = xs ≂⟨  xs≡ys ⟩ ys≈zs

Comparison

In principle, cast proofs can be written directly without using the combinators in this PR. Sadly, the chaining of the proofs of indices quickly become tedious to the degree of unmanageable. Here are two examples comparing proofs using the new combinators versus the proofs in #2045. It would be even annoying to prove fromList-reverse,

fromList-reverse : cast ... (fromList (List.reverse xs)) ≡ reverse (fromList xs)

since the proof necessarily involves List equational reasoning that ended up changing the index at every step.

(https://github.com/agda/agda-stdlib/commit/f8971193dce2620cdabf4c7f1d8319c2aa8fb0ed#diff-8e6f618f4d6093cefbe779df9d3964ca20710e5dc33da8596c22da33d761eccdR1033-R1043)

 cast-reverse : ∀ .(eq : m ≡ n) → cast eq ∘ reverse {A = A} {n = m} ≗ reverse ∘ cast eq
 cast-reverse {n = zero}  eq []       = refl
-cast-reverse {n = suc n} eq (x ∷ xs) = begin
-  cast eq (reverse (x ∷ xs))              ≡⟨ cong (cast eq) (reverse-∷ x xs) ⟩
-  cast eq (reverse xs ∷ʳ x)               ≡⟨ cast-∷ʳ eq x (reverse xs) ⟩
-  (cast (cong pred eq) (reverse xs)) ∷ʳ x ≡⟨ cong (_∷ʳ x) (cast-reverse (cong pred eq) xs) ⟩
-  (reverse (cast (cong pred eq) xs)) ∷ʳ x ≡˘⟨ reverse-∷ x (cast (cong pred eq) xs) ⟩
-  reverse (x ∷ cast (cong pred eq) xs)    ≡⟨⟩
-  reverse (cast eq (x ∷ xs))              ∎
+cast-reverse {n = suc n} eq (x ∷ xs) = begin′
+  reverse (x ∷ xs)           ≂⟨ reverse-∷ x xs ⟩
+  reverse xs ∷ʳ x            ≈⟨ cast-∷ʳ eq x (reverse xs)
+                                ≈cong[ (_∷ʳ x) ] cast-reverse (cong pred eq) xs ⟩
+  reverse (cast _ xs) ∷ʳ x   ≂˘⟨ reverse-∷ x (cast (cong pred eq) xs) ⟩
+  reverse (x ∷ cast _ xs)    ≈⟨⟩
+  reverse (cast eq (x ∷ xs)) ∎′
 reverse-++ : ∀ .(eq : m + n ≡ n + m) (xs : Vec A m) (ys : Vec A n) →
              cast eq (reverse (xs ++ ys)) ≡ reverse ys ++ reverse xs
-reverse-++ {m = zero}  {n = n} eq []       ys = begin
-  cast _ (reverse ys)                ≡˘⟨ cong (cast eq) (++-identityʳ (sym eq) (reverse ys)) ⟩
-  cast _ (cast _ (reverse ys ++ [])) ≡⟨ cast-trans (sym eq) eq (reverse ys ++ []) ⟩
-  cast _ (reverse ys ++ [])          ≡⟨ cast-is-id (trans (sym eq) eq) (reverse ys ++ []) ⟩
-  reverse ys ++ []                   ≡⟨⟩
-  reverse ys ++ reverse []           ∎
+reverse-++ {m = zero}  {n = n} eq []       ys = ≈-sym (++-identityʳ (sym eq) (reverse ys))
-reverse-++ {m = suc m} {n = n} eq (x ∷ xs) ys = begin
-  cast eq (reverse (x ∷ xs ++ ys))                ≡⟨ cong (cast eq) (reverse-∷ x (xs ++ ys)) ⟩
-  cast eq (reverse (xs ++ ys) ∷ʳ x)               ≡˘⟨ cast-trans eq₂ eq₁ (reverse (xs ++ ys) ∷ʳ x) ⟩
-  (cast eq₁ ∘ cast eq₂) (reverse (xs ++ ys) ∷ʳ x)  ≡⟨ cong (cast eq₁) (cast-∷ʳ _ x (reverse (xs ++ ys))) ⟩
-  cast eq₁ ((cast eq₃ (reverse (xs ++ ys))) ∷ʳ x)  ≡⟨ cong (cast eq₁) (cong (_∷ʳ x) (reverse-++ _ xs ys)) ⟩
-  cast eq₁ ((reverse ys ++ reverse xs)      ∷ʳ x) ≡⟨ ++-∷ʳ _ x (reverse ys) (reverse xs) ⟩
-  reverse ys ++ (reverse xs ∷ʳ x)                 ≡˘⟨ cong (reverse ys ++_) (reverse-∷ x xs) ⟩
-  reverse ys ++ (reverse (x ∷ xs))                ∎
-  where
-  eq₁ = sym (+-suc n m)
-  eq₂ = cong suc (+-comm m n)
-  eq₃ = cong pred eq₂
+reverse-++ {m = suc m} {n = n} eq (x ∷ xs) ys = begin′
+  reverse (x ∷ xs ++ ys)              ≂⟨ reverse-∷ x (xs ++ ys) ⟩
+  reverse (xs ++ ys) ∷ʳ x             ≈⟨ cast-∷ʳ (cong suc (+-comm m n)) x (reverse (xs ++ ys))
+                                         ≈cong[ (_∷ʳ x) ] reverse-++ _ xs ys ⟩
+  (reverse ys ++ reverse xs) ∷ʳ x     ≈⟨ ++-∷ʳ (sym (+-suc n m)) x (reverse ys) (reverse xs) ⟩
+  reverse ys ++ (reverse xs ∷ʳ x)     ≂˘⟨ cong (reverse ys ++_) (reverse-∷ x xs) ⟩
+  reverse ys ++ (reverse (x ∷ xs))    ∎′

Limitation

Here are some limitations I found while proving properties in this PR using the proposed combinators.

  1. The combinators heavily expects other lemmas to be properly shaped in the form of case eq xs ≡ ys. This is not surprising, but requires some sort of convention.

  2. The combinators don't help with more primitive lemmas that have to be proved directly using fold fusion. In other words, without the more fundamentals lemmas like reverse-∷, unfold-ʳ++ etc, the combinators probably can't prove anything. Thanks to @jamesmckinna for porting the reverse lemmas for vectors!

  3. An equational reasoning step xs ≈⟨ xs≈ys ⟩ ys≈zs obtains the underlying eq of cast from the result type and from the proof xs≈ys. Therefore, in the middle of an equational proof, the underlying eq will become an unsolved metavariable.

    pf : cast eq xs ≡ ys
    pf = begin
      xs ≈⟨ xs≈zs ⟩
      zs ≈⟨ {! !}-- this step introduces an unsolved metavariable until it's filled in
      ys ∎
{-# OPTIONS --without-K --safe #-}
module VecCastReason where
open import Data.Nat.Base
open import Data.Nat.Properties using (+-comm; +-suc; +-assoc)
open import Data.List.Base as List using (List; []; _∷_)
import Data.List.Properties as Listₚ
open import Data.Vec.Base
open import Data.Vec.Properties hiding (reverse-++; cast-reverse)
open import Function.Base using (_∘_; id; flip)
open import Relation.Binary.Core using (REL)
open import Relation.Binary.Definitions using (Sym; Trans)
open import Relation.Binary.PropositionalEquality as PropEq
using (_≡_; _≗_; refl; sym; trans; cong; subst; dsubst₂; module ≡-Reasoning)
open ≡-Reasoning using (begin_; _∎; step-≡; step-≡˘; _≡⟨⟩_)
open Agda.Primitive using (Level)
variable
a : Level
A : Set a
n m o p q : ℕ
xs ys zs ws : Vec A n
≈-by : .(eq : n ≡ m) → REL (Vec A n) (Vec A m) _
≈-by eq xs ys = cast eq xs ≡ ys
infix 5 ≈-by
syntax ≈-by n≡m xs ys = xs ≈[ n≡m ] ys
----------------------------------------------------------------
-- ≈-by is ‘reflexive’, ‘symmetric’ and ‘transitive’
≈-refl : {xs : Vec A n} → xs ≈[ refl ] xs
≈-refl {xs = xs} = cast-is-id refl xs
≈-sym : ∀ {a} {A : Set a} .{eq : n ≡ m} →
Sym (≈-by {A = A} eq) (≈-by (sym eq))
≈-sym {eq = eq} {xs} {ys} xs≈ys = begin
cast (sym eq) ys ≡˘⟨ cong (cast (sym eq)) xs≈ys ⟩
cast (sym eq) (cast eq xs) ≡⟨ cast-trans eq (sym eq) xs ⟩
cast (trans eq (sym eq)) xs ≡⟨ cast-is-id (trans eq (sym eq)) xs ⟩
xs ∎
≈-trans : ∀ {a} {A : Set a} .{eq₁ : n ≡ m} .{eq₂ : m ≡ o} →
Trans (≈-by {A = A} eq₁) (≈-by eq₂) (≈-by (trans eq₁ eq₂))
≈-trans {eq₁ = eq₁} {eq₂} {xs} {ys} {zs} xs≈ys ys≈zs = begin
cast (trans eq₁ eq₂) xs ≡˘⟨ cast-trans eq₁ eq₂ xs ⟩
cast eq₂ (cast eq₁ xs) ≡⟨ cong (cast eq₂) xs≈ys ⟩
cast eq₂ ys ≡⟨ ys≈zs ⟩
zs ∎
----------------------------------------------------------------
-- convenient syntax for ‘equational’ reasoning
infix 1 begin≈_
infixr 2 step-≡ʳ step-≡ˡ step-≡ʳ˘ step-≡ˡ˘ step-≈ step-≈˘ _≈⟨⟩_ ≈-cong
infix 3 _≈∎
begin≈_ : ∀ .{n≡m : n ≡ m} {xs : Vec A n} {ys : Vec A m} →
xs ≈[ n≡m ] ys →
cast n≡m xs ≡ ys
begin≈ xs≈ys = xs≈ys
_≈∎ : (xs : Vec A n) → cast refl xs ≡ xs
_≈∎ xs = cast-is-id refl xs
step-≡ʳ : ∀ .{n≡m : n ≡ m} (xs : Vec A n) {ys zs : Vec A m} →
ys ≡ zs →
xs ≈[ n≡m ] ys →
xs ≈[ n≡m ] zs
step-≡ʳ xs ys≡zs xs≈ys = trans xs≈ys ys≡zs
step-≡ˡ : ∀ .{n≡m : n ≡ m} (xs {ys} : Vec A n) {zs : Vec A m} →
ys ≈[ n≡m ] zs →
xs ≡ ys →
xs ≈[ n≡m ] zs
step-≡ˡ {n≡m = n≡m} xs ys≈zs xs≡ys = trans (cong (cast n≡m) xs≡ys) ys≈zs
step-≡ʳ˘ : ∀ .{n≡m : n ≡ m} (xs : Vec A n) {ys zs : Vec A m} →
ys ≡ zs →
ys ≈[ (sym n≡m) ] xs →
xs ≈[ n≡m ] zs
step-≡ʳ˘ xs ys≡zs ys≈xs = trans (≈-sym ys≈xs) ys≡zs
step-≡ˡ˘ : ∀ .{n≡m : n ≡ m} (xs {ys} : Vec A n) {zs : Vec A m} →
ys ≈[ n≡m ] zs →
ys ≡ xs →
xs ≈[ n≡m ] zs
step-≡ˡ˘ xs ys≈zs ys≡xs = step-≡ˡ xs ys≈zs (sym ys≡xs)
step-≈ : ∀ .{n≡o : n ≡ o} .{n≡m : n ≡ m} (xs : Vec A n) {ys : Vec A m} {zs : Vec A o} →
ys ≈[ trans (sym n≡m) n≡o ] zs →
xs ≈[ n≡m ] ys →
xs ≈[ n≡o ] zs
step-≈ xs ys≈zs xs≈ys = ≈-trans xs≈ys ys≈zs
step-≈˘ : ∀ .{n≡o : n ≡ o} .{m≡n : m ≡ n} (xs : Vec A n) {ys : Vec A m} {zs : Vec A o} →
ys ≈[ trans m≡n n≡o ] zs →
ys ≈[ m≡n ] xs →
xs ≈[ n≡o ] zs
step-≈˘ xs ys≈zs ys≈xs = step-≈ xs ys≈zs (≈-sym ys≈xs)
_≈⟨⟩_ : ∀ .{m≡n : m ≡ n} (xs : Vec A m) {ys : Vec A n} →
xs ≈[ m≡n ] ys →
xs ≈[ m≡n ] ys
xs ≈⟨⟩ xs≈ys = xs≈ys
≈-cong : ∀ .{o≡p : o ≡ p} .{m≡n : m ≡ n} {xs : Vec A o} {ys} {zs} →
(f : Vec A n → Vec A p) →
xs ≈[ o≡p ] f (cast m≡n ys) →
ys ≈[ m≡n ] zs →
xs ≈[ o≡p ] f zs
≈-cong {o≡p = o≡p} f xs≈fys ys≈zs = trans xs≈fys (cong f ys≈zs)
syntax step-≡ʳ xs ys≡zs xs≈ys = xs ≡ʳ⟨ xs≈ys ⟩ ys≡zs
syntax step-≡ʳ˘ xs ys≡zs xs≈ys = xs ≡ʳ˘⟨ xs≈ys ⟩ ys≡zs
syntax step-≡ˡ xs ys≈zs xs≡ys = xs ≡ˡ⟨ xs≡ys ⟩ ys≈zs
syntax step-≡ˡ˘ xs ys≈zs ys≡xs = xs ≡ˡ˘⟨ ys≡xs ⟩ ys≈zs
syntax step-≈ xs ys≈zs xs≈ys = xs ≈⟨ xs≈ys ⟩ ys≈zs
syntax step-≈˘ xs ys≈zs ys≈xs = xs ≈˘⟨ ys≈xs ⟩ ys≈zs
syntax ≈-cong f xs≈fys ys≈zs = xs≈fys ≈cong f ⟨ ys≈zs ⟩
∷ʳ-++ : ∀ .(eq : (suc n) + m ≡ n + suc m) a (xs : Vec A n) {ys} →
cast eq ((xs ∷ʳ a) ++ ys) ≡ xs ++ (a ∷ ys)
∷ʳ-++ eq a [] {ys} = cong (a ∷_) (cast-is-id (cong pred eq) ys)
∷ʳ-++ eq a (y ∷ xs) {ys} = cong (y ∷_) (∷ʳ-++ (cong pred eq) a xs)
cast-++ˡ : ∀ .(eq : n ≡ o) (xs : Vec A n) {ys : Vec A m} →
cast (cong (_+ m) eq) (xs ++ ys) ≡ cast eq xs ++ ys
cast-++ˡ {o = zero} eq [] {ys} = cast-is-id refl (cast eq [] ++ ys)
cast-++ˡ {o = suc o} eq (x ∷ xs) {ys} = cong (x ∷_) (cast-++ˡ (cong pred eq) xs)
cast-++ʳ : ∀ .(eq : m ≡ o) (xs : Vec A n) {ys : Vec A m} →
cast (cong (n +_) eq) (xs ++ ys) ≡ xs ++ cast eq ys
cast-++ʳ {n = zero} eq [] {ys} = refl
cast-++ʳ {n = suc n} eq (x ∷ xs) {ys} = cong (x ∷_) (cast-++ʳ eq xs)
fromList-reverse : (xs : List A) → cast (Listₚ.length-reverse xs) (fromList (List.reverse xs)) ≡ reverse (fromList xs)
fromList-reverse List.[] = refl
fromList-reverse (x List.∷ xs) = begin≈
fromList (List.reverse (x List.∷ xs)) ≈⟨ cast-fromList (Listₚ.ʳ++-defn xs {List.[ x ]}) ⟩
fromList (List.reverse xs List.++ List.[ x ]) ≈⟨ fromList-++ (List.reverse xs) {List.[ x ]} ⟩
fromList (List.reverse xs) ++ [ x ] ≈˘⟨ unfold-∷ʳ (+-comm 1 _) x vec-of-rev-xs ⟩
fromList (List.reverse xs) ∷ʳ x ≡ʳ⟨ cast-∷ʳ (cong suc (Listₚ.length-reverse xs)) x vec-of-rev-xs ⟩
cast _ (fromList (List.reverse xs)) ∷ʳ x ≡⟨ cong (_∷ʳ x) (fromList-reverse xs) ⟩
reverse (fromList xs) ∷ʳ x ≡˘⟨ reverse-∷ x (fromList xs) ⟩
reverse (x ∷ fromList xs) ≡⟨⟩
reverse (fromList (x List.∷ xs)) ∎
where vec-of-rev-xs = fromList (List.reverse xs)
fromList-reverse-alt : (xs : List A) → cast (Listₚ.length-reverse xs) (fromList (List.reverse xs)) ≡ reverse (fromList xs)
fromList-reverse-alt List.[] = refl
fromList-reverse-alt (x List.∷ xs) = fromList (List.reverse (x List.∷ xs)) ≈⟨ cast-fromList (Listₚ.ʳ++-defn xs {List.[ x ]}) ⟩
fromList (List.reverse xs List.++ List.[ x ]) ≈⟨ fromList-++ (List.reverse xs) {List.[ x ]} ⟩
fromList (List.reverse xs) ++ [ x ] ≈˘⟨ unfold-∷ʳ (+-comm 1 _) x (fromList (List.reverse xs)) ⟩
fromList (List.reverse xs) ∷ʳ x ≈⟨ cast-∷ʳ (cong suc (Listₚ.length-reverse xs)) _ _
≈cong (_∷ʳ x) ⟨ fromList-reverse-alt xs ⟩ ⟩
reverse (fromList xs) ∷ʳ x ≡ˡ˘⟨ reverse-∷ x (fromList xs) ⟩
reverse (x ∷ fromList xs) ≈⟨⟩
reverse (fromList (x List.∷ xs)) ≈∎
ʳ++-∷ : ∀ .(eq : (suc n) + m ≡ n + suc m) x (xs : Vec A n) {ys} →
cast eq ((x ∷ xs) ʳ++ ys) ≡ xs ʳ++ (x ∷ ys)
ʳ++-∷ eq x xs {ys} = begin≈
(x ∷ xs) ʳ++ ys ≡ˡ⟨ unfold-ʳ++ (x ∷ xs) ys ⟩
reverse (x ∷ xs) ++ ys ≡ˡ⟨ cong (_++ ys) (reverse-∷ x xs) ⟩
(reverse xs ∷ʳ x) ++ ys ≡ʳ⟨ ∷ʳ-++ eq x (reverse xs) ⟩
reverse xs ++ (x ∷ ys) ≡˘⟨ unfold-ʳ++ xs (x ∷ ys) ⟩
xs ʳ++ (x ∷ ys) ∎
ʳ++-∷-alt : ∀ .(eq : (suc n) + m ≡ n + suc m) x (xs : Vec A n) {ys} →
cast eq ((x ∷ xs) ʳ++ ys) ≡ xs ʳ++ (x ∷ ys)
ʳ++-∷-alt eq x xs {ys} = begin≈
(x ∷ xs) ʳ++ ys ≡ˡ⟨ unfold-ʳ++ (x ∷ xs) ys ⟩
reverse (x ∷ xs) ++ ys ≡ˡ⟨ cong (_++ ys) (reverse-∷ x xs) ⟩
(reverse xs ∷ʳ x) ++ ys ≈⟨ ∷ʳ-++ eq x (reverse xs) ⟩
reverse xs ++ (x ∷ ys) ≡ˡ˘⟨ unfold-ʳ++ xs (x ∷ ys) ⟩
xs ʳ++ (x ∷ ys) ≈∎
ʳ++-++ : ∀ .(eq : n + m + o ≡ m + (n + o)) (xs : Vec A n) {ys : Vec A m} {zs : Vec A o} →
cast eq ((xs ++ ys) ʳ++ zs) ≡ ys ʳ++ (xs ʳ++ zs)
ʳ++-++ {n = zero} {m} {o} eq [] {ys} {zs} = cast-is-id eq (([] ++ ys) ʳ++ zs)
ʳ++-++ {n = suc n} {m} {o} eq (x ∷ xs) {ys} {zs} = begin≈
(x ∷ xs ++ ys) ʳ++ zs ≈⟨ ʳ++-∷ (sym (+-suc (n + m) o)) x (xs ++ ys) ⟩
(xs ++ ys) ʳ++ (x ∷ zs) ≈⟨ ʳ++-++ (eq-induction-step eq) xs ⟩
ys ʳ++ (xs ʳ++ (x ∷ zs)) ≡ˡ⟨ unfold-ʳ++ ys (xs ʳ++ (x ∷ zs)) ⟩
reverse ys ++ (xs ʳ++ (x ∷ zs)) ≡ʳ⟨ cast-++ʳ (+-suc n o) (reverse ys) ⟩
reverse ys ++ cast _ (xs ʳ++ (x ∷ zs)) ≡⟨ cong (reverse ys ++_) (≈-sym (ʳ++-∷ (sym (+-suc n o)) x xs)) ⟩
reverse ys ++ ((x ∷ xs) ʳ++ zs) ≡˘⟨ unfold-ʳ++ ys ((x ∷ xs) ʳ++ zs) ⟩
ys ʳ++ ((x ∷ xs) ʳ++ zs) ∎
where
eq-induction-step : (suc n + m + o ≡ m + (suc n + o)) → ((n + m) + suc o ≡ m + (n + suc o))
eq-induction-step eq = begin
n + m + suc o ≡⟨ +-suc (n + m) o ⟩
suc (n + m + o) ≡⟨ eq ⟩
m + suc (n + o) ≡˘⟨ cong (m +_) (+-suc n o) ⟩
m + (n + suc o) ∎
ʳ++-++-alt : ∀ .(eq : n + m + o ≡ m + (n + o)) (xs : Vec A n) {ys : Vec A m} {zs : Vec A o} →
cast eq ((xs ++ ys) ʳ++ zs) ≡ ys ʳ++ (xs ʳ++ zs)
ʳ++-++-alt {n = zero} {m} {o} eq [] {ys} {zs} = cast-is-id eq (([] ++ ys) ʳ++ zs)
ʳ++-++-alt {n = suc n} {m} {o} eq (x ∷ xs) {ys} {zs} = begin≈
(x ∷ xs ++ ys) ʳ++ zs ≈⟨ ʳ++-∷ (sym (+-suc (n + m) o)) x (xs ++ ys) ⟩
(xs ++ ys) ʳ++ (x ∷ zs) ≈⟨ ʳ++-++-alt (eq-induction-step eq) xs ⟩
ys ʳ++ (xs ʳ++ (x ∷ zs)) ≡ˡ⟨ unfold-ʳ++ ys (xs ʳ++ (x ∷ zs)) ⟩
reverse ys ++ (xs ʳ++ (x ∷ zs)) ≈˘⟨ cast-++ʳ (sym (+-suc n o)) (reverse ys)
≈cong (reverse ys ++_) ⟨ ʳ++-∷ (sym (+-suc n o)) x xs ⟩ ⟩
reverse ys ++ ((x ∷ xs) ʳ++ zs) ≡ˡ˘⟨ unfold-ʳ++ ys ((x ∷ xs) ʳ++ zs) ⟩
ys ʳ++ ((x ∷ xs) ʳ++ zs) ≈∎
where
eq-induction-step : (suc n + m + o ≡ m + (suc n + o)) → ((n + m) + suc o ≡ m + (n + suc o))
eq-induction-step eq = begin
n + m + suc o ≡⟨ +-suc (n + m) o ⟩
suc (n + m + o) ≡⟨ eq ⟩
m + suc (n + o) ≡˘⟨ cong (m +_) (+-suc n o) ⟩
m + (n + suc o) ∎
-- uses ʳ++-++
reverse-++-another : ∀ .(eq : n + m ≡ m + n) (xs : Vec A n) (ys : Vec A m) →
cast eq (reverse (xs ++ ys)) ≡ reverse ys ++ reverse xs
reverse-++-another {n = n} {m} eq xs ys = begin≈
reverse (xs ++ ys) ≈˘⟨ ++-identityʳ (+-comm (n + m) 0) (reverse (xs ++ ys)) ⟩
reverse (xs ++ ys) ++ [] ≡ˡ˘⟨ unfold-ʳ++ (xs ++ ys) [] ⟩
(xs ++ ys) ʳ++ [] ≈⟨ ʳ++-++ (trans (cong (_+ 0) (+-comm n m)) (+-assoc m n zero)) xs ⟩
ys ʳ++ (xs ʳ++ []) ≡ˡ⟨ cong (ys ʳ++_) (unfold-ʳ++ xs []) ⟩
ys ʳ++ (reverse xs ++ []) ≡ˡ⟨ unfold-ʳ++ ys (reverse xs ++ []) ⟩
reverse ys ++ (reverse xs ++ []) ≡ʳ⟨ cast-++ʳ (+-comm n 0) (reverse ys) ⟩
reverse ys ++ cast _ (reverse xs ++ []) ≡˘⟨ unfold-ʳ++ ys (cast _ (reverse xs ++ [])) ⟩
ys ʳ++ cast _ (reverse xs ++ []) ≡⟨ cong (ys ʳ++_) (++-identityʳ (+-comm n 0) (reverse xs)) ⟩
ys ʳ++ reverse xs ≡⟨ unfold-ʳ++ ys (reverse xs) ⟩
reverse ys ++ reverse xs ∎
-- uses ʳ++-++
reverse-++-another-alt : ∀ .(eq : n + m ≡ m + n) (xs : Vec A n) (ys : Vec A m) →
cast eq (reverse (xs ++ ys)) ≡ reverse ys ++ reverse xs
reverse-++-another-alt {n = n} {m} eq xs ys = begin≈
reverse (xs ++ ys) ≈˘⟨ ++-identityʳ (+-comm (n + m) 0) (reverse (xs ++ ys)) ⟩
reverse (xs ++ ys) ++ [] ≡ˡ˘⟨ unfold-ʳ++ (xs ++ ys) [] ⟩
(xs ++ ys) ʳ++ [] ≈⟨ ʳ++-++ (trans (cong (_+ 0) (+-comm n m)) (+-assoc m n zero)) xs ⟩
ys ʳ++ (xs ʳ++ []) ≡ˡ⟨ cong (ys ʳ++_) (unfold-ʳ++ xs []) ⟩
ys ʳ++ (reverse xs ++ []) ≡ˡ⟨ unfold-ʳ++ ys (reverse xs ++ []) ⟩
reverse ys ++ (reverse xs ++ []) ≈⟨ cast-++ʳ (+-comm n 0) (reverse ys)
≈cong (reverse ys ++_) ⟨ ++-identityʳ (+-comm n 0) (reverse xs) ⟩ ⟩
reverse ys ++ reverse xs ≈∎
reverse-++ : ∀ .(eq : n + m ≡ m + n) (xs : Vec A n) (ys : Vec A m) →
cast eq (reverse (xs ++ ys)) ≡ reverse ys ++ reverse xs
reverse-++ {n = zero} {m = m} eq [] ys = ≈-sym (++-identityʳ (+-comm m 0) (reverse ys))
reverse-++ {n = suc n} {m = m} eq (x ∷ xs) ys = begin≈
reverse (x ∷ xs ++ ys) ≡ˡ⟨ reverse-∷ x (xs ++ ys) ⟩
reverse (xs ++ ys) ∷ʳ x ≈⟨ cast-∷ʳ (cong suc (+-comm n m)) x (reverse (xs ++ ys)) ⟩
(cast _ (reverse (xs ++ ys))) ∷ʳ x ≡ˡ⟨ cong (_∷ʳ x) (reverse-++ _ xs ys) ⟩
(reverse ys ++ reverse xs) ∷ʳ x ≡ʳ⟨ ++-∷ʳ _ x (reverse ys) (reverse xs) ⟩
reverse ys ++ (reverse xs ∷ʳ x) ≡˘⟨ cong (reverse ys ++_) (reverse-∷ x xs) ⟩
reverse ys ++ (reverse (x ∷ xs)) ∎
reverse-++-alt : ∀ .(eq : n + m ≡ m + n) (xs : Vec A n) (ys : Vec A m) →
cast eq (reverse (xs ++ ys)) ≡ reverse ys ++ reverse xs
reverse-++-alt {n = zero} {m = m} eq [] ys = ≈-sym (++-identityʳ (+-comm m 0) (reverse ys))
reverse-++-alt {n = suc n} {m = m} eq (x ∷ xs) ys = begin≈
reverse (x ∷ xs ++ ys) ≡ˡ⟨ reverse-∷ x (xs ++ ys) ⟩
reverse (xs ++ ys) ∷ʳ x ≈⟨ cast-∷ʳ (cong suc (+-comm n m)) x (reverse (xs ++ ys))
≈cong (_∷ʳ x) ⟨ reverse-++-alt _ xs ys ⟩ ⟩
(reverse ys ++ reverse xs) ∷ʳ x ≈⟨ ++-∷ʳ (sym (+-suc m n)) x (reverse ys) (reverse xs) ⟩
reverse ys ++ (reverse xs ∷ʳ x) ≡ˡ˘⟨ cong (reverse ys ++_) (reverse-∷ x xs) ⟩
reverse ys ++ (reverse (x ∷ xs)) ≈∎
-- uses reverse-++
ʳ++-++-another : ∀ .(eq : n + m + o ≡ m + (n + o)) (xs : Vec A n) {ys : Vec A m} {zs : Vec A o} →
cast eq ((xs ++ ys) ʳ++ zs) ≡ ys ʳ++ (xs ʳ++ zs)
ʳ++-++-another {n = n} {m} {o} eq xs {ys} {zs} = begin≈
((xs ++ ys) ʳ++ zs) ≡ˡ⟨ unfold-ʳ++ (xs ++ ys) zs ⟩
reverse (xs ++ ys) ++ zs ≈⟨ eq-cong-rev-++ ⟩
(reverse ys ++ reverse xs) ++ zs ≡ʳ⟨ ++-assoc (trans (cong (_+ o) (+-comm m n)) eq) (reverse ys) (reverse xs) zs ⟩
reverse ys ++ (reverse xs ++ zs) ≡˘⟨ cong (reverse ys ++_) (unfold-ʳ++ xs zs) ⟩
reverse ys ++ (xs ʳ++ zs) ≡˘⟨ unfold-ʳ++ ys (xs ʳ++ zs) ⟩
ys ʳ++ (xs ʳ++ zs) ∎
where
eq-cong-rev-++ = begin
cast _ (reverse (xs ++ ys) ++ zs) ≡⟨ cast-++ˡ (+-comm n m) (reverse (xs ++ ys)) ⟩
cast _ (reverse (xs ++ ys)) ++ zs ≡⟨ cong (_++ zs) (reverse-++ (+-comm n m) xs ys) ⟩
(reverse ys ++ reverse xs) ++ zs ∎
-- uses reverse-++
ʳ++-++-another-alt : ∀ .(eq : n + m + o ≡ m + (n + o)) (xs : Vec A n) {ys : Vec A m} {zs : Vec A o} →
cast eq ((xs ++ ys) ʳ++ zs) ≡ ys ʳ++ (xs ʳ++ zs)
ʳ++-++-another-alt {n = n} {m} {o} eq xs {ys} {zs} = begin≈
((xs ++ ys) ʳ++ zs) ≡ˡ⟨ unfold-ʳ++ (xs ++ ys) zs ⟩
reverse (xs ++ ys) ++ zs ≈⟨ cast-++ˡ (+-comm n m) (reverse (xs ++ ys))
≈cong (_++ zs) ⟨ reverse-++ (+-comm n m) xs ys ⟩ ⟩
(reverse ys ++ reverse xs) ++ zs ≈⟨ ++-assoc (trans (cong (_+ o) (+-comm m n)) eq) (reverse ys) (reverse xs) zs ⟩
reverse ys ++ (reverse xs ++ zs) ≡ˡ˘⟨ cong (reverse ys ++_) (unfold-ʳ++ xs zs) ⟩
reverse ys ++ (xs ʳ++ zs) ≡ˡ˘⟨ unfold-ʳ++ ys (xs ʳ++ zs) ⟩
ys ʳ++ (xs ʳ++ zs) ≈∎
ʳ++-ʳ++ : ∀ .(eq : (n + m) + o ≡ m + (n + o)) (xs : Vec A n) {ys : Vec A m} {zs} →
cast eq ((xs ʳ++ ys) ʳ++ zs) ≡ ys ʳ++ (xs ++ zs)
ʳ++-ʳ++ {n = n} {m} {o} eq xs {ys} {zs} = begin≈
(xs ʳ++ ys) ʳ++ zs ≡ˡ⟨ cong (_ʳ++ zs) (unfold-ʳ++ xs ys) ⟩
(reverse xs ++ ys) ʳ++ zs ≡ˡ⟨ unfold-ʳ++ (reverse xs ++ ys) zs ⟩
reverse (reverse xs ++ ys) ++ zs ≈⟨ eq-cong-rev-++ ⟩
(reverse ys ++ reverse (reverse xs)) ++ zs ≡ˡ⟨ cong ((_++ zs) ∘ (reverse ys ++_)) (reverse-involutive xs) ⟩
(reverse ys ++ xs) ++ zs ≡ʳ⟨ ++-assoc (+-assoc m n o) (reverse ys) xs zs ⟩
reverse ys ++ (xs ++ zs) ≡˘⟨ unfold-ʳ++ ys (xs ++ zs) ⟩
ys ʳ++ (xs ++ zs) ∎
where
eq-cong-rev-++ = begin
cast _ (reverse (reverse xs ++ ys) ++ zs) ≡⟨ cast-++ˡ (+-comm n m) (reverse (reverse xs ++ ys)) ⟩
cast _ (reverse (reverse xs ++ ys)) ++ zs ≡⟨ cong (_++ zs) (reverse-++ (+-comm n m) (reverse xs) ys) ⟩
(reverse ys ++ reverse (reverse xs)) ++ zs ∎
ʳ++-ʳ++-alt : ∀ .(eq : (n + m) + o ≡ m + (n + o)) (xs : Vec A n) {ys : Vec A m} {zs} →
cast eq ((xs ʳ++ ys) ʳ++ zs) ≡ ys ʳ++ (xs ++ zs)
ʳ++-ʳ++-alt {n = n} {m} {o} eq xs {ys} {zs} = begin≈
(xs ʳ++ ys) ʳ++ zs ≡ˡ⟨ cong (_ʳ++ zs) (unfold-ʳ++ xs ys) ⟩
(reverse xs ++ ys) ʳ++ zs ≡ˡ⟨ unfold-ʳ++ (reverse xs ++ ys) zs ⟩
reverse (reverse xs ++ ys) ++ zs ≈⟨ cast-++ˡ (+-comm n m) (reverse (reverse xs ++ ys))
≈cong (_++ zs) ⟨ reverse-++ (+-comm n m) (reverse xs) ys ⟩ ⟩
(reverse ys ++ reverse (reverse xs)) ++ zs ≡ˡ⟨ cong ((_++ zs) ∘ (reverse ys ++_)) (reverse-involutive xs) ⟩
(reverse ys ++ xs) ++ zs ≈⟨ ++-assoc (+-assoc m n o) (reverse ys) xs zs ⟩
reverse ys ++ (xs ++ zs) ≡ˡ˘⟨ unfold-ʳ++ ys (xs ++ zs) ⟩
ys ʳ++ (xs ++ zs) ≈∎
cast-reverse : ∀ .(eq : n ≡ m) (xs : Vec A n) → cast eq (reverse xs) ≡ reverse (cast eq xs)
cast-reverse {m = zero} eq [] = refl
cast-reverse {m = suc m} eq (x ∷ xs) = begin≈
reverse (x ∷ xs) ≡ˡ⟨ reverse-∷ x xs ⟩
reverse xs ∷ʳ x ≡ʳ⟨ cast-∷ʳ eq x (reverse xs) ⟩
(cast _ (reverse xs)) ∷ʳ x ≡⟨ cong (_∷ʳ x) (cast-reverse _ xs) ⟩
(reverse (cast _ xs)) ∷ʳ x ≡˘⟨ reverse-∷ x (cast _ xs) ⟩
reverse (x ∷ cast _ xs) ≡⟨⟩
reverse (cast eq (x ∷ xs)) ∎
cast-reverse-alt : ∀ .(eq : n ≡ m) (xs : Vec A n) → cast eq (reverse xs) ≡ reverse (cast eq xs)
cast-reverse-alt {m = zero} eq [] = refl
cast-reverse-alt {m = suc m} eq (x ∷ xs) = begin≈
reverse (x ∷ xs) ≡ˡ⟨ reverse-∷ x xs ⟩
reverse xs ∷ʳ x ≈⟨ ≈-cong (_∷ʳ x) (cast-∷ʳ eq _ _) (cast-reverse-alt _ xs) ⟩
reverse (cast _ xs) ∷ʳ x ≡ˡ˘⟨ reverse-∷ x (cast _ xs) ⟩
reverse (x ∷ cast _ xs) ≈⟨⟩
reverse (cast eq (x ∷ xs)) ≈∎
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment