{-# 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.ToFrom3 {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
open import homotopy.3x3.ToFrom2 d

module M3 (c : A₂₂) where

  open M2 c

  lemma2-3 =
    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 /)
              ∙□-i/ E∙₂Red.lhs-o c / E∙₂Red.rhs-o c /)

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

    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 /))
    ∙□-i/ ap (ap to) (E∙₂Red.lhs-o c) / ap (ap to) (E∙₂Red.rhs-o c) /

         =⟨ lemma2-4 |in-ctx (λ u → u ∙□-i/ ap (ap to) (E∙₂Red.lhs-o c) / ap (ap to) (E∙₂Red.rhs-o 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)) /
    ∙□-i/ E∙₂Red.ap-ap-coh!-lhs-o c to / E∙₂Red.ap-ap-coh!-rhs-o c to /
    ∙□-i/ ap (ap to) (E∙₂Red.lhs-o c) / ap (ap to) (E∙₂Red.rhs-o c) / ∎

  lemma2'-3 =
    ap-∘ to (i∙₄ ∘ f∙₃) (glue c)
    ∙ ap (ap to) (E∙₂Red.lhs-o c)
    ∙ E∙₂Red.ap-ap-coh!-lhs-o c to
    ∙ ((To.glue-β (right (f₂₃ c))) |in-ctx (λ u → ap (right ∘ left) (H₁₃ c) ∙ u ∙ ! (ap (right ∘ right) (H₃₃ c))))
    ∙ E₂∙Red.lhs-i c

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

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

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

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

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

               (ap-∙∙`∘`∘ to (left ∘ right) (right ∘ right) (H₁₃ c) (glue (right (f₂₃ c))) (! (H₃₃ c)))
               ((To.glue-β (right (f₂₃ c))) |in-ctx (λ u → ap (right ∘ left) (H₁₃ c) ∙ u ∙ ap (right ∘ right) (! (H₃₃ c))))
               (! (ap-∙∙`∘`∘ right left right (H₁₃ c) (glue (f₂₃ c)) (! (H₃₃ c))))
               (ap-! (right ∘ right) (H₃₃ c) |in-ctx (λ u → ap (right ∘ left) (H₁₃ c) ∙ ap right (glue (f₂₃ c)) ∙ u))
               (ap-∙∙!`∘`∘-coh1 to (left ∘ right) (right ∘ right) (H₁₃ c) (To.glue-β (right (f₂₃ c))) (H₃₃ c))
               (ap-∙∙!`∘`∘-coh2 right left right (H₁₃ c) {glue (f₂₃ c)} (H₃₃ c))
          ⟩

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

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

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

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

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

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

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

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

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

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

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

      =⟨ coh4 (λ u → ap (right ∘ left) (H₁₃ c) ∙ u ∙ ap (right ∘ right) (! (H₃₃ c)))
               (∘-ap (to ∘ i∙₄) f∙₃ (glue c)) _ _ _ _ _ _ _ _ ⟩

    ! end-lemma1 ∎  where

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

      coh3 : ∀ {i} {A : Type i} {a b c d e f g : A} (p : a == b) (q : b == c) (r : c == d) (s : d == e)
        (t : e == f) (u : f == g)
        → (p ∙ q ∙ r) ∙ (s ∙ t) ∙ u == (p ∙ q ∙ r ∙ s) ∙ t ∙ u
      coh3 idp idp idp idp idp idp = idp

      coh4 : ∀ {i j} {A : Type i} {B : Type j} (h : A → B)
        {a b c d : A} {e f g k l m : B} (p : f == e) (q : f == g) (r : g == h a) (s : a == b) (t : b == c)
        (u : c == d) (v : k == h d) (w : l == k) (x : m == l)
        → (! p ∙ q) ∙ (r ∙ (s |in-ctx h) ∙ (t |in-ctx h)) ∙ ((u |in-ctx h) ∙ (! v) ∙ (! w) ∙ ! x)
          == ! (_ =⟨ x ⟩ _ =⟨ w ⟩ _ =⟨ v ⟩ _ =⟨ ! (_ =⟨ s ⟩ _ =⟨ t ⟩ _ =⟨ u ⟩ _ ∎) |in-ctx h ⟩ _ =⟨ ! r ⟩ _ =⟨ ! q ⟩ _ =⟨ p ⟩ _ ∎)
      coh4 h idp idp r idp idp idp v idp idp = ch r v  where

        ch : ∀ {i} {B : Type i} {a b c : B} (r : a == b) (v : c == b)
           → (r ∙ idp) ∙ ! v ∙ idp == ! (_ =⟨ idp ⟩ _ =⟨ idp ⟩ _ =⟨ v ⟩ _ =⟨ idp ⟩ _ =⟨ ! r ⟩ _ ∎)
        ch idp idp = idp

      coh5 : ∀ {i} {A : Type i} {a b c d e e' f f' g h : A} (p : a == b) (q : b == c)
        (r : c == d) (s : d == e) (t : e == f) (u : f == g) (v : g == h) (s' : d == e')
        (t' : e' == f') (u' : f' == g) (w : f' == f) (α : s ∙ t == s' ∙ t' ∙ w) (β : w ∙ u == u')
        → p ∙ (q ∙ r ∙ s) ∙ (t ∙ u ∙ v)
          == p ∙ (q ∙ r ∙ s') ∙ (t' ∙ u' ∙ v)
      coh5 idp idp idp idp idp idp idp idp idp ._ ._ idp idp = idp

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

      =⟨ coh2 (ap to)
           (ap-∘ left f∙₁ (glue c))
           (F∙₁.glue-β c |in-ctx (ap left))
           (ap-!∙∙`∘`∘ left left right (H₁₁ c) (glue (f₂₁ c)) (H₃₁ c))
           ((! (To.glue-β (left (f₂₁ c)))) |in-ctx (λ u → ! (ap (left ∘ left) (H₁₁ c)) ∙ u ∙ ap (left ∘ right) (H₃₁ c)))
           (ap-∘ to (i∙₀ ∘ 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 ∘ left) (H₁₁ c)) ∙ u ∙ ap (right ∘ left) (H₃₁ c)))
           (ap-!'∙∙`∘`∘ to (left ∘ left) (right ∘ left) (H₁₁ c) (glue (left (f₂₁ c))) (H₃₁ c))
           (!-ap (λ u → ! (ap (left ∘ left) (H₁₁ c)) ∙ u ∙ ap (right ∘ left) (H₃₁ c)) (I∙₀.glue-β (f₂₁ c)))
           (!-ap (ap i∙₀) (F∙₁.glue-β c))
           (!-ap-∘ i∙₀ f∙₁ (glue c))
           (!-∘-ap to (i∙₀ ∘ 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))
    ∙ ((! (To.glue-β (left (f₂₁ c)))) |in-ctx (λ u → ! (ap (left ∘ left) (H₁₁ c)) ∙ u ∙ ap (left ∘ right) (H₃₁ c)))
    ∙ ! ((ap-∘ to (i∙₀ ∘ f∙₁) (glue c)
          ∙ ap (ap to) (ap-∘ i∙₀ f∙₁ (glue c))
          ∙ ap (ap to) ((F∙₁.glue-β c) |in-ctx (λ u → ap i∙₀ u)))
         ∙ (ap (ap to) (ap-!∙∙`∘`∘ i∙₀ left right (H₁₁ c) (glue (f₂₁ c)) (H₃₁ c))
            ∙ ap (ap to) ((I∙₀.glue-β (f₂₁ c)) |in-ctx (λ u → ! (ap (left ∘ left) (H₁₁ c)) ∙ u ∙ ap (right ∘ left) (H₃₁ c)))
            ∙ ap-!'∙∙`∘`∘ to (left ∘ left) (right ∘ left) (H₁₁ c) (glue (left (f₂₁ c))) (H₃₁ c)))

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

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

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

    end-lemma3 ∎  where

      coh2 : ∀ {i j} {A : Type i} {B : Type j} (f : A → B) {a b c d e o : B} (p : a == b) (q : b == c) (r : c == d) (s : d == e)
        {g h l m n : A} (y : o == f g) (x : g == h) (w : h == l) (v : l == m) (u : m == n) (t : f n == e)
        {u' : n == m} (γ : ! u == u') {w' : l == h} (δ : ! w == w') {x' : h == g} (α : ! x == x') {y' : f g == o} (β : ! y' == y)
        →
        (_ =⟨ p ⟩ _ =⟨ q ⟩ _ =⟨ r ⟩ _ ∎) ∙ s ∙ ! t ∙ ap f (_ =⟨ u' ⟩ _ =⟨ ! v ⟩ _ =⟨ w' ⟩ _ =⟨ x' ⟩ _ ∎) ∙ y'
        == p ∙ q ∙ r ∙ s ∙ ! ((y ∙ ap f x ∙ ap f w) ∙ (ap f v ∙ ap f u ∙ t))
      coh2 f idp idp idp idp .idp idp idp idp idp idp idp idp idp {y' = idp} idp = idp

      coh3 : ∀ {i j} {A : Type i} {B : Type j} {f : A → B} {a b c d e g o o' : B} {h k l m : A}
        {p : a == b} {q : b == c} {r : c == f m} {v : h == k} {w : k == l} {x : l == m}
        {s : d == f h} {t : e == d} {u : g == e} {u' : e == g} (α : ! u == u')
        {r' : c == o} {x' : o == o'} {y : f l == o'}
        (β : (r' ∙ x' ∙ ! y) == (r ∙' (! x |in-ctx f)))
        →
        p ∙ q ∙ r' ∙ x' ∙ ! ((u ∙ t) ∙ (s ∙ (v |in-ctx f) ∙ (w |in-ctx f) ∙ y))
        ==
        (_ =⟨ p ⟩ _ =⟨ q ⟩ _ =⟨ r ⟩ _ =⟨ ! (_ =⟨ v ⟩ _ =⟨ w ⟩ _ =⟨ x ⟩ _ ∎) |in-ctx f ⟩
         _ =⟨ ! s ⟩ _ =⟨ ! t ⟩ _ =⟨ u' ⟩ _ ∎)
      coh3 {p = idp} {idp} {._} {idp} {idp} {idp} {s} {idp} {idp} idp {idp} {idp} {y} idp = coh' s y  where

        coh' : ∀ {i} {B : Type i} {a b c : B} (s : a == b) (y : b == c)
          → ! (s ∙ y) == (_ =⟨ idp ⟩ _ =⟨ idp ⟩ _ =⟨ ! y ⟩ _ =⟨ idp ⟩ _ =⟨ ! s ⟩ _ ∎)
        coh' idp idp = idp

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

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

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

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

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

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

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

          assoc : ∀ {i} {A : Type i} {a b c d e f g : A} (p : a == b) (q : b == c) (r : c == d) (s : d == e) (t : e == f) (u : f == g)
            → (p ∙ q ∙ r) ∙ (s ∙ t ∙ u) == (p ∙ q) ∙ (r ∙ s ∙ t ∙ u)
          assoc idp idp idp idp idp idp = idp

  lemma2-2' =
    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 /)
              ∙□-i/ E∙₂Red.lhs-o c / E∙₂Red.rhs-o c /)
    ∙□-i/ ap-∘ to (i∙₄ ∘ f∙₃) (glue c) / ∘-ap to (i∙₀ ∘ f∙₁) (glue c) /

         =⟨ lemma2-3 |in-ctx (λ u → u ∙□-i/ ap-∘ to (i∙₄ ∘ f∙₃) (glue c) / ∘-ap to (i∙₀ ∘ f∙₁) (glue 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)) /
    ∙□-i/ E∙₂Red.ap-ap-coh!-lhs-o c to / E∙₂Red.ap-ap-coh!-rhs-o c to /
    ∙□-i/ ap (ap to) (E∙₂Red.lhs-o c) / ap (ap to) (E∙₂Red.rhs-o c) /
    ∙□-i/ ap-∘ to (i∙₄ ∘ f∙₃) (glue c) / ∘-ap to (i∙₀ ∘ f∙₁) (glue c) /

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

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

         =⟨ ∙□-i/-rewrite (↓-='-out (apd (glue {d = h-v-span}) (glue c))
    ∙□-o/ ∘-ap to left (glue (f₁₂ c)) ∙ I₀∙.glue-β (f₁₂ c) / ! (∘-ap to right (glue (f₃₂ c)) ∙ I₄∙.glue-β (f₃₂ c)) /) lemma2'-3 lemma2'-4 ⟩

    ↓-='-out (apd (glue {d = h-v-span}) (glue c))
    ∙□-o/ ∘-ap to left (glue (f₁₂ c)) ∙ I₀∙.glue-β (f₁₂ c) / ! (∘-ap to right (glue (f₃₂ c)) ∙ I₄∙.glue-β (f₃₂ c)) /
    ∙□-i/ ! end-lemma1 / end-lemma3 / ∎  where

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

  lemma2-2 =
    ap↓ (ap to) (↓-='-in (E∙₂Red.coh! c (↓-='-out (apd (glue {d = v-h-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 /))

         =⟨ ap↓-↓-='-in-β _ _ 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 /)
                                    ∙□-i/ E∙₂Red.lhs-o c / E∙₂Red.rhs-o c /) ⟩

    ↓-='-in ((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 /)
                        ∙□-i/ E∙₂Red.lhs-o c / E∙₂Red.rhs-o c /))
             ∙□-i/ ap-∘ to (i∙₄ ∘ f∙₃) (glue c) / ∘-ap to (i∙₀ ∘ f∙₁) (glue c) /)

         =⟨ lemma2-2' |in-ctx ↓-='-in ⟩

    ↓-='-in (↓-='-out (apd (glue {d = h-v-span}) (glue c))
             ∙□-o/ ∘-ap to left (glue (f₁₂ c)) ∙ I₀∙.glue-β (f₁₂ c) / ! (∘-ap to right (glue (f₃₂ c)) ∙ I₄∙.glue-β (f₃₂ c)) /
             ∙□-i/ ! end-lemma1 / end-lemma3 /) ∎

  lemma2-1 =
    apd (ap to ∘ ap from ∘ glue) (glue c)

         =⟨ apd-∘' (ap to ∘ ap from) glue (glue c) ⟩

    ap↓ (ap to ∘ ap from) (apd (glue {d = h-v-span}) (glue c))

         =⟨ ap↓-∘ (ap to) (ap from) (apd glue (glue c)) ⟩

    ap↓ (ap to) (ap↓ (ap from) (apd glue (glue c)))

         =⟨ from-glue-glue-β c |in-ctx (ap↓ (ap to)) ⟩

    ap↓ (ap to) ((↓-='-in (E∙₂Red.coh! c (↓-='-out (apd (glue {d = v-h-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 /))
                   ◃/ From.glue-β (left (f₁₂ c)) / ! (From.glue-β (right (f₃₂ c))) /)

         =⟨ ap↓-◃/ (ap to) _ (From.glue-β (left (f₁₂ c))) _ ⟩

    ap↓ (ap to) (↓-='-in (E∙₂Red.coh! c (↓-='-out (apd (glue {d = v-h-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 /))
    ◃/ ap (ap to) (From.glue-β (left (f₁₂ c))) / ap (ap to) (! (From.glue-β (right (f₃₂ c)))) /

         =⟨ lemma2-2 |in-ctx (λ u → u ◃/ ap (ap to) (From.glue-β (left (f₁₂ c))) / ap (ap to) (! (From.glue-β (right (f₃₂ c)))) /) ⟩

    ↓-='-in (↓-='-out (apd (glue {d = h-v-span}) (glue c))
             ∙□-o/ ∘-ap to left (glue (f₁₂ c)) ∙ I₀∙.glue-β (f₁₂ c) / ! (∘-ap to right (glue (f₃₂ c)) ∙ I₄∙.glue-β (f₃₂ c)) /
             ∙□-i/ ! end-lemma1 / end-lemma3 /)
    ◃/ ap (ap to) (From.glue-β (left (f₁₂ c))) / ap (ap to) (! (From.glue-β (right (f₃₂ c)))) / ∎

  lemma2 =
    ↓-='-out (apd (ap to ∘ ap from ∘ glue) (glue c))

         =⟨ lemma2-1 |in-ctx ↓-='-out ⟩

    ↓-='-out (↓-='-in (↓-='-out (apd (glue {d = h-v-span}) (glue c))
                       ∙□-o/ ∘-ap to left (glue (f₁₂ c)) ∙ I₀∙.glue-β (f₁₂ c)
                           / ! (∘-ap to right (glue (f₃₂ c)) ∙ I₄∙.glue-β (f₃₂ c)) /
                       ∙□-i/ ! end-lemma1
                           / end-lemma3 /)
              ◃/ ap (ap to) (From.glue-β (left (f₁₂ c))) / ap (ap to) (! (From.glue-β (right (f₃₂ c)))) /)

         =⟨ thing (↓-='-out (apd (glue {d = h-v-span}) (glue c))
                       ∙□-o/ ∘-ap to left (glue (f₁₂ c)) ∙ I₀∙.glue-β (f₁₂ c)
                           / ! (∘-ap to right (glue (f₃₂ c)) ∙ I₄∙.glue-β (f₃₂ c)) /
                       ∙□-i/ ! end-lemma1
                           / end-lemma3 /) (ap (ap to) (From.glue-β (left (f₁₂ c)))) (ap (ap to) (! (From.glue-β (right (f₃₂ c))))) ⟩

    ↓-='-out (apd (glue {d = h-v-span}) (glue c))
    ∙□-o/ ∘-ap to left (glue (f₁₂ c)) ∙ I₀∙.glue-β (f₁₂ c)
        / ! (∘-ap to right (glue (f₃₂ c)) ∙ I₄∙.glue-β (f₃₂ c)) /
    ∙□-i/ ! end-lemma1
        / end-lemma3 /
    ∙□-o/ ap (ap to) (From.glue-β (left (f₁₂ c))) / ap (ap to) (! (From.glue-β (right (f₃₂ c)))) /

         =⟨ ch (↓-='-out (apd (glue {d = h-v-span}) (glue c))) (∘-ap to left (glue (f₁₂ c)))
               (ap-∘ to left (glue (f₁₂ c))) (!-∘-ap to left (glue (f₁₂ c))) (I₀∙.glue-β (f₁₂ c)) (∘-ap to right (glue (f₃₂ c)))
               (ap-∘ to right (glue (f₃₂ c))) (!-∘-ap to right (glue (f₃₂ c))) (I₄∙.glue-β (f₃₂ c)) (! end-lemma1) end-lemma3
               (ap (ap to) (From.glue-β (left (f₁₂ c)))) (! (From.glue-β (left (f₁₂ c))) |in-ctx ap to) (!-ap (ap to) (From.glue-β (left (f₁₂ c)))) (ap (ap to) (! (From.glue-β (right (f₃₂ c))))) ⟩

    ↓-='-out (apd (glue {d = h-v-span}) (glue c))
    ∙□-i/ ! end-lemma1
        / end-lemma3 /
    ∙□-o/ ! (to-from-g-l (f₁₂ c))
        / to-from-g-r (f₃₂ c) / ∎  where

      ch : ∀ {i} {A : Type i} {a b b' c : A} {p₁ p₂ p₃ p₄ : a == b} {q₁ q₂ : b == c} {r₁ r₂ : a == b'}
           {s₁ s₂ s₃ s₄ : b' == c} (α : (p₁ , q₁ =□ r₁ , s₁)) (β₁ : p₃ == p₂) (β₁-inv : p₂ == p₃)
           (eq : ! β₁ == β₁-inv) (β₂ : p₂ == p₁) (β'₁ : s₃ == s₂)
           (β'₁-inv : s₂ == s₃) (eq' : ! β'₁ == β'₁-inv) (β'₂ : s₂ == s₁)
           (γ : q₂ == q₁) (γ' : r₁ == r₂) (β₃ : p₄ == p₃) (β₃-inv : p₃ == p₄) (eq₃ : ! β₃ == β₃-inv) (β'₃ : s₃ == s₄)
           →
           α ∙□-o/ β₁ ∙ β₂ / ! (β'₁ ∙ β'₂) /
             ∙□-i/ γ / γ' /
             ∙□-o/ β₃ / β'₃ /
           ==
           α ∙□-i/ γ / γ' /
             ∙□-o/ ! (_ =⟨ ! β₂ ⟩ _ =⟨ β₁-inv ⟩ _ =⟨ β₃-inv ⟩ _ ∎) / (_ =⟨ ! β'₂ ⟩ _ =⟨ β'₁-inv ⟩ _ =⟨ β'₃ ⟩ _ ∎) /
      ch α idp .idp idp idp idp .idp idp idp idp idp idp .idp idp idp = idp


open import Data.Empty
open import Data.List hiding ([_]) renaming (_∷_ to _∷ₗ_)
open import Data.Maybe
open import Data.Product
open import Data.Sum
open import Data.Unit

open import AEff
open import EffectAnnotations
open import Preservation
open import Progress
open import Renamings
open import Substitutions renaming (⟨_,_⟩ to ⟨_,,_⟩)
open import Types

open import Relation.Binary.PropositionalEquality hiding ([_])
open import Relation.Nullary
open import Relation.Nullary.Negation

module Finality where

-- SMALL-STEP OPERATIONAL SEMANTICS FOR WELL-TYPED COMPUTATIONS
-- WITH INLINED EVALUATION CONTEXT RULES

mutual

  infix 10 _↝↝_

  data _↝↝_ {Γ : Ctx} : {C : CType} → Γ ⊢C⦂ C → Γ ⊢C⦂ C → Set where

    -- COMPUTATIONAL RULES

    apply           : {X : VType}
                      {C : CType} →
                      (M : Γ ∷ X ⊢C⦂ C) →
                      (V : Γ ⊢V⦂ X) →
                      ----------------------
                      (ƛ M) · V
                      ↝↝
                      M [ sub-id [ V ]s ]c

    let-return      : {X Y : VType}
                      {o : O}
                      {i : I} →
                      (V : Γ ⊢V⦂ X) →
                      (N : Γ ∷ X ⊢C⦂ Y ! (o , i)) →
                      -----------------------------
                      let= (return V) `in N
                      ↝↝
                      N [ sub-id [ V ]s ]c

    let-↑           : {X Y : VType}
                      {o : O}
                      {i : I}
                      {op : Σₛ} →
                      (p : op ∈ₒ o) →
                      (V : Γ ⊢V⦂ proj₁ (payload op)) →
                      (M : Γ ⊢C⦂ X ! (o , i)) →
                      (N : Γ ∷ X ⊢C⦂ Y ! (o , i)) →
                      --------------------------------
                      let= (↑ op p V M) `in N
                      ↝↝
                      ↑ op p V (let= M `in N)

    let-promise     : {X Y Z : VType}
                      {o o' : O}
                      {i i' : I}
                      {op : Σₛ} →
                      (p : (o' , i') ⊑ lkpᵢ op i) →
                      (M₁ : Γ ∷ proj₁ (payload op) ∷ (𝟙 ⇒ (⟨ X ⟩ ! (∅ₒ , ∅ᵢ [ op ↦ just (o' , i') ]ᵢ))) ⊢C⦂ ⟨ X ⟩ ! (o' , i')) →
                      (M₂ : Γ ∷ ⟨ X ⟩ ⊢C⦂ Y ! (o , i)) →
                      (N : Γ ∷ Y ⊢C⦂ Z ! (o , i)) →
                      ---------------------------------------------------------------------------------------------------------
                      let= (promise op ∣ p ↦ M₁ `in M₂) `in N
                      ↝↝
                      (promise op ∣ p ↦ M₁ `in (let= M₂ `in (C-rename (ren-cong ren-wk) N)))

    let-await       : {X Y Z : VType}
                      {o : O}
                      {i : I} →
                      (V : Γ ⊢V⦂ ⟨ X ⟩) →
                      (M : Γ ∷ X ⊢C⦂ Y ! (o , i)) →
                      (N : Γ ∷ Y ⊢C⦂ Z ! (o , i)) →
                      -------------------------------------------------------
                      let= (await V until M) `in N
                      ↝↝
                      await V until (let= M `in C-rename (ren-cong ren-wk) N)

    let-spawn       : {X Y : VType}
                      {C : CType}
                      {o : O}
                      {i : I} →
                      (M : Γ ■ ⊢C⦂ C) →
                      (N : Γ ⊢C⦂ X ! (o , i)) →
                      (K : Γ ∷ X ⊢C⦂ Y ! (o , i)) →
                      ---------------------------------------
                      let= (spawn M N) `in K
                      ↝↝
                      spawn M (let= N `in K)

    promise-↑       : {X Y : VType}
                      {o o' : O}
                      {i i' : I}
                      {op op' : Σₛ} →
                      (p : (o' , i') ⊑ lkpᵢ op i) →
                      (q : op' ∈ₒ o) →
                      (V : Γ ∷ ⟨ X ⟩ ⊢V⦂ proj₁ (payload op')) →
                      (M : Γ ∷ proj₁ (payload op) ∷ (𝟙 ⇒ (⟨ X ⟩ ! (∅ₒ , ∅ᵢ [ op ↦ just (o' , i') ]ᵢ))) ⊢C⦂ ⟨ X ⟩ ! (o' , i')) →
                      (N : Γ ∷ ⟨ X ⟩ ⊢C⦂ Y ! (o , i)) →
                      --------------------------------------------------------------------------------------------------------
                      (promise op ∣ p ↦ M `in (↑ op' q V N))
                      ↝↝
                      ↑ op' q (strengthen-val {Δ = X ∷ₗ []} (proj₂ (payload op')) V) (promise op ∣ p ↦ M `in N)

    promise-spawn   : {X Y : VType}
                      {C : CType}
                      {o o' : O}
                      {i i' : I}
                      {op : Σₛ} →
                      (p : (o' , i') ⊑ lkpᵢ op i) →
                      (M : Γ ∷ proj₁ (payload op) ∷ (𝟙 ⇒ (⟨ X ⟩ ! (∅ₒ , ∅ᵢ [ op ↦ just (o' , i') ]ᵢ))) ⊢C⦂ ⟨ X ⟩ ! (o' , i')) →
                      (N : Γ ∷ ⟨ X ⟩ ■ ⊢C⦂ C) →
                      (K : Γ ∷ ⟨ X ⟩ ⊢C⦂ Y ! (o , i)) →
                      ---------------------------------------------------------------------------------------------------------
                      (promise op ∣ p ↦ M `in (spawn N K))
                      ↝↝
                      spawn (strengthen-■-c {Γ' = []} {Δ = X ∷ₗ []} N) (promise op ∣ p ↦ M `in K)

    ↓-return        : {X : VType}
                      {o : O}
                      {i : I}
                      {op : Σₛ} →
                      (V : Γ ⊢V⦂ proj₁ (payload op)) →
                      (W : Γ ⊢V⦂ X) →
                      ----------------------------------------------------------------
                      ↓ {o = o} {i = i} op V (return W)
                      ↝↝
                      return {o = proj₁ (op ↓ₑ (o , i))} {i = proj₂ (op ↓ₑ (o , i))} W

    ↓-↑             : {X : VType}
                      {o : O}
                      {i : I}
                      {op : Σₛ}
                      {op' : Σₛ} →
                      (p : op' ∈ₒ o) →
                      (V : Γ ⊢V⦂ proj₁ (payload op)) →
                      (W : Γ ⊢V⦂ proj₁ (payload op')) →
                      (M : Γ ⊢C⦂ X ! (o , i)) →
                      ---------------------------------
                      ↓ op V (↑ op' p W M)
                      ↝↝
                      ↑ op' (↓ₑ-⊑ₒ op' p) W (↓ op V M)

    ↓-promise-op    : {X Y : VType}
                      {o o' : O}
                      {i i' : I}
                      {op : Σₛ} →
                      (p : (o' , i') ⊑ lkpᵢ op i) →
                      (V : Γ ⊢V⦂ proj₁ (payload op)) →
                      (M : Γ ∷ proj₁ (payload op) ∷ (𝟙 ⇒ (⟨ X ⟩ ! (∅ₒ , ∅ᵢ [ op ↦ just (o' , i') ]ᵢ))) ⊢C⦂ ⟨ X ⟩ ! (o' , i')) →
                      (N : Γ ∷ ⟨ X ⟩ ⊢C⦂ Y ! (o , i)) →
                      --------------------------------------------------------------------------------------------------------------------------------------------------------
                      ↓ op V (promise op ∣ p ↦ M `in N )
                      ↝↝
                      (let= (coerce (⊑ₒ-trans (proj₁ (⊑-proj p (proj₂ (proj₂ (⊑-just p))))) (↓ₑ-⊑ₒ-o' {o = o} (proj₂ (proj₂ (⊑-just p)))))
                                    (⊑ᵢ-trans (proj₂ (⊑-proj p (proj₂ (proj₂ (⊑-just p))))) (↓ₑ-⊑ₒ-i' {o = o} (proj₂ (proj₂ (⊑-just p)))))
                                    (M [ (sub-id [ V ]s)
                                       [ ƛ (promise op ∣ subst (λ oi → (o' , i') ⊑ oi) (sym ite-≡) ⊑-refl ↦ C-rename (ren-cong (ren-cong ren-wk)) M `in return (` Hd)) ]s ]c))
                       `in (↓ op (V-rename ren-wk V) N))

    ↓-promise-op'   : {X Y : VType}
                      {o o' : O}
                      {i i' : I}
                      {op op' : Σₛ} →
                      (p : ¬ op ≡ op') →
                      (q : (o' , i') ⊑ lkpᵢ op' i) →
                      (V : Γ ⊢V⦂ proj₁ (payload op)) →
                      (M : Γ ∷ proj₁ (payload op') ∷ (𝟙 ⇒ (⟨ X ⟩ ! (∅ₒ , ∅ᵢ [ op' ↦ just (o' , i') ]ᵢ))) ⊢C⦂ ⟨ X ⟩ ! (o' , i')) →
                      (N : Γ ∷ ⟨ X ⟩ ⊢C⦂ Y ! (o , i)) →
                      -----------------------------------------------------------------------------------------------------------
                      ↓ op V (promise op' ∣ q ↦ M `in N )
                      ↝↝
                      promise op' ∣ (lkpᵢ-↓ₑ-neq-⊑ {o = o} {i = i} p q) ↦ M `in ↓ op (V-rename ren-wk V) N

    ↓-await        : {X Y : VType}
                     {o : O}
                     {i : I}
                     {op : Σₛ} →
                     (V : Γ ⊢V⦂ proj₁ (payload op)) →
                     (W : Γ ⊢V⦂ ⟨ X ⟩) →
                     (M : Γ ∷ X ⊢C⦂ Y ! (o , i)) →
                     ------------------------------------------
                     ↓ op V (await W until M)
                     ↝↝
                     await W until (↓ op (V-rename ren-wk V) M)

    ↓-spawn         : {X : VType}
                      {C : CType}
                      {o : O}
                      {i : I}
                      {op : Σₛ} →
                      (V : Γ ⊢V⦂ proj₁ (payload op)) →
                      (M : Γ ■ ⊢C⦂ C) →
                      (N : Γ ⊢C⦂ X ! (o , i)) →
                      --------------------------------
                      ↓ op V (spawn M N)
                      ↝↝
                      spawn M (↓ op V N)

    await-promise   : {X : VType}
                      {C : CType} →
                      (V : Γ ⊢V⦂ X) →
                      (M : Γ ∷ X ⊢C⦂ C) →
                      --------------------
                      await ⟨ V ⟩ until M
                      ↝↝
                      M [ sub-id [ V ]s ]c

    box-unbox       : {X : VType}
                      {C : CType} →
                      (V : Γ ■ ⊢V⦂ X) →
                      (M : Γ ∷ X ⊢C⦂ C) →
                      ----------------------------------------
                      unbox (□ V) `in M
                      ↝↝
                      M [ ⟨ sub-id ,, ■-str-v {Γ' = []} V ⟩ ]c

    -- INLINED EVALUATION CONTEXT RULES

    context-let      : {X Y : VType}
                       {o : O}
                       {i : I} →
                       {M M' : Γ ⊢C⦂ X ! (o , i)} →
                       {N : Γ ∷ X ⊢C⦂ Y ! (o , i)} →
                       M ↝↝ M' →
                       -----------------------------
                       let= M `in N
                       ↝↝
                       let= M' `in N

    context-↑        : {X : VType}
                       {o : O}
                       {i : I}
                       {op : Σₛ}
                       {p : op ∈ₒ o}
                       {V : Γ ⊢V⦂ proj₁ (payload op)}
                       {M N : Γ ⊢C⦂ X ! (o , i)} →
                       M ↝↝ N →
                       ---------------------------
                       ↑ op p V M
                       ↝↝
                       ↑ op p V N

    context-↓        : {X : VType}
                       {o : O}
                       {i : I}
                       {op : Σₛ}
                       {V : Γ ⊢V⦂ proj₁ (payload op)}
                       {M N : Γ ⊢C⦂ X ! (o , i)} →
                       M ↝↝ N →
                       ------------------------------
                       ↓ op V M
                       ↝↝
                       ↓ op V N

    context-promise : {X Y : VType}
                      {o o' : O}
                      {i i' : I}
                      {op : Σₛ} →
                      {r : (o' , i') ⊑ lkpᵢ op i}
                      {M : Γ ∷ proj₁ (payload op) ∷ (𝟙 ⇒ (⟨ X ⟩ ! (∅ₒ , ∅ᵢ [ op ↦ just (o' , i') ]ᵢ))) ⊢C⦂ ⟨ X ⟩ ! (o' , i')} →
                      {N N' : Γ ∷ ⟨ X ⟩ ⊢C⦂ Y ! (o , i)} →
                      N ↝↝ N' →
                      --------------------------------------------------------------------------------------------------------
                      promise op ∣ r ↦ M `in N
                      ↝↝
                      promise op ∣ r ↦ M `in N'

    context-spawn   : {C D : CType}
                      {M : Γ ■ ⊢C⦂ C}
                      {N N' : Γ ⊢C⦂ D} →
                      N ↝↝ N' →
                      ------------------
                      spawn M N
                      ↝↝
                      spawn M N'

    context-coerce  : {X : VType}
                      {o o' : O}
                      {i i' : I}
                      {p : o ⊑ₒ o'}
                      {q : i ⊑ᵢ i'} →
                      {M N : Γ ⊢C⦂ X ! (o , i)} →
                      M ↝↝ N →
                      ---------------------------
                      coerce p q M
                      ↝↝
                      coerce p q N

    -- COERCION RULES

    coerce-return   : {X : VType}
                      {o o' : O}
                      {i i' : I}
                      {p : o ⊑ₒ o'}
                      {q : i ⊑ᵢ i'} →
                      (V : Γ ⊢V⦂ X) →
                      --------------------------------
                      coerce p q (return V) ↝↝ return V

    coerce-↑        : {X : VType}
                      {o o' : O}
                      {i i' : I}
                      {p : o ⊑ₒ o'}
                      {q : i ⊑ᵢ i'}
                      {op : Σₛ} →
                      (r : op ∈ₒ o) →
                      (V : Γ ⊢V⦂ proj₁ (payload op)) →
                      (M : Γ ⊢C⦂ X ! (o , i)) →
                      -------------------------------
                      coerce p q (↑ op r V M)
                      ↝↝
                      ↑ op (p op r) V (coerce p q M)

    coerce-promise  : {X Y : VType}
                      {o o' o'' : O}
                      {i i' i'' : I}
                      {p : o ⊑ₒ o'}
                      {q : i ⊑ᵢ i'}
                      {op : Σₛ} →
                      (r : (o'' , i'') ⊑ lkpᵢ op i )
                      (M : Γ ∷ proj₁ (payload op) ∷ (𝟙 ⇒ (⟨ X ⟩ ! (∅ₒ , ∅ᵢ [ op ↦ just (o'' , i'') ]ᵢ))) ⊢C⦂ ⟨ X ⟩ ! (o'' , i'')) →
                      (N : Γ ∷ ⟨ X ⟩ ⊢C⦂ Y ! (o , i)) →
                      -------------------------------------------------------------------------------------------------------------
                      coerce p q (promise op ∣ r ↦ M `in N)
                      ↝↝
                      promise_∣_↦_`in_ op (subst (λ oi → (o'' , i'') ⊑ oi) (sym (lkpᵢ-next-eq q (proj₂ (proj₂ (⊑-just r)))))
                                            (⊑-trans r (proj₂ (proj₂ (⊑-just r))) (
                                              (lkpᵢ-next-⊑ₒ q (proj₂ (proj₂ (⊑-just r)))) ,
                                              (lkpᵢ-next-⊑ᵢ q (proj₂ (proj₂ (⊑-just r)))))))
                                          M
                                          (coerce p q N)

    coerce-await   : {X Y : VType}
                     {o o' : O}
                     {i i' : I}
                     {p : o ⊑ₒ o'}
                     {q : i ⊑ᵢ i'} →
                     (V : Γ ⊢V⦂ ⟨ X ⟩) →
                     (M : Γ ∷ X ⊢C⦂ Y ! (o , i)) →
                     -----------------------------
                     coerce p q (await V until M)
                     ↝↝
                     await V until (coerce p q M)

    coerce-spawn   : {X : VType}
                     {C : CType}
                     {o o' : O}
                     {i i' : I}
                     {p : o ⊑ₒ o'}
                     {q : i ⊑ᵢ i'} →
                     (M : Γ ■ ⊢C⦂ C) →
                     (N : Γ ⊢C⦂ X ! (o , i)) →
                     -------------------------
                     coerce p q (spawn M N)
                     ↝↝
                     spawn M (coerce p q N)

-- ONE-TO-ONE CORRESPONDENCE BETWEEN THE TWO SETS OF REDUCTION RULES

↝↝-to-↝ : {Γ : Ctx}
          {C : CType}
          {M N : Γ ⊢C⦂ C} →
          M ↝↝ N →
          -----------------
          M ↝ N

↝↝-to-↝ (apply M V) =
  apply M V
↝↝-to-↝ (let-return V N) =
  let-return V N
↝↝-to-↝ (let-↑ p V M N) =
  let-↑ p V M N
↝↝-to-↝ (let-promise p M₁ M₂ N) =
  let-promise p M₁ M₂ N
↝↝-to-↝ (let-await V M N) =
  let-await V M N
↝↝-to-↝ (let-spawn M N K) =
  let-spawn M N K
↝↝-to-↝ (promise-↑ p q V M N) =
  promise-↑ p q V M N
↝↝-to-↝ (promise-spawn p M N K) =
  promise-spawn p M N K
↝↝-to-↝ (↓-return V W) =
  ↓-return V W
↝↝-to-↝ (↓-↑ p V W M) =
  ↓-↑ p V W M
↝↝-to-↝ (↓-promise-op p V M N) =
  ↓-promise-op p V M N
↝↝-to-↝ (↓-promise-op' p q V M N) =
  ↓-promise-op' p q V M N
↝↝-to-↝ (↓-await V W M) =
  ↓-await V W M
↝↝-to-↝ (↓-spawn V M N) =
  ↓-spawn V M N
↝↝-to-↝ (await-promise V M) =
  await-promise V M
↝↝-to-↝ (box-unbox V M) =
  box-unbox V M
↝↝-to-↝ (context-let r) =
  context _ (↝↝-to-↝ r)
↝↝-to-↝ (context-↑ r) =
  context _ (↝↝-to-↝ r)
↝↝-to-↝ (context-↓ r) =
  context _ (↝↝-to-↝ r)
↝↝-to-↝ (context-promise r) =
  context _ (↝↝-to-↝ r)
↝↝-to-↝ (context-spawn r) =
  context _ (↝↝-to-↝ r)
↝↝-to-↝ (context-coerce r) =
  context _ (↝↝-to-↝ r)
↝↝-to-↝ (coerce-return V) =
  coerce-return V
↝↝-to-↝ (coerce-↑ p V M) =
  coerce-↑ p V M
↝↝-to-↝ (coerce-promise p M N) =
  coerce-promise p M N
↝↝-to-↝ (coerce-await V M) =
  coerce-await V M
↝↝-to-↝ (coerce-spawn M N) =
  coerce-spawn M N

mutual
  ↝-context-to-↝↝ : {Γ : Ctx}
                    {Δ : BCtx}
                    {C : CType} →
                    (E : Γ ⊢E[ Δ ]⦂ C) →
                    {M N : (Γ ⋈ Δ) ⊢C⦂ hole-ty-e E} →
                    M ↝ N →
                    ---------------------------------
                    E [ M ] ↝↝ E [ N ]

  ↝-context-to-↝↝ [-] r =
    ↝-to-↝↝ r
  ↝-context-to-↝↝ (let= E `in x) r =
    context-let (↝-context-to-↝↝ E r)
  ↝-context-to-↝↝ (↑ op p V E) r =
    context-↑ (↝-context-to-↝↝ E r)
  ↝-context-to-↝↝ (↓ op V E) r =
    context-↓ (↝-context-to-↝↝ E r)
  ↝-context-to-↝↝ (promise op ∣ p ↦ M `in E) r =
    context-promise (↝-context-to-↝↝ E r)
  ↝-context-to-↝↝ (spawn M E) r =
    context-spawn (↝-context-to-↝↝ E r)
  ↝-context-to-↝↝ (coerce p q E) r =
    context-coerce (↝-context-to-↝↝ E r)

  ↝-to-↝↝ : {Γ : Ctx}
            {C : CType}
            {M N : Γ ⊢C⦂ C} →
            M ↝ N →
            -----------------
            M ↝↝ N

  ↝-to-↝↝ (apply M V) =
    apply M V
  ↝-to-↝↝ (let-return V N) =
    let-return V N
  ↝-to-↝↝ (let-↑ p V M N) =
    let-↑ p V M N
  ↝-to-↝↝ (let-promise p M₁ M₂ N) =
    let-promise p M₁ M₂ N
  ↝-to-↝↝ (let-await V M N) =
    let-await V M N
  ↝-to-↝↝ (let-spawn M N K) =
    let-spawn M N K
  ↝-to-↝↝ (promise-↑ p q V M N) =
    promise-↑ p q V M N
  ↝-to-↝↝ (promise-spawn p M N K) =
    promise-spawn p M N K
  ↝-to-↝↝ (↓-return V W) =
    ↓-return V W
  ↝-to-↝↝ (↓-↑ p V W M) =
    ↓-↑ p V W M
  ↝-to-↝↝ (↓-promise-op p V M N) =
    ↓-promise-op p V M N
  ↝-to-↝↝ (↓-promise-op' p q V M N) =
    ↓-promise-op' p q V M N
  ↝-to-↝↝ (↓-await V W M) =
    ↓-await V W M
  ↝-to-↝↝ (↓-spawn V M N) =
    ↓-spawn V M N
  ↝-to-↝↝ (await-promise V M) =
    await-promise V M
  ↝-to-↝↝ (box-unbox V M) =
    box-unbox V M
  ↝-to-↝↝ (context E r) =
    ↝-context-to-↝↝ E r
  ↝-to-↝↝ (coerce-return V) =
    coerce-return V
  ↝-to-↝↝ (coerce-↑ p V M) =
    coerce-↑ p V M
  ↝-to-↝↝ (coerce-promise p M N) =
    coerce-promise p M N
  ↝-to-↝↝ (coerce-await V M) =
    coerce-await V M
  ↝-to-↝↝ (coerce-spawn M N) =
    coerce-spawn M N

-- FINALITY OF RESULT FORMS

run-finality-↝↝ : {Γ : MCtx}
                  {C : CType}
                  {M N : ⟨⟨ Γ ⟩⟩ ⊢C⦂ C} →
                  RunResult⟨ Γ ∣ M ⟩ →
                  M ↝↝ N →
                  -----------------------
                  ⊥

run-finality-↝↝ (promise ()) (promise-↑ p q V M N)
run-finality-↝↝ (promise ()) (promise-spawn p M N K)
run-finality-↝↝ (promise R) (context-promise r) =
  run-finality-↝↝ R r

comp-finality-↝↝ : {Γ : MCtx}
                   {C : CType}
                   {M N : ⟨⟨ Γ ⟩⟩ ⊢C⦂ C} →
                   CompResult⟨ Γ ∣ M ⟩ →
                   M ↝↝ N →
                   -----------------------
                   ⊥

comp-finality-↝↝ (comp R) r =
  run-finality-↝↝ R r
comp-finality-↝↝ (signal R) (context-↑ r) =
  comp-finality-↝↝ R r
comp-finality-↝↝ (spawn R) (context-spawn r) =
  comp-finality-↝↝ R r

comp-finality : {Γ : MCtx}
                {C : CType}
                {M N : ⟨⟨ Γ ⟩⟩ ⊢C⦂ C} →
                CompResult⟨ Γ ∣ M ⟩ →
                M ↝ N →
                -----------------------
                ⊥

comp-finality R r =
  comp-finality-↝↝ R (↝-to-↝↝ r)


{-# OPTIONS --rewriting --prop #-}

open import common
open import syntx
open import derivability

{- Helper functions to compute the arity of a rule given the arity of the symbol. -}

SStoJS : SyntaxSort → JudgmentSort
SStoJS Ty = Ty
SStoJS Tm = Tm

TArityArgs : SyntaxArityArgs → JudgmentArityArgs
TArityArgs [] = []
TArityArgs (ar , (n , k)) = TArityArgs ar , (n , SStoJS k)

TArity : SyntaxArity → JudgmentArity
TArity ar = (TArityArgs (args ar) , SStoJS (sort ar))

SStoJS= : SyntaxSort → JudgmentSort
SStoJS= Ty = Ty=
SStoJS= Tm = Tm=

CArityArgs : SyntaxArityArgs → JudgmentArityArgs
CArityArgs [] = []
CArityArgs (ar , (n , k)) = CArityArgs ar , (n , SStoJS= k)

CArity : SyntaxArity → JudgmentArity
CArity ar = (CArityArgs (args ar) , SStoJS= (sort ar))

{-
[↑DerivationRule r] extends the derivation rule [r] to an extended signature.
This is easy because derivation rules were designed to be extendable.
-}
↑DerivationRule : {Σ : Signature} {sar : SyntaxArity} {jar : JudgmentArity}
                → DerivationRule Σ jar → DerivationRule (ExtSig Σ sar) jar
rule (↑DerivationRule r) ↑ Γ = rule r (Ext→ ↑) Γ

{- Record combining the typing and congruence rules for a new symbol. -}
record DerivationRules {Σ : Signature} (E : DerivabilityStructure Σ) (ar : SyntaxArity) : Set₁ where
  field
    typingdrule     : DerivationRule (ExtSig Σ ar) (TArity ar)
    congruencedrule : DerivationRule (ExtSig Σ ar) (CArity ar)
open DerivationRules public

{-
[extend E tc] extends the derivability structure [E] to an extended signature, where [tc] is the
typing/congruence rules of a new symbol. We also use a custom data type in order to add the two new
rules, in order to get something readable.
-}

data ExtT (A : JudgmentArity → Set) (sar : SyntaxArity) : JudgmentArity → Set where
  typingrule : ExtT A sar (TArity sar)
  prev : {jar : JudgmentArity} → A jar → ExtT A sar jar

data ExtC (A : JudgmentArity → Set) (sar : SyntaxArity) : JudgmentArity → Set where
  congruencerule : ExtC A sar (CArity sar)
  prev : {jar : JudgmentArity} → A jar → ExtC A sar jar

extend : {Σ : Signature} (E : DerivabilityStructure Σ)
         {ar : SyntaxArity}
         (tc : DerivationRules E ar)
         → DerivabilityStructure (ExtSig Σ ar)

Rules (extend E {ar} tc) S  = Rules E S
Rules (extend E {ar} tc) T  = ExtT (Rules E T) ar
Rules (extend E {ar} tc) C  = ExtC (Rules E C) ar
Rules (extend E {ar} tc) Eq = Rules E Eq
derivationRule (extend E tc) {t = S} r = ↑DerivationRule (derivationRule E r)
derivationRule (extend E tc) {t = T} (prev r) = ↑DerivationRule (derivationRule E r)
derivationRule (extend E tc) {t = T} typingrule = typingdrule tc
derivationRule (extend E tc) {t = C} (prev r) = ↑DerivationRule (derivationRule E r)
derivationRule (extend E tc) {t = C} congruencerule = congruencedrule tc
derivationRule (extend E tc) {t = Eq} r = ↑DerivationRule (derivationRule E r)

-- data Ext (A : Tag → JudgmentArity → Set) (sar : SyntaxArity) : Tag → JudgmentArity → Set where
--   typingrule : Ext A sar T (TArity sar)
--   congruencerule : Ext A sar C (CArity sar)
--   prev : {t : Tag} {jar : JudgmentArity} → A t jar → Ext A sar t jar

-- extend : {Σ : Signature} (E : DerivabilityStructure Σ)
--          {ar : SyntaxArity}
--          (tc : DerivationRules E ar 0)
--          → DerivabilityStructure (ExtSig Σ ar)
-- Rules (extend E {ar} tc) = Ext (Rules E) ar
-- derivationRule (extend E tc) typingrule = typingdrule tc
-- derivationRule (extend E tc) congruencerule = congruencedrule tc
-- derivationRule (extend E tc) (prev r) = ↑DerivationRule (derivationRule E r)

{- Typing rules for basic metavariables (simply a derivable type in the empty context) -}

record BMTypingRule {Σ : Signature} (E : DerivabilityStructure Σ) : Set where
  constructor _/_
  field
    type : TyExpr Σ 0
    der : Derivable E {Γ = ◇} (◇ ⊢ type)
open BMTypingRule public

{- The derivation rules corresponding to a basic metavariable (on the extended signature). -}

BMRules : {Σ : Signature} {E : DerivabilityStructure Σ}
          (t : BMTypingRule E)
          → DerivationRules E ([] , Tm)
rule (typingdrule     (BMRules t)) ↑ Γ [] = return (◇ ⊢ (↑ $ new) []
                                                      :> ↑Expr (Ext→ ↑) (weaken0 (type t)))
rule (congruencedrule (BMRules t)) ↑ Γ [] = return (◇ ⊢ (↑ $ new) [] == (↑ $ new) []
                                                      :> ↑Expr (Ext→ ↑) (weaken0 (type t)))

-- --------------    -----------------
--   Γ ⊢ s : A         Γ ⊢ s = s : A

{-
The premises of a typing rule for a metavariables form essentially a list of typing rules for basic
metavariables in increasingly extended signatures. There are two different ways to order the premises:
- either we have the first premise, and then the rest in an extended signature,
- or we have all but the last premises, and then the last one in a signature extended by all the
  previous ones.

The first option looks simpler, but we use the second option because we will need to talk about
multiple substitution later anyway, and also it allows us to keep typing rules in the empty context.

The type [MTypingRulePremises E n] represents a list of length [n] of such premises. It is defined
simultaneously with multiple substitution: [extend^BM E ts] represents the derivability structure
[E] extended by all the basic metavariables of [ts].
-}

data MTypingRulePremises : {Σ : Signature} (E : DerivabilityStructure Σ) (n : ℕ) → Set

extend^BM : {Σ : Signature} (E : DerivabilityStructure Σ) {n : ℕ} (ts : MTypingRulePremises E n)
          → DerivabilityStructure (ExtSig^ Σ (MArityArgs n))

data MTypingRulePremises where
  [] : ∀ {Σ} {E : DerivabilityStructure Σ} → MTypingRulePremises E 0
  _,_ : ∀ {Σ} {E : DerivabilityStructure Σ} {n : ℕ}
      → (ts : MTypingRulePremises E n)
      → (t : BMTypingRule (extend^BM E ts))
      → MTypingRulePremises E (suc n)

extend^BM E [] = E
extend^BM E (ts , t) = extend (extend^BM E ts) (BMRules t)

{-
[MTypingRule E n k] represents typing rules in derivability structure [E] for a metavariable of
arity (n , k).
There are two cases depending on [k]:
- if [k] is [Ty], then we simply need a list of premises,
- if [k] is [Tm], then we need a list of premises and a type for the conclusion, in the correctly
  extended derivability structure.
-}

data MTypingRule {Σ : Signature} (E : DerivabilityStructure Σ) (n : ℕ) : (k : SyntaxSort) → Set where
  Ty : MTypingRulePremises E n → MTypingRule E n Ty
  Tm : (ts : MTypingRulePremises E n) → BMTypingRule (extend^BM E ts) → MTypingRule E n Tm

{-
Γ, n : ℕ, y : P n ⊢ dS : P (n + 1)

◇ ⊢ _n : ℕ
◇ ⊢ _y : P _n
----------------------------
◇ ⊢ dS(_n , _y) : P (_n + 1)

Γ ⊢ n = m : ℕ
Γ ⊢ u = v : P n
-----------
Γ ⊢ dS(n , u) = dS(m , v) : P (n + 1)

Γ ⊢ 3 : ℕ
Γ ⊢ u : P 3
~~~>
Γ ⊢ dS(3 , u) : P (3 + 1)

(n : ℕ, y : P n)

-}

{-
The derivation rules associated to a typing rule for a metavariable.
-}

MTypingRule-TArgs : {Σ Σ' : Signature} (E : DerivabilityStructure Σ) {n m : ℕ} (↑ : (Σ →Sig Σ') m) {Γ : Ctx Σ' m}
                   (ts : MTypingRulePremises E n) (js : DerivationRulePremises Σ' Γ (TArityArgs (MArityArgs n)))
                   → Partial (Args Σ' m (MArityArgs n))
MTypingRule-TArgs E ↑ [] [] = return []
MTypingRule-TArgs E ↑ (ts , t) (js , ◇ ⊢ a :> A) = do
  as ← MTypingRule-TArgs E ↑ ts js
  assume (A ≡ ↑Expr (SubstM ↑ as) (weaken0 (type t)))
  return (as , a)

MTypingRule-TRule : {Σ : Signature} (E : DerivabilityStructure Σ) {n : ℕ} {k : SyntaxSort}
                    (t : MTypingRule E n k)
                    → DerivationRule (ExtSig Σ (MArity n k)) (TArity (MArity n k))
rule (MTypingRule-TRule E (Ty ts)) ↑ Γ js = do
  as ← MTypingRule-TArgs E (Ext→ ↑) ts js
  return (◇ ⊢ (↑ $ new) as)
rule (MTypingRule-TRule E (Tm ts t)) ↑ Γ js = do
  as ← MTypingRule-TArgs E (Ext→ ↑) ts js
  return (◇ ⊢ (↑ $ new) as :> ↑Expr (SubstM (Ext→ ↑) as) (weaken0 (type t)))

MTypingRule-CArgs : {Σ Σ' : Signature} (E : DerivabilityStructure Σ) {n m : ℕ} (↑ : (Σ →Sig Σ') m) {Γ : Ctx Σ' m}
                   (ts : MTypingRulePremises E n) (js : DerivationRulePremises Σ' Γ (CArityArgs (MArityArgs n)))
                   → Partial (Args Σ' m (MArityArgs n) × Args Σ' m (MArityArgs n))
MTypingRule-CArgs E ↑ [] [] = return ([] , [])
MTypingRule-CArgs E ↑ (ts , t) (js , ◇ ⊢ a == a' :> A) = do
  (as , as') ← MTypingRule-CArgs E ↑ ts js
  assume (A ≡ ↑Expr (SubstM ↑ as) (weaken0 (type t)))
  return ((as , a) , (as' , a'))

MTypingRule-CRule : {Σ : Signature} (E : DerivabilityStructure Σ) {n : ℕ} {k : SyntaxSort}
                    (t : MTypingRule E n k)
                    → DerivationRule (ExtSig Σ (MArity n k)) (CArity (MArity n k))
rule (MTypingRule-CRule E (Ty ts)) ↑ Γ js = do
  (as , as') ← MTypingRule-CArgs E (Ext→ ↑) ts js
  return (◇ ⊢ (↑ $ new) as == (↑ $ new) as')
rule (MTypingRule-CRule E (Tm ts t)) ↑ Γ js = do
  (as , as') ← MTypingRule-CArgs E (Ext→ ↑) ts js
  return (◇ ⊢ (↑ $ new) as == (↑ $ new) as' :> ↑Expr (SubstM (Ext→ ↑) as) (weaken0 (type t)))

MRules : {Σ : Signature} {E : DerivabilityStructure Σ} {n : ℕ} {k : SyntaxSort}
                    (t : MTypingRule E n k)
                    → DerivationRules E (MArity n k)
typingdrule (MRules t) = MTypingRule-TRule _ t
congruencedrule (MRules t) = MTypingRule-CRule _ t

{-
General typing rules are very similar to typing rules of metavariables, except that they are using
[MTypingRule] instead of [BMTypingRule] for the premises.
-}

data TypingRulePremises : {Σ : Signature} (E : DerivabilityStructure Σ) (args : SyntaxArityArgs) → Set

extend^M : {Σ : Signature} (E : DerivabilityStructure Σ) {args : SyntaxArityArgs} (ts : TypingRulePremises E args) → DerivabilityStructure (ExtSig^ Σ args)

data TypingRulePremises where
  [] : ∀ {Σ} {E : DerivabilityStructure Σ} → TypingRulePremises E []
  _,_ : ∀ {Σ} {E : DerivabilityStructure Σ} {args : SyntaxArityArgs} {m : ℕ} {k : SyntaxSort}
      → (ts : TypingRulePremises E args)
      → (t : MTypingRule (extend^M E ts) m k)
      → TypingRulePremises E (args , (m , k))

extend^M E [] = E
extend^M E (ts , t) = extend (extend^M E ts) (MRules t)

data TypingRule {Σ : Signature} (E : DerivabilityStructure Σ) (args : SyntaxArityArgs) : (k : SyntaxSort) → Set where
  Ty : TypingRulePremises E args → TypingRule E args Ty
  Tm : (ts : TypingRulePremises E args) → BMTypingRule (extend^M E ts) → TypingRule E args Tm

{- The derivation rules associated to a typing rule. -}

{- List of all the last [n] variables in scope [m + n] -}
Vars : {Σ : Signature} {n : ℕ} (m : ℕ) → Args Σ (m + n) (MArityArgs n)
Vars {n = zero} m = []
Vars {n = suc n} m = weakenA {{≤-+ {m + n} {1}}} last (Vars m) , var last

{-
[check-DepCtx ↑ as ts Δ] checks that the premises [ts] correspond to the dependent context [Δ],
where [as] corresponds to the interpretations of the metavariables.
-}
check-DepCtx : {Σ Σ' : Signature} {m n : ℕ} {args : SyntaxArityArgs}
               {E : DerivabilityStructure (ExtSig^ Σ args)}
               → (Σ →Sig Σ') m → Args Σ' m args
               → MTypingRulePremises E n → DepCtx Σ' m n → Prop
check-DepCtx ↑ as [] ◇ = ⊤
check-DepCtx {m = m} {n = suc n} ↑ as (ts , t) (Δ , A) =
  ΣP (check-DepCtx ↑ as ts Δ)
  (λ _ → A ≡ ↑Expr (SubstM (liftSig ↑) (weakenAL as)) (↑Expr (SubstM idSig (Vars m)) (weaken0 (type t))))

TypingRule-TArgs : {Σ Σ' : Signature} (E : DerivabilityStructure Σ) {args : SyntaxArityArgs} {m : ℕ} (↑ : (Σ →Sig Σ') m) {Γ : Ctx Σ' m}
                   (ts : TypingRulePremises E args) (js : DerivationRulePremises Σ' Γ (TArityArgs args))
                   → Partial (Args Σ' m args)
TypingRule-TArgs E ↑ [] [] = return []
TypingRule-TArgs E ↑ (ts , Ty t's) (js , Δ ⊢ A) = do
  as ← TypingRule-TArgs E ↑ ts js
  assume (check-DepCtx ↑ as t's Δ)
  return (as , A)
TypingRule-TArgs E {m = m} ↑ (ts , Tm t's t) (_,_ {m = m'} js (Δ ⊢ u :> A)) = do
  as ← TypingRule-TArgs E ↑ ts js
  assume (check-DepCtx ↑ as t's Δ)
  assume (A ≡ ↑Expr (SubstM (liftSig ↑) (weakenAL as)) (↑Expr (SubstM idSig (Vars m)) (weaken0 (type t))))
  return (as , u)

TypingRule-TRule : {Σ : Signature} (E : DerivabilityStructure Σ) {args : SyntaxArityArgs} {k : SyntaxSort}
                   (t : TypingRule E args k)
                   → DerivationRule (ExtSig Σ (args , k)) (TArity (args , k))
rule (TypingRule-TRule E (Ty ts)) ↑ Γ js = do
  as ← TypingRule-TArgs E (Ext→ ↑) ts js
  return (◇ ⊢ (↑ $ new) as)
rule (TypingRule-TRule E (Tm ts t)) ↑ Γ js = do
  as ← TypingRule-TArgs E (Ext→ ↑) ts js
  return (◇ ⊢ (↑ $ new) as :> ↑Expr (SubstM (Ext→ ↑) as) (weaken0 (type t)))

TypingRule-CArgs : {Σ Σ' : Signature} (E : DerivabilityStructure Σ) {args : SyntaxArityArgs} {m : ℕ} (↑ : (Σ →Sig Σ') m) {Γ : Ctx Σ' m}
                   (ts : TypingRulePremises E args) (js : DerivationRulePremises Σ' Γ (CArityArgs args))
                   → Partial (Args Σ' m args × Args Σ' m args)
TypingRule-CArgs E ↑ [] [] = return ([] , [])
TypingRule-CArgs E {args = args , (n , Ty)} {m} ↑ (ts , Ty t's) (js , Δ ⊢ A == A') = do
  (as , as') ← TypingRule-CArgs E ↑ ts js
  assume (check-DepCtx ↑ as t's Δ)
  return ((as , A) , (as' , A'))
TypingRule-CArgs E {args = args , (n , Tm)} {m} ↑ (ts , Tm t's t) (js , Δ ⊢ u == u' :> A) = do
  (as , as') ← TypingRule-CArgs E ↑ ts js
  assume (check-DepCtx ↑ as t's Δ)
  assume (A ≡ ↑Expr (SubstM (liftSig ↑) (weakenAL as)) (↑Expr (SubstM idSig (Vars m)) (weaken0 (type t))))
  return ((as , u) , (as' , u'))

TypingRule-CRule : {Σ : Signature} (E : DerivabilityStructure Σ) {args : SyntaxArityArgs} {k : SyntaxSort}
                   (t : TypingRule E args k)
                   → DerivationRule (ExtSig Σ (args , k)) (CArity (args , k))
rule (TypingRule-CRule E (Ty ts)) ↑ Γ js = do
  (as , as') ← TypingRule-CArgs E (Ext→ ↑) ts js
  return (◇ ⊢ (↑ $ new) as == (↑ $ new) as')
rule (TypingRule-CRule E (Tm ts t)) {n = n} ↑ Γ js = do
  (as , as') ← TypingRule-CArgs E (Ext→ ↑) ts js
  return (◇ ⊢ (↑ $ new) as == (↑ $ new) as' :> ↑Expr (SubstM (Ext→ ↑) as) (weaken0 (type t)))

TRules : {Σ : Signature} {E : DerivabilityStructure Σ} {ar : SyntaxArity}
        (t : TypingRule E (args ar) (sort ar))
        → DerivationRules E ar
typingdrule (TRules t) = TypingRule-TRule _ t
congruencedrule (TRules t) = TypingRule-CRule _ t

{-
Γ ⊢ A == A'
Γ , x : A ⊢ B == B'
--------------------
Γ ⊢ Π A B == Π A' B'
-}

{- Equality rules -}

{-
[extendE E tc] extends the derivability structure with one single (equality) rule
-}

data ExtE (A : JudgmentArity → Set) (nar : JudgmentArity) : JudgmentArity → Set where
  equalityrule : ExtE A nar nar
  prev : {jar : JudgmentArity} → A jar → ExtE A nar jar

extendE : {Σ : Signature} (E : DerivabilityStructure Σ)
          {ar : JudgmentArity}
          (tc : DerivationRule Σ ar)
          → DerivabilityStructure Σ
Rules (extendE E {ar} tc) S = Rules E S
Rules (extendE E {ar} tc) T = Rules E T
Rules (extendE E {ar} tc) C = Rules E C
Rules (extendE E {ar} tc) Eq = ExtE (Rules E Eq) ar
derivationRule (extendE E tc) {S} r = derivationRule E r
derivationRule (extendE E tc) {T} r = derivationRule E r
derivationRule (extendE E tc) {C} r = derivationRule E r
derivationRule (extendE E tc) {Eq} (prev r) = derivationRule E r
derivationRule (extendE E tc) {Eq} equalityrule = tc

-- data ExtE (A : Tag → JudgmentArity → Set) (nar : JudgmentArity) : Tag → JudgmentArity → Set where
--   equalityrule : ExtE A nar Eq nar
--   prev : {t : Tag} {jar : JudgmentArity} → A t jar → ExtE A nar t jar

-- extendE : {Σ : Signature} (E : DerivabilityStructure Σ)
--           {ar : JudgmentArity}
--           (tc : {n : ℕ} → DerivationRule Σ ar n)
--           → DerivabilityStructure Σ
-- Rules (extendE E {ar} tc) = ExtE (Rules E) ar
-- derivationRule (extendE E tc) (prev r) = derivationRule E r
-- derivationRule (extendE E tc) equalityrule = tc

record TermEquality {Σ : Signature} (E : DerivabilityStructure Σ) : Set where
  constructor _<:_/_//_/_
  field
    type : TyExpr Σ 0
    term1 : TmExpr Σ 0
    der1 : Derivable E {Γ = ◇} (◇ ⊢ term1 :> type)
    term2 : TmExpr Σ 0
    der2 : Derivable E {Γ = ◇} (◇ ⊢ term2 :> type)
open BMTypingRule public

data EqualityRule {Σ : Signature} (E : DerivabilityStructure Σ) (args : SyntaxArityArgs) : (k : SyntaxSort) → Set where
  Ty= : (ts : TypingRulePremises E args) (A B : BMTypingRule (extend^M E ts)) → EqualityRule E args Ty
  Tm= : (ts : TypingRulePremises E args) (A : TermEquality (extend^M E ts)) → EqualityRule E args Tm

ERule : {Σ : Signature} {E : DerivabilityStructure Σ} {args : SyntaxArityArgs} {k : SyntaxSort}
        → EqualityRule E args k
        → DerivationRule Σ (TArityArgs args , SStoJS= k)
rule (ERule {E = E} (Ty= ts A B)) ↑ Γ js = do
  as ← TypingRule-TArgs E ↑ ts js
  return (◇ ⊢ (↑Expr (SubstM ↑ as) (weaken0 (A .type))) == (↑Expr (SubstM ↑ as) (weaken0 (B .type))))
rule (ERule {E = E} (Tm= ts (A <: u / _ // v / _))) ↑ Γ js = do
  as ← TypingRule-TArgs E ↑ ts js
  return (◇ ⊢ (↑Expr (SubstM ↑ as) (weaken0 u)) == (↑Expr (SubstM ↑ as) (weaken0 v)) :> ↑Expr (SubstM ↑ as) (weaken0 A))


------------------------------------------------------------------------
-- Parsers containing non-terminals, and grammars using such parsers
------------------------------------------------------------------------

module StructurallyRecursiveDescentParsing.Grammar where

open import Data.Bool
open import Data.Empty
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Codata.Musical.Notation
open import Level

open import StructurallyRecursiveDescentParsing.Index
import StructurallyRecursiveDescentParsing.Simplified as Simplified
open Simplified hiding (Parser; module Parser; ⟦_⟧)

infixl 10 _!>>=_ _?>>=_
infixl  5 _∣_

-- The parsers are parameterised on a type of nonterminals.

data Parser (NT : NonTerminalType) (Tok : Set) : NonTerminalType where
  return : ∀ {R} (x : R) → Parser NT Tok (true ◇ ε) R

  fail   : ∀ {R} → Parser NT Tok (false ◇ ε) R

  token  : Parser NT Tok (false ◇ ε) Tok

  _∣_    : ∀ {e₁ e₂ c₁ c₂ R}
           (p₁ : Parser NT Tok (e₁      ◇ c₁     ) R)
           (p₂ : Parser NT Tok (     e₂ ◇      c₂) R) →
                 Parser NT Tok (e₁ ∨ e₂ ◇ c₁ ∪ c₂) R

  _?>>=_ : ∀ {e₂ c₁ c₂ R₁ R₂}
           (p₁ :      Parser NT Tok (true ◇ c₁     ) R₁)
           (p₂ : R₁ → Parser NT Tok (e₂   ◇      c₂) R₂) →
                      Parser NT Tok (e₂   ◇ c₁ ∪ c₂) R₂

  _!>>=_ : ∀ {c₁ R₁ R₂} {i₂ : R₁ → Index}
           (p₁ :               Parser NT Tok (false ◇ c₁) R₁)
           (p₂ : (x : R₁) → ∞ (Parser NT Tok (i₂ x)       R₂)) →
                               Parser NT Tok (false ◇ c₁) R₂

  !      : ∀ {e c R} (nt : NT (e ◇ c) R) → Parser NT Tok (e ◇ c ∪ ε) R

-- Grammars.

Grammar : NonTerminalType → Set → Set1
Grammar NT Tok = ∀ {i R} → NT i R → Parser NT Tok i R

-- An empty non-terminal type.

EmptyNT : NonTerminalType
EmptyNT _ _ = Lift _ ⊥

-- An empty grammar.

emptyGrammar : ∀ {Tok} → Grammar EmptyNT Tok
emptyGrammar (lift ())

-- The semantics of grammar-based parsers is defined in terms of their
-- translation into "plain" parsers. The translation instantiates all
-- non-terminals corecursively.

⟦_⟧ : ∀ {Tok NT e c R} →
      Parser NT Tok (e ◇ c) R → Grammar NT Tok →
      Simplified.Parser Tok e R
⟦ return x   ⟧ g = return x
⟦ fail       ⟧ g = fail
⟦ token      ⟧ g = token
⟦ p₁ ∣ p₂    ⟧ g = ⟦ p₁ ⟧ g ∣ ⟦ p₂ ⟧ g
⟦ p₁ ?>>= p₂ ⟧ g = ⟦ p₁ ⟧ g ?>>= λ x →   ⟦    p₂ x  ⟧ g
⟦ p₁ !>>= p₂ ⟧ g = ⟦ p₁ ⟧ g !>>= λ x → ♯ ⟦ ♭ (p₂ x) ⟧ g
⟦ ! nt       ⟧ g = ⟦ g nt ⟧ g

-- Note that some "plain" parsers cannot be directly rewritten using
-- the parser type in this module (although there may be /equivalent/
-- parsers):

private

  only-plain : Simplified.Parser Bool false Bool
  only-plain = return true ?>>= λ x →
               if x then token else token ∣ token

  -- The following code does not type-check.

  -- doesnt-work : Parser EmptyNT Bool (false ◇ _) Bool
  -- doesnt-work = return true ?>>= λ x →
  --               if x then token else token ∣ token

-- A map function which can be useful when combining grammars.

mapNT : ∀ {NT₁ NT₂ Tok i R} →
        (∀ {i R} → NT₁ i R → NT₂ i R) →
        Parser NT₁ Tok i R → Parser NT₂ Tok i R
mapNT f (return x)   = return x
mapNT f fail         = fail
mapNT f token        = token
mapNT f (p₁ ∣ p₂)    = mapNT f p₁ ∣ mapNT f p₂
mapNT f (p₁ ?>>= p₂) = mapNT f p₁ ?>>= λ x →   mapNT f    (p₂ x)
mapNT f (p₁ !>>= p₂) = mapNT f p₁ !>>= λ x → ♯ mapNT f (♭ (p₂ x))
mapNT f (! nt)       = ! (f nt)


module calculus where

open import utility

open import Esterel.Lang
open import Esterel.Lang.Binding
open import Esterel.Lang.Properties
open import Esterel.Lang.CanFunction
  using (Canθₛ ; Canθₛₕ ; [S]-env)
open import Esterel.Environment as Env
  using (Env ; Θ ; _←_ ; sig ; []env ; module SigMap ; module ShrMap ; module VarMap)
open import Esterel.Context
  using (EvaluationContext ; EvaluationContext1 ; _⟦_⟧e ; _≐_⟦_⟧e ;
         Context ; Context1 ; _⟦_⟧c ; _≐_⟦_⟧c)
open import Esterel.Variable.Signal as Signal
  using (Signal)
open import Esterel.Variable.Shared as SharedVar
  using (SharedVar)
open import Esterel.Variable.Sequential as SeqVar
  using (SeqVar)
open import Esterel.Context.Properties

open import Relation.Nullary
  using (¬_)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl)
open import Data.Empty
  using (⊥ ; ⊥-elim)
import Data.FiniteMap
open import Data.List
  using (List ; _∷_ ; [] ; _++_)
open import Data.List.All as All
  using (All ; _∷_ ; [])
open import Data.Nat
  using (ℕ ; zero ; suc ; _+_) renaming (_⊔_ to _⊔ℕ_)
open import Data.Product
  using (Σ-syntax ; Σ ; _,_ ; proj₁ ; proj₂ ; _×_ ; _,′_)
open import Data.Sum
  using (_⊎_ ; inj₁ ; inj₂)
open import Relation.Binary.PropositionalEquality

open import sn-calculus

open _≐_⟦_⟧e
open _≐_⟦_⟧c

open EvaluationContext1
open Context1

infix 4 _⟶₁_
infix 4 _⟶_
infix 4 _⟶*_

data _⟶₁_ : Term → Term → Set where
  [par-swap] : ∀{p q} →
    (p ∥ q) ⟶₁ (q ∥ p)

  [par-nothing] : ∀ {q} ->
    done q ->
    (nothin ∥ q) ⟶₁ q

  [par-1exit] : ∀ {q} -> ∀ n ->
    (pausedq : paused q) ->
    (exit n ∥ q) ⟶₁ exit n

  [par-2exit] : ∀ n m ->
    (exit n ∥ exit m) ⟶₁ exit (n ⊔ℕ m)

  [is-present] : ∀{θ r p q E A} → ∀ S ->
    (S∈ : (Env.isSig∈ S θ)) →
    (θ[S]≡present : Env.sig-stats{S} θ S∈ ≡ Signal.present) →
    (de : r ≐ E ⟦ present S ∣⇒ p ∣⇒ q ⟧e) →
    (ρ⟨ θ , A ⟩· r) ⟶₁ (ρ⟨ θ , A ⟩· E ⟦ p ⟧e)

  [is-absent] : ∀{θ r p q E A} → ∀ S ->
    (S∈ : (Env.isSig∈ S θ)) →
    (θ[S]≡absent : Env.sig-stats{S} θ S∈ ≡ Signal.absent) →
    (de : r ≐ E ⟦ present S ∣⇒ p ∣⇒ q ⟧e) →
    (ρ⟨ θ , A ⟩· r) ⟶₁ (ρ⟨ θ , A ⟩· E ⟦ q ⟧e)

  [emit] : ∀{θ r S E} →
    (S∈ : (Env.isSig∈ S θ)) →
    (¬S≡a : ¬ (Env.sig-stats{S} θ S∈) ≡ Signal.absent) →
    (de : r ≐ E ⟦ emit S ⟧e) →
    (ρ⟨ θ , GO ⟩· r) ⟶₁
    (ρ⟨ (Env.set-sig{S} θ S∈ Signal.present) , GO ⟩·
      E ⟦ nothin ⟧e)

  [loop-unroll] : ∀{p} →
    (loop p)
    ⟶₁
    (loopˢ p p)

  [seq-done] : ∀{q} →
    (nothin >> q) ⟶₁ q

  [seq-exit] : ∀{q n} →
    (exit n >> q) ⟶₁ (exit n)

  [loopˢ-exit] : ∀{q n} →
    (loopˢ (exit n) q) ⟶₁ (exit n)

  [suspend-done] : ∀{p S} →
    (haltedp : halted p) →
    (suspend p S) ⟶₁ p

  -- traps
  [trap-done] : ∀{p} →
    (haltedp : halted p) →
    (trap p) ⟶₁ (↓ haltedp)

  -- lifting signals
  [raise-signal] : ∀{p S} →
    (signl S p) ⟶₁
    (ρ⟨ (Θ SigMap.[ S ↦ Signal.unknown ] ShrMap.empty VarMap.empty) , WAIT ⟩·
      p)

  -- shared state
  [raise-shared] : ∀{θ r s e p E A} →
    (all-readyeθ : all-ready e θ) →
    (de : r ≐ E ⟦ shared s ≔ e in: p ⟧e) →
    (ρ⟨ θ , A ⟩· r) ⟶₁
    (ρ⟨ θ , A ⟩· E ⟦ (ρ⟨ [s,δe]-env s (δ all-readyeθ) , WAIT ⟩· p) ⟧e)

  [set-shared-value-old] : ∀{θ r s e E} →
    (e' : all-ready e θ) →
    (s∈ : (Env.isShr∈ s θ)) →
    (θ[s]≡old : Env.shr-stats{s} θ s∈ ≡ SharedVar.old) →
    (de : r ≐ E ⟦ s ⇐ e ⟧e) →
    (ρ⟨ θ , GO ⟩· r) ⟶₁
    (ρ⟨ (Env.set-shr{s} θ s∈ (SharedVar.new) (δ e')) , GO ⟩·
      E ⟦ nothin ⟧e)

  [set-shared-value-new] : ∀{θ r s e E} →
    (e' : all-ready e θ) →
    (s∈ : (Env.isShr∈ s θ)) →
    (θ[s]≡n : Env.shr-stats{s} θ s∈ ≡ SharedVar.new) →
    (de : r ≐ E ⟦ s ⇐ e ⟧e) →
    (ρ⟨ θ , GO ⟩· r) ⟶₁
    (ρ⟨ (Env.set-shr{s} θ s∈ (SharedVar.new) (Env.shr-vals{s} θ s∈ + δ e')) , GO ⟩·
      E ⟦ nothin ⟧e)

  -- unshared state
  [raise-var] : ∀{θ r x p e E A} →
    (all-readyeθ : all-ready e θ) →
    (de : r ≐ E ⟦ var x ≔ e in: p ⟧e) →
    (ρ⟨ θ , A ⟩· r) ⟶₁
    (ρ⟨ θ , A ⟩·
      E ⟦ (ρ⟨ [x,δe]-env x (δ all-readyeθ) , WAIT ⟩· p) ⟧e)

  [set-var] : ∀{θ r x e E A} →
    (x∈ : (Env.isVar∈ x θ)) →
    (all-readyeθ : all-ready e θ) →
    (de : r ≐ E ⟦ x ≔ e ⟧e) →
    (ρ⟨ θ , A ⟩· r) ⟶₁
    (ρ⟨ (Env.set-var{x} θ x∈ (δ all-readyeθ)) , A ⟩·
      E ⟦ nothin ⟧e)

  -- if
  [if-false] : ∀{θ r p q x E A} →
    (x∈ : (Env.isVar∈ x θ)) →
    (θ[x]≡z : Env.var-vals{x} θ x∈ ≡ zero) →
    (de : r ≐ E ⟦ if x ∣⇒ p ∣⇒ q ⟧e) →
    (ρ⟨ θ , A ⟩· r) ⟶₁ (ρ⟨ θ , A ⟩· E ⟦ q ⟧e)

  [if-true] : ∀{θ r p q x E n A} →
    (x∈ : (Env.isVar∈ x θ)) →
    (θ[x]≡s : Env.var-vals{x} θ x∈ ≡ suc n) →
    (de : r ≐ E ⟦ if x ∣⇒ p ∣⇒ q ⟧e) →
    (ρ⟨ θ , A ⟩· r) ⟶₁ (ρ⟨ θ , A ⟩· E ⟦ p ⟧e)

  -- progression
  [absence] : ∀{θ p A} -> ∀ S →
    (S∈ : (Env.isSig∈ S θ)) →
    (θ[S]≡unknown : Env.sig-stats{S} θ S∈ ≡ Signal.unknown) →
    (S∉Canθₛ : (Signal.unwrap S) ∉ Canθₛ (sig θ) 0 p []env) →
    (ρ⟨ θ , A ⟩· p) ⟶₁
    (ρ⟨ (Env.set-sig{S} θ S∈ (Signal.absent)) , A ⟩·
      p)

  [readyness] : ∀{θ p A} -> ∀ s →
    (s∈ : (Env.isShr∈ s θ)) →
    (θ[s]≡old⊎θ[s]≡new : (Env.shr-stats{s} θ s∈ ≡ SharedVar.old) ⊎
                         (Env.shr-stats{s} θ s∈ ≡ SharedVar.new)) →
    (s∉Canθₛₕ : (SharedVar.unwrap s) ∉ Canθₛₕ (sig θ) 0 p []env) →
    (ρ⟨ θ , A ⟩· p) ⟶₁
    (ρ⟨ (Env.set-shr{s} θ s∈ (SharedVar.ready) (Env.shr-vals{s} θ s∈)) , A ⟩·
      p)

  [merge] : ∀{θ₁ θ₂ r p E A₁ A₂} →
    (de : r ≐ E ⟦ ρ⟨ θ₂ , A₂ ⟩· p ⟧e) →
    (ρ⟨ θ₁ , A₁ ⟩· r) ⟶₁ (ρ⟨ (θ₁ ← θ₂) , (A-max A₁ A₂) ⟩· E ⟦ p ⟧e)

-- The compatible closure of _⟶₁_.
data _⟶_ : Term → Term → Set where
  [context] : ∀{r p p'} →
    (C : Context) →
    (dc : r ≐ C ⟦ p ⟧c) →
    (p⟶₁p' : p ⟶₁ p') →
    r ⟶ (C ⟦ p' ⟧c)

-- The reflexive transitive closure of ⟶
data _⟶*_ : Term → Term → Set where
  [refl] : ∀{p} → (p ⟶* p)
  [step] : ∀{p q r} → (p⟶q : p ⟶ q) → (q⟶*r : q ⟶* r) → (p ⟶* r)

data _≡ₑ_#_ : Term -> Term -> List Context1 -> Set where

  ≡ₑrefl : ∀ {p C} ->

    ------------
     p ≡ₑ p # C

  ≡ₑtran : ∀ {p r q C} ->

     (p≡ₑr#C : p ≡ₑ r # C) ->
     (r≡ₑq#C : r ≡ₑ q # C) ->
    -----------------------
      p ≡ₑ q # C

  ≡ₑsymm : ∀ {p q C BVq FVq} ->

     (CBq : CorrectBinding (C ⟦ q ⟧c) BVq FVq) ->
     (q≡ₑp : q ≡ₑ p # C) ->
    -------------------------------------------
      p ≡ₑ q # C

  ≡ₑctxt : ∀ {C C′ p q C′⟦p⟧ C′⟦q⟧ } ->

     (C′⟦p⟧≐C′⟦p⟧c : C′⟦p⟧ ≐ C′ ⟦ p ⟧c) ->
     (C′⟦q⟧≐C′⟦q⟧c : C′⟦q⟧ ≐ C′ ⟦ q ⟧c) ->
     (p≡ₑq : p ≡ₑ q # (C ++ C′)) ->
    -----------------------------------
     C′⟦p⟧ ≡ₑ C′⟦q⟧ # C

  ≡ₑstep : ∀ {C p q} ->

     (p⟶₁q : p ⟶₁ q) ->
    --------------------
     p ≡ₑ q # C


-- MIT License

-- Copyright (c) 2021 Luca Ciccone and Luca Padovani

-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use,
-- copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the
-- Software is furnished to do so, subject to the following
-- conditions:

-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.

-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
-- OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
-- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
-- OTHER DEALINGS IN THE SOFTWARE.

{-# OPTIONS --guardedness --sized-types #-}

open import Data.Empty
open import Data.Product
open import Data.Sum
open import Data.List using ([]; _∷_; _∷ʳ_; _++_)
open import Data.List.Properties using (∷-injective)

open import Relation.Nullary
open import Relation.Nullary.Negation using (contraposition)
open import Relation.Unary using (_∈_; _∉_; _⊆_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; subst; subst₂; cong)
open import Relation.Binary.Construct.Closure.ReflexiveTransitive using (ε; _◅_)

open import Function.Base using (case_of_)

open import Common

module Discriminator {ℙ : Set} (message : Message ℙ)
  where

open import Trace message
open import SessionType message
open import HasTrace message
open import TraceSet message
open import Transitions message
open import Subtyping message
open import Divergence message
open import Session message
open import Semantics message

make-diverge-backward :
  ∀{T S α}
  (tα : T HasTrace (α ∷ []))
  (sα : S HasTrace (α ∷ [])) ->
  T ↑ S ->
  after tα ↑ after sα ->
  DivergeBackward tα sα
make-diverge-backward tα sα divε divα none = divε
make-diverge-backward tα sα divε divα (some none) =
  subst₂ (λ u v -> after u ↑ after v) (sym (⊑-has-trace-after tα)) (sym (⊑-has-trace-after sα)) divα

has-trace-after-split :
  ∀{T φ ψ} ->
  (tφ : T HasTrace φ)
  (tφψ : T HasTrace (φ ++ ψ)) ->
  has-trace-after tφ (split-trace tφ tφψ) ≡ tφψ
has-trace-after-split (_ , tdef , refl) tφψ = refl
has-trace-after-split (_ , tdef , step inp tr) (_ , sdef , step inp sr)
  rewrite has-trace-after-split (_ , tdef , tr) (_ , sdef , sr) = refl
has-trace-after-split (T , tdef , step (out fx) tr) (S , sdef , step (out gx) sr)
  rewrite has-trace-after-split (_ , tdef , tr) (_ , sdef , sr) =
  cong (S ,_) (cong (sdef ,_) (cong (λ z -> step z sr) (cong out (Defined-eq (transitions+defined->defined sr sdef) gx))))

disc-set-has-outputs :
  ∀{T S φ x} ->
  T <: S ->
  φ ∈ DiscSet T S ->
  T HasTrace (φ ∷ʳ O x) ->
  S HasTrace φ ->
  φ ∷ʳ O x ∈ DiscSet T S
disc-set-has-outputs {_} {S} {φ} {x} sub (inc tφ sφ div←φ) tφx _ with S HasTrace? (φ ∷ʳ O x)
... | yes sφx =
  let tφ/x = split-trace tφ tφx in
  let sφ/x = split-trace sφ sφx in
  let divφ = subst₂ (λ u v -> after u ↑ after v) (⊑-has-trace-after tφ) (⊑-has-trace-after sφ) (div←φ (⊑-refl φ)) in
  let divx = _↑_.divergence divφ {[]} {x} none tφ/x sφ/x in
  let divφ←x = make-diverge-backward tφ/x sφ/x divφ divx in
  let div←φx = subst₂ DivergeBackward (has-trace-after-split tφ tφx) (has-trace-after-split sφ sφx) (append-diverge-backward tφ sφ tφ/x sφ/x div←φ divφ←x) in
  inc tφx sφx div←φx
... | no nsφx = exc refl tφ sφ tφx nsφx div←φ
disc-set-has-outputs sub (exc eq tψ sψ tφ nsφ div←ψ) tφx sφ = ⊥-elim (nsφ sφ)

defined-becomes-nil :
  ∀{T φ S} ->
  Defined T ->
  ¬ Defined S ->
  Transitions T φ S ->
  ∃[ ψ ] ∃[ x ] (φ ≡ ψ ∷ʳ I x × T HasTrace ψ × ¬ T HasTrace φ)
defined-becomes-nil def ndef refl = ⊥-elim (ndef def)
defined-becomes-nil def ndef (step (inp {_} {x}) refl) =
  [] , x , refl , (_ , inp , refl) , inp-has-no-trace λ { (_ , def , refl) → ⊥-elim (ndef def) }
defined-becomes-nil def ndef (step inp tr@(step t _)) with defined-becomes-nil (transition->defined t) ndef tr
... | ψ , x , eq , tψ , ntφ =
  I _ ∷ ψ , x , cong (I _ ∷_) eq , inp-has-trace tψ , inp-has-no-trace ntφ
defined-becomes-nil def ndef (step (out fx) tr) with defined-becomes-nil fx ndef tr
... | ψ , x , refl , tψ , ntφ =
  O _ ∷ ψ , x , refl , out-has-trace tψ , out-has-no-trace ntφ

sub+diverge->defined : ∀{T S} -> T <: S -> T ↑ S -> Defined T × Defined S
sub+diverge->defined nil<:any div with _↑_.with-trace div
... | _ , def , tr = ⊥-elim (contraposition (transitions+defined->defined tr) (λ ()) def)
sub+diverge->defined (end<:def (inp _) def) _ = inp , def
sub+diverge->defined (end<:def (out _) def) _ = out , def
sub+diverge->defined (inp<:inp _ _) _ = inp , inp
sub+diverge->defined (out<:out _ _ _) _ = out , out

sub+diverge->has-empty-trace : ∀{T S} -> T <: S -> T ↑ S -> DiscSet T S []
sub+diverge->has-empty-trace nil<:any div with _↑_.with-trace div
... | tφ = ⊥-elim (nil-has-no-trace tφ)
sub+diverge->has-empty-trace (end<:def e def) div with _↑_.with-trace div | _↑_.without-trace div
... | tφ | nsφ rewrite end-has-empty-trace e tφ = ⊥-elim (nsφ (defined->has-empty-trace def))
sub+diverge->has-empty-trace (inp<:inp _ _) div = inc (_ , inp , refl) (_ , inp , refl) λ { none → div }
sub+diverge->has-empty-trace (out<:out _ _ _) div = inc (_ , out , refl) (_ , out , refl) λ { none → div }

discriminator : SessionType -> SessionType -> SessionType
discriminator T S = decode (co-semantics (disc-set->semantics T S)) .force

discriminator-disc-set-sub : (T S : SessionType) -> CoSet ⟦ discriminator T S ⟧ ⊆ DiscSet T S
discriminator-disc-set-sub T S rφ =
  co-inversion {DiscSet T S} (decode-sub (co-semantics (disc-set->semantics T S)) rφ)

discriminator-disc-set-sup : (T S : SessionType) -> DiscSet T S ⊆ CoSet ⟦ discriminator T S ⟧
discriminator-disc-set-sup T S dφ =
  decode-sup (co-semantics (disc-set->semantics T S)) (co-definition {DiscSet T S} dφ)

sub+diverge->discriminator-defined : ∀{T S} -> T <: S -> T ↑ S -> Defined (discriminator T S)
sub+diverge->discriminator-defined {T} {S} sub div =
  has-trace->defined (co-set-right->left {DiscSet T S} {⟦ discriminator T S ⟧} (discriminator-disc-set-sup T S) (co-definition {DiscSet T S} {[]} (sub+diverge->has-empty-trace sub div)))

input-does-not-win :
  ∀{T S φ x} (tφ : T HasTrace φ) -> Transitions T (φ ∷ʳ I x) S -> ¬ Win (after tφ)
input-does-not-win (_ , _ , refl) (step inp _) ()
input-does-not-win (_ , def , step inp tr) (step inp sr) w = input-does-not-win (_ , def , tr) sr w
input-does-not-win (_ , def , step (out _) tr) (step (out _) sr) w = input-does-not-win (_ , def , tr) sr w

ends-with-output->has-trace : ∀{T S φ x} -> Transitions T (φ ∷ʳ O x) S -> T HasTrace (φ ∷ʳ O x)
ends-with-output->has-trace tr = _ , output-transitions->defined tr , tr

co-trace-swap : ∀{φ ψ} -> co-trace φ ≡ ψ -> φ ≡ co-trace ψ
co-trace-swap {φ} eq rewrite sym eq rewrite co-trace-involution φ = refl

co-trace-swap-⊑ : ∀{φ ψ} -> co-trace φ ⊑ ψ -> φ ⊑ co-trace ψ
co-trace-swap-⊑ {[]} none = none
co-trace-swap-⊑ {α ∷ _} (some le) rewrite co-action-involution α = some (co-trace-swap-⊑ le)

co-maximal : ∀{X φ} -> φ ∈ Maximal X -> co-trace φ ∈ Maximal (CoSet X)
co-maximal {X} (maximal xφ F) =
  maximal (co-definition {X} xφ) λ le xψ -> let le' = co-trace-swap-⊑ le in
                                             let eq = F le' xψ in
                                             co-trace-swap eq

co-maximal-2 : ∀{X φ} -> co-trace φ ∈ Maximal (CoSet X) -> φ ∈ Maximal X
co-maximal-2 {X} (maximal wit F) =
  maximal (co-inversion {X} wit) λ le xψ -> let le' = ⊑-co-trace le in
                                             let eq = F le' (co-definition {X} xψ) in
                                             co-trace-injective eq

co-trace->co-set : ∀{X φ} -> co-trace φ ∈ Maximal X -> φ ∈ Maximal (CoSet X)
co-trace->co-set {_} {φ} cxφ with co-maximal cxφ
... | res rewrite co-trace-involution φ = res

discriminator-after-sync->defined :
  ∀{R T S T' φ} ->
  T <: S ->
  (rdef : Defined (discriminator T S))
  (rr : Transitions (discriminator T S) (co-trace φ) R)
  (tr : Transitions T φ T') ->
  Defined R
discriminator-after-sync->defined {R} {T} {S} sub rdef rr tr with Defined? R
... | yes rdef' = rdef'
... | no nrdef' with defined-becomes-nil rdef nrdef' rr
... | ψ , x , eq , rψ , nrφ rewrite eq with input-does-not-win rψ rr
... | nwin with contraposition (decode+maximal->win (co-semantics (disc-set->semantics T S)) rψ) nwin
... | ncψ with decode-sub (co-semantics (disc-set->semantics T S)) rψ
... | dsψ with contraposition (disc-set-maximal-1 dsψ) (contraposition co-trace->co-set ncψ)
... | nnsψ with has-trace-double-negation nnsψ
... | sψ with (let tr' = subst (λ z -> Transitions _ z _) (co-trace-swap eq) tr in
              let tr'' = subst (λ z -> Transitions _ z _) (co-trace-++ ψ (I x ∷ [])) tr' in
              ends-with-output->has-trace tr'')
... | tψ with disc-set-has-outputs sub dsψ tψ sψ
... | dsφ with decode-sup (co-semantics (disc-set->semantics T S)) (co-definition {DiscSet T S} dsφ)
... | rφ = let rφ' = subst (_ HasTrace_) (co-trace-++ (co-trace ψ) (O x ∷ [])) rφ in
           let rφ'' = subst (λ z -> _ HasTrace (z ++ _)) (co-trace-involution ψ) rφ' in
           ⊥-elim (nrφ rφ'')

after-trace-defined : ∀{T T' φ} -> T HasTrace φ -> Transitions T φ T' -> Defined T'
after-trace-defined (_ , def , refl) refl = def
after-trace-defined (_ , def , step inp tr) (step inp sr) = after-trace-defined (_ , def , tr) sr
after-trace-defined (_ , def , step (out _) tr) (step (out _) sr) = after-trace-defined (_ , def , tr) sr

after-trace-defined-2 : ∀{T φ} (tφ : T HasTrace φ) -> Defined (after tφ)
after-trace-defined-2 (_ , def , _) = def

⊑-after : ∀{φ ψ} -> φ ⊑ ψ -> Trace
⊑-after {_} {ψ} none = ψ
⊑-after (some le) = ⊑-after le

⊑-after-co-trace : ∀{φ ψ} (le : φ ⊑ ψ) -> ⊑-after (⊑-co-trace le) ≡ co-trace (⊑-after le)
⊑-after-co-trace none = refl
⊑-after-co-trace (some le) = ⊑-after-co-trace le

extend-transitions :
  ∀{T S φ ψ}
  (le : φ ⊑ ψ)
  (tr : Transitions T φ S)
  (tψ : T HasTrace ψ) ->
  Transitions S (⊑-after le) (after tψ)
extend-transitions none refl (_ , _ , sr) = sr
extend-transitions (some le) (step inp tr) (_ , sdef , step inp sr) = extend-transitions le tr (_ , sdef , sr)
extend-transitions (some le) (step (out _) tr) (_ , sdef , step (out _) sr) = extend-transitions le tr (_ , sdef , sr)

discriminator-compliant : ∀{T S} -> T <: S -> T ↑ S -> FairComplianceS (discriminator T S # T)
discriminator-compliant {T} {S} sub div {R' # T'} reds with unzip-red* reds
... | φ , rr , tr with sub+diverge->discriminator-defined sub div | sub+diverge->defined sub div
... | rdef | tdef , sdef with discriminator-after-sync->defined sub rdef rr tr
... | rdef' with decode-sub (co-semantics (disc-set->semantics T S)) (_ , rdef' , rr)
... | dsφ rewrite co-trace-involution φ =
  case completion sub dsφ of
  λ { (inj₁ (ψ , lt , cψ@(maximal dsψ _))) ->
      let rψ = decode-sup (co-semantics (disc-set->semantics T S)) (co-definition {DiscSet T S} dsψ) in
      let tψ = disc-set-subset dsψ in
      let rr' = subst (λ z -> Transitions _ z _) (⊑-after-co-trace (⊏->⊑ lt)) (extend-transitions (⊑-co-trace (⊏->⊑ lt)) rr rψ) in
      let tr' = extend-transitions (⊏->⊑ lt) tr tψ in
      let winr = decode+maximal->win (co-semantics (disc-set->semantics T S)) rψ (co-maximal cψ) in
      let reds' = zip-red* rr' tr' in
      _ , reds' , win#def winr (after-trace-defined-2 tψ)
    ; (inj₂ (cφ , nsφ)) ->
      let winr = decode+maximal->win (co-semantics (disc-set->semantics T S)) (_ , rdef' , rr) (co-maximal cφ) in
      _ , ε , win#def winr (after-trace-defined (disc-set-subset dsφ) tr) }

discriminator-not-compliant : ∀{T S} -> T <: S -> T ↑ S -> ¬ FairComplianceS (discriminator T S # S)
discriminator-not-compliant {T} {S} sub div comp with comp ε
... | _ , reds , win#def w def with unzip-red* reds
... | φ , rr , sr with decode+win->maximal (co-semantics (disc-set->semantics T S)) (_ , win->defined w , rr) w
... | cφ with co-maximal-2 {DiscSet T S} cφ
... | csφ with disc-set-maximal-2 sub csφ
... | nsφ = nsφ (_ , def , sr)


{-# OPTIONS --safe #-}

module Definition.Conversion.Soundness where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Conversion
open import Definition.Conversion.Whnf
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.NeTypeEq

open import Tools.Product
import Tools.PropositionalEquality as PE

mutual
  -- Algorithmic equality of neutrals is well-formed.
  soundness~↑! : ∀ {k l A lA Γ} → Γ ⊢ k ~ l ↑! A ^ lA → Γ ⊢ k ≡ l ∷ A ^ [ ! , lA ]
  soundness~↑! (var-refl x x≡y) = PE.subst (λ y → _ ⊢ _ ≡ var y ∷ _ ^ _) x≡y (refl x)
  soundness~↑! (app-cong {rF = !} k~l x₁) = app-cong (soundness~↓! k~l) (soundnessConv↑Term x₁)
  soundness~↑! (app-cong {rF = %} k~l x₁) = app-cong (soundness~↓! k~l) (let _ , _ , y = soundness~↑% x₁ in y)
  soundness~↑! (natrec-cong x₁ x₂ x₃ k~l) =
    natrec-cong (soundnessConv↑ x₁) (soundnessConv↑Term x₂)
                (soundnessConv↑Term x₃) (soundness~↓! k~l)
  soundness~↑! (Emptyrec-cong x₁ k~l) = let ⊢k , ⊢l , _ = soundness~↑% k~l in
    Emptyrec-cong (soundnessConv↑ x₁) ⊢k ⊢l
  soundness~↑! (Id-cong X x x₁) = Id-cong (soundness~↓! X) (soundnessConv↑Term x) (soundnessConv↑Term x₁)
  soundness~↑! (Id-ℕ X x) = Id-cong (refl (ℕⱼ (wfEqTerm (soundness~↓! X)))) (soundness~↓! X) (soundnessConv↑Term x)
  soundness~↑! (Id-ℕ0 X) = let XX = soundness~↓! X in Id-cong (refl (ℕⱼ (wfEqTerm XX))) (refl (zeroⱼ (wfEqTerm XX))) XX
  soundness~↑! (Id-ℕS x X) = let XX = soundness~↓! X in Id-cong (refl (ℕⱼ (wfEqTerm XX))) (suc-cong (soundnessConv↑Term x)) XX
  soundness~↑! (Id-U X x) = Id-cong (refl (univ 0<1 (wfEqTerm (soundness~↓! X)))) (soundness~↓! X) (soundnessConv↑Term x)
  soundness~↑! (Id-Uℕ X) = let XX = soundness~↓! X in Id-cong (refl (univ 0<1 (wfEqTerm XX))) (refl (ℕⱼ (wfEqTerm XX))) XX
  soundness~↑! (Id-UΠ x X) = let XX = soundness~↓! X
                                 xx = soundnessConv↑Term x
                             in Id-cong (refl (univ 0<1 (wfEqTerm XX))) xx XX
  soundness~↑! (cast-cong X x x₁ x₂ x₃) = cast-cong (soundness~↓! X) (soundnessConv↑Term x) (soundnessConv↑Term x₁) x₂ x₃
  soundness~↑! (cast-ℕ X x x₁ x₂) = let XX = soundness~↓! X in cast-cong (refl (ℕⱼ (wfEqTerm XX))) XX (soundnessConv↑Term x) x₁ x₂
  soundness~↑! (cast-ℕℕ X x x₁) = let XX = soundness~↓! X in cast-cong (refl (ℕⱼ (wfEqTerm XX))) (refl (ℕⱼ (wfEqTerm XX))) XX x x₁
  soundness~↑! (cast-Π x X x₁ x₂ x₃) = cast-cong (soundnessConv↑Term x) (soundness~↓! X) (soundnessConv↑Term x₁) x₂ x₃
  soundness~↑! (cast-Πℕ x x₁ x₂ x₃) = let XX = (soundnessConv↑Term x) in cast-cong XX (refl (ℕⱼ (wfEqTerm XX))) (soundnessConv↑Term x₁) x₂ x₃
  soundness~↑! (cast-ℕΠ x x₁ x₂ x₃) = let XX = (soundnessConv↑Term x) in cast-cong (refl (ℕⱼ (wfEqTerm XX))) XX (soundnessConv↑Term x₁) x₂ x₃
  soundness~↑! (cast-ΠΠ%! x x₁ x₂ x₃ x₄) = cast-cong (soundnessConv↑Term x) (soundnessConv↑Term x₁) (soundnessConv↑Term x₂) x₃ x₄
  soundness~↑! (cast-ΠΠ!% x x₁ x₂ x₃ x₄) = cast-cong (soundnessConv↑Term x) (soundnessConv↑Term x₁) (soundnessConv↑Term x₂) x₃ x₄

  soundness~↑% : ∀ {k l A lA Γ} → Γ ⊢ k ~ l ↑% A ^ lA  →  Γ ⊢ k ∷ A ^ [ % , lA ] × Γ ⊢ l ∷ A ^ [ % , lA ] × Γ ⊢ k ≡ l ∷ A ^ [ % , lA ]
  soundness~↑% (%~↑ ⊢k ⊢l) =  ⊢k , ⊢l , proof-irrelevance ⊢k ⊢l

  soundness~↑ : ∀ {k l A rA lA Γ} → Γ ⊢ k ~ l ↑ A ^ [ rA , lA ] → Γ ⊢ k ≡ l ∷ A ^ [ rA , lA ]
  soundness~↑ (~↑! x) = soundness~↑! x
  soundness~↑ (~↑% x) = let _ , _ , y = soundness~↑% x in y

  -- Algorithmic equality of neutrals in WHNF is well-formed.
  soundness~↓! : ∀ {k l A lA Γ} → Γ ⊢ k ~ l ↓! A ^ lA → Γ ⊢ k ≡ l ∷ A ^ [ ! , lA ]
  soundness~↓! ([~] A₁ D whnfA k~l) = conv (soundness~↑! k~l) (subset* D)

  -- Algorithmic equality of types is well-formed.
  soundnessConv↑ : ∀ {A B rA Γ} → Γ ⊢ A [conv↑] B ^ rA → Γ ⊢ A ≡ B ^ rA
  soundnessConv↑ ([↑] A′ B′ D D′ whnfA′ whnfB′ A′<>B′) =
    trans (subset* D) (trans (soundnessConv↓ A′<>B′) (sym (subset* D′)))

  -- Algorithmic equality of types in WHNF is well-formed.
  soundnessConv↓ : ∀ {A B rA Γ} → Γ ⊢ A [conv↓] B ^ rA → Γ ⊢ A ≡ B ^ rA
  soundnessConv↓ (U-refl PE.refl ⊢Γ) = refl (Uⱼ ⊢Γ)
  soundnessConv↓ (univ x₂) = univ (soundnessConv↓Term x₂)

  -- Algorithmic equality of terms is well-formed.
  soundnessConv↑Term : ∀ {a b A lA Γ} → Γ ⊢ a [conv↑] b ∷ A ^ lA → Γ ⊢ a ≡ b ∷ A ^ [ ! , lA ]
  soundnessConv↑Term ([↑]ₜ B t′ u′ D d d′ whnfB whnft′ whnfu′ t<>u) =
    conv (trans (subset*Term d)
                (trans (soundnessConv↓Term t<>u)
                       (sym (subset*Term d′))))
         (sym (subset* D))

  -- Algorithmic equality of terms in WHNF is well-formed.
  soundnessConv↓Term : ∀ {a b A lA Γ} → Γ ⊢ a [conv↓] b ∷ A ^ lA → Γ ⊢ a ≡ b ∷ A ^ [ ! , lA ]
  soundnessConv↓Term (ne x) = soundness~↓! x
  soundnessConv↓Term (ℕ-refl ⊢Γ) = refl (ℕⱼ ⊢Γ)
  soundnessConv↓Term (Empty-refl PE.refl ⊢Γ) = refl (Emptyⱼ ⊢Γ)
  soundnessConv↓Term (Π-cong PE.refl PE.refl PE.refl PE.refl l< l<' F c c₁) =
    Π-cong l< l<' F (soundnessConv↑Term c) (soundnessConv↑Term c₁)
  soundnessConv↓Term (∃-cong PE.refl F c c₁) =
    ∃-cong F (soundnessConv↑Term c) (soundnessConv↑Term c₁)
  soundnessConv↓Term (ℕ-ins x) = soundness~↓! x
  -- soundnessConv↓Term (Empty-ins x) = soundness~↓% x
  soundnessConv↓Term (ne-ins t u x x₁) =
    let whnfM , neA , neB = ne~↓! x₁
        X = soundness~↓! x₁
        _ , t∷M , _ = syntacticEqTerm X
        _ , M≡A' = neTypeEq neA t∷M t -- soundnessConv↑ M≡A
    in conv X M≡A'
  soundnessConv↓Term (zero-refl ⊢Γ) = refl (zeroⱼ ⊢Γ)
  soundnessConv↓Term (suc-cong c) = suc-cong (soundnessConv↑Term c)
  soundnessConv↓Term (η-eq l< l<' F x x₁ y y₁ c) = η-eq l< l<' F x x₁ (soundnessConv↑Term c)
  soundnessConv↓Term (U-refl PE.refl ⊢Γ) = refl (univ 0<1 ⊢Γ)

app-cong′ : ∀ {Γ k l t v F rF lF G lG lΠ}
          → Γ ⊢ k ~ l ↓! Π F ^ rF ° lF ▹ G ° lG ° lΠ ^ ι lΠ
          → Γ ⊢ t [genconv↑] v ∷ F ^ [ rF , ι lF ]
          → Γ ⊢ k ∘ t ^ lΠ ~ l ∘ v ^ lΠ ↑ G [ t ] ^ [ ! , ι lG ]
app-cong′ k~l t=v = ~↑! (app-cong k~l t=v)

natrec-cong′ : ∀ {Γ k l h g a b F lF G}
             → Γ ∙ ℕ ^ [ ! , ι ⁰ ]  ⊢ F [conv↑] G ^ [ ! , ι lF ]
             → Γ ⊢ a [conv↑] b ∷ F [ zero ] ^ ι lF
             → Γ ⊢ h [conv↑] g ∷ Π ℕ ^ ! ° ⁰ ▹ (F ^ ! ° lF ▹▹ F [ suc (var 0) ]↑ ° lF ° lF) ° lF ° lF ^ ι lF
             → Γ ⊢ k ~ l ↓! ℕ ^ ι ⁰
             → Γ ⊢ natrec lF F a h k ~ natrec lF G b g l ↑ F [ k ] ^ [ ! , ι lF ]
natrec-cong′ F=G a=b h=g k~l = ~↑! (natrec-cong F=G a=b h=g k~l)

Emptyrec-cong′ : ∀ {Γ k l F lF lEmpty G}
               → Γ ⊢ F [conv↑] G ^ [ ! , ι lF ]
               → Γ ⊢ k ~ l ↑% Empty lEmpty ^ ι lEmpty
               → Γ ⊢ Emptyrec lF lEmpty F k ~ Emptyrec lF lEmpty G l ↑ F ^ [ ! , ι lF ]
Emptyrec-cong′ F=G k~l = ~↑! (Emptyrec-cong F=G k~l)