------------------------------------------------------------------------
-- M-types for indexed containers, defined using functions
------------------------------------------------------------------------

-- Based on "Non-wellfounded trees in Homotopy Type Theory" by Ahrens,
-- Capriotti and Spadotti.

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

open import Equality

module Container.Indexed.M.Function
  {e⁺} (eq : ∀ {a p} → Equality-with-J a p e⁺) where

open Derived-definitions-and-properties eq

open import Logical-equivalence using (_⇔_)
open import Prelude

open import Bijection eq as Bijection using (_↔_)
open import Container.Indexed eq
open import Equivalence eq as Eq using (_≃_)
open import Function-universe eq as F hiding (id; _∘_)
open import H-level eq as H-level using (H-level)
open import H-level.Closure eq
import Nat eq as Nat
open import Surjection eq using (_↠_)
open import Tactic.Sigma-cong eq
open import Univalence-axiom eq

private
  variable
    a ℓ o p s             : Level
    A I O                 : Type a
    b ext ext₁ ext₂ i k x : A
    Q                     : A → Type p
    C                     : Container I s p
    n                     : ℕ

------------------------------------------------------------------------
-- Chains

-- Chains (indexed).

Chain : Type i → ∀ ℓ → Type (i ⊔ lsuc ℓ)
Chain {i = i} I ℓ =
  ∃ λ (P : ℕ → I → Type ℓ) → ∀ n → P (suc n) ⇾ P n

-- Limits of chains.

Limit : {I : Type i} → Chain I ℓ → I → Type ℓ
Limit (P , down) i =
  ∃ λ (f : ∀ n → P n i) →
    ∀ n → down n i (f (suc n)) ≡ f n

-- A kind of dependent universal property for limits.

universal-property-Π :
  {A : Type a} {I : Type i} {g : A → I} →
  (X@(P , down) : Chain I ℓ) →

  ((a : A) → Limit X (g a))
    ≃
  (∃ λ (f : ∀ n (a : A) → P n (g a)) →
     ∀ n a → down n (g a) (f (suc n) a) ≡ f n a)

universal-property-Π {g = g} X@(P , down) =
  (∀ a → Limit X (g a))                           ↔⟨⟩

  (∀ a → ∃ λ (f : ∀ n → P n (g a)) →
           ∀ n → down n (g a) (f (suc n)) ≡ f n)  ↔⟨ ΠΣ-comm ⟩

  (∃ λ (f : ∀ a n → P n (g a)) →
     ∀ a n → down n (g a) (f a (suc n)) ≡ f a n)  ↝⟨ Σ-cong-refl Π-comm (λ _ → Π-comm) ⟩□

  (∃ λ (f : ∀ n a → P n (g a)) →
     ∀ n a → down n (g a) (f (suc n) a) ≡ f n a)  □

-- A universal property for limits.

universal-property :
  {I : Type i} {P : I → Type p} →
  (X@(Q , down) : Chain I ℓ) →

  (P ⇾ Limit X)
    ↝[ i ∣ p ⊔ ℓ ]
  (∃ λ (f : ∀ n → P ⇾ Q n) →
     ∀ n i x → down n i (f (suc n) i x) ≡ f n i x)

universal-property {P = P} X@(Q , down) ext =
  (P ⇾ Limit X)                                     ↔⟨⟩

  (∀ i → P i → Limit X i)                           ↝⟨ (∀-cong ext λ _ → from-equivalence $ universal-property-Π X) ⟩

  (∀ i → ∃ λ (f : ∀ n → P i → Q n i) →
           ∀ n x → down n i (f (suc n) x) ≡ f n x)  ↔⟨ ΠΣ-comm ⟩

  (∃ λ (f : ∀ i n → P i → Q n i) →
     ∀ i n x → down n i (f i (suc n) x) ≡ f i n x)  ↝⟨ Σ-cong-refl Π-comm (λ _ → Π-comm) ⟩

  (∃ λ (f : ∀ n i → P i → Q n i) →
     ∀ n i x → down n i (f (suc n) i x) ≡ f n i x)  ↔⟨⟩

  (∃ λ (f : ∀ n → P ⇾ Q n) →
     ∀ n i x → down n i (f (suc n) i x) ≡ f n i x)  □

-- Cones.

Cone : {I : Type i} → (I → Type p) → Chain I ℓ → Type (i ⊔ p ⊔ ℓ)
Cone P (Q , down) =
  ∃ λ (f : ∀ n → P ⇾ Q n) →
    ∀ n → down n ∘⇾ f (suc n) ≡ f n

-- A variant of the non-dependent universal property.

universal-property-≃ :
  {I : Type i} {P : I → Type p} →
  Extensionality (i ⊔ p) (i ⊔ p ⊔ ℓ) →
  (X : Chain I ℓ) →

  (P ⇾ Limit X) ≃ Cone P X

universal-property-≃ {i = i} {p = p} {ℓ = ℓ} {P = P} ext X@(Q , down) =
  P ⇾ Limit X                                       ↝⟨ universal-property X (lower-extensionality p i ext) ⟩

  (∃ λ (f : ∀ n → P ⇾ Q n) →
     ∀ n i x → down n i (f (suc n) i x) ≡ f n i x)  ↝⟨ (∃-cong λ _ → ∀-cong (lower-extensionality _ lzero ext) λ _ →
                                                        ∀-cong (lower-extensionality p i ext) λ _ →
                                                        Eq.extensionality-isomorphism (lower-extensionality (i ⊔ p) (i ⊔ p) ext)) ⟩
  (∃ λ (f : ∀ n → P ⇾ Q n) →
     ∀ n i → down n i ∘ f (suc n) i ≡ f n i)        ↝⟨ (∃-cong λ _ → ∀-cong (lower-extensionality _ lzero ext) λ _ →
                                                        Eq.extensionality-isomorphism (lower-extensionality (i ⊔ p) (i ⊔ p) ext)) ⟩
  (∃ λ (f : ∀ n → P ⇾ Q n) →
     ∀ n → down n ∘⇾ f (suc n) ≡ f n)               ↔⟨⟩

  Cone P X                                          □

-- Shifts a chain one step.

shift : Chain I ℓ → Chain I ℓ
shift = Σ-map (_∘ suc) (_∘ suc)

-- Shifting does not affect the limit (assuming extensionality).
--
-- This is a variant of Lemma 12 in "Non-wellfounded trees in Homotopy
-- Type Theory".

Limit-shift :
  ∀ (X : Chain I ℓ) {i} →
  Limit (shift X) i ↝[ lzero ∣ ℓ ] Limit X i
Limit-shift {ℓ = ℓ} X@(P , down) {i = i} ext =
  Limit (shift X) i                                ↔⟨⟩

  (∃ λ (p : ∀ n → P (suc n) i) →
     ∀ n → down (suc n) i (p (suc n)) ≡ p n)       ↔⟨ (∃-cong λ _ → inverse $
                                                       drop-⊤-left-× λ _ →
                                                       _⇔_.to contractible⇔↔⊤ $
                                                       other-singleton-contractible _) ⟩
  (∃ λ (p : ∀ n → P (suc n) i) →
     (∃ λ (p₀ : P 0 i) → down 0 i (p 0) ≡ p₀) ×
     ∀ n → down (suc n) i (p (suc n)) ≡ p n)       ↔⟨ Σ-assoc F.∘
                                                      ∃-comm F.∘
                                                      (∃-cong λ _ → inverse Σ-assoc) ⟩
  (∃ λ ((p₀ , p) : P 0 i × (∀ n → P (suc n) i)) →
     down 0 i (p 0) ≡ p₀ ×
     ∀ n → down (suc n) i (p (suc n)) ≡ p n)       ↝⟨ inverse-ext?
                                                        (generalise-ext?
                                                           (_↠_.logical-equivalence lemma₂-↠)
                                                           (λ ext →
                                                                _↠_.right-inverse-of lemma₂-↠
                                                              , _↔_.left-inverse-of (lemma₂-↔ ext)))
                                                        ext ⟩
  (∃ λ (p : ∀ n → P n i) →
     ∀ n → down n i (p (suc n)) ≡ p n)             ↔⟨⟩

  Limit X i                                        □
  where
  lemma₁-↠ :
    {P : ℕ → Type ℓ} →
    (∀ n → P n) ↠ (P 0 × (∀ n → P (suc n)))
  lemma₁-↠ ._↠_.logical-equivalence ._⇔_.to   = λ p → p 0 , p ∘ suc
  lemma₁-↠ ._↠_.logical-equivalence ._⇔_.from = uncurry ℕ-case
  lemma₁-↠ ._↠_.right-inverse-of              = refl

  lemma₁-↔ :
    {P : ℕ → Type ℓ} →
    Extensionality lzero ℓ →
    (∀ n → P n) ↔ (P 0 × (∀ n → P (suc n)))
  lemma₁-↔ _   ._↔_.surjection      = lemma₁-↠
  lemma₁-↔ ext ._↔_.left-inverse-of = λ f →
    apply-ext ext $ ℕ-case (refl _) λ _ → refl _

  lemma₂-↠ : _ ↠ _
  lemma₂-↠ =
    (∃ λ (p : ∀ n → P n i) →
       ∀ n → down n i (p (suc n)) ≡ p n)              ↝⟨ (∃-cong λ _ → lemma₁-↠) ⟩

    (∃ λ (p : ∀ n → P n i) →
       down 0 i (p 1) ≡ p 0 ×
       ∀ n → down (suc n) i (p (2 + n)) ≡ p (1 + n))  ↝⟨ Σ-cong-id-↠ lemma₁-↠ ⟩□

    (∃ λ ((p₀ , p) : P 0 i × (∀ n → P (suc n) i)) →
       down 0 i (p 0) ≡ p₀ ×
       ∀ n → down (suc n) i (p (suc n)) ≡ p n)        □

  lemma₂-↔ : Extensionality lzero ℓ → _ ↔ _
  lemma₂-↔ ext =
    (∃ λ (p : ∀ n → P n i) →
       ∀ n → down n i (p (suc n)) ≡ p n)              ↝⟨ (∃-cong λ _ → lemma₁-↔ ext) ⟩

    (∃ λ (p : ∀ n → P n i) →
       down 0 i (p 1) ≡ p 0 ×
       ∀ n → down (suc n) i (p (2 + n)) ≡ p (1 + n))  ↝⟨ Σ-cong-id (Eq.↔⇒≃ $ lemma₁-↔ ext) ⟩□

    (∃ λ ((p₀ , p) : P 0 i × (∀ n → P (suc n) i)) →
       down 0 i (p 0) ≡ p₀ ×
       ∀ n → down (suc n) i (p (suc n)) ≡ p n)        □

------------------------------------------------------------------------
-- Cochains

-- Cochains (non-indexed).

Cochain : ∀ ℓ → Type (lsuc ℓ)
Cochain ℓ =
  ∃ λ (P : ℕ → Type ℓ) → ∀ n → P n → P (suc n)

-- There is a pointwise split surjection from the "limit" of a cochain
-- to the first element.

cochain-limit-↠ :
  ((P , up) : Cochain ℓ) →

  (∃ λ (p : ∀ n → P n) → ∀ n → p (suc n) ≡ up n (p n))
    ↠
  P 0
cochain-limit-↠ (_ , up) = λ where
  ._↠_.logical-equivalence ._⇔_.to   (p , _)     → p 0
  ._↠_.logical-equivalence ._⇔_.from p₀ .proj₁   → ℕ-rec p₀ up
  ._↠_.logical-equivalence ._⇔_.from p₀ .proj₂ _ → refl _
  ._↠_.right-inverse-of                          → refl

-- The "limit" of a cochain is pointwise equivalent to the first
-- element (assuming extensionality).
--
-- This is a variant of Lemma 11 in "Non-wellfounded trees in Homotopy
-- Type Theory".

cochain-limit :
  ((P , up) : Cochain ℓ) →

  (∃ λ (p : ∀ n → P n) → ∀ n → p (suc n) ≡ up n (p n))
    ↝[ lzero ∣ ℓ ]
  P 0
cochain-limit X@(_ , up) ext =
  generalise-ext?
  (_↠_.logical-equivalence cl)
  (λ ext → _↠_.right-inverse-of cl , from∘to ext)
  ext
  where
  cl = cochain-limit-↠ X

  open _↠_ cl

  from₁∘to : ∀ l n → proj₁ (from (to l)) n ≡ proj₁ l n
  from₁∘to _         zero    = refl _
  from₁∘to l@(p , q) (suc n) =
    up n (proj₁ (from (to l)) n)  ≡⟨ cong (up n) $ from₁∘to l n ⟩
    up n (p n)                    ≡⟨ sym $ q n ⟩∎
    p (suc n)                     ∎

  from∘to :
    Extensionality lzero _ →
    ∀ l → from (to l) ≡ l
  from∘to ext l@(p , q) = Σ-≡,≡→≡
    (apply-ext ext′ (from₁∘to l))
    (apply-ext ext λ n →

     subst (λ p → ∀ n → p (suc n) ≡ up n (p n))
       (apply-ext ext′ (from₁∘to l))
       (λ _ → refl _) n                                            ≡⟨ sym $ push-subst-application _ _ ⟩

     subst (λ p → p (suc n) ≡ up n (p n))
       (apply-ext ext′ (from₁∘to l))
       (refl _)                                                    ≡⟨ trans subst-in-terms-of-trans-and-cong $
                                                                      cong (trans _) $
                                                                      trans-reflˡ _ ⟩
     trans (sym $ cong (_$ suc n) (apply-ext ext′ (from₁∘to l)))
       (cong (λ p → up n (p n)) (apply-ext ext′ (from₁∘to l)))     ≡⟨ cong₂ trans
                                                                        (cong sym $ Eq.cong-good-ext ext _)
                                                                        (trans (sym $ cong-∘ _ _ _) $
                                                                         cong (cong _) $ Eq.cong-good-ext ext _) ⟩
     trans (sym $ from₁∘to l (suc n))
       (cong (up n) $ from₁∘to l n)                                ≡⟨⟩

     trans (sym $ trans (cong (up n) $ from₁∘to l n) (sym $ q n))
       (cong (up n) $ from₁∘to l n)                                ≡⟨ cong (flip trans _) $
                                                                      trans (sym-trans _ _) $
                                                                      cong (flip trans _) $
                                                                      sym-sym _ ⟩
     trans (trans (q n) (sym $ cong (up n) $ from₁∘to l n))
       (cong (up n) $ from₁∘to l n)                                ≡⟨ trans-[trans-sym]- _ _ ⟩∎

     q n                                                           ∎)
    where
    ext′ = Eq.good-ext ext

