import cedille-options
open import general-util
module meta-vars (options : cedille-options.options) {mF : Set → Set} ⦃ _ : monad mF ⦄ where

open import cedille-types
open import constants
open import conversion
open import ctxt
open import free-vars
open import rename
open import spans options {mF}
open import subst
open import syntax-util
open import to-string options

-- misc
----------------------------------------------------------------------

-- Meta-variables, prototypes, decorated types
-- ==================================================

record meta-var-sol (A : Set) : Set where
  constructor mk-meta-var-sol
  field
    sol : A
    src : checking-mode

data meta-var-sort : Set where
  meta-var-tp : (k  : kind) → (mtp : maybe $ meta-var-sol type) → meta-var-sort
  meta-var-tm : (tp : type) → (mtm : maybe $ meta-var-sol term) → meta-var-sort

record meta-var : Set where
  constructor meta-var-mk
  field
    name : string
    sort  : meta-var-sort
    loc  : span-location
open meta-var

pattern meta-var-mk-tp x k mtp l = meta-var-mk x (meta-var-tp k mtp) l

record meta-vars : Set where
  constructor meta-vars-mk
  field
    order   : 𝕃 var
    varset  : trie meta-var
open meta-vars

data prototype : Set where
  proto-maybe : maybe type → prototype
  proto-arrow : erased? → prototype → prototype

data decortype : Set where
  decor-type  : type → decortype
  decor-arrow : erased? → type → decortype → decortype
  decor-decor : erased? → var → tpkd → meta-var-sort → decortype → decortype
  decor-stuck : type → prototype → decortype
  decor-error : type → prototype → decortype

-- Simple definitions and accessors
-- --------------------------------------------------

meta-var-name : meta-var → var
meta-var-name X = meta-var.name X

meta-vars-get-varlist : meta-vars → 𝕃 var
meta-vars-get-varlist Xs = map (name ∘ snd) (trie-mappings (varset Xs))

meta-var-solved? : meta-var → 𝔹
meta-var-solved? (meta-var-mk n (meta-var-tp k nothing) _) = ff
meta-var-solved? (meta-var-mk n (meta-var-tp k (just _)) _) = tt
meta-var-solved? (meta-var-mk n (meta-var-tm tp nothing) _) = ff
meta-var-solved? (meta-var-mk n (meta-var-tm tp (just _)) _) = tt

meta-vars-empty : meta-vars
meta-vars-empty = meta-vars-mk [] empty-trie

meta-vars-empty? : meta-vars → 𝔹
meta-vars-empty? Xs = ~ (trie-nonempty (varset Xs ))

meta-vars-solved? : meta-vars → 𝔹
meta-vars-solved? Xs = trie-all meta-var-solved? (varset Xs)

meta-vars-filter : (meta-var → 𝔹) → meta-vars → meta-vars
meta-vars-filter f Xs =
  meta-vars-mk or vs
  where
  vs = trie-filter f (varset Xs)
  or = filter (trie-contains vs) (order Xs)

meta-var-sort-eq? : ctxt → (=S =T : meta-var-sort) → 𝔹
meta-var-sort-eq? Γ (meta-var-tp k₁ mtp₁) (meta-var-tp k₂ mtp₂)
  with conv-kind Γ k₁ k₂
... | ff = ff
... | tt =
  maybe-equal? sol-eq mtp₁ mtp₂
  where
    sol-eq : (sol₁ sol₂ : meta-var-sol type) → 𝔹
    sol-eq (mk-meta-var-sol sol₁ src) (mk-meta-var-sol sol₂ src₁) =
      conv-type Γ sol₁ sol₂

meta-var-sort-eq? _ _ _ = ff
-- TODO terms not supported
-- meta-var-sol-eq? (meta-var-tm tp mtm) (meta-var-tm tp₁ mtm₁) = {!!}

