module Thesis.Subst where

--------------------------------------------------------------------------------
-- Prove substitution lemma. Unfortunately, this is done using a quite different
-- machinery from what we use elsewhere. The machinery for defining substitution
-- is taken from a formalization of hereditary substitution (Hereditary
-- Substitutions for Simple Types, Formalized, by Keller and Altenkirch), and
-- uses a different machinery for weakening.

-- I developed the lemmas relating substitution and this form of weakening from
-- scratch.
--------------------------------------------------------------------------------

open import Thesis.Lang hiding (_-_)

_-_ : ∀ {σ} Γ → Var Γ σ → Context
∅ - ()
(σ • Γ) - this = Γ
(τ • Γ) - that x = τ • (Γ - x)

import Relation.Binary.PropositionalEquality as P
open P hiding (subst)
open import Postulate.Extensionality

extend-env : ∀ {σ Γ} (x : Var Γ σ) (rho : ⟦ Γ - x ⟧Context) (v : ⟦ σ ⟧Type) → ⟦ Γ ⟧Context
extend-env this rho v = v • rho
extend-env (that x) (v1 • rho) v = v1 • extend-env x rho v

extend-env-sound : ∀ {σ Γ} (x : Var Γ σ) (rho : ⟦ Γ - x ⟧Context) (v : ⟦ σ ⟧Type) → v ≡ ⟦ x ⟧Var (extend-env x rho v)
extend-env-sound this rho v = refl
extend-env-sound (that x) (v1 • rho) v = extend-env-sound x rho v

wkv : ∀ {Γ σ τ} → (x : Var Γ σ) → Var (Γ - x) τ → Var Γ τ
wkv this y = that y
wkv (that x) this = this
wkv (that x) (that y) = that (wkv x y)

data EqV : ∀ {Γ σ τ} → Var Γ σ → Var Γ τ → Set where
  same : ∀ {Γ σ} → {x : Var Γ σ} → EqV x x
  diff : ∀ {Γ σ τ} → (x : Var Γ σ) → (z : Var (Γ - x) τ) → EqV x (wkv x z)
  -- If x and y do not represent the same variable, then
  -- ∃ z. y ≡ wkv x z, allowing us to construct a proof that diff x z : EqV x y

eq : ∀ {Γ σ τ} → (x : Var Γ σ) → (y : Var Γ τ) → EqV x y
eq this this = same
eq this (that y) = diff this y
eq (that x) this = diff (that x) this
eq (that x) (that y) with eq x y
eq (that y) (that .y) | same = same
eq (that x) (that .(wkv x z)) | diff .x z = diff (that x) (that z)

wkTerm : ∀ {Γ σ τ} → (x : Var Γ σ) → Term (Γ - x) τ → Term Γ τ
wkTerm x (var v) = var (wkv x v)
wkTerm x (app t₁ t₂) = (app (wkTerm x t₁) (wkTerm x t₂))
wkTerm x (abs t) = abs (wkTerm (that x) t)
wkTerm x (const c) = const c

wkv-sound : ∀ {Γ σ τ} → (x : Var Γ σ) → (y : Var (Γ - x) τ) →
  (ρ : ⟦ Γ - x ⟧Context) (v : ⟦ σ ⟧Type) →
  ⟦ wkv x y ⟧Var (extend-env x ρ v) ≡ ⟦ y ⟧Var ρ
wkv-sound this y ρ v = refl
wkv-sound (that x) this (v0 • ρ) v = refl
wkv-sound (that x) (that y) (v0 • ρ) v = wkv-sound x y ρ v

wkTerm-sound : ∀ {Γ σ τ} → (x : Var Γ σ) → (t : Term (Γ - x) τ) →
  (ρ : ⟦ Γ - x ⟧Context) (v : ⟦ σ ⟧Type) →
  ⟦ wkTerm x t ⟧Term (extend-env x ρ v) ≡ ⟦ t ⟧Term ρ
wkTerm-sound x (const c) ρ v = refl
wkTerm-sound x (var y) ρ v = wkv-sound x y ρ v
wkTerm-sound x (app t₁ t₂) ρ v
  rewrite wkTerm-sound x t₁ ρ v
  | wkTerm-sound x t₂ ρ v = refl
wkTerm-sound x (abs t) ρ v = ext (λ v₁ → wkTerm-sound (that x) t (v₁ • ρ) v)

substVar : ∀ {Γ σ τ} → Var Γ τ → (x : Var Γ σ) → Term (Γ - x) σ → Term (Γ - x) τ
substVar v x u with eq x v
substVar v .v u | same = u
substVar .(wkv x z) x u | diff .x z = var z

-- The above is the crucial rule. The dotted pattern makes producing the result
-- easy.

subst : ∀ {Γ σ τ} → Term Γ τ → (x : Var Γ σ) → Term (Γ - x) σ → Term (Γ - x) τ
subst (var v) x u = substVar v x u
subst (app t₁ t₂) x u = app (subst t₁ x u) (subst t₂ x u)
subst (abs t) x u = abs (subst t (that x) (wkTerm this u))
subst (const c) x u = const c

substVar-lemma : ∀ {σ τ Γ} (v : Var Γ τ) (x : Var Γ σ) s rho → ⟦ substVar v x s ⟧Term rho ≡ ⟦ v ⟧Var (extend-env x rho (⟦ s ⟧Term rho))
substVar-lemma v x s rho with eq x v
substVar-lemma .(wkv x z) x s rho | diff .x z = sym (wkv-sound x z rho (⟦ s ⟧Term rho))
substVar-lemma x .x s rho | same = extend-env-sound x rho (⟦ s ⟧Term rho)

subst-lemma : ∀ {σ τ Γ} (t : Term Γ τ) (x : Var Γ σ) s rho → ⟦ subst t x s ⟧Term rho ≡ ⟦ t ⟧Term (extend-env x rho (⟦ s ⟧Term rho))
subst-lemma (const c) x s rho = refl
subst-lemma (var y) x s rho = substVar-lemma y x s rho
subst-lemma (app t₁ t₂) x s rho rewrite subst-lemma t₁ x s rho | subst-lemma t₂ x s rho = refl
subst-lemma (abs t) x s rho = ext body
  where
    body : ∀ v → ⟦ subst t (that x) (wkTerm this s) ⟧Term (v • rho) ≡
           ⟦ t ⟧Term (v • extend-env x rho (⟦ s ⟧Term rho))
    body v rewrite subst-lemma t (that x) (wkTerm this s) (v • rho) |
      wkTerm-sound this s rho v = refl


------------------------------------------------------------------------
-- The Agda standard library
--
-- Environments (heterogeneous collections)
------------------------------------------------------------------------