-- A variant of cochain-limit-↠ for simple cochains.

simple-cochain-limit-↠ :
  (∃ λ (f : ℕ → A) → ∀ n → f (suc n) ≡ f n) ↠ A
simple-cochain-limit-↠ = λ where
  ._↠_.logical-equivalence ._⇔_.to   (f , _)     → f 0
  ._↠_.logical-equivalence ._⇔_.from f₀ .proj₁ _ → f₀
  ._↠_.logical-equivalence ._⇔_.from f₀ .proj₂ _ → refl _
  ._↠_.right-inverse-of                          → refl

-- The first projection of the right-to-left direction of
-- simple-cochain-limit-↠ computes in a certain way.

_ : proj₁ (_↠_.from simple-cochain-limit-↠ x) n ≡ x
_ = refl _

-- A variant of cochain-limit for simple cochains.

simple-cochain-limit :
  {A : Type a} →
  (∃ λ (f : ℕ → A) → ∀ n → f (suc n) ≡ f n) ↝[ lzero ∣ a ] A
simple-cochain-limit =
  generalise-ext?
    (_↠_.logical-equivalence scl)
    (λ ext → _↠_.right-inverse-of scl , from∘to ext)
  where
  scl = simple-cochain-limit-↠

  open _↠_ scl

  from₁∘to : ∀ l n → proj₁ (from (to l)) n ≡ proj₁ l n
  from₁∘to _         zero    = refl _
  from₁∘to l@(f , p) (suc n) =
    proj₁ (from (to l)) n  ≡⟨ from₁∘to l n ⟩
    f n                    ≡⟨ sym $ p n ⟩∎
    f (suc n)              ∎

  from∘to :
    Extensionality lzero _ →
    ∀ l → from (to l) ≡ l
  from∘to ext l@(f , p) = Σ-≡,≡→≡
    (apply-ext ext′ (from₁∘to l))
    (apply-ext ext λ n →

     subst (λ f → ∀ n → f (suc n) ≡ f n)
       (apply-ext ext′ (from₁∘to l))
       (λ _ → refl _) n                                             ≡⟨ sym $ push-subst-application _ _ ⟩

     subst (λ f → f (suc n) ≡ f n)
       (apply-ext ext′ (from₁∘to l))
       (refl _)                                                     ≡⟨ trans subst-in-terms-of-trans-and-cong $
                                                                       cong (trans _) $
                                                                       trans-reflˡ _ ⟩
     trans (sym $ cong (_$ suc n) (apply-ext ext′ (from₁∘to l)))
       (cong (_$ n) (apply-ext ext′ (from₁∘to l)))                  ≡⟨ cong₂ trans
                                                                         (cong sym $ Eq.cong-good-ext ext _)
                                                                         (Eq.cong-good-ext ext _) ⟩
     trans (sym $ from₁∘to l (suc n)) (from₁∘to l n)                ≡⟨⟩

     trans (sym $ trans (from₁∘to l n) (sym $ p n)) (from₁∘to l n)  ≡⟨ cong (flip trans _) $
                                                                       trans (sym-trans _ _) $
                                                                       cong (flip trans _) $
                                                                       sym-sym _ ⟩

     trans (trans (p n) (sym $ from₁∘to l n)) (from₁∘to l n)        ≡⟨ trans-[trans-sym]- _ _ ⟩∎

     p n                                                            ∎)
    where
    ext′ = Eq.good-ext ext

-- The first projection of the right-to-left direction of
-- simple-cochain-limit computes in a certain way (at least when "k"
-- has certain values).

_ : proj₁ (_⇔_.from (simple-cochain-limit _) x) n ≡ x
_ = refl _

_ : proj₁ (_≃_.from (simple-cochain-limit ext) x) n ≡ x
_ = refl _

------------------------------------------------------------------------
-- Chains and containers

-- Containers can be applied to chains.

Container-chain :
  {I : Type i} {O : Type o} →
  Container₂ I O s p → Chain I ℓ → Chain O (s ⊔ p ⊔ ℓ)
Container-chain C = Σ-map (⟦ C ⟧ ∘_) (map C ∘_)

-- The polynomial functor (for a container C) of the limit of a chain
-- is pointwise equivalent to the limit of C applied to the chain
-- (assuming extensionality).
--
-- This is a variant of Lemma 13 in "Non-wellfounded trees in Homotopy
-- Type Theory".

⟦⟧-Limit≃ :
  {I : Type i} {O : Type o} →
  Extensionality p (s ⊔ p ⊔ ℓ) →
  (C : Container₂ I O s p) (X : Chain I ℓ) {o : O} →

  ⟦ C ⟧ (Limit X) o ≃ Limit (Container-chain C X) o
⟦⟧-Limit≃ {p = p} {s = s} {ℓ = ℓ} ext C X@(Q , down) {o = o} =

  ⟦ C ⟧ (Limit X) o                                            ↔⟨⟩

  (∃ λ (s : Shape C o) →
     (p : Position C s) → Limit X (index C p))                 ↝⟨ (∃-cong λ _ →
                                                                   universal-property-Π X) ⟩
  (∃ λ (s : Shape C o) →
   ∃ λ (f : ∀ n (p : Position C s) → Q n (index C p)) →
     ∀ n p → down n (index C p) (f (suc n) p) ≡ f n p)         ↝⟨ (∃-cong λ _ → ∃-cong λ _ →
                                                                   ∀-cong (lower-extensionality p r ext) λ _ →
                                                                   Eq.extensionality-isomorphism (lower-extensionality p r ext)) ⟩
  (∃ λ (s : Shape C o) →
   ∃ λ (f : ∀ n (p : Position C s) → Q n (index C p)) →
     ∀ n → down n _ ∘ f (suc n) ≡ f n)                         ↝⟨ (∃-cong λ _ → ∃-cong λ _ → ∀-cong (lower-extensionality p r ext) λ _ →
                                                                   ≡⇒↝ _ $ cong (_≡ _) $ sym $
                                                                   subst-refl _ _) ⟩
  (∃ λ (s : Shape C o) →
   ∃ λ (f : ∀ n (p : Position C s) → Q n (index C p)) →
     ∀ n → subst (λ s → (p : Position C s) → Q n (index C p))
             (refl _) (down n _ ∘ f (suc n)) ≡
           f n)                                                ↝⟨ (Σ-cong (inverse $
                                                                           simple-cochain-limit {k = equivalence}
                                                                             (lower-extensionality p r ext)) λ _ →
                                                                   F.id) ⟩
  (∃ λ ((s , eq) : ∃ λ (s : ℕ → Shape C o) →
                     ∀ n → s (suc n) ≡ s n) →
   ∃ λ (f : ∀ n (p : Position C (s n)) → Q n (index C p)) →
     ∀ n → subst (λ s → (p : Position C s) → Q n (index C p))
             (eq n) (down n _ ∘ f (suc n)) ≡
           f n)                                                ↔⟨ (∃-cong λ _ →
                                                                   (∃-cong λ _ →
                                                                    (∀-cong (lower-extensionality p r ext) λ _ →
                                                                     Bijection.Σ-≡,≡↔≡) F.∘
                                                                    inverse ΠΣ-comm) F.∘
                                                                   ∃-comm) F.∘
                                                                  inverse Σ-assoc ⟩
  (∃ λ (s : ℕ → Shape C o) →
   ∃ λ (f : ∀ n (p : Position C (s n)) → Q n (index C p)) →
     ∀ n → (s (suc n) , down n _ ∘ f (suc n)) ≡ (s n , f n))   ↔⟨⟩

  (∃ λ (s : ℕ → Shape C o) →
   ∃ λ (f : ∀ n (p : Position C (s n)) → Q n (index C p)) →
     ∀ n → map C (down n) o (s (suc n) , f (suc n)) ≡
           (s n , f n))                                        ↝⟨ (inverse $ Σ-cong-id (Eq.↔⇒≃ ΠΣ-comm)) F.∘
                                                                  Eq.↔⇒≃ Σ-assoc ⟩
  (∃ λ (f : ∀ n → ∃ λ (s : Shape C o) →
                    (p : Position C s) → Q n (index C p)) →
     ∀ n → map C (down n) o (f (suc n)) ≡ f n)                 ↔⟨⟩

  Limit (Container-chain C X) o                                □
  where
  r = s ⊔ p ⊔ ℓ

------------------------------------------------------------------------
-- M-types

private

  -- Up-to C n is the n-fold application of ⟦ C ⟧ to something
  -- trivial.

  Up-to : {I : Type i} → Container I s p → ℕ → I → Type (i ⊔ s ⊔ p)
  Up-to C zero    = λ _ → ↑ _ ⊤
  Up-to C (suc n) = ⟦ C ⟧ (Up-to C n)

  -- Up-to C is downwards closed.

  down : ∀ n → Up-to C (suc n) ⇾ Up-to C n
  down zero    = _
  down (suc n) = map _ (down n)

-- One can combine Up-to and down into a chain.

M-chain : {I : Type i} → Container I s p → Chain I (i ⊔ s ⊔ p)
M-chain C = Up-to C , down

-- An M-type for a given container.

M : {I : Type i} → Container I s p → I → Type (i ⊔ s ⊔ p)
M C = Limit (M-chain C)

-- M C is, in a certain sense, a fixpoint of ⟦ C ⟧ (assuming
-- extensionality).

M-fixpoint :
  Block "M-fixpoint" →
  {I : Type i} →
  Extensionality p (i ⊔ s ⊔ p) →
  {C : Container I s p} {i : I} →
  ⟦ C ⟧ (M C) i ≃ M C i
M-fixpoint ⊠ ext {C = C} {i = i} =
  ⟦ C ⟧ (M C) i                            ↔⟨⟩
  ⟦ C ⟧ (Limit (M-chain C)) i              ↝⟨ ⟦⟧-Limit≃ ext C (M-chain C) ⟩
  Limit (Container-chain C (M-chain C)) i  ↔⟨⟩
  Limit (shift (M-chain C)) i              ↝⟨ Limit-shift (M-chain C) (lower-extensionality _ lzero ext) ⟩
  Limit (M-chain C) i                      ↔⟨⟩
  M C i                                    □

-- One direction of the fixpoint.

out-M :
  Block "M-fixpoint" →
  {I : Type i} {C : Container I s p} →
  Extensionality p (i ⊔ s ⊔ p) →
  M C ⇾ ⟦ C ⟧ (M C)
out-M b ext _ = _≃_.from (M-fixpoint b ext)

-- The other direction of the fixpoint.

in-M :
  Block "M-fixpoint" →
  {I : Type i} {C : Container I s p} →
  Extensionality p (i ⊔ s ⊔ p) →
  ⟦ C ⟧ (M C) ⇾ M C
in-M b ext _ = _≃_.to (M-fixpoint b ext)

-- A "computation" rule for in-M.

in-M≡ :
  (b : Block "M-fixpoint")
  {I : Type i}
  (ext : Extensionality p (i ⊔ s ⊔ p)) →
  let ext′ = apply-ext $ Eq.good-ext $
             lower-extensionality p (i ⊔ s ⊔ p) ext
  in
  {C : Container I s p} {i : I}
  (x@(s , f) : ⟦ C ⟧ (M C) i) →
  in-M b ext _ x ≡
  ( ℕ-case _ (λ n → s , λ p → proj₁ (f p) n)
  , ℕ-case (refl _) (λ n → cong (s ,_) $ ext′ λ p → proj₂ (f p) n)
  )
in-M≡ {i = i} {p = p} {s = sℓ} ⊠ ext {C = C} x@(s , f) =
  ( ℕ-case _ (λ n → s , λ p → proj₁ (f p) n)
  , ℕ-case (refl _)
      (λ n → Σ-≡,≡→≡
         (refl _)
         (≡⇒→
            (cong (_≡ λ p → proj₁ (f p) n) $ sym $
             subst-refl _ _)
            (ext′ λ p → proj₂ (f p) n)))
  )                                                                 ≡⟨ cong (ℕ-case _ (λ n → s , λ p → proj₁ (f p) n) ,_) $
                                                                       cong (ℕ-case (refl _)) $
                                                                       apply-ext (lower-extensionality _ lzero ext) lemma ⟩∎
  ( ℕ-case _ (λ n → s , λ p → proj₁ (f p) n)
  , ℕ-case (refl _) (λ n → cong (s ,_) $ ext′ λ p → proj₂ (f p) n)
  )                                                                 ∎
  where
  ext′ =
    apply-ext $
    Eq.good-ext $
    lower-extensionality p (i ⊔ sℓ ⊔ p) ext

  lemma = λ n →
    Σ-≡,≡→≡
      (refl _)
      (≡⇒→
         (cong (_≡ λ p → proj₁ (f p) n) $ sym $
          subst-refl _ _)
         (ext′ λ p → proj₂ (f p) n))                ≡⟨ Σ-≡,≡→≡-reflˡ _ ⟩

    cong (_ ,_)
         (trans (sym $ subst-refl _ _) $
          ≡⇒→
            (cong (_≡ λ p → proj₁ (f p) n) $ sym $
             subst-refl _ _)
            (ext′ λ p → proj₂ (f p) n))             ≡⟨ cong (cong (_ ,_)) $ cong (trans _) $ sym $
                                                       subst-id-in-terms-of-≡⇒↝ equivalence ⟩
    cong (_ ,_)
         (trans (sym $ subst-refl _ _) $
          subst id
            (cong (_≡ λ p → proj₁ (f p) n) $ sym $
             subst-refl _ _)
            (ext′ λ p → proj₂ (f p) n))             ≡⟨ cong (cong (_ ,_)) $ cong (trans _) $ sym $
                                                       subst-∘ _ _ _ ⟩
    cong (_ ,_)
         (trans (sym $ subst-refl _ _) $
          subst (_≡ λ p → proj₁ (f p) n)
            (sym $ subst-refl _ _)
            (ext′ λ p → proj₂ (f p) n))             ≡⟨ cong (cong (_ ,_)) $ cong (trans _) $
                                                       subst-trans _ ⟩
    cong (_ ,_)
         (trans (sym $ subst-refl _ _) $
          trans (subst-refl _ _)
            (ext′ λ p → proj₂ (f p) n))             ≡⟨ cong (cong (_ ,_)) $
                                                       trans-sym-[trans] _ _ ⟩∎
    cong (_ ,_) (ext′ λ p → proj₂ (f p) n)          ∎