meta-var-equal? : ctxt → (X Y : meta-var) → 𝔹
meta-var-equal? Γ (meta-var-mk name₁ sol₁ _) (meta-var-mk name₂ sol₂ _) =
  name₁ =string name₂ && meta-var-sort-eq? Γ sol₁ sol₂

meta-vars-equal? : ctxt → (Xs Ys : meta-vars) → 𝔹
meta-vars-equal? Γ Xs Ys =
  trie-equal? (meta-var-equal? Γ) (meta-vars.varset Xs) (meta-vars.varset Ys)

meta-vars-lookup : meta-vars → var → maybe meta-var
meta-vars-lookup Xs x = trie-lookup (varset Xs) x

meta-vars-lookup-with-kind : meta-vars → var → maybe (meta-var × kind)
meta-vars-lookup-with-kind Xs x
  with meta-vars-lookup Xs x
... | nothing = nothing
... | (just X@(meta-var-mk-tp _ k _ _)) = just $ X , k
... | (just X) = nothing

meta-var-set-src : meta-var → checking-mode → meta-var
meta-var-set-src (meta-var-mk-tp name₁ k (just sol) loc₁) m =
  meta-var-mk-tp name₁ k (just (record sol { src = m })) loc₁
meta-var-set-src (meta-var-mk-tp name₁ k nothing loc₁) m =
  meta-var-mk-tp name₁ k nothing loc₁
meta-var-set-src (meta-var-mk name₁ (meta-var-tm tp (just sol)) loc₁) m =
  meta-var-mk name₁ (meta-var-tm tp (just (record sol { src = m }))) loc₁
meta-var-set-src (meta-var-mk name₁ (meta-var-tm tp nothing) loc₁) m
  = meta-var-mk name₁ (meta-var-tm tp nothing) loc₁

meta-vars-lookup-kind : meta-vars → var → maybe kind
meta-vars-lookup-kind Xs x with meta-vars-lookup Xs x
... | nothing = nothing
... | (just (meta-var-mk-tp _ k _ _)) = just k
... | (just X) = nothing

-- conversion to types, terms, tks
-- --------------------------------------------------

meta-var-sort-to-tk : meta-var-sort → tpkd
meta-var-sort-to-tk (meta-var-tp k mtp) = Tkk k
meta-var-sort-to-tk (meta-var-tm tp mtm) = Tkt tp

meta-var-to-type : meta-var → maybe type
meta-var-to-type (meta-var-mk-tp x k (just tp) _) = just (meta-var-sol.sol tp)
meta-var-to-type (meta-var-mk-tp x k nothing _) = just (TpVar x)
meta-var-to-type (meta-var-mk x (meta-var-tm tp mtm) _) = nothing

meta-var-to-term : meta-var → maybe term
meta-var-to-term (meta-var-mk-tp x k mtp _) = nothing
meta-var-to-term (meta-var-mk x (meta-var-tm tp (just tm)) _) = just (meta-var-sol.sol tm)
meta-var-to-term (meta-var-mk x (meta-var-tm tp nothing) _) = just (Var x)

meta-var-to-type-unsafe : meta-var → type
meta-var-to-type-unsafe X
  with meta-var-to-type X
... | just tp = tp
... | nothing = TpVar (meta-var-name X)

meta-var-to-term-unsafe : meta-var → term
meta-var-to-term-unsafe X
  with meta-var-to-term X
... | just tm = tm
... | nothing = Var (meta-var-name X)

-- if all meta-vars are solved, return their solutions as args
meta-vars-to-args : meta-vars → maybe args
meta-vars-to-args (meta-vars-mk or vs) =
  flip 𝕃maybe-map or λ x → trie-lookup vs x ≫=maybe λ where
    (meta-var-mk name (meta-var-tm tp tm?) loc) →
      tm? >>= just ∘' ArgEr ∘' meta-var-sol.sol
    (meta-var-mk name (meta-var-tp kd tp?) loc) →
      tp? >>= just ∘' ArgTp ∘' meta-var-sol.sol

