-- The SIP applied to groups
{-# OPTIONS --safe #-}
module Cubical.Algebra.Group.GroupPath where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function using (_∘_)
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.GroupoidLaws hiding (assoc)
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.SIP

open import Cubical.Data.Sigma

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

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

private
  variable
    ℓ ℓ' ℓ'' : Level

open Iso
open GroupStr
open IsGroupHom

𝒮ᴰ-Group : DUARel (𝒮-Univ ℓ) GroupStr ℓ
𝒮ᴰ-Group =
  𝒮ᴰ-Record (𝒮-Univ _) IsGroupEquiv
    (fields:
      data[ _·_ ∣ autoDUARel _ _ ∣ pres· ]
      data[ 1g ∣ autoDUARel _ _ ∣ pres1 ]
      data[ inv ∣ autoDUARel _ _ ∣ presinv ]
      prop[ isGroup ∣ (λ _ _ → isPropIsGroup _ _ _) ])
  where
  open GroupStr
  open IsGroupHom

GroupPath : (M N : Group ℓ) → GroupEquiv M N ≃ (M ≡ N)
GroupPath = ∫ 𝒮ᴰ-Group .UARel.ua

-- The module below defines a group induced from an equivalence
-- between a group G and a type A which preserves the full raw group
-- structure from G to A. This version is useful when proving that
-- some type equivalent to a group is a group while also specifying
-- the binary operation, unit and inverse.
module _ (G : Group ℓ) {A : Type ℓ}
  (m : A → A → A)
  (u : A)
  (inverse : A → A)
  (e : ⟨ G ⟩ ≃ A)
  (p· : ∀ x y → e .fst (G .snd ._·_ x y) ≡ m (e .fst x) (e .fst y))
  (pu : e .fst (G .snd .1g) ≡ u)
  (pinv : ∀ x → e .fst (G .snd .inv x) ≡ inverse (e .fst x))
  where

  private
    module G = GroupStr (G .snd)

    BaseΣ : Type (ℓ-suc ℓ)
    BaseΣ = Σ[ B ∈ Type ℓ ] (B → B → B) × B × (B → B)

    FamilyΣ : BaseΣ → Type ℓ
    FamilyΣ (B , m , u , i) = IsGroup u m i

    inducedΣ : FamilyΣ (A , m , u , inverse)
    inducedΣ =
      subst FamilyΣ
        (UARel.≅→≡ (autoUARel BaseΣ) (e , p· , pu , pinv))
        G.isGroup

  InducedGroup : Group ℓ
  InducedGroup .fst = A
  InducedGroup .snd ._·_ = m
  InducedGroup .snd .1g = u
  InducedGroup .snd .inv = inverse
  InducedGroup .snd .isGroup = inducedΣ

  InducedGroupEquiv : GroupEquiv G InducedGroup
  fst InducedGroupEquiv = e
  snd InducedGroupEquiv = makeIsGroupHom p·

  InducedGroupPath : G ≡ InducedGroup
  InducedGroupPath = GroupPath _ _ .fst InducedGroupEquiv

-- The module below defines a group induced from an equivalence which
-- preserves the binary operation (i.e. a group isomorphism). This
-- version is useful when proving that some type equivalent to a group
-- G is a group when one doesn't care about what the unit and inverse
-- are. When using this version the unit and inverse will both be
-- defined by transporting over the unit and inverse from G to A.
module _ (G : Group ℓ) {A : Type ℓ}
  (m : A → A → A)
  (e : ⟨ G ⟩ ≃ A)
  (p· : ∀ x y → e .fst (G .snd ._·_ x y) ≡ m (e .fst x) (e .fst y))
  where

  private
    module G = GroupStr (G .snd)

    FamilyΣ : Σ[ B ∈ Type ℓ ] (B → B → B) → Type ℓ
    FamilyΣ (B , n) = Σ[ e ∈ B ] Σ[ i ∈ (B → B) ] IsGroup e n i

    inducedΣ : FamilyΣ (A , m)
    inducedΣ =
      subst FamilyΣ
        (UARel.≅→≡ (autoUARel (Σ[ B ∈ Type ℓ ] (B → B → B))) (e , p·))
        (G.1g , G.inv , G.isGroup)

  InducedGroupFromPres· : Group ℓ
  InducedGroupFromPres· .fst = A
  InducedGroupFromPres· .snd ._·_ = m
  InducedGroupFromPres· .snd .1g = inducedΣ .fst
  InducedGroupFromPres· .snd .inv = inducedΣ .snd .fst
  InducedGroupFromPres· .snd .isGroup = inducedΣ .snd .snd

  InducedGroupEquivFromPres· : GroupEquiv G InducedGroupFromPres·
  fst InducedGroupEquivFromPres· = e
  snd InducedGroupEquivFromPres· = makeIsGroupHom p·

  InducedGroupPathFromPres· : G ≡ InducedGroupFromPres·
  InducedGroupPathFromPres· = GroupPath _ _ .fst InducedGroupEquivFromPres·

uaGroup : {G H : Group ℓ} → GroupEquiv G H → G ≡ H
uaGroup {G = G} {H = H} = equivFun (GroupPath G H)

-- Group-ua functoriality
Group≡ : (G H : Group ℓ) → (
  Σ[ p ∈ ⟨ G ⟩ ≡ ⟨ H ⟩ ]
  Σ[ q ∈ PathP (λ i → p i) (1g (snd G)) (1g (snd H)) ]
  Σ[ r ∈ PathP (λ i → p i → p i → p i) (_·_ (snd G)) (_·_ (snd H)) ]
  Σ[ s ∈ PathP (λ i → p i → p i) (inv (snd G)) (inv (snd H)) ]
  PathP (λ i → IsGroup (q i) (r i) (s i)) (isGroup (snd G)) (isGroup (snd H)))
  ≃ (G ≡ H)
Group≡ G H = isoToEquiv theIso
  where
  theIso : Iso _ _
  fun theIso (p , q , r , s , t) i = p i , groupstr (q i) (r i) (s i) (t i)
  inv theIso x = cong ⟨_⟩ x , cong (1g ∘ snd) x , cong (_·_ ∘ snd) x , cong (inv ∘ snd) x , cong (isGroup ∘ snd) x
  rightInv theIso _ = refl
  leftInv theIso _ = refl

caracGroup≡ : {G H : Group ℓ} (p q : G ≡ H) → cong ⟨_⟩ p ≡ cong ⟨_⟩ q → p ≡ q
caracGroup≡ {G = G} {H = H} p q P =
  sym (transportTransport⁻ (ua (Group≡ G H)) p)
                                   ∙∙ cong (transport (ua (Group≡ G H))) helper
                                   ∙∙ transportTransport⁻ (ua (Group≡ G H)) q
    where
    helper : transport (sym (ua (Group≡ G H))) p ≡ transport (sym (ua (Group≡ G H))) q
    helper = Σ≡Prop
               (λ _ → isPropΣ
                         (isOfHLevelPathP' 1 (is-set (snd H)) _ _)
                         λ _ → isPropΣ (isOfHLevelPathP' 1 (isSetΠ2 λ _ _ → is-set (snd H)) _ _)
                         λ _ → isPropΣ (isOfHLevelPathP' 1 (isSetΠ λ _ → is-set (snd H)) _ _)
                         λ _ → isOfHLevelPathP 1 (isPropIsGroup _ _ _) _ _)
               (transportRefl (cong ⟨_⟩ p) ∙ P ∙ sym (transportRefl (cong ⟨_⟩ q)))

uaGroupId : (G : Group ℓ) → uaGroup (idGroupEquiv {G = G}) ≡ refl
uaGroupId G = caracGroup≡ _ _ uaIdEquiv

uaCompGroupEquiv : {F G H : Group ℓ} (f : GroupEquiv F G) (g : GroupEquiv G H)
                 → uaGroup (compGroupEquiv f g) ≡ uaGroup f ∙ uaGroup g
uaCompGroupEquiv f g = caracGroup≡ _ _ (
  cong ⟨_⟩ (uaGroup (compGroupEquiv f g))
    ≡⟨ uaCompEquiv _ _ ⟩
  cong ⟨_⟩ (uaGroup f) ∙ cong ⟨_⟩ (uaGroup g)
    ≡⟨ sym (cong-∙ ⟨_⟩ (uaGroup f) (uaGroup g)) ⟩
  cong ⟨_⟩ (uaGroup f ∙ uaGroup g) ∎)

-- J-rule for GroupEquivs
GroupEquivJ : {G : Group ℓ} (P : (H : Group ℓ) → GroupEquiv G H → Type ℓ')
            → P G idGroupEquiv
            → ∀ {H} e → P H e
GroupEquivJ {G = G} P p {H} e =
  transport (λ i → P (GroupPath G H .fst e i)
    (transp (λ j → GroupEquiv G (GroupPath G H .fst e (i ∨ ~ j))) i e))
      (subst (P G) (sym lem) p)
  where
  lem : transport (λ j → GroupEquiv G (GroupPath G H .fst e (~ j))) e
       ≡ idGroupEquiv
  lem = Σ≡Prop (λ _ → isPropIsGroupHom _ _)
       (Σ≡Prop (λ _ → isPropIsEquiv _)
         (funExt λ x → (λ i → fst (fst (fst e .snd .equiv-proof
                          (transportRefl (fst (fst e) (transportRefl x i)) i))))
                         ∙ retEq (fst e) x))


record ⊤ : Set where constructor tt
data ⊥ : Set where

open import Agda.Builtin.Size

record Delay (F : Size → Set) (i : Size) : Set where
  coinductive
  field force : {j : Size< i} → F j
open Delay public

data Stream (A : Set) (i : Size) : Set where
 _∷_ : A → Delay (Stream A) i → Stream A i

concat : Stream ⊤ ∞ → Delay (Stream ⊥) ∞
concat (xs ∷ xss) = concat (force xss)

head : Stream ⊥ ∞ → ⊥
head (x ∷ xs) = x

units : ∀ {i} → Stream ⊤ i
units = tt ∷ λ where .force → units

false : ⊥
false = head (force (concat units))


open import Categories
open import Functors
open import RMonads

module RMonads.RKleisli.Functors {a b c d}{C : Cat {a}{b}}{D : Cat {c}{d}}
                                 {J : Fun C D}(M : RMonad J) where

open import Library
open import RMonads.RKleisli M
open import RAdjunctions

open Cat
open Fun
open RMonad M

RKlL : Fun C Kl
RKlL = record{
  OMap  = id;
  HMap  = λ f → comp D η (HMap J f);
  fid   =
    proof
    comp D η (HMap J (iden C))
    ≅⟨ cong (comp D η) (fid J) ⟩
    comp D η (iden D)
    ≅⟨ idr D ⟩
    η ∎;
  fcomp = λ{_ _ _ f g} →
    proof
    comp D η (HMap J (comp C f g))
    ≅⟨ cong (comp D η) (fcomp J) ⟩
    comp D η (comp D (HMap J f) (HMap J g))
    ≅⟨ sym (ass D) ⟩
    comp D (comp D η (HMap J f)) (HMap J g)
    ≅⟨ cong (λ f → comp D f (HMap J g)) (sym law2) ⟩
    comp D (comp D (bind (comp D η (HMap J f))) η) (HMap J g)
    ≅⟨ ass D ⟩
    comp D (bind (comp D η (HMap J f))) (comp D η (HMap J g))
    ∎}

RKlR : Fun Kl D
RKlR = record{
  OMap  = T;
  HMap  = bind;
  fid   = law1;
  fcomp = law3}


module Categories.Category.CartesianClosed.Bundle where

open import Categories.Category using (Category)
open import Categories.Category.CartesianClosed using (CartesianClosed)

open import Level

record CartesianClosedCategory o ℓ e : Set (suc (o ⊔ ℓ ⊔ e)) where
  field
    U : Category o ℓ e
    cartesianClosed : CartesianClosed U

  open Category U public
  open CartesianClosed cartesianClosed public


-- Issue #80.

-- The disjunction data type.
data _∨_ (A B : Set) : Set where
  inj₁ : A → A ∨ B
  inj₂ : B → A ∨ B

-- A different symbol for disjunction.
_⊕_ : Set → Set → Set
P ⊕ Q = P ∨ Q
{-# ATP definition _⊕_ #-}

postulate
  P Q : Set
  ⊕-comm : P ⊕ Q → Q ⊕ P
{-# ATP prove ⊕-comm #-}

-- The previous error was:

-- $ apia Issue80.agda
-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/Apia/Translation/Functions.hs:188

-- The current error is:

-- $ apia Issue80.agda
-- apia: the translation of ‘IssueXX._⊕_’ failed because it is not a FOL-definition


open import Categories.Category using (Category)
import Categories.Category.CartesianClosed

open import Data.Fin using (Fin) renaming (zero to fzero; suc to fsuc)
open import Data.List using (List; []; _∷_)
open import Data.Product using (Σ; Σ-syntax; proj₁; proj₂)

open import Syntax

open import Level using (_⊔_; suc)

module Semantics {o ℓ e}
  (𝒞 : Category o ℓ e)
  (CC : Categories.Category.CartesianClosed.CartesianClosed 𝒞)
  {ℓ₁ ℓ₂}
  (Sg : Signature ℓ₁ ℓ₂)
  where
  open Categories.Category.CartesianClosed 𝒞
  open import Categories.Category.Cartesian 𝒞
  open import Categories.Category.BinaryProducts 𝒞
  open import Categories.Object.Terminal 𝒞
  open import Categories.Object.Product 𝒞

  open Category 𝒞

  open CartesianClosed CC
  open Cartesian cartesian
  open BinaryProducts products
  private module T = Terminal terminal

  open Signature Sg
  open Term Sg

  module I (⟦_⟧G : Gr -> Obj) where
    ⟦_⟧T : Type -> Obj
    ⟦ ⌊ g ⌋ ⟧T = ⟦ g ⟧G
    ⟦ Unit ⟧T = T.⊤
    ⟦ A * A₁ ⟧T = ⟦ A ⟧T × ⟦ A₁ ⟧T
    ⟦ A => A₁ ⟧T = ⟦ A ⟧T ⇨ ⟦ A₁ ⟧T

  record Structure : Set (o ⊔ ℓ ⊔ ℓ₁ ⊔ ℓ₂) where
    field
      ⟦_⟧G : Gr -> Obj

    open I ⟦_⟧G public

    field
      ⟦_⟧F : (f : Func) -> ⟦ dom f ⟧T ⇒ ⟦ cod f ⟧T

    ⟦_⟧C : Context -> Obj
    ⟦ [] ⟧C = T.⊤
    ⟦ A ∷ Γ ⟧C = ⟦ Γ ⟧C × ⟦ A ⟧T

    ⟦_⟧ : forall {Γ A} -> Γ ⊢ A -> ⟦ Γ ⟧C ⇒ ⟦ A ⟧T
    ⟦_⟧S : forall {Γ Γ′} -> Γ ⊨ Γ′ -> ⟦ Γ ⟧C ⇒ ⟦ Γ′ ⟧C

    ⟦ func f e ⟧ = ⟦ f ⟧F ∘ ⟦ e ⟧
    ⟦ var ⟧ = π₂
    ⟦ unit ⟧ = T.!
    ⟦ pair e e₁ ⟧ = ⟨ ⟦ e ⟧ , ⟦ e₁ ⟧ ⟩
    ⟦ fst e ⟧ = π₁ ∘ ⟦ e ⟧
    ⟦ snd e ⟧ = π₂ ∘ ⟦ e ⟧
    ⟦ abs e ⟧ = λg ⟦ e ⟧
    ⟦ app e e₁ ⟧ = eval′ ∘ ⟨ ⟦ e ⟧ , ⟦ e₁ ⟧ ⟩
    ⟦ e [ γ ] ⟧ = ⟦ e ⟧ ∘ ⟦ γ ⟧S

    ⟦ id ⟧S = Category.id 𝒞
    ⟦ γ ∙ γ₁ ⟧S = ⟦ γ ⟧S ∘ ⟦ γ₁ ⟧S
    ⟦ weaken ⟧S = π₁
    ⟦ ext γ e ⟧S = ⟨ ⟦ γ ⟧S , ⟦ e ⟧ ⟩
    ⟦ ! ⟧S = T.!

  ⟦_⟧G_ : Gr -> (M : Structure) -> Obj
  ⟦_⟧G_ g M = Structure.⟦_⟧G M g

  ⟦_⟧T_ : Type -> (M : Structure) -> Obj
  ⟦_⟧T_ A M = Structure.⟦_⟧T M A

  ⟦_⟧F_ : (f : Func) -> (M : Structure) -> Structure.⟦_⟧T M (dom f) ⇒ Structure.⟦_⟧T M (cod f)
  ⟦_⟧F_ f M = Structure.⟦_⟧F M f

  ⟦_⟧_ : forall {Γ A} -> Γ ⊢ A -> (M : Structure) -> Structure.⟦_⟧C M Γ ⇒ Structure.⟦_⟧T M A
  ⟦_⟧_ e M = Structure.⟦_⟧ M e


module Tuples where

open import Data.Product

_² : ∀ {a} (A : Set a) → Set a
A ² = A × A

_³ : ∀ {a} (A : Set a) → Set a
A ³ = A × A ²

_⁴ : ∀ {a} (A : Set a) → Set a
A ⁴ = A × A ³

_⁵ : ∀ {a} (A : Set a) → Set a
A ⁵ = A × A ⁴

_⁶ : ∀ {a} (A : Set a) → Set a
A ⁶ = A × A ⁵

_⁷ : ∀ {a} (A : Set a) → Set a
A ⁷ = A × A ⁶


-- A minor variant of code reported by Andreas Abel.

-- Andreas, 2011-10-04
--
-- Agda's coinduction is incompatible with initial algebras
--
-- Sized types are needed to formulate initial algebras in general:
--
{-# OPTIONS --sized-types #-}
--
-- We need to skip the positivity check since we cannot communicate
-- to Agda that we only want strictly positive F's in the definition of Mu
--
{-# OPTIONS --no-positivity-check #-}
--
module _ where

open import Agda.Builtin.Coinduction renaming (∞ to co)
open import Agda.Builtin.Size

-- initial algebras

data Mu (F : Set → Set) : Size → Set where
  inn : ∀ {i} → F (Mu F i) → Mu F (↑ i)

iter : ∀ {F : Set → Set}
         (map : ∀ {A B} → (A → B) → F A → F B)
         {A} → (F A → A) → ∀ {i} → Mu F i → A
iter map s (inn t) = s (map (iter map s) t)

-- the co functor (aka Lift functor)

F : Set → Set
F A = co A

map : ∀ {A B : Set} → (A → B) → co A → co B
map f a = ♯ f (♭ a)

-- the least fixed-point of co is inhabited

bla : Mu F ∞
bla = inn (♯ bla)

-- and goal!

data ⊥ : Set where

false : ⊥
false = iter map ♭ bla

-- note that co is indeed strictly positive, as the following
-- direct definition of Mu F ∞ is accepted

data Bla : Set where
  c : co Bla → Bla

{- -- if we inline ♭ map into iter, the termination checker detects the cheat
iter' : Bla → ⊥
iter' (c t) = ♭ (♯ iter' (♭ t))
-- iter' (c t) = ♭ (map iter' t)
-}

-- Again, I want to emphasize that the problem is not with sized types.
-- I have only used sized types to communicate to Agda that initial algebras
-- (F, iter) are ok.  Once we have initial algebras, we can form the
-- initial algebra of the co functor and abuse the guardedness checker
-- to construct an inhabitant in this empty initial algebra.
--
-- Agda's coinduction mechanism confuses constructor and coconstructors.
-- Convenient, but, as you have seen...


module BTA5 where

open import Data.Nat hiding (_<_)
open import Data.Bool
open import Data.List

open import Data.Nat.Properties

open import Relation.Nullary

-----------------
-- CLEANUP (∈) : this is surely in the standard library
-----------------
-- More general purpose definitions (should also be in standard library)
-- list membership
infix 4 _∈_
data _∈_ {A : Set} : A → List A → Set where
  hd : ∀ {x xs} → x ∈ (x ∷ xs)
  tl : ∀ {x y xs} → x ∈ xs → x ∈ (y ∷ xs)

data Type : Set where
  Int : Type
  Fun : Type → Type → Type

data AType : Set where
    AInt  : AType
    AFun  : AType → AType → AType
    D     : Type → AType

-- typed annotated expressions
ACtx = List AType

Ctx = List Type

-----------------------
-- CLEANUP (≤) : these properties are surely in the standard library
-----------------------
≤-refl : ∀ {n} → n ≤ n
≤-refl {zero} = z≤n
≤-refl {suc n} = s≤s ≤-refl

-----------------------
-- CLEANUP (≤) : these properties are surely in the standard library
-----------------------
≤-trans : ∀ {a b c} → a ≤ b → b ≤ c → a ≤ c
≤-trans z≤n q = z≤n
≤-trans (s≤s p) (s≤s q) = s≤s (≤-trans p q)

-----------------------
-- CLEANUP (≤) : these properties are surely in the standard library
-----------------------
≤-suc-right : ∀ {m n} → m ≤ n → m ≤ suc n
≤-suc-right z≤n = z≤n
≤-suc-right (s≤s p) = s≤s (≤-suc-right p)

-----------------------
-- CLEANUP (≤) : these properties are surely in the standard library
-----------------------
≤-suc-left : ∀ {m n} → suc m ≤ n → m ≤ n
≤-suc-left (s≤s p) = ≤-suc-right p

data _↝_ : Ctx → Ctx → Set where
  ↝-refl   : ∀ {Γ}      → Γ ↝ Γ
  ↝-extend : ∀ {Γ Γ' τ} → Γ ↝ Γ' → Γ ↝ (τ ∷ Γ')

↝-≤ : ∀ Γ Γ' → Γ ↝ Γ' → length Γ ≤ length Γ'
↝-≤ .Γ' Γ' ↝-refl = ≤-refl
↝-≤ Γ .(τ ∷ Γ') (↝-extend {.Γ} {Γ'} {τ} Γ↝Γ') = ≤-suc-right (↝-≤ Γ Γ' Γ↝Γ')

↝-no-left : ∀ Γ τ → ¬ (τ ∷ Γ) ↝ Γ
↝-no-left Γ τ p = 1+n≰n (↝-≤ (τ ∷ Γ) Γ p)

↝-trans : ∀ {Γ Γ' Γ''} → Γ ↝ Γ' → Γ' ↝ Γ'' → Γ ↝ Γ''
↝-trans Γ↝Γ' ↝-refl = Γ↝Γ'
↝-trans Γ↝Γ' (↝-extend Γ'↝Γ'') = ↝-extend (↝-trans Γ↝Γ' Γ'↝Γ'')

lem : ∀ x y xs xs' → (x ∷ xs) ↝ xs' → xs ↝ (y ∷ xs')
lem x y xs .(x ∷ xs) ↝-refl = ↝-extend (↝-extend ↝-refl)
lem x y xs .(x' ∷ xs') (↝-extend {.(x ∷ xs)} {xs'} {x'} p) = ↝-extend (lem x x' xs xs' p)

data _↝_↝_ : Ctx → Ctx → Ctx → Set where
  ↝↝-base   : ∀ {Γ Γ''} → Γ ↝ Γ'' → Γ ↝ [] ↝ Γ''
  ↝↝-extend : ∀ {Γ Γ' Γ'' τ} → Γ ↝ Γ' ↝ Γ'' → (τ ∷ Γ) ↝ (τ ∷ Γ') ↝ (τ ∷ Γ'')

-- Typed residula expressions
data Exp'' (Γ : Ctx) : Type → Set where
  EVar : ∀ {τ} → τ ∈ Γ → Exp'' Γ τ
  EInt : ℕ → Exp'' Γ Int
  EAdd : Exp'' Γ Int → Exp'' Γ Int -> Exp'' Γ Int
  ELam : ∀ {τ τ'} → Exp'' (τ ∷ Γ) τ' → Exp'' Γ (Fun τ τ')
  EApp : ∀ {τ τ'} → Exp'' Γ (Fun τ τ')  → Exp'' Γ τ → Exp'' Γ τ'

data AExp (Δ : ACtx) : AType → Set where
  AVar : ∀ {α} → α ∈ Δ → AExp Δ α
  AInt : ℕ → AExp Δ AInt
  AAdd : AExp Δ AInt → AExp Δ AInt → AExp Δ AInt
  ALam : ∀ {α₁ α₂}   → AExp (α₂ ∷ Δ) α₁ → AExp Δ (AFun α₂ α₁)
  AApp : ∀ {α₁ α₂}   → AExp Δ (AFun α₂ α₁) → AExp Δ α₂ → AExp Δ α₁
  DInt : ℕ → AExp Δ (D Int)
  DAdd : AExp Δ (D Int) → AExp Δ (D Int) → AExp Δ (D Int)
  DLam : ∀ {α₁ α₂}   → AExp ((D α₂) ∷ Δ) (D α₁) → AExp Δ (D (Fun α₂ α₁))
  DApp : ∀ {α₁ α₂}   → AExp Δ (D (Fun α₂ α₁)) → AExp Δ (D α₂) → AExp Δ (D α₁)

-- -- index Γ = nesting level of dynamic definitions / dynamic environment
Imp'' : Ctx → AType → Set
Imp'' Γ (AInt) = ℕ
Imp'' Γ (AFun α₁ α₂) = ∀ {Γ'} → Γ ↝ Γ' → (Imp'' Γ' α₁ → Imp'' Γ' α₂)
Imp'' Γ (D σ) = Exp'' Γ σ

-- -- index = nesting level of dynamic definitions
data AEnv2 : Ctx → ACtx → Set where
  [] : AEnv2 [] []
  consS : ∀ {Γ Δ Γ'} → Γ ↝ Γ' → (α : AType) → Imp'' Γ' α → AEnv2 Γ Δ → AEnv2 Γ' (α ∷ Δ)
  consD : ∀ {Γ Δ} → (σ : Type) → Exp'' (σ ∷ Γ)  σ → AEnv2 Γ Δ → AEnv2 (σ ∷ Γ) (D σ ∷ Δ)

elevate-var : ∀ {Γ Γ' τ} → Γ ↝ Γ' → τ ∈ Γ → τ ∈ Γ'
elevate-var ↝-refl x = x
elevate-var (↝-extend Γ↝Γ') x = tl (elevate-var Γ↝Γ' x)

elevate-var2 : ∀ {Γ Γ' Γ'' τ} → Γ ↝ Γ' ↝ Γ'' → τ ∈ Γ → τ ∈ Γ''
elevate-var2 (↝↝-base x) x₁ = elevate-var x x₁
elevate-var2 (↝↝-extend Γ↝Γ'↝Γ'') hd = hd
elevate-var2 (↝↝-extend Γ↝Γ'↝Γ'') (tl x) = tl (elevate-var2 Γ↝Γ'↝Γ'' x)

elevate : ∀ {Γ Γ' Γ'' τ} → Γ ↝ Γ' ↝ Γ'' → Exp'' Γ τ → Exp'' Γ'' τ
elevate Γ↝Γ'↝Γ'' (EVar x) = EVar (elevate-var2 Γ↝Γ'↝Γ'' x)
elevate Γ↝Γ'↝Γ'' (EInt x) = EInt x
elevate Γ↝Γ'↝Γ'' (EAdd e e₁) = EAdd (elevate Γ↝Γ'↝Γ'' e) (elevate Γ↝Γ'↝Γ'' e₁)
elevate Γ↝Γ'↝Γ'' (ELam e) = ELam (elevate (↝↝-extend Γ↝Γ'↝Γ'') e)
elevate Γ↝Γ'↝Γ'' (EApp e e₁) = EApp (elevate Γ↝Γ'↝Γ'' e) (elevate Γ↝Γ'↝Γ'' e₁)

lift2 : ∀ {Γ Γ'} α → Γ ↝ Γ' → Imp'' Γ α → Imp'' Γ' α
lift2 AInt p v = v
lift2 (AFun x x₁) Γ↝Γ' v = λ Γ'↝Γ'' → v (↝-trans Γ↝Γ' Γ'↝Γ'')
lift2 (D x₁) Γ↝Γ' v = elevate (↝↝-base Γ↝Γ') v

lookup2 : ∀ {α Δ Γ Γ'} → Γ ↝ Γ' → AEnv2 Γ Δ → α ∈ Δ → Imp'' Γ' α
lookup2 Γ↝Γ' (consS p α v env) hd = lift2 α Γ↝Γ' v
lookup2 Γ↝Γ' (consS p α₁ v env) (tl x) = lookup2 (↝-trans p Γ↝Γ') env x
lookup2 Γ↝Γ' (consD α v env) hd = lift2 (D α) Γ↝Γ' v
lookup2 ↝-refl (consD α₁ v env) (tl x) = lookup2 (↝-extend ↝-refl) env x
lookup2 (↝-extend Γ↝Γ') (consD α₁ v env) (tl x) = lookup2 (lem α₁ _ _ _ Γ↝Γ') env x

pe2 : ∀ {α Δ Γ} → AExp Δ α → AEnv2 Γ Δ → Imp'' Γ α
pe2 (AVar x) env = lookup2 ↝-refl env x
pe2 (AInt x) env = x
pe2 (AAdd e₁ e₂) env = pe2 e₁ env + pe2 e₂ env
pe2 {AFun α₂ α₁} (ALam e) env = λ Γ↝Γ' → λ y → pe2 e (consS Γ↝Γ' α₂ y env)
pe2 (AApp e₁ e₂) env = ((pe2 e₁ env) ↝-refl) (pe2 e₂ env)
pe2 (DInt x) env = EInt x
pe2 (DAdd e e₁) env = EAdd (pe2 e env) (pe2 e₁ env)
pe2 {D (Fun σ₁ σ₂)} (DLam e) env = ELam (pe2 e (consD σ₁ (EVar hd) env))
                                                 -- ELam (pe2 (consS (↝-extend {τ = σ₁} ↝-refl) (D σ₁) (EVar hd) env)) works too;
                                                 -- it is probably a canonical solution, but I (Lu) do not see why...
pe2 (DApp e e₁) env = EApp (pe2 e env) (pe2 e₁ env)

module Examples where
  open import Relation.Binary.PropositionalEquality

  x : ∀ {α Δ} → AExp (α ∷ Δ) α
  x = AVar hd
  y : ∀ {α₁ α Δ} → AExp (α₁ ∷ α ∷ Δ) α
  y = AVar (tl hd)
  z : ∀ {α₁ α₂ α Δ} → AExp (α₁ ∷ α₂ ∷ α ∷ Δ) α
  z = AVar (tl (tl hd))

-- Dλ y → let f = λ x → x D+ y in Dλ z → f z
  term1 : AExp [] (D (Fun Int (Fun Int Int)))
  term1 = DLam (AApp (ALam (DLam (AApp (ALam y) x)))
                     ((ALam (DAdd x y))))

-- Dλ y → let f = λ x → (Dλ w → x D+ y) in Dλ z → f z
-- Dλ y → (λ f → Dλ z → f z) (λ x → (Dλ w → x D+ y))
  term2 : AExp [] (D (Fun Int (Fun Int Int)))
  term2 = DLam (AApp (ALam (DLam (AApp (ALam y) x)))
                     ((ALam (DLam {α₂ = Int} (DAdd y z)))))

  ex-pe-term1 : pe2 term1 [] ≡ ELam (ELam (EVar hd))
  ex-pe-term1 = refl

  ex-pe-term2 : pe2 term2 [] ≡ ELam (ELam (EVar hd))
  ex-pe-term2 = refl

-- end of file


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

module CPermCat where

open import Level using (zero)
open import Data.Nat using (ℕ; _+_; _*_)
open import Data.Fin using () renaming (zero to 0F)
open import Data.Product using (_,_; uncurry)
import Relation.Binary.PropositionalEquality as P
  using (_≡_; refl; sym; cong₂; isEquivalence)

open import Categories.Category using (Category)
open import Categories.Groupoid using (Groupoid)
open import Categories.Monoidal using (Monoidal)
open import Categories.Monoidal.Helpers using (module MonoidalHelperFunctors)
open import Categories.Bifunctor using (Bifunctor)
open import Categories.NaturalIsomorphism using (NaturalIsomorphism)
open import Categories.Monoidal.Braided using (Braided)
open import Categories.Monoidal.Symmetric using (Symmetric)
open import Categories.RigCategory
  using (RigCategory; module BimonoidalHelperFunctors)

--

open import ConcretePermutation using (CPerm)

open import Permutation using (idp; symp; _●p_; _⊎p_; _×p_)
open import PermutationProperties
  using (assocp; lidp; ridp; rinv; linv; 1p⊎1p≡1p; ⊎p●p≡●p⊎p)

------------------------------------------------------------------------------
-- CPerm is is a category
-- Permutations can be compared by strict propositional equality

CPermCat : Category zero zero zero
CPermCat = record
  { Obj = ℕ
  ; _⇒_ = CPerm
  ; _≡_ = P._≡_
  ; id = idp
  ; _∘_ = _●p_
  ; assoc = λ {_} {_} {_} {_} {f} {g} {h} → assocp {p₁ = h} {g} {f}
  ; identityˡ = lidp
  ; identityʳ = ridp
  ; equiv = P.isEquivalence
  ; ∘-resp-≡ = λ { {_} {_} {_} {f} {.f} {g} {.g} P.refl P.refl → P.refl}
  }

-- ... and a groupoid

CPermGroupoid : Groupoid CPermCat
CPermGroupoid = record
  { _⁻¹ = symp
  ; iso = λ {_} {_} {f} → record { isoˡ = linv f ; isoʳ = rinv f }
  }

-- additive bifunctor and monoidal structure

⊎p-bifunctor : Bifunctor CPermCat CPermCat CPermCat
⊎p-bifunctor = record
  { F₀ = uncurry _+_
  ; F₁ = uncurry _⊎p_
  ; identity = 1p⊎1p≡1p
    -- perhaps the weird order below means the underlying combinators should be fixed?
  ; homomorphism = λ { {_} {_} {_} {p₁ , p₂} {q₁ , q₂} → ⊎p●p≡●p⊎p {f = q₁} {q₂} {p₁} {p₂}}
  ; F-resp-≡ = uncurry (P.cong₂ _⊎p_)
  }

-- the 0 below is the id from CPermMonoidal

module ⊎h = MonoidalHelperFunctors CPermCat ⊎p-bifunctor 0

{- these are all commented out because unite+p and companions are
  no longer defined!
0⊕x≡x : NaturalIsomorphism ⊎h.id⊗x ⊎h.x
0⊕x≡x = record
  { F⇒G = record { η = λ _ → unite+p
                 ; commute = λ f → unite+p∘[0⊎x]≡x∘unite+p (f 0F)
                 }
  ; F⇐G = record { η = λ _ → uniti+p
                  ; commute = λ f → uniti+p∘x≡[0⊎x]∘uniti+p (f 0F)
                  }
  ; iso = λ X → record { isoˡ = linv uniti+p ; isoʳ = linv unite+p }
  }

x⊕0≡x : NaturalIsomorphism ⊎h.x⊗id ⊎h.x
x⊕0≡x = record
  { F⇒G = record { η = λ _ → uniti+rp
                 ; commute = λ f → uniti+rp∘[x⊎0]≡x∘uniti+rp (f 0F)
                 }
  ; F⇐G = record { η = λ _ → unite+rp
                 ; commute = λ f → unite+rp∘[x⊎0]≡x∘unite+rp (f 0F)
                 }
  ; iso = λ X → record { isoˡ = linv unite+rp ; isoʳ = linv uniti+rp }
  }
-}

{--
[x⊕y]⊕z≡x⊕[y⊕z] : NaturalIsomorphism ⊎h.[x⊗y]⊗z ⊎h.x⊗[y⊗z]
[x⊕y]⊕z≡x⊕[y⊕z] = record
  { F⇒G = record
    { η = {!!}
    ; commute = {!!}
    }
  ; F⇐G = record
    { η = {!!}
    ; commute = {!!}
    }
  ; iso = λ X → record { isoˡ = {!!} ; isoʳ = {!!} }
  }

-- and a monoidal category (additive)

M⊕ : Monoidal CPermCat
M⊕ = record
  { ⊗ = ⊎p-bifunctor
  ; id = 0
  ; identityˡ = 0⊕x≡x
  ; identityʳ = x⊕0≡x
  ; assoc = [x⊕y]⊕z≡x⊕[y⊕z]
  ; triangle = {!!}
  ; pentagon = {!!}
  }

-- multiplicative bifunctor and monoidal structure

×p-bifunctor : Bifunctor CPermCat CPermCat CPermCat
×p-bifunctor = record
  { F₀ = λ { (m , n) → m * n}
  ; F₁ = λ { (p₁ , p₂) → p₁ ×p p₂ }
  ; identity = λ { {m , n} → 1p×1p≡1p {m} }
  ; homomorphism = λ { {_} {_} {_} {p₁ , p₂} {q₁ , q₂} →
      ×p-distrib {p₁ = q₁} {q₂} {p₁} {p₂}}
  ; F-resp-≡ = λ {(p₁≡p₃ , p₂≡p₄) → P.cong₂ _×p_ p₁≡p₃ p₂≡p₄ }
  }

module ×h = MonoidalHelperFunctors CPermCat ×p-bifunctor 1

1⊗x≡x : NaturalIsomorphism ×h.id⊗x ×h.x
1⊗x≡x = record
  { F⇒G = record
    { η = {!!}
    ; commute = {!!}
    }
  ; F⇐G = record
    { η = {!!}
    ; commute = {!!}
    }
  ; iso = λ X → record { isoˡ = {!!} ; isoʳ = {!!} }
  }

x⊗1≡x : NaturalIsomorphism ×h.x⊗id ×h.x
x⊗1≡x = record
  { F⇒G = record
    { η = {!!}
    ; commute = {!!}
    }
  ; F⇐G = record
    { η = {!!}
    ; commute = {!!}
    }
  ; iso = λ X → record { isoˡ = {!!} ; isoʳ = {!!} }
  }

[x⊗y]⊗z≡x⊗[y⊗z] : NaturalIsomorphism ×h.[x⊗y]⊗z ×h.x⊗[y⊗z]
[x⊗y]⊗z≡x⊗[y⊗z] = record
  { F⇒G = record
    { η = {!!}
    ; commute = {!!}
    }
  ; F⇐G = record
    { η = {!!}
    ; commute = {!!}
    }
  ; iso = λ X → record { isoˡ = {!!} ; isoʳ = {!!} }
  }

-- and a monoidal category (multiplicative)

M⊗ : Monoidal CPermCat
M⊗ = record
  { ⊗ = ×p-bifunctor
  ; id = 1
  ; identityˡ = 1⊗x≡x
  ; identityʳ = x⊗1≡x
  ; assoc = [x⊗y]⊗z≡x⊗[y⊗z]
  ; triangle = {!!}
  ; pentagon = {!!}
  }

x⊕y≡y⊕x : NaturalIsomorphism ⊎h.x⊗y ⊎h.y⊗x
x⊕y≡y⊕x = record
  { F⇒G = record { η = {!!} ; commute = {!!} }
  ; F⇐G = record { η = {!!} ; commute = {!!} }
  ; iso = λ X → record { isoˡ = {!!} ; isoʳ = {!!} } }

BM⊕ : Braided M⊕
BM⊕ = record
  { braid = x⊕y≡y⊕x
  ; hexagon₁ = {!!}
  ; hexagon₂ = {!!}
  }

x⊗y≡y⊗x : NaturalIsomorphism ×h.x⊗y ×h.y⊗x
x⊗y≡y⊗x = record
  { F⇒G = record { η = {!!} ; commute = {!!} }
  ; F⇐G = record { η = {!!} ; commute = {!!} }
  ; iso = λ X → record { isoˡ = {!!} ; isoʳ = {!!} } }

BM⊗ : Braided M⊗
BM⊗ = record
  { braid = x⊗y≡y⊗x
  ; hexagon₁ = {!!}
  ; hexagon₂ = {!!}
  }

-- with both monoidal structures being symmetric

SBM⊕ : Symmetric BM⊕
SBM⊕ = record { symmetry = {!!} }

SBM⊗ : Symmetric BM⊗
SBM⊗ = record { symmetry = {!!} }

module r = BimonoidalHelperFunctors BM⊕ BM⊗

x⊗0≡0 : NaturalIsomorphism r.x⊗0 r.0↑
x⊗0≡0 = record
  { F⇒G = record
    { η = {!!}
    ; commute = {!!}
    }
  ; F⇐G = record
    { η = {!!}
    ; commute = {!!}
    }
  ; iso = λ X → record { isoˡ = {!!} ; isoʳ = {!!} }
  }

0⊗x≡0 : NaturalIsomorphism r.0⊗x r.0↑
0⊗x≡0 = record
  { F⇒G = record { η = {!!} ; commute = {!!} }
  ; F⇐G = record { η = {!!} ; commute = {!!} }
  ; iso = λ X → record { isoˡ = {!!} ; isoʳ = {!!} }
  }

x⊗[y⊕z]≡[x⊗y]⊕[x⊗z] : NaturalIsomorphism r.x⊗[y⊕z] r.[x⊗y]⊕[x⊗z]
x⊗[y⊕z]≡[x⊗y]⊕[x⊗z] = record
  { F⇒G = record { η = {!!} ; commute = {!!} }
  ; F⇐G = record { η = {!!} ; commute = {!!} }
  ; iso = λ X → record { isoˡ = {!!} ; isoʳ = {!!} }
  }

[x⊕y]⊗z≡[x⊗z]⊕[y⊗z] : NaturalIsomorphism r.[x⊕y]⊗z r.[x⊗z]⊕[y⊗z]
[x⊕y]⊗z≡[x⊗z]⊕[y⊗z] = record
  { F⇒G = record { η = {!!} ; commute = {!!} }
  ; F⇐G = record { η = {!!} ; commute = {!!} }
  ; iso = λ X → record { isoˡ = {!!} ; isoʳ = {!!} }
  }

-- and the multiplicative structure distributing over the additive one

Pi1Rig : RigCategory SBM⊕ SBM⊗
Pi1Rig = record
  { distribₗ = x⊗[y⊕z]≡[x⊗y]⊕[x⊗z]
  ; distribᵣ = [x⊕y]⊗z≡[x⊗z]⊕[y⊗z]
  ; annₗ = 0⊗x≡0
  ; annᵣ = x⊗0≡0
  ; laplazaI = {!!}
  ; laplazaII = {!!}
  ; laplazaIV = {!!}
  ; laplazaVI = {!!}
  ; laplazaIX = {!!}
  ; laplazaX = {!!}
  ; laplazaXI = {!!}
  ; laplazaXIII = {!!}
  ; laplazaXV = {!!}
  ; laplazaXVI =  {!!}
  ; laplazaXVII = {!!}
  ; laplazaXIX = {!!}
  ; laplazaXXIII = {!!}
  }

--}
------------------------------------------------------------------------------


-- A module which re-exports Type.Category.ExtensionalFunctionsCategory as the default category for types, and defines some shorthand names for categorical stuff.
module Type.Category where

open import Functional
open import Function.Equals
open import Logic.Predicate
open import Relator.Equals.Proofs.Equiv
import      Structure.Category.Functor               as Category
import      Structure.Category.Monad.ExtensionSystem as Category
import      Structure.Category.NaturalTransformation as Category
open import Syntax.Transitivity
open import Type

module _ {ℓ} where
  open import Type.Category.ExtensionalFunctionsCategory{ℓ} public

  -- Shorthand for the category-related types in the category of types.
  Functor = Category.Endofunctor(typeExtensionalFnCategory) -- TODO: Should not be an endofunctor. Let it be parameterized by different levels
  module Functor {F} ⦃ functor : Functor(F) ⦄ where
    open Category.Endofunctor(typeExtensionalFnCategory) functor public

    module HaskellNames where
      _<$_ : ∀{x y} → y → (F(x) → F(y))
      _<$_ = map ∘ const

      _$>_ : ∀{x y} → F(x) → y → F(y)
      _$>_ = swap(_<$_)

      _<$>_ : ∀{x y} → (x → y) → (F(x) → F(y))
      _<$>_ = map

      _<&>_ : ∀{x y} → F(x) → (x → y) → F(y)
      _<&>_ = swap(_<$>_)

      -- Applies an unlifted argument to a lifted function, returning a lifted value.
      -- TODO: When `f` is an instance of `Applicative`, it should be functionally equivalent
      -- to `f <*> pure x` because:
      --   f <*$> x
      --   = fmap ($ x) f //Definition: <*$>
      --   = pure ($ x) <*> f //Applicative: "As a consequence of these laws, the Functor instance for f will satisfy..."
      --   = f <*> pure x //Applicative: interchange
      _<*$>_ : ∀{x y : Type{ℓ}} → F(x → y) → (x → F(y))
      f <*$> x = (_$ x) <$> f

  module _ {F₁} ⦃ functor₁ : Functor(F₁) ⦄ {F₂} ⦃ functor₂ : Functor(F₂) ⦄ where
    NaturalTransformation : (∀{T} → F₁(T) → F₂(T)) → Type
    NaturalTransformation η = Category.NaturalTransformation {Cₗ = typeExtensionalFnCategoryObject} {Cᵣ = typeExtensionalFnCategoryObject} ([∃]-intro F₁) ([∃]-intro F₂) (T ↦ η{T})
    module NaturalTransformation {η : ∀{T} → F₁(T) → F₂(T)} ⦃ nt : NaturalTransformation(η) ⦄ where
      open Category.NaturalTransformation {Cₗ = typeExtensionalFnCategoryObject} {Cᵣ = typeExtensionalFnCategoryObject} {[∃]-intro F₁} {[∃]-intro F₂} nt public

    {-
    -- All mappings between functors are natural.
    -- Also called: Theorems for free.
    -- TODO: Is this correct? Is this provable? Maybe one needs to prove stuff about how types are formed?
    natural-functor-mapping : ∀{η : ∀{T} → F₁(T) → F₂(T)} → NaturalTransformation(η)
    Dependent._⊜_.proof (Category.NaturalTransformation.natural (natural-functor-mapping {η}) {X}{Y} {f}) {F₁X} =
      (η ∘ (Functor.map f)) F₁X 🝖[ _≡_ ]-[]
      η(Functor.map f(F₁X))     🝖[ _≡_ ]-[ {!!} ]
      Functor.map f (η(F₁X))    🝖[ _≡_ ]-[]
      ((Functor.map f) ∘ η) F₁X 🝖-end
    -}

  Monad = Category.ExtensionSystem{cat = typeExtensionalFnCategoryObject}
  module Monad {T} ⦃ monad : Monad(T) ⦄ where
    open Category.ExtensionSystem{cat = typeExtensionalFnCategoryObject} (monad) public

    -- Do notation for monads.
    open import Syntax.Do
    instance
      doNotation : DoNotation(T)
      return ⦃ doNotation ⦄ = HaskellNames.return
      _>>=_  ⦃ doNotation ⦄ = swap(HaskellNames.bind)

  open Monad using () renaming (doNotation to Monad-doNotation) public


{-# OPTIONS --type-in-type #-}

Ty% : Set; Ty%
 = (Ty  : Set)
   (ι   : Ty)
   (arr : Ty → Ty → Ty)
 → Ty

ι%   : Ty%; ι% = λ _ ι% _ → ι%
arr% : Ty% → Ty% → Ty%; arr% = λ A B Ty% ι% arr% → arr% (A Ty% ι% arr%) (B Ty% ι% arr%)

Con% : Set;Con%
 = (Con% : Set)
   (nil  : Con%)
   (snoc : Con% → Ty% → Con%)
 → Con%

nil% : Con%;nil%
 = λ Con% nil% snoc → nil%

snoc% : Con% → Ty% → Con%;snoc%
 = λ Γ A Con% nil% snoc% → snoc% (Γ Con% nil% snoc%) A

Var% : Con% → Ty% → Set;Var%
 = λ Γ A →
   (Var% : Con% → Ty% → Set)
   (vz  : (Γ : _)(A : _) → Var% (snoc% Γ A) A)
   (vs  : (Γ : _)(B A : _) → Var% Γ A → Var% (snoc% Γ B) A)
 → Var% Γ A

vz% : ∀{Γ A} → Var% (snoc% Γ A) A;vz%
 = λ Var% vz% vs → vz% _ _

vs% : ∀{Γ B A} → Var% Γ A → Var% (snoc% Γ B) A;vs%
 = λ x Var% vz% vs% → vs% _ _ _ (x Var% vz% vs%)

Tm% : Con% → Ty% → Set;Tm%
 = λ Γ A →
   (Tm%    : Con% → Ty% → Set)
   (var   : (Γ : _) (A : _) → Var% Γ A → Tm% Γ A)
   (lam   : (Γ : _) (A B : _) → Tm% (snoc% Γ A) B → Tm% Γ (arr% A B))
   (app   : (Γ : _) (A B : _) → Tm% Γ (arr% A B) → Tm% Γ A → Tm% Γ B)
 → Tm% Γ A

var% : ∀{Γ A} → Var% Γ A → Tm% Γ A;var%
 = λ x Tm% var% lam app → var% _ _ x

lam% : ∀{Γ A B} → Tm% (snoc% Γ A) B → Tm% Γ (arr% A B);lam%
 = λ t Tm% var% lam% app → lam% _ _ _ (t Tm% var% lam% app)

app% : ∀{Γ A B} → Tm% Γ (arr% A B) → Tm% Γ A → Tm% Γ B;app%
 = λ t u Tm% var% lam% app% →
     app% _ _ _ (t Tm% var% lam% app%) (u Tm% var% lam% app%)

v0% : ∀{Γ A} → Tm% (snoc% Γ A) A;v0%
 = var% vz%

v1% : ∀{Γ A B} → Tm% (snoc% (snoc% Γ A) B) A;v1%
 = var% (vs% vz%)

v2% : ∀{Γ A B C} → Tm% (snoc% (snoc% (snoc% Γ A) B) C) A;v2%
 = var% (vs% (vs% vz%))

v3% : ∀{Γ A B C D} → Tm% (snoc% (snoc% (snoc% (snoc% Γ A) B) C) D) A;v3%
 = var% (vs% (vs% (vs% vz%)))

v4% : ∀{Γ A B C D E} → Tm% (snoc% (snoc% (snoc% (snoc% (snoc% Γ A) B) C) D) E) A;v4%
 = var% (vs% (vs% (vs% (vs% vz%))))

test% : ∀{Γ A} → Tm% Γ (arr% (arr% A A) (arr% A A));test%
  = lam% (lam% (app% v1% (app% v1% (app% v1% (app% v1% (app% v1% (app% v1% v0%)))))))


{-# OPTIONS --cubical --no-import-sorts --guardedness --safe #-}

module Cubical.Codata.M.AsLimit.Container where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv using (_≃_)
open import Cubical.Foundations.Function using (_∘_)

open import Cubical.Data.Unit
open import Cubical.Data.Prod
open import Cubical.Data.Nat as ℕ using (ℕ ; suc ; _+_ )

open import Cubical.Foundations.Transport

open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Function

open import Cubical.Data.Sum

open import Cubical.Foundations.Structure

open import Cubical.Codata.M.AsLimit.helper

-------------------------------------
-- Container and Container Functor --
-------------------------------------

-- Σ[ A ∈ (Type ℓ) ] (A → Type ℓ)
Container : ∀ ℓ -> Type (ℓ-suc ℓ)
Container ℓ = TypeWithStr ℓ (λ x → x → Type ℓ)

-- Polynomial functor (P₀ , P₁)  defined over a container
-- https://ncatlab.org/nlab/show/polynomial+functor

-- P₀ object part of functor
P₀ : ∀ {ℓ} (S : Container ℓ) -> Type ℓ -> Type ℓ
P₀ (A , B) X  = Σ[ a ∈ A ] (B a -> X)

-- P₁ morphism part of functor
P₁ : ∀ {ℓ} {S : Container ℓ} {X Y} (f : X -> Y) -> P₀ S X -> P₀ S Y
P₁ {S = S} f = λ { (a , g) ->  a , f ∘ g }

-----------------------
-- Chains and Limits --
-----------------------

record Chain ℓ : Type (ℓ-suc ℓ) where
  constructor _,,_
  field
    X : ℕ -> Type ℓ
    π : {n : ℕ} -> X (suc n) -> X n

open Chain public

limit-of-chain : ∀ {ℓ} -> Chain ℓ → Type ℓ
limit-of-chain (x ,, pi) = Σ[ x ∈ ((n : ℕ) → x n) ] ((n : ℕ) → pi {n = n} (x (suc n)) ≡ x n)

shift-chain : ∀ {ℓ} -> Chain ℓ -> Chain ℓ
shift-chain = λ X,π -> ((λ x → X X,π (suc x)) ,, λ {n} → π X,π {suc n})

------------------------------------------------------
-- Limit type of a Container , and Shift of a Limit --
------------------------------------------------------

Wₙ : ∀ {ℓ} -> Container ℓ -> ℕ -> Type ℓ
Wₙ S 0 = Lift Unit
Wₙ S (suc n) = P₀ S (Wₙ S n)

πₙ : ∀ {ℓ} -> (S : Container ℓ) -> {n : ℕ} -> Wₙ S (suc n) -> Wₙ S n
πₙ {ℓ} S {0} _ = lift tt
πₙ S {suc n} = P₁ (πₙ S {n})

sequence : ∀ {ℓ} -> Container ℓ -> Chain ℓ
X (sequence S) n = Wₙ S n
π (sequence S) {n} = πₙ S {n}

PX,Pπ : ∀ {ℓ} (S : Container ℓ) -> Chain ℓ
PX,Pπ {ℓ} S =
  (λ n → P₀ S (X (sequence S) n)) ,,
  (λ {n : ℕ} x → P₁ (λ z → z) (π (sequence S) {n = suc n} x ))

-----------------------------------
-- M type is limit of a sequence --
-----------------------------------

M : ∀ {ℓ} -> Container ℓ → Type ℓ
M = limit-of-chain ∘ sequence


module Issue175 where

data List (A : Set) : Set where
  []  : List A
  _∷_ : A → List A → List A

{-# BUILTIN LIST List #-}
{-# BUILTIN NIL  []   #-}
{-# BUILTIN CONS _∷_  #-}

data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x

postulate
  Char   : Set
  String : Set

{-# BUILTIN CHAR   Char   #-}
{-# BUILTIN STRING String #-}

primitive primStringToList : String → List Char

lemma : primStringToList "0" ≡ ('0' ∷ [])
lemma = refl


module L.Base.Id.Core where

-- Use the builtin _≡_ and refl
open import Agda.Builtin.Equality public

J : ∀{a c} {A : Set a} → (C : (x y : A) → x ≡ y → Set c)
              → ((x : A) → C x x refl)
              → (M N : A) → (P : M ≡ N ) → C M N P
J C c M .M refl = c M


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.Polynomials.Multivariate.EquivCarac.A[X]X-A where

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

open import Cubical.Data.Nat
open import Cubical.Data.Vec
open import Cubical.Data.Sigma
open import Cubical.Data.FinData

open import Cubical.Algebra.DirectSum.DirectSumHIT.Base
open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.FGIdeal
open import Cubical.Algebra.CommRing.QuotientRing

open import Cubical.Algebra.CommRing.Instances.Int renaming (ℤCommRing to ℤCR)
open import Cubical.Algebra.CommRing.Instances.Polynomials.MultivariatePoly
     renaming (PolyCommRing to A[X1,···,Xn] ; Poly to A[x1,···,xn])
open import Cubical.Algebra.CommRing.Instances.Polynomials.MultivariatePoly-Quotient
open import Cubical.Algebra.CommRing.Instances.Polynomials.MultivariatePoly-notationZ

open import Cubical.Relation.Nullary

open import Cubical.HITs.SetQuotients as SQ
open import Cubical.HITs.PropositionalTruncation as PT

private variable
  ℓ : Level

-----------------------------------------------------------------------------
-- Functions

module Properties-Equiv-QuotientXn-A
  (Ar@(A , Astr) : CommRing ℓ)
  where

  private
    A[X] : CommRing ℓ
    A[X] = A[X1,···,Xn] Ar 1

    A[x] : Type ℓ
    A[x] = A[x1,···,xn] Ar 1

    A[X]/X : CommRing ℓ
    A[X]/X = A[X1,···,Xn]/<Xkʲ> Ar 1 0 1

    A[x]/x : Type ℓ
    A[x]/x = A[x1,···,xn]/<xkʲ> Ar 1 0 1

  open CommRingStr Astr using ()
    renaming
    ( 0r        to 0A
    ; 1r        to 1A
    ; _+_       to _+A_
    ; -_        to -A_
    ; _·_       to _·A_
    ; +Assoc    to +AAssoc
    ; +IdL      to +AIdL
    ; +IdR      to +AIdR
    ; +InvL     to +AInvL
    ; +InvR     to +AInvR
    ; +Comm     to +AComm
    ; ·Assoc    to ·AAssoc
    ; ·IdL      to ·AIdL
    ; ·IdR      to ·AIdR
    ; ·DistR+   to ·ADistR+
    ; ·DistL+   to ·ADistL+
    ; is-set    to isSetA     )

  open CommRingStr (snd A[X] ) using ()
    renaming
    ( 0r        to 0PA
    ; 1r        to 1PA
    ; _+_       to _+PA_
    ; -_        to -PA_
    ; _·_       to _·PA_
    ; +Assoc    to +PAAssoc
    ; +IdL      to +PAIdL
    ; +IdR      to +PAIdR
    ; +InvL     to +PAInvL
    ; +InvR     to +PAInvR
    ; +Comm     to +PAComm
    ; ·Assoc    to ·PAAssoc
    ; ·IdL      to ·PAIdL
    ; ·IdR      to ·PAIdR
    ; ·Comm     to ·PAComm
    ; ·DistR+   to ·PADistR+
    ; ·DistL+   to ·PADistL+
    ; is-set    to isSetPA     )

  open CommRingStr (snd A[X]/X) using ()
    renaming
    ( 0r        to 0PAI
    ; 1r        to 1PAI
    ; _+_       to _+PAI_
    ; -_        to -PAI_
    ; _·_       to _·PAI_
    ; +Assoc    to +PAIAssoc
    ; +IdL      to +PAIIdL
    ; +IdR      to +PAIIdR
    ; +InvL     to +PAIInvL
    ; +InvR     to +PAIInvR
    ; +Comm     to +PAIComm
    ; ·Assoc    to ·PAIAssoc
    ; ·IdL      to ·PAIIdL
    ; ·IdR      to ·PAIIdR
    ; ·DistR+   to ·PAIDistR+
    ; ·DistL+   to ·PAIDistL+
    ; is-set    to isSetPAI     )

  open RingTheory

-----------------------------------------------------------------------------
-- Direct sens

  A[x]→A : A[x] → A
  A[x]→A = DS-Rec-Set.f _ _ _ _ isSetA
          0A
          base-trad
          _+A_
          +AAssoc
          +AIdR
          +AComm
          base-neutral-eq
          base-add-eq

       where
       base-trad : _
       base-trad (zero ∷ []) a = a
       base-trad (suc k ∷ []) a = 0A

       base-neutral-eq : _
       base-neutral-eq (zero ∷ []) = refl
       base-neutral-eq (suc k ∷ []) = refl

       base-add-eq : _
       base-add-eq (zero ∷ []) a b = refl
       base-add-eq (suc k ∷ []) a b = +AIdR _

  A[x]→A-pres1 : A[x]→A 1PA ≡ 1A
  A[x]→A-pres1 = refl

  A[x]→A-pres+ : (x y : A[x]) → (A[x]→A (x +PA y)) ≡ A[x]→A x +A A[x]→A y
  A[x]→A-pres+ x y = refl

  A[x]→A-pres· : (x y : A[x]) → (A[x]→A (x ·PA y)) ≡ A[x]→A x ·A A[x]→A y
  A[x]→A-pres· = DS-Ind-Prop.f _ _ _ _
               (λ x u v i y → isSetA _ _ (u y) (v y) i)
               (λ y → sym (0LeftAnnihilates (CommRing→Ring Ar) _))
               (λ v a → DS-Ind-Prop.f _ _ _ _ (λ _ → isSetA _ _)
                         (sym (0RightAnnihilates (CommRing→Ring Ar) _))
                         (λ v' a' → base-eq a a' v v')
                         (λ {U V} ind-U ind-V → cong₂ _+A_ ind-U ind-V ∙ sym (·ADistR+ _ _ _)))
               λ {U V} ind-U ind-V y → cong₂ _+A_ (ind-U y) (ind-V y) ∙ sym (·ADistL+ _ _ _)
            where
            base-eq : (a a' : A) → (v v' : Vec ℕ 1) → (A[x]→A (base v a ·PA base v' a')) ≡ A[x]→A (base v a) ·A A[x]→A (base v' a')
            base-eq a a' (zero ∷ []) (zero ∷ []) = refl
            base-eq a a' (zero ∷ []) (suc k' ∷ []) = sym (0RightAnnihilates (CommRing→Ring Ar) _)
            base-eq a a' (suc k ∷ []) (k' ∷ []) = sym (0LeftAnnihilates (CommRing→Ring Ar) _)

  A[X]→A : CommRingHom A[X] Ar
  fst A[X]→A = A[x]→A
  snd A[X]→A = makeIsRingHom A[x]→A-pres1 A[x]→A-pres+ A[x]→A-pres·

  A[x]→A-cancel : (k : Fin 1) → A[x]→A (<Xkʲ> Ar 1 0 1 k) ≡ 0A
  A[x]→A-cancel zero = refl

  A[X]/X→A : CommRingHom A[X]/X Ar
  A[X]/X→A = Quotient-FGideal-CommRing-CommRing.inducedHom A[X] Ar A[X]→A (<Xkʲ> Ar 1 0 1) A[x]→A-cancel

  A[x]/x→A : A[x]/x → A
  A[x]/x→A = fst A[X]/X→A

-----------------------------------------------------------------------------
-- Converse sens

  A→A[x] : A → A[x]
  A→A[x] a = base (0 ∷ []) a

  A→A[x]-pres+ : (a a' : A) → A→A[x] (a +A a') ≡ A→A[x] a +PA A→A[x] a'
  A→A[x]-pres+ a a' = sym (base-add (0 ∷ []) a a')

  A→A[x]/x : A → A[x]/x
  A→A[x]/x = [_] ∘ A→A[x]

  A→A[x]/x-pres+ : (a a' : A) → A→A[x]/x (a +A a') ≡ A→A[x]/x a +PAI A→A[x]/x a'
  A→A[x]/x-pres+ a a' = cong [_] (A→A[x]-pres+ a a')

-----------------------------------------------------------------------------
-- Section sens

  e-sect : (a : A) → A[x]→A (A→A[x] a) ≡ a
  e-sect a = refl

-----------------------------------------------------------------------------
-- Retraction sens

  open IsRing

  e-retr : (x : A[x]/x) → A→A[x]/x (A[x]/x→A x) ≡ x
  e-retr = SQ.elimProp (λ x → isSetPAI _ _)
           (DS-Ind-Prop.f _ _ _ _ (λ x → isSetPAI _ _)
           (cong [_] (base-neutral _))
           (λ v a → base-eq a v)
           λ {U V} ind-U ind-V → cong [_] ((A→A[x]-pres+ _ _)) ∙ cong₂ _+PAI_ ind-U ind-V)

         where
         base-eq : (a : A) → (v : Vec ℕ 1) → A→A[x]/x (A[x]/x→A [ (base v a) ]) ≡ [ (base v a) ]
         base-eq a (zero ∷ []) = cong [_] refl
         base-eq a (suc k ∷ []) = eq/ (base (0 ∷ []) 0A) (base (suc k ∷ []) a) ∣ ((λ x → base (k ∷ []) (-A a)) , helper) ∣₁
           where
           helper : _
           helper = cong (λ X → X +PA base (suc k ∷ []) (-A a)) (base-neutral _)
                     ∙ +PAIdL _
                     ∙ sym (+PAIdR _
                            ∙ cong₂ base
                                    (cong (λ X → X ∷ []) (+-suc _ _ ∙ +-zero _))
                                    (·AIdR _))

module _
  (Ar@(A , Astr) : CommRing ℓ)
  where

  open Iso
  open Properties-Equiv-QuotientXn-A Ar

  Equiv-A[X]/X-A : CommRingEquiv (A[X1,···,Xn]/<Xkʲ> Ar 1 0 1) Ar
  fst Equiv-A[X]/X-A = isoToEquiv is
    where
    is : Iso (A[x1,···,xn]/<xkʲ> Ar 1 0 1) A
    fun is = A[x]/x→A
    inv is = A→A[x]/x
    rightInv is = e-sect
    leftInv is = e-retr
  snd Equiv-A[X]/X-A = snd A[X]/X→A

Equiv-ℤ[X]/X-ℤ : RingEquiv (CommRing→Ring ℤ[X]/X) (CommRing→Ring ℤCR)
Equiv-ℤ[X]/X-ℤ = Equiv-A[X]/X-A ℤCR


module Type.Properties.Homotopy.Proofs where

import      Data.Tuple as Tuple
open import Functional
open import Function.Axioms
open import Logic
open import Logic.Classical
open import Logic.Predicate
open import Logic.Propositional
import      Lvl
open import Numeral.Natural
open import Type
open import Type.Dependent
open import Type.Properties.Homotopy
open import Type.Properties.MereProposition
open import Type.Properties.Singleton
open import Type.Properties.Singleton.Proofs
open import Structure.Function.Domain
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties
open import Structure.Setoid
open import Structure.Type.Identity
open import Syntax.Function
open import Syntax.Transitivity

private variable ℓ ℓₑ ℓₑₑ ℓₚ ℓ₁ ℓ₂ : Lvl.Level
private variable n : ℕ

module _ {ℓ} ⦃ equiv : ∀{T : Type{ℓ}} → Equiv{ℓ}(T) ⦄ where
  private variable T : Type{ℓ}
  {-
  private open module EquivEquiv{T} = Equiv(equiv{T}) using () renaming (_≡_ to _≡ₑ_)
  module _ ⦃ identElim : ∀{ℓ}{T : Type{ℓ}} → IdentityEliminator(_≡ₑ_ {T = T}) ⦄ where
    constant-endofunction-existence-on-equivalence-is-hset : ∀{x y : T} → ∃{Obj = (x ≡ y) → (x ≡ y)}(Constant) → HomotopyLevel(2)(T)
    HomotopyLevel.proof (constant-endofunction-existence-on-equivalence-is-hset ([∃]-intro const)) {x = x} {y} {xy₁} {xy₂} = {!!} where
      equivalence-endofunction-invertibleₗ : ∀{f : ∀{x y : T} → (x ≡ y) → (x ≡ y)} → (∀{x y : T} → Invertibleₗ(f{x}{y}))
      ∃.witness (equivalence-endofunction-invertibleₗ {T = T}{f = f} {x}{y}) xy =
        xy 🝖 symmetry(_≡ₑ_) (f(reflexivity _))
      Tuple.left (∃.proof equivalence-endofunction-invertibleₗ) = {!!}
      Inverseₗ.proof (Tuple.right (∃.proof (equivalence-endofunction-invertibleₗ {T = T}{f = f} {x}{y}))) {xy} = idElim(_≡ₑ_) ⦃ inst = identElim{T = T} ⦄ (xy ↦ (f(xy) 🝖 symmetry(_≡ₑ_) (f(reflexivity(_≡ₑ_))) ≡ₑ xy)) {!!} xy
  -}

  HomotopyLevel-zero-step-is-one : (∀{x y : T} → HomotopyLevel(0)(x ≡ y)) → HomotopyLevel(1)(T)
  HomotopyLevel.proof (HomotopyLevel-zero-step-is-one p) {x}{y} = Σ.left(HomotopyLevel.proof(p{x}{y}))

  HomotopyLevel-step-is-successor : (∀{x y : T} → HomotopyLevel(n)(x ≡ y)) → HomotopyLevel(𝐒(n))(T)
  HomotopyLevel-step-is-successor {n = 𝟎}      = HomotopyLevel-zero-step-is-one
  HomotopyLevel-step-is-successor {n = 𝐒(n)} p = intro(\{x}{y} → HomotopyLevel.proof(p{x}{y}))

module _
  ⦃ equiv : ∀{ℓ}{T : Type{ℓ}} → Equiv{ℓ}(T) ⦄
  ⦃ funcExt : ∀{ℓ₁ ℓ₂}{T : Type{ℓ₁}}{P : T → Stmt{ℓ₂}} → DependentImplicitFunctionExtensionality(T)(P) ⦄
  ⦃ prop-eq : ∀{ℓ}{T : Type{ℓ}}{x y : T} → MereProposition(x ≡ y) ⦄
  where

  private variable T : Type{ℓ}

  HomotopyLevel-prop₊ : MereProposition(Names.HomotopyLevel(𝐒(n))(T))
  HomotopyLevel-prop₊ {𝟎}    = prop-universal ⦃ prop-p = prop-universal ⦃ prop-p = prop-eq ⦄ ⦄
  HomotopyLevel-prop₊ {𝐒(n)} = prop-universal ⦃ prop-p = prop-universal ⦃ prop-p = HomotopyLevel-prop₊ {n} ⦄ ⦄

  module _
    (base₁ : ∀{ℓ}{A : Type{ℓ}} → HomotopyLevel(1)(A) → HomotopyLevel(2)(A))
    where

    HomotopyLevel-one-is-zero-step : HomotopyLevel(1)(T) → (∀{x y : T} → HomotopyLevel(0)(x ≡ y))
    HomotopyLevel.proof(HomotopyLevel-one-is-zero-step h1 {x} {y}) = intro (HomotopyLevel.proof h1) (HomotopyLevel.proof(base₁ h1))

    HomotopyLevel-successor-step : HomotopyLevel(𝐒(n))(T) → (∀{x y : T} → HomotopyLevel(n)(x ≡ y))
    HomotopyLevel-successor-step {n = 𝟎}      = HomotopyLevel-one-is-zero-step
    HomotopyLevel-successor-step {n = 𝐒(n)} p = intro(HomotopyLevel.proof p)

    HomotopyLevel-successor : HomotopyLevel(n)(T) → HomotopyLevel(𝐒(n))(T)
    HomotopyLevel-successor {n = 0}       h0   = MereProposition.uniqueness(unit-is-prop ⦃ proof = intro (Σ.left h0) (Σ.right h0) ⦄)
    HomotopyLevel-successor {n = 1}            = base₁
    HomotopyLevel-successor {n = 𝐒(𝐒(n))} hssn = HomotopyLevel-successor {n = 𝐒(n)} hssn

{-
    {- TODO: The zero case needs assumptions about the sigma type because it is not a mere proposition unless both A and equality are mere propositions. So first, prove if equality on the sigma type depends only on its components, and its types are mere propositions, then the sigma type is a mere proposition. Secondly, one can use that proof here
    HomotopyLevel-prop : MereProposition(HomotopyLevel(n)(A))
    HomotopyLevel-prop {𝟎} = intro {!!}
    HomotopyLevel-prop {𝐒 n} = {!!}
    -}

{-
module _ ⦃ equiv : Equiv{ℓₑ}(T) ⦄ ⦃ equiv-equiv : Equiv{ℓₑ}(Equiv._≡_ equiv) ⦄ where
    -- TODO: ComputablyDecidable → UIP (https://homotopytypetheory.org/2012/03/30/a-direct-proof-of-hedbergs-theorem/)
    -- TODO: http://www.cse.chalmers.se/~nad/listings/equality/Equality.Decidable-UIP.html
  classical-to-uip : (∀{x y : T} → ((x ≡ y) ∨ (x ≢ y))) → UniqueIdentityProofs(T)
  MereProposition.uniqueness (classical-to-uip {T = T} dec {x} {y}) {xy₁} {xy₂} = {!p xy₁!} where
    {-
    p : ∀{x y : T} → (x ≡ y) → Stmt
    p {x}{y} eq with dec{x}{x} | dec{x}{y}
    ... | [∨]-introₗ xx  | [∨]-introₗ xy  = eq ≡ transitivity(_≡_) xx xy
    ... | [∨]-introₗ xx  | [∨]-introᵣ nxy with () ← nxy eq
    ... | [∨]-introᵣ nxx | [∨]-introₗ _   with () ← nxx [≡]-intro
    -}

    dec-eq : ∀{x y} → (x ≡ y) → (x ≡ y)
    dec-eq {x}{y} eq with dec{x}{y}
    ... | [∨]-introₗ xy  = xy
    ... | [∨]-introᵣ nxy with () ← nxy eq

    dec-eq-unique : ∀{x y}{xy₁ xy₂ : x ≡ y} → (dec-eq xy₁ ≡ dec-eq xy₂)
    dec-eq-unique {x}{y} {xy₁} with dec{x}{y}
    ... | [∨]-introₗ _   = ?
    ... | [∨]-introᵣ nxy with () ← nxy xy₁

    dec-eq-unit : ∀{x y}{eq : x ≡ y} → (eq ≡ dec-eq eq)
    dec-eq-unit  {x}{y}{eq} with dec{y}{y} | dec{x}{y}
    ... | [∨]-introₗ yy | [∨]-introₗ xy = {!!}
    ... | [∨]-introₗ yy | [∨]-introᵣ x₂ = {!!}
    ... | [∨]-introᵣ x₁ | [∨]-introₗ x₂ = {!!}
    ... | [∨]-introᵣ x₁ | [∨]-introᵣ x₂ = {!!}

{-    p : ∀{x y : T} → (xy : x ≡ y) → (xy ≡ dec-eq(xy))
    p {x}{y} [≡]-intro with dec{x}{x} | dec{x}{y}
    ... | [∨]-introₗ a | [∨]-introₗ x₁ = {![≡]-intro!}
    ... | [∨]-introₗ a | [∨]-introᵣ x₁ = {!!}
    ... | [∨]-introᵣ a | [∨]-introₗ x₁ = {!!}
    ... | [∨]-introᵣ a | [∨]-introᵣ x₁ = {!!}
-}
-}
-}


{-# OPTIONS --universe-polymorphism #-}
open import Level
open import Categories.Category
module Categories.Power.Functorial {o ℓ e : Level} (C : Category o ℓ e) where

open import Relation.Binary.PropositionalEquality using (≡-irrelevance)
open import Data.Unit using (⊤; tt)
open import Function using () renaming (_∘_ to _∙_)
open import Relation.Binary using (module IsEquivalence)

open import Categories.Support.PropositionalEquality
import Categories.Power as Power
open Power C
open import Categories.Functor hiding (identityˡ) renaming (_≡_ to _≡F_; _∘_ to _∘F_; id to idF)
open import Categories.NaturalTransformation using (NaturalTransformation; module NaturalTransformation)
open import Categories.Discrete
open import Categories.Equivalence.Strong hiding (module Equiv)

open Category using (Obj)
open Category C using (_⇒_; _∘_; _≡_; module Equiv)
open import Categories.FunctorCategory
open import Categories.Lift
open import Categories.NaturalIsomorphism as NI using (NaturalIsomorphism; module NaturalIsomorphism)
open Functor using () renaming (F₀ to map₀; F₁ to map₁)
open NaturalTransformation using (η)

z : Level
z = o ⊔ ℓ ⊔ e

open import Categories.Categories using (Categories)
import Categories.Morphisms as M
open M (Categories z z e) using (_≅_)

exp→functor₀ : ∀ {I} → Obj (Exp I) → Functor (Discrete I) C
exp→functor₀ X =
  record
  { F₀ = X
  ; F₁ = my-F₁
  ; identity = Equiv.refl
  ; homomorphism = λ {_ _ _ A≣B B≣C} → my-homomorphism A≣B B≣C
  ; F-resp-≡ = λ {_ _ e1 e2} _ → Equiv.reflexive (≣-cong my-F₁ (≡-irrelevance e1 e2))
  }
  where
  my-F₁ : ∀ {A B} → (A ≣ B) → (X A ⇒ X B)
  my-F₁ ≣-refl = C.id
  .my-homomorphism : ∀ {A B C} (A≣B : A ≣ B) (B≣C : B ≣ C) → my-F₁ (≣-trans A≣B B≣C) ≡ my-F₁ B≣C ∘ my-F₁ A≣B
  my-homomorphism ≣-refl ≣-refl = Equiv.sym C.identityˡ

exp→functor₁ : ∀ {I} {X Y} → Exp I [ X , Y ] → NaturalTransformation (exp→functor₀ X) (exp→functor₀ Y)
exp→functor₁ {X = X} {Y} F = record { η = F; commute = my-commute }
  where
  .my-commute : ∀ {A B} (A≣B : A ≣ B) → F B ∘ map₁ (exp→functor₀ X) A≣B ≡ map₁ (exp→functor₀ Y) A≣B ∘ F A
  my-commute ≣-refl = Equiv.trans C.identityʳ (Equiv.sym C.identityˡ)

exp→functor : ∀ {I} → Functor (Exp I) (Functors (Discrete I) C)
exp→functor =
  record
  { F₀ = exp→functor₀
  ; F₁ = exp→functor₁
  ; identity = Equiv.refl
  ; homomorphism = Equiv.refl
  ; F-resp-≡ = λ eqs {x} → eqs x
  }

functor→exp : ∀ {I} → Functor (Functors (Discrete I) C) (Exp I)
functor→exp =
  record
  { F₀ = Functor.F₀
  ; F₁ = NaturalTransformation.η
  ; identity = λ _ → Equiv.refl
  ; homomorphism = λ _ → Equiv.refl
  ; F-resp-≡ = λ eqs i → eqs {i}
  }

semicanonical : ∀ {I} → (F : Functor (Discrete I) C) → F ≡F (exp→functor₀ (map₀ F))
semicanonical {I} F ≣-refl = ≡⇒∼ F.identity
  where
  module F = Functor F
  open Heterogeneous C

exp≋functor : ∀ {I} → StrongEquivalence (Exp I) (Functors (Discrete I) C)
exp≋functor {I} = record
  { F = exp→functor
  ; G = functor→exp
  ; weak-inverse = record
    { F∘G≅id = record
      { F⇒G = record
        { η = Sc.F⇐G
        ; commute = λ f → Equiv.trans C.identityˡ (Equiv.sym C.identityʳ)
        }
      ; F⇐G = record
        { η = Sc.F⇒G
        ; commute = λ f → Equiv.trans C.identityˡ (Equiv.sym C.identityʳ)
        }
      ; iso = λ X → record { isoˡ = C.identityˡ; isoʳ = C.identityˡ }
      }
    ; G∘F≅id = IsEquivalence.refl NI.equiv
    }
  }
  where
  FDIC = Functors (Discrete I) C
  module Sc (X : Obj FDIC) = NaturalIsomorphism (NI.≡→iso X (exp→functor₀ (map₀ X)) (semicanonical X))

exp≅functor : (ext : ∀ {a b} {A : Set a} {B : A → Set b} (f g : (x : A) → B x) → (∀ x → f x ≣ g x) → f ≣ g) → (id-propositionally-unique : (A : C.Obj) (f : A ⇒ A) → .(f ≡ C.id) → f ≣ C.id) → ∀ {I} → LiftC z z e (Exp I) ≅ Functors (Discrete I) C
exp≅functor ext id-propositionally-unique {I} =
  record
  { f = LiftFˡ exp→functor
  ; g = LiftFʳ functor→exp
  ; iso = record
    { isoˡ = λ f → Heterogeneous.refl _
    ; isoʳ = λ {A B} f → ir A B f
    }
  }
  where
  FDIC = Functors (Discrete I) C
  f∘g = LiftFˡ exp→functor ∘F LiftFʳ functor→exp

  squash : ∀ (A : Obj FDIC) → Obj FDIC
  squash A = exp→functor₀ (map₀ A)

  ≣-cong′ : ∀ {a b} {A : Set a} {B : Set b} {x y : A} (f : (z : A) → (y ≣ z) → B) → (eq : x ≣ y) → f x (≣-sym eq) ≣ f y ≣-refl
  ≣-cong′ f ≣-refl = ≣-refl

  squash-does-nothing : (A : Obj FDIC) → squash A ≣ A
  squash-does-nothing A = ≣-cong′ {B = Obj FDIC} (λ f eq → record {
                             F₀ = map₀ A;
                             F₁ = λ {i j : I} → f i j;
                             identity = λ {i} → ≣-subst (λ f → f i i ≣-refl ≡ C.id) eq (Functor.identity A {i});
                             homomorphism = λ {i j k i≣j j≣k} → ≣-subst (λ f → f i k (≣-trans i≣j j≣k) ≡ f j k j≣k ∘ f i j i≣j) eq (Functor.homomorphism A {f = i≣j} {j≣k});
                             F-resp-≡ = λ {i j ij ji} → ≣-subst (λ f → ⊤ → f i j ij ≡ f i j ji) eq (Functor.F-resp-≡ A {i} {j} {ij} {ji}) })
                    lemma₃
    where
    .lemma₁ : (i : I) (eq : i ≣ i) → map₁ A eq ≡ C.id
    lemma₁ i eq = Equiv.trans (Functor.F-resp-≡ A tt) (Functor.identity A)

    lemma₂ : (i j : I) (eq : i ≣ j) → map₁ (squash A) eq ≣ map₁ A eq
    lemma₂ i .i ≣-refl = ≣-sym (id-propositionally-unique (map₀ A i) (map₁ A ≣-refl) (lemma₁ i ≣-refl))

    lemma₃ : (λ (i j : I) → map₁ (squash A) {i} {j}) ≣ (λ (i j : I) → map₁ A {i} {j})
    lemma₃ = ext (λ (i j : I) → map₁ (squash A)) (λ (i j : I) → map₁ A)
      (λ (i : I) → ext (λ (j : I) → map₁ (squash A)) (λ (j : I) → map₁ A)
        (λ (j : I) → ext (map₁ (squash A)) (map₁ A) (lemma₂ i j)))

  ∼-subst : ∀ {o ℓ e} {C : Category o ℓ e} {A B A′ B′ : Obj C} (f : C [ A , B ]) (g : C [ A′ , B′ ]) (A′≣A : A′ ≣ A) (B′≣B : B′ ≣ B) → .(C [ ≣-subst (λ X → C [ X , B ]) A′≣A (≣-subst (λ Y → C [ A′ , Y ]) B′≣B g) ≡ f ]) → C [ g ∼ f ]
  ∼-subst {C = C} f g ≣-refl ≣-refl eq = ≡⇒∼ eq
    where open Heterogeneous C

  .∼-unsubst : ∀ {o ℓ e} {C : Category o ℓ e} {A B A′ B′ : Obj C} (f : C [ A , B ]) (g : C [ A′ , B′ ]) (A′≣A : A′ ≣ A) (B′≣B : B′ ≣ B) → C [ g ∼ f ] → C [ ≣-subst (λ X → C [ X , B ]) A′≣A (≣-subst (λ Y → C [ A′ , Y ]) B′≣B g) ≡ f ]
  ∼-unsubst f g ≣-refl ≣-refl (Heterogeneous.≡⇒∼ eq) = irr eq
    where open Heterogeneous C

  ≣-subst-irrel : ∀ {a p} {A : Set a} (P : A → Set p) {x y : A} → (eq₁ eq₂ : x ≣ y) → ∀ {it} → ≣-subst P eq₁ it ≣ ≣-subst P eq₂ it
  ≣-subst-irrel _ ≣-refl ≣-refl = ≣-refl

  ≣-subst-cong : ∀ {a a′ p} {A : Set a} {A′ : Set a′} (P′ : A′ → Set p) (f : A → A′) {x y : A} (eq : x ≣ y) → ∀ {it} → ≣-subst (P′ ∙ f) eq it ≣ ≣-subst P′ (≣-cong f eq) it
  ≣-subst-cong P′ f ≣-refl = ≣-refl

  ≣-subst-fatten : ∀ {a a′ p} {A : Set a} {A′ : Set a′} (P′ : A′ → Set p) (f : A → A′) {x y : A} (eq : x ≣ y) (eq′ : f x ≣ f y) → ∀ {it} → ≣-subst (P′ ∙ f) eq it ≣ ≣-subst P′ eq′ it
  ≣-subst-fatten P′ f eq eq′ = ≣-trans (≣-subst-cong P′ f eq) (≣-subst-irrel P′ (≣-cong f eq) eq′)

  η-under-substˡ : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {F F′ G : Functor C D} (α : NaturalTransformation F′ G) (F′≣F : F′ ≣ F) (c : Obj C) → η (≣-subst (λ H → NaturalTransformation H G) F′≣F α) c ≣ (≣-subst (λ (H : Functor C D) → D [ map₀ H c , map₀ G c ]) F′≣F (η α c))
  η-under-substˡ α ≣-refl c = ≣-refl

  η-under-substʳ : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {F G G′ : Functor C D} (α : NaturalTransformation F G′) (G′≣G : G′ ≣ G) (c : Obj C) → η (≣-subst (λ H → NaturalTransformation F H) G′≣G α) c ≣ (≣-subst (λ (H : Functor C D) → D [ map₀ F c , map₀ H c ]) G′≣G (η α c))
  η-under-substʳ α ≣-refl c = ≣-refl

  .lemma : (A B : Obj FDIC) (f : FDIC [ A , B ]) (i : I) → C [ η (≣-subst (λ X → FDIC [ X , B ]) (squash-does-nothing A) (≣-subst (λ Y → FDIC [ squash A , Y ]) (squash-does-nothing B) (map₁ f∘g f))) i ≡ η f i ]
  lemma A B f i =
    let loc X = map₀ X i in
    let sqdnA = squash-does-nothing A in
    let sqdnB = squash-does-nothing B in
    let MESS = ≣-subst (λ Y → FDIC [ squash A , Y ]) sqdnB (map₁ f∘g f) in

    C.Equiv.reflexive (
      begin
        η (≣-subst (λ X → FDIC [ X , B ]) sqdnA MESS) i
      ≣⟨ η-under-substˡ MESS sqdnA i ⟩
        ≣-subst (λ X → C [ loc X , loc B ]) sqdnA (η MESS i)
      ≣⟨ ≣-subst-fatten (λ c → C [ c , loc B ]) loc sqdnA ≣-refl ⟩
        η (≣-subst (λ Y → FDIC [ squash A , Y ]) sqdnB (map₁ f∘g f)) i
      ≣⟨ η-under-substʳ (map₁ f∘g f) sqdnB i ⟩
        ≣-subst (λ Y → C [ loc A , loc Y ]) sqdnB (η (map₁ f∘g f) i)
      ≣⟨ ≣-subst-fatten (λ c → C [ loc A , c ]) loc sqdnB ≣-refl ⟩
        η f i
      ∎)
    where
    open ≣-reasoning

  ir : (A B : Obj FDIC) (f : FDIC [ A , B ]) → FDIC [ map₁ f∘g f ∼ f ]
  ir A B f = ∼-subst {C = FDIC} f (map₁ f∘g f) (squash-does-nothing A) (squash-does-nothing B) (λ {x} → lemma A B f x)


module Extensions.Vec where

open import Data.Product hiding (map; zip)
open import Data.Nat
open import Data.Fin
open import Data.Vec
open import Data.Product hiding (map)
open import Relation.Binary.PropositionalEquality hiding ([_])
open import Data.List as L using ()
open import Data.List.Properties
open import Relation.Binary.HeterogeneousEquality as H using ()
open ≡-Reasoning public

private
  module HR = H.≅-Reasoning

[]=-functional : ∀ {a n} {A : Set a} (l : Vec A n) i →
                   ∀ {x y : A} → l [ i ]= x → l [ i ]= y → x ≡ y
[]=-functional .(_ ∷ _) _ here here = refl
[]=-functional .(_ ∷ _) .(suc _) (there p) (there q) = []=-functional _ _ p q

lookup⋆map : ∀ {a b : Set} {n} (v : Vec a n) (f : a → b) x →
             f (lookup x v) ≡ lookup x (map f v)
lookup⋆map [] f ()
lookup⋆map (x ∷ xs) f zero = refl
lookup⋆map (x ∷ xs) f (suc y) = lookup⋆map xs f y

strong-lookup : ∀ {a} {A : Set a} {n} → (v : Vec A n) → (i : Fin n) → ∃ λ x → v [ i ]= x
strong-lookup (x ∷ v) zero = x , here
strong-lookup (x ∷ v) (suc i) with strong-lookup v i
... | y , p = y , there p

∷⋆map : ∀ {a b : Set} {n} (f : a → b) (x : a) (xs : Vec a n) → map f (x ∷ xs) ≡ f x ∷ (map f xs)
∷⋆map f x [] = refl
∷⋆map f x (y ∷ xs) = cong (_∷_ (f x)) (∷⋆map f y xs)

-- TODO replace with []=↔lookup
∈⟶index : ∀ {A : Set} {n} {v : Vec A n} {a : A} → a ∈ v → ∃ λ i → lookup i v ≡ a
∈⟶index here = zero , refl
∈⟶index (there e) with ∈⟶index e
∈⟶index (there e) | i , lookup-i≡a = suc i , lookup-i≡a

∈⋆map : ∀ {A B : Set} {n} {v : Vec A n} {a} → a ∈ v → (f : A → B) → (f a) ∈ (map f v)
∈⋆map here f = here
∈⋆map (there a∈v) f = there (∈⋆map a∈v f)

∷-cong : ∀ {l n n'} {A : Set l} {x : A} {xs : Vec A n} {xs' : Vec A n'} →
         n ≡ n' →
         xs H.≅ xs' →
         x ∷ xs H.≅ x ∷ xs'
∷-cong refl H.refl = H.refl

fromList-map : ∀ {l} {A B : Set l} (f : A → B) (xs : L.List A) →
               (fromList ((L.map f xs))) H.≅ (map f (fromList xs))
fromList-map f L.[] = H.refl
fromList-map f (x L.∷ xs) = ∷-cong (length-map _ xs) (fromList-map f xs)

length-toList : ∀ {A : Set } {n} (v : Vec A n) → L.length (toList v) ≡ n
length-toList [] = refl
length-toList (x ∷ v) = cong suc (length-toList v)

length-map-toList : ∀ {A B : Set} {n} {f : A → B} (v : Vec A n) → L.length (L.map f (toList v)) ≡ n
length-map-toList {n = n} {f} v = begin
  L.length (L.map f (toList v))
    ≡⟨ length-map f (toList v) ⟩
  L.length (toList v)
    ≡⟨ length-toList v ⟩
  n ∎

lookup-≔ : ∀ {n k} {A : Set k} (v : Vec A n) i (a : A) → lookup i (v [ i ]≔ a) ≡ a
lookup-≔ (x ∷ v) zero a = refl
lookup-≔ (x ∷ v) (suc i) a = lookup-≔ v i a

infixl 4 _⊑_
data _⊑_ {a} {A : Set a} : ∀ {n m} → Vec A n -> Vec A m -> Set where
  []  : ∀ {n} {xs : Vec A n} → [] ⊑ xs
  _∷_ : ∀ {n m} x {xs : Vec A n} {ys : Vec A m} -> xs ⊑ ys -> (x ∷ xs) ⊑ (x ∷ ys)

infixl 4 _⊒_
_⊒_ : ∀ {a} {A : Set a} {n m} → Vec A n -> Vec A m -> Set
xs ⊒ ys = ys ⊑ xs

open import Relation.Binary.Core using (Reflexive; Transitive)

⊑-refl : ∀ {a n} {A : Set a} → Reflexive (_⊑_ {A = A} {n = n})
⊑-refl {x = []} = []
⊑-refl {x = x ∷ xs} = x ∷ ⊑-refl

⊑-trans : ∀ {a n m k} {A : Set a} {xs : Vec A n} {ys : Vec A m} {zs : Vec A k} →
          xs ⊑ ys → ys ⊑ zs → xs ⊑ zs
⊑-trans [] [] = []
⊑-trans [] (x ∷ b) = []
⊑-trans (x ∷ xs) (.x ∷ ys) = x ∷ (⊑-trans xs ys)

∷ʳ-⊒ : ∀ {a} {A : Set a} (x : A) {n} (xs : Vec A n) → xs ∷ʳ x ⊒ xs
∷ʳ-⊒ x [] = []
∷ʳ-⊒ x (x₁ ∷ Σ₁) = x₁ ∷ (∷ʳ-⊒ x Σ₁)

xs⊒ys-length : ∀ {a n m} {A : Set a} {xs : Vec A n} {ys : Vec A m} → xs ⊒ ys → n ≥ m
xs⊒ys-length [] = z≤n
xs⊒ys-length (x ∷ p) = s≤s (xs⊒ys-length p)

xs⊒ys[i] : ∀ {a n m} {A : Set a} {xs : Vec A n} {ys : Vec A m} {i y} →
           xs [ i ]= y → (p : ys ⊒ xs) → ys [ inject≤ i (xs⊒ys-length p) ]= y
xs⊒ys[i] here (x ∷ q) = here
xs⊒ys[i] (there p) (x ∷ q) = there (xs⊒ys[i] p q)

∷ʳ[length] : ∀ {a n} {A : Set a} (l : Vec A n) x → ∃ λ i → (l ∷ʳ x) [ i ]= x
∷ʳ[length] [] _ = , here
∷ʳ[length] (x ∷ Σ) y with ∷ʳ[length] Σ y
∷ʳ[length] (x ∷ Σ₁) y | i , p = (suc i) , there p

-- Moar All properties

open import Data.Vec.All

all-lookup' : ∀ {a p} {A : Set a} {P : A → Set p} {k} {xs : Vec A k} {i x} →
              xs [ i ]= x → All P xs → P x
all-lookup' here (px ∷ _) = px
all-lookup' (there p) (_ ∷ xs) = all-lookup' p xs

-- proof matters; update a particular witness of a property
_All[_]≔_ : ∀ {a p} {A : Set a} {P : A → Set p} {k} {xs : Vec A k} {i x} →
            All P xs → xs [ i ]= x → P x → All P xs
[] All[ () ]≔ px
(px ∷ xs) All[ here ]≔ px' = px' ∷ xs
(px ∷ xs) All[ there i ]≔ px' = px ∷ (xs All[ i ]≔ px')

_all-∷ʳ_ : ∀ {a n p} {A : Set a} {l : Vec A n} {x} {P : A → Set p} → All P l → P x → All P (l ∷ʳ x)
_all-∷ʳ_ [] q = q ∷ []
_all-∷ʳ_ (px ∷ p) q = px ∷ (p all-∷ʳ q)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Consequences of a monomorphism between monoid-like structures
------------------------------------------------------------------------

-- See Data.Nat.Binary.Properties for examples of how this and similar
-- modules can be used to easily translate properties between types.

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

open import Algebra.Bundles
open import Algebra.Morphism.Structures
open import Relation.Binary.Core

module Algebra.Morphism.MonoidMonomorphism
  {a b ℓ₁ ℓ₂} {M₁ : RawMonoid a ℓ₁} {M₂ : RawMonoid b ℓ₂} {⟦_⟧}
  (isMonoidMonomorphism : IsMonoidMonomorphism M₁ M₂ ⟦_⟧)
  where

open IsMonoidMonomorphism isMonoidMonomorphism
open RawMonoid M₁ renaming (Carrier to A; _≈_ to _≈₁_; _∙_ to _∙_; ε to ε₁)
open RawMonoid M₂ renaming (Carrier to B; _≈_ to _≈₂_; _∙_ to _◦_; ε to ε₂)

open import Algebra.Definitions
open import Algebra.Structures
open import Data.Product using (map)
import Relation.Binary.Reasoning.Setoid as SetoidReasoning

------------------------------------------------------------------------
-- Re-export all properties of magma monomorphisms

open import Algebra.Morphism.MagmaMonomorphism
  isMagmaMonomorphism public

------------------------------------------------------------------------
-- Properties

module _ (◦-isMagma : IsMagma _≈₂_ _◦_) where

  open IsMagma ◦-isMagma renaming (∙-cong to ◦-cong)
  open SetoidReasoning setoid

  identityˡ : LeftIdentity _≈₂_ ε₂ _◦_ → LeftIdentity _≈₁_ ε₁ _∙_
  identityˡ idˡ x = injective (begin
    ⟦ ε₁ ∙ x ⟧      ≈⟨ homo ε₁ x ⟩
    ⟦ ε₁ ⟧ ◦ ⟦ x ⟧  ≈⟨ ◦-cong ε-homo refl ⟩
    ε₂ ◦ ⟦ x ⟧      ≈⟨ idˡ ⟦ x ⟧ ⟩
    ⟦ x ⟧           ∎)

  identityʳ : RightIdentity _≈₂_ ε₂ _◦_ → RightIdentity _≈₁_ ε₁ _∙_
  identityʳ idʳ x = injective (begin
    ⟦ x ∙ ε₁ ⟧      ≈⟨ homo x ε₁ ⟩
    ⟦ x ⟧ ◦ ⟦ ε₁ ⟧  ≈⟨ ◦-cong refl ε-homo ⟩
    ⟦ x ⟧ ◦ ε₂      ≈⟨ idʳ ⟦ x ⟧ ⟩
    ⟦ x ⟧           ∎)

  identity : Identity _≈₂_ ε₂ _◦_ → Identity _≈₁_ ε₁ _∙_
  identity = map identityˡ identityʳ

  zeroˡ : LeftZero _≈₂_ ε₂ _◦_ → LeftZero _≈₁_ ε₁ _∙_
  zeroˡ zeˡ x = injective (begin
    ⟦ ε₁ ∙ x ⟧     ≈⟨  homo ε₁ x ⟩
    ⟦ ε₁ ⟧ ◦ ⟦ x ⟧ ≈⟨  ◦-cong ε-homo refl ⟩
    ε₂   ◦ ⟦ x ⟧   ≈⟨  zeˡ ⟦ x ⟧ ⟩
    ε₂             ≈˘⟨ ε-homo ⟩
    ⟦ ε₁ ⟧         ∎)

  zeroʳ : RightZero _≈₂_ ε₂ _◦_ → RightZero _≈₁_ ε₁ _∙_
  zeroʳ zeʳ x = injective (begin
    ⟦ x ∙ ε₁ ⟧     ≈⟨  homo x ε₁ ⟩
    ⟦ x ⟧ ◦ ⟦ ε₁ ⟧ ≈⟨  ◦-cong refl ε-homo ⟩
    ⟦ x ⟧ ◦ ε₂     ≈⟨  zeʳ ⟦ x ⟧ ⟩
    ε₂             ≈˘⟨ ε-homo ⟩
    ⟦ ε₁ ⟧         ∎)

  zero : Zero _≈₂_ ε₂ _◦_ → Zero _≈₁_ ε₁ _∙_
  zero = map zeroˡ zeroʳ

------------------------------------------------------------------------
-- Structures

isMonoid : IsMonoid _≈₂_ _◦_ ε₂ → IsMonoid _≈₁_ _∙_ ε₁
isMonoid isMonoid = record
  { isSemigroup = isSemigroup M.isSemigroup
  ; identity    = identity    M.isMagma M.identity
  } where module M = IsMonoid isMonoid

isCommutativeMonoid : IsCommutativeMonoid _≈₂_ _◦_ ε₂ →
                      IsCommutativeMonoid _≈₁_ _∙_ ε₁
isCommutativeMonoid isCommMonoid = record
  { isMonoid = isMonoid C.isMonoid
  ; comm     = comm     C.isMagma C.comm
  } where module C = IsCommutativeMonoid isCommMonoid


{-

Basic properties about Σ-types

- Action of Σ on functions ([map-fst], [map-snd])
- Characterization of equality in Σ-types using dependent paths ([ΣPath{Iso,≃,≡}PathΣ], [Σ≡Prop])
- Proof that discrete types are closed under Σ ([discreteΣ])
- Commutativity and associativity ([Σ-swap-*, Σ-assoc-*])
- Distributivity of Π over Σ ([Σ-Π-*])
- Action of Σ on isomorphisms, equivalences, and paths ([Σ-cong-fst], [Σ-cong-snd], ...)
- Characterization of equality in Σ-types using transport ([ΣPathTransport{≃,≡}PathΣ])
- Σ with a contractible base is its fiber ([Σ-contractFst, ΣUnit])

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

open import Cubical.Data.Sigma.Base

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Path
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Univalence
open import Cubical.Relation.Nullary
open import Cubical.Data.Unit.Base

open import Cubical.Reflection.StrictEquiv

open Iso

private
  variable
    ℓ ℓ' ℓ'' : Level
    A A' : Type ℓ
    B B' : (a : A) → Type ℓ
    C : (a : A) (b : B a) → Type ℓ

map-fst : {B : Type ℓ} → (f : A → A') → A × B → A' × B
map-fst f (a , b) = (f a , b)

map-snd : (∀ {a} → B a → B' a) → Σ A B → Σ A B'
map-snd f (a , b) = (a , f b)

map-× : {B : Type ℓ} {B' : Type ℓ'} → (A → A') → (B → B') → A × B → A' × B'
map-× f g (a , b) = (f a , g b)

≡-× : {A : Type ℓ} {B : Type ℓ'} {x y : A × B} → fst x ≡ fst y → snd x ≡ snd y → x ≡ y
≡-× p q i = (p i) , (q i)

-- Characterization of paths in Σ using dependent paths

module _ {A : I → Type ℓ} {B : (i : I) → A i → Type ℓ'}
  {x : Σ (A i0) (B i0)} {y : Σ (A i1) (B i1)}
  where

  ΣPathP : Σ[ p ∈ PathP A (fst x) (fst y) ] PathP (λ i → B i (p i)) (snd x) (snd y)
         → PathP (λ i → Σ (A i) (B i)) x y
  ΣPathP eq i = fst eq i , snd eq i

  PathPΣ : PathP (λ i → Σ (A i) (B i)) x y
         → Σ[ p ∈ PathP A (fst x) (fst y) ] PathP (λ i → B i (p i)) (snd x) (snd y)
  PathPΣ eq = (λ i → fst (eq i)) , (λ i → snd (eq i))

  -- allows one to write
  -- open PathPΣ somePathInΣAB renaming (fst ... )
  module PathPΣ (p : PathP (λ i → Σ (A i) (B i)) x y) where
    open Σ (PathPΣ p) public

  ΣPathIsoPathΣ : Iso (Σ[ p ∈ PathP A (fst x) (fst y) ] (PathP (λ i → B i (p i)) (snd x) (snd y)))
                      (PathP (λ i → Σ (A i) (B i)) x y)
  fun ΣPathIsoPathΣ        = ΣPathP
  inv ΣPathIsoPathΣ        = PathPΣ
  rightInv ΣPathIsoPathΣ _ = refl
  leftInv ΣPathIsoPathΣ _  = refl

  unquoteDecl ΣPath≃PathΣ = declStrictIsoToEquiv ΣPath≃PathΣ ΣPathIsoPathΣ

  ΣPath≡PathΣ : (Σ[ p ∈ PathP A (fst x) (fst y) ] (PathP (λ i → B i (p i)) (snd x) (snd y)))
              ≡ (PathP (λ i → Σ (A i) (B i)) x y)
  ΣPath≡PathΣ = ua ΣPath≃PathΣ

×≡Prop : isProp A' → {u v : A × A'} → u .fst ≡ v .fst → u ≡ v
×≡Prop pB {u} {v} p i = (p i) , (pB (u .snd) (v .snd) i)

-- Characterization of dependent paths in Σ

module _ {A : I → Type ℓ} {B : (i : I) → (a : A i) → Type ℓ'}
  {x : Σ (A i0) (B i0)} {y : Σ (A i1) (B i1)}
  where

  ΣPathPIsoPathPΣ :
    Iso (Σ[ p ∈ PathP A (x .fst) (y .fst) ] PathP (λ i → B i (p i)) (x .snd) (y .snd))
        (PathP (λ i → Σ (A i) (B i)) x y)
  ΣPathPIsoPathPΣ .fun (p , q) i = p i , q i
  ΣPathPIsoPathPΣ .inv pq .fst i = pq i .fst
  ΣPathPIsoPathPΣ .inv pq .snd i = pq i .snd
  ΣPathPIsoPathPΣ .rightInv _ = refl
  ΣPathPIsoPathPΣ .leftInv _ = refl

  unquoteDecl ΣPathP≃PathPΣ = declStrictIsoToEquiv ΣPathP≃PathPΣ ΣPathPIsoPathPΣ

  ΣPathP≡PathPΣ = ua ΣPathP≃PathPΣ

-- Σ of discrete types

discreteΣ : Discrete A → ((a : A) → Discrete (B a)) → Discrete (Σ A B)
discreteΣ {B = B} Adis Bdis (a0 , b0) (a1 , b1) = discreteΣ' (Adis a0 a1)
  where
    discreteΣ' : Dec (a0 ≡ a1) → Dec ((a0 , b0) ≡ (a1 , b1))
    discreteΣ' (yes p) = J (λ a1 p → ∀ b1 → Dec ((a0 , b0) ≡ (a1 , b1))) (discreteΣ'') p b1
      where
        discreteΣ'' : (b1 : B a0) → Dec ((a0 , b0) ≡ (a0 , b1))
        discreteΣ'' b1 with Bdis a0 b0 b1
        ... | (yes q) = yes (transport ΣPath≡PathΣ (refl , q))
        ... | (no ¬q) = no (λ r → ¬q (subst (λ X → PathP (λ i → B (X i)) b0 b1) (Discrete→isSet Adis a0 a0 (cong fst r) refl) (cong snd r)))
    discreteΣ' (no ¬p) = no (λ r → ¬p (cong fst r))

module _ {A : Type ℓ} {A' : Type ℓ'} where
  Σ-swap-Iso : Iso (A × A') (A' × A)
  fun Σ-swap-Iso (x , y) = (y , x)
  inv Σ-swap-Iso (x , y) = (y , x)
  rightInv Σ-swap-Iso _ = refl
  leftInv Σ-swap-Iso _  = refl

  unquoteDecl Σ-swap-≃ = declStrictIsoToEquiv Σ-swap-≃ Σ-swap-Iso

module _ {A : Type ℓ} {B : A → Type ℓ'} {C : ∀ a → B a → Type ℓ''} where
  Σ-assoc-Iso : Iso (Σ[ (a , b) ∈ Σ A B ] C a b) (Σ[ a ∈ A ] Σ[ b ∈ B a ] C a b)
  fun Σ-assoc-Iso ((x , y) , z) = (x , (y , z))
  inv Σ-assoc-Iso (x , (y , z)) = ((x , y) , z)
  rightInv Σ-assoc-Iso _ = refl
  leftInv Σ-assoc-Iso _  = refl

  unquoteDecl Σ-assoc-≃ = declStrictIsoToEquiv Σ-assoc-≃ Σ-assoc-Iso

  Σ-Π-Iso : Iso ((a : A) → Σ[ b ∈ B a ] C a b) (Σ[ f ∈ ((a : A) → B a) ] ∀ a → C a (f a))
  fun Σ-Π-Iso f         = (fst ∘ f , snd ∘ f)
  inv Σ-Π-Iso (f , g) x = (f x , g x)
  rightInv Σ-Π-Iso _    = refl
  leftInv Σ-Π-Iso _     = refl

  unquoteDecl Σ-Π-≃ = declStrictIsoToEquiv Σ-Π-≃ Σ-Π-Iso

Σ-cong-iso-fst : (isom : Iso A A') → Iso (Σ A (B ∘ fun isom)) (Σ A' B)
fun (Σ-cong-iso-fst isom) x = fun isom (x .fst) , x .snd
inv (Σ-cong-iso-fst {B = B} isom) x = inv isom (x .fst) , subst B (sym (ε (x .fst))) (x .snd)
  where
  ε = isHAEquiv.rinv (snd (iso→HAEquiv isom))
rightInv (Σ-cong-iso-fst {B = B} isom) (x , y) = ΣPathP (ε x , toPathP goal)
  where
  ε = isHAEquiv.rinv (snd (iso→HAEquiv isom))
  goal : subst B (ε x) (subst B (sym (ε x)) y) ≡ y
  goal = sym (substComposite B (sym (ε x)) (ε x) y)
      ∙∙ cong (λ x → subst B x y) (lCancel (ε x))
      ∙∙ substRefl {B = B} y
leftInv (Σ-cong-iso-fst {A = A} {B = B} isom) (x , y) = ΣPathP (leftInv isom x , toPathP goal)
  where
  ε = isHAEquiv.rinv (snd (iso→HAEquiv isom))
  γ = isHAEquiv.com (snd (iso→HAEquiv isom))

  lem : (x : A) → sym (ε (fun isom x)) ∙ cong (fun isom) (leftInv isom x) ≡ refl
  lem x = cong (λ a → sym (ε (fun isom x)) ∙ a) (γ x) ∙ lCancel (ε (fun isom x))

  goal : subst B (cong (fun isom) (leftInv isom x)) (subst B (sym (ε (fun isom x))) y) ≡ y
  goal = sym (substComposite B (sym (ε (fun isom x))) (cong (fun isom) (leftInv isom x)) y)
      ∙∙ cong (λ a → subst B a y) (lem x)
      ∙∙ substRefl {B = B} y

Σ-cong-equiv-fst : (e : A ≃ A') → Σ A (B ∘ equivFun e) ≃ Σ A' B
-- we could just do this:
-- Σ-cong-equiv-fst e = isoToEquiv (Σ-cong-iso-fst (equivToIso e))
-- but the following reduces slightly better
Σ-cong-equiv-fst {A = A} {A' = A'} {B = B} e = intro , isEqIntro
 where
  intro : Σ A (B ∘ equivFun e) → Σ A' B
  intro (a , b) = equivFun e a , b
  isEqIntro : isEquiv intro
  isEqIntro .equiv-proof x = ctr , isCtr where
    PB : ∀ {x y} → x ≡ y → B x → B y → Type _
    PB p = PathP (λ i → B (p i))

    open Σ x renaming (fst to a'; snd to b)
    open Σ (equivCtr e a') renaming (fst to ctrA; snd to α)
    ctrB : B (equivFun e ctrA)
    ctrB = subst B (sym α) b
    ctrP : PB α ctrB b
    ctrP = symP (transport-filler (λ i → B (sym α i)) b)
    ctr : fiber intro x
    ctr = (ctrA , ctrB) , ΣPathP (α , ctrP)

    isCtr : ∀ y → ctr ≡ y
    isCtr ((r , s) , p) = λ i → (a≡r i , b!≡s i) , ΣPathP (α≡ρ i , coh i) where
      open PathPΣ p renaming (fst to ρ; snd to σ)
      open PathPΣ (equivCtrPath e a' (r , ρ)) renaming (fst to a≡r; snd to α≡ρ)

      b!≡s : PB (cong (equivFun e) a≡r) ctrB s
      b!≡s i = comp (λ k → B (α≡ρ i (~ k))) (λ k → (λ
        { (i = i0) → ctrP (~ k)
        ; (i = i1) → σ (~ k)
        })) b

      coh : PathP (λ i → PB (α≡ρ i) (b!≡s i) b) ctrP σ
      coh i j = fill (λ k → B (α≡ρ i (~ k))) (λ k → (λ
        { (i = i0) → ctrP (~ k)
        ; (i = i1) → σ (~ k)
        })) (inS b) (~ j)

Σ-cong-fst : (p : A ≡ A') → Σ A (B ∘ transport p) ≡ Σ A' B
Σ-cong-fst {B = B} p i = Σ (p i) (B ∘ transp (λ j → p (i ∨ j)) i)

Σ-cong-iso-snd : ((x : A) → Iso (B x) (B' x)) → Iso (Σ A B) (Σ A B')
fun (Σ-cong-iso-snd isom) (x , y) = x , fun (isom x) y
inv (Σ-cong-iso-snd isom) (x , y') = x , inv (isom x) y'
rightInv (Σ-cong-iso-snd isom) (x , y) = ΣPathP (refl , rightInv (isom x) y)
leftInv (Σ-cong-iso-snd isom) (x , y') = ΣPathP (refl , leftInv (isom x) y')

Σ-cong-equiv-snd : (∀ a → B a ≃ B' a) → Σ A B ≃ Σ A B'
Σ-cong-equiv-snd h = isoToEquiv (Σ-cong-iso-snd (equivToIso ∘ h))

Σ-cong-snd : ((x : A) → B x ≡ B' x) → Σ A B ≡ Σ A B'
Σ-cong-snd {A = A} p i = Σ[ x ∈ A ] (p x i)

Σ-cong-iso : (isom : Iso A A')
           → ((x : A) → Iso (B x) (B' (fun isom x)))
           → Iso (Σ A B) (Σ A' B')
Σ-cong-iso isom isom' = compIso (Σ-cong-iso-snd isom') (Σ-cong-iso-fst isom)

Σ-cong-equiv : (e : A ≃ A')
             → ((x : A) → B x ≃ B' (equivFun e x))
             → Σ A B ≃ Σ A' B'
Σ-cong-equiv e e' = isoToEquiv (Σ-cong-iso (equivToIso e) (equivToIso ∘ e'))

Σ-cong' : (p : A ≡ A') → PathP (λ i → p i → Type ℓ') B B' → Σ A B ≡ Σ A' B'
Σ-cong' p p' = cong₂ (λ (A : Type _) (B : A → Type _) → Σ A B) p p'

-- Alternative version for path in Σ-types, as in the HoTT book

ΣPathTransport : (a b : Σ A B) → Type _
ΣPathTransport {B = B} a b = Σ[ p ∈ (fst a ≡ fst b) ] transport (λ i → B (p i)) (snd a) ≡ snd b

IsoΣPathTransportPathΣ : (a b : Σ A B) → Iso (ΣPathTransport a b) (a ≡ b)
IsoΣPathTransportPathΣ {B = B} a b = compIso (Σ-cong-iso-snd (λ p → invIso (equivToIso (PathP≃Path (λ i → B (p i)) _ _))))
         ΣPathIsoPathΣ

ΣPathTransport≃PathΣ : (a b : Σ A B) → ΣPathTransport a b ≃ (a ≡ b)
ΣPathTransport≃PathΣ {B = B} a b = isoToEquiv (IsoΣPathTransportPathΣ a b)

ΣPathTransport→PathΣ : (a b : Σ A B) → ΣPathTransport a b → (a ≡ b)
ΣPathTransport→PathΣ a b = Iso.fun (IsoΣPathTransportPathΣ a b)

PathΣ→ΣPathTransport : (a b : Σ A B) → (a ≡ b) → ΣPathTransport a b
PathΣ→ΣPathTransport a b = Iso.inv (IsoΣPathTransportPathΣ a b)

ΣPathTransport≡PathΣ : (a b : Σ A B) → ΣPathTransport a b ≡ (a ≡ b)
ΣPathTransport≡PathΣ a b = ua (ΣPathTransport≃PathΣ a b)

Σ-contractFst : (c : isContr A) → Σ A B ≃ B (c .fst)
Σ-contractFst {B = B} c = isoToEquiv isom
  where
  isom : Iso _ _
  isom .fun (a , b) = subst B (sym (c .snd a)) b
  isom .inv b = (c .fst , b)
  isom .rightInv b =
    cong (λ p → subst B p b) (isProp→isSet (isContr→isProp c) _ _ _ _) ∙ transportRefl _
  isom .leftInv (a , b) =
    ΣPathTransport≃PathΣ _ _ .fst (c .snd a , transportTransport⁻ (cong B (c .snd a)) _)

-- a special case of the above
module _ (A : Unit → Type ℓ) where
  ΣUnit : Σ Unit A ≃ A tt
  unquoteDef ΣUnit = defStrictEquiv ΣUnit snd (λ { x → (tt , x) })

Σ-contractSnd : ((a : A) → isContr (B a)) → Σ A B ≃ A
Σ-contractSnd c = isoToEquiv isom
  where
  isom : Iso _ _
  isom .fun = fst
  isom .inv a = a , c a .fst
  isom .rightInv _ = refl
  isom .leftInv (a , b) = cong (a ,_) (c a .snd b)

isEmbeddingFstΣProp : ((x : A) → isProp (B x))
                    → {u v : Σ A B}
                    → isEquiv (λ (p : u ≡ v) → cong fst p)
isEmbeddingFstΣProp {B = B} pB {u = u} {v = v} .equiv-proof x = ctr , isCtr
  where
  ctrP : u ≡ v
  ctrP = ΣPathP (x , isProp→PathP (λ _ → pB _) _ _)
  ctr  : fiber (λ (p : u ≡ v) → cong fst p) x
  ctr  = ctrP , refl

  isCtr : ∀ z → ctr ≡ z
  isCtr (z , p) = ΣPathP (ctrP≡ , cong (sym ∘ snd) fzsingl) where
    fzsingl : Path (singl x) (x , refl) (cong fst z , sym p)
    fzsingl = isContrSingl x .snd (cong fst z , sym p)
    ctrSnd : SquareP (λ i j → B (fzsingl i .fst j)) (cong snd ctrP) (cong snd z) _ _
    ctrSnd = isProp→SquareP (λ _ _ → pB _) _ _ _ _
    ctrP≡ : ctrP ≡ z
    ctrP≡ i = ΣPathP (fzsingl i .fst , ctrSnd i)

Σ≡PropEquiv : ((x : A) → isProp (B x)) → {u v : Σ A B}
            → (u .fst ≡ v .fst) ≃ (u ≡ v)
Σ≡PropEquiv pB = invEquiv (_ , isEmbeddingFstΣProp pB)

Σ≡Prop : ((x : A) → isProp (B x)) → {u v : Σ A B}
       → (p : u .fst ≡ v .fst) → u ≡ v
Σ≡Prop pB p = equivFun (Σ≡PropEquiv pB) p

≃-× : ∀ {ℓ'' ℓ'''} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} {D : Type ℓ'''} → A ≃ C → B ≃ D → A × B ≃ C × D
≃-× eq1 eq2 =
    map-× (fst eq1) (fst eq2)
  , record
     { equiv-proof
       = λ {(c , d) → ((eq1⁻ c .fst .fst
                        , eq2⁻ d .fst .fst)
                          , ≡-× (eq1⁻ c .fst .snd)
                                (eq2⁻ d .fst .snd))
                     , λ {((a , b) , p) → ΣPathP (≡-× (cong fst (eq1⁻ c .snd (a , cong fst p)))
                                                       (cong fst (eq2⁻ d .snd (b , cong snd p)))
                                                , λ i → ≡-× (snd ((eq1⁻ c .snd (a , cong fst p)) i))
                                                             (snd ((eq2⁻ d .snd (b , cong snd p)) i)))}}}
  where
  eq1⁻ = equiv-proof (eq1 .snd)
  eq2⁻ = equiv-proof (eq2 .snd)

{- Some simple ismorphisms -}

prodIso : ∀ {ℓ ℓ' ℓ'' ℓ'''} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} {D : Type ℓ'''}
       → Iso A C
       → Iso B D
       → Iso (A × B) (C × D)
Iso.fun (prodIso iAC iBD) (a , b) = (Iso.fun iAC a) , Iso.fun iBD b
Iso.inv (prodIso iAC iBD) (c , d) = (Iso.inv iAC c) , Iso.inv iBD d
Iso.rightInv (prodIso iAC iBD) (c , d) = ΣPathP ((Iso.rightInv iAC c) , (Iso.rightInv iBD d))
Iso.leftInv (prodIso iAC iBD) (a , b) = ΣPathP ((Iso.leftInv iAC a) , (Iso.leftInv iBD b))

toProdIso : {B C : A → Type ℓ}
          → Iso ((a : A) → B a × C a) (((a : A) → B a) × ((a : A) → C a))
Iso.fun toProdIso = λ f → (λ a → fst (f a)) , (λ a → snd (f a))
Iso.inv toProdIso (f , g) = λ a → (f a) , (g a)
Iso.rightInv toProdIso (f , g) = refl
Iso.leftInv toProdIso b = refl

module _ {A : Type ℓ} {B : A → Type ℓ'} {C : ∀ a → B a → Type ℓ''} where
  curryIso : Iso (((a , b) : Σ A B) → C a b) ((a : A) → (b : B a) → C a b)
  Iso.fun curryIso f a b = f (a , b)
  Iso.inv curryIso f a = f (fst a) (snd a)
  Iso.rightInv curryIso a = refl
  Iso.leftInv curryIso f = refl

  unquoteDecl curryEquiv = declStrictIsoToEquiv curryEquiv curryIso


{-# OPTIONS --safe #-}

module Definition.Typed.Consequences.Syntactic 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.Substitution
open import Definition.LogicalRelation.Substitution.Escape
open import Definition.LogicalRelation.Fundamental
open import Definition.Typed.Consequences.Injectivity

open import Tools.Product

-- the `with` syntax does not work

-- Syntactic validity of type equality.
syntacticEq : ∀ {A B rA Γ} → Γ ⊢ A ≡ B ^ rA → Γ ⊢ A ^ rA × Γ ⊢ B ^ rA
syntacticEq {A} {B} {rA} {Γ} A≡B =
  let X = fundamentalEq A≡B
      [Γ] = proj₁ X
      [A] = proj₁ (proj₂ X)
      [B] = proj₁ (proj₂ (proj₂ X))
  in escapeᵛ [Γ] [A] , escapeᵛ [Γ] [B]

-- Syntactic validity of terms.
syntacticTerm : ∀ {t A rA Γ} → Γ ⊢ t ∷ A ^ rA → Γ ⊢ A ^ rA
syntacticTerm t =
  let X = fundamentalTerm t
      [Γ] = proj₁ X
      [A] = proj₁ (proj₂ X)
      [t] = proj₂ (proj₂ X)
   in  escapeᵛ [Γ] [A]

-- Syntactic validity of term equality.
syntacticEqTerm : ∀ {t u A rA Γ} → Γ ⊢ t ≡ u ∷ A ^ rA → Γ ⊢ A ^ rA × (Γ ⊢ t ∷ A ^ rA × Γ ⊢ u ∷ A ^ rA)
syntacticEqTerm t≡u with fundamentalTermEq t≡u
syntacticEqTerm t≡u | [Γ] , modelsTermEq [A] [t] [u] [t≡u] =
  escapeᵛ [Γ] [A] , escapeTermᵛ [Γ] [A] [t] , escapeTermᵛ [Γ] [A] [u]

-- Syntactic validity of type reductions.
syntacticRed : ∀ {A B rA Γ} → Γ ⊢ A ⇒* B ^ rA → Γ ⊢ A ^ rA × Γ ⊢ B ^ rA
syntacticRed D =
  let X = fundamentalEq (subset* D)
      [Γ] = proj₁ X
      [A] = proj₁ (proj₂ X)
      [B] = proj₁ (proj₂ (proj₂ X))
  in escapeᵛ [Γ] [A] , escapeᵛ [Γ] [B]

-- Syntactic validity of term reductions.
syntacticRedTerm : ∀ {t u A Γ l} → Γ ⊢ t ⇒* u ∷ A ^ l → Γ ⊢ A ^ [ ! , l ] × (Γ ⊢ t ∷ A ^ [ ! , l ] × Γ ⊢ u ∷ A ^ [ ! , l ])
syntacticRedTerm d with fundamentalTermEq (subset*Term d)
syntacticRedTerm d | [Γ] , modelsTermEq [A] [t] [u] [t≡u] =
  escapeᵛ [Γ] [A] , escapeTermᵛ [Γ] [A] [t] , escapeTermᵛ [Γ] [A] [u]

-- Syntactic validity of Π-types.
syntacticΠ : ∀ {Γ F G rF lF lG rΠ lΠ} → Γ ⊢ Π F ^ rF ° lF ▹ G ° lG ° lΠ ^ [ rΠ , ι lΠ ] → Γ ⊢ F ^ [ rF , ι lF ] × Γ ∙ F ^ [ rF , ι lF ] ⊢ G ^ [ rΠ , ι lG ]
syntacticΠ ΠFG with injectivity (refl ΠFG)
syntacticΠ ΠFG | F≡F , rF≡rF , lF≡lF , lG≡lG , G≡G = proj₁ (syntacticEq F≡F) , proj₁ (syntacticEq G≡G)


-- Andreas, 2011-05-09
-- {-# OPTIONS -v tc.inj:40 -v tc.meta:30 #-}
module Issue383b where

postulate
  Σ  : (A : Set) → (A → Set) → Set
  U  : Set
  El : U → Set

mutual

  data Ctxt : Set where
    _▻_ : (Γ : Ctxt) → (Env Γ → U) → Ctxt

  Env : Ctxt → Set
  Env (Γ ▻ σ) = Σ (Env Γ) λ γ → El (σ γ)

postulate
  Δ : Ctxt
  σ : Env Δ → U
  δ : U → Env (Δ ▻ σ)

data Foo : (Γ : Ctxt) → (U → Env Γ) → Set where
  foo : Foo _ δ

-- WORKS NOW;  OLD COMPLAINT:
-- Agda does not solve or simplify the following constraint. Why? Env
-- is constructor-headed.
--
-- _40 := δ  if  [(Σ (Env Δ) (λ γ → El (σ γ))) =< (Env _39) : Set]