{-# 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


-- {-# OPTIONS -v tc.with:100 #-}
module Issue818 where

data ⊤ : Set where
  tt : ⊤

Foo : {x : ⊤} → Set₁
Foo with tt
Foo {x = _} | tt = Set

-- Panic: wrong number of arguments in with clause: given 1, expected
-- 0
-- when checking that the clause
-- Foo with tt
-- Foo {x = _} | tt = Set
-- has type {⊤} → Set₁

-- The code above type-checks using Agda 2.3.0.1, but not with Agda
-- 2.3.2.

-- Andreas, 2013-03-08: same error thrown by

-- foo : ⊤ → Set₁
-- foo with tt
-- foo x | tt = Set

-- Implicit arguments are no longer eagerly introduced (see release notes
-- for 2.3.2, text for issue 679).

-- Should now throw a proper error message (not a panic).


module Issue561 where

open import Common.Prelude

open import Common.MAlonzo using ()
  -- if I do not include this, I get compilation errors
  -- MAlonzo/Code/Common/Prelude.hs:8:7:
  --   Not in scope: type constructor or class `Common.FFI.Nat'

primitive
  primIsDigit : Char → Bool

postulate
  return : ∀ {A} → A → IO A

main : IO Bool
main = return true


module _ where

data ⊤ : Set where tt : ⊤

pattern id x = x

postulate
  X : Set

loops : X
loops = tt


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)


module Selective.Examples.ChatAO where

open import Selective.ActorMonad
open import Selective.Libraries.Channel
open import Selective.Libraries.Call2
open import Selective.Libraries.ActiveObjects
open import Prelude
  hiding (Maybe)
open import Data.Maybe as Maybe
  hiding (map)

open import Data.List.Properties
open import Category.Monad

open import Debug
open import Data.Nat.Show using (show)

RoomName = ℕ
ClientName = ℕ

Room-to-Client : InboxShape

record Client : Set where
  field
    name : ClientName
    channel : UniqueTag

ClientList : Set
ClientList = List Client

record RoomState : Set₁ where
  field
    clients : ClientList

cl-to-context : ClientList → TypingContext
cl-to-context = map λ _ → Room-to-Client

rs-to-context : RoomState → TypingContext
rs-to-context rs = let open RoomState
  in cl-to-context (rs .clients)

record ChatMessageContent : Set where
  constructor chat-from_message:_
  field
    sender : ClientName
    message : String

SendChatMessage : MessageType
SendChatMessage = [ ValueType ChatMessageContent ]ˡ

ReceiveChatMessage : MessageType
ReceiveChatMessage = ValueType UniqueTag ∷ [ ValueType ChatMessageContent ]ˡ

chat-message-header : ActiveMethod
chat-message-header = VoidMethod [ SendChatMessage ]ˡ

Room-to-Client = [ ReceiveChatMessage ]ˡ

AddToRoom : MessageType
AddToRoom = ValueType UniqueTag ∷ ValueType ClientName ∷ [ ReferenceType Room-to-Client ]ˡ

add-to-room-header : ActiveMethod
add-to-room-header = VoidMethod [ AddToRoom ]ˡ

LeaveRoom : MessageType
LeaveRoom = [ ValueType ClientName ]ˡ

leave-room-header : ActiveMethod
leave-room-header = VoidMethod [ LeaveRoom ]ˡ

room-methods : List ActiveMethod
room-methods = chat-message-header ∷ leave-room-header ∷ [ add-to-room-header ]ˡ

room-inbox = methods-shape room-methods

add-to-room : (active-method room-inbox RoomState rs-to-context add-to-room-header)
add-to-room _ (Msg Z (tag ∷ client-name ∷ _ ∷ [])) state = do
  let
    open RoomState
    state' = record { clients = record { name = client-name ; channel = tag } ∷ state .clients }
  strengthen (Z ∷ ⊆-refl)
  return₁ state'
add-to-room _ (Msg (S ()) _)

record RoomLeave (rs : ClientList) (name : ClientName) : Set₁ where
  field
    filtered : ClientList
    subs : (cl-to-context filtered) ⊆ (cl-to-context rs)

leave-room : (active-method room-inbox RoomState rs-to-context leave-room-header)
leave-room _ (Msg Z (client-name ∷ [])) state = do
    let
      open RoomState
      open RoomLeave
      rl = remove-first-client (state .clients) client-name
      state' = record { clients = rl .filtered }
    debug ("client#" || show client-name || " left the room") (strengthen (rl .subs))
    return₁ state'
  where
    remove-first-client : (cl : ClientList) → (name : ClientName) → RoomLeave cl name
    remove-first-client [] name = record { filtered = [] ; subs = [] }
    remove-first-client (x ∷ cl) name with ((Client.name x) ≟ name)
    ... | (yes _) = record { filtered = cl ; subs = ⊆-suc ⊆-refl }
    ... | (no _) =
      let
        rec = remove-first-client cl name
        open RoomLeave
      in record { filtered = x ∷ rec .filtered ; subs = Z ∷ ⊆-suc (rec .subs) }
leave-room _ (Msg (S ()) _) _

chat-message : (active-method room-inbox RoomState rs-to-context chat-message-header)
chat-message _ (Msg Z ((chat-from sender message: message) ∷ [])) state = do
    let
      open RoomState
      debug-msg = ("room sending " || show (pred (length (state .clients))) ||  " messages from " || show sender || ": " || message)
    debug debug-msg (send-to-others (state .clients) sender message)
    return₁ state
  where
    ++-temp-fix : (l r : ClientList) → (x : Client) → (l ++ (x ∷ r)) ≡ ((l ∷ʳ x) ++ r)
    ++-temp-fix [] r x = refl
    ++-temp-fix (x₁ ∷ l) r x = cong (_∷_ x₁) (++-temp-fix l r x)
    send-to-others : ∀ {i} → (cl : ClientList) →
                     ClientName →
                     String →
                     ∞ActorM i room-inbox ⊤₁ (cl-to-context cl) (λ _ → cl-to-context cl)
    send-to-others [] _ _ = return _
    send-to-others cl@(_ ∷ _) name message = send-loop [] cl
      where
        build-pointer : (l r : ClientList) →
                      cl-to-context r ⊢ Room-to-Client →
                      (cl-to-context (l ++ r)) ⊢ Room-to-Client
        build-pointer [] r p = p
        build-pointer (x ∷ l) r p = S (build-pointer l r p)
        recurse : ∀ {i} → (l r : ClientList) → (x : Client) →
                  ∞ActorM i room-inbox ⊤₁ (cl-to-context (l ++ (x ∷ r))) (λ _ → (cl-to-context (l ++ (x ∷ r))))
        send-loop : ∀ {i} → (l r : ClientList) →
          ∞ActorM i room-inbox ⊤₁ (cl-to-context (l ++ r)) (λ _ → cl-to-context (l ++ r))
        send-loop l [] = return _
        send-loop l (x ∷ r) with ((Client.name x) ≟ name)
        ... | (yes _) = recurse l r x
        ... | (no _) = let p = build-pointer l (x ∷ r) Z
          in debug ("Sending to " || show (Client.name x) || ": " || message) (p ![t: Z ] (lift (Client.channel x) ∷ [ lift (chat-from name message: message) ]ᵃ) ) >> recurse l r x
        recurse l r x rewrite ++-temp-fix l r x = send-loop (l ∷ʳ x) r
chat-message _ (Msg (S ()) _) _

room : ActiveObject
room = record {
  state-type = RoomState
  ; vars = rs-to-context
  ; methods = room-methods
  ; extra-messages = []
  ; handlers = chat-message ∷ leave-room ∷ [ add-to-room ]ᵃ
  }

Client-to-Room : InboxShape
Client-to-Room = SendChatMessage ∷ [ LeaveRoom ]ˡ

-- =============
--  JOIN ROOM
-- =============

data JoinRoomSuccess : Set where
  JR-SUCCESS : RoomName → JoinRoomSuccess

data JoinRoomFail : Set where
  JR-FAIL : RoomName → JoinRoomFail

data JoinRoomStatus : Set where
  JRS-SUCCESS JRS-FAIL : RoomName → JoinRoomStatus

JoinRoomSuccessReply : MessageType
JoinRoomSuccessReply = ValueType UniqueTag ∷ ValueType JoinRoomSuccess ∷ [ ReferenceType Client-to-Room ]ˡ

JoinRoomFailReply : MessageType
JoinRoomFailReply = ValueType UniqueTag ∷ [ ValueType JoinRoomFail ]ˡ

JoinRoomReplyInterface : InboxShape
JoinRoomReplyInterface = JoinRoomSuccessReply ∷ JoinRoomFailReply ∷ Room-to-Client

JoinRoom : MessageType
JoinRoom = ValueType UniqueTag ∷ ReferenceType JoinRoomReplyInterface ∷ ValueType RoomName ∷ [ ValueType ClientName ]ˡ

-- =============
--  CREATE ROOM
-- =============

data CreateRoomResult : Set where
  CR-SUCCESS CR-EXISTS : RoomName → CreateRoomResult

CreateRoomReply : MessageType
CreateRoomReply = ValueType UniqueTag ∷ [ ValueType CreateRoomResult ]ˡ

CreateRoom : MessageType
CreateRoom = ValueType UniqueTag ∷ ReferenceType [ CreateRoomReply ]ˡ ∷ [ ValueType RoomName ]ˡ

-- ============
--  LIST ROOMS
-- ============

RoomList : Set
RoomList = List RoomName

ListRoomsReply : MessageType
ListRoomsReply = ValueType UniqueTag ∷ [ ValueType RoomList ]ˡ

ListRooms : MessageType
ListRooms = ValueType UniqueTag ∷ [ ReferenceType [ ListRoomsReply ]ˡ ]ˡ

-- ===
--
-- ===

Client-to-RoomManager : InboxShape
Client-to-RoomManager = JoinRoom ∷ CreateRoom ∷ [ ListRooms ]ˡ

RoomManagerInterface : InboxShape
RoomManagerInterface = Client-to-RoomManager

GetRoomManagerReply : MessageType
GetRoomManagerReply = ValueType UniqueTag ∷ [ ReferenceType RoomManagerInterface ]ˡ

GetRoomManager : MessageType
GetRoomManager = ValueType UniqueTag ∷ [ ReferenceType [ GetRoomManagerReply ]ˡ ]ˡ

get-room-manager-ci : ChannelInitiation
get-room-manager-ci = record {
  request = [ GetRoomManager ]ˡ
  ; response = record {
    channel-shape = [ GetRoomManagerReply ]ˡ
    ; all-tagged = (HasTag _) ∷ [] }
  ; request-tagged = (HasTag+Ref _) ∷ []
  }

get-room-manager-header : ActiveMethod
get-room-manager-header = ResponseMethod get-room-manager-ci

RoomSupervisorInterface : InboxShape
RoomSupervisorInterface = [ GetRoomManager ]ˡ

ClientSupervisorInterface : InboxShape
ClientSupervisorInterface =
  [ ReferenceType RoomSupervisorInterface ]ˡ ∷ [ GetRoomManagerReply ]ˡ

--
--
--

-- ======================
--  ROOM MANAGER METHODS
-- ======================

join-room-header : ActiveMethod
join-room-header = VoidMethod [ JoinRoom ]ˡ

create-room-ci : ChannelInitiation
create-room-ci = record {
  request = [ CreateRoom ]ˡ
  ; response = record {
    channel-shape = [ CreateRoomReply ]ˡ
    ; all-tagged = (HasTag _) ∷ [] }
  ; request-tagged = (HasTag+Ref _) ∷ []
  }

create-room-header : ActiveMethod
create-room-header = ResponseMethod create-room-ci

list-rooms-header : ActiveMethod
list-rooms-header = ResponseMethod (record {
  request = [ ListRooms ]ˡ
  ; response = record {
    channel-shape = [ ListRoomsReply ]ˡ
    ; all-tagged = (HasTag _) ∷ []
    }
  ; request-tagged = (HasTag+Ref _) ∷ []
  })

record RoomManagerState : Set₁ where
  field
    rooms : RoomList

rms-to-context : RoomManagerState → TypingContext
rms-to-context rms =
  let
    open RoomManagerState
    rl-to-context : RoomList → TypingContext
    rl-to-context = map λ _ → room-inbox
  in rl-to-context (rms .rooms)

room-manager-methods : List ActiveMethod
room-manager-methods = join-room-header ∷ create-room-header ∷ [ list-rooms-header ]ˡ

room-manager-inbox = methods-shape room-manager-methods

list-rooms : active-method room-manager-inbox RoomManagerState rms-to-context list-rooms-header
list-rooms _ msg state =
  let
    open RoomManagerState
  in return₁ (record {
    new-state = state
    ; reply = SendM Z ((lift (state .rooms)) ∷ [])
    })

lookup-room : ∀ {i} → {Γ : TypingContext} →
              (rms : RoomManagerState) →
              RoomName →
              ∞ActorM i room-manager-inbox (Maybe ((Γ ++ (rms-to-context rms)) ⊢ room-inbox)) (Γ ++ (rms-to-context rms)) (λ _ → Γ ++ (rms-to-context rms))
lookup-room rms name =
    let open RoomManagerState
    in return₁ (loop _ (rms .rooms))
    where
      rl-to-context : RoomList → TypingContext
      rl-to-context = map λ _ → room-inbox
      loop : (Γ : TypingContext) → (rl : RoomList) → Maybe ((Γ ++ rl-to-context rl) ⊢ room-inbox)
      loop [] [] = nothing
      loop [] (x ∷ xs) with (x ≟ name)
      ... | (yes p) = just Z
      ... | (no _) = RawMonad._>>=_ Maybe.monad (loop [] xs) λ p → just (S p)
      loop (x ∷ Γ) rl = RawMonad._>>=_ Maybe.monad (loop Γ rl) (λ p → just (S p))

create-room : active-method room-manager-inbox RoomManagerState rms-to-context create-room-header
create-room _ input@(_ sent Msg Z (room-name ∷ [])) state = do
    p ← lookup-room state room-name
    handle-create-room p
  where
    open ResponseInput
    return-type = ActiveReply create-room-ci RoomManagerState rms-to-context input
    precondition = reply-state-vars rms-to-context input state
    postcondition = reply-vars rms-to-context input
    handle-create-room : ∀ {i} → Maybe (precondition ⊢ room-inbox) →
                         ∞ActorM i
                           room-manager-inbox
                           return-type
                           precondition
                           postcondition
    handle-create-room (just x) = return₁ (record { new-state = state ; reply = SendM Z ((lift (CR-EXISTS room-name)) ∷ []) })
    handle-create-room nothing = do
      spawn∞ (run-active-object room (record { clients = [] }))
      let
        open RoomManagerState
        state' : RoomManagerState
        state' = record { rooms = room-name ∷ state .rooms}
      strengthen ((S Z) ∷ (Z ∷ (⊆-suc (⊆-suc ⊆-refl))))
      return₁ (record { new-state = state' ; reply = SendM Z ((lift (CR-SUCCESS room-name)) ∷ []) })
create-room _ (_ sent Msg (S ()) _) _

join-room : active-method room-manager-inbox RoomManagerState rms-to-context join-room-header
join-room _ (Msg Z (tag ∷ _ ∷ room-name ∷ client-name ∷ [])) state = do
    p ← lookup-room state room-name
    handle-join-room p Z
    return₁ state
  where
    handle-join-room : ∀ {i Γ} → Maybe (Γ ⊢ room-inbox) → Γ ⊢ JoinRoomReplyInterface → ∞ActorM i room-manager-inbox ⊤₁ Γ (λ _ → Γ)
    handle-join-room (just rp) cp = do
      (rp ![t: S (S Z) ] ((lift tag) ∷ ((lift client-name) ∷ (([ cp ]>: [ S (S Z) ]ᵐ) ∷ []))))
      (cp ![t: Z ] ((lift tag) ∷ ((lift (JR-SUCCESS room-name)) ∷ (([ rp ]>: (Z ∷ [ S Z ]ᵐ)) ∷ []))))
    handle-join-room nothing cp = cp ![t: S Z ] ((lift tag) ∷ ((lift (JR-FAIL room-name)) ∷ []))
join-room _ (Msg (S ()) _) _

room-manager : ActiveObject
room-manager = record {
  state-type = RoomManagerState
  ; vars = rms-to-context
  ; methods = room-manager-methods
  ; extra-messages = []
  ; handlers = join-room ∷ (create-room ∷ (list-rooms ∷ []))
  }

-- =================
--  ROOM SUPERVISOR
-- =================

rs-context : TypingContext
rs-context = [ room-manager-inbox ]ˡ

rs-vars : ⊤₁ → TypingContext
rs-vars _ = rs-context

room-supervisor-methods : List ActiveMethod
room-supervisor-methods = [ get-room-manager-header ]ˡ

rs-inbox = methods-shape room-supervisor-methods

get-room-manager-handler : active-method rs-inbox ⊤₁ rs-vars get-room-manager-header
get-room-manager-handler _ (_ sent Msg Z received-fields) _ = return₁ (record { new-state = _ ; reply = SendM Z [ [ (S Z) ]>: ⊆-refl ]ᵃ })
get-room-manager-handler _ (_ sent Msg (S ()) _) _

room-supervisor-ao : ActiveObject
room-supervisor-ao = record
                       { state-type = ⊤₁
                       ; vars = λ _ → rs-context
                       ; methods = room-supervisor-methods
                       ; extra-messages = []
                       ; handlers = [ get-room-manager-handler ]ᵃ
                       }

-- room-supervisor spawns the room-manager
-- and provides an interface for getting a reference to the current room-manager
-- we don't ever change that instance, but we could if we want
room-supervisor : ∀ {i} → ActorM i RoomSupervisorInterface ⊤₁ [] (λ _ → rs-context)
room-supervisor = begin do
    spawn∞ (run-active-object room-manager (record { rooms = [] }))
    run-active-object room-supervisor-ao _

-- ================
--  CLIENT GENERAL
-- ================
ClientInterface : InboxShape
ClientInterface = [ ReferenceType RoomManagerInterface ]ˡ ∷ CreateRoomReply ∷ ListRoomsReply ∷ JoinRoomReplyInterface

busy-wait : ∀ {i IS Γ} → ℕ → ∞ActorM i IS ⊤₁ Γ (λ _ → Γ)
busy-wait zero = return _
busy-wait (suc n) = return tt >> busy-wait n

client-get-room-manager : ∀ {i} → ∞ActorM i ClientInterface ⊤₁ [] (λ _ → [ RoomManagerInterface ]ˡ)
client-get-room-manager = do
  record { msg = Msg Z _} ← (selective-receive (λ {
    (Msg Z x₁) → true
    ; (Msg (S _) _) → false
    }))
    where
      record { msg = (Msg (S _) _) ; msg-ok = ()}
  return _

client-create-room : ∀ {i } →
                     {Γ : TypingContext} →
                     Γ ⊢ RoomManagerInterface →
                     UniqueTag →
                     RoomName →
                     ∞ActorM i ClientInterface (Lift (lsuc lzero) CreateRoomResult) Γ (λ _ → Γ)
client-create-room p tag name = do
  Msg Z (_ ∷ cr ∷ []) ← (call create-room-ci (record {
    var = p
    ; chosen-field = Z
    ; fields = (lift name) ∷ []
    ; session = record {
      can-request = (S Z) ∷ []
      ; response-session = record {
      can-receive = (S Z) ∷ []
      ; tag = tag
      }
      }
      }))
    where
      Msg (S ()) _
  return cr

add-if-join-success : TypingContext →
                      Lift (lsuc lzero) JoinRoomStatus →
                      TypingContext
add-if-join-success Γ (lift (JRS-SUCCESS x)) = Client-to-Room ∷ Γ
add-if-join-success Γ (lift (JRS-FAIL x)) = Γ

client-join-room : ∀ {i Γ} →
                   Γ ⊢ RoomManagerInterface →
                   UniqueTag →
                   RoomName →
                   ClientName →
                   ∞ActorM i ClientInterface (Lift (lsuc lzero) JoinRoomStatus) Γ (add-if-join-success Γ)
client-join-room p tag room-name client-name = do
    self
    S p ![t: Z ] (lift tag ∷ (([ Z ]>: ⊆-suc (⊆-suc (⊆-suc ⊆-refl))) ∷ (lift room-name) ∷ [ lift client-name ]ᵃ))
    (strengthen (⊆-suc ⊆-refl))
    m ← (selective-receive (select-join-reply tag))
    handle-message m
  where
    select-join-reply : UniqueTag → MessageFilter ClientInterface
    select-join-reply tag (Msg Z _) = false
    select-join-reply tag (Msg (S Z) _) = false
    select-join-reply tag (Msg (S (S Z)) _) = false
    select-join-reply tag (Msg (S (S (S Z))) (tag' ∷ _)) = ⌊ tag ≟ tag' ⌋
    select-join-reply tag (Msg (S (S (S (S Z)))) (tag' ∷ _)) = ⌊ tag ≟ tag' ⌋
    select-join-reply tag (Msg (S (S (S (S (S Z))))) x₁) = false
    select-join-reply tag (Msg (S (S (S (S (S (S ())))))) _)
    handle-message : ∀ {tag i Γ} → (m : SelectedMessage (select-join-reply tag)) →
                     ∞ActorM i ClientInterface (Lift (lsuc lzero) JoinRoomStatus)
                       (add-selected-references Γ m) (add-if-join-success Γ)
    handle-message record { msg = (Msg Z _) ; msg-ok = () }
    handle-message record { msg = (Msg (S Z) _) ; msg-ok = () }
    handle-message record { msg = (Msg (S (S Z)) _) ; msg-ok = () }
    handle-message record { msg = (Msg (S (S (S Z))) (_ ∷ JR-SUCCESS room-name ∷ _ ∷ [])) } = return (JRS-SUCCESS room-name)
    handle-message record { msg = (Msg (S (S (S (S Z)))) (_ ∷ JR-FAIL room-name ∷ [])) } = return (JRS-FAIL room-name)
    handle-message record { msg = (Msg (S (S (S (S (S Z))))) _) ; msg-ok = () }
    handle-message record { msg = (Msg (S (S (S (S (S (S ())))))) _) }

client-send-message : ∀ {i  Γ} →
                      Γ ⊢ Client-to-Room →
                      ClientName →
                      String →
                      ∞ActorM i ClientInterface ⊤₁ Γ (λ _ → Γ)
client-send-message p client-name message = p ![t: Z ] ([ lift (chat-from client-name message: message) ]ᵃ)

client-receive-message : ∀ {i Γ} →
                         ∞ActorM i ClientInterface (Lift (lsuc lzero) ChatMessageContent) Γ (λ _ → Γ)
client-receive-message = do
    m ← (selective-receive select-message)
    handle-message m
  where
    select-message : MessageFilter ClientInterface
    select-message (Msg (S (S (S (S (S Z))))) _) = true
    select-message (Msg _ _) = false
    handle-message : ∀ {i Γ} → (m : SelectedMessage select-message) →
                     ∞ActorM i ClientInterface (Lift (lsuc lzero) ChatMessageContent) (add-selected-references Γ m) (λ _ → Γ)
    handle-message record { msg = (Msg Z _) ; msg-ok = () }
    handle-message record { msg = (Msg (S Z) _) ; msg-ok = () }
    handle-message record { msg = (Msg (S (S Z)) _) ; msg-ok = () }
    handle-message record { msg = (Msg (S (S (S Z))) x₁) ; msg-ok = () }
    handle-message record { msg = (Msg (S (S (S (S Z)))) _) ; msg-ok = () }
    handle-message record { msg = (Msg (S (S (S (S (S Z))))) (_ ∷ m ∷ f)) ; msg-ok = _ } = return m
    handle-message record { msg = (Msg (S (S (S (S (S (S ())))))) _) }

client-leave-room : ∀ {i Γ} →
                    Γ ⊢ Client-to-Room →
                    ClientName →
                    ∞ActorM i ClientInterface ⊤₁ Γ (λ _ → Γ)
client-leave-room p name = p ![t: S Z ] [ lift name ]ᵃ

debug-chat : {a : Level} {A : Set a} → ClientName → ChatMessageContent → A → A
debug-chat client-name content = let open ChatMessageContent
  in debug ("client#" || show client-name || " received \"" || content .message || "\" from client#" || show (content .sender))

-- ==========
--  CLIENT 1
-- ==========

room1-2 = 1
room2-3 = 2
room3-1 = 3
room1-2-3 = 4
name1 = 1

client1 : ∀ {i} → ActorM i ClientInterface ⊤₁ [] (λ _ → [])
client1 = begin do
  client-get-room-manager
  _ ← (client-create-room Z 0 room1-2)
  _ ← (client-create-room Z 1 room3-1)
  _ ← (client-create-room Z 2 room1-2-3)
  lift (JRS-SUCCESS joined-room) ← (client-join-room Z 3 room3-1 name1)
    where
      (lift (JRS-FAIL failed-room)) → strengthen []
  lift (JRS-SUCCESS joined-room) ← (client-join-room (S Z) 4 room1-2 name1)
    where
      (lift (JRS-FAIL failed-room)) → strengthen []
  lift (JRS-SUCCESS joined-room) ← (client-join-room (S (S Z)) 5 room1-2-3 name1)
    where
      (lift (JRS-FAIL failed-room)) → strengthen []
  busy-wait 100
  (client-send-message (S Z) name1 "hi from 1 to 2")
  (client-send-message Z name1 "hi from 1 to 2-3")
  let open ChatMessageContent
  lift m1 ← client-receive-message
  lift m2 ← debug-chat name1 m1 client-receive-message
  lift m3 ← debug-chat name1 m2 client-receive-message
  debug-chat name1 m3 (client-send-message Z name1 "hi1 from 1 to 2-3")
  (client-send-message Z name1 "hi2 from 1 to 2-3")
  (client-send-message Z name1 "hi3 from 1 to 2-3")
  client-leave-room (S Z) name1
  client-leave-room (Z) name1
  (strengthen [])

-- ==========
--  CLIENT 2
-- ==========

name2 = 2

client2 : ∀ {i} → ActorM i ClientInterface ⊤₁ [] (λ _ → [])
client2 = begin do
  client-get-room-manager
  _ ← (client-create-room Z 0 room1-2)
  _ ← (client-create-room Z 1 room2-3)
  _ ← (client-create-room Z 2 room1-2-3)
  lift (JRS-SUCCESS joined-room) ← (client-join-room Z 3 room1-2 name2)
    where
    (lift (JRS-FAIL failed-room)) → strengthen []
  lift (JRS-SUCCESS joined-room) ← (client-join-room (S Z) 4 room2-3 name2)
    where
      (lift (JRS-FAIL failed-room)) → strengthen []
  lift (JRS-SUCCESS joined-room) ← (client-join-room (S (S Z)) 5 room1-2-3 name2)
    where
      (lift (JRS-FAIL failed-room)) → strengthen []
  busy-wait 100
  debug "client2 send message" (client-send-message (S Z) name2 "hi from 2 to 3")
  debug "client2 send message" (client-send-message Z name2 "hi from 2 to 1-3")
  let open ChatMessageContent
  lift m1 ← client-receive-message
  lift m2 ← debug-chat name2 m1 client-receive-message
  lift m3 ← debug-chat name2 m2 client-receive-message
  client-leave-room (S Z) name2
  client-leave-room (Z) name2
  debug-chat name2 m3 (strengthen [])

-- ==========
--  CLIENT 3
-- ==========

name3 = 3

client3 : ∀ {i} → ActorM i ClientInterface ⊤₁ [] (λ _ → [])
client3 = begin do
  client-get-room-manager
  _ ← (client-create-room Z 0 room2-3)
  _ ← (client-create-room Z 1 room3-1)
  _ ← (client-create-room Z 2 room1-2-3)
  lift (JRS-SUCCESS joined-room) ← (client-join-room Z 3 room2-3 name3)
    where
    (lift (JRS-FAIL failed-room)) → strengthen []
  lift (JRS-SUCCESS joined-room) ← (client-join-room (S Z) 4 room3-1 name3)
    where
      (lift (JRS-FAIL failed-room)) → strengthen []
  lift (JRS-SUCCESS joined-room) ← (client-join-room (S (S Z)) 5 room1-2-3 name3)
    where
      (lift (JRS-FAIL failed-room)) → strengthen []
  busy-wait 100
  debug "client3 send message" (client-send-message (S Z) name3 "hi from 3 to 1")
  debug "client3 send message" (client-send-message Z name3 "hi from 3 to 1-2")
  let open ChatMessageContent
  lift m1 ← client-receive-message
  lift m2 ← debug-chat name3 m1 client-receive-message
  lift m3 ← debug-chat name3 m2 client-receive-message
  debug-chat name3 m3 (client-leave-room Z name3)
  client-leave-room (S Z) name3
  client-leave-room Z name3
  (strengthen [])

-- ===================
--  CLIENT SUPERVISOR
-- ===================

cs-context : TypingContext
cs-context = RoomManagerInterface ∷ RoomSupervisorInterface ∷ []

client-supervisor : ∀ {i} → ActorM i ClientSupervisorInterface ⊤₁ [] (λ _ → cs-context)
client-supervisor = begin do
    wait-for-room-supervisor
    (get-room-manager Z 0)
    spawn-clients
  where
    wait-for-room-supervisor : ∀ {i Γ} → ∞ActorM i ClientSupervisorInterface ⊤₁ Γ (λ _ → RoomSupervisorInterface ∷ Γ)
    wait-for-room-supervisor = do
      record { msg = Msg Z f } ← (selective-receive (λ {
        (Msg Z _) → true
        ; (Msg (S _) _) → false
        }))
        where
          record { msg = (Msg (S _) _) ; msg-ok = () }
      return _
    get-room-manager : ∀ {i Γ} →
                     Γ ⊢ RoomSupervisorInterface →
                     UniqueTag →
                      ∞ActorM i ClientSupervisorInterface ⊤₁ Γ (λ _ → RoomManagerInterface ∷ Γ)
    get-room-manager p tag = do
      Msg Z f ← (call get-room-manager-ci (record {
          var = p
          ; chosen-field = Z
          ; fields = []
          ; session = record {
            can-request = ⊆-refl
            ; response-session = record {
            can-receive = (S Z) ∷ []
            ; tag = tag }
            }
          }))
        where
          Msg (S ()) _
      return _
    spawn-clients : ∀ {i} → ∞ActorM i ClientSupervisorInterface ⊤₁ cs-context (λ _ → cs-context)
    spawn-clients = do
      spawn client1
      Z ![t: Z ] [ [ S Z ]>: ⊆-refl ]ᵃ
      (strengthen (⊆-suc ⊆-refl))
      (spawn client2)
      Z ![t: Z ] [ [ S Z ]>: ⊆-refl ]ᵃ
      (strengthen (⊆-suc ⊆-refl))
      (spawn client3)
      Z ![t: Z ] [ [ S Z ]>: ⊆-refl ]ᵃ
      (strengthen (⊆-suc ⊆-refl))

-- chat-supervisor is the top-most actor
-- it spawns and connects the ClientRegistry to the RoomRegistry
chat-supervisor : ∀ {i} → ∞ActorM i [] ⊤₁ [] (λ _ → [])
chat-supervisor = do
    spawn room-supervisor
    spawn client-supervisor
    Z ![t: Z ] [ [ S Z ]>: ⊆-refl ]ᵃ
    strengthen []


{-# OPTIONS --safe #-}

useful-lemma : ∀ {a} {A : Set a} → A
useful-lemma = useful-lemma


module DuplicateBuiltinBinding where

postulate Int : Set

{-# BUILTIN INTEGER Int #-}
{-# BUILTIN INTEGER Int #-}


{-# 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))