prototype-to-maybe : prototype → maybe type
prototype-to-maybe (proto-maybe mtp) = mtp
prototype-to-maybe (proto-arrow _ _) = nothing

prototype-to-checking : prototype → checking-mode
prototype-to-checking = maybe-to-checking ∘ prototype-to-maybe

decortype-to-type : decortype → type
decortype-to-type (decor-type tp) = tp
decortype-to-type (decor-arrow at tp dt) =
  TpArrow tp at (decortype-to-type dt)
decortype-to-type (decor-decor b x tk sol dt) =
  TpAbs b x tk (decortype-to-type dt)
decortype-to-type (decor-stuck tp pt) = tp
decortype-to-type (decor-error tp pt) = tp

-- hnf for decortype
-- --------------------------------------------------

hnf-decortype : ctxt → unfolding → decortype → (is-head : 𝔹) → decortype
hnf-decortype Γ uf (decor-type tp) ish =
  decor-type (hnf Γ (record uf {unfold-defs = ish}) tp)
hnf-decortype Γ uf (decor-arrow e? tp dt) ish =
  decor-arrow e? (hnf Γ (record uf {unfold-defs = ff}) tp) (hnf-decortype Γ uf dt ff)
hnf-decortype Γ uf (decor-decor e? x tk sol dt) ish =
  decor-decor e? x tk sol (hnf-decortype Γ uf dt ff)
hnf-decortype Γ uf dt@(decor-stuck _ _) ish = dt
hnf-decortype Γ uf (decor-error tp pt) ish =
  decor-error (hnf Γ (record uf {unfold-defs = ff}) tp) pt

-- substitutions
-- --------------------------------------------------

substh-meta-var-sort : substh-ret-t meta-var-sort
substh-meta-var-sort Γ ρ σ (meta-var-tp k mtp) =
  meta-var-tp (substh Γ ρ σ k) ((flip maybe-map) mtp λ sol →
    record sol { sol = substh Γ ρ σ (meta-var-sol.sol sol) })
substh-meta-var-sort Γ ρ σ (meta-var-tm tp mtm) =
  meta-var-tm (substh Γ ρ σ tp) (flip maybe-map mtm λ sol →
    record sol { sol = substh Γ ρ σ (meta-var-sol.sol sol) })

subst-meta-var-sort : subst-ret-t meta-var-sort
subst-meta-var-sort Γ t x (meta-var-tp k mtp) =
  meta-var-tp (subst Γ t x k) $ (flip maybe-map) mtp λ sol →
    record sol { sol = subst Γ t x $ meta-var-sol.sol sol }

subst-meta-var-sort Γ t x (meta-var-tm tp mtm) =
  meta-var-tm (subst Γ t x tp) $ (flip maybe-map) mtm λ where
    (mk-meta-var-sol sol src) → mk-meta-var-sol (subst Γ t x sol) src

meta-vars-get-sub : meta-vars → trie (Σi exprd ⟦_⟧)
meta-vars-get-sub Xs =
  trie-catMaybe (trie-map (maybe-map ,_ ∘ meta-var-to-type) (varset Xs))

meta-vars-subst-type' : (unfold : 𝔹) → ctxt → meta-vars → type → type
meta-vars-subst-type' u Γ Xs tp =
  let tp' = substs Γ (meta-vars-get-sub Xs) tp in
  if u then hnf Γ unfold-head-elab tp' else tp'

meta-vars-subst-type : ctxt → meta-vars → type → type
meta-vars-subst-type = meta-vars-subst-type' tt

meta-vars-subst-kind : ctxt → meta-vars → kind → kind
meta-vars-subst-kind Γ Xs k
  = hnf Γ unfold-head-elab (substh Γ empty-renamectxt (meta-vars-get-sub Xs) k)

-- string and span helpers
-- --------------------------------------------------

