{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.DStructures.Meta.Properties where

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

open import Cubical.Data.Sigma

open import Cubical.Relation.Binary

open import Cubical.DStructures.Base

private
  variable
    ℓ ℓ' ℓ'' ℓ₁ ℓ₁' ℓ₁'' ℓ₂ ℓA ℓA' ℓ≅A ℓ≅A' ℓB ℓB' ℓ≅B ℓC ℓ≅C ℓ≅ᴰ ℓ≅ᴰ' ℓX ℓ≅X ℓD ℓ≅D : Level

-- the total space of a DURGS is a URGS
𝒮ᴰ→𝒮 : {A : Type ℓA} (𝒮-A : URGStr A ℓ≅A)
        {B : A → Type ℓB} (𝒮ᴰ-B : URGStrᴰ 𝒮-A B ℓ≅B)
        → URGStr (Σ A B) (ℓ-max ℓ≅A ℓ≅B)
𝒮ᴰ→𝒮 {A = A} 𝒮-A {B = B} 𝒮ᴰ-B
  = make-𝒮 {_≅_ = _≅Σ_} ρΣ contrTotalΣ
  where
   open URGStr 𝒮-A
   open URGStrᴰ 𝒮ᴰ-B

   -- in the context of a fixed point (a , b)
   module _ ((a , b) : Σ A B) where
     -- the graph relation on the total space
     _≅Σ_ = λ ((a' , b') : Σ A B)
              → Σ[ e ∈ a ≅ a' ] (b ≅ᴰ⟨ e ⟩ b')
     -- reflexivity for that relation
     ρΣ = ρ a , ρᴰ b
     -- contractability of the corresponding total space
     contrTotalA : isContr (Σ[ a' ∈ A ] (a ≅ a'))
     contrTotalA = isUnivalent→contrRelSingl _≅_ ρ uni a
     contrTotalB : isContr (Σ[ b' ∈ B a ] (b ≅ᴰ⟨ ρ a ⟩ b'))
     contrTotalB = isUnivalent→contrRelSingl (_≅ᴰ⟨ ρ a ⟩_) ρᴰ uniᴰ b

     contrTotalΣ
       = isContrRespectEquiv (relSinglAt (_≅ᴰ⟨ ρ a ⟩_) b
                                  ≃⟨ idEquiv (relSinglAt (_≅ᴰ⟨ ρ a ⟩_) b) ⟩
                                Σ[ b' ∈ B a ] (b ≅ᴰ⟨ ρ a ⟩ b')
                                  -- ≃⟨ invEquiv (Σ-contractFst contrTotalA') ⟩
                                  ≃⟨ invEquiv (Σ-contractFst-recenter contrTotalA (a , ρ a)) ⟩
                                Σ[ (a' , e) ∈ (Σ[ a' ∈ A ] (a ≅ a')) ] Σ[ b' ∈ B a' ] (b ≅ᴰ⟨ e ⟩ b')
                                  ≃⟨ Σ-assoc-≃ ⟩
                                Σ[ a' ∈ A ] Σ[ e ∈ (a ≅ a') ] Σ[ b' ∈ B a' ] (b ≅ᴰ⟨ e ⟩ b')
                                  ≃⟨ Σ-cong-equiv-snd (λ a' → invEquiv Σ-assoc-≃) ⟩
                                Σ[ a' ∈ A ] Σ[ (e , b') ∈ (a ≅ a') × B a' ] (b ≅ᴰ⟨ e ⟩ b')
                                  ≃⟨ Σ-cong-equiv-snd (λ a' → Σ-cong-equiv-fst Σ-swap-≃) ⟩
                                Σ[ a' ∈ A ] Σ[ (b' , e) ∈ (B a' × (a ≅ a')) ] (b ≅ᴰ⟨ e ⟩ b')
                                  ≃⟨ Σ-cong-equiv-snd (λ a' → Σ-assoc-≃) ⟩
                                Σ[ a' ∈ A ] Σ[ b' ∈ B a' ] Σ[ e ∈ (a ≅ a') ] (b ≅ᴰ⟨ e ⟩ b')
                                  ≃⟨ invEquiv Σ-assoc-≃ ⟩
                                Σ[ (a' , b') ∈ Σ A B ] Σ[ e ∈ (a ≅ a') ] (b ≅ᴰ⟨ e ⟩ b') ■)
                                contrTotalB

-- integral notation like in the disp cats paper
∫⟨_⟩_ : {A : Type ℓA} (𝒮-A : URGStr A ℓ≅A)
       {B : A → Type ℓB} (𝒮ᴰ-B : URGStrᴰ 𝒮-A B ℓ≅B)
       → URGStr (Σ A B) (ℓ-max ℓ≅A ℓ≅B)
∫⟨_⟩_ 𝒮-A {B} DispStrB .URGStr._≅_ = 𝒮ᴰ→𝒮 𝒮-A DispStrB .URGStr._≅_
∫⟨_⟩_ 𝒮-A {B} DispStrB .URGStr.ρ = 𝒮ᴰ→𝒮 𝒮-A DispStrB .URGStr.ρ
∫⟨_⟩_ 𝒮-A {B} DispStrB .URGStr.uni = 𝒮ᴰ→𝒮 𝒮-A DispStrB .URGStr.uni

-- transport URG structures along an equivalence
𝒮-transport : {A : Type ℓA} {A' : Type ℓA'}
               (e : A ≃ A') (StrA : URGStr A ℓ≅A)
               → URGStr A' ℓ≅A
𝒮-transport {A = A} {A' = A'} e StrA =
  make-𝒮 {_≅_ = λ a a' → e- a ≅ e- a'}
             (λ a → ρ (e- a))
             λ a → isContrRespectEquiv (Σ[ x ∈ A ] e- a ≅ x
                                           ≃⟨ Σ-cong-equiv-snd (λ x → pathToEquiv (cong (e- a ≅_)
                                                                                (sym (Iso.leftInv (equivToIso e)
                                                                                x)))) ⟩
                                       Σ[ x ∈ A ] e- a ≅ e- (e* x)
                                          ≃⟨ Σ-cong-equiv-fst e ⟩
                                       Σ[ a' ∈ A' ] e- a ≅ e- a' ■)
                                         (𝒮→cTS StrA (e- a))
                                       where
                                         open URGStr StrA
                                         e⁻¹ = invEquiv e
                                         e- = equivFun e⁻¹
                                         e* = equivFun e

-- obtain a path from a relation
𝒮-≅→≡ : {A : Type ℓA} (𝒮-A : URGStr A ℓ≅A)
          {a a' : A} (p : URGStr._≅_ 𝒮-A a a')
          → a ≡ a'
𝒮-≅→≡ 𝒮-A {a} {a'} p = equivFun (invEquiv (isUnivalent→isUnivalent' _≅_ ρ uni a a')) p
  where
    open URGStr 𝒮-A

-- context: structure on A, B and C displayed over A
-- then B can be lifted to be displayed over ∫⟨ 𝒮-A ⟩ 𝒮ᴰ-C
VerticalLift-𝒮ᴰ : {A : Type ℓA} (𝒮-A : URGStr A ℓ≅A)
        {B : A → Type ℓB}
        (𝒮ᴰ-B : URGStrᴰ 𝒮-A B ℓ≅B)
        {C : A → Type ℓC}
        (𝒮ᴰ-C : URGStrᴰ 𝒮-A C ℓ≅C)
        → URGStrᴰ (∫⟨ 𝒮-A ⟩ 𝒮ᴰ-C) (λ (a , _) → B a) ℓ≅B
VerticalLift-𝒮ᴰ {ℓ≅B = ℓ≅B} 𝒮-A {B = B} 𝒮ᴰ-B 𝒮ᴰ-C =
  urgstrᴰ (λ b (pA , _) b' → b ≅ᴰ⟨ pA ⟩ b')
          ρᴰ
          uniᴰ
  where open URGStrᴰ 𝒮ᴰ-B

VerticalLift2-𝒮ᴰ : {A : Type ℓA} (𝒮-A : URGStr A ℓ≅A)
                   {X : A → Type ℓX} (𝒮ᴰ-X : URGStrᴰ 𝒮-A X ℓ≅X)
                   {B : A → Type ℓB} (𝒮ᴰ-B : URGStrᴰ 𝒮-A B ℓ≅B)
                   {C : Σ A B → Type ℓC} (𝒮ᴰ-C : URGStrᴰ (∫⟨ 𝒮-A ⟩ 𝒮ᴰ-B) C ℓ≅C)
                   → URGStrᴰ (∫⟨ ∫⟨ 𝒮-A ⟩ 𝒮ᴰ-B ⟩ 𝒮ᴰ-C)
                             (λ ((a , b) , c) → X a)
                             ℓ≅X
VerticalLift2-𝒮ᴰ 𝒮-A 𝒮ᴰ-X 𝒮ᴰ-B 𝒮ᴰ-C =
  VerticalLift-𝒮ᴰ (∫⟨ 𝒮-A ⟩ 𝒮ᴰ-B)
                  (VerticalLift-𝒮ᴰ 𝒮-A 𝒮ᴰ-X 𝒮ᴰ-B)
                  𝒮ᴰ-C

-- context: 𝒮-A on A, 𝒮ᴰ-B / A, 𝒮ᴰ-C / ∫⟨𝒮-A⟩ 𝒮ᴰ-B
-- then 𝒮ᴰ-C can be rebased to 𝒮-A
splitTotal-𝒮ᴰ : {A : Type ℓA} (𝒮-A : URGStr A ℓ≅A)
                {B : A → Type ℓB} (𝒮ᴰ-B : URGStrᴰ 𝒮-A B ℓ≅B)
                {C : Σ A B → Type ℓC} (𝒮ᴰ-C : URGStrᴰ (∫⟨ 𝒮-A ⟩ 𝒮ᴰ-B) C ℓ≅C)
                → URGStrᴰ 𝒮-A
                          (λ a → Σ[ b ∈ B a ] C (a , b))
                          (ℓ-max ℓ≅B ℓ≅C)
splitTotal-𝒮ᴰ {A = A} 𝒮-A {B} 𝒮ᴰ-B {C} 𝒮ᴰ-C
  = make-𝒮ᴰ (λ (b , c) eA (b' , c') → Σ[ eB ∈ b B≅ᴰ⟨ eA ⟩ b' ] c ≅ᴰ⟨ eA , eB ⟩ c')
            (λ (b , c) → Bρᴰ b , ρᴰ c)
            q

  where
    open URGStrᴰ 𝒮ᴰ-C
    open URGStr 𝒮-A
    _B≅ᴰ⟨_⟩_ = URGStrᴰ._≅ᴰ⟨_⟩_ 𝒮ᴰ-B
    Bρᴰ = URGStrᴰ.ρᴰ 𝒮ᴰ-B
    Buniᴰ = URGStrᴰ.uniᴰ 𝒮ᴰ-B

    module _ (a : A) (b : B a) where
      abstract
        contrTotalB : isContr (Σ[ b' ∈ B a ] b B≅ᴰ⟨ ρ a ⟩ b')
        contrTotalB = isUnivalent→contrRelSingl (_B≅ᴰ⟨ ρ a ⟩_) Bρᴰ Buniᴰ b

        contrTotalC : (c : C (a , b)) → isContr (Σ[ c' ∈ C (a , b) ] c ≅ᴰ⟨ ρ a , Bρᴰ b ⟩ c')
        contrTotalC = isUnivalent→contrRelSingl (λ c₁ c₂ → c₁ ≅ᴰ⟨ ρ a , Bρᴰ b ⟩ c₂) ρᴰ uniᴰ

    abstract
      q = λ a (b , c) → isContrRespectEquiv (Σ[ c' ∈ C (a , b) ] c ≅ᴰ⟨ ρ a , Bρᴰ b ⟩ c'
                                                ≃⟨ invEquiv (Σ-contractFst-recenter (contrTotalB a b) (b , Bρᴰ b)) ⟩
                                            Σ[ (b' , eB) ∈ Σ[ b' ∈ B a ] b B≅ᴰ⟨ ρ a ⟩ b' ] (Σ[ c' ∈ C (a , b') ] (c ≅ᴰ⟨ ρ a , eB ⟩ c'))
                                                       ≃⟨ compEquiv Σ-assoc-≃
                                                                    (compEquiv (Σ-cong-equiv-snd (λ b' → compEquiv (invEquiv Σ-assoc-≃)
                                                                                (compEquiv (Σ-cong-equiv-fst Σ-swap-≃)
                                                                                Σ-assoc-≃)))
                                                                               (invEquiv Σ-assoc-≃)) ⟩
                                                     Σ[ (b' , c') ∈ Σ[ b' ∈ B a ] C (a , b') ] (Σ[ eB ∈ b B≅ᴰ⟨ ρ a ⟩ b' ] (c ≅ᴰ⟨ ρ a , eB ⟩ c')) ■)
                                                     (contrTotalC a b c)

-- pullback in the (∞,1)-topos of DURGs,
-- combine two DURGs over the same URG to one
combine-𝒮ᴰ : {A : Type ℓA} {𝒮-A : URGStr A ℓ≅A}
             {B : A → Type ℓB} {C : A → Type ℓC}
             (𝒮ᴰ-B : URGStrᴰ 𝒮-A B ℓ≅B)
             (𝒮ᴰ-C : URGStrᴰ 𝒮-A C ℓ≅C)
             → URGStrᴰ 𝒮-A (λ a → B a × C a) (ℓ-max ℓ≅B ℓ≅C)
combine-𝒮ᴰ {𝒮-A = 𝒮-A} 𝒮ᴰ-B 𝒮ᴰ-C = splitTotal-𝒮ᴰ 𝒮-A 𝒮ᴰ-B (VerticalLift-𝒮ᴰ 𝒮-A 𝒮ᴰ-C 𝒮ᴰ-B)

-- old stuff, not sure if relevant

-- extract the relational family from a DURG
SplitTotal-𝒮ᴰ→RelFamily : {ℓ≅A ℓ≅B ℓ≅C : Level}
                          {A : Type ℓA} (𝒮-A : URGStr A ℓ≅A)
                          {B : A → Type ℓB} (𝒮ᴰ-B : URGStrᴰ 𝒮-A B ℓ≅B)
                          {C : Σ A B → Type ℓC} (𝒮ᴰ-C : URGStrᴰ (∫⟨ 𝒮-A ⟩ 𝒮ᴰ-B) C ℓ≅C)
                          → Σ[ _≅_ ∈ Rel A A ℓ≅A ]
                               ({a a' : A} ((b , c) : Σ[ b ∈ B a ] C (a , b)) (e : a ≅ a') ((b' , c') : (Σ[ b' ∈ B a' ] C (a' , b'))) → Type (ℓ-max ℓ≅B ℓ≅C))
SplitTotal-𝒮ᴰ→RelFamily 𝒮-A {B = B} 𝒮ᴰ-B {C = C} 𝒮ᴰ-C .fst = _≅_
  where
    open URGStr 𝒮-A
SplitTotal-𝒮ᴰ→RelFamily 𝒮-A {B = B} 𝒮ᴰ-B {C = C} 𝒮ᴰ-C .snd (b , c) e (b' , c') = Σ[ eB ∈ b B≅ᴰ⟨ e ⟩ b' ] (c ≅ᴰ⟨ e , eB ⟩ c')
  where
    open URGStr 𝒮-A
    _B≅ᴰ⟨_⟩_ = URGStrᴰ._≅ᴰ⟨_⟩_ 𝒮ᴰ-B
    open URGStrᴰ 𝒮ᴰ-C

SplitTotal-𝒮ᴰ→RelFamily' : {ℓ≅A ℓ≅B ℓ≅C : Level}
                          {A : Type ℓA} (𝒮-A : URGStr A ℓ≅A)
                          {B : A → Type ℓB} (𝒮ᴰ-B : URGStrᴰ 𝒮-A B ℓ≅B)
                          {C : Σ A B → Type ℓC} (𝒮ᴰ-C : URGStrᴰ (∫⟨ 𝒮-A ⟩ 𝒮ᴰ-B) C ℓ≅C)
                          → RelFamily A (ℓ-max ℓB ℓC) (ℓ-max ℓ≅B ℓ≅C)
SplitTotal-𝒮ᴰ→RelFamily' 𝒮-A {B = B} 𝒮ᴰ-B {C = C} 𝒮ᴰ-C .fst a = Σ[ b ∈ B a ] C (a , b)
SplitTotal-𝒮ᴰ→RelFamily' 𝒮-A {B = B} 𝒮ᴰ-B {C = C} 𝒮ᴰ-C .snd {a = a} (b , c) (b' , c') = Σ[ p ∈ b B≅ᴰ⟨ ρ a ⟩ b' ] (c C≅ᴰ⟨ ρ a , p ⟩ c')
  where
    open URGStr 𝒮-A
    _B≅ᴰ⟨_⟩_ = URGStrᴰ._≅ᴰ⟨_⟩_ 𝒮ᴰ-B
    _C≅ᴰ⟨_⟩_ = URGStrᴰ._≅ᴰ⟨_⟩_ 𝒮ᴰ-C

-- combine two structures 𝒮-B and 𝒮-C over 𝒮-A to a structure 𝒮-B × 𝒮-C over A, direct proof
combine'-𝒮ᴰ : {A : Type ℓA} {𝒮-A : URGStr A ℓ≅A}
                 {B : A → Type ℓB} {C : A → Type ℓC}
                 (𝒮ᴰ-B : URGStrᴰ 𝒮-A B ℓ≅B)
                 (𝒮ᴰ-C : URGStrᴰ 𝒮-A C ℓ≅C)
                 → URGStrᴰ 𝒮-A (λ a → B a × C a) (ℓ-max ℓ≅B ℓ≅C)
combine'-𝒮ᴰ {ℓ≅B = ℓ≅B} {ℓ≅C = ℓ≅C} {A = A} {𝒮-A = 𝒮-A} {B = B} {C = C} 𝒮ᴰ-B 𝒮ᴰ-C =
  make-𝒮ᴰ -- equality in the combined structure is defined componentwise
              (λ (b , c) p (b' , c') → b B≅ᴰ⟨ p ⟩ b' × c C≅ᴰ⟨ p ⟩ c')
              -- reflexivity follows from B and C reflexivity
              (λ (b , c) → Bρᴰ b , Cρᴰ c)
              -- so does univalence
              contrTot
  where
    ρ = URGStr.ρ 𝒮-A
    _B≅ᴰ⟨_⟩_ = URGStrᴰ._≅ᴰ⟨_⟩_ 𝒮ᴰ-B
    _C≅ᴰ⟨_⟩_ = URGStrᴰ._≅ᴰ⟨_⟩_ 𝒮ᴰ-C
    Bρᴰ = URGStrᴰ.ρᴰ 𝒮ᴰ-B
    Cρᴰ = URGStrᴰ.ρᴰ 𝒮ᴰ-C
    Buniᴰ = URGStrᴰ.uniᴰ 𝒮ᴰ-B
    Cuniᴰ = URGStrᴰ.uniᴰ 𝒮ᴰ-C
    contrTot : (a : A) ((b , c) : B a × C a) → isContr (Σ[ (b' , c') ∈ B a × C a ] (b B≅ᴰ⟨ ρ a ⟩ b' × c C≅ᴰ⟨ ρ a ⟩ c') )
    contrTot = λ (a : A) ((b , c) : B a × C a)
      → isContrRespectEquiv (Σ[ b' ∈ B a ] (b B≅ᴰ⟨ ρ a ⟩ b')
                                 ≃⟨ invEquiv (Σ-contractSnd (λ _ → isUnivalent→contrRelSingl (_C≅ᴰ⟨ ρ a ⟩_) Cρᴰ Cuniᴰ c)) ⟩
                               (Σ[ b' ∈ B a ] (b B≅ᴰ⟨ ρ a ⟩ b')) × (Σ[ c' ∈ C a ] (c C≅ᴰ⟨ ρ a ⟩ c'))
                                 ≃⟨ Σ-assoc-≃ ⟩
                               (Σ[ b' ∈ B a ] Σ[ _ ∈ b B≅ᴰ⟨ ρ a ⟩ b' ] Σ[ c' ∈ C a ] (c C≅ᴰ⟨ ρ a ⟩ c'))
                                 ≃⟨ Σ-cong-equiv-snd (λ b' → compEquiv (invEquiv Σ-assoc-≃) (compEquiv (Σ-cong-equiv-fst Σ-swap-≃) Σ-assoc-≃)) ⟩
                               (Σ[ b' ∈ B a ] Σ[ c' ∈ C a ] Σ[ _ ∈ b B≅ᴰ⟨ ρ a ⟩ b' ] (c C≅ᴰ⟨ ρ a ⟩ c'))
                                 ≃⟨ invEquiv Σ-assoc-≃ ⟩
                               (Σ[ (b' , c') ∈ B a × C a ] (b B≅ᴰ⟨ ρ a ⟩ b' × c C≅ᴰ⟨ ρ a ⟩ c') ) ■)
                               (isUnivalent→contrRelSingl (_B≅ᴰ⟨ ρ a ⟩_) Bρᴰ Buniᴰ b)


-- Andreas, 2018-10-17
--
-- Cannot branch on erased argument.

open import Agda.Builtin.Bool

T : @0 Bool → Set
T true  = Bool
T false = Bool → Bool

-- Should fail with error like:
--
-- Cannot branch on erased argument of datatype Bool
-- when checking the definition of T


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

module TheSame where

open import Level using (_⊔_) renaming (zero to l0; suc to lsuc)
open import Universe using (Universe)

open import Categories.Category using (Category)
open import Categories.Groupoid using (Groupoid)
open import Categories.Functor using (Functor)

open import Data.Empty using (⊥)
open import Data.Unit using (⊤; tt)
open import Data.Sum hiding ([_,_])
open import Data.Product
open import Relation.Binary.PropositionalEquality as P
open import Function using (flip)
open import Data.Nat using (ℕ; zero; suc)
open import Data.Integer using (+_)

open import Categories.Groupoid.Sum using () renaming (Sum to GSum)
open import Categories.Groupoid.Product using () renaming (Product to GProduct)

open import PiU using (U; ZERO; ONE; PLUS; TIMES; toℕ)
open import PiLevel0
open import PiLevel1
open import PiEquiv
open import Equiv

open import PiIter

-- our values come in three flavours, base, up and down (i.e. #p and 1/# p)
data Flavour : Set where
  base up down : Flavour

-- all our values will be 'subtypes' of this:
record V (fl : Flavour) (t₀ t₁ : U) (p : t₁ ⟷ t₁) : Set where
  constructor v
  field
    pt : ⟦ t₀ ⟧
    auto : Iter p

-- we need t₀ and t₁ to potentially be different to embed
-- #p and 1/#p.  The values of these are the same, but
-- the homomorphisms will be different, and thus how to count them.

-- We can embed our (current) values into V easily:
embedBase : {t : U} → ⟦ t ⟧ → V base t ONE id⟷
embedBase w = v w (iter (+ 0) id⟷ id⇔)

embed#p : {t : U} → {p : t ⟷ t} → Iter p → V up ONE t p
embed#p it = v tt it

embed1/#p : {t : U} → {p : t ⟷ t} → Iter p → V down ONE t p
embed1/#p it = v tt it

-- We can then define combinators on V as two actions, one on each part
record C (s₀ s₁ t₀ t₁ : U) : Set where
  constructor cc
  field
    comb : s₀ ⟷ t₀
    transp : s₁ ⟷ t₁

-- evaluation is then straightforward, just follow the types:
evalV : {s₀ s₁ t₀ t₁ : U} {fl : Flavour} {p₀ : s₁ ⟷ s₁} →
  (c : C s₀ s₁ t₀ t₁) → (val : V fl s₀ s₁ p₀) →
  V fl t₀ t₁ (! (C.transp c) ◎ p₀ ◎ (C.transp c))
evalV {p₀ = p} (cc comb transp) (v pt (iter i q α)) =
  v (eval comb pt) (iter i (! transp ◎ (q ◎ transp)) {!!}) --

-- we should go backwards too
evalVB : {s₀ s₁ t₀ t₁ : U} {fl : Flavour} {p₁ : t₁ ⟷ t₁} →
  (c : C s₀ s₁ t₀ t₁) → (val : V fl t₀ t₁ p₁) →
    V fl s₀ s₁ ((C.transp c) ◎ p₁ ◎ ! (C.transp c))
evalVB (cc comb transp) (v pt (iter i q α)) =
  v (evalB comb pt) (iter (+ 1) (transp ◎ (q ◎ ! transp)) {!!})

-- Next comes the (generic) type of morphisms. Note that this type is
-- 'too big', in practice we use particular sub-types.
record H {s₀ s₁ t₀ t₁ : U} {fl : Flavour} {p : s₁ ⟷ s₁} {q : t₁ ⟷ t₁}
  (a : V fl s₀ s₁ p) (b : V fl t₀ t₁ q) : Set where
  constructor mor
  open V
  field
    combi : C s₀ s₁ t₀ t₁

  vb = evalV combi a

  field
    pt-eq : pt vb P.≡ pt b
    t-eq : Iter.p' (auto vb) ⇔ Iter.p' (auto b)
    -- should p transport to ⇔ q ?

-- The above gives, implicitly, a notion of equality, which can
-- be extracted as below.  Note how we insist on the types being
-- the same.  This is basically the same as H when combi is id⟷ id⟷
record _≡V_ {s₀ s₁ : U} {fl : Flavour} {p q : s₁ ⟷ s₁}
  (a : V fl s₀ s₁ p) (b : V fl s₀ s₁ q) : Set where
  constructor veq
  open V
  field
    pt-eq : pt a P.≡ pt b
    t-eq : Iter.p' (auto a) ⇔ Iter.p' (auto b)
    p⇔q : p ⇔ q

-- And now we can say what back-and-forth do:
evBF : {s₀ s₁ t₀ t₁ : U} {fl : Flavour} {p₀ : s₁ ⟷ s₁} →
  (c : C s₀ s₁ t₀ t₁) → (val : V fl s₀ s₁ p₀) →
  evalVB c (evalV c val) ≡V val
evBF (cc comb transp) (v pt (iter i p' α)) =
  veq (P.trans (lemma1 comb (eval comb pt)) (
       P.trans (P.cong (proj₁ (sym≃ (c2equiv comb))) (lemma0 comb pt))
               (isqinv.β (proj₂ (c2equiv comb)) pt)))
      {!!} {!!}

-- and Homs.  Note how the range of this is quite restricted
embedBaseHom : {τ : U} → (s t : ⟦ τ ⟧) → s ≡ t → H (embedBase s) (embedBase t)
embedBaseHom s .s P.refl = mor (cc id⟷ id⟷) P.refl (trans⇔ idl◎l idr◎l )

-- for #p.  The only Homs are when p ^ i ⇔ p ^ j
embed#pHom : {τ : U} → {p : τ ⟷ τ} → (v₀ v₁ : Iter p) → (Iter.p' v₀) ⇔ (Iter.p' v₁) →
  H (embed#p v₀) (embed#p v₁)
embed#pHom {_} {p} (iter i q α) (iter j r β) iso = mor (cc id⟷ p) P.refl (
  trans⇔ (id⇔ ⊡ (α ⊡ id⇔)) (trans⇔ (trans⇔ (id⇔ ⊡ (2! (assoc1g i)))
  (trans⇔ assoc◎l (trans⇔ (rinv◎l ⊡ (2! α)) idl◎l))) iso))

-- for 1/#p; a bit lazy here, q should be Iter p, but the core of the
-- idea remains the same.
embed1/#pHom : {τ : U} → (p : τ ⟷ τ) → (q : Iter p) →
  H (embed1/#p q) (embed1/#p q)
embed1/#pHom p (iter i q α) = mor (cc id⟷ p) P.refl (trans⇔
  (id⇔ ⊡ (α ⊡ id⇔)) (trans⇔ (id⇔ ⊡ 2! (assoc1g i)) (trans⇔
  assoc◎l (trans⇔ (rinv◎l ⊡ id⇔) (trans⇔ idl◎l (2! α))))))

-- infix 40 _⇿_
infixl 50 ↑_

-- let's make the relationship much clearer
data U↑ : Set where
  ↑_ : U → U↑
  -- we need to do a more complicated lift of 1
  𝟙 : {t : U} → (p : t ⟷ t) → U↑
  #p   : {t : U} → (p : t ⟷ t) → U↑
  1/#p : {t : U} → (p : t ⟷ t) → U↑

-- This corresponds exactly to Obj (proj₁ ⟦ t ⟧ ) from 2D/Frac.agda
⟦_⟧↑ : U↑ → Set
⟦ ↑ x ⟧↑ = ⟦ x ⟧
⟦ 𝟙 p ⟧↑ = {!!}
⟦ #p p ⟧↑ = Iter p
⟦ 1/#p p ⟧↑ = ⊤

flavour : U↑ → Flavour
flavour (↑ _) = base
flavour (𝟙 p) = {!!}
flavour (#p _) = up
flavour (1/#p _) = down

t₀↑ : U↑ → U
t₀↑ (↑ t) = t
t₀↑ (𝟙 p) = {!!}
t₀↑ (#p p) = ONE
t₀↑ (1/#p p) = ONE

t₁↑ : U↑ → U
t₁↑ (↑ t) = ONE
t₁↑ (𝟙 p) = {!!}
t₁↑ (#p {t} _) = t
t₁↑ (1/#p {t} _) = t

auto↑ : (t : U↑) → (t₁↑ t ⟷ t₁↑ t)
auto↑ (↑ x) = id⟷
auto↑ (𝟙 p) = {!!}
auto↑ (#p p) = p
auto↑ (1/#p p) = id⟷

iter↑ : (t : U↑) → Iter (auto↑ t)
iter↑ (↑ x) = iter (+ 0) id⟷ id⇔
iter↑ (𝟙 p) = {!!}
iter↑ (#p p) = iter (+ 1) p idr◎r
iter↑ (1/#p p) = iter (+ 0) id⟷ id⇔

⟦_⟧V : (t : U↑)  → Set
⟦ t ⟧V = V (flavour t) (t₀↑ t) (t₁↑ t) (auto↑ t)

fwd : {t : U↑} → ⟦ t ⟧↑ → ⟦ t ⟧V
fwd {↑ x} val = embedBase val
fwd {𝟙 p} val = {!!}
fwd {#p p} val = embed#p val
fwd {1/#p p} tt = embed1/#p (iter (+ 0) id⟷ id⇔)

bwd : {t : U↑} → ⟦ t ⟧V → ⟦ t ⟧↑
bwd {↑ x} val = V.pt val
bwd {𝟙 p} val = {!!}
bwd {#p p} val = V.auto val
bwd {1/#p p} val = tt

-- (This should be packed up to use ≡V)
fwdbwd≈id : {t : U↑} → (x : ⟦ t ⟧V) → V.pt (fwd {t} (bwd x)) P.≡ V.pt x
fwdbwd≈id {↑ x} (v pt auto) = P.refl
fwdbwd≈id {𝟙 p} (v pt auto) = {!!}
fwdbwd≈id {#p p} (v tt auto) = P.refl
fwdbwd≈id {1/#p p} (v tt auto) = P.refl

fb-auto : {t : U↑} → (x : ⟦ t ⟧V) → Iter.p' (V.auto (fwd {t} (bwd x))) ⇔ Iter.p' (V.auto x)
fb-auto {↑ x} (v pt (iter i p' α)) = 2! (trans⇔ α (id^i≡id i))
fb-auto {𝟙 p} vv = {!!}
fb-auto {#p p} (v pt (iter i p' α)) = id⇔
fb-auto {1/#p p} (v pt (iter i p' α)) = 2! (trans⇔ α (id^i≡id i))

bf-x : {t : U↑} → (x : ⟦ t ⟧↑) → bwd (fwd {t} x) P.≡ x
bf-x {↑ x} x₁ = P.refl
bf-x {𝟙 p} x = {!!}
bf-x {#p p} x = P.refl
bf-x {1/#p p} tt = P.refl

{-
data _⇿_ : U↑ → U↑ → Set where
  prim : {t₁ t₂ : U} → (t₁ ⟷ t₂) → (↑ t₁ ⇿ ↑ t₂)
-}


{-# OPTIONS --allow-unsolved-metas #-}
postulate
  Foo : Set

record BaseT : Set₁ where
  field f : Foo

record ParamT (p : Foo) : Set₁ where
  field f : Foo

instance
  postulate asBaseT : ∀ {p} → ParamT p → BaseT
--  BaseT.f (asBaseT p) = ParamT.f p

data Bar : Set where
  o : Bar

data Baz {{_ : BaseT}} : Bar → Set where
  t1 : Baz o
  t2 : Baz o → Baz o
  t3 : Baz o → Baz o → Baz o
  t4 : Baz o → Baz o → Baz o → Baz o


------------------------------------------------------------------------------
-- Testing Agsy *without* using the Agda standard library
------------------------------------------------------------------------------

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

-- Tested with the development version of Agda on 15 June 2012.

module FOT.Agsy.NoStd.AgsyNoStd where

-- The equational reasoning from the Agda standard library 0.8.1.
-- open import Relation.Binary.PropositionalEquality
-- open ≡-Reasoning

-- My equational reasoning.
open import FOT.Agsy.NoStd.MyPropositionalEquality
open ≡-Reasoning

-- We add 3 to the fixities of the Agda standard library 0.8.1 (see
-- Data/Nat.agda).
infixl 9 _+_

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

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

_+_ : ℕ → ℕ → ℕ
zero  + n = n
suc m + n = suc (m + n)

+-assoc : ∀ m n o → m + n + o ≡ m + (n + o)
+-assoc zero    n o = refl  -- via Agsy
+-assoc (suc m) n o = {!!}  -- Agsy fails using my propositional equality


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

module FormalLanguage.Proofs {ℓ} where

import      Lvl
open import Data
open import Data.Boolean
open import Data.Boolean.Proofs
open import Data.Boolean.Operators
open        Data.Boolean.Operators.Programming
open import Data.Boolean.Stmt
open import Data.Boolean.Stmt.Proofs
import      Data.Tuple as Tuple
open import FormalLanguage
open import FormalLanguage.Equals
open import Functional using (id)
open import Sized.Data.List renaming (∅ to [])
open import Lang.Size
open import Logic.Predicate
open import Logic.Propositional
open import Logic.Propositional.Theorems
open import Relator.Equals using ([≡]-intro) renaming (_≡_ to _≡ₑ_)
open import Relator.Equals.Proofs
import      Function.Names as Names
open import Structure.Setoid
open import Structure.Operator.Monoid
import      Structure.Operator.Names as Names
open import Structure.Operator.Proofs
open import Structure.Operator.Properties
-- open import Structure.Operator.SetAlgebra
open import Structure.Operator
open import Structure.Function.Domain
open import Structure.Relator
open import Structure.Relator.Properties
open import Syntax.Transitivity
open import Type

-- TODO: Prove all these
-- TODO: http://www.cse.chalmers.se/~abela/jlamp17.pdf

private variable s s₁ s₂ s₃ : Size

{-
module _ {Σ : Alphabet{ℓ}} where
  open Oper{ℓ}{Σ}
  open Language renaming (accepts-ε to accepts ; suffix-lang to suffix)

  instance
    [∪]-associativity : Associativity ⦃ [≅]-equiv {s = s} ⦄ (_∪_)
    Associativity.proof([∪]-associativity {s = s}) = [∪]-associativity-raw {s = s} where
      [∪]-associativity-raw : ∀{s} → Names.Associativity ⦃ [≅]-equiv {s = s} ⦄ (_∪_)
      _≅[_]≅_.accepts-ε   ([∪]-associativity-raw {x = A})     = associativity(_||_) {Language.accepts-ε A}
      _≅[_]≅_.suffix-lang ([∪]-associativity-raw {x = A}) {c} = [∪]-associativity-raw {x = Language.suffix-lang A c}

  instance
    [∪]-commutativity : Commutativity ⦃ [≅]-equiv {s = s} ⦄ (_∪_)
    Commutativity.proof([∪]-commutativity {s = s}) = [∪]-commutativity-raw {s = s} where
      [∪]-commutativity-raw : ∀{s} → Names.Commutativity ⦃ [≅]-equiv {s = s} ⦄ (_∪_)
      _≅[_]≅_.accepts-ε   ([∪]-commutativity-raw {x = A})     = commutativity(_||_) {Language.accepts-ε A}
      _≅[_]≅_.suffix-lang ([∪]-commutativity-raw {x = A}) {c} = [∪]-commutativity-raw {x = Language.suffix-lang A c}

  instance
    [∪]-identityₗ : Identityₗ ⦃ [≅]-equiv {s = s} ⦄ (_∪_)(∅)
    Identityₗ.proof([∪]-identityₗ {s = s}) = [∪]-identityₗ-raw {s = s} where
      [∪]-identityₗ-raw : ∀{s} → Names.Identityₗ ⦃ [≅]-equiv {s = s} ⦄ (_∪_)(∅)
      _≅[_]≅_.accepts-ε   ([∪]-identityₗ-raw {x = A})     = [≡]-intro
      _≅[_]≅_.suffix-lang ([∪]-identityₗ-raw {x = A}) {c} = [∪]-identityₗ-raw {x = Language.suffix-lang A c}

  instance
    [∪]-identityᵣ : Identityᵣ ⦃ [≅]-equiv {s = s} ⦄ (_∪_)(∅)
    Identityᵣ.proof([∪]-identityᵣ {s = s}) = [∪]-identityᵣ-raw {s = s} where
      [∪]-identityᵣ-raw : ∀{s} → Names.Identityᵣ ⦃ [≅]-equiv {s = s} ⦄ (_∪_)(∅)
      _≅[_]≅_.accepts-ε   ([∪]-identityᵣ-raw {x = A})     = [≡]-intro
      _≅[_]≅_.suffix-lang ([∪]-identityᵣ-raw {x = A}) {c} = [∪]-identityᵣ-raw {x = Language.suffix-lang A c}

  instance
    [∪]-identity : Identity ⦃ [≅]-equiv {s = s} ⦄ (_∪_)(∅)
    [∪]-identity = intro

  instance
    [∪]-absorberₗ : Absorberₗ ⦃ [≅]-equiv {s = s} ⦄ (_∪_)(𝐔)
    Absorberₗ.proof([∪]-absorberₗ {s = s}) = [∪]-absorberₗ-raw {s = s} where
      [∪]-absorberₗ-raw : ∀{s} → Names.Absorberₗ ⦃ [≅]-equiv {s = s} ⦄ (_∪_)(𝐔)
      _≅[_]≅_.accepts-ε   ([∪]-absorberₗ-raw {x = A})     = [≡]-intro
      _≅[_]≅_.suffix-lang ([∪]-absorberₗ-raw {x = A}) {c} = [∪]-absorberₗ-raw {x = Language.suffix-lang A c}

  instance
    [∪]-absorberᵣ : Absorberᵣ ⦃ [≅]-equiv {s = s} ⦄ (_∪_)(𝐔)
    Absorberᵣ.proof([∪]-absorberᵣ {s = s}) = [∪]-absorberᵣ-raw {s = s} where
      [∪]-absorberᵣ-raw : ∀{s} → Names.Absorberᵣ ⦃ [≅]-equiv {s = s} ⦄ (_∪_)(𝐔)
      _≅[_]≅_.accepts-ε   ([∪]-absorberᵣ-raw {x = A})     = [≡]-intro
      _≅[_]≅_.suffix-lang ([∪]-absorberᵣ-raw {x = A}) {c} = [∪]-absorberᵣ-raw {x = Language.suffix-lang A c}

  instance
    [∪]-absorber : Absorber ⦃ [≅]-equiv {s = s} ⦄ (_∪_)(𝐔)
    [∪]-absorber = intro

  instance
    [∪]-binary-operator : BinaryOperator ⦃ [≅]-equiv {s = s} ⦄ ⦃ [≅]-equiv {s = s} ⦄ ⦃ [≅]-equiv {s = s} ⦄ (_∪_)
    BinaryOperator.congruence([∪]-binary-operator {s = s}) = [∪]-binary-operator-raw {s = s} where
      [∪]-binary-operator-raw : ∀{s} → Names.Congruence₂ ⦃ [≅]-equiv {s = s} ⦄ ⦃ [≅]-equiv {s = s} ⦄ ⦃ [≅]-equiv {s = s} ⦄ (_∪_)
      _≅[_]≅_.accepts-ε   ([∪]-binary-operator-raw aeq beq) = [≡]-with-op(_||_) (_≅[_]≅_.accepts-ε aeq) (_≅[_]≅_.accepts-ε beq)
      _≅[_]≅_.suffix-lang ([∪]-binary-operator-raw aeq beq) = [∪]-binary-operator-raw (_≅[_]≅_.suffix-lang aeq) (_≅[_]≅_.suffix-lang beq)

  instance
    [∪]-monoid : Monoid ⦃ [≅]-equiv {s = s} ⦄ (_∪_)
    Monoid.identity-existence [∪]-monoid = [∃]-intro(∅)

  instance
    [∩]-associativity : Associativity ⦃ [≅]-equiv {s = s} ⦄ (_∩_)
    Associativity.proof([∩]-associativity {s = s}) = [∩]-associativity-raw {s = s} where
      [∩]-associativity-raw : ∀{s} → Names.Associativity ⦃ [≅]-equiv {s = s} ⦄ (_∩_)
      _≅[_]≅_.accepts-ε   ([∩]-associativity-raw {x = A})     = associativity(_&&_) {Language.accepts-ε A}
      _≅[_]≅_.suffix-lang ([∩]-associativity-raw {x = A}) {c} = [∩]-associativity-raw {x = Language.suffix-lang A c}

  instance
    [∩]-commutativity : Commutativity ⦃ [≅]-equiv {s = s} ⦄ (_∩_)
    Commutativity.proof([∩]-commutativity {s = s}) = [∩]-commutativity-raw {s = s} where
      [∩]-commutativity-raw : ∀{s} → Names.Commutativity ⦃ [≅]-equiv {s = s} ⦄ (_∩_)
      _≅[_]≅_.accepts-ε   ([∩]-commutativity-raw {x = A})     = commutativity(_&&_) {Language.accepts-ε A}
      _≅[_]≅_.suffix-lang ([∩]-commutativity-raw {x = A}) {c} = [∩]-commutativity-raw {x = Language.suffix-lang A c}

  instance
    [∩]-identityₗ : Identityₗ ⦃ [≅]-equiv {s = s} ⦄ (_∩_)(𝐔)
    Identityₗ.proof([∩]-identityₗ {s = s}) = [∩]-identityₗ-raw {s = s} where
      [∩]-identityₗ-raw : ∀{s} → Names.Identityₗ ⦃ [≅]-equiv {s = s} ⦄ (_∩_)(𝐔)
      _≅[_]≅_.accepts-ε   ([∩]-identityₗ-raw {x = A})     = [≡]-intro
      _≅[_]≅_.suffix-lang ([∩]-identityₗ-raw {x = A}) {c} = [∩]-identityₗ-raw {x = Language.suffix-lang A c}

  instance
    [∩]-identityᵣ : Identityᵣ ⦃ [≅]-equiv {s = s} ⦄ (_∩_)(𝐔)
    Identityᵣ.proof([∩]-identityᵣ {s = s}) = [∩]-identityᵣ-raw {s = s} where
      [∩]-identityᵣ-raw : ∀{s} → Names.Identityᵣ ⦃ [≅]-equiv {s = s} ⦄ (_∩_)(𝐔)
      _≅[_]≅_.accepts-ε   ([∩]-identityᵣ-raw {x = A})     = [≡]-intro
      _≅[_]≅_.suffix-lang ([∩]-identityᵣ-raw {x = A}) {c} = [∩]-identityᵣ-raw {x = Language.suffix-lang A c}

  instance
    [∩]-identity : Identity ⦃ [≅]-equiv {s = s} ⦄ (_∩_)(𝐔)
    [∩]-identity = intro

  instance
    [∩]-absorberₗ : Absorberₗ ⦃ [≅]-equiv {s = s} ⦄ (_∩_)(∅)
    Absorberₗ.proof([∩]-absorberₗ {s = s}) = [∩]-absorberₗ-raw {s = s} where
      [∩]-absorberₗ-raw : ∀{s} → Names.Absorberₗ ⦃ [≅]-equiv {s = s} ⦄ (_∩_)(∅)
      _≅[_]≅_.accepts-ε   ([∩]-absorberₗ-raw {x = A})     = [≡]-intro
      _≅[_]≅_.suffix-lang ([∩]-absorberₗ-raw {x = A}) {c} = [∩]-absorberₗ-raw {x = Language.suffix-lang A c}

  instance
    [∩]-absorberᵣ : Absorberᵣ ⦃ [≅]-equiv {s = s} ⦄ (_∩_)(∅)
    Absorberᵣ.proof([∩]-absorberᵣ {s = s}) = [∩]-absorberᵣ-raw {s = s} where
      [∩]-absorberᵣ-raw : ∀{s} → Names.Absorberᵣ ⦃ [≅]-equiv {s = s} ⦄ (_∩_)(∅)
      _≅[_]≅_.accepts-ε   ([∩]-absorberᵣ-raw {x = A})     = [≡]-intro
      _≅[_]≅_.suffix-lang ([∩]-absorberᵣ-raw {x = A}) {c} = [∩]-absorberᵣ-raw {x = Language.suffix-lang A c}

  instance
    [∩]-absorber : Absorber ⦃ [≅]-equiv {s = s} ⦄ (_∩_)(∅)
    [∩]-absorber = intro

  instance
    [∩]-binary-operator : BinaryOperator ⦃ [≅]-equiv {s = s} ⦄ ⦃ [≅]-equiv {s = s} ⦄ ⦃ [≅]-equiv {s = s} ⦄ (_∩_)
    BinaryOperator.congruence([∩]-binary-operator {s = s}) = [∩]-binary-operator-raw {s = s} where
      [∩]-binary-operator-raw : ∀{s} → Names.Congruence₂ ⦃ [≅]-equiv {s = s} ⦄ ⦃ [≅]-equiv {s = s} ⦄ ⦃ [≅]-equiv {s = s} ⦄(_∩_)
      _≅[_]≅_.accepts-ε   ([∩]-binary-operator-raw aeq beq) = [≡]-with-op(_&&_) (_≅[_]≅_.accepts-ε aeq) (_≅[_]≅_.accepts-ε beq)
      _≅[_]≅_.suffix-lang ([∩]-binary-operator-raw aeq beq) = [∩]-binary-operator-raw (_≅[_]≅_.suffix-lang aeq) (_≅[_]≅_.suffix-lang beq)

  instance
    [∩]-monoid : Monoid ⦃ [≅]-equiv {s = s} ⦄ (_∩_)
    Monoid.identity-existence [∩]-monoid = [∃]-intro(𝐔)

  instance
    [∪][∩]-distributivityₗ : Distributivityₗ ⦃ [≅]-equiv {s = s} ⦄ (_∪_)(_∩_)
    Distributivityₗ.proof([∪][∩]-distributivityₗ {s = s}) = [∪][∩]-distributivityₗ-raw {s = s} where
      [∪][∩]-distributivityₗ-raw : ∀{s} → Names.Distributivityₗ ⦃ [≅]-equiv {s = s} ⦄ (_∪_)(_∩_)
      _≅[_]≅_.accepts-ε   ([∪][∩]-distributivityₗ-raw {x = A})     = distributivityₗ(_||_)(_&&_) {x = Language.accepts-ε A}
      _≅[_]≅_.suffix-lang ([∪][∩]-distributivityₗ-raw {x = A}) {c} = [∪][∩]-distributivityₗ-raw {x = Language.suffix-lang A c}

  instance
    [∩][∪]-distributivityₗ : Distributivityₗ ⦃ [≅]-equiv {s = s} ⦄ (_∩_)(_∪_)
    Distributivityₗ.proof([∩][∪]-distributivityₗ {s = s}) = [∩][∪]-distributivityₗ-raw {s = s} where
      [∩][∪]-distributivityₗ-raw : ∀{s} → Names.Distributivityₗ ⦃ [≅]-equiv {s = s} ⦄ (_∩_)(_∪_)
      _≅[_]≅_.accepts-ε   ([∩][∪]-distributivityₗ-raw {x = A})     = distributivityₗ(_&&_)(_||_) {x = Language.accepts-ε A}
      _≅[_]≅_.suffix-lang ([∩][∪]-distributivityₗ-raw {x = A}) {c} = [∩][∪]-distributivityₗ-raw {x = Language.suffix-lang A c}

  instance
    [𝁼][∪]-distributivityₗ : Distributivityₗ ⦃ [≅]-equiv {s = s} ⦄ (_𝁼_)(_∪_)
    Distributivityₗ.proof ([𝁼][∪]-distributivityₗ {s = s}) = [𝁼][∪]-distributivityₗ-raw {s = s} where
      [𝁼][∪]-distributivityₗ-raw : ∀{s} → Names.Distributivityₗ ⦃ [≅]-equiv {s = s} ⦄ (_𝁼_)(_∪_)
      _≅[_]≅_.accepts-ε ([𝁼][∪]-distributivityₗ-raw {x = x}) with accepts x
      ... | 𝑇 = [≡]-intro
      ... | 𝐹 = [≡]-intro
      _≅[_]≅_.suffix-lang ([𝁼][∪]-distributivityₗ-raw {x = x}{y}{z}) {c} with accepts x
      ... | 𝑇 =
        ((suffix x c) 𝁼 (y ∪ z)) ∪ ((suffix y c) ∪ (suffix z c))                  🝖[ _≅_ ]-[ congruence₂ₗ(_∪_) _ [𝁼][∪]-distributivityₗ-raw ]
        (((suffix x c) 𝁼 y) ∪ ((suffix x c) 𝁼 z)) ∪ ((suffix y c) ∪ (suffix z c)) 🝖[ _≅_ ]-[ One.associate-commute4 (commutativity(_∪_)) ]
        (((suffix x c) 𝁼 y) ∪ (suffix y c)) ∪ (((suffix x c) 𝁼 z) ∪ (suffix z c)) 🝖[ _≅_ ]-end
      ... | 𝐹 = [𝁼][∪]-distributivityₗ-raw

{-TODO
idempotence-by-dist-id-abs-idemp
x ∪ x
(x ∩ x) ∪ (x ∩ x)
(x ∪ x) ∩ x
(x ∪ x) ∩ (x ∪ ∅)
x ∪ (x ∩ ∅)
x ∪ ∅
x

idempotence-by-dist-inv-id
x ∪ x
(x ∪ x) ∩ 𝐔
(x ∪ x) ∩ (x ∪ (∁ x))
x ∪ (x ∩ (∁ x))
x ∪ ∅
x
-}

  instance
    [𝁼][∪]-distributivityᵣ : Distributivityᵣ ⦃ [≅]-equiv {s = s} ⦄ (_𝁼_)(_∪_)
    Distributivityᵣ.proof ([𝁼][∪]-distributivityᵣ {s}) = [𝁼][∪]-distributivityᵣ-raw where
      [𝁼][∪]-distributivityᵣ-raw : ∀{s} → Names.Distributivityᵣ ⦃ [≅]-equiv {s = s} ⦄ (_𝁼_)(_∪_)
      _≅[_]≅_.accepts-ε ([𝁼][∪]-distributivityᵣ-raw {x = x}{y}{z}) with accepts z
      ... | 𝑇 = [≡]-intro
      ... | 𝐹 = [≡]-intro
      _≅[_]≅_.suffix-lang ([𝁼][∪]-distributivityᵣ-raw {x = x}{y}{z}) {c} with accepts x | accepts y
      ... | 𝑇 | 𝑇 =
        (((suffix x c) ∪ (suffix y c)) 𝁼 z) ∪ (suffix z c)                        🝖[ _≅_ ]-[ congruence₂ₗ(_∪_) _ [𝁼][∪]-distributivityᵣ-raw ]
        (((suffix x c) 𝁼 z) ∪ ((suffix y c) 𝁼 z)) ∪ (suffix z c)                  🝖[ _≅_ ]-[ congruence₂ᵣ(_∪_) _ {!!} ]-sym
        (((suffix x c) 𝁼 z) ∪ ((suffix y c) 𝁼 z)) ∪ ((suffix z c) ∪ (suffix z c)) 🝖[ _≅_ ]-[ One.associate-commute4 (commutativity(_∪_)) ]
        (((suffix x c) 𝁼 z) ∪ (suffix z c)) ∪ (((suffix y c) 𝁼 z) ∪ (suffix z c)) 🝖[ _≅_ ]-end
      ... | 𝑇 | 𝐹 = {!!}
      ... | 𝐹 | 𝑇 = {!!}
      ... | 𝐹 | 𝐹 = {!!}

  instance
    [𝁼]-associativity : Associativity ⦃ [≅]-equiv {s = s} ⦄ (_𝁼_)
    Associativity.proof ([𝁼]-associativity {s = s}) = [𝁼]-associativity-raw {s = s} where
      [𝁼]-associativity-raw : ∀{s} → Names.Associativity ⦃ [≅]-equiv {s = s} ⦄ (_𝁼_)
      _≅[_]≅_.accepts-ε   ([𝁼]-associativity-raw {s = s} {x} {y} {z} ) with Language.accepts-ε(x)
      ... | 𝑇 = [≡]-intro
      ... | 𝐹 = [≡]-intro
      _≅[_]≅_.suffix-lang ([𝁼]-associativity-raw {s = s} {x} {y} {z}) {c} {sₛ} with [𝁼]-associativity-raw {s = sₛ} {suffix x c}{y}{z} | accepts(x) | accepts(y)
      ... | p | 𝑇 | 𝑇 =
        ((((suffix x c) 𝁼 y) ∪ (suffix y c)) 𝁼 z) ∪ (suffix z c)       🝖[ _≅_ ]-[ congruence₂ₗ(_∪_) _ (distributivityᵣ(_𝁼_)(_∪_)) ]
        ((((suffix x c) 𝁼 y) 𝁼 z) ∪ ((suffix y c) 𝁼 z)) ∪ (suffix z c) 🝖[ _≅_ ]-[ congruence₂ₗ(_∪_) _ (congruence₂ₗ(_∪_) _ p) ]
        (((suffix x c) 𝁼 (y 𝁼 z)) ∪ ((suffix y c) 𝁼 z)) ∪ (suffix z c) 🝖[ _≅_ ]-[ associativity(_∪_) ]
        ((suffix x c) 𝁼 (y 𝁼 z)) ∪ (((suffix y c) 𝁼 z) ∪ (suffix z c)) 🝖[ _≅_ ]-end
      ... | p | 𝑇 | 𝐹 =
        (((suffix x c) 𝁼 y) ∪ (suffix y c)) 𝁼 z       🝖[ _≅_ ]-[ distributivityᵣ(_𝁼_)(_∪_) ]
        (((suffix x c) 𝁼 y) 𝁼 z) ∪ ((suffix y c) 𝁼 z) 🝖[ _≅_ ]-[ congruence₂ₗ(_∪_) _ p ]
        ((suffix x c) 𝁼 (y 𝁼 z)) ∪ ((suffix y c) 𝁼 z) 🝖[ _≅_ ]-end
      ... | p | 𝐹 | _ = p

  {- TODO: Is it possible to describe concatenation using an algebraic property? Maybe something about that it behaves like (_⨯_) (combining every element with each other in some way)? Probably a "Kleene algebra".

  postulate [𝁼]-identityₗ : Identityₗ(_𝁼_)(ε)
  -- Identityₗ.proof([𝁼]-identityₗ) {x} =

  postulate [𝁼]-identityᵣ : Identityᵣ(_𝁼_)(ε)
  postulate [𝁼]-absorberₗ : Absorberₗ(_𝁼_)(∅)
  postulate [𝁼]-absorberᵣ : Absorberᵣ(_𝁼_)(∅)
--  postulate [*]-fixpoint-[ε] : FixPoint(_*)(ε)
  postulate [*]-on-[∅] : (∅ * ≡ ε)
  postulate [*]-on-[*] : ∀{L} → ((L *)* ≡ L *)
  postulate [𝁼]-commutativity-with-[*] : ∀{L} → ((L *) 𝁼 L ≡ L 𝁼 (L *))
  -- postulate [𝁼]-set-algebra : SetAlgebra -- TODO: Complement is missing
  -}

-}

module _ {Σ : Alphabet{ℓ}} where
  open Oper{ℓ}{Σ}
  open Language renaming (accepts-ε to accepts ; suffix-lang to suffix)

  open import Logic.IntroInstances
  open import Structure.Sets.Operator hiding (_∪_ ; _∩_ ; ∁ ; ∅ ; 𝐔)
  open import Structure.Sets.Relator hiding (_≡_ ; _⊆_)

  instance
    [≅]-set-equality : SetEqualityRelation([ s ]_∈_)([ s ]_∈_)(_≅[ s ]≅_)
    SetEqualityRelation.membership [≅]-set-equality {A}{B} = [↔]-intro (l{A = A}{B = B}) (r{A = A}{B = B}) where
      l : ∀{A B : Language(Σ)} → (A ≅[ s ]≅ B) ← (∀{w} → ([ s ] w ∈ A) ↔ ([ s ] w ∈ B))
      _≅[_]≅_.accepts-ε (l {A = A} {B = B} p) with accepts A | accepts B | p{[]}
      ... | 𝑇 | 𝑇 | _ = [≡]-intro
      ... | 𝑇 | 𝐹 | q with () ← [↔]-to-[→] q <>
      ... | 𝐹 | 𝑇 | q with () ← [↔]-to-[←] q <>
      ... | 𝐹 | 𝐹 | _ = [≡]-intro
      _≅[_]≅_.suffix-lang (l {A = A} {B = B} p) {c} = l {A = suffix A c}{B = suffix B c} (\{w} → p{c ⊰ w})

      r : ∀{A B : Language(Σ)} → (A ≅[ s ]≅ B) → (∀{w} → ([ s ] w ∈ A) ↔ ([ s ] w ∈ B))
      Tuple.left (r ab {[]}) wB = substitute₁ₗ(IsTrue) (_≅[_]≅_.accepts-ε ab) wB
      Tuple.right (r ab {[]}) wA = substitute₁ᵣ(IsTrue) (_≅[_]≅_.accepts-ε ab) wA
      Tuple.left (r {s = s} {A} {B} ab {_⊰_ {sₛ} x w}) wB = [↔]-to-[←] (r {s = sₛ} (_≅[_]≅_.suffix-lang {s = s} ab {sₛ = sₛ}) {w}) wB
      Tuple.right (r {s = s} {A} {B} ab {_⊰_ {sₛ} x w}) wA = [↔]-to-[→] (r {s = sₛ} (_≅[_]≅_.suffix-lang {s = s} ab {sₛ = sₛ}) {w}) wA

  instance
    [∪]-operator : UnionOperator([ s ]_∈_)([ s ]_∈_)([ s ]_∈_)(_∪_)
    UnionOperator.membership [∪]-operator {A}{B}{w} = [↔]-intro (l{w = w}{A}{B}) (r{w = w}{A}{B}) where
      l : ∀{w}{A B} → ([ s ] w ∈ (A ∪ B)) ← (([ s ] w ∈ A) ∨ ([ s ] w ∈ B))
      l {w = []}    = [↔]-to-[←] IsTrue.preserves-[||][∨]
      l {w = c ⊰ w} = l {w = w}

      r : ∀{w}{A B} → ([ s ] w ∈ (A ∪ B)) → (([ s ] w ∈ A) ∨ ([ s ] w ∈ B))
      r {w = []}    = [↔]-to-[→] IsTrue.preserves-[||][∨]
      r {w = c ⊰ w} = r {w = w}

  instance
    [∩]-operator : IntersectionOperator([ s ]_∈_)([ s ]_∈_)([ s ]_∈_)(_∩_)
    IntersectionOperator.membership [∩]-operator {A}{B}{w} = [↔]-intro (l{w = w}{A}{B}) (r{w = w}{A}{B}) where
      l : ∀{w}{A B} → ([ s ] w ∈ (A ∩ B)) ← (([ s ] w ∈ A) ∧ ([ s ] w ∈ B))
      l {w = []}    = [↔]-to-[←] IsTrue.preserves-[&&][∧]
      l {w = c ⊰ w} = l {w = w}

      r : ∀{w}{A B} → ([ s ] w ∈ (A ∩ B)) → (([ s ] w ∈ A) ∧ ([ s ] w ∈ B))
      r {w = []}    = [↔]-to-[→] IsTrue.preserves-[&&][∧]
      r {w = c ⊰ w} = r {w = w}

  instance
    [∁]-operator : ComplementOperator([ s ]_∈_)([ s ]_∈_)(∁_)
    ComplementOperator.membership [∁]-operator {A}{w} = [↔]-intro (l{w = w}{A}) (r{w = w}{A}) where
      l : ∀{w}{A} → ([ s ] w ∈ (∁ A)) ← ¬([ s ] w ∈ A)
      l {w = []}    = [↔]-to-[←] IsTrue.preserves-[!][¬]
      l {w = c ⊰ w} = l {w = w}

      r : ∀{w}{A} → ([ s ] w ∈ (∁ A)) → ¬([ s ] w ∈ A)
      r {w = []} = [↔]-to-[→] IsTrue.preserves-[!][¬]
      r {w = c ⊰ w} = r {w = w}

  instance
    [∅]-set : EmptySet([ s ]_∈_)(∅)
    EmptySet.membership [∅]-set {x = w} = p{w = w} where
      p : ∀{w} → ¬([ s ] w ∈ ∅)
      p {w = []} ()
      p {w = x ⊰ w} = p {w = w}

  instance
    [𝐔]-set : UniversalSet([ s ]_∈_)(𝐔)
    UniversalSet.membership [𝐔]-set {x = w} = p{w = w} where
      p : ∀{w} → ([ s ] w ∈ 𝐔)
      p {w = []}    = [⊤]-intro
      p {w = c ⊰ w} = p {w = w}

  [ε]-set : ∀{x} → (x ∈ ε) ↔ (x ≡ [])
  [ε]-set {x} = [↔]-intro (l{x}) (r{x}) where
    l : ∀{x} → (x ∈ ε) ← (x ≡ [])
    l {[]} [≡]-intro = [⊤]-intro

    r : ∀{x} → (x ∈ ε) → (x ≡ [])
    r {[]}    _     = [≡]-intro
    r {a ⊰ l} proof with () ← [∅]-membership {x = l} proof

  {-open import Structure.Container.SetLike hiding (_∪_ ; _∩_ ; ∁ ; ∅ ; 𝐔)
  -- TODO: Copy-pasted from the previous code that only used coinduction
  instance
    [𝁼][∪]-distributivityₗ : Distributivityₗ ⦃ [≅]-equiv {s = s} ⦄ (_𝁼_)(_∪_)
    Distributivityₗ.proof ([𝁼][∪]-distributivityₗ {s = s}) = [𝁼][∪]-distributivityₗ-raw {s = s} where
      [𝁼][∪]-distributivityₗ-raw : ∀{s} → Names.Distributivityₗ ⦃ [≅]-equiv {s = s} ⦄ (_𝁼_)(_∪_)
      _≅[_]≅_.accepts-ε ([𝁼][∪]-distributivityₗ-raw {x = x}) with accepts x
      ... | 𝑇 = [≡]-intro
      ... | 𝐹 = [≡]-intro
      _≅[_]≅_.suffix-lang ([𝁼][∪]-distributivityₗ-raw {s = s} {x = x}{y}{z}) {c} with accepts x
      ... | 𝑇 =
        ((suffix x c) 𝁼 (y ∪ z)) ∪ ((suffix y c) ∪ (suffix z c))                  🝖[ _≅[ s ]≅_ ]-[ congruence₂ₗ(_∪_) _ [𝁼][∪]-distributivityₗ-raw ]
        (((suffix x c) 𝁼 y) ∪ ((suffix x c) 𝁼 z)) ∪ ((suffix y c) ∪ (suffix z c)) 🝖[ _≅[ s ]≅_ ]-[ One.associate-commute4 (commutativity(_∪_)) ]
        (((suffix x c) 𝁼 y) ∪ (suffix y c)) ∪ (((suffix x c) 𝁼 z) ∪ (suffix z c)) 🝖[ _≅[ s ]≅_ ]-end
      ... | 𝐹 = [𝁼][∪]-distributivityₗ-raw
  -}

{- -- TODO: Sizes and (_++_)
  [𝁼]-membershipₗ : ∀{x y}{A B : Language(Σ)} → ([ s ] x ∈ A) → ([ s ] y ∈ B) → ([ s ] (x ++ y) ∈ (A 𝁼 B))
  [𝁼]-membershipₗ {x = []}   {[]}   {A}{B} xA yB with accepts A | accepts B
  ... | 𝑇 | 𝑇 = <>
  [𝁼]-membershipₗ {x = []}   {c ⊰ y}{A}{B} xA yB with accepts A
  ... | 𝑇 = [↔]-to-[←] (Union.membership {a = suffix A c 𝁼 B} {b = suffix B c} {x = y}) ([∨]-introᵣ yB)
  [𝁼]-membershipₗ {x = c ⊰ x}{y}{A}{B} xA yB with accepts A
  ... | 𝑇 = {!!}
  ... | 𝐹 = [𝁼]-membershipₗ {x = x}{y}{suffix A c}{B} {!xA!} {!!}
-}

-- [𝁼]-membershipₗ {[]}{y}{suffix }
-- [↔]-to-[←] (Union.membership {a = {!!}}{b = {!!}}{x = {!!}}) ([∨]-introᵣ yB)
{-

  single-containment : ⦃ _ : ComputablyDecidable(_≡_) ⦄ → ∀{x}{a} → (x ∈ single(a)) ↔ (x ≡ singleton(a))
  single-containment ⦃ dec ⦄ = [↔]-intro l r where
    postulate l : ∀{x}{a} → (x ∈ single(a)) ← (x ≡ singleton(a))
    {-l {c ⊰ w} [≡]-intro with ComputablyDecidable.decide(_≡_) ⦃ dec ⦄ c c
    ... | 𝑇 = {!!}
    ... | 𝐹 = {!!}-}

    postulate r : ∀{x}{a} → (x ∈ single(a)) → (x ≡ singleton(a))
    --r {c ⊰ w} p = {![↔]-to-[←] (ComputablyDecidable.proof-istrue(_≡_) {x = ?}) ?!}

  Language-list-suffix : Language(Σ) → List(Σ) → Language(Σ)
  Language-list-suffix A []      = A
  Language-list-suffix A (x ⊰ l) = Language.suffix-lang(A)(x)

  postulate suffix-concat-step : ∀{A : Language(Σ)}{l₁ l₂} → ((l₁ ++ l₂) ∈ A) → (l₂ ∈ Language-list-suffix(A)(l₁))
  -- suffix-concat-step {A}{[]}         p = p
  -- suffix-concat-step {A}{x ⊰ l₁}{l₂} p = {!!}

  postulate [𝁼]-containmentₗ : ∀{x y}{A B : Language(Σ)} → (x ∈ A) → (y ∈ B) → ((x ++ y) ∈ (A 𝁼 B))
  -- [𝁼]-containmentₗ {x} {y} {A} {B} xa xb with Language.accepts-ε(A) | y Oper.∈? B
  {-[𝁼]-containmentₗ {LongOper.empty} {LongOper.empty} {A} {B} xa xb with Language.accepts-ε(A) | Language.accepts-ε(B)
  [𝁼]-containmentₗ {LongOper.empty} {LongOper.empty} {A} {B} xa xb | 𝑇 | 𝑇 = [⊤]-intro
  [𝁼]-containmentₗ {LongOper.empty} {LongOper.prepend x y} {A} {B} xa xb = {![⊤]-intro!} where
    test : ∀{A B : Language(Σ)}{a} → ([] ∈ A) → (a ∈ B) → (a ∈ (A 𝁼 B))
    test {A}{B}{LongOper.empty} p q with Language.accepts-ε(A) | Language.accepts-ε(B)
    test {A}{B}{LongOper.empty} p q | 𝑇 | 𝑇 = [⊤]-intro
    test {A}{B}{LongOper.prepend x a} p q = {!test {A}{B}{a} p !}
    -- test {LongOper.prepend x a} p q with test {a} p (Language.suffix-lang q)
    -- ... | test = ?

  [𝁼]-containmentₗ {LongOper.prepend x x₁} {LongOper.empty} {A} {B} xa xb = {!!}
  [𝁼]-containmentₗ {LongOper.prepend x x₁} {LongOper.prepend x₂ y} {A} {B} xa xb = {!!}
-}

  -- [𝁼]-containment : ∀{x}{A B : Language(Σ)} → (x ∈ (A 𝁼 B)) ↔ ∃(a ↦ ∃ b ↦ (a ++ b ≡ x)∧(a ∈ A)∧(b ∈ B))
  -- [𝁼]-containment {x} = [↔]-intro (l{x}) (r{x}) where

-- TODO: Set properties
-- TODO: Connection with logic (from sets) in relations
-}


module Categories.Comonad.Cofree where


{-# OPTIONS --safe #-}

module Issue2250-2 where

open import Agda.Builtin.Bool
open import Agda.Builtin.Equality

data ⊥ : Set where

abstract

  f : Bool → Bool
  f x = true
  {-# INJECTIVE f #-}

  same : f true ≡ f false
  same = refl

not-same : f true ≡ f false → ⊥
not-same ()

absurd : ⊥
absurd = not-same same


{-

Proof of the standard formulation of the univalence theorem and
various consequences of univalence

- Re-exports Glue types from Cubical.Core.Glue
- The ua constant and its computation rule (up to a path)
- Proof of univalence using that unglue is an equivalence ([EquivContr])
- Equivalence induction ([EquivJ], [elimEquiv])
- Univalence theorem ([univalence])
- The computation rule for ua ([uaβ])
- Isomorphism induction ([elimIso])

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Foundations.Univalence where

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

open import Cubical.Data.Sigma.Base

open import Cubical.Core.Glue public
  using ( Glue ; glue ; unglue ; lineToEquiv )

open import Cubical.Reflection.StrictEquiv

private
  variable
    ℓ ℓ' : Level

-- The ua constant
ua : ∀ {A B : Type ℓ} → A ≃ B → A ≡ B
ua {A = A} {B = B} e i = Glue B (λ { (i = i0) → (A , e)
                                   ; (i = i1) → (B , idEquiv B) })

uaIdEquiv : {A : Type ℓ} → ua (idEquiv A) ≡ refl
uaIdEquiv {A = A} i j = Glue A {φ = i ∨ ~ j ∨ j} (λ _ → A , idEquiv A)

-- Propositional extensionality
hPropExt : {A B : Type ℓ} → isProp A → isProp B → (A → B) → (B → A) → A ≡ B
hPropExt Aprop Bprop f g = ua (propBiimpl→Equiv Aprop Bprop f g)

-- the unglue and glue primitives specialized to the case of ua

ua-unglue : ∀ {A B : Type ℓ} (e : A ≃ B) (i : I) (x : ua e i)
            → B {- [ _ ↦ (λ { (i = i0) → e .fst x ; (i = i1) → x }) ] -}
ua-unglue e i x = unglue (i ∨ ~ i) x

ua-glue : ∀ {A B : Type ℓ} (e : A ≃ B) (i : I) (x : Partial (~ i) A)
            (y : B [ _ ↦ (λ { (i = i0) → e .fst (x 1=1) }) ])
          → ua e i {- [ _ ↦ (λ { (i = i0) → x 1=1 ; (i = i1) → outS y }) ] -}
ua-glue e i x y = glue {φ = i ∨ ~ i} (λ { (i = i0) → x 1=1 ; (i = i1) → outS y }) (outS y)

module _ {A B : Type ℓ} (e : A ≃ B) {x : A} {y : B} where
  -- sometimes more useful are versions of these functions with the (i : I) factored in

  ua-ungluePath : PathP (λ i → ua e i) x y → e .fst x ≡ y
  ua-ungluePath p i = ua-unglue e i (p i)

  ua-gluePath : e .fst x ≡ y → PathP (λ i → ua e i) x y
  ua-gluePath p i = ua-glue e i (λ { (i = i0) → x }) (inS (p i))

  -- ua-ungluePath and ua-gluePath are definitional inverses
  ua-ungluePath-Equiv : (PathP (λ i → ua e i) x y) ≃ (e .fst x ≡ y)
  unquoteDef ua-ungluePath-Equiv =
    defStrictEquiv ua-ungluePath-Equiv ua-ungluePath ua-gluePath

-- ua-unglue and ua-glue are also definitional inverses, in a way
-- strengthening the types of ua-unglue and ua-glue gives a nicer formulation of this, see below

ua-unglue-glue : ∀ {A B : Type ℓ} (e : A ≃ B) (i : I) (x : Partial (~ i) A) (y : B [ _ ↦ _ ])
                 → ua-unglue e i (ua-glue e i x y) ≡ outS y
ua-unglue-glue _ _ _ _ = refl

ua-glue-unglue : ∀ {A B : Type ℓ} (e : A ≃ B) (i : I) (x : ua e i)
                 → ua-glue e i (λ { (i = i0) → x }) (inS (ua-unglue e i x)) ≡ x
ua-glue-unglue _ _ _ = refl

-- mainly for documentation purposes, ua-unglue and ua-glue wrapped in cubical subtypes

ua-unglueS : ∀ {A B : Type ℓ} (e : A ≃ B) (i : I) (x : A) (y : B)
             → ua e i [ _ ↦ (λ { (i = i0) → x        ; (i = i1) → y }) ]
             → B      [ _ ↦ (λ { (i = i0) → e .fst x ; (i = i1) → y }) ]
ua-unglueS e i x y s = inS (ua-unglue e i (outS s))

ua-glueS : ∀ {A B : Type ℓ} (e : A ≃ B) (i : I) (x : A) (y : B)
           → B      [ _ ↦ (λ { (i = i0) → e .fst x ; (i = i1) → y }) ]
           → ua e i [ _ ↦ (λ { (i = i0) → x        ; (i = i1) → y }) ]
ua-glueS e i x y s = inS (ua-glue e i (λ { (i = i0) → x }) (inS (outS s)))

ua-unglueS-glueS : ∀ {A B : Type ℓ} (e : A ≃ B) (i : I) (x : A) (y : B)
                     (s : B [ _ ↦ (λ { (i = i0) → e .fst x ; (i = i1) → y }) ])
                   → outS (ua-unglueS e i x y (ua-glueS e i x y s)) ≡ outS s
ua-unglueS-glueS _ _ _ _ _ = refl

ua-glueS-unglueS : ∀ {A B : Type ℓ} (e : A ≃ B) (i : I) (x : A) (y : B)
                     (s : ua e i [ _ ↦ (λ { (i = i0) → x ; (i = i1) → y }) ])
                   → outS (ua-glueS e i x y (ua-unglueS e i x y s)) ≡ outS s
ua-glueS-unglueS _ _ _ _ _ = refl

-- a version of ua-glue with a single endpoint, identical to `ua-gluePath e {x} refl i`
ua-gluePt : ∀ {A B : Type ℓ} (e : A ≃ B) (i : I) (x : A)
            → ua e i {- [ _ ↦ (λ { (i = i0) → x ; (i = i1) → e .fst x }) ] -}
ua-gluePt e i x = ua-glue e i (λ { (i = i0) → x }) (inS (e .fst x))

-- Proof of univalence using that unglue is an equivalence:

-- unglue is an equivalence
unglueIsEquiv : ∀ (A : Type ℓ) (φ : I)
                (f : PartialP φ (λ o → Σ[ T ∈ Type ℓ ] T ≃ A)) →
                isEquiv {A = Glue A f} (unglue φ)
equiv-proof (unglueIsEquiv A φ f) = λ (b : A) →
  let u : I → Partial φ A
      u i = λ{ (φ = i1) → equivCtr (f 1=1 .snd) b .snd (~ i) }
      ctr : fiber (unglue φ) b
      ctr = ( glue (λ { (φ = i1) → equivCtr (f 1=1 .snd) b .fst }) (hcomp u b)
            , λ j → hfill u (inS b) (~ j))
  in ( ctr
     , λ (v : fiber (unglue φ) b) i →
         let u' : I → Partial (φ ∨ ~ i ∨ i) A
             u' j = λ { (φ = i1) → equivCtrPath (f 1=1 .snd) b v i .snd (~ j)
                      ; (i = i0) → hfill u (inS b) j
                      ; (i = i1) → v .snd (~ j) }
         in ( glue (λ { (φ = i1) → equivCtrPath (f 1=1 .snd) b v i .fst }) (hcomp u' b)
            , λ j → hfill u' (inS b) (~ j)))

-- Any partial family of equivalences can be extended to a total one
-- from Glue [ φ ↦ (T,f) ] A to A
unglueEquiv : ∀ (A : Type ℓ) (φ : I)
              (f : PartialP φ (λ o → Σ[ T ∈ Type ℓ ] T ≃ A)) →
              (Glue A f) ≃ A
unglueEquiv A φ f = ( unglue φ , unglueIsEquiv A φ f )

-- The following is a formulation of univalence proposed by Martín Escardó:
-- https://groups.google.com/forum/#!msg/homotopytypetheory/HfCB_b-PNEU/Ibb48LvUMeUJ
-- See also Theorem 5.8.4 of the HoTT Book.
--
-- The reason we have this formulation in the core library and not the
-- standard one is that this one is more direct to prove using that
-- unglue is an equivalence. The standard formulation can be found in
-- Cubical/Basics/Univalence.
--
EquivContr : ∀ (A : Type ℓ) → ∃![ T ∈ Type ℓ ] (T ≃ A)
EquivContr {ℓ = ℓ} A =
  ( (A , idEquiv A)
  , idEquiv≡ )
 where
  idEquiv≡ : (y : Σ (Type ℓ) (λ T → T ≃ A)) → (A , idEquiv A) ≡ y
  idEquiv≡ w = \ { i .fst                   → Glue A (f i)
                 ; i .snd .fst              → unglueEquiv _ _ (f i) .fst
                 ; i .snd .snd .equiv-proof → unglueEquiv _ _ (f i) .snd .equiv-proof
                 }
    where
      f : ∀ i → PartialP (~ i ∨ i) (λ x → Σ[ T ∈ Type ℓ ] T ≃ A)
      f i = λ { (i = i0) → A , idEquiv A ; (i = i1) → w }

contrSinglEquiv : {A B : Type ℓ} (e : A ≃ B) → (B , idEquiv B) ≡ (A , e)
contrSinglEquiv {A = A} {B = B} e =
  isContr→isProp (EquivContr B) (B , idEquiv B) (A , e)

-- Equivalence induction
EquivJ : {A B : Type ℓ} (P : (A : Type ℓ) → (e : A ≃ B) → Type ℓ')
       → (r : P B (idEquiv B)) → (e : A ≃ B) → P A e
EquivJ P r e = subst (λ x → P (x .fst) (x .snd)) (contrSinglEquiv e) r

-- Assuming that we have an inverse to ua we can easily prove univalence
module Univalence (au : ∀ {ℓ} {A B : Type ℓ} → A ≡ B → A ≃ B)
                  (aurefl : ∀ {ℓ} {A B : Type ℓ} → au refl ≡ idEquiv A) where

  ua-au : {A B : Type ℓ} (p : A ≡ B) → ua (au p) ≡ p
  ua-au {B = B} = J (λ _ p → ua (au p) ≡ p)
                    (cong ua (aurefl {B = B}) ∙ uaIdEquiv)

  au-ua : {A B : Type ℓ} (e : A ≃ B) → au (ua e) ≡ e
  au-ua {B = B} = EquivJ (λ _ f → au (ua f) ≡ f)
                         (subst (λ r → au r ≡ idEquiv _) (sym uaIdEquiv) (aurefl {B = B}))

  isoThm : ∀ {ℓ} {A B : Type ℓ} → Iso (A ≡ B) (A ≃ B)
  isoThm .Iso.fun = au
  isoThm .Iso.inv = ua
  isoThm .Iso.rightInv = au-ua
  isoThm .Iso.leftInv = ua-au

  thm : ∀ {ℓ} {A B : Type ℓ} → isEquiv au
  thm {A = A} {B = B} = isoToIsEquiv {B = A ≃ B} isoThm

pathToEquiv : {A B : Type ℓ} → A ≡ B → A ≃ B
pathToEquiv p = lineToEquiv (λ i → p i)

pathToEquivRefl : {A : Type ℓ} → pathToEquiv refl ≡ idEquiv A
pathToEquivRefl {A = A} = equivEq (λ i x → transp (λ _ → A) i x)

pathToEquiv-ua : {A B : Type ℓ} (e : A ≃ B) → pathToEquiv (ua e) ≡ e
pathToEquiv-ua = Univalence.au-ua pathToEquiv pathToEquivRefl

ua-pathToEquiv : {A B : Type ℓ} (p : A ≡ B) → ua (pathToEquiv p) ≡ p
ua-pathToEquiv = Univalence.ua-au pathToEquiv pathToEquivRefl

-- Univalence
univalenceIso : {A B : Type ℓ} → Iso (A ≡ B) (A ≃ B)
univalenceIso = Univalence.isoThm pathToEquiv pathToEquivRefl

univalence : {A B : Type ℓ} → (A ≡ B) ≃ (A ≃ B)
univalence = ( pathToEquiv , Univalence.thm pathToEquiv pathToEquivRefl  )

-- The original map from UniMath/Foundations
eqweqmap : {A B : Type ℓ} → A ≡ B → A ≃ B
eqweqmap {A = A} e = J (λ X _ → A ≃ X) (idEquiv A) e

eqweqmapid : {A : Type ℓ} → eqweqmap refl ≡ idEquiv A
eqweqmapid {A = A} = JRefl (λ X _ → A ≃ X) (idEquiv A)

univalenceStatement : {A B : Type ℓ} → isEquiv (eqweqmap {ℓ} {A} {B})
univalenceStatement = Univalence.thm eqweqmap eqweqmapid

univalenceUAH : {A B : Type ℓ} → (A ≡ B) ≃ (A ≃ B)
univalenceUAH = ( _ , univalenceStatement )

univalencePath : {A B : Type ℓ} → (A ≡ B) ≡ Lift (A ≃ B)
univalencePath = ua (compEquiv univalence LiftEquiv)

-- The computation rule for ua. Because of "ghcomp" it is now very
-- simple compared to cubicaltt:
-- https://github.com/mortberg/cubicaltt/blob/master/examples/univalence.ctt#L202
uaβ : {A B : Type ℓ} (e : A ≃ B) (x : A) → transport (ua e) x ≡ equivFun e x
uaβ e x = transportRefl (equivFun e x)

uaη : ∀ {A B : Type ℓ} → (P : A ≡ B) → ua (pathToEquiv P) ≡ P
uaη = J (λ _ q → ua (pathToEquiv q) ≡ q) (cong ua pathToEquivRefl ∙ uaIdEquiv)

-- Lemmas for constructing and destructing dependent paths in a function type where the domain is ua.
ua→ : ∀ {ℓ ℓ'} {A₀ A₁ : Type ℓ} {e : A₀ ≃ A₁} {B : (i : I) → Type ℓ'}
  {f₀ : A₀ → B i0} {f₁ : A₁ → B i1}
  → ((a : A₀) → PathP B (f₀ a) (f₁ (e .fst a)))
  → PathP (λ i → ua e i → B i) f₀ f₁
ua→ {e = e} {f₀ = f₀} {f₁} h i a =
  hcomp
    (λ j → λ
      { (i = i0) → f₀ a
      ; (i = i1) → f₁ (lem a j)
      })
    (h (transp (λ j → ua e (~ j ∧ i)) (~ i) a) i)
  where
  lem : ∀ a₁ → e .fst (transport (sym (ua e)) a₁) ≡ a₁
  lem a₁ = retEq e _ ∙ transportRefl _

ua→⁻ : ∀ {ℓ ℓ'} {A₀ A₁ : Type ℓ} {e : A₀ ≃ A₁} {B : (i : I) → Type ℓ'}
  {f₀ : A₀ → B i0} {f₁ : A₁ → B i1}
  → PathP (λ i → ua e i → B i) f₀ f₁
  → ((a : A₀) → PathP B (f₀ a) (f₁ (e .fst a)))
ua→⁻ {e = e} {f₀ = f₀} {f₁} p a i =
  hcomp
    (λ k → λ
      { (i = i0) → f₀ a
      ; (i = i1) → f₁ (uaβ e a k)
      })
    (p i (transp (λ j → ua e (j ∧ i)) (~ i) a))

-- Useful lemma for unfolding a transported function over ua
-- If we would have regularity this would be refl
transportUAop₁ : ∀ {A B : Type ℓ} → (e : A ≃ B) (f : A → A) (x : B)
               → transport (λ i → ua e i → ua e i) f x ≡ equivFun e (f (invEq e x))
transportUAop₁ e f x i = transportRefl (equivFun e (f (invEq e (transportRefl x i)))) i

-- Binary version
transportUAop₂ : ∀ {ℓ} {A B : Type ℓ} → (e : A ≃ B) (f : A → A → A) (x y : B)
               → transport (λ i → ua e i → ua e i → ua e i) f x y ≡
                 equivFun e (f (invEq e x) (invEq e y))
transportUAop₂ e f x y i =
    transportRefl (equivFun e (f (invEq e (transportRefl x i))
                                 (invEq e (transportRefl y i)))) i

-- Alternative version of EquivJ that only requires a predicate on functions
elimEquivFun : {A B : Type ℓ} (P : (A : Type ℓ) → (A → B) → Type ℓ')
             → (r : P B (idfun B)) → (e : A ≃ B) → P A (e .fst)
elimEquivFun P r e = subst (λ x → P (x .fst) (x .snd .fst)) (contrSinglEquiv e) r

-- Isomorphism induction
elimIso : {B : Type ℓ} → (Q : {A : Type ℓ} → (A → B) → (B → A) → Type ℓ') →
          (h : Q (idfun B) (idfun B)) → {A : Type ℓ} →
          (f : A → B) → (g : B → A) → section f g → retract f g → Q f g
elimIso {ℓ} {ℓ'} {B} Q h {A} f g sfg rfg = rem1 f g sfg rfg
  where
  P : (A : Type ℓ) → (f : A → B) → Type (ℓ-max ℓ' ℓ)
  P A f = (g : B → A) → section f g → retract f g → Q f g

  rem : P B (idfun B)
  rem g sfg rfg = subst (Q (idfun B)) (λ i b → (sfg b) (~ i)) h

  rem1 : {A : Type ℓ} → (f : A → B) → P A f
  rem1 f g sfg rfg = elimEquivFun P rem (f , isoToIsEquiv (iso f g sfg rfg)) g sfg rfg

uaInvEquiv : ∀ {A B : Type ℓ} → (e : A ≃ B) → ua (invEquiv e) ≡ sym (ua e)
uaInvEquiv {B = B} = EquivJ (λ _ e → ua (invEquiv e) ≡ sym (ua e))
                            (cong ua (invEquivIdEquiv B))

uaCompEquiv : ∀ {A B C : Type ℓ} → (e : A ≃ B) (f : B ≃ C) → ua (compEquiv e f) ≡ ua e ∙ ua f
uaCompEquiv {B = B} {C} = EquivJ (λ _ e → (f : B ≃ C) → ua (compEquiv e f) ≡ ua e ∙ ua f)
                                 (λ f → cong ua (compEquivIdEquiv f)
                                        ∙ sym (cong (λ x → x ∙ ua f) uaIdEquiv
                                        ∙ sym (lUnit (ua f))))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Lexicographic ordering of lists
------------------------------------------------------------------------

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

module Data.List.Relation.Binary.Lex.Core where

open import Data.Empty using (⊥; ⊥-elim)
open import Data.Unit.Base using (⊤; tt)
open import Function using (_∘_; flip; id)
open import Data.Product using (_,_; proj₁; proj₂)
open import Data.List.Base using (List; []; _∷_)
open import Level using (_⊔_)
open import Relation.Nullary using (Dec; yes; no; ¬_)
open import Relation.Binary
open import Data.List.Relation.Binary.Pointwise
   using (Pointwise; []; _∷_; head; tail)

-- The lexicographic ordering itself can be either strict or non-strict,
-- depending on whether type P is inhabited.

data Lex {a ℓ₁ ℓ₂} {A : Set a} (P : Set)
         (_≈_ : Rel A ℓ₁) (_≺_ : Rel A ℓ₂) :
         Rel (List A) (a ⊔ ℓ₁ ⊔ ℓ₂) where
  base : P                             → Lex P _≈_ _≺_ []       []
  halt : ∀ {y ys}                      → Lex P _≈_ _≺_ []       (y ∷ ys)
  this : ∀ {x xs y ys} (x≺y : x ≺ y)   → Lex P _≈_ _≺_ (x ∷ xs) (y ∷ ys)
  next : ∀ {x xs y ys} (x≈y : x ≈ y)
         (xs<ys : Lex P _≈_ _≺_ xs ys) → Lex P _≈_ _≺_ (x ∷ xs) (y ∷ ys)

-- Properties

module _ {a ℓ₁ ℓ₂} {A : Set a} {P : Set}
         {_≈_ : Rel A ℓ₁} {_≺_ : Rel A ℓ₂} where

  private
    _≋_ = Pointwise _≈_
    _<_ = Lex P _≈_ _≺_

  ¬≤-this : ∀ {x y xs ys} → ¬ (x ≈ y) → ¬ (x ≺ y) →
            ¬ (x ∷ xs) < (y ∷ ys)
  ¬≤-this x≉y x≮y (this x≺y)       = x≮y x≺y
  ¬≤-this x≉y x≮y (next x≈y xs<ys) = x≉y x≈y

  ¬≤-next : ∀ {x y xs ys} → ¬ x ≺ y → ¬ xs < ys →
            ¬ (x ∷ xs) < (y ∷ ys)
  ¬≤-next x≮y xs≮ys (this x≺y)     = x≮y x≺y
  ¬≤-next x≮y xs≮ys (next _ xs<ys) = xs≮ys xs<ys

  transitive : IsEquivalence _≈_ → _≺_ Respects₂ _≈_ → Transitive _≺_ →
               Transitive _<_
  transitive eq resp tr = trans
    where
    trans : Transitive (Lex P _≈_ _≺_)
    trans (base p)         (base _)         = base p
    trans (base y)         halt             = halt
    trans halt             (this y≺z)       = halt
    trans halt             (next y≈z ys<zs) = halt
    trans (this x≺y)       (this y≺z)       = this (tr x≺y y≺z)
    trans (this x≺y)       (next y≈z ys<zs) = this (proj₁ resp y≈z x≺y)
    trans (next x≈y xs<ys) (this y≺z)       =
      this (proj₂ resp (IsEquivalence.sym eq x≈y) y≺z)
    trans (next x≈y xs<ys) (next y≈z ys<zs) =
      next (IsEquivalence.trans eq x≈y y≈z) (trans xs<ys ys<zs)

  antisymmetric : Symmetric _≈_ → Irreflexive _≈_ _≺_ →
                  Asymmetric _≺_ → Antisymmetric _≋_ _<_
  antisymmetric sym ir asym = as
    where
    as : Antisymmetric _≋_ _<_
    as (base _)         (base _)         = []
    as halt             ()
    as (this x≺y)       (this y≺x)       = ⊥-elim (asym x≺y y≺x)
    as (this x≺y)       (next y≈x ys<xs) = ⊥-elim (ir (sym y≈x) x≺y)
    as (next x≈y xs<ys) (this y≺x)       = ⊥-elim (ir (sym x≈y) y≺x)
    as (next x≈y xs<ys) (next y≈x ys<xs) = x≈y ∷ as xs<ys ys<xs

  respects₂ : IsEquivalence _≈_ → _≺_ Respects₂ _≈_ → _<_ Respects₂ _≋_
  respects₂ eq (resp₁ , resp₂) = resp¹ , resp²
    where
    open IsEquivalence eq using (sym; trans)
    resp¹ : ∀ {xs} → Lex P _≈_ _≺_ xs Respects _≋_
    resp¹ []            xs<[]            = xs<[]
    resp¹ (_   ∷ _)     halt             = halt
    resp¹ (x≈y ∷ _)     (this z≺x)       = this (resp₁ x≈y z≺x)
    resp¹ (x≈y ∷ xs≋ys) (next z≈x zs<xs) =
      next (trans z≈x x≈y) (resp¹ xs≋ys zs<xs)

    resp² : ∀ {ys} → flip (Lex P _≈_ _≺_) ys Respects _≋_
    resp² []            []<ys            = []<ys
    resp² (x≈z ∷ _)     (this x≺y)       = this (resp₂ x≈z x≺y)
    resp² (x≈z ∷ xs≋zs) (next x≈y xs<ys) =
      next (trans (sym x≈z) x≈y) (resp² xs≋zs xs<ys)

  decidable : Dec P → Decidable _≈_ → Decidable _≺_ → Decidable _<_
  decidable (yes p) dec-≈ dec-≺ []       []       = yes (base p)
  decidable (no ¬p) dec-≈ dec-≺ []       []       = no λ{(base p) → ¬p p}
  decidable dec-P   dec-≈ dec-≺ []       (y ∷ ys) = yes halt
  decidable dec-P   dec-≈ dec-≺ (x ∷ xs) []       = no λ()
  decidable dec-P   dec-≈ dec-≺ (x ∷ xs) (y ∷ ys) with dec-≺ x y
  ... | yes x≺y = yes (this x≺y)
  ... | no x≮y with dec-≈ x y
  ...   | no x≉y = no (¬≤-this x≉y x≮y)
  ...   | yes x≈y with decidable dec-P dec-≈ dec-≺ xs ys
  ...     | yes xs<ys = yes (next x≈y xs<ys)
  ...     | no  xs≮ys = no (¬≤-next x≮y xs≮ys)


-- {-# OPTIONS -v tc.cover.split.con:100 #-}

{-# OPTIONS --show-implicit #-}

data D : Set where
  d : {x : D} → D

f : D → Set
f y = {!!}


-- The Agda primitives (preloaded).

{-# OPTIONS --without-K --no-subtyping --no-import-sorts #-}

module Agda.Primitive where

------------------------------------------------------------------------
-- Universe levels
------------------------------------------------------------------------

infixl 6 _⊔_

{-# BUILTIN TYPE Set #-}
{-# BUILTIN PROP Prop #-}
{-# BUILTIN SETOMEGA Setω #-}

-- Level is the first thing we need to define.
-- The other postulates can only be checked if built-in Level is known.

postulate
  Level : Set

-- MAlonzo compiles Level to (). This should be safe, because it is
-- not possible to pattern match on levels.

{-# BUILTIN LEVEL Level #-}

postulate
  lzero : Level
  lsuc  : (ℓ : Level) → Level
  _⊔_   : (ℓ₁ ℓ₂ : Level) → Level

{-# BUILTIN LEVELZERO lzero #-}
{-# BUILTIN LEVELSUC  lsuc  #-}
{-# BUILTIN LEVELMAX  _⊔_   #-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Lists with fast append
------------------------------------------------------------------------

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

module Data.DifferenceList where

open import Data.List.Base as L using (List)
open import Function
open import Data.Nat.Base

infixr 5 _∷_ _++_

DiffList : ∀ {ℓ} → Set ℓ → Set ℓ
DiffList A = List A → List A

lift : ∀ {a} {A : Set a} →
       (List A → List A) → (DiffList A → DiffList A)
lift f xs = λ k → f (xs k)

[] : ∀ {a} {A : Set a} → DiffList A
[] = λ k → k

_∷_ : ∀ {a} {A : Set a} → A → DiffList A → DiffList A
_∷_ x = lift (L._∷_ x)

[_] : ∀ {a} {A : Set a} → A → DiffList A
[ x ] = x ∷ []

_++_ : ∀ {a} {A : Set a} → DiffList A → DiffList A → DiffList A
xs ++ ys = λ k → xs (ys k)

toList : ∀ {a} {A : Set a} → DiffList A → List A
toList xs = xs L.[]

-- fromList xs is linear in the length of xs.

fromList : ∀ {a} {A : Set a} → List A → DiffList A
fromList xs = λ k → xs ⟨ L._++_ ⟩ k

-- It is OK to use L._++_ here, since map is linear in the length of
-- the list anyway.

map : ∀ {a b} {A : Set a} {B : Set b} →
      (A → B) → DiffList A → DiffList B
map f xs = λ k → L.map f (toList xs) ⟨ L._++_ ⟩ k

-- concat is linear in the length of the outer list.

concat : ∀ {a} {A : Set a} → DiffList (DiffList A) → DiffList A
concat xs = concat' (toList xs)
  where
  concat' : ∀ {a} {A : Set a} → List (DiffList A) → DiffList A
  concat' = L.foldr _++_ []

take : ∀ {a} {A : Set a} → ℕ → DiffList A → DiffList A
take n = lift (L.take n)

drop : ∀ {a} {A : Set a} → ℕ → DiffList A → DiffList A
drop n = lift (L.drop n)


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

module Definition.Typed.Consequences.Equality where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.EqRelInstance
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Fundamental.Reducibility

open import Tools.Embedding
open import Tools.Product
import Tools.PropositionalEquality as PE

U≡A′ : ∀ {A Γ l} ([U] : Γ ⊩⟨ l ⟩U)
    → Γ ⊩⟨ l ⟩ U ≡ A / (U-intr [U])
    → A PE.≡ U
U≡A′ (noemb [U]) (U₌ [U≡A]) = [U≡A]
U≡A′ (emb 0<1 [U]) (ιx [U≡A]) = U≡A′ [U] [U≡A]

-- If A is judgmentally equal to U, then A is propsitionally equal to U.
U≡A : ∀ {A Γ}
    → Γ ⊢ U ≡ A
    → A PE.≡ U
U≡A {A} U≡A with reducibleEq U≡A
U≡A {A} U≡A | [U] , [A] , [U≡A] =
  U≡A′ (U-elim [U]) (irrelevanceEq [U] (U-intr (U-elim [U])) [U≡A])

ℕ≡A′ : ∀ {A Γ l} ([ℕ] : Γ ⊩⟨ l ⟩ℕ ℕ)
    → Γ ⊩⟨ l ⟩ ℕ ≡ A / (ℕ-intr [ℕ])
    → Whnf A
    → A PE.≡ ℕ
ℕ≡A′ (noemb x) (ιx (ℕ₌ [ℕ≡A])) whnfA = whnfRed* [ℕ≡A] whnfA
ℕ≡A′ (emb 0<1 [ℕ]) (ιx [ℕ≡A]) whnfA = ℕ≡A′ [ℕ] [ℕ≡A] whnfA

-- If A in WHNF is judgmentally equal to ℕ, then A is propsitionally equal to ℕ.
ℕ≡A : ∀ {A Γ}
    → Γ ⊢ ℕ ≡ A
    → Whnf A
    → A PE.≡ ℕ
ℕ≡A {A} ℕ≡A whnfA with reducibleEq ℕ≡A
ℕ≡A {A} ℕ≡A whnfA | [ℕ] , [A] , [ℕ≡A] =
  ℕ≡A′ (ℕ-elim [ℕ]) (irrelevanceEq [ℕ] (ℕ-intr (ℕ-elim [ℕ])) [ℕ≡A]) whnfA

ne≡A′ : ∀ {A K Γ l}
     → ([K] : Γ ⊩⟨ l ⟩ne K)
     → Γ ⊩⟨ l ⟩ K ≡ A / (ne-intr [K])
     → Whnf A
     → ∃ λ M → Neutral M × A PE.≡ M
ne≡A′ (noemb [K]) (ιx (ne₌ M D′ neM K≡M)) whnfA =
  M , neM , (whnfRed* (red D′) whnfA)
ne≡A′ (emb 0<1 [K]) (ιx [K≡A]) whnfA = ne≡A′ [K] [K≡A] whnfA

-- If A in WHNF is judgmentally equal to K, then there exists a M such that
-- A is propsitionally equal to M.
ne≡A : ∀ {A K Γ}
    → Neutral K
    → Γ ⊢ K ≡ A
    → Whnf A
    → ∃ λ M → Neutral M × A PE.≡ M
ne≡A {A} neK ne≡A whnfA with reducibleEq ne≡A
ne≡A {A} neK ne≡A whnfA | [ne] , [A] , [ne≡A] =
  ne≡A′ (ne-elim neK [ne])
        (irrelevanceEq [ne] (ne-intr (ne-elim neK [ne])) [ne≡A]) whnfA

Π≡A′ : ∀ {A F G Γ l} ([Π] : Γ ⊩⟨ l ⟩Π Π F ▹ G)
    → Γ ⊩⟨ l ⟩ Π F ▹ G ≡ A / (Π-intr [Π])
    → Whnf A
    → ∃₂ λ H E → A PE.≡ Π H ▹ E
Π≡A′ (noemb [Π]) (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) whnfA =
  F′ , G′ , whnfRed* D′ whnfA
Π≡A′ (emb 0<1 [Π]) (ιx [Π≡A]) whnfA = Π≡A′ [Π] [Π≡A] whnfA

-- If A is judgmentally equal to Π F ▹ G, then there exists H and E such that
-- A is propsitionally equal to  Π H ▹ E.
Π≡A : ∀ {A F G Γ}
    → Γ ⊢ Π F ▹ G ≡ A
    → Whnf A
    → ∃₂ λ H E → A PE.≡ Π H ▹ E
Π≡A {A} Π≡A whnfA with reducibleEq Π≡A
Π≡A {A} Π≡A whnfA | [Π] , [A] , [Π≡A] =
  Π≡A′ (Π-elim [Π]) (irrelevanceEq [Π] (Π-intr (Π-elim [Π])) [Π≡A]) whnfA


open import Agda.Builtin.Equality

postulate
  A : Set

mutual
  F : ((@♭ _ : A) -> A) → A → A
  F f = _

  testF : {f : A -> A} → F f ≡ f
  testF = refl


open import Prelude hiding (id; Bool; _∷_; [])

module Examples.CompleteResolution where

data TC : Set where
  tc-int : TC
  tc-bool : TC

_tc≟_ : (a b : TC) → Dec (a ≡ b)
tc-int tc≟ tc-int = yes refl
tc-int tc≟ tc-bool = no (λ ())
tc-bool tc≟ tc-int = no (λ ())
tc-bool tc≟ tc-bool = yes refl

open import Implicits.Syntax TC _tc≟_
open import Implicits.WellTyped TC _tc≟_
open import Implicits.Substitutions TC _tc≟_
open import Implicits.Syntax.Type.Unification TC _tc≟_
open import Implicits.Resolution.Finite.Resolution TC _tc≟_
open import Implicits.Resolution.Finite.Algorithm TC _tc≟_
open import Data.Maybe
open import Data.List
open import Category.Monad.Partiality

Bool : ∀ {n} → Type n
Bool = simpl (tc tc-bool)

Int : ∀ {n} → Type n
Int = simpl (tc tc-int)

module Ex₁ where

  Δ : ICtx zero
  Δ = Bool ∷ Int ∷ []

  -- resolves directly using a value from the implicit context
  r = resolve Δ Int

  p : is-just r ≡ true
  p = refl

module Ex₂ where

  Δ : ICtx zero
  Δ = Bool ∷ (Bool ⇒ Int) ∷ []

  -- resolves using implicit application
  r = resolve Δ Int

  p : is-just r ≡ true
  p = refl

module Ex₃ where

  Δ : ICtx zero
  Δ = Bool ∷ (∀' (Bool ⇒ (simpl (tvar zero)))) ∷ []

  -- resolves using polymorphic implicit application
  r = resolve Δ Int

  p : is-just r ≡ true
  p = refl

module Ex₅ where

  -- The following context would not resolved Int in Oliveira's deterministic calculus.
  -- Demonstratint that partial resolution is more powerful for terminating contexts.
  Δ : ICtx zero
  Δ = (Bool ⇒ Int) ∷ Int ∷ []

  r = resolve Δ Int

  p : is-just r ≡ true
  p = refl

module Ex₆ where

  Δ : ICtx zero
  Δ = Bool ∷ (∀' (Bool ⇒ (simpl (tvar zero)))) ∷ []

  -- resolves rule types
  r = resolve Δ (Bool ⇒ Int)

  p : is-just r ≡ true
  p = refl

module Ex₇ where

  Δ : ICtx zero
  Δ = Bool ∷ (∀' (Bool ⇒ (simpl (tvar zero)))) ∷ []

  q : Type zero
  q = (∀' (Bool ⇒ (simpl (tvar zero))))

  -- Resolves polymorphic types.
  -- Note that it doesn't resolve to the rule in the context directly.
  -- Instead, it will apply r-tabs and r-iabs, to obtain resolve Δ' ⊢ᵣ (∀' (tvar zero))
  r = resolve Δ q

  p : is-just r ≡ true
  p = refl

module Ex₈ where

  Δ : ICtx zero
  Δ = Bool ∷ (∀' ((simpl (tvar zero)) ⇒ (simpl (tvar zero)))) ∷ []

  -- infinite derivation exists: fails divergence checking
  r = resolve Δ Int

  p : is-just r ≡ false
  p = refl

module Ex₉ where

  a⇒consta : Type zero
  a⇒consta = (∀' ((simpl (tvar zero)) ⇒ (∀' (simpl (simpl (tvar zero) →' (simpl (tvar (suc zero))))))))

  Δ : ICtx zero
  Δ = Bool ∷ a⇒consta ∷ []

  const-bool : Type zero
  const-bool = (∀' (simpl ((simpl (tvar zero)) →' Bool)))

  r = resolve Δ const-bool

  p : is-just r ≡ true
  p = refl

module Ex₁₀ where

  -- similar to Ex₉ but for this particular example we have that for the rule part
  -- || ρ₁ || ≮ || ρ₂ || such that Oliveira's ⊢term predicate on ρ₁ ⇒ ρ₂ fails
  a⇒∀a : Type zero
  a⇒∀a = (∀' ((simpl (tvar zero)) ⇒ (∀' (simpl (tvar (suc zero))))))

  Δ : ICtx zero
  Δ = Bool ∷ a⇒∀a ∷ []

  r = resolve Δ (∀' Bool)

  p : is-just r ≡ true
  p = refl


module PiQ.Examples where
open import Data.Empty
open import Data.Unit hiding (_≟_)
open import Data.Sum
open import Data.Product
open import Data.Maybe
open import Data.Nat
open import Data.Nat.Properties
open import Relation.Binary.PropositionalEquality
open import PiQ.Syntax
open import PiQ.Opsem
open import PiQ.Eval
open import PiQ.Interp

-----------------------------------------------------------------------------
-- Patterns and data definitions

pattern 𝔹 = 𝟙 +ᵤ 𝟙
pattern 𝔽 = inj₁ tt
pattern 𝕋 = inj₂ tt

𝔹+ : ℕ → 𝕌
𝔹+ 0 = 𝟘
𝔹+ 1 = 𝔹
𝔹+ (suc (suc n)) = 𝔹 +ᵤ (𝔹+ (suc n))

𝔹^ : ℕ → 𝕌
𝔹^ 0 = 𝟙
𝔹^ 1 = 𝔹
𝔹^ (suc (suc n)) = 𝔹 ×ᵤ 𝔹^ (suc n)

𝔹* : ℕ → 𝕌
𝔹* n = 𝔹^ (1 + n)

𝔽^ : (n : ℕ) → ⟦ 𝔹^ n ⟧
𝔽^ 0 = tt
𝔽^ 1 = 𝔽
𝔽^ (suc (suc n)) = 𝔽 , 𝔽^ (suc n)

-----------------------------------------------------------------------------
-- Adaptors

[A+B]+C=[C+B]+A : ∀ {A B C} → (A +ᵤ B) +ᵤ C ↔ (C +ᵤ B) +ᵤ A
[A+B]+C=[C+B]+A = assocr₊ ⨾ (id↔ ⊕ swap₊) ⨾ swap₊

[A+B]+C=[A+C]+B : ∀ {A B C} → (A +ᵤ B) +ᵤ C ↔ (A +ᵤ C) +ᵤ B
[A+B]+C=[A+C]+B = assocr₊ ⨾ (id↔ ⊕ swap₊) ⨾ assocl₊

[A+B]+[C+D]=[A+C]+[B+D] : {A B C D : 𝕌} →
  (A +ᵤ B) +ᵤ (C +ᵤ D) ↔ (A +ᵤ C) +ᵤ (B +ᵤ D)
[A+B]+[C+D]=[A+C]+[B+D] = assocl₊ ⨾ (assocr₊ ⊕ id↔) ⨾ ((id↔ ⊕ swap₊) ⊕ id↔) ⨾ (assocl₊ ⊕ id↔) ⨾ assocr₊

Ax[BxC]=Bx[AxC] : {A B C : 𝕌} → A ×ᵤ (B ×ᵤ C) ↔ B ×ᵤ (A ×ᵤ C)
Ax[BxC]=Bx[AxC] = assocl⋆ ⨾ (swap⋆ ⊗ id↔) ⨾  assocr⋆

[AxB]×C=[A×C]xB : ∀ {A B C} → (A ×ᵤ B) ×ᵤ C ↔ (A ×ᵤ C) ×ᵤ B
[AxB]×C=[A×C]xB = assocr⋆ ⨾ (id↔ ⊗ swap⋆) ⨾ assocl⋆

[A×B]×[C×D]=[A×C]×[B×D] : {A B C D : 𝕌} → (A ×ᵤ B) ×ᵤ (C ×ᵤ D) ↔ (A ×ᵤ C) ×ᵤ (B ×ᵤ D)
[A×B]×[C×D]=[A×C]×[B×D] = assocl⋆ ⨾ (assocr⋆ ⊗ id↔) ⨾ ((id↔ ⊗ swap⋆) ⊗ id↔) ⨾ (assocl⋆ ⊗ id↔) ⨾ assocr⋆

-- FST2LAST(b₁,b₂,…,bₙ) = (b₂,…,bₙ,b₁)
FST2LAST : ∀ {n} → 𝔹^ n ↔ 𝔹^ n
FST2LAST {0} = id↔
FST2LAST {1} = id↔
FST2LAST {2} = swap⋆
FST2LAST {suc (suc (suc n))} = Ax[BxC]=Bx[AxC] ⨾ (id↔ ⊗ FST2LAST)

FST2LAST⁻¹ : ∀ {n} → 𝔹^ n ↔ 𝔹^ n
FST2LAST⁻¹ = ! FST2LAST

-----------------------------------------------------------------------------
-- Reversible Conditionals

-- not(b) = ¬b
NOT : 𝔹 ↔ 𝔹
NOT = swap₊

-- cnot(b₁,b₂) = (b₁,b₁ xor b₂)
CNOT : 𝔹 ×ᵤ 𝔹 ↔ 𝔹 ×ᵤ 𝔹
CNOT = dist ⨾ (id↔ ⊕ (id↔ ⊗ swap₊)) ⨾ factor

-- CIF(c₁,c₂)(𝔽,a) = (𝔽,c₁ a)
-- CIF(c₁,c₂)(𝕋,a) = (𝕋,c₂ a)
CIF : {A : 𝕌} → (c₁ c₂ : A ↔ A) → 𝔹 ×ᵤ A ↔ 𝔹 ×ᵤ A
CIF c₁ c₂ = dist ⨾ ((id↔ ⊗ c₁) ⊕ (id↔ ⊗ c₂)) ⨾ factor

CIF₁ CIF₂ : {A : 𝕌} → (c : A ↔ A) → 𝔹 ×ᵤ A ↔ 𝔹 ×ᵤ A
CIF₁ c = CIF c id↔
CIF₂ c = CIF id↔ c

-- toffoli(b₁,…,bₙ,b) = (b₁,…,bₙ,b xor (b₁ ∧ … ∧ bₙ))
TOFFOLI : {n : ℕ} → 𝔹^ n ↔ 𝔹^ n
TOFFOLI {0} = id↔
TOFFOLI {1} = swap₊
TOFFOLI {suc (suc n)} = CIF₂ TOFFOLI

-- TOFFOLI(b₁,…,bₙ,b) = (b₁,…,bₙ,b xor (¬b₁ ∧ … ∧ ¬bₙ))
TOFFOLI' : ∀ {n} → 𝔹^ n ↔ 𝔹^ n
TOFFOLI' {0} = id↔
TOFFOLI' {1} = swap₊
TOFFOLI' {suc (suc n)} = CIF₁ TOFFOLI'

-- reset(b₁,b₂,…,bₙ) = (b₁ xor (b₂ ∨ … ∨ bₙ),b₂,…,bₙ)
RESET : ∀ {n} → 𝔹 ×ᵤ 𝔹^ n ↔ 𝔹 ×ᵤ 𝔹^ n
RESET {0} = id↔
RESET {1} = swap⋆ ⨾ CNOT ⨾ swap⋆
RESET {suc (suc n)} = Ax[BxC]=Bx[AxC] ⨾ CIF RESET (swap₊ ⊗ id↔) ⨾ Ax[BxC]=Bx[AxC]

-----------------------------------------------------------------------------
-- Reversible Copy
-- copy(𝔽,b₁,…,bₙ) = (b₁,b₁,…,bₙ)
COPY : ∀ {n} → 𝔹 ×ᵤ 𝔹^ n ↔ 𝔹 ×ᵤ 𝔹^ n
COPY {0} = id↔
COPY {1} = swap⋆ ⨾ CNOT ⨾ swap⋆
COPY {suc (suc n)} = assocl⋆ ⨾ (COPY {1} ⊗ id↔) ⨾ assocr⋆

-----------------------------------------------------------------------------
-- Arithmetic
-- incr(b̅) = incr(b̅ + 1)
INCR : ∀ {n} → 𝔹^ n ↔ 𝔹^ n
INCR {0} = id↔
INCR {1} = swap₊
INCR {suc (suc n)} = (id↔ ⊗ INCR) ⨾ FST2LAST ⨾ TOFFOLI' ⨾ FST2LAST⁻¹

-----------------------------------------------------------------------------
-- Control flow
zigzag : 𝔹 ↔ 𝔹
zigzag = uniti₊l ⨾ (η₊ ⊕ id↔) ⨾ [A+B]+C=[C+B]+A ⨾ (ε₊ ⊕ id↔) ⨾ unite₊l
zigzagₜᵣ = evalₜᵣ zigzag 𝔽

-----------------------------------------------------------------------------
-- Iteration
trace₊ : ∀ {A B C} → A +ᵤ C ↔ B +ᵤ C → A ↔ B
trace₊ f = uniti₊r ⨾ (id↔ ⊕ η₊) ⨾ assocl₊ ⨾ (f ⊕ id↔) ⨾ assocr₊ ⨾ (id↔ ⊕ ε₊) ⨾ unite₊r

-----------------------------------------------------------------------------
-- Ancilla Management

trace⋆ : ∀ {A B C} → (c : ⟦ C ⟧) → A ×ᵤ C ↔ B ×ᵤ C → A ↔ B
trace⋆ c f = uniti⋆r ⨾ (id↔ ⊗ ηₓ c) ⨾ assocl⋆ ⨾
             (f ⊗ id↔) ⨾
             assocr⋆ ⨾ (id↔ ⊗ εₓ _) ⨾ unite⋆r

-----------------------------------------------------------------------------
-- Higher-Order Combinators

hof- : {A B : 𝕌} → (A ↔ B) → (𝟘 ↔ - A +ᵤ B)
hof- c = η₊ ⨾ (c ⊕ id↔) ⨾ swap₊

comp- : {A B C : 𝕌} → (- A +ᵤ B) +ᵤ (- B +ᵤ C) ↔ (- A +ᵤ C)
comp- = assocl₊ ⨾ (assocr₊ ⊕ id↔) ⨾ ((id↔ ⊕ ε₊) ⊕ id↔) ⨾ (unite₊r ⊕ id↔)

app- : {A B : 𝕌} → (- A +ᵤ B) +ᵤ A ↔ B
app- = swap₊ ⨾ assocl₊ ⨾ (ε₊ ⊕ id↔) ⨾ unite₊l

curry- : {A B C : 𝕌} → (A +ᵤ B ↔ C) → (A ↔ - B +ᵤ C)
curry- c = uniti₊l ⨾ (η₊ ⊕ id↔) ⨾ swap₊ ⨾ assocl₊ ⨾ (c ⊕ id↔) ⨾ swap₊

hof/ : {A B : 𝕌} → (A ↔ B) → (v : ⟦ A ⟧) → (𝟙 ↔ 𝟙/ v ×ᵤ B)
hof/ c v = ηₓ v ⨾ (c ⊗ id↔) ⨾ swap⋆

comp/ : {A B C : 𝕌} {v : ⟦ A ⟧} → (w : ⟦ B ⟧) →
        (𝟙/ v ×ᵤ B) ×ᵤ (𝟙/ w ×ᵤ C) ↔ (𝟙/ v ×ᵤ C)
comp/ w = assocl⋆ ⨾ (assocr⋆ ⊗ id↔) ⨾ ((id↔ ⊗ εₓ w) ⊗ id↔) ⨾ (unite⋆r ⊗ id↔)

app/ : {A B : 𝕌} → (v : ⟦ A ⟧) → (𝟙/ v ×ᵤ B) ×ᵤ A ↔ B
app/ v = swap⋆ ⨾ assocl⋆ ⨾ (εₓ _ ⊗ id↔) ⨾ unite⋆l

curry/ : {A B C : 𝕌} → (A ×ᵤ B ↔ C) → (v : ⟦ B ⟧) → (A ↔ 𝟙/ v ×ᵤ C)
curry/ c v = uniti⋆l ⨾ (ηₓ v ⊗ id↔) ⨾ swap⋆ ⨾ assocl⋆ ⨾ (c ⊗ id↔) ⨾ swap⋆

-----------------------------------------------------------------------------
-- Algebraic Identities

inv- : {A : 𝕌} → A ↔ - (- A)
inv- = uniti₊r ⨾ (id↔ ⊕ η₊) ⨾ assocl₊ ⨾ (ε₊ ⊕ id↔) ⨾ unite₊l

dist- : {A B : 𝕌} → - (A +ᵤ B) ↔ - A +ᵤ - B
dist- =
  uniti₊l ⨾ (η₊ ⊕ id↔) ⨾ uniti₊l ⨾ (η₊ ⊕ id↔) ⨾ assocl₊ ⨾
  ([A+B]+[C+D]=[A+C]+[B+D] ⊕ id↔) ⨾
  (swap₊ ⊕ id↔) ⨾ assocr₊ ⨾ (id↔ ⊕ ε₊) ⨾ unite₊r

neg- : {A B : 𝕌} → (A ↔ B) →  (- A ↔ - B)
neg- c =
  uniti₊r ⨾ (id↔ ⊕ η₊) ⨾
  (id↔ ⊕ ! c ⊕ id↔) ⨾ assocl₊ ⨾
  ((swap₊ ⨾ ε₊) ⊕ id↔) ⨾ unite₊l

inv/ : {A : 𝕌} {v : ⟦ A ⟧} → A ↔ (𝟙/_ {𝟙/ v} ↻)
inv/ = uniti⋆r ⨾ (id↔ ⊗ ηₓ _) ⨾ assocl⋆ ⨾ (εₓ _ ⊗ id↔) ⨾ unite⋆l

dist/ : {A B : 𝕌} {a : ⟦ A ⟧} {b : ⟦ B ⟧} → 𝟙/ (a , b) ↔ 𝟙/ a ×ᵤ 𝟙/ b
dist/ {A} {B} {a} {b} =
  uniti⋆l ⨾ (ηₓ b ⊗ id↔) ⨾ uniti⋆l ⨾ (ηₓ a ⊗ id↔) ⨾ assocl⋆ ⨾
  ([A×B]×[C×D]=[A×C]×[B×D] ⊗ id↔) ⨾
  (swap⋆ ⊗ id↔) ⨾ assocr⋆ ⨾ (id↔ ⊗ εₓ (a , b)) ⨾ unite⋆r

neg/ : {A B : 𝕌} {a : ⟦ A ⟧} {b : ⟦ B ⟧} → (A ↔ B) → (𝟙/ a ↔ 𝟙/ b)
neg/ {A} {B} {a} {b} c =
  uniti⋆r ⨾ (id↔ ⊗ ηₓ _) ⨾
  (id↔ ⊗ ! c ⊗ id↔) ⨾ assocl⋆ ⨾
  ((swap⋆ ⨾ εₓ _) ⊗ id↔) ⨾ unite⋆l

dist×- : {A B : 𝕌} → (- A) ×ᵤ B ↔ - (A ×ᵤ B)
dist×- =
  uniti₊r ⨾ (id↔ ⊕ η₊) ⨾ assocl₊ ⨾
  ((factor ⨾ ((swap₊ ⨾ ε₊) ⊗ id↔) ⨾ absorbr) ⊕ id↔) ⨾
  unite₊l

neg× : {A B : 𝕌} → A ×ᵤ B ↔ (- A) ×ᵤ (- B)
neg× = inv- ⨾ neg- (! dist×- ⨾ swap⋆) ⨾ ! dist×- ⨾ swap⋆

fracDist : ∀ {A B} {a : ⟦ A ⟧} {b : ⟦ B ⟧} → 𝟙/ a ×ᵤ 𝟙/ b ↔ 𝟙/ (a , b)
fracDist =
  uniti⋆l ⨾ ((ηₓ _ ⨾ swap⋆) ⊗ id↔) ⨾ assocr⋆ ⨾
  (id↔ ⊗ ([A×B]×[C×D]=[A×C]×[B×D] ⨾ (εₓ _ ⊗ εₓ _) ⨾ unite⋆l)) ⨾ unite⋆r

mulFrac : ∀ {A B C D} {b : ⟦ B ⟧} {d : ⟦ D ⟧}
        → (A ×ᵤ 𝟙/ b) ×ᵤ (C ×ᵤ 𝟙/ d) ↔ (A ×ᵤ C) ×ᵤ (𝟙/ (b , d))
mulFrac = [A×B]×[C×D]=[A×C]×[B×D] ⨾ (id↔ ⊗ fracDist)

addFracCom : ∀ {A B C} {v : ⟦ C ⟧}
        → (A ×ᵤ 𝟙/ v) +ᵤ (B ×ᵤ 𝟙/ v) ↔ (A +ᵤ B) ×ᵤ (𝟙/ v)
addFracCom = factor

addFrac : ∀ {A B C D} → (v : ⟦ C ⟧) → (w : ⟦ D ⟧)
        → (A ×ᵤ 𝟙/_ {C} v) +ᵤ (B ×ᵤ 𝟙/_ {D} w) ↔
         ((A ×ᵤ D) +ᵤ (C ×ᵤ B)) ×ᵤ (𝟙/_ {C ×ᵤ D} (v , w))
addFrac v w = ((uniti⋆r ⨾ (id↔ ⊗ ηₓ w)) ⊕ (uniti⋆l  ⨾ (ηₓ v ⊗ id↔))) ⨾
              [A×B]×[C×D]=[A×C]×[B×D] ⊕ [A×B]×[C×D]=[A×C]×[B×D] ⨾
              ((id↔ ⊗ fracDist) ⊕ (id↔ ⊗ fracDist)) ⨾ factor

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


-- The purpose of this universe construction is to get some definitional
-- equalities in the model. Specifically, if we define ⟦σ⟧ : ⟦Δ⟧ → ⟦Ω⟧
-- (a functor) for the "canonical" notion of subsitution, then we have
-- ⟦Wk⟧ (δ , m) ≡ δ propositionally, but *not* definitionally. This then
-- complicates proofs involving ⟦Wk⟧, and similar for the other substitutions.

{-# OPTIONS --without-K --safe #-}
module Source.Size.Substitution.Universe where

open import Relation.Binary using (IsEquivalence ; Setoid)

open import Source.Size
open import Source.Size.Substitution.Canonical as Can using (Sub⊢)
open import Util.Prelude

import Relation.Binary.Reasoning.Setoid as SetoidReasoning

infix  4 _≈_
infixl 5 _>>_

data Sub : (Δ Ω : Ctx) → Set where
  Id : Sub Δ Δ
  _>>_ : (σ : Sub Δ Δ′) (τ : Sub Δ′ Ω) → Sub Δ Ω
  Wk : Sub (Δ ∙ n) Δ
  Lift : (σ : Sub Δ Ω) → Sub (Δ ∙ m) (Ω ∙ n)
  Sing : (n : Size Δ) → Sub Δ (Δ ∙ m)
  Skip : Sub (Δ ∙ n ∙ v0) (Δ ∙ n)

⟨_⟩ : Sub Δ Ω → Can.Sub Δ Ω
⟨ Id ⟩ = Can.Id
⟨ σ >> τ ⟩ = ⟨ σ ⟩ Can.>> ⟨ τ ⟩
⟨ Wk ⟩ = Can.Wk
⟨ Lift σ ⟩ = Can.Lift ⟨ σ ⟩
⟨ Sing n ⟩ = Can.Sing n
⟨ Skip ⟩ = Can.Skip

subV : (σ : Sub Δ Ω) (x : Var Ω) → Size Δ
subV σ = Can.subV ⟨ σ ⟩

sub : (σ : Sub Δ Ω) (n : Size Ω) → Size Δ
sub σ = Can.sub ⟨ σ ⟩

pattern Lift′ σ ⊢n = Lift σ ⊢n refl

variable σ τ ι : Sub Δ Ω

data Sub⊢ᵤ : ∀ Δ Ω → Sub Δ Ω → Set where
  Id : Sub⊢ᵤ Δ Δ Id
  comp : (⊢σ : Sub⊢ᵤ Δ Δ′ σ) (⊢τ : Sub⊢ᵤ Δ′ Δ″ τ) → Sub⊢ᵤ Δ Δ″ (σ >> τ)
  Wk : Sub⊢ᵤ (Δ ∙ n) Δ Wk
  Lift : (⊢σ : Sub⊢ᵤ Δ Ω σ) (m≡n[σ] : m ≡ sub σ n)
    → Sub⊢ᵤ (Δ ∙ m) (Ω ∙ n) (Lift σ)
  Sing : (n<m : n < m) → Sub⊢ᵤ Δ (Δ ∙ m) (Sing n)
  Skip : Sub⊢ᵤ (Δ ∙ n ∙ v0) (Δ ∙ n) Skip

syntax Sub⊢ᵤ Δ Ω σ = σ ∶ Δ ⇒ᵤ Ω

⟨⟩-resp-⊢ : σ ∶ Δ ⇒ᵤ Ω → ⟨ σ ⟩ ∶ Δ ⇒ Ω
⟨⟩-resp-⊢ Id = Can.Id⊢
⟨⟩-resp-⊢ (comp ⊢σ ⊢τ) = Can.>>⊢ (⟨⟩-resp-⊢ ⊢σ) (⟨⟩-resp-⊢ ⊢τ)
⟨⟩-resp-⊢ Wk = Can.Wk⊢
⟨⟩-resp-⊢ (Lift ⊢σ m≡n[σ]) = Can.Lift⊢ (⟨⟩-resp-⊢ ⊢σ) m≡n[σ]
⟨⟩-resp-⊢ (Sing n<m) = Can.Sing⊢ n<m
⟨⟩-resp-⊢ Skip = Can.Skip⊢

record _≈_ (σ τ : Sub Δ Ω) : Set where
  constructor ≈⁺
  field ≈⁻ : ⟨ σ ⟩ ≡ ⟨ τ ⟩

open _≈_ public

≈-refl : σ ≈ σ
≈-refl = ≈⁺ refl

≈-sym : σ ≈ τ → τ ≈ σ
≈-sym (≈⁺ p) = ≈⁺ (sym p)

≈-trans : σ ≈ τ → τ ≈ ι → σ ≈ ι
≈-trans (≈⁺ p) (≈⁺ q) = ≈⁺ (trans p q)

≈-isEquivalence : IsEquivalence (_≈_ {Δ} {Ω})
≈-isEquivalence = record { refl = ≈-refl ; sym = ≈-sym ; trans = ≈-trans }

Sub-setoid : (Δ Ω : Ctx) → Setoid 0ℓ 0ℓ
Sub-setoid Δ Ω = record
  { Carrier = Sub Δ Ω
  ; _≈_ = _≈_
  ; isEquivalence = ≈-isEquivalence
  }

module ≈-Reasoning {Δ} {Ω} = SetoidReasoning (Sub-setoid Δ Ω)

abstract
  >>-resp-≈ : {σ σ′ : Sub Δ Δ′} {τ τ′ : Sub Δ′ Δ″}
    → σ ≈ σ′ → τ ≈ τ′ → σ >> τ ≈ σ′ >> τ′
  >>-resp-≈ (≈⁺ p) (≈⁺ q) = ≈⁺ (cong₂ Can._>>_ p q)

  Lift-resp-≈ : σ ≈ τ → Lift {m = m} {n} σ ≈ Lift τ
  Lift-resp-≈ (≈⁺ p) = ≈⁺ (cong Can.Lift p)

  sub-resp-< : σ ∶ Δ ⇒ᵤ Ω → n < m → sub σ n < sub σ m
  sub-resp-< ⊢σ = Can.sub-resp-< (⟨⟩-resp-⊢ ⊢σ)

mutual
  subV′ : Sub Δ Ω → Var Ω → Size Δ
  subV′ Id x = var x
  subV′ (σ >> τ) x = sub′ σ (subV′ τ x)
  subV′ Wk x = var (suc x)
  subV′ (Lift σ) zero = var zero
  subV′ (Lift σ) (suc x) = wk (subV′ σ x)
  subV′ (Sing n) zero = n
  subV′ (Sing n) (suc x) = var x
  subV′ Skip zero = var zero
  subV′ Skip (suc x) = var (suc (suc x))

  sub′ : Sub Δ Ω → Size Ω → Size Δ
  sub′ σ (var x) = subV′ σ x
  sub′ σ ∞ = ∞
  sub′ σ zero = zero
  sub′ σ (suc n) = suc (sub′ σ n)

  abstract
    subV′≡subV : ∀ (σ : Sub Δ Ω) x → subV′ σ x ≡ subV σ x
    subV′≡subV Id x = sym (Can.subV-Id x)
    subV′≡subV (σ >> τ) x
      = trans (sub′≡sub σ (subV′ τ x))
          (trans (cong (sub σ) (subV′≡subV τ x))
            (sym (Can.subV->> ⟨ σ ⟩ ⟨ τ ⟩ x)))
    subV′≡subV Wk x = sym (Can.sub-Wk (var x))
    subV′≡subV (Lift σ) zero = refl
    subV′≡subV (Lift σ) (suc x)
      = trans (cong wk (subV′≡subV σ x)) (sym (Can.subV-Weaken ⟨ σ ⟩ x))
    subV′≡subV (Sing n) zero = refl
    subV′≡subV (Sing n) (suc x) = sym (Can.subV-Id x)
    subV′≡subV Skip zero = refl
    subV′≡subV Skip (suc x) = sym
      (trans (Can.subV-Weaken (Can.Weaken Can.Id) x) (cong wk (Can.sub-Wk (var x))))

    sub′≡sub : ∀ (σ : Sub Δ Ω) n → sub′ σ n ≡ sub σ n
    sub′≡sub σ (var x) = subV′≡subV σ x
    sub′≡sub σ ∞ = refl
    sub′≡sub σ zero = refl
    sub′≡sub σ (suc n) = cong suc (sub′≡sub σ n)


-- div shouldn't termination check, but it also shouldn't make the termination
-- checker loop.
module Issue503 where

data Bool : Set where
  true : Bool
  false : Bool

if_then_else_ : {C : Set} -> Bool -> C -> C -> C
if true then a else b = a
if false then a else b = b

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

pred : Nat -> Nat
pred zero = zero
pred (succ n) = n

_+_ : Nat -> Nat -> Nat
zero + b = b
succ a + b = succ (a + b)

_*_ : Nat -> Nat -> Nat
zero * _ = zero
succ a * b = (a * b) + b

{-# BUILTIN NATURAL Nat #-}
{-# BUILTIN ZERO zero #-}
{-# BUILTIN SUC succ #-}
{-# BUILTIN NATPLUS _+_ #-}
{-# BUILTIN NATTIMES _*_ #-}

_-_ : Nat -> Nat -> Nat
a - zero = a
a - succ b = pred (a - b)

_<_ : Nat -> Nat -> Bool
a < zero = false
zero < succ b = true
succ a < succ b = a < b

div : Nat -> Nat -> Nat
div m n = if (m < n) then zero else succ (div (m - n) n)


module PatternSynonymUnderapplied where

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

pattern suc' x = suc x

f : Nat -> Nat
f zero = zero
f suc' = zero


module Imports.ATP-A where

postulate
  D    : Set
  _≡_  : D → D → Set
  a b  : D

postulate p : a ≡ b


{-# OPTIONS --cumulativity #-}

postulate
  F : (X : Set) → X → Set
  X : Set₁
  a : X
  shouldfail : F _ a


open import Agda.Primitive
open import Agda.Primitive.Cubical

record Wrap : Set (lsuc lzero) where
  field
    A : IUniv


open import Data.Sum
open import Data.Fin
open import Data.Product
open import Data.Maybe
open import Signature

Σ-N∞ : Sig
Σ-N∞ = record { ∥_∥ = Fin 2 ; ar = Σ-N∞-ar }
  where
    Σ-N∞-ar : Fin 2 → Set
    Σ-N∞-ar zero    = Fin 0
    Σ-N∞-ar (suc zero) = Fin 1
    Σ-N∞-ar (suc (suc ()))

D-N∞ : Set
D-N∞ = Fin 1

open import MixedTest Σ-N∞ D-N∞ as LP-N∞ renaming (Term to N∞μ; CoTerm to N∞)

stop' : N∞μ
stop' = cons (# 0 , λ())

step' : N∞ → N∞μ
step' x = (cons (# 1 , (λ _ → inj₂ x)))

-- Immediate stop -> 0
stop : N∞
destr stop zero = just (inj₁ stop')
destr stop (suc ())

-- Do a step -> successor
succ : N∞ → N∞
destr (succ x) zero    = just (inj₁ (step' x))
destr (succ x) (suc ())

-- Not actually in N∞
foo : N∞
destr foo x = nothing


-- Andreas, issue #2482, reported by Guillaume Allais
-- Internal error because of wrong value for
-- number of parameters for data type.

-- {-# OPTIONS -v tc.data.sort:50 #-}
-- {-# OPTIONS -v tc.term.con:50 #-}

data D {b} (B : Set b) : Set b

-- This used to falsely compute the number of parameters to 1

data D B where
  c : B → D B

-- ... leading to a violated invariant when applying the constructor.

test : ∀ {B : Set} (b : B) → D B
test b = c b

-- n  = npars  = conPars (c)
-- n' = npars' = getNumberOfParameters (D)
-- should be the same