-- A coalgebra defined using M and out-M.

M-coalgebra :
  Block "M-fixpoint" →
  {I : Type i} →
  Extensionality p (i ⊔ s ⊔ p) →
  (C : Container I s p) → Coalgebra C
M-coalgebra b ext C = M C , out-M b ext

-- Definitions used to implement unfold.

private
 module Unfold
  ((P , f) : Coalgebra C)
  where
  up : ∀ n → P ⇾ Up-to C n
  up zero    = _
  up (suc n) = map C (up n) ∘⇾ f

  ok : ∀ n → down n ∘⇾ up (suc n) ≡ up n
  ok zero    = refl _
  ok (suc n) =
    map C (down n ∘⇾ up (suc n)) ∘⇾ f  ≡⟨ cong (λ g → map C g ∘⇾ f) $ ok n ⟩∎
    map C (up n) ∘⇾ f                  ∎

-- A direct implementation of an unfold operation.

unfold :
  ((P , _) : Coalgebra C) →
  P ⇾ M C
unfold Y i p =
    (λ n → up n i p)
  , (λ n → cong (λ f → f i p) (ok n))
  where
  open Unfold Y

-- Definitions used to implement M-final.

private
 module M-final
  (b : Block "M-fixpoint")
  {I : Type i} {C : Container I s p}
  (ext : Extensionality p (i ⊔ s ⊔ p))
  (ext′ : Extensionality (i ⊔ s ⊔ p) (i ⊔ s ⊔ p))
  (Y@(P , f) : Coalgebra C)
  where

  step : P ⇾ Q → P ⇾ ⟦ C ⟧ Q
  step h = map C h ∘⇾ f

  univ : Cone P (M-chain C) → P ⇾ M C
  univ = _≃_.from (universal-property-≃ ext′ (M-chain C))

  steps₁ : (∀ n → P ⇾ Up-to C n) → (∀ n → P ⇾ Up-to C n)
  steps₁ g n i p =
    ℕ-case
      {P = λ n → Up-to C n i}
      _
      (λ n → step (g n) i p)
      n

  Eq : (∀ n → P ⇾ Up-to C n) → Type (i ⊔ s ⊔ p)
  Eq g = ∀ n → down n ∘⇾ g (suc n) ≡ g n

  steps₂ : {g : ∀ n → P ⇾ Up-to C n} → Eq g → Eq (steps₁ g)
  steps₂         p zero    = refl _
  steps₂ {g = g} p (suc n) =
    down (suc n) ∘⇾ steps₁ g (suc (suc n))  ≡⟨⟩
    step (down n ∘⇾ g (suc n))              ≡⟨ cong step (p n) ⟩∎
    step (g n)                              ∎

  steps : Cone P (M-chain C) → Cone P (M-chain C)
  steps = Σ-map steps₁ steps₂

  ext-i : Extensionality i (i ⊔ s ⊔ p)
  ext-i = lower-extensionality (s ⊔ p) lzero ext′

  ext₀ : Extensionality lzero (i ⊔ s ⊔ p)
  ext₀ = lower-extensionality _ lzero ext

  ext₀′ :
    {A : Type} {P : A → Type (i ⊔ s ⊔ p)} →
    Extensionality′ A P
  ext₀′ = apply-ext (Eq.good-ext ext₀)

  ≡univ-steps : ∀ c → in-M b ext ∘⇾ step (univ c) ≡ univ (steps c)
  ≡univ-steps c@(g , eq) = apply-ext ext-i λ i → apply-ext ext′ λ p →
    in-M b ext i (step (univ c) i p)                                  ≡⟨ in-M≡ b ext (step (univ c) i p) ⟩

    ( (λ n → steps₁ g n i p)
    , ℕ-case (refl _)
        (λ n →
           cong (proj₁ (f i p) ,_)
             (ext‴ λ p′ →
              ext⁻¹ (ext⁻¹ (eq n) (index C p′)) (proj₂ (f i p) p′)))
    )                                                                 ≡⟨ cong ((λ n → steps₁ g n i p) ,_) $
                                                                         ext₀′ $ ℕ-case
                                                                           (
        refl _                                                              ≡⟨ sym $ ext⁻¹-refl _ {x = p} ⟩
        ext⁻¹ (refl _) p                                                    ≡⟨ cong (flip ext⁻¹ p) $ sym $ ext⁻¹-refl _ ⟩
        ext⁻¹ (ext⁻¹ {B = λ x → P x → ↑ _ ⊤} (refl _) i) p                  ≡⟨⟩
        ext⁻¹ (ext⁻¹ (steps₂ eq zero) i) p                                  ∎)
                                                                           (λ n →
        cong (proj₁ (f i p) ,_)
          (ext‴ λ p′ →
           ext⁻¹ (ext⁻¹ (eq n) (index C p′)) (proj₂ (f i p) p′))              ≡⟨ elim₁
                                                                                (λ eq →
                                                                                cong (proj₁ (f i p) ,_)
                                                                                (ext‴ λ p′ →
                                                                                ext⁻¹ (ext⁻¹ eq (index C p′)) (proj₂ (f i p) p′)) ≡
                                                                                ext⁻¹ (ext⁻¹ (cong (λ g → map C g ∘⇾ f) eq) i) p)
                                                                                (
            cong (proj₁ (f i p) ,_)
              (ext‴ λ p′ →
               ext⁻¹ (ext⁻¹ (refl (g n)) (index C p′))
                 (proj₂ (f i p) p′))                                                ≡⟨ (cong (cong _) $
                                                                                cong ext‴ $ ext‴ λ _ →
                                                                                trans (cong (flip ext⁻¹ _) $
                                                                                ext⁻¹-refl _) $
                                                                                ext⁻¹-refl _) ⟩

            cong (proj₁ (f i p) ,_) (ext‴ λ _ → refl _)                            ≡⟨ trans (cong (cong _) $
                                                                                Eq.good-ext-refl ext″ _) $
                                                                                cong-refl _ ⟩

            refl _                                                                  ≡⟨ sym $
                                                                                trans (cong (flip ext⁻¹ _) $
                                                                                trans (cong (flip ext⁻¹ _) $
                                                                                cong-refl _) $
                                                                                ext⁻¹-refl _) $
                                                                                ext⁻¹-refl _ ⟩∎
            ext⁻¹ (ext⁻¹ (cong step (refl (g n))) i) p                              ∎)
                                                                                (eq n) ⟩
        ext⁻¹ (ext⁻¹ (cong step (eq n)) i) p                                  ∎) ⟩

    ( (λ n → steps₁ g n i p)
    , (λ n → ext⁻¹ (ext⁻¹ (steps₂ eq n) i) p)
    )                                                                 ≡⟨⟩

    univ (steps c) i p                                                ∎
    where
    ext″ = lower-extensionality p (i ⊔ s ⊔ p) ext
    ext‴ = apply-ext (Eq.good-ext ext″)

  contr : Contractible (P ⇾ Up-to C 0)
  contr =
    Π-closure ext-i 0 λ _ →
    Π-closure ext′ 0 λ _ →
    ↑-closure 0 ⊤-contractible

  steps₁-fixpoint≃ :
    {g : ∀ n → P ⇾ Up-to C n} →
    (g ≡ steps₁ g) ≃ (∀ n → g (suc n) ≡ step (g n))
  steps₁-fixpoint≃ {g = g} =
    g ≡ steps₁ g                                             ↝⟨ inverse $ Eq.extensionality-isomorphism ext₀ ⟩

    (∀ n → g n ≡ steps₁ g n)                                 ↝⟨ Πℕ≃ ext₀ ⟩

    g 0 ≡ steps₁ g 0 × (∀ n → g (suc n) ≡ steps₁ g (suc n))  ↔⟨⟩

    (λ _ _ → lift tt) ≡ (λ _ _ → lift tt) ×
    (∀ n → g (suc n) ≡ step (g n))                           ↔⟨ (drop-⊤-left-× λ _ →
                                                                 _⇔_.to contractible⇔↔⊤ $
                                                                 H-level.⇒≡ 0 contr) ⟩□
    (∀ n → g (suc n) ≡ step (g n))                           □

  cochain₁ : Cochain (i ⊔ s ⊔ p)
  cochain₁ = (λ n → P ⇾ Up-to C n)
           , (λ _ → step)

  cl₁← : P ⇾ Up-to C 0 → ∀ n → P ⇾ Up-to C n
  cl₁← = proj₁ ∘ _↠_.from (cochain-limit-↠ cochain₁)

  ⇾↔⊤ : (P ⇾ Up-to C 0) ↔ ⊤
  ⇾↔⊤ = _⇔_.to contractible⇔↔⊤ contr

  g₀ : P ⇾ Up-to C 0
  g₀ = _↔_.from ⇾↔⊤ _

  steps₁-fixpoint : ∀ n → cl₁← g₀ n ≡ steps₁ (cl₁← g₀) n
  steps₁-fixpoint = ℕ-case (refl _) (λ _ → refl _)

  steps₁-fixpoint-lemma :
    {p : Eq (cl₁← g₀)} →
    subst Eq (_≃_.from steps₁-fixpoint≃ (λ _ → refl _)) p n ≡
    trans (p n) (steps₁-fixpoint n)
  steps₁-fixpoint-lemma {n = n} {p = p} =
    subst Eq (_≃_.from steps₁-fixpoint≃ (λ _ → refl _)) p n    ≡⟨⟩

    subst Eq (ext₀′ (ℕ-case _ (λ _ → refl _))) p n             ≡⟨ cong (λ eq → subst Eq eq p n) $
                                                                  cong ext₀′ $
                                                                  cong (flip ℕ-case _) $
                                                                  H-level.mono (Nat.zero≤ 2) contr _ _ ⟩

    subst Eq (ext₀′ steps₁-fixpoint) p n                       ≡⟨ sym $ push-subst-application _ _ ⟩

    subst (λ g → down n ∘⇾ g (suc n) ≡ g n)
      (ext₀′ steps₁-fixpoint) (p n)                            ≡⟨ trans subst-in-terms-of-trans-and-cong $
                                                                  cong (flip trans _) $ cong sym $ sym $
                                                                  cong-∘ _ _ _ ⟩
    trans (sym (cong (down n ∘⇾_)
                  (cong (_$ suc n) (ext₀′ steps₁-fixpoint))))
      (trans (p n) (cong (_$ n) (ext₀′ steps₁-fixpoint)))      ≡⟨ cong₂ (λ eq₁ eq₂ → trans (sym (cong (down n ∘⇾_) eq₁)) (trans _ eq₂))
                                                                    (Eq.cong-good-ext ext₀ _)
                                                                    (Eq.cong-good-ext ext₀ _) ⟩
    trans (sym (cong (down n ∘⇾_) (steps₁-fixpoint (suc n))))
      (trans (p n) (steps₁-fixpoint n))                        ≡⟨⟩

    trans (sym (cong (down n ∘⇾_) (refl _)))
      (trans (p n) (steps₁-fixpoint n))                        ≡⟨ trans (cong (flip trans _) $
                                                                         trans (cong sym $ cong-refl _)
                                                                         sym-refl) $
                                                                  trans-reflˡ _ ⟩∎
    trans (p n) (steps₁-fixpoint n)                            ∎

  cochain₂ : Cochain (i ⊔ s ⊔ p)
  cochain₂ = (λ n → down n ∘⇾ step (cl₁← g₀ n) ≡ cl₁← g₀ n)
           , (λ _ → cong step)

  equiv : Block "equiv" → (Y ⇨ M-coalgebra b ext C) ≃ ⊤
  equiv ⊠ =
    Y ⇨ M-coalgebra b ext C                                             ↔⟨⟩

    (∃ λ (h : P ⇾ M C) → out-M b ext ∘⇾ h ≡ step h)                     ↝⟨ (∃-cong λ _ → inverse $
                                                                            Eq.≃-≡ $ ∀-cong ext-i λ _ → ∀-cong ext′ λ _ →
                                                                            M-fixpoint b ext) ⟩
    (∃ λ (h : P ⇾ M C) →
       (in-M b ext ∘⇾ out-M b ext) ∘⇾ h ≡ in-M b ext ∘⇾ step h)         ↝⟨ (∃-cong λ h → ≡⇒↝ _ $ cong (_≡ in-M b ext ∘⇾ step h) $
                                                                            apply-ext ext-i λ _ → apply-ext ext′ λ _ →
                                                                            _≃_.right-inverse-of (M-fixpoint b ext) _) ⟩

    (∃ λ (h : P ⇾ M C) → h ≡ in-M b ext ∘⇾ step h)                      ↝⟨ (inverse $
                                                                            Σ-cong (inverse $ universal-property-≃ ext′ (M-chain C)) λ _ →
                                                                            F.id) ⟩
    (∃ λ (c : Cone P (M-chain C)) →
       univ c ≡ in-M b ext ∘⇾ step (univ c))                            ↝⟨ (∃-cong λ c → ≡⇒↝ _ $ cong (univ c ≡_) $ ≡univ-steps c) ⟩

    (∃ λ (c : Cone P (M-chain C)) → univ c ≡ univ (steps c))            ↝⟨ (∃-cong λ _ →
                                                                            Eq.≃-≡ $ inverse $ universal-property-≃ ext′ (M-chain C)) ⟩

    (∃ λ (c : Cone P (M-chain C)) → c ≡ steps c)                        ↔⟨ (∃-cong λ _ → inverse
                                                                            Bijection.Σ-≡,≡↔≡) ⟩
    (∃ λ ((g , p) : Cone P (M-chain C)) →
     ∃ λ (q : g ≡ steps₁ g) → subst Eq q p ≡ steps₂ p)                  ↔⟨ Σ-assoc F.∘
                                                                           (∃-cong λ _ → ∃-comm) F.∘
                                                                           inverse Σ-assoc ⟩
    (∃ λ ((g , q) : ∃ λ (g : ∀ n → P ⇾ Up-to C n) → g ≡ steps₁ g) →
     ∃ λ (p : Eq g) → subst Eq q p ≡ steps₂ p)                          ↝⟨ (inverse $
                                                                            Σ-cong (inverse $
                                                                                ∃-cong λ _ →
                                                                                steps₁-fixpoint≃) λ _ →
                                                                            F.id) ⟩
    (∃ λ ((g , q) : ∃ λ (g : ∀ n → P ⇾ Up-to C n) →
                      ∀ n → g (suc n) ≡ step (g n)) →
     ∃ λ (p : Eq g) →
       subst Eq (_≃_.from steps₁-fixpoint≃ q) p ≡ steps₂ p)             ↝⟨ (inverse $
                                                                            Σ-cong (inverse $
                                                                                cochain-limit cochain₁ {k = equivalence} ext₀) λ _ →
                                                                            F.id) ⟩
    (∃ λ (g : P ⇾ Up-to C 0) →
     ∃ λ (p : Eq (cl₁← g)) →
       subst Eq (_≃_.from steps₁-fixpoint≃ (λ _ → refl _)) p ≡
       steps₂ p)                                                        ↔⟨ drop-⊤-left-Σ ⇾↔⊤ ⟩

    (∃ λ (p : Eq (cl₁← g₀)) →
       subst Eq (_≃_.from steps₁-fixpoint≃ (λ _ → refl _)) p ≡
       steps₂ p)                                                        ↝⟨ (∃-cong λ _ → inverse $
                                                                            Eq.extensionality-isomorphism ext₀) ⟩
    (∃ λ (p : Eq (cl₁← g₀)) →
       ∀ n → subst Eq (_≃_.from steps₁-fixpoint≃ (λ _ → refl _)) p n ≡
             steps₂ p n)                                                ↝⟨ (∃-cong λ p → ∀-cong ext₀ λ n → ≡⇒↝ _ $ cong (_≡ steps₂ p n)
                                                                            steps₁-fixpoint-lemma) ⟩
    (∃ λ (p : Eq (cl₁← g₀)) →
       ∀ n → trans (p n) (steps₁-fixpoint n) ≡ steps₂ p n)              ↝⟨ (∃-cong λ _ → ∀-cong ext₀ λ _ → ≡⇒↝ _ $
                                                                            [trans≡]≡[≡trans-symʳ] _ _ _) ⟩
    (∃ λ (p : Eq (cl₁← g₀)) →
       ∀ n → p n ≡ trans (steps₂ p n) (sym (steps₁-fixpoint n)))        ↝⟨ (∃-cong λ _ →
                                                                            Πℕ≃ ext₀) ⟩
    (∃ λ (p : Eq (cl₁← g₀)) →
       p zero ≡ trans (steps₂ p zero) (sym (steps₁-fixpoint zero)) ×
       (∀ n → p (suc n) ≡
              trans (steps₂ p (suc n))
                (sym (steps₁-fixpoint (suc n)))))                       ↔⟨ (∃-cong λ _ → drop-⊤-left-× λ _ →
                                                                            _⇔_.to contractible⇔↔⊤ $
                                                                            H-level.⇒≡ 0 $ H-level.⇒≡ 0 contr) ⟩
    (∃ λ (p : Eq (cl₁← g₀)) →
       ∀ n → p (suc n) ≡
             trans (steps₂ p (suc n)) (sym (steps₁-fixpoint (suc n))))  ↔⟨⟩

    (∃ λ (p : Eq (cl₁← g₀)) →
       ∀ n → p (suc n) ≡
             trans (cong step (p n)) (sym (refl _)))                    ↝⟨ (∃-cong λ _ → ∀-cong ext₀ λ _ → ≡⇒↝ _ $ cong (_ ≡_) $
                                                                            trans (cong (trans _) sym-refl) $
                                                                            trans-reflʳ _) ⟩
    (∃ λ (p : Eq (cl₁← g₀)) →
       ∀ n → p (suc n) ≡ cong step (p n))                               ↝⟨ cochain-limit cochain₂ ext₀ ⟩

    down {C = C} 0 ∘⇾ step (cl₁← g₀ 0) ≡ cl₁← g₀ 0                      ↔⟨ _⇔_.to contractible⇔↔⊤ $
                                                                           H-level.⇒≡ 0 contr ⟩□
    ⊤                                                                   □

  -- The definition of M-final is set up so that it returns unfold Y
  -- rather than the function obtained directly from equiv. Here it is
  -- shown that the two functions are equal.

  ≡-unfold : ∀ b → proj₁ (_≃_.from (equiv b) _) ≡ unfold Y
  ≡-unfold ⊠ =
    apply-ext ext-i λ i → apply-ext ext′ λ p →
    Σ-≡,≡→≡
      (ext₀′ λ n → cong (λ f → f i p) (lemma₁ n))
      (lemma₃ i p)
    where

    -- Pieces of the function obtained from equiv.
    --
    -- These pieces are rather similar to pieces of unfold. I chose to
    -- implement unfold using explicit pattern matching rather than
    -- ℕ-rec to ensure that things do not unfold too much.

    up′ : ∀ n → P ⇾ Up-to C n
    up′ = ℕ-rec _ (λ _ ih → map C ih ∘⇾ f)

    ok′ : ∀ n → down n ∘⇾ up′ (suc n) ≡ up′ n
    ok′ = ℕ-rec
      (proj₁ (H-level.⇒≡ 0 contr))
      (λ _ → cong step)

    lemma₁ : ∀ n → up′ n ≡ Unfold.up Y n
    lemma₁ zero    = refl _
    lemma₁ (suc n) =
      step (up′ n)          ≡⟨ cong step $ lemma₁ n ⟩∎
      step (Unfold.up Y n)  ∎

    lemma₂ :
      ∀ n →
      trans (sym (cong (down n ∘⇾_) (lemma₁ (suc n))))
        (trans (ok′ n) (lemma₁ n)) ≡
      Unfold.ok Y n
    lemma₂ zero =
      trans (sym (cong (const _) (cong step (refl _))))
        (trans (proj₁ (H-level.⇒≡ 0 contr)) (refl _))    ≡⟨ trans (cong (flip trans _) $
                                                                   trans (cong sym $ cong-const _) $
                                                                   sym-refl) $
                                                            trans (trans-reflˡ _) $
                                                            trans-reflʳ _ ⟩

      proj₁ (H-level.⇒≡ 0 contr)                         ≡⟨ H-level.mono (Nat.zero≤ 2) contr _ _ ⟩∎

      refl _                                             ∎
    lemma₂ (suc n) =
      trans (sym (cong (down (1 + n) ∘⇾_) (lemma₁ (2 + n))))
        (trans (ok′ (1 + n)) (lemma₁ (1 + n)))                           ≡⟨⟩

      trans (sym (cong (map C (down n) ∘⇾_)
                    (cong step (lemma₁ (suc n)))))
        (trans (cong step (ok′ n)) (cong step (lemma₁ n)))               ≡⟨ cong (flip trans _) $ cong sym $
                                                                            cong-∘ _ _ _ ⟩
      trans (sym (cong ((map C (down n) ∘⇾_) ∘ step) (lemma₁ (suc n))))
        (trans (cong step (ok′ n)) (cong step (lemma₁ n)))               ≡⟨⟩

      trans (sym (cong (step ∘ (down n ∘⇾_)) (lemma₁ (suc n))))
        (trans (cong step (ok′ n)) (cong step (lemma₁ n)))               ≡⟨ sym $
                                                                            trans (cong-trans _ _ _) $
                                                                            cong₂ trans
                                                                              (trans (cong-sym _ _) $
                                                                               cong sym $ cong-∘ _ _ _)
                                                                              (cong-trans _ _ _) ⟩
      cong step
        (trans (sym (cong (down n ∘⇾_) (lemma₁ (suc n))))
           (trans (ok′ n) (lemma₁ n)))                                   ≡⟨ cong (cong _) $ lemma₂ n ⟩

      cong step (Unfold.ok Y n)                                          ≡⟨⟩

      Unfold.ok Y (1 + n)                                                ∎

    lemma₃ :
      ∀ i p →
      subst (λ f → ∀ n → down n i (f (suc n)) ≡ f n)
        (ext₀′ λ n → cong (λ f → f i p) (lemma₁ n))
        (cong (_$ p) ∘ cong (_$ i) ∘ ok′) ≡
      (λ n → cong (λ f → f i p) (Unfold.ok Y n))
    lemma₃ i p = ext₀′ λ n →
      subst (λ f → ∀ n → down n i (f (suc n)) ≡ f n)
        (ext₀′ λ n → cong (λ f → f i p) (lemma₁ n))
        (cong (_$ p) ∘ cong (_$ i) ∘ ok′) n                            ≡⟨ sym $
                                                                          push-subst-application _ _ ⟩
      subst (λ f → down n i (f (suc n)) ≡ f n)
        (ext₀′ λ n → cong (λ f → f i p) (lemma₁ n))
        (cong (_$ p) (cong (_$ i) (ok′ n)))                            ≡⟨ cong (subst (λ f → down n i (f (suc n)) ≡ f n) _) $
                                                                          cong-∘ _ _ _ ⟩
      subst (λ f → down n i (f (suc n)) ≡ f n)
        (ext₀′ λ n → cong (λ f → f i p) (lemma₁ n))
        (cong (λ f → f i p) (ok′ n))                                   ≡⟨ subst-in-terms-of-trans-and-cong ⟩

      trans (sym (cong (λ f → down n i (f (suc n)))
                    (ext₀′ λ n → cong (λ f → f i p) (lemma₁ n))))
        (trans (cong (λ f → f i p) (ok′ n))
           (cong (_$ n) (ext₀′ λ n → cong (λ f → f i p) (lemma₁ n))))  ≡⟨ cong₂ (λ eq₁ eq₂ →
                                                                                trans (sym eq₁) (trans (cong (λ f → f i p) (ok′ n)) eq₂))
                                                                            (trans (sym $ cong-∘ _ _ _) $
                                                                             cong (cong _) $
                                                                             Eq.cong-good-ext ext₀ _)
                                                                            (Eq.cong-good-ext ext₀ _) ⟩
      trans (sym (cong (down n i)
                    (cong (λ f → f i p) (lemma₁ (suc n)))))
        (trans (cong (λ f → f i p) (ok′ n))
           (cong (λ f → f i p) (lemma₁ n)))                            ≡⟨ cong (flip trans _) $ cong sym $
                                                                          cong-∘ _ _ _ ⟩
      trans (sym (cong (λ f → down n i (f i p)) (lemma₁ (suc n))))
        (trans (cong (λ f → f i p) (ok′ n))
           (cong (λ f → f i p) (lemma₁ n)))                            ≡⟨ sym $
                                                                          trans (cong-trans _ _ _) $
                                                                          cong₂ trans
                                                                            (trans (cong-sym _ _) $
                                                                             cong sym $
                                                                             cong-∘ _ _ _)
                                                                            (cong-trans _ _ _) ⟩
      cong (λ f → f i p)
        (trans (sym (cong (down n ∘⇾_) (lemma₁ (suc n))))
           (trans (ok′ n) (lemma₁ n)))                                 ≡⟨ cong (cong _) $ lemma₂ n ⟩∎

      cong (λ f → f i p) (Unfold.ok Y n)                               ∎

  unfold-lemma :
    Block "equiv" →
    out-M b ext ∘⇾ unfold Y ≡ map _ (unfold Y) ∘⇾ f
  unfold-lemma b′ =
    subst
       (λ h → out-M b ext ∘⇾ h ≡ map C h ∘⇾ f)
       (≡-unfold b′)
       (proj₂ (_≃_.from (equiv b′) _))

  unfold-morphism :
    Block "equiv" → Y ⇨ M-coalgebra b ext C
  unfold-morphism b = unfold Y , unfold-lemma b

  ≡-unfold-morphism : ∀ b → _≃_.from (equiv b) _ ≡ unfold-morphism b
  ≡-unfold-morphism b =
    Σ-≡,≡→≡ (≡-unfold b) (refl (unfold-lemma b))

  M-final : Contractible (Y ⇨ M-coalgebra b ext C)
  M-final =
    block λ b →
    _↔_.from (contractible↔≃⊤ ext′) $
    Eq.with-other-inverse
      (equiv b)
      (λ _ → unfold-morphism b)
      (λ _ → ≡-unfold-morphism b)

  -- Note that unfold is not blocked, but that the other pieces are.

  M-final-partly-blocked :
    Block "M-final" →
    Contractible (Y ⇨ M-coalgebra b ext C)
  M-final-partly-blocked _ .proj₁ .proj₁ = unfold Y
  M-final-partly-blocked ⊠ .proj₁ .proj₂ = M-final .proj₁ .proj₂
  M-final-partly-blocked ⊠ .proj₂        = M-final .proj₂

