------------------------------------------------------------------------
-- The Agda standard library
--
-- Lexicographic products of binary relations
------------------------------------------------------------------------

-- The definition of lexicographic product used here is suitable if
-- the left-hand relation is a strict partial order.

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

module Data.Product.Relation.Binary.Lex.Strict where

open import Data.Product
open import Data.Product.Relation.Binary.Pointwise.NonDependent as Pointwise
  using (Pointwise)
open import Data.Sum using (inj₁; inj₂; _-⊎-_; [_,_])
open import Data.Empty
open import Function
open import Level
open import Relation.Nullary
open import Relation.Nullary.Product
open import Relation.Nullary.Sum
open import Relation.Binary
open import Relation.Binary.Consequences

module _ {a₁ a₂ ℓ₁ ℓ₂} {A₁ : Set a₁} {A₂ : Set a₂} where

------------------------------------------------------------------------
-- A lexicographic ordering over products

  ×-Lex : (_≈₁_ _<₁_ : Rel A₁ ℓ₁) → (_≤₂_ : Rel A₂ ℓ₂) → Rel (A₁ × A₂) _
  ×-Lex _≈₁_ _<₁_ _≤₂_ =
    (_<₁_ on proj₁) -⊎- (_≈₁_ on proj₁) -×- (_≤₂_ on proj₂)