meta-var-to-string : meta-var → strM
meta-var-to-string (meta-var-mk-tp name k nothing sl)
  = strMetaVar name sl
    >>str strAdd " : " >>str to-stringe k
meta-var-to-string (meta-var-mk-tp name k (just tp) sl)
  = strMetaVar name sl
    >>str strAdd " : " >>str to-stringe k
    >>str strAdd " = " >>str to-stringe (meta-var-sol.sol tp) -- tp
meta-var-to-string (meta-var-mk name (meta-var-tm tp nothing) sl)
  = strMetaVar name sl
    >>str strAdd " : " >>str to-stringe tp
meta-var-to-string (meta-var-mk name (meta-var-tm tp (just tm)) sl)
  = strMetaVar name sl
    >>str strAdd " : " >>str to-stringe tp
    >>str strAdd " = " >>str to-stringe (meta-var-sol.sol tm) -- tm

meta-vars-to-stringe : 𝕃 meta-var → strM
meta-vars-to-stringe []
  = strEmpty
meta-vars-to-stringe (v :: [])
  = meta-var-to-string v
meta-vars-to-stringe (v :: vs)
  = meta-var-to-string v >>str strAdd ", " >>str meta-vars-to-stringe vs

meta-vars-to-string : meta-vars → strM
meta-vars-to-string Xs =
  meta-vars-to-stringe
    ((flip map) (order Xs) λ x →
      case trie-lookup (varset Xs) x of λ where
        nothing  →
          meta-var-mk
            (x ^ "-missing!") (meta-var-tp KdStar nothing)
            missing-span-location
        (just X) → X)

prototype-to-string : prototype → strM
prototype-to-string (proto-maybe nothing) = strAdd "⁇"
prototype-to-string (proto-maybe (just tp)) = to-stringe tp
prototype-to-string (proto-arrow e? pt) =
  strAdd "⁇" >>str strAdd (arrowtype-to-string e?)
  >>str prototype-to-string pt

decortype-to-string : decortype → strM
decortype-to-string (decor-type tp) =
  strAdd "[" >>str to-stringe tp >>str strAdd "]"
decortype-to-string (decor-arrow e? tp dt) =
  to-stringe tp
  >>str strAdd (arrowtype-to-string e?)
  >>str decortype-to-string dt
decortype-to-string (decor-decor e? x tk sol dt) =
  strAdd (binder e? sol) >>str meta-var-to-string (meta-var-mk x sol missing-span-location)
  >>str strAdd "<" >>str tpkd-to-stringe tk >>str strAdd ">" >>str strAdd " . " >>str decortype-to-string dt
  where
  binder : erased? → meta-var-sort → string
  binder Erased sol = "∀ "
  binder Pi (meta-var-tm tp mtm) = "Π "
  -- vv clause below "shouldn't" happen
  binder Pi (meta-var-tp k mtp) = "∀ "

decortype-to-string (decor-stuck tp pt) =
  strAdd "(" >>str to-stringe tp >>str strAdd " , " >>str prototype-to-string pt >>str strAdd ")"
decortype-to-string (decor-error tp pt) =
  strAdd "([" >>str (to-stringe tp) >>str strAdd "] ‼ " >>str prototype-to-string pt >>str strAdd ")"

meta-vars-data-h : ctxt → string → kind ∨ (meta-var-sol type) → tagged-val
meta-vars-data-h Γ X (inj₁ k) =
  strRunTag "meta-vars-intro" Γ
    (strAdd (unqual-local X ^ "  ") >>str to-stringe k)
meta-vars-data-h Γ X (inj₂ sol) =
  strRunTag "meta-vars-sol" Γ $
  strAdd (unqual-local X ^ " ") >>str
  strAdd (checking-to-string (meta-var-sol.src sol) ^ " ") >>str
  (to-stringe ∘ meta-var-sol.sol $ sol)