-- M-coalgebra b ext C is a final coalgebra (assuming extensionality).
--
-- This is a variant of Theorem 7 from "Non-wellfounded trees in
-- Homotopy Type Theory".

M-final :
  (b : Block "M-final")
  {I : Type i} {C : Container I s p} →
  (ext : Extensionality p (i ⊔ s ⊔ p)) →
  Extensionality (i ⊔ s ⊔ p) (i ⊔ s ⊔ p) →
  Final (M-coalgebra b ext C)
M-final b ext ext′ Y =
  M-final.M-final-partly-blocked b ext ext′ Y b

-- The morphism returned by M-final is definitionally equal to an
-- instance of unfold.

_ :
  {Y : Coalgebra C} →
  proj₁ (proj₁ (M-final b ext₁ ext₂ Y)) ≡ unfold Y
_ = refl _

------------------------------------------------------------------------
-- H-levels

-- If the shape types of C have h-level n, then M C i has h-level n
-- (assuming extensionality).
--
-- This is a variant of Lemma 14 from "Non-wellfounded trees in
-- Homotopy Type Theory".

H-level-M :
  Extensionality p (i ⊔ s ⊔ p) →
  {I : Type i} {C : Container I s p} {i : I} →
  (∀ i → H-level n (Shape C i)) →
  H-level n (M C i)
