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

open import HoTT
open import cohomology.SuspAdjointLoopIso
open import cohomology.WithCoefficients
open import cohomology.Theory
open import cohomology.Exactness
open import cohomology.Choice

{- A spectrum (family (Eₙ | n : ℤ) such that ΩEₙ₊₁ = Eₙ)
 - gives rise to a cohomology theory C with Cⁿ(S⁰) = π₁(Eₙ₊₁). -}

module cohomology.SpectrumModel
  {i} (E : ℤ → Ptd i) (spectrum : (n : ℤ) → ⊙Ω (E (succ n)) == E n) where

module SpectrumModel where

  {- Definition of cohomology group C -}
  module _ (n : ℤ) (X : Ptd i) where
    C : Group i
    C = →Ω-group X (E (succ n))

    {- convenient abbreviations -}
    CEl = Group.El C
    ⊙CEl = Group.⊙El C
    Cid = Group.ident C

    {- before truncation -}
    uCEl = fst (X ⊙→ ⊙Ω (E (succ n)))

  {- Cⁿ(X) is an abelian group -}
  C-abelian : (n : ℤ) (X : Ptd i) → is-abelian (C n X)
  C-abelian n X =
    transport (is-abelian ∘ →Ω-group X) (spectrum (succ n)) $
      Trunc-group-abelian (→Ω-group-structure _ _) $ λ {(f , fpt) (g , gpt) →
        ⊙λ= (λ x → conc^2-comm (f x) (g x)) (pt-lemma fpt gpt)}
    where
    pt-lemma : ∀ {i} {A : Type i} {x : A} {p q : idp {a = x} == idp {a = x}}
      (α : p == idp) (β : q == idp)
      → ap (uncurry _∙_) (ap2 _,_ α β) ∙ idp
        == conc^2-comm p q ∙ ap (uncurry _∙_) (ap2 _,_ β α) ∙ idp
    pt-lemma idp idp = idp

  {- CF, the functorial action of C:
   - contravariant functor from pointed spaces to abelian groups -}
  module _ (n : ℤ) {X Y : Ptd i} where

    CF-hom : fst (X ⊙→ Y) → (C n Y →ᴳ C n X)
    CF-hom f = →Ω-group-dom-act f (E (succ n))

    CF : fst (X ⊙→ Y) → fst (⊙CEl n Y ⊙→ ⊙CEl n X)
    CF F = GroupHom.⊙f (CF-hom F)

  {- CF-hom is a functor from pointed spaces to abelian groups -}
  module _ (n : ℤ) {X : Ptd i} where

    CF-ident : CF-hom n {X} {X} (⊙idf X) == idhom (C n X)
    CF-ident = →Ω-group-dom-idf (E (succ n))

    CF-comp : {Y Z : Ptd i} (g : fst (Y ⊙→ Z)) (f : fst (X ⊙→ Y))
      → CF-hom n (g ⊙∘ f) == CF-hom n f ∘ᴳ CF-hom n g
    CF-comp g f = →Ω-group-dom-∘ g f (E (succ n))

  -- Eilenberg-Steenrod Axioms

  {- Suspension Axiom -}
  private
    C-Susp' : {E₁ E₀ : Ptd i} (p : ⊙Ω E₁ == E₀) (X : Ptd i)
      → →Ω-group (⊙Susp X) E₁ ≃ᴳ →Ω-group X E₀
    C-Susp' {E₁ = E₁} idp X = SuspAdjointLoopIso.iso X E₁

    C-SuspF' : {E₁ E₀ : Ptd i} (p : ⊙Ω E₁ == E₀)
      {X Y : Ptd i} (f : fst (X ⊙→ Y))
      → fst (C-Susp' p X) ∘ᴳ →Ω-group-dom-act (⊙susp-fmap f) E₁
        == →Ω-group-dom-act f E₀ ∘ᴳ fst (C-Susp' p Y)
    C-SuspF' {E₁ = E₁} idp f = SuspAdjointLoopIso.nat-dom f E₁

  C-Susp : (n : ℤ) (X : Ptd i) → C (succ n) (⊙Susp X) ≃ᴳ C n X
  C-Susp n X = C-Susp' (spectrum (succ n)) X

  C-SuspF : (n : ℤ) {X Y : Ptd i} (f : fst (X ⊙→ Y))
    → fst (C-Susp n X) ∘ᴳ CF-hom (succ n) (⊙susp-fmap f)
      == CF-hom n f ∘ᴳ fst (C-Susp n Y)
  C-SuspF n f = C-SuspF' (spectrum (succ n)) f

  {- Non-truncated Exactness Axiom -}
  module _ (n : ℤ) {X Y : Ptd i} where

    {- precomposing [⊙cfcod' f] and then [f] gives [0] -}
    exact-itok-lemma : (f : fst (X ⊙→ Y)) (g : uCEl n (⊙Cof f))
      → (g ⊙∘ ⊙cfcod' f) ⊙∘ f == ⊙cst
    exact-itok-lemma (f , fpt) (g , gpt) = ⊙λ=
      (λ x → ap g (! (cfglue' f x)) ∙ gpt)
      (ap (g ∘ cfcod) fpt
       ∙ ap g (ap cfcod (! fpt) ∙ ! (cfglue (snd X))) ∙ gpt
         =⟨ lemma cfcod g fpt (! (cfglue (snd X))) gpt ⟩
       ap g (! (cfglue (snd X))) ∙ gpt
         =⟨ ! (∙-unit-r _) ⟩
       (ap g (! (cfglue (snd X))) ∙ gpt) ∙ idp ∎)
      where
      lemma : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k}
        {a₁ a₂ : A} {b : B} {c : C} (f : A → B) (g : B → C)
        (p : a₁ == a₂) (q : f a₁ == b) (r : g b == c)
        → ap (g ∘ f) p ∙ ap g (ap f (! p) ∙ q) ∙ r == ap g q ∙ r
      lemma f g idp idp idp = idp

    {- if g ⊙∘ f is constant then g factors as h ⊙∘ ⊙cfcod' f -}
    exact-ktoi-lemma : (f : fst (X ⊙→ Y)) (g : uCEl n Y)
      → g ⊙∘ f == ⊙cst
      → Σ (uCEl n (⊙Cof f)) (λ h → h ⊙∘ ⊙cfcod' f == g)
    exact-ktoi-lemma (f , fpt) (h , hpt) p =
      ((g , ! q ∙ hpt) ,
       pair= idp (! (∙-assoc q (! q) hpt) ∙ ap (_∙ hpt) (!-inv-r q)))
      where
      g : Cofiber f → Ω (E (succ n))
      g = CofiberRec.f idp h (! ∘ app= (ap fst p))

      q : h (snd Y) == g (cfbase' f)
      q = ap g (snd (⊙cfcod' (f , fpt)))

  {- Truncated Exactness Axiom -}
  module _ (n : ℤ) {X Y : Ptd i} where

    {- in image of (CF n (⊙cfcod' f)) ⇒ in kernel of (CF n f) -}
    abstract
      C-exact-itok : (f : fst (X ⊙→ Y))
        → is-exact-itok (CF-hom n (⊙cfcod' f)) (CF-hom n f)
      C-exact-itok f =
        itok-alt-in (CF-hom n (⊙cfcod' f)) (CF-hom n f) $
          Trunc-elim (λ _ → =-preserves-level _ (Trunc-level {n = 0}))
            (ap [_] ∘ exact-itok-lemma n f)

    {- in kernel of (CF n f) ⇒ in image of (CF n (⊙cfcod' f)) -}
    abstract
      C-exact-ktoi : (f : fst (X ⊙→ Y))
        → is-exact-ktoi (CF-hom n (⊙cfcod' f)) (CF-hom n f)
      C-exact-ktoi f =
        Trunc-elim
          (λ _ → Π-level (λ _ → raise-level _ Trunc-level))
          (λ h tp → Trunc-rec Trunc-level (lemma h) (–> (Trunc=-equiv _ _) tp))
        where
        lemma : (h : uCEl n Y) → h ⊙∘ f == ⊙cst
          → Trunc -1 (Σ (CEl n (⊙Cof f))
                          (λ tk → fst (CF n (⊙cfcod' f)) tk == [ h ]))
        lemma h p = [ [ fst wit ] , ap [_] (snd wit) ]
          where
          wit : Σ (uCEl n (⊙Cof f)) (λ k → k ⊙∘ ⊙cfcod' f == h)
          wit = exact-ktoi-lemma n f h p

    C-exact : (f : fst (X ⊙→ Y)) → is-exact (CF-hom n (⊙cfcod' f)) (CF-hom n f)
    C-exact f = record {itok = C-exact-itok f; ktoi = C-exact-ktoi f}

  {- Additivity Axiom -}
  module _ (n : ℤ) {A : Type i} (X : A → Ptd i)
    (ac : (W : A → Type i) → has-choice 0 A W)
    where

    into : CEl n (⊙BigWedge X) → Trunc 0 (Π A (uCEl n ∘ X))
    into = Trunc-rec Trunc-level (λ H → [ (λ a → H ⊙∘ ⊙bwin a) ])

    module Out' (K : Π A (uCEl n ∘ X)) = BigWedgeRec
      idp
      (fst ∘ K)
      (! ∘ snd ∘ K)

    out : Trunc 0 (Π A (uCEl n ∘ X)) → CEl n (⊙BigWedge X)
    out = Trunc-rec Trunc-level (λ K → [ Out'.f K , idp ])

    into-out : ∀ y → into (out y) == y
    into-out = Trunc-elim
      (λ _ → =-preserves-level _ Trunc-level)
      (λ K → ap [_] (λ= (λ a → pair= idp $
        ap (Out'.f K) (! (bwglue a)) ∙ idp
          =⟨ ∙-unit-r _ ⟩
        ap (Out'.f K) (! (bwglue a))
          =⟨ ap-! (Out'.f K) (bwglue a) ⟩
        ! (ap (Out'.f K) (bwglue a))
          =⟨ ap ! (Out'.glue-β K a) ⟩
        ! (! (snd (K a)))
          =⟨ !-! (snd (K a)) ⟩
        snd (K a) ∎)))

    out-into : ∀ x → out (into x) == x
    out-into = Trunc-elim
      {P = λ tH → out (into tH) == tH}
      (λ _ → =-preserves-level _ Trunc-level)
      (λ {(h , hpt) → ap [_] $ pair=
         (λ= (out-into-fst (h , hpt)))
         (↓-app=cst-in $ ! $
            ap (λ w → w ∙ hpt) (app=-β (out-into-fst (h , hpt)) bwbase)
            ∙ !-inv-l hpt)})
      where
      lemma : ∀ {i j} {A : Type i} {B : Type j} (f : A → B)
        {a₁ a₂ : A} {b : B} (p : a₁ == a₂) (q : f a₁ == b)
        → ! q ∙ ap f p == ! (ap f (! p) ∙ q)
      lemma f idp idp = idp

      out-into-fst : (H : fst (⊙BigWedge X ⊙→ ⊙Ω (E (succ n))))
        → ∀ w → Out'.f (λ a → H ⊙∘ ⊙bwin a) w == fst H w
      out-into-fst (h , hpt) = BigWedge-elim
        (! hpt)
        (λ _ _ → idp)
        (λ a → ↓-='-in $
           ! hpt ∙ ap h (bwglue a)
             =⟨ lemma h (bwglue a) hpt ⟩
           ! (ap h (! (bwglue a)) ∙ hpt)
             =⟨ ! (Out'.glue-β (λ a → (h , hpt) ⊙∘ ⊙bwin a) a) ⟩
           ap (Out'.f (λ a → (h , hpt) ⊙∘ ⊙bwin a)) (bwglue a) ∎)

    abstract
      C-additive : is-equiv (GroupHom.f (Πᴳ-hom-in (CF-hom n ∘ ⊙bwin {X = X})))
      C-additive = transport is-equiv
        (λ= $ Trunc-elim
          (λ _ → =-preserves-level _ $ Π-level $ λ _ → Trunc-level)
          (λ _ → idp))
        ((ac (uCEl n ∘ X)) ∘ise (is-eq into out into-out out-into))

open SpectrumModel

spectrum-cohomology : CohomologyTheory i
spectrum-cohomology = record {
  C = C;
  CF-hom = CF-hom;
  CF-ident = CF-ident;
  CF-comp = CF-comp;
  C-abelian = C-abelian;
  C-Susp = C-Susp;
  C-SuspF = C-SuspF;
  C-exact = C-exact;
  C-additive = C-additive}

spectrum-C-S⁰ : (n : ℤ) → C n (⊙Lift ⊙S⁰) == πS 0 (E (succ n))
spectrum-C-S⁰ n = Bool⊙→Ω-is-π₁ (E (succ n))


module Oscar.Data.Unit where

open import Agda.Builtin.Unit public using (⊤; tt)


module Structure.Function.Domain.Proofs where

open import Data.Tuple as Tuple using (_⨯_ ; _,_)
import      Lvl
open import Functional
open import Function.Domains
open import Function.Equals
import      Function.Names as Names
open import Lang.Instance
open import Logic
open import Logic.Classical
open import Logic.Propositional
open import Logic.Propositional.Theorems
open import Logic.Predicate
open import Structure.Setoid
open import Structure.Setoid.Uniqueness
open import Structure.Function.Domain
open import Structure.Function
open import Structure.Relator.Properties
open import Structure.Relator
open import Syntax.Transitivity
open import Type
open import Type.Dependent

private variable ℓ ℓ₁ ℓ₂ ℓₑ ℓₑ₁ ℓₑ₂ ℓₑ₃ ℓₒ₁ ℓₒ₂ : Lvl.Level
private variable T A B C : Type{ℓ}

module _ {A : Type{ℓₒ₁}} ⦃ _ : Equiv{ℓₑ₁}(A) ⦄ {B : Type{ℓₒ₂}} ⦃ _ : Equiv{ℓₑ₂}(B) ⦄ (f : A → B) where
  injective-to-unique : Injective(f) → ∀{y} → Unique(x ↦ f(x) ≡ y)
  injective-to-unique (intro(inj)) {y} {x₁}{x₂} fx₁y fx₂y =
    inj{x₁}{x₂} (fx₁y 🝖 symmetry(_≡_) fx₂y)

  instance
    bijective-to-injective : ⦃ bij : Bijective(f) ⦄ → Injective(f)
    Injective.proof(bijective-to-injective ⦃ intro(bij) ⦄) {x₁}{x₂} (fx₁fx₂) =
      ([∃!]-existence-eq (bij {f(x₂)}) {x₁} (fx₁fx₂))
      🝖 symmetry(_≡_) ([∃!]-existence-eq (bij {f(x₂)}) {x₂} (reflexivity(_≡_)))
    -- ∀{y : B} → ∃!(x ↦ f(x) ≡ y)
    -- ∃!(x ↦ f(x) ≡ f(x₂))
    -- ∀{x} → (f(x) ≡ f(x₂)) → (x ≡ [∃!]-witness e)
    -- (f(x₁) ≡ f(x₂)) → (x₁ ≡ [∃!]-witness e)
    --
    -- ∀{y : B} → ∃!(x ↦ f(x) ≡ y)
    -- ∃!(x ↦ f(x) ≡ f(x₂))
    -- ∀{x} → (f(x) ≡ f(x₂)) → (x ≡ [∃!]-witness e)
    -- (f(x₂) ≡ f(x₂)) → (x₂ ≡ [∃!]-witness e)

  instance
    bijective-to-surjective : ⦃ bij : Bijective(f) ⦄ → Surjective(f)
    Surjective.proof(bijective-to-surjective ⦃ intro(bij) ⦄) {y} =
      [∃!]-existence (bij {y})

  instance
    injective-surjective-to-bijective : ⦃ inj : Injective(f) ⦄ → ⦃ surj : Surjective(f) ⦄ → Bijective(f)
    Bijective.proof(injective-surjective-to-bijective ⦃ inj ⦄ ⦃ intro(surj) ⦄) {y} =
      [∃!]-intro surj (injective-to-unique inj)

  injective-surjective-bijective-equivalence : (Injective(f) ∧ Surjective(f)) ↔ Bijective(f)
  injective-surjective-bijective-equivalence =
    [↔]-intro
      (\bij → [∧]-intro (bijective-to-injective ⦃ bij = bij ⦄) (bijective-to-surjective ⦃ bij = bij ⦄))
      (\{([∧]-intro inj surj) → injective-surjective-to-bijective ⦃ inj = inj ⦄ ⦃ surj = surj ⦄})

module _ {A : Type{ℓₒ₁}} ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄ {B : Type{ℓₒ₂}} ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄ where
  instance
    injective-relator : UnaryRelator(Injective{A = A}{B = B})
    Injective.proof (UnaryRelator.substitution injective-relator {f₁}{f₂} (intro f₁f₂) (intro inj-f₁)) f₂xf₂y = inj-f₁ (f₁f₂ 🝖 f₂xf₂y 🝖 symmetry(_≡_) f₁f₂)

module _ {A : Type{ℓₒ₁}} {B : Type{ℓₒ₂}} ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄ where
  instance
    surjective-relator : UnaryRelator(Surjective{A = A}{B = B})
    Surjective.proof (UnaryRelator.substitution surjective-relator {f₁}{f₂} (intro f₁f₂) (intro surj-f₁)) {y} = [∃]-map-proof (\{x} f₁xf₁y → symmetry(_≡_) (f₁f₂{x}) 🝖 f₁xf₁y) (surj-f₁{y})

module _ {A : Type{ℓₒ₁}} ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄ {B : Type{ℓₒ₂}} ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄ where
  instance
    bijective-relator : UnaryRelator(Bijective{A = A}{B = B})
    UnaryRelator.substitution bijective-relator {f₁}{f₂} f₁f₂ bij-f₁ = injective-surjective-to-bijective(f₂) ⦃ substitute₁(Injective) f₁f₂ (bijective-to-injective(f₁)) ⦄ ⦃ substitute₁(Surjective) f₁f₂ (bijective-to-surjective(f₁)) ⦄ where
      instance _ = bij-f₁

module _
  {A : Type{ℓₒ₁}}
  {B : Type{ℓₒ₂}} ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄
  where

  invᵣ-surjective : (f : A → B) ⦃ surj : Surjective(f) ⦄ → (B → A)
  invᵣ-surjective _ ⦃ surj ⦄ (y) = [∃]-witness(Surjective.proof surj{y})

module _
  {A : Type{ℓₒ₁}}
  {B : Type{ℓₒ₂}} ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄
  {f : A → B}
  where

  surjective-to-inverseᵣ : ⦃ surj : Surjective(f) ⦄ → Inverseᵣ(f)(invᵣ-surjective f)
  surjective-to-inverseᵣ ⦃ intro surj ⦄ = intro([∃]-proof surj)

module _
  {A : Type{ℓₒ₁}} ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄
  {B : Type{ℓₒ₂}} ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄
  {f : A → B} {f⁻¹ : B → A}
  where

  inverseᵣ-to-surjective : ⦃ inverᵣ : Inverseᵣ(f)(f⁻¹) ⦄ → Surjective(f)
  Surjective.proof inverseᵣ-to-surjective {y} = [∃]-intro (f⁻¹(y)) ⦃ inverseᵣ(f)(f⁻¹) ⦄

  Inverse-symmetry : Inverse(f)(f⁻¹) → Inverse(f⁻¹)(f)
  Inverse-symmetry ([∧]-intro (intro inverₗ) (intro inverᵣ)) = [∧]-intro (intro inverᵣ) (intro inverₗ)

module _
  {A : Type{ℓₒ₁}} ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄
  {B : Type{ℓₒ₂}} ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄
  {f : A → B}
  where

  invertibleᵣ-to-surjective : ⦃ inverᵣ : Invertibleᵣ(f) ⦄ → Surjective(f)
  ∃.witness (Surjective.proof(invertibleᵣ-to-surjective ⦃ inverᵣ ⦄) {y}) = [∃]-witness inverᵣ(y)
  ∃.proof   (Surjective.proof(invertibleᵣ-to-surjective ⦃ inverᵣ ⦄) {y}) = inverseᵣ _ _ ⦃ [∧]-elimᵣ([∃]-proof inverᵣ) ⦄

  -- Every surjective function has a right inverse with respect to function composition.
  -- One of the right inverse functions of a surjective function f.
  -- Specifically the one that is used in the constructive proof of surjectivity for f.
  -- Without assuming that the value used in the proof of surjectivity constructs a function, this would be unprovable because it is not guaranteed in arbitrary setoids.
  -- Note: The usual formulation of this proposition (without assuming `inv-func`) is equivalent to the axiom of choice from set theory in classical logic.
  surjective-to-invertibleᵣ : ⦃ surj : Surjective(f) ⦄ ⦃ inv-func : Function(invᵣ-surjective f) ⦄ → Invertibleᵣ(f)
  ∃.witness (surjective-to-invertibleᵣ)                                                 = invᵣ-surjective f
  ∃.proof   (surjective-to-invertibleᵣ ⦃ surj = intro surj ⦄ ⦃ inv-func = inv-func ⦄)   = [∧]-intro inv-func (intro([∃]-proof surj))

  invertibleᵣ-when-surjective : Invertibleᵣ(f) ↔ Σ(Surjective(f)) (surj ↦ Function(invᵣ-surjective f ⦃ surj ⦄))
  invertibleᵣ-when-surjective =
    [↔]-intro
      (surj   ↦ surjective-to-invertibleᵣ ⦃ Σ.left surj ⦄ ⦃ Σ.right surj ⦄)
      (inverᵣ ↦ intro (invertibleᵣ-to-surjective ⦃ inverᵣ ⦄) ([∧]-elimₗ([∃]-proof inverᵣ)))

module _
  {A : Type{ℓ₁}} ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄
  {B : Type{ℓ₂}} ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄
  {f : A → B} {f⁻¹ : B → A} ⦃ inverᵣ : Inverseᵣ(f)(f⁻¹) ⦄
  where

  -- Note: This states that a function which is injective and surjective (bijective) is a function, but another way of satisfying this proposition is from a variant of axiom of choice which directly state that the right inverse of a surjective function always exist.
  inverseᵣ-function : ⦃ inj : Injective(f) ⦄ → Function(f⁻¹)
  Function.congruence (inverseᵣ-function) {y₁}{y₂} y₁y₂ =
    injective(f) (
      f(f⁻¹(y₁)) 🝖-[ inverseᵣ(f)(f⁻¹) ]
      y₁         🝖-[ y₁y₂ ]
      y₂         🝖-[ inverseᵣ(f)(f⁻¹) ]-sym
      f(f⁻¹(y₂)) 🝖-end
    )

  -- The right inverse is injective when f is a surjective function.
  inverseᵣ-injective : ⦃ func : Function(f) ⦄ → Injective(f⁻¹)
  Injective.proof(inverseᵣ-injective) {x₁}{x₂} (invᵣfx₁≡invᵣfx₂) =
    x₁         🝖-[ inverseᵣ(f)(f⁻¹) ]-sym
    f(f⁻¹(x₁)) 🝖-[ congruence₁(f) {f⁻¹(x₁)} {f⁻¹(x₂)} (invᵣfx₁≡invᵣfx₂) ]
    f(f⁻¹(x₂)) 🝖-[ inverseᵣ(f)(f⁻¹) ]
    x₂         🝖-end

  -- The right inverse is surjective when the surjective f is injective.
  inverseᵣ-surjective : ⦃ inj : Injective(f) ⦄ → Surjective(f⁻¹)
  ∃.witness (Surjective.proof inverseᵣ-surjective {x}) = f(x)
  ∃.proof   (Surjective.proof inverseᵣ-surjective {x}) =
    injective(f) (
      f(f⁻¹(f(x))) 🝖-[ inverseᵣ(f)(f⁻¹) ]
      f(x)         🝖-end
    )

  -- The right inverse is a left inverse when the surjective f is injective.
  inverseᵣ-inverseₗ : ⦃ inj : Injective(f) ⦄ → Inverseₗ(f)(f⁻¹)
  inverseᵣ-inverseₗ = intro([∃]-proof(surjective(f⁻¹) ⦃ inverseᵣ-surjective ⦄))

  -- The right inverse is bijective when the surjective f is injective.
  inverseᵣ-bijective : ⦃ func : Function(f) ⦄ ⦃ inj : Injective(f) ⦄ → Bijective(f⁻¹)
  inverseᵣ-bijective = injective-surjective-to-bijective(f⁻¹) ⦃ inverseᵣ-injective ⦄ ⦃ inverseᵣ-surjective ⦄

  inverseᵣ-inverse : ⦃ inj : Injective(f) ⦄ → Inverse(f)(f⁻¹)
  inverseᵣ-inverse = [∧]-intro inverseᵣ-inverseₗ inverᵣ

  -- The right inverse is an unique right inverse when f is injective.
  inverseᵣ-unique-inverseᵣ : ⦃ inj : Injective(f) ⦄ → ∀{g} → (f ∘ g ⊜ id) → (g ⊜ f⁻¹)
  inverseᵣ-unique-inverseᵣ {g = g} (intro p) = intro $ \{x} →
    g(x)         🝖-[ inverseₗ(f)(f⁻¹) ⦃ inverseᵣ-inverseₗ ⦄ ]-sym
    f⁻¹(f(g(x))) 🝖-[ congruence₁(f⁻¹) ⦃ inverseᵣ-function ⦄ p ]
    f⁻¹(x)       🝖-end

  -- The right inverse is an unique left inverse function.
  inverseᵣ-unique-inverseₗ : ∀{g} ⦃ _ : Function(g) ⦄ → (g ∘ f ⊜ id) → (g ⊜ f⁻¹)
  inverseᵣ-unique-inverseₗ {g = g} (intro p) = intro $ \{x} →
    g(x)         🝖-[ congruence₁(g) (inverseᵣ(f)(f⁻¹)) ]-sym
    g(f(f⁻¹(x))) 🝖-[ p{f⁻¹(x)} ]
    f⁻¹(x)       🝖-end

  -- The right inverse is invertible.
  inverseᵣ-invertibleᵣ : ⦃ func : Function(f) ⦄ ⦃ inj : Injective(f) ⦄ → Invertibleᵣ(f⁻¹)
  ∃.witness inverseᵣ-invertibleᵣ                   = f
  ∃.proof   (inverseᵣ-invertibleᵣ ⦃ func = func ⦄) = [∧]-intro func inverseᵣ-inverseₗ

  -- TODO: invᵣ-unique-function : ∀{g} → (invᵣ(f) ∘ g ⊜ id) → (g ⊜ f)

module _
  {A : Type{ℓ₁}} ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄
  {B : Type{ℓ₂}} ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄
  {f : A → B} {f⁻¹ : B → A} ⦃ inverₗ : Inverseₗ(f)(f⁻¹) ⦄
  where

  inverseₗ-surjective : Surjective(f⁻¹)
  inverseₗ-surjective = inverseᵣ-to-surjective

  inverseₗ-to-injective : ⦃ invₗ-func : Function(f⁻¹) ⦄ → Injective(f)
  inverseₗ-to-injective = inverseᵣ-injective

module _
  {A : Type{ℓ₁}} ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄
  {B : Type{ℓ₂}} ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄
  {f   : A → B} ⦃ func     : Function(f)   ⦄
  {f⁻¹ : B → A} ⦃ inv-func : Function(f⁻¹) ⦄
  where

  inverseₗ-to-inverseᵣ : ⦃ surj : Surjective(f) ⦄ ⦃ inverₗ : Inverseₗ(f)(f⁻¹) ⦄ → Inverseᵣ(f)(f⁻¹)
  Inverseᵣ.proof inverseₗ-to-inverseᵣ {x} with [∃]-intro y ⦃ p ⦄ ← surjective f{x} =
    f(f⁻¹(x))    🝖-[ congruence₁(f) (congruence₁(f⁻¹) p) ]-sym
    f(f⁻¹(f(y))) 🝖-[ congruence₁(f) (inverseₗ(f)(f⁻¹)) ]
    f(y)         🝖-[ p ]
    x            🝖-end

  module _ ⦃ surj : Surjective(f) ⦄ ⦃ inverₗ : Inverseₗ(f)(f⁻¹) ⦄ where
    inverseₗ-injective : Injective(f⁻¹)
    Injective.proof inverseₗ-injective {x}{y} p =
      x         🝖-[ inverseᵣ(f)(f⁻¹) ⦃ inverseₗ-to-inverseᵣ ⦄ ]-sym
      f(f⁻¹(x)) 🝖-[ congruence₁(f) p ]
      f(f⁻¹(y)) 🝖-[ inverseᵣ(f)(f⁻¹) ⦃ inverseₗ-to-inverseᵣ ⦄ ]
      y         🝖-end

    inverseₗ-bijective : Bijective(f⁻¹)
    inverseₗ-bijective = injective-surjective-to-bijective(f⁻¹) ⦃ inverseₗ-injective ⦄ ⦃ inverseₗ-surjective ⦄

    inverseₗ-to-surjective : Surjective(f)
    inverseₗ-to-surjective = inverseᵣ-surjective ⦃ inj = inverseₗ-injective ⦄

    inverseₗ-to-bijective : Bijective(f)
    inverseₗ-to-bijective = injective-surjective-to-bijective(f) ⦃ inverseₗ-to-injective ⦄ ⦃ inverseₗ-to-surjective ⦄

module _
  {A : Type{ℓ₁}} ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄
  {B : Type{ℓ₂}} ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄
  {f : A → B} {f⁻¹ : B → A} ⦃ inver : Inverse(f)(f⁻¹) ⦄
  where

  inverse-to-surjective : Surjective(f)
  inverse-to-surjective = inverseᵣ-to-surjective ⦃ inverᵣ = [∧]-elimᵣ inver ⦄

  module _ ⦃ inv-func : Function(f⁻¹) ⦄ where
    inverse-to-injective : Injective(f)
    inverse-to-injective = inverseₗ-to-injective ⦃ inverₗ = [∧]-elimₗ inver ⦄

    inverse-to-bijective : Bijective(f)
    inverse-to-bijective = injective-surjective-to-bijective(f) ⦃ inj = inverse-to-injective ⦄ ⦃ surj = inverse-to-surjective ⦄

  inverse-surjective : Surjective(f⁻¹)
  inverse-surjective = inverseₗ-surjective ⦃ inverₗ = [∧]-elimₗ inver ⦄

  module _ ⦃ func : Function(f) ⦄ where
    inverse-injective : Injective(f⁻¹)
    inverse-injective = inverseᵣ-injective ⦃ inverᵣ = [∧]-elimᵣ inver ⦄ ⦃ func = func ⦄

    inverse-bijective : Bijective(f⁻¹)
    inverse-bijective = injective-surjective-to-bijective(f⁻¹) ⦃ inj = inverse-injective ⦄ ⦃ surj = inverse-surjective ⦄

  inverse-function-when-injective : Function(f⁻¹) ↔ Injective(f)
  inverse-function-when-injective =
    [↔]-intro
      (inj ↦ inverseᵣ-function ⦃ inverᵣ = [∧]-elimᵣ inver ⦄ ⦃ inj = inj ⦄)
      (inv-func ↦ inverse-to-injective ⦃ inv-func = inv-func ⦄)

  function-when-inverse-injective : Function(f) ↔ Injective(f⁻¹)
  function-when-inverse-injective =
    [↔]-intro
      (inv-inj ↦ intro(\{x y} → xy ↦ injective(f⁻¹) ⦃ inv-inj ⦄ (
        f⁻¹(f(x)) 🝖-[ inverseₗ(f)(f⁻¹) ⦃ [∧]-elimₗ inver ⦄ ]
        x         🝖-[ xy ]
        y         🝖-[ inverseₗ(f)(f⁻¹) ⦃ [∧]-elimₗ inver ⦄ ]-sym
        f⁻¹(f(y)) 🝖-end
      )))
      (func ↦ inverse-injective ⦃ func = func ⦄)

  -- TODO: inverse-function-when-bijective : Function(f⁻¹) ↔ Bijective(f)
  -- Surjective(f) ↔ Injective(f⁻¹)
  -- Injective(f) ↔ Surjective(f⁻¹)

module _
  {A : Type{ℓ₁}} ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄
  {B : Type{ℓ₂}} ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄
  {f : A → B} ⦃ inver : Invertible(f) ⦄
  where

  invertible-elimₗ : Invertibleₗ(f)
  invertible-elimₗ = [∃]-map-proof (Tuple.mapRight [∧]-elimₗ) inver

  invertible-elimᵣ : Invertibleᵣ(f)
  invertible-elimᵣ = [∃]-map-proof (Tuple.mapRight [∧]-elimᵣ) inver

module _
  {A : Type{ℓ₁}} ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄
  {B : Type{ℓ₂}} ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄
  where

  private variable f : A → B

  -- invertible-intro : ⦃ inverₗ : Invertibleₗ(f) ⦄ ⦃ inverᵣ : Invertibleᵣ(f) ⦄ → Invertible(f)
  -- invertible-intro = {!!}

  bijective-to-invertible : ⦃ bij : Bijective(f) ⦄ → Invertible(f)
  bijective-to-invertible {f = f} ⦃ bij = bij ⦄ = [∃]-intro f⁻¹ ⦃ [∧]-intro f⁻¹-function ([∧]-intro f⁻¹-inverseₗ f⁻¹-inverseᵣ) ⦄ where
    f⁻¹ : B → A
    f⁻¹ = invᵣ-surjective f ⦃ bijective-to-surjective(f) ⦄

    f⁻¹-inverseᵣ : Inverseᵣ(f)(f⁻¹)
    f⁻¹-inverseᵣ = surjective-to-inverseᵣ ⦃ surj = bijective-to-surjective(f) ⦄

    f⁻¹-inverseₗ : Inverseₗ(f)(f⁻¹)
    f⁻¹-inverseₗ = inverseᵣ-inverseₗ ⦃ inverᵣ = f⁻¹-inverseᵣ ⦄  ⦃ inj = bijective-to-injective(f) ⦄

    f⁻¹-function : Function(f⁻¹)
    f⁻¹-function = inverseᵣ-function ⦃ inverᵣ = f⁻¹-inverseᵣ ⦄ ⦃ inj = bijective-to-injective(f) ⦄

  invertible-to-bijective : ⦃ inver : Invertible(f) ⦄ → Bijective(f)
  invertible-to-bijective {f} ⦃ ([∃]-intro f⁻¹ ⦃ [∧]-intro func inver ⦄) ⦄ =
    injective-surjective-to-bijective(f)
      ⦃ inj  = inverse-to-injective  ⦃ inver = inver ⦄ ⦃ inv-func = func ⦄ ⦄
      ⦃ surj = inverse-to-surjective ⦃ inver = inver ⦄ ⦄

  invertible-when-bijective : Invertible(f) ↔ Bijective(f)
  invertible-when-bijective = [↔]-intro (bij ↦ bijective-to-invertible ⦃ bij ⦄) (inver ↦ invertible-to-bijective ⦃ inver ⦄)


{-# OPTIONS --cubical --no-import-sorts --no-exact-split --safe #-}
module Cubical.Data.Queue.Untruncated2List where

open import Cubical.Foundations.Everything

open import Cubical.Foundations.SIP
open import Cubical.Structures.Queue

open import Cubical.Data.Maybe
open import Cubical.Data.List
open import Cubical.Data.Sigma
open import Cubical.HITs.PropositionalTruncation

open import Cubical.Data.Queue.1List

module Untruncated2List {ℓ} (A : Type ℓ) (Aset : isSet A) where
 open Queues-on A Aset

 -- Untruncated 2Lists
 data Q : Type ℓ where
   Q⟨_,_⟩ : (xs ys : List A) → Q
   tilt : ∀ xs ys z → Q⟨ xs ++ [ z ] , ys ⟩ ≡ Q⟨ xs , ys ++ [ z ] ⟩

  -- enq into the first list, deq from the second if possible

 flushEq' : (xs ys : List A) → Q⟨ xs ++ ys , [] ⟩ ≡ Q⟨ xs , rev ys ⟩
 flushEq' xs [] = cong Q⟨_, [] ⟩ (++-unit-r xs)
 flushEq' xs (z ∷ ys) j =
   hcomp
     (λ i → λ
       { (j = i0) → Q⟨ ++-assoc xs [ z ] ys i , [] ⟩
       ; (j = i1) → tilt xs (rev ys) z i
       })
     (flushEq' (xs ++ [ z ]) ys j)

 flushEq : (xs ys : List A) → Q⟨ xs ++ rev ys , [] ⟩ ≡ Q⟨ xs , ys ⟩
 flushEq xs ys = flushEq' xs (rev ys) ∙ cong Q⟨ xs ,_⟩ (rev-rev ys)

 emp : Q
 emp = Q⟨ [] , [] ⟩

 enq : A → Q → Q
 enq a Q⟨ xs , ys ⟩ = Q⟨ a ∷ xs , ys ⟩
 enq a (tilt xs ys z i) = tilt (a ∷ xs) ys z i

 deqFlush : List A → Maybe (Q × A)
 deqFlush [] = nothing
 deqFlush (x ∷ xs) = just (Q⟨ [] , xs ⟩ , x)

 deq : Q → Maybe (Q × A)
 deq Q⟨ xs , [] ⟩ = deqFlush (rev xs)
 deq Q⟨ xs , y ∷ ys ⟩ = just (Q⟨ xs , ys ⟩ , y)
 deq (tilt xs [] z i) = path i
   where
   path : deqFlush (rev (xs ++ [ z ])) ≡ just (Q⟨ xs , [] ⟩ , z)
   path =
     cong deqFlush (rev-snoc xs z)
     ∙ cong (λ q → just (q , z)) (sym (flushEq' [] xs))
 deq (tilt xs (y ∷ ys) z i) = just (tilt xs ys z i , y)

 Raw : RawQueue
 Raw = (Q , emp , enq , deq)

 -- We construct an equivalence Q₁≃Q and prove that this is an equivalence of queue structures

 private
   module One = 1List A Aset
   open One renaming (Q to Q₁; emp to emp₁; enq to enq₁; deq to deq₁) using ()

 quot : Q₁ → Q
 quot xs = Q⟨ xs , [] ⟩

 eval : Q → Q₁
 eval Q⟨ xs , ys ⟩ = xs ++ rev ys
 eval (tilt xs ys z i) =
   hcomp
     (λ j → λ
       { (i = i0) → (xs ++ [ z ]) ++ rev ys
       ; (i = i1) → xs ++ rev-snoc ys z (~ j)
       })
     (++-assoc xs [ z ] (rev ys) i)

 quot∘eval : ∀ q → quot (eval q) ≡ q
 quot∘eval Q⟨ xs , ys ⟩ = flushEq xs ys
 quot∘eval (tilt xs ys z i) j =
   hcomp
     (λ k → λ
       { (i = i0) →
         compPath-filler (flushEq' (xs ++ [ z ]) (rev ys)) (cong Q⟨ xs ++ [ z ] ,_⟩ (rev-rev ys)) k j
       ; (i = i1) → helper k
       ; (j = i0) →
         Q⟨ compPath-filler (++-assoc xs [ z ] (rev ys)) (cong (xs ++_) (sym (rev-snoc ys z))) k i , [] ⟩
       ; (j = i1) → tilt xs (rev-rev ys k) z i
       })
     flushEq'-filler
   where
   flushEq'-filler : Q
   flushEq'-filler =
     hfill
       (λ i → λ
         { (j = i0) → Q⟨ ++-assoc xs [ z ] (rev ys) i , [] ⟩
         ; (j = i1) → tilt xs (rev (rev ys)) z i
         })
       (inS (flushEq' (xs ++ [ z ]) (rev ys) j))
       i

   helper : I → Q
   helper k =
     hcomp
       (λ l → λ
         { (j = i0) → Q⟨ xs ++ rev-snoc ys z (l ∧ ~ k) , [] ⟩
         ; (j = i1) → Q⟨ xs , rev-rev-snoc ys z l k ⟩
         ; (k = i0) → flushEq' xs (rev-snoc ys z l) j
         ; (k = i1) → flushEq xs (ys ++ [ z ]) j
         })
       (compPath-filler (flushEq' xs (rev (ys ++ [ z ]))) (cong Q⟨ xs ,_⟩ (rev-rev (ys ++ [ z ]))) k j)

 eval∘quot : ∀ xs → eval (quot xs) ≡ xs
 eval∘quot = ++-unit-r

 -- We get our desired equivalence
 quotEquiv : Q₁ ≃ Q
 quotEquiv = isoToEquiv (iso quot eval quot∘eval eval∘quot)

 -- Now it only remains to prove that this is an equivalence of queue structures
 quot∘emp : quot emp₁ ≡ emp
 quot∘emp = refl

 quot∘enq : ∀ x xs → quot (enq₁ x xs) ≡ enq x (quot xs)
 quot∘enq x xs = refl

 quot∘deq : ∀ xs → deqMap quot (deq₁ xs) ≡ deq (quot xs)
 quot∘deq [] = refl
 quot∘deq (x ∷ []) = refl
 quot∘deq (x ∷ x' ∷ xs) =
   deqMap-∘ quot (enq₁ x) (deq₁ (x' ∷ xs))
   ∙ sym (deqMap-∘ (enq x) quot (deq₁ (x' ∷ xs)))
   ∙ cong (deqMap (enq x)) (quot∘deq (x' ∷ xs))
   ∙ lemma x x' (rev xs)
   where
   lemma : ∀ x x' ys
     → deqMap (enq x) (deqFlush (ys ++ [ x' ]))
       ≡ deqFlush ((ys ++ [ x' ]) ++ [ x ])
   lemma x x' [] i = just (tilt [] [] x i , x')
   lemma x x' (y ∷ ys) i = just (tilt [] (ys ++ [ x' ]) x i , y)

 quotEquivHasQueueEquivStr : RawQueueEquivStr One.Raw Raw quotEquiv
 quotEquivHasQueueEquivStr = quot∘emp , quot∘enq , quot∘deq

 -- And we get a path between the raw 1Lists and 2Lists
 Raw-1≡2 : One.Raw ≡ Raw
 Raw-1≡2 = sip rawQueueUnivalentStr _ _ (quotEquiv , quotEquivHasQueueEquivStr)

 -- We derive the axioms for 2List from those for 1List
 WithLaws : Queue
 WithLaws = Q , str Raw , subst (uncurry QueueAxioms) Raw-1≡2 (snd (str One.WithLaws))

 -- In particular, the untruncated queue type is a set
 isSetQ : isSet Q
 isSetQ = str WithLaws .snd .fst

 WithLaws-1≡2 : One.WithLaws ≡ WithLaws
 WithLaws-1≡2 = sip queueUnivalentStr _ _ (quotEquiv , quotEquivHasQueueEquivStr)

 Finite : FiniteQueue
 Finite = Q , str WithLaws , subst (uncurry FiniteQueueAxioms) WithLaws-1≡2 (snd (str One.Finite))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties related to setoid list membership
------------------------------------------------------------------------

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

module Data.List.Membership.Setoid.Properties where

open import Algebra.FunctionProperties using (Op₂; Selective)
open import Data.Fin using (Fin; zero; suc)
open import Data.List
open import Data.List.Relation.Unary.Any as Any using (Any; here; there)
import Data.List.Relation.Unary.Any.Properties as Any
import Data.List.Membership.Setoid as Membership
import Data.List.Relation.Binary.Equality.Setoid as Equality
open import Data.Nat using (suc; z≤n; s≤s; _≤_; _<_)
open import Data.Nat.Properties using (≤-trans; n≤1+n)
open import Data.Product as Prod using (∃; _×_; _,_ ; ∃₂)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Function using (_$_; flip; _∘_; id)
open import Relation.Binary hiding (Decidable)
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Unary using (Decidable; Pred)
open import Relation.Nullary using (¬_; yes; no)
open import Relation.Nullary.Negation using (contradiction)
open Setoid using (Carrier)

------------------------------------------------------------------------
-- Equality properties

module _ {c ℓ} (S : Setoid c ℓ) where

  open Setoid S
  open Equality S
  open Membership S

  -- _∈_ respects the underlying equality

  ∈-resp-≈ : ∀ {xs} → (_∈ xs) Respects _≈_
  ∈-resp-≈ x≈y x∈xs = Any.map (trans (sym x≈y)) x∈xs

  ∉-resp-≈ : ∀ {xs} → (_∉ xs) Respects _≈_
  ∉-resp-≈ v≈w v∉xs w∈xs = v∉xs (∈-resp-≈ (sym v≈w) w∈xs)

  ∈-resp-≋ : ∀ {x} → (x ∈_) Respects _≋_
  ∈-resp-≋ = Any.lift-resp (flip trans)

  ∉-resp-≋ : ∀ {x} → (x ∉_) Respects _≋_
  ∉-resp-≋ xs≋ys v∉xs v∈ys = v∉xs (∈-resp-≋ (≋-sym xs≋ys) v∈ys)

------------------------------------------------------------------------
-- mapWith∈

module _ {c₁ c₂ ℓ₁ ℓ₂} (S₁ : Setoid c₁ ℓ₁) (S₂ : Setoid c₂ ℓ₂) where

  open Setoid S₁ renaming (Carrier to A₁; _≈_ to _≈₁_; refl to refl₁)
  open Setoid S₂ renaming (Carrier to A₂; _≈_ to _≈₂_; refl to refl₂)
  open Equality S₁ using ([]; _∷_) renaming (_≋_ to _≋₁_)
  open Equality S₂ using () renaming (_≋_ to _≋₂_)
  open Membership S₁

  mapWith∈-cong : ∀ {xs ys} → xs ≋₁ ys →
                  (f : ∀ {x} → x ∈ xs → A₂) →
                  (g : ∀ {y} → y ∈ ys → A₂) →
                  (∀ {x y} → x ≈₁ y → (x∈xs : x ∈ xs) (y∈ys : y ∈ ys) →
                     f x∈xs ≈₂ g y∈ys) →
                  mapWith∈ xs f ≋₂ mapWith∈ ys g
  mapWith∈-cong []            f g cong = []
  mapWith∈-cong (x≈y ∷ xs≋ys) f g cong =
    cong x≈y (here refl₁) (here refl₁) ∷
    mapWith∈-cong xs≋ys (f ∘ there) (g ∘ there)
      (λ x≈y x∈xs y∈ys → cong x≈y (there x∈xs) (there y∈ys))

  mapWith∈≗map : ∀ f xs → mapWith∈ xs (λ {x} _ → f x) ≋₂ map f xs
  mapWith∈≗map f []       = []
  mapWith∈≗map f (x ∷ xs) = refl₂ ∷ mapWith∈≗map f xs

module _ {c ℓ} (S : Setoid c ℓ) where

  open Setoid S
  open Membership S

  length-mapWith∈ : ∀ {a} {A : Set a} xs {f : ∀ {x} → x ∈ xs → A} →
                    length (mapWith∈ xs f) ≡ length xs
  length-mapWith∈ []       = P.refl
  length-mapWith∈ (x ∷ xs) = P.cong suc (length-mapWith∈ xs)

------------------------------------------------------------------------
-- map

module _ {c₁ c₂ ℓ₁ ℓ₂} (S₁ : Setoid c₁ ℓ₁) (S₂ : Setoid c₂ ℓ₂) where

  open Setoid S₁ renaming (Carrier to A₁; _≈_ to _≈₁_; refl to refl₁)
  open Setoid S₂ renaming (Carrier to A₂; _≈_ to _≈₂_)
  private module M₁ = Membership S₁; open M₁ using (find) renaming (_∈_ to _∈₁_)
  private module M₂ = Membership S₂; open M₂ using () renaming (_∈_ to _∈₂_)

  ∈-map⁺ : ∀ {f} → f Preserves _≈₁_ ⟶ _≈₂_ → ∀ {v xs} →
            v ∈₁ xs → f v ∈₂ map f xs
  ∈-map⁺ pres x∈xs = Any.map⁺ (Any.map pres x∈xs)

  ∈-map⁻ : ∀ {v xs f} → v ∈₂ map f xs →
           ∃ λ x → x ∈₁ xs × v ≈₂ f x
  ∈-map⁻ x∈map = find (Any.map⁻ x∈map)

  map-∷= : ∀ {f} (f≈ : f Preserves _≈₁_ ⟶ _≈₂_)
           {xs x v} → (x∈xs : x ∈₁ xs) →
           map f (x∈xs M₁.∷= v) ≡ ∈-map⁺ f≈ x∈xs M₂.∷= f v
  map-∷= f≈ (here x≈y)   = P.refl
  map-∷= f≈ (there x∈xs) = P.cong (_ ∷_) (map-∷= f≈ x∈xs)

------------------------------------------------------------------------
-- _++_

module _ {c ℓ} (S : Setoid c ℓ) where

  open Membership S using (_∈_)
  open Setoid S
  open Equality S using (_≋_; _∷_; ≋-refl)

  ∈-++⁺ˡ : ∀ {v xs ys} → v ∈ xs → v ∈ xs ++ ys
  ∈-++⁺ˡ = Any.++⁺ˡ

  ∈-++⁺ʳ : ∀ {v} xs {ys} → v ∈ ys → v ∈ xs ++ ys
  ∈-++⁺ʳ = Any.++⁺ʳ

  ∈-++⁻ : ∀ {v} xs {ys} → v ∈ xs ++ ys → (v ∈ xs) ⊎ (v ∈ ys)
  ∈-++⁻ = Any.++⁻

  ∈-insert : ∀ xs {ys v w} → v ≈ w → v ∈ xs ++ [ w ] ++ ys
  ∈-insert xs = Any.++-insert xs

  ∈-∃++ : ∀ {v xs} → v ∈ xs → ∃₂ λ ys zs → ∃ λ w →
          v ≈ w × xs ≋ ys ++ [ w ] ++ zs
  ∈-∃++ (here px)                  = [] , _ , _ , px , ≋-refl
  ∈-∃++ (there {d} v∈xs) with ∈-∃++ v∈xs
  ... | hs , _ , _ , v≈v′ , eq = d ∷ hs , _ , _ , v≈v′ , refl ∷ eq

------------------------------------------------------------------------
-- concat

module _ {c ℓ} (S : Setoid c ℓ) where

  open Setoid S using (_≈_)
  open Membership S using (_∈_)
  open Equality S using (≋-setoid)
  open Membership ≋-setoid using (find) renaming (_∈_ to _∈ₗ_)

  ∈-concat⁺ : ∀ {v xss} → Any (v ∈_) xss → v ∈ concat xss
  ∈-concat⁺ = Any.concat⁺

  ∈-concat⁻ : ∀ {v} xss → v ∈ concat xss → Any (v ∈_) xss
  ∈-concat⁻ = Any.concat⁻

  ∈-concat⁺′ : ∀ {v vs xss} → v ∈ vs → vs ∈ₗ xss → v ∈ concat xss
  ∈-concat⁺′ v∈vs = ∈-concat⁺ ∘ Any.map (flip (∈-resp-≋ S) v∈vs)

  ∈-concat⁻′ : ∀ {v} xss → v ∈ concat xss → ∃ λ xs → v ∈ xs × xs ∈ₗ xss
  ∈-concat⁻′ xss v∈c[xss] with find (∈-concat⁻ xss v∈c[xss])
  ... | xs , t , s = xs , s , t

------------------------------------------------------------------------
-- applyUpTo

module _ {c ℓ} (S : Setoid c ℓ) where

  open Setoid S using (_≈_; refl)
  open Membership S using (_∈_)

  ∈-applyUpTo⁺ : ∀ f {i n} → i < n → f i ∈ applyUpTo f n
  ∈-applyUpTo⁺ f = Any.applyUpTo⁺ f refl

  ∈-applyUpTo⁻ : ∀ {v} f {n} → v ∈ applyUpTo f n →
                 ∃ λ i → i < n × v ≈ f i
  ∈-applyUpTo⁻ = Any.applyUpTo⁻

------------------------------------------------------------------------
-- tabulate

module _ {c ℓ} (S : Setoid c ℓ) where

  open Setoid S using (_≈_; refl) renaming (Carrier to A)
  open Membership S using (_∈_)

  ∈-tabulate⁺ : ∀ {n} {f : Fin n → A} i → f i ∈ tabulate f
  ∈-tabulate⁺ i = Any.tabulate⁺ i refl

  ∈-tabulate⁻ : ∀ {n} {f : Fin n → A} {v} →
                v ∈ tabulate f → ∃ λ i → v ≈ f i
  ∈-tabulate⁻ = Any.tabulate⁻

------------------------------------------------------------------------
-- filter

module _ {c ℓ p} (S : Setoid c ℓ) {P : Pred (Carrier S) p}
         (P? : Decidable P) (resp : P Respects (Setoid._≈_ S)) where

  open Setoid S using (_≈_; sym)
  open Membership S using (_∈_)

  ∈-filter⁺ : ∀ {v xs} → v ∈ xs → P v → v ∈ filter P? xs
  ∈-filter⁺ {xs = x ∷ _} (here v≈x) Pv with P? x
  ... | yes _   = here v≈x
  ... | no  ¬Px = contradiction (resp v≈x Pv) ¬Px
  ∈-filter⁺ {xs = x ∷ _} (there v∈xs) Pv with P? x
  ... | yes _ = there (∈-filter⁺ v∈xs Pv)
  ... | no  _ = ∈-filter⁺ v∈xs Pv

  ∈-filter⁻ : ∀ {v xs} → v ∈ filter P? xs → v ∈ xs × P v
  ∈-filter⁻ {xs = []}     ()
  ∈-filter⁻ {xs = x ∷ xs} v∈f[x∷xs] with P? x
  ... | no  _  = Prod.map there id (∈-filter⁻ v∈f[x∷xs])
  ... | yes Px with v∈f[x∷xs]
  ...   | here  v≈x   = here v≈x , resp (sym v≈x) Px
  ...   | there v∈fxs = Prod.map there id (∈-filter⁻ v∈fxs)

------------------------------------------------------------------------
-- length

module _ {c ℓ} (S : Setoid c ℓ) where

  open Membership S using (_∈_)

  ∈-length : ∀ {x xs} → x ∈ xs → 1 ≤ length xs
  ∈-length (here px)    = s≤s z≤n
  ∈-length (there x∈xs) = ≤-trans (∈-length x∈xs) (n≤1+n _)

------------------------------------------------------------------------
-- lookup

module _ {c ℓ} (S : Setoid c ℓ) where

  open Setoid S using (refl)
  open Membership S using (_∈_)

  ∈-lookup : ∀ xs i → lookup xs i ∈ xs
  ∈-lookup []       ()
  ∈-lookup (x ∷ xs) zero    = here refl
  ∈-lookup (x ∷ xs) (suc i) = there (∈-lookup xs i)

------------------------------------------------------------------------
-- foldr

module _ {c ℓ} (S : Setoid c ℓ) {_•_ : Op₂ (Carrier S)} where

  open Setoid S using (_≈_; refl; sym; trans)
  open Membership S using (_∈_)

  foldr-selective : Selective _≈_ _•_ → ∀ e xs →
                    (foldr _•_ e xs ≈ e) ⊎ (foldr _•_ e xs ∈ xs)
  foldr-selective •-sel i [] = inj₁ refl
  foldr-selective •-sel i (x ∷ xs) with •-sel x (foldr _•_ i xs)
  ... | inj₁ x•f≈x = inj₂ (here x•f≈x)
  ... | inj₂ x•f≈f with foldr-selective •-sel i xs
  ...   | inj₁ f≈i  = inj₁ (trans x•f≈f f≈i)
  ...   | inj₂ f∈xs = inj₂ (∈-resp-≈ S (sym x•f≈f) (there f∈xs))

------------------------------------------------------------------------
-- _∷=_

module _ {c ℓ} (S : Setoid c ℓ) where

  open Setoid S
  open Membership S

  ∈-∷=⁺-updated : ∀ {xs x v} (x∈xs : x ∈ xs) → v ∈ (x∈xs ∷= v)
  ∈-∷=⁺-updated (here  px)  = here refl
  ∈-∷=⁺-updated (there pxs) = there (∈-∷=⁺-updated pxs)

  ∈-∷=⁺-untouched : ∀ {xs x y v} (x∈xs : x ∈ xs) → (¬ x ≈ y) → y ∈ xs → y ∈ (x∈xs ∷= v)
  ∈-∷=⁺-untouched (here  x≈z)  x≉y (here  y≈z)  = contradiction (trans x≈z (sym y≈z)) x≉y
  ∈-∷=⁺-untouched (here  x≈z)  x≉y (there y∈xs) = there y∈xs
  ∈-∷=⁺-untouched (there x∈xs) x≉y (here  y≈z)  = here y≈z
  ∈-∷=⁺-untouched (there x∈xs) x≉y (there y∈xs) = there (∈-∷=⁺-untouched x∈xs x≉y y∈xs)

  ∈-∷=⁻ : ∀ {xs x y v} (x∈xs : x ∈ xs) → (¬ y ≈ v) → y ∈ (x∈xs ∷= v) → y ∈ xs
  ∈-∷=⁻ (here x≈z)   y≉v (here y≈v) = contradiction y≈v y≉v
  ∈-∷=⁻ (here x≈z)   y≉v (there y∈) = there y∈
  ∈-∷=⁻ (there x∈xs) y≉v (here y≈z) = here y≈z
  ∈-∷=⁻ (there x∈xs) y≉v (there y∈) = there (∈-∷=⁻ x∈xs y≉v y∈)


------------------------------------------------------------------------------
-- Totality properties for Forest
------------------------------------------------------------------------------

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

module FOTC.Program.Mirror.Forest.TotalityATP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.List
open import FOTC.Program.Mirror.Type

------------------------------------------------------------------------------

++-Forest : ∀ {xs ys} → Forest xs → Forest ys → Forest (xs ++ ys)
++-Forest {ys = ys} fnil Fys = prf
  where postulate prf : Forest ([] ++ ys)
        {-# ATP prove prf #-}
++-Forest {ys = ys} (fcons {x} {xs} Tx Fxs) Fys = prf (++-Forest Fxs Fys)
  where postulate prf : Forest (xs ++ ys) →
                        Forest ((x ∷ xs) ++ ys)
        {-# ATP prove prf #-}

-- We don't use a combined proof, because it is necessary to erase a
-- proof term which we don't know how to erase.
map-Forest : ∀ {xs} f → (∀ {x} → Tree x → Tree (f · x)) →
             Forest xs → Forest (map f xs)
map-Forest f fTree fnil = subst Forest (sym (map-[] f)) fnil
map-Forest f fTree (fcons {x} {xs} Tx Fxs) =
  subst Forest
        (sym (map-∷ f x xs))
        (fcons (fTree Tx) (map-Forest f fTree Fxs))

rev-Forest : ∀ {xs ys} → Forest xs → Forest ys → Forest (rev xs ys)
rev-Forest {ys = ys} fnil Fys = prf
  where postulate prf : Forest (rev [] ys)
        {-# ATP prove prf #-}
rev-Forest {ys = ys} (fcons {x} {xs} Tx Fxs) Fys =
  prf (rev-Forest Fxs (fcons Tx Fys))
  where postulate prf : Forest (rev xs (x ∷ ys)) →
                        Forest (rev (x ∷ xs) ys)
        {-# ATP prove prf #-}

postulate reverse-Forest : ∀ {xs} → Forest xs → Forest (reverse xs)
{-# ATP prove reverse-Forest rev-Forest #-}


-- Andreas, 2017-12-03, issue #2826, reported by Snicksi, shrunk by sattlerc

data A : Set where
  a : A

data B : Set where
  b : (x : A) → B

foo : B → B
foo s with a
-- WAS: case splitting produces repeated variables in pattern
foo s | x = {!s!}

-- Expected: Something like the following
-- foo (b x₁) | x = {!!}


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

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

open import LibraBFT.Impl.OBM.Rust.RustTypes
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Consensus.Types.EpochIndep
open import Util.Prelude

module LibraBFT.Impl.OBM.Util where

-- To tolerate f failures, cluster must contain at least n ≥ 3f + 1 nodes,
-- where n − f nodes form a quorum, assuming 1 vote per node.
-- Note: our Haskell implementation and our model of it support non-uniform voting power,
-- that is NOT reflected in these functions, but is reflected in functions in ValidatorVerifier.

numNodesNeededForNFailures : U64 -> U64
numNodesNeededForNFailures numFaultsAllowed = 3 * numFaultsAllowed + 1

checkBftAndRun : ∀ {names : Set} {b : Set}
               → U64 → List names → (U64 → List names → b)
               → Either ErrLog b
checkBftAndRun numFailures authors f =
  if-dec length authors <? numNodesNeededForNFailures numFailures
  then Left fakeErr --(ErrL [ "checkBftAndRun: not enough authors for given number of failures"
                    --      , show numFailures, show (length authors) ])
  else pure (f numFailures authors)


{-

Eilenberg–Mac Lane type K(G, 1)

-}

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

open import Cubical.HITs.EilenbergMacLane1.Base

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Path
open import Cubical.Foundations.GroupoidLaws

open import Cubical.Data.Sigma

open import Cubical.Algebra.Group.Base

open import Cubical.HITs.PropositionalTruncation as PropTrunc using (∥_∥; ∣_∣; squash)
open import Cubical.HITs.SetTruncation as SetTrunc using (∥_∥₂; ∣_∣₂; squash₂)

-- Type quotients

private
  variable
    ℓG ℓ : Level

module _ (G : Group {ℓG}) where

  open Group G

  elimEq : {B : EM₁ G → Type ℓ}
           (Bprop : (x : EM₁ G) → isProp (B x))
           {x y : EM₁ G}
           (eq : x ≡ y)
           (bx : B x)
           (by : B y) →
           PathP (λ i → B (eq i)) bx by
  elimEq {B = B} Bprop {x = x} =
    J (λ y eq → ∀ bx by → PathP (λ i → B (eq i)) bx by) (λ bx by → Bprop x bx by)

  elimProp : {B : EM₁ G → Type ℓ}
             → ((x : EM₁ G) → isProp (B x))
             → B embase
             → (x : EM₁ G)
             → B x
  elimProp Bprop b embase = b
  elimProp Bprop b (emloop g i) = elimEq Bprop (emloop g) b b i
  elimProp Bprop b (emcomp g h i j) =
    isSet→isSetDep (λ x → isProp→isSet (Bprop x))
    (emloop g) (emloop (g + h)) (λ j → embase) (emloop h) (emcomp g h)
    (λ i → elimEq Bprop (emloop g) b b i)
    (λ i → elimEq Bprop (emloop (g + h)) b b i)
    (λ j → b) (λ j → elimEq Bprop (emloop h) b b j) i j
  elimProp Bprop b (emsquash x y p q r s i j k) =
    isOfHLevel→isOfHLevelDep 3 (λ x → isSet→isGroupoid (isProp→isSet (Bprop x)))
    _ _ _ _ (λ j k → g (r j k)) (λ j k → g (s j k)) (emsquash x y p q r s) i j k
    where
      g = elimProp Bprop b

  elimProp2 : {C : EM₁ G → EM₁ G → Type ℓ}
            → ((x y : EM₁ G) → isProp (C x y))
            → C embase embase
            → (x y : EM₁ G)
            → C x y
  elimProp2 Cprop c = elimProp (λ x → isPropΠ (λ y → Cprop x y))
                               (elimProp (λ y → Cprop embase y) c)

  elimSet : {B : EM₁ G → Type ℓ}
          → ((x : EM₁ G) → isSet (B x))
          → (b : B embase)
          → ((g : Carrier) → PathP (λ i → B (emloop g i)) b b)
          → (x : EM₁ G)
          → B x
  elimSet Bset b bloop embase = b
  elimSet Bset b bloop (emloop g i) = bloop g i
  elimSet Bset b bloop (emcomp g h i j) =
    isSet→isSetDep Bset (emloop g) (emloop (g + h)) (λ j → embase) (emloop h) (emcomp g h)
      (bloop g) (bloop (g + h)) refl (bloop h) i j
  elimSet Bset b bloop (emsquash x y p q r s i j k) =
    isOfHLevel→isOfHLevelDep 3 (λ x → isSet→isGroupoid (Bset x))
      _ _ _ _ (λ j k → g (r j k)) (λ j k → g (s j k)) (emsquash x y p q r s) i j k
    where
      g = elimSet Bset b bloop

  elim : {B : EM₁ G → Type ℓ}
       → ((x : EM₁ G) → isGroupoid (B x))
       → (b : B embase)
       → (bloop : (g : Carrier) → PathP (λ i → B (emloop g i)) b b)
       → ((g h : Carrier) → SquareP (λ i j → B (emcomp g h i j))
            (bloop g) (bloop (g + h)) (λ j → b) (bloop h))
       → (x : EM₁ G)
       → B x
  elim Bgpd b bloop bcomp embase = b
  elim Bgpd b bloop bcomp (emloop g i) = bloop g i
  elim Bgpd b bloop bcomp (emcomp g h i j) = bcomp g h i j
  elim Bgpd b bloop bcomp (emsquash x y p q r s i j k) =
     isOfHLevel→isOfHLevelDep 3 Bgpd
      _ _ _ _ (λ j k → g (r j k)) (λ j k → g (s j k)) (emsquash x y p q r s) i j k
    where
      g = elim Bgpd b bloop bcomp

  rec : {B : Type ℓ}
      → isGroupoid B
      → (b : B)
      → (bloop : Carrier → b ≡ b)
      → ((g h : Carrier) → Square (bloop g) (bloop (g + h)) refl (bloop h))
      → (x : EM₁ G)
      → B
  rec Bgpd = elim (λ _ → Bgpd)

  rec' : {B : Type ℓ}
      → isGroupoid B
      → (b : B)
      → (bloop : Carrier → b ≡ b)
      → ((g h : Carrier) → (bloop g) ∙ (bloop h) ≡ bloop (g + h))
      → (x : EM₁ G)
      → B
  rec' Bgpd b bloop p = rec Bgpd b bloop sq
    where
      module _ (g h : Carrier) where
        abstract
          sq : Square (bloop g) (bloop (g + h)) refl (bloop h)
          sq =
            transport (sym (Square≡doubleComp (bloop g) (bloop (g + h)) refl (bloop h)))
                      (refl ∙∙ bloop g ∙∙ bloop h
                        ≡⟨ doubleCompPath-elim refl (bloop g) (bloop h) ⟩
                      (refl ∙ bloop g) ∙ bloop h
                        ≡⟨ cong (_∙ bloop h) (sym (lUnit (bloop g))) ⟩
                      bloop g ∙ bloop h
                        ≡⟨ p g h ⟩
                      bloop (g + h) ∎)


------------------------------------------------------------------------
-- Simple expressions
------------------------------------------------------------------------

-- Several examples based on Matsuda and Wang's "FliPpr: A Prettier
-- Invertible Printing System".

{-# OPTIONS --guardedness #-}

module Examples.Expression where

open import Algebra
open import Codata.Musical.Notation
open import Data.List
open import Data.List.Properties
open import Data.Product
open import Data.Unit
open import Function
open import Relation.Binary.PropositionalEquality as P using (_≡_; refl)

private
  module LM {A : Set} = Monoid (++-monoid A)

open import Examples.Identifier
import Grammar.Infinite as Grammar
import Pretty
open import Renderer
open import Utilities

-- Very simple expressions.

module Expression₁ where

  data Expr : Set where
    one : Expr
    sub : Expr → Expr → Expr

  module _ where

    open Grammar

    mutual

      expr : Grammar Expr
      expr = term
           ∣ sub <$> ♯ expr
                  <⊛ whitespace ⋆
                  <⊛ string′ "-"
                  <⊛ whitespace ⋆
                  ⊛  term

      term : Grammar Expr
      term = one <$ string′ "1"
           ∣    string′ "("
             ⊛> whitespace ⋆
             ⊛> ♯ expr
             <⊛ whitespace ⋆
             <⊛ string′ ")"

  open Pretty

  one-doc : Doc term one
  one-doc = left (<$ text)

  mutual

    expr-printer : Pretty-printer expr
    expr-printer one         = left one-doc
    expr-printer (sub e₁ e₂) =
      group (right (<$> expr-printer e₁ <⊛-tt
                    nest 2 line⋆ <⊛ text <⊛ space ⊛
                    nest 2 (term-printer e₂)))

    term-printer : Pretty-printer term
    term-printer one = one-doc
    term-printer e   =
      right (text ⊛> nil-⋆ ⊛> expr-printer e <⊛ nil-⋆ <⊛ text)

  example : Expr
  example = sub (sub one one) (sub one one)

  test₁ : render 80 (expr-printer example) ≡ "1 - 1 - (1 - 1)"
  test₁ = refl

  test₂ : render 11 (expr-printer example) ≡ "1 - 1\n  - (1 - 1)"
  test₂ = refl

  test₃ : render 8 (expr-printer example) ≡ "1 - 1\n  - (1\n    - 1)"
  test₃ = refl

-- Expression₁.expr does not accept final whitespace. The grammar
-- below does.

module Expression₂ where

  open Expression₁ using (Expr; one; sub; example)

  module _ where

    open Grammar

    mutual

      expr : Grammar Expr
      expr = term
           ∣ sub <$> ♯ expr <⊛ symbol′ "-" ⊛ term

      term : Grammar Expr
      term = one <$ symbol′ "1"
           ∣ symbol′ "(" ⊛> ♯ expr <⊛ symbol′ ")"

    private

      -- A manual proof of Trailing-whitespace expr (included for
      -- illustrative purposes; not used below).

      Trailing-whitespace″ : ∀ {A} → Grammar A → Set₁
      Trailing-whitespace″ g =
        ∀ {x s s₁ s₂} →
        x ∈ g · s₁ → s ∈ whitespace ⋆ · s₂ → x ∈ g · s₁ ++ s₂

      tw′-whitespace : Trailing-whitespace′ (whitespace ⋆)
      tw′-whitespace ⋆-[]-sem                                  w = _ , w
      tw′-whitespace (⋆-+-sem (⊛-sem {s₁ = s₁} (<$>-sem p) q)) w
        with tw′-whitespace q w
      ... | _ , r = _ , cast (P.sym $ LM.assoc s₁ _ _)
                             (⋆-+-sem (⊛-sem (<$>-sem p) r))

      tw″-symbol : ∀ {s} → Trailing-whitespace″ (symbol s)
      tw″-symbol (<⊛-sem {s₁ = s₁} p q) w =
        cast (P.sym $ LM.assoc s₁ _ _)
             (<⊛-sem p (proj₂ (tw′-whitespace q w)))

      tw″-term : Trailing-whitespace″ term
      tw″-term (left-sem (<$-sem p)) w =
        left-sem (<$-sem (tw″-symbol p w))
      tw″-term (right-sem (<⊛-sem {s₁ = s₁} p q)) w =
        cast (P.sym $ LM.assoc s₁ _ _)
             (right-sem (<⊛-sem p (tw″-symbol q w)))

      tw″-expr : Trailing-whitespace″ expr
      tw″-expr (left-sem p) w =
        left-sem (tw″-term p w)
      tw″-expr (right-sem (⊛-sem {s₁ = s₁} p q)) w =
        cast (P.sym $ LM.assoc s₁ _ _)
             (right-sem (⊛-sem p (tw″-term q w)))

      tw-expr : Trailing-whitespace expr
      tw-expr (<⊛-sem p w) = tw″-expr p w

  open Pretty

  one-doc : Doc term one
  one-doc = left (<$ symbol)

  mutual

    expr-printer : Pretty-printer expr
    expr-printer one         = left one-doc
    expr-printer (sub e₁ e₂) =
      group (right (<$> final-line 6 (expr-printer e₁) 2 <⊛
                    symbol-space ⊛ nest 2 (term-printer e₂)))

    term-printer : Pretty-printer term
    term-printer one = one-doc
    term-printer e   = right (symbol ⊛> expr-printer e <⊛ symbol)

  test₁ : render 80 (expr-printer example) ≡ "1 - 1 - (1 - 1)"
  test₁ = refl

  test₂ : render 11 (expr-printer example) ≡ "1 - 1\n  - (1 - 1)"
  test₂ = refl

  test₃ : render 8 (expr-printer example) ≡ "1 - 1\n  - (1\n    - 1)"
  test₃ = refl

-- A somewhat larger expression example.

module Expression₃ where

  -- Expressions.

  data Expr : Set where
    one : Expr
    sub : Expr → Expr → Expr
    div : Expr → Expr → Expr
    var : Identifier → Expr

  -- Precedences.

  data Prec : Set where
    ′5 ′6 ′7 : Prec

  module _ where

    open Grammar

    -- One expression grammar for each precedence level.

    expr : Prec → Grammar Expr
    expr ′5 = ♯ expr ′6
            ∣ sub <$> ♯ expr ′5 <⊛ symbol′ "-" ⊛ ♯ expr ′6
    expr ′6 = ♯ expr ′7
            ∣ div <$> ♯ expr ′6 <⊛ symbol′ "/" ⊛ ♯ expr ′7
    expr ′7 = one <$ symbol′ "1"
            ∣ var <$> identifier-w
            ∣ symbol′ "(" ⊛> ♯ expr ′5 <⊛ symbol′ ")"

  open Pretty

  -- Document for one.

  one-doc : Doc (expr ′7) one
  one-doc = left (left (<$ symbol))

  -- Documents for variables.

  var-doc : ∀ x → Doc (expr ′7) (var x)
  var-doc x = left (right (<$> identifier-w-printer x))

  -- Adds parentheses to a document.

  parens : ∀ {e} → Doc (expr ′5) e → Doc (expr ′7) e
  parens d = right (symbol ⊛> d <⊛ symbol)

  -- Adds parentheses only when necessary (when p₁ < p₂).

  parens-if[_<_] : ∀ p₁ p₂ {e} → Doc (expr p₁) e → Doc (expr p₂) e
  parens-if[ ′5 < ′5 ] = id
  parens-if[ ′5 < ′6 ] = left ∘ parens
  parens-if[ ′5 < ′7 ] = parens
  parens-if[ ′6 < ′5 ] = left
  parens-if[ ′6 < ′6 ] = id
  parens-if[ ′6 < ′7 ] = parens ∘ left
  parens-if[ ′7 < ′5 ] = left ∘ left
  parens-if[ ′7 < ′6 ] = left
  parens-if[ ′7 < ′7 ] = id

  mutual

    -- Pretty-printers.

    expr-printer : ∀ p → Pretty-printer (expr p)
    expr-printer p (sub e₁ e₂) = parens-if[ ′5 < p ] (sub-printer e₁ e₂)
    expr-printer p (div e₁ e₂) = parens-if[ ′6 < p ] (div-printer e₁ e₂)
    expr-printer p one         = parens-if[ ′7 < p ] one-doc
    expr-printer p (var x)     = parens-if[ ′7 < p ] (var-doc x)

    sub-printer : ∀ e₁ e₂ → Doc (expr ′5) (sub e₁ e₂)
    sub-printer e₁ e₂ =
      group (right (<$> final-line 10 (expr-printer ′5 e₁) 2 <⊛
                    symbol-space ⊛ nest 2 (expr-printer ′6 e₂)))

    div-printer : ∀ e₁ e₂ → Doc (expr ′6) (div e₁ e₂)
    div-printer e₁ e₂ =
      group (right (<$> final-line 10 (expr-printer ′6 e₁) 2 <⊛
                    symbol-space ⊛ nest 2 (expr-printer ′7 e₂)))

  -- Unit tests.

  example : Expr
  example = sub (div (var (str⁺ "x")) one) (sub one (var (str⁺ "y")))

  test₁ : render 80 (expr-printer ′5 example) ≡ "x / 1 - (1 - y)"
  test₁ = refl

  test₂ : render 11 (expr-printer ′5 example) ≡ "x / 1\n  - (1 - y)"
  test₂ = refl

  test₃ : render 8 (expr-printer ′5 example) ≡ "x / 1\n  - (1\n    - y)"
  test₃ = refl

  test₄ : render 11 (expr-printer ′6 example) ≡ "(x / 1\n  - (1\n    - y))"
  test₄ = refl

  test₅ : render 12 (expr-printer ′6 example) ≡ "(x / 1\n  - (1 - y))"
  test₅ = refl


{-# OPTIONS --keep-pattern-variables #-}

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

test₁ : (m : Nat) → m ≡ 0 → Set
test₁ m eq = {!eq!}

test₂ : (A B : Set) → A ≡ B → Set
test₂ A B eq = {!eq!}


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommRingSolver.HornerForms where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Nat using (ℕ)
open import Cubical.Data.Int hiding (_+_ ; _·_ ; -_)
open import Cubical.Data.FinData
open import Cubical.Data.Vec
open import Cubical.Data.Bool

open import Cubical.Relation.Nullary.Base using (yes; no)

open import Cubical.Algebra.CommRingSolver.Utility

open import Cubical.Algebra.CommRingSolver.RawRing
open import Cubical.Algebra.CommRingSolver.IntAsRawRing
open import Cubical.Algebra.CommRingSolver.RawAlgebra renaming (⟨_⟩ to ⟨_⟩ₐ)
open import Cubical.Algebra.CommRingSolver.AlgebraExpression public

private
  variable
    ℓ ℓ' : Level

{-
  This defines the type of multivariate Polynomials over the RawRing R.
  The construction is based on the algebraic fact

    R[X₀][X₁]⋯[Xₙ] ≅ R[X₀,⋯,Xₙ]

  BUT: Contrary to algebraic convetions, we will give 'Xₙ' the lowest index
  in the definition of 'Variable' below. So if 'Variable n R k' is identified
  with 'Xₖ', then the RawRing we construct should rather be denoted with

    R[Xₙ][Xₙ₋₁]⋯[X₀]

  or, to be precise about the evaluation order:

    (⋯((R[Xₙ])[Xₙ₋₁])⋯)[X₀]

-}

data IteratedHornerForms (A : RawAlgebra ℤAsRawRing ℓ) : ℕ → Type ℓ where
  const : ℤ → IteratedHornerForms A ℕ.zero
  0H : {n : ℕ} → IteratedHornerForms A (ℕ.suc n)
  _·X+_ : {n : ℕ} → IteratedHornerForms A (ℕ.suc n) → IteratedHornerForms A n
                  → IteratedHornerForms A (ℕ.suc n)

{-
  The following function returns true, if there is some
  obvious reason that the Horner-Expression should be zero.
  Since Equality is undecidable in a general RawAlgebra, we cannot
  have a function that fully lives up to the name 'isZero'.
-}
module _ (A : RawAlgebra ℤAsRawRing ℓ) where
  open RawRing ℤAsRawRing
  isZero : {n : ℕ} → IteratedHornerForms A n
                   → Bool
  isZero (const (pos ℕ.zero)) = true
  isZero (const (pos (ℕ.suc _))) = false
  isZero (const (negsuc _)) = false
  isZero 0H = true
  isZero (P ·X+ Q) = (isZero P) and (isZero Q)

  leftIsZero : {n : ℕ}
               (P : IteratedHornerForms A (ℕ.suc n))
               (Q : IteratedHornerForms A n)
               → isZero (P ·X+ Q) ≡ true
               → isZero P ≡ true
  leftIsZero P Q isZeroSum with isZero P
  ... | true = refl
  ... | false = byBoolAbsurdity (fst (extractFromAnd _ _ isZeroSum))

  rightIsZero : {n : ℕ}
               (P : IteratedHornerForms A (ℕ.suc n))
               (Q : IteratedHornerForms A n)
               → isZero (P ·X+ Q) ≡ true
               → isZero Q ≡ true
  rightIsZero P Q isZeroSum with isZero Q
  ... | true = refl
  ... | false = byBoolAbsurdity (snd (extractFromAnd _ _ isZeroSum))

module IteratedHornerOperations (A : RawAlgebra ℤAsRawRing ℓ) where
  open RawRing ℤAsRawRing

  private
    1H' : (n : ℕ) → IteratedHornerForms A n
    1H' ℕ.zero = const 1r
    1H' (ℕ.suc n) = 0H ·X+ 1H' n

    0H' : (n : ℕ) → IteratedHornerForms A n
    0H' ℕ.zero = const 0r
    0H' (ℕ.suc n) = 0H

  1ₕ : {n : ℕ} → IteratedHornerForms A n
  1ₕ {n = n} = 1H' n

  0ₕ : {n : ℕ} → IteratedHornerForms A n
  0ₕ {n = n} = 0H' n

  X : (n : ℕ) (k : Fin n) → IteratedHornerForms A n
  X (ℕ.suc m) zero = 1ₕ ·X+ 0ₕ
  X (ℕ.suc m) (suc k) = 0ₕ ·X+ X m k

  _+ₕ_ : {n : ℕ} → IteratedHornerForms A n → IteratedHornerForms A n
               → IteratedHornerForms A n
  (const r) +ₕ (const s) = const (r + s)
  0H +ₕ Q = Q
  (P ·X+ r) +ₕ 0H = P ·X+ r
  (P ·X+ r) +ₕ (Q ·X+ s) =
    let left = (P +ₕ Q)
        right = (r +ₕ s)
    in if ((isZero A left) and (isZero A right))
       then 0ₕ
       else left ·X+ right

  -ₕ : {n : ℕ} → IteratedHornerForms A n → IteratedHornerForms A n
  -ₕ (const x) = const (- x)
  -ₕ 0H = 0H
  -ₕ (P ·X+ Q) = (-ₕ P) ·X+ (-ₕ Q)

  _⋆_ : {n : ℕ} → IteratedHornerForms A n → IteratedHornerForms A (ℕ.suc n)
                → IteratedHornerForms A (ℕ.suc n)
  _·ₕ_ : {n : ℕ} → IteratedHornerForms A n → IteratedHornerForms A n
                → IteratedHornerForms A n
  r ⋆ 0H = 0H
  r ⋆ (P ·X+ Q) =
    if (isZero A r)
    then 0ₕ
    else (r ⋆ P) ·X+ (r ·ₕ Q)

  const x ·ₕ const y = const (x · y)
  0H ·ₕ Q = 0H
  (P ·X+ Q) ·ₕ S =
     let
        z = (P ·ₕ S)
     in if (isZero A z)
        then (Q ⋆ S)
        else (z ·X+ 0ₕ) +ₕ (Q ⋆ S)

  isZeroPresLeft⋆ :
    {n : ℕ}
    (r : IteratedHornerForms A n)
    (P : IteratedHornerForms A (ℕ.suc n))
    → isZero A r ≡ true
    → isZero A (r ⋆ P) ≡ true
  isZeroPresLeft⋆ r 0H isZero-r = refl
  isZeroPresLeft⋆ r (P ·X+ Q) isZero-r with isZero A r
  ...  | true = refl
  ...  | false = byBoolAbsurdity isZero-r

  isZeroPresLeft·ₕ :
    {n : ℕ} (P Q : IteratedHornerForms A n)
    → isZero A P ≡ true
    → isZero A (P ·ₕ Q) ≡ true
  isZeroPresLeft·ₕ (const (pos ℕ.zero)) (const _) isZeroP = refl
  isZeroPresLeft·ₕ (const (pos (ℕ.suc n))) (const _) isZeroP = byBoolAbsurdity isZeroP
  isZeroPresLeft·ₕ (const (negsuc n)) (const _) isZeroP = byBoolAbsurdity isZeroP
  isZeroPresLeft·ₕ 0H Q isZeroP = refl
  isZeroPresLeft·ₕ (P ·X+ Q) S isZeroSum with isZero A (P ·ₕ S) ≟ true
  ... | no p = byBoolAbsurdity (sym notZeroProd ∙ isZeroProd)
               where notZeroProd = ¬true→false _ p
                     isZeroP = extractFromAndLeft isZeroSum
                     isZeroProd = isZeroPresLeft·ₕ P S isZeroP
  ... | yes p with isZero A (P ·ₕ S)
  ...        | true = isZeroPresLeft⋆ Q S isZeroQ
                      where isZeroQ = extractFromAndRight isZeroSum
  ...        | false = byBoolAbsurdity p

  asRawRing : (n : ℕ) → RawRing ℓ
  RawRing.Carrier (asRawRing n) = IteratedHornerForms A n
  RawRing.0r (asRawRing n) = 0ₕ
  RawRing.1r (asRawRing n) = 1ₕ
  RawRing._+_ (asRawRing n) = _+ₕ_
  RawRing._·_ (asRawRing n) = _·ₕ_
  RawRing.- (asRawRing n) =  -ₕ

Variable : (n : ℕ) (R : RawAlgebra ℤAsRawRing ℓ') (k : Fin n) → IteratedHornerForms R n
Variable n R k = IteratedHornerOperations.X R n k

Constant : (n : ℕ) (R : RawAlgebra ℤAsRawRing ℓ') (r : ℤ) → IteratedHornerForms R n
Constant ℕ.zero R r = const r
Constant (ℕ.suc n) R r = IteratedHornerOperations.0ₕ R ·X+ Constant n R r


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

module LeftCancellation where

open import Data.Empty using (⊥; ⊥-elim)
open import Data.Unit using (⊤; tt)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (_,_; proj₁; proj₂)
open import Function renaming (_∘_ to _○_)

open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; cong)
  renaming (trans to _∘_; sym to !_)

open import Equiv using (_∼_; _≃_; sym≃; inj≃; qinv; _●_)

------------------------------------------------------------------------------
-- This is WAY simpler than using 'with' and 'inspect'!

record Ev {A B : Set} (f : A → B) (x : A) : Set where
  constructor ev
  field
    v : B
    fx=v : f x ≡ v

mkV : {A B : Set} → (f : A → B) → (x : A) → Ev f x
mkV f x = ev (f x) refl

private
  bad-path : {A B : Set} → (a : A) → (b : B) → inj₁ a ≡ inj₂ b → ⊥
  bad-path x y ()

------------------------------------------------------------------------------
-- Very complex proof that we can cancel units on the left of ⊎

-- Some repeated patterns:

inj₁≡ : {A B : Set} → {a b : A} → inj₁ {A = A} {B} a ≡ inj₁ b → a ≡ b
inj₁≡ refl = refl

inj₂≡ : {A B : Set} → {a b : B} → inj₂ {A = A} {B} a ≡ inj₂ b → a ≡ b
inj₂≡ refl = refl

-- use injectivity of equivalences to go from f x ≡ f y to x ≡ y

injectivity : {A B : Set} (equiv : (⊤ ⊎ A) ≃ (⊤ ⊎ B)) →
  (a : A) → proj₁ equiv (inj₁ tt) ≡ proj₁ equiv (inj₂ a) → (inj₁ tt ≡ inj₂ a)
injectivity equiv x path = inj≃ equiv (inj₁ tt) (inj₂ x) path

left-cancel-⊤ : {A B : Set} →  ((⊤ ⊎ A) ≃ (⊤ ⊎ B)) → A ≃ B
left-cancel-⊤ {A} {B} (f₁ , qinv g₁ α₁ β₁) =
  let eqv = (f₁ , qinv g₁ α₁ β₁) in
  let v₁ = mkV f₁ (inj₁ tt) in
  let v₂ = mkV g₁ (inj₁ tt) in
  mk₁ {A} {B} eqv v₁ v₂
  where
    mk₁ : {A B : Set} (e : (⊤ ⊎ A) ≃ (⊤ ⊎ B)) →
              let (f₁ , qinv g₁ α₁ β₁) = e in
              Ev f₁ (inj₁ tt) → Ev g₁ (inj₁ tt) → A ≃ B
    mk₁ {A} {B} (f , qinv g α β) (ev (inj₁ tt) eq₁) (ev (inj₁ tt) eq₂) = A≃B
      where
        equiv : (⊤ ⊎ A) ≃ (⊤ ⊎ B)
        equiv = (f , qinv g α β)

        elim-path : {X Y Z : Set} → (e : (⊤ ⊎ X) ≃ (⊤ ⊎ Y)) → (x : X) →
           (proj₁ e) (inj₁ tt) ≡ (proj₁ e) (inj₂ x) → Z
        elim-path e a path = ⊥-elim (bad-path tt a (injectivity e a path))

        mkf : (a : A) → Ev f (inj₂ a) → B
        mkf a (ev (inj₁ tt) eq) = elim-path equiv a (eq₁ ∘ ! eq)
        mkf a (ev (inj₂ y) fx≡v) = y

        ff : A → B
        ff a = mkf a (mkV f (inj₂ a))

        mkg : (b : B) → Ev g (inj₂ b) → A
        mkg b (ev (inj₁ tt) eq) = elim-path (sym≃ equiv) b (eq₂ ∘ ! eq)
        mkg b (ev (inj₂ a) eq) = a

        gg : B → A
        gg b = mkg b (mkV g (inj₂ b))

        mkα : (b : B) →  (e : Ev g (inj₂ b)) → ff (mkg b e) ≡ b
        mkα b (ev (inj₁ tt) eq) = elim-path (sym≃ equiv) b (eq₂ ∘ ! eq)
        mkα b (ev (inj₂ a) eq) = mkα' (mkV f (inj₂ a))
          where
            mkα' : (ev : Ev f (inj₂ a)) → mkf a ev ≡ b
            mkα' (ev (inj₁ tt) eq₃) = elim-path equiv a (eq₁ ∘ ! eq₃)
            mkα' (ev (inj₂ _) eq₃) = inj₂≡ (! (cong f eq ∘ eq₃) ∘ α (inj₂ b))

        αα : ff ○ gg ∼ id
        αα b = mkα b (mkV g (inj₂ b))

        -- need to expand the definition of ff and gg "by hand" otherwise there is
        -- nowhere to 'stick in' the explicit e₁ and e₂ we have.

        mkβ : (a : A) → (e₁ : Ev f (inj₂ a)) → (e₂ : Ev g (inj₂ (mkf a e₁))) →
              mkg (mkf a e₁) e₂ ≡ a
        mkβ a (ev (inj₁ tt) eq) _ = elim-path equiv a (eq₁ ∘ ! eq)
        mkβ a (ev (inj₂ y) eq) (ev (inj₁ tt) eq₃) =
          elim-path (sym≃ equiv) y (eq₂ ∘ ! eq₃)
        mkβ a (ev (inj₂ _) eq) (ev (inj₂ _) eq₃) =
          inj₂≡ (((! eq₃) ∘ cong g (! eq)) ∘ β (inj₂ a))

        ββ : gg ○ ff ∼ id
        ββ a = let ev₁ = mkV f (inj₂ a) in mkβ a ev₁ (mkV g (inj₂ (mkf a ev₁)))

        A≃B : A ≃ B
        A≃B = ff , qinv gg αα ββ

    mk₁ (f , qinv g α β) (ev (inj₁ tt) eq₁) (ev (inj₂ a) eq₂) =
      let e = (f , qinv g α β) in
      ⊥-elim
        (bad-path tt a
          (injectivity e a ((eq₁ ∘ ! (α (inj₁ tt))) ∘ cong f eq₂)))
    mk₁ (f , qinv g α β) (ev (inj₂ b) eq₁) (ev (inj₁ tt) eq₂) =
     ⊥-elim (bad-path tt b (((! α (inj₁ tt)) ∘ cong f eq₂) ∘ eq₁))
    mk₁ {A} {B} (f , qinv g α β) (ev (inj₂ x) ftt=x) (ev (inj₂ y) gtt=y) =
      A≃B
      where
        equiv : (⊤ ⊎ A) ≃ (⊤ ⊎ B)
        equiv = (f , qinv g α β)

        elim-path : {X Y Z : Set} → (e : (⊤ ⊎ X) ≃ (⊤ ⊎ Y)) → (x : X) →
           (proj₁ e) (inj₁ tt) ≡ (proj₁ e) (inj₂ x) → Z
        elim-path e a path = ⊥-elim (bad-path tt a (injectivity e a path))

        mkf : (a : A) → Ev f (inj₂ a) → B
        mkf a (ev (inj₁ tt) _) = x
        mkf a (ev (inj₂ y) _) = y

        ff : A → B
        ff a = mkf a (mkV f (inj₂ a))

        mkg : (b : B) → Ev g (inj₂ b) → A
        mkg b (ev (inj₁ tt) eq) = y
        mkg b (ev (inj₂ a) eq) = a

        gg : B → A
        gg b = mkg b (mkV g (inj₂ b))

        mkα : (b : B) →  (e₁ : Ev g (inj₂ b)) → (e₂ : Ev f (inj₂ (mkg b e₁))) →
              mkf (mkg b e₁) e₂ ≡ b
        mkα b (ev (inj₁ tt) gb=tt) (ev (inj₁ tt) fgb=tt) =
          inj₂≡ ((! ftt=x ∘ ! cong f gb=tt) ∘ α (inj₂ b))
        mkα b (ev (inj₁ tt) gb=tt) (ev (inj₂ y₁) fy=y₁) =
          elim-path
            (sym≃ equiv)
            y₁
            ( ! ((! cong g fy=y₁ ∘ β (inj₂ y)) ∘ (! gtt=y)))
        mkα b (ev (inj₂ z) gb=z) (ev (inj₁ tt) fgb=tt) =
          elim-path
            (sym≃ equiv) b ((cong g (! fgb=tt) ∘ β (inj₂ z)) ∘ (! gb=z))
        mkα b (ev (inj₂ z) gb=z) (ev (inj₂ z₂) fgb=z₂) =
            let path = (cong g (! fgb=z₂) ∘ β (inj₂ z)) ∘ ! gb=z in
            inj₂≡ (inj≃ (sym≃ equiv) (inj₂ z₂) (inj₂ b)  path)

        αα : ff ○ gg ∼ id
        αα b = let ev₁ = mkV g (inj₂ b) in mkα b ev₁ (mkV f (inj₂ (mkg b ev₁)))

        -- need to expand the definition of ff and gg "by hand"
        -- otherwise there is nowhere to 'stick in' the explicit e₁
        -- and e₂ we have.

        mkβ : (a : A) → (e₁ : Ev f (inj₂ a)) →
          (e₂ : Ev g (inj₂ (mkf a e₁))) → mkg (mkf a e₁) e₂ ≡ a
        mkβ a (ev (inj₁ tt) eq) (ev (inj₁ _) eq₃) =
          inj₂≡ (! (cong g eq ∘ gtt=y) ∘ β (inj₂ a))
        mkβ a (ev (inj₁ tt) eq) (ev (inj₂ y₁) eq₃) =
          elim-path equiv y₁ ((ftt=x ∘ (! α (inj₂ x))) ∘ cong f eq₃)
        mkβ a (ev (inj₂ z) fa=z) (ev (inj₁ tt) eq₃) =
          elim-path equiv a ((cong f (! eq₃) ∘ α (inj₂ z)) ∘ (! fa=z) )
        mkβ a (ev (inj₂ _) fa=y) (ev (inj₂ _) eq₃) =
          inj₂≡ (((! eq₃) ∘ cong g (! fa=y)) ∘ β (inj₂ a))

        ββ : gg ○ ff ∼ id
        ββ a = let ev₁ = mkV f (inj₂ a) in mkβ a ev₁ (mkV g (inj₂ (mkf a ev₁)))

        A≃B : A ≃ B
        A≃B = ff , qinv gg αα ββ

------------------------------------------------------------------------------

open import Data.Nat using (ℕ; _+_)
open import Data.Fin using (Fin)
open import FinEquivPlusTimes using (module Plus; Fin1≃⊤)
open Plus using (⊎≃+; +≃⊎)
open import Equiv using (_⊎≃_; id≃)

left-cancel-1 : {m n : ℕ} →  (Fin (1 + m) ≃ Fin (1 + n)) → Fin m ≃ Fin n
left-cancel-1 pf = left-cancel-⊤ ((Fin1≃⊤ ⊎≃ id≃) ● +≃⊎ ● (pf ● ⊎≃+) ● (sym≃ Fin1≃⊤ ⊎≃ id≃))


{-

Eilenberg–Mac Lane type K(G, 1)

-}

{-# OPTIONS --cubical --no-import-sorts --safe  --experimental-lossy-unification #-}
module Cubical.HITs.EilenbergMacLane1.Properties where

open import Cubical.HITs.EilenbergMacLane1.Base

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Univalence

open import Cubical.Data.Sigma
open import Cubical.Data.Empty renaming (rec to ⊥-rec) hiding (elim)

open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.Properties

open import Cubical.Algebra.AbGroup.Base

open import Cubical.Functions.Morphism

private
  variable
    ℓG ℓ : Level

module _ ((G , str) : Group ℓG) where

  open GroupStr str

  elimGroupoid :
   {B : EM₁ (G , str) → Type ℓ}
          → ((x : EM₁ (G , str)) → isGroupoid (B x))
          → (b : B embase)
          → (bloop : ((g : G) → PathP (λ i → B (emloop g i)) b b))
          → ((g h : G) → PathP (λ i → PathP (λ j → B (emcomp g h j i))
                                 (bloop g i) (bloop (g · h) i)) (λ _ → b) (bloop h))
          → (x : EM₁ (G , str))
          → B x
  elimGroupoid Bgroup b bloop bcomp embase = b
  elimGroupoid Bgroup b bloop bcomp (emloop x i) = bloop x i
  elimGroupoid Bgroup b bloop bcomp (emcomp g h j i) = bcomp g h i j
  elimGroupoid {B = B} Bgroup b bloop bcomp (emsquash g h p q r s i j k) = help i j k
    where
    help : PathP (λ i → PathP (λ j → PathP (λ k → B (emsquash g h p q r s i j k))
                 (elimGroupoid Bgroup b bloop bcomp g)
                 (elimGroupoid Bgroup b bloop bcomp h))
                 (λ k → elimGroupoid Bgroup b bloop bcomp (p k))
                 λ k → elimGroupoid Bgroup b bloop bcomp (q k))
                 (λ j k → elimGroupoid Bgroup b bloop bcomp (r j k))
                 λ j k → elimGroupoid Bgroup b bloop bcomp (s j k)
    help = toPathP (isOfHLevelPathP' 1 (isOfHLevelPathP' 2 (Bgroup _) _ _) _ _ _ _)

  elimSet : {B : EM₁ (G , str) → Type ℓ}
          → ((x : EM₁ (G , str)) → isSet (B x))
          → (b : B embase)
          → ((g : G) → PathP (λ i → B (emloop g i)) b b)
          → (x : EM₁ (G , str))
          → B x
  elimSet Bset b bloop embase = b
  elimSet Bset b bloop (emloop g i) = bloop g i
  elimSet Bset b bloop (emcomp g h i j) =
    isSet→SquareP
      (λ i j → Bset (emcomp g h i j))
      (λ j → bloop g j) (λ j → bloop (g · h) j)
      (λ i → b) (λ i → bloop h i)
      i j
  elimSet Bset b bloop (emsquash x y p q r s i j k) =
    isOfHLevel→isOfHLevelDep 3 (λ x → isSet→isGroupoid (Bset x))
      _ _ _ _ (λ j k → g (r j k)) (λ j k → g (s j k)) (emsquash x y p q r s) i j k
    where
      g = elimSet Bset b bloop

  elimProp : {B : EM₁ (G , str) → Type ℓ}
             → ((x : EM₁ (G , str)) → isProp (B x))
             → B embase
             → (x : EM₁ (G , str))
             → B x
  elimProp Bprop b x =
    elimSet
      (λ x → isProp→isSet (Bprop x))
      b
      (λ g → isProp→PathP (λ i → Bprop ((emloop g) i)) b b)
      x

  elimProp2 : {C : EM₁ (G , str) → EM₁ (G , str) → Type ℓ}
    → ((x y : EM₁ (G , str)) → isProp (C x y))
    → C embase embase
    → (x y : EM₁ (G , str))
    → C x y
  elimProp2 Cprop c =
    elimProp
      (λ x → isPropΠ (λ y → Cprop x y))
      (elimProp (λ y → Cprop embase y) c)

  elim : {B : EM₁ (G , str) → Type ℓ}
       → ((x : EM₁ (G , str)) → isGroupoid (B x))
       → (b : B embase)
       → (bloop : (g : G) → PathP (λ i → B (emloop g i)) b b)
       → ((g h : G) → SquareP (λ i j → B (emcomp g h i j))
            (bloop g) (bloop (g · h)) (λ j → b) (bloop h))
       → (x : EM₁ (G , str))
       → B x
  elim Bgpd b bloop bcomp embase = b
  elim Bgpd b bloop bcomp (emloop g i) = bloop g i
  elim Bgpd b bloop bcomp (emcomp g h i j) = bcomp g h i j
  elim Bgpd b bloop bcomp (emsquash x y p q r s i j k) =
    isOfHLevel→isOfHLevelDep 3 Bgpd
      _ _ _ _ (λ j k → g (r j k)) (λ j k → g (s j k)) (emsquash x y p q r s) i j k
    where
      g = elim Bgpd b bloop bcomp

  rec : {B : Type ℓ}
      → isGroupoid B
      → (b : B)
      → (bloop : G → b ≡ b)
      → ((g h : G) → Square (bloop g) (bloop (g · h)) refl (bloop h))
      → (x : EM₁ (G , str))
      → B
  rec Bgpd = elim (λ _ → Bgpd)


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

module Data.Empty.Base where

open import Cubical.Data.Empty
  using (⊥; isProp⊥)
  public
open import Level

infix 4.5 ¬_
¬_ : Type a → Type a
¬ A = A → ⊥

⊥-elim : ⊥ → A
⊥-elim ()


-- Andreas, 2015-05-06

module Issue1484 where

data ⊥ : Set where

-- Smörgåsbord of legal absurd lambdas

-- non-hidden

abs esabs eabs eabs2 eabs3 : ⊥ → Set
abs = λ()

esabs = λ{ ()}
eabs  = λ{()}
eabs2 = λ{(())}
eabs3 = λ{((()))}

-- hidden

habs eshabs eshpabs eshpabs2 : {_ : ⊥} → Set
habs     = λ{}

eshabs   = λ{ {}}
eshpabs  = λ{ {()}}
eshpabs2 = λ{ {(())}}

-- instance

iabs esiabs esipabs esipabs2 : {{_ : ⊥}} → Set
iabs     = λ{{}}

esiabs   = λ{ {{}}}
esipabs  = λ{ {{()}}}
esipabs2 = λ{ {{(())}}}


module Oscar (FunctionName PredicateName VariableName QuantifierName Name : Set) where

open import Oscar.Data.Fin using (Fin; zero; suc; thick?)

open import Data.Nat using (ℕ; suc; zero)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong₂; cong; sym; trans)
open import Function using (_∘_; flip)
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Data.Product using (∃; _,_; _×_)
open import Data.Empty using (⊥-elim)
open import Data.Vec using (Vec; []; _∷_)

data Term (n : ℕ) : Set where
  i : (x : Fin n) -> Term n
  leaf : Term n
  _fork_ : (s t : Term n) -> Term n
  function : FunctionName → ∀ {f} → Vec (Term n) f → Term n

data Formula (n : ℕ) : Set
 where
  atomic : PredicateName → ∀ {t} → Vec (Term n) t → Formula n
  logical : Formula n →
            Formula n →
            Formula n
  quantified : VariableName → Formula (suc n) → Formula n

Term-function-inj-FunctionName : ∀ {fn₁ fn₂} {n N₁ N₂} {ts₁ : Vec (Term n) N₁} {ts₂ : Vec (Term n) N₂} → Term.function fn₁ ts₁ ≡ Term.function fn₂ ts₂ → fn₁ ≡ fn₂
Term-function-inj-FunctionName refl = refl

Term-function-inj-VecSize : ∀ {fn₁ fn₂} {n N₁ N₂} {ts₁ : Vec (Term n) N₁} {ts₂ : Vec (Term n) N₂} → Term.function fn₁ ts₁ ≡ Term.function fn₂ ts₂ → N₁ ≡ N₂
Term-function-inj-VecSize refl = refl

Term-function-inj-Vector : ∀ {fn₁ fn₂} {n N} {ts₁ : Vec (Term n) N} {ts₂ : Vec (Term n) N} → Term.function fn₁ ts₁ ≡ Term.function fn₂ ts₂ → ts₁ ≡ ts₂
Term-function-inj-Vector refl = refl

Term-fork-inj-left : ∀ {n} {l₁ r₁ l₂ r₂ : Term n} → l₁ Term.fork r₁ ≡ l₂ fork r₂ → l₁ ≡ l₂
Term-fork-inj-left refl = refl

Term-fork-inj-right : ∀ {n} {l₁ r₁ l₂ r₂ : Term n} → l₁ Term.fork r₁ ≡ l₂ fork r₂ → r₁ ≡ r₂
Term-fork-inj-right refl = refl

open import Relation.Binary.HeterogeneousEquality using (_≅_; refl)

Term-function-inj-HetVector : ∀ {fn₁ fn₂} {n N₁ N₂} {ts₁ : Vec (Term n) N₁} {ts₂ : Vec (Term n) N₂} → Term.function fn₁ ts₁ ≡ Term.function fn₂ ts₂ → ts₁ ≅ ts₂
Term-function-inj-HetVector refl = refl

_~>_ : (m n : ℕ) -> Set
m ~> n = Fin m -> Term n

▹ : ∀ {m n} -> (r : Fin m -> Fin n) -> Fin m -> Term n
▹ r = i ∘ r

record Substitution (T : ℕ → Set) : Set where
  field
    _◃_ : ∀ {m n} -> (f : m ~> n) -> T m -> T n

open Substitution ⦃ … ⦄ public

{-# DISPLAY Substitution._◃_ _ = _◃_ #-}

mutual

  instance SubstitutionTerm : Substitution Term
  Substitution._◃_ SubstitutionTerm = _◃′_ where
    _◃′_ : ∀ {m n} -> (f : m ~> n) -> Term m -> Term n
    f ◃′ i x = f x
    f ◃′ leaf = leaf
    f ◃′ (s fork t) = (f ◃ s) fork (f ◃ t)
    f ◃′ (function fn ts) = function fn (f ◃ ts)

  instance SubstitutionVecTerm : ∀ {N} → Substitution (flip Vec N ∘ Term )
  Substitution._◃_ (SubstitutionVecTerm {N}) = _◃′_ where
    _◃′_ : ∀ {m n} -> (f : m ~> n) -> Vec (Term m) N -> Vec (Term n) N
    f ◃′ [] = []
    f ◃′ (t ∷ ts) = f ◃ t ∷ f ◃ ts

_≐_ : {m n : ℕ} -> (Fin m -> Term n) -> (Fin m -> Term n) -> Set
f ≐ g = ∀ x -> f x ≡ g x

record SubstitutionExtensionality (T : ℕ → Set) ⦃ _ : Substitution T ⦄ : Set₁ where
  field
    ◃ext : ∀ {m n} {f g : Fin m -> Term n} -> f ≐ g -> (t : T m) -> f ◃ t ≡ g ◃ t

open SubstitutionExtensionality ⦃ … ⦄ public

mutual

  instance SubstitutionExtensionalityTerm : SubstitutionExtensionality Term
  SubstitutionExtensionality.◃ext SubstitutionExtensionalityTerm = ◃ext′ where
    ◃ext′ : ∀ {m n} {f g : Fin m -> Term n} -> f ≐ g -> ∀ t -> f ◃ t ≡ g ◃ t
    ◃ext′ p (Term.i x) = p x
    ◃ext′ p leaf = refl
    ◃ext′ p (s fork t) = cong₂ _fork_ (◃ext p s) (◃ext p t)
    ◃ext′ p (function fn ts) = cong (function fn) (◃ext p ts)

  instance SubstitutionExtensionalityVecTerm : ∀ {N} → SubstitutionExtensionality (flip Vec N ∘ Term)
  SubstitutionExtensionality.◃ext (SubstitutionExtensionalityVecTerm {N}) = λ x → ◃ext′ x where
    ◃ext′ : ∀ {m n} {f g : Fin m -> Term n} -> f ≐ g -> ∀ {N} (t : Vec (Term m) N) -> f ◃ t ≡ g ◃ t
    ◃ext′ p [] = refl
    ◃ext′ p (t ∷ ts) = cong₂ _∷_ (◃ext p t) (◃ext p ts)

_◇_ : ∀ {l m n : ℕ } -> (f : Fin m -> Term n) (g : Fin l -> Term m) -> Fin l -> Term n
f ◇ g = (f ◃_) ∘ g

≐-cong : ∀ {m n o} {f : m ~> n} {g} (h : _ ~> o) -> f ≐ g -> (h ◇ f) ≐ (h ◇ g)
≐-cong h f≐g t = cong (h ◃_) (f≐g t)

≐-sym : ∀ {m n} {f : m ~> n} {g} -> f ≐ g -> g ≐ f
≐-sym f≐g = sym ∘ f≐g

module Sub where
  record Fact1 (T : ℕ → Set) ⦃ _ : Substitution T ⦄ : Set where
    field
      fact1 : ∀ {n} -> (t : T n) -> i ◃ t ≡ t

  open Fact1 ⦃ … ⦄ public

  mutual

    instance Fact1Term : Fact1 Term
    Fact1.fact1 Fact1Term (i x) = refl
    Fact1.fact1 Fact1Term leaf = refl
    Fact1.fact1 Fact1Term (s fork t) = cong₂ _fork_ (fact1 s) (fact1 t)
    Fact1.fact1 Fact1Term (function fn ts) = cong (function fn) (fact1 ts)

    instance Fact1TermVec : ∀ {N} → Fact1 (flip Vec N ∘ Term)
    Fact1.fact1 Fact1TermVec [] = refl
    Fact1.fact1 Fact1TermVec (t ∷ ts) = cong₂ _∷_ (fact1 t) (fact1 ts)

  record Fact2 (T : ℕ → Set) ⦃ _ : Substitution T ⦄ : Set where
    field
      -- ⦃ s ⦄ : Substitution T
      fact2 : ∀ {l m n} -> {f : Fin m -> Term n} {g : _} (t : T l) → (f ◇ g) ◃ t ≡ f ◃ (g ◃ t)

  open Fact2 ⦃ … ⦄ public

  mutual

    instance Fact2Term : Fact2 Term
    -- Fact2.s Fact2Term = SubstitutionTerm
    Fact2.fact2 Fact2Term (i x) = refl
    Fact2.fact2 Fact2Term leaf = refl
    Fact2.fact2 Fact2Term (s fork t) = cong₂ _fork_ (fact2 s) (fact2 t)
    Fact2.fact2 Fact2Term {f = f} {g = g} (function fn ts) = cong (function fn) (fact2 {f = f} {g = g} ts) -- fact2 ts

    instance Fact2TermVec : ∀ {N} → Fact2 (flip Vec N ∘ Term)
    -- Fact2.s Fact2TermVec = SubstitutionVecTerm
    Fact2.fact2 Fact2TermVec [] = refl
    Fact2.fact2 Fact2TermVec (t ∷ ts) = cong₂ _∷_ (fact2 t) (fact2 ts)

  fact3 : ∀ {l m n} (f : Fin m -> Term n) (r : Fin l -> Fin m) -> (f ◇ (▹ r)) ≡ (f ∘ r)
  fact3 f r = refl

◃ext' : ∀ {m n o} {f : Fin m -> Term n}{g : Fin m -> Term o}{h} -> f ≐ (h ◇ g) -> ∀ (t : Term _) -> f ◃ t ≡ h ◃ (g ◃ t)
◃ext' p t = trans (◃ext p t) (Sub.fact2 t)

open import Data.Maybe using (Maybe; nothing; just; functor; maybe′)
open import Category.Monad
import Level
open RawMonad (Data.Maybe.monad {Level.zero})

record Check (T : ℕ → Set) : Set where
  field
    check : ∀{n} (x : Fin (suc n)) (t : T (suc n)) -> Maybe (T n)

open Check ⦃ … ⦄ public

_<*>_ = _⊛_

mutual

  instance CheckTerm : Check Term
  Check.check CheckTerm x (i y) = i <$> thick? x y
  Check.check CheckTerm x leaf = just leaf
  Check.check CheckTerm x (s fork t) = _fork_ <$> check x s ⊛ check x t
  Check.check CheckTerm x (function fn ts) = ⦇ (function fn) (check x ts) ⦈

  instance CheckTermVec : ∀ {N} → Check (flip Vec N ∘ Term)
  Check.check CheckTermVec x [] = just []
  Check.check CheckTermVec x (t ∷ ts) = ⦇ check x t ∷ check x ts ⦈

_for_ : ∀ {n} (t' : Term n) (x : Fin (suc n)) -> Fin (suc n) -> Term n
(t' for x) y = maybe′ i t' (thick? x y)

data AList : ℕ -> ℕ -> Set where
  anil : ∀ {n} -> AList n n
  _asnoc_/_ : ∀ {m n} (σ : AList m n) (t' : Term m) (x : Fin (suc m))
               -> AList (suc m) n

sub : ∀ {m n} (σ : AList m n) -> Fin m -> Term n
sub anil = i
sub (σ asnoc t' / x) = sub σ ◇ (t' for x)

_++_ : ∀ {l m n} (ρ : AList m n) (σ : AList l m) -> AList l n
ρ ++ anil = ρ
ρ ++ (σ asnoc t' / x) = (ρ ++ σ) asnoc t' / x

++-assoc : ∀ {l m n o} (ρ : AList l m) (σ : AList n _) (τ : AList o _) -> ρ ++ (σ ++ τ) ≡ (ρ ++ σ) ++ τ
++-assoc ρ σ anil = refl
++-assoc ρ σ (τ asnoc t / x) = cong (λ s -> s asnoc t / x) (++-assoc ρ σ τ)

module SubList where
  anil-id-l : ∀ {m n} (σ : AList m n) -> anil ++ σ ≡ σ
  anil-id-l anil = refl
  anil-id-l (σ asnoc t' / x) = cong (λ σ -> σ asnoc t' / x) (anil-id-l σ)

  fact1 : ∀ {l m n} (ρ : AList m n) (σ : AList l m) -> sub (ρ ++ σ) ≐ (sub ρ ◇ sub σ)
  fact1 ρ anil v = refl
  fact1 {suc l} {m} {n} r (s asnoc t' / x) v = trans hyp-on-terms ◃-assoc
    where
      t = (t' for x) v
      hyp-on-terms = ◃ext (fact1 r s) t
      ◃-assoc = Sub.fact2 t

_∃asnoc_/_ : ∀ {m} (a : ∃ (AList m)) (t' : Term m) (x : Fin (suc m))
  -> ∃ (AList (suc m))
(n , σ) ∃asnoc t' / x = n , σ asnoc t' / x

flexFlex : ∀ {m} (x y : Fin m) -> ∃ (AList m)
flexFlex {suc m} x y with thick? x y
...              | just y' = m , anil asnoc i y' / x
...              | nothing = suc m , anil
flexFlex {zero} () _

flexRigid : ∀ {m} (x : Fin m) (t : Term m) -> Maybe (∃(AList m))
flexRigid {suc m} x t with check x t
...                   | just t' = just (m , anil asnoc t' / x)
...                   | nothing = nothing
flexRigid {zero} () _


module Logic{ℓ} where

-- open import Logic
-- open import Logic.Classical

-- Everything is computably decidable
-- instance postulate classical : ∀{ℓ}{P : Stmt{ℓ}} → Classical(P)

Stmt : _
Stmt = Set(ℓ) -- Prop(ℓ)

open import Agda.Primitive public
  renaming (Setω to Stmtω)


{-# OPTIONS --cubical --safe #-}
module Cubical.Data.List.Base where

open import Agda.Builtin.List        public
open import Cubical.Core.Everything

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

  infixr 5 _++_

  [_] : A → List A
  [ a ] = a ∷ []

  _++_ : List A → List A → List A
  [] ++ ys = ys
  (x ∷ xs) ++ ys = x ∷ xs ++ ys

  rev : List A → List A
  rev [] = []
  rev (x ∷ xs) = rev xs ++ [ x ]


{-# OPTIONS --safe --warning=error --without-K #-}

open import Lists.Definition

module Lists.Fold.Fold {a b : _} {A : Set a} {B : Set b} where

fold : (f : A → B → B) → B → List A → B
fold f default [] = default
fold f default (x :: l) = f x (fold f default l)


{-# OPTIONS --without-K --rewriting #-}

open import lib.Basics
open import lib.NConnected
open import lib.NType2
open import lib.types.Paths
open import lib.types.Pi
open import lib.types.Truncation
open import lib.types.Unit
open import lib.types.Bool
open import lib.types.Suspension
open import lib.types.IteratedSuspension

module lib.types.Circle where

{-
Idea :

data S¹ : Type₀ where
  base : S¹
  loop : base == base

I’m using Dan Licata’s trick to have a higher inductive type with definitional
reduction rule for [base]
-}

{-
  favonia (2016/05): Now [Circle] is defined as [Sphere 1].
-}

module _ where
  -- (already defined in IteratedSuspension.agda)
  -- S¹ : Type₀
  -- S¹ = Sphere 1

  base : S¹
  base = north

  loop : base == base
  loop = σloop ⊙Bool false

  module S¹Elim {i} {P : S¹ → Type i} (base* : P base)
    (loop* : base* == base* [ P ↓ loop ]) where

    private
      north* = base*
      south* = transport P (merid false) base*
      merid*-general :
        ∀ {x : S¹} (p q : base == x)
          (loop* :  base* == base* [ P ↓ p ∙ ! q ]) (b : Bool)
        → base* == transport P p base* [ P ↓ Bool-rec q p b ]
      merid*-general idp q loop* false = idp
      merid*-general idp q loop* true = !ᵈ' loop*

      merid* : ∀ (b : Bool) → north* == south* [ P ↓ merid b ]
      merid* false = merid*-general (merid false) (merid true) loop* false
      merid* true = merid*-general (merid false) (merid true) loop* true

      module SE = SuspElim north* south* merid*

    f : Π S¹ P
    f = SE.f

    private
      merid*-general-lemma :
        ∀ {x : S¹} (p q : base == x) (loop* :  base* == base* [ P ↓ p ∙ ! q ])
        → merid*-general p q loop* false ◃ !ᵈ (merid*-general p q loop* true) == loop*
      merid*-general-lemma idp q loop* = idp◃ _ ∙ !ᵈ-!ᵈ' loop*

    loop-β : apd f loop == loop*
    loop-β =
      apd f loop
        =⟨ apd-∙ f (merid false) (! (merid true)) ⟩
      apd f (merid false) ◃ apd f (! (merid true))
        =⟨ apd-! f (merid true) |in-ctx apd f (merid false) ◃_ ⟩
      apd f (merid false) ◃ !ᵈ (apd f (merid true))
        =⟨ SE.merid-β false |in-ctx _◃ !ᵈ (apd f (merid true)) ⟩
      merid* false ◃ !ᵈ (apd f (merid true))
        =⟨ SE.merid-β true |in-ctx (λ p → merid* false ◃ !ᵈ p) ⟩
      merid* false ◃ !ᵈ (merid* true)
        =⟨ merid*-general-lemma (merid false) (merid true) loop* ⟩
      loop*
        =∎

open S¹Elim public using () renaming (f to S¹-elim)

module S¹Rec {i} {A : Type i} (base* : A) (loop* : base* == base*) where

  private
    module M = S¹Elim base* (↓-cst-in loop*)

  f : S¹ → A
  f = M.f

  loop-β : ap f loop == loop*
  loop-β = apd=cst-in {f = f} M.loop-β

open S¹Rec public using () renaming (f to S¹-rec)

S¹-rec-η : ∀ {i} {A : Type i} (f : S¹ → A)
  → ∀ x → S¹-rec (f base) (ap f loop) x == f x
S¹-rec-η f = S¹-elim idp (↓-='-in' $ ! $ S¹Rec.loop-β (f base) (ap f loop))

module S¹RecType {i} (A : Type i) (e : A ≃ A) where

  open S¹Rec A (ua e) public

  coe-loop-β : (a : A) → coe (ap f loop) a == –> e a
  coe-loop-β a =
    coe (ap f loop) a   =⟨ loop-β |in-ctx (λ u → coe u a) ⟩
    coe (ua e) a        =⟨ coe-β e a ⟩
    –> e a =∎

  coe!-loop-β : (a : A) → coe! (ap f loop) a == <– e a
  coe!-loop-β a =
    coe! (ap f loop) a   =⟨ loop-β |in-ctx (λ u → coe! u a) ⟩
    coe! (ua e) a        =⟨ coe!-β e a ⟩
    <– e a =∎

  ↓-loop-out : {a a' : A} → a == a' [ f ↓ loop ] → –> e a == a'
  ↓-loop-out {a} {a'} p =
    –> e a              =⟨ ! (coe-loop-β a) ⟩
    coe (ap f loop) a   =⟨ to-transp p ⟩
    a' =∎

  import lib.types.Generic1HIT as Generic1HIT
  module S¹G = Generic1HIT Unit Unit (idf _) (idf _)
  module P = S¹G.RecType (cst A) (cst e)

  private
    generic-S¹ : Σ S¹ f == Σ S¹G.T P.f
    generic-S¹ = eqv-tot where

      module To = S¹Rec (S¹G.cc tt) (S¹G.pp tt)
      to = To.f

      module From = S¹G.Rec (cst base) (cst loop)
      from : S¹G.T → S¹
      from = From.f

      abstract
        to-from : (x : S¹G.T) → to (from x) == x
        to-from = S¹G.elim (λ _ → idp) (λ _ → ↓-∘=idf-in' to from
          (ap to (ap from (S¹G.pp tt)) =⟨ From.pp-β tt |in-ctx ap to ⟩
           ap to loop                  =⟨ To.loop-β ⟩
           S¹G.pp tt =∎))

        from-to : (x : S¹) → from (to x) == x
        from-to = S¹-elim idp (↓-∘=idf-in' from to
          (ap from (ap to loop)   =⟨ To.loop-β |in-ctx ap from ⟩
           ap from (S¹G.pp tt)    =⟨ From.pp-β tt ⟩
           loop =∎))

      eqv : S¹ ≃ S¹G.T
      eqv = equiv to from to-from from-to

      eqv-fib : f == P.f [ (λ X → (X → Type _)) ↓ ua eqv ]
      eqv-fib =
        ↓-app→cst-in (λ {t} p → S¹-elim {P = λ t → f t == P.f (–> eqv t)} idp
          (↓-='-in'
            (ap (P.f ∘ (–> eqv)) loop   =⟨ ap-∘ P.f to loop ⟩
             ap P.f (ap to loop)        =⟨ To.loop-β |in-ctx ap P.f ⟩
             ap P.f (S¹G.pp tt)         =⟨ P.pp-β tt ⟩
             ua e                       =⟨ ! loop-β ⟩
             ap f loop =∎))
        t ∙ ap P.f (↓-idf-ua-out eqv p))

      eqv-tot : Σ S¹ f == Σ S¹G.T P.f
      eqv-tot = ap (uncurry Σ) (pair= (ua eqv) eqv-fib)

  import lib.types.Flattening as Flattening
  module FlatteningS¹ = Flattening
    Unit Unit (idf _) (idf _) (cst A) (cst e)
  open FlatteningS¹ public hiding (flattening-equiv; module P)

  flattening-S¹ : Σ S¹ f == Wt
  flattening-S¹ = generic-S¹ ∙ ua FlatteningS¹.flattening-equiv

instance
  S¹-conn : is-connected 0 S¹
  S¹-conn = Sphere-conn 1


{-# OPTIONS --safe #-}
module Cubical.Algebra.Monoid.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Transport
open import Cubical.Foundations.SIP

open import Cubical.Data.Sigma

open import Cubical.Algebra.Semigroup

open import Cubical.Displayed.Base
open import Cubical.Displayed.Auto
open import Cubical.Displayed.Record
open import Cubical.Displayed.Universe

open import Cubical.Reflection.RecordEquiv

open Iso

private
  variable
    ℓ : Level

record IsMonoid {A : Type ℓ} (ε : A) (_·_ : A → A → A) : Type ℓ where
  constructor ismonoid

  field
    isSemigroup : IsSemigroup _·_
    identity    : (x : A) → (x · ε ≡ x) × (ε · x ≡ x)

  open IsSemigroup isSemigroup public

  lid : (x : A) → ε · x ≡ x
  lid x = identity x .snd

  rid : (x : A) → x · ε ≡ x
  rid x = identity x .fst

unquoteDecl IsMonoidIsoΣ = declareRecordIsoΣ IsMonoidIsoΣ (quote IsMonoid)

record MonoidStr (A : Type ℓ) : Type ℓ where
  constructor monoidstr

  field
    ε        : A
    _·_      : A → A → A
    isMonoid : IsMonoid ε _·_

  infixl 7 _·_

  open IsMonoid isMonoid public

Monoid : ∀ ℓ → Type (ℓ-suc ℓ)
Monoid ℓ = TypeWithStr ℓ MonoidStr

monoid : (A : Type ℓ) (ε : A) (_·_ : A → A → A) (h : IsMonoid ε _·_) → Monoid ℓ
monoid A ε _·_ h = A , monoidstr ε _·_ h

-- Easier to use constructors

makeIsMonoid : {M : Type ℓ} {ε : M} {_·_ : M → M → M}
               (is-setM : isSet M)
               (assoc : (x y z : M) → x · (y · z) ≡ (x · y) · z)
               (rid : (x : M) → x · ε ≡ x)
               (lid : (x : M) → ε · x ≡ x)
             → IsMonoid ε _·_
IsMonoid.isSemigroup (makeIsMonoid is-setM assoc rid lid) = issemigroup is-setM assoc
IsMonoid.identity (makeIsMonoid is-setM assoc rid lid) = λ x → rid x , lid x

makeMonoid : {M : Type ℓ} (ε : M) (_·_ : M → M → M)
             (is-setM : isSet M)
             (assoc : (x y z : M) → x · (y · z) ≡ (x · y) · z)
             (rid : (x : M) → x · ε ≡ x)
             (lid : (x : M) → ε · x ≡ x)
           → Monoid ℓ
makeMonoid ε _·_ is-setM assoc rid lid =
  monoid _ ε _·_ (makeIsMonoid is-setM assoc rid lid)

record IsMonoidEquiv {A : Type ℓ} {B : Type ℓ}
  (M : MonoidStr A) (e : A ≃ B) (N : MonoidStr B)
  : Type ℓ
  where

  constructor monoidequiv

  -- Shorter qualified names
  private
    module M = MonoidStr M
    module N = MonoidStr N

  field
    presε : equivFun e M.ε ≡ N.ε
    isHom : (x y : A) → equivFun e (x M.· y) ≡ equivFun e x N.· equivFun e y

MonoidEquiv : (M N : Monoid ℓ) → Type ℓ
MonoidEquiv M N = Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] IsMonoidEquiv (M .snd) e (N .snd)

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

isPropIsMonoid : {M : Type ℓ} (ε : M) (_·_ : M → M → M) → isProp (IsMonoid ε _·_)
isPropIsMonoid ε _·_ =
  isOfHLevelRetractFromIso 1 IsMonoidIsoΣ
    (isPropΣ
      (isPropIsSemigroup _·_)
      (λ semi → isPropΠ λ _ → isProp× (semi .is-set _ _) (semi .is-set _ _)))
  where
  open IsSemigroup

𝒮ᴰ-Monoid : DUARel (𝒮-Univ ℓ) MonoidStr ℓ
𝒮ᴰ-Monoid =
  𝒮ᴰ-Record (𝒮-Univ _) IsMonoidEquiv
    (fields:
      data[ ε ∣ autoDUARel _ _ ∣ presε ]
      data[ _·_ ∣ autoDUARel _ _ ∣ isHom ]
      prop[ isMonoid ∣ (λ _ _ → isPropIsMonoid _ _) ])
  where
  open MonoidStr
  open IsMonoidEquiv

MonoidPath : (M N : Monoid ℓ) → MonoidEquiv M N ≃ (M ≡ N)
MonoidPath = ∫ 𝒮ᴰ-Monoid .UARel.ua

module MonoidTheory {ℓ} (M : Monoid ℓ) where

  open MonoidStr (snd M)

  -- Added for its use in groups
  -- If there exists a inverse of an element it is unique
  inv-lemma : (x y z : ⟨ M ⟩) → y · x ≡ ε → x · z ≡ ε → y ≡ z
  inv-lemma x y z left-inverse right-inverse =
    y           ≡⟨ sym (rid y) ⟩
    y · ε       ≡⟨ cong (λ - → y · -) (sym right-inverse) ⟩
    y · (x · z) ≡⟨ assoc y x z ⟩
    (y · x) · z ≡⟨ cong (λ - → - · z) left-inverse ⟩
    ε · z       ≡⟨ lid z ⟩
    z ∎


{- Copyright © 2015 Benjamin Barenblat

Licensed under the Apache License, Version 2.0 (the ‘License’); you may not use
this file except in compliance with the License.  You may obtain a copy of the
License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software distributed
under the License is distributed on an ‘AS IS’ BASIS, WITHOUT WARRANTIES OR
CONDITIONS OF ANY KIND, either express or implied.  See the License for the
specific language governing permissions and limitations under the License. -}

module B.Prelude.Bool where

open import B.Prelude.BooleanAlgebra using (BooleanAlgebra)
import Data.Bool
import Data.Bool.Properties

open Data.Bool
  using (Bool; if_then_else_; T)
  public

instance
  BooleanAlgebra-Bool : BooleanAlgebra _ _
  BooleanAlgebra-Bool = Data.Bool.Properties.booleanAlgebra

module Bool where
  open Data.Bool
    using (_xor_)
    public