{-# 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.FromTo2 {i} (d : Span^2 {i}) where

open Span^2 d
open M d hiding (Pushout^2)
open M (transpose d) using () renaming (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.FromToInit d

module M2 (c : A₂₂) where

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

         =⟨ coh' ⟩
    end-lemma1 ∎  where

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      =⟨ coh3 ⟩

    end-lemma3 ∎  where

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

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

{- Lemma 2 -}

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

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

    ↓-='-out (↓-='-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))) /)

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

    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 /
    ∙□-o/ From.glue-β (left (f₁₂ c)) / ! (From.glue-β (right (f₃₂ c))) / ∎

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

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

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

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

    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 /
    ∙□-o/ From.glue-β (left (f₁₂ c)) / ! (From.glue-β (right (f₃₂ c))) /
    ∙□-i/ ∘-ap from (right ∘ f∙₃) (glue c) / ap-∘ from (left ∘ f∙₁) (glue c) / ∎

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

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

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

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

    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 /
    ∙□-o/ From.glue-β (left (f₁₂ c)) / ! (From.glue-β (right (f₃₂ c))) /
    ∙□-i/ ∘-ap from (right ∘ f∙₃) (glue c) / ap-∘ from (left ∘ f∙₁) (glue c) /
    ∙□-i/ ap (ap from) (E₂∙Red.lhs-i c) / ap (ap from) (E₂∙Red.rhs-i c) / ∎

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

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

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

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

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

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

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

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

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

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

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

    where

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

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

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

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

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

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

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

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

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

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

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

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

    where

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

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

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

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

    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 /
    ∙□-o/ From.glue-β (left (f₁₂ c)) / ! (From.glue-β (right (f₃₂ c))) /
    ∙□-i/ ∘-ap from (right ∘ f∙₃) (glue c) / ap-∘ from (left ∘ f∙₁) (glue c) /
    ∙□-i/ ap (ap from) (E₂∙Red.lhs-i c) / ap (ap from) (E₂∙Red.rhs-i c) /
    ∙□-i/ E₂∙Red.ap-ap-coh-lhs-i c from / E₂∙Red.ap-ap-coh-rhs-i c from /

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