meta-vars-data-all : ctxt → meta-vars → 𝕃 tagged-val
meta-vars-data-all Γ = foldr
  (uncurry λ where
    _ (meta-var-mk X (meta-var-tp kd nothing) loc) xs →
      meta-vars-data-h Γ X (inj₁ kd) :: xs
    _ (meta-var-mk X (meta-var-tp kd (just tp)) loc) xs →
      meta-vars-data-h Γ X (inj₁ kd)
      :: meta-vars-data-h Γ X (inj₂ tp) :: xs
    _ _ xs → xs)
  [] ∘ (trie-mappings ∘ meta-vars.varset)

meta-vars-intro-data : ctxt → meta-vars → 𝕃 tagged-val
meta-vars-intro-data Γ = map (h ∘ snd) ∘ (trie-mappings ∘ meta-vars.varset)
  where
  h : meta-var → tagged-val
  h (meta-var-mk X (meta-var-tp kd mtp) loc) = meta-vars-data-h Γ X (inj₁ kd)
  h (meta-var-mk X (meta-var-tm tp mtm) loc) =
    meta-vars-data-h Γ X
      (inj₂ (mk-meta-var-sol (TpVar "unimplemented") untyped))

meta-vars-sol-data : ctxt → meta-vars → meta-vars → 𝕃 tagged-val
meta-vars-sol-data Γ Xsₒ Xsₙ = foldr (λ X xs → maybe-else xs (_:: xs) (h (snd X)))
  [] (trie-mappings (meta-vars.varset Xsₙ))
  where
  h : meta-var → maybe tagged-val
  h (meta-var-mk X (meta-var-tp kd (just tp)) loc) with trie-lookup (meta-vars.varset Xsₒ) X
  ...| just (meta-var-mk _ (meta-var-tp _ (just _)) _) = nothing
  ...| _ = just (meta-vars-data-h Γ X (inj₂ tp)
    )
  h (meta-var-mk X (meta-var-tp kd nothing) loc) = nothing
  h (meta-var-mk X (meta-var-tm tp mtm) loc) =
    just (meta-vars-data-h Γ X
      (inj₂ (mk-meta-var-sol (TpVar "unimplemented") untyped)))

meta-vars-check-type-mismatch : ctxt → string → type → meta-vars → type
                                 → 𝕃 tagged-val × err-m
meta-vars-check-type-mismatch Γ s tp Xs tp'
  = (expected-type Γ tp :: [ type-data Γ tp'' ]) ,
    (if conv-type Γ tp tp''
        then nothing
        else just ("The expected type does not match the "
               ^ s ^ " type."))
    where tp'' = meta-vars-subst-type' ff Γ Xs tp'

meta-vars-check-type-mismatch-if : maybe type → ctxt → string → meta-vars
                                    → type → 𝕃 tagged-val × err-m
meta-vars-check-type-mismatch-if (just tp) Γ s Xs tp'
  = meta-vars-check-type-mismatch Γ s tp Xs tp'
meta-vars-check-type-mismatch-if nothing Γ s Xs tp'
  = [ type-data Γ tp″ ] , nothing
  where
  tp″ = meta-vars-subst-type' ff Γ Xs tp'

decortype-data : ctxt → decortype → tagged-val
decortype-data Γ dt = strRunTag "head decoration" Γ (decortype-to-string dt)

prototype-data : ctxt → prototype → tagged-val
prototype-data Γ pt = strRunTag "head prototype" Γ (prototype-to-string pt)

-- collecting, merging, matching
-- --------------------------------------------------

meta-var-fresh-t : (S : Set) → Set
meta-var-fresh-t S = meta-vars → var → span-location → S → meta-var

meta-var-fresh : meta-var-fresh-t meta-var-sort
meta-var-fresh Xs x sl sol
  with fresh-h (trie-contains (varset Xs)) (meta-var-pfx-str ^ x)
... | x' = meta-var-mk x' sol sl

