{-# OPTIONS --no-positivity-check #-}

module Section4b where

open import Section4a public

-- 4.4. The inversion function
-- ---------------------------
--
-- It is possible to go from the semantics back to the proof trees by an inversion function, `reify`
-- that, given a semantic object in a particular Kripke model, returns a proof tree.  The particular
-- Kripke model that we choose has contexts as possible worlds, the order on contexts as the
-- order on worlds, and `_⊢ •` as `𝒢`.  (…)

instance
  canon : Model
  canon = record
    { 𝒲      = 𝒞
    ; _⊒_    = _⊇_
    ; refl⊒ = refl⊇
    ; _◇_    = _○_
    ; uniq⊒ = uniq⊇
    ; 𝒢      = _⊢ •
    }

-- In order to define the inversion function we need to be able to choose a unique fresh
-- name given a context.  We suppose a function `gensym : 𝒞 → Name` and a proof of
-- `T (fresh (gensym Γ) Γ)` which proves that `gensym` returns a fresh variable.  Note that `gensym`
-- is a function taking a context as an argument and it hence always returns the same variable
-- for a given context.

-- TODO: Can we do better than this?
postulate
  gensym : (Γ : 𝒞) → Σ Name (λ x → T (fresh x Γ))

-- The function `reify` is quite intricate.  (…)
--
-- The function `reify` is mutually defined with `val`, which given a function from a context
-- extension to a proof tree returns a semantic object as result.
--
-- We define an abbreviation for the semantic object corresponding to a variable, `⟦ν⟧`.
--
-- The functions `reify` and `val` are both defined by induction on the type:

mutual
  reify : ∀ {A Γ} → Γ ⊩ A → Γ ⊢ A
  reify {•}     {Γ} f = f ⟦g⟧⟨ refl⊇ ⟩
  reify {A ⊃ B} {Γ} f = let x , φ = gensym Γ in
                        let instance _ = φ in
                        ƛ x (reify (f ⟦∙⟧⟨ weak⊇ ⟩ ⟦ν⟧ zero))

  val : ∀ {A Γ} → (∀ {Δ} → Δ ⊇ Γ → Δ ⊢ A) → Γ ⊩ A
  val {•}     f = ⟦𝒢⟧ f
  val {A ⊃ B} f = ⟦ƛ⟧ (λ c a → val (λ c′ → f (c ○ c′) ∙ reify (↑⟨ c′ ⟩ a)))

  ⟦ν⟧ : ∀ {x Γ A} → Γ ∋ x ∷ A → Γ ⊩ A
  ⟦ν⟧ {x} i = val (λ c → ν x (↑⟨ c ⟩ i))

-- We also have that if two semantic objects in a Kripke model are extensionally equal, then
-- the result of applying the inversion function to them is intensionally equal.  To prove this
-- we first have to show the following two lemmas:

aux₄₄₁ : ∀ {A Γ} →
           (f f′ : ∀ {Δ} → Δ ⊇ Γ → Δ ⊢ A) → (∀ {Δ} → (c : Δ ⊇ Γ) → f c ≡ f′ c) →
           Eq (val f) (val f′)
aux₄₄₁ {•}     f f′ h = eq• (λ c        → h c)
aux₄₄₁ {A ⊃ B} f f′ h = eq⊃ (λ c {a} uₐ → aux₄₄₁ (λ c′ → f (c ○ c′) ∙ reify (↑⟨ c′ ⟩ a))
                            (λ c′       → f′ (c ○ c′) ∙ reify (↑⟨ c′ ⟩ a))
                            (λ c′       → cong (_∙ reify (↑⟨ c′ ⟩ a))
                                             (h (c ○ c′))))

aux₄₄₂⟨_⟩ : ∀ {A Γ Δ} →
              (c : Δ ⊇ Γ) (f : (∀ {Δ} → Δ ⊇ Γ → Δ ⊢ A)) →
              Eq (↑⟨ c ⟩ (val f)) (val (λ c′ → f (c ○ c′)))
aux₄₄₂⟨_⟩ {•}     c f = eq• (λ c′        → cong f refl)
aux₄₄₂⟨_⟩ {A ⊃ B} c f = eq⊃ (λ c′ {a} uₐ → aux₄₄₁ (λ c″ → f ((c ○ c′) ○ c″) ∙ reify (↑⟨ c″ ⟩ a))
                            (λ c″        → f (c ○ (c′ ○ c″)) ∙ reify (↑⟨ c″ ⟩ a))
                            (λ c″        → cong (_∙ reify (↑⟨ c″ ⟩ a))
                                              (cong f
                                                (sym (assoc○ c c′ c″)))))

-- Both lemmas are proved by induction on the type and they are used in order to prove the
-- following theorem,
-- which is shown mutually with a lemma
-- which states that `val` returns a uniform semantic object.  Both the theorem and the lemma
-- are proved by induction on the type.

-- Theorem 1.
mutual
  thm₁ : ∀ {Γ A} {a a′ : Γ ⊩ A} → Eq a a′ → reify a ≡ reify a′
  thm₁ {Γ} (eq• h) = h refl⊇
  thm₁ {Γ} (eq⊃ h) = let x , φ = gensym Γ in
                     let instance _ = φ in
                     cong (ƛ x)
                       (thm₁ (h weak⊇ (⟦ν⟧𝒰 zero)))

  ⟦ν⟧𝒰 : ∀ {x Γ A} → (i : Γ ∋ x ∷ A) → 𝒰 (⟦ν⟧ i)
  ⟦ν⟧𝒰 {x} i = aux₄₄₃ (λ c → ν x (↑⟨ c ⟩ i))

  aux₄₄₃ : ∀ {A Γ} → (f : ∀ {Δ} → Δ ⊇ Γ → Δ ⊢ A) → 𝒰 (val f)
  aux₄₄₃ {•}     f = 𝓊•
  aux₄₄₃ {A ⊃ B} f =
    𝓊⊃ (λ c {a} uₐ              → aux₄₄₃ (λ c′ → f (c ○ c′) ∙ reify (↑⟨ c′ ⟩ a)))
       (λ c {a} {a′} eqₐ uₐ uₐ′ → aux₄₄₁ (λ c′ → f (c ○ c′) ∙ reify (↑⟨ c′ ⟩ a))
                                          (λ c′ → f (c ○ c′) ∙ reify (↑⟨ c′ ⟩ a′))
                                          (λ c′ → cong (f (c ○ c′) ∙_)
                                                     (thm₁ (cong↑⟨ c′ ⟩Eq eqₐ))))
       (λ c c′ c″ {a} uₐ        →
         transEq (aux₄₄₂⟨ c′ ⟩ (λ c‴ → f (c ○ c‴) ∙ reify (↑⟨ c‴ ⟩ a)))
                 (aux₄₄₁ (λ c‴ → f (c ○ (c′ ○ c‴)) ∙ reify (↑⟨ c′ ○ c‴ ⟩ a))
                         (λ c‴ → f (c″ ○ c‴) ∙ reify (↑⟨ c‴ ⟩ (↑⟨ c′ ⟩ a)))
                         (λ c‴ → cong² _∙_
                                    (cong f
                                      (trans (assoc○ c c′ c‴)
                                             (comp○ (c ○ c′) c‴ (c″ ○ c‴))))
                                    (thm₁ (symEq (aux₄₁₂ c′ c‴ (c′ ○ c‴) uₐ))))))

-- We are now ready to define the function that given a proof tree computes its normal form.
-- For this we define the identity environment `proj⟨_⟩⊩⋆` which to each variable
-- in the context `Γ` associates the corresponding value of the variable in `Δ` (`⟦ν⟧` gives the
-- value of this variable).  The normalisation function, `nf`, is defined as the composition of the
-- evaluation function and `reify`.  This function is similar to the normalisation algorithm given
-- by Berger [3]; one difference is our use of Kripke models to deal with reduction under `λ`.
-- One other difference is that, since we use explicit contexts, we can use the context to find
-- the fresh names in the `reify` function.

proj⟨_⟩⊩⋆ : ∀ {Γ Δ} → Δ ⊇ Γ → Δ ⊩⋆ Γ
proj⟨ done ⟩⊩⋆             = []
proj⟨ step {x = x} c i ⟩⊩⋆ = [ proj⟨ c ⟩⊩⋆ , x ≔ ⟦ν⟧ i ]

refl⊩⋆ : ∀ {Γ} → Γ ⊩⋆ Γ
refl⊩⋆ = proj⟨ refl⊇ ⟩⊩⋆

-- The computation of the normal form is done by computing the semantics of the proof
-- tree in the identity environment and then inverting the result:

nf : ∀ {Γ A} → Γ ⊢ A → Γ ⊢ A
nf M = reify (⟦ M ⟧ refl⊩⋆)

-- We know by Theorem 1 that `nf` returns the same result when applied to two proof trees
-- having the same semantics:

-- Corollary 1.
cor₁ : ∀ {Γ A} → (M M′ : Γ ⊢ A) → Eq (⟦ M ⟧ refl⊩⋆) (⟦ M′ ⟧ refl⊩⋆) →
         nf M ≡ nf M′
cor₁ M M′ = thm₁

-- 4.5. Soundness and completeness of proof trees
-- ----------------------------------------------
--
-- We have in fact already shown soundness and completeness of the calculus of proof trees.
--
-- The evaluation function, `⟦_⟧`, for proof trees corresponds via the Curry-Howard isomorphism
-- to a proof of the soundness theorem of minimal logic with respect to Kripke models.
-- The function is defined by pattern matching which corresponds to a proof by case analysis
-- of the proof trees.
--
-- The inversion function `reify` is, again via the Curry-Howard isomorphism, a proof of the
-- completeness theorem of minimal logic with respect to a particular Kripke model where
-- the worlds are contexts.

-- 4.6. Completeness of the conversion rules for proof trees
-- ---------------------------------------------------------
--
-- In order to prove that the set of conversion rules is complete, i.e.,
-- `Eq (⟦ M ⟧ refl⊩⋆) (⟦ M′ ⟧ refl⊩⋆)` implies `M ≅ M′`, we must first prove Theorem 2: `M ≅ nf M`.
--
-- To prove the theorem we define a Kripke logical relation [15, 18]
-- which corresponds to Tait’s computability predicate.
--
-- A proof tree of base type is intuitively `CV`-related to a semantic object of base type if
-- they are convertible with each other.  (…)
--
-- A proof tree of function type, `A ⊃ B`, is intuitively `CV`-related to a semantic object of the
-- same type if they send `CV`-related proof trees and objects of type `A` to `CV`-related proof
-- trees and objects of type `B`.  (…)

data CV : ∀ {Γ A} → Γ ⊢ A → Γ ⊩ A → Set where
  cv• : ∀ {Γ} {M : Γ ⊢ •} {f : Γ ⊩ •} →
          (∀ {Δ} → (c : Δ ⊇ Γ) → M ▶ π⟨ c ⟩ ≅ f ⟦g⟧⟨ c ⟩) →
          CV M f
  cv⊃ : ∀ {Γ A B} {M : Γ ⊢ A ⊃ B} {f : Γ ⊩ A ⊃ B} →
          (∀ {Δ N a} → (c : Δ ⊇ Γ) → CV N a → CV ((M ▶ π⟨ c ⟩) ∙ N) (f ⟦∙⟧⟨ c ⟩ a)) →
          CV M f

-- The idea of this predicate is that we can show that if `CV M a` then `M ≅ reify a`, hence
-- if we show that `CV M (⟦ M ⟧ refl⊩⋆)`, we have a proof of Theorem 2.
--
-- Correspondingly for the environment we define:  (…)

data CV⋆ : ∀ {Γ Δ} → Δ ⋙ Γ → Δ ⊩⋆ Γ → Set where
  cv⋆[] : ∀ {Γ} →
            {γ : Γ ⋙ []} →
            CV⋆ γ []
  cv⋆≔  : ∀ {Γ Δ A x} {{_ : T (fresh x Γ)}}
            {γ : Δ ⋙ [ Γ , x ∷ A ]} {c : [ Γ , x ∷ A ] ⊇ Γ} {ρ : Δ ⊩⋆ Γ} {a : Δ ⊩ A} →
            CV⋆ (π⟨ c ⟩ ● γ) ρ → CV (ν x zero ▶ γ) a →
            CV⋆ γ [ ρ , x ≔ a ]

-- In order to prove Lemma 8 below we need to prove the following properties about `CV`:

cong≅CV : ∀ {Γ A} {M M′ : Γ ⊢ A} {a : Γ ⊩ A} →
            M ≅ M′ → CV M′ a →
            CV M a
cong≅CV p (cv• h) = cv• (λ c     → trans≅ (cong▶≅ p refl≅ₛ)
                                           (h c))
cong≅CV p (cv⊃ h) = cv⊃ (λ c cvₐ → cong≅CV (cong∙≅ (cong▶≅ p refl≅ₛ) refl≅)
                                            (h c cvₐ))

cong≅ₛCV⋆ : ∀ {Γ Δ} {γ γ′ : Δ ⋙ Γ} {ρ : Δ ⊩⋆ Γ} →
              γ ≅ₛ γ′ → CV⋆ γ′ ρ →
              CV⋆ γ ρ
cong≅ₛCV⋆ p cv⋆[]         = cv⋆[]
cong≅ₛCV⋆ p (cv⋆≔ cv⋆ cv) = cv⋆≔ (cong≅ₛCV⋆ (cong●≅ₛ refl≅ₛ p) cv⋆)
                                 (cong≅CV (cong▶≅ refl≅ p) cv)

cong↑⟨_⟩CV : ∀ {Γ Δ A} {M : Γ ⊢ A} {a : Γ ⊩ A} →
               (c : Δ ⊇ Γ) → CV M a →
               CV (M ▶ π⟨ c ⟩) (↑⟨ c ⟩ a)
cong↑⟨ c ⟩CV (cv• h) = cv• (λ c′     → trans≅ (trans≅ (conv₇≅ _ _ _)
                                                       (cong▶≅ refl≅ (conv₄≅ₛ _ _ _)))
                                               (h (c ○ c′)))
cong↑⟨ c ⟩CV (cv⊃ h) = cv⊃ (λ c′ cvₐ → cong≅CV (cong∙≅ (trans≅ (conv₇≅ _ _ _)
                                                                (cong▶≅ refl≅ (conv₄≅ₛ _ _ _)))
                                                        refl≅)
                                                (h (c ○ c′) cvₐ))

conglookupCV : ∀ {Γ Δ A x} {γ : Δ ⋙ Γ} {ρ : Δ ⊩⋆ Γ} →
                 CV⋆ γ ρ → (i : Γ ∋ x ∷ A) →
                 CV (ν x i ▶ γ) (lookup ρ i)
conglookupCV cv⋆[]         ()
conglookupCV (cv⋆≔ cv⋆ cv) zero    = cv
conglookupCV (cv⋆≔ cv⋆ cv) (suc i) = cong≅CV (trans≅ (cong▶≅ (sym≅ (conv₄≅ _ _ _)) refl≅ₛ)
                                                     (conv₇≅ _ _ _))
                                             (conglookupCV cv⋆ i)

cong↑⟨_⟩CV⋆ : ∀ {Γ Δ Θ} {γ : Δ ⋙ Γ} {ρ : Δ ⊩⋆ Γ} →
                (c : Θ ⊇ Δ) → CV⋆ γ ρ →
                CV⋆ (γ ● π⟨ c ⟩) (↑⟨ c ⟩ ρ)
cong↑⟨ c ⟩CV⋆ cv⋆[]         = cv⋆[]
cong↑⟨ c ⟩CV⋆ (cv⋆≔ cv⋆ cv) = cv⋆≔ (cong≅ₛCV⋆ (sym≅ₛ (conv₁≅ₛ _ _ _)) (cong↑⟨ c ⟩CV⋆ cv⋆))
                                   (cong≅CV (sym≅ (conv₇≅ _ _ _)) (cong↑⟨ c ⟩CV cv))

cong↓⟨_⟩CV⋆ : ∀ {Γ Δ Θ} {γ : Δ ⋙ Γ} {ρ : Δ ⊩⋆ Γ} →
                (c : Γ ⊇ Θ) → CV⋆ γ ρ →
                CV⋆ (π⟨ c ⟩ ● γ) (↓⟨ c ⟩ ρ)
cong↓⟨ done ⟩CV⋆     cv⋆ = cv⋆[]
cong↓⟨ step c i ⟩CV⋆ cv⋆ = cv⋆≔ {c = weak⊇}
                                (cong≅ₛCV⋆ (trans≅ₛ (sym≅ₛ (conv₁≅ₛ _ _ _))
                                                    (cong●≅ₛ (conv₄≅ₛ _ _ _) refl≅ₛ))
                                           (cong↓⟨ c ⟩CV⋆ cv⋆))
                                (cong≅CV (trans≅ (sym≅ (conv₇≅ _ _ _))
                                                 (cong▶≅ (conv₄≅ _ _ _) refl≅ₛ))
                                         (conglookupCV cv⋆ i))

-- Now we are ready to prove that if `γ` and `ρ` are `CV`-related, then `M ▶ γ` and `⟦ M ⟧ ρ` are
-- `CV`-related.  This lemma corresponds to Tait’s lemma saying that each term is computable
-- under substitution.  We prove the lemma
-- mutually with a corresponding lemma for substitutions.

-- Lemma 8.
mutual
  CV⟦_⟧ : ∀ {Γ Δ A} {γ : Δ ⋙ Γ} {ρ : Δ ⊩⋆ Γ} →
            (M : Γ ⊢ A) → CV⋆ γ ρ →
            CV (M ▶ γ) (⟦ M ⟧ ρ)
  CV⟦ ν x i ⟧ cv⋆ = conglookupCV cv⋆ i
  CV⟦ ƛ x M ⟧ cv⋆ = cv⊃ (λ c cvₐ → cong≅CV (trans≅ (cong∙≅ (conv₇≅ _ _ _) refl≅)
                                                    (conv₁≅ _ _ _))
                                            (CV⟦ M ⟧ (cv⋆≔ {c = weak⊇}
                                                           (cong≅ₛCV⋆ (conv₃≅ₛ _ _ _)
                                                                      (cong↑⟨ c ⟩CV⋆ cv⋆))
                                                           (cong≅CV (conv₃≅ _ _) cvₐ))))
  CV⟦ M ∙ N ⟧ cv⋆ with CV⟦ M ⟧ cv⋆
  CV⟦ M ∙ N ⟧ cv⋆ | (cv⊃ h) = cong≅CV (trans≅ (conv₆≅ _ _ _)
                                              (cong∙≅ (sym≅ (conv₅≅ _ _)) refl≅))
                                      (h refl⊇ (CV⟦ N ⟧ cv⋆))
  CV⟦ M ▶ γ ⟧ cv⋆ = cong≅CV (conv₇≅ _ _ _)
                            (CV⟦ M ⟧ (CV⋆⟦ γ ⟧ₛ cv⋆))

  CV⋆⟦_⟧ₛ : ∀ {Γ Δ Θ} {δ : Θ ⋙ Δ} {ρ : Θ ⊩⋆ Δ} →
              (γ : Δ ⋙ Γ) → CV⋆ δ ρ →
              CV⋆ (γ ● δ) (⟦ γ ⟧ₛ ρ)
  CV⋆⟦ π⟨ c ⟩ ⟧ₛ        cv⋆ = cong↓⟨ c ⟩CV⋆ cv⋆
  CV⋆⟦ γ ● γ′ ⟧ₛ        cv⋆ = cong≅ₛCV⋆ (conv₁≅ₛ _ _ _)
                                        (CV⋆⟦ γ ⟧ₛ (CV⋆⟦ γ′ ⟧ₛ cv⋆))
  CV⋆⟦ [ γ , x ≔ M ] ⟧ₛ cv⋆ = cv⋆≔ {c = weak⊇}
                                   (cong≅ₛCV⋆ (trans≅ₛ (sym≅ₛ (conv₁≅ₛ _ _ _))
                                                       (cong●≅ₛ (conv₃≅ₛ _ _ _) refl≅ₛ))
                                              (CV⋆⟦ γ ⟧ₛ cv⋆))
                                   (cong≅CV (trans≅ (sym≅ (conv₇≅ _ _ _))
                                                    (cong▶≅ (conv₃≅ _ _) refl≅ₛ))
                                            (CV⟦ M ⟧ cv⋆))

-- Both lemmas are proved by induction on the proof trees using the lemmas above.
--
-- Lemma 9 is shown mutually with a corresponding lemma for `val`:

-- Lemma 9.
mutual
  lem₉ : ∀ {Γ A} {M : Γ ⊢ A} {a : Γ ⊩ A} →
           CV M a →
           M ≅ reify a
  lem₉ (cv• h) = trans≅ (sym≅ (conv₅≅ _ _))
                        (h refl⊇)
  lem₉ (cv⊃ h) = trans≅ (conv₂≅ _ _)
                        (congƛ≅ (lem₉ (h weak⊇ (aux₄₆₈ (λ c → conv₄≅ _ _ _)))))

  aux₄₆₈ : ∀ {A Γ} {M : Γ ⊢ A} {f : ∀ {Δ} → Δ ⊇ Γ → Δ ⊢ A} →
             (∀ {Δ} → (c : Δ ⊇ Γ) → M ▶ π⟨ c ⟩ ≅ f c) →
             CV M (val f)
  aux₄₆₈ {•}                 h = cv• (λ c → h c)
  aux₄₆₈ {A ⊃ B} {M = M} {f} h = cv⊃ (λ {_} {N} {a} c cvₐ →
                                       aux₄₆₈ (λ {Δ′} c′ →
                                         begin
                                           ((M ▶ π⟨ c ⟩) ∙ N) ▶ π⟨ c′ ⟩
                                         ≅⟨ conv₆≅ _ _ _ ⟩
                                           ((M ▶ π⟨ c ⟩) ▶ π⟨ c′ ⟩) ∙ (N ▶ π⟨ c′ ⟩)
                                         ≅⟨ cong∙≅ (conv₇≅ _ _ _) refl≅ ⟩
                                           (M ▶ (π⟨ c ⟩ ● π⟨ c′ ⟩)) ∙ (N ▶ π⟨ c′ ⟩)
                                         ≅⟨ cong∙≅ (cong▶≅ refl≅ (conv₄≅ₛ _ _ _)) refl≅ ⟩
                                           (M ▶ π⟨ c ○ c′ ⟩) ∙ (N ▶ π⟨ c′ ⟩)
                                         ≅⟨ cong∙≅ (h (c ○ c′)) refl≅ ⟩
                                           f (c ○ c′) ∙ (N ▶ π⟨ c′ ⟩)
                                         ≅⟨ cong∙≅ refl≅ (lem₉ (cong↑⟨ c′ ⟩CV cvₐ)) ⟩
                                           f (c ○ c′) ∙ reify (↑⟨ c′ ⟩ a)
                                         ∎))
                                         where
                                           open ≅-Reasoning

-- In order to prove Theorem 2 we also prove that `CV⋆ π⟨ c ⟩ proj⟨ c ⟩⊩⋆`; then by this, Lemma 8
-- and Lemma 9 we get that `M ▶ π⟨ c ⟩ ≅ nf M`, where `c : Γ ⊇ Γ`.  Using the conversion rule
-- `M ≅ M ▶ π⟨ c ⟩` for `c : Γ ⊇ Γ` we get by transitivity of conversion of `_≅_` that `M ≅ nf M`.

proj⟨_⟩CV⋆ : ∀ {Γ Δ} →
               (c : Δ ⊇ Γ) →
               CV⋆ π⟨ c ⟩ proj⟨ c ⟩⊩⋆
proj⟨ done ⟩CV⋆             = cv⋆[]
proj⟨ step {x = x} c i ⟩CV⋆ = cv⋆≔ {c = weak⊇}
                                   (cong≅ₛCV⋆ (conv₄≅ₛ _ _ _) (proj⟨ c ⟩CV⋆))
                                   (aux₄₆₈ (λ c′ →
                                     begin
                                       (ν x zero ▶ π⟨ step c i ⟩) ▶ π⟨ c′ ⟩
                                     ≅⟨ cong▶≅ (conv₄≅ _ _ _) refl≅ₛ ⟩
                                       ν x i ▶ π⟨ c′ ⟩
                                     ≅⟨ conv₄≅ _ _ _ ⟩
                                       ν x (↑⟨ c′ ⟩ i)
                                     ∎))
                                     where
                                       open ≅-Reasoning

reflCV⋆ : ∀ {Γ} → CV⋆ π⟨ refl⊇ ⟩ (refl⊩⋆ {Γ})
reflCV⋆ = proj⟨ refl⊇ ⟩CV⋆

aux₄₆₉⟨_⟩ : ∀ {Γ A} →
              (c : Γ ⊇ Γ) (M : Γ ⊢ A) →
              M ▶ π⟨ c ⟩ ≅ nf M
aux₄₆₉⟨ c ⟩ M rewrite uniq⊇ refl⊇ c
              = lem₉ (CV⟦ M ⟧ proj⟨ c ⟩CV⋆)

-- Theorem 2.
thm₂ : ∀ {Γ A} → (M : Γ ⊢ A) →
         M ≅ nf M
thm₂ M = trans≅ (sym≅ (conv₅≅ _ _))
                (aux₄₆₉⟨ refl⊇ ⟩ M)

-- It is now easy to prove the completeness theorem:

-- Theorem 3.
thm₃ : ∀ {Γ A} → (M M′ : Γ ⊢ A) → Eq (⟦ M ⟧ refl⊩⋆) (⟦ M′ ⟧ refl⊩⋆) →
         M ≅ M′
thm₃ M M′ eq = begin
                 M
               ≅⟨ thm₂ M ⟩
                 nf M
               ≡⟨ cor₁ M M′ eq ⟩
                 nf M′
               ≅⟨ sym≅ (thm₂ M′) ⟩
                 M′
               ∎
               where
                 open ≅-Reasoning

-- 4.7. Completeness of the conversion rules for substitutions
-- -----------------------------------------------------------
--
-- The proof of completeness above does not imply that the set of conversion rules for substitutions
-- is complete.  In order to prove the completeness of conversion rules for the substitutions
-- we define an inversion function for semantic environments:  (…)

reify⋆ : ∀ {Γ Δ} → Δ ⊩⋆ Γ → Δ ⋙ Γ
reify⋆ []            = π⟨ done ⟩
reify⋆ [ ρ , x ≔ a ] = [ reify⋆ ρ , x ≔ reify a ]

-- The normalisation function on substitutions is defined as the inversion of the semantics
-- of the substitution in the identity environment.

nf⋆ : ∀ {Δ Γ} → Δ ⋙ Γ → Δ ⋙ Γ
nf⋆ γ = reify⋆ (⟦ γ ⟧ₛ refl⊩⋆)

-- The completeness result for substitutions follows in the same way as for proof trees, i.e.,
-- we must prove that `γ ≅ₛ nf⋆ γ`.

thm₁ₛ : ∀ {Γ Δ} {ρ ρ′ : Δ ⊩⋆ Γ} → Eq⋆ ρ ρ′ → reify⋆ ρ ≡ reify⋆ ρ′
thm₁ₛ eq⋆[]         = refl
thm₁ₛ (eq⋆≔ eq⋆ eq) = cong² (λ γ M → [ γ , _ ≔ M ]) (thm₁ₛ eq⋆) (thm₁ eq)

cor₁ₛ : ∀ {Γ Δ} → (γ γ′ : Δ ⋙ Γ) → Eq⋆ (⟦ γ ⟧ₛ refl⊩⋆) (⟦ γ′ ⟧ₛ refl⊩⋆) →
          nf⋆ γ ≡ nf⋆ γ′
cor₁ₛ γ γ′ = thm₁ₛ

lem₉ₛ : ∀ {Γ Δ} {γ : Δ ⋙ Γ} {ρ : Δ ⊩⋆ Γ} →
          CV⋆ γ ρ →
          γ ≅ₛ reify⋆ ρ
lem₉ₛ cv⋆[]         = conv₆≅ₛ _ _
lem₉ₛ (cv⋆≔ cv⋆ cv) = trans≅ₛ (conv₇≅ₛ _ _ _)
                              (cong≔≅ₛ (lem₉ₛ cv⋆) (lem₉ cv))

aux₄₆₉ₛ⟨_⟩ : ∀ {Γ Δ} →
               (c : Δ ⊇ Δ) (γ : Δ ⋙ Γ) →
               γ ● π⟨ c ⟩ ≅ₛ nf⋆ γ
aux₄₆₉ₛ⟨ c ⟩ γ rewrite uniq⊇ refl⊇ c
               = lem₉ₛ (CV⋆⟦ γ ⟧ₛ proj⟨ c ⟩CV⋆)

thm₂ₛ : ∀ {Γ Δ} → (γ : Δ ⋙ Γ) →
          γ ≅ₛ nf⋆ γ
thm₂ₛ γ = trans≅ₛ (sym≅ₛ (conv₅≅ₛ _ _))
                  (aux₄₆₉ₛ⟨ refl⊇ ⟩ γ)

thm₃ₛ : ∀ {Γ Δ} → (γ γ′ : Δ ⋙ Γ) → Eq⋆ (⟦ γ ⟧ₛ refl⊩⋆) (⟦ γ′ ⟧ₛ refl⊩⋆) →
          γ ≅ₛ γ′
thm₃ₛ γ γ′ eq⋆ = begin
                   γ
                 ≅ₛ⟨ thm₂ₛ γ ⟩
                   nf⋆ γ
                 ≡⟨ cor₁ₛ γ γ′ eq⋆ ⟩
                   nf⋆ γ′
                 ≅ₛ⟨ sym≅ₛ (thm₂ₛ γ′) ⟩
                   γ′
                 ∎
                 where
                   open ≅ₛ-Reasoning

-- 4.8. Soundness of the conversion rules
-- --------------------------------------
--
-- In order to prove the soundness of the conversion rules we first have to show:

-- NOTE: Added missing uniformity assumptions.
mutual
  𝒰⟦_⟧ : ∀ {A Γ Δ} {ρ : Δ ⊩⋆ Γ} →
           (M : Γ ⊢ A) → 𝒰⋆ ρ →
           𝒰 (⟦ M ⟧ ρ)
  𝒰⟦ ν x i ⟧ u⋆ = conglookup𝒰 u⋆ i
  𝒰⟦ ƛ x M ⟧ u⋆ = 𝓊⊃ (λ c uₐ         → 𝒰⟦ M ⟧ (𝓊⋆≔ (cong↑⟨ c ⟩𝒰⋆ u⋆) uₐ))
                     (λ c eqₐ uₐ uₐ′ → Eq⟦ M ⟧ (eq⋆≔ (cong↑⟨ c ⟩Eq⋆ (reflEq⋆ u⋆)) eqₐ)
                                                (𝓊⋆≔ (cong↑⟨ c ⟩𝒰⋆ u⋆) uₐ)
                                                (𝓊⋆≔ (cong↑⟨ c ⟩𝒰⋆ u⋆) uₐ′))
                     (λ c c′ c″ uₐ   → transEq (↑⟨ c′ ⟩Eq⟦ M ⟧ (𝓊⋆≔ (cong↑⟨ c ⟩𝒰⋆ u⋆) uₐ))
                                                (Eq⟦ M ⟧ (eq⋆≔ (aux₄₂₇ c c′ c″ u⋆)
                                                               (reflEq (cong↑⟨ c′ ⟩𝒰 uₐ)))
                                                         (𝓊⋆≔ (cong↑⟨ c′ ⟩𝒰⋆ (cong↑⟨ c ⟩𝒰⋆ u⋆))
                                                              (cong↑⟨ c′ ⟩𝒰 uₐ))
                                                         (𝓊⋆≔ (cong↑⟨ c″ ⟩𝒰⋆ u⋆)
                                                              (cong↑⟨ c′ ⟩𝒰 uₐ))))
  𝒰⟦ M ∙ N ⟧ u⋆ with 𝒰⟦ M ⟧ u⋆
  𝒰⟦ M ∙ N ⟧ u⋆ | (𝓊⊃ h₀ h₁ h₂) = h₀ refl⊇ (𝒰⟦ N ⟧ u⋆)
  𝒰⟦ M ▶ γ ⟧ u⋆ = 𝒰⟦ M ⟧ (𝒰⋆⟦ γ ⟧ₛ u⋆)

  𝒰⋆⟦_⟧ₛ : ∀ {Γ Δ Θ} {ρ : Θ ⊩⋆ Δ} →
             (γ : Δ ⋙ Γ) → 𝒰⋆ ρ →
             𝒰⋆ (⟦ γ ⟧ₛ ρ)
  𝒰⋆⟦ π⟨ c ⟩ ⟧ₛ        u⋆ = cong↓⟨ c ⟩𝒰⋆ u⋆
  𝒰⋆⟦ γ ● γ′ ⟧ₛ        u⋆ = 𝒰⋆⟦ γ ⟧ₛ (𝒰⋆⟦ γ′ ⟧ₛ u⋆)
  𝒰⋆⟦ [ γ , x ≔ M ] ⟧ₛ u⋆ = 𝓊⋆≔ (𝒰⋆⟦ γ ⟧ₛ u⋆) (𝒰⟦ M ⟧ u⋆)

  Eq⟦_⟧ : ∀ {Γ Δ A} {ρ ρ′ : Δ ⊩⋆ Γ} →
            (M : Γ ⊢ A) → Eq⋆ ρ ρ′ → 𝒰⋆ ρ → 𝒰⋆ ρ′ →
            Eq (⟦ M ⟧ ρ) (⟦ M ⟧ ρ′)
  Eq⟦ ν x i ⟧ eq⋆ u⋆ u⋆′ = conglookupEq eq⋆ i
  Eq⟦ ƛ x M ⟧ eq⋆ u⋆ u⋆′ = eq⊃ (λ c uₐ → Eq⟦ M ⟧ (eq⋆≔ (cong↑⟨ c ⟩Eq⋆ eq⋆) (reflEq uₐ))
                                                  (𝓊⋆≔ (cong↑⟨ c ⟩𝒰⋆ u⋆) uₐ)
                                                  (𝓊⋆≔ (cong↑⟨ c ⟩𝒰⋆ u⋆′) uₐ))
  Eq⟦ M ∙ N ⟧ eq⋆ u⋆ u⋆′ = cong⟦∙⟧⟨ refl⊇ ⟩Eq (Eq⟦ M ⟧ eq⋆ u⋆ u⋆′) (𝒰⟦ M ⟧ u⋆) (𝒰⟦ M ⟧ u⋆′)
                                              (Eq⟦ N ⟧ eq⋆ u⋆ u⋆′) (𝒰⟦ N ⟧ u⋆) (𝒰⟦ N ⟧ u⋆′)
  Eq⟦ M ▶ γ ⟧ eq⋆ u⋆ u⋆′ = Eq⟦ M ⟧ (Eq⋆⟦ γ ⟧ₛ eq⋆ u⋆ u⋆′) (𝒰⋆⟦ γ ⟧ₛ u⋆) (𝒰⋆⟦ γ ⟧ₛ u⋆′)

  Eq⋆⟦_⟧ₛ : ∀ {Γ Δ Θ} {ρ ρ′ : Θ ⊩⋆ Δ} →
              (γ : Δ ⋙ Γ) → Eq⋆ ρ ρ′ → 𝒰⋆ ρ → 𝒰⋆ ρ′ →
              Eq⋆ (⟦ γ ⟧ₛ ρ) (⟦ γ ⟧ₛ ρ′)
  Eq⋆⟦ π⟨ c ⟩ ⟧ₛ        eq⋆ u⋆ u⋆′ = cong↓⟨ c ⟩Eq⋆ eq⋆
  Eq⋆⟦ γ ● γ′ ⟧ₛ        eq⋆ u⋆ u⋆′ = Eq⋆⟦ γ ⟧ₛ (Eq⋆⟦ γ′ ⟧ₛ eq⋆ u⋆ u⋆′) (𝒰⋆⟦ γ′ ⟧ₛ u⋆) (𝒰⋆⟦ γ′ ⟧ₛ u⋆′)
  Eq⋆⟦ [ γ , x ≔ M ] ⟧ₛ eq⋆ u⋆ u⋆′ = eq⋆≔ (Eq⋆⟦ γ ⟧ₛ eq⋆ u⋆ u⋆′)
                                          (Eq⟦ M ⟧ eq⋆ u⋆ u⋆′)

  ↑⟨_⟩Eq⟦_⟧ : ∀ {Γ Δ Θ A} {ρ : Δ ⊩⋆ Γ} →
                (c : Θ ⊇ Δ) (M : Γ ⊢ A) → 𝒰⋆ ρ →
                Eq (↑⟨ c ⟩ (⟦ M ⟧ ρ)) (⟦ M ⟧ (↑⟨ c ⟩ ρ))
  ↑⟨ c ⟩Eq⟦ ν x i ⟧ u⋆ = conglookup↑⟨ c ⟩Eq u⋆ i
  ↑⟨ c ⟩Eq⟦ ƛ x M ⟧ u⋆ = eq⊃ (λ c′ uₐ → Eq⟦ M ⟧ (eq⋆≔ (symEq⋆ (aux₄₂₇ c c′ (c ○ c′) u⋆)) (reflEq uₐ))
                                                 (𝓊⋆≔ (cong↑⟨ c ○ c′ ⟩𝒰⋆ u⋆) uₐ)
                                                 (𝓊⋆≔ (cong↑⟨ c′ ⟩𝒰⋆ (cong↑⟨ c ⟩𝒰⋆ u⋆)) uₐ))
  ↑⟨ c ⟩Eq⟦ M ∙ N ⟧ u⋆ with 𝒰⟦ M ⟧ u⋆
  ↑⟨ c ⟩Eq⟦ M ∙ N ⟧ u⋆ | (𝓊⊃ h₀ h₁ h₂) = transEq (h₂ refl⊇ c c (𝒰⟦ N ⟧ u⋆))
                                                 (transEq (aux₄₁₃ c refl⊇ (𝒰⟦ M ⟧ u⋆) (cong↑⟨ c ⟩𝒰 (𝒰⟦ N ⟧ u⋆)))
                                                          (cong⟦∙⟧⟨ refl⊇ ⟩Eq (↑⟨ c ⟩Eq⟦ M ⟧ u⋆)
                                                                              (cong↑⟨ c ⟩𝒰 (𝒰⟦ M ⟧ u⋆))
                                                                              (𝒰⟦ M ⟧ (cong↑⟨ c ⟩𝒰⋆ u⋆))
                                                                              (↑⟨ c ⟩Eq⟦ N ⟧ u⋆)
                                                                              (cong↑⟨ c ⟩𝒰 (𝒰⟦ N ⟧ u⋆))
                                                                              (𝒰⟦ N ⟧ (cong↑⟨ c ⟩𝒰⋆ u⋆))))
  ↑⟨ c ⟩Eq⟦ M ▶ γ ⟧ u⋆ = transEq (↑⟨ c ⟩Eq⟦ M ⟧ (𝒰⋆⟦ γ ⟧ₛ u⋆))
                                 (Eq⟦ M ⟧ (↑⟨ c ⟩Eq⋆⟦ γ ⟧ₛ u⋆)
                                          (cong↑⟨ c ⟩𝒰⋆ (𝒰⋆⟦ γ ⟧ₛ u⋆))
                                          (𝒰⋆⟦ γ ⟧ₛ (cong↑⟨ c ⟩𝒰⋆ u⋆)))

  ↑⟨_⟩Eq⋆⟦_⟧ₛ : ∀ {Γ Δ Θ Ω} {ρ : Θ ⊩⋆ Δ} →
                  (c : Ω ⊇ Θ) (γ : Δ ⋙ Γ) → 𝒰⋆ ρ →
                  Eq⋆ (↑⟨ c ⟩ (⟦ γ ⟧ₛ ρ)) (⟦ γ ⟧ₛ (↑⟨ c ⟩ ρ))
  ↑⟨ c ⟩Eq⋆⟦ π⟨ c′ ⟩ ⟧ₛ       u⋆ = aux₄₂₈ c′ c u⋆
  ↑⟨ c ⟩Eq⋆⟦ γ ● γ′ ⟧ₛ        u⋆ = transEq⋆ (↑⟨ c ⟩Eq⋆⟦ γ ⟧ₛ (𝒰⋆⟦ γ′ ⟧ₛ u⋆))
                                            (Eq⋆⟦ γ ⟧ₛ (↑⟨ c ⟩Eq⋆⟦ γ′ ⟧ₛ u⋆)
                                                      (cong↑⟨ c ⟩𝒰⋆ (𝒰⋆⟦ γ′ ⟧ₛ u⋆))
                                                      (𝒰⋆⟦ γ′ ⟧ₛ (cong↑⟨ c ⟩𝒰⋆ u⋆)))
  ↑⟨ c ⟩Eq⋆⟦ [ γ , x ≔ M ] ⟧ₛ u⋆ = eq⋆≔ (↑⟨ c ⟩Eq⋆⟦ γ ⟧ₛ u⋆) (↑⟨ c ⟩Eq⟦ M ⟧ u⋆)

-- NOTE: Added missing lemmas.
module _ where
  aux₄₈₁⟨_⟩ : ∀ {Γ Δ A x} {{_ : T (fresh x Γ)}} {ρ : Δ ⊩⋆ Γ} {a : Δ ⊩ A} →
                (c : [ Γ , x ∷ A ] ⊇ Γ) → 𝒰⋆ ρ →
                Eq⋆ (↓⟨ c ⟩ [ ρ , x ≔ a ]) ρ
  aux₄₈₁⟨ c ⟩ u⋆ = transEq⋆ (aux₄₂₃ refl⊇ c u⋆) (aux₄₂₄⟨ refl⊇ ⟩ u⋆)

  aux₄₈₂⟨_⟩ : ∀ {Γ Δ} {ρ : Δ ⊩⋆ Γ} →
                (c : Γ ⊇ []) → 𝒰⋆ ρ →
                ↓⟨ c ⟩ ρ ≡ []
  aux₄₈₂⟨ done ⟩ u⋆ = refl

  aux₄₈₃ : ∀ {Γ Δ} {ρ : Δ ⊩⋆ Γ} →
             (γ : Γ ⋙ []) → 𝒰⋆ ρ →
             Eq⋆ (⟦ γ ⟧ₛ ρ) []
  aux₄₈₃ π⟨ c ⟩   u⋆ rewrite aux₄₈₂⟨ c ⟩ u⋆ = reflEq⋆ 𝓊⋆[]
  aux₄₈₃ (γ ● γ′) u⋆ = aux₄₈₃ γ (𝒰⋆⟦ γ′ ⟧ₛ u⋆)

  aux₄₈₄ : ∀ {Γ Δ A x} {{_ : T (fresh x Γ)}} {ρ : Δ ⊩⋆ Γ} {a : Δ ⊩ A} →
             (i : [ Γ , x ∷ A ] ∋ x ∷ A) → 𝒰 a →
             Eq (lookup [ ρ , x ≔ a ] i) a
  aux₄₈₄ i uₐ rewrite uniq∋ i zero = reflEq uₐ

  conv₆Eq⋆⟨_⟩ : ∀ {Γ Δ} {ρ : Δ ⊩⋆ Γ} →
                  (c : Γ ⊇ []) (γ : Γ ⋙ []) → 𝒰⋆ ρ →
                  Eq⋆ (⟦ γ ⟧ₛ ρ) (↓⟨ c ⟩⊩⋆ ρ)
  conv₆Eq⋆⟨ c ⟩ γ u⋆ rewrite aux₄₈₂⟨ c ⟩ u⋆ = aux₄₈₃ γ u⋆

  conv₇Eq⋆⟨_⟩ : ∀ {Γ Δ Θ A x} {{_ : T (fresh x Γ)}} {ρ : Θ ⊩⋆ Δ} →
                  (c : [ Γ , x ∷ A ] ⊇ Γ) (γ : Δ ⋙ [ Γ , x ∷ A ]) (i : [ Γ , x ∷ A ] ∋ x ∷ A) → 𝒰⋆ ρ →
                  Eq⋆ (⟦ γ ⟧ₛ ρ) [ ↓⟨ c ⟩ (⟦ γ ⟧ₛ ρ) , x ≔ lookup (⟦ γ ⟧ₛ ρ) i ]
  conv₇Eq⋆⟨_⟩ {x = x} {ρ = ρ} c γ i u⋆ with ⟦ γ ⟧ₛ ρ | 𝒰⋆⟦ γ ⟧ₛ u⋆
  conv₇Eq⋆⟨_⟩ {x = x} {ρ = ρ} c γ i u⋆ | [ ρ′ , .x ≔ a ] | 𝓊⋆≔ u⋆′ uₐ =
    begin
      [ ρ′ , x ≔ a ]
    Eq⋆⟨ eq⋆≔ (symEq⋆ (aux₄₈₁⟨ c ⟩ u⋆′)) (symEq (aux₄₈₄ i uₐ)) ⟩
      [ ↓⟨ c ⟩⊩⋆ [ ρ′ , x ≔ a ] , x ≔ lookup [ ρ′ , x ≔ a ] i ]
    ∎⟨ 𝓊⋆≔ (cong↓⟨ c ⟩𝒰⋆ (𝓊⋆≔ u⋆′ uₐ)) (conglookup𝒰 (𝓊⋆≔ u⋆′ uₐ) i) ⟩
   where
     open Eq⋆Reasoning

-- The soundness theorem is shown mutually with a corresponding lemma for substitutions:

-- Theorem 4.
-- NOTE: Added missing uniformity assumptions.
module _ {{_ : Model}} where
  mutual
    Eq⟦_⟧≅ : ∀ {Γ A w} {M M′ : Γ ⊢ A} {ρ : w ⊩⋆ Γ} →
               M ≅ M′ → 𝒰⋆ ρ →
               Eq (⟦ M ⟧ ρ) (⟦ M′ ⟧ ρ)
    Eq⟦ refl≅ {M = M} ⟧≅                     u⋆ = reflEq (𝒰⟦ M ⟧ u⋆)
    Eq⟦ sym≅ p ⟧≅                            u⋆ = symEq (Eq⟦ p ⟧≅ u⋆)
    Eq⟦ trans≅ p p′ ⟧≅                       u⋆ = transEq (Eq⟦ p ⟧≅ u⋆) (Eq⟦ p′ ⟧≅ u⋆)
    Eq⟦ congƛ≅ {M = M} {M′} p ⟧≅             u⋆ = eq⊃ (λ c uₐ → Eq⟦ p ⟧≅ (𝓊⋆≔ (cong↑⟨ c ⟩𝒰⋆ u⋆) uₐ))
    Eq⟦ cong∙≅ {M = M} {M′} {N} {N′} p p′ ⟧≅ u⋆ = cong⟦∙⟧⟨ refl⊇ ⟩Eq (Eq⟦ p ⟧≅ u⋆)
                                                                     (𝒰⟦ M ⟧ u⋆)
                                                                     (𝒰⟦ M′ ⟧ u⋆)
                                                                     (Eq⟦ p′ ⟧≅ u⋆)
                                                                     (𝒰⟦ N ⟧ u⋆)
                                                                     (𝒰⟦ N′ ⟧ u⋆)
    Eq⟦ cong▶≅ {M = M} {M′} {γ} {γ′} p pₛ ⟧≅ u⋆ = transEq (Eq⟦ M ⟧ (Eq⋆⟦ pₛ ⟧≅ₛ u⋆) (𝒰⋆⟦ γ ⟧ₛ u⋆) (𝒰⋆⟦ γ′ ⟧ₛ u⋆))
                                                          (transEq (Eq⟦ p ⟧≅ (𝒰⋆⟦ γ′ ⟧ₛ u⋆))
                                                                   (reflEq (𝒰⟦ M′ ⟧ (𝒰⋆⟦ γ′ ⟧ₛ u⋆))))
    Eq⟦ conv₁≅ M N γ ⟧≅                      u⋆ = Eq⟦ M ⟧ (eq⋆≔ (aux₄₂₅⟨ refl⊇ ⟩ (𝒰⋆⟦ γ ⟧ₛ u⋆))
                                                                (reflEq (𝒰⟦ N ⟧ u⋆)))
                                                          (𝓊⋆≔ (cong↑⟨ refl⊇ ⟩𝒰⋆ (𝒰⋆⟦ γ ⟧ₛ u⋆))
                                                               (𝒰⟦ N ⟧ u⋆))
                                                          (𝓊⋆≔ (𝒰⋆⟦ γ ⟧ₛ u⋆)
                                                               (𝒰⟦ N ⟧ u⋆))
    Eq⟦_⟧≅ {ρ = ρ} (conv₂≅ {x = x} c M) u⋆ =
      eq⊃ (λ c′ {a} uₐ →
        begin
          ⟦ M ⟧ ρ ⟦∙⟧⟨ c′ ⟩ a
        Eq⟨ aux₄₁₃ c′ refl⊇ (𝒰⟦ M ⟧ u⋆) uₐ ⟩
          (↑⟨ c′ ⟩ (⟦ M ⟧ ρ) ⟦∙⟧⟨ refl⊇ ⟩ a)
        Eq⟨ cong⟦∙⟧⟨ refl⊇ ⟩Eq (↑⟨ c′ ⟩Eq⟦ M ⟧ u⋆)
                               (cong↑⟨ c′ ⟩𝒰 (𝒰⟦ M ⟧ u⋆))
                               (𝒰⟦ M ⟧ (cong↑⟨ c′ ⟩𝒰⋆ u⋆))
                               (reflEq uₐ) uₐ uₐ ⟩
          ⟦ M ⟧ (↑⟨ c′ ⟩ ρ) ⟦∙⟧⟨ refl⊇ ⟩ a
        Eq⟨ cong⟦∙⟧⟨ refl⊇ ⟩Eq (Eq⟦ M ⟧ (symEq⋆ (aux₄₈₁⟨ c ⟩ (cong↑⟨ c′ ⟩𝒰⋆ u⋆)))
                                        (cong↑⟨ c′ ⟩𝒰⋆ u⋆)
                                        (cong↓⟨ c ⟩𝒰⋆ (𝓊⋆≔ (cong↑⟨ c′ ⟩𝒰⋆ u⋆) uₐ)))
                               (𝒰⟦ M ⟧ (cong↑⟨ c′ ⟩𝒰⋆ u⋆))
                               (𝒰⟦ M ⟧ (cong↓⟨ c ⟩𝒰⋆ (𝓊⋆≔ (cong↑⟨ c′ ⟩𝒰⋆ u⋆) uₐ)))
                               (reflEq uₐ) uₐ uₐ ⟩
          ⟦ M ⟧ (↓⟨ c ⟩ [ ↑⟨ c′ ⟩ ρ , x ≔ a ]) ⟦∙⟧⟨ refl⊇ ⟩ a
        ∎⟨ case (𝒰⟦ M ⟧ (cong↓⟨ c ⟩𝒰⋆ (𝓊⋆≔ (cong↑⟨ c′ ⟩𝒰⋆ u⋆) uₐ))) of
             (λ { (𝓊⊃ h₀ h₁ h₂) → h₀ refl⊇ uₐ }) ⟩)
        where
          open EqReasoning
    Eq⟦ conv₃≅ M γ ⟧≅                        u⋆ = reflEq (𝒰⟦ M ⟧ u⋆)
    Eq⟦ conv₄≅ c i j ⟧≅                      u⋆ = symEq (aux₄₂₁⟨ c ⟩ u⋆ j i)
    Eq⟦ conv₅≅ c M ⟧≅                        u⋆ = Eq⟦ M ⟧ (aux₄₂₄⟨ c ⟩ u⋆) (cong↓⟨ c ⟩𝒰⋆ u⋆) u⋆
    Eq⟦ conv₆≅ M N γ ⟧≅                      u⋆ = cong⟦∙⟧⟨ refl⊇ ⟩Eq (reflEq (𝒰⟦ M ⟧ (𝒰⋆⟦ γ ⟧ₛ u⋆)))
                                                                     (𝒰⟦ M ⟧ (𝒰⋆⟦ γ ⟧ₛ u⋆))
                                                                     (𝒰⟦ M ⟧ (𝒰⋆⟦ γ ⟧ₛ u⋆))
                                                                     (reflEq (𝒰⟦ N ⟧ (𝒰⋆⟦ γ ⟧ₛ u⋆)))
                                                                     (𝒰⟦ N ⟧ (𝒰⋆⟦ γ ⟧ₛ u⋆))
                                                                     (𝒰⟦ N ⟧ (𝒰⋆⟦ γ ⟧ₛ u⋆))
    Eq⟦ conv₇≅ M γ δ ⟧≅                      u⋆ = reflEq (𝒰⟦ M ⟧ (𝒰⋆⟦ γ ⟧ₛ (𝒰⋆⟦ δ ⟧ₛ u⋆)))

    Eq⋆⟦_⟧≅ₛ : ∀ {Γ Δ w} {γ γ′ : Γ ⋙ Δ} {ρ : w ⊩⋆ Γ} →
                 γ ≅ₛ γ′ → 𝒰⋆ ρ →
                 Eq⋆ (⟦ γ ⟧ₛ ρ) (⟦ γ′ ⟧ₛ ρ)
    Eq⋆⟦ refl≅ₛ {γ = γ} ⟧≅ₛ                    u⋆ = reflEq⋆ (𝒰⋆⟦ γ ⟧ₛ u⋆)
    Eq⋆⟦ sym≅ₛ pₛ ⟧≅ₛ                          u⋆ = symEq⋆ (Eq⋆⟦ pₛ ⟧≅ₛ u⋆)
    Eq⋆⟦ trans≅ₛ pₛ pₛ′ ⟧≅ₛ                    u⋆ = transEq⋆ (Eq⋆⟦ pₛ ⟧≅ₛ u⋆) (Eq⋆⟦ pₛ′ ⟧≅ₛ u⋆)
    Eq⋆⟦ cong●≅ₛ {γ′ = γ′} {δ} {δ′} pₛ pₛ′ ⟧≅ₛ u⋆ = transEq⋆ (Eq⋆⟦ pₛ ⟧≅ₛ (𝒰⋆⟦ δ ⟧ₛ u⋆))
                                                             (Eq⋆⟦ γ′ ⟧ₛ (Eq⋆⟦ pₛ′ ⟧≅ₛ u⋆)
                                                                         (𝒰⋆⟦ δ ⟧ₛ u⋆)
                                                                         (𝒰⋆⟦ δ′ ⟧ₛ u⋆))
    Eq⋆⟦ cong≔≅ₛ pₛ p ⟧≅ₛ                      u⋆ = eq⋆≔ (Eq⋆⟦ pₛ ⟧≅ₛ u⋆) (Eq⟦ p ⟧≅ u⋆)
    Eq⋆⟦ conv₁≅ₛ γ δ θ ⟧≅ₛ                     u⋆ = reflEq⋆ (𝒰⋆⟦ γ ⟧ₛ (𝒰⋆⟦ δ ⟧ₛ (𝒰⋆⟦ θ ⟧ₛ u⋆)))
    Eq⋆⟦ conv₂≅ₛ M γ δ ⟧≅ₛ                     u⋆ = reflEq⋆ (𝓊⋆≔ (𝒰⋆⟦ γ ⟧ₛ (𝒰⋆⟦ δ ⟧ₛ u⋆))
                                                                 (𝒰⟦ M ⟧ (𝒰⋆⟦ δ ⟧ₛ u⋆)))
    Eq⋆⟦ conv₃≅ₛ c M γ ⟧≅ₛ                     u⋆ = transEq⋆ (aux₄₂₃ refl⊇ c (𝒰⋆⟦ γ ⟧ₛ u⋆))
                                                             (aux₄₂₄⟨ refl⊇ ⟩ (𝒰⋆⟦ γ ⟧ₛ u⋆))
    Eq⋆⟦ conv₄≅ₛ c c′ c″ ⟧≅ₛ                   u⋆ = aux₄₂₆ c′ c″ c u⋆
    Eq⋆⟦ conv₅≅ₛ c γ ⟧≅ₛ                       u⋆ = Eq⋆⟦ γ ⟧ₛ (aux₄₂₄⟨ c ⟩ u⋆) (cong↓⟨ c ⟩𝒰⋆ u⋆) u⋆
    Eq⋆⟦ conv₆≅ₛ c γ ⟧≅ₛ                       u⋆ = conv₆Eq⋆⟨ c ⟩ γ u⋆
    Eq⋆⟦ conv₇≅ₛ c γ i ⟧≅ₛ                     u⋆ = conv₇Eq⋆⟨ c ⟩ γ i u⋆

-- They are both shown by induction on the rules of conversion.  Notice that the soundness
-- result holds in any Kripke model.

-- 4.9. Decision algorithm for conversion
-- --------------------------------------
--
-- We now have a decision algorithm for testing convertibility between proof trees: compute
-- the normal form and check if they are exactly the same.  This decision algorithm is correct,
-- since by Theorem 2 we have `M ≅ nf M` and `M′ ≅ nf M′` and, by hypothesis, `nf M ≡ nf M′`,
-- we get by transitivity of `_≅_`, that `M ≅ M′`.

-- Theorem 5.
thm₅ : ∀ {Γ A} → (M M′ : Γ ⊢ A) → nf M ≡ nf M′ → M ≅ M′
thm₅ M M′ p = begin
                M
              ≅⟨ thm₂ M ⟩
                nf M
              ≡⟨ p ⟩
                nf M′
              ≅⟨ sym≅ (thm₂ M′) ⟩
                M′
              ∎
              where
                open ≅-Reasoning

-- The decision algorithm is also complete since by Theorem 4 and the hypothesis, `M ≅ M′`, we get
-- `Eq (⟦ M ⟧ refl⊩⋆) (⟦ N ⟧ refl⊩⋆)` and by Corollary 1 we get `nf M ≡ nf N`.

-- NOTE: Added missing lemmas.
module _ where
  proj⟨_⟩𝒰⋆ : ∀ {Γ Δ} →
                (c : Δ ⊇ Γ) →
                𝒰⋆ proj⟨ c ⟩⊩⋆
  proj⟨ done ⟩𝒰⋆     = 𝓊⋆[]
  proj⟨ step c i ⟩𝒰⋆ = 𝓊⋆≔ proj⟨ c ⟩𝒰⋆ (⟦ν⟧𝒰 i)

  refl𝒰⋆ : ∀ {Γ} → 𝒰⋆ (refl⊩⋆ {Γ})
  refl𝒰⋆ = proj⟨ refl⊇ ⟩𝒰⋆

-- Theorem 6.
thm₆ : ∀ {Γ A} → (M M′ : Γ ⊢ A) → M ≅ M′ → nf M ≡ nf M′
thm₆ M M′ p = cor₁ M M′ (Eq⟦ p ⟧≅ refl𝒰⋆)


{-

The sheaf property of a presheaf on a distributive lattice or a basis thereof
can be expressed as preservation of limits over diagrams defined in this file.

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

module Cubical.Categories.DistLatticeSheaf.Diagram where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.HLevels

open import Cubical.Data.Nat
open import Cubical.Data.Nat.Order
open import Cubical.Data.Empty
open import Cubical.Data.Sigma
open import Cubical.Data.FinData
open import Cubical.Data.FinData.Order
open import Cubical.Data.Sum

open import Cubical.Relation.Nullary
open import Cubical.Relation.Binary.Poset

open import Cubical.Categories.Category
open import Cubical.Categories.Functor
open import Cubical.Categories.Limits.Limits
open import Cubical.Categories.Limits.Pullback
open import Cubical.Categories.Instances.DistLattice

open import Cubical.Algebra.DistLattice
open import Cubical.Algebra.Lattice
open import Cubical.Algebra.Semilattice
open import Cubical.Algebra.DistLattice.BigOps

private
  variable
    ℓ ℓ' ℓ'' : Level

data DLShfDiagOb (n : ℕ) : Type where
  sing : Fin n → DLShfDiagOb n
  pair : (i j : Fin n) → i <'Fin j → DLShfDiagOb n

data DLShfDiagHom (n : ℕ) : DLShfDiagOb n → DLShfDiagOb n → Type where
  idAr : {x : DLShfDiagOb n} → DLShfDiagHom n x x
  singPairL : {i j : Fin n} {i<j : i <'Fin j}  → DLShfDiagHom n (sing i) (pair i j i<j)
  singPairR : {i j : Fin n} {i<j : i <'Fin j}→ DLShfDiagHom n (sing j) (pair i j i<j)

module DLShfDiagHomPath where
  variable
   n : ℕ

  -- DLShfDiagHom n x y is a retract of Code x y
  Code : (x y : DLShfDiagOb n) → Type
  Code (sing i) (sing j) = i ≡ j
  Code (sing i) (pair j k j<k) =
      (Σ[ p ∈ (i ≡ j) ] Σ[ i<k ∈ i <'Fin k ] PathP (λ ι → p ι <'Fin k) i<k j<k)
    ⊎ (Σ[ p ∈ (i ≡ k) ] Σ[ j<i ∈ j <'Fin i ] PathP (λ ι → j <'Fin p ι) j<i j<k)
  Code (pair i j i<j) (sing k) = ⊥
  Code (pair i j i<j) (pair k l k<l) =
    Σ[ p ∈ (i ≡ k) × (j ≡ l) ] PathP (λ ι → fst p ι <'Fin snd p ι) i<j k<l

  isSetCode : ∀ (x y : DLShfDiagOb n) → isSet (Code x y)
  isSetCode (sing _) (sing _) = isProp→isSet (isSetFin _ _)
  isSetCode (sing i) (pair j k j<k) =
    isSet⊎
      (isSetΣ (isProp→isSet (isSetFin _ _))
        λ _ → isSetΣ (isProp→isSet (≤'FinIsPropValued _ _))
        λ _ → isOfHLevelPathP 2 (isProp→isSet (≤'FinIsPropValued _ _)) _ _)
      (isSetΣ (isProp→isSet (isSetFin _ _))
        λ _ → isSetΣ (isProp→isSet (≤'FinIsPropValued _ _))
        λ _ → isOfHLevelPathP 2 (isProp→isSet (≤'FinIsPropValued _ _)) _ _)
  isSetCode (pair _ _ _) (sing _) = isProp→isSet isProp⊥
  isSetCode (pair _ _ _) (pair _ _ _) =
    isSetΣ
      (isSet× (isProp→isSet (isSetFin _ _)) (isProp→isSet (isSetFin _ _)))
        λ _ → isOfHLevelPathP 2 (isProp→isSet (≤'FinIsPropValued _ _)) _ _

  encode : (x y : DLShfDiagOb n) → DLShfDiagHom n x y → Code x y
  encode (sing i) (sing .i) idAr = refl
  encode (sing i) (pair .i j i<j) singPairL = inl (refl , i<j , refl)
  encode (sing j) (pair i .j i<j) singPairR = inr (refl , i<j , refl)
  encode (pair i j i<j) (pair .i .j .i<j) idAr = (refl , refl) , refl

  decode : (x y : DLShfDiagOb n) → Code x y → DLShfDiagHom n x y
  decode (sing i) (sing j) p = subst (λ k → DLShfDiagHom _ (sing i) (sing k)) p idAr
  decode (sing i) (pair j k j<k) (inl (p , i<k , q)) =
    transport (λ ι → DLShfDiagHom _ (sing i) (pair (p ι) k (q ι))) singPairL
  decode (sing i) (pair k j k<j) (inr (p , k<i , q)) =
    transport (λ ι → DLShfDiagHom _ (sing i) (pair k (p ι) (q ι))) singPairR
  decode (pair i j i<j) (pair k l k<l) (_ , p) =
    transport (λ ι → DLShfDiagHom _ (pair _ _ i<j) (pair _ _ (p ι))) idAr

  codeRetract : ∀ (x y : DLShfDiagOb n) (f : DLShfDiagHom n x y)
              → decode x y (encode x y f) ≡ f
  codeRetract (sing i) (sing .i) idAr = transportRefl idAr
  codeRetract (sing i) (pair .i k i<k) singPairL = transportRefl singPairL
  codeRetract (sing i) (pair j .i j<i) singPairR = transportRefl singPairR
  codeRetract (pair i j i<j) (pair .i .j .i<j) idAr = transportRefl idAr

  isSetDLShfDiagHom : ∀ (x y : DLShfDiagOb n) → isSet (DLShfDiagHom n x y)
  isSetDLShfDiagHom x y = isSetRetract (encode x y) (decode x y)
                                         (codeRetract x y) (isSetCode x y)

open Category
DLShfDiag : ℕ → Category ℓ-zero ℓ-zero
ob (DLShfDiag n) = DLShfDiagOb n
Hom[_,_] (DLShfDiag n) = DLShfDiagHom n
id (DLShfDiag n) = idAr
_⋆_ (DLShfDiag n) idAr f = f
_⋆_ (DLShfDiag n) singPairL idAr = singPairL
_⋆_ (DLShfDiag n) singPairR idAr = singPairR
⋆IdL (DLShfDiag n) _ = refl
⋆IdR (DLShfDiag n) idAr = refl
⋆IdR (DLShfDiag n) singPairL = refl
⋆IdR (DLShfDiag n) singPairR = refl
⋆Assoc (DLShfDiag n) idAr _ _ = refl
⋆Assoc (DLShfDiag n) singPairL idAr _ = refl
⋆Assoc (DLShfDiag n) singPairR idAr _ = refl
isSetHom (DLShfDiag n) = let open DLShfDiagHomPath in (isSetDLShfDiagHom _ _)

module _ (L' : DistLattice ℓ) where
 private
  L = fst L'
  LCat = (DistLatticeCategory L') ^op
  instance
   _ = snd L'

 open DistLatticeStr ⦃...⦄
 open Join L'
 open JoinSemilattice (Lattice→JoinSemilattice (DistLattice→Lattice L'))
 open PosetStr (IndPoset .snd) hiding (_≤_)
 open MeetSemilattice (Lattice→MeetSemilattice (DistLattice→Lattice L'))
      using (∧≤RCancel ; ∧≤LCancel)
 open Order (DistLattice→Lattice L')

 open Category LCat
 open Functor
 open Cone

 FinVec→Diag : {n : ℕ} → FinVec L n → Functor (DLShfDiag n) LCat
 F-ob (FinVec→Diag α) (sing i) = α i
 F-ob (FinVec→Diag α) (pair i j _) = α i ∧l α j
 F-hom (FinVec→Diag α) idAr = is-refl _
 F-hom (FinVec→Diag α) singPairL = ≤m→≤j _ _ (∧≤RCancel _ _)
 F-hom (FinVec→Diag α) singPairR = ≤m→≤j _ _ (∧≤LCancel _ _)
 F-id (FinVec→Diag α) = is-prop-valued _ _ _ _
 F-seq (FinVec→Diag α) _ _ = is-prop-valued _ _ _ _

 ⋁Cone : {n : ℕ} (α : FinVec L n) → Cone (FinVec→Diag α) (⋁ α)
 coneOut (⋁Cone α) (sing i) = ind≤⋁ α i
 coneOut (⋁Cone α) (pair i _ _) = is-trans _ (α i) _ (≤m→≤j _ _ (∧≤RCancel _ _)) (ind≤⋁ α i)
 coneOutCommutes (⋁Cone α) _ = is-prop-valued _ _ _ _

 isLimCone⋁Cone : {n : ℕ} (α : FinVec L n) → isLimCone (FinVec→Diag α) (⋁ α) (⋁Cone α)
 fst (fst (isLimCone⋁Cone α u uCone)) = ⋁IsMax α _ λ i → uCone .coneOut (sing i)
 snd (fst (isLimCone⋁Cone α u uCone)) _ = is-prop-valued _ _ _ _
 snd (isLimCone⋁Cone α _ uCone) _ = Σ≡Prop (λ _ → isPropIsConeMor uCone (⋁Cone α) _)
                                           (is-prop-valued _ _ _ _)

module PullbacksAsDLShfDiags (C : Category ℓ ℓ')
                             (cspan : Cospan C)
                             (pback : Pullback C cspan) where

 open Functor
 open Cone
 open Cospan ⦃...⦄
 open Pullback ⦃...⦄
 instance
  _ = cspan
  _ = pback

 cospanAsDiag : Functor (DLShfDiag 2) C
 F-ob cospanAsDiag (sing zero) = l
 F-ob cospanAsDiag (sing (suc zero)) = r
 F-ob cospanAsDiag (pair _ _ _) = m
 F-hom cospanAsDiag idAr = id C
 F-hom cospanAsDiag {x = sing zero} singPairL = s₁
 F-hom cospanAsDiag {x = sing (suc zero)} singPairL = s₂
 F-hom cospanAsDiag {x = sing zero} singPairR = s₁
 F-hom cospanAsDiag {x = sing (suc zero)} singPairR = s₂
 F-id cospanAsDiag = refl
 F-seq cospanAsDiag idAr idAr = sym (⋆IdL C _)
 F-seq cospanAsDiag idAr singPairL = sym (⋆IdL C _)
 F-seq cospanAsDiag idAr singPairR = sym (⋆IdL C _)
 F-seq cospanAsDiag singPairL idAr = sym (⋆IdR C _)
 F-seq cospanAsDiag singPairR idAr = sym (⋆IdR C _)

 pbPrAsCone : Cone cospanAsDiag pbOb
 coneOut pbPrAsCone (sing zero) = pbPr₁
 coneOut pbPrAsCone (sing (suc zero)) = pbPr₂
 coneOut pbPrAsCone (pair _ _ _) = pbPr₁ ⋆⟨ C ⟩ s₁
 coneOutCommutes pbPrAsCone idAr = ⋆IdR C _
 coneOutCommutes pbPrAsCone (singPairL {zero}) = refl
 coneOutCommutes pbPrAsCone (singPairL {suc zero}) = sym pbCommutes
 coneOutCommutes pbPrAsCone (singPairR {zero} {zero}) = refl
 coneOutCommutes pbPrAsCone (singPairR {zero} {suc zero}) = sym pbCommutes
 coneOutCommutes pbPrAsCone (singPairR {suc zero} {zero}) = refl
 coneOutCommutes pbPrAsCone (singPairR {suc zero} {suc zero}) = sym pbCommutes

 pbAsLimit : isLimCone cospanAsDiag pbOb pbPrAsCone
 pbAsLimit c cc = uniqueExists (fromPBUnivProp .fst .fst)
                               toConeMor
                               (λ _ → isPropIsConeMor cc pbPrAsCone _)
                               (λ f cf → cong fst (fromPBUnivProp .snd (f , fromConeMor cf)))
  where
  fromPBUnivProp : ∃![ hk ∈ C [ c , Pullback.pbOb pback ] ]
                      (coneOut cc (sing zero) ≡ hk ⋆⟨ C ⟩ pbPr₁) ×
                      (coneOut cc (sing (suc zero)) ≡ hk ⋆⟨ C ⟩ pbPr₂)
  fromPBUnivProp = univProp
     (cc .coneOut (sing zero)) (cc .coneOut (sing (suc zero)))
     (cc .coneOutCommutes (singPairL {i<j = s≤s z≤}) ∙ sym (cc .coneOutCommutes singPairR))

  toConeMor : isConeMor cc pbPrAsCone (fromPBUnivProp .fst .fst)
  toConeMor (sing zero) = sym (fromPBUnivProp .fst .snd .fst)
  toConeMor (sing (suc zero)) = sym (fromPBUnivProp .fst .snd .snd)
  toConeMor (pair zero j _) = path
   where
   path : fromPBUnivProp .fst .fst ⋆⟨ C ⟩ (pbPr₁ ⋆⟨ C ⟩ s₁) ≡ cc .coneOut (pair zero j _)
   path = fromPBUnivProp .fst .fst ⋆⟨ C ⟩ (pbPr₁ ⋆⟨ C ⟩ s₁)
        ≡⟨ sym (⋆Assoc C _ _ _) ⟩
          (fromPBUnivProp .fst .fst ⋆⟨ C ⟩ pbPr₁) ⋆⟨ C ⟩ s₁
        ≡⟨ cong (λ f → f ⋆⟨ C ⟩ s₁) (sym (fromPBUnivProp .fst .snd .fst)) ⟩
          cc .coneOut (sing zero) ⋆⟨ C ⟩ s₁
        ≡⟨ cc .coneOutCommutes singPairL ⟩
          cc .coneOut (pair zero j _) ∎
  toConeMor (pair (suc zero) j _) = path
   where
   path : fromPBUnivProp .fst .fst ⋆⟨ C ⟩ (pbPr₁ ⋆⟨ C ⟩ s₁)
        ≡ cc .coneOut (pair (suc zero) j _)
   path = fromPBUnivProp .fst .fst ⋆⟨ C ⟩ (pbPr₁ ⋆⟨ C ⟩ s₁)
        ≡⟨ cong (λ f → fromPBUnivProp .fst .fst ⋆⟨ C ⟩ f) pbCommutes ⟩
          fromPBUnivProp .fst .fst ⋆⟨ C ⟩ (pbPr₂ ⋆⟨ C ⟩ s₂)
        ≡⟨ sym (⋆Assoc C _ _ _) ⟩
          (fromPBUnivProp .fst .fst ⋆⟨ C ⟩ pbPr₂) ⋆⟨ C ⟩ s₂
        ≡⟨ cong (λ f → f ⋆⟨ C ⟩ s₂) (sym (fromPBUnivProp .fst .snd .snd)) ⟩
          cc .coneOut (sing (suc zero)) ⋆⟨ C ⟩ s₂
        ≡⟨ cc .coneOutCommutes singPairL ⟩
          cc .coneOut (pair (suc zero) j _) ∎

  fromConeMor : {f : C [ c , pbOb ]}
              → isConeMor cc pbPrAsCone f
              → (coneOut cc (sing zero) ≡ f ⋆⟨ C ⟩ pbPr₁) ×
                (coneOut cc (sing (suc zero)) ≡ f ⋆⟨ C ⟩ pbPr₂)
  fst (fromConeMor cf) = sym (cf (sing zero))
  snd (fromConeMor cf) = sym (cf (sing (suc zero)))

module DLShfDiagsAsPullbacks (C : Category ℓ ℓ')
                             (F : Functor (DLShfDiag 2) C)
                             (limF : LimCone F) where

 open Cospan
 open Pullback
 open Functor ⦃...⦄
 open Cone ⦃...⦄
 open LimCone ⦃...⦄
 instance
  _ = F
  _ = limF
  _ = limF .limCone

 DiagAsCospan : Cospan C
 l DiagAsCospan = F-ob (sing zero)
 m DiagAsCospan = F-ob (pair zero (suc zero) (s≤s z≤))
 r DiagAsCospan = F-ob (sing (suc zero))
 s₁ DiagAsCospan = F-hom singPairL
 s₂ DiagAsCospan = F-hom singPairR

 LimAsPullback : Pullback C DiagAsCospan
 pbOb LimAsPullback = lim
 pbPr₁ LimAsPullback = coneOut (sing zero)
 pbPr₂ LimAsPullback = coneOut (sing (suc zero))
 pbCommutes LimAsPullback = coneOutCommutes singPairL ∙ sym (coneOutCommutes singPairR)
 univProp LimAsPullback {d = d} f g cSq =
  uniqueExists
    (fromUnivProp .fst .fst)
      (sym (fromUnivProp .fst .snd (sing zero)) , sym (fromUnivProp .fst .snd (sing (suc zero))))
        (λ _ → isProp× (isSetHom C _ _) (isSetHom C _ _))
          λ h' trs → cong fst (fromUnivProp .snd (h' , toConeMor h' trs))
  where
  theCone : Cone F d
  Cone.coneOut theCone (sing zero) = f
  Cone.coneOut theCone (sing (suc zero)) = g
  Cone.coneOut theCone (pair zero zero ())
  Cone.coneOut theCone (pair zero (suc zero) (s≤s z≤)) = f ⋆⟨ C ⟩ DiagAsCospan .s₁
  Cone.coneOut theCone (pair (suc zero) zero ())
  Cone.coneOut theCone (pair (suc zero) (suc zero) (s≤s ()))
  Cone.coneOutCommutes theCone {u} idAr = cong (seq' C (Cone.coneOut theCone u)) F-id
                                        ∙ ⋆IdR C (Cone.coneOut theCone u)
  Cone.coneOutCommutes theCone {sing zero} {pair ._ (suc zero) (s≤s z≤)} singPairL = refl
  Cone.coneOutCommutes theCone {sing (suc zero)} {pair ._ (suc zero) (s≤s ())} singPairL
  Cone.coneOutCommutes theCone {sing (suc zero)} {pair zero ._ (s≤s z≤)} singPairR = sym cSq
  Cone.coneOutCommutes theCone {sing (suc zero)} {pair (suc zero) ._ (s≤s ())} singPairR

  fromUnivProp : ∃![ h ∈ C [ d , lim ] ] isConeMor theCone limCone h
  fromUnivProp = LimCone.univProp limF d theCone

  toConeMor : ∀ (h' : C [ d , lim ])
            → (f ≡ h' ⋆⟨ C ⟩ coneOut (sing zero)) × (g ≡ h' ⋆⟨ C ⟩ coneOut (sing (suc zero)))
            → isConeMor theCone limCone h'
  toConeMor h' (tr₁ , tr₂) (sing zero) = sym tr₁
  toConeMor h' (tr₁ , tr₂) (sing (suc zero)) = sym tr₂
  toConeMor h' (tr₁ , tr₂) (pair zero (suc zero) (s≤s z≤)) = path
    where
    path : h' ⋆⟨ C ⟩ coneOut (pair zero (suc zero) (s≤s z≤))
         ≡ f ⋆⟨ C ⟩ F-hom singPairL
    path = h' ⋆⟨ C ⟩ coneOut (pair zero (suc zero) (s≤s z≤))
         ≡⟨ cong (seq' C h') (sym (coneOutCommutes singPairL)) ⟩
           h' ⋆⟨ C ⟩ (coneOut (sing zero) ⋆⟨ C ⟩ F-hom singPairL)
         ≡⟨ sym (⋆Assoc C _ _ _) ⟩
           (h' ⋆⟨ C ⟩ coneOut (sing zero)) ⋆⟨ C ⟩ F-hom singPairL
         ≡⟨ cong (λ x → seq' C x (F-hom singPairL)) (sym tr₁) ⟩
           f ⋆⟨ C ⟩ F-hom singPairL ∎
  toConeMor h' (tr₁ , tr₂) (pair (suc zero) (suc zero) (s≤s ()))


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

open import Categories.Bicategory

-- The two Hom 2-functors from (op C) and C to Cats.

module Categories.Pseudofunctor.Hom {o ℓ e t} (C : Bicategory o ℓ e t) where

open import Data.Product using (_,_)

import Categories.Bicategory.Extras as BicategoryExtras
open import Categories.Bicategory.Opposite using (op)
open import Categories.Bicategory.Instance.Cats using (Cats)
import Categories.Category.Construction.Core as Core
open import Categories.Functor.Bifunctor.Properties
open import Categories.Pseudofunctor using (Pseudofunctor)
import Categories.Morphism.Reasoning as MorphismReasoning
import Categories.Morphism as Morphism
open import Categories.NaturalTransformation using (ntHelper)
open import Categories.NaturalTransformation.NaturalIsomorphism
  using (niHelper)

open BicategoryExtras C
open Shorthands
open hom.HomReasoning
private
  module MR {A} {B} where
    open Core.Shorthands (hom A B) public
    open MorphismReasoning (hom A B) public
  open MR

-- The left and right hom-pseudofunctors for a given bicategory.
--
-- Note that these are *not* simply partial applications of a single
-- *binary* hom-pseudofunctor because pre-/post-composition with
-- identity 1-cells in bicategories is only weakly unitary, i.e. the
-- partial applications Hom[ id , f ] and Hom[ g , id ] would send a
-- 1-cell h to (id ∘ h ∘ f) and (g ∘ h ∘ id) which are isomorphic but
-- not strictly equal to (h ∘ f) and (g ∘ h).

-- The right hom-pseudofunctor (post-composition)

Hom[_,-] : Obj → Pseudofunctor C (Cats o ℓ e)
Hom[ A ,-] = record
  { P₀ = hom A
  ; P₁ = [-]⊚-
  -- A curried version of the left unitor
  ; P-identity  = niHelper (record
    { η         = λ _ → ntHelper (record
      { η       = λ f → unitˡ.⇐.η (_ , f)
      ; commute = λ _ → ⟺ ▷-∘ᵥ-λ⇐
      })
    ; η⁻¹       = λ _ → ntHelper (record
      { η       = λ f → unitˡ.⇒.η (_ , f)
      ; commute = λ _ → λ⇒-∘ᵥ-▷
      })
    ; commute = λ _ → unitˡ.⇐.commute (_ , hom.id)
    ; iso     = λ _ → record
      { isoˡ  = λ {f} → unitˡ.iso.isoʳ (_ , f)
      ; isoʳ  = λ {f} → unitˡ.iso.isoˡ (_ , f)
      }
    })
  -- A curried version of the associator
  ; P-homomorphism = niHelper (record
    { η         = λ{ (f , g) → ntHelper (record
      { η       = λ h → ⊚-assoc.⇐.η ((f , g) , h)
      ; commute = λ _ → α⇐-▷-∘₁
      }) }
    ; η⁻¹       = λ{ (f , g) → ntHelper (record
      { η       = λ h → ⊚-assoc.⇒.η ((f , g) , h)
      ; commute = λ _ → α⇒-▷-∘₁
      }) }
    ; commute = λ{ {f₁ , g₁} {f₂ , g₂} (β , γ) {h} → begin
          α⇐ ∘ᵥ f₂ ▷ (γ ◁ h) ∘ᵥ β ◁ (g₁ ⊚₀ h)
        ≈˘⟨ refl⟩∘⟨ [ ⊚ ]-decompose₂ ⟩
          α⇐ ∘ᵥ β ⊚₁ (γ ◁ h)
        ≈⟨ ⊚-assoc.⇐.commute ((β , γ) , id₂) ⟩
          (β ⊚₁ γ) ◁ h ∘ᵥ α⇐
        ∎ }
    ; iso    = λ{ (f , g) → record
      { isoˡ = λ {h} → ⊚-assoc.iso.isoʳ ((f , g) , h)
      ; isoʳ = λ {h} → ⊚-assoc.iso.isoˡ ((f , g) , h) }
      }
    })
  ; unitaryˡ = λ {_ _ f g} → begin
      λ⇒ ◁ g ∘ᵥ α⇐ ∘ᵥ (id₂ ◁ (f ⊚₀ g)) ∘ᵥ λ⇐
                                 ≈⟨ refl⟩∘⟨ refl⟩∘⟨ ⊚.identity ⟩∘⟨refl ⟩
      λ⇒ ◁ g ∘ᵥ α⇐ ∘ᵥ id₂ ∘ᵥ λ⇐  ≈⟨ unitorˡ-coherence ⟩∘⟨ refl⟩∘⟨ hom.identityˡ ⟩
      (λ⇒ ∘ᵥ α⇒) ∘ᵥ α⇐ ∘ᵥ λ⇐     ≈⟨ isoʳ (unitorˡ ∘ᵢ associator) ⟩
      id₂                        ∎
  ; unitaryʳ = λ {_ _ f g} → begin
        ρ⇒ ◁ g ∘ᵥ α⇐ ∘ᵥ f ▷ λ⇐ ∘ᵥ id₂
      ≈⟨ pushʳ (refl⟩∘⟨ hom.identityʳ) ⟩
        (ρ⇒ ◁ g ∘ᵥ α⇐) ∘ᵥ f ▷ λ⇐
      ≈˘⟨ switch-tofromʳ (associator ⁻¹) triangle ⟩∘⟨refl ⟩
        f ▷ λ⇒ ∘ᵥ f ▷ λ⇐
      ≈⟨ isoʳ (f ▷ᵢ unitorˡ) ⟩
        id₂
      ∎
  ; assoc = λ {_ _ _ _ f g h e} → begin
        α⇒ ◁ e ∘ᵥ α⇐ ∘ᵥ (id₂ ⊚₁ id₂) ∘ᵥ α⇐
      ≈⟨ refl⟩∘⟨ refl⟩∘⟨ ⊚.identity ⟩∘⟨refl ⟩
        α⇒ ◁ e ∘ᵥ α⇐ ∘ᵥ id₂ ∘ᵥ α⇐
      ≈⟨ refl⟩∘⟨ refl⟩∘⟨ hom.identityˡ ⟩
        α⇒ ◁ e ∘ᵥ α⇐ ∘ᵥ α⇐
      ≈˘⟨ switch-fromtoˡ ((associator ◁ᵢ e) ⁻¹)
                         (hom.sym-assoc ○ pentagon-inv) ⟩
        α⇐ ∘ᵥ h ▷ α⇐
      ≈˘⟨ pushʳ hom.identityʳ ○ hom.identityʳ  ⟩
        α⇐ ∘ᵥ (h ▷ α⇐ ∘ᵥ id₂) ∘ᵥ id₂
      ∎
  }

-- The left hom-pseudofunctor (pre-composition)

Hom[-,_] : Obj → Pseudofunctor (op C) (Cats o ℓ e)
Hom[-, B ] = record
  { P₀ = λ A → hom A B
  ; P₁ = -⊚[-]
  -- A curried version of the right unitor
  ; P-identity  = niHelper (record
    { η         = λ _ → ntHelper (record
      { η       = λ f → unitʳ.⇐.η (f , _)
      ; commute = λ _ → ⟺ ◁-∘ᵥ-ρ⇐
      })
    ; η⁻¹       = λ _ → ntHelper (record
      { η       = λ f → unitʳ.⇒.η (f , _)
      ; commute = λ _ → ρ⇒-∘ᵥ-◁
      })
    ; commute = λ _ → unitʳ.⇐.commute (hom.id , _)
    ; iso     = λ _ → record
      { isoˡ  = λ {f} → unitʳ.iso.isoʳ (f , _)
      ; isoʳ  = λ {f} → unitʳ.iso.isoˡ (f , _)
      }
    })
  -- A curried version of the associator
  ; P-homomorphism = niHelper (record
    { η         = λ{ (f , g) → ntHelper (record
      { η       = λ h → ⊚-assoc.⇒.η ((h , g) , f)
      ; commute = λ _ → α⇒-◁-∘₁
      }) }
    ; η⁻¹       = λ{ (f , g) → ntHelper (record
      { η       = λ h → ⊚-assoc.⇐.η ((h , g) , f)
      ; commute = λ _ → α⇐-◁-∘₁
      }) }
    ; commute = λ{ {f₁ , g₁} {f₂ , g₂} (β , γ) {h} → begin
          α⇒ ∘ᵥ (h ▷ γ) ◁ f₂ ∘ᵥ (h ⊚₀ g₁) ▷ β
        ≈˘⟨ refl⟩∘⟨ [ ⊚ ]-decompose₁ ⟩
          α⇒ ∘ᵥ (h ▷ γ) ⊚₁ β
        ≈⟨ ⊚-assoc.⇒.commute ((id₂ , γ) , β) ⟩
          h ▷ (γ ⊚₁ β) ∘ᵥ α⇒
        ∎ }
    ; iso    = λ{ (f , g) → record
      { isoˡ = λ {h} → ⊚-assoc.iso.isoˡ ((h , g) , f)
      ; isoʳ = λ {h} → ⊚-assoc.iso.isoʳ ((h , g) , f) }
      }
    })
  ; unitaryˡ = λ {_ _ f g} → begin
      g ▷ ρ⇒ ∘ᵥ α⇒ ∘ᵥ ((g ⊚₀ f) ▷ id₂) ∘ᵥ ρ⇐
                                   ≈⟨ pushʳ (refl⟩∘⟨ ⊚.identity ⟩∘⟨refl) ⟩
      (g ▷ ρ⇒ ∘ᵥ α⇒) ∘ᵥ id₂ ∘ᵥ ρ⇐  ≈⟨ ⟺ unitorʳ-coherence ⟩∘⟨ hom.identityˡ ⟩
      ρ⇒ ∘ᵥ ρ⇐                     ≈⟨ isoʳ unitorʳ ⟩
      id₂                          ∎
  ; unitaryʳ = λ {_ _ f g} → begin
        g ▷ λ⇒ ∘ᵥ α⇒ ∘ᵥ ρ⇐ ◁ f ∘ᵥ id₂
      ≈⟨ pushʳ (refl⟩∘⟨ hom.identityʳ) ⟩
        (g ▷ λ⇒ ∘ᵥ α⇒) ∘ᵥ ρ⇐ ◁ f
      ≈⟨ triangle ⟩∘⟨refl ⟩
        ρ⇒ ◁ f ∘ᵥ ρ⇐ ◁ f
      ≈⟨ isoʳ (unitorʳ ◁ᵢ f) ⟩
        id₂
      ∎
  ; assoc = λ {_ _ _ _ f g h e} → begin
        e ▷ α⇐ ∘ᵥ α⇒ ∘ᵥ (id₂ ⊚₁ id₂) ∘ᵥ α⇒
      ≈⟨ refl⟩∘⟨ refl⟩∘⟨ ⊚.identity ⟩∘⟨refl ⟩
        e ▷ α⇐ ∘ᵥ α⇒ ∘ᵥ id₂ ∘ᵥ α⇒
      ≈⟨ refl⟩∘⟨ refl⟩∘⟨ hom.identityˡ ⟩
        e ▷ α⇐ ∘ᵥ α⇒ ∘ᵥ α⇒
      ≈˘⟨ switch-fromtoˡ (e ▷ᵢ associator) pentagon ⟩
        α⇒ ∘ᵥ α⇒ ◁ h
      ≈˘⟨ pushʳ hom.identityʳ ○ hom.identityʳ  ⟩
        α⇒ ∘ᵥ (α⇒ ◁ h ∘ᵥ id₂) ∘ᵥ id₂
      ∎
  }


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.Group.Properties where

open import Cubical.Core.Everything
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function using (id; flip)
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.HLevels
open import Cubical.Functions.Embedding

open import Cubical.Data.Nat hiding (_+_; _*_)
open import Cubical.Data.NatPlusOne using (ℕ₊₁→ℕ)
open import Cubical.Data.Int
open import Cubical.Data.Sigma hiding (_×_)
open import Cubical.Data.Prod

open import Cubical.Algebra
open import Cubical.Algebra.Properties
open import Cubical.Algebra.Group.Morphism

open import Cubical.Algebra.Monoid.Properties using (isPropIsMonoid; module MonoidLemmas)

open import Cubical.Relation.Unary as Unary hiding (isPropValued)
open import Cubical.Relation.Binary as Binary hiding (isPropValued)
open import Cubical.HITs.PropositionalTruncation
open import Cubical.Relation.Binary.Reasoning.Equality

open import Cubical.Algebra.Group.MorphismProperties public
  using (GroupPath; uaGroup; carac-uaGroup; Group≡; caracGroup≡)

private
  variable
    ℓ ℓ′ : Level

isPropIsGroup : ∀ {G : Type ℓ} {_•_ ε _⁻¹} → isProp (IsGroup G _•_ ε _⁻¹)
isPropIsGroup {G = G} {_•_} {ε} {_⁻¹} (isgroup aMon aInv) (isgroup bMon bInv) =
  cong₂ isgroup (isPropIsMonoid aMon bMon) (isPropInverse (IsMonoid.is-set aMon) _•_ _⁻¹ ε aInv bInv)

module GroupLemmas (G : Group ℓ) where
  open Group G

  open MonoidLemmas monoid public using (ε-comm) renaming (_^′_ to _^′′_; ^semi≡^ to ^semi≡^mon)

  invInvo : Involutive _⁻¹
  invInvo a = cancelʳ (a ⁻¹) (inverseˡ (a ⁻¹) ∙ sym (inverseʳ a))

  invId : ε ⁻¹ ≡ ε
  invId = cancelʳ ε (inverseˡ ε ∙ sym (identityʳ ε))

  invDistr : Homomorphic₂ _⁻¹ _•_ (flip _•_)
  invDistr x y = sym (inv-uniqueˡ _ _ (
    (x • y) • (y ⁻¹ • x ⁻¹)
      ≡˘⟨ assoc (x • y) (y ⁻¹) (x ⁻¹) ⟩
    x • y / y / x
      ≡⟨ cong (_/ x) (assoc _ _ _ ∙ cong (x •_) (inverseʳ y)) ⟩
    x • ε / x
      ≡⟨ cong (_/ x) (identityʳ x) ∙ inverseʳ x ⟩
    ε ∎))

  inv-comm : ∀ x → x • x ⁻¹ ≡ x ⁻¹ • x
  inv-comm x = inverseʳ x ∙ sym (inverseˡ x)

  isEquiv-•ˡ : ∀ x → isEquiv (x •_)
  isEquiv-•ˡ x = isoToIsEquiv (iso _ (x ⁻¹ •_) section-• retract-•)
    where
      section-• : section (x •_) (x ⁻¹ •_)
      section-• y =
        x • (x ⁻¹ • y) ≡˘⟨ assoc x (x ⁻¹) y ⟩
        x • x ⁻¹ • y   ≡⟨ cong (_• y) (inverseʳ x) ⟩
        ε • y          ≡⟨ identityˡ y ⟩
        y              ∎

      retract-• : retract (x •_) (x ⁻¹ •_)
      retract-• y =
        x ⁻¹ • (x • y) ≡˘⟨ assoc (x ⁻¹) x y ⟩
        x ⁻¹ • x • y   ≡⟨ cong (_• y) (inverseˡ x) ⟩
        ε • y          ≡⟨ identityˡ y ⟩
        y              ∎

  isEquiv-•ʳ : ∀ x → isEquiv (_• x)
  isEquiv-•ʳ x = isoToIsEquiv (iso _ (_• x ⁻¹) section-• retract-•)
    where
      section-• : section (_• x) (_• x ⁻¹)
      section-• y =
        y • x ⁻¹ • x   ≡⟨ assoc y (x ⁻¹) x ⟩
        y • (x ⁻¹ • x) ≡⟨ cong (y •_) (inverseˡ x) ⟩
        y • ε          ≡⟨ identityʳ y ⟩
        y              ∎

      retract-• : retract (_• x) (_• x ⁻¹)
      retract-• y =
        y • x • x ⁻¹   ≡⟨ assoc y x (x ⁻¹) ⟩
        y • (x • x ⁻¹) ≡⟨ cong (y •_) (inverseʳ x) ⟩
        y • ε          ≡⟨ identityʳ y ⟩
        y              ∎

  inv-≡ʳ : ∀ {x y} → x • y ⁻¹ ≡ ε → x ≡ y
  inv-≡ʳ p = inv-uniqueʳ _ _ p ∙ invInvo _

  inv-≡ˡ : ∀ {x y} → x ⁻¹ • y ≡ ε → x ≡ y
  inv-≡ˡ p = sym (invInvo _) ∙ sym (inv-uniqueˡ _ _ p)

  ≡-invʳ : ∀ {x y} → x ≡ y → x • y ⁻¹ ≡ ε
  ≡-invʳ p = subst (λ y → _ • y ⁻¹ ≡ ε) p (inverseʳ _)

  ≡-invˡ : ∀ {x y} → x ≡ y → x ⁻¹ • y ≡ ε
  ≡-invˡ p = subst (λ y → _ • y ≡ ε) p (inverseˡ _)

  ^-sucˡ : ∀ x n → x ^ sucInt n ≡ x • x ^ n
  ^-sucˡ x (pos n)                = refl
  ^-sucˡ x (negsuc zero)          = sym (inverseʳ x)
  ^-sucˡ x (negsuc (suc zero))    =
    x ^ -1          ≡⟨⟩
    x ⁻¹            ≡˘⟨ identityˡ _ ⟩
    ε • x ⁻¹        ≡˘⟨ cong (_• x ⁻¹) (inverseʳ x) ⟩
    x • x ⁻¹ • x ⁻¹ ≡⟨ assoc _ _ _ ⟩
    x • (x ^ -2)    ∎
  ^-sucˡ x (negsuc (suc (suc n))) =
    x ^ sucInt (negsuc (suc (suc n)))  ≡⟨⟩
    x ^ negsuc (suc n)                 ≡⟨⟩
    x ⁻¹ • x ^ negsuc n                ≡⟨⟩
    x ⁻¹ • x ^ sucInt (negsuc (suc n)) ≡⟨ cong (x ⁻¹ •_) (^-sucˡ x (negsuc (suc n))) ⟩
    x ⁻¹ • (x • x ^ negsuc (suc n))    ≡˘⟨ assoc _ _ _ ⟩
    x ⁻¹ • x • x ^ negsuc (suc n)      ≡˘⟨ cong (_• x ^ negsuc (suc n)) (inv-comm x) ⟩
    x • x ⁻¹ • x ^ negsuc (suc n)      ≡⟨ assoc _ _ _ ⟩
    x • (x ⁻¹ • x ^ negsuc (suc n))    ≡⟨⟩
    x • x ^ negsuc (suc (suc n))       ∎

  ^-sucʳ : ∀ x n → x ^ sucInt n ≡ x ^ n • x
  ^-sucʳ x (pos zero)       = ε-comm x
  ^-sucʳ x (pos (suc n))    =
    x ^ pos (suc (suc n)) ≡⟨⟩
    x • x ^ pos (suc n)   ≡⟨ cong (x •_) (^-sucʳ x (pos n)) ⟩
    x • (x ^ pos n • x)   ≡˘⟨ assoc _ _ _ ⟩
    x • x ^ pos n • x     ≡⟨⟩
    x ^ pos (suc n) • x   ∎
  ^-sucʳ x (negsuc zero)          = sym (inverseˡ x)
  ^-sucʳ x (negsuc (suc zero))    =
    x ⁻¹              ≡˘⟨ identityʳ _ ⟩
    x ⁻¹ • ε          ≡˘⟨ cong (x ⁻¹ •_) (inverseˡ x) ⟩
    x ⁻¹ • (x ⁻¹ • x) ≡˘⟨ assoc _ _ _ ⟩
    x ^ -2 • x        ∎
  ^-sucʳ x (negsuc (suc (suc n))) =
    x ^ sucInt (negsuc (suc (suc n)))  ≡⟨⟩
    x ^ negsuc (suc n)                 ≡⟨⟩
    x ⁻¹ • x ^ negsuc n                ≡⟨⟩
    x ⁻¹ • x ^ sucInt (negsuc (suc n)) ≡⟨ cong (x ⁻¹ •_) (^-sucʳ x (negsuc (suc n))) ⟩
    x ⁻¹ • (x ^ negsuc (suc n) • x)    ≡˘⟨ assoc _ _ _ ⟩
    x ⁻¹ • x ^ negsuc (suc n) • x      ≡⟨⟩
    x ^ negsuc (suc (suc n)) • x       ∎

  ^-predˡ : ∀ x n → x ^ predInt n ≡ x ⁻¹ • x ^ n
  ^-predˡ x (pos zero) = sym (identityʳ _)
  ^-predˡ x (pos (suc zero)) =
    ε              ≡˘⟨ inverseˡ x ⟩
    x ⁻¹ • x       ≡˘⟨ cong (x ⁻¹ •_) (identityʳ x) ⟩
    x ⁻¹ • (x • ε) ∎
  ^-predˡ x (pos (suc (suc n))) =
    x ^ predInt (pos (suc (suc n))) ≡⟨⟩
    x ^ pos (suc n)                 ≡⟨⟩
    x • x ^ pos n                   ≡⟨⟩
    x • x ^ predInt (pos (suc n))   ≡⟨ cong (x •_) (^-predˡ x (pos (suc n))) ⟩
    x • (x ⁻¹ • x ^ pos (suc n))    ≡˘⟨ assoc _ _ _ ⟩
    x • x ⁻¹ • x ^ pos (suc n)      ≡⟨ cong (_• x ^ pos (suc n)) (inv-comm x) ⟩
    x ⁻¹ • x • x ^ pos (suc n)      ≡⟨ assoc _ _ _ ⟩
    x ⁻¹ • (x • x ^ pos (suc n))    ≡⟨⟩
    x ⁻¹ • x ^ pos (suc (suc n))    ∎
  ^-predˡ x (negsuc n) = refl

  ^-predʳ : ∀ x n → x ^ predInt n ≡ x ^ n • x ⁻¹
  ^-predʳ x (pos zero) = sym (identityˡ _)
  ^-predʳ x (pos (suc zero)) =
    ε              ≡˘⟨ identityʳ _ ⟩
    ε • ε          ≡˘⟨ cong (ε •_) (inverseʳ _) ⟩
    ε • (x • x ⁻¹) ≡˘⟨ assoc _ _ _ ⟩
    ε • x • x ⁻¹   ≡˘⟨ cong (_• x ⁻¹) (ε-comm _) ⟩
    x • ε • x ⁻¹   ∎
  ^-predʳ x (pos (suc (suc n))) =
    x ^ predInt (pos (suc (suc n))) ≡⟨⟩
    x ^ pos (suc n)                 ≡⟨⟩
    x • x ^ pos n                   ≡⟨⟩
    x • x ^ predInt (pos (suc n))   ≡⟨ cong (x •_) (^-predʳ x (pos (suc n))) ⟩
    x • (x ^ pos (suc n) • x ⁻¹)    ≡˘⟨ assoc _ _ _ ⟩
    x • x ^ pos (suc n) • x ⁻¹      ≡⟨⟩
    x ^ pos (suc (suc n)) • x ⁻¹    ∎
  ^-predʳ x (negsuc zero) = refl
  ^-predʳ x (negsuc (suc n)) =
    x ^ predInt (negsuc (suc n))  ≡⟨⟩
    x ^ negsuc (suc (suc n))      ≡⟨⟩
    x ⁻¹ • x ^ negsuc (suc n)     ≡⟨⟩
    x ⁻¹ • x ^ predInt (negsuc n) ≡⟨ cong (x ⁻¹ •_) (^-predʳ x (negsuc n)) ⟩
    x ⁻¹ • (x ^ negsuc n • x ⁻¹)  ≡˘⟨ assoc _ _ _ ⟩
    x ⁻¹ • x ^ negsuc n • x ⁻¹    ≡⟨⟩
    x ^ negsuc (suc n) • x ⁻¹     ∎

  ^-plus : ∀ x → Homomorphic₂ (x ^_) _+_ _•_
  ^-plus x m (pos zero) = sym (identityʳ (x ^ m))
  ^-plus x m (pos (suc n)) =
    x ^ sucInt (m +pos n)   ≡⟨ ^-sucʳ x (m +pos n) ⟩
    x ^ (m +pos n) • x      ≡⟨ cong (_• x) (^-plus x m (pos n)) ⟩
    x ^ m • x ^ pos n • x   ≡⟨ assoc _ _ _ ⟩
    x ^ m • (x ^ pos n • x) ≡˘⟨ cong (x ^ m •_) (^-sucʳ x (pos n)) ⟩
    x ^ m • x ^ pos (suc n) ∎
  ^-plus x m (negsuc zero) = ^-predʳ x m
  ^-plus x m (negsuc (suc n)) =
    x ^ predInt (m +negsuc n)     ≡⟨ ^-predʳ x (m +negsuc n) ⟩
    x ^ (m +negsuc n) • x ⁻¹      ≡⟨ cong (_• x ⁻¹) (^-plus x m (negsuc n)) ⟩
    x ^ m • x ^ negsuc n • x ⁻¹   ≡⟨ assoc _ _ _ ⟩
    x ^ m • (x ^ negsuc n • x ⁻¹) ≡˘⟨ cong (x ^ m •_) (^-predʳ x (negsuc n)) ⟩
    x ^ m • x ^ negsuc (suc n)    ∎

  _^′_ : ⟨ G ⟩ → ℕ → ⟨ G ⟩
  _^′_ = IsMonoid._^_ isMonoid

  ^mon≡^ : ∀ x n → x ^′ n ≡ x ^ pos n
  ^mon≡^ x zero = refl
  ^mon≡^ x (suc n) = cong (x •_) (^mon≡^ x n)

  ^semi≡^ : ∀ x n → x ^′′ n ≡ x ^ pos (ℕ₊₁→ℕ n)
  ^semi≡^ x n = ^semi≡^mon x n ∙ ^mon≡^ x (ℕ₊₁→ℕ n)

module Conjugation (G : Group ℓ) where
  open Group G
  open GroupLemmas G using (isEquiv-•ˡ; isEquiv-•ʳ)

  module _ (g : ⟨ G ⟩) where

    conjugate : ⟨ G ⟩ → ⟨ G ⟩
    conjugate x = g • x • g ⁻¹

    conjugate-isEquiv : isEquiv conjugate
    conjugate-isEquiv = compIsEquiv (isEquiv-•ˡ g) (isEquiv-•ʳ (g ⁻¹))

    conjugate-hom : Homomorphic₂ conjugate _•_ _•_
    conjugate-hom x y =
      g • (x • y) • g ⁻¹              ≡˘⟨ cong (λ v → g • (v • y) • g ⁻¹) (identityʳ x) ⟩
      g • (x • ε • y) • g ⁻¹          ≡˘⟨ cong (λ v → g • (x • v • y) • g ⁻¹) (inverseˡ g) ⟩
      g • (x • (g ⁻¹ • g) • y) • g ⁻¹ ≡˘⟨ cong (λ v → g • (v • y) • g ⁻¹) (assoc _ _ _) ⟩
      g • (x • g ⁻¹ • g • y) • g ⁻¹   ≡˘⟨ cong (_• g ⁻¹) (assoc _ _ _) ⟩
      g • (x • g ⁻¹ • g) • y • g ⁻¹   ≡˘⟨ cong (λ v → v • y • g ⁻¹) (assoc _ _ _) ⟩
      g • (x • g ⁻¹) • g • y • g ⁻¹   ≡˘⟨ cong (λ v → v • g • y • g ⁻¹) (assoc _ _ _) ⟩
      g • x • g ⁻¹ • g • y • g ⁻¹     ≡⟨ cong (_• g ⁻¹) (assoc _ _ _) ⟩
      g • x • g ⁻¹ • (g • y) • g ⁻¹   ≡⟨ assoc _ _ _ ⟩
      g • x • g ⁻¹ • (g • y • g ⁻¹)   ∎

    conjugate-isHom : IsGroupHom G G conjugate
    conjugate-isHom = isgrouphom conjugate-hom

    conjugate-Hom : GroupHom G G
    conjugate-Hom = record { isHom = conjugate-isHom }

    conjugate-Equiv : GroupEquiv G G
    conjugate-Equiv = record { eq = conjugate , conjugate-isEquiv; isHom = conjugate-isHom }

    conjugate-Path : G ≡ G
    conjugate-Path = uaGroup conjugate-Equiv

  Conjugate : Rel ⟨ G ⟩ ℓ
  Conjugate a b = (∃[ g ∈ ⟨ G ⟩ ] conjugate g a ≡ b) , squash

module Kernel {G : Group ℓ} {H : Group ℓ′} (hom : GroupHom G H) where
  private
    module G = Group G
    module H = Group H
  open GroupHom hom renaming (fun to f)
  open GroupLemmas

  Kernel′ : RawPred ⟨ G ⟩ ℓ′
  Kernel′ x = f x ≡ H.ε

  isPropKernel : Unary.isPropValued Kernel′
  isPropKernel x = H.is-set (f x) H.ε

  Kernel : Pred ⟨ G ⟩ ℓ′
  Kernel = Unary.fromRaw Kernel′ isPropKernel

  ker-preservesId : G.ε ∈ Kernel
  ker-preservesId = preservesId

  ker-preservesOp : G._•_ Unary.Preserves₂ Kernel
  ker-preservesOp {x} {y} fx≡ε fy≡ε =
    f (x G.• y) ≡⟨ preservesOp x y ⟩
    f x H.• f y ≡⟨ cong₂ H._•_ fx≡ε fy≡ε ⟩
    H.ε H.• H.ε ≡⟨ H.identityʳ H.ε ⟩
    H.ε         ∎

  ker-preservesInv : G._⁻¹ Unary.Preserves Kernel
  ker-preservesInv {x} fx≡ε =
    f (x G.⁻¹) ≡⟨ preservesInv _ ⟩
    f x H.⁻¹   ≡⟨ cong H._⁻¹ fx≡ε ⟩
    H.ε H.⁻¹   ≡⟨ invId H ⟩
    H.ε        ∎

  ker⊆ε→inj : Kernel ⊆ ｛ G.ε ｝ → ∀ {x y} → f x ≡ f y → x ≡ y
  ker⊆ε→inj sub fx≡fy = inv-≡ʳ G (rec (G.is-set _ _) id (sub (preservesOp+Inv _ _ ∙ ≡-invʳ H fx≡fy)))
    where
      preservesOp+Inv : ∀ a b → f (a G.• b G.⁻¹) ≡ f a H.• f b H.⁻¹
      preservesOp+Inv a b = preservesOp a (b G.⁻¹) ∙ cong (f a H.•_) (preservesInv b)

  ker⊆ε→emb : Kernel ⊆ ｛ G.ε ｝ → isEmbedding f
  ker⊆ε→emb sub = injEmbedding G.is-set H.is-set (ker⊆ε→inj sub)

  inj→ker⊆ε : (∀ {x y} → f x ≡ f y → x ≡ y) → Kernel ⊆ ｛ G.ε ｝
  inj→ker⊆ε inj fx≡ε = ∣ inj (fx≡ε ∙ sym preservesId) ∣

  emb→ker⊆ε : isEmbedding f → Kernel ⊆ ｛ G.ε ｝
  emb→ker⊆ε emb = inj→ker⊆ε (invIsEq (emb _ _))


module RepeatedVariableInPattern where

K : Set -> Set
K A A = A


------------------------------------------------------------------------------
-- The gcd is a common divisor
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOTC.Program.GCD.Partial.CommonDivisorATP where

open import FOTC.Base
open import FOTC.Base.PropertiesATP
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Divisibility.NotBy0
open import FOTC.Data.Nat.Divisibility.NotBy0.PropertiesATP
open import FOTC.Data.Nat.Induction.NonAcc.LexicographicATP
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.EliminationPropertiesATP
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.PropertiesATP
open import FOTC.Program.GCD.Partial.Definitions
open import FOTC.Program.GCD.Partial.GCD
open import FOTC.Program.GCD.Partial.TotalityATP

------------------------------------------------------------------------------
-- Some cases of the gcd-∣₁.

-- We don't prove that
--
-- gcd-∣₁ : ... → (gcd m n) ∣ m

-- because this proof should be defined mutually recursive with the
-- proof
--
-- gcd-∣₂ : ... → (gcd m n) ∣ n.
--
-- Therefore, instead of proving
--
-- gcdCD : ... → CD m n (gcd m n)
--
-- using these proofs (i.e. the conjunction of them), we proved it
-- using well-founded induction.

-- gcd 0 (succ n) ∣ 0.
postulate gcd-0S-∣₁ : ∀ {n} → N n → gcd zero (succ₁ n) ∣ zero
{-# ATP prove gcd-0S-∣₁ #-}

-- gcd (succ₁ m) 0 ∣ succ₁ m.
postulate gcd-S0-∣₁ : ∀ {n} → N n → gcd (succ₁ n) zero ∣ succ₁ n
{-# ATP prove gcd-S0-∣₁ ∣-refl-S #-}

-- gcd (succ₁ m) (succ₁ n) ∣ succ₁ m, when succ₁ m ≯ succ₁ n.
postulate gcd-S≯S-∣₁ : ∀ {m n} → N m → N n →
                       (gcd (succ₁ m) (succ₁ n ∸ succ₁ m) ∣ succ₁ m) →
                       succ₁ m ≯ succ₁ n →
                       gcd (succ₁ m) (succ₁ n) ∣ succ₁ m
{-# ATP prove gcd-S≯S-∣₁ #-}

-- gcd (succ₁ m) (succ₁ n) ∣ succ₁ m when succ₁ m > succ₁ n.
{- Proof:
1. gcd (Sm ∸ Sn) Sn | (Sm ∸ Sn)        IH
2. gcd (Sm ∸ Sn) Sn | Sn               gcd-∣₂
3. gcd (Sm ∸ Sn) Sn | (Sm ∸ Sn) + Sn   m∣n→m∣o→m∣n+o 1,2
4. Sm > Sn                             Hip
5. gcd (Sm ∸ Sn) Sn | Sm               arith-gcd-m>n₂ 3,4
6. gcd Sm Sn = gcd (Sm ∸ Sn) Sn        gcd eq. 4
7. gcd Sm Sn | Sm                      subst 5,6
-}

-- For the proof using the ATP we added the helper hypothesis:
-- 1. gcd (succ₁ m ∸ succ₁ n) (succ₁ n) ∣ (succ₁ m ∸ succ₁ n) + succ₁ n.
-- 2. (succ₁ m ∸ succ₁ n) + succ₁ n ≡ succ₁ m.
postulate
  gcd-S>S-∣₁-ah :
    ∀ {m n} → N m → N n →
    (gcd (succ₁ m ∸ succ₁ n) (succ₁ n) ∣ (succ₁ m ∸ succ₁ n)) →
    (gcd (succ₁ m ∸ succ₁ n) (succ₁ n) ∣ succ₁ n) →
    succ₁ m > succ₁ n →
    gcd (succ₁ m ∸ succ₁ n) (succ₁ n) ∣ (succ₁ m ∸ succ₁ n) + succ₁ n →
    ((succ₁ m ∸ succ₁ n) + succ₁ n ≡ succ₁ m) →
    gcd (succ₁ m) (succ₁ n) ∣ succ₁ m
{-# ATP prove gcd-S>S-∣₁-ah #-}

gcd-S>S-∣₁ :
  ∀ {m n} → N m → N n →
  (gcd (succ₁ m ∸ succ₁ n) (succ₁ n) ∣ (succ₁ m ∸ succ₁ n)) →
  (gcd (succ₁ m ∸ succ₁ n) (succ₁ n) ∣ succ₁ n) →
  succ₁ m > succ₁ n →
  gcd (succ₁ m) (succ₁ n) ∣ succ₁ m
gcd-S>S-∣₁ {m} {n} Nm Nn ih gcd-∣₂ Sm>Sn =
  gcd-S>S-∣₁-ah Nm Nn ih gcd-∣₂ Sm>Sn
    (x∣y→x∣z→x∣y+z gcd-Sm-Sn,Sn-N Sm-Sn-N (nsucc Nn) ih gcd-∣₂)
    (x>y→x∸y+y≡x (nsucc Nm) (nsucc Nn) Sm>Sn)

  where
  Sm-Sn-N : N (succ₁ m ∸ succ₁ n)
  Sm-Sn-N = ∸-N (nsucc Nm) (nsucc Nn)

  gcd-Sm-Sn,Sn-N : N (gcd (succ₁ m ∸ succ₁ n) (succ₁ n))
  gcd-Sm-Sn,Sn-N = gcd-N Sm-Sn-N (nsucc Nn) (λ p → ⊥-elim (S≢0 (∧-proj₂ p)))

------------------------------------------------------------------------------
-- Some case of the gcd-∣₂.
-- We don't prove that gcd-∣₂ : ... → gcd m n ∣ n. The reason is
-- the same to don't prove gcd-∣₁ : ... → gcd m n ∣ m.

-- gcd 0 (succ₁ n) ∣₂ succ₁ n.
postulate gcd-0S-∣₂ : ∀ {n} → N n → gcd zero (succ₁ n) ∣ succ₁ n
{-# ATP prove gcd-0S-∣₂ ∣-refl-S #-}

-- gcd (succ₁ m) 0 ∣ 0.
postulate gcd-S0-∣₂ : ∀ {m} → N m → gcd (succ₁ m) zero ∣ zero
{-# ATP prove gcd-S0-∣₂ #-}

-- gcd (succ₁ m) (succ₁ n) ∣ succ₁ n when succ₁ m ≯ succ₁ n.
{- Proof:
1. gcd Sm (Sn ∸ Sm) | (Sn ∸ Sm)        IH
2  gcd Sm (Sn ∸ Sm) | Sm               gcd-∣₁
3. gcd Sm (Sn ∸ Sm) | (Sn ∸ Sm) + Sm   m∣n→m∣o→m∣n+o 1,2
4. Sm ≯ Sn                             Hip
5. gcd (Sm ∸ Sn) Sn | Sm               arith-gcd-m≤n₂ 3,4
6. gcd Sm Sn = gcd Sm (Sn ∸ Sm)        gcd eq. 4
7. gcd Sm Sn | Sn                      subst 5,6
-}

-- For the proof using the ATP we added the helper hypothesis:
-- 1. gcd (succ₁ m) (succ₁ n ∸ succ₁ m) ∣ (succ₁ n ∸ succ₁ m) + succ₁ m.
-- 2 (succ₁ n ∸ succ₁ m) + succ₁ m ≡ succ₁ n.
postulate
  gcd-S≯S-∣₂-ah :
    ∀ {m n} → N m → N n →
    (gcd (succ₁ m) (succ₁ n ∸ succ₁ m) ∣ (succ₁ n ∸ succ₁ m)) →
    (gcd (succ₁ m) (succ₁ n ∸ succ₁ m) ∣ succ₁ m) →
    succ₁ m ≯ succ₁ n →
    (gcd (succ₁ m) (succ₁ n ∸ succ₁ m) ∣ (succ₁ n ∸ succ₁ m) + succ₁ m) →
    ((succ₁ n ∸ succ₁ m) + succ₁ m ≡ succ₁ n) →
    gcd (succ₁ m) (succ₁ n) ∣ succ₁ n
{-# ATP prove gcd-S≯S-∣₂-ah #-}

gcd-S≯S-∣₂ :
  ∀ {m n} → N m → N n →
  (gcd (succ₁ m) (succ₁ n ∸ succ₁ m) ∣ (succ₁ n ∸ succ₁ m)) →
  (gcd (succ₁ m) (succ₁ n ∸ succ₁ m) ∣ succ₁ m) →
  succ₁ m ≯ succ₁ n →
  gcd (succ₁ m) (succ₁ n) ∣ succ₁ n
gcd-S≯S-∣₂ {m} {n} Nm Nn ih gcd-∣₁ Sm≯Sn =
  gcd-S≯S-∣₂-ah Nm Nn ih gcd-∣₁ Sm≯Sn
    (x∣y→x∣z→x∣y+z gcd-Sm,Sn-Sm-N Sn-Sm-N (nsucc Nm) ih gcd-∣₁)
    (x≤y→y∸x+x≡y (nsucc Nm) (nsucc Nn) (x≯y→x≤y (nsucc Nm) (nsucc Nn) Sm≯Sn))

  where
  Sn-Sm-N : N (succ₁ n ∸ succ₁ m)
  Sn-Sm-N = ∸-N (nsucc Nn) (nsucc Nm)

  gcd-Sm,Sn-Sm-N : N (gcd (succ₁ m) (succ₁ n ∸ succ₁ m))
  gcd-Sm,Sn-Sm-N = gcd-N (nsucc Nm) (Sn-Sm-N) (λ p → ⊥-elim (S≢0 (∧-proj₁ p)))

-- gcd (succ₁ m) (succ₁ n) ∣ succ₁ n when succ₁ m > succ₁ n.
postulate gcd-S>S-∣₂ : ∀ {m n} → N m → N n →
                       (gcd (succ₁ m ∸ succ₁ n) (succ₁ n) ∣ succ₁ n) →
                       succ₁ m > succ₁ n →
                       gcd (succ₁ m) (succ₁ n) ∣ succ₁ n
{-# ATP prove gcd-S>S-∣₂ #-}

------------------------------------------------------------------------------
-- The gcd is CD.
-- We will prove that gcdCD : ... → CD m n (gcd m n).

-- The gcd 0 (succ₁ n) is CD.
gcd-0S-CD : ∀ {n} → N n → CD zero (succ₁ n) (gcd zero (succ₁ n))
gcd-0S-CD Nn = (gcd-0S-∣₁ Nn , gcd-0S-∣₂ Nn)

-- The gcd (succ₁ m) 0 is CD.
gcd-S0-CD : ∀ {m} → N m → CD (succ₁ m) zero (gcd (succ₁ m) zero)
gcd-S0-CD Nm = (gcd-S0-∣₁ Nm , gcd-S0-∣₂ Nm)

-- The gcd (succ₁ m) (succ₁ n) when succ₁ m > succ₁ n is CD.
gcd-S>S-CD :
  ∀ {m n} → N m → N n →
  (CD (succ₁ m ∸ succ₁ n) (succ₁ n) (gcd (succ₁ m ∸ succ₁ n) (succ₁ n))) →
  succ₁ m > succ₁ n →
  CD (succ₁ m) (succ₁ n) (gcd (succ₁ m) (succ₁ n))
gcd-S>S-CD {m} {n} Nm Nn acc Sm>Sn =
   (gcd-S>S-∣₁ Nm Nn acc-∣₁ acc-∣₂ Sm>Sn , gcd-S>S-∣₂ Nm Nn acc-∣₂ Sm>Sn)
  where
  acc-∣₁ : gcd (succ₁ m ∸ succ₁ n) (succ₁ n) ∣ (succ₁ m ∸ succ₁ n)
  acc-∣₁ = ∧-proj₁ acc

  acc-∣₂ : gcd (succ₁ m ∸ succ₁ n) (succ₁ n) ∣ succ₁ n
  acc-∣₂ = ∧-proj₂ acc

-- The gcd (succ₁ m) (succ₁ n) when succ₁ m ≯ succ₁ n is CD.
gcd-S≯S-CD :
  ∀ {m n} → N m → N n →
  (CD (succ₁ m) (succ₁ n ∸ succ₁ m) (gcd (succ₁ m) (succ₁ n ∸ succ₁ m))) →
  succ₁ m ≯ succ₁ n →
  CD (succ₁ m) (succ₁ n) (gcd (succ₁ m) (succ₁ n))
gcd-S≯S-CD {m} {n} Nm Nn acc Sm≯Sn =
  (gcd-S≯S-∣₁ Nm Nn acc-∣₁ Sm≯Sn , gcd-S≯S-∣₂ Nm Nn acc-∣₂ acc-∣₁ Sm≯Sn)
  where
  acc-∣₁ : gcd (succ₁ m) (succ₁ n ∸ succ₁ m) ∣ succ₁ m
  acc-∣₁ = ∧-proj₁ acc

  acc-∣₂ : gcd (succ₁ m) (succ₁ n ∸ succ₁ m) ∣ (succ₁ n ∸ succ₁ m)
  acc-∣₂ = ∧-proj₂ acc

-- The gcd m n when m > n is CD.
gcd-x>y-CD :
  ∀ {m n} → N m → N n →
  (∀ {o p} → N o → N p → Lexi o p m n → x≢0≢y o p → CD o p (gcd o p)) →
  m > n →
  x≢0≢y m n →
  CD m n (gcd m n)
gcd-x>y-CD nzero          Nn             _  0>n   _ = ⊥-elim (0>x→⊥ Nn 0>n)
gcd-x>y-CD (nsucc Nm)     nzero          _  _     _ = gcd-S0-CD Nm
gcd-x>y-CD (nsucc {m} Nm) (nsucc {n} Nn) ah Sm>Sn _ =
  gcd-S>S-CD Nm Nn ih Sm>Sn
  where
  -- Inductive hypothesis.
  ih : CD (succ₁ m ∸ succ₁ n) (succ₁ n) (gcd (succ₁ m ∸ succ₁ n) (succ₁ n))
  ih  = ah {succ₁ m ∸ succ₁ n}
           {succ₁ n}
           (∸-N (nsucc Nm) (nsucc Nn))
           (nsucc Nn)
           ([Sx∸Sy,Sy]<[Sx,Sy] Nm Nn)
           (λ p → ⊥-elim (S≢0 (∧-proj₂ p)))

-- The gcd m n when m ≯ n is CD.
gcd-x≯y-CD :
  ∀ {m n} → N m → N n →
  (∀ {o p} → N o → N p → Lexi o p m n → x≢0≢y o p → CD o p (gcd o p)) →
  m ≯ n →
  x≢0≢y m n →
  CD m n (gcd m n)
gcd-x≯y-CD nzero          nzero         _   _     h = ⊥-elim (h (refl , refl))
gcd-x≯y-CD nzero          (nsucc Nn)     _  _     _ = gcd-0S-CD Nn
gcd-x≯y-CD (nsucc _)      nzero          _  Sm≯0  _ = ⊥-elim (S≯0→⊥ Sm≯0)
gcd-x≯y-CD (nsucc {m} Nm) (nsucc {n} Nn) ah Sm≯Sn _ = gcd-S≯S-CD Nm Nn ih Sm≯Sn
  where
  -- Inductive hypothesis.
  ih : CD (succ₁ m) (succ₁ n ∸ succ₁ m)  (gcd (succ₁ m) (succ₁ n ∸ succ₁ m))
  ih = ah {succ₁ m}
          {succ₁ n ∸ succ₁ m}
          (nsucc Nm)
          (∸-N (nsucc Nn) (nsucc Nm))
          ([Sx,Sy∸Sx]<[Sx,Sy] Nm Nn)
          (λ p → ⊥-elim (S≢0 (∧-proj₁ p)))

-- The gcd is CD.
gcdCD : ∀ {m n} → N m → N n → x≢0≢y m n → CD m n (gcd m n)
gcdCD = Lexi-wfind A h
  where
  A : D → D → Set
  A i j = x≢0≢y i j → CD i j (gcd i j)

  h : ∀ {i j} → N i → N j → (∀ {k l} → N k → N l → Lexi k l i j → A k l) →
      A i j
  h Ni Nj ah = case (gcd-x>y-CD Ni Nj ah) (gcd-x≯y-CD Ni Nj ah) (x>y∨x≯y Ni Nj)


module sum where

open import level
open import bool
open import eq
open import maybe
open import product
open import functions
open import empty public

----------------------------------------------------------------------
-- datatypes
----------------------------------------------------------------------

data _⊎_ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') : Set (ℓ ⊔ ℓ') where
  inj₁ : (x : A) → A ⊎ B
  inj₂ : (y : B) → A ⊎ B

_∨_ : ∀ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') → Set (ℓ ⊔ ℓ')
_∨_ = _⊎_

----------------------------------------------------------------------
-- syntax
----------------------------------------------------------------------

infixr 1 _⊎_ _∨_

----------------------------------------------------------------------
-- operations
----------------------------------------------------------------------

_≫=⊎_ : ∀ {ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'}{C : Set (ℓ ⊔ ℓ')}  → A ⊎ B → (B → A ⊎ C) → A ⊎ C
inj₁ x ≫=⊎ f = inj₁ x
inj₂ x ≫=⊎ f = f x

return⊎ : ∀ {ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'} → B → A ⊎ B
return⊎ b = inj₂ b

infix 5 error⊎_

error⊎_ : ∀ {ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'} → A → A ⊎ B
error⊎_ a = inj₁ a

extract-inj₁≡ : ∀{ℓ}{ℓ'}{A : Set ℓ}{B : Set ℓ'}{a a' : A} → inj₁{B = B} a ≡ inj₁ a' → a ≡ a'
extract-inj₁≡ refl = refl

extract-inj₂≡ : ∀{ℓ}{ℓ'}{A : Set ℓ}{B : Set ℓ'}{b b' : B} → inj₂{A = A} b ≡ inj₂ b' → b ≡ b'
extract-inj₂≡ refl = refl

=⊎ : ∀{ℓ}{ℓ'}{A : Set ℓ}{B : Set ℓ'} → (A → A → 𝔹) → (B → B → 𝔹) → A ⊎ B → A ⊎ B → 𝔹
=⊎ eqa eqb (inj₁ a) (inj₁ a') = eqa a a'
=⊎ eqa eqb (inj₂ b) (inj₂ b') = eqb b b'
=⊎ _ _ _ _ = ff

=⊎-to-≡ : ∀{ℓ}{ℓ'}{A : Set ℓ}{B : Set ℓ'} → (_eqa_ : A → A → 𝔹) → (_eqb_ : B → B → 𝔹) → ((a a' : A) → (a eqa a' ≡ tt) → a ≡ a') → ((b b' : B) → (b eqb b' ≡ tt) → b ≡ b') →  (x y : A ⊎ B) → =⊎ _eqa_ _eqb_ x y  ≡ tt → x ≡ y
=⊎-to-≡ eqa eqb risea riseb (inj₁ a) (inj₁ a') p rewrite risea a a' p = refl
=⊎-to-≡ eqa eqb risea riseb (inj₂ b) (inj₂ b') p rewrite riseb b b' p = refl
=⊎-to-≡ eqa eqb risea riseb (inj₁ a) (inj₂ b) ()
=⊎-to-≡ eqa eqb risea riseb (inj₂ b) (inj₁ a) ()

≡⊎-to-= : ∀{ℓ}{ℓ'}{A : Set ℓ}{B : Set ℓ'} → (_eqa_ : A → A → 𝔹) → (_eqb_ : B → B → 𝔹) → ((a a' : A) → a ≡ a' → a eqa a' ≡ tt) → ((b b' : B) → b ≡ b' → b eqb b' ≡ tt) →  (x y : A ⊎ B) → x ≡ y → =⊎ _eqa_ _eqb_ x y  ≡ tt
≡⊎-to-= eqa eqb dropa dropb (inj₁ a) (inj₁ a') p = dropa a a' (extract-inj₁≡ p)
≡⊎-to-= eqa eqb dropa dropb (inj₂ b) (inj₂ b') p = dropb b b' (extract-inj₂≡ p)
≡⊎-to-= eqa eqb dropa dropb (inj₁ a) (inj₂ b) ()
≡⊎-to-= eqa eqb dropa dropb (inj₂ b) (inj₁ a) ()

⊎-assoc : ∀{ℓ}{U V W : Set ℓ} → U ⊎ V ⊎ W → (U ⊎ V) ⊎ W
⊎-assoc (inj₁ x) = inj₁ (inj₁ x)
⊎-assoc (inj₂ (inj₁ x)) = inj₁ (inj₂ x)
⊎-assoc (inj₂ (inj₂ y)) = inj₂ y

⊎-assoc-inv : ∀{ℓ}{U V W : Set ℓ} → (U ⊎ V) ⊎ W → U ⊎ V ⊎ W
⊎-assoc-inv (inj₁ (inj₁ x)) = inj₁ x
⊎-assoc-inv (inj₁ (inj₂ y)) = inj₂ (inj₁ y)
⊎-assoc-inv (inj₂ y) = inj₂ (inj₂ y)

⊎-ar : ∀{ℓ}{U V W : Set ℓ} → (U → W) → (V → W) → U ⊎ V → W
⊎-ar f g (inj₁ x) = f x
⊎-ar f g (inj₂ y) = g y

⊎-sym : ∀{ℓ}{X Y : Set ℓ} → X ⊎ Y → Y ⊎ X
⊎-sym (inj₁ x) = inj₂ x
⊎-sym (inj₂ y) = inj₁ y

⊎-left-ident : ∀{ℓ}{X : Set ℓ} → ⊥ {ℓ} ⊎ X → X
⊎-left-ident (inj₁ x) = ⊥-elim x
⊎-left-ident (inj₂ y) = y

⊎-left-ident-inv : ∀{ℓ}{X : Set ℓ} → X → ⊥ {ℓ} ⊎ X
⊎-left-ident-inv = inj₂

⊎-right-ident : ∀{ℓ}{X : Set ℓ} → X ⊎ ⊥ {ℓ} → X
⊎-right-ident (inj₁ x) = x
⊎-right-ident (inj₂ y) = ⊥-elim y

⊎-right-ident-inv : ∀{ℓ}{X : Set ℓ} → X → X ⊎ ⊥ {ℓ}
⊎-right-ident-inv = inj₁

⊎-map : {U W V R : Set} → (U → V) → (W → R) → U ⊎ W → V ⊎ R
⊎-map {U} {W} {V} {R} f g (inj₁ u) = inj₁ (f u)
⊎-map {U} {W} {V} {R} f g (inj₂ w) = inj₂ (g w)

⊎-×-distl : {U V W : Set} → U × (V ⊎ W) → U × V ⊎ U × W
⊎-×-distl {U} {V} {W} (u , inj₁ v) = inj₁ (u , v)
⊎-×-distl {U} {V} {W} (u , inj₂ w) = inj₂ (u , w)

⊎-×-distl-inv : {X Y Z : Set} → X × Y ⊎ X × Z → X × (Y ⊎ Z)
⊎-×-distl-inv {X} {Y} {Z} (inj₁ (x , y)) = x , inj₁ y
⊎-×-distl-inv {X} {Y} {Z} (inj₂ (x , z)) = x , inj₂ z

⊎-×-distl-iso₁ : ∀{U V W}{a : U × (V ⊎ W)} → (⊎-×-distl-inv ∘ ⊎-×-distl) a ≡ id a
⊎-×-distl-iso₁ {a = u , inj₁ v} = refl
⊎-×-distl-iso₁ {a = u , inj₂ w} = refl

⊎-×-distl-iso₂ : ∀{U V W}{a : U × V ⊎ U × W} → (⊎-×-distl ∘ ⊎-×-distl-inv) a ≡ id a
⊎-×-distl-iso₂ {a = inj₁ (u , v)} = refl
⊎-×-distl-iso₂ {a = inj₂ (u , w)} = refl

⊎-×-distr : {U V W : Set} → (U ⊎ V) × W → U × W ⊎ V × W
⊎-×-distr {U} {V} {W} (inj₁ u , w) = inj₁ (u , w)
⊎-×-distr {U} {V} {W} (inj₂ v , w) = inj₂ (v , w)

⊎-×-distr-inv : {X Z Y : Set} → X × Z ⊎ Y × Z → (X ⊎ Y) × Z
⊎-×-distr-inv {X} {Z} {Y} (inj₁ (x , z)) = inj₁ x , z
⊎-×-distr-inv {X} {Z} {Y} (inj₂ (y , z)) = inj₂ y , z

⊎-×-distr-iso₁ : ∀{U V W}{a : (U ⊎ V) × W} → (⊎-×-distr-inv ∘ ⊎-×-distr) a ≡ id a
⊎-×-distr-iso₁ {a = inj₁ u , w} = refl
⊎-×-distr-iso₁ {a = inj₂ v , w} = refl

⊎-×-distr-iso₂ : ∀{U V W}{a : (U × W) ⊎ (V × W)} → (⊎-×-distr ∘ ⊎-×-distr-inv) a ≡ id a
⊎-×-distr-iso₂ {a = inj₁ (u , w)} = refl
⊎-×-distr-iso₂ {a = inj₂ (v , w)} = refl

⊎-codiag : ∀{ℓ : level}{U : Set ℓ} → U ⊎ U → U
⊎-codiag (inj₁ x) = x
⊎-codiag (inj₂ y) = y


postulate
  A B : Set
  f : A → B

data D : B → Set where
  c : {n : A} → D (f n)

test : (x : B) → D x → Set
test n c = {!!}

test2 : Set
test2 =
  let X = A in
  let X = B in
  {!!}


{-# OPTIONS --cubical-compatible #-}

postulate
  A : Set
  B : A → Set

-- fine
record R₀ : Set where
  field
    @0 x : A
    @0 y : B x

-- bad
record R : Set where
  field
    @0 x : A
    y : B x


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

open import Agda.Builtin.Bool

postulate
  A : Set

F : Bool → Set
F true  = A
F false = A

data D {b : Bool} (x : F b) : Set where

variable
  b : Bool
  x : F b

postulate
  f : D x → (P : F b → Set) → P x


open import Data.Nat using ()
open import Data.Bool using (true; false)
open import Data.Product using (_×_; _,_)
open import Data.String using (String; _≟_)
open import Data.Empty using ()
open import Level using (suc; _⊔_)
open import Relation.Nullary           using (yes; no)
open import Relation.Nullary.Decidable using (⌊_⌋)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym)

open import IMP
open import OperationalSemantics

assn : ∀{l} → Set (suc l)
assn {a} = state → Set a

data ⊢[_]_[_] {l} : assn {l} → com → assn {l} → Set (suc l) where
  Skip : ∀{P}
     → ⊢[ P ] SKIP [ P ]
  Loc : ∀{Q a x}
     → ⊢[ (λ s → Q (s [ x ::= aval a s ])) ] (x ::= a) [ Q ]
  Comp : ∀{P Q R c₁ c₂}
     → ⊢[ P ] c₁ [ Q ]
     → ⊢[ Q ] c₂ [ R ]
     → ⊢[ P ] c₁ :: c₂ [ R ]
  If : ∀{P b c₁ Q c₂}
     → ⊢[ (λ s → P s × bval b s ≡ true)  ] c₁ [ Q ]
     → ⊢[ (λ s → P s × bval b s ≡ false) ] c₂ [ Q ]
     → ⊢[ P ] (IF b THEN c₁ ELSE c₂) [ Q ]
  While : ∀{P b c}
     → ⊢[ (λ s → P s × bval b s ≡ true) ] c [ P ]
     → ⊢[ P ] (WHILE b DO c) [ (λ s → P s × bval b s ≡ false) ]
  Conseq : ∀{P Q P′ Q′ : assn} {c}
     → (∀ s → P′ s → P s)
     → ⊢[ P  ] c [ Q  ]
     → (∀ s → Q s → Q′ s)
     → ⊢[ P′ ] c [ Q′ ]

⊨[_]_[_] : assn → com → assn → Set
⊨[ P ] c [ Q ] = ∀{s t} → P s → ⦅ c , s ⦆⇒ t → Q t


-- Andreas, 2017-01-27, issue #2437
-- Polarity checker turns Nonvariant to Unused arg in types,
-- thus, reducing them.
-- However, this should not happen without need.
-- We wish to preserve the types as much as possible.

-- {-# OPTIONS -v 20 #-}
-- {-# OPTIONS -v tc.polarity:30 #-}
-- {-# OPTIONS -v tc.decl:30 #-}
-- {-# OPTIONS -v tc.term:30 #-}
-- {-# OPTIONS -v tc.conv.coerce:20 #-}
-- {-# OPTIONS -v tc.signature:30 #-}
-- {-# OPTIONS -v import.iface:100 #-}

open import Agda.Primitive
open import Agda.Builtin.Nat
open import Agda.Builtin.Equality

plus0 : ∀ x → x + 0 ≡ x
plus0 zero = refl
plus0 (suc x) rewrite plus0 x = refl

Identity : ∀{a} {A : Set a} (f : A → A) → Set a
Identity f = ∀ x → f x ≡ x

plus-0 : Identity (_+ 0)
plus-0 = plus0

-- Test (interactive): C-c C-d plus-0 RET
-- Expected:           Identity (λ section → section + 0)

-- Type should be inferred non-reduced, i.e, not as
-- ∀ x → x + 0 ≡ x


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

module Lens.Definition where

open import Prelude

record LensPart (A : Type a) (B : Type b) : Type (a ℓ⊔ b) where
  constructor lens-part
  eta-equality
  field
    get : B
    set : B → A
open LensPart public

map-lens-part : LensPart A C → (A → B) → LensPart B C
get (map-lens-part xs f) = get xs
set (map-lens-part xs f) x = f (set xs x)

record LensLaws {A : Type a} {B : Type b} (into : A → LensPart A B) : Type (a ℓ⊔ b) where
  no-eta-equality
  field
    get-set : ∀ s v → into (into s .set v) .get ≡ v
    set-get : ∀ s → into s .set (into s .get) ≡ s
    set-set : ∀ s v₁ v₂ → into (into s .set v₁) .set v₂ ≡ into s .set v₂
open LensLaws public

Lens : Type a → Type b → Type (a ℓ⊔ b)
Lens A B = Σ (A → LensPart A B) LensLaws


module CTL.Modalities.EF where

open import FStream.Core
open import Library

-- Possibly sometime : s₀ ⊧ φ ⇔ ∃ s₀ R s₁ R ... ∃ i . sᵢ ⊧ φ
data EF' {ℓ₁ ℓ₂} {C : Container ℓ₁}
     (props : FStream' C (Set ℓ₂)) : Set (ℓ₁ ⊔ ℓ₂) where
  alreadyE : head props → EF' props
  notYetE  : E (fmap EF' (inF (tail props))) → EF' props
open EF'

EF : ∀ {ℓ₁ ℓ₂} {C : Container ℓ₁}
     → FStream C (Set ℓ₂) → Set (ℓ₁ ⊔ ℓ₂)
EF props = APred EF' (inF props)

mutual
  EFₛ' : ∀ {i ℓ₁ ℓ₂} {C : Container ℓ₁}
       → FStream' C (Set ℓ₂) → FStream' {i} C (Set (ℓ₁ ⊔ ℓ₂))
  head (EFₛ' props) = EF' props
  tail (EFₛ' props) = EFₛ (tail props)

  EFₛ : ∀ {i ℓ₁ ℓ₂} {C : Container ℓ₁}
      → FStream C (Set ℓ₂) → FStream {i} C (Set (ℓ₁ ⊔ ℓ₂))
  inF (EFₛ props) = fmap EFₛ' (inF props)


{-# OPTIONS --cubical --no-import-sorts #-}
module Cubical.Codata.Stream where

open import Cubical.Codata.Stream.Base public

open import Cubical.Codata.Stream.Properties public


open import Agda.Builtin.Equality

postulate
  A : Set
  B : A → Set

variable
  a : A
  b : B a

postulate
  C : B a → Set

postulate
  f : (b : B a) → {!!}
  g : (c : C b) → {!!}

module _ (a′ : A) where
  postulate
    h : (b : B a) (b′ : B a′) → {!!}
    j : (b′ : B a) (c : C b) (c′ : C b′) → {!!}


-- Andreas, 2014-01-09, extend parser of typed bindings to allow hiding

postulate
  _≡_   : ∀{A : Set} (a b : A) → Set
  List  : Set → Set
  _++_  : ∀{A : Set} (xs ys : List A) → List A
  assoc : ∀{A : Set} (xs {ys} {zs} : List A) → ((xs ++ ys) ++ zs) ≡ (xs ++ (ys ++ zs))
  assoc1 : ∀{A : Set} (xs {ys zs} : List A) → ((xs ++ ys) ++ zs) ≡ (xs ++ (ys ++ zs))
  test  : (xs {ys zs} _ us : Set) → Set
  test1 : .(xs {ys zs} _ us : Set) → Set
  test2 : ..(xs {ys zs} _ us : Set) → Set


module _ where

open import Agda.Builtin.Nat
open import Agda.Builtin.Equality

data ⊥ : Set where

T : Nat → Set
T zero    = ⊥
T (suc n) = Nat

module M (n : Nat) where

  foo : n ≡ 0 → T n → Nat
  foo refl t = 0
    module M' where
      bar : ⊥
      bar = t

  bad : ⊥
  bad = M'.bar

loop : ⊥
loop = M.bad 0


open import Relation.Binary.Core

module BBHeap.Push.Properties {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_)
                  (trans≤ : Transitive _≤_) where

open import BBHeap _≤_
open import BBHeap.Equality.Properties _≤_
open import BBHeap.Push _≤_ tot≤ trans≤
open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import Data.Nat
open import Data.List
open import Data.Sum
open import List.Permutation.Base A
open import List.Permutation.Base.Concatenation A
open import List.Permutation.Base.Equivalence A
open import Order.Total _≤_ tot≤

mutual
  lemma-push⋘# : {b : Bound}{x y : A}{l r : BBHeap (val y)}(b≤x : LeB b (val x))(b≤y : LeB b (val y))(l⋘r : l ⋘ r) → # (push⋘ b≤x b≤y l⋘r) ≡ suc (# l + # r)
  lemma-push⋘# b≤x _ lf⋘ = refl
  lemma-push⋘# {x = x} b≤x b≤y (ll⋘ {x = y₁} {x' = y₂} y≤y₁ y≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂)
      with tot≤ y₁ y₂ | tot≤ x y₁ | tot≤ x y₂
  ... | inj₁ y₁≤y₂ | inj₁ x≤y₁ | _ =  refl
  ... | inj₂ y₂≤y₁ | _ | inj₁ x≤y₂ = refl
  ... | inj₁ y₁≤y₂ | inj₂ y₁≤x | _
      with # (push⋘ (lexy y₁≤x) (lexy refl≤) l₁⋘r₁) | lemma-push⋘# (lexy y₁≤x) (lexy refl≤) l₁⋘r₁
  ... | ._ | refl = refl
  lemma-push⋘# b≤x b≤y (ll⋘ y≤y₁ y≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂) | inj₂ y₂≤y₁ | _ | inj₂ y₂≤x
      with # (push⋘ (lexy y₂≤x) (lexy refl≤) l₂⋘r₂) | lemma-push⋘# (lexy y₂≤x) (lexy refl≤) l₂⋘r₂
  ... | ._ | refl = refl
  lemma-push⋘# {x = x} b≤x b≤y (lr⋘ {x = y₁} {x' = y₂} y≤y₁ y≤y₂ l₁⋙r₁ l₂⋘r₂ l₂≃r₂ l₁⋗l₂)
      with tot≤ y₁ y₂ | tot≤ x y₁ | tot≤ x y₂
  ... | inj₁ y₁≤y₂ | inj₁ x≤y₁ | _ = refl
  ... | inj₂ y₂≤y₁ | _ | inj₁ x≤y₂ = refl
  ... | inj₁ y₁≤y₂ | inj₂ y₁≤x | _
      with # (push⋙ (lexy y₁≤x) (lexy refl≤) l₁⋙r₁) | lemma-push⋙# (lexy y₁≤x) (lexy refl≤) l₁⋙r₁
  ... | ._ | refl = refl
  lemma-push⋘# b≤x b≤y (lr⋘ y≤y₁ y≤y₂ l₁⋙r₁ l₂⋘r₂ l₂≃r₂ l₁⋗l₂) | inj₂ y₂≤y₁ | _ | inj₂ y₂≤x
      with # (push⋘ (lexy y₂≤x) (lexy refl≤) l₂⋘r₂) | lemma-push⋘# (lexy y₂≤x) (lexy refl≤) l₂⋘r₂
  ... | ._ | refl = refl

  lemma-push⋙# : {b : Bound}{x y : A}{l r : BBHeap (val y)}(b≤x : LeB b (val x))(b≤y : LeB b (val y))(l⋙r : l ⋙ r) → # (push⋙ b≤x b≤y l⋙r) ≡ suc (# l + # r)
  lemma-push⋙# {x = x} b≤x b≤y (⋙lf {x = z} y≤z)
      with tot≤ x z
  ... | inj₁ x≤z = refl
  ... | inj₂ z≤x = refl
  lemma-push⋙# {x = x} b≤x b≤y (⋙rl {x = y₁} {x' = y₂} y≤y₁ y≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋘r₂ l₁⋗r₂)
      with tot≤ y₁ y₂ | tot≤ x y₁ | tot≤ x y₂
  ... | inj₁ y₁≤y₂ | inj₁ x≤y₁ | _ = refl
  ... | inj₂ y₂≤y₁ | _ | inj₁ x≤y₂ = refl
  ... | inj₁ y₁≤y₂ | inj₂ y₁≤x | _
      with # (push⋘ (lexy y₁≤x) (lexy refl≤) l₁⋘r₁) | lemma-push⋘# (lexy y₁≤x) (lexy refl≤) l₁⋘r₁
  ... | ._ | refl = refl
  lemma-push⋙# b≤x b≤y (⋙rl y≤y₁ y≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋘r₂ l₁⋗r₂) | inj₂ y₂≤y₁ | _ | inj₂ y₂≤x
      with # (push⋘ (lexy y₂≤x) (lexy refl≤) l₂⋘r₂) | lemma-push⋘# (lexy y₂≤x) (lexy refl≤) l₂⋘r₂
  ... | ._ | refl = refl
  lemma-push⋙# {x = x} b≤x b≤y (⋙rr {x = y₁} {x' = y₂} y≤y₁ y≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋙r₂ l₁≃l₂)
      with tot≤ y₁ y₂ | tot≤ x y₁ | tot≤ x y₂
  ... | inj₁ y₁≤y₂ | inj₁ x≤y₁ | _ = refl
  ... | inj₂ y₂≤y₁ | _ | inj₁ x≤y₂ = refl
  ... | inj₁ y₁≤y₂ | inj₂ y₁≤x | _
      with # (push⋘ (lexy y₁≤x) (lexy refl≤) l₁⋘r₁) | lemma-push⋘# (lexy y₁≤x) (lexy refl≤) l₁⋘r₁
  ... | ._ | refl = refl
  lemma-push⋙# b≤x b≤y (⋙rr y≤y₁ y≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋙r₂ l₁≃l₂) | inj₂ y₂≤y₁ | _ | inj₂ y₂≤x
      with # (push⋙ (lexy y₂≤x) (lexy refl≤) l₂⋙r₂) | lemma-push⋙# (lexy y₂≤x) (lexy refl≤) l₂⋙r₂
  ... | ._ | refl = refl

lemma-push# : {b : Bound}{x : A}(b≤x : LeB b (val x))(h : BBHeap b) → # (push b≤x h) ≡ # h
lemma-push# b≤x leaf = refl
lemma-push# b≤x (left b≤y l⋘r) = lemma-push⋘# b≤x b≤y l⋘r
lemma-push# b≤x (right b≤y l⋙r) = lemma-push⋙# b≤x b≤y l⋙r

mutual
  lemma-push⋘∼ : {b : Bound}{x y : A}{l r : BBHeap (val y)}(b≤x : LeB b (val x))(b≤y : LeB b (val y))(l⋘r : l ⋘ r) → flatten (push⋘ b≤x b≤y l⋘r) ∼ (x ∷ (flatten l ++ flatten r))
  lemma-push⋘∼ b≤x _ lf⋘ = ∼x /head /head ∼[]
  lemma-push⋘∼ {x = x} b≤x b≤y (ll⋘ {x = y₁} {x' = y₂} y≤y₁ y≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂)
      with tot≤ y₁ y₂ | tot≤ x y₁ | tot≤ x y₂
  ... | inj₁ y₁≤y₂ | inj₁ x≤y₁ | _ =  refl∼
  ... | inj₁ y₁≤y₂ | inj₂ y₁≤x | _ =
                   let pl'∼xfl₁fr₁ = lemma-push⋘∼ (lexy y₁≤x) (lexy refl≤) l₁⋘r₁ ;
                        fpl'fr'∼xfl₁fr₁fr' = lemma++∼r pl'∼xfl₁fr₁
                   in ∼x /head (/tail /head) fpl'fr'∼xfl₁fr₁fr'
  ... | inj₂ y₂≤y₁ | _ | inj₁ x≤y₂ = refl∼
  ... | inj₂ y₂≤y₁ | _ | inj₂ y₂≤x =
                   let pr'∼xfl₂fr₂ = lemma-push⋘∼ (lexy y₂≤x) (lexy refl≤) l₂⋘r₂ ;
                        fl' = flatten (left (lexy y₂≤y₁) l₁⋘r₁) ;
                        fl'fpr'∼fl'xfl₂fr₂ = lemma++∼l {xs = fl'} pr'∼xfl₂fr₂ ;
                        xfl'fr'/y₂⟶xfl'fl₂fr₂ = lemma++/l {xs = x ∷ fl'} /head ;
                        fl'xfl₂fr₂/x⟶fl'fl₂fr₂ = lemma++/ {xs = fl'};
                        fl'xfl₂fr₂∼xfl'fl₂fr₂ = ∼x fl'xfl₂fr₂/x⟶fl'fl₂fr₂ /head refl∼ ;
                        fl'fpr'∼xfl'fl₂fr₂ = trans∼ fl'fpr'∼fl'xfl₂fr₂  fl'xfl₂fr₂∼xfl'fl₂fr₂
                   in ∼x /head xfl'fr'/y₂⟶xfl'fl₂fr₂ fl'fpr'∼xfl'fl₂fr₂
  lemma-push⋘∼ {x = x} b≤x b≤y (lr⋘ {x = y₁} {x' = y₂} y≤y₁ y≤y₂ l₁⋙r₁ l₂⋘r₂ l₂≃r₂ l₁⋗l₂)
      with tot≤ y₁ y₂ | tot≤ x y₁ | tot≤ x y₂
  ... | inj₁ y₁≤y₂ | inj₁ x≤y₁ | _ = refl∼
  ... | inj₁ y₁≤y₂ | inj₂ y₁≤x | _ =
                   let pl'∼xfl₁fr₁ = lemma-push⋙∼ (lexy y₁≤x) (lexy refl≤) l₁⋙r₁ ;
                        fpl'fr'∼xfl₁fr₁fr' = lemma++∼r pl'∼xfl₁fr₁
                   in ∼x /head (/tail /head) fpl'fr'∼xfl₁fr₁fr'
  ... | inj₂ y₂≤y₁ | _ | inj₁ x≤y₂ = refl∼
  ... | inj₂ y₂≤y₁ | _ | inj₂ y₂≤x =
                   let pr'∼xfl₂fr₂ = lemma-push⋘∼ (lexy y₂≤x) (lexy refl≤) l₂⋘r₂ ;
                        fl' = flatten (right (lexy y₂≤y₁) l₁⋙r₁) ;
                        fl'fpr'∼fl'xfl₂fr₂ = lemma++∼l {xs = fl'} pr'∼xfl₂fr₂ ;
                        xfl'fr'/y₂⟶xfl'fl₂fr₂ = lemma++/l {xs = x ∷ fl'} /head ;
                        fl'xfl₂fr₂/x⟶fl'fl₂fr₂ = lemma++/ {xs = fl'};
                        fl'xfl₂fr₂∼xfl'fl₂fr₂ = ∼x fl'xfl₂fr₂/x⟶fl'fl₂fr₂ /head refl∼ ;
                        fl'fpr'∼xfl'fl₂fr₂ = trans∼ fl'fpr'∼fl'xfl₂fr₂  fl'xfl₂fr₂∼xfl'fl₂fr₂
                   in ∼x /head xfl'fr'/y₂⟶xfl'fl₂fr₂ fl'fpr'∼xfl'fl₂fr₂

  lemma-push⋙∼ : {b : Bound}{x y : A}{l r : BBHeap (val y)}(b≤x : LeB b (val x))(b≤y : LeB b (val y))(l⋙r : l ⋙ r) → flatten (push⋙ b≤x b≤y l⋙r) ∼ (x ∷ (flatten l ++ flatten r))
  lemma-push⋙∼ {x = x} b≤x b≤y (⋙lf {x = z} y≤z)
      with tot≤ x z
  ... | inj₁ x≤z = ∼x /head /head (∼x /head /head ∼[])
  ... | inj₂ z≤x = ∼x (/tail /head) /head (∼x /head /head ∼[])
  lemma-push⋙∼ {x = x} b≤x b≤y (⋙rl {x = y₁} {x' = y₂} y≤y₁ y≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋘r₂ l₁⋗r₂)
      with tot≤ y₁ y₂ | tot≤ x y₁ | tot≤ x y₂
  ... | inj₁ y₁≤y₂ | inj₁ x≤y₁ | _ = refl∼
  ... | inj₁ y₁≤y₂ | inj₂ y₁≤x | _ =
                   let pl'∼xfl₁fr₁ = lemma-push⋘∼ (lexy y₁≤x) (lexy refl≤) l₁⋘r₁ ;
                        fpl'fr'∼xfl₁fr₁fr' = lemma++∼r pl'∼xfl₁fr₁
                   in ∼x /head (/tail /head) fpl'fr'∼xfl₁fr₁fr'
  ... | inj₂ y₂≤y₁ | _ | inj₁ x≤y₂ = refl∼
  ... | inj₂ y₂≤y₁ | _ | inj₂ y₂≤x =
                   let pr'∼xfl₂fr₂ = lemma-push⋘∼ (lexy y₂≤x) (lexy refl≤) l₂⋘r₂ ;
                        fl' = flatten (left (lexy y₂≤y₁) l₁⋘r₁) ;
                        fl'fpr'∼fl'xfl₂fr₂ = lemma++∼l {xs = fl'} pr'∼xfl₂fr₂ ;
                        xfl'fr'/y₂⟶xfl'fl₂fr₂ = lemma++/l {xs = x ∷ fl'} /head ;
                        fl'xfl₂fr₂/x⟶fl'fl₂fr₂ = lemma++/ {xs = fl'};
                        fl'xfl₂fr₂∼xfl'fl₂fr₂ = ∼x fl'xfl₂fr₂/x⟶fl'fl₂fr₂ /head refl∼ ;
                        fl'fpr'∼xfl'fl₂fr₂ = trans∼ fl'fpr'∼fl'xfl₂fr₂  fl'xfl₂fr₂∼xfl'fl₂fr₂
                   in ∼x /head xfl'fr'/y₂⟶xfl'fl₂fr₂ fl'fpr'∼xfl'fl₂fr₂
  lemma-push⋙∼ {x = x} b≤x b≤y (⋙rr {x = y₁} {x' = y₂} y≤y₁ y≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋙r₂ l₁≃l₂)
      with tot≤ y₁ y₂ | tot≤ x y₁ | tot≤ x y₂
  ... | inj₁ y₁≤y₂ | inj₁ x≤y₁ | _ = refl∼
  ... | inj₁ y₁≤y₂ | inj₂ y₁≤x | _ =
                   let pl'∼xfl₁fr₁ = lemma-push⋘∼ (lexy y₁≤x) (lexy refl≤) l₁⋘r₁ ;
                        fpl'fr'∼xfl₁fr₁fr' = lemma++∼r pl'∼xfl₁fr₁
                   in ∼x /head (/tail /head) fpl'fr'∼xfl₁fr₁fr'
  ... | inj₂ y₂≤y₁ | _ | inj₁ x≤y₂ = refl∼
  ... | inj₂ y₂≤y₁ | _ | inj₂ y₂≤x =
                   let pr'∼xfl₂fr₂ = lemma-push⋙∼ (lexy y₂≤x) (lexy refl≤) l₂⋙r₂ ;
                        fl' = flatten (left (lexy y₂≤y₁) l₁⋘r₁) ;
                        fl'fpr'∼fl'xfl₂fr₂ = lemma++∼l {xs = fl'} pr'∼xfl₂fr₂ ;
                        xfl'fr'/y₂⟶xfl'fl₂fr₂ = lemma++/l {xs = x ∷ fl'} /head ;
                        fl'xfl₂fr₂/x⟶fl'fl₂fr₂ = lemma++/ {xs = fl'};
                        fl'xfl₂fr₂∼xfl'fl₂fr₂ = ∼x fl'xfl₂fr₂/x⟶fl'fl₂fr₂ /head refl∼ ;
                        fl'fpr'∼xfl'fl₂fr₂ = trans∼ fl'fpr'∼fl'xfl₂fr₂  fl'xfl₂fr₂∼xfl'fl₂fr₂
                   in ∼x /head xfl'fr'/y₂⟶xfl'fl₂fr₂ fl'fpr'∼xfl'fl₂fr₂