H-level-M {p = p} {i = iℓ} {n = m} ext {C = C} hyp =
  Σ-closure m
    (Π-closure ext′ m
     H-level-Up-to) λ _ →
  Π-closure ext′ m $
  H-level.⇒≡ m ∘ H-level-Up-to
  where
  ext′ = lower-extensionality _ lzero ext

  step :
    ∀ P → (∀ {i} → H-level m (P i)) → (∀ {i} → H-level m (⟦ C ⟧ P i))
  step P h =
    Σ-closure m (hyp _) λ _ →
    Π-closure ext m λ _ →
    h

  H-level-Up-to : ∀ n → H-level m (Up-to C n i)
  H-level-Up-to (suc n) = step (Up-to C n) (H-level-Up-to n)
  H-level-Up-to zero    =
    ↑-closure m (H-level.mono (Nat.zero≤ m) ⊤-contractible)

-- If the shape types of C have h-level n, then F i has h-level n,
-- where F is the carrier of any final coalgebra of C, and "final
-- coalgebra" is defined using Final′. (Assuming extensionality.)

H-level-final-coalgebra′ :
  Extensionality (i ⊔ s ⊔ p) (i ⊔ s ⊔ p) →
  {I : Type i} {C : Container I s p} {i : I} →
  (((X , _) , _) : Final-coalgebra′ C) →
  (∀ i → H-level n (Shape C i)) →
  H-level n (X i)
H-level-final-coalgebra′
  {i = iℓ} {s = s} {n = n} ext {C = C} {i = i} F@((X , _) , _) =
  block λ b →

  (∀ i → H-level n (Shape C i))  ↝⟨ H-level-M ext′ ⟩
  H-level n (M C i)              ↝⟨ H-level-cong _ n $
                                    carriers-of-final-coalgebras-equivalent′
                                      (Final-coalgebra→Final-coalgebra′ $
                                       M-coalgebra b ext′ C , M-final b ext′ ext)
                                      F _ ⟩□
  H-level n (X i)                □
  where
  ext′ = lower-extensionality (iℓ ⊔ s) lzero ext

-- The previous result holds also if Final-coalgebra′ is replaced by
-- Final-coalgebra.

H-level-final-coalgebra :
  Extensionality (i ⊔ s ⊔ p) (i ⊔ s ⊔ p) →
  {I : Type i} {C : Container I s p} {i : I} →
  (((X , _) , _) : Final-coalgebra C) →
  (∀ i → H-level n (Shape C i)) →
  H-level n (X i)
H-level-final-coalgebra ext =
  H-level-final-coalgebra′ ext ∘
  Final-coalgebra→Final-coalgebra′


