{-# OPTIONS --without-K #-}

--open import HoTT
open import homotopy.3x3.PushoutPushout
open import homotopy.3x3.Transpose
import homotopy.3x3.To as To
import homotopy.3x3.From as From
open import homotopy.3x3.Common

module homotopy.3x3.ToFrom2 {i} (d : Span^2 {i}) where

open Span^2 d
open M d hiding (Pushout^2)
open M (transpose d) using () renaming (A₀∙ to A∙₀; A₂∙ to A∙₂; A₄∙ to A∙₄;
                                        module F₁∙ to F∙₁; f₁∙ to f∙₁;
                                        module F₃∙ to F∙₃; f₃∙ to f∙₃;
                                        v-h-span to h-v-span)
open M using (Pushout^2)

open To d
open From d

open import homotopy.3x3.ToFromInit d

module M2 (c : A₂₂) where

  coh : ∀ {i} {A : Type i} {a b c d : A}
    {p q : a == b} (α : p == q)
    {v w : b == d} {β β' : w == v} (eqβ : β == β')
    {t u : a == c} {ε ε' : u == t} (eqε : ε == ε')
    {r s : c == d} (ζ : r == s)
    (γ : (q , v =□ t , s))
    (δ : (p , w =□ u , r))
    (eq : γ == δ ∙□-i/ ! β' / ε' / ∙□-o/ ! α / ζ /)
    → (α , β , γ =□□ δ , ε , ζ)
  coh idp {β = idp} idp {ε = idp} idp idp _ _ x = x

  end-lemma1 : ap (right ∘ f∙₃) (glue c) == ap (to ∘ i∙₄ ∘ f∙₃) (glue c) :> E₂∙Red.T-lhs c
  end-lemma1 =
    ap (right ∘ f∙₃) (glue c)
         =⟨ ap-∘ right f∙₃ (glue c) ⟩
    ap right (ap f∙₃ (glue c))
         =⟨ ap (ap right) (F∙₃.glue-β c) ⟩
    ap right (ap left (H₁₃ c) ∙ glue (f₂₃ c) ∙ ap right (! (H₃₃ c)))
         =⟨ ap-∙∙`∘`∘ right left right (H₁₃ c) (glue (f₂₃ c)) (! (H₃₃ c)) ⟩
    ap (right ∘ left) (H₁₃ c) ∙ ap right (glue (f₂₃ c)) ∙ ap (right ∘ right) (! (H₃₃ c))
         =⟨ ! (to-from-r-g (f₂₃ c)) |in-ctx (λ u → ap (right ∘ left) (H₁₃ c) ∙ u ∙ ap (right ∘ right) (! (H₃₃ c))) ⟩
    ap (right ∘ left) (H₁₃ c) ∙ (ap (to ∘ i∙₄) (glue (f₂₃ c))) ∙ ap (right ∘ right) (! (H₃₃ c))
         =⟨ ! (ap-∙∙`∘`∘ (to ∘ i∙₄) left right (H₁₃ c) (glue (f₂₃ c)) (! (H₃₃ c))) ⟩
    ap (to ∘ i∙₄) (ap left (H₁₃ c) ∙ glue (f₂₃ c) ∙ ap right (! (H₃₃ c)))
         =⟨ ! (ap (ap (to ∘ i∙₄)) (F∙₃.glue-β c)) ⟩
    ap (to ∘ i∙₄) (ap f∙₃ (glue c))
         =⟨ ∘-ap (to ∘ i∙₄) f∙₃ (glue c) ⟩
    ap (to ∘ i∙₄ ∘ f∙₃) (glue c) ∎

  abstract
   lemma1 : ↓-='-out (apd (to-from-r ∘ f∙₃) (glue c)) == end-lemma1
   lemma1 =
    ↓-='-out (apd (to-from-r ∘ f∙₃) (glue c))

         =⟨ apd-∘'' to-from-r f∙₃ (glue c) (F∙₃.glue-β c) |in-ctx ↓-='-out ⟩

    ↓-='-out (↓-ap-out= (λ b → to (from (right b)) == right b) f∙₃ (glue c) (F∙₃.glue-β c) (apd to-from-r (ap left (H₁₃ c) ∙ glue (f₂₃ c) ∙ ap right (! (H₃₃ c)))))

         =⟨ apd-∙∙`∘`∘ to-from-r left right (H₁₃ c) (glue (f₂₃ c)) (! (H₃₃ c)) |in-ctx (λ u → ↓-='-out (↓-ap-out= (λ b → to (from (right b)) == right b) f∙₃ (glue c) (F∙₃.glue-β c) u)) ⟩

    ↓-='-out (↓-ap-out= (λ b → to (from (right b)) == right b) f∙₃ (glue c) (F∙₃.glue-β c) (↓-ap-in _ _ (apd (λ _ → idp) (H₁₃ c)) ∙ᵈ apd to-from-r (glue (f₂₃ c)) ∙ᵈ ↓-ap-in _ _  (apd (λ _ → idp) (! (H₃₃ c)))))

         =⟨ ToFromR.glue-β (f₂₃ c) |in-ctx (λ u → ↓-='-out (↓-ap-out= (λ b → to (from (right b)) == right b) f∙₃ (glue c) (F∙₃.glue-β c)
                                                                      (↓-ap-in _ _ (apd (λ _ → idp) (H₁₃ c)) ∙ᵈ u ∙ᵈ ↓-ap-in _ _  (apd (λ _ → idp) (! (H₃₃ c)))))) ⟩

    ↓-='-out (↓-ap-out= (λ b → to (from (right b)) == right b) f∙₃ (glue c) (F∙₃.glue-β c)
                        (↓-ap-in _ _ (apd (λ _ → idp) (H₁₃ c)) ∙ᵈ ↓-='-in (! (to-from-r-g (f₂₃ c))) ∙ᵈ ↓-ap-in _ _  (apd (λ _ → idp) (! (H₃₃ c)))))

         =⟨ lemma-a _ f∙₃ (glue c) (F∙₃.glue-β c) _ ⟩

    ↓-='-out (↓-ap-in _ _ (apd (λ x → idp {a = right (left x)}) (H₁₃ c)) ∙ᵈ ↓-='-in (! (to-from-r-g (f₂₃ c))) ∙ᵈ ↓-ap-in _ _  (apd (λ _ → idp) (! (H₃₃ c))))
    ∙□-i/ ap-∘ right f∙₃ (glue c) ∙ ap (ap right) (F∙₃.glue-β c)
        / ! (ap (ap (to ∘ i∙₄)) (F∙₃.glue-β c)) ∙ ∘-ap (to ∘ i∙₄) f∙₃ (glue c) /

         =⟨ lemma-b (glue (f₂₃ c)) (apd (λ _ → idp) (H₁₃ c)) (! (to-from-r-g (f₂₃ c))) (apd (λ _ → idp) (! (H₃₃ c))) |in-ctx (λ u → u ∙□-i/ ap-∘ right f∙₃ (glue c) ∙ ap (ap right) (F∙₃.glue-β c)
                                      / ! (ap (ap (to ∘ i∙₄)) (F∙₃.glue-β c)) ∙ ∘-ap (to ∘ i∙₄) f∙₃ (glue c) /) ⟩

    (↓-='-out (apd (λ x → idp {a = right (left x)}) (H₁₃ c))
    ∙□h ((! (to-from-r-g (f₂₃ c)))
    ∙□h (↓-='-out (apd (λ _ → idp) (! (H₃₃ c))))))
    ∙□-i/ ap-∙∙`∘`∘ right left right (H₁₃ c) (glue (f₂₃ c)) (! (H₃₃ c))
        / ! (ap-∙∙`∘`∘ (to ∘ i∙₄) left right (H₁₃ c) (glue (f₂₃ c)) (! (H₃₃ c))) /
    ∙□-i/ ap-∘ right f∙₃ (glue c) ∙ ap (ap right) (F∙₃.glue-β c)
        / ! (ap (ap (to ∘ i∙₄)) (F∙₃.glue-β c)) ∙ ∘-ap (to ∘ i∙₄) f∙₃ (glue c) /

         =⟨ coh3 |in-ctx (λ u → u
                                ∙□-i/ ap-∙∙`∘`∘ right left right (H₁₃ c) (glue (f₂₃ c)) (! (H₃₃ c))
                                    / ! (ap-∙∙`∘`∘ (to ∘ i∙₄) left right (H₁₃ c) (glue (f₂₃ c)) (! (H₃₃ c))) /
                                ∙□-i/ ap-∘ right f∙₃ (glue c) ∙ ap (ap right) (F∙₃.glue-β c)
                                    / ! (ap (ap (to ∘ i∙₄)) (F∙₃.glue-β c)) ∙ ∘-ap (to ∘ i∙₄) f∙₃ (glue c) /) ⟩

    ((! (to-from-r-g (f₂₃ c))) |in-ctx (λ u → ap (right ∘ left) (H₁₃ c) ∙ u ∙ ap (right ∘ right) (! (H₃₃ c))))
    ∙□-i/ ap-∙∙`∘`∘ right left right (H₁₃ c) (glue (f₂₃ c)) (! (H₃₃ c))
        / ! (ap-∙∙`∘`∘ (to ∘ i∙₄) left right (H₁₃ c) (glue (f₂₃ c)) (! (H₃₃ c))) /
    ∙□-i/ ap-∘ right f∙₃ (glue c) ∙ ap (ap right) (F∙₃.glue-β c)
        / ! (ap (ap (to ∘ i∙₄)) (F∙₃.glue-β c)) ∙ ∘-ap (to ∘ i∙₄) f∙₃ (glue c) /

         =⟨ coh' ⟩
    end-lemma1 ∎  where

      coh' : ∀ {i} {A : Type i} {x y : A} {a b c d e f g h : x == y} {p : a == b} {q : b == c}
        {r : c == d} {s : d == e} {t : e == f} {u : f == g} {v : g == h}
        → (s ∙□-i/ r / t / ∙□-i/ p ∙ q / u ∙ v /) == (a =⟨ p ⟩ b =⟨ q ⟩ c =⟨ r ⟩ d =⟨ s ⟩ e =⟨ t ⟩ f =⟨ u ⟩ g =⟨ v ⟩ h ∎)
      coh' {p = idp} {idp} {idp} {idp} {idp} {idp} {idp} = idp

      coh2 : ∀ {i j} {A : Type i} {B : Type j} {f : A → B} {x y : A} {p : x == y}
        → ↓-='-out (apd (λ x → idp {a = f x}) p) == idp {a = ap f p}
      coh2 {p = idp} = idp

      coh3 : (↓-='-out (apd (λ x → idp {a = right (left x)}) (H₁₃ c))
              ∙□h ((! (to-from-r-g (f₂₃ c)))
              ∙□h (↓-='-out (apd (λ _ → idp) (! (H₃₃ c)))))) == ((! (to-from-r-g (f₂₃ c))) |in-ctx (λ u → ap (right ∘ left) (H₁₃ c) ∙ u ∙ ap (right ∘ right) (! (H₃₃ c))))
      coh3 =
        ↓-='-out (apd (λ x → idp {a = right (left x)}) (H₁₃ c))
        ∙□h ((! (to-from-r-g (f₂₃ c)))
        ∙□h (↓-='-out (apd (λ _ → idp) (! (H₃₃ c)))))

             =⟨ coh2 {f = right ∘ left} {p = H₁₃ c} |in-ctx (λ u → u ∙□h ((! (to-from-r-g (f₂₃ c))) ∙□h (↓-='-out (apd (λ _ → idp) (! (H₃₃ c)))))) ⟩

        idp {a = ap (right ∘ left) (H₁₃ c)} ∙□h ((! (to-from-r-g (f₂₃ c)))
            ∙□h (↓-='-out (apd (λ _ → idp) (! (H₃₃ c)))))

             =⟨ coh2 {f = right ∘ right} {p = ! (H₃₃ c)} |in-ctx (λ u → idp {a = ap (right ∘ left) (H₁₃ c)} ∙□h ((! (to-from-r-g (f₂₃ c))) ∙□h u)) ⟩

        idp {a = ap (right ∘ left) (H₁₃ c)} ∙□h ((! (to-from-r-g (f₂₃ c))) ∙□h idp {a = ap (right ∘ right) (! (H₃₃ c))})

              =⟨ coh4 (ap (right ∘ left) (H₁₃ c)) (ap (right ∘ right) (! (H₃₃ c))) (! (to-from-r-g (f₂₃ c))) ⟩

        ((! (to-from-r-g (f₂₃ c))) |in-ctx (λ u → ap (right ∘ left) (H₁₃ c) ∙ u ∙ ap (right ∘ right) (! (H₃₃ c)))) ∎  where

          coh4 : ∀ {i} {A : Type i} {x y z t : A} (p : x == y) (q : z == t) {s t : y == z} (r : s == t)
            → (idp {a = p} ∙□h (r ∙□h idp {a = q})) == (r |in-ctx (λ u → p ∙ u ∙ q))
          coh4 idp idp idp = idp

  end-lemma3 : ap (left ∘ f∙₁) (glue c) == ap (to ∘ i∙₀ ∘ f∙₁) (glue c)
  end-lemma3 =
    ap (left ∘ f∙₁) (glue c)
         =⟨ ap-∘ left f∙₁ (glue c) ⟩
    ap left (ap f∙₁ (glue c))
         =⟨ ap (ap left) (F∙₁.glue-β c) ⟩
    ap left (ap left (! (H₁₁ c)) ∙ glue (f₂₁ c) ∙ ap right (H₃₁ c))
         =⟨ ap-∙∙`∘`∘ left left right (! (H₁₁ c)) (glue (f₂₁ c)) (H₃₁ c) ⟩
    ap (left ∘ left) (! (H₁₁ c)) ∙ ap left (glue (f₂₁ c)) ∙ ap (left ∘ right) (H₃₁ c)
         =⟨ ! (to-from-l-g (f₂₁ c)) |in-ctx (λ u → ap (left ∘ left) (! (H₁₁ c)) ∙ u ∙ ap (left ∘ right) (H₃₁ c)) ⟩
    ap (left ∘ left) (! (H₁₁ c)) ∙ (ap (to ∘ i∙₀) (glue (f₂₁ c))) ∙ ap (left ∘ right) (H₃₁ c)
         =⟨ ! (ap-∙∙`∘`∘ (to ∘ i∙₀) left right (! (H₁₁ c)) (glue (f₂₁ c)) (H₃₁ c)) ⟩
    ap (to ∘ i∙₀) (ap left (! (H₁₁ c)) ∙ glue (f₂₁ c) ∙ ap right (H₃₁ c))
         =⟨ ! (ap (ap (to ∘ i∙₀)) (F∙₁.glue-β c)) ⟩
    ap (to ∘ i∙₀) (ap f∙₁ (glue c))
         =⟨ ∘-ap (to ∘ i∙₀) f∙₁ (glue c) ⟩
    ap (to ∘ i∙₀ ∘ f∙₁) (glue c) ∎

  lemma3 : ↓-='-out (apd (to-from-l ∘ f∙₁) (glue c)) == end-lemma3
  lemma3 =
    ↓-='-out (apd (to-from-l ∘ f∙₁) (glue c))

      =⟨ apd-∘'' to-from-l f∙₁ (glue c) (F∙₁.glue-β c) |in-ctx ↓-='-out ⟩

    ↓-='-out (↓-ap-out= (λ b → to (from (left b)) == left b) f∙₁ (glue c) (F∙₁.glue-β c) (apd to-from-l (ap left (! (H₁₁ c)) ∙ glue (f₂₁ c) ∙ ap right (H₃₁ c))))

      =⟨ lemma-a _ f∙₁ (glue c) (F∙₁.glue-β c) (apd to-from-l (ap left (! (H₁₁ c)) ∙ glue (f₂₁ c) ∙ ap right (H₃₁ c))) ⟩

    ↓-='-out (apd to-from-l (ap left (! (H₁₁ c)) ∙ glue (f₂₁ c) ∙ ap right (H₃₁ c)))
    ∙□-i/ ap-∘ left f∙₁ (glue c) ∙ ap (ap left) (F∙₁.glue-β c) / ! (ap (ap (to ∘ from ∘ left)) (F∙₁.glue-β c)) ∙ ∘-ap (to ∘ from ∘ left) f∙₁ (glue c) /

      =⟨ apd-∙∙`∘`∘ to-from-l left right (! (H₁₁ c)) (glue (f₂₁ c)) (H₃₁ c) |in-ctx
         (λ u → ↓-='-out u ∙□-i/ ap-∘ left f∙₁ (glue c) ∙ ap (ap left) (F∙₁.glue-β c) / ! (ap (ap (to ∘ from ∘ left)) (F∙₁.glue-β c)) ∙ ∘-ap (to ∘ from ∘ left) f∙₁ (glue c) /) ⟩

    ↓-='-out (↓-ap-in _ _ (apd (λ _ → idp) (! (H₁₁ c))) ∙ᵈ apd to-from-l (glue (f₂₁ c)) ∙ᵈ ↓-ap-in _ _ (apd (λ _ → idp) (H₃₁ c)))
    ∙□-i/ ap-∘ left f∙₁ (glue c) ∙ ap (ap left) (F∙₁.glue-β c) / ! (ap (ap (to ∘ from ∘ left)) (F∙₁.glue-β c)) ∙ ∘-ap (to ∘ from ∘ left) f∙₁ (glue c) /

      =⟨ ToFromL.glue-β (f₂₁ c) |in-ctx (λ u → ↓-='-out (↓-ap-in _ _ (apd (λ _ → idp) (! (H₁₁ c))) ∙ᵈ u ∙ᵈ ↓-ap-in _ _ (apd (λ _ → idp) (H₃₁ c)))
         ∙□-i/ ap-∘ left f∙₁ (glue c) ∙ ap (ap left) (F∙₁.glue-β c) / ! (ap (ap (to ∘ from ∘ left)) (F∙₁.glue-β c)) ∙ ∘-ap (to ∘ from ∘ left) f∙₁ (glue c) /) ⟩

    ↓-='-out (↓-ap-in _ _ (apd (λ _ → idp) (! (H₁₁ c))) ∙ᵈ ↓-='-in (! (to-from-l-g (f₂₁ c))) ∙ᵈ ↓-ap-in _ _ (apd (λ _ → idp) (H₃₁ c)))
    ∙□-i/ ap-∘ left f∙₁ (glue c) ∙ ap (ap left) (F∙₁.glue-β c) / ! (ap (ap (to ∘ from ∘ left)) (F∙₁.glue-β c)) ∙ ∘-ap (to ∘ from ∘ left) f∙₁ (glue c) /

      =⟨ lemma-b (glue (f₂₁ c)) (apd (λ _ → idp) (! (H₁₁ c))) (! (to-from-l-g (f₂₁ c))) (apd (λ _ → idp) (H₃₁ c))
         |in-ctx (λ u → u ∙□-i/ ap-∘ left f∙₁ (glue c) ∙ ap (ap left) (F∙₁.glue-β c) / ! (ap (ap (to ∘ from ∘ left)) (F∙₁.glue-β c)) ∙ ∘-ap (to ∘ from ∘ left) f∙₁ (glue c) /) ⟩

    (↓-='-out (apd (λ _ → idp) (! (H₁₁ c))) ∙□h ((! (to-from-l-g (f₂₁ c))) ∙□h ↓-='-out (apd (λ _ → idp) (H₃₁ c))))
    ∙□-i/ ap-∙∙`∘`∘ left left right (! (H₁₁ c)) (glue (f₂₁ c)) (H₃₁ c) / ! (ap-∙∙`∘`∘ (to ∘ i∙₀) left right (! (H₁₁ c)) (glue (f₂₁ c)) (H₃₁ c)) /
    ∙□-i/ ap-∘ left f∙₁ (glue c) ∙ ap (ap left) (F∙₁.glue-β c) / ! (ap (ap (to ∘ from ∘ left)) (F∙₁.glue-β c)) ∙ ∘-ap (to ∘ from ∘ left) f∙₁ (glue c) /

      =⟨ coh2 (left ∘ left) (left ∘ right) (! (H₁₁ c)) (! (to-from-l-g (f₂₁ c))) (H₃₁ c) |in-ctx (λ u →
         u ∙□-i/ ap-∙∙`∘`∘ left left right (! (H₁₁ c)) (glue (f₂₁ c)) (H₃₁ c) / ! (ap-∙∙`∘`∘ (to ∘ i∙₀) left right (! (H₁₁ c)) (glue (f₂₁ c)) (H₃₁ c)) /
    ∙□-i/ ap-∘ left f∙₁ (glue c) ∙ ap (ap left) (F∙₁.glue-β c) / ! (ap (ap (to ∘ from ∘ left)) (F∙₁.glue-β c)) ∙ ∘-ap (to ∘ from ∘ left) f∙₁ (glue c) /) ⟩

    ((! (to-from-l-g (f₂₁ c))) |in-ctx (λ u → ap (left ∘ left) (! (H₁₁ c)) ∙ u ∙ ap (left ∘ right) (H₃₁ c)))
    ∙□-i/ ap-∙∙`∘`∘ left left right (! (H₁₁ c)) (glue (f₂₁ c)) (H₃₁ c) / ! (ap-∙∙`∘`∘ (to ∘ i∙₀) left right (! (H₁₁ c)) (glue (f₂₁ c)) (H₃₁ c)) /
    ∙□-i/ ap-∘ left f∙₁ (glue c) ∙ ap (ap left) (F∙₁.glue-β c) / ! (ap (ap (to ∘ from ∘ left)) (F∙₁.glue-β c)) ∙ ∘-ap (to ∘ from ∘ left) f∙₁ (glue c) /

      =⟨ coh3 ⟩

    end-lemma3 ∎  where

      coh2 : ∀ {i i' j} {A : Type i} {A' : Type i'} {B : Type j} (f : A → B) (f' : A' → B)
             {a b : A} {a' b' : A'} (p : a == b) {s s' : f b == f' a'} (q : s == s') (r : a' == b')
             → (↓-='-out (apd (λ x → idp) p) ∙□h (q ∙□h (↓-='-out (apd (λ _ → idp) r))))
               == (q |in-ctx (λ u → ap f p ∙ u ∙ ap f' r))
      coh2 f f' idp idp idp = idp

      coh3 : ∀ {i} {A : Type i} {x y : A} {a b c d e f g h : x == y} {p : a == b} {q : b == c}
        {r : c == d} {s : d == e} {t : e == f} {u : f == g} {v : g == h}
        → (s ∙□-i/ r / t / ∙□-i/ p ∙ q / u ∙ v /) == (a =⟨ p ⟩ b =⟨ q ⟩ c =⟨ r ⟩ d =⟨ s ⟩ e =⟨ t ⟩ f =⟨ u ⟩ g =⟨ v ⟩ h ∎)
      coh3 {p = idp} {idp} {idp} {idp} {idp} {idp} {idp} = idp

{- Lemma 2 -}

  lemma2-7 =
    ↓-='-out (ap↓ (ap to) (apd (glue {d = v-h-span}) (glue c)))

         =⟨ to-glue-glue-β c |in-ctx ↓-='-out ⟩

    ↓-='-out (↓-='-in (E₂∙Red.coh c (↓-='-out (apd (glue {d = h-v-span}) (glue c))
                                      ∙□-i/ E₂∙Red.lhs-i c / E₂∙Red.rhs-i c /)
                       ∙□-i/ E₂∙Red.lhs-o c / E₂∙Red.rhs-o c /)
              ◃/ To.glue-β (left (f₂₁ c)) / ! (To.glue-β (right (f₂₃ c))) /)

         =⟨ thing _ (To.glue-β (left (f₂₁ c))) _ ⟩

    E₂∙Red.coh c (↓-='-out (apd (glue {d = h-v-span}) (glue c))
                   ∙□-i/ E₂∙Red.lhs-i c / E₂∙Red.rhs-i c /)
    ∙□-i/ E₂∙Red.lhs-o c / E₂∙Red.rhs-o c /
    ∙□-o/ To.glue-β (left (f₂₁ c)) / ! (To.glue-β (right (f₂₃ c))) / ∎

  lemma2-6 =
    ap□ to (↓-='-out (apd (glue {d = v-h-span}) (glue c)))

         =⟨ ap□-↓-='-out-β _ _ to (apd (glue {d = v-h-span}) (glue c)) ⟩

    ↓-='-out (ap↓ (ap to) (apd (glue {d = v-h-span}) (glue c)))
    ∙□-i/ ∘-ap to (right ∘ f₃∙) (glue c) / ap-∘ to (left ∘ f₁∙) (glue c) /

         =⟨ lemma2-7 |in-ctx (λ u → (u ∙□-i/ ∘-ap to (right ∘ f₃∙) (glue c) / ap-∘ to (left ∘ f₁∙) (glue c) /)) ⟩

    E₂∙Red.coh c (↓-='-out (apd (glue {d = h-v-span}) (glue c))
                   ∙□-i/ E₂∙Red.lhs-i c / E₂∙Red.rhs-i c /)
    ∙□-i/ E₂∙Red.lhs-o c / E₂∙Red.rhs-o c /
    ∙□-o/ To.glue-β (left (f₂₁ c)) / ! (To.glue-β (right (f₂₃ c))) /
    ∙□-i/ ∘-ap to (right ∘ f₃∙) (glue c) / ap-∘ to (left ∘ f₁∙) (glue c) / ∎

  lemma2-5 =
    ap□ to (↓-='-out (apd (glue {d = v-h-span}) (glue c))
              ∙□-i/ E∙₂Red.lhs-i c / E∙₂Red.rhs-i c /)

         =⟨ ap□-∙□-i/ to _ (E∙₂Red.lhs-i c) _ ⟩

    ap□ to (↓-='-out (apd (glue {d = v-h-span}) (glue c)))
    ∙□-i/ ap (ap to) (E∙₂Red.lhs-i c) / ap (ap to) (E∙₂Red.rhs-i c) /

         =⟨ lemma2-6 |in-ctx (λ u → u ∙□-i/ ap (ap to) (E∙₂Red.lhs-i c) / ap (ap to) (E∙₂Red.rhs-i c) /) ⟩

    E₂∙Red.coh c (↓-='-out (apd (glue {d = h-v-span}) (glue c))
                   ∙□-i/ E₂∙Red.lhs-i c / E₂∙Red.rhs-i c /)
    ∙□-i/ E₂∙Red.lhs-o c / E₂∙Red.rhs-o c /
    ∙□-o/ To.glue-β (left (f₂₁ c)) / ! (To.glue-β (right (f₂₃ c))) /
    ∙□-i/ ∘-ap to (right ∘ f₃∙) (glue c) / ap-∘ to (left ∘ f₁∙) (glue c) /
    ∙□-i/ ap (ap to) (E∙₂Red.lhs-i c) / ap (ap to) (E∙₂Red.rhs-i c) / ∎

  lemma2'-1 =
    E∙₂Red.ap-ap-coh!-lhs-i c to ∙ ap (ap to) (E∙₂Red.lhs-i c) ∙ ∘-ap to (right ∘ f₃∙) (glue c) ∙ E₂∙Red.lhs-o c

         =⟨ eq1 {f = ap to}
                {q = ! (ap-∙∙`∘`∘ right left right (H₃₁ c) (glue (f₃₂ c)) (H₃₃ c))}
                { ! (ap (ap right) (F₃∙.glue-β c))}
                { ! (F₃∙.glue-β c) |in-ctx (ap right)}
                (!-ap (ap right) (F₃∙.glue-β c))
                {∘-ap right f₃∙ (glue c)}
                {p = E∙₂Red.ap-ap-coh!-lhs-i c to}
                {∘-ap to (right ∘ f₃∙) (glue c)}
                {ap-∘ i₄∙ f₃∙ (glue c)}
                {F₃∙.glue-β c |in-ctx (ap i₄∙)}
                {ap-∙∙`∘`∘ i₄∙ left right (H₃₁ c) (glue (f₃₂ c)) (H₃₃ c)}
                {I₄∙.glue-β (f₃₂ c) |in-ctx (λ u → ap (left ∘ right) (H₃₁ c) ∙ u ∙ ap (right ∘ right) (H₃₃ c))}
          ⟩

    (! (ap-∙∙`∘`∘ to (right ∘ left) (right ∘ right) (H₃₁ c) (ap right (glue (f₃₂ c))) (H₃₃ c))
     ∙ ap (ap to) (! (ap-∙∙`∘`∘ right left right (H₃₁ c) (glue (f₃₂ c)) (H₃₃ c)))
     ∙ (ap (ap to) (! (F₃∙.glue-β c) |in-ctx (ap right))
        ∙ (ap (ap to) (∘-ap right f₃∙ (glue c))
           ∙ ∘-ap to (right ∘ f₃∙) (glue c)
           ∙ ap-∘ i₄∙ f₃∙ (glue c))
        ∙ (F₃∙.glue-β c |in-ctx (ap i₄∙)))
     ∙ ap-∙∙`∘`∘ i₄∙ left right (H₃₁ c) (glue (f₃₂ c)) (H₃₃ c))
    ∙ (I₄∙.glue-β (f₃₂ c) |in-ctx (λ u → ap (left ∘ right) (H₃₁ c) ∙ u ∙ ap (right ∘ right) (H₃₃ c)))

         =⟨ ap-∘^3-coh to right f₃∙ (glue c) |in-ctx (λ u →
    (! (ap-∙∙`∘`∘ to (right ∘ left) (right ∘ right) (H₃₁ c) (ap right (glue (f₃₂ c))) (H₃₃ c))
     ∙ ap (ap to) (! (ap-∙∙`∘`∘ right left right (H₃₁ c) (glue (f₃₂ c)) (H₃₃ c)))
     ∙ (ap (ap to) (! (F₃∙.glue-β c) |in-ctx (ap right))
        ∙ u
        ∙ (F₃∙.glue-β c |in-ctx (ap i₄∙)))
     ∙ ap-∙∙`∘`∘ i₄∙ left right (H₃₁ c) (glue (f₃₂ c)) (H₃₃ c))
    ∙ (I₄∙.glue-β (f₃₂ c) |in-ctx (λ u → ap (left ∘ right) (H₃₁ c) ∙ u ∙ ap (right ∘ right) (H₃₃ c))))
          ⟩

    (! (ap-∙∙`∘`∘ to (right ∘ left) (right ∘ right) (H₃₁ c) (ap right (glue (f₃₂ c))) (H₃₃ c))
     ∙ ap (ap to) (! (ap-∙∙`∘`∘ right left right (H₃₁ c) (glue (f₃₂ c)) (H₃₃ c)))
     ∙ (ap (ap to) (! (F₃∙.glue-β c) |in-ctx (ap right))
        ∙ ∘-ap to right (ap f₃∙ (glue c))
        ∙ (F₃∙.glue-β c |in-ctx (ap i₄∙)))
     ∙ ap-∙∙`∘`∘ i₄∙ left right (H₃₁ c) (glue (f₃₂ c)) (H₃₃ c))
    ∙ (I₄∙.glue-β (f₃₂ c) |in-ctx (λ u → ap (left ∘ right) (H₃₁ c) ∙ u ∙ ap (right ∘ right) (H₃₃ c)))

         =⟨ ap-∘-ap-coh to right (F₃∙.glue-β c) |in-ctx (λ u →
    (! (ap-∙∙`∘`∘ to (right ∘ left) (right ∘ right) (H₃₁ c) (ap right (glue (f₃₂ c))) (H₃₃ c))
     ∙ ap (ap to) (! (ap-∙∙`∘`∘ right left right (H₃₁ c) (glue (f₃₂ c)) (H₃₃ c)))
     ∙ u
     ∙ ap-∙∙`∘`∘ i₄∙ left right (H₃₁ c) (glue (f₃₂ c)) (H₃₃ c))
    ∙ (I₄∙.glue-β (f₃₂ c) |in-ctx (λ u → ap (left ∘ right) (H₃₁ c) ∙ u ∙ ap (right ∘ right) (H₃₃ c)))) ⟩

    (! (ap-∙∙`∘`∘ to (right ∘ left) (right ∘ right) (H₃₁ c) (ap right (glue (f₃₂ c))) (H₃₃ c))
     ∙ ap (ap to) (! (ap-∙∙`∘`∘ right left right (H₃₁ c) (glue (f₃₂ c)) (H₃₃ c)))
     ∙ ∘-ap to right (ap left (H₃₁ c) ∙ glue (f₃₂ c) ∙ ap right (H₃₃ c))
     ∙ ap-∙∙`∘`∘ i₄∙ left right (H₃₁ c) (glue (f₃₂ c)) (H₃₃ c))
    ∙ (I₄∙.glue-β (f₃₂ c) |in-ctx (λ u → ap (left ∘ right) (H₃₁ c) ∙ u ∙ ap (right ∘ right) (H₃₃ c)))

         =⟨ ap-∘-ap-∙∙3`∘`∘-coh to right left right (H₃₁ c) (glue (f₃₂ c)) (H₃₃ c) |in-ctx (λ u →
                 u ∙ (I₄∙.glue-β (f₃₂ c) |in-ctx (λ u → ap (left ∘ right) (H₃₁ c) ∙ u ∙ ap (right ∘ right) (H₃₃ c)))) ⟩

    (∘-ap to right (glue (f₃₂ c)) |in-ctx (λ u → ap (left ∘ right) (H₃₁ c) ∙ u ∙ ap (right ∘ right) (H₃₃ c)))
    ∙ (I₄∙.glue-β (f₃₂ c) |in-ctx (λ u → ap (left ∘ right) (H₃₁ c) ∙ u ∙ ap (right ∘ right) (H₃₃ c)))

         =⟨ ∙-|in-ctx (λ u → ap (left ∘ right) (H₃₁ c) ∙ u ∙ ap (right ∘ right) (H₃₃ c)) (∘-ap to right (glue (f₃₂ c))) (I₄∙.glue-β (f₃₂ c)) ⟩

    ((∘-ap to right (glue (f₃₂ c)) ∙ I₄∙.glue-β (f₃₂ c)) |in-ctx (λ u → ap (left ∘ right) (H₃₁ c) ∙ u ∙ ap (right ∘ right) (H₃₃ c))) ∎

    where

      eq1 : ∀ {i j} {A : Type i} {B : Type j} {f : A → B} {a b c d : A}
        {q : a == b} {r r' : b == c} (e : r == r') {s : c == d}
        {g h k l m n : B} {p : g == f a} {t : f d == h} {u : h == k}
        {v : k == l} {w : l == m} {x : m == n}
         → p ∙ ap f (_ =⟨ q ⟩ _ =⟨ r ⟩ _ =⟨ s ⟩ _ ∎) ∙ t
           ∙ (_ =⟨ u ⟩ _ =⟨ v ⟩ _ =⟨ w ⟩ _ =⟨ x ⟩ _ ∎)
         == (p ∙ ap f q ∙ (ap f r' ∙ (ap f s ∙ t ∙ u) ∙ v) ∙ w) ∙ x
      eq1 {q = idp} {idp} {.idp} idp {idp} {p = p} {idp} {idp} {idp} {idp} {idp} = ! (∙-unit-r (p ∙ idp))

  lemma2'-2 :
    E₂∙Red.rhs-o c
    ∙ ap-∘ to (left ∘ f₁∙) (glue c)
    ∙ ap (ap to) (E∙₂Red.rhs-i c)
    ∙ E∙₂Red.ap-ap-coh!-rhs-i c to
    == (! (∘-ap to left (glue (f₁₂ c)) ∙ I₀∙.glue-β (f₁₂ c)) |in-ctx (λ u → ap (left ∘ left) (H₁₁ c) ∙ u ∙ ap (right ∘ left) (H₁₃ c)))
  lemma2'-2 =
    E₂∙Red.rhs-o c ∙ ap-∘ to (left ∘ f₁∙) (glue c) ∙ ap (ap to) (E∙₂Red.rhs-i c) ∙ E∙₂Red.ap-ap-coh!-rhs-i c to

      =⟨ eq1 {f = ap to}
             {p = ! (I₀∙.glue-β (f₁₂ c) |in-ctx (λ u → (ap (left ∘ left) (H₁₁ c) ∙ u ∙ ap (right ∘ left) (H₁₃ c))))}
             { ! (ap-∙∙`∘`∘ i₀∙ left right (H₁₁ c) (glue (f₁₂ c)) (H₁₃ c))}
             { ! (F₁∙.glue-β c |in-ctx ap i₀∙)}
             {∘-ap i₀∙ f₁∙ (glue c)}
             {ap-∘ to (left ∘ f₁∙) (glue c)}
             {ap-∘ left f₁∙ (glue c)}
             {F₁∙.glue-β c |in-ctx (ap left)}
             {ap-∙∙`∘`∘ left left right (H₁₁ c) (glue (f₁₂ c)) (H₁₃ c)}
             {ap-∙∙`∘`∘ to (left ∘ left) (left ∘ right) (H₁₁ c) (ap left (glue (f₁₂ c))) (H₁₃ c)}
       ⟩

    (! (I₀∙.glue-β (f₁₂ c) |in-ctx (λ u → (ap (left ∘ left) (H₁₁ c) ∙ u ∙ ap (right ∘ left) (H₁₃ c)))))
    ∙ ((! (ap-∙∙`∘`∘ i₀∙ left right (H₁₁ c) (glue (f₁₂ c)) (H₁₃ c)))
       ∙ ((! (F₁∙.glue-β c |in-ctx (λ u → ap i₀∙ u)))
          ∙ (∘-ap i₀∙ f₁∙ (glue c)
             ∙ ap-∘ to (left ∘ f₁∙) (glue c)
             ∙ ap (ap to) (ap-∘ left f₁∙ (glue c)))
          ∙ ap (ap to) (F₁∙.glue-β c |in-ctx (ap left)))
       ∙ ap (ap to) (ap-∙∙`∘`∘ left left right (H₁₁ c) (glue (f₁₂ c)) (H₁₃ c))
       ∙ ap-∙∙`∘`∘ to (left ∘ left) (left ∘ right) (H₁₁ c) (ap left (glue (f₁₂ c))) (H₁₃ c))

      =⟨ ap-∘^3-coh' to left f₁∙ (glue c)
         |in-ctx (λ u → (! (I₀∙.glue-β (f₁₂ c) |in-ctx (λ u → (ap (left ∘ left) (H₁₁ c) ∙ u ∙ ap (right ∘ left) (H₁₃ c)))))
    ∙ ((! (ap-∙∙`∘`∘ i₀∙ left right (H₁₁ c) (glue (f₁₂ c)) (H₁₃ c)))
       ∙ ((! (F₁∙.glue-β c |in-ctx (λ u → ap i₀∙ u)))
          ∙ u
          ∙ ap (ap to) (F₁∙.glue-β c |in-ctx (ap left)))
       ∙ ap (ap to) (ap-∙∙`∘`∘ left left right (H₁₁ c) (glue (f₁₂ c)) (H₁₃ c))
       ∙ ap-∙∙`∘`∘ to (left ∘ left) (left ∘ right) (H₁₁ c) (ap left (glue (f₁₂ c))) (H₁₃ c))) ⟩

    (! (I₀∙.glue-β (f₁₂ c) |in-ctx (λ u → (ap (left ∘ left) (H₁₁ c) ∙ u ∙ ap (right ∘ left) (H₁₃ c)))))
    ∙ ((! (ap-∙∙`∘`∘ i₀∙ left right (H₁₁ c) (glue (f₁₂ c)) (H₁₃ c)))
       ∙ ((! (F₁∙.glue-β c |in-ctx (ap i₀∙)))
          ∙ ap-∘ to left (ap f₁∙ (glue c))
          ∙ ap (ap to) (F₁∙.glue-β c |in-ctx (ap left)))
       ∙ ap (ap to) (ap-∙∙`∘`∘ left left right (H₁₁ c) (glue (f₁₂ c)) (H₁₃ c))
       ∙ ap-∙∙`∘`∘ to (left ∘ left) (left ∘ right) (H₁₁ c) (ap left (glue (f₁₂ c))) (H₁₃ c))

      =⟨ ap-∘-ap-coh'2 to left (F₁∙.glue-β c)
         |in-ctx (λ u → (! (I₀∙.glue-β (f₁₂ c) |in-ctx (λ u → (ap (left ∘ left) (H₁₁ c) ∙ u ∙ ap (right ∘ left) (H₁₃ c)))))
    ∙ ((! (ap-∙∙`∘`∘ i₀∙ left right (H₁₁ c) (glue (f₁₂ c)) (H₁₃ c)))
       ∙ u
       ∙ ap (ap to) (ap-∙∙`∘`∘ left left right (H₁₁ c) (glue (f₁₂ c)) (H₁₃ c))
       ∙ ap-∙∙`∘`∘ to (left ∘ left) (left ∘ right) (H₁₁ c) (ap left (glue (f₁₂ c))) (H₁₃ c))) ⟩

    (! (I₀∙.glue-β (f₁₂ c) |in-ctx (λ u → (ap (left ∘ left) (H₁₁ c) ∙ u ∙ ap (right ∘ left) (H₁₃ c)))))
    ∙ ((! (ap-∙∙`∘`∘ i₀∙ left right (H₁₁ c) (glue (f₁₂ c)) (H₁₃ c)))
       ∙ ap-∘ to left (ap left (H₁₁ c) ∙ glue (f₁₂ c) ∙ ap right (H₁₃ c))
       ∙ ap (ap to) (ap-∙∙`∘`∘ left left right (H₁₁ c) (glue (f₁₂ c)) (H₁₃ c))
       ∙ ap-∙∙`∘`∘ to (left ∘ left) (left ∘ right) (H₁₁ c) (ap left (glue (f₁₂ c))) (H₁₃ c))

      =⟨ ap-∘-ap-∙∙2`∘`∘-coh to left left right (H₁₁ c) (glue (f₁₂ c)) (H₁₃ c)
         |in-ctx (λ u → (! (I₀∙.glue-β (f₁₂ c) |in-ctx (λ u → (ap (left ∘ left) (H₁₁ c) ∙ u ∙ ap (right ∘ left) (H₁₃ c)))) ∙ u)) ⟩

    (! (I₀∙.glue-β (f₁₂ c) |in-ctx (λ u → (ap (left ∘ left) (H₁₁ c) ∙ u ∙ ap (right ∘ left) (H₁₃ c)))))
    ∙ (ap-∘ to left (glue (f₁₂ c)) |in-ctx (λ u → ap (left ∘ left) (H₁₁ c) ∙ u ∙ ap (right ∘ left) (H₁₃ c)))

      =⟨ coh2 (glue (f₁₂ c)) (I₀∙.glue-β (f₁₂ c)) ⟩

    (! (∘-ap to left (glue (f₁₂ c)) ∙ I₀∙.glue-β (f₁₂ c)) |in-ctx (λ u → ap (left ∘ left) (H₁₁ c) ∙ u ∙ ap (right ∘ left) (H₁₃ c))) ∎

    where

      eq1 : ∀ {i j} {A : Type i} {B : Type j} {f : A → B} {a b c d e : B} {k l m n : A} {o : B}
         {p : a == b} {q : b == c} {r : c == d} {s : d == e} {t : e == f k} {u : k == l}
         {v : l == m} {w : m == n} {x : f n == o}
         → (_ =⟨ p ⟩ _ =⟨ q ⟩ _ =⟨ r ⟩ _ =⟨ s ⟩ _ ∎) ∙ t ∙ ap f (_ =⟨ u ⟩ _ =⟨ v ⟩ _ =⟨ w ⟩ _ ∎) ∙ x
         == (p ∙ (q ∙ ((r ∙ (s ∙ t ∙ ap f u) ∙ ap f v) ∙ ap f w ∙ x)))
      eq1 {p = idp} {idp} {idp} {idp} {t = t} {idp} {idp} {idp} {idp} = ! (∙-unit-r (t ∙ idp)) ∙ ! (∙-unit-r ((t ∙ idp) ∙ idp))

      coh2 : ∀ {i j k l} {A : Type i} {B : Type j} {C : Type k} {D : Type l}
        {a a' : A} (q : a == a') {h : A → B} {g : B → C} {f : (g (h a) == g (h a')) → D} {r : g (h a) == g (h a')} (p : ap (g ∘ h) q == r)
        → (! (p |in-ctx f)) ∙ (ap-∘ g h q |in-ctx f) == (! (∘-ap g h q ∙ p) |in-ctx f)
      coh2 idp idp = idp

  lemma2-4' =
    ap□ to (↓-='-out (apd (glue {d = v-h-span}) (glue c))
              ∙□-i/ E∙₂Red.lhs-i c / E∙₂Red.rhs-i c /)
    ∙□-i/ E∙₂Red.ap-ap-coh!-lhs-i c to / E∙₂Red.ap-ap-coh!-rhs-i c to /

         =⟨ lemma2-5 |in-ctx (λ u → u ∙□-i/ E∙₂Red.ap-ap-coh!-lhs-i c to / E∙₂Red.ap-ap-coh!-rhs-i c to /) ⟩

    E₂∙Red.coh c (↓-='-out (apd (glue {d = h-v-span}) (glue c))
                  ∙□-i/ E₂∙Red.lhs-i c / E₂∙Red.rhs-i c /)
    ∙□-i/ E₂∙Red.lhs-o c / E₂∙Red.rhs-o c /
    ∙□-o/ To.glue-β (left (f₂₁ c)) / ! (To.glue-β (right (f₂₃ c))) /
    ∙□-i/ ∘-ap to (right ∘ f₃∙) (glue c) / ap-∘ to (left ∘ f₁∙) (glue c) /
    ∙□-i/ ap (ap to) (E∙₂Red.lhs-i c) / ap (ap to) (E∙₂Red.rhs-i c) /
    ∙□-i/ E∙₂Red.ap-ap-coh!-lhs-i c to / E∙₂Red.ap-ap-coh!-rhs-i c to /

         =⟨ assoc (E₂∙Red.coh c (↓-='-out (apd (glue {d = h-v-span}) (glue c))
                   ∙□-i/ E₂∙Red.lhs-i c / E₂∙Red.rhs-i c /))
                   (E₂∙Red.lhs-o c) (∘-ap to (right ∘ f₃∙) (glue c)) (ap (ap to) (E∙₂Red.lhs-i c))
                   (E∙₂Red.ap-ap-coh!-lhs-i c to) _ _ _ _ (To.glue-β (left (f₂₁ c))) _ ⟩

    E₂∙Red.coh c (↓-='-out (apd (glue {d = h-v-span}) (glue c))
                   ∙□-i/ E₂∙Red.lhs-i c / E₂∙Red.rhs-i c /)
    ∙□-o/ To.glue-β (left (f₂₁ c)) / ! (To.glue-β (right (f₂₃ c))) /
    ∙□-i/ E∙₂Red.ap-ap-coh!-lhs-i c to ∙ ap (ap to) (E∙₂Red.lhs-i c) ∙ ∘-ap to (right ∘ f₃∙) (glue c) ∙ E₂∙Red.lhs-o c
        / E₂∙Red.rhs-o c ∙ ap-∘ to (left ∘ f₁∙) (glue c) ∙ ap (ap to) (E∙₂Red.rhs-i c) ∙ E∙₂Red.ap-ap-coh!-rhs-i c to /

         =⟨ ∙□-i/-rewrite (E₂∙Red.coh c (↓-='-out (apd (glue {d = h-v-span}) (glue c))
                   ∙□-i/ E₂∙Red.lhs-i c / E₂∙Red.rhs-i c /)
    ∙□-o/ To.glue-β (left (f₂₁ c)) / ! (To.glue-β (right (f₂₃ c))) /) lemma2'-1 lemma2'-2 ⟩

    E₂∙Red.coh c (↓-='-out (apd (glue {d = h-v-span}) (glue c))
                   ∙□-i/ E₂∙Red.lhs-i c / E₂∙Red.rhs-i c /)
    ∙□-o/ To.glue-β (left (f₂₁ c)) / ! (To.glue-β (right (f₂₃ c))) /
    ∙□-i/ (∘-ap to right (glue (f₃₂ c)) ∙ I₄∙.glue-β (f₃₂ c)) |in-ctx (λ u → ap (left ∘ right) (H₃₁ c) ∙ u ∙ ap (right ∘ right) (H₃₃ c))
        / (! (∘-ap to left (glue (f₁₂ c)) ∙ I₀∙.glue-β (f₁₂ c))) |in-ctx (λ u → ap (left ∘ left) (H₁₁ c) ∙ u ∙ ap (right ∘ left) (H₁₃ c)) / ∎  where

      assoc : ∀ {i} {A : Type i} {a b b' c : A} {u u' : a == b} {v v1 v2 v3 v4 : b == c}
         {w w1 w2 w3 w4 : a == b'} {x x' : b' == c} (α : (u , v =□ w , x))
         (p1 : v1 == v) (p2 : v2 == v1) (p3 : v3 == v2) (p4 : v4 == v3)
         (q1 : w == w1) (q2 : w1 == w2) (q3 : w2 == w3) (q4 : w3 == w4)
         (r : u' == u) (s : x == x')
         → α ∙□-i/ p1 / q1 / ∙□-o/ r / s / ∙□-i/ p2 / q2 / ∙□-i/ p3 / q3 / ∙□-i/ p4 / q4 /
         == α ∙□-o/ r / s / ∙□-i/ p4 ∙ p3 ∙ p2 ∙ p1 / q1 ∙ q2 ∙ q3 ∙ q4 /
      assoc α idp idp idp idp idp idp idp idp idp idp = idp

  lemma2-4'' =
    E∙₂Red.ap-ap-coh! c to (ap□ to (↓-='-out (apd (glue {d = v-h-span}) (glue c))
                                       ∙□-i/ E∙₂Red.lhs-i c / E∙₂Red.rhs-i c /)
                             ∙□-i/ E∙₂Red.ap-ap-coh!-lhs-i c to / E∙₂Red.ap-ap-coh!-rhs-i c to /)

         =⟨ lemma2-4' |in-ctx (E∙₂Red.ap-ap-coh! c to) ⟩

    E∙₂Red.ap-ap-coh! c to (E₂∙Red.coh c (↓-='-out (apd (glue {d = h-v-span}) (glue c))
                                            ∙□-i/ E₂∙Red.lhs-i c / E₂∙Red.rhs-i c /)
                             ∙□-o/ To.glue-β (left (f₂₁ c)) / ! (To.glue-β (right (f₂₃ c))) /
                             ∙□-i/ (∘-ap to right (glue (f₃₂ c)) ∙ I₄∙.glue-β (f₃₂ c)) |in-ctx (λ u → ap (left ∘ right) (H₃₁ c) ∙ u ∙ ap (right ∘ right) (H₃₃ c))
                                 / (! (∘-ap to left (glue (f₁₂ c)) ∙ I₀∙.glue-β (f₁₂ c))) |in-ctx (λ u → ap (left ∘ left) (H₁₁ c) ∙ u ∙ ap (right ∘ left) (H₁₃ c))/)

         =⟨ lemma! (∘-ap to left (glue (f₁₂ c)) ∙ I₀∙.glue-β (f₁₂ c)) (To.glue-β (right (f₂₃ c))) (To.glue-β (left (f₂₁ c))) (∘-ap to right (glue (f₃₂ c)) ∙ I₄∙.glue-β (f₃₂ c))
                   (↓-='-out (apd (glue {d = h-v-span}) (glue c))
                   ∙□-i/ E₂∙Red.lhs-i c / E₂∙Red.rhs-i c /) ⟩

    ↓-='-out (apd (glue {d = h-v-span}) (glue c))
    ∙□-i/ E₂∙Red.lhs-i c / E₂∙Red.rhs-i c /
    ∙□-o/ ∘-ap to left (glue (f₁₂ c)) ∙ I₀∙.glue-β (f₁₂ c) / ! (∘-ap to right (glue (f₃₂ c)) ∙ I₄∙.glue-β (f₃₂ c)) /
    ∙□-i/ (To.glue-β (right (f₂₃ c))) |in-ctx (λ u → ap (right ∘ left) (H₁₃ c) ∙ u ∙ ! (ap (right ∘ right) (H₃₃ c)))
        / (! (To.glue-β (left (f₂₁ c)))) |in-ctx (λ u → ! (ap (left ∘ left) (H₁₁ c)) ∙ u ∙ ap (left ∘ right) (H₃₁ c)) / ∎

  lemma2-4 =
    ap□ to (E∙₂Red.coh! c (↓-='-out (apd (glue {d = v-h-span}) (glue c))
                            ∙□-i/ E∙₂Red.lhs-i c / E∙₂Red.rhs-i c /))

         =⟨ E∙₂Red.ap-ap-coh!-β c to (↓-='-out (apd (glue {d = v-h-span}) (glue c)) ∙□-i/ E∙₂Red.lhs-i c / E∙₂Red.rhs-i c /) ⟩

    E∙₂Red.ap-ap-coh! c to (ap□ to (↓-='-out (apd (glue {d = v-h-span}) (glue c))
                                       ∙□-i/ E∙₂Red.lhs-i c / E∙₂Red.rhs-i c /)
                             ∙□-i/ E∙₂Red.ap-ap-coh!-lhs-i c to / E∙₂Red.ap-ap-coh!-rhs-i c to /)
    ∙□-i/ E∙₂Red.ap-ap-coh!-lhs-o c to / E∙₂Red.ap-ap-coh!-rhs-o c to /

         =⟨ lemma2-4'' |in-ctx (λ u → u ∙□-i/ E∙₂Red.ap-ap-coh!-lhs-o c to / E∙₂Red.ap-ap-coh!-rhs-o c to /) ⟩

    ↓-='-out (apd (glue {d = h-v-span}) (glue c))
    ∙□-i/ E₂∙Red.lhs-i c / E₂∙Red.rhs-i c /
    ∙□-o/ ∘-ap to left (glue (f₁₂ c)) ∙ I₀∙.glue-β (f₁₂ c) / ! (∘-ap to right (glue (f₃₂ c)) ∙ I₄∙.glue-β (f₃₂ c)) /
    ∙□-i/ (To.glue-β (right (f₂₃ c))) |in-ctx (λ u → ap (right ∘ left) (H₁₃ c) ∙ u ∙ ! (ap (right ∘ right) (H₃₃ c)))
        / (! (To.glue-β (left (f₂₁ c)))) |in-ctx (λ u → ! (ap (left ∘ left) (H₁₁ c)) ∙ u ∙ ap (left ∘ right) (H₃₁ c)) /
    ∙□-i/ E∙₂Red.ap-ap-coh!-lhs-o c to / E∙₂Red.ap-ap-coh!-rhs-o c to / ∎


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import Optics.All
open import LibraBFT.Prelude
open import LibraBFT.Hash
open import LibraBFT.Base.ByteString
open import LibraBFT.Base.Encode
open import LibraBFT.Base.KVMap as KVMap
open import LibraBFT.Base.PKCS
open import LibraBFT.Base.Types
open import LibraBFT.Impl.Base.Types

open import Data.String using (String)

-- Defines the types that /DO NOT/ depend on an epoch config.
-- TODO-3: update types to reflect more recent version of LibraBFT.  This is
-- a substantial undertaking that should probably be led by someone who can
-- access our internal implementation.
module LibraBFT.Impl.Consensus.Types.EpochIndep where
  -- Below here is incremental progress towards something
  -- that will eventually mirror the types in LBFT.Consensus.Types
  -- that /DO NOT/ depend on the set of active authors
  -- or safety rules, which we call the /EpochConfig/.

  Author : Set
  Author = NodeId

  AccountAddress : Set
  AccountAddress = Author

  HashValue : Set
  HashValue = Hash

  TX : Set
  TX = ByteString

  Instant : Set
  Instant = ℕ   -- TODO-2: should eventually be a time stamp

  -----------------
  -- Information --
  -----------------

  record BlockInfo : Set where
    constructor BlockInfo∙new
    field
      ₋biEpoch : Epoch
      ₋biRound : Round
      ₋biId    : HashValue
      -- This has more fields...
  open BlockInfo public
  unquoteDecl biEpoch   biRound   biId = mkLens (quote BlockInfo)
             (biEpoch ∷ biRound ∷ biId ∷ [])
  postulate instance enc-BlockInfo : Encoder BlockInfo

  BlockInfo-η : ∀{e1 e2 r1 r2 i1 i2} → e1 ≡ e2 → r1 ≡ r2 → i1 ≡ i2
              → BlockInfo∙new e1 r1 i1 ≡ BlockInfo∙new e2 r2 i2
  BlockInfo-η refl refl refl = refl

  record LedgerInfo : Set where
    constructor LedgerInfo∙new
    field
      ₋liCommitInfo        : BlockInfo
      ₋liConsensusDataHash : HashValue
  open LedgerInfo public
  unquoteDecl liCommitInfo   liConsensusDataHash = mkLens (quote LedgerInfo)
             (liCommitInfo ∷ liConsensusDataHash ∷ [])
  postulate instance enc-LedgerInfo : Encoder LedgerInfo

  LedgerInfo-η : ∀ {ci1 ci2 : BlockInfo} {cdh1 cdh2 : Hash}
             → ci1  ≡ ci2
             → cdh1 ≡ cdh2
             → (LedgerInfo∙new ci1 cdh1) ≡ (LedgerInfo∙new ci2 cdh2)
  LedgerInfo-η refl refl = refl

  record LedgerInfoWithSignatures : Set where
    constructor LedgerInfoWithSignatures∙new
    field
      ₋liwsLedgerInfo : LedgerInfo
      ₋liwsSignatures : KVMap Author Signature
  open LedgerInfoWithSignatures public
  unquoteDecl liwsLedgerInfo   liwsSignatures = mkLens (quote LedgerInfoWithSignatures)
             (liwsLedgerInfo ∷ liwsSignatures ∷ [])
  postulate instance enc-LedgerInfoWithSignatures : Encoder LedgerInfoWithSignatures

  -------------------
  -- Votes and QCs --
  -------------------

  record VoteData : Set where
    constructor VoteData∙new
    field
      ₋vdProposed : BlockInfo
      ₋vdParent   : BlockInfo
  open VoteData public
  unquoteDecl vdProposed   vdParent = mkLens (quote VoteData)
             (vdProposed ∷ vdParent ∷ [])
  postulate instance enc-VoteData : Encoder VoteData

  VoteData-η : ∀ {pr1 par1 pr2 par2 : BlockInfo} → pr1  ≡ pr2 → par1 ≡ par2
             → (VoteData∙new pr1 par1) ≡ (VoteData∙new pr2 par2)
  VoteData-η refl refl = refl

  -- DESIGN NOTE: The ₋vAuthor field is included only to facilitate lookup of the public key against
  -- which to verify the signature.  An alternative would be to use an index into the members of the
  -- epoch config, which would save message space and therefore bandwidth.

  record Vote : Set where
    constructor Vote∙new
    field
      ₋vVoteData         : VoteData
      ₋vAuthor           : Author
      ₋vLedgerInfo       : LedgerInfo
      ₋vSignature        : Signature
      ₋vTimeoutSignature : Maybe Signature
  open Vote public
  unquoteDecl vVoteData   vAuthor   vLedgerInfo   vSignature   vTimeoutSignature = mkLens (quote Vote)
             (vVoteData ∷ vAuthor ∷ vLedgerInfo ∷ vSignature ∷ vTimeoutSignature ∷ [])
  postulate instance enc-Vote     : Encoder Vote

  vParent : Lens Vote BlockInfo
  vParent = vVoteData ∙ vdParent

  vProposed : Lens Vote BlockInfo
  vProposed = vVoteData ∙ vdProposed

  vParentId : Lens Vote Hash
  vParentId = vVoteData ∙ vdParent ∙ biId

  vParentRound : Lens Vote Round
  vParentRound = vVoteData ∙ vdParent ∙ biRound

  vProposedId : Lens Vote Hash
  vProposedId = vVoteData ∙ vdProposed ∙ biId

  vEpoch : Lens Vote Epoch
  vEpoch = vVoteData ∙ vdProposed ∙ biEpoch

  vdRound : Lens VoteData Round
  vdRound = vdProposed ∙ biRound

  vRound : Lens Vote Round
  vRound = vVoteData ∙ vdRound

  record QuorumCert : Set where
    constructor QuorumCert∙new
    field
      ₋qcVoteData         : VoteData
      ₋qcSignedLedgerInfo : LedgerInfoWithSignatures
  open QuorumCert public
  unquoteDecl qcVoteData   qcSignedLedgerInfo = mkLens (quote QuorumCert)
             (qcVoteData ∷ qcSignedLedgerInfo ∷ [])
  postulate instance enc-QuorumCert : Encoder QuorumCert

  -- Because QuorumCert has an injective encoding (postulated, for now),
  -- we can use it to determine equality of QuorumCerts.
  _≟QC_ : (q1 q2 : QuorumCert) → Dec (q1 ≡ q2)
  _≟QC_ = ≡-Encoder enc-QuorumCert

  _QCBoolEq_ : QuorumCert → QuorumCert → Bool
  _QCBoolEq_ q1 q2 = does (q1 ≟QC q2)

  qcCertifiedBlock : Lens QuorumCert BlockInfo
  qcCertifiedBlock = qcVoteData ∙ vdProposed

  -- Constructs a 'vote' that was gathered in a QC.
  rebuildVote : QuorumCert → Author × Signature → Vote
  rebuildVote qc (α , sig)
    = record { ₋vVoteData         = ₋qcVoteData qc
             ; ₋vAuthor           = α
             ; ₋vLedgerInfo       = qc ^∙ (qcSignedLedgerInfo ∙ liwsLedgerInfo)
             ; ₋vSignature        = sig
             ; ₋vTimeoutSignature = nothing -- Is this correct?  The original vote may have had a
                                            -- timeout signature, but we don't know.  Does it
                                            -- matter?
             }

  -- Two votes are equivalent if they are identical except they may differ on timeout signature
  _≈Vote_ : (v1 v2 : Vote) → Set
  v1 ≈Vote v2 = v2 ≡ record v1 { ₋vTimeoutSignature = ₋vTimeoutSignature v2 }

  qcVotesKV : QuorumCert → KVMap Author Signature
  qcVotesKV = ₋liwsSignatures ∘ ₋qcSignedLedgerInfo

  qcVotes : QuorumCert → List (Author × Signature)
  qcVotes qc = kvm-toList (qcVotesKV qc)

  qcCertifies : Lens QuorumCert  Hash
  qcCertifies = qcVoteData ∙ vdProposed ∙ biId

  qcRound : Lens QuorumCert Round
  qcRound = qcVoteData ∙ vdProposed ∙ biRound

  ₋qcCertifies : QuorumCert → Hash
  ₋qcCertifies q = q ^∙ qcCertifies

  ₋qcRound : QuorumCert → Round
  ₋qcRound q = q ^∙ qcRound

  ------------
  -- Blocks --
  ------------

  data BlockType : Set where
    Proposal : TX → Author → BlockType
    NilBlock : BlockType
    Genesis  : BlockType
  postulate instance enc-BlockType : Encoder BlockType

  record BlockData : Set where
    constructor BlockData∙new
    field
      ₋bdEpoch      : Epoch
      ₋bdRound      : Round
      -- QUESTION: How do we represent a block that extends the
      -- genesis block, which doesn't come with a QC.  Maybe the
      -- genesis block has an associated QC established for the epoch?
      ₋bdQuorumCert : QuorumCert
      ₋bdBlockType  : BlockType
  open BlockData public
  unquoteDecl bdEpoch   bdRound   bdQuorumCert   bdBlockType = mkLens (quote BlockData)
             (bdEpoch ∷ bdRound ∷ bdQuorumCert ∷ bdBlockType ∷ [])
  postulate instance enc-BlockData : Encoder BlockData

  bdParentId : Lens BlockData Hash
  bdParentId = bdQuorumCert ∙ qcVoteData ∙ vdParent ∙ biId

  -- This is the id of a block
  bdBlockId : Lens BlockData Hash
  bdBlockId = bdQuorumCert ∙ qcVoteData ∙ vdProposed ∙ biId

  -- The signature is a Maybe to allow us to use 'nothing' as the
  -- 'bSignature' when constructing a block to sign later.  Also,
  -- "nil" blocks are not signed because they are produced
  -- independently by different validators.  This is to enable
  -- committing after an epoch-changing command is processed: we
  -- cannot add more commands, but we need to add some quorum
  -- certificates in order to commit the epoch-changing command.
  record Block : Set where
    constructor Block∙new
    field
      ₋bId        : HashValue
      ₋bBlockData : BlockData
      ₋bSignature : Maybe Signature
  open Block public
  unquoteDecl bId   bBlockData   bSignature = mkLens (quote Block)
             (bId ∷ bBlockData ∷ bSignature ∷ [])

  postulate instance enc : Encoder Block

  bQuorumCert : Lens Block QuorumCert
  bQuorumCert  = bBlockData ∙ bdQuorumCert

  bRound : Lens Block Round
  bRound =  bBlockData ∙ bdRound

  record SyncInfo : Set where
    constructor mkSyncInfo -- Bare constructor to enable pattern matching against SyncInfo; "smart"
                           -- constructor SyncInfo∙new is below
    field
      ₋siHighestQuorumCert  : QuorumCert
      ₋siHighestCommitCert  : Maybe QuorumCert
      -- ₋siHighestTimeoutCert : Mabe TimeoutCert -- Not used yet.
  open SyncInfo public
  -- Note that we do not automatically derive a lens for siHighestCommitCert;
  -- it is defined manually below.
  unquoteDecl siHighestQuorumCert   = mkLens (quote SyncInfo)
             (siHighestQuorumCert ∷ [])
  postulate instance enc-SyncInfo : Encoder SyncInfo

  SyncInfo∙new : QuorumCert → QuorumCert → SyncInfo
  SyncInfo∙new highestQuorumCert highestCommitCert =
    record { ₋siHighestQuorumCert = highestQuorumCert
           ; ₋siHighestCommitCert = if highestQuorumCert QCBoolEq highestCommitCert
                                    then nothing else (just highestCommitCert) }

  siHighestCommitCert : Lens SyncInfo QuorumCert
  siHighestCommitCert = mkLens' (λ x → fromMaybe (x ^∙ siHighestQuorumCert) (₋siHighestCommitCert x))
                                (λ x si → record x { ₋siHighestCommitCert = just si })

  ----------------------
  -- Network Messages --
  ----------------------

  record ProposalMsg : Set where
    constructor ProposalMsg∙new
    field
      ₋pmProposal : Block
      ₋pmSyncInfo : SyncInfo
  open ProposalMsg public
  unquoteDecl pmProposal   pmSyncInfo = mkLens (quote ProposalMsg)
             (pmProposal ∷ pmSyncInfo ∷ [])
  postulate instance enc-ProposalMsg : Encoder ProposalMsg

  record VoteMsg : Set where
    constructor  VoteMsg∙new
    field
      ₋vmVote     : Vote
      ₋vmSyncInfo : SyncInfo
  open VoteMsg public
  unquoteDecl vmVote   vmSyncInfo = mkLens (quote VoteMsg)
             (vmVote ∷ vmSyncInfo ∷ [])
  postulate instance enc-VoteMsg : Encoder VoteMsg

  vmProposed : Lens VoteMsg BlockInfo
  vmProposed = vmVote ∙ vVoteData ∙ vdProposed

  vmParent : Lens VoteMsg BlockInfo
  vmParent = vmVote ∙ vVoteData ∙ vdParent

  -- This is a notification of a commit.  It may not be explicitly included in an implementation,
  -- but we need something to be able to express correctness conditions.  It will
  -- probably have something different in it, but will serve the purpose for now.
  record CommitMsg : Set where
    constructor CommitMsg∙new
    field
      ₋cmEpoch   : Epoch
      ₋cmAuthor  : NodeId
      ₋cmRound   : Round
      ₋cmCert    : QuorumCert  -- We assume for now that a CommitMsg contains the QuorumCert of the head of the 3-chain
      ₋cmSigMB   : Maybe Signature
  open CommitMsg public
  unquoteDecl cmEpoch   cmAuthor   cmRound   cmCert   cmSigMB = mkLens (quote CommitMsg)
             (cmEpoch ∷ cmAuthor ∷ cmRound ∷ cmCert ∷ cmSigMB ∷ [])
  postulate instance enc-CommitMsg : Encoder CommitMsg

  record LastVoteInfo : Set where
    constructor LastVoteInfo∙new
    field
      ₋lviLiDigest  : HashValue
      ₋lviRound     : Round
      ₋lviIsTimeout : Bool
  open LastVoteInfo public

  record PendingVotes : Set where
    constructor PendingVotes∙new
    field
      ₋pvLiDigestToVotes   : KVMap HashValue LedgerInfoWithSignatures
      -- -pvMaybePartialTC : Maybe TimeoutCertificate
      ₋pvAuthorToVote      : KVMap Author Vote
  open PendingVotes public

  -- Note: this is a placeholder.
  -- We are not concerned for now with executing transactions, just ordering/committing them.
  -- This is outdated (see comment at top).
  data StateComputeResult : Set where
    stateComputeResult : StateComputeResult

  record ExecutedBlock : Set where
    constructor ExecutedBlock∙new
    field
      ₋ebBlock  : Block
      ₋ebOutput : StateComputeResult
  open ExecutedBlock public
  unquoteDecl ebBlock   ebOutput = mkLens (quote ExecutedBlock)
             (ebBlock ∷ ebOutput ∷ [])

  ebId : Lens ExecutedBlock HashValue
  ebId = ebBlock ∙ bId

  ebQuorumCert : Lens ExecutedBlock QuorumCert
  ebQuorumCert = ebBlock ∙ bQuorumCert

  ebParentId : Lens ExecutedBlock HashValue
  ebParentId = ebQuorumCert ∙ qcCertifiedBlock ∙ biId

  ebRound : Lens ExecutedBlock Round
  ebRound = ebBlock ∙ bRound

-- ------------------------------------------------------------------------------

  record LinkableBlock : Set where
    constructor LinkableBlock₋new
    field
      ₋lbExecutedBlock : ExecutedBlock
      -- ₋lbChildren      : Set HashValue
  open LinkableBlock public
  unquoteDecl lbExecutedBlock = mkLens (quote LinkableBlock)
             (lbExecutedBlock ∷ [])

  lbId : Lens LinkableBlock HashValue
  lbId = lbExecutedBlock ∙ ebId

-- ------------------------------------------------------------------------------

  -- Note BlockTree and BlockStore are defined in EpochDep.agda as they depend on an EpochConfig

  record SafetyData : Set where
    constructor SafetyData∙new
    field
      :sdEpoch          : Epoch
      :sdLastVotedRound : Round
      :sdPreferredRound : Round
      :sdLastVote       : Maybe Vote
  open SafetyData public
  unquoteDecl sdEpoch sdLastVotedRound sdPreferredRound sdLastVote =
    mkLens (quote SafetyData)
    (sdEpoch ∷ sdLastVotedRound ∷ sdPreferredRound ∷ sdLastVote ∷  [])

  record PersistentSafetyStorage : Set where
    constructor PersistentSafetyStorage∙new
    field
      :pssSafetyData : SafetyData
      :pssAuthor     : Author
      -- :pssWaypoint : Waypoint
  open PersistentSafetyStorage public
  unquoteDecl pssSafetyData pssAuthor = mkLens (quote PersistentSafetyStorage)
    (pssSafetyData ∷ pssAuthor ∷ [])

  record ValidatorSigner : Set where
    constructor ValidatorSigner∙new
    field
      :vsAuthor     : AccountAddress
      -- :vsPrivateKey : SK   -- Note that the SystemModel doesn't
                              -- allow one node to examine another's
                              -- state, so we don't model someone being
                              -- able to impersonate someone else unless
                              -- PK is "dishonest", which models the
                              -- possibility that the corresponding secret
                              -- key may have been leaked.
  open ValidatorSigner public

  record ValidatorConfig : Set where
    constructor ValidatorConfig∙new
    field
     :vcConsensusPublicKey : PK
  open ValidatorConfig public
  unquoteDecl vcConsensusPublicKey = mkLens (quote ValidatorConfig)
    (vcConsensusPublicKey ∷ [])

  record ValidatorInfo : Set where
    constructor ValidatorInfo∙new
    field
      -- :viAccountAddress       : AccountAddress
      -- :viConsensusVotingPower : Int -- TODO-2: Each validator has one vote. Generalize later.
      :viConfig : ValidatorConfig
  open ValidatorInfo public

  record ValidatorConsensusInfo : Set where
    constructor ValidatorConsensusInfo∙new
    field
     :vciPublicKey   : PK
     --:vciVotingPower : U64
  open ValidatorConsensusInfo public

  record ValidatorVerifier : Set where
    constructor ValidatorVerifier∙new
    field
      :vvAddressToValidatorInfo : (KVMap AccountAddress ValidatorConsensusInfo)
      :vvQuorumVotingPower      : ℕ  -- TODO-2: see above; for now, this is QuorumSize
      -- :vvTotalVotingPower    : ℕ  -- TODO-2: see above; for now, this is number of peers in EpochConfig
  open ValidatorVerifier public
  unquoteDecl vvAddressToValidatorInfo vvQuorumVotingPower = mkLens
    (quote ValidatorVerifier)
    (vvAddressToValidatorInfo ∷ vvQuorumVotingPower ∷ [])

  record SafetyRules : Set where
    constructor SafetyRules∙new
    field
      :srPersistentStorage : PersistentSafetyStorage
      -- :srValidatorSigner   : Maybe ValidatorSigner
  open SafetyRules public
  unquoteDecl srPersistentStorage = mkLens (quote SafetyRules)
   (srPersistentStorage ∷ [])

  data Output : Set where
    BroadcastProposal : ProposalMsg           → Output
    LogErr            : String                → Output
    -- LogInfo           : InfoLog a          → Output
    SendVote          : VoteMsg → List Author → Output
  open Output public

  SendVote-inj-v : ∀ {x1 x2 y1 y2} → SendVote x1 y1 ≡ SendVote x2 y2 → x1 ≡ x2
  SendVote-inj-v refl = refl

  SendVote-inj-si : ∀ {x1 x2 y1 y2} → SendVote x1 y1 ≡ SendVote x2 y2 → y1 ≡ y2
  SendVote-inj-si refl = refl


open import Reflection
open import Reflection.Term
open import Reflection.Universe
open import Reflection.Annotated
open import Agda.Builtin.Reflection using (withReconstructed; dontReduceDefs; onlyReduceDefs)
open import Relation.Nullary
open import Data.String as S
open import Data.Maybe hiding (_>>=_)
open import Data.Unit
open import Function
open import Data.List as L
open import Data.Vec as V using (Vec; []; _∷_)
open import Data.Nat
open import Data.Product
open import Data.Bool

-- Get a reference to the local term such as where-function or
-- with- or rewrite- by its name.
get-defn : String → AnnotationFun (λ _ → Maybe Name)
get-defn n ⟨term⟩ (def f x) with showName f S.≟ n
...                         | yes _ = just f
...                         | no  _ = nothing
get-defn n u t = defaultAnn nothing _<∣>_ u t

do-get-defn : String → ∀ {u} → (t : ⟦ u ⟧) → Annotated (λ _ → Maybe Name) t
do-get-defn n = annotate (get-defn n)

to-pat-lam : Definition → TC (Maybe Term)
to-pat-lam (function cs) = return $ just (pat-lam cs [])
to-pat-lam _ = return $ nothing

tel-norm : Names → Telescope → Telescope → TC Telescope
tel-norm base-funs [] ctx = return []
tel-norm base-funs ((v , arg i x) ∷ tel) ctx = do
  x ← dontReduceDefs base-funs
      $ inContext (reverse $ L.map proj₂ ctx)
      $ withReconstructed
      $ normalise x
      --$ reduce x
  let p = (v , arg i x)
  tel ← tel-norm base-funs tel (ctx L.++ [ p ])
  return $! p ∷ tel

pat-lam-norm : Term → Names → TC Term
pat-lam-norm (pat-lam cs args) base-funs = do
  cs ← hlpr cs
  return $ pat-lam cs args
  where
    hlpr : List Clause → TC $ List Clause
    hlpr [] = return []
    hlpr (clause tel ps t ∷ l) = do
      --gctx ← getContext

      -- Try normalising telescope
      tel ← tel-norm base-funs tel []
      let ctx = reverse $ L.map proj₂ tel
      t ← dontReduceDefs base-funs
          $ inContext ctx --(gctx L.++ ctx)
          $ withReconstructed
          $ normalise t
          --$ reduce t
      l ← hlpr l
      return $! clause tel ps t ∷ l
    hlpr (absurd-clause tel ps ∷ l) = do
      l ← hlpr l
      return $! absurd-clause tel ps ∷ l
pat-lam-norm t _ = return t

get-term : (f : Name) (base-funs : List Name) → TC Term
get-term t bf = do
     td ← withReconstructed $ dontReduceDefs bf $ getDefinition t
     just te ← to-pat-lam td where _ → typeError [ strErr $ "get-term: " S.++ showName t S.++ " is not a function" ]
     te ← pat-lam-norm te bf
     return te

get-ty : (f : Name) (base-funs : List Name) → TC Term
get-ty t bf = do
     ty ← getType t
     withReconstructed $ dontReduceDefs bf $ normalise ty

-- A helper function to get a term or a type (first parameter true/false) using
-- the chain of names so that we could traverse into helper functions.  For example
-- assume that `f` has  `with-x` in its body which in turn has `rewrite-y` which we
-- want to obtain.  Then we should call frefln as follows:
--
--     frefln true ("with-x" ∷ "rewrite-y" ∷ []) (base-funs) (quote f)
frefln-h : Bool → (name-chain : List String) (base-funs : Names) → Name → TC Term
frefln-h true [] bf t  = get-term t bf
frefln-h false [] bf t = get-ty t bf
frefln-h te/ty (x ∷ ns) bf t = do
     xt ← get-term t bf
     case (ann $ do-get-defn x {⟨term⟩} xt) of λ where
       (nothing) → typeError [ strErr $ "frefln: cannot find name `" S.++ x S.++ "` in term " S.++ showName t ]
       (just f') → frefln-h te/ty ns bf f'

macro
  frefl : Name → List Name → Term → TC ⊤
  frefl n bf a = frefln-h true [] bf n >>= quoteTC >>= unify a

  fty : Name → List Name → Term → TC ⊤
  fty n bf a = frefln-h false [] bf n >>= quoteTC >>= unify a

  frefln : Name → List Name → List String → Term → TC ⊤
  frefln n bf ns a = frefln-h true ns bf n >>= quoteTC >>= unify a

  ftyn : Name → List Name → List String → Term → TC ⊤
  ftyn n bf ns a = frefln-h false ns bf n >>= quoteTC >>= unify a
{-
  -- For debugging purposes.
  frefl : Name → List Name → Term → TC ⊤
  frefl f base-funs a = do

     ty ← getType f
     ty ← withReconstructed $ dontReduceDefs base-funs $ normalise ty
     te ← withReconstructed $ getDefinition f >>= λ where
           (function cs) → return $ pat-lam cs []
           _ → return unknown
     te ← pat-lam-norm te base-funs
     q ← quoteTC te
     unify a q

  fty : Name → List Name → Term → TC ⊤
  fty f base-funs a = do
     ty ← getType f
     ty ← withReconstructed $ dontReduceDefs base-funs $ normalise ty
     q ← quoteTC ty
     unify a q

  -- XXX We can generalise this to List of names, then the local function can be
  -- at arbitrary depth.
  frefl2 : Name → String → Term → TC ⊤
  frefl2 f na a = do
     td ← withReconstructed $ getDefinition f
     just te ← to-pat-lam td where _ → typeError [ strErr "ERROR₁" ]
     te ← pat-lam-norm te []
     --te ← normalise te
     case (ann $ do-get-defn na {⟨term⟩} te) of λ where
       (nothing) → typeError [ strErr "ERROR₁" ]
       (just f') → do
          td' ← withReconstructed $ getDefinition f
          just te ← to-pat-lam td' where _ → typeError [ strErr "ERROR₃" ]
          quoteTC te >>= unify a

  fty2 : Name → String → Term → TC ⊤
  fty2 f na a = do
     td ← withReconstructed $ getDefinition f
     just te ← to-pat-lam td where _ → typeError [ strErr "ERROR₁" ]
     te ← pat-lam-norm te []
     --te ← normalise te
     case (ann $ do-get-defn na {⟨term⟩} te) of λ where
       (nothing) → typeError [ strErr "ERROR₁" ]
       (just f') → do
          ty ← getType f'
          ty ← withReconstructed $ normalise ty
          quoteTC ty >>= unify a
-}


module datatype-functions where
open import lib
open import ctxt
open import syntax-util
open import general-util
open import cedille-types
open import subst
open import rename
open import is-free

data indx : Set where
  Index : var → tk → indx
indices = 𝕃 indx

data datatype : Set where
  Data : var → params → indices → ctrs → datatype

{-# TERMINATING #-}
decompose-arrows : ctxt → type → params × type
decompose-arrows Γ (Abs pi me pi' x atk T) =
  let x' = fresh-var-new Γ x in
  case decompose-arrows (ctxt-var-decl x' Γ) (rename-var Γ x x' T) of λ where
    (ps , T') → Decl posinfo-gen posinfo-gen me x' atk posinfo-gen :: ps , T'
decompose-arrows Γ (TpArrow T me T') =
  let x = fresh-var-new Γ "x" in
  case decompose-arrows (ctxt-var-decl x Γ) T' of λ where
    (ps , T'') → Decl posinfo-gen posinfo-gen me x (Tkt T) posinfo-gen :: ps , T''
decompose-arrows Γ (TpParens pi T pi') = decompose-arrows Γ T
decompose-arrows Γ T = [] , T

decompose-ctr-type : ctxt → type → type × params × 𝕃 tty
decompose-ctr-type Γ T with decompose-arrows Γ T
...| ps , Tᵣ with decompose-tpapps Tᵣ
...| Tₕ , as = Tₕ , ps , as

{-# TERMINATING #-}
kind-to-indices : ctxt → kind → indices
kind-to-indices Γ (KndArrow k k') =
  let x' = fresh-var-new Γ "x" in
  Index x' (Tkk k) :: kind-to-indices (ctxt-var-decl x' Γ) k'
kind-to-indices Γ (KndParens pi k pi') = kind-to-indices Γ k
kind-to-indices Γ (KndPi pi pi' x atk k) =
  let x' = fresh-var-new Γ x in
  Index x' atk :: kind-to-indices (ctxt-var-decl x' Γ) (rename-var Γ x x' k)
kind-to-indices Γ (KndTpArrow T k) =
  let x' = fresh-var-new Γ "x" in
  Index x' (Tkt T) :: kind-to-indices (ctxt-var-decl x' Γ) k
kind-to-indices Γ (KndVar pi x as) with ctxt-lookup-kind-var-def Γ x
...| nothing = []
...| just (ps , k) = kind-to-indices Γ $ fst $ subst-params-args Γ ps as k
kind-to-indices Γ (Star pi) = []

tk-erased : tk → maybeErased → maybeErased
tk-erased (Tkk _) me = Erased
tk-erased (Tkt _) me = me

params-set-erased : maybeErased → params → params
params-set-erased me = map λ where
  (Decl pi pi' me' x atk pi'') → Decl pi pi' me x atk pi''

args-set-erased : maybeErased → args → args
args-set-erased = map ∘ arg-set-erased

indices-to-kind : indices → kind → kind
indices-to-kind = flip $ foldr λ {(Index x atk) → KndPi posinfo-gen posinfo-gen x atk}

params-to-kind : params → kind → kind
params-to-kind = flip $ foldr λ {(Decl pi pi' me x atk pi'') → KndPi pi pi' x atk}

indices-to-tplams : indices → (body : type) → type
indices-to-tplams = flip $ foldr λ where
  (Index x atk) → TpLambda posinfo-gen posinfo-gen x atk

params-to-tplams : params → (body : type) → type
params-to-tplams = flip $ foldr λ where
  (Decl pi pi' me x atk pi'') → TpLambda pi pi' x atk

indices-to-alls : indices → (body : type) → type
indices-to-alls = flip $ foldr λ where
  (Index x atk) → Abs posinfo-gen Erased posinfo-gen x atk

params-to-alls : params → (body : type) → type
params-to-alls = flip $ foldr λ where
  (Decl pi pi' me x atk pi'') → Abs pi (tk-erased atk me) pi' x atk

indices-to-lams : indices → (body : term) → term
indices-to-lams = flip $ foldr λ where
  (Index x atk) → Lam posinfo-gen Erased posinfo-gen x (SomeClass atk)

indices-to-lams' : indices → (body : term) → term
indices-to-lams' = flip $ foldr λ where
  (Index x atk) → Lam posinfo-gen Erased posinfo-gen x NoClass

params-to-lams : params → (body : term) → term
params-to-lams = flip $ foldr λ where
  (Decl pi pi' me x atk pi'') → Lam pi (tk-erased atk me) pi' x (SomeClass atk)

params-to-lams' : params → (body : term) → term
params-to-lams' = flip $ foldr λ where
  (Decl pi pi' me x atk pi'') → Lam pi (tk-erased atk me) pi' x NoClass

indices-to-apps : indices → (body : term) → term
indices-to-apps = flip $ foldl λ where
  (Index x (Tkt T)) t → App t Erased (mvar x)
  (Index x (Tkk k)) t → AppTp t (mtpvar x)

params-to-apps : params → (body : term) → term
params-to-apps = flip $ foldl λ where
  (Decl pi pi' me x (Tkt T) pi'') t → App t me (mvar x)
  (Decl pi pi' me x (Tkk k) pi'') t → AppTp t (mtpvar x)

indices-to-tpapps : indices → (body : type) → type
indices-to-tpapps = flip $ foldl λ where
  (Index x (Tkt T)) T' → TpAppt T' (mvar x)
  (Index x (Tkk k)) T  → TpApp  T  (mtpvar x)

params-to-tpapps : params → (body : type) → type
params-to-tpapps = flip $ foldl λ where
  (Decl pi pi' me x (Tkt T) pi'') T' → TpAppt T' (mvar x)
  (Decl pi pi' me x (Tkk k) pi'') T  → TpApp  T  (mtpvar x)

ctrs-to-lams' : ctrs → (body : term) → term
ctrs-to-lams' = flip $ foldr λ where
  (Ctr _ x T) → Lam posinfo-gen NotErased posinfo-gen x NoClass

ctrs-to-lams : ctxt → var → params → ctrs → (body : term) → term
ctrs-to-lams Γ x ps cs t = foldr
  (λ {(Ctr _ y T) f Γ → Lam posinfo-gen NotErased posinfo-gen y
    (SomeClass $ Tkt $ subst Γ (params-to-tpapps ps $ mtpvar y) y T)
    $ f $ ctxt-var-decl y Γ})
  (λ Γ → t) cs Γ

add-indices-to-ctxt : indices → ctxt → ctxt
add-indices-to-ctxt = flip $ foldr λ {(Index x atk) → ctxt-var-decl x}

add-params-to-ctxt : params → ctxt → ctxt
add-params-to-ctxt = flip $ foldr λ {(Decl _ _ _ x'' _ _) → ctxt-var-decl x''}

add-caseArgs-to-ctxt : caseArgs → ctxt → ctxt
add-caseArgs-to-ctxt = flip $ foldr λ {(CaseTermArg _ _ x) → ctxt-var-decl x; (CaseTypeArg _ x) → ctxt-var-decl x}

add-ctrs-to-ctxt : ctrs → ctxt → ctxt
add-ctrs-to-ctxt = flip $ foldr λ {(Ctr _ x T) → ctxt-var-decl x}

positivity : Set
positivity = 𝔹 × 𝔹 -- occurs positively × occurs negatively

pattern occurs-nil = ff , ff
pattern occurs-pos = tt , ff
pattern occurs-neg = ff , tt
pattern occurs-all = tt , tt

--positivity-inc : positivity → positivity
--positivity-dec : positivity → positivity
positivity-neg : positivity → positivity
positivity-add : positivity → positivity → positivity

--positivity-inc = map-fst λ _ → tt
--positivity-dec = map-snd λ _ → tt
positivity-neg = uncurry $ flip _,_
positivity-add (+ₘ , -ₘ) (+ₙ , -ₙ) = (+ₘ || +ₙ) , (-ₘ || -ₙ)

-- just tt = negative occurrence; just ff = not in the return type; nothing = okay
{-# TERMINATING #-}
ctr-positive : ctxt → var → type → maybe 𝔹
ctr-positive Γ x = arrs+ Γ ∘ hnf' Γ where

  open import conversion

  not-free : ∀ {ed} → ⟦ ed ⟧ → maybe 𝔹
  not-free = maybe-map (λ _ → tt) ∘' maybe-if ∘' is-free-in check-erased x

  if-free : ∀ {ed} → ⟦ ed ⟧ → positivity
  if-free t with is-free-in check-erased x t
  ...| f = f , f

  hnf' : ctxt → type → type
  hnf' Γ T = hnf Γ unfold-all T tt

  mtt = maybe-else tt id
  mff = maybe-else ff id

  posₒ = fst
  negₒ = snd

  occurs : positivity → maybe 𝔹
  occurs p = maybe-if (negₒ p) ≫maybe just tt

  arrs+ : ctxt → type → maybe 𝔹
  type+ : ctxt → type → positivity
  kind+ : ctxt → kind → positivity
  tk+ : ctxt → tk → positivity

  arrs+ Γ (Abs _ _ _ x' atk T) =
    let Γ' = ctxt-var-decl x' Γ in
    occurs (tk+ Γ atk) maybe-or arrs+ Γ' (hnf' Γ' T)
  arrs+ Γ (TpApp T T') = arrs+ Γ T maybe-or not-free T'
  arrs+ Γ (TpAppt T t) = arrs+ Γ T maybe-or not-free t
  arrs+ Γ (TpArrow T _ T') = occurs (type+ Γ (hnf' Γ T)) maybe-or arrs+ Γ (hnf' Γ T')
  arrs+ Γ (TpLambda _ _ x' atk T) =
    let Γ' = ctxt-var-decl x' Γ in
    occurs (tk+ Γ atk) maybe-or arrs+ Γ' (hnf' Γ' T)
  arrs+ Γ (TpVar _ x') = maybe-not (maybe-if (x =string x')) ≫maybe just ff
  arrs+ Γ T = just ff

  type+ Γ (Abs _ _ _ x' atk T) =
    let Γ' = ctxt-var-decl x' Γ; atk+? = tk+ Γ atk in
    positivity-add (positivity-neg $ tk+ Γ atk) (type+ Γ' $ hnf' Γ' T)
  type+ Γ (Iota _ _ x' T T') =
    let Γ' = ctxt-var-decl x' Γ; T? = type+ Γ T in
    positivity-add (type+ Γ T) (type+ Γ' T')
  type+ Γ (Lft _ _ x' t lT) = occurs-all
  type+ Γ (NoSpans T _) = type+ Γ T
  type+ Γ (TpLet _ (DefTerm _ x' T? t) T) = type+ Γ (hnf' Γ (subst Γ t x' T))
  type+ Γ (TpLet _ (DefType _ x' k T) T') = type+ Γ (hnf' Γ (subst Γ T x' T'))
  type+ Γ (TpApp T T') = positivity-add (type+ Γ T) (if-free T')
  type+ Γ (TpAppt T t) = positivity-add (type+ Γ T) (if-free t)
  type+ Γ (TpArrow T _ T') = positivity-add (positivity-neg $ type+ Γ T) (type+ Γ $ hnf' Γ T')
  type+ Γ (TpEq _ tₗ tᵣ _) = occurs-nil
  type+ Γ (TpHole _) = occurs-nil
  type+ Γ (TpLambda _ _ x' atk T)=
    let Γ' = ctxt-var-decl x' Γ in
    positivity-add (positivity-neg $ tk+ Γ atk) (type+ Γ' (hnf' Γ' T))
  type+ Γ (TpParens _ T _) = type+ Γ T
  type+ Γ (TpVar _ x') = x =string x' , ff

  kind+ Γ (KndArrow k k') = positivity-add (positivity-neg $ kind+ Γ k) (kind+ Γ k')
  kind+ Γ (KndParens _ k _) = kind+ Γ k
  kind+ Γ (KndPi _ _ x' atk k) =
    let Γ' = ctxt-var-decl x' Γ in
    positivity-add (positivity-neg $ tk+ Γ atk) (kind+ Γ' k)
  kind+ Γ (KndTpArrow T k) = positivity-add (positivity-neg $ type+ Γ T) (kind+ Γ k)
  kind+ Γ (KndVar _ κ as) =
    maybe-else' (ctxt-lookup-kind-var-def Γ κ) occurs-nil $ uncurry λ ps k → kind+ Γ (fst (subst-params-args Γ ps as k))
  kind+ Γ (Star _) = occurs-nil

  tk+ Γ (Tkt T) = type+ Γ (hnf' Γ T)
  tk+ Γ (Tkk k) = kind+ Γ k


{-# OPTIONS -v tc.lhs:50 #-}
{-# OPTIONS -v tc.coverage:50 #-}

open import Agda.Builtin.String

test : String → String
test x@"foo" = "bar"
test x       = x


{-# OPTIONS --safe #-}

module Definition.Conversion.Symmetry where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Conversion
open import Definition.Conversion.Stability
open import Definition.Conversion.Soundness
open import Definition.Conversion.Conversion
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.Equality
open import Definition.Typed.Consequences.Reduction
open import Definition.Typed.Consequences.Injectivity
open import Definition.Typed.Consequences.Substitution
open import Definition.Typed.Consequences.SucCong

open import Tools.Product
import Tools.PropositionalEquality as PE

mutual
  -- Symmetry of algorithmic equality of neutrals
  sym~↑! : ∀ {t u A Γ Δ l} → ⊢ Γ ≡ Δ
        → Γ ⊢ t ~ u ↑! A ^ l
        → ∃ λ B → Γ ⊢ A ≡ B ^ [ ! , l ]  × Δ ⊢ u ~ t ↑! B ^ l
  sym~↑! Γ≡Δ (var-refl x x≡y) =
    let ⊢A = syntacticTerm x
    in  _ , refl ⊢A
     ,  var-refl (PE.subst (λ y → _ ⊢ var y ∷ _ ^ _) x≡y (stabilityTerm Γ≡Δ x))
                 (PE.sym x≡y)
  sym~↑! Γ≡Δ (app-cong {rF = !} t~u x) =
    let ⊢Γ , ⊢Δ , _ = contextConvSubst Γ≡Δ
        B , whnfB , A≡B , u~t = sym~↓! Γ≡Δ t~u
        F′ , G′ , ΠF′G′≡B = Π≡A A≡B whnfB
        F≡F′ , rF≡rF′ , lF≡lF' , lG≡lG' , G≡G′ = injectivity (PE.subst (λ x → _ ⊢ _ ≡ x ^ _) ΠF′G′≡B A≡B)
    in  _ , substTypeEq G≡G′ (soundnessConv↑Term x)
    ,   app-cong (PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) ΠF′G′≡B u~t)
                 (convConvTerm (symConv↑Term Γ≡Δ x) (stabilityEq Γ≡Δ F≡F′))
  sym~↑! Γ≡Δ (app-cong {rF = %} t~u x) =
    let ⊢Γ , ⊢Δ , _ = contextConvSubst Γ≡Δ
        B , whnfB , A≡B , u~t = sym~↓! Γ≡Δ t~u
        F′ , G′ , ΠF′G′≡B = Π≡A A≡B whnfB
        F≡F′ , rF≡rF′ , lF≡lF' , lG≡lG' , G≡G′ = injectivity (PE.subst (λ x → _ ⊢ _ ≡ x ^ _) ΠF′G′≡B A≡B)
    in  _ , substTypeEq G≡G′ (proj₂ (proj₂ (soundness~↑% x)))
    ,   app-cong (PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) ΠF′G′≡B u~t)
                 (sym~↑% Γ≡Δ (conv~↑% x (stabilityEq (reflConEq ⊢Γ) F≡F′)))
  sym~↑! Γ≡Δ (natrec-cong x x₁ x₂ t~u) =
    let ⊢Γ , ⊢Δ , _ = contextConvSubst Γ≡Δ
        B , whnfB , A≡B , u~t = sym~↓! Γ≡Δ t~u
        B≡ℕ = ℕ≡A A≡B whnfB
        F≡G = stabilityEq (Γ≡Δ ∙ refl (univ (ℕⱼ ⊢Γ))) (soundnessConv↑ x)
        F[0]≡G[0] = substTypeEq F≡G (refl (zeroⱼ ⊢Δ))
    in  _ , substTypeEq (soundnessConv↑ x) (soundness~↓! t~u)
    ,   natrec-cong (symConv↑ (Γ≡Δ ∙ (refl (univ (ℕⱼ ⊢Γ)))) x)
                    (convConvTerm (symConv↑Term Γ≡Δ x₁) F[0]≡G[0])
                    (convConvTerm (symConv↑Term Γ≡Δ x₂) (sucCong F≡G))
                    (PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡ℕ u~t)
  sym~↑! Γ≡Δ (Emptyrec-cong x t~u) =
    let ⊢Γ , ⊢Δ , _ = contextConvSubst Γ≡Δ
        u~t = sym~↑% Γ≡Δ t~u
        -- F≡G = stabilityEq Γ≡Δ (soundnessConv↑ x)
    in  _ , soundnessConv↑ x
    , Emptyrec-cong (symConv↑ Γ≡Δ x) u~t
  sym~↑! Γ≡Δ (Id-cong X x x₁) =
    let ⊢Γ , ⊢Δ , _ = contextConvSubst Γ≡Δ
        B , whnfB , A≡B , u~t = sym~↓! Γ≡Δ X
        U≡B = U≡A-whnf A≡B whnfB
        A'≡A = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) U≡B u~t
    in _ , refl (Ugenⱼ ⊢Γ) , Id-cong A'≡A
                                     (convConvTerm (symConv↑Term Γ≡Δ x) (univ (soundness~↓! (stability~↓! Γ≡Δ X))))
                                     (convConvTerm (symConv↑Term Γ≡Δ x₁) (univ (soundness~↓! (stability~↓! Γ≡Δ X))))
  sym~↑! Γ≡Δ (Id-ℕ X x) =
    let ⊢Γ , ⊢Δ , _ = contextConvSubst Γ≡Δ
        B , whnfB , A≡B , u~t = sym~↓! Γ≡Δ X
        U≡B = ℕ≡A A≡B whnfB
        A'≡A = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) U≡B u~t
    in _ , refl (Ugenⱼ ⊢Γ) , Id-ℕ A'≡A (symConv↑Term Γ≡Δ x)
  sym~↑! Γ≡Δ (Id-ℕ0 X) =
    let ⊢Γ , ⊢Δ , _ = contextConvSubst Γ≡Δ
        B , whnfB , A≡B , u~t = sym~↓! Γ≡Δ X
        U≡B = ℕ≡A A≡B whnfB
        A'≡A = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) U≡B u~t
    in _ , refl (Ugenⱼ ⊢Γ) , Id-ℕ0 A'≡A
  sym~↑! Γ≡Δ (Id-ℕS x X) =
    let ⊢Γ , ⊢Δ , _ = contextConvSubst Γ≡Δ
        B , whnfB , A≡B , u~t = sym~↓! Γ≡Δ X
        U≡B = ℕ≡A A≡B whnfB
        A'≡A = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) U≡B u~t
    in _ , refl (Ugenⱼ ⊢Γ) , Id-ℕS (symConv↑Term Γ≡Δ x) A'≡A
  sym~↑! Γ≡Δ (Id-U X x) =
    let ⊢Γ , ⊢Δ , _ = contextConvSubst Γ≡Δ
        B , whnfB , A≡B , u~t = sym~↓! Γ≡Δ X
        U≡B = U≡A-whnf A≡B whnfB
        A'≡A = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) U≡B u~t
    in _ , refl (Ugenⱼ ⊢Γ) , Id-U A'≡A (symConv↑Term Γ≡Δ x)
  sym~↑! Γ≡Δ (Id-Uℕ X) =
    let ⊢Γ , ⊢Δ , _ = contextConvSubst Γ≡Δ
        B , whnfB , A≡B , u~t = sym~↓! Γ≡Δ X
        U≡B = U≡A-whnf A≡B whnfB
        A'≡A = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) U≡B u~t
    in _ , refl (Ugenⱼ ⊢Γ) , Id-Uℕ A'≡A
  sym~↑! Γ≡Δ (Id-UΠ x X) =
    let ⊢Γ , ⊢Δ , _ = contextConvSubst Γ≡Δ
        B , whnfB , A≡B , u~t = sym~↓! Γ≡Δ X
        U≡B = U≡A-whnf A≡B whnfB
        A'≡A = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) U≡B u~t
    in _ , refl (Ugenⱼ ⊢Γ) , Id-UΠ (symConv↑Term Γ≡Δ x) A'≡A
  sym~↑! Γ≡Δ (cast-cong X x x₁ x₂ x₃) =
      let U , whnfU , U≡U' , A'~A = sym~↓! Γ≡Δ X
          B'~B = symConv↑Term Γ≡Δ x
          U≡B = U≡A-whnf U≡U' whnfU
          A'≡A = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) U≡B A'~A
      in
          _ , univ (soundnessConv↑Term x), cast-cong A'≡A B'~B
                                                     (convConvTerm (symConv↑Term Γ≡Δ x₁) (univ (soundness~↓! (stability~↓! Γ≡Δ X))))
                                                     (stabilityTerm Γ≡Δ x₃) (stabilityTerm Γ≡Δ x₂)
  sym~↑! Γ≡Δ (cast-ℕ X x x₁ x₂) =
      let U , whnfU , U≡U' , A'~A = sym~↓! Γ≡Δ X
          B'~B = symConv↑Term Γ≡Δ x
          U≡B = U≡A-whnf U≡U' whnfU
          A'≡A = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) U≡B A'~A
      in _ , univ (soundness~↓! X) , cast-ℕ A'≡A (symConv↑Term Γ≡Δ x) (stabilityTerm Γ≡Δ x₂) (stabilityTerm Γ≡Δ x₁)
  sym~↑! Γ≡Δ (cast-ℕℕ X x x₁) =
      let ⊢Γ , ⊢Δ , _ = contextConvSubst Γ≡Δ
          N , whnfN , N≡N' , t'~t = sym~↓! Γ≡Δ X
          ℕ≡B = ℕ≡A N≡N' whnfN
          t'≡t = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) ℕ≡B t'~t
      in _ , refl (univ (ℕⱼ ⊢Γ)) , cast-ℕℕ t'≡t (stabilityTerm Γ≡Δ x₁) (stabilityTerm Γ≡Δ x)
  sym~↑! Γ≡Δ (cast-Π x X x₁ x₂ x₃) =
      let U , whnfU , U≡U' , A'~A = sym~↓! Γ≡Δ X
          B'~B = symConv↑Term Γ≡Δ x
          U≡B = U≡A-whnf U≡U' whnfU
          A'≡A = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) U≡B A'~A
      in _ , univ (soundness~↓! X) , cast-Π B'~B A'≡A
                                            (convConvTerm (symConv↑Term Γ≡Δ x₁) (univ (soundnessConv↑Term (stabilityConv↑Term Γ≡Δ x))))
                                            (stabilityTerm Γ≡Δ x₃) (stabilityTerm Γ≡Δ x₂)
  sym~↑! Γ≡Δ (cast-Πℕ x x₁ x₂ x₃) =
      let ⊢Γ , ⊢Δ , _ = contextConvSubst Γ≡Δ
      in _ , refl (univ (ℕⱼ ⊢Γ)) , cast-Πℕ (symConv↑Term Γ≡Δ x)
                                           (convConvTerm (symConv↑Term Γ≡Δ x₁) (univ (soundnessConv↑Term (stabilityConv↑Term Γ≡Δ x))))
                                           (stabilityTerm Γ≡Δ x₃) (stabilityTerm Γ≡Δ x₂)
  sym~↑! Γ≡Δ (cast-ℕΠ x x₁ x₂ x₃) = _ , univ (soundnessConv↑Term x) , cast-ℕΠ (symConv↑Term Γ≡Δ x) (symConv↑Term Γ≡Δ x₁)
                                                                              (stabilityTerm Γ≡Δ x₃) (stabilityTerm Γ≡Δ x₂)
  sym~↑! Γ≡Δ (cast-ΠΠ%! x x₁ x₂ x₃ x₄) = _ , univ (soundnessConv↑Term x₁) ,
                                         cast-ΠΠ%! (symConv↑Term Γ≡Δ x) (symConv↑Term Γ≡Δ x₁)
                                                   (convConvTerm (symConv↑Term Γ≡Δ x₂) (univ (soundnessConv↑Term (stabilityConv↑Term Γ≡Δ x))))
                                                   (stabilityTerm Γ≡Δ x₄) (stabilityTerm Γ≡Δ x₃)
  sym~↑! Γ≡Δ (cast-ΠΠ!% x x₁ x₂ x₃ x₄) = _ , univ (soundnessConv↑Term x₁) ,
                                         cast-ΠΠ!% (symConv↑Term Γ≡Δ x) (symConv↑Term Γ≡Δ x₁)
                                                   (convConvTerm (symConv↑Term Γ≡Δ x₂) (univ (soundnessConv↑Term (stabilityConv↑Term Γ≡Δ x))))
                                                   (stabilityTerm Γ≡Δ x₄) (stabilityTerm Γ≡Δ x₃)

  sym~↑% : ∀ {t u A Γ Δ l} → ⊢ Γ ≡ Δ
         → Γ ⊢ t ~ u ↑% A ^ l
         → Δ ⊢ u ~ t ↑% A ^ l
  sym~↑% Γ≡Δ (%~↑ ⊢k ⊢l) = %~↑ (stabilityTerm Γ≡Δ ⊢l) (stabilityTerm Γ≡Δ ⊢k)

  sym~↑ : ∀ {t u A rA Γ Δ l} → ⊢ Γ ≡ Δ
        → Γ ⊢ t ~ u ↑ A ^ [ rA , l ]
        → ∃ λ B → Γ ⊢ A ≡ B ^ [ rA , l ] × Δ ⊢ u ~ t ↑ B ^ [ rA , l ]
  sym~↑ Γ≡Δ (~↑! x) =
    let B , A≡B , x′ = sym~↑! Γ≡Δ x
    in B , A≡B , ~↑! x′
  sym~↑ {A = A} Γ≡Δ (~↑% x) =
    let x′ = sym~↑% Γ≡Δ x
        ⊢A , _ , _ = syntacticEqTerm (proj₂ (proj₂ (soundness~↑% x)))
    in A , refl ⊢A , ~↑% x′

  -- Symmetry of algorithmic equality of neutrals of types in WHNF.
  sym~↓! : ∀ {t u A Γ Δ l} → ⊢ Γ ≡ Δ → Γ ⊢ t ~ u ↓! A ^ l
         → ∃ λ B → Whnf B × Γ ⊢ A ≡ B ^ [ ! , l ] × Δ ⊢ u ~ t ↓! B ^ l
  sym~↓! Γ≡Δ ([~] A₁ D whnfA k~l) =
    let B , A≡B , k~l′ = sym~↑! Γ≡Δ k~l
        _ , ⊢B = syntacticEq A≡B
        B′ , whnfB′ , D′ = whNorm ⊢B
        A≡B′ = trans (sym (subset* D)) (trans A≡B (subset* (red D′)))
    in  B′ , whnfB′ , A≡B′ , [~] B (stabilityRed* Γ≡Δ (red D′)) whnfB′ k~l′

  -- Symmetry of algorithmic equality of types.
  symConv↑ : ∀ {A B r Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ A [conv↑] B ^ r → Δ ⊢ B [conv↑] A ^ r
  symConv↑ Γ≡Δ ([↑] A′ B′ D D′ whnfA′ whnfB′ A′<>B′) =
    [↑] B′ A′ (stabilityRed* Γ≡Δ D′) (stabilityRed* Γ≡Δ D) whnfB′ whnfA′
        (symConv↓ Γ≡Δ A′<>B′)

  -- Symmetry of algorithmic equality of types in WHNF.
  symConv↓ : ∀ {A B r Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ A [conv↓] B ^ r → Δ ⊢ B [conv↓] A ^ r
  symConv↓ Γ≡Δ (U-refl PE.refl x) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  U-refl PE.refl ⊢Δ
  symConv↓ Γ≡Δ (univ x) = univ (symConv↓Term Γ≡Δ x)

  -- Symmetry of algorithmic equality of terms.
  symConv↑Term : ∀ {t u A Γ Δ l} → ⊢ Γ ≡ Δ → Γ ⊢ t [conv↑] u ∷ A ^ l → Δ ⊢ u [conv↑] t ∷ A ^ l
  symConv↑Term Γ≡Δ ([↑]ₜ B t′ u′ D d d′ whnfB whnft′ whnfu′ t<>u) =
    [↑]ₜ B u′ t′ (stabilityRed* Γ≡Δ D) (stabilityRed*Term Γ≡Δ d′)
         (stabilityRed*Term Γ≡Δ d) whnfB whnfu′ whnft′ (symConv↓Term Γ≡Δ t<>u)

  -- Symmetry of algorithmic equality of terms in WHNF.
  symConv↓Term : ∀ {t u A Γ Δ l} → ⊢ Γ ≡ Δ → Γ ⊢ t [conv↓] u ∷ A ^ l  → Δ ⊢ u [conv↓] t ∷ A ^ l
  symConv↓Term Γ≡Δ (U-refl x x₁) =
      let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ in U-refl (PE.sym x) ⊢Δ
  symConv↓Term Γ≡Δ (ne t~u) =
    let ⊢Γ , ⊢Δ , _ = contextConvSubst Γ≡Δ
        B , whnfB , A≡B , u~t = sym~↓! Γ≡Δ t~u
        U≡B = U≡A-whnf A≡B whnfB
    in ne (PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) U≡B (proj₂ (proj₂ (proj₂ (sym~↓! Γ≡Δ t~u)))))
  symConv↓Term Γ≡Δ (ℕ-refl x) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  ℕ-refl ⊢Δ
  symConv↓Term Γ≡Δ (Empty-refl x _) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  Empty-refl x ⊢Δ
  symConv↓Term Γ≡Δ (∃-cong PE.refl x A<>B A<>B₁) =
    let F≡H = soundnessConv↑Term A<>B
        _ , ⊢H = syntacticEq (stabilityEq Γ≡Δ (univ F≡H))
    in ∃-cong PE.refl ⊢H (symConv↑Term Γ≡Δ A<>B)
                 (symConv↑Term (Γ≡Δ ∙ univ F≡H) A<>B₁)
  symConv↓Term Γ≡Δ (Π-cong PE.refl PE.refl PE.refl PE.refl l< l<' x A<>B A<>B₁) =
    let F≡H = soundnessConv↑Term A<>B
        _ , ⊢H = syntacticEq (stabilityEq Γ≡Δ (univ F≡H))
    in  Π-cong PE.refl PE.refl PE.refl PE.refl l< l<' ⊢H (symConv↑Term Γ≡Δ A<>B)
                  (symConv↑Term (Γ≡Δ ∙ univ F≡H) A<>B₁)
  symConv↓Term Γ≡Δ (ℕ-ins t~u) =
    let B , whnfB , A≡B , u~t = sym~↓! Γ≡Δ t~u
        B≡ℕ = ℕ≡A A≡B whnfB
    in  ℕ-ins (PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡ℕ u~t)
  symConv↓Term Γ≡Δ (ne-ins t u x t~u) =
    let B , whnfB , A≡B , u~t = sym~↓! Γ≡Δ t~u
    in  ne-ins (stabilityTerm Γ≡Δ u) (stabilityTerm Γ≡Δ t) x u~t
  symConv↓Term Γ≡Δ (zero-refl x) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  zero-refl ⊢Δ
  symConv↓Term Γ≡Δ (suc-cong t<>u) = suc-cong (symConv↑Term Γ≡Δ t<>u)
  symConv↓Term Γ≡Δ (η-eq l< l<' x x₁ x₂ y y₁ t<>u) =
    η-eq l<  l<' (stability Γ≡Δ x) (stabilityTerm Γ≡Δ x₂) (stabilityTerm Γ≡Δ x₁)
         y₁ y (symConv↑Term (Γ≡Δ ∙ refl x) t<>u)

-- Symmetry of algorithmic equality of types with preserved context.
symConv : ∀ {A B r Γ} → Γ ⊢ A [conv↑] B ^ r → Γ ⊢ B [conv↑] A ^ r
symConv A<>B =
  let ⊢Γ = wfEq (soundnessConv↑ A<>B)
  in  symConv↑ (reflConEq ⊢Γ) A<>B

-- Symmetry of algorithmic equality of terms with preserved context.
symConvTerm : ∀ {t u A Γ l} → Γ ⊢ t [conv↑] u ∷ A ^ l → Γ ⊢ u [conv↑] t ∷ A ^ l
symConvTerm t<>u =
  let ⊢Γ = wfEqTerm (soundnessConv↑Term t<>u)
  in  symConv↑Term (reflConEq ⊢Γ) t<>u


module rewriting where

open import cedille-types
open import constants
open import conversion
open import ctxt
open import general-util
open import free-vars
--open import lift
open import rename
open import subst
open import syntax-util
open import type-util
--open import erase
open import datatype-util

rewrite-mk-phi : var → (eq t t' : term) → term
rewrite-mk-phi x eq t t' =
  Phi (Rho (VarSigma eq) x (TpEq t t') (Beta t id-term)) t t'

rewrite-t : Set → Set
rewrite-t T = ctxt → (is-plus : 𝔹) → (nums : maybe stringset) → (eq : maybe term) →
              (left : term) → (right : var) → (total-matches : ℕ) →
              T {- Returned value -} ×
              ℕ {- Number of rewrites actually performed -} ×
              ℕ {- Total number of matches, including skipped ones -}

instance
  rewrite-functor : functor rewrite-t
  rewrite-applicative : applicative rewrite-t
  rewrite-monad : monad rewrite-t

  fmap ⦃ rewrite-functor ⦄ g r Γ op on eq t₁ t₂ n with r Γ op on eq t₁ t₂ n
  ...| a , n' , sn = g a , n' , sn

  pure ⦃ rewrite-applicative ⦄ a Γ p on eq t₁ t₂ n = a , 0 , n
  _<*>_ ⦃ rewrite-applicative ⦄ f a Γ op on eq t₁ t₂ n with f Γ op on eq t₁ t₂ n
  ...| f' , n' , sn with a Γ op on eq t₁ t₂ sn
  ...| b , n'' , sn' = f' b , n' + n'' , sn'

  return ⦃ rewrite-monad ⦄ a = pure a
  _>>=_ ⦃ rewrite-monad ⦄ fa fab Γ op on eq t₁ t₂ n with fa Γ op on eq t₁ t₂ n
  ...| a' , n' , sn with fab a' Γ op on eq t₁ t₂ sn
  ...| b , n'' , sn' = b , n' + n'' , sn'

infixl 4 _≫rewrite_
_≫rewrite_ = _<*>_

{-# TERMINATING #-}
rewrite-term  : term → rewrite-t term
rewrite-terma : term → rewrite-t term
rewrite-termh : term → rewrite-t term
rewrite-type  : type → rewrite-t type
rewrite-typeh : type → rewrite-t type
rewrite-kind  : kind → rewrite-t kind
rewrite-tpkd  : tpkd → rewrite-t tpkd
rewrite-tmtp  : tmtp → rewrite-t tmtp
rewrite-exprd : ∀ {ed} → ⟦ ed ⟧ → rewrite-t ⟦ ed ⟧
rewrite-case  : maybe (var × var) → case → rewrite-t case

rewrite-exprd {TERM} = rewrite-term
rewrite-exprd {TYPE} = rewrite-type
rewrite-exprd {KIND} = rewrite-kind

rewrite-rename-var : ∀ {A} → var → (var → rewrite-t A) → rewrite-t A
rewrite-rename-var x r Γ op on eq t₁ t₂ n =
  let x' = rename-var-if Γ (renamectxt-insert empty-renamectxt t₂ t₂) x t₁ in
  r x' Γ op on eq t₁ t₂ n

rewrite-abs : ∀ {ed} → var → var → (⟦ ed ⟧ → rewrite-t ⟦ ed ⟧) → ⟦ ed ⟧ → rewrite-t ⟦ ed ⟧
rewrite-abs x x' g a Γ = let Γ = ctxt-var-decl x' Γ in g (rename-var Γ x x' a) Γ

rewrite-term t Γ op on eq t₁ t₂ sn =
  case rewrite-terma (erase t) Γ op on eq t₁ t₂ sn of λ where
    (t' , 0 , sn') → t , 0 , sn'
    (t' , n , sn') → maybe-else' eq t' (λ eq → rewrite-mk-phi t₂ eq t t') , n , sn'

rewrite-terma t Γ op on eq t₁ t₂ sn =
  case conv-term Γ t t₁ of λ where
  tt → case on of λ where
    (just ns) → case trie-contains ns (ℕ-to-string (suc sn)) of λ where
      tt → Var t₂ , 1 , suc sn -- ρ nums contains n
      ff → t , 0 , suc sn -- ρ nums does not contain n
    nothing → Var t₂ , 1 , suc sn
  ff → case op of λ where
    tt → case rewrite-termh (hnf Γ unfold-head t) Γ op on eq t₁ t₂ sn of λ where
      (t' , 0 , sn') → t , 0 , sn' -- if no rewrites were performed, return the pre-hnf t
      (t' , n' , sn') → t' , n' , sn'
    ff → rewrite-termh t Γ op on eq t₁ t₂ sn

rewrite-termh (App t t') =
  pure App <*> rewrite-terma t <*> rewrite-terma t'
rewrite-termh (Lam NotErased y nothing t) =
  rewrite-rename-var y λ y' → pure (Lam NotErased y' nothing) <*>
  rewrite-abs y y' rewrite-terma t
rewrite-termh (Var x) = pure (Var x)
rewrite-termh (LetTm ff x nothing t t') Γ = rewrite-terma (subst Γ t x t') Γ
--  rewrite-rename-var x λ x' → pure (Let pi₁) <*>
--  (pure (DefTerm pi₂ x' NoType) <*> rewrite-terma t) <*>
--  rewrite-abs x x' rewrite-terma t'
-- ^^^ Need to DEFINE "x" as "hnf Γ unfold-head t tt", not just declare it!
--     We may instead simply rewrite t' after substituting t for x
rewrite-termh (Mu x t nothing t~ ms) =
  rewrite-rename-var x λ x' →
  pure (Mu x') <*>
  rewrite-terma t <*>
  pure nothing <*>
  pure t~ <*>
  foldr (λ c r → pure _::_ <*> rewrite-case (just $ x , x') c <*> r)
    (pure []) ms
rewrite-termh (Sigma tᵢ t nothing t~ ms) =
  pure (Sigma tᵢ) <*>
  rewrite-terma t <*>
  pure nothing <*>
  pure t~ <*>
  foldr (λ c r → pure _::_ <*> rewrite-case nothing c <*> r)
    (pure []) ms
rewrite-termh = pure

rewrite-case xᵣ? (Case x cas t T) =
  let f = maybe-else' xᵣ? id (uncurry rewrite-abs) rewrite-terma in
  pure (uncurry $ Case x) <*>
  foldr {B = rewrite-t case-args → (term → rewrite-t term) → rewrite-t (case-args × term)}
    (λ {(CaseArg ff x nothing) r cas fₜ →
      r (rewrite-rename-var x λ x' → pure _::_ <*> pure (CaseArg ff x' nothing) <*> cas) (λ t → rewrite-rename-var x λ x' → rewrite-abs x x' fₜ t); _ → id})
    (λ cas fₜ → pure (_,_ ∘ reverse) <*> cas <*> fₜ t) cas (pure []) f <*> return T

rewrite-type T Γ tt on eq t₁ t₂ sn
  with rewrite-typeh (hnf Γ unfold-head-elab T) Γ tt on eq t₁ t₂ sn
...| T' , 0 , sn' = T  , 0 , sn'
...| T' , n , sn' = T' , n , sn'
rewrite-type = rewrite-typeh

rewrite-typeh (TpAbs me x atk T) =
  rewrite-rename-var x λ x' →
  pure (TpAbs me x') <*> rewrite-tpkd atk <*>
  rewrite-abs x x' rewrite-type T
rewrite-typeh (TpIota x T T') =
  rewrite-rename-var x λ x' →
  pure (TpIota x') <*> rewrite-type T <*>
  rewrite-abs x x' rewrite-type T'
rewrite-typeh (TpApp T tT) =
  pure TpApp <*> rewrite-typeh T <*> rewrite-tmtp tT
rewrite-typeh (TpEq t₁ t₂) =
  pure TpEq <*> (pure erase <*> rewrite-term t₁) <*>
  (pure erase <*> rewrite-term t₂)
rewrite-typeh (TpLam x atk T) =
  rewrite-rename-var x λ x' →
  pure (TpLam x') <*> rewrite-tpkd atk <*>
  rewrite-abs x x' rewrite-type T
rewrite-typeh (TpHole pi) = pure (TpHole pi)
rewrite-typeh (TpVar x) = pure (TpVar x)

-- If we ever implement kind-level rewriting, we will need to go through
-- all the types of kind pi binding a term or type-to-kind arrow
-- if the right-hand side variable is free in the types of the bound variable,
-- and substitute each occurence of the term variable (eta-expanding if necessary)
-- in the body of the type with itself surrounded by a rewrite back the original
-- expected type (unless we lifted a term, then it gets really tricky because
-- we may not want to rewrite back?).
rewrite-kind = pure
rewrite-liftingType = pure

rewrite-tpkd (Tkt T) = pure Tkt <*> rewrite-type T
rewrite-tpkd (Tkk k) = pure Tkk <*> rewrite-kind k

rewrite-tmtp (Ttm t) = pure Ttm <*> rewrite-term t
rewrite-tmtp (Ttp T) = pure Ttp <*> rewrite-type T

post-rewrite-binder-type : ∀ {ed} → ctxt → var → term → (var → tpkd → ctxt → ctxt) → var → ⟦ ed ⟧ → type → ⟦ ed ⟧
post-rewrite-binder-type Γ x eq tk-decl x' Tₓ Tₓ' with is-free-in x Tₓ'
...| ff = Tₓ
...| tt = subst (tk-decl x' (Tkt Tₓ') Γ) (Rho eq x Tₓ' (Var x')) x' Tₓ

post-rewrite-binder-kind : ∀ {ed} → ctxt → var → term → (var → tpkd → ctxt → ctxt) → var → ⟦ ed ⟧ → kind → ⟦ ed ⟧
post-rewrite-binder-kind Γ x eq tk-decl x' Tₓ kₓ' = Tₓ

post-rewrite-binder-tk : ∀ {ed} → ctxt → var → term → (var → tpkd → ctxt → ctxt) → var → ⟦ ed ⟧ → tpkd → ⟦ ed ⟧
post-rewrite-binder-tk Γ x eq tk-decl x' Tₓ (Tkt Tₓ') =
  post-rewrite-binder-type Γ x eq tk-decl x' Tₓ Tₓ'
post-rewrite-binder-tk Γ x eq tk-decl x' Tₓ (Tkk kₓ') =
  post-rewrite-binder-kind Γ x eq tk-decl x' Tₓ kₓ'

post-rewriteh : ctxt → var → term → (ctxt → var → term → tpkd → tpkd) → (var → tpkd → ctxt → ctxt) → type → type × kind

post-rewriteh Γ x eq prtk tk-decl (TpAbs me x' atk T) =
  let atk = prtk Γ x eq atk
      T = fst $ post-rewriteh (tk-decl x' atk Γ) x eq prtk tk-decl T
      T = post-rewrite-binder-tk Γ x eq tk-decl x' T atk in
  TpAbs me x' atk T , KdStar
post-rewriteh Γ x eq prtk tk-decl (TpIota x' T T') =
  let T = fst $ post-rewriteh Γ x eq prtk tk-decl T
      T' = fst $ post-rewriteh (tk-decl x' (Tkt T) Γ) x eq prtk tk-decl T'
      T' = post-rewrite-binder-type Γ x eq tk-decl x' T' T in
  TpIota x' T T' , KdStar
post-rewriteh Γ x eq prtk tk-decl (TpApp T (Ttp T')) =
  elim-pair (post-rewriteh Γ x eq prtk tk-decl T') λ T' k' →
  elim-pair (post-rewriteh Γ x eq prtk tk-decl T) λ where
    T (KdAbs x' atk k) → TpApp T (Ttp T') , hnf Γ unfold-head-elab (subst Γ T' x' k)
    T k → TpApp T (Ttp T') , k
post-rewriteh Γ x eq prtk tk-decl (TpApp T (Ttm t)) =
  let t2 T' = if is-free-in x T' then Rho (VarSigma eq) x T' t else t in
  elim-pair (post-rewriteh Γ x eq prtk tk-decl T) λ where
    T (KdAbs x' (Tkt T') k) →
      let t3 = t2 T' in TpApp T (Ttm t3) , hnf Γ unfold-head-elab (subst Γ t3 x' k)
    T k → TpApp T (Ttm t) , k
post-rewriteh Γ x eq prtk tk-decl (TpLam x' atk T) =
  let atk = prtk Γ x eq atk in
  elim-pair (post-rewriteh (tk-decl x' atk Γ) x eq prtk tk-decl T) λ T k →
  let T = post-rewrite-binder-tk Γ x eq tk-decl x' T atk
      k = post-rewrite-binder-tk Γ x eq tk-decl x' k atk in
  TpLam x' atk T , KdAbs x' atk k
post-rewriteh Γ x eq prtk tk-decl (TpVar x') with env-lookup Γ x'
...| just (type-decl k , _) = TpVar x' , hnf Γ unfold-head-elab k
...| just (type-def mps _ T k , _) = TpVar x' , (hnf Γ unfold-head-elab (maybe-else id abs-expand-kind mps k))
...| _ = TpVar x' , KdStar
post-rewriteh Γ x eq prtk tk-decl T = T , KdStar

{-# TERMINATING #-}
post-rewrite : ctxt → var → (eq t₂ : term) → type → type
post-rewrite Γ x eq t₂ T = subst Γ t₂ x (fst (post-rewriteh Γ x eq prtk tk-decl T)) where
  prtk : ctxt → var → term → tpkd → tpkd
  tk-decl : var → tpkd → ctxt → ctxt
  prtk Γ x t (Tkt T) = Tkt (fst (post-rewriteh Γ x t prtk tk-decl T))
  prtk Γ x t (Tkk k) = Tkk (hnf Γ unfold-head-elab k)
  tk-decl x atk Γ =
    record Γ { i = trie-insert (ctxt.i Γ) x (either-else' atk term-decl type-decl , "" , "") }

-- Functions for substituting the type T in ρ e @ x . T - t
rewrite-at-t : Set → Set
rewrite-at-t X = ctxt → var → maybe term → 𝔹 → X → X → X
{-# TERMINATING #-}
rewrite-at : rewrite-at-t type
rewrite-at' : ∀ {ed} → rewrite-at-t ⟦ ed ⟧ → rewrite-at-t ⟦ ed ⟧
rewrite-ath : rewrite-at-t type
rewrite-atₖ : rewrite-at-t kind
rewrite-athₖ : rewrite-at-t kind
rewrite-at-tk : rewrite-at-t tpkd

rewrite-at-tk Γ x eq b (Tkt T) (Tkt T') = Tkt (rewrite-at Γ x eq b T T')
rewrite-at-tk Γ x eq b (Tkk k) (Tkk k') = Tkk (rewrite-atₖ Γ x eq b k k')
rewrite-at-tk Γ x eq b atk1 atk2 = atk1

rewrite-at = rewrite-at' rewrite-ath
rewrite-atₖ = rewrite-at' rewrite-athₖ

rewrite-head-types-match : ∀ {ed} → ctxt → var → (complete partial : ⟦ ed ⟧) → 𝔹
rewrite-head-types-match{TYPE} Γ x (TpApp T _) (TpApp T' _) = conv-type Γ T ([ Γ - Hole pi-gen / x ] T')
rewrite-head-types-match Γ x T T' = tt

rewrite-at' ra Γ x eq b T T' =
  if ~ is-free-in x T'
    then T
    else if b && ~ rewrite-head-types-match Γ x T T'
      then ra Γ x eq ff (hnf Γ unfold-head-elab T) (hnf Γ unfold-head-elab T')
      else ra Γ x eq b T T'

rewrite-athₖ Γ x eq b (KdAbs x1 atk1 k1) (KdAbs x2 atk2 k2) =
  KdAbs x1 (rewrite-at-tk Γ x eq tt atk1 atk2) (rewrite-atₖ (ctxt-var-decl x1 Γ) x eq tt k1 $ rename-var Γ x2 x1 k2)
rewrite-athₖ Γ x eq b KdStar KdStar = KdStar
rewrite-athₖ Γ x eq tt k1 k2 = rewrite-atₖ Γ x eq ff (hnf Γ unfold-head-elab k1) (hnf Γ unfold-head-elab k2)
rewrite-athₖ Γ x eq ff k1 k2 = k1

rewrite-ath Γ x eq b (TpAbs me1 x1 atk1 T1) (TpAbs me2 x2 atk2 T2) =
  TpAbs me1 x1 (rewrite-at-tk Γ x eq tt atk1 atk2) (rewrite-at (ctxt-var-decl x1 Γ) x eq tt T1 (rename-var Γ x2 x1 T2))
rewrite-ath Γ x eq b (TpIota x1 T1 T1') (TpIota x2 T2 T2') =
  TpIota x1 (rewrite-at Γ x eq tt T1 T2) (rewrite-at (ctxt-var-decl x1 Γ) x eq tt T1' (rename-var Γ x2 x1 T2'))
rewrite-ath Γ x eq b (TpApp T1 (Ttp T1')) (TpApp T2 (Ttp T2')) =
  TpApp (rewrite-at Γ x eq b T1 T2) (Ttp (rewrite-at Γ x eq tt T1' T2'))
rewrite-ath Γ x eq b (TpApp T1 (Ttm t1)) (TpApp T2 (Ttm t2)) =
  TpApp (rewrite-at Γ x eq b T1 T2) (Ttm (maybe-else' (ifMaybe (is-free-in x t2) eq) t1 λ eq → rewrite-mk-phi x eq t1 t2))
rewrite-ath Γ x eq b (TpEq t1 t1') (TpEq t2 t2') =
  TpEq t2 t2'
rewrite-ath Γ x eq b (TpLam x1 atk1 T1) (TpLam x2 atk2 T2) =
  TpLam x1 (rewrite-at-tk Γ x eq tt atk1 atk2) (rewrite-at (ctxt-var-decl x1 Γ) x eq tt T1 (rename-var Γ x2 x1 T2))
rewrite-ath Γ x eq b (TpVar x1) (TpVar x2) = TpVar x1
rewrite-ath Γ x eq b (TpHole pi1) (TpHole pi2) = TpHole pi1
rewrite-ath Γ x eq tt T1 T2 = rewrite-at Γ x eq ff (hnf Γ unfold-head-elab T1) (hnf Γ unfold-head-elab T2)
rewrite-ath Γ x eq ff T1 T2 = T1

hnf-ctr : ctxt → var → type → type
hnf-ctr Γ x T = hnf Γ unfold-no-defs (rewrite-at Γ x nothing tt (hnf Γ (unfold tt ff ff) T) $ hnf Γ (record unfold-all {unfold-erase = ff}) T)

{-# TERMINATING #-}
refine-term : ctxt → tmtp → var → term → term
refine-type : ctxt → tmtp → var → type → type
refine-typeh : ctxt → tmtp → var → type → type
refine-kind : ctxt → tmtp → var → kind → kind
refine : ∀ {ed} → ctxt → tmtp → var → ⟦ ed ⟧ → ⟦ ed ⟧

refine {TERM} = refine-term
refine {TYPE} = refine-type
refine {KIND} = refine-kind

refine-term Γ (Ttp T) to t = t
refine-term Γ (Ttm t') to t with rewrite-term t Γ ff nothing nothing t' to 0
...| t'' , zero , _ = t
...| t'' , suc _ , _ = t''

refine-type Γ fm to T =
  if either-else' fm (const ff) (conv-type Γ T)
    then TpVar to
    else refine-typeh Γ fm to T

refine-typeh Γ fm to (TpAbs me x atk T) =
  let x' = fresh-var Γ x in
  TpAbs me x' (refine Γ fm to -tk atk) (refine-type (ctxt-var-decl x' Γ) fm to (rename-var Γ x x' T))
refine-typeh Γ fm to (TpIota x T T') =
  let x' = fresh-var Γ x in
  TpIota x' (refine-type Γ fm to T) (refine-type (ctxt-var-decl x' Γ) fm to (rename-var Γ x x' T'))
refine-typeh Γ fm to (TpApp T tT) =
   TpApp (refine-type Γ fm to T) (refine Γ fm to -tT tT)
refine-typeh Γ fm to (TpEq t₁ t₂) =
  TpEq (refine-term Γ fm to t₁) (refine-term Γ fm to t₂)
refine-typeh Γ fm to (TpLam x atk T) =
  let x' = fresh-var Γ x in
  TpLam x' (refine Γ fm to -tk atk) (refine-type (ctxt-var-decl x' Γ) fm to (rename-var Γ x x' T))
refine-typeh Γ fm to (TpHole pi) = TpHole pi
refine-typeh Γ fm to (TpVar x) = TpVar x

refine-kind Γ fm to (KdAbs x atk k) =
  let x' = fresh-var Γ x in
  KdAbs x (refine Γ fm to -tk atk) (refine-kind (ctxt-var-decl x' Γ) fm to (rename-var Γ x x' k))
refine-kind Γ fm to (KdHole pi) = KdHole pi
refine-kind Γ fm to KdStar = KdStar

refine-motive : ctxt → indices → (asᵢ : 𝕃 tmtp) → (expected : type) → type
refine-motive Γ is as =
  foldr
    (λ where
      (Index x atk , ty) f Γ T →
        let body = f (ctxt-var-decl x Γ) $ refine-type (ctxt-var-decl x Γ) ty x T
            x' = if is-free-in x body then x else ignored-var in
        TpLam x' atk body)
    (λ Γ T → T) (zip (rename-indices Γ is as) as) Γ

-- Given a context, the (qualified) scrutinee, the (qualified) datatype name,
-- the datatype's indices, the arguments for module parameter instantiation,
-- the arguments for the indices in the type of the scrutinee, and the expected type,
-- calculate a possibly ill-typed motive that is approximately abstracted over the
-- indices and the scrutinee itself.
{-
refine-motive : ctxt → (scrutinee : term) → (datatype-name : var) → indices → (mod-as : 𝕃 tty) → (idx-as : 𝕃 tty) → (expected : type) → type
refine-motive Γ t name is asₚ asᵢ =
  let x = fresh-var (add-indices-to-ctxt is Γ) "x"
      atkₓ = Tkt $ indices-to-tpapps is $ recompose-tpapps asₚ $ TpVar pi-gen name
      as' = asᵢ ++ [ tterm t ]
      is' = rename? Γ empty-renamectxt (is ++ [ Index x atkₓ ]) as'
      as = zip is' as' in
  foldr
    (λ where
      (Index x atk , ty) f Γ T →
        TpLambda pi-gen pi-gen x atk $ f (ctxt-var-decl x Γ) $
          refine-type (ctxt-var-decl x Γ) ty x T)
    (λ Γ T → T) as Γ
  where
  get-var : var → tty → var
  get-var x (tterm (Var _ x')) = maybe-else (unqual-local x') id $ var-suffix x'
  get-var x (ttype (TpVar _ x')) = maybe-else (unqual-local x') id $ var-suffix x'
  get-var x _ = x

  rename? : ctxt → renamectxt → indices → 𝕃 tty → indices
  rename? Γ ρ (Index x atk :: is) (ty :: tys) =
    let x' = get-var x ty in
    Index x' (subst-renamectxt Γ ρ atk) :: rename? (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') is tys
  rename? _ _ _ _ = []
-}


{-# OPTIONS --no-auto-inline #-}
module DefaultMethods where

open import Agda.Builtin.Equality
open import Agda.Builtin.Bool
open import Agda.Builtin.Nat using (Nat)
import Agda.Builtin.Nat as Nat
open import Agda.Builtin.List
open import Agda.Builtin.String renaming (primStringAppend to _++_)
open import Agda.Builtin.Char
open import Agda.Builtin.Reflection renaming (bindTC to _>>=_)

open import Haskell.Prim
open import Haskell.Prim.Bool
open import Haskell.Prim.Maybe
open import Haskell.Prim.Foldable

{-# FOREIGN AGDA2HS
{-# LANGUAGE TypeSynonymInstances #-}
import Prelude hiding (Show, ShowS, show, showList, showString, showParen, Ord, (<), (>))
#-}

-- ** Ord

record Ord (a : Set) : Set where
  field
    _<_ _>_ : a → a → Bool

record Ord₁ (a : Set) : Set where
  field
    _<_ : a → a → Bool

  _>_ : a → a → Bool
  x > y = y < x

record Ord₂ (a : Set) : Set where
  field
    _>_ : a → a → Bool

  _<_ : a → a → Bool
  _<_ = flip _>_

open Ord ⦃ ... ⦄

{-# COMPILE AGDA2HS Ord class Ord₁ Ord₂ #-}

OB : Ord₁ Bool
OB .Ord₁._<_ false b = b
OB .Ord₁._<_ true  _ = false

instance
  OrdBool₀ : Ord Bool
  OrdBool₀ ._<_ = Ord₁._<_ OB
  OrdBool₀ ._>_ = Ord₁._>_ OB
{-# COMPILE AGDA2HS OrdBool₀ #-}

data Bool1 : Set where
  Mk1 : Bool -> Bool1
{-# COMPILE AGDA2HS Bool1 #-}
instance
  OrdBool₁ : Ord Bool1
  OrdBool₁ = record {Ord₁ ord₁}
    where
      ord₁ : Ord₁ Bool1
      ord₁ .Ord₁._<_ (Mk1 false) (Mk1 b) = b
      ord₁ .Ord₁._<_ (Mk1 true)  _       = false
{-# COMPILE AGDA2HS OrdBool₁ #-}

data Bool2 : Set where
  Mk2 : Bool -> Bool2
{-# COMPILE AGDA2HS Bool2 #-}
instance
  OrdBool₂ : Ord Bool2
  OrdBool₂ = record {_<_ = _<:_; _>_ = flip _<:_}
    where
      _<:_ : Bool2 → Bool2 → Bool
      (Mk2 false) <: (Mk2 b) = b
      (Mk2 true)  <: _       = false
{-# COMPILE AGDA2HS OrdBool₂ #-}

data Bool3 : Set where
  Mk3 : Bool -> Bool3
{-# COMPILE AGDA2HS Bool3 #-}
instance
  OrdBool₃ : Ord Bool3
  OrdBool₃ = record {Ord₁ (λ where .Ord₁._<_ → _<:_)}
    where
      _<:_ : Bool3 → Bool3 → Bool
      (Mk3 false) <: (Mk3 b) = b
      (Mk3 true)  <: _       = false
{-# COMPILE AGDA2HS OrdBool₃ #-}

data Bool4 : Set where
  Mk4 : Bool -> Bool4
{-# COMPILE AGDA2HS Bool4 #-}
lift4 : (Bool → Bool → a) → (Bool4 → Bool4 → a)
lift4 f (Mk4 x) (Mk4 y) = f x y
{-# COMPILE AGDA2HS lift4 #-}
instance
  OrdBool₄ : Ord Bool4
  OrdBool₄ = record {Ord₁ (λ where .Ord₁._<_ → lift4 (λ x y → not x && y))}
{-# COMPILE AGDA2HS OrdBool₄ #-}

data Bool5 : Set where
  Mk5 : Bool -> Bool5
{-# COMPILE AGDA2HS Bool5 #-}
instance
  OrdBool₅ : Ord Bool5
  OrdBool₅ = record {Ord₂ (λ where .Ord₂._>_ → _>:_)}
    where
      _>:_ : Bool5 → Bool5 → Bool
      (Mk5 false) >: _       = false
      (Mk5 true)  >: (Mk5 b) = not b
{-# COMPILE AGDA2HS OrdBool₅ #-}

data Bool6 : Set where
  Mk6 : Bool -> Bool6
{-# COMPILE AGDA2HS Bool6 #-}
instance
  OrdBool₆ : Ord Bool6
  OrdBool₆ = record {Ord₂ (λ where .Ord₂._>_ → _>:_); _<_ = flip _>:_}
    where
      _>:_ : Bool6 → Bool6 → Bool
      (Mk6 false) >: _       = false
      (Mk6 true)  >: (Mk6 b) = not b
{-# COMPILE AGDA2HS OrdBool₆ #-}

instance
  Ordℕ : Ord Nat
  Ordℕ = record {Ord₁ (λ where .Ord₁._<_ → Nat._<_)}
-- {-# COMPILE AGDA2HS Ordℕ #-}

ShowS : Set
ShowS = String → String
{-# COMPILE AGDA2HS ShowS #-}

showString : String → ShowS
showString = _++_
{-# COMPILE AGDA2HS showString #-}

showParen : Bool → ShowS → ShowS
showParen false s = s
showParen true  s = showString "(" ∘ s ∘ showString ")"
{-# COMPILE AGDA2HS showParen #-}

defaultShowList : (a → ShowS) → List a → ShowS
defaultShowList _     []       = showString "[]"
defaultShowList shows (x ∷ xs) = showString "[" ∘ foldl (λ s x → s ∘ showString "," ∘ shows x) (shows x) xs ∘ showString "]"
{-# COMPILE AGDA2HS defaultShowList #-}

record Show (a : Set) : Set where
  field
    show : a → String
    showPrec : Nat → a → ShowS
    showList : List a → ShowS

record Show₁ (a : Set) : Set where
  field
    showPrec : Nat → a → ShowS

  show : a → String
  show x = showPrec 0 x ""

  showList : List a → ShowS
  showList = defaultShowList (showPrec 0)

record Show₂ (a : Set) : Set where
  field
    show : a → String

  showPrec : Nat → a → ShowS
  showPrec _ x s = show x ++ s

  showList : List a → ShowS
  showList = defaultShowList (showPrec 0)

open Show ⦃ ... ⦄

{-# COMPILE AGDA2HS Show class Show₁ Show₂ #-}

SB : Show₂ Bool
SB .Show₂.show true  = "true"
SB .Show₂.show false = "false"

instance
  ShowBool : Show Bool
  ShowBool .show     = Show₂.show SB
  ShowBool .showPrec = Show₂.showPrec SB
  ShowBool .showList []       = showString ""
  ShowBool .showList (true ∷ bs) = showString "1" ∘ showList bs
  ShowBool .showList (false ∷ bs) = showString "0" ∘ showList bs
{-# COMPILE AGDA2HS ShowBool #-}

instance
  ShowMaybe : ⦃ Show a ⦄ → Show (Maybe a)
  ShowMaybe {a = a} = record {Show₁ s₁}
    where
      s₁ : Show₁ (Maybe a)
      s₁ .Show₁.showPrec n Nothing = showString "nothing"
      s₁ .Show₁.showPrec n (Just x) = showParen true {-(9 < n)-} (showString "just " ∘ showPrec 10 x)
{-# COMPILE AGDA2HS ShowMaybe #-}

instance
  ShowList : ⦃ Show a ⦄ → Show (List a)
  ShowList = record {Show₁ (λ where .Show₁.showPrec _ → showList)}
{-# COMPILE AGDA2HS ShowList #-}