meta-var-fresh-tp : meta-var-fresh-t (kind × maybe (meta-var-sol type))
meta-var-fresh-tp Xs x sl (k , msol) =
  meta-var-fresh Xs x sl (meta-var-tp k msol)

meta-var-fresh-tm : meta-var-fresh-t (type × maybe (meta-var-sol term))
meta-var-fresh-tm Xs x sl (tp , mtm) = meta-var-fresh Xs x sl (meta-var-tm tp mtm)

private
  meta-vars-set : meta-vars → meta-var → meta-vars
  meta-vars-set Xs X = record Xs { varset = trie-insert (varset Xs) (name X) X }

-- add a meta-var
meta-vars-add : meta-vars → meta-var → meta-vars
meta-vars-add Xs X
 = record (meta-vars-set Xs X) { order = (order Xs) ++ [ name X ] }

meta-vars-add* : meta-vars → 𝕃 meta-var → meta-vars
meta-vars-add* Xs [] = Xs
meta-vars-add* Xs (Y :: Ys) = meta-vars-add* (meta-vars-add Xs Y) Ys

meta-vars-from-list : 𝕃 meta-var → meta-vars
meta-vars-from-list Xs = meta-vars-add* meta-vars-empty Xs

meta-vars-remove : meta-vars → meta-var → meta-vars
meta-vars-remove (meta-vars-mk or vs) X =
  let x = meta-var-name X
  in meta-vars-mk (remove _=string_ x or) (trie-remove vs x)

meta-vars-in-type : meta-vars → type → meta-vars
meta-vars-in-type Xs tp =
  let xs = free-vars tp in
  meta-vars-filter (stringset-contains xs ∘ name) Xs

meta-vars-unsolved : meta-vars → meta-vars
meta-vars-unsolved = meta-vars-filter λ where
  (meta-var-mk x (meta-var-tp k mtp) _)  → ~ isJust mtp
  (meta-var-mk x (meta-var-tm tp mtm) _) → ~ isJust mtm

meta-vars-are-free-in-type : meta-vars → type → 𝔹
meta-vars-are-free-in-type Xs tp =
  let xs = free-vars tp in
  list-any (stringset-contains xs) (order Xs)

-- Unfolding a type with meta-vars
-- ==================================================

-- ... in order to reveal a term or type application

-- "View" data structures
-- --------------------------------------------------

-- The decorated type is really an arrow
record is-tmabsd : Set where
  constructor mk-tmabsd
  field
    is-tmabsd-dt  : decortype
    is-tmabsd-e?  : erased?
    is-tmabsd-var : var
    is-tmabsd-dom : type
    is-tmabsd-var-in-body : 𝔹
    is-tmabsd-cod : decortype
open is-tmabsd public

is-tmabsd? = decortype ∨ is-tmabsd

pattern yes-tmabsd dt e? x dom occ cod = inj₂ (mk-tmabsd dt e? x dom occ cod)
pattern not-tmabsd tp = inj₁ tp

record is-tpabsd : Set where
  constructor mk-tpabsd
  field
    is-tpabsd-dt   : decortype
    is-tpabsd-e?   : erased?
    is-tpabsd-var  : var
    is-tpabsd-kind : kind
    is-tpabsd-sol  : maybe type
    is-tpabsd-body : decortype
open is-tpabsd public

is-tpabsd? = decortype ∨ is-tpabsd

pattern yes-tpabsd dt e? x k mtp dt' = inj₂ (mk-tpabsd dt e? x k mtp dt')
pattern not-tpabsd dt = inj₁ dt