{-# OPTIONS -Wall #-}

module noinfixdecl where

-- warning acts on data constructors
data #2 : Set where
  one  : #2
  two  : #2
  neg_ : #2 → #2

-- warning acts on definitions
infixl 3 _⊓_
_⊔_ : #2 → #2 → #2
_⊓_ : #2 → #2 → #2

one     ⊔ n = n
two     ⊔ n = two
(neg v) ⊔ n = neg (v ⊓ neg n)

one     ⊓ n = one
two     ⊓ n = n
(neg m) ⊓ n = neg (m ⊔ (neg n))

-- warning acts on postulates
postulate _≤_ : #2 → #2 → Set

-- warning does not act on 'closed' mixfix definitions
postulate [_] : #2 → Set


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.Sn.Properties where

open import Cubical.Data.Int hiding (_+_)
open import Cubical.Data.Bool
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Function
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Univalence
open import Cubical.HITs.S1
open import Cubical.HITs.S3
open import Cubical.Data.Nat
open import Cubical.Data.Prod
open import Cubical.HITs.Sn.Base
open import Cubical.HITs.Susp
open import Cubical.Data.Unit
open import Cubical.HITs.Join
open import Cubical.HITs.Pushout
open import Cubical.HITs.SmashProduct
open import Cubical.HITs.PropositionalTruncation

open Iso

private
  variable
    ℓ ℓ' : Level
    A : Type ℓ
    B : Type ℓ'

--- Some silly lemmas on S1 ---

isGroupoidS1 : isGroupoid (S₊ 1)
isGroupoidS1 = isGroupoidS¹

isConnectedS1 : (x : S₊ 1) → ∥ base ≡ x ∥
isConnectedS1 = isConnectedS¹


module Categories.Functor.Construction.Exponential where

open import Categories.Category
open import Categories.Category.Product using (Product)
open import Categories.Category.CartesianClosed
open import Categories.Category.Cartesian
open import Categories.Category.BinaryProducts
open import Categories.Object.Exponential
open import Categories.Functor.Bifunctor

open import Data.Product using (_,_; proj₁; proj₂)

module _ {o ℓ e} (𝒞 : Category o ℓ e) (cartesianClosed : CartesianClosed 𝒞) where
  open import Categories.Morphism.Reasoning 𝒞

  open CartesianClosed cartesianClosed
  open Cartesian cartesian
  open BinaryProducts products

  open Category 𝒞
  open Equiv

  private
    P : Category _ _ _
    P = Product 𝒞 op

  Exp : Bifunctor 𝒞 (Category.op 𝒞) 𝒞
  Exp = record
              { F₀ = λ (x , y) → x ^ y
              ; F₁ = λ (f , g) → λg (f ∘ eval′ ∘ (id ⁂ g))
              ; identity = λ {A} →
                  begin
                    λg (id ∘ eval′ ∘ (id ⁂ id))
                  ≈⟨ λ-cong identityˡ ⟩
                    λg (eval′ ∘ (id ⁂ id))
                  ≈⟨ λ-cong (elimʳ (Equiv.trans (⟨⟩-cong₂ identityˡ identityˡ) η)) ⟩
                    λg eval′
                  ≈⟨ η-id′ ⟩
                    id
                  ∎
              ; homomorphism = λ {X} {Y} {Z} {f} {g} →
                  begin
                    λg ((proj₁ g ∘ proj₁ f) ∘ eval′ ∘ (id ⁂ (proj₂ f ∘ proj₂ g)))
                  ≈⟨ λ-cong assoc ⟩
                    λg (proj₁ g ∘ proj₁ f ∘ eval′ ∘ (id ⁂ proj₂ f ∘ proj₂ g))
                  ≈˘⟨ λ-cong (∘-resp-≈ʳ (∘-resp-≈ʳ (∘-resp-≈ʳ (trans ⁂∘⁂ (⁂-cong₂ identity² refl))))) ⟩
                    λg (proj₁ g ∘ proj₁ f ∘ eval′ ∘ (id ⁂ proj₂ f) ∘ (id ⁂ proj₂ g))
                  ≈˘⟨ λ-cong (∘-resp-≈ʳ assoc²') ⟩
                    λg (proj₁ g ∘ (proj₁ f ∘ eval′ ∘ (id ⁂ proj₂ f)) ∘ (id ⁂ proj₂ g))
                  ≈˘⟨ λ-cong (∘-resp-≈ʳ (pullˡ β′)) ⟩
                    λg (proj₁ g ∘ eval′ ∘ (λg (proj₁ f ∘ eval′ ∘ (id ⁂ proj₂ f)) ⁂ id) ∘ (id ⁂ proj₂ g))
                  ≈⟨ λ-cong (∘-resp-≈ʳ (∘-resp-≈ʳ ⁂∘⁂)) ⟩
                    λg (proj₁ g ∘ eval′ ∘ (λg (proj₁ f ∘ eval′ ∘ (id ⁂ proj₂ f)) ∘ id ⁂ id ∘ proj₂ g))
                  ≈⟨ λ-cong (∘-resp-≈ʳ (∘-resp-≈ʳ (⁂-cong₂ (trans identityʳ (sym identityˡ)) (trans identityˡ (sym identityʳ))))) ⟩
                    λg (proj₁ g ∘ eval′ ∘ (id ∘ λg (proj₁ f ∘ eval′ ∘ (id ⁂ proj₂ f)) ⁂ proj₂ g ∘ id))
                  ≈˘⟨ λ-cong (∘-resp-≈ʳ (∘-resp-≈ʳ ⁂∘⁂)) ⟩
                    λg (proj₁ g ∘ eval′ ∘ (id ⁂ proj₂ g) ∘ (λg (proj₁ f ∘ eval′ ∘ (id ⁂ proj₂ f)) ⁂ id))
                  ≈˘⟨ λ-cong assoc²' ⟩
                    λg ((proj₁ g ∘ eval′ ∘ (id ⁂ proj₂ g)) ∘ (λg (proj₁ f ∘ eval′ ∘ (id ⁂ proj₂ f)) ⁂ id))
                  ≈˘⟨ exp.subst product product ⟩
                    λg (proj₁ g ∘ eval′ ∘ (id ⁂ proj₂ g)) ∘ λg (proj₁ f ∘ eval′ ∘ (id ⁂ proj₂ f))
                  ∎
              ; F-resp-≈ = λ (x , y) → λ-cong (∘-resp-≈ x (∘-resp-≈ʳ (⁂-cong₂ Equiv.refl y)))
              }
    where open HomReasoning


module examplesPaperJFP.Object where

open import Data.Product
open import Data.String.Base

open import examplesPaperJFP.NativeIOSafe
open import examplesPaperJFP.BasicIO hiding (main)
open import examplesPaperJFP.Console hiding (main)

record Interface  :  Set₁ where
  field  Method   :  Set
         Result   :  (m : Method) → Set

open Interface public

record Object (I : Interface) : Set where
  coinductive
  field objectMethod : (m : Method I) → Result I m × Object I

open Object public

record IOObject (Iᵢₒ : IOInterface) (I : Interface) : Set where
  coinductive
  field method : (m : Method I) → IO Iᵢₒ (Result I m × IOObject Iᵢₒ I)

open IOObject public

data CellMethod A : Set where
    get  :  CellMethod A
    put  :  A → CellMethod A

CellResult             :  ∀{A} → CellMethod A → Set
CellResult   {A} get   =  A
CellResult   (put _)   =  Unit

cellJ                  :  (A : Set) → Interface
Method    (cellJ A)    =  CellMethod A
Result    (cellJ A) m  =  CellResult m

CellC : Set
CellC = IOObject ConsoleInterface (cellJ String)

simpleCell : (s : String) → CellC
force (method (simpleCell s) get) =
  exec′ (putStrLn ("getting (" ++ s ++ ")")) λ _ →
  delay (return′ (s , simpleCell s))
force (method (simpleCell s) (put x)) =
  exec′ (putStrLn ("putting (" ++ x ++ ")")) λ _ →
  delay (return′ (unit , simpleCell x))

{-# TERMINATING #-}

program : IOConsole Unit
force program =
  let c₁ = simpleCell "Start" in
  exec′ getLine          λ{ nothing → return unit; (just s) →
  method c₁ (put s)    >>= λ{ (_ , c₂) →
  method c₂ get        >>= λ{ (s′ , _ ) →
  exec (putStrLn s′)     λ _ →
  program }}}

main : NativeIO Unit
main = translateIOConsole program


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.AssocList where

open import Cubical.HITs.AssocList.Base public
open import Cubical.HITs.AssocList.Properties public


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Values for standard evaluation (Def. 3.1 and 3.2, Fig. 4c and 4f).
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type

module Parametric.Denotation.Value
    (Base : Type.Structure)
  where

open import Base.Denotation.Notation

open Type.Structure Base

-- Extension point: Values for base types.
Structure : Set₁
Structure = Base → Set

module Structure (⟦_⟧Base : Structure) where
  -- We provide: Values for arbitrary types.
  ⟦_⟧Type : Type → Set
  ⟦ base ι ⟧Type = ⟦ ι ⟧Base
  ⟦ σ ⇒ τ ⟧Type = ⟦ σ ⟧Type → ⟦ τ ⟧Type

  instance
    -- This means: Overload ⟦_⟧ to mean ⟦_⟧Type.
    meaningOfType : Meaning Type
    meaningOfType = meaning ⟦_⟧Type

  -- We also provide: Environments of such values.
  open import Base.Denotation.Environment Type ⟦_⟧Type public


module Monads.Identity where

open import Class.Functor
open import Class.Monad
open import Class.MonadTrans
open import Level

private
  variable
    a : Level

Id : Set a -> Set a
Id A = A

IdentityT : (Set a -> Set a) -> Set a -> Set a
IdentityT M A = M A

instance
  Id-Monad : Monad (Id {a})
  Id-Monad = record { _>>=_ = λ a f -> f a ; return = λ a -> a }

module _ (M : Set a -> Set a) {{_ : Monad M}} where
  IdentityT-Monad : Monad (IdentityT M)
  IdentityT-Monad = record { _>>=_ = _>>=_ ; return = return }


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

open import Prelude
open import Relation.Binary

module LexPerm where


-- Christian Sattler, 2017-08-05
-- Nullary extended lambdas are useful in the interaction mode
-- for case splitting on the result inside an expression.
module NullaryExtendedLambda where

f : {A : Set} → A → A
f a = λ { → a }

g : {A : Set} → A → A
g a = λ where
  → a


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Functions.Fibration where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.Properties
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Path
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Transport
open import Cubical.Data.Sigma

private
  variable
    ℓ ℓb : Level
    B : Type ℓb

module FiberIso {ℓ} (p⁻¹ : B → Type ℓ) (x : B) where

  p : Σ B p⁻¹ → B
  p = fst

  fwd : fiber p x → p⁻¹ x
  fwd ((x' , y) , q) = subst (λ z → p⁻¹ z) q y

  bwd : p⁻¹ x → fiber p x
  bwd y = (x , y) , refl

  fwd-bwd : ∀ x → fwd (bwd x) ≡ x
  fwd-bwd y = transportRefl y

  bwd-fwd : ∀ x → bwd (fwd x) ≡ x
  bwd-fwd ((x' , y) , q) i = h (r i)
    where h : Σ[ s ∈ singl x ] p⁻¹ (s .fst) → fiber p x
          h ((x , p) , y) = (x , y) , sym p
          r : Path (Σ[ s ∈ singl x ] p⁻¹ (s .fst))
                   ((x  , refl ) , subst p⁻¹ q y)
                   ((x' , sym q) , y                            )
          r = ΣPathP (isContrSingl x .snd (x' , sym q)
                     , toPathP (transport⁻Transport (λ i → p⁻¹ (q i)) y))

  -- HoTT Lemma 4.8.1
  fiberEquiv : fiber p x ≃ p⁻¹ x
  fiberEquiv = isoToEquiv (iso fwd bwd fwd-bwd bwd-fwd)

open FiberIso using (fiberEquiv) public

module _ {ℓ} {E : Type ℓ} (p : E → B) where

  -- HoTT Lemma 4.8.2
  totalEquiv : E ≃ Σ B (fiber p)
  totalEquiv = isoToEquiv isom
    where isom : Iso E (Σ B (fiber p))
          Iso.fun isom x           = p x , x , refl
          Iso.inv isom (b , x , q) = x
          Iso.leftInv  isom x           i = x
          Iso.rightInv isom (b , x , q) i = q i , x , λ j → q (i ∧ j)

module _ (B : Type ℓb) (ℓ : Level) where
  private
    ℓ' = ℓ-max ℓb ℓ

  -- HoTT Theorem 4.8.3
  fibrationEquiv : (Σ[ E ∈ Type ℓ' ] (E → B)) ≃ (B → Type ℓ')
  fibrationEquiv = isoToEquiv isom
    where isom : Iso (Σ[ E ∈ Type ℓ' ] (E → B)) (B → Type ℓ')
          Iso.fun isom (E , p) = fiber p
          Iso.inv isom p⁻¹     = Σ B p⁻¹ , fst
          Iso.rightInv isom p⁻¹ i x = ua (fiberEquiv p⁻¹ x) i
          Iso.leftInv  isom (E , p) i = ua e (~ i) , fst ∘ ua-unglue e (~ i)
            where e = totalEquiv p

-- The path type in a fiber of f is equivalent to a fiber of (cong f)
open import Cubical.Foundations.Function

fiberPath : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} {f : A → B} {b : B} (h h' : fiber f b) →
             (Σ[ p ∈ (fst h ≡ fst h') ] (PathP (λ i → f (p i) ≡ b) (snd h) (snd h')))
           ≡ fiber (cong f) (h .snd ∙∙ refl ∙∙ sym (h' .snd))
fiberPath h h' = cong (Σ (h .fst ≡ h' .fst)) (funExt λ p → flipSquarePath ∙ PathP≡doubleCompPathʳ _ _ _ _)

fiber≡ : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} {f : A → B} {b : B} (h h' : fiber f b)
  → (h ≡ h') ≡ fiber (cong f) (h .snd ∙∙ refl ∙∙ sym (h' .snd))
fiber≡ {f = f} {b = b} h h' =
  ΣPath≡PathΣ ⁻¹ ∙
  fiberPath h h'

FibrationStr : (B : Type ℓb) → Type ℓ → Type (ℓ-max ℓ ℓb)
FibrationStr B A = A → B

Fibration : (B : Type ℓb) → (ℓ : Level) → Type (ℓ-max ℓb (ℓ-suc ℓ))
Fibration {ℓb = ℓb} B ℓ = Σ[ A ∈ Type ℓ ] FibrationStr B A


{-# OPTIONS --safe #-}
module Cubical.Categories.Instances.CommRings where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Structure
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Powerset

open import Cubical.Data.Unit
open import Cubical.Data.Sigma

open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.FiberedProduct
open import Cubical.Algebra.CommRing.Instances.Unit

open import Cubical.Categories.Category
open import Cubical.Categories.Functor
open import Cubical.Categories.Instances.Sets
open import Cubical.Categories.Instances.Functors
open import Cubical.Categories.Limits.Terminal
open import Cubical.Categories.Limits.Pullback
open import Cubical.Categories.Limits.Limits

open import Cubical.HITs.PropositionalTruncation

open Category hiding (_∘_)
open isUnivalent
open CatIso
open Functor
open CommRingStr
open RingHoms
open IsRingHom

private
  variable
    ℓ ℓ' ℓ'' : Level

CommRingsCategory : Category (ℓ-suc ℓ) ℓ
ob CommRingsCategory                     = CommRing _
Hom[_,_] CommRingsCategory               = CommRingHom
id CommRingsCategory {R}                 = idCommRingHom R
_⋆_ CommRingsCategory {R} {S} {T}        = compCommRingHom R S T
⋆IdL CommRingsCategory {R} {S}           = compIdCommRingHom {R = R} {S}
⋆IdR CommRingsCategory {R} {S}           = idCompCommRingHom {R = R} {S}
⋆Assoc CommRingsCategory {R} {S} {T} {U} = compAssocCommRingHom {R = R} {S} {T} {U}
isSetHom CommRingsCategory               = isSetRingHom _ _

forgetfulFunctor : Functor CommRingsCategory (SET ℓ)
F-ob forgetfulFunctor R    = R .fst , CommRingStr.is-set (snd R)
F-hom forgetfulFunctor f x = f .fst x
F-id forgetfulFunctor      = funExt (λ _ → refl)
F-seq forgetfulFunctor f g = funExt (λ _ → refl)

open Iso

CommRingIsoIsoCatIso : {R S : CommRing ℓ} → Iso (CommRingIso R S) (CatIso CommRingsCategory R S)
mor (fun CommRingIsoIsoCatIso e) = (e .fst .fun) , (e .snd)
inv (fun (CommRingIsoIsoCatIso {R = R} {S}) e) =
    e .fst .inv
  , makeIsRingHom (sym (cong (e .fst .inv) (pres1 (e .snd))) ∙ e .fst .leftInv _)
                  (λ x y → let rem = e .fst .rightInv _
                                  ∙∙ (λ i → S .snd ._+_ (e .fst .rightInv x (~ i)) (e .fst .rightInv y (~ i)))
                                  ∙∙ sym (pres+ (e .snd) _ _)
                            in injCommRingIso {R = R} {S} e _ _ rem)
                  (λ x y → let rem = e .fst .rightInv _
                                  ∙∙ (λ i → S .snd ._·_ (e .fst .rightInv x (~ i)) (e .fst .rightInv y (~ i)))
                                  ∙∙ sym (pres· (e .snd) _ _)
                           in injCommRingIso {R = R} {S} e _ _ rem)
sec (fun CommRingIsoIsoCatIso e) = RingHom≡ (funExt (e .fst .rightInv))
ret (fun CommRingIsoIsoCatIso e) = RingHom≡ (funExt (e .fst .leftInv))
fun (fst (inv CommRingIsoIsoCatIso e)) = e .mor .fst
inv (fst (inv CommRingIsoIsoCatIso e)) = e .inv .fst
rightInv (fst (inv CommRingIsoIsoCatIso e)) x i = fst (e .sec i) x
leftInv (fst (inv CommRingIsoIsoCatIso e)) x i = fst (e .ret i) x
snd (inv CommRingIsoIsoCatIso e) = e .mor .snd
rightInv CommRingIsoIsoCatIso x = CatIso≡ _ _ (RingHom≡ refl) (RingHom≡ refl)
leftInv (CommRingIsoIsoCatIso {R = R} {S}) x =
  Σ≡Prop (λ x → isPropIsRingHom (CommRingStr→RingStr (R .snd))
                                (x .fun)
                                (CommRingStr→RingStr (S .snd)))
         (Iso≡Set (is-set (snd R)) (is-set (snd S)) _ _ (λ _ → refl) (λ _ → refl))

isUnivalentCommRingsCategory : ∀ {ℓ} → isUnivalent {ℓ = ℓ-suc ℓ} CommRingsCategory
univ isUnivalentCommRingsCategory R S = subst isEquiv (funExt rem) (≡≃CatIso .snd)
  where
  CommRingEquivIso≡ : Iso (CommRingEquiv R S) (R ≡ S)
  CommRingEquivIso≡ = equivToIso (CommRingPath R S)

  ≡≃CatIso : (R ≡ S) ≃ (CatIso CommRingsCategory R S)
  ≡≃CatIso = isoToEquiv (compIso (invIso CommRingEquivIso≡)
                                 (compIso (CommRingEquivIsoCommRingIso R S) CommRingIsoIsoCatIso))

  rem : ∀ p → ≡≃CatIso .fst p ≡ pathToIso p
  rem p = CatIso≡ _ _
                 (RingHom≡ (funExt (λ x → cong (transport (λ i → fst (p i))) (sym (transportRefl x)))))
                 (RingHom≡ (funExt (λ x → sym (transportRefl _))))

TerminalCommRing : Terminal {ℓ-suc ℓ-zero} CommRingsCategory
fst TerminalCommRing = UnitCommRing
fst (fst (snd TerminalCommRing y)) _ = tt*
snd (fst (snd TerminalCommRing y)) = makeIsRingHom refl (λ _ _ → refl) (λ _ _ → refl)
snd (snd TerminalCommRing y) f = RingHom≡ (funExt (λ _ → refl))

open Pullback

{-
   A x_C B -----> A
      |           |
      |           | α
      |           |
      V           V
      B --------> C
            β
-}
PullbackCommRingsCategory : Pullbacks {ℓ-suc ℓ} CommRingsCategory
pbOb (PullbackCommRingsCategory (cospan A C B α β))             = fiberedProduct A B C α β
pbPr₁ (PullbackCommRingsCategory (cospan A C B α β))            = fiberedProductPr₁ A B C α β
pbPr₂ (PullbackCommRingsCategory (cospan A C B α β))            = fiberedProductPr₂ A B C α β
pbCommutes (PullbackCommRingsCategory (cospan A C B α β))       = fiberedProductPr₁₂Commutes A B C α β
univProp (PullbackCommRingsCategory (cospan A C B α β)) {d = D} = fiberedProductUnivProp A B C α β D

-- General limits
module _ {ℓJ ℓJ' : Level} where

  open LimCone
  open Cone

  LimitsCommRingsCategory : Limits {ℓJ} {ℓJ'} CommRingsCategory
  fst (lim (LimitsCommRingsCategory J D)) =
    lim {J = J} (completeSET J (funcComp forgetfulFunctor D)) .fst
  0r (snd (lim (LimitsCommRingsCategory J D))) =
    cone (λ v _ → 0r (snd (F-ob D v)))
         (λ e → funExt (λ _ → F-hom D e .snd .pres0))
  1r (snd (lim (LimitsCommRingsCategory J D))) =
    cone (λ v _ → 1r (snd (F-ob D v)))
         (λ e → funExt (λ _ → F-hom D e .snd .pres1))
  _+_ (snd (lim (LimitsCommRingsCategory J D))) x y =
    cone (λ v _ → _+_ (snd (F-ob D v)) _ _)
         ( λ e → funExt (λ _ → F-hom D e .snd .pres+ _ _
         ∙ λ i → _+_ (snd (F-ob D _)) (coneOutCommutes x e i tt*) (coneOutCommutes y e i tt*)))
  _·_ (snd (lim (LimitsCommRingsCategory J D))) x y =
    cone (λ v _ → _·_ (snd (F-ob D v)) _ _)
         ( λ e → funExt (λ _ → F-hom D e .snd .pres· _ _
         ∙ λ i → _·_ (snd (F-ob D _)) (coneOutCommutes x e i tt*) (coneOutCommutes y e i tt*)))
  (- snd (lim (LimitsCommRingsCategory J D))) x =
    cone (λ v _ → -_ (snd (F-ob D v)) _)
         ( λ e → funExt (λ z → F-hom D e .snd .pres- _
         ∙ λ i → -_ (snd (F-ob D _)) (coneOutCommutes x e i tt*)))
  isCommRing (snd (lim (LimitsCommRingsCategory J D))) =
    makeIsCommRing
      (isSetCone (funcComp forgetfulFunctor D) (Unit* , _))
      (λ _ _ _ → cone≡ (λ v → funExt (λ _ → snd (F-ob D v) .+Assoc _ _ _)))
      (λ _ → cone≡ (λ v → funExt (λ _ → +Rid (snd (F-ob D v)) _)))
      (λ _ → cone≡ (λ v → funExt (λ _ → +Rinv (snd (F-ob D v)) _)))
      (λ _ _ → cone≡ (λ v → funExt (λ _ → snd (F-ob D v) .+Comm _ _)))
      (λ _ _ _ → cone≡ (λ v → funExt (λ _ → snd (F-ob D v) .·Assoc _ _ _)))
      (λ _ → cone≡ (λ v → funExt (λ _ → ·Rid (snd (F-ob D v)) _)))
      (λ _ _ _ → cone≡ (λ v → funExt (λ _ → ·Rdist+ (snd (F-ob D v)) _ _ _)))
      (λ _ _ → cone≡ (λ v → funExt (λ _ → snd (F-ob D v) .·Comm _ _)))
  fst (coneOut (limCone (LimitsCommRingsCategory J D)) v) =
    coneOut (limCone (completeSET J (funcComp forgetfulFunctor D))) v
  pres0 (snd (coneOut (limCone (LimitsCommRingsCategory J D)) v)) = refl
  pres1 (snd (coneOut (limCone (LimitsCommRingsCategory J D)) v)) = refl
  pres+ (snd (coneOut (limCone (LimitsCommRingsCategory J D)) v)) = λ _ _ → refl
  pres· (snd (coneOut (limCone (LimitsCommRingsCategory J D)) v)) = λ _ _ → refl
  pres- (snd (coneOut (limCone (LimitsCommRingsCategory J D)) v)) = λ _ → refl
  coneOutCommutes (limCone (LimitsCommRingsCategory J D)) e =
    RingHom≡ (coneOutCommutes (limCone (completeSET J (funcComp forgetfulFunctor D))) e)
  univProp (LimitsCommRingsCategory J D) c cc =
    uniqueExists
      ( (λ x → limArrow (completeSET J (funcComp forgetfulFunctor D))
                        (fst c , snd c .is-set)
                        (cone (λ v _ → coneOut cc v .fst x)
                              (λ e → funExt (λ _ → funExt⁻ (cong fst (coneOutCommutes cc e)) x))) x)
      , makeIsRingHom
          (cone≡ (λ v → funExt (λ _ → coneOut cc v .snd .pres1)))
          (λ x y → cone≡ (λ v → funExt (λ _ → coneOut cc v .snd .pres+ _ _)))
          (λ x y → cone≡ (λ v → funExt (λ _ → coneOut cc v .snd .pres· _ _))))
      (λ _ → RingHom≡ refl)
      (isPropIsConeMor cc (limCone (LimitsCommRingsCategory J D)))
      (λ a' x → Σ≡Prop (λ _ → isPropIsRingHom _ _ _)
                       (funExt (λ y → cone≡ λ v → funExt (λ _ → sym (funExt⁻ (cong fst (x v)) y)))))


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.Semigroup.MorphismProperties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.SIP
open import Cubical.Foundations.Function using (_∘_; id)
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Functions.Embedding
open import Cubical.Data.Sigma

open import Cubical.Algebra
open import Cubical.Algebra.Properties
open import Cubical.Algebra.Semigroup.Morphism

open import Cubical.Structures.Axioms
open import Cubical.Structures.Auto
open import Cubical.Structures.Pointed

open import Cubical.Algebra.Magma.Properties using (isPropIsMagma)

open import Cubical.Relation.Binary.Reasoning.Equality

open Iso

private
  variable
    ℓ ℓ′ ℓ′′ : Level
    R : Semigroup ℓ
    S : Semigroup ℓ′
    T : Semigroup ℓ′′

isPropIsSemigroupHom : ∀ (S : Semigroup ℓ) (T : Semigroup ℓ′) f → isProp (IsSemigroupHom S T f)
isPropIsSemigroupHom S T f = isPropHomomorphic₂ (Semigroup.is-set T) f (Semigroup._•_ S) (Semigroup._•_ T)

isSetSemigroupHom : isSet (S ⟶ᴴ T)
isSetSemigroupHom {S = S} {T = T} = isOfHLevelRespectEquiv 2 equiv
                                      (isSetΣ (isSetΠ λ _ → is-set T)
                                              (λ f → isProp→isSet (isPropIsSemigroupHom S T f)))
  where
    open Semigroup
    equiv : (Σ[ g ∈ (⟨ S ⟩ → ⟨ T ⟩) ] IsSemigroupHom S T g) ≃ SemigroupHom S T
    equiv = isoToEquiv (iso (λ (g , m) → semigrouphom g m)
                            (λ (semigrouphom g m) → g , m)
                            (λ _ → refl) λ _ → refl)

isSemigroupHomComp : {f : ⟨ R ⟩ → ⟨ S ⟩} {g : ⟨ S ⟩ → ⟨ T ⟩}
                      → IsSemigroupHom R S f → IsSemigroupHom S T g
                      → IsSemigroupHom R T (g ∘ f)
isSemigroupHomComp {g = g} fHom gHom _ _ = cong g (fHom _ _) ∙ gHom _ _

private
  isSemigroupHomComp′ : (f : R ⟶ᴴ S) (g : S ⟶ᴴ T)
                        → IsSemigroupHom R T (SemigroupHom.fun g ∘ SemigroupHom.fun f)
  isSemigroupHomComp′ (semigrouphom f fHom) (semigrouphom g gHom) _ _ =
    cong g (fHom _ _) ∙ gHom _ _

compSemigroupHom : (R ⟶ᴴ S) → (S ⟶ᴴ T) → (R ⟶ᴴ T)
compSemigroupHom f g =
  semigrouphom _ (isSemigroupHomComp′ f g)

compSemigroupEquiv : R ≃ᴴ S → S ≃ᴴ T → R ≃ᴴ T
compSemigroupEquiv f g =
  semigroupequiv (compEquiv f.eq g.eq) (isSemigroupHomComp′ f.hom g.hom)
  where
    module f = SemigroupEquiv f
    module g = SemigroupEquiv g

isSemigroupHomId : (S : Semigroup ℓ) → IsSemigroupHom S S id
isSemigroupHomId S _ _ = refl

idSemigroupHom : (S : Semigroup ℓ) → (S ⟶ᴴ S)
idSemigroupHom S = record
  { fun   = id
  ; isHom = isSemigroupHomId S
  }

idSemigroupEquiv : (S : Semigroup ℓ) → S ≃ᴴ S
idSemigroupEquiv S = record
  { eq    = idEquiv ⟨ S ⟩
  ; isHom = isSemigroupHomId S
  }

-- Isomorphism inversion
isSemigroupHomInv : (eqv : S ≃ᴴ T) → IsSemigroupHom T S (invEq (SemigroupEquiv.eq eqv))
isSemigroupHomInv {S = S} {T = T} (semigroupequiv eq isHom) x y = isInj-f _ _ (
  f (f⁻¹ (x •ᵀ y))       ≡⟨ retEq eq _ ⟩
  x •ᵀ y                 ≡˘⟨ cong₂ _•ᵀ_ (retEq eq x) (retEq eq y) ⟩
  f (f⁻¹ x) •ᵀ f (f⁻¹ y) ≡˘⟨ isHom (f⁻¹ x) (f⁻¹ y) ⟩
  f (f⁻¹ x • f⁻¹ y)      ∎)
  where
    _•_ = Semigroup._•_ S -- superscript S isn't available for some reason
    _•ᵀ_ = Semigroup._•_ T
    f = equivFun eq
    f⁻¹ = invEq eq
    isInj-f : (x y : ⟨ S ⟩) → f x ≡ f y → x ≡ y
    isInj-f x y = invEq (_ , isEquiv→isEmbedding (eq .snd) x y)

invSemigroupHom : S ≃ᴴ T → (T ⟶ᴴ S)
invSemigroupHom eq = record { isHom = isSemigroupHomInv eq }

invSemigroupEquiv : S ≃ᴴ T → T ≃ᴴ S
invSemigroupEquiv eq = record
  { eq    = invEquiv (SemigroupEquiv.eq eq)
  ; isHom = isSemigroupHomInv eq
  }

semigroupHomEq : {f g : S ⟶ᴴ T} → (SemigroupHom.fun f ≡ SemigroupHom.fun g) → f ≡ g
semigroupHomEq {S = S} {T = T} {semigrouphom f fm} {semigrouphom g gm} p i =
  semigrouphom (p i) (p-hom i)
  where
    p-hom : PathP (λ i → IsSemigroupHom S T (p i)) fm gm
    p-hom = toPathP (isPropIsSemigroupHom S T _ _ _)

semigroupEquivEq : {f g : S ≃ᴴ T} → (SemigroupEquiv.eq f ≡ SemigroupEquiv.eq g) → f ≡ g
semigroupEquivEq {S = S} {T = T} {semigroupequiv f fm} {semigroupequiv g gm} p i =
  semigroupequiv (p i) (p-hom i)
  where
    p-hom : PathP (λ i → IsSemigroupHom S T (p i .fst)) fm gm
    p-hom = toPathP (isPropIsSemigroupHom S T _ _ _)

module SemigroupΣTheory {ℓ} where

  RawSemigroupStructure : Type ℓ → Type ℓ
  RawSemigroupStructure X = X → X → X

  RawSemigroupEquivStr = AutoEquivStr RawSemigroupStructure

  rawSemigroupUnivalentStr : UnivalentStr _ RawSemigroupEquivStr
  rawSemigroupUnivalentStr = autoUnivalentStr RawSemigroupStructure

  SemigroupAxioms : (A : Type ℓ) → RawSemigroupStructure A → Type ℓ
  SemigroupAxioms A _•_ = IsMagma A _•_ × Associative _•_

  SemigroupStructure : Type ℓ → Type ℓ
  SemigroupStructure = AxiomsStructure RawSemigroupStructure SemigroupAxioms

  SemigroupΣ : Type (ℓ-suc ℓ)
  SemigroupΣ = TypeWithStr ℓ SemigroupStructure

  isPropSemigroupAxioms : (A : Type ℓ) (_•_ : RawSemigroupStructure A) →
                          isProp (SemigroupAxioms A _•_)
  isPropSemigroupAxioms A _•_ = isPropΣ isPropIsMagma λ isMagmaA → isPropAssociative (IsMagma.is-set isMagmaA) _•_

  SemigroupEquivStr : StrEquiv SemigroupStructure ℓ
  SemigroupEquivStr = AxiomsEquivStr RawSemigroupEquivStr SemigroupAxioms

  SemigroupAxiomsIsoIsSemigroup : {A : Type ℓ} {_•_ : RawSemigroupStructure A} →
                                  Iso (SemigroupAxioms A _•_) (IsSemigroup A _•_)
  fun SemigroupAxiomsIsoIsSemigroup (x , y)           = issemigroup x y
  inv SemigroupAxiomsIsoIsSemigroup (issemigroup x y) = (x , y)
  rightInv SemigroupAxiomsIsoIsSemigroup _            = refl
  leftInv SemigroupAxiomsIsoIsSemigroup _             = refl

  SemigroupAxioms≡IsSemigroup : {A : Type ℓ} {_•_ : RawSemigroupStructure A} →
                                SemigroupAxioms _ _•_ ≡ IsSemigroup A _•_
  SemigroupAxioms≡IsSemigroup = isoToPath SemigroupAxiomsIsoIsSemigroup

  Semigroup→SemigroupΣ : Semigroup ℓ → SemigroupΣ
  Semigroup→SemigroupΣ (mksemigroup A _•_ isSemigroupA) =
    A , _•_ , SemigroupAxiomsIsoIsSemigroup .inv isSemigroupA

  SemigroupΣ→Semigroup : SemigroupΣ → Semigroup ℓ
  SemigroupΣ→Semigroup (A , _•_ , isSemigroupA) =
    mksemigroup A _•_ (SemigroupAxiomsIsoIsSemigroup .fun isSemigroupA)

  SemigroupIsoSemigroupΣ : Iso (Semigroup ℓ) SemigroupΣ
  SemigroupIsoSemigroupΣ =
    iso Semigroup→SemigroupΣ SemigroupΣ→Semigroup (λ _ → refl) (λ _ → refl)

  semigroupUnivalentStr : UnivalentStr SemigroupStructure SemigroupEquivStr
  semigroupUnivalentStr = axiomsUnivalentStr _ isPropSemigroupAxioms rawSemigroupUnivalentStr

  SemigroupΣPath : (S T : SemigroupΣ) → (S ≃[ SemigroupEquivStr ] T) ≃ (S ≡ T)
  SemigroupΣPath = SIP semigroupUnivalentStr

  SemigroupEquivΣ : (S T : Semigroup ℓ) → Type ℓ
  SemigroupEquivΣ S T = Semigroup→SemigroupΣ S ≃[ SemigroupEquivStr ] Semigroup→SemigroupΣ T

  SemigroupIsoΣPath : {S T : Semigroup ℓ} → Iso (SemigroupEquiv S T) (SemigroupEquivΣ S T)
  fun SemigroupIsoΣPath (semigroupequiv e h) = (e , h)
  inv SemigroupIsoΣPath (e , h)            = semigroupequiv e h
  rightInv SemigroupIsoΣPath _             = refl
  leftInv SemigroupIsoΣPath _              = refl

  SemigroupPath : (S T : Semigroup ℓ) → (SemigroupEquiv S T) ≃ (S ≡ T)
  SemigroupPath S T =
    SemigroupEquiv S T                                ≃⟨ isoToEquiv SemigroupIsoΣPath ⟩
    SemigroupEquivΣ S T                               ≃⟨ SemigroupΣPath _ _ ⟩
    Semigroup→SemigroupΣ S ≡ Semigroup→SemigroupΣ T   ≃⟨ isoToEquiv (invIso (congIso SemigroupIsoSemigroupΣ)) ⟩
    S ≡ T                                             ■

  RawSemigroupΣ : Type (ℓ-suc ℓ)
  RawSemigroupΣ = TypeWithStr ℓ RawSemigroupStructure

  Semigroup→RawSemigroupΣ : Semigroup ℓ → RawSemigroupΣ
  Semigroup→RawSemigroupΣ S = (⟨ S ⟩ , Semigroup._•_ S)

  InducedSemigroup : (S : Semigroup ℓ) (T : RawSemigroupΣ) (e : ⟨ S ⟩ ≃ ⟨ T ⟩) →
                      RawSemigroupEquivStr (Semigroup→RawSemigroupΣ S) T e → Semigroup ℓ
  InducedSemigroup S T e r =
    SemigroupΣ→Semigroup (inducedStructure rawSemigroupUnivalentStr (Semigroup→SemigroupΣ S) T (e , r))

  InducedSemigroupPath : (S : Semigroup ℓ) (T : RawSemigroupΣ) (e : ⟨ S ⟩ ≃ ⟨ T ⟩)
                          (E : RawSemigroupEquivStr (Semigroup→RawSemigroupΣ S) T e) →
                          S ≡ InducedSemigroup S T e E
  InducedSemigroupPath S T e E =
    SemigroupPath S (InducedSemigroup S T e E) .fst (semigroupequiv e E)

-- We now extract the important results from the above module

open SemigroupΣTheory public using (InducedSemigroup; InducedSemigroupPath)

SemigroupPath : (S ≃ᴴ T) ≃ (S ≡ T)
SemigroupPath = SemigroupΣTheory.SemigroupPath _ _

isPropIsSemigroup : {A : Type ℓ} {_•_ : Op₂ A} → isProp (IsSemigroup A _•_)
isPropIsSemigroup =
  subst isProp SemigroupΣTheory.SemigroupAxioms≡IsSemigroup
        (SemigroupΣTheory.isPropSemigroupAxioms _ _)

open Semigroup

uaSemigroup : S ≃ᴴ T → S ≡ T
uaSemigroup = equivFun SemigroupPath

carac-uaSemigroup : {S T : Semigroup ℓ} (f : S ≃ᴴ T)
                    → cong Carrier (uaSemigroup f) ≡ ua (SemigroupEquiv.eq f)
carac-uaSemigroup (semigroupequiv f m) =
  (refl ∙∙ ua f ∙∙ refl)
    ≡˘⟨ rUnit (ua f) ⟩
  ua f ∎

Semigroup≡ : (S T : Semigroup ℓ) → (
  Σ[ p ∈ ⟨ S ⟩ ≡ ⟨ T ⟩ ]
  Σ[ q ∈ PathP (λ i → p i → p i → p i) (_•_ S) (_•_ T) ]
  PathP (λ i → IsSemigroup (p i) (q i)) (isSemigroup S) (isSemigroup T))
  ≃ (S ≡ T)
Semigroup≡ S T = isoToEquiv (iso
  (λ (p , q , r) i → mksemigroup (p i) (q i) (r i))
  (λ p → cong Carrier p , cong _•_ p , cong isSemigroup p)
  (λ _ → refl) (λ _ → refl))

caracSemigroup≡ : {S T : Semigroup ℓ} (p q : S ≡ T) → cong Carrier p ≡ cong Carrier q → p ≡ q
caracSemigroup≡ {S = S} {T} p q t = cong (fst (Semigroup≡ S T)) (Σ≡Prop (λ _ →
    isPropΣ
    (isOfHLevelPathP' 1 (isSetΠ2 λ _ _ → is-set T) _ _) λ _ →
    isOfHLevelPathP 1 isPropIsSemigroup _ _)
  t)

uaSemigroupId : (S : Semigroup ℓ) → uaSemigroup (idSemigroupEquiv S) ≡ refl
uaSemigroupId S = caracSemigroup≡ _ _ (carac-uaSemigroup (idSemigroupEquiv S) ∙ uaIdEquiv)

uaCompSemigroupEquiv : {R S T : Semigroup ℓ} (f : R ≃ᴴ S) (g : S ≃ᴴ T)
                        → uaSemigroup (compSemigroupEquiv f g) ≡ uaSemigroup f ∙ uaSemigroup g
uaCompSemigroupEquiv f g = caracSemigroup≡ _ _ (
  cong Carrier (uaSemigroup (compSemigroupEquiv f g))
    ≡⟨ carac-uaSemigroup (compSemigroupEquiv f g) ⟩
  ua (eq (compSemigroupEquiv f g))
    ≡⟨ uaCompEquiv _ _ ⟩
  ua (eq f) ∙ ua (eq g)
    ≡˘⟨ cong (_∙ ua (eq g)) (carac-uaSemigroup f) ⟩
  cong Carrier (uaSemigroup f) ∙ ua (eq g)
    ≡˘⟨ cong (cong Carrier (uaSemigroup f) ∙_) (carac-uaSemigroup g) ⟩
  cong Carrier (uaSemigroup f) ∙ cong Carrier (uaSemigroup g)
    ≡˘⟨ cong-∙ Carrier (uaSemigroup f) (uaSemigroup g) ⟩
  cong Carrier (uaSemigroup f ∙ uaSemigroup g) ∎)
  where open SemigroupEquiv


module PatternSynonymImports2 where

open import PatternSynonyms hiding (test)
open import PatternSynonymImports

myzero' = z
myzero'' = myzero

list2 : List _
list2 = 1 ∷ []

test : ℕ → ℕ
test myzero = 0
test sz     = 1
test (ss x) = x


import Fragment.Algebra.Algebra
import Fragment.Algebra.Free
import Fragment.Algebra.Free.Atoms
import Fragment.Algebra.Free.Base
import Fragment.Algebra.Free.Evaluation
import Fragment.Algebra.Free.Monad
import Fragment.Algebra.Free.Properties
import Fragment.Algebra.Free.Syntax
import Fragment.Algebra.Homomorphism
import Fragment.Algebra.Homomorphism.Base
import Fragment.Algebra.Homomorphism.Definitions
import Fragment.Algebra.Homomorphism.Equivalence
import Fragment.Algebra.Homomorphism.Properties
import Fragment.Algebra.Homomorphism.Setoid
import Fragment.Algebra.Properties
import Fragment.Algebra.Quotient
import Fragment.Algebra.Signature
import Fragment.Equational.Coproduct
import Fragment.Equational.FreeExtension
import Fragment.Equational.FreeExtension.Base
import Fragment.Equational.FreeExtension.Properties
import Fragment.Equational.FreeExtension.Synthetic
import Fragment.Equational.Model
import Fragment.Equational.Model.Base
import Fragment.Equational.Model.Properties
import Fragment.Equational.Model.Satisfaction
import Fragment.Equational.Model.Synthetic
import Fragment.Equational.Structures
import Fragment.Equational.Theory
import Fragment.Equational.Theory.Base
import Fragment.Equational.Theory.Bundles
import Fragment.Equational.Theory.Combinators
import Fragment.Equational.Theory.Laws
import Fragment.Examples.CSemigroup.Arith.Atomic
import Fragment.Examples.CSemigroup.Arith.Base
import Fragment.Examples.CSemigroup.Arith.Functions
import Fragment.Examples.CSemigroup.Arith.Reasoning
import Fragment.Examples.CSemigroup.Types
import Fragment.Examples.Semigroup.Arith.Atomic
import Fragment.Examples.Semigroup.Arith.Base
import Fragment.Examples.Semigroup.Arith.Functions
import Fragment.Examples.Semigroup.Arith.Reasoning
import Fragment.Examples.Semigroup.Types
import Fragment.Extensions.CSemigroup
import Fragment.Extensions.CSemigroup.Base
import Fragment.Extensions.CSemigroup.Monomial
import Fragment.Extensions.CSemigroup.Nat
-- import Fragment.Extensions.Combinators
import Fragment.Extensions.Semigroup
import Fragment.Prelude
import Fragment.Setoid.Morphism
import Fragment.Setoid.Morphism.Base
import Fragment.Setoid.Morphism.Properties
import Fragment.Setoid.Morphism.Setoid
import Fragment.Tactic.Fragment
import Fragment.Tactic.Utils


{-

ℚ is a Field

-}
{-# OPTIONS --safe #-}
module Cubical.Algebra.Field.Instances.QuoQ where

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

open import Cubical.Data.Sigma
open import Cubical.Data.Empty as Empty
open import Cubical.Data.Nat using (ℕ ; zero ; suc)
open import Cubical.Data.NatPlusOne
open import Cubical.Data.Int.MoreInts.QuoInt
  using    (ℤ ; spos ; sneg ; pos ; neg ; signed ; posneg ; isSetℤ ; 0≢1-ℤ)
  renaming (_·_ to _·ℤ_ ; -_ to -ℤ_
           ; ·-zeroˡ to ·ℤ-zeroˡ
           ; ·-identityʳ to ·ℤ-identityʳ)
open import Cubical.HITs.SetQuotients as SetQuot
open import Cubical.HITs.Rationals.QuoQ
  using    (ℚ ; ℕ₊₁→ℤ ; isEquivRel∼)

open import Cubical.Algebra.Field
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRingSolver.Reflection
open import Cubical.Algebra.CommRing.Instances.QuoInt
open import Cubical.Algebra.CommRing.Instances.QuoQ

open import Cubical.Relation.Nullary

-- It seems there are bugs when applying ring solver to explicit ring.
-- The following is a work-around.
private
  module Helpers {ℓ : Level}(𝓡 : CommRing ℓ) where
    open CommRingStr (𝓡 .snd)

    helper1 : (x y : 𝓡 .fst) → (x · y) · 1r ≡ 1r · (y · x)
    helper1 = solve 𝓡

    helper2 : (x y : 𝓡 .fst) → ((- x) · (- y)) · 1r ≡ 1r · (y · x)
    helper2 = solve 𝓡

-- A rational number is zero if and only if its numerator is zero

a/b≡0→a≡0 : (x : ℤ × ℕ₊₁) → [ x ] ≡ 0 → x .fst ≡ 0
a/b≡0→a≡0 (a , b) a/b≡0 = sym (·ℤ-identityʳ a) ∙ a·1≡0·b ∙ ·ℤ-zeroˡ (ℕ₊₁→ℤ b)
  where a·1≡0·b : a ·ℤ 1 ≡ 0 ·ℤ (ℕ₊₁→ℤ b)
        a·1≡0·b = effective (λ _ _ → isSetℤ _ _) isEquivRel∼ _ _ a/b≡0

a≡0→a/b≡0 : (x : ℤ × ℕ₊₁) → x .fst ≡ 0 → [ x ] ≡ 0
a≡0→a/b≡0 (a , b) a≡0 = eq/ _ _ a·1≡0·b
  where a·1≡0·b : a ·ℤ 1 ≡ 0 ·ℤ (ℕ₊₁→ℤ b)
        a·1≡0·b = (λ i → a≡0 i ·ℤ 1) ∙ ·ℤ-zeroˡ {s = spos} 1 ∙ sym (·ℤ-zeroˡ (ℕ₊₁→ℤ b))

-- ℚ is a field

open CommRingStr (ℚCommRing .snd)
open Units        ℚCommRing
open Helpers      ℤCommRing

hasInverseℚ : (q : ℚ) → ¬ q ≡ 0 → Σ[ p ∈ ℚ ] q · p ≡ 1
hasInverseℚ = SetQuot.elimProp (λ q → isPropΠ (λ _ → inverseUniqueness q))
  (λ x x≢0 → let a≢0 = λ a≡0 → x≢0 (a≡0→a/b≡0 x a≡0) in inv-helper x a≢0 , inv·-helper x a≢0)
  where
  inv-helper : (x : ℤ × ℕ₊₁) → ¬ x .fst ≡ 0 → ℚ
  inv-helper (signed spos (suc a) , b) _ = [ ℕ₊₁→ℤ b , 1+ a ]
  inv-helper (signed sneg (suc a) , b) _ = [ -ℤ ℕ₊₁→ℤ b , 1+ a ]
  inv-helper (signed spos zero , _) a≢0 = Empty.rec (a≢0 refl)
  inv-helper (signed sneg zero , _) a≢0 = Empty.rec (a≢0 (sym posneg))
  inv-helper (posneg i , _) a≢0 = Empty.rec (a≢0 (λ j → posneg (i ∧ ~ j)))

  inv·-helper : (x : ℤ × ℕ₊₁)(a≢0 : ¬ x .fst ≡ 0) → [ x ] · inv-helper x a≢0 ≡ 1
  inv·-helper (signed spos zero , b) a≢0 = Empty.rec (a≢0 refl)
  inv·-helper (signed sneg zero , b) a≢0 = Empty.rec (a≢0 (sym posneg))
  inv·-helper (posneg i , b) a≢0 = Empty.rec (a≢0 (λ j → posneg (i ∧ ~ j)))
  inv·-helper (signed spos (suc a) , b) _ = eq/ _ _ (helper1 (pos (suc a)) (ℕ₊₁→ℤ b))
  inv·-helper (signed sneg (suc a) , b) _ = eq/ _ _ (helper2 (pos (suc a)) (ℕ₊₁→ℤ b))

0≢1-ℚ : ¬ Path ℚ 0 1
0≢1-ℚ p = 0≢1-ℤ (effective (λ _ _ → isSetℤ _ _) isEquivRel∼ _ _ p)

-- The instance

ℚField : Field ℓ-zero
ℚField = makeFieldFromCommRing ℚCommRing hasInverseℚ 0≢1-ℚ


-- Andreas, 2016-02-02 added Ambiguous

module Issue480 where

module Simple where

  data Q : Set where
    a : Q

  f : _ → Q
  f a = a

  postulate helper : ∀ {T : Set} → (T → T) → Q

  test₁ : Q → Q
  test₁ = λ { a → a }

  test₂ : Q
  test₂ = helper test₁

  -- Same as test₂ and test₁, but stuck together.
  test₃ : Q
  test₃ = helper λ { a → a } -- this says "Type mismatch when checking that the pattern a has type _45"

module Ambiguous where

  data Q : Set where
    a : Q

  data Overlap : Set where
    a : Overlap

  postulate helper : ∀ {T : Set} → (T → T) → T -- result type needs to be propagated

  test₁ : Q → Q
  test₁ = λ { a → a }

  test₃ : Q
  test₃ = helper λ { a → a }

  _$_ : ∀ {T : Set} → (T → T) → T → T
  f $ x = f x

  test : Q
  test = (λ { a → a }) $ a

  test₂ : _
  test₂ = (λ { a → a }) $ Q.a

module Example where

  infixr 5 _∷_

  data ℕ : Set where
    zero : ℕ
    suc  : (n : ℕ) → ℕ

  data List : Set₁ where
    []   : List
    _∷_  : Set → List → List

  data Tree (L : Set) : List → Set₁ where
    tip  : Tree L []
    node : ∀ {T Ts} → (cs : T → Tree L Ts) → Tree L (T ∷ Ts)

  data Q (n : ℕ) : Set where
    a : Q n
    b : Q n

  test₁ : Q zero → Tree ℕ (Q zero ∷ [])
  test₁ = λ
    { a → node λ { a → tip ; b → tip }
    ; b → node λ { a → tip ; b → tip }
    }

  test₂ = node test₁

  test₃ : Tree ℕ (Q zero ∷ Q zero ∷ [])
  test₃ = node λ
    { a → node λ { a → tip ; b → tip }
    ; b → node λ { a → tip ; b → tip }
    }