{-# OPTIONS --with-K --safe #-}

module Data.Star.Environment {ℓ} (Ty : Set ℓ) where

open import Level
open import Data.Star.List
open import Data.Star.Decoration
open import Data.Star.Pointer as Pointer hiding (lookup)
open import Data.Unit
open import Function hiding (_∋_)
open import Relation.Binary.PropositionalEquality
open import Relation.Binary.Construct.Closure.ReflexiveTransitive

-- Contexts, listing the types of all the elements in an environment.

Ctxt : Set ℓ
Ctxt = List Ty

-- Variables (de Bruijn indices); pointers into environments.

infix 4 _∋_

_∋_ : Ctxt → Ty → Set ℓ
Γ ∋ σ = Any (const (Lift ℓ ⊤)) (σ ≡_) Γ

vz : ∀ {Γ σ} → Γ ▻ σ ∋ σ
vz = this refl

vs : ∀ {Γ σ τ} → Γ ∋ τ → Γ ▻ σ ∋ τ
vs = that _

-- Environments. The T function maps types to element types.

Env : ∀ {e} → (Ty → Set e) → (Ctxt → Set (ℓ ⊔ e))
Env T Γ = All T Γ

-- A safe lookup function for environments.

lookup : ∀ {Γ σ} {T : Ty → Set} → Γ ∋ σ → Env T Γ → T σ
lookup i ρ with Pointer.lookup i ρ
... | result refl x = x


{-# OPTIONS --rewriting #-}

module Luau.VarCtxt where

open import Agda.Builtin.Equality using (_≡_)
open import Luau.Type using (Type; _∪_; _∩_)
open import Luau.Var using (Var)
open import FFI.Data.Aeson using (KeyMap; Key; empty; unionWith; singleton; insert; delete; lookup; toString; fromString; lookup-insert; lookup-insert-not; lookup-empty; to-from; insert-swap; insert-over)
open import FFI.Data.Maybe using (Maybe; just; nothing)
open import Properties.Equality using (_≢_; cong; sym; trans)

VarCtxt : Set
VarCtxt = KeyMap Type

∅ : VarCtxt
∅ = empty

_⋒_ : VarCtxt → VarCtxt → VarCtxt
_⋒_ = unionWith _∩_

_⋓_ : VarCtxt → VarCtxt → VarCtxt
_⋓_ = unionWith _∪_

_[_] : VarCtxt → Var → Maybe Type
Γ [ x ] = lookup (fromString x) Γ

_⊝_ : VarCtxt → Var → VarCtxt
Γ ⊝ x = delete (fromString x) Γ

_↦_ : Var → Type → VarCtxt
x ↦ T = singleton (fromString x) T

_⊕_↦_ : VarCtxt → Var → Type → VarCtxt
Γ ⊕ x ↦ T = insert (fromString x) T Γ

⊕-over : ∀ {Γ x y T U} → (x ≡ y) → ((Γ ⊕ x ↦ T) ⊕ y ↦ U) ≡ (Γ ⊕ y ↦ U)
⊕-over p = insert-over _ _ _ _ _ (cong fromString (sym p))

⊕-swap : ∀ {Γ x y T U} → (x ≢ y) → ((Γ ⊕ x ↦ T) ⊕ y ↦ U) ≡ ((Γ ⊕ y ↦ U) ⊕ x ↦ T)
⊕-swap p = insert-swap _ _ _ _ _ (λ q → p (trans (sym (to-from _)) (trans (cong toString (sym q) ) (to-from _))) )

⊕-lookup-miss : ∀ x y T Γ → (x ≢ y) → (Γ [ y ] ≡ (Γ ⊕ x ↦ T) [ y ])
⊕-lookup-miss x y T Γ p = lookup-insert-not (fromString x) (fromString y) T Γ λ q → p (trans (sym (to-from x)) (trans (cong toString q) (to-from y)))


module Negative2 where

data Tree (A : Set) : Set where
    leaf : Tree A
    node : (A -> Tree A) -> Tree A

data Bad : Set where
    bad : Tree Bad -> Bad


open import Data.Nat using ( ℕ )

module README ( n : ℕ ) where

------------------------------------------------------------------------------
-- Agda-Prop Library.
-- Deep Embedding for Propositional Logic.
------------------------------------------------------------------------------

open import Data.PropFormula n public


import      Lvl
open import Structure.Setoid
open import Type

module Automaton.Deterministic where

open import Data.List renaming (∅ to ε ; _⊰_ to _·_)
open import Data.List.Setoid
open import Data.List.Functions using (postpend ; _++_)
open import Data.List.Proofs
open import Functional
open import Logic
open import Sets.ExtensionalPredicateSet using (PredSet ; intro ; _∈_ ; _∋_ ; ⊶ ; [∋]-binaryRelator)
import      Structure.Function.Names as Names
open import Structure.Operator
open import Structure.Relator.Properties

-- According to http://www.cse.chalmers.se/edu/course/TMV027/lec5.pdf

private variable ℓₚ ℓₛ ℓₑ₁ ℓₐ ℓₑ₂ : Lvl.Level

module _
  {ℓₚ}
  (State : Type{ℓₛ}) ⦃ equiv-state : Equiv{ℓₑ₁}(State) ⦄
  (Alphabet : Type{ℓₐ}) ⦃ equiv-alphabet : Equiv{ℓₑ₂}(Alphabet) ⦄
  where

  -- Deterministic Automata
  -- `State`      (Q)  is the set of states.
  -- `Alphabet`   (Σ)  is the set of symbols/the alphabet.
  -- `transition` (δ)  is the transition function.
  -- `start`      (q₀) is the start state.
  -- `Final`      (F)  is the subset of State which are the final/accepting states.
  record Deterministic : Type{ℓₛ Lvl.⊔ ℓₑ₁ Lvl.⊔ ℓₑ₂ Lvl.⊔ ℓₐ Lvl.⊔ Lvl.𝐒(ℓₚ)} where
    constructor deterministic
    field
      transition : State → Alphabet → State
      ⦃ transition-binaryOperator ⦄ : BinaryOperator(transition)
      start      : State
      Final      : PredSet{ℓₚ}(State)

    Word = List(Alphabet)

    -- Chained transition using a word (list of characters).
    wordTransition : State → Word → State
    wordTransition initialState ε       = initialState
    wordTransition initialState (a · l) = wordTransition (transition initialState a) l

    module LetterNotation where
      Q  = State
      Σ  = Alphabet
      δ  = transition
      δ̂  = wordTransition
      q₀ = start
      F  = Final

    -- A word is accepted by the automaton when it can transition from the start state to a final state.
    AcceptsWord : Word → Stmt
    AcceptsWord = (_∈ Final) ∘ wordTransition start

    transitionedAutomaton : Alphabet → Deterministic
    transition (transitionedAutomaton _) = transition
    start      (transitionedAutomaton c) = transition start c
    Final      (transitionedAutomaton _) = Final

    wordTransitionedAutomaton : Word → Deterministic
    transition (wordTransitionedAutomaton _) = transition
    start      (wordTransitionedAutomaton w) = wordTransition start w
    Final      (wordTransitionedAutomaton _) = Final

module _
  {State : Type{ℓₛ}} ⦃ equiv-state : Equiv{ℓₑ₁}(State) ⦄
  {Alphabet : Type{ℓₐ}} ⦃ equiv-alphabet : Equiv{ℓₑ₂}(Alphabet) ⦄
  {d : Deterministic{ℓₚ = ℓₚ}(State)(Alphabet)}
  where

  open import Data.List.Equiv
  open import Structure.Operator.Properties
  open import Syntax.Transitivity

  open Deterministic(d)

  instance
    wordTransition-binaryOperator : BinaryOperator(wordTransition)
    wordTransition-binaryOperator = intro p where
      p : Names.Congruence₂(wordTransition)
      p {x₂ = ε}       {y₂ = ε}       xy1 xy2 = xy1
      p {x₂ = c₁ · w₁} {y₂ = c₂ · w₂} xy1 xy2 = p{x₂ = w₁}{y₂ = w₂} (congruence₂(transition) xy1 ([⊰]-generalized-cancellationᵣ xy2)) ([⊰]-generalized-cancellationₗ xy2)

  wordTransition-postpend : ∀{s}{w}{a} → ((wordTransition s (postpend a w)) ≡ transition (wordTransition s w) a)
  wordTransition-postpend {s}{ε}    {a} = reflexivity(_≡_) {x = transition s a}
  wordTransition-postpend {s}{x · w}{a} = wordTransition-postpend {transition s x}{w}{a}

  -- Note: ((swap ∘ wordTransition) d (w₁ ++ w₂) ⊜ (swap ∘ wordTransition) d w₂ ∘ (swap ∘ wordTransition) d w₁)
  wordTransition-[++] : ∀{s}{w₁ w₂} → (wordTransition s (w₁ ++ w₂) ≡ (wordTransition (wordTransition s w₁) w₂))
  wordTransition-[++] {s = s} {w₁ = w₁} {w₂ = ε} =
    wordTransition s (w₁ ++ ε)             🝖[ _≡_ ]-[ congruence₂ᵣ(wordTransition)(s) (identityᵣ(_++_)(ε) {w₁}) ]
    wordTransition s w₁                    🝖[ _≡_ ]-[]
    wordTransition (wordTransition s w₁) ε 🝖-end
  wordTransition-[++] {s = s} {w₁ = w₁} {w₂ = c₂ · w₂} =
    wordTransition s (w₁ ++ (c₂ · w₂))                      🝖[ _≡_ ]-[ congruence₂ᵣ(wordTransition)(s) ([++]-middle-prepend-postpend{l₁ = w₁}) ]-sym
    wordTransition s (postpend c₂ w₁ ++ w₂)                 🝖[ _≡_ ]-[ wordTransition-[++] {s = s}{w₁ = postpend c₂ w₁}{w₂ = w₂} ]
    wordTransition (wordTransition s (postpend c₂ w₁)) w₂   🝖[ _≡_ ]-[ congruence₂ₗ(wordTransition)(w₂) (wordTransition-postpend{s = s}{w = w₁}) ]
    wordTransition (transition (wordTransition s w₁) c₂) w₂ 🝖-end


module Basic.Compiler.CorrectFrom where

open import Basic.AST
open import Basic.BigStep
open import Basic.Compiler.Code
open import Basic.Compiler.SplitCode
open import Utils.NatOrdLemmas
open import Utils.Decidable
open import Utils.Monoid

open import Data.Fin using (Fin; #_)
open import Data.Vec hiding (_∷ʳ_; _++_; [_]; _∈_; foldr)
open import Data.Nat
open import Data.Nat.Properties.Simple
open import Data.Nat.Properties
open import Data.Empty
open import Data.Bool renaming (not to notBool; if_then_else_ to ifBool_then_else)
open import Data.List hiding ([_])
open import Data.List.Properties
open import Relation.Binary.PropositionalEquality
open import Function
open import Data.Product
open import Relation.Nullary
open import Relation.Nullary.Decidable
import Level as L

open import Algebra
private
  module LM {a A} = Algebra.Monoid (Data.List.monoid {a} A)

open import Relation.Unary
open import Induction.Nat
open import Induction.WellFounded

{-
Lemma 3.22

This proof caused me considerable headache. First I started to prove it
by strctural recursion on the to-be-compiled statement, but then Agda complained
that it was not structurally recursive. And indeed it isn't.

In the "while-true" case, we start with a program derivation of the type:

  ⟨ 𝓒⟦ S ⟧ˢ ++ LOOP 𝓒⟦ b ⟧ᵉ 𝓒⟦ S ⟧ˢ ∷ [] , [] , s ⟩▷*⟨ [] , e , s' ⟩

And a statement with the following form:

  while b do S

Then we split this derivation into two parts:

  ⟨ 𝓒⟦ S ⟧ˢ , [] , s ⟩▷*⟨ [] , e'' , s'' ⟩
  ⟨ LOOP 𝓒⟦ b ⟧ᵉ 𝓒⟦ S ⟧ˢ ∷ [] , e'' , s'' ⟩▷*⟨ [] , e , s' ⟩

But now if we recurse on the second derivation, the corresponding statement will
be again "while b do S". Thus Agda will not be able to prove termination.

So I had to use well-founded induction. It is a standard library machinery that
allows us to do induction on a well-ordered set. Here's an introduction to how
it works:

http://blog.ezyang.com/2010/06/well-founded-recursion-in-agda/

We usually prefer to not use well-founded recursion, because it demands us proofs
of decreasing order even on cases where recursion is otherwise evidently structural, and
it also makes certain proofs rather difficult.
-}

-- Well-foundedness lemmas
------------------------------------------------------------

{-
We do well-founded recursion on the length of derivation sequences.
But we also have to prove that splitting a derivation sequence will
never produce empty sequences, or else the lenghts will not be strictly
decreasing.

To show this, we have to show that

  - compilation into abstract machine code never outputs
    an empty list of instructions

  - computation sequences starting with a non-empty instruction list are never empty

-}

∷ʳ-nonempty : ∀ {a}{A : Set a}(xs : List A) x → xs ∷ʳ x ≢ []
∷ʳ-nonempty [] x ()
∷ʳ-nonempty (x ∷ xs) x₁ ()

++-xs-empty : ∀ {a}{A : Set a}(xs : List A) {ys} → xs <> ys ≡ [] → xs ≡ []
++-xs-empty [] p = refl
++-xs-empty (x ∷ xs)  ()

{- Compiled statement are non-empty -}
𝓒ˢ-nonempty : ∀ {n}(S : St n) → 𝓒⟦ S ⟧ˢ ≢ []
𝓒ˢ-nonempty (x := x₁)             = ∷ʳ-nonempty 𝓒⟦ x₁ ⟧ᵉ (STORE x)
𝓒ˢ-nonempty (S , S₁)              = 𝓒ˢ-nonempty S ∘ ++-xs-empty 𝓒⟦ S ⟧ˢ
𝓒ˢ-nonempty (if x then S else S₁) = ∷ʳ-nonempty 𝓒⟦ x ⟧ᵉ (BRANCH 𝓒⟦ S ⟧ˢ 𝓒⟦ S₁ ⟧ˢ)
𝓒ˢ-nonempty (while x do S) ()
𝓒ˢ-nonempty skip ()

{- Compiled expressions are non-empty -}
𝓒-Exp-nonempty : ∀ {n t} (e : Exp n t) → 𝓒⟦ e ⟧ᵉ ≢ []
𝓒-Exp-nonempty (add e e₁)     = ∷ʳ-nonempty (𝓒⟦ e₁ ⟧ᵉ <> 𝓒⟦ e ⟧ᵉ) ADD
𝓒-Exp-nonempty (mul e e₁)     = ∷ʳ-nonempty (𝓒⟦ e₁ ⟧ᵉ <> 𝓒⟦ e ⟧ᵉ) MUL
𝓒-Exp-nonempty (sub e e₁)     = ∷ʳ-nonempty (𝓒⟦ e₁ ⟧ᵉ <> 𝓒⟦ e ⟧ᵉ) SUB
𝓒-Exp-nonempty (eq e e₁)      = ∷ʳ-nonempty (𝓒⟦ e₁ ⟧ᵉ <> 𝓒⟦ e ⟧ᵉ) EQ
𝓒-Exp-nonempty (lte e e₁)     = ∷ʳ-nonempty (𝓒⟦ e₁ ⟧ᵉ <> 𝓒⟦ e ⟧ᵉ) LTE
𝓒-Exp-nonempty (lt e e₁)      = ∷ʳ-nonempty (𝓒⟦ e₁ ⟧ᵉ <> 𝓒⟦ e ⟧ᵉ) LT
𝓒-Exp-nonempty (Exp.and e e₁) = ∷ʳ-nonempty (𝓒⟦ e₁ ⟧ᵉ <> 𝓒⟦ e ⟧ᵉ) AND
𝓒-Exp-nonempty (not e)        = ∷ʳ-nonempty 𝓒⟦ e ⟧ᵉ NOT
𝓒-Exp-nonempty (lit x) ()
𝓒-Exp-nonempty (var x) ()
𝓒-Exp-nonempty tt ()
𝓒-Exp-nonempty ff ()

{-Computations sequences for non-empty code are non-zero length -}
▷*-S-nonempty :
  ∀ {n S}{s s' : State n}{e e'} (p : ⟨ 𝓒⟦ S ⟧ˢ , e , s ⟩▷*⟨ [] , e' , s' ⟩)
  → ▷*-length p ≢ 0
▷*-S-nonempty{_}{S} p x with 𝓒ˢ-nonempty S | 𝓒⟦ S ⟧ˢ | inspect 𝓒⟦_⟧ˢ S
▷*-S-nonempty done x      | ¬empty | []     | [ remember ] = ¬empty remember
▷*-S-nonempty (() ∷ p) x₁ | ¬empty | []     | [ remember ]
▷*-S-nonempty (x₁ ∷ p) () | ¬empty | x ∷ cs | [ remember ]

{- misc ordering lemmas -}
a<′a+sb : ∀ a b → b ≢ 0 → a <′ a + b
a<′a+sb a zero x = ⊥-elim (x refl)
a<′a+sb a (suc b) x rewrite +-comm a (suc b) = ≤⇒≤′ $ a<sb+a a b

a<′b+sa : ∀ a b → a <′ b + suc a
a<′b+sa a zero    = ≤′-refl
a<′b+sa a (suc b) = ≤′-step (a<′b+sa a b)

≤′-weaken-l : ∀ {a b} c → a ≤′ b → a ≤′ c + b
≤′-weaken-l zero p = p
≤′-weaken-l (suc c) p = ≤′-step (≤′-weaken-l c p)

-- Correctness
------------------------------------------------------------

{-
This is a shorthand for the actual type of the theorem. We use this because
otherwise we'd have to write out the type three times in the following code.
-}
𝓒-correct-from-Ty : {_ : ℕ} → ℕ → Set
𝓒-correct-from-Ty {n} size =
    ∀ {S : St n} {e s s'}
    → (p : ⟨ 𝓒⟦ S ⟧ˢ , [] , s ⟩▷*⟨ [] , e , s' ⟩)
    → size ≡ ▷*-length p
    → ⟨ S , s ⟩⟱ s' × e ≡ []

𝓒-correct-from : ∀ {n} size → 𝓒-correct-from-Ty {n} size
𝓒-correct-from {n} = <-rec _ go where

  {-
  Note: we use ▷*-deterministic quite a few times below. We separately use
  ▷*-split to split the sequence and 𝓒-Exp to establish the contents of the stack
  after evaluating an expression, but these remain separate facts until we use
  determinism to prove that the first split sequence and 𝓒-Exp's resulting sequence
  are the same.

  We see 𝓒-Exp , ▷*-split and ▷*-deterministic chained together several times below.
  This is admittedly pretty ugly and it would be better to factor out this pattern
  and possibly include all the relevant information in the output of ▷*-split.
  -}

  {-
  "go" is the helper function for well-founded recursion. "<-rec" can be viewed as
  a sort of a fixpoint operator that demands a proof that the argument strictly decreases
  on every recursion. "size" is the size argument, and we recurse via the "recurse"
  argument.
  -}
  go : ∀ size → (∀ y → y <′ size → 𝓒-correct-from-Ty {n} y) → 𝓒-correct-from-Ty {n} size

  -- Assignment
  go size recurse {x := exp}{e}{s} p sizeEq
    with ▷*-split 𝓒⟦ exp ⟧ᵉ p | 𝓒-Exp-nat {e = []}{s = s} exp
  go size recurse {.x := exp} p sizeEq | s₁ , ._ , p1 , STORE x ∷ () ∷ p2 , eqn | exp'
  go size recurse {.x := exp} p sizeEq | s₁ , ._ , p1 , STORE x ∷ done , eqn | exp'
    with ▷*-deterministic p1 exp'
  ... | _ , eqe , eqs
    rewrite eqs
    with ∷-injective eqe
  ... | eq-cond , e≡[]
    rewrite nat-inj eq-cond
    = ass , e≡[]

  -- Skip
  go size recurse {skip} (NOOP ∷ done) sizeEq = skip , refl
  go size recurse {skip} (NOOP ∷ () ∷ p) sizeEq

  -- Sequencing
  go size recurse {S , S₁} p sizeEq
    with ▷*-split 𝓒⟦ S ⟧ˢ p
  ... | s'' , e'' , p1 , p2 , size+eq
    rewrite sizeEq | sym size+eq
    with recurse _ (a<′a+sb _ _ (▷*-S-nonempty {S = S₁} p2)) {S} p1 refl
  ... | p1' , e''≡[]
    rewrite e''≡[] | +-comm (▷*-length p1) (▷*-length p2)
    with recurse _ (a<′a+sb _ _ (▷*-S-nonempty {S = S} p1)) {S₁} p2 refl
  ... | p2' , e≡[] = (p1' , p2') , e≡[]

  -- If then else
  go size recurse {if b then S else S₁} {e}{s}{s'} p sizeEq
    with ▷*-split 𝓒⟦ b ⟧ᵉ p | 𝓒-Exp-bool {e = []}{s = s} b
  ... | s'' , ._ , p1 , BRANCH ∷ p2 , size+eq | b'
    with ▷*-deterministic p1 b'
  ... | _ , eqe , eqs
    rewrite eqs
    with ∷-injective eqe
  ... | eq-cond , e'≡[]
    rewrite bool-inj eq-cond | e'≡[] |
           proj₂ LM.identity (ifBool ⟦ b ⟧ᵉ s then 𝓒⟦ S ⟧ˢ else 𝓒⟦ S₁ ⟧ˢ)
           | sizeEq | sym size+eq
    with ⟦ b ⟧ᵉ s | inspect ⟦ b ⟧ᵉ s

  ... | true  | [ condTrue  ]
    = (if-true (≡true→T condTrue) (proj₁ rest)) , proj₂ rest
    where rest : ⟨ S , s ⟩⟱ s' × e ≡ []
          rest = recurse (▷*-length p2) (a<′b+sa (▷*-length p2) (▷*-length p1)) p2 refl

  ... | false | [ condFalse ]
    = (if-false (≡false→F condFalse) (proj₁ rest)) , proj₂ rest
    where rest : ⟨ S₁ , s ⟩⟱ s' × e ≡ []
          rest = recurse (▷*-length p2) (a<′b+sa (▷*-length p2) (▷*-length p1)) p2 refl

  -- While
  go size recurse {while b do S}{e}{s}{s'} (LOOP ∷ p) sizeEq
    with 𝓒-Exp-bool {e = []}{s = s} b | ▷*-split 𝓒⟦ b ⟧ᵉ p
  ... | b' | s'' , ._ , p1 , BRANCH ∷ p2 , size+eq
    with ▷*-deterministic p1 b'
  ... | _ , eqe , eqs
    rewrite eqs
    with ∷-injective eqe
  ... | eq-cond , e'≡[]
    rewrite bool-inj eq-cond | e'≡[] |
       proj₂ LM.identity (ifBool ⟦ b ⟧ᵉ s then 𝓒⟦ S ⟧ˢ ++ LOOP 𝓒⟦ b ⟧ᵉ 𝓒⟦ S ⟧ˢ ∷ [] else (NOOP ∷ []))
       | sym size+eq | sizeEq
    with ⟦ b ⟧ᵉ s | inspect ⟦ b ⟧ᵉ s

  {- Here we the proofs are a bit messed up by the two recursive calls with
     hideous hand-crafted proofs of size decrease. This is the sort of thing
     where Coq's solvers and tactics for arithmetic are really handy. Unfortunately
     we don't yet have those things in Agda, although there is some infrastructure
     already in place that could be used to create more automatization (like typeclasses
     and goal reflection)
   -}

  -- while-true
  ... | true  | [ condTrue  ] = 𝓒-while-true condTrue p2 refl
    where
      𝓒-while-true :
        ∀ {s s' : State n}{b e S}
        → ⟦ b ⟧ᵉ s ≡ true
        → (p3 : ⟨ 𝓒⟦ S ⟧ˢ ++ LOOP 𝓒⟦ b ⟧ᵉ 𝓒⟦ S ⟧ˢ ∷ [] , [] , s ⟩▷*⟨ [] , e , s' ⟩)
        → (▷*-length p3 ≡ ▷*-length p2)
        → (⟨ while b do S , s ⟩⟱ s') × e ≡ []
      𝓒-while-true {s}{s'}{b}{e}{S} condTrue p3 ≡len
        with ▷*-split 𝓒⟦ S ⟧ˢ p3
      ... | s'' , e'' , p1_new , p2_new , size+eq
        rewrite sym size+eq
        with recurse (▷*-length p1_new)
          (≤′-step
            (subst (λ x → suc (▷*-length p1_new) ≤′ ▷*-length p1 + suc x) ≡len
               (≤′-weaken-l (▷*-length p1)
                  (≤′-step (a<′a+sb (▷*-length p1_new) (▷*-length p2_new)
                    (▷*-S-nonempty {S = while b do S} p2_new))))))
          {S} p1_new refl

      ... | p1' , e''≡[]
        rewrite e''≡[]
        with recurse (▷*-length p2_new)
          (≤′-step (subst (λ x → suc (▷*-length p2_new) ≤′ ▷*-length p1 + suc x) ≡len
               (≤′-weaken-l (▷*-length p1)
                 (≤′-step (
                   subst
                     (λ x → ▷*-length p2_new <′ x)
                     (+-comm (▷*-length p2_new) (▷*-length p1_new))
                     (a<′a+sb
                         (▷*-length p2_new) (▷*-length p1_new)
                         (▷*-S-nonempty {S = S} p1_new)))))))
          {while b do S} p2_new refl
      ... | p2' , e≡[] = (while-true (≡true→T condTrue) p1' p2') , e≡[]

  -- while-false
  ... | false | [ condFalse ] = 𝓒-while-false condFalse p2
    where
      𝓒-while-false :
        ∀ {n}{s s' : State n}{e b S}
        → ⟦ b ⟧ᵉ s ≡ false
        → ⟨ NOOP ∷ [] , [] , s ⟩▷*⟨ [] , e , s' ⟩
        → (⟨ while b do S , s ⟩⟱ s' × e ≡ [])
      𝓒-while-false f (NOOP ∷ done) = (while-false (≡false→F f)) , refl
      𝓒-while-false f (NOOP ∷ () ∷ p)


module _ where

open import Agda.Primitive

-- Named implicit parameters

data D₁ {a b} (A : Set a) (B : Set b) : Set (a ⊔ lsuc b)
data D₁ {b = c} X Y where
  mkD₁ : Set c → D₁ X Y

-- Trailing implicit parameters

data D₂ {a} : Set a
data D₂ where
  tt : D₂


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.List.Properties where

open import Agda.Builtin.List
open import Cubical.Core.Everything
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Prelude
open import Cubical.Data.Empty as ⊥
open import Cubical.Data.Nat
open import Cubical.Data.Sigma
open import Cubical.Data.Unit
open import Cubical.Relation.Nullary

open import Cubical.Data.List.Base

module _ {ℓ} {A : Type ℓ} where

  ++-unit-r : (xs : List A) → xs ++ [] ≡ xs
  ++-unit-r [] = refl
  ++-unit-r (x ∷ xs) = cong (_∷_ x) (++-unit-r xs)

  ++-assoc : (xs ys zs : List A) → (xs ++ ys) ++ zs ≡ xs ++ ys ++ zs
  ++-assoc [] ys zs = refl
  ++-assoc (x ∷ xs) ys zs = cong (_∷_ x) (++-assoc xs ys zs)

  rev-snoc : (xs : List A) (y : A) → rev (xs ++ [ y ]) ≡ y ∷ rev xs
  rev-snoc [] y = refl
  rev-snoc (x ∷ xs) y = cong (_++ [ x ]) (rev-snoc xs y)

  rev-++ : (xs ys : List A) → rev (xs ++ ys) ≡ rev ys ++ rev xs
  rev-++ [] ys = sym (++-unit-r (rev ys))
  rev-++ (x ∷ xs) ys =
    cong (λ zs → zs ++ [ x ]) (rev-++ xs ys)
    ∙ ++-assoc (rev ys) (rev xs) [ x ]

  rev-rev : (xs : List A) → rev (rev xs) ≡ xs
  rev-rev [] = refl
  rev-rev (x ∷ xs) = rev-snoc (rev xs) x ∙ cong (_∷_ x) (rev-rev xs)

  rev-rev-snoc : (xs : List A) (y : A) →
    Square (rev-rev (xs ++ [ y ])) (cong (_++ [ y ]) (rev-rev xs)) (cong rev (rev-snoc xs y)) refl
  rev-rev-snoc [] y = sym (lUnit refl)
  rev-rev-snoc (x ∷ xs) y i j =
    hcomp
      (λ k → λ
        { (i = i1) → compPath-filler (rev-snoc (rev xs) x) (cong (x ∷_) (rev-rev xs)) k j ++ [ y ]
        ; (j = i0) → rev (rev-snoc xs y i ++ [ x ])
        ; (j = i1) → x ∷ rev-rev-snoc xs y i k
        })
      (rev-snoc (rev-snoc xs y i) x j)

  data SnocView : List A → Type ℓ where
    nil : SnocView []
    snoc : (x : A) → (xs : List A) → (sx : SnocView xs) → SnocView (xs ∷ʳ x)

  snocView : (xs : List A) → SnocView xs
  snocView xs = helper nil xs
    where
    helper : {l : List A} -> SnocView l -> (r : List A) -> SnocView (l ++ r)
    helper {l} sl [] = subst SnocView (sym (++-unit-r l)) sl
    helper {l} sl (x ∷ r) = subst SnocView (++-assoc l (x ∷ []) r) (helper (snoc x l sl) r)

-- Path space of list type
module ListPath {ℓ} {A : Type ℓ} where

  Cover : List A → List A → Type ℓ
  Cover [] [] = Lift Unit
  Cover [] (_ ∷ _) = Lift ⊥
  Cover (_ ∷ _) [] = Lift ⊥
  Cover (x ∷ xs) (y ∷ ys) = (x ≡ y) × Cover xs ys

  reflCode : ∀ xs → Cover xs xs
  reflCode [] = lift tt
  reflCode (_ ∷ xs) = refl , reflCode xs

  encode : ∀ xs ys → (p : xs ≡ ys) → Cover xs ys
  encode xs _ = J (λ ys _ → Cover xs ys) (reflCode xs)

  encodeRefl : ∀ xs → encode xs xs refl ≡ reflCode xs
  encodeRefl xs = JRefl (λ ys _ → Cover xs ys) (reflCode xs)

  decode : ∀ xs ys → Cover xs ys → xs ≡ ys
  decode [] [] _ = refl
  decode [] (_ ∷ _) (lift ())
  decode (x ∷ xs) [] (lift ())
  decode (x ∷ xs) (y ∷ ys) (p , c) = cong₂ _∷_ p (decode xs ys c)

  decodeRefl : ∀ xs → decode xs xs (reflCode xs) ≡ refl
  decodeRefl [] = refl
  decodeRefl (x ∷ xs) = cong (cong₂ _∷_ refl) (decodeRefl xs)

  decodeEncode : ∀ xs ys → (p : xs ≡ ys) → decode xs ys (encode xs ys p) ≡ p
  decodeEncode xs _ =
    J (λ ys p → decode xs ys (encode xs ys p) ≡ p)
      (cong (decode xs xs) (encodeRefl xs) ∙ decodeRefl xs)

  isOfHLevelCover : (n : HLevel) (p : isOfHLevel (suc (suc n)) A)
    (xs ys : List A) → isOfHLevel (suc n) (Cover xs ys)
  isOfHLevelCover n p [] [] =
    isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isPropUnit)
  isOfHLevelCover n p [] (y ∷ ys) =
    isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isProp⊥)
  isOfHLevelCover n p (x ∷ xs) [] =
    isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isProp⊥)
  isOfHLevelCover n p (x ∷ xs) (y ∷ ys) =
    isOfHLevelΣ (suc n) (p x y) (\ _ → isOfHLevelCover n p xs ys)

isOfHLevelList : ∀ {ℓ} (n : HLevel) {A : Type ℓ}
  → isOfHLevel (suc (suc n)) A → isOfHLevel (suc (suc n)) (List A)
isOfHLevelList n ofLevel xs ys =
  isOfHLevelRetract (suc n)
    (ListPath.encode xs ys)
    (ListPath.decode xs ys)
    (ListPath.decodeEncode xs ys)
    (ListPath.isOfHLevelCover n ofLevel xs ys)

private
  variable
    ℓ : Level
    A : Type ℓ

  caseList : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} → (n c : B) → List A → B
  caseList n _ []      = n
  caseList _ c (_ ∷ _) = c

  safe-head : A → List A → A
  safe-head x []      = x
  safe-head _ (x ∷ _) = x

  safe-tail : List A → List A
  safe-tail []       = []
  safe-tail (_ ∷ xs) = xs

cons-inj₁ : ∀ {x y : A} {xs ys} → x ∷ xs ≡ y ∷ ys → x ≡ y
cons-inj₁ {x = x} p = cong (safe-head x) p

cons-inj₂ : ∀ {x y : A} {xs ys} → x ∷ xs ≡ y ∷ ys → xs ≡ ys
cons-inj₂ = cong safe-tail

¬cons≡nil : ∀ {x : A} {xs} → ¬ (x ∷ xs ≡ [])
¬cons≡nil {A = A} p = lower (subst (caseList (Lift ⊥) (List A)) p [])

¬nil≡cons : ∀ {x : A} {xs} → ¬ ([] ≡ x ∷ xs)
¬nil≡cons {A = A} p = lower (subst (caseList (List A) (Lift ⊥)) p [])

¬snoc≡nil : ∀ {x : A} {xs} → ¬ (xs ∷ʳ x ≡ [])
¬snoc≡nil {xs = []} contra = ¬cons≡nil contra
¬snoc≡nil {xs = x ∷ xs} contra = ¬cons≡nil contra

¬nil≡snoc : ∀ {x : A} {xs} → ¬ ([] ≡ xs ∷ʳ x)
¬nil≡snoc contra = ¬snoc≡nil (sym contra)

cons≡rev-snoc : (x : A) → (xs : List A) → x ∷ rev xs ≡ rev (xs ∷ʳ x)
cons≡rev-snoc _ [] = refl
cons≡rev-snoc x (y ∷ ys) = λ i → cons≡rev-snoc x ys i ++ y ∷ []

isContr[]≡[] : isContr (Path (List A) [] [])
isContr[]≡[] = refl , ListPath.decodeEncode [] []

isPropXs≡[] : {xs : List A} → isProp (xs ≡ [])
isPropXs≡[] {xs = []} = isOfHLevelSuc 0 isContr[]≡[]
isPropXs≡[] {xs = x ∷ xs} = λ p _ → ⊥.rec (¬cons≡nil p)

discreteList : Discrete A → Discrete (List A)
discreteList eqA []       []       = yes refl
discreteList eqA []       (y ∷ ys) = no ¬nil≡cons
discreteList eqA (x ∷ xs) []       = no ¬cons≡nil
discreteList eqA (x ∷ xs) (y ∷ ys) with eqA x y | discreteList eqA xs ys
... | yes p | yes q = yes (λ i → p i ∷ q i)
... | yes _ | no ¬q = no (λ p → ¬q (cons-inj₂ p))
... | no ¬p | _     = no (λ q → ¬p (cons-inj₁ q))

foldrCons : (xs : List A) → foldr _∷_ [] xs ≡ xs
foldrCons [] = refl
foldrCons (x ∷ xs) = cong (x ∷_) (foldrCons xs)


open import Data.Bool using ( Bool ; true ; false ; if_then_else_ )
open import Data.Product using ( _×_ ; _,_ )
open import Data.Sum using ( inj₁ ; inj₂ )
open import Relation.Unary using ( _∈_ )
open import Web.Semantic.DL.Concept using ( Concept ; ⟨_⟩ ; ¬⟨_⟩ ; ⊤ ; ⊥ ; _⊓_ ; _⊔_ ; ∀[_]_ ; ∃⟨_⟩_ ; ≤1 ; >1 ; neg )
open import Web.Semantic.DL.Concept.Model using ( _⟦_⟧₁ ; ⟦⟧₁-resp-≈ )
open import Web.Semantic.DL.FOL using  ( Formula ; true ; false ; _∧_ ; _∈₁_ ; _∈₂_ ; _∈₁_⇒_ ; _∼_ ; _∼_⇒_ ; ∀₁ )
open import Web.Semantic.DL.FOL.Model using ( _⊨f_ )
open import Web.Semantic.DL.Role.Skolemization using ( rskolem ; rskolem⇒ ; rskolem-sound ; rskolem⇒-sound )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.Util using ( True ; tt )

module Web.Semantic.DL.Concept.Skolemization {Σ : Signature} where

CSkolems : Set → Concept Σ → Set
CSkolems Δ ⟨ c ⟩ = True
CSkolems Δ ¬⟨ c ⟩ = True
CSkolems Δ ⊤ = True
CSkolems Δ ⊥ = True
CSkolems Δ (C ⊓ D) = (CSkolems Δ C) × (CSkolems Δ D)
CSkolems Δ (C ⊔ D) = (Δ → Bool) × (CSkolems Δ C) × (CSkolems Δ D)
CSkolems Δ (∀[ R ] C) = CSkolems Δ C
CSkolems Δ (∃⟨ R ⟩ C) = (Δ → Δ) × (CSkolems Δ C)
CSkolems Δ (≤1 R) = True
CSkolems Δ (>1 R) = (Δ → Δ) × (Δ → Δ)

cskolem : ∀ {Δ} C → (CSkolems Δ C) → Δ → Formula Σ Δ
cskolem ⟨ c ⟩ Φ x = x ∈₁ c
cskolem ¬⟨ c ⟩ Φ x = x ∈₁ c ⇒ false
cskolem ⊤ Φ x = true
cskolem ⊥ Φ x = false
cskolem (C ⊓ D) (Φ , Ψ) x = (cskolem C Φ x) ∧ (cskolem D Ψ x)
cskolem (C ⊔ D) (φ , Φ , Ψ) x = if (φ x) then (cskolem C Φ x) else (cskolem D Ψ x)
cskolem (∀[ R ] C) Φ x = ∀₁ λ y → rskolem⇒ R x y (cskolem C Φ y)
cskolem (∃⟨ R ⟩ C) (φ , Ψ) x = (rskolem R x (φ x)) ∧ (cskolem C Ψ (φ x))
cskolem (≤1 R) Φ x = ∀₁ λ y → ∀₁ λ z → rskolem⇒ R x y (rskolem⇒ R x z (y ∼ z))
cskolem (>1 R) (φ , ψ) x = (rskolem R x (φ x)) ∧ (rskolem R x (ψ x)) ∧ (φ x ∼ ψ x ⇒ false)

cskolem-sound : ∀ I C Φ x → (I ⊨f cskolem C Φ x) → (x ∈ I ⟦ C ⟧₁)
cskolem-sound I ⟨ c ⟩ Φ x x∈⟦c⟧ = x∈⟦c⟧
cskolem-sound I ¬⟨ c ⟩ Φ x x∉⟦c⟧ = x∉⟦c⟧
cskolem-sound I ⊤ Φ x _ = tt
cskolem-sound I ⊥ Φ x ()
cskolem-sound I (C ⊓ D) (Φ , Ψ) x (Fx , Gx) =
  (cskolem-sound I C Φ x Fx , cskolem-sound I D Ψ x Gx)
cskolem-sound I (C ⊔ D) (φ , Φ , Ψ) x  F∨Gx with φ x
cskolem-sound I (C ⊔ D) (φ , Φ , Ψ) x  Fx | true  = inj₁ (cskolem-sound I C Φ x Fx)
cskolem-sound I (C ⊔ D) (φ , Φ , Ψ) x  Gx | false = inj₂ (cskolem-sound I D Ψ x Gx)
cskolem-sound I (∀[ R ] C) Φ x ∀RFx =
  λ y xy∈R → cskolem-sound I C Φ y (rskolem⇒-sound I R x y (cskolem C Φ y) (∀RFx y) xy∈R)
cskolem-sound I (∃⟨ R ⟩ C) (φ , Ψ) x (xy∈R , Fy) =
  ( φ x , rskolem-sound I R x (φ x) xy∈R , cskolem-sound I C Ψ (φ x) Fy )
cskolem-sound I (≤1 R) Φ x ≤1Rx =
  λ y z xy∈R xz∈R → rskolem⇒-sound I R x z (y ∼ z)
    (rskolem⇒-sound I R x y (rskolem⇒ R x z (y ∼ z)) (≤1Rx y z) xy∈R) xz∈R
cskolem-sound I (>1 R) (φ , ψ) x  (xy∈R , xz∈R , y≁z) =
  (φ x , ψ x , rskolem-sound I R x (φ x) xy∈R , rskolem-sound I R x (ψ x) xz∈R , y≁z)


{-

A Cubical proof of Blakers-Massey Theorem (KANG Rongji, Oct. 2021)

Based on the previous type-theoretic proof described in
  Kuen-Bang Hou (Favonia), Eric Finster, Dan Licata, Peter LeFanu Lumsdaine,
  "A Mechanization of the Blakers–Massey Connectivity Theorem in Homotopy Type Theory"
  (https://arxiv.org/abs/1605.03227)

Also the HoTT-Agda formalization by Favonia:
  (https://github.com/HoTT/HoTT-Agda/blob/master/theorems/homotopy/BlakersMassey.agda)

Using cubes explicitly as much as possible.

-}
{-# OPTIONS  --safe #-}
module Cubical.Homotopy.BlakersMassey where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Transport
open import Cubical.Foundations.HLevels

open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.Properties
open import Cubical.Foundations.Isomorphism
open Iso
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Function
open import Cubical.Foundations.Equiv.HalfAdjoint

open import Cubical.Data.Nat hiding (elim)
open import Cubical.Data.Sigma
open import Cubical.Data.Unit

open import Cubical.HITs.Truncation renaming (hLevelTrunc to Trunc)
open import Cubical.HITs.Pushout hiding (PushoutGenFib)

open import Cubical.Homotopy.Connected
open import Cubical.Homotopy.WedgeConnectivity

module BlakersMassey {ℓ₁ ℓ₂ ℓ₃ : Level}
  (X : Type ℓ₁)(Y : Type ℓ₂)(Q : X → Y → Type ℓ₃)
  {m : HLevel} (leftConn  : (x : X) → isConnected (1 + m) (Σ[ y ∈ Y ] Q x y))
  {n : HLevel} (rightConn : (y : Y) → isConnected (1 + n) (Σ[ x ∈ X ] Q x y))
  where

  ℓ : Level
  ℓ = ℓ-max (ℓ-max ℓ₁ ℓ₂) ℓ₃

  leftFiber  : X → Type (ℓ-max ℓ₂ ℓ₃)
  leftFiber x  = Σ[ y ∈ Y ] Q x y

  rightFiber : Y → Type (ℓ-max ℓ₁ ℓ₃)
  rightFiber y = Σ[ x ∈ X ] Q x y

  {- We use the alternative formulation of pushout with fewer parameters -}

  PushoutQ = PushoutGen Q

  {- Some preliminary definitions for convenience -}

  fiberSquare :
      {x₀ x₁ : X}{y₀ : Y}{p : PushoutQ}(q₀₀ : Q x₀ y₀)(q₁₀ : Q x₁ y₀)
    → inl x₁ ≡ p → inl x₀ ≡ p → Type ℓ
  fiberSquare q₀₀ q₁₀ r' r = PathP (λ i → push q₀₀ (~ i) ≡ r' i) (sym (push q₁₀)) r

  fiberSquarePush :
      {x₀ x₁ : X}{y₀ y₁ : Y}(q₀₀ : Q x₀ y₀)(q₁₀ : Q x₁ y₀)(q₁₁ : Q x₁ y₁)
    → inl x₀ ≡ inr y₁ → Type ℓ
  fiberSquarePush q₀₀ q₁₀ q₁₁ = fiberSquare q₀₀ q₁₀ (push q₁₁)

  fiber' : {x₀ : X}{y₀ : Y}(q₀₀ : Q x₀ y₀){x₁ : X}{p : PushoutQ} → inl x₁ ≡ p → inl x₀ ≡ p → Type ℓ
  fiber' {y₀ = y₀} q₀₀ {x₁ = x₁} r' r = Σ[ q₁₀ ∈ Q x₁ y₀ ] fiberSquare q₀₀ q₁₀ r' r

  fiber'Push : {x₀ x₁ : X}{y₀ y₁ : Y}(q₀₀ : Q x₀ y₀)(q₁₁ : Q x₁ y₁) → inl x₀ ≡ inr y₁ → Type ℓ
  fiber'Push q₀₀ q₁₁ = fiber' q₀₀ (push q₁₁)

  leftCodeExtended :
      {x₀ : X}{y₀ : Y}(q₀₀ : Q x₀ y₀)
    → (x₁ : X){p : PushoutQ} → inl x₁ ≡ p → inl x₀ ≡ p → Type ℓ
  leftCodeExtended {y₀ = y₀} q₀₀ x₁ r' r = Trunc (m + n) (fiber' q₀₀ r' r)

  rightCode : {x₀ : X}(y : Y) → Path PushoutQ (inl x₀) (inr y) → Type ℓ
  rightCode y r = Trunc (m + n) (fiber push r)

  {- Bunch of coherence data that will be used to construct Code -}

  {- Definitions of fiber→ -}

  module _
    {x₁ : X}{y₀ : Y}(q₁₀ : Q x₁ y₀) where

    {- (x₀ , q₀₀) = (x₁ , q₁₀) -}
    module _
      {y₁ : Y}(q₁₁ : Q x₁ y₁)
      (r : inl x₁ ≡ inr y₁)
      (p : fiberSquarePush q₁₀ q₁₀ q₁₁ r) where

      fiber→[q₀₀=q₁₀]-filler : (i j k : I) → PushoutQ
      fiber→[q₀₀=q₁₀]-filler i j k' =
        hfill (λ k → λ { (i = i0) → push q₁₁ (j ∧ k)
                       ; (i = i1) → p k j
                       ; (j = i0) → push q₁₀ (i ∧ ~ k)
                       ; (j = i1) → push q₁₁ k })
              (inS (push q₁₀ (i ∧ ~ j))) k'

      fiber→[q₀₀=q₁₀] : fiber push r
      fiber→[q₀₀=q₁₀] .fst = q₁₁
      fiber→[q₀₀=q₁₀] .snd i j = fiber→[q₀₀=q₁₀]-filler i j i1

      ∣fiber→[q₀₀=q₁₀]∣ : rightCode _ r
      ∣fiber→[q₀₀=q₁₀]∣ = ∣ fiber→[q₀₀=q₁₀] ∣ₕ

    {- (y₁ , q₁₁) = (y₀ , q₁₀) -}
    module _
      {x₀ : X}(q₀₀ : Q x₀ y₀)
      (r : inl x₀ ≡ inr y₀)
      (p : fiberSquarePush q₀₀ q₁₀ q₁₀ r) where

      fiber→[q₁₁=q₁₀]-filler : (i j k : I) → PushoutQ
      fiber→[q₁₁=q₁₀]-filler i j k' =
        hfill (λ k → λ { (i = i0) → push q₀₀ (j ∨ ~ k)
                       ; (i = i1) → p k j
                       ; (j = i0) → push q₀₀ (~ k)
                       ; (j = i1) → push q₁₀ (~ i ∨ k) })
              (inS (push q₁₀ (~ i ∨ ~ j))) k'

      fiber→[q₁₁=q₁₀] : fiber push r
      fiber→[q₁₁=q₁₀] .fst = q₀₀
      fiber→[q₁₁=q₁₀] .snd i j = fiber→[q₁₁=q₁₀]-filler i j i1

      ∣fiber→[q₁₁=q₁₀]∣ : rightCode _ r
      ∣fiber→[q₁₁=q₁₀]∣ = ∣ fiber→[q₁₁=q₁₀] ∣ₕ

    {- q₀₀ = q₁₁ = q₁₀ -}
    fiber→[q₀₀=q₁₀=q₁₁]-filler :
        (r : inl x₁ ≡ inr y₀)
      → (p : fiberSquarePush q₁₀ q₁₀ q₁₀ r)
      → (i j k l : I) → PushoutQ
    fiber→[q₀₀=q₁₀=q₁₁]-filler r p i j k l' =
      hfill (λ l → λ { (i = i0) → fiber→[q₀₀=q₁₀]-filler q₁₀ r p j k l
                     ; (i = i1) → fiber→[q₁₁=q₁₀]-filler q₁₀ r p j k l
                     ; (j = i0) → push q₁₀ ((i ∨ (k ∧ l)) ∧ (k ∨ (i ∧ ~ l)))
                     ; (j = i1) → p l k
                     ; (k = i0) → push q₁₀ ((i ∨ j) ∧ ~ l)
                     ; (k = i1) → push q₁₀ ((i ∧ ~ j) ∨ l) })
            (inS (push q₁₀ ((i ∨ (~ k ∧ j)) ∧ (~ k ∨ (i ∧ ~ j))))) l'

    fiber→[q₀₀=q₁₀=q₁₁] : fiber→[q₀₀=q₁₀] q₁₀ ≡ fiber→[q₁₁=q₁₀] q₁₀
    fiber→[q₀₀=q₁₀=q₁₁] i r p .fst = q₁₀
    fiber→[q₀₀=q₁₀=q₁₁] i r p .snd j k = fiber→[q₀₀=q₁₀=q₁₁]-filler r p i j k i1

    ∣fiber→[q₀₀=q₁₀=q₁₁]∣ : ∣fiber→[q₀₀=q₁₀]∣ q₁₀ ≡ ∣fiber→[q₁₁=q₁₀]∣ q₁₀
    ∣fiber→[q₀₀=q₁₀=q₁₁]∣ i r p = ∣ fiber→[q₀₀=q₁₀=q₁₁] i r p ∣ₕ

  {- Definitions of fiber← -}

  module _
    {x₀ : X}{y₁ : Y}(q₀₁ : Q x₀ y₁) where

    {- (x₁ , q₁₁) = (x₀ , q₀₁) -}
    module _
      {y₀ : Y}(q₀₀ : Q x₀ y₀)
      (r : inl x₀ ≡ inr y₁)
      (p : push q₀₁ ≡ r) where

      fiber←[q₁₁=q₀₁]-filler : (i j k : I) → PushoutQ
      fiber←[q₁₁=q₀₁]-filler i j k' =
        hfill (λ k → λ { (i = i0) → push q₀₀ (~ j ∧ k)
                       ; (i = i1) → p k j
                       ; (j = i0) → push q₀₀ (~ i ∧ k)
                       ; (j = i1) → push q₀₁ i })
              (inS (push q₀₁ (i ∧ j))) k'

      fiber←[q₁₁=q₀₁] : fiber'Push  q₀₀ q₀₁ r
      fiber←[q₁₁=q₀₁] .fst = q₀₀
      fiber←[q₁₁=q₀₁] .snd i j = fiber←[q₁₁=q₀₁]-filler i j i1

      ∣fiber←[q₁₁=q₀₁]∣ : leftCodeExtended q₀₀ _ (push q₀₁) r
      ∣fiber←[q₁₁=q₀₁]∣ = ∣ fiber←[q₁₁=q₀₁] ∣ₕ

    {- (y₀ , q₀₀) = (y₁ , q₀₁) -}
    module _
      {x₁ : X}(q₁₁ : Q x₁ y₁)
      (r : inl x₀ ≡ inr y₁)
      (p : push q₀₁ ≡ r) where

      fiber←[q₀₀=q₀₁]-filler : (i j k : I) → PushoutQ
      fiber←[q₀₀=q₀₁]-filler i j k' =
        hfill (λ k → λ { (i = i0) → push q₁₁ (~ j ∨ ~ k)
                       ; (i = i1) → p k j
                       ; (j = i0) → push q₀₁ (~ i)
                       ; (j = i1) → push q₁₁ (i ∨ ~ k) })
              (inS (push q₀₁ (~ i ∨ j))) k'

      fiber←[q₀₀=q₀₁] : fiber'Push q₀₁ q₁₁ r
      fiber←[q₀₀=q₀₁] .fst = q₁₁
      fiber←[q₀₀=q₀₁] .snd i j = fiber←[q₀₀=q₀₁]-filler i j i1

      ∣fiber←[q₀₀=q₀₁]∣ : leftCodeExtended q₀₁ _ (push q₁₁) r
      ∣fiber←[q₀₀=q₀₁]∣ = ∣ fiber←[q₀₀=q₀₁] ∣ₕ

    {- q₀₀ = q₀₁ = q₁₁ -}
    fiber←[q₀₀=q₀₁=q₁₁]-filler :
        (r : inl x₀ ≡ inr y₁)
      → (p : push q₀₁ ≡ r)
      → (i j k l : I) → PushoutQ
    fiber←[q₀₀=q₀₁=q₁₁]-filler r p i j k l' =
      hfill (λ l → λ { (i = i0) → fiber←[q₁₁=q₀₁]-filler q₀₁ r p j k l
                     ; (i = i1) → fiber←[q₀₀=q₀₁]-filler q₀₁ r p j k l
                     ; (j = i0) → push q₀₁ ((i ∨ (~ k ∧ l)) ∧ (~ k ∨ (i ∧ ~ l)))
                     ; (j = i1) → p l k
                     ; (k = i0) → push q₀₁ ((i ∨ l) ∧ ~ j)
                     ; (k = i1) → push q₀₁ ((i ∧ ~ l) ∨ j) })
            (inS (push q₀₁ ((i ∨ (k ∧ j)) ∧ (k ∨ (i ∧ ~ j))))) l'

    fiber←[q₀₀=q₀₁=q₁₁] : fiber←[q₁₁=q₀₁] q₀₁ ≡ fiber←[q₀₀=q₀₁] q₀₁
    fiber←[q₀₀=q₀₁=q₁₁] i r p .fst = q₀₁
    fiber←[q₀₀=q₀₁=q₁₁] i r p .snd j k = fiber←[q₀₀=q₀₁=q₁₁]-filler r p i j k i1

    ∣fiber←[q₀₀=q₀₁=q₁₁]∣ : ∣fiber←[q₁₁=q₀₁]∣ q₀₁ ≡ ∣fiber←[q₀₀=q₀₁]∣ q₀₁
    ∣fiber←[q₀₀=q₀₁=q₁₁]∣ i r p = ∣ fiber←[q₀₀=q₀₁=q₁₁] i r p ∣ₕ

  {- Definitions of fiber→← -}

  module _
    {x₁ : X}{y₀ : Y}(q₁₀ : Q x₁ y₀) where

    {- (x₀ , q₀₀) = (x₁ , q₁₀) -}
    module _
      {y₁ : Y}(q₁₁ : Q x₁ y₁)
      (r : inl x₁ ≡ inr y₁)
      (p : fiberSquarePush q₁₀ q₁₀ q₁₁ r) where

      fiber→←[q₀₀=q₁₀]-filler : (i j k l : I) → PushoutQ
      fiber→←[q₀₀=q₁₀]-filler i j k l' =
        let p' = fiber→[q₀₀=q₁₀] q₁₀ q₁₁ r p .snd in
        hfill (λ l → λ { (i = i0) → fiber←[q₁₁=q₀₁]-filler q₁₁ q₁₀ r p' j k l
                       ; (i = i1) → fiber→[q₀₀=q₁₀]-filler q₁₀ q₁₁ r p l k j
                       ; (j = i0) → push q₁₀ (~ k ∧ l)
                       ; (j = i1) → p' l k
                       ; (k = i0) → push q₁₀ (~ j ∧ l)
                       ; (k = i1) → push q₁₁ j })
              (inS (push q₁₁ (j ∧ k))) l'

      fiber→←[q₀₀=q₁₀] : fiber←[q₁₁=q₀₁] q₁₁ q₁₀ r (fiber→[q₀₀=q₁₀] q₁₀ q₁₁ r p .snd) .snd ≡ p
      fiber→←[q₀₀=q₁₀] i j k = fiber→←[q₀₀=q₁₀]-filler i j k i1

    {- (y₁ , q₁₁) = (y₀ , q₁₀) -}
    module _
      {x₀ : X}(q₀₀ : Q x₀ y₀)
      (r : inl x₀ ≡ inr y₀)
      (p : fiberSquarePush q₀₀ q₁₀ q₁₀ r) where

      fiber→←[q₁₁=q₁₀]-filler : (i j k l : I) → PushoutQ
      fiber→←[q₁₁=q₁₀]-filler i j k l' =
        let p' = fiber→[q₁₁=q₁₀] q₁₀ q₀₀ r p .snd in
        hfill (λ l → λ { (i = i0) → fiber←[q₀₀=q₀₁]-filler q₀₀ q₁₀ r p' j k l
                       ; (i = i1) → fiber→[q₁₁=q₁₀]-filler q₁₀ q₀₀ r p l k j
                       ; (j = i0) → push q₁₀ (~ k ∨ ~ l)
                       ; (j = i1) → p' l k
                       ; (k = i0) → push q₀₀ (~ j)
                       ; (k = i1) → push q₁₀ (j ∨ ~ l) })
              (inS (push q₀₀ (~ j ∨ k))) l'

      fiber→←[q₁₁=q₁₀] : fiber←[q₀₀=q₀₁] q₀₀ q₁₀ r (fiber→[q₁₁=q₁₀] q₁₀ q₀₀ r p .snd) .snd ≡ p
      fiber→←[q₁₁=q₁₀] i j k = fiber→←[q₁₁=q₁₀]-filler i j k i1

    {- q₀₀ = q₁₀ = q₁₁ -}
    fiber→←hypercube :
        (r : inl x₁ ≡ inr y₀)
      → (p : fiberSquarePush q₁₀ q₁₀ q₁₀ r)
      → PathP (λ i → fiber←[q₀₀=q₀₁=q₁₁] q₁₀ i r (fiber→[q₀₀=q₁₀=q₁₁] q₁₀ i r p .snd) .snd ≡ p)
              (fiber→←[q₀₀=q₁₀] q₁₀ r p) (fiber→←[q₁₁=q₁₀] q₁₀ r p)
    fiber→←hypercube r p i j u v =
      hcomp (λ l → λ { (i = i0) → fiber→←[q₀₀=q₁₀]-filler q₁₀ r p j u v l
                     ; (i = i1) → fiber→←[q₁₁=q₁₀]-filler q₁₀ r p j u v l
                     ; (j = i0) → fiber←[q₀₀=q₀₁=q₁₁]-filler q₁₀ r (fiber→[q₀₀=q₁₀=q₁₁] q₁₀ i r p .snd) i u v l
                     ; (j = i1) → fiber→[q₀₀=q₁₀=q₁₁]-filler q₁₀ r p i l v u
                     ; (u = i0) → push q₁₀ ((i ∨ (~ v ∧ l)) ∧ (~ v ∨ (i ∧ ~ l)))
                     ; (u = i1) → fiber→[q₀₀=q₁₀=q₁₁] q₁₀ i r p .snd l v
                     ; (v = i0) → push q₁₀ ((i ∨ l) ∧ ~ u)
                     ; (v = i1) → push q₁₀ ((i ∧ ~ l) ∨ u) })
            (push q₁₀ ((i ∨ (v ∧ u)) ∧ (v ∨ (i ∧ ~ u))))

  {- Definitions of fiber←→ -}

  module _
    {x₀ : X}{y₁ : Y}(q₀₁ : Q x₀ y₁) where

    {- (x₁ , q₁₁) = (x₀ , q₀₁) -}
    module _
      {y₀ : Y}(q₀₀ : Q x₀ y₀)
      (r : inl x₀ ≡ inr y₁)
      (p : push q₀₁ ≡ r) where

      fiber←→[q₁₁=q₀₁]-filler : (i j k l : I) → PushoutQ
      fiber←→[q₁₁=q₀₁]-filler i j k l' =
        let p' = fiber←[q₁₁=q₀₁] q₀₁ q₀₀ r p .snd in
        hfill (λ l → λ { (i = i0) → fiber→[q₀₀=q₁₀]-filler q₀₀ q₀₁ r p' j k l
                       ; (i = i1) → fiber←[q₁₁=q₀₁]-filler q₀₁ q₀₀ r p l k j
                       ; (j = i0) → push q₀₁ (k ∧ l)
                       ; (j = i1) → p' l k
                       ; (k = i0) → push q₀₀ (j ∧ ~ l)
                       ; (k = i1) → push q₀₁ l })
              (inS (push q₀₀ (j ∧ ~ k))) l'

      fiber←→[q₁₁=q₀₁] : fiber→[q₀₀=q₁₀] q₀₀ q₀₁ r (fiber←[q₁₁=q₀₁] q₀₁ q₀₀ r p .snd) .snd ≡ p
      fiber←→[q₁₁=q₀₁] i j k = fiber←→[q₁₁=q₀₁]-filler i j k i1

    {- (y₀ , q₀₀) = (y₁ , q₀₁) -}
    module _
      {x₁ : X}(q₁₁ : Q x₁ y₁)
      (r : inl x₀ ≡ inr y₁)
      (p : push q₀₁ ≡ r) where

      fiber←→[q₀₀=q₀₁]-filler : (i j k l : I) → PushoutQ
      fiber←→[q₀₀=q₀₁]-filler i j k l' =
        let p' = fiber←[q₀₀=q₀₁] q₀₁ q₁₁ r p .snd in
        hfill (λ l → λ { (i = i0) → fiber→[q₁₁=q₁₀]-filler q₁₁ q₀₁ r p' j k l
                       ; (i = i1) → fiber←[q₀₀=q₀₁]-filler q₀₁ q₁₁ r p l k j
                       ; (j = i0) → push q₀₁ (k ∨ ~ l)
                       ; (j = i1) → p' l k
                       ; (k = i0) → push q₀₁ (~ l)
                       ; (k = i1) → push q₁₁ (~ j ∨ l) })
              (inS (push q₁₁ (~ j ∨ ~ k))) l'

      fiber←→[q₀₀=q₀₁] : fiber→[q₁₁=q₁₀] q₁₁ q₀₁ r (fiber←[q₀₀=q₀₁] q₀₁ q₁₁ r p .snd) .snd ≡ p
      fiber←→[q₀₀=q₀₁] i j k = fiber←→[q₀₀=q₀₁]-filler i j k i1

    {- q₀₀ = q₀₁ = q₁₁ -}
    fiber←→hypercube :
        (r : inl x₀ ≡ inr y₁)
      → (p : push q₀₁ ≡ r)
      → PathP (λ i → fiber→[q₀₀=q₁₀=q₁₁] q₀₁ i r (fiber←[q₀₀=q₀₁=q₁₁] q₀₁ i r p .snd) .snd ≡ p)
              (fiber←→[q₁₁=q₀₁] q₀₁ r p) (fiber←→[q₀₀=q₀₁] q₀₁ r p)
    fiber←→hypercube r p i j u v =
      hcomp (λ l → λ { (i = i0) → fiber←→[q₁₁=q₀₁]-filler q₀₁ r p j u v l
                     ; (i = i1) → fiber←→[q₀₀=q₀₁]-filler q₀₁ r p j u v l
                     ; (j = i0) → fiber→[q₀₀=q₁₀=q₁₁]-filler q₀₁ r (fiber←[q₀₀=q₀₁=q₁₁] q₀₁ i r p .snd) i u v l
                     ; (j = i1) → fiber←[q₀₀=q₀₁=q₁₁]-filler q₀₁ r p i l v u
                     ; (u = i0) → push q₀₁ ((i ∨ (v ∧ l)) ∧ (v ∨ (i ∧ ~ l)))
                     ; (u = i1) → fiber←[q₀₀=q₀₁=q₁₁] q₀₁ i r p .snd l v
                     ; (v = i0) → push q₀₁ ((i ∨ u) ∧ ~ l)
                     ; (v = i1) → push q₀₁ ((i ∧ ~ u) ∨ l) })
           (push q₀₁ ((i ∨ (~ v ∧ u)) ∧ (~ v ∨ (i ∧ ~ u))))

  module Fiber→
    {x₁ : X}{y₀ : Y}(q₁₀ : Q x₁ y₀) =
    WedgeConnectivity m n
      (leftFiber  x₁ , (y₀ , q₁₀)) (leftConn  x₁)
      (rightFiber y₀ , (x₁ , q₁₀)) (rightConn y₀)
      (λ (y₁ , q₁₁) (x₀ , q₀₀) →
        (((r : inl x₀ ≡ inr y₁) → fiberSquarePush q₀₀ q₁₀ q₁₁ r → rightCode _ r)
        , isOfHLevelΠ2 _ (λ x y → isOfHLevelTrunc _)))
      (λ (y₁ , q₁₁) → ∣fiber→[q₀₀=q₁₀]∣ q₁₀ q₁₁)
      (λ (x₀ , q₀₀) → ∣fiber→[q₁₁=q₁₀]∣ q₁₀ q₀₀)
      (∣fiber→[q₀₀=q₁₀=q₁₁]∣ q₁₀)

  fiber→ :
      {x₁ : X}{y₀ : Y}(q₁₀ : Q x₁ y₀)
    → {x₀ : X}(q₀₀ : Q x₀ y₀) → {y₁ : Y}(q₁₁ : Q x₁ y₁)
    → (r : inl x₀ ≡ inr y₁)
    → fiberSquarePush q₀₀ q₁₀ q₁₁ r → rightCode _ r
  fiber→ q₁₀ q₀₀ q₁₁ = Fiber→.extension q₁₀ (_ , q₁₁) (_ , q₀₀)

  module Fiber←
    {x₀ : X}{y₁ : Y}(q₀₁ : Q x₀ y₁) =
    WedgeConnectivity m n
      (leftFiber  x₀ , (y₁ , q₀₁)) (leftConn  x₀)
      (rightFiber y₁ , (x₀ , q₀₁)) (rightConn y₁)
      (λ (y₀ , q₀₀) (x₁ , q₁₁) →
        (((r : inl x₀ ≡ inr y₁) → push q₀₁ ≡ r → leftCodeExtended q₀₀ _ (push q₁₁) r)
        , isOfHLevelΠ2 _ (λ x y → isOfHLevelTrunc _)))
      (λ (y₀ , q₀₀) → ∣fiber←[q₁₁=q₀₁]∣ q₀₁ q₀₀)
      (λ (x₁ , q₁₁) → ∣fiber←[q₀₀=q₀₁]∣ q₀₁ q₁₁)
      (∣fiber←[q₀₀=q₀₁=q₁₁]∣ q₀₁)

  fiber← :
      {x₀ : X}{y₁ : Y}(q₀₁ : Q x₀ y₁)
    → {y₀ : Y}(q₀₀ : Q x₀ y₀) → {x₁ : X}(q₁₁ : Q x₁ y₁)
    → (r : inl x₀ ≡ inr y₁)
    → push q₀₁ ≡ r → leftCodeExtended q₀₀ _ (push q₁₁) r
  fiber← q₀₁ q₀₀ q₁₁ = Fiber←.extension q₀₁ (_ , q₀₀) (_ , q₁₁)

  module _
    {x₀ x₁ : X}{y₀ y₁ : Y}
    (q₀₀ : Q x₀ y₀)(q₁₁ : Q x₁ y₁)
    (r : inl x₀ ≡ inr y₁) where

    left→rightCodeExtended : leftCodeExtended q₀₀ _ (push q₁₁) r → rightCode _ r
    left→rightCodeExtended =
      rec (isOfHLevelTrunc _) (λ (q₁₀ , p) → fiber→ q₁₀ q₀₀ q₁₁ r p)

    right→leftCodeExtended : rightCode _ r → leftCodeExtended q₀₀ _ (push q₁₁) r
    right→leftCodeExtended =
      rec (isOfHLevelTrunc _) (λ (q₀₁ , p) → fiber← q₀₁ q₀₀ q₁₁ r p)

  {- Definition of one-side homotopy -}

  module _
    {x₁ : X}{y₀ : Y}(q₁₀ : Q x₁ y₀) where

    {- (x₀ , q₀₀) = (x₁ , q₁₀) -}
    module _
      {y₁ : Y}(q₁₁ : Q x₁ y₁)
      (r : inl x₁ ≡ inr y₁)
      (p : fiberSquarePush q₁₀ q₁₀ q₁₁ r) where

      ∣fiber→←[q₀₀=q₁₀]∣ : right→leftCodeExtended q₁₀ q₁₁ r (fiber→ q₁₀ q₁₀ q₁₁ r p) ≡ ∣ q₁₀ , p ∣ₕ
      ∣fiber→←[q₀₀=q₁₀]∣ =
          (λ i → right→leftCodeExtended q₁₀ q₁₁ r (Fiber→.left q₁₀ (_ , q₁₁) i r p))
        ∙ recUniq {n = m + n} _ _ _
        ∙ (λ i → Fiber←.left q₁₁ (_ , q₁₀) i r (fiber→[q₀₀=q₁₀] q₁₀ q₁₁ r p .snd))
        ∙ (λ i → ∣ q₁₀ , fiber→←[q₀₀=q₁₀] q₁₀ q₁₁ r p i ∣ₕ)

    {- (y₁ , q₁₁) = (y₀ , q₁₀) -}
    module _
      {x₀ : X}(q₀₀ : Q x₀ y₀)
      (r : inl x₀ ≡ inr y₀)
      (p : fiberSquarePush q₀₀ q₁₀ q₁₀ r) where

      ∣fiber→←[q₁₁=q₁₀]∣ : right→leftCodeExtended q₀₀ q₁₀ r (fiber→ q₁₀ q₀₀ q₁₀ r p) ≡ ∣ q₁₀ , p ∣ₕ
      ∣fiber→←[q₁₁=q₁₀]∣ =
          (λ i → right→leftCodeExtended q₀₀ q₁₀ r (Fiber→.right q₁₀ (_ , q₀₀) i r p))
        ∙ recUniq {n = m + n} _ _ _
        ∙ (λ i → Fiber←.right q₀₀ (_ , q₁₀) i r (fiber→[q₁₁=q₁₀] q₁₀ q₀₀ r p .snd))
        ∙ (λ i → ∣ q₁₀ , fiber→←[q₁₁=q₁₀] q₁₀ q₀₀ r p i ∣ₕ)

    {- q₀₀ = q₁₁ = q₁₀ -}
    module _
      (r : inl x₁ ≡ inr y₀)
      (p : fiberSquarePush q₁₀ q₁₀ q₁₀ r) where

      path→←Square =
           (λ i j → right→leftCodeExtended q₁₀ q₁₀ r (Fiber→.homSquare q₁₀ i j r p))
        ∙₂ (λ i → recUniq {n = m + n} _ _ _)
        ∙₂ (λ i j → Fiber←.homSquare q₁₀ i j r (fiber→[q₀₀=q₁₀=q₁₁] q₁₀ i r p .snd))
        ∙₂ (λ i j → ∣ (q₁₀ , fiber→←hypercube q₁₀ r p i j) ∣ₕ)

    ∣fiber→←[q₀₀=q₁₀=q₁₁]∣ : ∣fiber→←[q₀₀=q₁₀]∣ q₁₀ ≡ ∣fiber→←[q₁₁=q₁₀]∣ q₁₀
    ∣fiber→←[q₀₀=q₁₀=q₁₁]∣ i r p = path→←Square r p i

  fiber→← :
      {x₁ : X}{y₀ : Y}(q₁₀ : Q x₁ y₀)
    → {x₀ : X}(q₀₀ : Q x₀ y₀) → {y₁ : Y}(q₁₁ : Q x₁ y₁)
    → (r : inl x₀ ≡ inr y₁)
    → (p : fiberSquarePush q₀₀ q₁₀ q₁₁ r)
    → right→leftCodeExtended q₀₀ q₁₁ r (fiber→ q₁₀ q₀₀ q₁₁ r p) ≡ ∣ q₁₀ , p ∣ₕ
  fiber→← {x₁ = x₁} {y₀ = y₀} q₁₀ q₀₀' q₁₁' =
    WedgeConnectivity.extension m n
      (leftFiber  x₁ , (y₀ , q₁₀)) (leftConn  x₁)
      (rightFiber y₀ , (x₁ , q₁₀)) (rightConn y₀)
      (λ (y₁ , q₁₁) (x₀ , q₀₀) →
        ((  (r : inl x₀ ≡ inr y₁) → (p : fiberSquarePush q₀₀ q₁₀ q₁₁ r)
          → right→leftCodeExtended q₀₀ q₁₁ r (fiber→ q₁₀ q₀₀ q₁₁ r p) ≡ ∣ q₁₀ , p ∣ₕ )
        , isOfHLevelΠ2 _ (λ x y → isOfHLevelTruncPath)))
      (λ (y₁ , q₁₁) → ∣fiber→←[q₀₀=q₁₀]∣ q₁₀ q₁₁)
      (λ (x₀ , q₀₀) → ∣fiber→←[q₁₁=q₁₀]∣ q₁₀ q₀₀)
      (∣fiber→←[q₀₀=q₁₀=q₁₁]∣ q₁₀)
      (_ , q₁₁') (_ , q₀₀')

  {- Definition of the other side homotopy -}

  module _
    {x₀ : X}{y₁ : Y}(q₀₁ : Q x₀ y₁) where

    {- (x₁ , q₁₁) = (x₀ , q₀₁) -}
    module _
      {y₀ : Y}(q₀₀ : Q x₀ y₀)
      (r : inl x₀ ≡ inr y₁)
      (p : push q₀₁ ≡ r) where

      ∣fiber←→[q₁₁=q₀₁]∣ : left→rightCodeExtended q₀₀ q₀₁ r (fiber← q₀₁ q₀₀ q₀₁ r p) ≡ ∣ q₀₁ , p ∣ₕ
      ∣fiber←→[q₁₁=q₀₁]∣ =
          (λ i → left→rightCodeExtended q₀₀ q₀₁ r (Fiber←.left q₀₁ (_ , q₀₀) i r p))
        ∙ recUniq {n = m + n} _ _ _
        ∙ (λ i → Fiber→.left q₀₀ (_ , q₀₁) i r (fiber←[q₁₁=q₀₁] q₀₁ q₀₀ r p .snd))
        ∙ (λ i → ∣ q₀₁ , fiber←→[q₁₁=q₀₁] q₀₁ q₀₀ r p i ∣ₕ)

    {- (y₀ , q₀₀) = (y₁ , q₀₁) -}
    module _
      {x₁ : X}(q₁₁ : Q x₁ y₁)
      (r : inl x₀ ≡ inr y₁)
      (p : push q₀₁ ≡ r) where

      ∣fiber←→[q₀₀=q₀₁]∣ : left→rightCodeExtended q₀₁ q₁₁ r (fiber← q₀₁ q₀₁ q₁₁ r p) ≡ ∣ q₀₁ , p ∣ₕ
      ∣fiber←→[q₀₀=q₀₁]∣  =
          (λ i → left→rightCodeExtended q₀₁ q₁₁ r (Fiber←.right q₀₁ (_ , q₁₁) i r p))
        ∙ recUniq {n = m + n} _ _ _
        ∙ (λ i → Fiber→.right q₁₁ (_ , q₀₁) i r (fiber←[q₀₀=q₀₁] q₀₁ q₁₁ r p .snd))
        ∙ (λ i → ∣ q₀₁ , fiber←→[q₀₀=q₀₁] q₀₁ q₁₁ r p i ∣ₕ)

    {- q₀₀ = q₀₁ = q₁₁ -}
    module _
      (r : inl x₀ ≡ inr y₁)
      (p : push q₀₁ ≡ r) where

      path←→Square =
           (λ i j → left→rightCodeExtended q₀₁ q₀₁ r (Fiber←.homSquare q₀₁ i j r p))
        ∙₂ (λ i → recUniq {n = m + n} _ _ _)
        ∙₂ (λ i j → Fiber→.homSquare q₀₁ i j r (fiber←[q₀₀=q₀₁=q₁₁] q₀₁ i r p .snd))
        ∙₂ (λ i j → ∣ q₀₁ , fiber←→hypercube q₀₁ r p i j ∣ₕ)

    ∣fiber←→[q₀₀=q₀₁=q₁₁]∣ : ∣fiber←→[q₁₁=q₀₁]∣ q₀₁ ≡ ∣fiber←→[q₀₀=q₀₁]∣ q₀₁
    ∣fiber←→[q₀₀=q₀₁=q₁₁]∣ i r p = path←→Square r p i

  fiber←→ :
      {x₀ : X}{y₁ : Y}(q₀₁ : Q x₀ y₁)
    → {y₀ : Y}(q₀₀ : Q x₀ y₀) → {x₁ : X}(q₁₁ : Q x₁ y₁)
    → (r : inl x₀ ≡ inr y₁)
    → (p : push q₀₁ ≡ r)
    → left→rightCodeExtended q₀₀ q₁₁ r (fiber← q₀₁ q₀₀ q₁₁ r p) ≡ ∣ q₀₁ , p ∣ₕ
  fiber←→ {x₀ = x₀} {y₁ = y₁} q₀₁ q₀₀' q₁₁' =
    WedgeConnectivity.extension m n
      (leftFiber  x₀ , (y₁ , q₀₁)) (leftConn  x₀)
      (rightFiber y₁ , (x₀ , q₀₁)) (rightConn y₁)
      (λ (y₀ , q₀₀) (x₁ , q₁₁) →
        ((  (r : inl x₀ ≡ inr y₁) → (p : push q₀₁ ≡ r)
          → left→rightCodeExtended q₀₀ q₁₁ r (fiber← q₀₁ q₀₀ q₁₁ r p) ≡ ∣ q₀₁ , p ∣ₕ )
        , isOfHLevelΠ2 _ (λ x y → isOfHLevelTruncPath)))
      (λ (y₀ , q₀₀) → ∣fiber←→[q₁₁=q₀₁]∣ q₀₁ q₀₀)
      (λ (x₁ , q₁₁) → ∣fiber←→[q₀₀=q₀₁]∣ q₀₁ q₁₁)
      (∣fiber←→[q₀₀=q₀₁=q₁₁]∣ q₀₁)
      (_ , q₀₀') (_ , q₁₁')

  module _
    {x₀ x₁ : X}{y₀ y₁ : Y}
    (q₀₀ : Q x₀ y₀)(q₁₁ : Q x₁ y₁)
    (r : inl x₀ ≡ inr y₁) where

    left→right→leftCodeExtended :
        (a : leftCodeExtended q₀₀ _ (push q₁₁) r)
      → right→leftCodeExtended q₀₀ q₁₁ r (left→rightCodeExtended q₀₀ q₁₁ r a) ≡ a
    left→right→leftCodeExtended a =
      sym (∘rec _ _ _ (right→leftCodeExtended q₀₀ q₁₁ r) a) ∙
      (λ i → recId _ (λ (q₁₀ , p) → fiber→← q₁₀ q₀₀ q₁₁ r p) i a)

    right→left→rightCodeExtended :
        (a : rightCode _ r)
      → left→rightCodeExtended q₀₀ q₁₁ r (right→leftCodeExtended q₀₀ q₁₁ r a) ≡ a
    right→left→rightCodeExtended a =
      sym (∘rec _ _ _ (left→rightCodeExtended q₀₀ q₁₁ r) a) ∙
      (λ i → recId _ (λ (q₀₁ , p) → fiber←→ q₀₁ q₀₀ q₁₁ r p) i a)

    left≃rightCodeExtended : leftCodeExtended q₀₀ _ (push q₁₁) r ≃ rightCode y₁ r
    left≃rightCodeExtended =
      isoToEquiv (iso (left→rightCodeExtended _ _ _) (right→leftCodeExtended _ _ _)
                       right→left→rightCodeExtended left→right→leftCodeExtended)

  {- Definition and properties of Code -}

  module _ (x₀ : X)(y₀ : Y)(q₀₀ : Q x₀ y₀) where

    leftCode' : (x : X){p : PushoutQ} → inl x ≡ p → inl x₀ ≡ p → Type ℓ
    leftCode' x r' = leftCodeExtended q₀₀ x r'

    leftCode : (x : X) → inl x₀ ≡ inl x → Type ℓ
    leftCode x = leftCode' x refl

    fiberPath : {x : X}{y : Y} → (q : Q x y) → leftCode' x (push q) ≡ rightCode y
    fiberPath q i r = ua (left≃rightCodeExtended q₀₀ q r) i

    pushCode :
        {x : X}{y : Y} → (q : Q x y)
      → PathP (λ i → inl x₀ ≡ push q i → Type ℓ) (leftCode x) (rightCode y)
    pushCode q i =
      hcomp (λ j → λ { (i = i0) → leftCode _
                     ; (i = i1) → fiberPath q j })
            (leftCode' _ (λ j → push q (i ∧ j)))

    Code : (p : PushoutQ) → inl x₀ ≡ p → Type ℓ
    Code (inl x) = leftCode  x
    Code (inr y) = rightCode y
    Code (push q i) = pushCode q i

    {- Transportation rule of pushCode -}

    transpLeftCode : (y : Y) → (q : Q x₀ y) → (q' : leftCodeExtended q₀₀ _ refl refl) → leftCode' _ (push q) (push q)
    transpLeftCode y q q' =
      transport (λ i → leftCode' _ (λ j → push q (i ∧ j)) (λ j → push q (i ∧ j))) q'

    transpPushCodeβ' :
        (y : Y) → (q : Q x₀ y) → (q' : leftCodeExtended q₀₀ _ refl refl)
      → transport (λ i → pushCode q i (λ j → push q (i ∧ j))) q' ≡ left→rightCodeExtended _ _ _ (transpLeftCode y q q')
    transpPushCodeβ' y q q' i = transportRefl (left→rightCodeExtended _ _ _ (transpLeftCode y q (transportRefl q' i))) i

    module _
      {p : PushoutQ}(r : inl x₀ ≡ p) where

      fiber-filler : I → Type ℓ
      fiber-filler i = fiber' q₀₀ (λ j → r (i ∧ j)) (λ j → r (i ∧ j))

      module _
        (q : fiberSquare q₀₀ q₀₀ refl refl) where

        transpLeftCode-filler : (i j k : I) → PushoutQ
        transpLeftCode-filler i j k' =
          hfill (λ k → λ { (i = i0) → push q₀₀ (~ j)
                         ; (i = i1) → r (j ∧ k)
                         ; (j = i0) → push q₀₀ (~ i)
                         ; (j = i1) → r (i ∧ k) })
                (inS (q i j)) k'

    transpLeftCodeβ' :
        {p : PushoutQ} → (r : inl x₀ ≡ p) → (q : fiberSquare q₀₀ q₀₀ refl refl)
      → transport (λ i → fiber-filler r i) (q₀₀ , q) ≡ (q₀₀ , λ i j → transpLeftCode-filler r q i j i1)
    transpLeftCodeβ' r q =
      J (λ p r → transport (λ i → fiber-filler r i) (q₀₀ , q) ≡ (q₀₀ , λ i j → transpLeftCode-filler r q i j i1))
        (transportRefl _ ∙ (λ k → (q₀₀ , λ i j → transpLeftCode-filler refl q i j k))) r

    transpLeftCodeβ :
        (y : Y) → (q : Q x₀ y) → (q' : fiberSquare q₀₀ q₀₀ refl refl)
      → transpLeftCode y q ∣ q₀₀ , q' ∣ₕ ≡ ∣ q₀₀ , (λ i j → transpLeftCode-filler (push q) q' i j i1) ∣ₕ
    transpLeftCodeβ y q q' = transportTrunc _ ∙ (λ i → ∣ transpLeftCodeβ' _ q' i ∣ₕ)

    transpPushCodeβ :
        (y : Y) → (q : Q x₀ y) → (q' : fiberSquare q₀₀ q₀₀ refl refl)
      →   transport (λ i → pushCode q i (λ j → push q (i ∧ j))) ∣ q₀₀ , q' ∣ₕ
        ≡ ∣fiber→[q₀₀=q₁₀]∣ q₀₀ q (push q) (λ i j → transpLeftCode-filler (push q) q' i j i1)
    transpPushCodeβ y q q' =
        transpPushCodeβ' _ _ _
      ∙ (λ i → left→rightCodeExtended _ _ _ (transpLeftCodeβ _ _ q' i))
      ∙ recUniq {n = m + n} _ _ _
      ∙ (λ i' → Fiber→.left q₀₀ (_ , q) i' (push q) (λ i j → transpLeftCode-filler (push q) q' i j i1))

    {- The contractibility of Code -}

    centerCode : {p : PushoutQ} → (r : inl x₀ ≡ p) → Code p r
    centerCode r =
      transport (λ i → Code _ (λ j → r (i ∧ j))) ∣ q₀₀ , (λ i j → push q₀₀ (~ i ∧ ~ j)) ∣ₕ

    module _
      (y : Y)(q : Q x₀ y) where

      transp-filler : (i j k : I) → PushoutQ
      transp-filler = transpLeftCode-filler (push q) (λ i' j' → push q₀₀ (~ i' ∧ ~ j'))

      transp-square : fiberSquare q₀₀ q₀₀ (push q) (push q)
      transp-square i j = transp-filler i j i1

      contractionCodeRefl' :
        fiber→[q₀₀=q₁₀] q₀₀ q (push q) transp-square .snd ≡ refl
      contractionCodeRefl' i j k =
        hcomp (λ l → λ { (i = i0) → fiber→[q₀₀=q₁₀]-filler q₀₀ q (push q) transp-square j k l
                       ; (i = i1) → transp-square (~ j ∨ l) k
                       ; (j = i0) → push q (k ∧ (i ∨ l))
                       ; (j = i1) → transp-square l k
                       ; (k = i0) → push q₀₀ (j ∧ ~ l)
                       ; (k = i1) → push q ((i ∧ ~ j) ∨ l) })
              (transp-filler (~ j) k i)

      contractionCodeRefl : centerCode (push q) ≡ ∣ q , refl ∣ₕ
      contractionCodeRefl = transpPushCodeβ _ _ _ ∙ (λ i → ∣ q , contractionCodeRefl' i ∣ₕ)

    module _
      (y : Y)(r : inl x₀ ≡ inr y) where

      contractionCode' : (a : fiber push r) → centerCode r ≡ ∣ a ∣ₕ
      contractionCode' (q , p') = J (λ r' p → centerCode r' ≡ ∣ q , p ∣ₕ) (contractionCodeRefl _ q) p'

      contractionCode : (a : Code _ r) → centerCode r ≡ a
      contractionCode = elim (λ _ → isOfHLevelTruncPath) contractionCode'

      isContrCode : isContr (Code _ r)
      isContrCode = centerCode r , contractionCode

  excision-helper :
      (x : X) → Trunc (1 + m) (Σ[ y₀ ∈ Y ] Q x y₀)
    → (y : Y) → (r : inl x ≡ inr y) → isContr (Trunc (m + n) (fiber push r))
  excision-helper x y' y r = rec (isProp→isOfHLevelSuc m isPropIsContr) (λ (y₀ , q₀₀) → isContrCode x y₀ q₀₀ y r ) y'

  {- The Main Result : Blakers-Massey Homotopy Excision Theorem -}
  Excision : (x : X)(y : Y) → isConnectedFun (m + n) (push {x = x} {y = y})
  Excision x y = excision-helper x (leftConn x .fst) y

{-
We also give the following version of the theorem: Given a square

          g
  A --------------> B
  |\              ↗ |
  |  \         ↗    |
  |    \    ↗       |
f |      X          |  inr
  |    /            |
  |   /             |
  |  /              |
  v /               v
  B -----------> Pushout f g
         inl

where X is the pullback of inl and inr
  (X := Σ[ (b , c) ∈ B × C ] (inl b ≡ inr c)).

If f in n-connected and g in m-connected, then the diagonal map
A → X is (n+m)-connected
-}

private
  shuffleFibIso₁ :
       {ℓ ℓ' ℓ'' : Level} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''}
       (f : A → B) (g : A → C) (b : B)
     → Iso (Σ[ c ∈ C ] Σ[ a ∈ A ] (f a ≡ b) × (g a ≡ c))
             (Σ[ a ∈ A ] ((Σ[ c ∈ C ] (g a ≡ c)) × (f a ≡ b)))
  shuffleFibIso₁ f g b =
    compIso (invIso Σ-assoc-Iso)
     (compIso (Σ-cong-iso-fst Σ-swap-Iso)
      (compIso
       (Σ-cong-iso-snd (λ y → Σ-swap-Iso))
       (compIso Σ-assoc-Iso
         (Σ-cong-iso-snd λ a → invIso Σ-assoc-Iso))))

  shuffleFibIso₂ : {ℓ ℓ' ℓ'' : Level} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''}
         (f : A → B) (g : A → C) (x : _)
         → Iso (Σ[ a ∈ A ] ((Σ[ c ∈ C ] (g a ≡ c)) × (f a ≡ x)))
                (fiber f x)
  shuffleFibIso₂ f g x = Σ-cong-iso-snd
        λ a → compIso (Σ-cong-iso-fst
                        (isContr→Iso (isContrSingl (g a))
                         isContrUnit))
                       lUnit×Iso

module BlakersMassey□ {ℓ ℓ' ℓ'' : Level}
  {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''}
  (f : A → B) (g : A → C) (n m : ℕ)
  (con-f : isConnectedFun (suc n) f)
  (con-g : isConnectedFun (suc m) g) where

  {- Some abbreviations and connectivity -}
  private
    fib = doubleFib f g

    B-con : (x : B) → isConnected (suc n) (Σ[ c ∈ C ] (fib x c))
    B-con x =
      isConnectedRetractFromIso (suc n)
        (compIso
          (shuffleFibIso₁ f g x)
          (shuffleFibIso₂ f g x))
        (con-f x)

    C-con : (c : C) → isConnected (suc m) (Σ[ b ∈ B ] (fib b c))
    C-con c =
      isConnectedRetractFromIso (suc m)
        (compIso
          (compIso (Σ-cong-iso-snd
                    (λ _ → Σ-cong-iso-snd λ _ → Σ-swap-Iso))
            (shuffleFibIso₁ g f c))
            (shuffleFibIso₂ g f c))
        (con-g c)

  open module BM-f-g = BlakersMassey B C fib {m = n} B-con {n = m} C-con

  fib× : (B × C) → Type _
  fib× (b , c) = fib b c

  PushoutGenPath× : B × C → Type _
  PushoutGenPath× (b , c) = Path (PushoutGen fib) (inl b) (inr c)

  PushoutPath× : B × C → Type _
  PushoutPath× (b , c) = Path (Pushout f g) (inl b) (inr c)

  {- The function in question -}
  toPullback : A → Σ (B × C) PushoutPath×
  toPullback a = (f a , g a) , push a

  {- We redescribe toPullback as a composition of three maps,
     two of which are equivs and one of which is (n+m)-connected -}
  Totalfib×→Total : Σ (B × C) fib× → Σ (B × C) PushoutGenPath×
  Totalfib×→Total =
    TotalFun {A = B × C} {B = fib×} {C = PushoutGenPath×} (λ a → push)

  isConnectedTotalFun : isConnectedFun (n + m) Totalfib×→Total
  isConnectedTotalFun =
    FunConnected→TotalFunConnected (λ _ → push) (n + m) (uncurry BM-f-g.Excision)

  TotalPathGen×Iso : Iso (Σ (B × C) PushoutGenPath×) (Σ (B × C) PushoutPath×)
  TotalPathGen×Iso =
    Σ-cong-iso-snd λ x
      → congIso (invIso (IsoPushoutPushoutGen f g))

  Totalfib×Iso : Iso (Σ (B × C) fib×) A
  fun Totalfib×Iso ((b , c) , a , p) = a
  inv Totalfib×Iso a = (f a , g a) , a , refl , refl
  rightInv Totalfib×Iso _ = refl
  leftInv Totalfib×Iso ((b , c) , a , (p , q)) i =
    ((p i) , (q i)) , (a , ((λ j → p (i ∧ j)) , (λ j → q (i ∧ j))))

  toPullback' : A → Σ (B × C) PushoutPath×
  toPullback' =
    (fun TotalPathGen×Iso ∘ Totalfib×→Total) ∘ inv Totalfib×Iso

  toPullback'≡toPullback : toPullback' ≡ toPullback
  toPullback'≡toPullback =
    funExt λ x → ΣPathP (refl , (sym (rUnit (push x))))

  isConnected-toPullback : isConnectedFun (n + m) toPullback
  isConnected-toPullback =
    subst (isConnectedFun (n + m)) toPullback'≡toPullback
      (isConnectedComp
        (fun TotalPathGen×Iso ∘ Totalfib×→Total)
        (inv Totalfib×Iso) (n + m)
        (isConnectedComp (fun TotalPathGen×Iso) Totalfib×→Total (n + m)
          (isEquiv→isConnected _ (isoToIsEquiv TotalPathGen×Iso) (n + m))
          isConnectedTotalFun)
        (isEquiv→isConnected _ (isoToIsEquiv (invIso Totalfib×Iso)) (n + m)))


open import Formalization.PredicateLogic.Signature

module Formalization.PredicateLogic.Classical.NaturalDeduction (𝔏 : Signature) where
open Signature(𝔏)

open import Data.ListSized
import      Lvl
open import Formalization.PredicateLogic.Syntax(𝔏)
open import Formalization.PredicateLogic.Syntax.Substitution(𝔏)
open import Functional using (_∘_ ; _∘₂_ ; swap)
open import Numeral.Finite
open import Numeral.Natural
open import Relator.Equals.Proofs.Equiv
open import Sets.PredicateSet using (PredSet ; _∈_ ; _∉_ ; _∪_ ; _∪•_ ; _∖_ ; _⊆_ ; _⊇_ ; ∅ ; [≡]-to-[⊆] ; [≡]-to-[⊇]) renaming (•_ to · ; _≡_ to _≡ₛ_)
open import Type

private variable ℓ : Lvl.Level
private variable args vars : ℕ
private variable Γ : PredSet{ℓ}(Formula(vars))

data _⊢_ {ℓ} : PredSet{ℓ}(Formula(vars)) → Formula(vars) → Type{Lvl.𝐒(ℓₚ Lvl.⊔ ℓₒ Lvl.⊔ ℓ)} where
  direct : (Γ ⊆ (Γ ⊢_))

  [⊤]-intro : (Γ ⊢ ⊤)

  [⊥]-elim  : ∀{φ} → ((Γ ∪ ·(¬ φ)) ⊢ ⊥) → (Γ ⊢ φ)

  [∧]-intro : ∀{φ ψ} → (Γ ⊢ φ) → (Γ ⊢ ψ) → (Γ ⊢ (φ ∧ ψ))
  [∧]-elimₗ : ∀{φ ψ} → (Γ ⊢ (φ ∧ ψ)) → (Γ ⊢ φ)
  [∧]-elimᵣ : ∀{φ ψ} → (Γ ⊢ (φ ∧ ψ)) → (Γ ⊢ ψ)

  [∨]-introₗ : ∀{φ ψ} → (Γ ⊢ φ) → (Γ ⊢ (φ ∨ ψ))
  [∨]-introᵣ : ∀{φ ψ} → (Γ ⊢ ψ) → (Γ ⊢ (φ ∨ ψ))
  [∨]-elim   : ∀{φ ψ χ} → ((Γ ∪ · φ) ⊢ χ) → ((Γ ∪ · ψ) ⊢ χ) → (Γ ⊢ (φ ∨ ψ)) → (Γ ⊢ χ)

  [⟶]-intro : ∀{φ ψ} → ((Γ ∪ · φ) ⊢ ψ) → (Γ ⊢ (φ ⟶ ψ))
  [⟶]-elim  : ∀{φ ψ} → (Γ ⊢ φ) → (Γ ⊢ (φ ⟶ ψ)) → (Γ ⊢ ψ)

  [Ɐ]-intro : ∀{φ} → (∀{t} → (Γ ⊢ (substitute0 t φ))) → (Γ ⊢ (Ɐ φ))
  [Ɐ]-elim  : ∀{φ} → (Γ ⊢ (Ɐ φ)) → ∀{t} → (Γ ⊢ (substitute0 t φ))

  [∃]-intro : ∀{φ}{t} → (Γ ⊢ (substitute0 t φ)) → (Γ ⊢ (∃ φ))
  [∃]-elim  : ∀{φ ψ} → (∀{t} → (Γ ∪ ·(substitute0 t φ)) ⊢ ψ) → (Γ ⊢ (∃ φ)) → (Γ ⊢ ψ)

module _ where
  open import Data.Either as Either
  import      Logic.Propositional as Meta
  open import Relator.Equals

  private variable Γ₁ Γ₂ : PredSet{ℓ}(Formula(vars))
  private variable φ ψ : Formula(vars)

  _⊬_ : PredSet{ℓ}(Formula(vars)) → Formula(vars) → Type
  _⊬_ = Meta.¬_ ∘₂ (_⊢_)

  [⟵]-intro : ((Γ ∪ · φ) ⊢ ψ) → (Γ ⊢ (ψ ⟵ φ))
  [⟵]-intro = [⟶]-intro

  [⟵]-elim : (Γ ⊢ φ) → (Γ ⊢ (ψ ⟵ φ)) → (Γ ⊢ ψ)
  [⟵]-elim = [⟶]-elim

  [¬]-intro : ((Γ ∪ · φ) ⊢ ⊥) → (Γ ⊢ (¬ φ))
  [¬]-intro = [⟶]-intro

  [⟷]-intro : ∀{φ ψ} → ((Γ ∪ · ψ) ⊢ φ) → ((Γ ∪ · φ) ⊢ ψ) → (Γ ⊢ (φ ⟷ ψ))
  [⟷]-intro l r = [∧]-intro ([⟶]-intro l) ([⟶]-intro r)

  [⟷]-elimₗ : ∀{φ ψ} → (Γ ⊢ ψ) → (Γ ⊢ (φ ⟷ ψ)) → (Γ ⊢ φ)
  [⟷]-elimₗ Γψ Γφψ = [⟶]-elim Γψ ([∧]-elimₗ Γφψ)

  [⟷]-elimᵣ : ∀{φ ψ} → (Γ ⊢ φ) → (Γ ⊢ (φ ⟷ ψ)) → (Γ ⊢ ψ)
  [⟷]-elimᵣ Γφ Γφψ = [⟶]-elim Γφ ([∧]-elimᵣ Γφψ)

  weaken-union-singleton : (Γ₁ ⊆ Γ₂) → (((Γ₁ ∪ · φ) ⊢_) ⊆ ((Γ₂ ∪ · φ) ⊢_))
  weaken : (Γ₁ ⊆ Γ₂) → ((Γ₁ ⊢_) ⊆ (Γ₂ ⊢_))

  weaken Γ₁Γ₂ {φ}                  (direct p)       = direct (Γ₁Γ₂ p)
  weaken Γ₁Γ₂ {.⊤}                 [⊤]-intro        = [⊤]-intro
  weaken Γ₁Γ₂ {φ}                  ([⊥]-elim p)     = [⊥]-elim (weaken-union-singleton Γ₁Γ₂ p)
  weaken Γ₁Γ₂ {.(_ ∧ _)}           ([∧]-intro p q)  = [∧]-intro (weaken Γ₁Γ₂ p) (weaken Γ₁Γ₂ q)
  weaken Γ₁Γ₂ {φ}                  ([∧]-elimₗ p)    = [∧]-elimₗ (weaken Γ₁Γ₂ p)
  weaken Γ₁Γ₂ {φ}                  ([∧]-elimᵣ p)    = [∧]-elimᵣ (weaken Γ₁Γ₂ p)
  weaken Γ₁Γ₂ {.(_ ∨ _)}           ([∨]-introₗ p)   = [∨]-introₗ (weaken Γ₁Γ₂ p)
  weaken Γ₁Γ₂ {.(_ ∨ _)}           ([∨]-introᵣ p)   = [∨]-introᵣ (weaken Γ₁Γ₂ p)
  weaken Γ₁Γ₂ {φ}                  ([∨]-elim p q r) = [∨]-elim (weaken-union-singleton Γ₁Γ₂ p) (weaken-union-singleton Γ₁Γ₂ q) (weaken Γ₁Γ₂ r)
  weaken Γ₁Γ₂ {.(_ ⟶ _)}           ([⟶]-intro p)    = [⟶]-intro (weaken-union-singleton Γ₁Γ₂ p)
  weaken Γ₁Γ₂ {φ}                  ([⟶]-elim p q)   = [⟶]-elim (weaken Γ₁Γ₂ p) (weaken Γ₁Γ₂ q)
  weaken Γ₁Γ₂ {.(Ɐ _)}             ([Ɐ]-intro p)    = [Ɐ]-intro (weaken Γ₁Γ₂ p)
  weaken Γ₁Γ₂ {.(substitute0 _ _)} ([Ɐ]-elim p)     = [Ɐ]-elim (weaken Γ₁Γ₂ p)
  weaken Γ₁Γ₂ {.(∃ _)}             ([∃]-intro p)    = [∃]-intro (weaken Γ₁Γ₂ p)
  weaken Γ₁Γ₂ {φ}                  ([∃]-elim p q)   = [∃]-elim (weaken-union-singleton Γ₁Γ₂ p) (weaken Γ₁Γ₂ q)
  weaken-union-singleton Γ₁Γ₂ p = weaken (Either.mapLeft Γ₁Γ₂) p

  weaken-union : (Γ₁ ⊢_) ⊆ ((Γ₁ ∪ Γ₂) ⊢_)
  weaken-union = weaken Left

  [⊥]-elim-constructive : (Γ ⊢ ⊥) → (Γ ⊢ φ)
  [⊥]-elim-constructive Γ⊥ = [⊥]-elim (weaken-union Γ⊥)

  [¬¬]-elim : (Γ ⊢ ¬(¬ φ)) → (Γ ⊢ φ)
  [¬¬]-elim nnφ =
    ([⊥]-elim
      ([⟶]-elim
        (direct(Right [≡]-intro))
        (weaken-union nnφ)
      )
    )

  [¬¬]-intro : (Γ ⊢ φ) → (Γ ⊢ ¬(¬ φ))
  [¬¬]-intro Γφ =
    ([¬]-intro
      ([⟶]-elim
        (weaken-union Γφ)
        (direct (Right [≡]-intro))
      )
    )


{-
  This file defines cohomology of a type with
  coefficients in a dependent spectrum over it.
  * Cohom and Cohom' are two versions of the cohomology groups
    - the only difference is the carrier type.
  * 'commDegreeΩ' commutes Ωs with degree shifts of the spectrum
  * 'cohomMap' implement the application of the cohomology functors
    to maps between types

  This general cohomology coincides with ZCohomology when the coefficients
  are constantly the Eilenberg-MacLane spectrum for ℤ (not proven here/yet)
-}
{-# OPTIONS --safe #-}
module Cubical.Cohomology.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed.Base
open import Cubical.Foundations.Pointed.Properties
open import Cubical.Foundations.Isomorphism using (isoToEquiv)
open import Cubical.Foundations.Function    using (_∘_)
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Univalence  using (ua)

open import Cubical.Functions.FunExtEquiv using (funExtEquiv)

open import Cubical.Algebra.Group.Base using (Group; GroupStr)
open import Cubical.Algebra.AbGroup.Base
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties

open import Cubical.Data.Int.Base hiding (_·_)
open import Cubical.Data.Nat.Base using (ℕ)
open import Cubical.Data.Sigma
open import Cubical.Homotopy.Group.Base
open import Cubical.HITs.SetTruncation hiding (map)

open import Cubical.Homotopy.Spectrum
open import Cubical.Homotopy.Loopspace renaming (EH to isCommΩ)
open import Cubical.Structures.Successor

private
  variable
    ℓ : Level

open Spectrum

module _ (X : Type ℓ) (A : (x : X) → Spectrum ℓ) where
  CohomClasses : ℤ → Pointed ℓ
  CohomClasses k = Πᵘ∙ X (λ x → space (A x) k)

  CohomType : ℤ → Type ℓ
  CohomType k = ∥  (fst (CohomClasses k)) ∥₂

  private
    commDegreeΩOnce : (k : ℤ) → (CohomClasses k) ≃∙ Πᵘ∙ X (λ x → Ω (space (A x) (sucℤ k)))
    commDegreeΩOnce k =
      (equivΠCod (λ x → fst (equivΩAt x))) ,
       λ i x → snd (equivΩAt x) i
      where equivΩAt : (x : X) → space (A x) k ≃∙ Ω (space (A x) (sucℤ k))
            equivΩAt x = (fst (map (A x) k) , equiv (A x) k) , snd (map (A x) k)

    commDegreeΩOnce' : (k : ℤ) → (CohomClasses k) ≃∙ Ω (CohomClasses (sucℤ k))
    commDegreeΩOnce' k =
      compEquiv∙ (commDegreeΩOnce k)
                 (funExtEquiv , refl)

  commDegreeΩ : (k : ℤ) (n : ℕ) → (CohomClasses k) ≃∙ (Ω^ n) (CohomClasses (k + (pos n)))
  commDegreeΩ k ℕ.zero = idEquiv∙ _
  commDegreeΩ k (ℕ.suc n) =
    CohomClasses k                                     ≃∙⟨ commDegreeΩ k n ⟩
    (Ω^ n) (CohomClasses (k + (pos n)))                ≃∙⟨ Ω^≃∙ n (commDegreeΩOnce' (k + pos n)) ⟩
    (Ω^ n) (Ω (CohomClasses (sucℤ (k + (pos n)))))     ≃∙⟨ invEquiv∙ (e n) ⟩
    (Ω^ (ℕ.suc n)) (CohomClasses (sucℤ (k + (pos n)))) ∎≃∙
    where e : {A : Pointed ℓ} (n : ℕ) → (Ω^ (ℕ.suc n)) A ≃∙ (Ω^ n) (Ω A)
          e ℕ.zero = isoToEquiv (flipΩIso ℕ.zero) , transportRefl refl
          e (ℕ.suc n) = isoToEquiv (flipΩIso (ℕ.suc n)) , flipΩrefl n

  {-
    Abelian group structure
  -}
  module abGroupStr (k : ℤ) where
    {-
      Use an equivalent type, where the group structure is just
      given by the homotopy group functor
      (index of homotopy groups is off by one below, we actually take π₂,
      to get an abelian group)
    -}
    CohomAsGroup : Group ℓ
    CohomAsGroup = (πGr 1) (Πᵘ∙ X  (λ x → (space (A x) (k + 2))))

    open GroupStr (snd CohomAsGroup)

    isComm :  (a b : fst CohomAsGroup) → a · b ≡ b · a
    isComm = elim2 (λ _ _ → isSetPathImplicit)
                   λ a b → ∣ a ∙ b ∣₂ ≡⟨ cong ∣_∣₂ (isCommΩ 0 a b) ⟩
                           ∣ b ∙ a ∣₂ ∎

    π₂AbGroup : AbGroup ℓ
    π₂AbGroup = Group→AbGroup CohomAsGroup isComm

  module _ (k : ℤ) where
    Cohom' : AbGroup ℓ
    Cohom' = abGroupStr.π₂AbGroup k

    CohomType' : Type ℓ
    CohomType' = fst (abGroupStr.π₂AbGroup k)

    private
      shiftΩTwicePath : fst (abGroupStr.π₂AbGroup k) ≡ CohomType k
      shiftΩTwicePath = sym (cong ∥_∥₂ (ua (fst (commDegreeΩ k 2))))

    Cohom : AbGroup ℓ
    Cohom = CohomType k , subst AbGroupStr shiftΩTwicePath (snd (abGroupStr.π₂AbGroup k))

    CohomPath : Cohom' ≡ Cohom
    CohomPath = ΣPathTransport→PathΣ Cohom' Cohom (shiftΩTwicePath , refl)

    CohomEquiv : AbGroupEquiv Cohom' Cohom
    CohomEquiv = fst (invEquiv (AbGroupPath Cohom' Cohom)) CohomPath

{-
  Functoriality in the type argument
-}
module _ {Y X : Type ℓ} (f : Y → X) (A : (x : X) → Spectrum ℓ) where
  {-
    The following will be used as coefficients for the
    cohomology of Y
  -}
  fA : (y : Y) → Spectrum ℓ
  fA y = A (f y)

  cohomMap' : (k : ℤ) → AbGroupHom (Cohom' X A k) (Cohom' Y fA k)
  cohomMap' k = πHom 1 mapOnClasses  -- apply π₂ to a map on cohomology classes
            where
             mapOnClasses : CohomClasses X A (k + 2) →∙ CohomClasses Y fA (k + 2)
             mapOnClasses = (λ l → (λ y → l (f y))) ,
                            refl

  cohomMap : (k : ℤ) → AbGroupHom (Cohom X A k) (Cohom Y fA k)
  cohomMap k = compGroupHom
                 (compGroupHom (GroupEquiv→GroupHom (invGroupEquiv (CohomEquiv X A k)))
                               (cohomMap' k))
                 (GroupEquiv→GroupHom (CohomEquiv Y fA k))


{-# OPTIONS --cubical #-}
module Agda.Builtin.Cubical.Sub where

  open import Agda.Primitive.Cubical

  {-# BUILTIN SUB Sub #-}

  postulate
    inc : ∀ {ℓ} {A : Set ℓ} {φ} (x : A) → Sub A φ (λ _ → x)

  {-# BUILTIN SUBIN inc #-}

  primitive
    primSubOut : ∀ {ℓ} {A : Set ℓ} {φ : I} {u : Partial φ A} → Sub _ φ u → A


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

open import Common.Size

-- An abuse of sized types, but as you wish...

data D (i : Size) : Set where
  c  : (j : Size< i) (k : Size< j) (l : Size< k) (m : Size< l) → D m → D i
  c' : (j : Size< i) → D j → D i

works : ∀ i → D i → Set
works i (c j k l m d) = works j (c' k (c' l (c' m d)))
works i (c' j d)      = works j d

test : ∀ i → D i → Set
test i (c j k l m d) = test ? (c' ? (c' ? (c' ? ?)))
test i (c' j d) = ?

-- Should not give a termination error as there is an instantiation
-- of meta variables that gives a terminating function.


open import Data.Nat using ( ℕ ; zero ; suc )
open import Data.Product using ( ∃ ; _×_ ; _,_ )
open import Data.Sum using ( _⊎_ ; inj₁ ; inj₂ )
open import Relation.Binary.PropositionalEquality using ( _≡_ ; _≢_ ; refl ; cong )
open import Relation.Nullary using ( ¬_ )
open import FRP.LTL.Time using
  ( Time ; _<_ ; _≤_ ; _≥_ ; ≤-refl ; _≤-trans_ ; _≤-asym_ ; _≤-total_ ; ≤-proof-irrel ; ≡-impl-≥
  ; _∸_ ; _+_ ; t≤u+t∸u ; +-unit ; +-assoc ; +-resp-≤ ; <-impl-+1≤ ; t<t+1
  ; _≤-case_ ; lt ; eq ; gt )
open import FRP.LTL.Util using ( ⊥-elim )

module FRP.LTL.Time.Bound where

infixr 2 _≼_ _≺_ _⋠_
infixr 4 _,_
infixr 5 _≼-trans_ _≼-asym_ _≼-total_ _≺-transˡ_ _≺-transʳ_ _≺-trans_

-- Time bounds, which extend Time with least and greatest elements

data Time∞ : Set where
  +∞ : Time∞
  fin : Time → Time∞

-- Order on time, generated by s ≺ t ≺ +∞ when s < t

data _≼_ : Time∞ → Time∞ → Set where
  +∞-top : ∀ {t} → (t ≼ +∞)
  ≤-impl-≼ : ∀ {t u} → (t ≤ u) → (fin t ≼ fin u)

_⋠_ : Time∞ → Time∞ → Set
s ⋠ t = ¬(s ≼ t)

_≺_ : Time∞ → Time∞ → Set
s ≺ t = (s ≼ t) × (t ⋠ s)

≼-impl-≤ : ∀ {t u} → (fin t ≼ fin u) → (t ≤ u)
≼-impl-≤ (≤-impl-≼ t≤u) = t≤u

-- Axioms for ≺

t≺+∞ : ∀ {t} → fin t ≺ +∞
t≺+∞ = (+∞-top , λ ())

<-impl-≺ : ∀ {t u} → (t < u) → (fin t ≺ fin u)
<-impl-≺ (t≤u , u≰t) = (≤-impl-≼ t≤u , λ u≼t → u≰t (≼-impl-≤ u≼t))

≺-impl-< : ∀ {t u} → (fin t ≺ fin u) → (t < u)
≺-impl-< (t≼u , u⋠t) = (≼-impl-≤ t≼u , λ u≤t → u⋠t (≤-impl-≼ u≤t))

t≺t+1 : ∀ {t} → (fin t ≺ fin (t + 1))
t≺t+1 = <-impl-≺ t<t+1

-- ≼ is a decidable total order

≼-refl : ∀ {t} → (t ≼ t)
≼-refl {+∞}     = +∞-top
≼-refl {fin t} = ≤-impl-≼ ≤-refl

_≼-trans_ : ∀ {s t u} → (s ≼ t) → (t ≼ u) → (s ≼ u)
s≼t          ≼-trans +∞-top       = +∞-top
≤-impl-≼ s≤t ≼-trans ≤-impl-≼ t≤u = ≤-impl-≼ (s≤t ≤-trans t≤u)

_≼-asym_ : ∀ {s t} → (s ≼ t) → (t ≼ s) → (s ≡ t)
+∞-top       ≼-asym +∞-top       = refl
≤-impl-≼ s≤t ≼-asym ≤-impl-≼ t≤s = cong fin (s≤t ≤-asym t≤s)

_≼-total_ : ∀ s t → (s ≼ t) ⊎ (t ≺ s)
+∞    ≼-total +∞    = inj₁ +∞-top
+∞    ≼-total fin t = inj₂ t≺+∞
fin s ≼-total +∞    = inj₁ +∞-top
fin s ≼-total fin t with s ≤-total t
... | inj₁ s≤t = inj₁ (≤-impl-≼ s≤t)
... | inj₂ t<s = inj₂ (<-impl-≺ t<s)

data _≼-Case_ (t u : Time∞) : Set where
  lt : .(t ≺ u) → (t ≼-Case u)
  eq : .(t ≡ u) → (t ≼-Case u)
  gt : .(u ≺ t) → (t ≼-Case u)

_≼-case_ : ∀ t u → (t ≼-Case u)
+∞    ≼-case +∞    = eq refl
+∞    ≼-case fin u = gt t≺+∞
fin t ≼-case +∞    = lt t≺+∞
fin t ≼-case fin u with t ≤-case u
fin t ≼-case fin u | lt t<u = lt (<-impl-≺ t<u)
fin t ≼-case fin u | eq t≡u = eq (cong fin t≡u)
fin t ≼-case fin u | gt t>u = gt (<-impl-≺ t>u)

≡-impl-≼ : ∀ {s t} → (s ≡ t) → (s ≼ t)
≡-impl-≼ refl = ≼-refl

≡-impl-≽ : ∀ {s t} → (s ≡ t) → (t ≼ s)
≡-impl-≽ refl = ≼-refl

≼-proof-irrel : ∀ {t u} → (p q : t ≼ u) → (p ≡ q)
≼-proof-irrel +∞-top          +∞-top          = refl
≼-proof-irrel (≤-impl-≼ t≤₁u) (≤-impl-≼ t≤₂u) = cong ≤-impl-≼ (≤-proof-irrel t≤₁u t≤₂u)

≺-impl-≼ : ∀ {t u} → (t ≺ u) → (t ≼ u)
≺-impl-≼ (t≼u , u⋠t) = t≼u

≺-impl-⋡ : ∀ {t u} → (t ≺ u) → (u ⋠ t)
≺-impl-⋡ (t≼u , u⋠t) = u⋠t

≺-impl-≢ : ∀ {t u} → (t ≺ u) → (t ≢ u)
≺-impl-≢ (t≼u , u⋠t) refl = u⋠t ≼-refl

_≺-transˡ_ : ∀ {t u v} → (t ≺ u) → (u ≼ v) → (t ≺ v)
(t≼u , u⋠t) ≺-transˡ u≼v = (t≼u ≼-trans u≼v , λ v≼t → u⋠t (u≼v ≼-trans v≼t))

_≺-transʳ_ : ∀ {t u v} → (t ≼ u) → (u ≺ v) → (t ≺ v)
t≼u ≺-transʳ (u≼v , v⋠u) = (t≼u ≼-trans u≼v , λ v≼t → v⋠u (v≼t ≼-trans t≼u))

_≺-trans_ : ∀ {t u v} → (t ≺ u) → (u ≺ v) → (t ≺ v)
(t≼u , u⋠t) ≺-trans (u≼v , v⋠u) = (t≼u ≼-trans u≼v , λ v≼t → v⋠u (v≼t ≼-trans t≼u))

∞≼-impl-≡∞ : ∀ {t} → (+∞ ≼ t) → (t ≡ +∞)
∞≼-impl-≡∞ +∞-top = refl

src : ∀ {s t} → .(s ≼ t) → Time∞
src {s} {t} s≼t = s

tgt : ∀ {s t} → .(s ≼ t) → Time∞
tgt {s} {t} s≼t = t

-- An induction scheme for time bounds

_+_≻_ : Time∞ → ℕ → Time∞ → Set
s + zero  ≻ u = u ≺ s
s + suc n ≻ u = ∀ {t} → (s ≺ t) → (t + n ≻ u)

data ≺-Indn (s u : Time∞) : Set where
  _,_ : ∀ n → .(s + n ≻ u) → ≺-Indn s u

≺-indn : ∀ {s u} → .(u ≺ +∞) → ≺-Indn s u
≺-indn {s}     {+∞}    u≺∞ = ⊥-elim (≺-impl-≢ u≺∞ refl)
≺-indn {+∞}    {fin u} u≺∞ = (zero , t≺+∞)
≺-indn {fin s} {fin u} u≺∞ = (suc (u ∸ s) , lemma s u (u ∸ s) t≤u+t∸u) where

  lemma : ∀ s u n → (s + n ≥ u) → (fin s + suc n ≻ fin u)
  lemma s u zero    s+0≥u   s≺t =
    (≤-impl-≼ s+0≥u ≼-trans ≡-impl-≼ (cong fin (+-unit s))) ≺-transʳ s≺t
  lemma s u (suc n) s+1+n≥u {fin t} s≺t = lemma t u n
    (s+1+n≥u ≤-trans ≡-impl-≥ (+-assoc s 1 n) ≤-trans +-resp-≤ (<-impl-+1≤ (≺-impl-< s≺t)) n)
  lemma s u (suc n) s+1+n≥u {+∞} s≺t =
    λ ∞≺v → ⊥-elim (≺-impl-⋡ ∞≺v +∞-top)