{-# OPTIONS --no-qualified-instances #-}
module JVM.Printer where

open import Function
open import Data.Bool
open import Data.Product hiding (swap)
open import Data.List as L
open import Data.List.Relation.Unary.Any
open import Data.Nat as N
open import Data.Nat.Show as Nat
open import Data.Fin
open import Data.String as S
open import Relation.Unary
open import Relation.Ternary.Core
open import Relation.Ternary.Structures
open import Relation.Ternary.Structures.Syntax hiding (_∣_)

open import Relation.Binary.PropositionalEquality
open import Relation.Ternary.Monad

open import JVM.Types
open import JVM.Contexts using (indexOf)
open import JVM.Syntax.Values
open import JVM.Syntax.Instructions as I hiding (Instr)
open import JVM.Printer.Printer StackTy
open import JVM.Printer.Jasmin as J hiding (procedure)

private
  module _ {T : Set} where
    open import JVM.Model T public

const-instr : Const a → Instr
const-instr Const.null   = aconst_null
const-instr (num x)      = sipush x
const-instr (bool false) = iconst0
const-instr (bool true)  = iconst1

load-instr : Ty → ℕ → Instr
load-instr (ref _)   = aload
load-instr (array _) = iload
load-instr int     = iload
load-instr boolean = iload
load-instr byte    = iload
load-instr short   = iload
load-instr long    = iload
load-instr char    = iload

store-instr : Ty → ℕ → Instr
store-instr (ref _)   = astore
store-instr (array _) = aastore
store-instr int     = istore
store-instr boolean = istore
store-instr byte    = istore
store-instr short   = istore
store-instr long    = istore
store-instr char    = istore

bop-instr : NativeBinOp a b c → Instr
bop-instr add = iadd
bop-instr sub = isub
bop-instr mul = imul
bop-instr div = idiv
bop-instr xor = ixor

if-instr : ∀ {as} → I.Comparator as → String → Instr
if-instr eq = if eq
if-instr ne = if ne
if-instr lt = if lt
if-instr ge = if ge
if-instr gt = if gt
if-instr le = if le
if-instr icmpge = if icmpge
if-instr icmpgt = if icmpgt
if-instr icmpeq = if icmpeq
if-instr icmpne = if icmpne
if-instr icmplt = if icmplt
if-instr icmple = if icmple

module _ {𝑭} where

  prettyᵢ : ∀ {ψ₁ ψ₂} → ∀[ Down ⟨ 𝑭 ∣ ψ₁ ↝ ψ₂ ⟩ ⇒ Printer Emp ]
  prettyᵢ (↓ noop)      = print (instr nop)
  prettyᵢ (↓ pop)       = print (instr pop)
  prettyᵢ (↓ dup)       = print (instr dup)
  prettyᵢ (↓ swap)      = print (instr swap)
  prettyᵢ (↓ (push x))  = print (instr (const-instr x))
  prettyᵢ (↓ (bop x))   = print (instr (bop-instr x))
  prettyᵢ (↓ (load {a = a} r))  = do
    print (instr (load-instr a (toℕ $ index r)))
  prettyᵢ (↓ (store {a = a} r)) = do
    print (instr (store-instr a (toℕ $ index r)))
  prettyᵢ (↓ (goto x))  = do
    emp n ← lookDown (↓ x)
    print (instr (goto (Nat.show n)))
  prettyᵢ (↓ (if c x)) = do
    emp n ← lookDown (↓ x)
    print (instr (if-instr c (Nat.show n)))

  import JVM.Syntax.Bytecode.Printer ⟨ 𝑭 ∣_↝_⟩ prettyᵢ as Printer

  pretty : ∀ {ψ₁ ψ₂ Φ} → ⟪ 𝑭 ∣ ψ₁ ↝ ψ₂ ⟫ Φ → List Stat
  pretty bc = execPrinter (Printer.pretty bc)

  procedure : ∀ {ψ₁ ψ₂ Φ} → String → ⟪ 𝑭 ∣ ψ₁ ↝ ψ₂ ⟫ Φ → Jasmin
  procedure name bc = J.procedure name (L.length 𝑭) 10 (pretty bc)


{-# OPTIONS --allow-unsolved-metas #-}

-- This file documents a bug caused by one of the fixes for issue 153.

module Issue153 where

open import Common.Coinduction

record R : Set₁ where
  field
    S : Set
    T : S → Set

module D (r : R) (s : R.S r) where
  open R r

  data D (t : T s) : Set where

module M (r : R) (s : R.S r) where
  open R r
  open D _ s

  postulate
    t : T s
    d : D t

  foo : ∞ (D t)
  foo = ♯ d

-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/Interaction/Highlighting/Generate.hs:383


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

   Copyright (c) 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

open import LibraBFT.Base.Types
open import LibraBFT.Concrete.Records
open import LibraBFT.Concrete.System
open import LibraBFT.Concrete.System.Parameters
open import LibraBFT.Impl.Consensus.EpochManager
import      LibraBFT.Impl.Consensus.BlockStorage.BlockStore            as BlockStore
import      LibraBFT.Impl.Consensus.BlockStorage.Properties.BlockStore as BlockStoreProps
import      LibraBFT.Impl.Consensus.ConsensusTypes.ExecutedBlock       as ExecutedBlock
import      LibraBFT.Impl.Consensus.Liveness.RoundState                as RoundState
import      LibraBFT.Impl.Consensus.Liveness.ProposerElection          as ProposerElection
import      LibraBFT.Impl.Consensus.PersistentLivenessStorage          as PersistentLivenessStorage
import      LibraBFT.Impl.Consensus.PersistentLivenessStorage.Properties as PersistentLivenessStorageProps
open import LibraBFT.Impl.Consensus.RoundManager
import      LibraBFT.Impl.Consensus.SafetyRules.SafetyRules            as SafetyRules
import      LibraBFT.Impl.Consensus.SafetyRules.Properties.SafetyRules as SafetyRulesProps
open import LibraBFT.Impl.OBM.Logging.Logging
open import LibraBFT.Impl.Properties.Util
open import LibraBFT.ImplShared.Base.Types
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Consensus.Types.EpochDep
open import LibraBFT.ImplShared.Interface.Output
open import LibraBFT.ImplShared.Util.Dijkstra.All
open import Optics.All
open import Util.ByteString
open import Util.Hash
open import Util.Lemmas
open import Util.Prelude
open import Yasm.System ℓ-RoundManager ℓ-VSFP ConcSysParms

open OutputProps
open Invariants
open RoundManagerTransProps

-- This module contains properties that are only about the behavior of the handlers, nothing to do
-- with system state

module LibraBFT.Impl.Consensus.RoundManager.Properties where

module executeAndVoteMSpec (vb : ValidBlock) where
  b = vbBlock vb

  open executeAndVoteM b
  open SafetyRulesProps
  open import LibraBFT.Impl.Consensus.BlockStorage.Properties.BlockStore

  isbQc = (_≡ b ^∙ bQuorumCert)

  VoteResultCorrect : (pre post : RoundManager) (lvr≡? : Bool) (r : Either ErrLog Vote) → Set
  VoteResultCorrect pre post lvr≡? (Left _) =
    VoteNotGenerated pre post lvr≡? ⊎ Voting.VoteGeneratedUnsavedCorrect pre post b
  VoteResultCorrect pre post lvr≡? (Right vote) =
    Voting.VoteGeneratedCorrect pre post vote b

  module _ (pre : RoundManager) where

    open QCProps
    open Invariants.Reqs b (pre ^∙ lBlockTree)

    record Contract (r : Either ErrLog Vote) (post : RoundManager) (outs : List Output) : Set where
      constructor mkContract
      field
        -- General properties / invariants
        rmInv         : Preserves RoundManagerInv pre post
        noEpochChange : NoEpochChange pre post
        noMsgOuts     : OutputProps.NoMsgs outs
        -- Voting
        lvr≡?             : Bool
        voteResultCorrect : NoHC1 → VoteResultCorrect pre post lvr≡? r
        -- QCs
        qcPost : ∈Post⇒∈PreOr isbQc pre post

    contract' :
      LBFT-weakestPre (executeAndVoteM b) Contract pre
    contract' =
      executeAndInsertBlockMSpec.contract vb pre Post₀
        (λ where e ._ refl → contractBail [] refl)
        contract₁
      where
      Post₀ : LBFT-Post (Either ErrLog ExecutedBlock)
      Post₀ = RWS-weakestPre-∙^∙Post unit (withErrCtx ("" ∷ []))
                (RWS-weakestPre-ebindPost unit step₁ Contract)

      contractBail : ∀ {e} outs → OutputProps.NoMsgs outs → Contract (Left e) pre outs
      contractBail{e} outs noMsgOuts =
        mkContract
          reflPreservesRoundManagerInv (reflNoEpochChange{pre})
          noMsgOuts true (const vrc)
          qcPost
        where
        vrc : VoteResultCorrect pre pre true (Left e)
        vrc = inj₁ reflVoteNotGenerated

        qcPost : ∈Post⇒∈PreOr isbQc pre pre
        qcPost qc = Left

      module EAIBM = executeAndInsertBlockMSpec vb
      module EAIBE = executeAndInsertBlockESpec (EAIBM.bs pre) vb
      module _ (isOk : EAIBE.Ok) (con : EAIBE.ContractOk (proj₁ isOk) (proj₁ (proj₂ isOk))) where

        module EAIBECon = EAIBE.ContractOk con

        bs' = proj₁ isOk
        eb  = proj₁ (proj₂ isOk)

        pre₁ = pre & rmBlockStore ∙~ bs'

        -- State invariants
        module _  where
          bsP : Preserves BlockStoreInv (rm→BlockStore-EC pre) (rm→BlockStore-EC pre₁)
          bsP bsi = EAIBECon.bsInv bsi

          srP : Preserves SafetyRulesInv (pre ^∙ lSafetyRules) (pre₁ ^∙ lSafetyRules)
          srP = mkPreservesSafetyRulesInv id

        invP₁ : Preserves RoundManagerInv pre pre₁
        invP₁ = mkPreservesRoundManagerInv id id bsP srP

        qcPost-BT : _
        qcPost-BT = ∈Post⇒∈PreOrBT-QCs≡ isbQc
                                        (cong (_^∙ bsInner ∙ btHighestCommitCert) EAIBECon.bs≡x)
                                        (cong (_^∙ bsInner ∙ btHighestQuorumCert) EAIBECon.bs≡x)

        qcPost₁ : ∈Post⇒∈PreOr isbQc pre pre₁
        qcPost₁ = ∈Post⇒∈PreOr-∙-BT-RM isbQc pre pre₁ qcPost-BT

        -- For the case any of the checks in `step₁` fails
        contractBail₁ : ∀ {e} outs → OutputProps.NoMsgs outs → Contract (Left e) pre₁ outs
        contractBail₁ outs noMsgOuts =
          mkContract invP₁ refl
            noMsgOuts true (const $ inj₁ (mkVoteNotGenerated refl refl))
            qcPost₁

        contract₁ : Post₀ (Right eb) pre₁ []
        proj₁ (contract₁ ._ refl ._ refl ._ refl ._ refl ._ refl) _ = contractBail₁ [] refl
        proj₁ (proj₂ (contract₁ ._ refl ._ refl ._ refl ._ refl ._ refl) _) _ = contractBail₁ [] refl
        proj₂ (proj₂ (contract₁ ._ refl ._ refl ._ refl ._ refl ._ refl) _) _ = contract₂
          where
          maybeSignedVoteProposal' = ExecutedBlock.maybeSignedVoteProposal eb

          module CASV = constructAndSignVoteMSpec

          proposedBlock = CASV.proposedBlock maybeSignedVoteProposal'

          Post₂ : LBFT-Post (Either ErrLog Vote)
          Post₂ = RWS-weakestPre-ebindPost unit step₃ Contract

          contract₂ : RWS-weakestPre (step₂ eb) Contract unit pre₁

          contract₂⇒ : RWS-Post-⇒ (CASV.Contract pre₁ proposedBlock) Post₂
          contract₂⇒ r pre₃ outs con = contract₂⇒-help r CASVCon.voteResCorrect
            where
            module CASVCon = CASV.Contract con
            CASVouts = outs

            invP₂ = transPreservesRoundManagerInv invP₁ CASVCon.rmInv

            qcPost₂ : QCProps.∈Post⇒∈PreOr (_≡ b ^∙ bQuorumCert) pre pre₃
            qcPost₂ = obm-dangerous-magic' "TODO: waiting on `constructAndSignVoteM` contract"

            contract₂⇒-help :
              (r : Either ErrLog Vote) (vrc : CASV.VoteResultCorrect pre₁ pre₃ proposedBlock CASVCon.lvr≡? r)
              → RWS-weakestPre-ebindPost unit step₃ Contract r pre₃ outs
            contract₂⇒-help (Left _) vrc =
              mkContract invP₂ CASVCon.noEpochChange CASVCon.noMsgOuts
                CASVCon.lvr≡? (const ∘ Left $ (transVoteNotGenerated (mkVoteNotGenerated refl refl) vrc))
                qcPost₂
            contract₂⇒-help (Right vote) vrc ._ refl = contract₃
              where

              open RoundManagerInv
              open BlockStoreInv
              open BlockTreeInv

              contract₃ : RWS-weakestPre (step₃ vote) (RWS-Post++ Contract CASVouts) unit pre₃
              contract₃ =
                PersistentLivenessStorageProps.saveVoteMSpec.contract vote
                  Post₃ pre₃
                  contractBail₃ contractOk₃
                where
                Post₃ : LBFT-Post (Either ErrLog Unit)
                Post₃ = RWS-weakestPre-ebindPost unit (const $ ok vote) (RWS-Post++ Contract CASVouts)

                vgc₃ : NoHC1 → Voting.VoteGeneratedCorrect pre pre₃ vote b {- proposedBlock -}
                vgc₃ nohc =
                  Voting.glue-VoteNotGenerated-VoteGeneratedCorrect
                    (mkVoteNotGenerated refl refl)
                    (Voting.substVoteGeneratedCorrect proposedBlock b
                      (EAIBECon.ebBlock≈ nohc)
                      vrc)

                noMsgOutsBail₃ : ∀ outs → NoMsgs outs → NoMsgs (CASVouts ++ outs)
                noMsgOutsBail₃ outs noMsgs = ++-NoMsgs CASVouts outs CASVCon.noMsgOuts noMsgs

                noMsgOutsOk₃ : ∀ outs → NoMsgs outs → NoMsgs (CASVouts ++ outs ++ [])
                noMsgOutsOk₃ outs noMsgs rewrite ++-identityʳ outs = noMsgOutsBail₃ outs noMsgs

                contractBail₃ : ∀ outs → NoMsgs outs → NoErrors outs → Post₃ (Left fakeErr) pre₃ outs
                contractBail₃ outs noMsgOuts noErrOuts =
                  mkContract invP₂ CASVCon.noEpochChange (noMsgOutsBail₃ outs noMsgOuts)
                    CASVCon.lvr≡? ((Right ∘ Voting.mkVoteGeneratedUnsavedCorrect vote) ∘ vgc₃)
                    qcPost₂

                contractOk₃ : ∀ outs → NoMsgs outs → NoErrors outs → Post₃ (Right unit) pre₃ outs
                contractOk₃ outs noMsgs noErrs unit refl =
                  mkContract invP₂ CASVCon.noEpochChange (noMsgOutsOk₃ outs noMsgs)
                    CASVCon.lvr≡? vgc₃ qcPost₂

          contract₂ = constructAndSignVoteMSpec.contract maybeSignedVoteProposal' pre₁ Post₂ contract₂⇒

    contract
      : ∀ Post
        → RWS-Post-⇒ Contract Post
        → LBFT-weakestPre (executeAndVoteM b) Post pre
    contract Post pf =
      RWS-⇒ (executeAndVoteM b) unit pre contract' pf

module processProposalMSpec (vproposal : ValidBlock) where
  proposal = vbBlock vproposal

  open import LibraBFT.Impl.Consensus.BlockStorage.Properties.BlockStore
  open import LibraBFT.Impl.Consensus.Liveness.Properties.ProposerElection
  open        LibraBFT.Impl.Consensus.RoundManager.processProposalM proposal

  module _ (pre : RoundManager) where

    open Invariants.Reqs (vbBlock vproposal) (pre ^∙ lBlockTree)

    record Contract (u : Unit) (post : RoundManager) (outs : List Output) : Set where
      constructor mkContract
      field
         -- General properties / invariants
        rmInv         : Preserves RoundManagerInv pre post
        noEpochChange : NoEpochChange pre post
        noProposals   : OutputProps.NoProposals outs
        -- Voting
        voteAttemptCorrect : NoHC1 → Voting.VoteAttemptCorrect pre post outs proposal
        -- QCs
        outQcs∈RM : QCProps.OutputQc∈RoundManager outs post
        qcPost    : QCProps.∈Post⇒∈PreOr (_≡ proposal ^∙ bQuorumCert) pre post

    contract' : LBFT-weakestPre (processProposalM proposal) Contract pre
    contract' ._ refl =
      isValidProposalMSpec.contract proposal pre
        (RWS-weakestPre-bindPost unit (step₁ (pre ^∙ lBlockStore)) Contract)
        (λ where
          mAuthor≡nothing ._ refl → (λ _ → contractBail refl) , (λ where ()))
        (λ where
          notValid ._ refl → (λ _ → contractBail refl) , (λ where ()))
        λ where
          vp ._ refl →
            (λ where ())
            , (λ _ →
                 (λ _ → contractBail refl)
                 , (λ _ →
                      (λ _ → contractBail refl)
                      , (λ _ → contract-step₂)))
      where
      contractBail : ∀ {outs} → OutputProps.NoMsgs outs → Contract unit pre outs
      contractBail{outs} nmo =
        mkContract reflPreservesRoundManagerInv (reflNoEpochChange{pre})
          noProposals vac outQcs qcPost
        where
          noProposals : NoProposals outs
          noProposals = OutputProps.NoMsgs⇒NoProposals outs nmo

          vac : NoHC1 → Voting.VoteAttemptCorrect pre pre outs proposal
          vac _ = Voting.voteAttemptBailed outs (OutputProps.NoMsgs⇒NoVotes outs nmo)

          outQcs : QCProps.OutputQc∈RoundManager outs pre
          outQcs = QCProps.NoMsgs⇒OutputQc∈RoundManager outs pre nmo

          qcPost : QCProps.∈Post⇒∈PreOr _ pre pre
          qcPost qc = Left

      contract-step₂ : RWS-weakestPre (executeAndVoteM proposal >>= step₂) Contract unit pre
      contract-step₂ =
        executeAndVoteMSpec.contract vproposal pre
          (RWS-weakestPre-bindPost unit step₂ Contract) pf-step₂
        where
        module EAV = executeAndVoteMSpec vproposal

        pf-step₂ : RWS-Post-⇒ (EAV.Contract pre) (RWS-weakestPre-bindPost unit step₂ Contract)
        pf-step₂ r st outs con = pf r EAVSpec.voteResultCorrect
          where
          module EAVSpec = executeAndVoteMSpec.Contract con
          rmInv₂ = transPreservesRoundManagerInv reflPreservesRoundManagerInv EAVSpec.rmInv

          pf : (r : Either ErrLog Vote) (vrc : NoHC1 → EAV.VoteResultCorrect pre st EAVSpec.lvr≡? r)
               → RWS-weakestPre-bindPost unit step₂ Contract r st outs
          pf (Left _) vrc ._ refl =
            mkContract rmInv₂ EAVSpec.noEpochChange
              noProposals
              vac
              qcOuts EAVSpec.qcPost
            where
            noMsgs : NoMsgs (outs ++ LogErr _ ∷ [])
            noMsgs = ++-NoMsgs outs (LogErr _ ∷ []) EAVSpec.noMsgOuts refl

            noProposals : NoProposals (outs ++ LogErr _ ∷ [])
            noProposals = NoMsgs⇒NoProposals (outs ++ LogErr _ ∷ []) noMsgs

            vac : NoHC1 → Voting.VoteAttemptCorrect pre st (outs ++ LogErr _ ∷ []) proposal
            vac nohc =
              inj₁ (EAVSpec.lvr≡?
                   , Voting.mkVoteUnsentCorrect
                       (NoMsgs⇒NoVotes (outs ++ LogErr _ ∷ []) noMsgs) (vrc nohc))

            qcOuts : QCProps.OutputQc∈RoundManager (outs ++ LogErr _ ∷ []) st
            qcOuts = QCProps.NoMsgs⇒OutputQc∈RoundManager (outs ++ LogErr _ ∷ []) st noMsgs

          pf (Right vote) vrc ._ refl ._ refl ._ refl =
            syncInfoMSpec.contract (st & rsVoteSent-rm ?~ vote)
              (RWS-weakestPre-bindPost unit (step₃ vote) (RWS-Post++ Contract outs))
              contract-step₃
            where
            stUpdateRS = st & rsVoteSent-rm ?~ vote

            module _
              (si : SyncInfo)
              (si≡ : si ≡ SyncInfo∙new
                            (st ^∙ lBlockStore ∙ bsHighestQuorumCert)
                            (st ^∙ lBlockStore ∙ bsHighestCommitCert)
                            (st ^∙ lBlockStore ∙ bsHighestTimeoutCert))
              where
              contract-step₃ : RWS-weakestPre (step₃ vote si) (RWS-Post++ Contract outs) unit stUpdateRS
              contract-step₃ ._ refl ._ refl ._ refl ._ refl recipient@._ refl =
                mkContract rmInv₃
                  (transNoEpochChange{i = pre}{j = st}{k = stUpdateRS} EAVSpec.noEpochChange refl)
                  (OutputProps.++-NoProposals outs _ (OutputProps.NoMsgs⇒NoProposals outs EAVSpec.noMsgOuts) refl)
                  vac
                  outQcs qcPost
                where
                vm = VoteMsg∙new vote si

                vac : NoHC1 → Voting.VoteAttemptCorrect pre stUpdateRS (outs ++ SendVote vm _ ∷ []) proposal
                vac nohc =
                  inj₂ (Voting.mkVoteSentCorrect vm recipient
                         (OutputProps.++-NoVotes-OneVote outs _ (OutputProps.NoMsgs⇒NoVotes outs EAVSpec.noMsgOuts) refl)
                         (Voting.glue-VoteGeneratedCorrect-VoteNotGenerated{s₂ = st}
                           (vrc nohc) (mkVoteNotGenerated refl refl)))

                outQcs : QCProps.OutputQc∈RoundManager (outs ++ SendVote vm _ ∷ []) stUpdateRS
                outQcs =
                  QCProps.++-OutputQc∈RoundManager{stUpdateRS}{outs}
                    (QCProps.NoMsgs⇒OutputQc∈RoundManager outs stUpdateRS EAVSpec.noMsgOuts)
                    (outQcSendVote ∷ [])
                  where
                  outQcSendVote : ∀ qc nm → qc QC∈NM nm → nm Msg∈Out (SendVote vm _) → qc QCProps.∈RoundManager stUpdateRS
                  outQcSendVote qc .(V (VoteMsg∙new vote si)) (inSI inV (withVoteSIHighQC qc≡)) inSV rewrite si≡ =
                    QCProps.inHQC (sym qc≡)
                  outQcSendVote qc .(V (VoteMsg∙new vote si)) (inSI inV (withVoteSIHighCC qc≡)) inSV =
                    QCProps.inHCC (just-injective $
                      begin
                        just qc ≡⟨ lem₁ ⟩
                        sixxx   ≡⟨ lem₂ (cong is-just (sym lem₁)) ⟩
                        just (stUpdateRS ^∙ lBlockStore ∙ bsInner ∙ btHighestCommitCert) ∎)
                    where
                    open ≡-Reasoning
                    sixxx = if (st ^∙ lBlockStore ∙ bsHighestQuorumCert) QCBoolEq (st ^∙ lBlockStore ∙ bsHighestCommitCert)
                            then nothing
                            else (just $ (st ^∙ lBlockStore ∙ bsHighestCommitCert))

                    lem₁ : just qc ≡ sixxx
                    lem₁ = begin
                      just qc ≡⟨ sym qc≡ ⟩
                      vm ^∙ vmSyncInfo ∙ sixxxHighestCommitCert ≡⟨ cong (_^∙ sixxxHighestCommitCert) si≡ ⟩
                      sixxx ∎

                    lem₂ : is-just sixxx ≡ true
                           → sixxx ≡ just (stUpdateRS ^∙ lBlockStore ∙ bsInner ∙ btHighestCommitCert)
                    lem₂ isj
                        with (st ^∙ lBlockStore ∙ bsHighestQuorumCert) QCBoolEq (st ^∙ lBlockStore ∙ bsHighestCommitCert)
                    ... | false = refl
                    ... | true = absurd false ≡ true case isj of λ ()

                qcPost : QCProps.∈Post⇒∈PreOr (_≡ proposal ^∙ bQuorumCert) pre stUpdateRS
                qcPost qc qc∈stUpdateRS = EAVSpec.qcPost qc (qc∈st qc∈stUpdateRS)
                  where
                  qc∈st : qc QCProps.∈RoundManager stUpdateRS → qc QCProps.∈RoundManager st
                  qc∈st (QCProps.inHQC qc≡) = QCProps.inHQC qc≡
                  qc∈st (QCProps.inHCC qc≡) = QCProps.inHCC qc≡

                -- state invariants
                module _ where
                  bsP : Preserves BlockStoreInv (rm→BlockStore-EC st) (rm→BlockStore-EC stUpdateRS)
                  bsP = id

                  srP : Preserves SafetyRulesInv (st ^∙ lSafetyRules) (stUpdateRS ^∙ lSafetyRules)
                  srP = mkPreservesSafetyRulesInv id

                  rmInv₃ : Preserves RoundManagerInv pre stUpdateRS
                  rmInv₃ = transPreservesRoundManagerInv rmInv₂
                           (mkPreservesRoundManagerInv id id bsP srP)

    contract : ∀ Post → RWS-Post-⇒ Contract Post → LBFT-weakestPre (processProposalM proposal) Post pre
    contract Post pf = LBFT-⇒ (processProposalM proposal) pre contract' pf

module syncUpMSpec
  (now : Instant) (syncInfo : SyncInfo) (author : Author) (_helpRemote : Bool) where

  open syncUpM now syncInfo author _helpRemote
  open import LibraBFT.Impl.Consensus.ConsensusTypes.Properties.SyncInfo
  open import LibraBFT.Impl.Consensus.BlockStorage.Properties.SyncManager

  module _ (pre : RoundManager) where

    record Contract (r : Either ErrLog Unit) (post : RoundManager) (outs : List Output) : Set where
      constructor mkContract
      field
        -- General invariants / properties
        rmInv         : Preserves RoundManagerInv pre post
        dnmBtIdToBlk  : post ≡L pre at (lBlockTree ∙ btIdToBlock)
        noEpochChange : NoEpochChange pre post
        noVoteOuts    : OutputProps.NoVotes outs
        -- Voting
        noVote        : VoteNotGenerated pre post true
        -- QCs
        noOutQcs : QCProps.¬OutputQc outs
        qcPost    : QCProps.∈Post⇒∈PreOr (_QC∈SyncInfo syncInfo) pre post

    contract' : LBFT-weakestPre (syncUpM now syncInfo author _helpRemote) Contract pre
    contract' =
      BlockStoreProps.syncInfoMSpec.contract pre
        (RWS-weakestPre-bindPost unit step₁ Contract)
        contract₁
      where
      localSyncInfo = BlockStoreProps.syncInfoMSpec.syncInfo pre

      contract₁ : RWS-weakestPre-bindPost unit step₁ Contract (BlockStoreProps.syncInfoMSpec.syncInfo pre) pre []
      proj₂ (contract₁ localSyncInfo lsi≡) hnc≡false =
        mkContract reflPreservesRoundManagerInv refl (reflNoEpochChange{pre}) refl
          (reflVoteNotGenerated{pre})
          [] qcPost
        where
        outQcs : QCProps.OutputQc∈RoundManager [] pre
        outQcs = QCProps.NoMsgs⇒OutputQc∈RoundManager [] pre refl

        qcPost : QCProps.∈Post⇒∈PreOr _ pre pre
        qcPost qc = Left
      proj₁ (contract₁ localSyncInfo lsi≡) hcn≡true vv@._ refl =
        verifyMSpec.contract syncInfo vv pre Post₁
          contract₃
        where
        Post₁ : LBFT-Post (Either ErrLog Unit)
        Post₁ = (RWS-weakestPre-∙^∙Post unit (withErrCtx (here' []))
                  (RWS-weakestPre-ebindPost unit (λ _ → step₃ localSyncInfo vv) Contract))

        contract₃ : RWS-Post-⇒ (verifyMSpec.Contract syncInfo vv pre) Post₁
        contract₃ r st outs con ._ refl
           with VSpec.noStateChange
           where module VSpec = verifyMSpec.Contract con
        contract₃ (Left x) st outs con ._ refl
           | refl
           = mkContract VSpec.rmInv (cong (_^∙ lBlockTree ∙ btIdToBlock) VSpec.noStateChange) (reflNoEpochChange{st})
               (++-NoVotes outs [] (NoMsgs⇒NoVotes outs VSpec.noMsgOuts) refl)
               (reflVoteNotGenerated{st})
               noOutQcs qcPost
           where
           module VSpec = verifyMSpec.Contract con
           noOutQcs : QCProps.¬OutputQc (outs ++ [])
           noOutQcs = QCProps.++-¬OutputQc (QCProps.NoMsgs⇒¬OutputQc outs VSpec.noMsgOuts) []

           qcPost : QCProps.∈Post⇒∈PreOr _ st st
           qcPost qc = Left
        contract₃ (Right y) st₃ outs₃ con₃ ._ refl
           | refl = λ where
             unit refl →
               addCertsMSpec.contract syncInfo retriever st₃
                 Post₃ contract₄
           where
           Post₃ : LBFT-Post (Either ErrLog Unit)
           Post₃ = (RWS-weakestPre-∙^∙Post unit (withErrCtx (here' []))
                     (RWS-weakestPre-ebindPost unit (λ _ → step₄ localSyncInfo vv)
                       (RWS-Post++ Contract (outs₃ ++ []))))

           retriever = BlockRetriever∙new now author

           contract₄ : RWS-Post-⇒ (addCertsMSpec.Contract syncInfo retriever st₃) Post₃
           contract₄ (Left  _) st₄ outs₄ con₄ ._ refl =
             mkContract AC.rmInv AC.dnmBtIdToBlk AC.noEpochChange noVotes₄ AC.noVote noOutQcs AC.qcPost
             where
             module AC    = addCertsMSpec.Contract con₄
             module VSpec = verifyMSpec.Contract con₃

             noVotes₄ : NoVotes $ (outs₃ ++ []) ++ outs₄ ++ []
             noVotes₄ =
               ++-NoVotes (outs₃ ++ []) (outs₄ ++ [])
                 (++-NoVotes outs₃ [] (NoMsgs⇒NoVotes outs₃ VSpec.noMsgOuts) refl)
                 (++-NoVotes outs₄ [] AC.noVoteOuts refl)

             noOutQcs : QCProps.¬OutputQc ((outs₃ ++ []) ++ outs₄ ++ [])
             noOutQcs =
               QCProps.++-¬OutputQc
                 (QCProps.++-¬OutputQc
                   (QCProps.NoMsgs⇒¬OutputQc outs₃ VSpec.noMsgOuts)
                   (QCProps.NoMsgs⇒¬OutputQc [] refl))
                 (QCProps.++-¬OutputQc
                   AC.noOutQc (QCProps.NoMsgs⇒¬OutputQc [] refl))

           contract₄ (Right _) st₄ outs₄ con₄ ._ refl =
             obm-dangerous-magic' "TODO: waiting on contract for `processCertificatesM`"

    contract
      : ∀ Post → RWS-Post-⇒ Contract Post
        → LBFT-weakestPre (syncUpM now syncInfo author _helpRemote) Post pre
    contract Post pf =
      LBFT-⇒ (syncUpM now syncInfo author _helpRemote) pre
        contract' pf

module ensureRoundAndSyncUpMSpec
  (now : Instant) (messageRound : Round) (syncInfo : SyncInfo)
  (author : Author) (helpRemote : Bool) where

  open ensureRoundAndSyncUpM now messageRound syncInfo author helpRemote

  module _ (pre : RoundManager) where

    record Contract (r : Either ErrLog Bool) (post : RoundManager) (outs : List Output) : Set where
      constructor mkContract
      field
        -- General invariants / properties
        rmInv         : Preserves RoundManagerInv pre post
        dnmBtIdToBlk  : post ≡L pre at (lBlockTree ∙ btIdToBlock)
        noEpochChange : NoEpochChange pre post
        noVoteOuts    : OutputProps.NoVotes outs
        -- Voting
        noVote        : VoteNotGenerated pre post true
        -- Signatures
        noOutQcs : QCProps.¬OutputQc outs
        qcPost   : QCProps.∈Post⇒∈PreOr (_QC∈SyncInfo syncInfo) pre post

    contract'
      : LBFT-weakestPre (ensureRoundAndSyncUpM now messageRound syncInfo author helpRemote) Contract pre
    proj₁ (contract' ._ refl) _         =
      mkContract id refl refl refl vng outqcs qcPost
      where
        vng : VoteNotGenerated pre pre true
        vng = mkVoteNotGenerated refl refl

        outqcs : QCProps.¬OutputQc []
        outqcs = []

        qcPost : QCProps.∈Post⇒∈PreOr _ pre pre
        qcPost qc = Left

    proj₂ (contract' ._ refl) mrnd≥crnd = contract-step₁
      where
      contract-step₁ : LBFT-weakestPre step₁ Contract pre
      contract-step₁ = syncUpMSpec.contract now syncInfo author helpRemote pre Post contract-step₁'
        where
        Post = RWS-weakestPre-ebindPost unit (const step₂) Contract

        contract-step₁' : _
        contract-step₁' (Left  _   ) st outs con =
          mkContract SU.rmInv SU.dnmBtIdToBlk SU.noEpochChange SU.noVoteOuts SU.noVote SU.noOutQcs SU.qcPost
          where
          module SU = syncUpMSpec.Contract con
        contract-step₁' (Right unit) st outs con = contract-step₂
          where
          module SU = syncUpMSpec.Contract con

          noVoteOuts' : NoVotes (outs ++ [])
          noVoteOuts' = ++-NoVotes outs [] SU.noVoteOuts refl

          noOutQcs : QCProps.¬OutputQc (outs ++ [])
          noOutQcs =
            QCProps.++-¬OutputQc SU.noOutQcs []

          contract-step₂ : Post (Right unit) st outs
          proj₁ (contract-step₂ ._ refl ._ refl) _ =
            mkContract SU.rmInv SU.dnmBtIdToBlk SU.noEpochChange noVoteOuts' SU.noVote
              noOutQcs SU.qcPost
          proj₂ (contract-step₂ ._ refl ._ refl) _ =
            mkContract SU.rmInv SU.dnmBtIdToBlk SU.noEpochChange noVoteOuts' SU.noVote
              noOutQcs SU.qcPost

    contract : ∀ Post → RWS-Post-⇒ Contract Post → LBFT-weakestPre (ensureRoundAndSyncUpM now messageRound syncInfo author helpRemote) Post pre
    contract Post pf =
      LBFT-⇒ (ensureRoundAndSyncUpM now messageRound syncInfo author helpRemote) pre contract' pf

module processProposalMsgMSpec
  (now : Instant) (pm : ProposalMsg) (vproposal : BlockId-correct (pm ^∙ pmProposal)) where

  proposal = pm ^∙ pmProposal
  open processProposalMsgM now pm

  module _ (pre : RoundManager) where

    open Invariants.Reqs proposal (pre ^∙ lBlockTree)

    record Contract (_ : Unit) (post : RoundManager) (outs : List Output) : Set where
      constructor mkContract
      field
        -- General invariants / properties
        rmInv         : Preserves RoundManagerInv pre post
        noEpochChange : NoEpochChange pre post
        -- Voting
        voteAttemptCorrect : NoHC1 → Voting.VoteAttemptCorrect pre post outs proposal
        -- QCs
        outQcs∈RM : QCProps.OutputQc∈RoundManager outs post
        qcPost    : QCProps.∈Post⇒∈PreOr (_QC∈NM (P pm)) pre post

    contract' : LBFT-weakestPre (processProposalMsgM now pm) Contract pre
    contract' rewrite processProposalMsgM≡ = contract
      where
      contractBail : ∀ outs → OutputProps.NoMsgs outs → Contract unit pre outs
      contractBail outs nmo =
        mkContract reflPreservesRoundManagerInv (reflNoEpochChange{pre}) vac outqcs qcPost
        where
        vac : NoHC1 → Voting.VoteAttemptCorrect pre pre outs proposal
        vac _ = Voting.voteAttemptBailed outs (OutputProps.NoMsgs⇒NoVotes outs nmo)

        outqcs : QCProps.OutputQc∈RoundManager outs pre
        outqcs = QCProps.NoMsgs⇒OutputQc∈RoundManager outs pre nmo

        qcPost : QCProps.∈Post⇒∈PreOr _ pre pre
        qcPost qc = Left

      contract : LBFT-weakestPre step₀ Contract pre
      proj₁ contract ≡nothing = contractBail _ refl
      proj₂ contract = contract-step₁
        where
        -- These arguments come from the second proof obligation of RWS-weakestPre for RWS-maybe
        module _ (pAuthor : Author) (pAuthor≡ : pm ^∙ pmProposer ≡ just pAuthor) where
          pf-step₂ : RWS-Post-⇒ _ (RWS-weakestPre-bindPost unit step₂ Contract)

          contract-step₁ : LBFT-weakestPre (step₁ pAuthor) Contract pre
          contract-step₁ =
            ensureRoundAndSyncUpMSpec.contract now (pm ^∙ pmProposal ∙ bRound) (pm ^∙ pmSyncInfo) pAuthor true pre
            (RWS-weakestPre-bindPost unit step₂ Contract)
            pf-step₂

          pf-step₂ r st outs con = pf-step₂' r
            where
            module ERASU = ensureRoundAndSyncUpMSpec.Contract con
            contractBailAfterSync : ∀ outs' → OutputProps.NoMsgs outs' → RWS-Post++ Contract outs unit st outs'
            contractBailAfterSync outs' noMsgs' =
              mkContract ERASU.rmInv ERASU.noEpochChange vac outqcs qcPost
              where
              vac : NoHC1 → Voting.VoteAttemptCorrect pre st (outs ++ outs') proposal
              vac _ = Left (true , (Voting.mkVoteUnsentCorrect
                                     (OutputProps.++-NoVotes outs _ ERASU.noVoteOuts (OutputProps.NoMsgs⇒NoVotes outs' noMsgs'))
                                     (Left ERASU.noVote)))

              outqcs : QCProps.OutputQc∈RoundManager (outs ++ outs') st
              outqcs =
                QCProps.¬OutputQc⇒OutputQc∈RoundManager (outs ++ outs') st
                  (QCProps.++-¬OutputQc ERASU.noOutQcs
                    (QCProps.NoMsgs⇒¬OutputQc outs' noMsgs'))

              qcPost : QCProps.∈Post⇒∈PreOr (_QC∈NM (P pm)) pre st
              qcPost qc qc∈st
                 with ERASU.qcPost qc qc∈st
              ... | Left qc∈pre = Left qc∈pre
              ... | Right qc∈si = Right (inSI inP qc∈si)

            pf-step₂' : (r : Either ErrLog Bool) → RWS-weakestPre-bindPost unit step₂ Contract r st outs
            pf-step₂' (Left e) ._ refl =
              contractBailAfterSync _ refl
            pf-step₂' (Right false) ._ refl ._ refl =
              contractBailAfterSync _ refl
            pf-step₂' (Right true) ._ refl =
              processProposalMSpec.contract (proposal , vproposal)
                                            st
                                            (RWS-Post++ Contract outs)
                                            pf-step₃
              where

              pf-step₃ : RWS-Post-⇒
                           (processProposalMSpec.Contract (proposal , vproposal) _)
                           (RWS-Post++ Contract outs)
              pf-step₃ unit st' outs' con =
                mkContract
                  (transPreservesRoundManagerInv ERASU.rmInv (PP.rmInv con))
                  (transNoEpochChange{i = pre}{j = st}{k = st'} ERASU.noEpochChange (PP.noEpochChange con))
                  vac outqcs qcPost
                where
                module PP = processProposalMSpec.Contract
                vac : NoHC1 → Voting.VoteAttemptCorrect pre st' (outs ++ outs') proposal
                vac nohc rewrite sym ERASU.dnmBtIdToBlk =
                  Voting.glue-VoteNotGenerated-VoteAttemptCorrect{outs₁ = outs}
                    ERASU.noVote ERASU.noVoteOuts (PP.voteAttemptCorrect con nohc)

                outqcs : QCProps.OutputQc∈RoundManager (outs ++ outs') st'
                outqcs =
                  QCProps.++-OutputQc∈RoundManager {rm = st'}
                    (QCProps.¬OutputQc⇒OutputQc∈RoundManager outs st' ERASU.noOutQcs)
                    (PP.outQcs∈RM con)

                qcPost : QCProps.∈Post⇒∈PreOr (_QC∈NM (P pm)) pre st'
                qcPost qc qc∈st'
                   with PP.qcPost con qc qc∈st'
                ...| Right refl = Right inP
                ...| Left qc∈st
                   with ERASU.qcPost qc qc∈st
                ... | Right qc∈si = Right (inSI inP qc∈si)
                ... | Left qc∈pre = Left qc∈pre

    contract : ∀ Post → RWS-Post-⇒ Contract Post → LBFT-weakestPre (processProposalMsgM now pm) Post pre
    contract Post pf =
      LBFT-⇒ (processProposalMsgM now pm) pre contract' pf

module startSpec
  (now          : Instant)
  (lastVoteSent : Maybe Vote)
  where

  module _ (pre : RoundManager)
           (rmi : RoundManagerInv pre) -- preconditions needed to prove contract
    where

    open InitProofDefs

    open start now lastVoteSent

    Contract : LBFT-Post Unit
    Contract _ post outs = ∃[ e ] (find' logErrMB outs ≡ just e)
                         ⊎ find' logErrMB outs ≡ nothing × InitContractOk lastVoteSent post outs

    syncInfo = SyncInfo∙new (pre ^∙ (lBlockStore ∙ bsHighestQuorumCert))
                            (pre ^∙ (lBlockStore ∙ bsHighestCommitCert))
                            (pre ^∙ (lBlockStore ∙ bsHighestTimeoutCert))

    postulate
      contract-step₁ : LBFT-weakestPre (step₁-abs syncInfo) Contract pre

    contract' : LBFT-weakestPre (start-abs now lastVoteSent) Contract pre
              -- These are due to the various binds arising from syncInfoM, which is not abstract
              -- because it's more trouble than it's worth
    contract' rewrite start-abs-≡ =
      λ where ._ refl ._ refl ._ refl ._ refl ._ refl ._ refl si refl → contract-step₁


open import Data.Product using ( _×_ ; _,_ )
open import Data.Sum using ( inj₁ ; inj₂ )
open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl )
open import Relation.Unary using ( _∈_ ; _⊆_ )
open import Web.Semantic.DL.ABox using
  ( ABox ; Assertions ; ⟨ABox⟩ ; ε ; _,_ ; _∼_ ; _∈₁_ ; _∈₂_ )
open import Web.Semantic.DL.ABox.Interp using ( Interp ; _,_ ; ⌊_⌋ ; ind ; _*_ )
open import Web.Semantic.DL.ABox.Interp.Morphism using
  ( _≲_ ; _,_ ; ≲⌊_⌋ ; ≲-resp-ind ; ≡³-impl-≲ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox.Interp using
  ( Δ ; _⊨_≈_ ; ≈-refl ; ≈-sym ; ≈-trans ; con ; rol ; con-≈ ; rol-≈ )
open import Web.Semantic.DL.TBox.Interp.Morphism using
  ( ≲-image ; ≲-resp-≈ ; ≲-resp-con ; ≲-resp-rol ; ≲-refl )
open import Web.Semantic.Util using
  ( True ; tt ; id ; _∘_ ; _⊕_⊕_ ; inode ; bnode ; enode ; →-dist-⊕ )

module Web.Semantic.DL.ABox.Model {Σ : Signature} where

infix 2 _⊨a_ _⊨b_
infixr 5 _,_

_⟦_⟧₀ : ∀ {X} (I : Interp Σ X) → X → (Δ ⌊ I ⌋)
I ⟦ x ⟧₀ = ind I x

_⊨a_ : ∀ {X} → Interp Σ X → ABox Σ X → Set
I ⊨a ε            = True
I ⊨a (A , B)      = (I ⊨a A) × (I ⊨a B)
I ⊨a x ∼ y        = ⌊ I ⌋ ⊨ ind I x ≈ ind I y
I ⊨a x ∈₁ c       = ind I x ∈ con ⌊ I ⌋ c
I ⊨a (x , y) ∈₂ r = (ind I x , ind I y) ∈ rol ⌊ I ⌋ r

Assertions✓ : ∀ {X} (I : Interp Σ X) A {a} →
  (a ∈ Assertions A) → (I ⊨a A) → (I ⊨a a)
Assertions✓ I ε         ()         I⊨A
Assertions✓ I (A , B)   (inj₁ a∈A) (I⊨A , I⊨B) = Assertions✓ I A a∈A I⊨A
Assertions✓ I (A , B)   (inj₂ a∈B) (I⊨A , I⊨B) = Assertions✓ I B a∈B I⊨B
Assertions✓ I (i ∼ j)   refl       I⊨A         = I⊨A
Assertions✓ I (i ∈₁ c)  refl       I⊨A         = I⊨A
Assertions✓ I (ij ∈₂ r) refl       I⊨A         = I⊨A

⊨a-resp-⊇ : ∀ {X} (I : Interp Σ X) A B →
  (Assertions A ⊆ Assertions B) → (I ⊨a B) → (I ⊨a A)
⊨a-resp-⊇ I ε B A⊆B I⊨B = tt
⊨a-resp-⊇ I (A₁ , A₂) B A⊆B I⊨B =
  ( ⊨a-resp-⊇ I A₁ B (A⊆B ∘ inj₁) I⊨B
  , ⊨a-resp-⊇ I A₂ B (A⊆B ∘ inj₂) I⊨B )
⊨a-resp-⊇ I (x ∼ y) B A⊆B I⊨B = Assertions✓ I B (A⊆B refl) I⊨B
⊨a-resp-⊇ I (x ∈₁ c) B A⊆B I⊨B = Assertions✓ I B (A⊆B refl) I⊨B
⊨a-resp-⊇ I (xy ∈₂ r) B A⊆B I⊨B = Assertions✓ I B (A⊆B refl) I⊨B

⊨a-resp-≲ : ∀ {X} {I J : Interp Σ X} → (I ≲ J) → ∀ A → (I ⊨a A) → (J ⊨a A)
⊨a-resp-≲ {X} {I} {J} I≲J ε I⊨A =
  tt
⊨a-resp-≲ {X} {I} {J} I≲J (A , B) (I⊨A , I⊨B) =
  (⊨a-resp-≲ I≲J A I⊨A , ⊨a-resp-≲ I≲J B I⊨B)
⊨a-resp-≲ {X} {I} {J} I≲J (x ∼ y)   I⊨x∼y =
  ≈-trans ⌊ J ⌋ (≈-sym ⌊ J ⌋ (≲-resp-ind I≲J x))
    (≈-trans ⌊ J ⌋ (≲-resp-≈ ≲⌊ I≲J ⌋ I⊨x∼y)
      (≲-resp-ind I≲J y))
⊨a-resp-≲ {X} {I} {J} I≲J (x ∈₁ c)  I⊨x∈c =
  con-≈ ⌊ J ⌋ c (≲-resp-con ≲⌊ I≲J ⌋ I⊨x∈c) (≲-resp-ind I≲J x)
⊨a-resp-≲ {X} {I} {J} I≲J ((x , y) ∈₂ r) I⊨xy∈r =
  rol-≈ ⌊ J ⌋ r (≈-sym ⌊ J ⌋ (≲-resp-ind I≲J x))
    (≲-resp-rol ≲⌊ I≲J ⌋ I⊨xy∈r) (≲-resp-ind I≲J y)

⊨a-resp-≡ : ∀ {X : Set} (I : Interp Σ X) j →
  (ind I ≡ j) → ∀ A → (I ⊨a A) → (⌊ I ⌋ , j ⊨a A)
⊨a-resp-≡ (I , i) .i refl A I⊨A = I⊨A

⊨a-resp-≡³ : ∀ {V X Y : Set} (I : Interp Σ (X ⊕ V ⊕ Y)) j →
  (→-dist-⊕ (ind I) ≡ →-dist-⊕ j) → ∀ A → (I ⊨a A) → (⌊ I ⌋ , j ⊨a A)
⊨a-resp-≡³ I j i≡j = ⊨a-resp-≲ (≡³-impl-≲ I j i≡j)

⟨ABox⟩-Assertions : ∀ {X Y a} (f : X → Y) (A : ABox Σ X) →
  (a ∈ Assertions A) → (⟨ABox⟩ f a ∈ Assertions (⟨ABox⟩ f A))
⟨ABox⟩-Assertions f ε ()
⟨ABox⟩-Assertions f (A , B) (inj₁ a∈A) = inj₁ (⟨ABox⟩-Assertions f A a∈A)
⟨ABox⟩-Assertions f (A , B) (inj₂ a∈B) = inj₂ (⟨ABox⟩-Assertions f B a∈B)
⟨ABox⟩-Assertions f (x ∼ y) refl = refl
⟨ABox⟩-Assertions f (x ∈₁ c) refl = refl
⟨ABox⟩-Assertions f ((x , y) ∈₂ r) refl = refl

⟨ABox⟩-resp-⊨ : ∀ {X Y} {I : Interp Σ X} {j : Y → Δ ⌊ I ⌋}
  (f : X → Y) → (∀ x → ⌊ I ⌋ ⊨ ind I x ≈ j (f x)) →
    ∀ A → (I ⊨a A) → (⌊ I ⌋ , j ⊨a ⟨ABox⟩ f A)
⟨ABox⟩-resp-⊨ {X} {Y} {I} f i≈j∘f ε I⊨ε =
  tt
⟨ABox⟩-resp-⊨ {X} {Y} {I} f i≈j∘f (A , B) (I⊨A , I⊨B) =
  (⟨ABox⟩-resp-⊨ f i≈j∘f A I⊨A , ⟨ABox⟩-resp-⊨ f i≈j∘f B I⊨B)
⟨ABox⟩-resp-⊨ {X} {Y} {I} f i≈j∘f (x ∼ y) x≈y =
  ≈-trans ⌊ I ⌋ (≈-sym ⌊ I ⌋ (i≈j∘f x)) (≈-trans ⌊ I ⌋ x≈y (i≈j∘f y))
⟨ABox⟩-resp-⊨ {X} {Y} {I} f i≈j∘f (x ∈₁ c) x∈⟦c⟧ =
  con-≈ ⌊ I ⌋ c x∈⟦c⟧ (i≈j∘f x)
⟨ABox⟩-resp-⊨ {X} {Y} {I} f i≈j∘f ((x , y) ∈₂ r) xy∈⟦r⟧ =
  rol-≈ ⌊ I ⌋ r (≈-sym ⌊ I ⌋ (i≈j∘f x)) xy∈⟦r⟧ (i≈j∘f y)

*-resp-⟨ABox⟩ : ∀ {X Y} (f : Y → X) I A →
  (I ⊨a ⟨ABox⟩ f A) → (f * I ⊨a A)
*-resp-⟨ABox⟩ f (I , i) ε I⊨ε =
  tt
*-resp-⟨ABox⟩ f (I , i) (A , B) (I⊨A , I⊨B) =
  (*-resp-⟨ABox⟩ f (I , i) A I⊨A , *-resp-⟨ABox⟩ f (I , i) B I⊨B )
*-resp-⟨ABox⟩ f (I , i) (x ∼ y) x≈y =
  x≈y
*-resp-⟨ABox⟩ f (I , i) (x ∈₁ c) x∈⟦c⟧ =
  x∈⟦c⟧
*-resp-⟨ABox⟩ f (I , i) ((x , y) ∈₂ r) xy∈⟦c⟧ =
  xy∈⟦c⟧

-- bnodes I f is the same as I, except that f is used as the interpretation
-- for bnodes.

on-bnode : ∀ {V W X Y Z : Set} → (W → Z) → ((X ⊕ V ⊕ Y) → Z) →
  ((X ⊕ W ⊕ Y) → Z)
on-bnode f g (inode x) = g (inode x)
on-bnode f g (bnode w) = f w
on-bnode f g (enode y) = g (enode y)

bnodes : ∀ {V W X Y} → (I : Interp Σ (X ⊕ V ⊕ Y)) → (W → Δ ⌊ I ⌋) →
  Interp Σ (X ⊕ W ⊕ Y)
bnodes I f = (⌊ I ⌋ , on-bnode f (ind I))

bnodes-resp-≲ : ∀ {V W X Y} (I J : Interp Σ (X ⊕ V ⊕ Y)) →
  (I≲J : I ≲ J) → (f : W → Δ ⌊ I ⌋) →
    (bnodes I f ≲ bnodes J (≲-image ≲⌊ I≲J ⌋ ∘ f))
bnodes-resp-≲ (I , i) (J , j) (I≲J , i≲j) f = (I≲J , lemma) where

  lemma : ∀ x →
    J ⊨ ≲-image I≲J (on-bnode f i x) ≈ on-bnode (≲-image I≲J ∘ f) j x
  lemma (inode x) = i≲j (inode x)
  lemma (bnode v) = ≈-refl J
  lemma (enode y) = i≲j (enode y)

-- I ⊨b A whenever there exists an f such that bnodes I f ⊨a A

data _⊨b_ {V W X Y} (I : Interp Σ (X ⊕ V ⊕ Y))
  (A : ABox Σ (X ⊕ W ⊕ Y)) : Set where
    _,_ : ∀ f → (bnodes I f ⊨a A) → (I ⊨b A)

inb : ∀ {V W X Y} {I : Interp Σ (X ⊕ V ⊕ Y)} {A : ABox Σ (X ⊕ W ⊕ Y)} →
  (I ⊨b A) → W → Δ ⌊ I ⌋
inb (f , I⊨A) = f

⊨b-impl-⊨a : ∀ {V W X Y} {I : Interp Σ (X ⊕ V ⊕ Y)} {A : ABox Σ (X ⊕ W ⊕ Y)} →
  (I⊨A : I ⊨b A) → (bnodes I (inb I⊨A) ⊨a A)
⊨b-impl-⊨a (f , I⊨A) = I⊨A

⊨a-impl-⊨b : ∀ {V X Y} (I : Interp Σ (X ⊕ V ⊕ Y)) A → (I ⊨a A) → (I ⊨b A)
⊨a-impl-⊨b I A I⊨A =
  (ind I ∘ bnode , ⊨a-resp-≲ (≲-refl ⌊ I ⌋ , lemma) A I⊨A) where

  lemma : ∀ x → ⌊ I ⌋ ⊨ ind I x ≈ on-bnode (ind I ∘ bnode) (ind I) x
  lemma (inode x) = ≈-refl ⌊ I ⌋
  lemma (bnode v) = ≈-refl ⌊ I ⌋
  lemma (enode y) = ≈-refl ⌊ I ⌋

⊨b-resp-≲ : ∀ {V W X Y} {I J : Interp Σ (X ⊕ V ⊕ Y)} → (I ≲ J)
  → ∀ (A : ABox Σ (X ⊕ W ⊕ Y)) → (I ⊨b A) → (J ⊨b A)
⊨b-resp-≲ I≲J A (f , I⊨A) =
  ((≲-image ≲⌊ I≲J ⌋ ∘ f) , ⊨a-resp-≲ (bnodes-resp-≲ _ _ I≲J f) A I⊨A)


------------------------------------------------------------------------
-- Compiler correctness
------------------------------------------------------------------------

{-# OPTIONS --cubical --safe #-}

module Lambda.Simplified.Partiality-monad.Inductive.Compiler-correctness
  where

open import Equality.Propositional.Cubical
open import Prelude hiding (⊥)

open import Monad equality-with-J
open import Vec.Function equality-with-J

open import Partiality-monad.Inductive
open import Partiality-monad.Inductive.Fixpoints hiding (comp; app)
open import Partiality-monad.Inductive.Monad

open import Lambda.Simplified.Compiler
open import Lambda.Simplified.Partiality-monad.Inductive.Interpreter
open import Lambda.Simplified.Partiality-monad.Inductive.Virtual-machine
open import Lambda.Simplified.Syntax
open import Lambda.Simplified.Virtual-machine

private
  module C = Closure Code
  module T = Closure Tm

open Partial
open Trans-⊑

-- Some abbreviations.

evalⁿ : ∀ {n} → Tm n → T.Env n → ℕ → T.Value ⊥
evalⁿ t ρ n = app→ eval n (_ , t , ρ)

_∙ⁿ_ : T.Value → T.Value → ℕ → T.Value ⊥
(v₁ ∙ⁿ v₂) n = function (v₁ ∙ v₂) (app→ eval n)

execⁿ : State → ℕ → Maybe C.Value ⊥
execⁿ s n = app→ (transformer execP) n s

-- Compiler correctness.

mutual

  ⟦⟧-correct :
    ∀ {n} t {ρ : T.Env n} {c s}
      {k : ℕ → T.Value → Maybe C.Value ⊥} {n} →
    (∀ v → execⁿ ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩ ≳[ n ]
           λ n → k n v) →
    execⁿ ⟨ comp t c , s , comp-env ρ ⟩ ≳[ n ]
    λ n → evalⁿ t ρ (suc n) >>= k n
  ⟦⟧-correct (var x) {ρ} {c} {s} {k} hyp =
    execⁿ ⟨ var x ∷ c , s , comp-env ρ ⟩                 ≳⟨ step⇓ ⟩
    execⁿ ⟨ c , val (comp-val (ρ x)) ∷ s , comp-env ρ ⟩  ≳⟨ hyp (ρ x) ⟩
    (λ n → k n (ρ x))                                    ≡⟨ sym now->>= ⟩≳
    (λ n → evalⁿ (var x) ρ (suc n) >>= k n)              ∎≳

  ⟦⟧-correct (ƛ t) {ρ} {c} {s} {k} hyp =
    execⁿ ⟨ clo (comp t (ret ∷ [])) ∷ c , s , comp-env ρ ⟩   ≳⟨ step⇓ ⟩
    execⁿ ⟨ c , val (comp-val (T.ƛ t ρ)) ∷ s , comp-env ρ ⟩  ≳⟨ hyp (T.ƛ t ρ) ⟩
    (λ n → k n (T.ƛ t ρ))                                    ≡⟨ sym now->>= ⟩≳
    (λ n → evalⁿ (ƛ t) ρ (suc n) >>= k n)                    ∎≳

  ⟦⟧-correct (t₁ · t₂) {ρ} {c} {s} {k} {n} hyp =
    execⁿ ⟨ comp t₁ (comp t₂ (app ∷ c)) , s , comp-env ρ ⟩    ≳⟨ (⟦⟧-correct t₁ {n = n} λ v₁ → ⟦⟧-correct t₂ λ v₂ → ∙-correct v₁ v₂ hyp) ⟩

    (λ n → evalⁿ t₁ ρ (suc n) >>=′ λ v₁ →
           evalⁿ t₂ ρ (suc n) >>=′ λ v₂ →
           (v₁ ∙ⁿ v₂) n >>=
           k n)                                               ≡⟨ cong (evalⁿ t₁ ρ (suc n) >>=′_)
                                                                      (⟨ext⟩ λ _ → associativity (evalⁿ t₂ ρ (suc n)) _ _) ⟩≳
    (λ n → evalⁿ t₁ ρ (suc n) >>=′ λ v₁ →
           (evalⁿ t₂ ρ (suc n) >>=′ λ v₂ → (v₁ ∙ⁿ v₂) n) >>=
           k n)                                               ≡⟨ associativity (evalⁿ t₁ ρ (suc n)) _ _ ⟩≳

    (λ n → evalⁿ (t₁ · t₂) ρ (suc n) >>= k n)                 ∎≳

  ∙-correct :
    ∀ {n} v₁ v₂ {ρ : T.Env n} {c s}
      {k : ℕ → T.Value → Maybe C.Value ⊥} {n} →
    (∀ v → execⁿ ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩ ≳[ n ]
           λ n → k n v) →
    execⁿ ⟨ app ∷ c
          , val (comp-val v₂) ∷ val (comp-val v₁) ∷ s
          , comp-env ρ
          ⟩ ≳[ n ]
    λ n → (v₁ ∙ⁿ v₂) n >>= k n

  ∙-correct (T.ƛ t₁ ρ₁) v₂ {ρ} {c} {s} {k} {zero} hyp =
    execⁿ ⟨ app ∷ c
          , val (comp-val v₂) ∷ val (comp-val (T.ƛ t₁ ρ₁)) ∷ s
          , comp-env ρ
          ⟩                                                     ≡⟨ refl ⟩≳

    const never                                                 ≡⟨ sym never->>= ⟩≳

    (λ n → (T.ƛ t₁ ρ₁ ∙ⁿ v₂) n >>= k n)                         ∎≳

  ∙-correct (T.ƛ t₁ ρ₁) v₂ {ρ} {c} {s} {k} {suc n} hyp = later (
    execⁿ ⟨ app ∷ c
          , val (comp-val v₂) ∷ val (comp-val (T.ƛ t₁ ρ₁)) ∷ s
          , comp-env ρ
          ⟩ ∘ suc                                               ≳⟨⟩

    execⁿ ⟨ comp t₁ (ret ∷ [])
          , ret c (comp-env ρ) ∷ s
          , cons (comp-val v₂) (comp-env ρ₁)
          ⟩                                                     ∀≡⟨ (λ n → cong (λ ρ′ → execⁿ ⟨ comp t₁ (ret ∷ []) , ret c (comp-env ρ) ∷ s , ρ′ ⟩ n)
                                                                                (sym comp-cons)) ⟩≳
    execⁿ ⟨ comp t₁ (ret ∷ [])
          , ret c (comp-env ρ) ∷ s
          , comp-env (cons v₂ ρ₁)
          ⟩                                                     ≳⟨ (⟦⟧-correct t₁ {n = n} λ v →

        execⁿ ⟨ ret ∷ []
              , val (comp-val v) ∷ ret c (comp-env ρ) ∷ s
              , comp-env (cons v₂ ρ₁)
              ⟩                                                       ≳⟨ step⇓ ⟩

        execⁿ ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩               ≳⟨ hyp v ⟩

        (λ n → k n v)                                                 ≳⟨ step⇓ ⟩

        (λ n → k (suc n) v)                                           ∎≳) ⟩

    (λ n → evalⁿ t₁ (cons v₂ ρ₁) (suc n) >>= k (suc n))         ≳⟨⟩

    (λ n → (T.ƛ t₁ ρ₁ ∙ⁿ v₂) (suc n) >>= k (suc n))             ∎≳)

-- Note that the equality that is used here is syntactic.

correct :
  ∀ t →
  exec ⟨ comp t [] , [] , nil ⟩ ≡
  (⟦ t ⟧ nil >>= λ v → return (just (comp-val v)))
correct t =
  exec ⟨ comp t [] , [] , nil ⟩                            ≡⟨ cong (λ ρ → exec ⟨ comp t [] , [] , ρ ⟩) $ sym comp-nil ⟩

  exec ⟨ comp t [] , [] , comp-env nil ⟩                   ≡⟨⟩

  ⨆ ( execⁿ ⟨ comp t [] , [] , comp-env nil ⟩
    , _
    )                                                      ≡⟨ ≳→⨆≡⨆ 1 (⟦⟧-correct t $ λ v →

      execⁿ ⟨ [] , val (comp-val v) ∷ [] , comp-env nil ⟩       ≳⟨ step⇓ ⟩
      const (return (just (comp-val v)))                        ∎≳) ⟩

  ⨆ ( (λ n → evalⁿ t nil n >>= λ v →
             return (just (comp-val v)))
    , _
    )                                                      ≡⟨ sym ⨆->>= ⟩

  (⟦ t ⟧ nil >>= λ v → return (just (comp-val v)))         ∎


module _ where

module A where

  postulate
    _∷_ _∙_ bind : Set

  infixr 5 _∷_
  infixr 5 _∙_
  infix  1 bind

  syntax bind c (λ x → d) = x ← c , d

module B where

  postulate
    _∷_ _∙_ bind : Set

  infix  5 _∷_
  infixr 4 _∙_
  infixl 2 bind

  syntax bind c d = c ∙ d

module C where

  postulate
    bind : Set

  infixr 2 bind

  syntax bind c d = c ∙ d

open A
open B
open C

-- _∷_ is infix 5.
-- _∙_ has two fixities: infixr 4 and infixr 5.
-- A.bind's notation is infix 1.
-- B.bind and C.bind's notations are infix 2.

-- There is one instance of _∷_ in the grammar.

-- There are three instances of _∙_ in the grammar, one
-- corresponding to A._∙_, one corresponding to B._∙_, and one
-- corresponding to both B.bind and C.bind.

Foo : Set
Foo = ∷ ∙ ← ,


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

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
{-# OPTIONS --allow-unsolved-metas #-}
open import Optics.All
open import LibraBFT.Prelude
open import LibraBFT.Base.PKCS
open import LibraBFT.Base.Encode
open import LibraBFT.Base.KVMap as KVMap
open import LibraBFT.Base.Types
open import Data.String using (String)

-- This module defines types for an out-of-date implementation, based
-- on a previous version of LibraBFT.  It will be updated to model a
-- more recent version in future.
--
-- One important trick here is that the RoundManager type separayes
-- types that /define/ the EpochConfig and types that /use/ the
-- /EpochConfig/. The advantage of doing this separation can be seen
-- in Util.Util.liftEC, where we define a lifting of a function that
-- does not change the bits that define the EpochConfig into the whole
-- state.  This enables a more elegant approach for reasoning about
-- functions that do not change parts of the state responsible for
-- defining the epoch config.  However, the separation is not perfect,
-- so sometimes fields may be modified in EpochIndep even though there
-- is no epoch change.

module LibraBFT.Impl.Consensus.Types where
  open import LibraBFT.Impl.Base.Types                       public
  open import LibraBFT.Impl.NetworkMsg                       public
  open import LibraBFT.Abstract.Types.EpochConfig UID NodeId public
  open import LibraBFT.Impl.Consensus.Types.EpochIndep       public
  open import LibraBFT.Impl.Consensus.Types.EpochDep         public

  record EpochState : Set where
    constructor EpochState∙new
    field
      ₋esEpoch    : Epoch
      ₋esVerifier : ValidatorVerifier
  open EpochState public
  unquoteDecl esEpoch esVerifier = mkLens (quote EpochState)
    (esEpoch ∷ esVerifier ∷ [])

  -- The parts of the state of a peer that are used to
  -- define the EpochConfig are the SafetyRules and ValidatorVerifier:
  record RoundManagerEC : Set where
    constructor RoundManagerEC∙new
    field
      ₋rmEpochState   : EpochState
      ₋rmSafetyRules  : SafetyRules
  open RoundManagerEC public
  unquoteDecl rmEpochState rmSafetyRules = mkLens (quote RoundManagerEC)
    (rmEpochState ∷ rmSafetyRules ∷ [])

  rmEpoch : Lens RoundManagerEC Epoch
  rmEpoch = rmEpochState ∙ esEpoch

  rmLastVotedRound : Lens RoundManagerEC Round
  rmLastVotedRound = rmSafetyRules ∙ srPersistentStorage ∙ pssSafetyData ∙ sdLastVotedRound

  -- We need enough authors to withstand the desired number of
  -- byzantine failures.  We enforce this with a predicate over
  -- 'RoundManagerEC'.
  RoundManagerEC-correct : RoundManagerEC → Set
  RoundManagerEC-correct rmec =
    let numAuthors = kvm-size (rmec ^∙ rmEpochState ∙ esVerifier ∙ vvAddressToValidatorInfo)
        qsize      = rmec ^∙ rmEpochState ∙ esVerifier ∙ vvQuorumVotingPower
        bizF       = numAuthors ∸ qsize
     in suc (3 * bizF) ≤ numAuthors

  RoundManagerEC-correct-≡ : (rmec1 : RoundManagerEC)
                             → (rmec2 : RoundManagerEC)
                             → (rmec1 ^∙ rmEpochState ∙ esVerifier) ≡ (rmec2 ^∙ rmEpochState ∙ esVerifier)
                             → RoundManagerEC-correct rmec1
                             → RoundManagerEC-correct rmec2
  RoundManagerEC-correct-≡ rmec1 rmec2 refl = id

  -- Given a well-formed set of definitions that defines an EpochConfig,
  -- α-EC will compute this EpochConfig by abstracting away the unecessary
  -- pieces from RoundManagerEC.
  -- TODO-2: update and complete when definitions are updated to more recent version
  α-EC : Σ RoundManagerEC RoundManagerEC-correct → EpochConfig
  α-EC (rmec , ok) =
    let numAuthors = kvm-size (rmec ^∙ rmEpochState ∙ esVerifier ∙ vvAddressToValidatorInfo)
        qsize      = rmec ^∙ rmEpochState ∙ esVerifier ∙ vvQuorumVotingPower
        bizF       = numAuthors ∸ qsize
     in (EpochConfig∙new {! someHash?!}
                (rmec ^∙ rmEpoch) numAuthors {!!} {!!} {!!} {!!} {!!} {!!} {!!} {!!})

  postulate
    α-EC-≡ : (rmec1  : RoundManagerEC)
           → (rmec2  : RoundManagerEC)
           → (vals≡  : rmec1 ^∙ rmEpochState ∙ esVerifier ≡ rmec2 ^∙ rmEpochState ∙ esVerifier)
           →           rmec1 ^∙ rmEpoch      ≡ rmec2 ^∙ rmEpoch
           → (rmec1-corr : RoundManagerEC-correct rmec1)
           → α-EC (rmec1 , rmec1-corr) ≡ α-EC (rmec2 , RoundManagerEC-correct-≡ rmec1 rmec2 vals≡ rmec1-corr)
  {-
  α-EC-≡ rmec1 rmec2 refl refl rmec1-corr = refl
  -}

  -- Just in case RoundManager is at a higher level in future
  ℓ-RoundManager : Level
  ℓ-RoundManager = 0ℓ

  -- Finally, the RoundManager is split in two pieces: those that are used to make an EpochConfig
  -- versus those that use an EpochConfig.  The reason is that the *abstract* EpochConfig is a
  -- function of some parts of the RoundManager (₋rmEC), and some parts depend on the abstract
  -- EpochConfig.  For example, ₋btIdToQuorumCert carries a proof that the QuorumCert is valid (for
  -- the abstract EpochConfig).
  record RoundManager : Set ℓ-RoundManager where
    constructor RoundManager∙new
    field
      ₋rmEC           : RoundManagerEC
      ₋rmEC-correct   : RoundManagerEC-correct ₋rmEC
      ₋rmWithEC       : RoundManagerWithEC (α-EC (₋rmEC , ₋rmEC-correct))
     -- If we want to add pieces that neither contribute to the
     -- construction of the EC nor need one, they should be defined in
     -- RoundManager directly
  open RoundManager public

  α-EC-RM : RoundManager → EpochConfig
  α-EC-RM rm = α-EC ((₋rmEC rm) , (₋rmEC-correct rm))

  ₋rmHighestQC : (rm : RoundManager) → QuorumCert
  ₋rmHighestQC rm = ₋btHighestQuorumCert ((₋rmWithEC rm) ^∙ (lBlockTree (α-EC-RM rm)))

  rmHighestQC : Lens RoundManager QuorumCert
  rmHighestQC = mkLens' ₋rmHighestQC
                        (λ (RoundManager∙new ec ecc (RoundManagerWithEC∙new (BlockStore∙new bsInner))) qc
                          → RoundManager∙new ec ecc (RoundManagerWithEC∙new (BlockStore∙new (record bsInner {₋btHighestQuorumCert = qc}))))

  ₋rmHighestCommitQC : (rm : RoundManager) → QuorumCert
  ₋rmHighestCommitQC rm = ₋btHighestCommitCert ((₋rmWithEC rm) ^∙ (lBlockTree (α-EC-RM rm)))

  rmHighestCommitQC : Lens RoundManager QuorumCert
  rmHighestCommitQC = mkLens' ₋rmHighestCommitQC
                        (λ (RoundManager∙new ec ecc (RoundManagerWithEC∙new (BlockStore∙new bsInner))) qc
                          → RoundManager∙new ec ecc (RoundManagerWithEC∙new (BlockStore∙new (record bsInner {₋btHighestCommitCert = qc}))))


-- {-# OPTIONS -v tc.meta:30 --show-irrelevant #-}
-- Andreas, 2013-10-29 submitted by sanzhiyan
-- Documents need for different treating of DontCare in
-- linearity analysis of Miller unification.
-- Now, there can be DontCares stemming from irrelevant projections.

module Issue927 where

import Common.Level

module Fails where

  postulate
    Σ : (B : Set) (C : B → Set) → Set

    <_,_> : {A : Set} {B : A → Set} {C : ∀ x → B x → Set}
          (f : (x : A) → B x) →
          (g : (x : A) → C x (f x)) →
          ((x : A) → Σ (B x) (C x))

  record _⟶_ (A B : Set) : Set  where
    field
      .app : A → B

  open _⟶_ public

  .⟪_,_⟫ : ∀ (A B C : Set) → (A ⟶ B) → (A ⟶ C) → A → Σ B (\ _ → C)
  ⟪_,_⟫ A B C f₁ f₂ = < app f₁ , app f₂ >

-- Using darcs Agda, the following code triggers an
-- internal error at src/full/Agda/TypeChecking/MetaVars.hs:897


module _ where

module M where
  postulate A : Set

module N = M  -- This alias introduces a display form M.A --> N.A

open M

postulate
  a : A

{-# DISPLAY N.A = A #-} -- Makes Agda loop

test : Set
test = a


-- New NO_POSITIVITY_CHECK pragma for data definitions and mutual
-- blocks

-- Skipping an old-style mutual block: Before the `mutual` keyword.
{-# NO_POSITIVITY_CHECK #-}
mutual
  data Cheat : Set where
    cheat : Oops → Cheat

  data Oops : Set where
    oops : (Cheat → Cheat) → Oops


module guarded-recursion where
import guarded-recursion.prelude
import guarded-recursion.model
import guarded-recursion.model.Agda
import guarded-recursion.embedding
import guarded-recursion.compute
import guarded-recursion.clocks


{-# OPTIONS --rewriting #-}

module Properties.Step where

open import Agda.Builtin.Equality using (_≡_; refl)
open import Agda.Builtin.Float using (primFloatPlus; primFloatMinus; primFloatTimes; primFloatDiv; primFloatEquality; primFloatLess)
open import Agda.Builtin.Bool using (true; false)
open import Agda.Builtin.String using (primStringAppend)
open import FFI.Data.Maybe using (just; nothing)
open import Luau.Heap using (Heap; _[_]; alloc; ok; function_is_end)
open import Luau.Syntax using (Block; Expr; nil; var; val; addr; bool; function_is_end; block_is_end; _$_; local_←_; return; done; _∙_; name; fun; arg; number; binexp; +; -; *; /; <; >; <=; >=; ==; ~=; ··; string)
open import Luau.OpSem using (_⟦_⟧_⟶_; _⊢_⟶ᴱ_⊣_; _⊢_⟶ᴮ_⊣_; app₁ ; app₂ ; beta; function; block; return; done; local; subst; binOp₀; binOp₁; binOp₂; +; -; *; /; <; >; <=; >=; ==; ~=; ··; evalEqOp; evalNeqOp)
open import Luau.RuntimeError using (BinOpError; RuntimeErrorᴱ; RuntimeErrorᴮ; FunctionMismatch; BinOpMismatch₁; BinOpMismatch₂; UnboundVariable; SEGV; app₁; app₂; block; local; return; bin₁; bin₂; +; -; *; /; <; >; <=; >=; ··)
open import Luau.RuntimeType using (valueType; function; number)
open import Luau.Substitution using (_[_/_]ᴮ)
open import Properties.Remember using (remember; _,_)
open import Utility.Bool using (not; _or_)

data BinOpStepResult v op w : Set where
  step : ∀ x → (v ⟦ op ⟧ w ⟶ x) → BinOpStepResult v op w
  error₁ : BinOpError op (valueType(v)) → BinOpStepResult v op w
  error₂ : BinOpError op (valueType(w)) → BinOpStepResult v op w

binOpStep : ∀ v op w → BinOpStepResult v op w
binOpStep nil + w = error₁ (+ (λ ()))
binOpStep (addr a) + w = error₁ (+ (λ ()))
binOpStep (number m) + nil = error₂ (+ (λ ()))
binOpStep (number m) + (addr a) = error₂ (+ (λ ()))
binOpStep (number m) + (number n) = step (number (primFloatPlus m n)) (+ m n)
binOpStep (number m) + (bool b) = error₂ (+ (λ ()))
binOpStep (number m) + (string x) = error₂ (+ (λ ()))
binOpStep (number m) - (string x) = error₂ (- (λ ()))
binOpStep (number m) * (string x) = error₂ (* (λ ()))
binOpStep (number m) / (string x) = error₂ (/ (λ ()))
binOpStep (number m) < (string x) = error₂ (< (λ ()))
binOpStep (number m) > (string x) = error₂ (> (λ ()))
binOpStep (number m) == (string x) = step (bool false) (== (number m) (string x))
binOpStep (number m) ~= (string x) = step (bool true) (~= (number m) (string x))
binOpStep (number m) <= (string x) = error₂ (<= (λ ()))
binOpStep (number m) >= (string x) = error₂ (>= (λ ()))
binOpStep (bool b) + w = error₁ (+ (λ ()))
binOpStep nil - w = error₁ (- (λ ()))
binOpStep (addr a) - w = error₁ (- (λ ()))
binOpStep (number x) - nil = error₂ (- (λ ()))
binOpStep (number x) - (addr a) = error₂ (- (λ ()))
binOpStep (number x) - (number n) = step (number (primFloatMinus x n)) (- x n)
binOpStep (number x) - (bool b) = error₂ (- (λ ()))
binOpStep (bool b) - w = error₁ (- (λ ()))
binOpStep nil * w = error₁ (* (λ ()))
binOpStep (addr a) * w = error₁ (* (λ ()))
binOpStep (number m) * nil = error₂ (* (λ ()))
binOpStep (number m) * (addr a) = error₂ (* (λ ()))
binOpStep (number m) * (number n) = step (number (primFloatDiv m n)) (* m n)
binOpStep (number m) * (bool b) = error₂ (* (λ ()))
binOpStep (bool b) * w = error₁ (* (λ ()))
binOpStep nil / w = error₁ (/ (λ ()))
binOpStep (addr a) / w = error₁ (/ (λ ()))
binOpStep (number m) / nil = error₂ (/ (λ ()))
binOpStep (number m) / (addr a) = error₂ (/ (λ ()))
binOpStep (number m) / (number n) = step (number (primFloatTimes m n)) (/ m n)
binOpStep (number m) / (bool b) = error₂ (/ (λ ()))
binOpStep (bool b) / w = error₁ (/ (λ ()))
binOpStep nil < w = error₁ (< (λ ()))
binOpStep (addr a) < w = error₁ (< (λ ()))
binOpStep (number m) < nil = error₂ (< (λ ()))
binOpStep (number m) < (addr a) = error₂ (< (λ ()))
binOpStep (number m) < (number n) = step (bool (primFloatLess m n)) (< m n)
binOpStep (number m) < (bool b) = error₂ (< (λ ()))
binOpStep (bool b) < w = error₁ (< (λ ()))
binOpStep nil > w = error₁ (> (λ ()))
binOpStep (addr a) > w = error₁ (> (λ ()))
binOpStep (number m) > nil = error₂ (> (λ ()))
binOpStep (number m) > (addr a) = error₂ (> (λ ()))
binOpStep (number m) > (number n) = step (bool (primFloatLess n m)) (> m n)
binOpStep (number m) > (bool b) = error₂ (> (λ ()))
binOpStep (bool b) > w = error₁ (> (λ ()))
binOpStep v == w = step (bool (evalEqOp v w)) (== v w)
binOpStep v ~= w = step (bool (evalNeqOp v w)) (~= v w)
binOpStep nil <= w = error₁ (<= (λ ()))
binOpStep (addr a) <= w = error₁ (<= (λ ()))
binOpStep (number m) <= nil = error₂ (<= (λ ()))
binOpStep (number m) <= (addr a) = error₂ (<= (λ ()))
binOpStep (number m) <= (number n) = step (bool (primFloatLess m n or primFloatEquality m n)) (<= m n)
binOpStep (number m) <= (bool b) = error₂ (<= (λ ()))
binOpStep (bool b) <= w = error₁ (<= (λ ()))
binOpStep nil >= w = error₁ (>= (λ ()))
binOpStep (addr a) >= w = error₁ (>= (λ ()))
binOpStep (number m) >= nil = error₂ (>= (λ ()))
binOpStep (number m) >= (addr a) = error₂ (>= (λ ()))
binOpStep (number m) >= (number n) = step (bool (primFloatLess n m or primFloatEquality m n)) (>= m n)
binOpStep (number m) >= (bool b) = error₂ (>= (λ ()))
binOpStep (bool b) >= w = error₁ (>= (λ ()))
binOpStep (string x) + w = error₁ (+ (λ ()))
binOpStep (string x) - w = error₁ (- (λ ()))
binOpStep (string x) * w = error₁ (* (λ ()))
binOpStep (string x) / w = error₁ (/ (λ ()))
binOpStep (string x) < w = error₁ (< (λ ()))
binOpStep (string x) > w = error₁ (> (λ ()))
binOpStep (string x) <= w = error₁ (<= (λ ()))
binOpStep (string x) >= w = error₁ (>= (λ ()))
binOpStep nil ·· y = error₁ (·· (λ ()))
binOpStep (addr x) ·· y = error₁ (BinOpError.·· (λ ()))
binOpStep (number x) ·· y = error₁ (BinOpError.·· (λ ()))
binOpStep (bool x) ·· y = error₁ (BinOpError.·· (λ ()))
binOpStep (string x) ·· nil = error₂ (·· (λ ()))
binOpStep (string x) ·· (addr y) = error₂ (·· (λ ()))
binOpStep (string x) ·· (number y) = error₂ (·· (λ ()))
binOpStep (string x) ·· (bool y) = error₂ (·· (λ ()))
binOpStep (string x) ·· (string y) = step (string (primStringAppend x y)) (·· x y)

data StepResultᴮ {a} (H : Heap a) (B : Block a) : Set
data StepResultᴱ {a} (H : Heap a) (M : Expr a) : Set

data StepResultᴮ H B where
  step : ∀ H′ B′ → (H ⊢ B ⟶ᴮ B′ ⊣ H′) → StepResultᴮ H B
  return : ∀ v {B′} → (B ≡ (return (val v) ∙ B′)) → StepResultᴮ H B
  done : (B ≡ done) → StepResultᴮ H B
  error : (RuntimeErrorᴮ H B) → StepResultᴮ H B

data StepResultᴱ H M where
  step : ∀ H′ M′ → (H ⊢ M ⟶ᴱ M′ ⊣ H′) → StepResultᴱ H M
  value : ∀ V → (M ≡ val V) → StepResultᴱ H M
  error : (RuntimeErrorᴱ H M) → StepResultᴱ H M

stepᴱ : ∀ {a} H M → StepResultᴱ {a} H M
stepᴮ : ∀ {a} H B → StepResultᴮ {a} H B

stepᴱ H (val v) = value v refl
stepᴱ H (var x) = error UnboundVariable
stepᴱ H (M $ N) with stepᴱ H M
stepᴱ H (M $ N) | step H′ M′ D = step H′ (M′ $ N) (app₁ D)
stepᴱ H (_ $ N) | value v refl with stepᴱ H N
stepᴱ H (_ $ N) | value v refl | step H′ N′ s = step H′ (val v $ N′) (app₂ v s)
stepᴱ H (_ $ _) | value (addr a) refl | value w refl with remember (H [ a ])
stepᴱ H (_ $ _) | value (addr a) refl | value w refl  | (nothing , p) = error (app₁ (SEGV p))
stepᴱ H (_ $ _) | value (addr a) refl | value w refl  | (just(function F is B end) , p) = step H (block (fun F) is B [ w / name (arg F) ]ᴮ end) (beta function F is B end w refl p)
stepᴱ H (_ $ _) | value nil refl | value w refl = error (FunctionMismatch nil w (λ ()))
stepᴱ H (_ $ _) | value (number m) refl | value w refl = error (FunctionMismatch (number m) w (λ ()))
stepᴱ H (_ $ _) | value (bool b) refl | value w refl = error (FunctionMismatch (bool b) w (λ ()))
stepᴱ H (_ $ _) | value (string x) refl | value w refl = error (FunctionMismatch (string x) w (λ ()))
stepᴱ H (M $ N) | value V p | error E = error (app₂ E)
stepᴱ H (M $ N) | error E = error (app₁ E)
stepᴱ H (block b is B end) with stepᴮ H B
stepᴱ H (block b is B end) | step H′ B′ D = step H′ (block b is B′ end) (block D)
stepᴱ H (block b is (return _ ∙ B′) end) | return v refl = step H (val v) (return v)
stepᴱ H (block b is done end) | done refl = step H (val nil) done
stepᴱ H (block b is B end) | error E = error (block E)
stepᴱ H (function F is C end) with alloc H (function F is C end)
stepᴱ H function F is C end | ok a H′ p = step H′ (val (addr a)) (function a p)
stepᴱ H (binexp M op N) with stepᴱ H M
stepᴱ H (binexp M op N) | step H′ M′ s = step H′ (binexp M′ op N) (binOp₁ s)
stepᴱ H (binexp M op N) | error E = error (bin₁ E)
stepᴱ H (binexp M op N) | value v refl with stepᴱ H N
stepᴱ H (binexp M op N) | value v refl | step H′ N′ s = step H′ (binexp (val v) op N′) (binOp₂ s)
stepᴱ H (binexp M op N) | value v refl | error E = error (bin₂ E)
stepᴱ H (binexp M op N) | value v refl | value w refl with binOpStep v op w
stepᴱ H (binexp M op N) | value v refl | value w refl | step x p = step H (val x) (binOp₀ p)
stepᴱ H (binexp M op N) | value v refl | value w refl | error₁ E = error (BinOpMismatch₁ v w E)
stepᴱ H (binexp M op N) | value v refl | value w refl | error₂ E = error (BinOpMismatch₂ v w E)

stepᴮ H (function F is C end ∙ B) with alloc H (function F is C end)
stepᴮ H (function F is C end ∙ B) | ok a H′ p = step H′ (B [ addr a / name (fun F) ]ᴮ) (function a p)
stepᴮ H (local x ← M ∙ B) with stepᴱ H M
stepᴮ H (local x ← M ∙ B) | step H′ M′ D = step H′ (local x ← M′ ∙ B) (local D)
stepᴮ H (local x ← _ ∙ B) | value v refl = step H (B [ v / name x ]ᴮ) (subst v)
stepᴮ H (local x ← M ∙ B) | error E = error (local E)
stepᴮ H (return M ∙ B) with stepᴱ H M
stepᴮ H (return M ∙ B) | step H′ M′ D = step H′ (return M′ ∙ B) (return D)
stepᴮ H (return _ ∙ B) | value V refl = return V refl
stepᴮ H (return M ∙ B) | error E = error (return E)
stepᴮ H done = done refl