------------------------------------------------------------------------
-- Some properties which are preserved by ×-Lex (under certain
-- assumptions).

  ×-reflexive : ∀ _≈₁_ _∼₁_ {_≈₂_ : Rel A₂ ℓ₂} _≤₂_ →
                _≈₂_ ⇒ _≤₂_ → (Pointwise _≈₁_ _≈₂_) ⇒ (×-Lex _≈₁_ _∼₁_ _≤₂_)
  ×-reflexive _ _ _ refl₂ = λ x≈y →
    inj₂ (proj₁ x≈y , refl₂ (proj₂ x≈y))

  ×-irreflexive : ∀ {_≈₁_ _<₁_}             → Irreflexive _≈₁_ _<₁_ →
                  ∀ {_≈₂_ _<₂_ : Rel A₂ ℓ₂} → Irreflexive _≈₂_ _<₂_ →
                  Irreflexive (Pointwise _≈₁_ _≈₂_) (×-Lex _≈₁_ _<₁_ _<₂_)
  ×-irreflexive ir₁ ir₂ x≈y (inj₁ x₁<y₁) = ir₁ (proj₁ x≈y) x₁<y₁
  ×-irreflexive ir₁ ir₂ x≈y (inj₂ x≈<y)  =
    ir₂ (proj₂ x≈y) (proj₂ x≈<y)

  ×-transitive : ∀ {_≈₁_ _<₁_} →
    IsEquivalence _≈₁_ → _<₁_ Respects₂ _≈₁_ → Transitive _<₁_ →
    ∀ {_≤₂_} → Transitive _≤₂_ → Transitive (×-Lex _≈₁_ _<₁_ _≤₂_)
  ×-transitive {_≈₁_} {_<₁_} eq₁ resp₁ trans₁ {_≤₂_} trans₂ = trans
    where
    module Eq₁ = IsEquivalence eq₁

    trans : Transitive (×-Lex _≈₁_ _<₁_ _≤₂_)
    trans (inj₁ x₁<y₁) (inj₁ y₁<z₁) = inj₁ (trans₁ x₁<y₁ y₁<z₁)
    trans (inj₁ x₁<y₁) (inj₂ y≈≤z)  =
      inj₁ (proj₁ resp₁ (proj₁ y≈≤z) x₁<y₁)
    trans (inj₂ x≈≤y)  (inj₁ y₁<z₁) =
      inj₁ (proj₂ resp₁ (Eq₁.sym $ proj₁ x≈≤y) y₁<z₁)
    trans (inj₂ x≈≤y)  (inj₂ y≈≤z)  =
      inj₂ ( Eq₁.trans (proj₁ x≈≤y) (proj₁ y≈≤z)
           , trans₂    (proj₂ x≈≤y) (proj₂ y≈≤z) )

  ×-antisymmetric : ∀ {_≈₁_ _<₁_} →
    Symmetric _≈₁_ → Irreflexive _≈₁_ _<₁_ → Asymmetric _<₁_ →
    ∀ {_≈₂_ _≤₂_ : Rel A₂ ℓ₂} → Antisymmetric _≈₂_ _≤₂_ →
    Antisymmetric (Pointwise _≈₁_ _≈₂_) (×-Lex _≈₁_ _<₁_ _≤₂_)
  ×-antisymmetric {_≈₁_} {_<₁_} sym₁ irrefl₁ asym₁
                  {_≈₂_} {_≤₂_} antisym₂ = antisym
    where
    antisym : Antisymmetric (Pointwise _≈₁_ _≈₂_) (×-Lex _≈₁_ _<₁_ _≤₂_)
    antisym (inj₁ x₁<y₁) (inj₁ y₁<x₁) =
      ⊥-elim $ asym₁ x₁<y₁ y₁<x₁
    antisym (inj₁ x₁<y₁) (inj₂ y≈≤x)  =
      ⊥-elim $ irrefl₁ (sym₁ $ proj₁ y≈≤x) x₁<y₁
    antisym (inj₂ x≈≤y)  (inj₁ y₁<x₁) =
      ⊥-elim $ irrefl₁ (sym₁ $ proj₁ x≈≤y) y₁<x₁
    antisym (inj₂ x≈≤y)  (inj₂ y≈≤x)  =
      proj₁ x≈≤y , antisym₂ (proj₂ x≈≤y) (proj₂ y≈≤x)

  ×-asymmetric : ∀ {_≈₁_ _<₁_} →
    Symmetric _≈₁_ → _<₁_ Respects₂ _≈₁_ → Asymmetric _<₁_ →
    ∀ {_<₂_} → Asymmetric _<₂_ →
    Asymmetric (×-Lex _≈₁_ _<₁_ _<₂_)
  ×-asymmetric {_≈₁_} {_<₁_} sym₁ resp₁ asym₁ {_<₂_} asym₂ = asym
    where
    irrefl₁ : Irreflexive _≈₁_ _<₁_
    irrefl₁ = asym⟶irr resp₁ sym₁ asym₁

    asym : Asymmetric (×-Lex _≈₁_ _<₁_ _<₂_)
    asym (inj₁ x₁<y₁) (inj₁ y₁<x₁) = asym₁ x₁<y₁ y₁<x₁
    asym (inj₁ x₁<y₁) (inj₂ y≈<x)  = irrefl₁ (sym₁ $ proj₁ y≈<x) x₁<y₁
    asym (inj₂ x≈<y)  (inj₁ y₁<x₁) = irrefl₁ (sym₁ $ proj₁ x≈<y) y₁<x₁
    asym (inj₂ x≈<y)  (inj₂ y≈<x)  = asym₂ (proj₂ x≈<y) (proj₂ y≈<x)

  ×-respects₂ :
    ∀ {_≈₁_ _<₁_} → IsEquivalence _≈₁_ → _<₁_ Respects₂ _≈₁_ →
    {_≈₂_ _<₂_ : Rel A₂ ℓ₂} → _<₂_ Respects₂ _≈₂_ →
    (×-Lex _≈₁_ _<₁_ _<₂_) Respects₂ (Pointwise _≈₁_ _≈₂_)
  ×-respects₂ {_≈₁_} {_<₁_} eq₁ resp₁
              {_≈₂_} {_<₂_}     resp₂ = resp¹ , resp²
    where
    _<_ = ×-Lex _≈₁_ _<₁_ _<₂_

    open IsEquivalence eq₁ renaming (sym to sym₁; trans to trans₁)

    resp¹ : ∀ {x} → (x <_) Respects (Pointwise _≈₁_ _≈₂_)
    resp¹ y≈y' (inj₁ x₁<y₁) = inj₁ (proj₁ resp₁ (proj₁ y≈y') x₁<y₁)
    resp¹ y≈y' (inj₂ x≈<y)  =
      inj₂ ( trans₁ (proj₁ x≈<y) (proj₁ y≈y')
           , proj₁ resp₂ (proj₂ y≈y') (proj₂ x≈<y) )

    resp² : ∀ {y} → (flip _<_ y) Respects (Pointwise _≈₁_ _≈₂_)
    resp² x≈x' (inj₁ x₁<y₁) = inj₁ (proj₂ resp₁ (proj₁ x≈x') x₁<y₁)
    resp² x≈x' (inj₂ x≈<y)  =
      inj₂ ( trans₁ (sym₁ $ proj₁ x≈x') (proj₁ x≈<y)
           , proj₂ resp₂ (proj₂ x≈x') (proj₂ x≈<y) )

  ×-decidable : ∀ {_≈₁_ _<₁_} → Decidable _≈₁_ → Decidable _<₁_ →
                ∀ {_≤₂_} → Decidable _≤₂_ →
                Decidable (×-Lex _≈₁_ _<₁_ _≤₂_)
  ×-decidable dec-≈₁ dec-<₁ dec-≤₂ x y =
    dec-<₁ (proj₁ x) (proj₁ y)
      ⊎-dec
    (dec-≈₁ (proj₁ x) (proj₁ y)
       ×-dec
     dec-≤₂ (proj₂ x) (proj₂ y))

  ×-total₁ : ∀ {_≈₁_ _<₁_} → Total _<₁_ →
             ∀ {_≤₂_} → Total (×-Lex _≈₁_ _<₁_ _≤₂_)
  ×-total₁ total₁ x y with total₁ (proj₁ x) (proj₁ y)
  ... | inj₁ x₁<y₁ = inj₁ (inj₁ x₁<y₁)
  ... | inj₂ x₁>y₁ = inj₂ (inj₁ x₁>y₁)

  ×-total₂ : ∀ {_≈₁_ _<₁_} → Symmetric _≈₁_ → Trichotomous _≈₁_ _<₁_ →
             ∀ {_≤₂_} → Total _≤₂_ →
             Total (×-Lex _≈₁_ _<₁_ _≤₂_)
  ×-total₂ sym tri₁ total₂ x y with tri₁ (proj₁ x) (proj₁ y)
  ... | tri< x₁<y₁ _ _ = inj₁ (inj₁ x₁<y₁)
  ... | tri> _ _ y₁<x₁ = inj₂ (inj₁ y₁<x₁)
  ... | tri≈ _ x₁≈y₁ _ with total₂ (proj₂ x) (proj₂ y)
  ...   | inj₁ x₂≤y₂ = inj₁ (inj₂ (x₁≈y₁     , x₂≤y₂))
  ...   | inj₂ y₂≤x₂ = inj₂ (inj₂ (sym x₁≈y₁ , y₂≤x₂))

  ×-compare :
    {_≈₁_ _<₁_ : Rel A₁ ℓ₁} → Symmetric _≈₁_ → Trichotomous _≈₁_ _<₁_ →
    {_≈₂_ _<₂_ : Rel A₂ ℓ₂} → Trichotomous _≈₂_ _<₂_ →
    Trichotomous (Pointwise _≈₁_ _≈₂_) (×-Lex _≈₁_ _<₁_ _<₂_)
  ×-compare sym₁ cmp₁ cmp₂ (x₁ , x₂) (y₁ , y₂) with cmp₁ x₁ y₁
  ... | (tri< x₁<y₁ x₁≉y₁ x₁≯y₁) =
    tri< (inj₁ x₁<y₁)
         (x₁≉y₁ ∘ proj₁)
         [ x₁≯y₁ , x₁≉y₁ ∘ sym₁ ∘ proj₁ ]
  ... | (tri> x₁≮y₁ x₁≉y₁ x₁>y₁) =
    tri> [ x₁≮y₁ , x₁≉y₁ ∘ proj₁ ]
         (x₁≉y₁ ∘ proj₁)
         (inj₁ x₁>y₁)
  ... | (tri≈ x₁≮y₁ x₁≈y₁ x₁≯y₁) with cmp₂ x₂ y₂
  ...   | (tri< x₂<y₂ x₂≉y₂ x₂≯y₂) =
    tri< (inj₂ (x₁≈y₁ , x₂<y₂))
         (x₂≉y₂ ∘ proj₂)
         [ x₁≯y₁ , x₂≯y₂ ∘ proj₂ ]
  ...   | (tri> x₂≮y₂ x₂≉y₂ x₂>y₂) =
    tri> [ x₁≮y₁ , x₂≮y₂ ∘ proj₂ ]
         (x₂≉y₂ ∘ proj₂)
         (inj₂ (sym₁ x₁≈y₁ , x₂>y₂))
  ...   | (tri≈ x₂≮y₂ x₂≈y₂ x₂≯y₂) =
    tri≈ [ x₁≮y₁ , x₂≮y₂ ∘ proj₂ ]
         (x₁≈y₁ , x₂≈y₂)
         [ x₁≯y₁ , x₂≯y₂ ∘ proj₂ ]

------------------------------------------------------------------------
-- Collections of properties which are preserved by ×-Lex.

  ×-isPreorder : ∀ {_≈₁_ _∼₁_} → IsPreorder _≈₁_ _∼₁_ →
                   ∀ {_≈₂_ _∼₂_} → IsPreorder _≈₂_ _∼₂_ →
                   IsPreorder (Pointwise _≈₁_ _≈₂_) (×-Lex _≈₁_ _∼₁_ _∼₂_)
  ×-isPreorder {_≈₁_} {_∼₁_} pre₁ {_∼₂_ = _∼₂_} pre₂ =
    record
      { isEquivalence = Pointwise.×-isEquivalence
                          (isEquivalence pre₁) (isEquivalence pre₂)
      ; reflexive     = ×-reflexive _≈₁_ _∼₁_ _∼₂_ (reflexive pre₂)
      ; trans         = ×-transitive
                          (isEquivalence pre₁) (∼-resp-≈ pre₁)
                          (trans pre₁) {_≤₂_ = _∼₂_} (trans pre₂)
      }
    where open IsPreorder

  ×-isStrictPartialOrder :
    ∀ {_≈₁_ _<₁_} → IsStrictPartialOrder _≈₁_ _<₁_ →
    ∀ {_≈₂_ _<₂_} → IsStrictPartialOrder _≈₂_ _<₂_ →
    IsStrictPartialOrder (Pointwise _≈₁_ _≈₂_) (×-Lex _≈₁_ _<₁_ _<₂_)
  ×-isStrictPartialOrder {_<₁_ = _<₁_} spo₁ {_<₂_ = _<₂_} spo₂ =
    record
      { isEquivalence = Pointwise.×-isEquivalence
                          (isEquivalence spo₁) (isEquivalence spo₂)
      ; irrefl        = ×-irreflexive {_<₁_ = _<₁_} (irrefl spo₁)
                                      {_<₂_ = _<₂_} (irrefl spo₂)
      ; trans         = ×-transitive
                          {_<₁_ = _<₁_} (isEquivalence spo₁)
                                        (<-resp-≈ spo₁) (trans spo₁)
                          {_≤₂_ = _<₂_} (trans spo₂)
      ; <-resp-≈      = ×-respects₂ (isEquivalence spo₁)
                                      (<-resp-≈ spo₁)
                                      (<-resp-≈ spo₂)
      }
    where open IsStrictPartialOrder

  ×-isStrictTotalOrder :
    ∀ {_≈₁_ _<₁_} → IsStrictTotalOrder _≈₁_ _<₁_ →
    ∀ {_≈₂_ _<₂_} → IsStrictTotalOrder _≈₂_ _<₂_ →
    IsStrictTotalOrder (Pointwise _≈₁_ _≈₂_) (×-Lex _≈₁_ _<₁_ _<₂_)
  ×-isStrictTotalOrder {_<₁_ = _<₁_} spo₁ {_<₂_ = _<₂_} spo₂ =
    record
      { isEquivalence = Pointwise.×-isEquivalence
                          (isEquivalence spo₁) (isEquivalence spo₂)
      ; trans         = ×-transitive
                          {_<₁_ = _<₁_} (isEquivalence spo₁)
                                        (<-resp-≈ spo₁) (trans spo₁)
                          {_≤₂_ = _<₂_} (trans spo₂)
      ; compare       = ×-compare (Eq.sym spo₁) (compare spo₁)
                                                (compare spo₂)
      }
    where open IsStrictTotalOrder

------------------------------------------------------------------------
-- "Packages" can also be combined.

module _ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} where

  ×-preorder : Preorder ℓ₁ ℓ₂ _ → Preorder ℓ₃ ℓ₄ _ → Preorder _ _ _
  ×-preorder p₁ p₂ = record
    { isPreorder = ×-isPreorder (isPreorder p₁) (isPreorder p₂)
    } where open Preorder

  ×-strictPartialOrder :
    StrictPartialOrder ℓ₁ ℓ₂ _ → StrictPartialOrder ℓ₃ ℓ₄ _ →
    StrictPartialOrder _ _ _
  ×-strictPartialOrder s₁ s₂ = record
    { isStrictPartialOrder = ×-isStrictPartialOrder
        (isStrictPartialOrder s₁) (isStrictPartialOrder s₂)
    } where open StrictPartialOrder

  ×-strictTotalOrder :
    StrictTotalOrder ℓ₁ ℓ₂ _ → StrictTotalOrder ℓ₃ ℓ₄ _ →
    StrictTotalOrder _ _ _
  ×-strictTotalOrder s₁ s₂ = record
    { isStrictTotalOrder = ×-isStrictTotalOrder
        (isStrictTotalOrder s₁) (isStrictTotalOrder s₂)
    } where open StrictTotalOrder

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 0.15

_×-irreflexive_ = ×-irreflexive
{-# WARNING_ON_USAGE _×-irreflexive_
"Warning: _×-irreflexive_ was deprecated in v0.15.
Please use ×-irreflexive instead."
#-}
_×-isPreorder_           = ×-isPreorder
{-# WARNING_ON_USAGE _×-isPreorder_
"Warning: _×-isPreorder_ was deprecated in v0.15.
Please use ×-isPreorder instead."
#-}
_×-isStrictPartialOrder_ = ×-isStrictPartialOrder
{-# WARNING_ON_USAGE _×-isStrictPartialOrder_
"Warning: _×-isStrictPartialOrder_ was deprecated in v0.15.
Please use ×-isStrictPartialOrder instead."
#-}
_×-isStrictTotalOrder_   = ×-isStrictTotalOrder
{-# WARNING_ON_USAGE _×-isStrictTotalOrder_
"Warning: _×-isStrictTotalOrder_ was deprecated in v0.15.
Please use ×-isStrictTotalOrder instead."
#-}
_×-preorder_             = ×-preorder
{-# WARNING_ON_USAGE _×-preorder_
"Warning: _×-preorder_ was deprecated in v0.15.
Please use ×-preorder instead."
#-}
_×-strictPartialOrder_   = ×-strictPartialOrder
{-# WARNING_ON_USAGE _×-strictPartialOrder_
"Warning: _×-strictPartialOrder_ was deprecated in v0.15.
Please use ×-strictPartialOrder instead."
#-}
_×-strictTotalOrder_     = ×-strictTotalOrder
{-# WARNING_ON_USAGE _×-strictTotalOrder_
"Warning: _×-strictTotalOrder_ was deprecated in v0.15.
Please use ×-strictTotalOrder instead."
#-}
×-≈-respects₂            = ×-respects₂
{-# WARNING_ON_USAGE ×-≈-respects₂
"Warning: ×-≈-respects₂ was deprecated in v0.15.
Please use ×-respects₂ instead."
#-}


module Agda.Builtin.FromString where

open import Agda.Primitive
open import Agda.Builtin.String

record IsString {a} (A : Set a) : Set (lsuc a) where
  field
    Constraint : String → Set a
    fromString : (s : String) {{_ : Constraint s}} → A

open IsString {{...}} public using (fromString)

{-# BUILTIN FROMSTRING fromString #-}
{-# DISPLAY IsString.fromString _ s = fromString s #-}


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

module Data.Pi where

open import Data.Pi.Base public


module Element where

open import OscarPrelude

record Element : Set
 where
  constructor ⟨_⟩
  field
    element : Nat

open Element public

instance EqElement : Eq Element
Eq._==_ EqElement ⟨ ε₁ ⟩ ⟨ ε₂ ⟩ with ε₁ ≟ ε₂
Eq._==_ EqElement ⟨ _ ⟩  ⟨ _ ⟩ | yes refl = yes refl
Eq._==_ EqElement ⟨ _ ⟩  ⟨ _ ⟩ | no ε₁≢ε₂ = no λ {refl → ε₁≢ε₂ refl}


module FlatDomInequality where

postulate
  A : Set

g : A → A
g x = x

-- this is fine
h : (@♭ x : A) → A
h = g

-- this should fail, although the error message should be improved.
q : A → A
q = h


module Ual.Both where

infix 10 _∧_
record _∧_ (A B : Set) : Set where
  field
    andL : A
    andR : B


{-

Set quotients:

-}

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

open import Cubical.HITs.SetQuotients.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.Data.Sigma

open import Cubical.Relation.Nullary
open import Cubical.Relation.Binary.Base

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

-- Type quotients

private
  variable
    ℓ : Level
    A : Type ℓ
    R : A → A → Type ℓ
    B : A / R → Type ℓ
    C : A / R → A / R → Type ℓ
    D : A / R → A / R → A / R → Type ℓ

elimEq/ : (Bprop : (x : A / R ) → isProp (B x))
          {x y : A / R}
          (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 : ((x : A / R ) → isProp (B x))
         → ((a : A) → B ( [ a ]))
         → (x : A / R)
         → B x
elimProp Bprop f [ x ] = f x
elimProp Bprop f (squash/ x y p q i j) =
  isOfHLevel→isOfHLevelDep 2 (λ x → isProp→isSet (Bprop x))
    (g x) (g y) (cong g p) (cong g q) (squash/ x y p q) i j
    where
    g = elimProp Bprop f
elimProp Bprop f (eq/ a b r i) = elimEq/ Bprop (eq/ a b r) (f a) (f b) i

elimProp2 : ((x y : A / R ) → isProp (C x y))
          → ((a b : A) → C [ a ] [ b ])
          → (x y : A / R)
          → C x y
elimProp2 Cprop f = elimProp (λ x → isPropΠ (λ y → Cprop x y))
                             (λ x → elimProp (λ y → Cprop [ x ] y) (f x))

elimProp3 : ((x y z : A / R ) → isProp (D x y z))
          → ((a b c : A) → D [ a ] [ b ] [ c ])
          → (x y z : A / R)
          → D x y z
elimProp3 Dprop f = elimProp (λ x → isPropΠ2 (λ y z → Dprop x y z))
                             (λ x → elimProp2 (λ y z → Dprop [ x ] y z) (f x))

-- lemma 6.10.2 in hott book
[]surjective : (x : A / R) → ∃[ a ∈ A ] [ a ] ≡ x
[]surjective = elimProp (λ x → squash) (λ a → ∣ a , refl ∣)

elim : {B : A / R → Type ℓ}
     → ((x : A / R) → isSet (B x))
     → (f : (a : A) → (B [ a ]))
     → ((a b : A) (r : R a b) → PathP (λ i → B (eq/ a b r i)) (f a) (f b))
     → (x : A / R)
     → B x
elim Bset f feq [ a ] = f a
elim Bset f feq (eq/ a b r i) = feq a b r i
elim Bset f feq (squash/ x y p q i j) =
  isOfHLevel→isOfHLevelDep 2 Bset
              (g x) (g y) (cong g p) (cong g q) (squash/ x y p q) i j
    where
      g = elim Bset f feq

rec : {B : Type ℓ}
      (Bset : isSet B)
      (f : A → B)
      (feq : (a b : A) (r : R a b) → f a ≡ f b)
    → A / R → B
rec Bset f feq [ a ] = f a
rec Bset f feq (eq/ a b r i) = feq a b r i
rec Bset f feq (squash/ x y p q i j) = Bset (g x) (g y) (cong g p) (cong g q) i j
  where
  g = rec Bset f feq

rec2 : {B : Type ℓ} (Bset : isSet B)
       (f : A → A → B) (feql : (a b c : A) (r : R a b) → f a c ≡ f b c)
                       (feqr : (a b c : A) (r : R b c) → f a b ≡ f a c)
    → A / R → A / R → B
rec2 Bset f feql feqr = rec (isSetΠ (λ _ → Bset))
                            (λ a → rec Bset (f a) (feqr a))
                            (λ a b r → funExt (elimProp (λ _ → Bset _ _)
                                              (λ c → feql a b c r)))

setQuotUniversal : {B : Type ℓ} (Bset : isSet B) →
                   (A / R → B) ≃ (Σ[ f ∈ (A → B) ] ((a b : A) → R a b → f a ≡ f b))
setQuotUniversal Bset = isoToEquiv (iso intro out outRightInv outLeftInv)
  where
  intro = λ g →  (λ a → g [ a ]) , λ a b r i → g (eq/ a b r i)
  out = λ h → elim (λ x → Bset) (fst h) (snd h)

  outRightInv : ∀ h → intro (out h) ≡ h
  outRightInv h = refl

  outLeftInv : ∀ g → out (intro g) ≡ g
  outLeftInv = λ g → funExt (λ x → PropTrunc.elim {P = λ sur → out (intro g) x ≡ g x}
    (λ sur → Bset (out (intro g) x) (g x))
    (λ sur → cong (out (intro g)) (sym (snd sur)) ∙ (cong g (snd sur))) ([]surjective x)
    )

open BinaryRelation

effective : (Rprop : isPropValued R) (Requiv : isEquivRel R) (a b : A) → [ a ] ≡ [ b ] → R a b
effective {A = A} {R = R} Rprop (equivRel R/refl R/sym R/trans) a b p = transport aa≡ab (R/refl _)
  where
    helper : A / R → hProp _
    helper =
      rec isSetHProp (λ c → (R a c , Rprop a c))
                     (λ c d cd → Σ≡Prop (λ _ → isPropIsProp)
                                        (hPropExt (Rprop a c) (Rprop a d)
                                                  (λ ac → R/trans _ _ _ ac cd) (λ ad → R/trans _ _ _ ad (R/sym _ _ cd))))

    aa≡ab : R a a ≡ R a b
    aa≡ab i = helper (p i) .fst

isEquivRel→isEffective : isPropValued R → isEquivRel R → isEffective R
isEquivRel→isEffective {R = R} Rprop Req a b = isoToIsEquiv (iso out intro out-intro intro-out)
  where
    intro : [ a ] ≡ [ b ] → R a b
    intro = effective Rprop Req a b

    out : R a b → [ a ] ≡ [ b ]
    out = eq/ a b

    intro-out : ∀ x → intro (out x) ≡ x
    intro-out ab = Rprop a b _ _

    out-intro : ∀ x → out (intro x) ≡ x
    out-intro eq = squash/ _ _ _ _

discreteSetQuotients : Discrete A → isPropValued R → isEquivRel R → (∀ a₀ a₁ → Dec (R a₀ a₁)) → Discrete (A / R)
discreteSetQuotients {A = A} {R = R} Adis Rprop Req Rdec =
  elim (λ a₀ → isSetΠ (λ a₁ → isProp→isSet (isPropDec (squash/ a₀ a₁))))
    discreteSetQuotients' discreteSetQuotients'-eq
  where
    discreteSetQuotients' : (a : A) (y : A / R) → Dec ([ a ] ≡ y)
    discreteSetQuotients' a₀ = elim (λ a₁ → isProp→isSet (isPropDec (squash/ [ a₀ ] a₁))) dis dis-eq
      where
        dis : (a₁ : A) → Dec ([ a₀ ] ≡ [ a₁ ])
        dis a₁ with Rdec a₀ a₁
        ... | (yes p) = yes (eq/ a₀ a₁ p)
        ... | (no ¬p) = no λ eq → ¬p (effective Rprop Req a₀ a₁ eq )

        dis-eq : (a b : A) (r : R a b) →
          PathP (λ i → Dec ([ a₀ ] ≡ eq/ a b r i)) (dis a) (dis b)
        dis-eq a b ab = J (λ b ab → ∀ k → PathP (λ i → Dec ([ a₀ ] ≡ ab i)) (dis a) k)
                          (λ k → isPropDec (squash/ _ _) _  _) (eq/ a b ab) (dis b)

    discreteSetQuotients'-eq : (a b : A) (r : R a b) →
      PathP (λ i → (y : A / R) → Dec (eq/ a b r i ≡ y))
            (discreteSetQuotients' a) (discreteSetQuotients' b)
    discreteSetQuotients'-eq a b ab =
      J (λ b ab → ∀ k → PathP (λ i → (y : A / R) → Dec (ab i ≡ y))
                              (discreteSetQuotients' a) k)
        (λ k → funExt (λ x → isPropDec (squash/ _ _) _ _)) (eq/ a b ab) (discreteSetQuotients' b)


{-# OPTIONS --safe #-}
module Cubical.Foundations.Pointed.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed.Base
open import Cubical.Foundations.Function
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv

open import Cubical.Data.Sigma

private
  variable
    ℓ ℓ' ℓA ℓB ℓC ℓD : Level

-- the default pointed Π-type: A is pointed, and B has a base point in the chosen fiber
Π∙ : (A : Pointed ℓ) (B : typ A → Type ℓ') (ptB : B (pt A)) → Type (ℓ-max ℓ ℓ')
Π∙ A B ptB = Σ[ f ∈ ((a : typ A) → B a) ] f (pt A) ≡ ptB

-- the unpointed Π-type becomes a pointed type if the fibers are all pointed
Πᵘ∙ : (A : Type ℓ) (B : A → Pointed ℓ') → Pointed (ℓ-max ℓ ℓ')
Πᵘ∙ A B .fst = ∀ a → typ (B a)
Πᵘ∙ A B .snd a = pt (B a)

-- if the base and all fibers are pointed, we have the pointed pointed Π-type
Πᵖ∙ : (A : Pointed ℓ) (B : typ A → Pointed ℓ') → Pointed (ℓ-max ℓ ℓ')
Πᵖ∙ A B .fst = Π∙ A (typ ∘ B) (pt (B (pt A)))
Πᵖ∙ A B  .snd .fst a = pt (B a)
Πᵖ∙ A B  .snd .snd = refl

-- the default pointed Σ-type is just the Σ-type, but as a pointed type
Σ∙ : (A : Pointed ℓ) (B : typ A → Type ℓ') (ptB : B (pt A)) → Pointed (ℓ-max ℓ ℓ')
Σ∙ A B ptB .fst = Σ[ a ∈ typ A ] B a
Σ∙ A B ptB .snd .fst = pt A
Σ∙ A B ptB .snd .snd = ptB

-- version if B is a family of pointed types
Σᵖ∙ : (A : Pointed ℓ) (B : typ A → Pointed ℓ') → Pointed (ℓ-max ℓ ℓ')
Σᵖ∙ A B = Σ∙ A (typ ∘ B) (pt (B (pt A)))

_×∙_ : (A∙ : Pointed ℓ) (B∙ : Pointed ℓ') → Pointed (ℓ-max ℓ ℓ')
(A∙ ×∙ B∙) .fst = (typ A∙) × (typ B∙)
(A∙ ×∙ B∙) .snd .fst = pt A∙
(A∙ ×∙ B∙) .snd .snd = pt B∙

-- composition of pointed maps
_∘∙_ : {A : Pointed ℓA} {B : Pointed ℓB} {C : Pointed ℓC}
       (g : B →∙ C) (f : A →∙ B) → (A →∙ C)
((g , g∙) ∘∙ (f , f∙)) .fst x = g (f  x)
((g , g∙) ∘∙ (f , f∙)) .snd = (cong g f∙) ∙ g∙

-- post composition
post∘∙ : ∀ {ℓX ℓ ℓ'} (X : Pointed ℓX) {A : Pointed ℓ} {B : Pointed ℓ'}
  → (A →∙ B) → ((X →∙ A ∙) →∙ (X →∙ B ∙))
post∘∙ X f .fst g = f ∘∙ g
post∘∙ X f .snd =
  ΣPathP
    ( (funExt λ _ → f .snd)
    , (sym (lUnit (f .snd)) ◁ λ i j → f .snd (i ∨ j)))

-- pointed identity
id∙ : (A : Pointed ℓA) → (A →∙ A)
id∙ A .fst x = x
id∙ A .snd = refl

-- constant pointed map
const∙ : (A : Pointed ℓA) (B : Pointed ℓB) → (A →∙ B)
const∙ _ B .fst _ = B .snd
const∙ _ B .snd = refl

-- left identity law for pointed maps
∘∙-idˡ : {A : Pointed ℓA} {B : Pointed ℓB} (f : A →∙ B) → f ∘∙ id∙ A ≡ f
∘∙-idˡ f = ΣPathP ( refl , (lUnit (f .snd)) ⁻¹ )

-- right identity law for pointed maps
∘∙-idʳ : {A : Pointed ℓA} {B : Pointed ℓB} (f : A →∙ B) → id∙ B ∘∙ f ≡ f
∘∙-idʳ f = ΣPathP ( refl , (rUnit (f .snd)) ⁻¹ )

-- associativity for composition of pointed maps
∘∙-assoc : {A : Pointed ℓA} {B : Pointed ℓB} {C : Pointed ℓC} {D : Pointed ℓD}
           (h : C →∙ D) (g : B →∙ C) (f : A →∙ B)
           → (h ∘∙ g) ∘∙ f ≡ h ∘∙ (g ∘∙ f)
∘∙-assoc (h , h∙) (g , g∙) (f , f∙) = ΣPathP (refl , q)
  where
    q : (cong (h ∘ g) f∙) ∙ (cong h g∙ ∙ h∙) ≡ cong h (cong g f∙ ∙ g∙) ∙ h∙
    q = ( (cong (h ∘ g) f∙) ∙ (cong h g∙ ∙ h∙)
        ≡⟨ refl ⟩
        (cong h (cong g f∙)) ∙ (cong h g∙ ∙ h∙)
        ≡⟨ assoc (cong h (cong g f∙)) (cong h g∙) h∙ ⟩
        (cong h (cong g f∙) ∙ cong h g∙) ∙ h∙
        ≡⟨ cong (λ p → p ∙ h∙) ((cong-∙ h (cong g f∙) g∙) ⁻¹) ⟩
        (cong h (cong g f∙ ∙ g∙) ∙ h∙) ∎ )

module _ {ℓ ℓ' : Level} {A : Pointed ℓ} {B : Pointed ℓ'} (f : A →∙ B) where
  isInIm∙ : (x : typ B) → Type (ℓ-max ℓ ℓ')
  isInIm∙ x = Σ[ z ∈ typ A ] fst f z ≡ x

  isInKer∙ : (x : fst A) → Type ℓ'
  isInKer∙ x = fst f x ≡ snd B

pre∘∙equiv : ∀ {ℓ ℓ'} {A : Pointed ℓ} {B C : Pointed ℓ'}
 → (B ≃∙ C) → Iso (A →∙ B) (A →∙ C)
pre∘∙equiv {A = A} {B = B} {C = C} eq = main
  where
  module _ {ℓ ℓ' : Level} (A : Pointed ℓ) (B C : Pointed ℓ')
           (eq : (B ≃∙ C)) where
    to : (A →∙ B) → (A →∙ C)
    to = ≃∙map eq ∘∙_

    from : (A →∙ C) → (A →∙ B)
    from = ≃∙map (invEquiv∙ eq) ∘∙_

  lem : {ℓ  : Level} {B : Pointed ℓ}
    → ≃∙map (invEquiv∙ {A = B} ((idEquiv (fst B)) , refl)) ≡ id∙ B
  lem = ΣPathP (refl , (sym (lUnit _)))

  J-lem : {ℓ ℓ' : Level} {A : Pointed ℓ} {B C : Pointed ℓ'}
             → (eq : (B ≃∙ C))
             → retract (to A B C eq) (from _ _ _ eq)
              × section (to A B C eq) (from _ _ _ eq)
  J-lem {A = A} {B = B} {C = C} =
    Equiv∙J (λ B eq → retract (to A B C eq) (from _ _ _ eq)
              × section (to A B C eq) (from _ _ _ eq))
            ((λ f → ((λ i → (lem i ∘∙ (id∙ C ∘∙ f)))
                  ∙ λ i → ∘∙-idʳ (∘∙-idʳ f i) i))
            , λ f → ((λ i → (id∙ C ∘∙ (lem i ∘∙ f)))
                  ∙ λ i → ∘∙-idʳ (∘∙-idʳ f i) i))

  main : Iso (A →∙ B) (A →∙ C)
  Iso.fun main = to A B C eq
  Iso.inv main = from A B C eq
  Iso.rightInv main = J-lem eq .snd
  Iso.leftInv main = J-lem eq .fst

post∘∙equiv : ∀ {ℓ ℓC} {A B : Pointed ℓ} {C : Pointed ℓC}
  → (A ≃∙ B) → Iso (A →∙ C) (B →∙ C)
post∘∙equiv {A = A} {B = B} {C = C} eq = main
  where
  module _ {ℓ ℓC : Level} (A B : Pointed ℓ) (C : Pointed ℓC)
           (eq : (A ≃∙ B)) where
    to : (A →∙ C) → (B →∙ C)
    to = _∘∙ ≃∙map (invEquiv∙ eq)

    from : (B →∙ C) → (A →∙ C)
    from = _∘∙ ≃∙map eq

  lem : {ℓ  : Level} {B : Pointed ℓ}
    → ≃∙map (invEquiv∙ {A = B} ((idEquiv (fst B)) , refl)) ≡ id∙ B
  lem = ΣPathP (refl , (sym (lUnit _)))

  J-lem : {ℓ ℓC : Level} {A B : Pointed ℓ} {C : Pointed ℓC}
             → (eq : (A ≃∙ B))
             → retract (to A B C eq) (from _ _ _ eq)
              × section (to A B C eq) (from _ _ _ eq)
  J-lem {B = B} {C = C} =
    Equiv∙J (λ A eq → retract (to A B C eq) (from _ _ _ eq)
              × section (to A B C eq) (from _ _ _ eq))
            ((λ f → ((λ i → (f ∘∙ lem i) ∘∙ id∙ B)
                  ∙ λ i → ∘∙-idˡ (∘∙-idˡ f i) i))
           , λ f → (λ i → (f ∘∙ id∙ B) ∘∙ lem i)
                  ∙ λ i → ∘∙-idˡ (∘∙-idˡ f i) i)

  main : Iso (A →∙ C) (B →∙ C)
  Iso.fun main = to A B C eq
  Iso.inv main = from A B C eq
  Iso.rightInv main = J-lem eq .snd
  Iso.leftInv main = J-lem eq .fst


-- Andrea(s), 2018-11-23, issue #3378
--
-- WAS: internal error in coverage checker and clause compiler
-- for missing hcomp clauses triggered by non-exact splitting.

{-# OPTIONS --cubical #-}

-- {-# OPTIONS -v tc.cover:10 #-}

open import Agda.Builtin.Cubical.Path
open import Agda.Builtin.Unit

data Interval : Set where
  pos : Interval
  neg : Interval
  zeroes-identified : pos ≡ neg

test : Interval → Interval → ⊤
test pos pos = tt
test neg pos = tt
test (zeroes-identified i) pos = tt
test x neg = tt
test x (zeroes-identified j) = tt

-- Should pass (with non-exact splitting).


------------------------------------------------------------------------------
-- Totality properties respect to OrdList (flatten-OrdList-helper)
------------------------------------------------------------------------------

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

-- The termination checker can not determine that the function
-- flatten-OrdList-helper is defined by structural recursion because
-- we are using postulates.

module FOT.FOTC.Program.SortList.Properties.Totality.OrdList.FlattenI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Bool
open import FOTC.Data.Bool.PropertiesI
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesI
open import FOTC.Data.Nat.Type
open import FOTC.Data.List
open import FOTC.Program.SortList.Properties.Totality.BoolI
open import FOTC.Program.SortList.Properties.Totality.ListN-I
open import FOTC.Program.SortList.Properties.Totality.OrdTreeI
open import FOTC.Program.SortList.Properties.MiscellaneousI
open import FOTC.Program.SortList.SortList

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

{-# TERMINATING #-}
flatten-OrdList-helper : ∀ {t₁ i t₂} → Tree t₁ → N i → Tree t₂ →
                         OrdTree (node t₁ i t₂) →
                         ≤-Lists (flatten t₁) (flatten t₂)

flatten-OrdList-helper {t₂ = t₂} tnil Ni Tt₂ OTt =
  subst (λ t → ≤-Lists t (flatten t₂))
        (sym (flatten-nil))
        (le-Lists-[] (flatten t₂))

flatten-OrdList-helper (ttip {i₁} Ni₁) _ tnil OTt =
  le-Lists (flatten (tip i₁)) (flatten nil)
    ≡⟨ subst₂ (λ x₁ x₂ → le-Lists (flatten (tip i₁)) (flatten nil) ≡
                         le-Lists x₁ x₂)
              (flatten-tip i₁)
              flatten-nil
              refl
    ⟩
  le-Lists (i₁ ∷ []) []
    ≡⟨ le-Lists-∷ i₁ [] [] ⟩
  le-ItemList i₁ [] && le-Lists [] []
    ≡⟨ subst₂ (λ x₁ x₂ → le-ItemList i₁ [] && le-Lists [] [] ≡ x₁ && x₂)
              (le-ItemList-[] i₁)
              (le-Lists-[] [])
              refl
    ⟩
  true && true
    ≡⟨ t&&x≡x true ⟩
  true ∎

flatten-OrdList-helper {i = i} (ttip {i₁} Ni₁) Ni (ttip {i₂} Ni₂) OTt =
  le-Lists (flatten (tip i₁)) (flatten (tip i₂))
    ≡⟨ subst₂ (λ x₁ x₂ → le-Lists (flatten (tip i₁)) (flatten (tip i₂)) ≡
                         le-Lists x₁ x₂)
              (flatten-tip i₁)
              (flatten-tip i₂)
              refl
    ⟩
  le-Lists (i₁ ∷ []) (i₂ ∷ [])
    ≡⟨ le-Lists-∷ i₁ [] (i₂ ∷ []) ⟩
  le-ItemList i₁ (i₂ ∷ []) && le-Lists [] (i₂ ∷ [])
    ≡⟨ subst (λ t → le-ItemList i₁ (i₂ ∷ []) && le-Lists [] (i₂ ∷ []) ≡
                    t && le-Lists [] (i₂ ∷ []))
             (le-ItemList-∷ i₁ i₂ [])
             refl
    ⟩
  (le i₁ i₂ && le-ItemList i₁ []) && le-Lists [] (i₂ ∷ [])
    ≡⟨ subst (λ t → (le i₁ i₂ && le-ItemList i₁ []) && le-Lists [] (i₂ ∷ []) ≡
                    (t        && le-ItemList i₁ []) && le-Lists [] (i₂ ∷ []))
             lemma
             refl
    ⟩
  (true && le-ItemList i₁ []) && le-Lists [] (i₂ ∷ [])
    ≡⟨ subst₂ (λ x₁ x₂ → (true && le-ItemList i₁ []) && le-Lists [] (i₂ ∷ []) ≡
                         (true && x₁)               && x₂)
              (le-ItemList-[] i₁)
              (le-Lists-[] (i₂ ∷ []))
              refl
    ⟩
  (true && true) && true
    ≡⟨ &&-assoc btrue btrue btrue ⟩
  true && true && true
    ≡⟨ &&-list₃-all-t btrue btrue btrue (refl , refl , refl) ⟩
  true
  ∎
  where
    helper₁ : Bool (ordTree (tip i₁))
    helper₁ = ordTree-Bool (ttip Ni₁)

    helper₂ : Bool (ordTree (tip i₂))
    helper₂ = ordTree-Bool (ttip Ni₂)

    helper₃ : Bool (le-TreeItem (tip i₁) i)
    helper₃ = le-TreeItem-Bool (ttip Ni₁) Ni

    helper₄ : Bool (le-ItemTree i (tip i₂))
    helper₄ = le-ItemTree-Bool Ni (ttip Ni₂)

    helper₅ : ordTree (tip i₁) &&
              ordTree (tip i₂) &&
              le-TreeItem (tip i₁) i &&
              le-ItemTree i (tip i₂) ≡ true
    helper₅ = trans (sym (ordTree-node (tip i₁) i (tip i₂))) OTt

    lemma : i₁ ≤ i₂
    lemma = ≤-trans Ni₁ Ni Ni₂ i₁≤i i≤i₂
     where
       i₁≤i : i₁ ≤ i
       i₁≤i = trans (sym (le-TreeItem-tip i₁ i))
                    (&&-list₄-t₃ helper₁ helper₂ helper₃ helper₄ helper₅)

       i≤i₂ : i ≤ i₂
       i≤i₂ = trans (sym (le-ItemTree-tip i i₂))
                    (&&-list₄-t₄ helper₁ helper₂ helper₃ helper₄ helper₅)

flatten-OrdList-helper {i = i} (ttip {i₁} Ni₁) Ni
                       (tnode {t₂₁} {i₂} {t₂₂} Tt₂₁ Ni₂ Tt₂₂) OTt =
  le-Lists (flatten (tip i₁)) (flatten (node t₂₁ i₂ t₂₂))
    ≡⟨ subst (λ x → le-Lists (flatten (tip i₁)) (flatten (node t₂₁ i₂ t₂₂)) ≡
                    le-Lists (flatten (tip i₁)) x)
             (flatten-node t₂₁ i₂ t₂₂)
             refl
    ⟩
  le-Lists (flatten (tip i₁)) (flatten t₂₁ ++ flatten t₂₂)
    ≡⟨ xs≤ys→xs≤zs→xs≤ys++zs (flatten-ListN (ttip Ni₁))
                             (flatten-ListN Tt₂₁)
                             (flatten-ListN Tt₂₂)
                             lemma₁
                             lemma₂
    ⟩
  true ∎
  where
    -- Helper terms to get the conjuncts from OTt.
    helper₁ = ordTree-Bool (ttip Ni₁)
    helper₂ = ordTree-Bool (tnode Tt₂₁ Ni₂ Tt₂₂)
    helper₃ = le-TreeItem-Bool (ttip Ni₁) Ni
    helper₄ = le-ItemTree-Bool Ni (tnode Tt₂₁ Ni₂ Tt₂₂)
    helper₅ = trans (sym (ordTree-node (tip i₁) i (node t₂₁ i₂ t₂₂))) OTt

    -- Helper terms to get the conjuncts from the fourth conjunct of OTt.
    helper₆ = le-ItemTree-Bool Ni Tt₂₁
    helper₇ = le-ItemTree-Bool Ni Tt₂₂
    helper₈ = trans (sym (le-ItemTree-node i t₂₁ i₂ t₂₂))
                    (&&-list₄-t₄ helper₁ helper₂ helper₃ helper₄ helper₅)

    -- Common terms for the lemma₁ and lemma₂.
    OrdTree-tip-i₁ : OrdTree (tip i₁)
    OrdTree-tip-i₁ = &&-list₄-t₁ helper₁ helper₂ helper₃ helper₄ helper₅

    ≤-TreeItem-tip-i₁-i : ≤-TreeItem (tip i₁) i
    ≤-TreeItem-tip-i₁-i = &&-list₄-t₃ helper₁ helper₂ helper₃ helper₄ helper₅

    lemma₁ : ≤-Lists (flatten (tip i₁)) (flatten t₂₁)
    lemma₁ = flatten-OrdList-helper (ttip Ni₁) Ni Tt₂₁ OT
      where
        OrdTree-t₂₁ : OrdTree t₂₁
        OrdTree-t₂₁ =
          leftSubTree-OrdTree Tt₂₁ Ni₂ Tt₂₂ (&&-list₄-t₂ helper₁ helper₂ helper₃
                                                         helper₄ helper₅)

        ≤-ItemTree-i-t₂₁ : ≤-ItemTree i t₂₁
        ≤-ItemTree-i-t₂₁ = &&-list₂-t₁ helper₆ helper₇ helper₈

        OT : OrdTree (node (tip i₁) i t₂₁)
        OT = ordTree (node (tip i₁) i t₂₁)
               ≡⟨ ordTree-node (tip i₁) i t₂₁ ⟩
             ordTree (tip i₁) &&
             ordTree t₂₁ &&
             le-TreeItem (tip i₁) i &&
             le-ItemTree i t₂₁
               ≡⟨ subst₄ (λ w x y z → ordTree (tip i₁) &&
                                      ordTree t₂₁ &&
                                      le-TreeItem (tip i₁) i &&
                                      le-ItemTree i t₂₁ ≡
                                      w && x && y && z)
                         OrdTree-tip-i₁
                         OrdTree-t₂₁
                         ≤-TreeItem-tip-i₁-i
                         ≤-ItemTree-i-t₂₁
                         refl
             ⟩
             true && true && true && true
               ≡⟨ &&-list₄-all-t btrue btrue btrue btrue (refl , refl , refl , refl) ⟩
             true ∎

    lemma₂ : ≤-Lists (flatten (tip i₁)) (flatten t₂₂)
    lemma₂ = flatten-OrdList-helper (ttip Ni₁) Ni Tt₂₂ OT
      where
        OrdTree-t₂₂ : OrdTree t₂₂
        OrdTree-t₂₂ =
          rightSubTree-OrdTree Tt₂₁ Ni₂ Tt₂₂ (&&-list₄-t₂ helper₁ helper₂ helper₃
                                                          helper₄ helper₅)

        ≤-ItemTree-i-t₂₂ : ≤-ItemTree i t₂₂
        ≤-ItemTree-i-t₂₂ = &&-list₂-t₂ helper₆ helper₇ helper₈

        OT : OrdTree (node (tip i₁) i t₂₂)
        OT = ordTree (node (tip i₁) i t₂₂)
               ≡⟨ ordTree-node (tip i₁) i t₂₂ ⟩
             ordTree (tip i₁) &&
             ordTree t₂₂ &&
             le-TreeItem (tip i₁) i &&
             le-ItemTree i t₂₂
               ≡⟨ subst₄ (λ w x y z → ordTree (tip i₁) &&
                                      ordTree t₂₂ &&
                                      le-TreeItem (tip i₁) i &&
                                      le-ItemTree i t₂₂ ≡
                                      w && x && y && z)
                         OrdTree-tip-i₁
                         OrdTree-t₂₂
                         ≤-TreeItem-tip-i₁-i
                         ≤-ItemTree-i-t₂₂
                         refl
             ⟩
             true && true && true && true
               ≡⟨ &&-list₄-all-t btrue btrue btrue btrue (refl , refl , refl , refl) ⟩
             true ∎

flatten-OrdList-helper {i = i} (tnode {t₁₁} {i₁} {t₁₂} Tt₁₁ Ni₁ Tt₁₂) Ni tnil OTt =
  le-Lists (flatten (node t₁₁ i₁ t₁₂)) (flatten nil)
    ≡⟨ subst (λ x → le-Lists (flatten (node t₁₁ i₁ t₁₂)) (flatten nil) ≡
                    le-Lists x                           (flatten nil))
             (flatten-node t₁₁ i₁ t₁₂)
             refl
    ⟩
  le-Lists (flatten t₁₁ ++  flatten t₁₂) (flatten nil)
    ≡⟨ xs≤zs→ys≤zs→xs++ys≤zs (flatten-ListN Tt₁₁)
                             (flatten-ListN Tt₁₂)
                             (flatten-ListN tnil)
                             lemma₁
                             lemma₂
    ⟩
  true ∎
  where
    -- Helper terms to get the conjuncts from OTt.
    helper₁ = ordTree-Bool (tnode Tt₁₁ Ni₁ Tt₁₂)
    helper₂ = ordTree-Bool tnil
    helper₃ = le-TreeItem-Bool (tnode Tt₁₁ Ni₁ Tt₁₂) Ni
    helper₄ = le-ItemTree-Bool Ni tnil
    helper₅ = trans (sym (ordTree-node (node t₁₁ i₁ t₁₂) i nil)) OTt

    -- Helper terms to get the conjuncts from the third conjunct of OTt.
    helper₆ = le-TreeItem-Bool Tt₁₁ Ni
    helper₇ = le-TreeItem-Bool Tt₁₂ Ni
    helper₈ = trans (sym (le-TreeItem-node t₁₁ i₁ t₁₂ i))
                    (&&-list₄-t₃ helper₁ helper₂ helper₃ helper₄ helper₅)

    -- Common terms for the lemma₁ and lemma₂.
    ≤-ItemTree-i-niltree : ≤-ItemTree i nil
    ≤-ItemTree-i-niltree = &&-list₄-t₄ helper₁ helper₂ helper₃ helper₄ helper₅

    lemma₁ : ≤-Lists (flatten t₁₁) (flatten nil)
    lemma₁ = flatten-OrdList-helper Tt₁₁ Ni tnil OT
      where
        OrdTree-t₁₁ : OrdTree t₁₁
        OrdTree-t₁₁ =
          leftSubTree-OrdTree Tt₁₁ Ni₁ Tt₁₂ (&&-list₄-t₁ helper₁ helper₂ helper₃
                                                         helper₄ helper₅)

        ≤-TreeItem-t₁₁-i : ≤-TreeItem t₁₁ i
        ≤-TreeItem-t₁₁-i = &&-list₂-t₁ helper₆ helper₇ helper₈

        OT : OrdTree (node t₁₁ i nil)
        OT = ordTree (node t₁₁ i nil)
               ≡⟨ ordTree-node t₁₁ i nil ⟩
             ordTree t₁₁ &&
             ordTree nil &&
             le-TreeItem t₁₁ i &&
             le-ItemTree i nil
               ≡⟨ subst₄ (λ w x y z → ordTree t₁₁ &&
                                      ordTree nil &&
                                      le-TreeItem t₁₁ i &&
                                      le-ItemTree i nil ≡
                                      w && x && y && z)
                         OrdTree-t₁₁
                         ordTree-nil
                         ≤-TreeItem-t₁₁-i
                         ≤-ItemTree-i-niltree
                         refl
             ⟩
             true && true && true && true
               ≡⟨ &&-list₄-all-t btrue btrue btrue btrue (refl , refl , refl , refl) ⟩
             true ∎

    lemma₂ : ≤-Lists (flatten t₁₂) (flatten nil)
    lemma₂ = flatten-OrdList-helper Tt₁₂ Ni tnil OT
      where
        OrdTree-t₁₂ : OrdTree t₁₂
        OrdTree-t₁₂ =
          rightSubTree-OrdTree Tt₁₁ Ni₁ Tt₁₂ (&&-list₄-t₁ helper₁ helper₂ helper₃
                                                          helper₄ helper₅)

        ≤-TreeItem-t₁₂-i : ≤-TreeItem t₁₂ i
        ≤-TreeItem-t₁₂-i = &&-list₂-t₂ helper₆ helper₇ helper₈

        OT : OrdTree (node t₁₂ i nil)
        OT = ordTree (node t₁₂ i nil)
              ≡⟨ ordTree-node t₁₂ i nil ⟩
             ordTree t₁₂ &&
             ordTree nil &&
             le-TreeItem t₁₂ i &&
             le-ItemTree i nil
               ≡⟨ subst₄ (λ w x y z → ordTree t₁₂ &&
                                      ordTree nil &&
                                      le-TreeItem t₁₂ i &&
                                      le-ItemTree i nil ≡
                                      w && x && y && z)
                         OrdTree-t₁₂
                         ordTree-nil
                         ≤-TreeItem-t₁₂-i
                         ≤-ItemTree-i-niltree
                         refl
             ⟩
             true && true && true && true
               ≡⟨ &&-list₄-all-t btrue btrue btrue btrue (refl , refl , refl , refl) ⟩
             true ∎

flatten-OrdList-helper {i = i} (tnode {t₁₁} {i₁} {t₁₂} Tt₁₁ Ni₁ Tt₁₂) Ni
                       (ttip {i₂} Ni₂) OTt =
  le-Lists (flatten (node t₁₁ i₁ t₁₂)) (flatten (tip i₂))
    ≡⟨ subst (λ x → le-Lists (flatten (node t₁₁ i₁ t₁₂)) (flatten (tip i₂)) ≡
                    le-Lists x                           (flatten (tip i₂)))
             (flatten-node t₁₁ i₁ t₁₂)
             refl
    ⟩
  le-Lists (flatten t₁₁ ++  flatten t₁₂) (flatten (tip i₂))
    ≡⟨ xs≤zs→ys≤zs→xs++ys≤zs (flatten-ListN Tt₁₁)
                             (flatten-ListN Tt₁₂)
                             (flatten-ListN (ttip Ni₂))
                             lemma₁
                             lemma₂
    ⟩
  true ∎
  where
    -- Helper terms to get the conjuncts from OTt.
    helper₁ = ordTree-Bool (tnode Tt₁₁ Ni₁ Tt₁₂)
    helper₂ = ordTree-Bool (ttip Ni₂)
    helper₃ = le-TreeItem-Bool (tnode Tt₁₁ Ni₁ Tt₁₂) Ni
    helper₄ = le-ItemTree-Bool Ni (ttip Ni₂)
    helper₅ = trans (sym (ordTree-node (node t₁₁ i₁ t₁₂) i (tip i₂))) OTt

    -- Helper terms to get the conjuncts from the third conjunct of OTt.
    helper₆ = le-TreeItem-Bool Tt₁₁ Ni
    helper₇ = le-TreeItem-Bool Tt₁₂ Ni
    helper₈ = trans (sym (le-TreeItem-node t₁₁ i₁ t₁₂ i))
                    (&&-list₄-t₃ helper₁ helper₂ helper₃ helper₄ helper₅)

    -- Common terms for the lemma₁ and lemma₂.
    OrdTree-tip-i₂ : OrdTree (tip i₂)
    OrdTree-tip-i₂ = &&-list₄-t₂ helper₁ helper₂ helper₃ helper₄ helper₅

    ≤-ItemTree-i-tip-i₂ : ≤-ItemTree i (tip i₂)
    ≤-ItemTree-i-tip-i₂ = &&-list₄-t₄ helper₁ helper₂ helper₃ helper₄ helper₅

    lemma₁ : ≤-Lists (flatten t₁₁) (flatten (tip i₂))
    lemma₁ = flatten-OrdList-helper Tt₁₁ Ni (ttip Ni₂) OT
      where
        OrdTree-t₁₁ : OrdTree t₁₁
        OrdTree-t₁₁ =
          leftSubTree-OrdTree Tt₁₁ Ni₁ Tt₁₂ (&&-list₄-t₁ helper₁ helper₂ helper₃
                                                         helper₄ helper₅)

        ≤-TreeItem-t₁₁-i : ≤-TreeItem t₁₁ i
        ≤-TreeItem-t₁₁-i = &&-list₂-t₁ helper₆ helper₇ helper₈

        OT : OrdTree (node t₁₁ i (tip i₂))
        OT = ordTree (node t₁₁ i (tip i₂))
               ≡⟨ ordTree-node t₁₁ i (tip i₂) ⟩
             ordTree t₁₁ &&
             ordTree (tip i₂) &&
             le-TreeItem t₁₁ i &&
             le-ItemTree i (tip i₂)
               ≡⟨ subst₄ (λ w x y z → ordTree t₁₁ &&
                                      ordTree (tip i₂) &&
                                      le-TreeItem t₁₁ i &&
                                      le-ItemTree i (tip i₂) ≡
                                      w && x && y && z)
                         OrdTree-t₁₁
                         OrdTree-tip-i₂
                         ≤-TreeItem-t₁₁-i
                         ≤-ItemTree-i-tip-i₂
                         refl
             ⟩
             true && true && true && true
               ≡⟨ &&-list₄-all-t btrue btrue btrue btrue (refl , refl , refl , refl) ⟩
             true ∎

    lemma₂ : ≤-Lists (flatten t₁₂) (flatten (tip i₂))
    lemma₂ = flatten-OrdList-helper Tt₁₂ Ni (ttip Ni₂) OT
      where
        OrdTree-t₁₂ : OrdTree t₁₂
        OrdTree-t₁₂ =
          rightSubTree-OrdTree Tt₁₁ Ni₁ Tt₁₂ (&&-list₄-t₁ helper₁ helper₂ helper₃
                                                          helper₄ helper₅)

        ≤-TreeItem-t₁₂-i : ≤-TreeItem t₁₂ i
        ≤-TreeItem-t₁₂-i = &&-list₂-t₂ helper₆ helper₇ helper₈

        OT : OrdTree (node t₁₂ i (tip i₂))
        OT = ordTree (node t₁₂ i (tip i₂))
               ≡⟨ ordTree-node t₁₂ i (tip i₂) ⟩
             ordTree t₁₂ &&
             ordTree (tip i₂) &&
             le-TreeItem t₁₂ i &&
             le-ItemTree i (tip i₂)
               ≡⟨ subst₄ (λ w x y z → ordTree t₁₂ &&
                                      ordTree (tip i₂) &&
                                      le-TreeItem t₁₂ i &&
                                      le-ItemTree i (tip i₂) ≡
                                      w && x && y && z)
                         OrdTree-t₁₂
                         OrdTree-tip-i₂
                         ≤-TreeItem-t₁₂-i
                         ≤-ItemTree-i-tip-i₂
                         refl
             ⟩
             true && true && true && true
               ≡⟨ &&-list₄-all-t btrue btrue btrue btrue (refl , refl , refl , refl) ⟩
             true ∎

flatten-OrdList-helper {i = i} (tnode {t₁₁} {i₁} {t₁₂} Tt₁₁ Ni₁ Tt₁₂) Ni
                       (tnode {t₂₁} {i₂} {t₂₂} Tt₂₁ Ni₂ Tt₂₂) OTt =
  le-Lists (flatten (node t₁₁ i₁ t₁₂)) (flatten (node t₂₁ i₂ t₂₂))
    ≡⟨ subst (λ x → le-Lists (flatten (node t₁₁ i₁ t₁₂))
                            (flatten (node t₂₁ i₂ t₂₂)) ≡
                    le-Lists x (flatten (node t₂₁ i₂ t₂₂)))
             (flatten-node t₁₁ i₁ t₁₂)
             refl
    ⟩
  le-Lists (flatten t₁₁ ++  flatten t₁₂) (flatten (node t₂₁ i₂ t₂₂))
    ≡⟨ xs≤zs→ys≤zs→xs++ys≤zs (flatten-ListN Tt₁₁)
                             (flatten-ListN Tt₁₂)
                             (flatten-ListN (tnode Tt₂₁ Ni₂ Tt₂₂))
                             lemma₁
                             lemma₂
    ⟩
  true ∎
  where
    -- Helper terms to get the conjuncts from OTt.
    helper₁ = ordTree-Bool (tnode Tt₁₁ Ni₁ Tt₁₂)
    helper₂ = ordTree-Bool (tnode Tt₂₁ Ni₂ Tt₂₂)
    helper₃ = le-TreeItem-Bool (tnode Tt₁₁ Ni₁ Tt₁₂) Ni
    helper₄ = le-ItemTree-Bool Ni (tnode Tt₂₁ Ni₂ Tt₂₂)
    helper₅ = trans (sym (ordTree-node (node t₁₁ i₁ t₁₂) i (node t₂₁ i₂ t₂₂))) OTt

    -- Helper terms to get the conjuncts from the third conjunct of OTt.
    helper₆ = le-TreeItem-Bool Tt₁₁ Ni
    helper₇ = le-TreeItem-Bool Tt₁₂ Ni
    helper₈ = trans (sym (le-TreeItem-node t₁₁ i₁ t₁₂ i))
                    (&&-list₄-t₃ helper₁ helper₂ helper₃ helper₄ helper₅)

    -- Common terms for the lemma₁ and lemma₂.
    OrdTree-node-t₂₁-i₂-t₂₂ : OrdTree (node t₂₁ i₂ t₂₂)
    OrdTree-node-t₂₁-i₂-t₂₂ = &&-list₄-t₂ helper₁ helper₂ helper₃ helper₄ helper₅

    ≤-ItemTree-i-node-t₂₁-i₂-t₂₂ : ≤-ItemTree i (node t₂₁ i₂ t₂₂)
    ≤-ItemTree-i-node-t₂₁-i₂-t₂₂ = &&-list₄-t₄ helper₁ helper₂ helper₃ helper₄
                                                helper₅

    lemma₁ : ≤-Lists (flatten t₁₁) (flatten (node t₂₁ i₂ t₂₂))
    lemma₁ = flatten-OrdList-helper Tt₁₁ Ni (tnode Tt₂₁ Ni₂ Tt₂₂) OT
      where
        OrdTree-t₁₁ : OrdTree t₁₁
        OrdTree-t₁₁ =
          leftSubTree-OrdTree Tt₁₁ Ni₁ Tt₁₂ (&&-list₄-t₁ helper₁ helper₂ helper₃
                                                         helper₄ helper₅)

        ≤-TreeItem-t₁₁-i : ≤-TreeItem t₁₁ i
        ≤-TreeItem-t₁₁-i = &&-list₂-t₁ helper₆ helper₇ helper₈

        OT : OrdTree (node t₁₁ i (node t₂₁ i₂ t₂₂))
        OT = ordTree (node t₁₁ i (node t₂₁ i₂ t₂₂))
               ≡⟨ ordTree-node t₁₁ i (node t₂₁ i₂ t₂₂) ⟩
             ordTree t₁₁ &&
             ordTree (node t₂₁ i₂ t₂₂) &&
             le-TreeItem t₁₁ i &&
             le-ItemTree i (node t₂₁ i₂ t₂₂)
               ≡⟨ subst₄ (λ w x y z → ordTree t₁₁ &&
                                      ordTree (node t₂₁ i₂ t₂₂) &&
                                      le-TreeItem t₁₁ i &&
                                      le-ItemTree i (node t₂₁ i₂ t₂₂) ≡
                                      w && x && y && z)
                         OrdTree-t₁₁
                         OrdTree-node-t₂₁-i₂-t₂₂
                         ≤-TreeItem-t₁₁-i
                         ≤-ItemTree-i-node-t₂₁-i₂-t₂₂
                         refl
             ⟩
             true && true && true && true
               ≡⟨ &&-list₄-all-t btrue btrue btrue btrue (refl , refl , refl , refl) ⟩
             true ∎

    lemma₂ : ≤-Lists (flatten t₁₂) (flatten (node t₂₁ i₂ t₂₂))
    lemma₂ = flatten-OrdList-helper Tt₁₂ Ni (tnode Tt₂₁ Ni₂ Tt₂₂) OT
      where
        OrdTree-t₁₂ : OrdTree t₁₂
        OrdTree-t₁₂ =
          rightSubTree-OrdTree Tt₁₁ Ni₁ Tt₁₂ (&&-list₄-t₁ helper₁ helper₂ helper₃
                                                          helper₄ helper₅)

        ≤-TreeItem-t₁₂-i : ≤-TreeItem t₁₂ i
        ≤-TreeItem-t₁₂-i = &&-list₂-t₂ helper₆ helper₇ helper₈

        OT : OrdTree (node t₁₂ i (node t₂₁ i₂ t₂₂))
        OT = ordTree (node t₁₂ i (node t₂₁ i₂ t₂₂))
               ≡⟨ ordTree-node t₁₂ i (node t₂₁ i₂ t₂₂) ⟩
             ordTree t₁₂ &&
             ordTree (node t₂₁ i₂ t₂₂) &&
             le-TreeItem t₁₂ i &&
             le-ItemTree i (node t₂₁ i₂ t₂₂)
               ≡⟨ subst₄ (λ w x y z → ordTree t₁₂ &&
                                      ordTree (node t₂₁ i₂ t₂₂) &&
                                      le-TreeItem t₁₂ i &&
                                      le-ItemTree i (node t₂₁ i₂ t₂₂) ≡
                                      w && x && y && z)
                         OrdTree-t₁₂
                         OrdTree-node-t₂₁-i₂-t₂₂
                         ≤-TreeItem-t₁₂-i
                         ≤-ItemTree-i-node-t₂₁-i₂-t₂₂
                         refl
             ⟩
             true && true && true && true
               ≡⟨ &&-list₄-all-t btrue btrue btrue btrue (refl , refl , refl , refl) ⟩
             true
           ∎


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.ZCohomology.Groups.Sn where

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.MayerVietorisUnreduced
open import Cubical.ZCohomology.Groups.Unit
open import Cubical.ZCohomology.Groups.Connected
open import Cubical.ZCohomology.KcompPrelims
open import Cubical.ZCohomology.Groups.Prelims

open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Structure
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws

open import Cubical.HITs.Pushout
open import Cubical.HITs.Sn
open import Cubical.HITs.S1
open import Cubical.HITs.Susp
open import Cubical.HITs.SetTruncation renaming (rec to sRec ; elim to sElim ; elim2 to sElim2 ; map to sMap)
open import Cubical.HITs.PropositionalTruncation renaming (rec to pRec ; elim to pElim ; elim2 to pElim2 ; ∥_∥ to ∥_∥₁ ; ∣_∣ to ∣_∣₁) hiding (map)

open import Cubical.Data.Bool
open import Cubical.Data.Sigma
open import Cubical.Data.Int renaming (_+_ to _+ℤ_; +-comm to +ℤ-comm ; +-assoc to +ℤ-assoc)
open import Cubical.Data.Nat
open import Cubical.HITs.Truncation renaming (elim to trElim ; map to trMap ; rec to trRec)
open import Cubical.Data.Unit

open import Cubical.Homotopy.Connected

open import Cubical.Algebra.Group

infixr 31 _□_
_□_ : _
_□_ = compGroupIso

open GroupEquiv
open vSES
open GroupIso
open GroupHom
open BijectionIso

Sn-connected : (n : ℕ) (x : typ (S₊∙ (suc n))) → ∥ pt (S₊∙ (suc n)) ≡ x ∥₁
Sn-connected zero = toPropElim (λ _ → propTruncIsProp) ∣ refl ∣₁
Sn-connected (suc zero) = suspToPropElim base (λ _ → propTruncIsProp) ∣ refl ∣₁
Sn-connected (suc (suc n)) = suspToPropElim north (λ _ → propTruncIsProp) ∣ refl ∣₁

H⁰-Sⁿ≅ℤ : (n : ℕ) → GroupIso (coHomGr 0 (S₊ (suc n))) intGroup
H⁰-Sⁿ≅ℤ zero = H⁰-connected base (Sn-connected 0)
H⁰-Sⁿ≅ℤ (suc n) = H⁰-connected north (Sn-connected (suc n))

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

--- We will need to switch between Sⁿ defined using suspensions and using pushouts
--- in order to apply Mayer Vietoris.

S1Iso : Iso S¹ (Pushout {A = Bool} (λ _ → tt) λ _ → tt)
S1Iso = S¹IsoSuspBool ⋄ invIso PushoutSuspIsoSusp

coHomPushout≅coHomSn : (n m : ℕ) → GroupIso (coHomGr m (S₊ (suc n)))
                                             (coHomGr m (Pushout {A = S₊ n} (λ _ → tt) λ _ → tt))
coHomPushout≅coHomSn zero m =
  Iso+Hom→GrIso (setTruncIso (domIso S1Iso))
                (sElim2 (λ _ _ → isSet→isGroupoid setTruncIsSet _ _) (λ _ _ → refl))
coHomPushout≅coHomSn (suc n) m =
  Iso+Hom→GrIso (setTruncIso (domIso (invIso PushoutSuspIsoSusp)))
                (sElim2 (λ _ _ → isSet→isGroupoid setTruncIsSet _ _) (λ _ _ → refl))

-------------------------- H⁰(S⁰) -----------------------------
S0→Int : (a : Int × Int) → S₊ 0 → Int
S0→Int a true = fst a
S0→Int a false = snd a

H⁰-S⁰≅ℤ×ℤ : GroupIso (coHomGr 0 (S₊ 0)) (dirProd intGroup intGroup)
fun (map H⁰-S⁰≅ℤ×ℤ) = sRec (isSet× isSetInt isSetInt) λ f → (f true) , (f false)
isHom (map H⁰-S⁰≅ℤ×ℤ) = sElim2 (λ _ _ → isSet→isGroupoid (isSet× isSetInt isSetInt) _ _)
                                λ a b i → addLemma (a true) (b true) i , addLemma (a false) (b false) i
inv H⁰-S⁰≅ℤ×ℤ a = ∣ S0→Int a ∣₂
rightInv H⁰-S⁰≅ℤ×ℤ _ = refl
leftInv H⁰-S⁰≅ℤ×ℤ = sElim (λ _ → isSet→isGroupoid setTruncIsSet _ _)
                           λ f → cong ∣_∣₂ (funExt (λ {true → refl ; false → refl}))

------------------------- H¹(S⁰) ≅ 0 -------------------------------

private
  Hⁿ-S0≃Kₙ×Kₙ : (n : ℕ) → Iso (S₊ 0 → coHomK (suc n)) (coHomK (suc n) × coHomK (suc n))
  Iso.fun (Hⁿ-S0≃Kₙ×Kₙ n) f = (f true) , (f false)
  Iso.inv (Hⁿ-S0≃Kₙ×Kₙ n) (a , b) true = a
  Iso.inv (Hⁿ-S0≃Kₙ×Kₙ n) (a , b) false = b
  Iso.rightInv (Hⁿ-S0≃Kₙ×Kₙ n) a = refl
  Iso.leftInv (Hⁿ-S0≃Kₙ×Kₙ n) b = funExt λ {true → refl ; false → refl}

  isContrHⁿ-S0 : (n : ℕ) → isContr (coHom (suc n) (S₊ 0))
  isContrHⁿ-S0 n = isContrRetract (Iso.fun (setTruncIso (Hⁿ-S0≃Kₙ×Kₙ n)))
                                  (Iso.inv (setTruncIso (Hⁿ-S0≃Kₙ×Kₙ n)))
                                  (Iso.leftInv (setTruncIso (Hⁿ-S0≃Kₙ×Kₙ n)))
                                  (isContrHelper n)
    where
    isContrHelper : (n : ℕ) → isContr (∥ (coHomK (suc n) × coHomK (suc n)) ∥₂)
    fst (isContrHelper zero) = ∣ (0₁ , 0₁) ∣₂
    snd (isContrHelper zero) = sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                                  λ y → elim2 {B = λ x y → ∣ (0₁ , 0₁) ∣₂ ≡ ∣(x , y) ∣₂ }
                                  (λ _ _ → isOfHLevelPlus {n = 2} 2 setTruncIsSet _ _)
                                  (toPropElim2 (λ _ _ → setTruncIsSet _ _) refl) (fst y) (snd y)
    isContrHelper (suc zero) = ∣ (0₂ , 0₂) ∣₂
                          , sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                                  λ y → elim2 {B = λ x y → ∣ (0₂ , 0₂) ∣₂ ≡ ∣(x , y) ∣₂ }
                                  (λ _ _ → isOfHLevelPlus {n = 2} 3 setTruncIsSet _ _)
                                  (suspToPropElim2 base (λ _ _ → setTruncIsSet _ _) refl) (fst y) (snd y)
    isContrHelper (suc (suc n)) = ∣ (0ₖ (3 + n) , 0ₖ (3 + n)) ∣₂
                          , sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                                  λ y → elim2 {B = λ x y → ∣ (0ₖ (3 + n) , 0ₖ (3 + n)) ∣₂ ≡ ∣(x , y) ∣₂ }
                                  (λ _ _ → isProp→isOfHLevelSuc (4 + n) (setTruncIsSet _ _))
                                  (suspToPropElim2 north (λ _ _ → setTruncIsSet _ _) refl) (fst y) (snd y)

H¹-S⁰≅0 : (n : ℕ) → GroupIso (coHomGr (suc n) (S₊ 0)) trivialGroup
H¹-S⁰≅0 n = IsoContrGroupTrivialGroup (isContrHⁿ-S0 n)

------------------------- H²(S¹) ≅ 0 -------------------------------

Hⁿ-S¹≅0 : (n : ℕ) → GroupIso (coHomGr (2 + n) (S₊ 1)) trivialGroup
Hⁿ-S¹≅0 n = IsoContrGroupTrivialGroup
            (isOfHLevelRetractFromIso 0 helper
              (_ , helper2))
  where
  helper : Iso ⟨ coHomGr (2 + n) (S₊ 1)⟩ ∥ Σ (hLevelTrunc (4 + n) (S₊ (2 + n))) (λ x → ∥ x ≡ x ∥₂) ∥₂
  helper = compIso (setTruncIso IsoFunSpaceS¹) IsoSetTruncateSndΣ

  helper2 : (x : ∥ Σ (hLevelTrunc (4 + n) (S₊ (2 + n))) (λ x → ∥ x ≡ x ∥₂) ∥₂) → ∣ ∣ north ∣ , ∣ refl ∣₂ ∣₂ ≡ x
  helper2 =
    sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
          (uncurry
            (trElim (λ _ → isOfHLevelΠ (4 + n) λ _ → isProp→isOfHLevelSuc (3 + n) (setTruncIsSet _ _))
              (suspToPropElim (ptSn (suc n)) (λ _ → isPropΠ λ _ → setTruncIsSet _ _)
                (sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                       λ p
                    → cong ∣_∣₂ (ΣPathP (refl , isContr→isProp helper3 _ _))))))
    where
    helper4 : isConnected (n + 3) (hLevelTrunc (4 + n) (S₊ (2 + n)))
    helper4 = subst (λ m → isConnected m (hLevelTrunc (4 + n) (S₊ (2 + n)))) (+-comm 3 n)
                    (isOfHLevelRetractFromIso 0 (invIso (truncOfTruncIso (3 + n) 1)) (sphereConnected (2 + n)))

    helper3 : isContr ∥ ∣ north ∣ ≡ ∣ north ∣ ∥₂
    helper3 = isOfHLevelRetractFromIso 0 setTruncTrunc2Iso
                                         (isConnectedPath 2 (isConnectedSubtr 3 n helper4) _ _)

-- --------------- H¹(Sⁿ), n ≥ 1 --------------------------------------------

H¹-Sⁿ≅0 : (n : ℕ) → GroupIso (coHomGr 1 (S₊ (2 + n))) trivialGroup
H¹-Sⁿ≅0 zero = IsoContrGroupTrivialGroup isContrH¹S²
  where
  isContrH¹S² : isContr ⟨ coHomGr 1 (S₊ 2) ⟩
  isContrH¹S² = ∣ (λ _ → ∣ base ∣) ∣₂
              , coHomPointedElim 0 north (λ _ → setTruncIsSet _ _)
                   λ f p → cong ∣_∣₂ (funExt λ x → sym p ∙∙ sym (spoke f north) ∙∙ spoke f x)
H¹-Sⁿ≅0 (suc n) = IsoContrGroupTrivialGroup isContrH¹S³⁺ⁿ
  where
  anIso : Iso ⟨ coHomGr 1 (S₊ (3 + n)) ⟩ ∥ (S₊ (3 + n) → hLevelTrunc (4 + n) (coHomK 1)) ∥₂
  anIso =
    setTruncIso
      (codomainIso
        (invIso (truncIdempotentIso (4 + n) (isOfHLevelPlus' {n = 1 + n} 3 (isOfHLevelTrunc 3)))))

  isContrH¹S³⁺ⁿ-ish : (f : (S₊ (3 + n) → hLevelTrunc (4 + n) (coHomK 1)))
                   → ∣ (λ _ → ∣ ∣ base ∣ ∣) ∣₂ ≡ ∣ f ∣₂
  isContrH¹S³⁺ⁿ-ish f = ind (f north) refl
    where
    ind : (x : hLevelTrunc (4 + n) (coHomK 1))
       → x ≡ f north
       → ∣ (λ _ → ∣ ∣ base ∣ ∣) ∣₂ ≡ ∣ f ∣₂
    ind = trElim (λ _ → isOfHLevelΠ (4 + n) λ _ → isOfHLevelPlus' {n = (3 + n)} 1 (setTruncIsSet _ _))
              (trElim (λ _ → isOfHLevelΠ 3 λ _ → isOfHLevelPlus {n = 1} 2 (setTruncIsSet _ _))
              (toPropElim (λ _ → isPropΠ λ _ → setTruncIsSet _ _)
              λ p → cong ∣_∣₂ (funExt λ x → p ∙∙ sym (spoke f north) ∙∙ spoke f x)))
  isContrH¹S³⁺ⁿ : isContr ⟨ coHomGr 1 (S₊ (3 + n)) ⟩
  isContrH¹S³⁺ⁿ =
    isOfHLevelRetractFromIso 0
      anIso
      (∣ (λ _ → ∣ ∣ base ∣ ∣) ∣₂
      , sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _) isContrH¹S³⁺ⁿ-ish)

--------- Direct proof of H¹(S¹) ≅ ℤ without Mayer-Vietoris -------

-- The strategy is to use the proof that ΩS¹ ≃ ℤ. Since we only have this for S¹ with the base/loop definition
-- we begin with some functions translating between H¹(S₊ 1) and ∥ S¹ → S¹ ∥₀.  The latter type is easy to characterise,
-- by (S¹ → S¹) ≃ S¹ × ℤ (see Cubical.ZCohomology.Groups.Prelims). Truncating this leaves only ℤ, since S¹ is connected.

-- The translation mentioned above uses the basechange function. We use basechange-lemma (Cubical.ZCohomology.Groups.Prelims) to prove the basechange2⁻ preserves
-- path composition (in a more general sense than what is proved in basechange2⁻-morph)

-- We can now give the group equivalence. The first bit is just a big composition of our previously defined translations and is pretty uninteresting.
-- The harder step is proving that the equivalence is a morphism. This relies heavily on the fact that addition the cohomology groups essentially is defined using an
-- application of cong₂, which allows us to use basechange-lemma.

coHom1S1≃ℤ : GroupIso (coHomGr 1 (S₊ 1)) intGroup
coHom1S1≃ℤ = theIso
  where
  F = Iso.fun S¹→S¹≡S¹×Int
  F⁻ = Iso.inv S¹→S¹≡S¹×Int

  theIso : GroupIso (coHomGr 1 (S₊ 1)) intGroup
  fun (map theIso) = sRec isSetInt (λ f → snd (F f))
  isHom (map theIso) = sElim2 (λ _ _ → isOfHLevelPath 2 isSetInt _ _)
                              λ f g → ((λ i → winding (guy (ΩKn+1→Kn 1 (Kn→ΩKn+1 1 (f base) ∙ Kn→ΩKn+1 1 (g base)))
                                              (λ i → S¹map (ΩKn+1→Kn 1 (Kn→ΩKn+1 1 (f (loop i)) ∙ Kn→ΩKn+1 1 (g (loop i))))))))
                                   ∙∙ cong winding (helper (f base) (g base) f g refl refl)
                                   ∙∙ winding-hom (guy (f base) (λ i → S¹map (f (loop i))))
                                                  (guy (g base) (λ i → S¹map (g (loop i))))
    where
    guy = basechange2⁻ ∘ S¹map

    helper : (x y : coHomK 1) (f g : S₊ 1 → coHomK 1)
           → (f base) ≡ x
           → (g base) ≡ y
           → (guy (ΩKn+1→Kn 1 (Kn→ΩKn+1 1 (f base) ∙ Kn→ΩKn+1 1 (g base)))
                   (λ i → S¹map ((ΩKn+1→Kn 1 (Kn→ΩKn+1 1 (f (loop i)) ∙ Kn→ΩKn+1 1 (g (loop i)))))))
             ≡ (guy (f base)
                    (λ i → S¹map (f (loop i))))
             ∙ (guy (g base)
                    (λ i → S¹map ((g (loop i)))))
    helper =
      elim2 (λ _ _ → isGroupoidΠ4 λ _ _ _ _ → isOfHLevelPath 3 (isOfHLevelSuc 3 (isGroupoidS¹) base base) _ _)
            (toPropElim2
              (λ _ _ → isPropΠ4 λ _ _ _ _ → isGroupoidS¹ _ _ _ _)
              λ f g reflf reflg →
              basechange-lemma base base
                (S¹map ∘ (ΩKn+1→Kn 1))
                ((Kn→ΩKn+1 1) ∘ f) ((Kn→ΩKn+1 1) ∘ g)
                (cong (Kn→ΩKn+1 1) reflf ∙ Kn→ΩKn+10ₖ 1) (cong (Kn→ΩKn+1 1) reflg ∙ Kn→ΩKn+10ₖ 1)
              ∙ λ j → guy (Iso.leftInv (Iso-Kn-ΩKn+1 1) (f base) j)
                          (λ i → S¹map (Iso.leftInv (Iso-Kn-ΩKn+1 1) (f (loop i)) j))
                    ∙ guy (Iso.leftInv (Iso-Kn-ΩKn+1 1) (g base) j)
                          (λ i → S¹map (Iso.leftInv (Iso-Kn-ΩKn+1 1) (g (loop i)) j)))
  inv theIso a = ∣ (F⁻ (base , a)) ∣₂
  rightInv theIso a = cong snd (Iso.rightInv S¹→S¹≡S¹×Int (base , a))
  leftInv theIso = sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                          λ f → cong ((sRec setTruncIsSet ∣_∣₂)
                                        ∘ sRec setTruncIsSet λ x → ∣ F⁻ (x , (snd (F f))) ∣₂)
                                      (Iso.inv PathIdTrunc₀Iso (isConnectedS¹ (fst (F f))))
                              ∙ cong ∣_∣₂ (Iso.leftInv S¹→S¹≡S¹×Int f)

---------------------------- Hⁿ(Sⁿ) ≅ ℤ , n ≥ 1 -------------------

Hⁿ-Sⁿ≅ℤ : (n : ℕ) → GroupIso intGroup (coHomGr (suc n) (S₊ (suc n)))
Hⁿ-Sⁿ≅ℤ zero = invGroupIso coHom1S1≃ℤ
Hⁿ-Sⁿ≅ℤ (suc n) =
    Hⁿ-Sⁿ≅ℤ n
  □ vSES→GroupIso _ _ theIso
  □ invGroupIso (coHomPushout≅coHomSn (suc n) (suc (suc n)))
  where
  module K = MV Unit Unit (S₊ (suc n)) (λ _ → tt) (λ _ → tt)
  theIso : vSES (coHomGr (suc n) (S₊ (suc n))) (coHomGr (suc (suc n))
                (Pushout {A = S₊ (suc n)} (λ _ → tt) (λ _ → tt)))
                _
                _
  isTrivialLeft theIso p q = ΣPathP (isOfHLevelSuc 0 (isContrHⁿ-Unit n) (fst p) (fst q)
                                        , isOfHLevelSuc 0 (isContrHⁿ-Unit n) (snd p) (snd q))
  isTrivialRight theIso p q = ΣPathP (isOfHLevelSuc 0 (isContrHⁿ-Unit (suc n)) (fst p) (fst q)
                                         , isOfHLevelSuc 0 (isContrHⁿ-Unit (suc n)) (snd p) (snd q))
  left theIso = K.Δ (suc n)
  right theIso = K.i (2 + n)
  vSES.ϕ theIso = K.d (suc n)
  Ker-ϕ⊂Im-left theIso = K.Ker-d⊂Im-Δ  (suc n)
  Ker-right⊂Im-ϕ theIso = K.Ker-i⊂Im-d (suc n)

{- More standard proof of H¹(S¹) ≅ ℤ using Mayer-Vietoris.
This is much slower than the direct proof, but let's keep it here for completeness.

-- --------------------------H¹(S¹) -----------------------------------
{-
In order to apply Mayer-Vietoris, we need the following lemma.
Given the following diagram
  a ↦ (a , 0)   ψ         ϕ
 A -->  A × A -------> B --->  C
If ψ is an isomorphism and ϕ is surjective with ker ϕ ≡ {ψ (a , a) ∣ a ∈ A}, then C ≅ B
-}

diagonalIso : ∀ {ℓ ℓ' ℓ''} {A : Group {ℓ}} (B : Group {ℓ'}) {C : Group {ℓ''}}
               (ψ : GroupIso (dirProd A A) B) (ϕ : GroupHom B C)
             → isSurjective _ _ ϕ
             → ((x : ⟨ B ⟩) → isInKer B C ϕ x
                                    → ∃[ y ∈ ⟨ A ⟩ ] x ≡ (fun (map ψ)) (y , y))
             → ((x : ⟨ B ⟩) → (∃[ y ∈ ⟨ A ⟩ ] x ≡ (fun (map ψ)) (y , y))
                                    → isInKer B C ϕ x)
             → GroupIso A C
diagonalIso {A = A} B {C = C} ψ ϕ issurj ker→diag diag→ker = BijectionIsoToGroupIso bijIso
  where
  open GroupStr
  module A = GroupStr (snd A)
  module B = GroupStr (snd B)
  module C = GroupStr (snd C)
  module A×A = GroupStr (snd (dirProd A A))
  module ψ = GroupIso ψ
  module ϕ = GroupHom ϕ
  ψ⁻ = inv ψ

  fstProj : GroupHom A (dirProd A A)
  fun fstProj a = a , GroupStr.0g (snd A)
  isHom fstProj g0 g1 i = (g0 A.+ g1) , GroupStr.lid (snd A) (GroupStr.0g (snd A)) (~ i)

  bijIso : BijectionIso A C
  map' bijIso = compGroupHom fstProj (compGroupHom (map ψ) ϕ)
  inj bijIso a inker = pRec (isSetCarrier A _ _)
                             (λ {(a' , id) → (cong fst (sym (leftInv ψ (a , GroupStr.0g (snd A))) ∙∙ cong ψ⁻ id ∙∙ leftInv ψ (a' , a')))
                                           ∙ cong snd (sym (leftInv ψ (a' , a')) ∙∙ cong ψ⁻ (sym id) ∙∙ leftInv ψ (a , GroupStr.0g (snd A)))})
                             (ker→diag _ inker)
  surj bijIso c =
    pRec propTruncIsProp
         (λ { (b , id) → ∣ (fst (ψ⁻ b) A.+ (A.- snd (ψ⁻ b)))
                          , ((sym (GroupStr.rid (snd C) _)
                           ∙∙ cong ((fun ϕ) ((fun (map ψ)) (fst (ψ⁻ b) A.+ (A.- snd (ψ⁻ b)) , GroupStr.0g (snd A))) C.+_)
                                  (sym (diag→ker (fun (map ψ) ((snd (ψ⁻ b)) , (snd (ψ⁻ b))))
                                                  ∣ (snd (ψ⁻ b)) , refl ∣₁))
                           ∙∙ sym ((isHom ϕ) _ _))
                           ∙∙ cong (fun ϕ) (sym ((isHom (map ψ)) _ _)
                                        ∙∙ cong (fun (map ψ)) (ΣPathP (sym (GroupStr.assoc (snd A) _ _ _)
                                                                           ∙∙ cong (fst (ψ⁻ b) A.+_) (GroupStr.invl (snd A) _)
                                                                           ∙∙ GroupStr.rid (snd A) _
                                                                        , (GroupStr.lid (snd A) _)))
                                        ∙∙ rightInv ψ b)
                           ∙∙ id) ∣₁ })
         (issurj c)

H¹-S¹≅ℤ : GroupIso intGroup (coHomGr 1 (S₊ 1))
H¹-S¹≅ℤ =
    diagonalIso (coHomGr 0 (S₊ 0))
                (invGroupIso H⁰-S⁰≅ℤ×ℤ)
                (K.d 0)
                (λ x → K.Ker-i⊂Im-d 0 x
                                     (ΣPathP (isOfHLevelSuc 0 (isContrHⁿ-Unit 0) _ _
                                            , isOfHLevelSuc 0 (isContrHⁿ-Unit 0) _ _)))
                ((sElim (λ _ → isOfHLevelΠ 2 λ _ → isOfHLevelSuc 1 propTruncIsProp)
                        (λ x inker
                            → pRec propTruncIsProp
                                    (λ {((f , g) , id') → helper x f g id' inker})
                                    ((K.Ker-d⊂Im-Δ 0 ∣ x ∣₂ inker)))))
                ((sElim (λ _ → isOfHLevelΠ 2 λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                         λ F surj
                           → pRec (setTruncIsSet _ _)
                                   (λ { (x , id) → K.Im-Δ⊂Ker-d 0 ∣ F ∣₂
                                                      ∣ (∣ (λ _ → x) ∣₂ , ∣ (λ _ → 0) ∣₂) ,
                                                       (cong ∣_∣₂ (funExt (surjHelper x))) ∙ sym id ∣₁ })
                                   surj) )
  □ invGroupIso (coHomPushout≅coHomSn 0 1)
  where
  module K = MV Unit Unit (S₊ 0) (λ _ → tt) (λ _ → tt)

  surjHelper :  (x : Int) (x₁ : S₊ 0) → x -[ 0 ]ₖ 0 ≡ S0→Int (x , x) x₁
  surjHelper x true = Iso.leftInv (Iso-Kn-ΩKn+1 0) x
  surjHelper x false = Iso.leftInv (Iso-Kn-ΩKn+1 0) x

  helper : (F : S₊ 0 → Int) (f g : ∥ (Unit → Int) ∥₂)
           (id : GroupHom.fun (K.Δ 0) (f , g) ≡ ∣ F ∣₂)
         → isInKer (coHomGr 0 (S₊ 0))
                    (coHomGr 1 (Pushout (λ _ → tt) (λ _ → tt)))
                    (K.d 0)
                    ∣ F ∣₂
         → ∃[ x ∈ Int ] ∣ F ∣₂ ≡ inv H⁰-S⁰≅ℤ×ℤ (x , x)
  helper F =
    sElim2 (λ _ _ → isOfHLevelΠ 2 λ _ → isOfHLevelΠ 2 λ _ → isOfHLevelSuc 1 propTruncIsProp)
           λ f g id inker
             → pRec propTruncIsProp
                     (λ ((a , b) , id2)
                        → sElim2 {C = λ f g → GroupHom.fun (K.Δ 0) (f , g) ≡ ∣ F ∣₂ → _ }
                                  (λ _ _ → isOfHLevelΠ 2 λ _ → isOfHLevelSuc 1 propTruncIsProp)
                                  (λ f g id → ∣ (helper2 f g .fst) , (sym id ∙ sym (helper2 f g .snd)) ∣₁)
                                  a b id2)
                     (MV.Ker-d⊂Im-Δ _ _ (S₊ 0) (λ _ → tt) (λ _ → tt) 0 ∣ F ∣₂ inker)
    where
    helper2 : (f g : Unit → Int)
            → Σ[ x ∈ Int ] (inv H⁰-S⁰≅ℤ×ℤ (x , x))
             ≡ GroupHom.fun (K.Δ 0) (∣ f ∣₂ , ∣ g ∣₂)
    helper2 f g = (f _ -[ 0 ]ₖ g _) , cong ∣_∣₂ (funExt λ {true → refl ; false → refl})

-}


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

open import PathInduction
open import Pushout

module JamesFirstComposite {i} (A : Type i) (⋆A : A) where

open import JamesTwoMaps A ⋆A

ap-from-αJ-δJ : (a : A) (x : JA) → ap from (ap (αJ a) (δJ x)) == ap (α∞ a) (δ∞ (from x))
ap-from-αJ-δJ a x = ap-from-αJ a (δJ x) ∙ ap (ap (α∞ a)) (δJ-β x)

ap-from-γ : (a : A) (x : JA) → ap from (γJ a x) == γ∞ a (from x)
ap-from-γ = λ a x → ap-!∙ from (ap (αJ a) (δJ x)) (δJ (αJ a x)) ∙ & coh (ap-from-αJ-δJ a x) (δJ-β (αJ a x))  module ApFromγ where

  coh : Coh ({A : Type i} {a b : A} {p p' : b == a} (p= : p == p') {c : A} {q q' : b == c} (q= : q == q') → ! p ∙ q == ! p' ∙ q')
  coh = path-induction

ap-from-η : (x : JA) → Square (ap (ap from) (ηJ x)) (ap-from-γ ⋆A x) idp (η∞ (from x))
ap-from-η x = & (η-ify-coh from) (ap-δJ (δJ x)) ∙□ & η-coh-homotopy from-δJ-δJ  where

  -- [ap] commutes with [ηIfy.coh]
  -- This lemma would also be true for arbitrary [αJ], [δJ], [α∞] and [δ∞], but for simplicity
  -- we do not abstract over them. We do abstract over [from] because otherwise Agda uses a
  -- crazy amount of memory.
  η-ify-coh : (from : JA → J∞A) → Coh ({a b : JA} {p : a == b} {c : JA} {q r : b == c} (sq : Square p p q r)
              → Square (ap (ap from) (& (ηIfy.coh αJ δJ) sq)) (ap-!∙ from q r) idp (& (ηIfy.coh α∞ δ∞) (ap-square from sq)))
  η-ify-coh = path-induction

  from-δJ-δJ : FlatCube (ap-square from (natural-square δJ (δJ x) (ap-idf (δJ x)) idp))
              (natural-square δ∞ (δ∞ (from x)) (ap-idf (δ∞ (from x))) idp)
              (δJ-β x)
              (δJ-β x)
              (ap-from-αJ-δJ ⋆A x)
              (δJ-β (αJ ⋆A x))
  from-δJ-δJ = adapt-flatcube ∙idp idp∙ idp∙ ∙idp
           (& (ap-square-natural-square from) (δJ x) δJ (& coh) ∙idp
           /∙³ & natural-square-homotopy (δJ-β) (δJ x)
           ∙fc & (natural-square-∘ (δJ x) from) δ∞ (& coh') idp
           /∙³ & natural-square= δ∞ (δJ-β x) (& ap2-idf) (& coh''))  where

    coh : {A B : Type i} {f : A → B} → Coh ({x y : A} {p : x == y} → ap-∘ f (λ z → z) p ∙ ap (ap f) (ap-idf p) == idp)
    coh = path-induction

    coh' : {A B : Type i} {f : A → B} → Coh ({x y : A} {p : x == y} → ∘-ap (λ z → z) f p ∙ idp == ap-idf _)
    coh' = path-induction

    coh'' : Coh ({A : Type i} {a b : A} {p : a == b} {c : A} {q : c == a} {d : A} {r : c == d}
                 → Square p (! q ∙ r) idp ((! r ∙ q) ∙ p))
    coh'' = path-induction

  -- If [sq] and [sq'] are equal (via a FlatCube), then applying [ηIfy.coh] to them give equal terms
  -- (via a Square).
  η-coh-homotopy : Coh ({a b : J∞A} {p : a == b} {c : J∞A} {q : b == c} {r : b == c} {sq : Square p p q r}
              {p' : a == b} {p= : p == p'} {q' : b == c} {q= : q == q'} {r' : b == c} {r= : r == r'}
              {sq' : Square p' p' q' r'} (cube : FlatCube sq sq' p= p= q= r=)
              → Square (& (ηIfy.coh α∞ δ∞) sq) (& ApFromγ.coh q= r=) idp (& (ηIfy.coh α∞ δ∞) sq'))
  η-coh-homotopy = path-induction

comp-square2 : Coh ({A : Type i} {a b : A} {p : a == b} {c : A} {q : b == c} → Square p idp q (p ∙ q))
comp-square2 = path-induction

ap-square-comp-square2 : {A B : Type i} (f : A → B) → Coh ({a b : A} {p : a == b} {c : A} {q : b == c}
                       → FlatCube (ap-square f (& comp-square2 {p = p} {q = q})) (& comp-square2) idp idp idp (ap-∙ f p q))
ap-square-comp-square2 f = path-induction

{- First composite -}

-- As for [inJ], we need both [from-inJ] and [from-inJS] for the termination checker
from-inJ : (n : ℕ) (x : J n) → from (inJ n x) == in∞ n x
from-inJS : (n : ℕ) (x : J (S n)) → from (inJS n x) == in∞ (S n) x

-- Those three describe [from ∘ inJS] applied to [ι], [α] and [β], in the case [S n] as it is
-- the only one we need.

from-inJSS-ι : (n : ℕ) (x : J (S n)) → from (inJS (S n) (ι (S n) x)) == in∞ (S (S n)) (ι (S n) x)
from-inJSS-ι n x = ap (α∞ ⋆A) (from-inJS n x) ∙ ap (in∞ (S (S n))) (β (S n) x)

from-inJSS-α : (n : ℕ) (a : A) (x : J (S n)) → from (inJS (S n) (α (S n) a x)) == in∞ (S (S n)) (α (S n) a x)
from-inJSS-α n a x = ap (α∞ a) (from-inJS n x)

from-inJSS-β : (n : ℕ) (x : J (S n)) → Square (ap from (ap (inJS (S n)) (β (S n) x))) (from-inJSS-α n ⋆A x) (from-inJSS-ι n x) (ap (in∞ (S (S n))) (β (S n) x))
from-inJSS-β n x = ap (ap from) (inJS-βS n x) |∙ comp-square

-- Those three terms describe what happens when we apply [from-inJS] to [ι], [α] or [β].
-- Note that the naming scheme is slightly ambiguous, they do *not* describe [from (inJS (ι _ _))] as above.
-- They are defined later, as we need to know the definition of [from-inJS].

from-inJS-ι : (n : ℕ) (x : J n) → Square (from-inJS n (ι n x)) (ap from (inJS-ι n x)) idp (ap (α∞ ⋆A) (from-inJ n x) ∙ ap (in∞ (S n)) (β n x))
from-inJS-α : (n : ℕ) (a : A) (x : J n) → Square (from-inJS n (α n a x)) (ap from (inJS-α n a x)) idp (ap (α∞ a) (from-inJ n x))
from-inJS-β : (n : ℕ) (x : J n) → Cube (natural-square (from-inJS n) (β n x) (ap-∘ from (inJS n) (β n x)) idp) (& comp-square2) (from-inJS-α n ⋆A x) (ap-square from (inJS-β n x)) hid-square (from-inJS-ι n x)

-- The following three terms show that the two ways of reducing [from ∘ inJS (S n) ∘ (ι (S n) | α (S n) a) ∘ (ι n | α n a)]
-- are equal. For some reason, we don’t need it with α twice

side1 : (n : ℕ) (a : A) (x : J n) → ap (α∞ a) (ap from (inJS-ι n x)) ∙
                                    ap (α∞ a) (ap (α∞ ⋆A) (from-inJ n x)) ∙
                                    ap (in∞ (S (S n))) (ap (α (S n) a) (β n x))
                                    == from-inJSS-α n a (ι n x)
side1 n = λ a x → & coh (ap-∙ _ _ _) (ap-square (α∞ a) (from-inJS-ι n x)) (ap-α∞-in∞ (S n) a (β n x))  module Side1 where

  coh : Coh ({A : Type i} {a c : A} {q : a == c} {d : A} {s1 : c == d} {b : A} {s2 : d == b} {s : c == b} (s= : s == s1 ∙ s2)
             {p : a == b} (sq : Square p q idp s) {s2' : d == b} (s2= : s2 == s2')
            → q ∙ s1 ∙ s2' == p)
  coh = path-induction

side2 : (n : ℕ) (a : A) (x : J n) → ap (α∞ ⋆A) (ap from (inJS-α n a x)) ∙
                                    ap (α∞ ⋆A) (ap (α∞ a) (from-inJ n x)) ∙
                                    ap (in∞ (S (S n))) (β (S n) (α n a x))
                                    == from-inJSS-ι n (α n a x)
side2 n = λ a x → & coh (ap-square (α∞ ⋆A) (from-inJS-α n a x))  module Side2 where

  coh : Coh ({A : Type i} {a b : A} {p : a == b} {c : A} {q : a == c} {s : c == b} (sq : Square p q idp s) {e : A} {t : b == e}
            → q ∙ s ∙ t == p ∙ t)
  coh = path-induction

side3 : (n : ℕ) (x : J n) → ap (α∞ ⋆A) (ap from (inJS-ι n x)) ∙
                            ap (α∞ ⋆A) (ap (α∞ ⋆A) (from-inJ n x)) ∙
                            ap (in∞ (S (S n))) (β (S n) (α n ⋆A x)) ∙
                            ap (in∞ (S (S n))) (ap (ι (S n)) (β n x))
                            == from-inJSS-ι n (ι n x)
side3 n = λ x → & coh (ap-∙ _ _ _) (ap-α∞-in∞ (S n) ⋆A (β n x)) (ap-square (α∞ ⋆A) (from-inJS-ι n x))
                      (ap-square (in∞ (S (S n))) (natural-square (β (S n)) (β n x) idp idp))  module Side3 where

  coh : Coh ({A : Type i} {a c : A} {q : a == c} {d : A} {s : c == d} {b : A} {r : d == b} {rs : c == b} (rs= : rs == s ∙ r)
             {r' : d == b} (r= : r == r') {p : a == b} (sq : Square p q idp rs)
             {e : A} {t : d == e} {f : A} {u : e == f} {v : b == f} (sq2 : Square t r' u v)
            → q ∙ s ∙ t ∙ u == p ∙ v)
  coh = path-induction

piece1 : (n : ℕ) (a : A) (x : J n) → Square (ap from (ap (inJS (S n)) (γ n a x)))
                                            (ap (α∞ a) (ap from (inJS-ι n x)))
                                            (ap (α∞ ⋆A) (ap from (inJS-α n a x)))
                                            (ap from (γJ a (inJ n x)))
piece1 n a x = adapt-square (ap-square from (inJSS-γ n a x)) (ap-from-αJ a (inJS-ι n x)) (ap-from-αJ ⋆A (inJS-α n a x))

from-inJSS-γ : (n : ℕ) (a : A) (x : J n) → Square (ap from (ap (inJS (S n)) (γ n a x))) (from-inJSS-α n a (ι n x)) (from-inJSS-ι n (α n a x)) (ap (in∞ (S (S n))) (γ n a x))
from-inJSS-γ n a x = adapt-square (piece1 n a x
                                  ∙□ ap-from-γ a (inJ n x)
                                  |∙ natural-square (γ∞ a) (from-inJ n x) (ap-∘ (α∞ a) (α∞ ⋆A) (from-inJ n x)) (ap-∘ (α∞ ⋆A) (α∞ a) (from-inJ n x))
                                  ∙□ γ∞-in a n x)
                                  (side1 n a x) (side2 n a x)

adapt-eq : Coh ({A : Type i} {a b : A} {q : a == b} {sq : Square idp q q idp} (sq= : sq == vid-square) {q' : a == b} {p : q == q'} → adapt-square sq p p == vid-square)
adapt-eq = path-induction

natural-square-idp : {A B : Type i} {f : A → B} {x y : A} {p : x == y} {fp : f x == f y} {fp= : ap f p == fp} → natural-square (λ a → idp {a = f a}) p fp= fp= == vid-square
natural-square-idp {p = idp} {fp= = idp} = idp

vid-square∙□vid-square∙□vid-square : Coh ({A : Type i} {a b : A} {p : a == b} {c : A} {q : b == c} {d : A} {r : c == d} → vid-square {p = p} ∙□ vid-square {p = q} ∙□ vid-square {p = r} == vid-square {p = p ∙ q ∙ r})
vid-square∙□vid-square∙□vid-square = path-induction

adapt-square-natural-square : ∀ {i j} {A : Type i} {B : Type j} → Coh ({f g : A → B} {h : (a : A) → f a == g a}
                                {x y : A} {p : x == y} {pf' : f x == f y} {q : ap f p == pf'} {pg' : g x == g y} {r : ap g p == pg'}
                              → adapt-square (natural-square h p idp idp) q r == natural-square h p q r)
adapt-square-natural-square = path-induction

piece1-η : (n : ℕ) (x : J n) → Cube (ap-square from (ap-square (inJS (S n)) (η n x)))
                                    (horiz-degen-square (ap (ap from) (ηJ (inJ n x))))
                                    (piece1 n ⋆A x) vid-square _ _
piece1-η n x = & (ap-shapeInJSη from) {to = ηJ (inJ n x)} (inJSS-η n x) (ap-from-αJ ⋆A (inJS-α n ⋆A x)) (ap-from-αJ ⋆A (inJS-ι n x))

coh-blip : {A B : Type i} {a b : A} (p : a == b)
       → Coh ({f g : A → B} {k : (a : A) → f a == g a} {h : A → B} {l : (a : A) → g a == h a}
              {fp : _} {fp= : ap f p == fp}
              {gp : _} (gp= : ap g p == gp)
              {hp : _} {hp= : ap h p == hp}
             → square-symmetry (natural-square (λ x → k x ∙ l x) p fp= hp=) == square-symmetry (natural-square k p fp= gp=) ∙□ square-symmetry (natural-square l p gp= hp=))
coh-blip {a = a} idp = path-induction

ap-square-hid : {A B : Type i} {f : A → B} {x y : A} {p : x == y} → ap-square f (hid-square {p = p}) == hid-square
ap-square-hid {p = idp} = idp

from-inJSS-η : (n : ℕ) (x : J n) → Cube (ap-square from (ap-square (inJS (S n)) (η n x)))
                                        (ap-square (in∞ (S (S n))) (η n x))
                                        (from-inJSS-γ n ⋆A x)
                                        vid-square
                                        (square-symmetry (natural-square (from-inJSS-ι n) (β n x) (ap-∘ _ _ _ ∙ ap-∘ _ _ _) (ap-∘ _ _ _)))
                                        (from-inJSS-β n (ι n x))
from-inJSS-η n x =
  adapt-cube (piece1-η n x
             ∙³x  ap-from-η (inJ n x)
             -|∙³ natural-cube-η∞ η∞ (from-inJ n x)
             ∙³x  η∞-in n x)
    (side1 n ⋆A x) (side2 n ⋆A x) (side1 n ⋆A x) (side3 n x)
    idp
    (& adapt-eq (& vid-square∙□vid-square∙□vid-square))
    (& coh4 (ap-square-from-αJ ⋆A (inJS-β n x)) (& (ap-square-comp-square2 (α∞ ⋆A))) ap-square-hid (ap-cube (α∞ ⋆A) (from-inJS-β n x))
            eq1
            eq2
      ∙ ! (& (coh-blip (β n x)) (ap-∘ (in∞ (S (S n))) (α (S n) ⋆A) (β n x))))
    (& coh (ap (ap from) (inJS-βS n (ι n x))))  where

  coh : {A : Type i} {a : A} → Coh ({p : a == a} (sq : p == idp) {b : A} {s : a == b}
        {c : A} {q : b == c} {d : A} {u u'' : c == d} {u= : u'' == u} {u' : b == d} {u'= : u' == q ∙ u''}
        {e : A} {t : c == e} {f : A} {v : e == f} {w : d == f} {ββ : Square t u v w} {k : a == d} {X : Square k s idp u'}
      → adapt-square ((sq |∙ vid-square {p = s}) ∙□ idp |∙ vid-square {p = q} ∙□ skew ββ) (& (Side1.coh n) u'= X u=) (& (Side3.coh n) u'= u= X ββ)
        == sq |∙ comp-square)
  coh = path-induction

  eq1 : natural-square (λ a₁ → ap (α∞ ⋆A) (from-inJS n a₁)) (β n x)
           (ap-∘ (from ∘ inJS (S n)) inr (β n x) ∙
            ap-∘ from (inJS (S n)) (ap inr (β n x)))
           (ap-∘ (in∞ (S (S n))) (α (S n) ⋆A) (β n x))
         == adapt-square (ap-square (α∞ ⋆A) (natural-square (from-inJS n) (β n x) (ap-∘ from (inJS n) (β n x)) idp)) (! (ap-from-αJ ⋆A (ap (inJS n) (β n x))) ∙ ! (ap (ap from) (ap-inJSS-ι n (β n x)))) (ap-α∞-in∞ (S n) ⋆A (β n x))
  eq1 = & (natural-square-ap (α∞ ⋆A)) (β n x) (from-inJS n) (coh' (β n x)) (coh'' (β n x))  where

    coh' : {x y : _} (p : x == y)
         → Square (∘-ap (α∞ ⋆A) (λ z → from (inJS n z)) p)
                  (ap (ap (α∞ ⋆A)) (ap-∘ from (inJS n) p))
                  (ap-∘ (from ∘ inJS (S n)) inr p
                    ∙ ap-∘ from (inJS (S n)) (ap inr p))
                  (! (ap-from-αJ ⋆A (ap (inJS n) p))
                    ∙ ! (ap (ap from) (ap-inJSS-ι n p)))
    coh' idp = ids

    coh'' : {x y : _} (p : x == y)
          → Square (∘-ap (α∞ ⋆A) (λ z → in∞ (S n) z) p)
                   idp
                   (ap-∘ (in∞ (S (S n))) (α (S n) ⋆A) p)
                   (ap-α∞-in∞ (S n) ⋆A p)
    coh'' idp = ids

  eq2 : ap-square (in∞ (S (S n))) (natural-square (β (S n)) (β n x) idp idp)
         == natural-square (λ a₁ → ap (in∞ (S (S n))) (β (S n) a₁)) (β n x)
                           (ap-∘ (in∞ (S (S n))) (α (S n) ⋆A) (β n x))
                           (ap-∘ (in∞ (S (S n))) inr (β n x))
  eq2 = & (ap-square-natural-square (in∞ (S (S n)))) (β n x) (β (S n)) ∙idp ∙idp

  coh4 : Coh ({A : Type i} {a b : A} {p : a == b} {c : A} {q q'' : a == c} {q''= : q'' == q} {q' : a == c}
         {q'= : q' == q''} {d : A} {r r' : b == d} {r= : r == r'}
         {s : c == d} {sq1 : Square p q r s} {e : A} {t : b == e} {f : A} {u : e == f} {v : d == f}
         {sqββ : Square t r' u v} {g : A} {k k' : a == g} {k= : k == k'} {l : c == g}
         {sq2 : Square q'' k l idp} {l' : c == g} {l= : l == l'} {u : g == b} {sqα : Square p k' idp u}
         {ur : g == d} {ur= : ur == u ∙ r} {sq3 : Square q k' l' idp}
         (cube-right : FlatCube sq2 sq3 q''= k= l= idp)
         {comp-square2' : _} (comp-square2'= : FlatCube comp-square2' (& comp-square2) idp idp idp ur=)
         {hid' : _} (hid'= : hid' == hid-square)
         {sqι : Square s l' idp ur} (cube-left : Cube sq1 comp-square2' sqα sq3 hid' sqι)
         {sqx : _} (eq1 : sqx == adapt-square sq1 (! q''= ∙ ! q'=) r=)
         {sqy : _} (eq2 : sqββ == sqy)
       → adapt-square (adapt-square (q'= |∙ sq2) k= l= ∙□ vid-square {p = u} ∙□ comp-square) (& (Side2.coh n) sqα) (& (Side3.coh n) ur= r= sqι sqββ)
         == square-symmetry sqx ∙□ square-symmetry sqy)
  coh4 = path-induction

from-inJ O ε = idp
from-inJ (S n) x = from-inJS n x

hdpssvs : Coh ({A : Type i} {x y : A} {p : x == y} → idp == horiz-degen-path (square-symmetry (vid-square {p = p})))
hdpssvs = path-induction

from-inJS O a = idp
from-inJS (S n) =
  JSS-elim n (from-inJSS-ι n)
             (from-inJSS-α n)
             (λ x   → ↓-='-from-square (ap-∘ from (inJS (S n)) (β (S n) x)) idp (square-symmetry (from-inJSS-β n x)))
             (λ a x → ↓-='-from-square (ap-∘ from (inJS (S n)) (γ n a x))   idp (square-symmetry (from-inJSS-γ n a x)))
             (λ x → cube-to-↓-square (from-inJSS-γ n ⋆A x)
                                     (& hdpssvs)
                                     (↓-ap-in-=' (ι (S n)) (from-inJSS-ι n))
                                     (from-inJSS-β n (ι n x))
                                     (ap-square-∘ from (inJS (S n)) (η n x) |∙³ from-inJSS-η n x))

from-inJS-ι O ε = ids
from-inJS-ι (S n) x = hid-square

from-inJS-α O a ε = ids
from-inJS-α (S n) a x = hid-square

from-inJS-β O ε = idc
from-inJS-β (S n) x = & coh (ap-square-horiz-degen-square (inJS-βS n x))
                            (natural-square-β (from-inJS (S n)) (β (S n) x) (push-βd _)) where

  coh : Coh ({A : Type i} {a b : A} {p : a == b} {q : a == a} {k : q == idp}
             {k' : Square q idp idp idp} (k= : k' == horiz-degen-square k)
             {c : A} {r : b == c} {sq : Square p q r (p ∙ r)} → sq == square-symmetry (k |∙ comp-square)
        → Cube sq (& comp-square2) hid-square k' hid-square hid-square)
  coh = path-induction

from-pushJ : (n : ℕ) (x : J n) → Square (ap from (pushJ n x)) (from-inJ n x) (from-inJ (S n) (ι n x)) (push∞ n x)
from-pushJ n x = & coh (δJ-β (inJ n x)) (ap from (inJS-ι n x)) (ap-∙! from _ _)
                       (natural-square δ∞ (from-inJ n x) (ap-idf (from-inJ n x)) idp) (from-inJS-ι n x)  where

  coh : Coh ({A : Type i} {a d : A} {p p' : a == d} (p= : p == p')
             {b : A} (q : b == d) {pq : a == b} (pq= : pq == p ∙ ! q)
             {c : A} {r : a == c} {f : A} {u : c == f} {e : A} {v : e == f}
             {s : d == e} (sq : Square p' r s (u ∙ ! v)) {t : b == f} (sq2 : Square t q idp (s ∙ v))
            → Square pq r t u)
  coh = path-induction

from-to : (x : J∞A) → from (to x) == x
from-to = J∞A-elim from-inJ (λ n x → ↓-='-from-square (ap-∘ from to (push∞ n x) ∙ ap (ap from) (push∞-β n x)) (ap-idf (push∞ n x)) (square-symmetry (from-pushJ n x)))


-- Andreas, 2011-05-10
-- {-# OPTIONS -v tc.term.con:20 -v tc.meta:20 #-}
module Issue380 where

data _==_ {A : Set}(a : A) : A -> Set where
  refl : a == a

record Sigma (A : Set)(B : A -> Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B fst
open Sigma public

testProj : {A : Set}{B : A -> Set}(y z : Sigma A B) ->
  let X : Sigma A B
      X = _
  in fst X == fst y -> snd X == snd z
testProj y z = refl , refl
{-  OLD BEHAVIOR: Error message about telescope comparison unreadable
This ill-typed term produces a weird error message:
(z' : fst (fst z , _283 y z) == fst y) !=<
when checking that the expression refl , refl has type
fst (fst z , _283 y z) == fst y → snd (fst z , _283 y z) == snd z
-}
{- FIXED.  Now it should complain that
Sigma (_47 y z == _47 y z) (_45 y z) !=<
fst (fst z , _43 y z) == fst y → snd (fst z , _43 y z) == snd z
when checking that the expression refl , refl has type
fst (fst z , _43 y z) == fst y → snd (fst z , _43 y z) == snd z
-}


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

open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; sym; cong; cong₂; subst; trans)
open import Relation.Nullary.Decidable using (True; from-yes)
open import Relation.Nullary.Negation using (¬?; contradiction)
open Relation.Binary.PropositionalEquality.≡-Reasoning
open import Function using (_∘_)
open import Relation.Nullary using (yes; no)

open import Data.Empty using (⊥)
open import Data.Product using (_×_; _,_; Σ-syntax; proj₁; proj₂)
open import Data.Fin.Base as Fin using (Fin; zero; suc)
open import Data.Unit using (⊤; tt)

open import Data.List.Base as List using (List; []; _∷_; [_])
import Data.List.Properties as Listₚ
import Data.Char.Properties as Charₚ
import Data.Digit as Digit
import Data.List.Membership.Propositional as ∈ₗ
import Data.List.Membership.Propositional.Properties as ∈ₗₚ
open import Data.Nat.Base as ℕ using (ℕ; zero; suc)
import Data.Nat.Properties as ℕₚ
import Data.Nat.Show as ℕₛ
import Data.Nat.Show.Properties as ℕₛₚ
open import Data.String.Base as String using (String)
import Data.Product.Properties as Productₚ
open import Data.Vec.Base as Vec using ([]; _∷_; Vec)
import Data.Vec.Properties as Vecₚ
open import Data.Vec.Relation.Unary.Any as Any using (here; there)
import Data.Vec.Membership.Propositional as ∈ᵥ
import Data.Vec.Membership.Propositional.Properties as ∈ᵥₚ

open import PiCalculus.Syntax
open Raw
open Scoped
open Conversion

open import PiCalculus.Utils

module PiCalculus.Syntax.Properties where

module _ where
  private
    variable
      n : ℕ
      P Q R S : Scoped n
      x y : Fin n
      namex namey : Name

  fromName∘toName : (i : Fin n) (ctx : Ctx n) → ∈toFin (∈ᵥₚ.∈-lookup i ctx) ≡ i
  fromName∘toName zero (x ∷ ctx) = refl
  fromName∘toName (suc i) (x ∷ ctx) rewrite fromName∘toName i ctx = refl

  toName∘fromName : ∀ {x} {ctx : Ctx n} (x∈ctx : x ∈ᵥ.∈ ctx) → Vec.lookup ctx (∈toFin x∈ctx) ≡ x
  toName∘fromName (here px) = sym px
  toName∘fromName (there x∈ctx) = toName∘fromName x∈ctx

  -- The circum (^) is not a decimal character
  ^∉DECIMALS : '^' ∈ᵥ.∉ Digit.digitChars
  ^∉DECIMALS = from-yes (¬? (Any.any? ('^' Charₚ.≟_) Digit.digitChars))

  module _ (base : ℕ) {2≤base : True (2 ℕₚ.≤? base)} {base≤16 : True (base ℕₚ.≤? 16)} where
    charsInBase∈digitChars : ∀ n c → c ∈ₗ.∈ ℕₛ.charsInBase base {2≤base} {base≤16} n → c ∈ᵥ.∈ Digit.digitChars
    charsInBase∈digitChars n c i with ∈ₗₚ.∈-map⁻ Digit.showDigit i
    charsInBase∈digitChars n c i | d , _ , refl = ∈ᵥₚ.∈-lookup (Fin.inject≤ d _) Digit.digitChars

  -- In <name>^<natural> the <natural> does not contain ^, therefore toChars is injective
  toChars-injective : (x y : Name × ℕ) → toChars x ≡ toChars y → x ≡ y
  toChars-injective (nx , cx) (ny , cy) eq = cong₂ _,_ cancel-names (ℕₛₚ.charsInBase-injective 10 cx cy count-repr)
    where
      count-repr = ListInv.inv-++ʳ nx ny '^'
                                   (^∉DECIMALS ∘ charsInBase∈digitChars 10 cx '^')
                                   (^∉DECIMALS ∘ charsInBase∈digitChars 10 cy '^')
                                   eq
      cancel-names = Listₚ.++-cancelʳ nx ny
                                      (subst (λ ● → nx List.++ ('^' ∷ ●) ≡ _)
                                            count-repr eq)

  -- A fresh variable name created from inspecting a context cannot be in that context
  fresh-∉' : ∀ m name (xs : Ctx n) → toChars (name , m ℕ.+ (count name xs)) ∈ᵥ.∉ apply xs
  fresh-∉' m name (x ∷ xs) (here seq) with Listₚ.≡-dec Charₚ._≟_ name x
  fresh-∉' m name (x ∷ xs) (here seq) | yes refl = ℕₚ.m≢1+n+m _ (begin
    count name xs
      ≡˘⟨ Productₚ.,-injectiveʳ (toChars-injective (name , m ℕ.+ suc (count name xs)) (name , count name xs) seq) ⟩
    m ℕ.+ suc (count name xs)
      ≡⟨ ℕₚ.+-suc m _ ⟩
    suc m ℕ.+ count name xs
      ∎)
  fresh-∉' m name (x ∷ xs) (here seq) | no ¬q = contradiction
    (Productₚ.,-injectiveˡ (toChars-injective (name , m ℕ.+ count name xs) (x , count x xs) seq)) ¬q
  fresh-∉' m name (x ∷ xs) (there ∈ps) with Listₚ.≡-dec Charₚ._≟_ name x
  fresh-∉' m name (x ∷ xs) (there ∈ps) | yes refl rewrite ℕₚ.+-suc m (count name xs) = fresh-∉' (suc m) name _ ∈ps
  fresh-∉' m name (x ∷ xs) (there ∈ps) | no ¬q = fresh-∉' m name _ ∈ps

  fresh-∉ : ∀ name (xs : Ctx n) → toChars (name , count name xs) ∈ᵥ.∉ apply xs
  fresh-∉ name xs = fresh-∉' zero name xs

  -- Translating from de Bruijn to names results in a well-scoped process

  toRaw-WellScoped : (ctx : Ctx n) (P : Scoped n) → WellScoped (apply ctx) (toRaw ctx P)
  toRaw-WellScoped ctx 𝟘 = tt
  toRaw-WellScoped ctx (ν P ⦃ name ⦄) = toRaw-WellScoped (name ∷ ctx) P
  toRaw-WellScoped ctx (P ∥ Q) = toRaw-WellScoped ctx P , toRaw-WellScoped ctx Q
  toRaw-WellScoped ctx ((x ⦅⦆ P) ⦃ name ⦄) = ∈ᵥₚ.∈-lookup _ _ , toRaw-WellScoped (name ∷ ctx) P
  toRaw-WellScoped ctx (x ⟨ y ⟩ P) = ∈ᵥₚ.∈-lookup _ _ , ∈ᵥₚ.∈-lookup _ _ , toRaw-WellScoped ctx P

  -- Translating from de Bruijn to names results in no shadowed variables

  toRaw-NotShadowed : (ctx : Ctx n) (P : Scoped n) → NotShadowed (apply ctx) (toRaw ctx P)
  toRaw-NotShadowed ctx 𝟘 = tt
  toRaw-NotShadowed ctx (ν P ⦃ name ⦄) = fresh-∉ name ctx , (toRaw-NotShadowed (_ ∷ ctx) P)
  toRaw-NotShadowed ctx (P ∥ Q) = toRaw-NotShadowed ctx P , toRaw-NotShadowed ctx Q
  toRaw-NotShadowed ctx ((x ⦅⦆ P) ⦃ name ⦄) = fresh-∉ name ctx , toRaw-NotShadowed (name ∷ ctx) P
  toRaw-NotShadowed ctx (x ⟨ y ⟩ P) = toRaw-NotShadowed ctx P

  -- Translating from de Bruijn to names and back results in the same process modulo name hints

  data _α-≡_ {n} : Scoped n → Scoped n → Set where
    inaction : 𝟘 α-≡ 𝟘
    scope    : P α-≡ Q → ν P ⦃ namex ⦄ α-≡ ν Q ⦃ namey ⦄
    comp     : P α-≡ Q → R α-≡ S → (P ∥ R) α-≡ (Q ∥ S)
    input    : P α-≡ Q → (x ⦅⦆ P) ⦃ namex ⦄ α-≡ (x ⦅⦆ Q) ⦃ namey ⦄
    output   : P α-≡ Q → (x ⟨ y ⟩ P) α-≡ (x ⟨ y ⟩ Q)

  fromRaw∘toRaw : (ctx : Ctx n) (P : Scoped n)
                → fromRaw' (apply ctx) (toRaw ctx P) (toRaw-WellScoped ctx P) α-≡ P
  fromRaw∘toRaw ctx 𝟘 = inaction
  fromRaw∘toRaw ctx (ν P ⦃ name ⦄) =
    scope (fromRaw∘toRaw (name ∷ ctx) P)
  fromRaw∘toRaw ctx (P ∥ Q) =
    comp (fromRaw∘toRaw ctx P) (fromRaw∘toRaw ctx Q)
  fromRaw∘toRaw ctx ((x ⦅⦆ P) ⦃ name ⦄)
    rewrite fromName∘toName x (apply ctx) =
    input (fromRaw∘toRaw (name ∷ ctx) P)
  fromRaw∘toRaw ctx (x ⟨ y ⟩ P)
    rewrite fromName∘toName x (apply ctx) | fromName∘toName y (apply ctx) =
    output (fromRaw∘toRaw ctx P)

module _ where
  private
    variable
      n : ℕ
      P Q R S : Raw
      x y w z : Name
      ks vs : Ctx n

  _∈²_ : ∀ {n} → (Name × Name) → (Ctx n × Ctx n) → Set
  (x , y ) ∈² (xs , ys) = Σ[ i ∈ Fin _ ] (Vec.lookup xs i ≡ x × Vec.lookup ys i ≡ y)

  infix 5 _α[_↦_]≡_
  data _α[_↦_]≡_ : Raw → ∀ {n} → Ctx n → Ctx n → Raw → Set where
    inaction : 𝟘 α[ ks ↦ vs ]≡ 𝟘
    scope    : P α[ x ∷ ks ↦ y ∷ vs ]≡ Q
             → ⦅ν x ⦆ P α[ ks ↦ vs ]≡ ⦅ν y ⦆ Q
    comp     : P α[ ks ↦ vs ]≡ Q
             → R α[ ks ↦ vs ]≡ S
             → P ∥ R α[ ks ↦ vs ]≡ Q ∥ S
    input    : (x , y) ∈² (ks , vs)
             → P α[ w ∷ ks ↦ z ∷ vs ]≡ Q
             → x ⦅ w ⦆ P α[ ks ↦ vs ]≡ y ⦅ z ⦆ Q
    output   : (x , y) ∈² (ks , vs)
             → (w , z) ∈² (ks , vs)
             → P α[ ks ↦ vs ]≡ Q
             → x ⟨ w ⟩ P α[ ks ↦ vs ]≡ (y ⟨ z ⟩ Q)

  -- Translating a well-scoped process to de Bruijn and back results in the same process
  -- modulo alpha renaming, where the new names in `apply isf` map to the old in `ctx`

  toRaw∘fromRaw : (ctx : Ctx n) (P : Raw) (wsP : WellScoped ctx P)
                → toRaw ctx (fromRaw' ctx P wsP) α[ apply ctx ↦ ctx ]≡ P
  toRaw∘fromRaw ctx 𝟘 wsP = inaction
  toRaw∘fromRaw ctx (⦅ν x ⦆ P) wsP
    = scope (toRaw∘fromRaw (x ∷ ctx) P wsP)
  toRaw∘fromRaw ctx (P ∥ Q) (wsP , wsQ)
    = comp (toRaw∘fromRaw ctx P wsP)
           (toRaw∘fromRaw ctx Q wsQ)
  toRaw∘fromRaw ctx (x ⦅ y ⦆ P) (x∈ctx , wsP)
    = input (_ , refl , toName∘fromName x∈ctx)
            (toRaw∘fromRaw (y ∷ ctx) P wsP)
  toRaw∘fromRaw ctx (x ⟨ y ⟩ P) (x∈ctx , y∈ctx , wsP)
    = output (_ , refl , toName∘fromName x∈ctx)
             (_ , refl , toName∘fromName y∈ctx)
             (toRaw∘fromRaw ctx P wsP)


module test.IntegerOverflow where

open import Type
open import Declarative
open import Builtin
open import Builtin.Constant.Type
open import Builtin.Constant.Term Ctx⋆ Kind * # _⊢⋆_ con size⋆
open import Agda.Builtin.Sigma
open import Data.Integer
open import Data.Nat
open import Data.Empty

-- zerepoch/zerepoch-core/test/data/integerOverflow.plc

-- This term is impossible as terms are intrinsically sized

-- completeting this definition requires an element of the empty type
{-
intOverflow : ∀{Γ} → Γ ⊢ con integer (size⋆ 1)
intOverflow = con (integer 1 (ℤ.pos 128) (-≤+ Σ., +≤+ (gen _ _ {!!})))
-}


{-# OPTIONS --prop #-}

open import Agda.Primitive
open import Agda.Builtin.Equality
open import Agda.Builtin.List
open import Agda.Builtin.Reflection

macro
  doQuote : ∀ {ℓ} {A : Set ℓ} → A → Term → TC _
  doQuote x hole = bindTC (quoteTC x) (λ qx → bindTC (quoteTC qx) (unify hole))

testQuote₁ : doQuote Prop ≡ agda-sort (propLit 0)
testQuote₁ = refl

testQuote₂ : ∀ {ℓ} → doQuote (Prop ℓ) ≡ agda-sort (prop (var 0 []))
testQuote₂ = refl

macro
  doUnquote : Term → Term → TC _
  doUnquote t hole = bindTC (unquoteTC t) (unify hole)

testUnquote₁ : doUnquote (agda-sort (propLit 0)) ≡ Prop
testUnquote₁ = refl

testUnquote₂ : ∀ {ℓ} → doUnquote (agda-sort (prop (var 0 []))) ≡ Prop ℓ
testUnquote₂ = refl


{-# OPTIONS --copatterns --sized-types #-}

module SDE where

open import Size
open import Function
open import Data.Product as Prod renaming (Σ to ⨿)
open import Data.Sum as Sum

open import Streams

-- | Signatures
record Sig : Set₁ where
  field
    ∥_∥ : Set
    ar : ∥_∥ → Set
open Sig public

-- | Extension of signature Σ, on objects
⟪_⟫ : Sig → Set → Set
⟪ Σ ⟫ X = ⨿ ∥ Σ ∥ λ f → (ar Σ f → X)

-- | Extension of signature Σ, on morphisms
⟪_⟫₁ : (Σ : Sig) {A B : Set} → (A → B) → ⟪ Σ ⟫ A → ⟪ Σ ⟫ B
⟪_⟫₁ Σ f (s , α) = (s , f ∘ α)

-- | Terms over a given signature together with some basic operations.
module Terms (Σ : Sig) where

  -- | Terms built from the signature Σ with variables in V.
  data T (V : Set) : Set where
    sup : ⟪ Σ ⟫ (T V) ⊎ V → T V

  -- | Recursion on terms.
  rec : ∀{V X} → (f : ⟪ Σ ⟫ X ⊎ V → X) → T V → X
  rec f (sup (inj₁ (s , α))) = f (inj₁ (s , λ i → rec f (α i)))
  rec f (sup (inj₂ y))       = f (inj₂ y)

  -- | Functor T, on morphisms
  T₁ : ∀ {V W} → (V → W) → T V → T W
  T₁ f = rec (sup ∘ Sum.map id f)

  -- | Injection of variables into terms.
  η : ∀{V} → V → T V
  η = sup ∘ inj₂

-- | Interpretation of SDEs that use the given signature and set of variables.
module SDE-Impl (Σ : Sig) (X : Set) where

  open Terms Σ

  -- | Variables for streams and their derivatives.
  V : Set
  V = X ⊎ X

  -- | An SDE consists of an assignment of outputs and terms for
  -- each symbol in the signature. Note that both output and the
  -- terms may depend on the outputs of the arguments of the corresponding
  -- symbol.
  SDE : Set → Set
  SDE A = (f : ∥ Σ ∥) → ((ar Σ f → A) → A) × ((ar Σ f → A) → T V)

  -- | Interpretation of terms over the symbols defined by the given SDE
  -- as streams.
  ⟦_⟧₁ : ∀ {A} → SDE A → ((f : ∥ Σ ∥) → ar Σ f → X) → T V →
         ∀{i} → (X → Stream {i} A) → ∀ {j : Size< i} → Stream {j} A

  -- | Interpretation of symbols defined by the given SDE as streams.
  ⟦_⟧ : ∀ {A} → SDE A → ((f : ∥ Σ ∥) → ar Σ f → X) → (f : ∥ Σ ∥) →
        ∀{i} → (X → Stream {i} A) → Stream {i} A
  hd (⟦ E ⟧ vars f vals) = f-out (hd ∘ vals ∘ vars f)
    where f-out = proj₁ (E f)
  tl (⟦ E ⟧ vars f vals) = ⟦ E ⟧₁ vars (f-step (hd ∘ vals ∘ vars f)) vals
    where f-step = proj₂ (E f)

  -- Interpret terms by induction. This map is assumed to be called from the
  -- tail case of ⟦_⟧.

  -- For a symbol, we just use its interpretation but on the tails of the
  -- argument streams
  ⟦ E ⟧₁ vars (sup (inj₁ (f , α)))  vals = ⟦ E ⟧ vars f (λ x → tl (vals x))
  -- A variable is just interpreted by its valuation.
  ⟦ E ⟧₁ vars (sup (inj₂ (inj₁ x))) vals = vals x
  -- A variable denoting a derivative is interpreted by the derivative of
  -- the corresponding stream.
  ⟦ E ⟧₁ vars (sup (inj₂ (inj₂ x))) vals = tl (vals x)


{-# OPTIONS --without-K #-}
module Equiv2Path where

open import FT using (FT; ⟦_⟧; _⇛_; _◎_; sym⇛)
open import Equivalences using (_≃_)
open import FT-Nat using (normal; bridge)

equiv2path : {B₁ B₂ : FT} → (⟦ B₁ ⟧ ≃ ⟦ B₂ ⟧) → (B₁ ⇛ B₂)
equiv2path {B₁} {B₂} eq = ((normal B₁) ◎ bridge eq) ◎ (sym⇛ (normal B₂))


module Dummy where

-- Run this in Acme: go build && ./acme-agda -v

data ℕ : Set where
  zero : ℕ
  succ : ℕ -> ℕ

_+_ : ℕ → ℕ → ℕ
m + n = {!!}

_*_ : ℕ → ℕ → ℕ
m * n = {!m !}