{-# TERMINATING #-}
num-arrows-in-type : ctxt → type → ℕ
num-arrows-in-type Γ tp = nait Γ (hnf' Γ tp) 0 tt
  where
  hnf' : ctxt → type → type
  hnf' Γ tp = hnf Γ unfold-head-elab tp

  nait : ctxt → type → (acc : ℕ) → 𝔹 → ℕ
  -- definitely another arrow
  nait Γ (TpAbs _ _ (Tkk _) tp) acc uf = nait Γ tp acc ff
  nait Γ (TpAbs _ _ (Tkt _) tp) acc uf = nait Γ tp (1 + acc) ff
  -- definitely not another arrow
  nait Γ (TpIota _ _ _) acc uf = acc
  nait Γ (TpEq _ _) acc uf = acc
  nait Γ (TpHole _) acc uf = acc
  nait Γ (TpLam _ _ _) acc uf = acc
  nait Γ (TpVar x) acc tt = acc
  nait Γ (TpApp tp₁ tp₂) acc tt = acc
  nait Γ tp acc ff = nait Γ (hnf' Γ tp) acc tt

-- Utilities for match-types in classify.agda
-- ==================================================
--
-- Match a type with meta-variables in it to one without

-- errors
-- --------------------------------------------------

match-error-data = string × 𝕃 tagged-val

match-error-t : ∀ {a} → Set a → Set a
match-error-t A = match-error-data ∨ A

pattern match-error e = inj₁ e
pattern match-ok a = inj₂ a

module meta-vars-match-errors where
  -- boilerplate
  match-error-msg = "Matching failed"

  -- tagged values for error messages
  match-lhs : {ed : exprd} → ctxt → ⟦ ed ⟧ → tagged-val
  match-lhs = to-string-tag "expected lhs"

  match-rhs : {ed : exprd} → ctxt → ⟦ ed ⟧ → tagged-val
  match-rhs = to-string-tag "computed rhs"

  the-meta-var : var → tagged-val
  the-meta-var = strRunTag "the meta-var" empty-ctxt ∘ strAdd

  the-solution : ctxt → type → tagged-val
  the-solution = to-string-tag "the solution"

  fst-snd-sol : {ed : exprd} → ctxt → (t₁ t₂ : ⟦ ed ⟧) → 𝕃 tagged-val
  fst-snd-sol Γ t₁ t₂ =
    to-string-tag "first solution" Γ t₁ :: [ to-string-tag "second solution" Γ t₂ ]

  lhs-rhs : {ed : exprd} → ctxt → (t₁ t₂ : ⟦ ed ⟧) → 𝕃 tagged-val
  lhs-rhs Γ t₁ t₂ = match-lhs Γ t₁ :: [ match-rhs Γ t₂ ]

  -- error-data
  e-solution-ineq : ctxt → (tp₁ tp₂ : type) → var → match-error-data
  e-solution-ineq Γ tp₁ tp₂ X =
    match-error-msg ^ " because it produced two incovertible solutions for a meta-variable"
    , the-meta-var X :: fst-snd-sol Γ tp₁ tp₂

  e-match-failure : match-error-data
  e-match-failure =
    "The expected argument type is not a (first-order) match of the computed type"
    , []

  e-matchk-failure : match-error-data
  e-matchk-failure =
    "The expected argument kind is not a (first-order) match of the computed kind"
    , []

  e-meta-scope : ctxt → (X tp : type) → match-error-data
--  e-meta-scope : ctxt → (x : var) → (tp₁ tp₂ : type) → match-error-data
  e-meta-scope Γ X tp =
    match-error-msg ^ " because the solution contains a bound variable of the computed argument type"
    , to-string-tag "the meta var" Γ X :: [ to-string-tag "the solution" Γ tp ]

  e-bad-sol-kind : ctxt → (X : var) → (sol : type) → match-error-data
  e-bad-sol-kind Γ X sol =
    "The meta-variable was matched to a type whose kind does not match its own"
    , the-meta-var X :: [ the-solution Γ sol ]

open meta-vars-match-errors

-- meta-vars-match auxiliaries
-- --------------------------------------------------

local-vars = stringset

meta-vars-solve-tp : ctxt → meta-vars → var → type → checking-mode → match-error-t meta-vars
meta-vars-solve-tp Γ Xs x tp m with trie-lookup (varset Xs) x
... | nothing
  = match-error $ x ^ " is not a meta-var!" , []
... | just (meta-var-mk _ (meta-var-tm tp' mtm) _)
  = match-error $ x ^ " is a term meta-var!" , []
... | just (meta-var-mk-tp _ k nothing sl)
  = match-ok (meta-vars-set Xs (meta-var-mk-tp x k (just (mk-meta-var-sol tp m)) sl))
... | just (meta-var-mk-tp _ k (just sol) _) =
  let mk-meta-var-sol tp' src = sol in
  err⊎-guard (~ conv-type Γ tp tp') (e-solution-ineq Γ tp tp x)
  >> match-ok Xs

-- update the kinds of HO meta-vars with
-- solutions
meta-vars-update-kinds : ctxt → (Xs Xsₖ : meta-vars) → meta-vars
meta-vars-update-kinds Γ Xs Xsₖ =
  record Xs { varset = (flip trie-map) (varset Xs) λ where
    (meta-var-mk-tp x k mtp sl) → meta-var-mk-tp x (meta-vars-subst-kind Γ Xsₖ k) mtp sl
    sol → sol
  }

hnf-elab-if : {ed : exprd} → 𝔹 → ctxt → ⟦ ed ⟧ → 𝔹 → ⟦ ed ⟧
hnf-elab-if b Γ t b' = if b then hnf Γ (record unfold-head-elab {unfold-defs = b'}) t else t

meta-vars-add-from-tpabs : ctxt → span-location → meta-vars → erased? → var → kind → type → meta-var × meta-vars
meta-vars-add-from-tpabs Γ sl Xs e? x k tp =
  let Y   = meta-var-fresh-tp Xs x sl (k , nothing)
      Xs' = meta-vars-add Xs Y
--      tp' = subst Γ (meta-var-to-type-unsafe Y) x tp
  in Y , Xs'

{-
-- Legacy for elaboration.agda
-- ==================================================

-- TODO: remove dependency and delete code

{-# TERMINATING #-} -- subst of a meta-var does not increase distance to arrow
meta-vars-peel : ctxt → span-location → meta-vars → type → (𝕃 meta-var) × type
meta-vars-peel Γ sl Xs (Abs pi e? pi' x tk@(Tkk k) tp)
  with meta-vars-add-from-tpabs Γ sl Xs (mk-tpabs e? x k tp)
... | (Y , Xs')
  with subst Γ (meta-var-to-type-unsafe Y) x tp
... | tp' =
  let ret =  meta-vars-peel Γ sl Xs' tp' ; Ys  = fst ret ; rtp = snd ret
  in (Y :: Ys , rtp)
meta-vars-peel Γ sl Xs (NoSpans tp _) =
  meta-vars-peel Γ sl Xs tp
meta-vars-peel Γ sl Xs (TpParens _ tp _) =
  meta-vars-peel Γ sl Xs tp
meta-vars-peel Γ sl Xs tp = [] , tp

meta-vars-unfold-tpapp : ctxt → meta-vars → type → is-tpabs?
meta-vars-unfold-tpapp Γ Xs tp
  with meta-vars-subst-type Γ Xs tp
... | Abs _ b _ x (Tkk k) tp' = yes-tpabs b x k tp'
... | tp'                        = not-tpabs tp'

meta-vars-unfold-tmapp : ctxt → span-location → meta-vars → type → 𝕃 meta-var × is-tmabs?
meta-vars-unfold-tmapp Γ sl Xs tp
  with meta-vars-peel Γ sl Xs (meta-vars-subst-type Γ Xs tp)
... | Ys , Abs _ b _ x (Tkt dom) cod =
  Ys , yes-tmabs b x dom (is-free-in check-erased x cod) cod
... | Ys , TpArrow dom e? cod =
  Ys , yes-tmabs e? "_" dom ff cod
... | Ys , tp' = Ys , not-tmabs tp'

-}


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


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