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

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

open import Cubical.Data.Vec
open import Cubical.Data.Nat

open import Cubical.Reflection.StrictEquiv

private
  variable
    ℓ ℓ₁ ℓ₂ ℓ₃ : Level

-- Function extensionality is an equivalence
module _ {A : Type ℓ} {B : A → I → Type ℓ₁}
  {f : (x : A) → B x i0} {g : (x : A) → B x i1} where

  funExtEquiv : (∀ x → PathP (B x) (f x) (g x)) ≃ PathP (λ i → ∀ x → B x i) f g
  unquoteDef funExtEquiv = defStrictEquiv funExtEquiv funExt funExt⁻

  funExtPath : (∀ x → PathP (B x) (f x) (g x)) ≡ PathP (λ i → ∀ x → B x i) f g
  funExtPath = ua funExtEquiv

  funExtIso : Iso (∀ x → PathP (B x) (f x) (g x)) (PathP (λ i → ∀ x → B x i) f g)
  funExtIso = iso funExt funExt⁻ (λ x → refl {x = x}) (λ x → refl {x = x})

-- Function extensionality for binary functions
funExt₂ : {A : Type ℓ} {B : A → Type ℓ₁} {C : (x : A) → B x → I → Type ℓ₂}
          {f : (x : A) → (y : B x) → C x y i0}
          {g : (x : A) → (y : B x) → C x y i1}
          → ((x : A) (y : B x) → PathP (C x y) (f x y) (g x y))
          → PathP (λ i → ∀ x y → C x y i) f g
funExt₂ p i x y = p x y i

-- Function extensionality for binary functions is an equivalence
module _ {A : Type ℓ} {B : A → Type ℓ₁} {C : (x : A) → B x → I → Type ℓ₂}
         {f : (x : A) → (y : B x) → C x y i0}
         {g : (x : A) → (y : B x) → C x y i1} where
  private
    appl₂ : PathP (λ i → ∀ x y → C x y i) f g → ∀ x y → PathP (C x y) (f x y) (g x y)
    appl₂ eq x y i = eq i x y

  funExt₂Equiv : (∀ x y → PathP (C x y) (f x y) (g x y)) ≃ (PathP (λ i → ∀ x y → C x y i) f g)
  unquoteDef funExt₂Equiv = defStrictEquiv funExt₂Equiv funExt₂ appl₂

  funExt₂Path : (∀ x y → PathP (C x y) (f x y) (g x y)) ≡ (PathP (λ i → ∀ x y → C x y i) f g)
  funExt₂Path = ua funExt₂Equiv

-- Function extensionality for ternary functions
funExt₃ : {A : Type ℓ} {B : A → Type ℓ₁} {C : (x : A) → B x → Type ℓ₂}
          {D : (x : A) → (y : B x) → C x y → I → Type ℓ₃}
          {f : (x : A) → (y : B x) → (z : C x y) → D x y z i0}
          {g : (x : A) → (y : B x) → (z : C x y) → D x y z i1}
        → ((x : A) (y : B x) (z : C x y) → PathP (D x y z) (f x y z) (g x y z))
        → PathP (λ i → ∀ x y z → D x y z i) f g
funExt₃ p i x y z = p x y z i

-- Function extensionality for ternary functions is an equivalence
module _ {A : Type ℓ} {B : A → Type ℓ₁} {C : (x : A) → B x → Type ℓ₂}
         {D : (x : A) → (y : B x) → C x y → I → Type ℓ₃}
         {f : (x : A) → (y : B x) → (z : C x y) → D x y z i0}
         {g : (x : A) → (y : B x) → (z : C x y) → D x y z i1} where
  private
    appl₃ : PathP (λ i → ∀ x y z → D x y z i) f g → ∀ x y z → PathP (D x y z) (f x y z) (g x y z)
    appl₃ eq x y z i = eq i x y z

  funExt₃Equiv : (∀ x y z → PathP (D x y z) (f x y z) (g x y z)) ≃ (PathP (λ i → ∀ x y z → D x y z i) f g)
  unquoteDef funExt₃Equiv = defStrictEquiv funExt₃Equiv funExt₃ appl₃

  funExt₃Path : (∀ x y z → PathP (D x y z) (f x y z) (g x y z)) ≡ (PathP (λ i → ∀ x y z → D x y z i) f g)
  funExt₃Path = ua funExt₃Equiv

-- n-ary non-dependent funext
nAryFunExt : {X : Type ℓ} {Y : I → Type ℓ₁} (n : ℕ) (fX : nAryOp n X (Y i0)) (fY : nAryOp n X (Y i1))
           → ((xs : Vec X n) → PathP Y (fX $ⁿ xs) (fY $ⁿ map (λ x → x) xs))
           → PathP (λ i → nAryOp n X (Y i)) fX fY
nAryFunExt zero fX fY p        = p []
nAryFunExt (suc n) fX fY p i x = nAryFunExt n (fX x) (fY x) (λ xs → p (x ∷ xs)) i

-- n-ary funext⁻
nAryFunExt⁻ : (n : ℕ) {X : Type ℓ} {Y : I → Type ℓ₁} (fX : nAryOp n X (Y i0)) (fY : nAryOp n X (Y i1))
           → PathP (λ i → nAryOp n X (Y i)) fX fY
           → ((xs : Vec X n) → PathP Y (fX $ⁿ xs) (fY $ⁿ map (λ x → x) xs))
nAryFunExt⁻ zero fX fY p [] = p
nAryFunExt⁻ (suc n) fX fY p (x ∷ xs) = nAryFunExt⁻ n (fX x) (fY x) (λ i → p i x) xs

nAryFunExtEquiv : (n : ℕ) {X : Type ℓ} {Y : I → Type ℓ₁} (fX : nAryOp n X (Y i0)) (fY : nAryOp n X (Y i1))
  → ((xs : Vec X n) → PathP Y (fX $ⁿ xs) (fY $ⁿ map (λ x → x) xs)) ≃ PathP (λ i → nAryOp n X (Y i)) fX fY
nAryFunExtEquiv n {X} {Y} fX fY = isoToEquiv (iso (nAryFunExt n fX fY) (nAryFunExt⁻ n fX fY)
                                              (linv n fX fY) (rinv n fX fY))
  where
  linv : (n : ℕ) (fX : nAryOp n X (Y i0)) (fY : nAryOp n X (Y i1))
    (p : PathP (λ i → nAryOp n X (Y i)) fX fY)
    → nAryFunExt n fX fY (nAryFunExt⁻ n fX fY p) ≡ p
  linv zero fX fY p          = refl
  linv (suc n) fX fY p i j x = linv n (fX x) (fY x) (λ k → p k x) i j

  rinv : (n : ℕ) (fX : nAryOp n X (Y i0)) (fY : nAryOp n X (Y i1))
         (p : (xs : Vec X n) → PathP Y (fX $ⁿ xs) (fY $ⁿ map (λ x → x) xs))
       → nAryFunExt⁻ n fX fY (nAryFunExt n fX fY p) ≡ p
  rinv zero fX fY p i []          = p []
  rinv (suc n) fX fY p i (x ∷ xs) = rinv n (fX x) (fY x) (λ ys i → p (x ∷ ys) i) i xs

-- Funext when the domain also depends on the interval

funExtDep : {A : I → Type ℓ} {B : (i : I) → A i → Type ℓ₁}
  {f : (x : A i0) → B i0 x} {g : (x : A i1) → B i1 x}
  → ({x₀ : A i0} {x₁ : A i1} (p : PathP A x₀ x₁) → PathP (λ i → B i (p i)) (f x₀) (g x₁))
  → PathP (λ i → (x : A i) → B i x) f g
funExtDep {A = A} {B} {f} {g} h i x =
  comp
    (λ k → B i (coei→i A i x k))
    (λ k → λ
      { (i = i0) → f (coei→i A i0 x k)
      ; (i = i1) → g (coei→i A i1 x k)
      })
    (h (λ j → coei→j A i j x) i)

funExtDep⁻ : {A : I → Type ℓ} {B : (i : I) → A i → Type ℓ₁}
  {f : (x : A i0) → B i0 x} {g : (x : A i1) → B i1 x}
  → PathP (λ i → (x : A i) → B i x) f g
  → ({x₀ : A i0} {x₁ : A i1} (p : PathP A x₀ x₁) → PathP (λ i → B i (p i)) (f x₀) (g x₁))
funExtDep⁻ q p i = q i (p i)

funExtDepEquiv : {A : I → Type ℓ} {B : (i : I) → A i → Type ℓ₁}
  {f : (x : A i0) → B i0 x} {g : (x : A i1) → B i1 x}
  → ({x₀ : A i0} {x₁ : A i1} (p : PathP A x₀ x₁) → PathP (λ i → B i (p i)) (f x₀) (g x₁))
  ≃ PathP (λ i → (x : A i) → B i x) f g
funExtDepEquiv {A = A} {B} {f} {g} = isoToEquiv isom
  where
  open Iso
  isom : Iso _ _
  isom .fun = funExtDep
  isom .inv = funExtDep⁻
  isom .rightInv q m i x =
    comp
      (λ k → B i (coei→i A i x (k ∨ m)))
      (λ k → λ
        { (i = i0) → f (coei→i A i0 x (k ∨ m))
        ; (i = i1) → g (coei→i A i1 x (k ∨ m))
        ; (m = i1) → q i x
        })
      (q i (coei→i A i x m))
  isom .leftInv h m p i =
    comp
      (λ k → B i (lemi→i m k))
      (λ k → λ
        { (i = i0) → f (lemi→i m k)
        ; (i = i1) → g (lemi→i m k)
        ; (m = i1) → h p i
        })
      (h (λ j → lemi→j j m) i)
    where
    lemi→j : ∀ j → coei→j A i j (p i) ≡ p j
    lemi→j j =
      coei→j (λ k → coei→j A i k (p i) ≡ p k) i j (coei→i A i (p i))

    lemi→i : PathP (λ m → lemi→j i m ≡ p i) (coei→i A i (p i)) refl
    lemi→i =
      sym (coei→i (λ k → coei→j A i k (p i) ≡ p k) i (coei→i A i (p i)))
      ◁ λ m k → lemi→j i (m ∨ k)

heteroHomotopy≃Homotopy : {A : I → Type ℓ} {B : (i : I) → Type ℓ₁}
  {f : A i0 → B i0} {g : A i1 → B i1}
  → ({x₀ : A i0} {x₁ : A i1} → PathP A x₀ x₁ → PathP B (f x₀) (g x₁))
  ≃ ((x₀ : A i0) → PathP B (f x₀) (g (transport (λ i → A i) x₀)))
heteroHomotopy≃Homotopy {A = A} {B} {f} {g} = isoToEquiv isom
  where
  open Iso
  isom : Iso _ _
  isom .fun h x₀ = h (isContrSinglP A x₀ .fst .snd)
  isom .inv k {x₀} {x₁} p =
    subst (λ fib → PathP B (f x₀) (g (fib .fst))) (isContrSinglP A x₀ .snd (x₁ , p)) (k x₀)
  isom .rightInv k = funExt λ x₀ →
    cong (λ α → subst (λ fib → PathP B (f x₀) (g (fib .fst))) α (k x₀))
      (isProp→isSet isPropSinglP (isContrSinglP A x₀ .fst) _
        (isContrSinglP A x₀ .snd (isContrSinglP A x₀ .fst))
        refl)
    ∙ transportRefl (k x₀)
  isom .leftInv h j {x₀} {x₁} p =
    transp
      (λ i → PathP B (f x₀) (g (isContrSinglP A x₀ .snd (x₁ , p) (i ∨ j) .fst)))
      j
      (h (isContrSinglP A x₀ .snd (x₁ , p) j .snd))


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.ZCohomology.Groups.WedgeOfSpheres where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Data.Sigma.Base

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.GroupStructure
open import Cubical.ZCohomology.Groups.Unit
open import Cubical.ZCohomology.Groups.Sn
open import Cubical.ZCohomology.Groups.Wedge
open import Cubical.ZCohomology.Groups.Connected
open import Cubical.Data.Int renaming (_+_ to _ℤ+_)

open import Cubical.HITs.Sn
open import Cubical.HITs.S1
open import Cubical.HITs.Susp
open import Cubical.HITs.Wedge
open import Cubical.HITs.Pushout
open import Cubical.HITs.Truncation renaming (elim to trElim) hiding (map ; elim2)
open import Cubical.Algebra.Group renaming (ℤ to ℤGroup ; Bool to BoolGroup ; Unit to UnitGroup)
open import Cubical.HITs.SetTruncation renaming (rec to sRec ; rec2 to sRec2 ; elim to sElim)

S¹⋁S¹ : Type₀
S¹⋁S¹ = S₊∙ 1 ⋁ S₊∙ 1

S²⋁S¹⋁S¹ : Type₀
S²⋁S¹⋁S¹ = S₊∙ 2 ⋁ (S¹⋁S¹ , inl base)

------------- H⁰(S¹⋁S¹) ------------
H⁰-S¹⋁S¹ : GroupIso (coHomGr 0 S¹⋁S¹) ℤGroup
H⁰-S¹⋁S¹ = H⁰-connected (inl base) (wedgeConnected _ _ (Sn-connected 0) (Sn-connected 0))

------------- H¹(S¹⋁S¹) ------------
H¹-S¹⋁S¹ : GroupIso (coHomGr 1 S¹⋁S¹) (DirProd ℤGroup ℤGroup)
H¹-S¹⋁S¹ =  (Hⁿ-⋁ _ _ 0) □ GroupIsoDirProd coHom1S1≃ℤ coHom1S1≃ℤ

------------- H⁰(S²⋁S¹⋁S¹) ---------
H⁰-S²⋁S¹⋁S¹ : GroupIso (coHomGr 0 S²⋁S¹⋁S¹) ℤGroup
H⁰-S²⋁S¹⋁S¹ = H⁰-connected (inl north)
                  (wedgeConnected _ _
                    (Sn-connected 1)
                    (wedgeConnected _ _
                      (Sn-connected 0)
                      (Sn-connected 0)))

------------- H¹(S²⋁S¹⋁S¹) ---------
H¹-S²⋁S¹⋁S¹ : GroupIso (coHomGr 1 S²⋁S¹⋁S¹) (DirProd ℤGroup ℤGroup)
H¹-S²⋁S¹⋁S¹ =
    Hⁿ-⋁ (S₊∙ 2) (S¹⋁S¹ , inl base) 0
  □ GroupIsoDirProd (H¹-Sⁿ≅0 0) H¹-S¹⋁S¹
  □ lUnitGroupIso

------------- H²(S²⋁S¹⋁S¹) ---------

H²-S²⋁S¹⋁S¹ : GroupIso (coHomGr 2 S²⋁S¹⋁S¹) ℤGroup
H²-S²⋁S¹⋁S¹ =
  compGroupIso
  (Hⁿ-⋁ _ _ 1)
  (GroupIsoDirProd {B = UnitGroup}
    (Hⁿ-Sⁿ≅ℤ 1)
    ((Hⁿ-⋁ _ _ 1)  □ GroupIsoDirProd (Hⁿ-S¹≅0 0) (Hⁿ-S¹≅0 0) □ rUnitGroupIso)
  □ rUnitGroupIso)

private
  open IsGroupHom
  open Iso

  to₂ : coHom 2 S²⋁S¹⋁S¹ → ℤ
  to₂ = fun (fst H²-S²⋁S¹⋁S¹)
  from₂ : ℤ → coHom 2 S²⋁S¹⋁S¹
  from₂ = inv (fst H²-S²⋁S¹⋁S¹)

  to₁ : coHom 1 S²⋁S¹⋁S¹ → ℤ × ℤ
  to₁ = fun (fst H¹-S²⋁S¹⋁S¹)
  from₁ : ℤ × ℤ → coHom 1 S²⋁S¹⋁S¹
  from₁ = inv (fst H¹-S²⋁S¹⋁S¹)

  to₀ : coHom 0 S²⋁S¹⋁S¹ → ℤ
  to₀ = fun (fst H⁰-S²⋁S¹⋁S¹)
  from₀ : ℤ → coHom 0 S²⋁S¹⋁S¹
  from₀ = inv (fst H⁰-S²⋁S¹⋁S¹)

{-

-- Compute pretty fast
test1 : to₁ (from₁ (1 , 0) +ₕ from₁ (0 , 1)) ≡ (1 , 1)
test1 = refl

-- Computes, but only when computing some smaller numbers first
test2 : to₁ (from₁ (50 , 3) +ₕ from₁ (2 , -2)) ≡ (52 , 1)
test2 = refl

test3 : to₂ (from₂ 0) ≡ 0
test3 = refl

test4 : to₂ (from₂ 3) ≡ 3
test4 = refl

test5 : to₂ (from₂ 1 +ₕ from₂ 1) ≡ 2
test5 = refl
-}

  g : S²⋁S¹⋁S¹ → ∥ Susp S¹ ∥ 4
  g (inl x) = ∣ x ∣
  g (inr x) = 0ₖ _
  g (push a i) = 0ₖ _

  G = ∣ g ∣₂

{- Does not compute:
test₀ : to₂ (G +ₕ G) ≡ 2
test₀ = refl

but this does:
test₀ : to₂ (G +'ₕ G) ≡ 2
test₀ = refl
-}


------------------------------------------------------------------------------
-- Totality properties respect to Tree
------------------------------------------------------------------------------

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

module FOTC.Program.SortList.Properties.Totality.TreeI where

open import FOTC.Base
open import FOTC.Data.Nat.List.Type
open import FOTC.Data.Nat.Type
open import FOTC.Program.SortList.SortList

------------------------------------------------------------------------------
-- See the ATP version.
postulate toTree-Tree : ∀ {item t} → N item → Tree t → Tree (toTree · item · t)

makeTree-Tree : ∀ {is} → ListN is → Tree (makeTree is)
makeTree-Tree lnnil = subst Tree (sym (lit-[] toTree nil)) tnil
makeTree-Tree (lncons {i} {is} Ni LNis) =
  subst Tree
        (sym (lit-∷ toTree i is nil))
        (toTree-Tree Ni (makeTree-Tree LNis))


{-

   The flattening lemma for pushouts (Lemma 8.5.3 in the HoTT book) proved in a cubical style.

   The proof in the HoTT book (the core lying in Lemma 6.12.2, the flattening lemma for coequalizers)
    consists mostly of long strings of equalities about transport. This proof follows almost
    entirely from definitional equalities involving glue/unglue.

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

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

open import Cubical.Data.Sigma

open import Cubical.HITs.Pushout.Base

module FlatteningLemma {ℓa ℓb ℓc} {A : Type ℓa} {B : Type ℓb} {C : Type ℓc} (f : A → B) (g : A → C)
                       {ℓ} (F : B → Type ℓ) (G : C → Type ℓ) (e : ∀ a → F (f a) ≃ G (g a)) where

  E : Pushout f g → Type ℓ
  E (inl x) = F x
  E (inr x) = G x
  E (push a i) = ua (e a) i

  Σf : Σ[ a ∈ A ] F (f a) → Σ[ b ∈ B ] F b
  Σf (a , x) = (f a , x)

  Σg : Σ[ a ∈ A ] F (f a) → Σ[ c ∈ C ] G c
  Σg (a , x) = (g a , (e a) .fst x)

  module FlattenIso where

    fwd : Pushout Σf Σg → Σ (Pushout f g) E
    fwd (inl (b , x)) = (inl b , x)
    fwd (inr (c , x)) = (inr c , x)
    fwd (push (a , x) i) = (push a i , ua-gluePt (e a) i x)

    bwd : Σ (Pushout f g) E → Pushout Σf Σg
    bwd (inl b , x) = inl (b , x)
    bwd (inr c , x) = inr (c , x)
    bwd (push a i , x) = hcomp (λ j → λ { (i = i0) → push (a , x) (~ j)
                                        ; (i = i1) → inr (g a , x) })
                               (inr (g a , ua-unglue (e a) i x))

    bwd-fwd : ∀ x → bwd (fwd x) ≡ x
    bwd-fwd (inl (b , x)) = refl
    bwd-fwd (inr (c , x)) = refl
    bwd-fwd (push (a , x) i) j =
      hcomp (λ k → λ { (i = i0) → push (a , ua-gluePt (e a) i0 x) (~ k)
                     ; (i = i1) → inr (g a , ua-gluePt (e a) i1 x)
                     ; (j = i1) → push (a , x) (i ∨ ~ k) })
            (inr (g a , ua-unglue (e a) i (ua-gluePt (e a) i x)))
      -- Note: the (j = i1) case typechecks because of the definitional equalities:
      --  ua-gluePt e i0 x ≡ x , ua-gluePt e i1 x ≡ e .fst x,
      --  ua-unglue-glue : ua-unglue e i (ua-gluePt e i x) ≡ e .fst x

    -- essentially: ua-glue e (i ∨ ~ k) ∘ ua-unglue e i
    sq : ∀ {ℓ} {A B : Type ℓ} (e : A ≃ B)
         → SquareP (λ i k → ua e i → ua e (i ∨ ~ k))
      {- i = i0 -} (λ k x → ua-gluePt e (~ k) x)
      {- i = i1 -} (λ k x → x)
      {- k = i0 -} (λ i x → ua-unglue e i x)
      {- k = i1 -} (λ i x → x)
    sq e i k x = ua-glue e (i ∨ ~ k) (λ { ((i ∨ ~ k) = i0) → x })
                                     (inS (ua-unglue e i x))
      -- Note: this typechecks because of the definitional equalities:
      --  ua-unglue e i0 x ≡ e .fst x, ua-glue e i1 _ (inS y) ≡ y, ua-unglue e i1 x ≡ x,
      --  ua-glue-unglue : ua-glue e i (λ { (i = i0) → x }) (inS (ua-unglue e i x)) ≡ x

    fwd-bwd : ∀ x → fwd (bwd x) ≡ x
    fwd-bwd (inl b , x) = refl
    fwd-bwd (inr c , x) = refl
    fwd-bwd (push a i , x) j =
      -- `fwd` (or any function) takes hcomps to comps on a constant family, so we must use a comp here
      comp (λ _ → Σ (Pushout f g) E)
           (λ k → λ { (i = i0) → push a (~ k) , ua-gluePt (e a) (~ k) x
                    ; (i = i1) → inr (g a) , x
                    ; (j = i1) → push a (i ∨ ~ k) , sq (e a) i k x })
            (inr (g a) , ua-unglue (e a) i x)

    isom : Iso (Σ (Pushout f g) E) (Pushout Σf Σg)
    isom = iso bwd fwd bwd-fwd fwd-bwd

  flatten : Σ (Pushout f g) E ≃ Pushout Σf Σg
  flatten = isoToEquiv FlattenIso.isom


------------------------------------------------------------------------
-- Comparisons of different kinds of lenses, focusing on the
-- definition of composable record setters and getters
------------------------------------------------------------------------

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

-- This module uses both dependent and non-dependent lenses, in order
-- to illustrate a problem with the non-dependent ones. It also uses
-- two kinds of dependent lenses, in order to illustrate a minor
-- problem with one of them.

module README.Record-getters-and-setters where

open import Equality.Propositional.Cubical
open import Prelude hiding (_∘_)

open import Bijection equality-with-J as Bij using (_↔_; module _↔_)
open import Equality.Decision-procedures equality-with-J
import Equivalence equality-with-J as Eq
open import Function-universe equality-with-J as F hiding (_∘_)

import Lens.Dependent
import Lens.Non-dependent.Higher equality-with-paths as Higher

------------------------------------------------------------------------
-- Dependent lenses with "remainder types" visible in the type

module Dependent₃ where

  open Lens.Dependent

  -- Nested records.

  record R₁ (A : Set) : Set where
    field
      f     : A → A
      x     : A
      lemma : ∀ y → f y ≡ y

  record R₂ : Set₁ where
    field
      A  : Set
      r₁ : R₁ A

  -- Lenses for each of the three fields of R₁.

  -- The x field is easiest, because it is independent of the others.
  --
  -- (Note that the from function is inferred automatically.)

  x : {A : Set} →
      Lens₃ (R₁ A) (∃ λ (f : A → A) → ∀ y → f y ≡ y) (λ _ → A)
  x = Eq.↔⇒≃ (record
    { surjection = record
      { logical-equivalence = record
        { to   = λ r → (R₁.f r , R₁.lemma r) , R₁.x r
        ; from = _
        }
      ; right-inverse-of = λ _ → refl
      }
    ; left-inverse-of = λ _ → refl
    })

  -- The lemma field depends on the f field, so whenever the f field
  -- is set the lemma field needs to be updated as well.

  f : {A : Set} →
      Lens₃ (R₁ A) A (λ _ → ∃ λ (f : A → A) → ∀ y → f y ≡ y)
  f = Eq.↔⇒≃ (record
    { surjection = record
      { logical-equivalence = record
        { to   = λ r → R₁.x r , (R₁.f r , R₁.lemma r)
        ; from = _
        }
      ; right-inverse-of = λ _ → refl
      }
    ; left-inverse-of = λ _ → refl
    })

  -- The lemma field can be updated independently.

  lemma : {A : Set} →
          Lens₃ (R₁ A) (A × (A → A)) (λ r → ∀ y → proj₂ r y ≡ y)
  lemma = Eq.↔⇒≃ (record
    { surjection = record
      { logical-equivalence = record
        { to   = λ r → (R₁.x r , R₁.f r) , R₁.lemma r
        ; from = _
        }
      ; right-inverse-of = λ _ → refl
      }
    ; left-inverse-of = λ _ → refl
    })

  -- Note that the type of the last lens may not be quite
  -- satisfactory: the type of the lens does not guarantee that the
  -- lemma applies to the input's f field. The following lemma may
  -- provide some form of consolation:

  consolation : {A : Set} (r : R₁ A) → ∀ y → R₁.f r y ≡ y
  consolation = Lens₃.get lemma

  -- Let us now construct lenses for the same fields, but accessed
  -- through an R₂ record.

  -- First we define lenses for the fields of R₂ (note that the A lens
  -- does not seem to be very useful):

  A : Lens₃ R₂ ⊤ (λ _ → R₂)
  A = id₃

  r₁ : Lens₃ R₂ Set R₁
  r₁ = Eq.↔⇒≃ (record
    { surjection = record
      { logical-equivalence = record
        { to   = λ r → R₂.A r , R₂.r₁ r
        ; from = _
        }
      ; right-inverse-of = λ _ → refl
      }
    ; left-inverse-of = λ _ → refl
    })

  -- The lenses for the three R₁ fields can now be defined by
  -- composition:

  x₂ : Lens₃ R₂ _ (λ r → proj₁ r)
  x₂ = x ₃∘₃ r₁

  f₂ : Lens₃ R₂ _ (λ r → ∃ λ (f : proj₁ r → proj₁ r) → ∀ y → f y ≡ y)
  f₂ = f ₃∘₃ r₁

  lemma₂ : Lens₃ R₂ _ (λ r → ∀ y → proj₂ (proj₂ r) y ≡ y)
  lemma₂ = lemma ₃∘₃ r₁

  consolation₂ : (r : R₂) → ∀ y → proj₁ (Lens₃.get f₂ r) y ≡ y
  consolation₂ = Lens₃.get lemma₂

------------------------------------------------------------------------
-- Dependent lenses without "remainder types" visible in the type

module Dependent where

  open Lens.Dependent
  open Dependent₃ using (R₁; module R₁; R₂; module R₂)

  -- Lenses for each of the three fields of R₁.

  x : {A : Set} → Lens (R₁ A) (λ _ → A)
  x = Lens₃-to-Lens Dependent₃.x

  f : {A : Set} → Lens (R₁ A) (λ _ → ∃ λ (f : A → A) → ∀ y → f y ≡ y)
  f = Lens₃-to-Lens Dependent₃.f

  lemma : {A : Set} → Lens (R₁ A) (λ r → ∀ y → R₁.f r y ≡ y)
  lemma = Lens₃-to-Lens Dependent₃.lemma

  -- Note that the type of lemma is now more satisfactory: the type of
  -- the lens /does/ guarantee that the lemma applies to the input's f
  -- field.

  -- A lens for the r₁ field of R₂.

  r₁ : Lens R₂ (λ r → R₁ (R₂.A r))
  r₁ = Lens₃-to-Lens {-a = # 0-} Dependent₃.r₁

  -- Lenses for the fields of R₁, accessed through an R₂ record. Note
  -- the use of /forward/ composition.

  x₂ : Lens R₂ (λ r → R₂.A r)
  x₂ = r₁ ⨾ x

  f₂ : Lens R₂ (λ r → ∃ λ (f : R₂.A r → R₂.A r) → ∀ y → f y ≡ y)
  f₂ = r₁ ⨾ f

  lemma₂ : Lens R₂ (λ r → ∀ y → R₁.f (R₂.r₁ r) y ≡ y)
  lemma₂ = r₁ ⨾ lemma

------------------------------------------------------------------------
-- Non-dependent lenses

module Non-dependent where

  open Higher
  open Lens-combinators

  -- Labels.

  data Label : Set where
    ″f″ ″x″ ″lemma″ ″A″ ″r₁″ : Label

  -- Labels come with decidable equality.

  Label↔Fin : Label ↔ Fin 5
  Label↔Fin = record
    { surjection = record
      { logical-equivalence = record
        { to   = to
        ; from = from
        }
      ; right-inverse-of = to∘from
      }
    ; left-inverse-of = from∘to
    }
    where

    to : Label → Fin 5
    to ″f″     = fzero
    to ″x″     = fsuc fzero
    to ″lemma″ = fsuc (fsuc fzero)
    to ″A″     = fsuc (fsuc (fsuc fzero))
    to ″r₁″    = fsuc (fsuc (fsuc (fsuc fzero)))

    from : Fin 5 → Label
    from fzero                                 = ″f″
    from (fsuc fzero)                          = ″x″
    from (fsuc (fsuc fzero))                   = ″lemma″
    from (fsuc (fsuc (fsuc fzero)))            = ″A″
    from (fsuc (fsuc (fsuc (fsuc fzero))))     = ″r₁″
    from (fsuc (fsuc (fsuc (fsuc (fsuc ())))))

    to∘from : ∀ i → to (from i) ≡ i
    to∘from fzero                                 = refl
    to∘from (fsuc fzero)                          = refl
    to∘from (fsuc (fsuc fzero))                   = refl
    to∘from (fsuc (fsuc (fsuc fzero)))            = refl
    to∘from (fsuc (fsuc (fsuc (fsuc fzero))))     = refl
    to∘from (fsuc (fsuc (fsuc (fsuc (fsuc ())))))

    from∘to : ∀ ℓ → from (to ℓ) ≡ ℓ
    from∘to ″f″     = refl
    from∘to ″x″     = refl
    from∘to ″lemma″ = refl
    from∘to ″A″     = refl
    from∘to ″r₁″    = refl

  _≟_ : Decidable-equality Label
  _≟_ = Bij.decidable-equality-respects (inverse Label↔Fin) Fin._≟_

  -- Records.

  open import Records-with-with equality-with-J Label _≟_

  -- Nested records (defined using the record language from Record, so
  -- that we can use manifest fields).

  R₁ : Set → Signature _
  R₁ A = ∅ , ″f″     ∶ (λ _ → A → A)
           , ″x″     ∶ (λ _ → A)
           , ″lemma″ ∶ (λ r → ∀ y → (r · ″f″) y ≡ y)

  R₂ : Signature _
  R₂ = ∅ , ″A″  ∶ (λ _ → Set)
         , ″r₁″ ∶ (λ r → ↑ _ (Record (R₁ (r · ″A″))))

  -- Lenses for each of the three fields of R₁.

  -- The x field is easiest, because it is independent of the others.

  x : {A : Set} → Lens (Record (R₁ A)) A
  x {A} = isomorphism-to-lens

    (Record (R₁ A)                                    ↝⟨ Record↔Recʳ ⟩
     (∃ λ (f : A → A) → ∃ λ (x : A) → ∀ y → f y ≡ y)  ↝⟨ ∃-comm ⟩
     (A × ∃ λ (f : A → A) → ∀ y → f y ≡ y)            ↝⟨ ×-comm ⟩□
     (∃ λ (f : A → A) → ∀ y → f y ≡ y) × A            □)

  -- The lemma field depends on the f field, so whenever the f field
  -- is set the lemma field needs to be updated as well.

  f : {A : Set} →
      Lens (Record (R₁ A))
           (Record (∅ , ″f″     ∶ (λ _ → A → A)
                      , ″lemma″ ∶ (λ r → ∀ x → (r · ″f″) x ≡ x)))
  f {A} = isomorphism-to-lens

    (Record (R₁ A)                                    ↝⟨ Record↔Recʳ ⟩
     (∃ λ (f : A → A) → ∃ λ (x : A) → ∀ y → f y ≡ y)  ↝⟨ ∃-comm ⟩
     A × (∃ λ (f : A → A) → ∀ y → f y ≡ y)            ↝⟨ F.id ×-cong inverse Record↔Recʳ ⟩□
     A × Record _                                     □)

  -- The lemma field can be updated independently. Note the use of a
  -- manifest field in the type of the lens to capture the dependency
  -- between the two lens parameters.

  lemma : {A : Set} {f : A → A} →
          Lens (Record (R₁ A With ″f″ ≔ (λ _ → f)))
               (∀ x → f x ≡ x)
  lemma {A} {f} = isomorphism-to-lens

    (Record (R₁ A With ″f″ ≔ (λ _ → f))  ↝⟨ Record↔Recʳ ⟩□
     A × (∀ x → f x ≡ x)                 □)

  -- The use of a manifest field is problematic, because the domain of
  -- the lens is no longer Record (R₁ A). It is easy to convert
  -- records into the required form, but this conversion is not a
  -- non-dependent lens (due to the dependency).

  convert : {A : Set} (r : Record (R₁ A)) →
            Record (R₁ A With ″f″ ≔ (λ _ → r · ″f″))
  convert (rec (rec (rec (_ , f) , x) , lemma)) =
    rec (rec (_ , x) , lemma)

  -- Let us now try to construct lenses for the same fields, but
  -- accessed through an R₂ record.

  -- First we define a lens for the r₁ field.

  r₁ : {A : Set} →
       Lens (Record (R₂ With ″A″ ≔ λ _ → A)) (Record (R₁ A))
  r₁ {A} = isomorphism-to-lens

    (Record (R₂ With ″A″ ≔ λ _ → A)  ↝⟨ Record↔Recʳ ⟩
     ↑ _ (Record (R₁ A))             ↝⟨ Bij.↑↔ ⟩
     Record (R₁ A)                   ↝⟨ inverse ×-left-identity ⟩
     ⊤ × Record (R₁ A)               ↝⟨ inverse Bij.↑↔ ×-cong F.id ⟩□
     ↑ _ ⊤ × Record (R₁ A)           □)

  -- It is now easy to construct lenses for the embedded x and f
  -- fields using composition of lenses.

  x₂ : {A : Set} →
       Lens (Record (R₂ With ″A″ ≔ λ _ → A)) A
  x₂ = ⟨ _ , _ ⟩ x ∘ r₁

  f₂ : {A : Set} →
       Lens (Record (R₂ With ″A″ ≔ λ _ → A))
            (Record (∅ , ″f″     ∶ (λ _ → A → A)
                       , ″lemma″ ∶ (λ r → ∀ x → (r · ″f″) x ≡ x)))
  f₂ = ⟨ _ , _ ⟩ f ∘ r₁

  -- It is less obvious how to construct the corresponding lens for
  -- the embedded lemma field.

  module Lemma-lens
    (r₁₂ : {A : Set} {r : Record (R₁ A)} →
           Lens (Record (R₂ With ″A″  ≔ (λ _ → A)
                            With ″r₁″ ≔ (λ _ → lift r)))
                (Record (R₁ A With ″f″ ≔ (λ _ → r · ″f″)))) where

    -- To start with, what should the type of the lemma lens be? The
    -- type used below is an obvious choice.

    lemma₂ : {A : Set} {r : Record (R₁ A)} →
             Lens (Record (R₂ With ″A″  ≔ (λ _ → A)
                              With ″r₁″ ≔ (λ _ → lift r)))
                  (∀ x → (r · ″f″) x ≡ x)

    -- If we can construct a suitable lens r₁₂, with the type
    -- signature given above, then we can define the lemma lens using
    -- composition.

    lemma₂ = ⟨ _ , _ ⟩ lemma ∘ r₁₂

    -- However, we cannot define r₁₂.

    not-r₁₂ : ⊥
    not-r₁₂ = no-isomorphism isomorphism
      where
      open Lens

      isomorphisms : ∀ _ _ → _
      isomorphisms = λ A r →
        ⊤                                                 ↝⟨ inverse Bij.↑↔ ⟩
        ↑ _ ⊤                                             ↝⟨ inverse Record↔Recʳ ⟩
        Record (R₂ With ″A″  ≔ (λ _ → A)
                   With ″r₁″ ≔ (λ _ → lift r))            ↔⟨ equiv r₁₂ ⟩
        R r₁₂ × Record (R₁ A With ″f″ ≔ (λ _ → r · ″f″))  ↝⟨ F.id ×-cong Record↔Recʳ ⟩□
        R r₁₂ × A × (∀ y → (r · ″f″) y ≡ y)               □

      isomorphism : ∃ λ (A : Set₁) → ⊤ ↔ A × Bool
      isomorphism =
        _ ,
        (⊤                               ↝⟨ isomorphisms Bool r ⟩
         R r₁₂ × Bool × (∀ b → b ≡ b)    ↝⟨ F.id ×-cong ×-comm ⟩
         R r₁₂ × (∀ b → b ≡ b) × Bool    ↝⟨ ×-assoc ⟩□
         (R r₁₂ × (∀ b → b ≡ b)) × Bool  □)
        where
        r : Record (R₁ Bool)
        r = rec (rec (rec (_ , F.id) , true) , λ _ → refl)

      no-isomorphism : ¬ ∃ λ (A : Set₁) → ⊤ ↔ A × Bool
      no-isomorphism (A , iso) = Bool.true≢false (
        true                           ≡⟨⟩
        proj₂ (a , true)               ≡⟨ cong proj₂ $ sym $ right-inverse-of (a , true) ⟩
        proj₂ (to (from (a , true)))   ≡⟨⟩
        proj₂ (to (from (a , false)))  ≡⟨ cong proj₂ $ right-inverse-of (a , false) ⟩
        proj₂ (a , false)              ≡⟨ refl ⟩∎
        false                          ∎)
        where
        open _↔_ iso

        a : A
        a = proj₁ (to _)

  -- Conclusion: The use of manifest fields limits the usefulness of
  -- these lenses, because they do not compose as well as they do for
  -- non-dependent records. Dependent lenses seem to be more useful.


------------------------------------------------------------------------------
-- Inequalities on partial natural numbers
------------------------------------------------------------------------------

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

module LTC-PCF.Data.Nat.Inequalities where

open import LTC-PCF.Base

infix 4 _<_ _≮_ _>_ _≯_ _≤_ _≰_ _≥_ _≱_

------------------------------------------------------------------------------
-- The function terms.

lth : D → D
lth lt = lam (λ m → lam (λ n →
           if (iszero₁ n)
             then false
             else (if (iszero₁ m) then true else (lt · pred₁ m · pred₁ n))))
lt : D → D → D
lt m n = fix lth · m · n

le : D → D → D
le m n = lt m (succ₁ n)

gt : D → D → D
gt m n = lt n m

ge : D → D → D
ge m n = le n m

------------------------------------------------------------------------
-- The relations.

_<_ : D → D → Set
m < n = lt m n ≡ true

_≮_ : D → D → Set
m ≮ n = lt m n ≡ false

_>_ : D → D → Set
m > n = gt m n ≡ true

_≯_ : D → D → Set
m ≯ n = gt m n ≡ false

_≤_  : D → D → Set
m ≤ n = le m n ≡ true

_≰_  : D → D → Set
m ≰ n = le m n ≡ false

_≥_ : D → D → Set
m ≥ n = ge m n ≡ true

_≱_ : D → D → Set
m ≱ n = ge m n ≡ false

------------------------------------------------------------------------------
-- The lexicographical order.
Lexi : D → D → D → D → Set
Lexi m n m' n' = m < m' ∨ m ≡ m' ∧ n < n'


-----------------------------------------------------------------------------
-- Existential elimination
-----------------------------------------------------------------------------

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

module FOT.Common.FOL.Existential.Elimination where

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

postulate D : Set

module ∃₁ where
  -- Type theoretical version

  -- We add 3 to the fixities of the Agda standard library 0.8.1 (see
  -- Data/Product.agda).
  infixr 7 _,_

  -- The existential quantifier type on D.
  data ∃ (A : D → Set) : Set where
    _,_ : (x : D) → A x → ∃ A

  -- Sugar syntax for the existential quantifier.
  syntax ∃ (λ x → e) = ∃[ x ] e

  -- The existential proyections.
  ∃-proj₁ : ∀ {A} → ∃ A → D
  ∃-proj₁ (x , _) = x

  ∃-proj₂ : ∀ {A} → (h : ∃ A) → A (∃-proj₁ h)
  ∃-proj₂ (_ , Ax) = Ax

  -- Some examples

  -- The order of quantifiers of the same sort is irrelevant.
  ∃-ord : {A² : D → D → Set} → (∃[ x ] ∃[ y ] A² x y) → (∃[ y ] ∃[ x ] A² x y)
  ∃-ord (x , y , h) = y , x , h

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

module ∃₂ where
  -- First-order logic version

  -- We add 3 to the fixities of the Agda standard library 0.8.1 (see
  -- Data/Product.agda).
  infixr 7 _,_

  -- The existential quantifier type on D.
  data ∃ (A : D → Set) : Set where
    _,_ : (x : D) → A x → ∃ A

  -- Sugar syntax for the existential quantifier.
  syntax ∃ (λ x → e) = ∃[ x ] e

  -- Existential elimination
  --     ∃x.A(x)   A(x) → B
  --  ------------------------
  --             B

  -- NB. We do not use the usual type theory elimination with two
  -- projections because we are working in first-order logic where we
  -- do need extract a witness from an existence proof.
  ∃-elim : {A : D → Set}{B : Set} → ∃ A → ((x : D) → A x → B) → B
  ∃-elim (x , Ax) h = h x Ax

  -- Some examples

  -- The order of quantifiers of the same sort is irrelevant.
  ∃-ord : {A² : D → D → Set} → (∃[ x ] ∃[ y ] A² x y) → (∃[ y ] ∃[ x ] A² x y)
  ∃-ord h = ∃-elim h (λ x h₁ → ∃-elim h₁ (λ y prf → y , x , prf))

  -- A proof non-FOL valid
  non-FOL : {A : D → Set} → ∃ A → D
  non-FOL h = ∃-elim h (λ x _ → x)

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

module ∃₃ where
  -- First-order logic version

  -- A different version from the existential introduction
  --      A(x)
  --  ------------
  --     ∃x.A(x)

  -- The existential quantifier type on D.
  data ∃ (A : D → Set) : Set where
    ∃-intro : ((x : D) → A x) → ∃ A

  -- Sugar syntax for the existential quantifier.
  syntax ∃ (λ x → e) = ∃[ x ] e

  postulate d : D

  -- Existential elimination.
  -- NB. It is neccesary that D ≢ ∅.
  ∃-elim : {A : D → Set}{B : Set} → ∃ A → ((x : D) → A x → B) → B
  ∃-elim (∃-intro h₁) h₂ = h₂ d (h₁ d)

  -- Some examples

  -- Impossible
  -- thm : {A : D → Set} → ∃[ x ] A x → ∃[ y ] A y
  -- thm h = ∃-elim h (λ x prf → {!!})


module Lec6 where

open import CS410-Prelude
open import CS410-Functor
open import CS410-Monoid
open import CS410-Nat

data Maybe (X : Set) : Set where
  yes  : X -> Maybe X
  no   : Maybe X

maybeFunctor : Functor Maybe
maybeFunctor = record
 { map      = \ { f (yes x) -> yes (f x)
                ; f no      -> no
                }
 ; mapid    = \ { (yes x) -> refl ; no -> refl }
 ; mapcomp  = \ { f g (yes x) -> refl ; f g no -> refl } }

open Functor maybeFunctor

data List (X : Set) : Set where  -- X scopes over the whole declaration...
  []    : List X                 -- ...so you can use it here...
  _::_  : X -> List X -> List X  -- ...and here.
infixr 3 _::_

may-take : {X : Set} -> Nat -> List X -> Maybe (List X)
may-take zero xs = yes []
may-take (suc n) [] = no
may-take (suc n) (x :: xs) = map (_::_ x) (may-take n xs)

data Hutton : Set where
  val : Nat -> Hutton
  _+H_ : Hutton -> Hutton -> Hutton
  fail : Hutton

maybeApplicative : Applicative Maybe
maybeApplicative = record
                     { pure = yes
                     ; _<*>_ = \ { no mx -> no
                                 ; (yes f) no -> no
                                 ; (yes f) (yes x) -> yes (f x)
                                 }
                     ; identity = \ {(yes x) -> refl ; no -> refl}
                     ; composition = \
                        { (yes f) (yes g) (yes x) -> refl
                        ; (yes f) (yes g) no -> refl
                        ; (yes x) no mx -> refl
                        ; no mg mx -> refl
                        }
                     ; homomorphism = \ f x -> refl
                     ; interchange = \ { (yes f) y -> refl ; no y → refl }
                     }

module Eval where
  open Applicative maybeApplicative public

  eval : Hutton -> Maybe Nat
  eval (val x) = yes x
  eval (h +H h') = pure _+N_ <*> eval h <*> eval h'
  eval fail = no

listTrav : forall {F} -> Applicative F -> forall {A B} ->
           (A -> F B) -> List A -> F (List B)
listTrav {F} appF = trav where
  open Applicative appF
  trav : forall {A B} -> (A -> F B) -> List A -> F (List B)
  trav f []         = pure []
  trav f (a :: as)  = pure _::_ <*> f a <*> trav f as

listTraversable : Traversable List
listTraversable = record { traverse = listTrav }

I : Set -> Set
I X = X

iApplicative : Applicative I
iApplicative = record
  { pure = id
  ; _<*>_ = id
  ; identity = \ v -> refl
  ; composition = \ f g v -> refl
  ; homomorphism = \ f x -> refl
  ; interchange = \ u y -> refl
  }

lmap : forall {A B} -> (A -> B) -> List A -> List B
lmap = traverse iApplicative where
  open Traversable listTraversable

MonCon : forall {X} -> Monoid X -> Applicative \_ -> X
MonCon M = record
             { pure          = {!!}
             ; _<*>_         = op
             ; identity      = {!!}
             ; composition   = {!!}
             ; homomorphism  = {!!}
             ; interchange   = {!!}
             } where open Monoid M

lCombine : forall {A X} -> Monoid X -> (A -> X) -> List A -> X
lCombine M = traverse (MonCon M) {B = One} where
  open Traversable listTraversable

CurryApplicative : forall {E} -> Applicative \X -> E -> X
CurryApplicative = record
                     { pure = \ x e -> x  -- K
                     ; _<*>_ = \ ef ex e -> ef e (ex e)  -- S
                     ; identity = λ {X} v → refl
                     ; composition = λ {X} {Y} {Z} u v w → refl
                     ; homomorphism = λ {X} {Y} f x → refl
                     ; interchange = λ {X} {Y} u y → refl
                     }


module Haskell.Prim.Bool where

open import Agda.Primitive
open import Agda.Builtin.Bool public

private
  variable
    ℓ : Level

--------------------------------------------------
-- Booleans

infixr 3 _&&_
_&&_ : Bool → Bool → Bool
false && _ = false
true  && x = x

infixr 2 _||_
_||_ : Bool → Bool → Bool
false || x = x
true  || _ = true

not : Bool → Bool
not false = true
not true  = false

otherwise : Bool
otherwise = true


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

module Dodo.Binary.Dec where

-- Stdlib imports
open import Level using (Level; _⊔_)
open import Relation.Nullary using (Dec)
open import Relation.Binary using (REL)

DecRel : {a b ℓ : Level} {A : Set a} {B : Set b}
  → REL A B ℓ → Set (a ⊔ b ⊔ ℓ)
DecRel R = ∀ x y → Dec (R x y)


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

open import Agda.Primitive renaming (_⊔_ to ℓ-max; lsuc to ℓ-suc; lzero to ℓ-zero)

module Number.Bundles where

private
  variable
    ℓ ℓ' : Level

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Relation.Binary.Base -- Rel
open import Cubical.Data.Sum.Base renaming (_⊎_ to infixr 4 _⊎_)
open import Cubical.Data.Sigma.Base renaming (_×_ to infixr 4 _×_)

open import MoreAlgebra
open import Number.Structures

-- ℕ ℤ ℚ ℝ ℂ and ℚ₀⁺ ℝ₀⁺ ...
-- ring without additive inverse
record RCommSemiring : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    Carrier     : Type ℓ
    _#_ : Rel Carrier Carrier ℓ'
    -- RCommSemiring
    0f 1f       : Carrier
    _+_ _·_     : Carrier → Carrier → Carrier
    isRCommSemiring : IsRCommSemiring _#_ 0f 1f _+_ _·_

  open IsRCommSemiring isRCommSemiring public

-- ℤ ℚ ℝ ℂ
record RCommRing : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    Carrier     : Type ℓ
    _#_ : Rel Carrier Carrier ℓ'
    -- RCommSemiring
    0f 1f       : Carrier
    _+_ _·_     : Carrier → Carrier → Carrier
    -- RCommRing
    -_          : Carrier → Carrier
    isRCommRing : IsRCommRing _#_ 0f 1f _+_ _·_ -_

  open IsRCommRing isRCommRing public

-- ℚ ℝ ℂ
record RField : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    Carrier     : Type ℓ
    _#_ : Rel Carrier Carrier ℓ'
    -- RCommSemiring
    0f 1f       : Carrier
    _+_ _·_     : Carrier → Carrier → Carrier
    -- RCommRing
    -_          : Carrier → Carrier
    -- RField
    _⁻¹         : (x : Carrier) → {{ x # 0f }} → Carrier
    isRField : IsRField _#_ 0f 1f _+_ _·_ -_ _⁻¹

-- Finₖ ℕ ℤ ℚ ℚ₀⁺ ℚ⁺ ℝ ℝ₀⁺ ℝ⁺
record RLattice : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  constructor rlattice
  field
    Carrier     : Type ℓ
    _<_ _≤_ _#_ : Rel Carrier Carrier ℓ'
    min max     : Carrier → Carrier → Carrier
    isRLattice  : IsRLattice _<_ _≤_ _#_ min max

  open IsRLattice isRLattice public

  infixl 4 _<_
  infixl 4 _≤_
  infixl 4 _#_

-- ℕ ℤ ℚ ℚ₀⁺ ℚ⁺ ℝ ℝ₀⁺ ℝ⁺
-- ring without additive inverse
record ROrderedCommSemiring : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    -- RLattice
    Carrier     : Type ℓ
    _<_ _≤_ _#_ : Rel Carrier Carrier ℓ'
    min max     : Carrier → Carrier → Carrier
    -- ROrderedCommSemiring
    0f 1f       : Carrier
    _+_ _·_     : Carrier → Carrier → Carrier
    -- _-_         : (x y : Carrier) → (y ≤ x) → Carrier -- is that a good idea?
    isROrderedCommSemiring : IsROrderedCommSemiring _<_ _≤_ _#_ min max 0f 1f _+_ _·_

  open IsROrderedCommSemiring isROrderedCommSemiring public

-- ℤ ℚ ℝ
record ROrderedCommRing : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    -- RLattice
    Carrier     : Type ℓ
    _<_ _≤_ _#_ : Rel Carrier Carrier ℓ'
    min max     : Carrier → Carrier → Carrier
    -- ROrderedCommSemiring
    0f 1f       : Carrier
    _+_ _·_     : Carrier → Carrier → Carrier
    -- ROrderedCommRing
    -_          : Carrier → Carrier
    isROrderedCommRing : IsROrderedCommRing _<_ _≤_ _#_ min max 0f 1f _+_ _·_ -_

  open IsROrderedCommRing isROrderedCommRing public

  abs : Carrier → Carrier
  abs x = max x (- x)

  field
    isAbsOrderedCommRing : IsAbsOrderedCommRing _<_ _≤_ _#_ min max 0f 1f _+_ _·_ -_ abs

  open IsAbsOrderedCommRing isAbsOrderedCommRing public

-- ℚ ℝ
record ROrderedField : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    -- RLattice
    Carrier     : Type ℓ
    _<_ _≤_ _#_ : Rel Carrier Carrier ℓ'
    min max     : Carrier → Carrier → Carrier
    -- ROrderedCommSemiring
    0f 1f       : Carrier
    _+_ _·_     : Carrier → Carrier → Carrier
    -- ROrderedCommRing
    -_          : Carrier → Carrier
    -- ROrderedField
    _⁻¹         : (x : Carrier) → {{ x # 0f }} → Carrier
    isROrderedField : IsROrderedField _<_ _≤_ _#_ min max 0f 1f _+_ _·_ -_ _⁻¹

  open IsROrderedField isROrderedField public

  abs : Carrier → Carrier
  abs x = max x (- x)

  field
    isAbsOrderedCommRing : IsAbsOrderedCommRing _<_ _≤_ _#_ min max 0f 1f _+_ _·_ -_ abs

  open IsAbsOrderedCommRing isAbsOrderedCommRing public

{-

-- ℚ₀⁺ ℝ₀⁺
record ROrderedSemifield : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    -- RLattice
    Carrier     : Type ℓ
    _<_ _≤_ _#_ : Rel Carrier Carrier ℓ'
    min max     : Carrier → Carrier → Carrier
    -- ROrderedCommSemiring
    0f 1f       : Carrier
    _+_ _·_     : Carrier → Carrier → Carrier
    -- ROrderedSemifield
    _-_         : (x y : Carrier) → (y ≤ x) → Carrier -- is that a good idea?
    _⁻¹         : (x : Carrier) → {{ 0f < x }} → Carrier

-- ℚ⁺ ℝ⁺
record ROrderedSemifieldWithoutZero : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    -- RLattice
    Carrier     : Type ℓ
    _<_ _≤_ _#_ : Rel Carrier Carrier ℓ'
    min max     : Carrier → Carrier → Carrier
    -- ROrderedSemifieldWithoutZero
    1f          : Carrier
    _+_ _·_     : Carrier → Carrier → Carrier
    _-_         : (x y : Carrier) → (y < x) → Carrier -- is that a good idea?
    _⁻¹         : Carrier → Carrier

-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties, related to products, that rely on the K rule
------------------------------------------------------------------------

{-# OPTIONS --with-K --safe #-}

module Data.Product.Properties.WithK where

open import Data.Bool.Base
open import Data.Product
open import Data.Product.Properties using (,-injectiveˡ)
open import Function
open import Relation.Binary using (Decidable)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary.Reflects
open import Relation.Nullary using (Dec; _because_; yes; no)
open import Relation.Nullary.Decidable using (map′)

------------------------------------------------------------------------
-- Equality

module _ {a b} {A : Set a} {B : Set b} where

  ,-injective : ∀ {a c : A} {b d : B} → (a , b) ≡ (c , d) → a ≡ c × b ≡ d
  ,-injective refl = refl , refl

module _ {a b} {A : Set a} {B : A → Set b} where

  ,-injectiveʳ : ∀ {a} {b c : B a} → (Σ A B ∋ (a , b)) ≡ (a , c) → b ≡ c
  ,-injectiveʳ refl = refl

  -- Note: this is not an instance of `_×-dec_`, because we need `x` and `y`
  -- to have the same type before we can test them for equality.
  ≡-dec : Decidable _≡_ → (∀ {a} → Decidable {A = B a} _≡_) →
          Decidable {A = Σ A B} _≡_
  ≡-dec dec₁ dec₂ (a , x) (b , y) with dec₁ a b
  ... | false because [a≢b] = no (invert [a≢b] ∘ ,-injectiveˡ)
  ... | yes refl = map′ (cong (a ,_)) ,-injectiveʳ (dec₂ x y)


-- {-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.lhs.unify:65 -v tc.irr:50 #-}

open import Agda.Builtin.Nat

data B {A : Set} : A → Set where
  b : (a : A) → B a

data C {A : Set} : ∀ a → B {A} a → Set where
  c : (a : A) → C a (b a)

id : ∀ x → C _ x → B 0
id x (c y) = {!!}


{- 2010-09-28 Andreas, see issue 336 -}

module WhyWeNeedUntypedLambda where

IdT = ({A : Set} -> A -> A)

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

-- Untyped lambda succeeds, because checking \ x -> x : X is postponed,
-- then the solution X = IdT is found, and upon revisiting the tc problem
-- a hidden lambda \ {A} is inserted.
foo : ({X : Set1} -> X -> X == IdT -> Set) -> Set
foo k = k (\ x -> x) refl         -- succeeds

{-
-- Typed lambda fails, because \ (x : _) -> x has inferred type ?A -> ?A
-- but then unification with IdT fails.
foo' : ({X : Set1} -> X -> X == IdT -> Set) -> Set
foo' k = k (\ (x : _) -> x) refl  -- fails
-}


-- Non-deterministic insert and permutation with choose oracle
-- The module abstracts over the choice structure by importing it.

open import bool

module perm-keep-length
  (Choice : Set)
  (choose : Choice → 𝔹)
  (lchoice : Choice → Choice)
  (rchoice : Choice → Choice)
 where

open import eq
open import bool-thms
open import nat
open import nat-thms
open import list

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

-- Non-deterministic insert:
ndinsert : {a : Set} → Choice → a → 𝕃 a  → 𝕃 a
ndinsert _  n []        = n :: []
ndinsert ch n (x :: xs) =
  if choose ch then n :: x :: xs
               else x :: ndinsert (lchoice ch) n xs

perm : {a : Set} → Choice → 𝕃 a  → 𝕃 a
perm _  []        = []
perm ch (x :: xs) = ndinsert (lchoice ch) x (perm (rchoice ch) xs)

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

-- Non-deterministic insertion increases the list length by one:
insert-inc-length : ∀ {a : Set} → (ch : Choice) (x : a) (xs : 𝕃 a)
                 → length (ndinsert ch x xs) ≡ suc (length xs)
insert-inc-length ch x [] = refl
insert-inc-length ch x (y :: ys) with choose ch
... | tt = refl
... | ff rewrite insert-inc-length (lchoice ch) x ys = refl

-- The length of a permuted list is identical to the length of the list:
perm-length : ∀ {a : Set} → (ch : Choice) (xs : 𝕃 a)
           → length (perm ch xs) =ℕ length xs ≡ tt
perm-length ch [] = refl
perm-length ch (x :: xs)
  rewrite insert-inc-length (lchoice ch) x (perm (rchoice ch) xs)
        | perm-length (rchoice ch) xs
  = refl

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


{-# OPTIONS --universe-polymorphism #-}
module Categories.NaturalTransformation where

open import Categories.Category
open import Categories.Functor hiding (equiv) renaming (id to idF; _≡_ to _≡F_; _∘_ to _∘F_)
open import Categories.NaturalTransformation.Core public

infixr 9 _∘ˡ_ _∘ʳ_

_∘ˡ_ : ∀ {o₀ ℓ₀ e₀ o₁ ℓ₁ e₁ o₂ ℓ₂ e₂}
     → {C : Category o₀ ℓ₀ e₀} {D : Category o₁ ℓ₁ e₁} {E : Category o₂ ℓ₂ e₂}
     → {F G : Functor C D}
     → (H : Functor D E) → (η : NaturalTransformation F G) → NaturalTransformation (H ∘F F) (H ∘F G)
_∘ˡ_ {C = C} {D} {E} {F} {G} H η′ = record
  { η       = λ X → Functor.F₁ H (NaturalTransformation.η η′ X)
  ; commute = commute′
  }
  where
  module C = Category C
  module D = Category D renaming (_∘_ to _∘D_; _≡_ to _≡D_)
  module E = Category E renaming (_∘_ to _∘E_; _≡_ to _≡E_)
  module H = Functor H
  open D
  open E

  .commute′ : ∀ {X Y} (f : C [ X , Y ]) →
      Functor.F₁ H (NaturalTransformation.η η′ Y) ∘E Functor.F₁ H (Functor.F₁ F f) ≡E
      Functor.F₁ H (Functor.F₁ G f) ∘E Functor.F₁ H (NaturalTransformation.η η′ X)
  commute′ {X} {Y} f =
      begin
        Functor.F₁ H (NaturalTransformation.η η′ Y) ∘E Functor.F₁ H (Functor.F₁ F f)
      ↑⟨ H.homomorphism ⟩
        Functor.F₁ H (NaturalTransformation.η η′ Y ∘D Functor.F₁ F f)
      ↓⟨ H.F-resp-≡ (NaturalTransformation.commute η′ f) ⟩
        Functor.F₁ H (Functor.F₁ G f ∘D NaturalTransformation.η η′ X)
      ↓⟨ H.homomorphism ⟩
        Functor.F₁ H (Functor.F₁ G f) ∘E Functor.F₁ H (NaturalTransformation.η η′ X)
      ∎
    where
    open E.HomReasoning

_∘ʳ_ : ∀ {o₀ ℓ₀ e₀ o₁ ℓ₁ e₁ o₂ ℓ₂ e₂}
     → {C : Category o₀ ℓ₀ e₀} {D : Category o₁ ℓ₁ e₁} {E : Category o₂ ℓ₂ e₂}
     → {F G : Functor C D}
     → (η : NaturalTransformation F G) → (K : Functor E C) → NaturalTransformation (F ∘F K) (G ∘F K)
_∘ʳ_ η K = record
  { η       = λ X → NaturalTransformation.η η (Functor.F₀ K X)
  ; commute = λ f → NaturalTransformation.commute η (Functor.F₁ K f)
  }

-- The vertical versions
.identity₁ˡ : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {F G : Functor C D} {X : NaturalTransformation F G}
           → id ∘₁ X ≡ X
identity₁ˡ {D = D} = Category.identityˡ D

.identity₁ʳ : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {F G : Functor C D} {X : NaturalTransformation F G}
           → X ∘₁ id ≡ X
identity₁ʳ {D = D} = Category.identityʳ D

.assoc₁ : ∀ {o ℓ e o′ ℓ′ e′}
           {P : Category o ℓ e} {Q : Category o′ ℓ′ e′} {A B C D : Functor P Q}
           {X : NaturalTransformation A B} {Y : NaturalTransformation B C} {Z : NaturalTransformation C D}
       → (Z ∘₁ Y) ∘₁ X ≡ Z ∘₁ (Y ∘₁ X)
assoc₁ {Q = Q} = Category.assoc Q

-- The horizontal ones
.identity₀ˡ : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {F G : Functor C D} {X : NaturalTransformation F G}
           → id {F = idF} ∘₀ X ≡ X
identity₀ˡ {D = D} = Category.identityʳ D

.identity₀ʳ : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {F G : Functor C D} {X : NaturalTransformation F G}
           → X ∘₀ id {F = idF} ≡ X
identity₀ʳ {C = C} {D} {F} {G} {X} =
    begin
      G₁ C.id ∘ (η _)
    ↓⟨ ∘-resp-≡ˡ G.identity ⟩
      D.id ∘ (η _)
    ↓⟨ D.identityˡ ⟩
      η _
    ∎
  where
  module C = Category C
  module D = Category D
  module F = Functor F
  module G = Functor G renaming (F₀ to G₀; F₁ to G₁; F-resp-≡ to G-resp-≡)
  open NaturalTransformation X
  open D.HomReasoning
  open F
  open G
  open D

open import Categories.Functor.Core using () renaming ( _∘_ to _∘F_)
.assoc₀ : ∀ {o₀ ℓ₀ e₀ o₁ ℓ₁ e₁ o₂ ℓ₂ e₂ o₃ ℓ₃ e₃}
            {C₀ : Category o₀ ℓ₀ e₀} {C₁ : Category o₁ ℓ₁ e₁} {C₂ : Category o₂ ℓ₂ e₂} {C₃ : Category o₃ ℓ₃ e₃}
            {F G : Functor C₀ C₁} {H I : Functor C₁ C₂} {J K : Functor C₂ C₃}
        → {X : NaturalTransformation F G} → {Y : NaturalTransformation H I} → {Z : NaturalTransformation J K}
        → (Z ∘₀ Y) ∘₀ X ≡ (_∘₀_   {F = H ∘F F} {I ∘F G} Z  (_∘₀_ {C = C₀} {C₁} {C₂} Y  X))
assoc₀ {C₀ = C₀} {C₁} {C₂} {C₃} {F} {G} {H} {I} {J} {K} {X} {Y} {Z} =
    begin
      K₁ (I₁ (X.η _)) ∘C₃ (K₁ (Y.η (F₀ _)) ∘C₃ Z.η (H₀ (F₀ _)))
    ↑⟨ C₃.assoc ⟩
      (K₁ (I₁ (X.η _)) ∘C₃ K₁ (Y.η (F₀ _))) ∘C₃ Z.η (H₀ (F₀ _))
    ↑⟨ C₃.∘-resp-≡ˡ K.homomorphism ⟩
      (K₁ ((I₁ (X.η _)) ∘C₂ Y.η (F₀ _))) ∘C₃ Z.η (H₀ (F₀ _))
    ∎
  where
  module C₂ = Category C₂ renaming (_∘_ to _∘C₂_; _≡_ to _≡C₂_)
  module C₃ = Category C₃ renaming (_∘_ to _∘C₃_; _≡_ to _≡C₃_)
  module F = Functor F
  module G = Functor G renaming (F₀ to G₀; F₁ to G₁; F-resp-≡ to G-resp-≡)
  module H = Functor H renaming (F₀ to H₀; F₁ to H₁; F-resp-≡ to H-resp-≡)
  module I = Functor I renaming (F₀ to I₀; F₁ to I₁; F-resp-≡ to I-resp-≡)
  module J = Functor J renaming (F₀ to J₀; F₁ to J₁; F-resp-≡ to J-resp-≡)
  module K = Functor K renaming (F₀ to K₀; F₁ to K₁; F-resp-≡ to K-resp-≡)
  module X = NaturalTransformation X
  module Y = NaturalTransformation Y
  module Z = NaturalTransformation Z
  open C₃.HomReasoning
  open C₂
  open C₃
  open F
  open H
  open I
  open K

.interchange : ∀ {o₀ ℓ₀ e₀} {o₁ ℓ₁ e₁} {o₂ ℓ₂ e₂}
                 {C₀ : Category o₀ ℓ₀ e₀} {C₁ : Category o₁ ℓ₁ e₁} {C₂ : Category o₂ ℓ₂ e₂}
                 {F₀ F₁ F₅ : Functor C₀ C₁} {F₂ F₃ F₄ : Functor C₁ C₂}
                 {α : NaturalTransformation F₃ F₄}
                 {β : NaturalTransformation F₁ F₅}
                 {γ : NaturalTransformation F₂ F₃}
                 {δ : NaturalTransformation F₀ F₁}
             → (α ∘₀ β) ∘₁ (γ ∘₀ δ) ≡ (α ∘₁ γ) ∘₀ (β ∘₁ δ)
interchange {C₀ = C₀} {C₁} {C₂} {F₀} {F₁} {F₅} {F₂} {F₃} {F₄} {α} {β} {γ} {δ} =
    begin
      (F₄.F₁ (β.η _) ∘ α.η (F₁.F₀ _)) ∘ (F₃.F₁ (δ.η _) ∘ γ.η (F₀.F₀ _))
    ↓⟨ C₂.assoc ⟩
      F₄.F₁ (β.η _) ∘ (α.η (F₁.F₀ _) ∘ (F₃.F₁ (δ.η _) ∘ γ.η (F₀.F₀ _)))
    ↑⟨ C₂.∘-resp-≡ʳ C₂.assoc ⟩
      F₄.F₁ (β.η _) ∘ ((α.η (F₁.F₀ _) ∘ (F₃.F₁ (δ.η _))) ∘ γ.η (F₀.F₀ _))
    ↓⟨ C₂.∘-resp-≡ʳ (C₂.∘-resp-≡ˡ (α.commute (δ.η _))) ⟩
      F₄.F₁ (β.η _) ∘ ((F₄.F₁ (δ.η _) ∘ α.η (F₀.F₀ _)) ∘ γ.η (F₀.F₀ _))
    ↓⟨ C₂.∘-resp-≡ʳ C₂.assoc ⟩
      F₄.F₁ (β.η _) ∘ (F₄.F₁ (δ.η _) ∘ (α.η (F₀.F₀ _) ∘ γ.η (F₀.F₀ _)))
    ↑⟨ C₂.assoc ⟩
      (F₄.F₁ (β.η _) ∘ F₄.F₁ (δ.η _)) ∘ (α.η (F₀.F₀ _) ∘ γ.η (F₀.F₀ _))
    ↑⟨ C₂.∘-resp-≡ˡ F₄.homomorphism ⟩
      F₄.F₁ (β.η _ ∘C₁ δ.η _) ∘ (α.η (F₀.F₀ _) ∘ γ.η (F₀.F₀ _))
    ∎
  where
  module C₁ = Category C₁ renaming (_∘_ to _∘C₁_; _≡_ to _≡C₁_)
  module C₂ = Category C₂
  module F₀ = Functor F₀
  module F₁ = Functor F₁
  module F₂ = Functor F₂
  module F₃ = Functor F₃
  module F₄ = Functor F₄
  module F₅ = Functor F₅
  module α = NaturalTransformation α
  module β = NaturalTransformation β
  module γ = NaturalTransformation γ
  module δ = NaturalTransformation δ
  open C₁
  open C₂
  open C₂.HomReasoning

.∘₁-resp-≡ : ∀ {o ℓ e} {o′ ℓ′ e′}
               {D : Category o ℓ e} {E : Category o′ ℓ′ e′}
               {A B C : Functor D E}
               {f h : NaturalTransformation B C} {g i : NaturalTransformation A B}
          → f ≡ h → g ≡ i → f ∘₁ g ≡ h ∘₁ i
∘₁-resp-≡ {E = E} f≡h g≡i = Category.∘-resp-≡ E f≡h g≡i

.∘₀-resp-≡ : ∀ {o ℓ e} {o′ ℓ′ e′} {o″ ℓ″ e″}
               {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {E : Category o″ ℓ″ e″}
               {F F′ : Functor C D} {G G′ : Functor D E}
               {f h : NaturalTransformation G G′} {g i : NaturalTransformation F F′}
           → f ≡ h → g ≡ i → f ∘₀ g ≡ h ∘₀ i
∘₀-resp-≡ {E = E} {G′ = G′} f≡h g≡i = Category.∘-resp-≡ E (Functor.F-resp-≡ G′ g≡i) f≡h


module Issue417 where

data _≡_ (A : Set₁) : Set₁ → Set₂ where
  refl : A ≡ A

abstract

  A : Set₁
  A = Set

  unfold-A : A ≡ Set
  unfold-A = refl

-- The result of inferring the type of unfold-A is the following:
--
--   Set ≡ Set


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

open import Categories.Category
open import Categories.Functor

module Categories.Diagram.Limit.Properties
       {o ℓ e} {o′ ℓ′ e′} {C : Category o ℓ e} {J : Category o′ ℓ′ e′}  where

open import Categories.Diagram.Cone.Properties
open import Categories.NaturalTransformation.NaturalIsomorphism using (NaturalIsomorphism; _≃_; module ≃)
open import Categories.Morphism.Reasoning C
open import Categories.Morphism C

import Categories.Category.Construction.Cones as Con
import Categories.Diagram.Limit as Lim

private
  module J = Category J
  module C = Category C

  open C
  variable
    X Y Z : Obj
    f g h : X ⇒ Y

open HomReasoning

-- natural isomorphisms respects limits
module _ {F G : Functor J C} (F≃G : F ≃ G) where
  private
    module F  = Functor F
    module G  = Functor G
    module LF = Lim F
    module LG = Lim G
    open NaturalIsomorphism F≃G

  ≃-resp-lim : LF.Limit → LG.Limit
  ≃-resp-lim L = record
    { terminal = record
      { ⊤        = record
        { apex = record
          { ψ       = λ j → ⇒.η j ∘ proj j
          ; commute = λ {X Y} f → begin
            G.F₁ f ∘ ⇒.η X ∘ proj X   ≈⟨ pullˡ (⇒.sym-commute f) ⟩
            (⇒.η Y ∘ F.F₁ f) ∘ proj X ≈⟨ pullʳ (limit-commute f) ⟩
            ⇒.η Y ∘ proj Y            ∎
          }
        }
      ; ⊤-is-terminal = record
        { !        = λ {A} → record
          { arr     = rep (nat-map-Cone F⇐G A)
          ; commute = λ {j} → assoc ○ ⟺ (switch-tofromˡ (record { iso = iso j }) (⟺ commute))
          }
        ; !-unique = λ {K} f →
          let module f = Con.Cone⇒ G f
          in terminal.!-unique record
            { arr     = f.arr
            ; commute = λ {j} → switch-fromtoˡ (record { iso = iso j }) (sym-assoc ○ f.commute)
            }
        }
      }
    }
    where open LF.Limit L

  ≃⇒Cone⇒ : ∀ (Lf : LF.Limit) (Lg : LG.Limit) → Con.Cones G [ LG.Limit.limit (≃-resp-lim Lf) , LG.Limit.limit Lg ]
  ≃⇒Cone⇒ Lf Lg = rep-cone (LG.Limit.limit (≃-resp-lim Lf))
    where open LG.Limit Lg

≃⇒lim≅ : ∀ {F G : Functor J C} (F≃G : F ≃ G) (Lf : Lim.Limit F) (Lg : Lim.Limit G) → Lim.Limit.apex Lf ≅ Lim.Limit.apex Lg
≃⇒lim≅ {F = F} {G} F≃G Lf Lg = record
  { from = arr (≃⇒Cone⇒ F≃G Lf Lg)
  ; to   = arr (≃⇒Cone⇒ (≃.sym F≃G) Lg Lf)
  ; iso  = record
    { isoˡ = Lf.terminal.⊤-id record
      { commute = λ {j} → begin
        Lf.proj j ∘ arr (≃⇒Cone⇒ (≃.sym F≃G) Lg Lf) ∘ arr (≃⇒Cone⇒ F≃G Lf Lg) ≈⟨ pullˡ (⇒-commute (≃⇒Cone⇒ (≃.sym F≃G) Lg Lf)) ⟩
        (⇐.η j ∘ Lg.proj j) ∘ arr (≃⇒Cone⇒ F≃G Lf Lg)                         ≈⟨ pullʳ (⇒-commute (≃⇒Cone⇒ F≃G Lf Lg)) ⟩
        ⇐.η j ∘ ⇒.η j ∘ Lf.proj j                                             ≈⟨ cancelˡ (iso.isoˡ j) ⟩
        Lf.proj j                                                             ∎
      }
    ; isoʳ = Lg.terminal.⊤-id record
      { commute = λ {j} → begin
        Lg.proj j ∘ arr (≃⇒Cone⇒ F≃G Lf Lg) ∘ arr (≃⇒Cone⇒ (≃.sym F≃G) Lg Lf) ≈⟨ pullˡ (⇒-commute (≃⇒Cone⇒ F≃G Lf Lg)) ⟩
        (⇒.η j ∘ Lf.proj j) ∘ arr (≃⇒Cone⇒ (≃.sym F≃G) Lg Lf)                 ≈⟨ pullʳ (⇒-commute (≃⇒Cone⇒ (≃.sym F≃G) Lg Lf)) ⟩
        ⇒.η j ∘ ⇐.η j ∘ Lg.proj j                                             ≈⟨ cancelˡ (iso.isoʳ j) ⟩
        Lg.proj j                                                             ∎
      }
    }
  }
  where open Con.Cone⇒ renaming (commute to ⇒-commute)
        module Lf = Lim.Limit Lf
        module Lg = Lim.Limit Lg
        open NaturalIsomorphism F≃G


-- Andreas, 2014-10-09
-- Reported by ohmanjoakim

infixr 8 _⇒_

data Ty : Set where
  _⇒_ : Ty → Ty → Ty

⟦_⟧ : Ty → Set
⟦ A ⇒ B ⟧ = ⟦ A ⟧ → ⟦ B ⟧

data Term : Ty → Set where
  K : (A B : Ty) → Term (A ⇒ B ⇒ A)

test : (A : Ty) (a : Term A) → ⟦ A ⟧
test A a = {!a!}

-- When doing a case split on a in foo, the following is written:
-- test .(x ⇒ x₁ ⇒ x) (K A B) x x₁ = ?

-- Correct is
-- test .(A ⇒ B ⇒ A) (K A B) x x₁ = ?


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

module Data.Binary.Bits where

open import Data.Bool
  as Bool
  using (not; _∨_; _∧_; _xor_; T)
  renaming (Bool to Bit; true to I; false to O)
  public

_xnor_ : Bit → Bit → Bit
O xnor y = not y
I xnor y = y

sumᵇ : Bit → Bit → Bit → Bit
sumᵇ O = _xor_
sumᵇ I = _xnor_

carryᵇ : Bit → Bit → Bit → Bit
carryᵇ O = _∧_
carryᵇ I = _∨_


module Prelude where

infixr 90 _∘_
infixr 50 _∧_
infix  20 _⟸⇒_
infixl 3  _from_

_from_ : (A : Set) -> A -> A
A from a = a

_∘_ : {A B C : Set} -> (A -> B) -> (C -> A) -> C -> B
(f ∘ g) x = f (g x)

record _∧_ (A B : Set) : Set where
  field
    p₁ : A
    p₂ : B

open _∧_ public renaming (p₁ to fst; p₂ to snd)

_,_ : {A B : Set} -> A -> B -> A ∧ B
x , y = record { p₁ = x; p₂ = y }

swap : {A B : Set} -> A ∧ B -> B ∧ A
swap p = (snd p , fst p)

_⇐⇒_ : Set -> Set -> Set
A ⇐⇒ B = (A -> B) ∧ (B -> A)


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

open import HoTT
open import homotopy.elims.SuspSmash
open import homotopy.elims.CofPushoutSection

-- Σ(X∧Y) ≃ X * Y

module homotopy.SuspSmash {i j} (X : Ptd i) (Y : Ptd j) where

private

  {- path lemmas -}
  private
    reduce-x : ∀ {i} {A : Type i} {x y z : A} (p : x == y) (q : z == y)
      → p ∙ ! q ∙ q ∙ ! p ∙ p == p
    reduce-x idp idp = idp

    reduce-y : ∀ {i} {A : Type i} {x y z : A} (p : x == y) (q : x == z)
      → p ∙ ! p ∙ q ∙ ! q ∙ p == p
    reduce-y idp idp = idp

  module Into = SuspRec {A = Smash X Y}
    {C = de⊙ X * de⊙ Y}
    (left (pt X))
    (right (pt Y))
    (Smash-rec
      (λ x y →
        jglue (pt X) (pt Y) ∙ ! (jglue x (pt Y))
        ∙ jglue x y
        ∙ ! (jglue (pt X) y) ∙ jglue (pt X) (pt Y))
      (jglue (pt X) (pt Y))
      (jglue (pt X) (pt Y))
      (λ x → reduce-x (jglue (pt X) (pt Y)) (jglue x (pt Y)))
      (λ y → reduce-y (jglue (pt X) (pt Y)) (jglue (pt X) y)))

  into = Into.f

  module Out = JoinRec
    {C = Susp (Smash X Y)}
    (λ _ → north)
    (λ _ → south)
    (λ x y → merid (smin x y))

  out = Out.f

  abstract
    into-out : (j : de⊙ X * de⊙ Y) → into (out j) == j
    into-out = Join-elim
      (λ x → glue (pt X , pt Y) ∙ ! (glue (x , pt Y)))
      (λ y → ! (glue (pt X , pt Y)) ∙ glue (pt X , y))
      (λ x y → ↓-∘=idf-from-square into out $
        (ap (ap into) (Out.glue-β x y)
         ∙ Into.merid-β (smin x y))
        ∙v⊡ lemma (glue (pt X , pt Y)) (glue (x , pt Y))
                  (glue (pt X , y)) (glue (x , y)))
      where
      lemma : ∀ {i} {A : Type i} {x y z w : A}
        (p : x == y) (q : z == y) (r : x == w) (s : z == w)
        → Square (p ∙ ! q) (p ∙ ! q ∙ s ∙ ! r ∙ p) s (! p ∙ r)
      lemma idp idp idp s =
        vert-degen-square (∙-unit-r s)

    out-into : (σ : Susp (Smash X Y)) → out (into σ) == σ
    out-into = SuspSmash-elim
      idp
      idp
      (λ x y → ↓-∘=idf-in' out into $
        ap (ap out) (Into.merid-β (smin x y))
        ∙ lemma₁ out (Out.glue-β (pt X) (pt Y))
                     (Out.glue-β x (pt Y))
                     (Out.glue-β x y)
                     (Out.glue-β (pt X) y)
                     (Out.glue-β (pt X) (pt Y))
        ∙ lemma₂ {p = merid (smin (pt X) (pt Y))}
                 {q = merid (smin x (pt Y))}
                 {r = merid (smin x y)}
                 {s = merid (smin (pt X) y)}
                 {t = merid (smin (pt X) (pt Y))}
            (ap merid (smgluel (pt X) ∙ ! (smgluel x)))
            (ap merid (smgluer y ∙ ! (smgluer (pt Y)))))
      where
      lemma₁ : ∀ {i j} {A : Type i} {B : Type j} (f : A → B)
        {x y z u v w : A}
        {p : x == y} {q : z == y} {r : z == u} {s : v == u} {t : v == w}
        {p' : f x == f y} {q' : f z == f y} {r' : f z == f u}
        {s' : f v == f u} {t' : f v == f w}
        (α : ap f p == p') (β : ap f q == q') (γ : ap f r == r')
        (δ : ap f s == s') (ε : ap f t == t')
        → ap f (p ∙ ! q ∙ r ∙ ! s ∙ t) == p' ∙ ! q' ∙ r' ∙ ! s' ∙ t'
      lemma₁ f {p = idp} {q = idp} {r = idp} {s = idp} {t = idp}
            idp idp idp idp idp
        = idp

      lemma₂ : ∀ {i} {A : Type i} {x y z u : A}
        {p q : x == y} {r : x == z} {s t : u == z}
        (α : p == q) (β : s == t)
        → p ∙ ! q  ∙ r ∙ ! s ∙ t == r
      lemma₂ {p = idp} {r = idp} {s = idp} idp idp = idp

module SuspSmash where

  eq : Susp (Smash X Y) ≃ (de⊙ X * de⊙ Y)
  eq = equiv into out into-out out-into

  ⊙eq : ⊙Susp (⊙Smash X Y) ⊙≃ (X ⊙* Y)
  ⊙eq = ≃-to-⊙≃ eq idp


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

module Categories.Category.Finite.Fin.Construction.Poset where

open import Data.Nat using (ℕ; z≤n; s≤s)
open import Data.Sum
open import Data.Product using (Σ; _,_; _×_)
open import Data.Fin
open import Data.Fin.Patterns

open import Relation.Binary.PropositionalEquality as ≡

open import Categories.Category.Finite.Fin
open import Categories.Category

private
  card : ∀ {n} → Fin n → Fin n → ℕ
  card {ℕ.suc n} zero y          = 1
  card {ℕ.suc n} (suc x) zero    = 0
  card {ℕ.suc n} (suc x) (suc y) = card x y

  id : ∀ n {a : Fin n} → Fin (card a a)
  id .(ℕ.suc _) {zero} = 0F
  id (ℕ.suc n) {suc a} = id n

  comp : ∀ n {a b c : Fin n} → Fin (card b c) → Fin (card a b) → Fin (card a c)
  comp (ℕ.suc n) {0F} {b} {c} f g = 0F
  comp (ℕ.suc n) {suc a} {suc b} {suc c} f g = comp n f g

  assoc : ∀ n {a b c d : Fin n} {f : Fin (card a b)} {g : Fin (card b c)} {h : Fin (card c d)} →
              comp n (comp n h g) f ≡ comp n h (comp n g f)
  assoc (ℕ.suc n) {0F} {b} {c} {d} {f} {g} {h}                = refl
  assoc (ℕ.suc n) {suc a} {suc b} {suc c} {suc d} {f} {g} {h} = assoc n

  identityˡ : ∀ n {a b : Fin n} {f : Fin (card a b)} → comp n (id n) f ≡ f
  identityˡ (ℕ.suc n) {0F} {b} {0F} = refl
  identityˡ (ℕ.suc n) {suc a} {suc b} {f} = identityˡ n

  identityʳ : ∀ n {a b : Fin n} {f : Fin (card a b)} → comp n f (id n) ≡ f
  identityʳ (ℕ.suc n) {0F} {b} {0F}       = refl
  identityʳ (ℕ.suc n) {suc a} {suc b} {f} = identityʳ n

card-rel : ∀ {n} (x y : Fin n) → card x y ≡ 1 × x ≤ y ⊎ card x y ≡ 0 × y < x
card-rel {ℕ.suc n} 0F y       = inj₁ (refl , z≤n)
card-rel {ℕ.suc n} (suc x) 0F = inj₂ (refl , s≤s z≤n)
card-rel {ℕ.suc n} (suc x) (suc y) with card-rel x y
... | inj₁ (eq , x≤y)         = inj₁ (eq , s≤s x≤y)
... | inj₂ (eq , y<x)         = inj₂ (eq , s≤s y<x)

card-sound₁ : ∀ {n} (x y : Fin n) → card x y ≡ 1 → x ≤ y
card-sound₁ 0F 0F eq           = z≤n
card-sound₁ 0F (suc y) eq      = z≤n
card-sound₁ (suc x) (suc y) eq = s≤s (card-sound₁ x y eq)

card-sound₂ : ∀ {n} (x y : Fin n) → card x y ≡ 0 → y ≤ x
card-sound₂ (suc x) 0F eq      = z≤n
card-sound₂ (suc x) (suc y) eq = s≤s (card-sound₂ x y eq)

card-complete₁ : ∀ {n} {x y : Fin n} → x ≤ y → card x y ≡ 1
card-complete₁ {.(ℕ.suc _)} {0F} {0F} x≤y             = refl
card-complete₁ {.(ℕ.suc _)} {0F} {suc y} x≤y          = refl
card-complete₁ {.(ℕ.suc _)} {suc x} {suc y} (s≤s x≤y) = card-complete₁ x≤y

card-complete₂ : ∀ {n} {x y : Fin n} → y < x → card x y ≡ 0
card-complete₂ {.(ℕ.suc _)} {suc x} {0F} y<x          = refl
card-complete₂ {.(ℕ.suc _)} {suc x} {suc y} (s≤s y<x) = card-complete₂ y<x

module _ (size : ℕ) where

  PosetShape : FinCatShape
  PosetShape = record
    { size     = size
    ; ∣_⇒_∣    = card
    ; hasShape = record
      { id        = id size
      ; _∘_       = comp size
      ; assoc     = assoc size
      ; identityˡ = identityˡ size
      ; identityʳ = identityʳ size
      }
    }

Poset : ℕ → Category _ _ _
Poset size = FinCategory (PosetShape size)

module Poset size = Category (Poset size)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Heterogeneous equality
------------------------------------------------------------------------

module Relation.Binary.HeterogeneousEquality where

open import Data.Product
open import Function
open import Function.Inverse using (Inverse)
open import Data.Unit.Core
open import Level
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.Consequences
open import Relation.Binary.Indexed as I using (_at_)
open import Relation.Binary.PropositionalEquality as P using (_≡_; refl)

import Relation.Binary.HeterogeneousEquality.Core as Core

------------------------------------------------------------------------
-- Heterogeneous equality

infix 4 _≇_

open Core public using (_≅_; refl)

-- Nonequality.

_≇_ : ∀ {ℓ} {A : Set ℓ} → A → {B : Set ℓ} → B → Set ℓ
x ≇ y = ¬ x ≅ y

------------------------------------------------------------------------
-- Conversion

≡-to-≅ : ∀ {a} {A : Set a} {x y : A} → x ≡ y → x ≅ y
≡-to-≅ refl = refl

open Core public using (≅-to-≡)

------------------------------------------------------------------------
-- Some properties

reflexive : ∀ {a} {A : Set a} → _⇒_ {A = A} _≡_ (λ x y → x ≅ y)
reflexive refl = refl

sym : ∀ {ℓ} {A B : Set ℓ} {x : A} {y : B} → x ≅ y → y ≅ x
sym refl = refl

trans : ∀ {ℓ} {A B C : Set ℓ} {x : A} {y : B} {z : C} →
        x ≅ y → y ≅ z → x ≅ z
trans refl eq = eq

subst : ∀ {a} {A : Set a} {p} → Substitutive {A = A} (λ x y → x ≅ y) p
subst P refl p = p

subst₂ : ∀ {a b p} {A : Set a} {B : Set b} (P : A → B → Set p) →
         ∀ {x₁ x₂ y₁ y₂} → x₁ ≅ x₂ → y₁ ≅ y₂ → P x₁ y₁ → P x₂ y₂
subst₂ P refl refl p = p

subst-removable : ∀ {a p} {A : Set a}
                  (P : A → Set p) {x y} (eq : x ≅ y) z →
                  subst P eq z ≅ z
subst-removable P refl z = refl

≡-subst-removable : ∀ {a p} {A : Set a}
                    (P : A → Set p) {x y} (eq : x ≡ y) z →
                    P.subst P eq z ≅ z
≡-subst-removable P refl z = refl

cong : ∀ {a b} {A : Set a} {B : A → Set b} {x y}
       (f : (x : A) → B x) → x ≅ y → f x ≅ f y
cong f refl = refl

cong-app : ∀ {a b} {A : Set a} {B : A → Set b} {f g : (x : A) → B x} →
           f ≅ g → (x : A) → f x ≅ g x
cong-app refl x = refl

cong₂ : ∀ {a b c} {A : Set a} {B : A → Set b} {C : ∀ x → B x → Set c}
          {x y u v}
        (f : (x : A) (y : B x) → C x y) → x ≅ y → u ≅ v → f x u ≅ f y v
cong₂ f refl refl = refl

resp₂ : ∀ {a ℓ} {A : Set a} (∼ : Rel A ℓ) → ∼ Respects₂ (λ x y → x ≅ y)
resp₂ _∼_ = subst⟶resp₂ _∼_ subst

proof-irrelevance : ∀ {ℓ} {A B : Set ℓ} {x : A} {y : B}
                    (p q : x ≅ y) → p ≡ q
proof-irrelevance refl refl = refl

isEquivalence : ∀ {a} {A : Set a} →
                IsEquivalence {A = A} (λ x y → x ≅ y)
isEquivalence = record
  { refl  = refl
  ; sym   = sym
  ; trans = trans
  }

setoid : ∀ {a} → Set a → Setoid _ _
setoid A = record
  { Carrier       = A
  ; _≈_           = λ x y → x ≅ y
  ; isEquivalence = isEquivalence
  }

indexedSetoid : ∀ {a b} {A : Set a} → (A → Set b) → I.Setoid A _ _
indexedSetoid B = record
  { Carrier       = B
  ; _≈_           = λ x y → x ≅ y
  ; isEquivalence = record
    { refl  = refl
    ; sym   = sym
    ; trans = trans
    }
  }

≡↔≅ : ∀ {a b} {A : Set a} (B : A → Set b) {x : A} →
      Inverse (P.setoid (B x)) (indexedSetoid B at x)
≡↔≅ B = record
  { to         = record { _⟨$⟩_ = id; cong = ≡-to-≅ }
  ; from       = record { _⟨$⟩_ = id; cong = ≅-to-≡ }
  ; inverse-of = record
    { left-inverse-of  = λ _ → refl
    ; right-inverse-of = λ _ → refl
    }
  }

decSetoid : ∀ {a} {A : Set a} →
            Decidable {A = A} {B = A} (λ x y → x ≅ y) →
            DecSetoid _ _
decSetoid dec = record
  { _≈_              = λ x y → x ≅ y
  ; isDecEquivalence = record
      { isEquivalence = isEquivalence
      ; _≟_           = dec
      }
  }

isPreorder : ∀ {a} {A : Set a} →
             IsPreorder {A = A} (λ x y → x ≅ y) (λ x y → x ≅ y)
isPreorder = record
  { isEquivalence = isEquivalence
  ; reflexive     = id
  ; trans         = trans
  }

isPreorder-≡ : ∀ {a} {A : Set a} →
               IsPreorder {A = A} _≡_ (λ x y → x ≅ y)
isPreorder-≡ = record
  { isEquivalence = P.isEquivalence
  ; reflexive     = reflexive
  ; trans         = trans
  }

preorder : ∀ {a} → Set a → Preorder _ _ _
preorder A = record
  { Carrier    = A
  ; _≈_        = _≡_
  ; _∼_        = λ x y → x ≅ y
  ; isPreorder = isPreorder-≡
  }

------------------------------------------------------------------------
-- Convenient syntax for equational reasoning

module ≅-Reasoning where

  -- The code in Relation.Binary.EqReasoning cannot handle
  -- heterogeneous equalities, hence the code duplication here.

  infix  4 _IsRelatedTo_
  infix  2 _∎
  infixr 2 _≅⟨_⟩_ _≡⟨_⟩_ _≡⟨⟩_
  infix  1 begin_

  data _IsRelatedTo_ {ℓ} {A : Set ℓ} (x : A) {B : Set ℓ} (y : B) :
                     Set ℓ where
    relTo : (x≅y : x ≅ y) → x IsRelatedTo y

  begin_ : ∀ {ℓ} {A : Set ℓ} {x : A} {B} {y : B} →
           x IsRelatedTo y → x ≅ y
  begin relTo x≅y = x≅y

  _≅⟨_⟩_ : ∀ {ℓ} {A : Set ℓ} (x : A) {B} {y : B} {C} {z : C} →
           x ≅ y → y IsRelatedTo z → x IsRelatedTo z
  _ ≅⟨ x≅y ⟩ relTo y≅z = relTo (trans x≅y y≅z)

  _≡⟨_⟩_ : ∀ {ℓ} {A : Set ℓ} (x : A) {y C} {z : C} →
           x ≡ y → y IsRelatedTo z → x IsRelatedTo z
  _ ≡⟨ x≡y ⟩ relTo y≅z = relTo (trans (reflexive x≡y) y≅z)

  _≡⟨⟩_ : ∀ {ℓ} {A : Set ℓ} (x : A) {B} {y : B} →
          x IsRelatedTo y → x IsRelatedTo y
  _ ≡⟨⟩ x≅y = x≅y

  _∎ : ∀ {a} {A : Set a} (x : A) → x IsRelatedTo x
  _∎ _ = relTo refl

------------------------------------------------------------------------
-- Functional extensionality

-- A form of functional extensionality for _≅_.

Extensionality : (a b : Level) → Set _
Extensionality a b =
  {A : Set a} {B₁ B₂ : A → Set b}
  {f₁ : (x : A) → B₁ x} {f₂ : (x : A) → B₂ x} →
  (∀ x → B₁ x ≡ B₂ x) → (∀ x → f₁ x ≅ f₂ x) → f₁ ≅ f₂

-- This form of extensionality follows from extensionality for _≡_.

≡-ext-to-≅-ext : ∀ {ℓ₁ ℓ₂} →
  P.Extensionality ℓ₁ (suc ℓ₂) → Extensionality ℓ₁ ℓ₂
≡-ext-to-≅-ext           ext B₁≡B₂ f₁≅f₂ with ext B₁≡B₂
≡-ext-to-≅-ext {ℓ₁} {ℓ₂} ext B₁≡B₂ f₁≅f₂ | P.refl =
  ≡-to-≅ $ ext′ (≅-to-≡ ∘ f₁≅f₂)
  where
  ext′ : P.Extensionality ℓ₁ ℓ₂
  ext′ = P.extensionality-for-lower-levels ℓ₁ (suc ℓ₂) ext

------------------------------------------------------------------------
-- Inspect on steroids

-- Inspect on steroids can be used when you want to pattern match on
-- the result r of some expression e, and you also need to "remember"
-- that r ≡ e.

data Reveal_is_ {a} {A : Set a} (x : Hidden A) (y : A) : Set a where
  [_] : (eq : reveal x ≅ y) → Reveal x is y

inspect : ∀ {a b} {A : Set a} {B : A → Set b}
          (f : (x : A) → B x) (x : A) → Reveal (hide f x) is (f x)
inspect f x = [ refl ]


open import Oscar.Prelude
open import Oscar.Data.Decidable
open import Oscar.Data.Proposequality

module Oscar.Class.IsDecidable where

record IsDecidable {𝔬} (𝔒 : Ø 𝔬) : Ø 𝔬 where
  infix 4 _≟_
  field
    _≟_ : (x y : 𝔒) → Decidable (x ≡ y)

open IsDecidable ⦃ … ⦄ public


------------------------------------------------------------------------
-- The Agda standard library
--
-- Booleans
------------------------------------------------------------------------

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

module Data.Bool where

open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; refl)

------------------------------------------------------------------------
-- The boolean type and some operations

open import Data.Bool.Base public

------------------------------------------------------------------------
-- Publicly re-export queries

open import Data.Bool.Properties public
  using (_≟_; _≤?_; _<?_)

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

-- Version 1.1

decSetoid = Data.Bool.Properties.≡-decSetoid
{-# WARNING_ON_USAGE decSetoid
"Warning: decSetoid was deprecated in v1.1.
Please use ≡-decSetoid from Data.Bool.Properties instead."
#-}


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

-- a categorical (i.e. non-skeletal) version of Lawvere Theory,
-- as per https://ncatlab.org/nlab/show/Lawvere+theory

module Categories.Theory.Lawvere where

open import Data.Nat using (ℕ)
open import Data.Product using (Σ; _,_)
open import Level

open import Categories.Category.Cartesian
open import Categories.Category using (Category; _[_,_])
open import Categories.Category.Instance.Setoids
open import Categories.Category.Monoidal.Instance.Setoids using (Setoids-Cartesian)
open import Categories.Category.Product
open import Categories.Functor using (Functor; _∘F_) renaming (id to idF)
open import Categories.Functor.Cartesian
open import Categories.Functor.Cartesian.Properties
import Categories.Morphism as Mor
open import Categories.NaturalTransformation using (NaturalTransformation)

private
  variable
    o ℓ e o′ ℓ′ e′ o″ ℓ″ e″ : Level

record FiniteProduct (o ℓ e : Level) : Set (suc (o ⊔ ℓ ⊔ e)) where
  field
    T : Category o ℓ e
  open Mor T
  field
    cart : Cartesian T
    generic : Category.Obj T
  open Cartesian cart using (power)
  field
    obj-iso-to-generic-power : (x : Category.Obj T) → Σ ℕ (λ n → x ≅ power generic n)

record LT-Hom (T₁ : FiniteProduct o ℓ e) (T₂ : FiniteProduct o′ ℓ′ e′) : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
  private
    module T₁ = FiniteProduct T₁
    module T₂ = FiniteProduct T₂

  field
    F : Functor T₁.T T₂.T
    cartF : CartesianF T₁.cart T₂.cart F

LT-id : {A : FiniteProduct o ℓ e} → LT-Hom A A
LT-id = record { F = idF ; cartF = idF-Cartesian }

LT-∘ : {A : FiniteProduct o ℓ e} {B : FiniteProduct o′ ℓ′ e′} {C : FiniteProduct o″ ℓ″ e″} →
  LT-Hom B C → LT-Hom A B → LT-Hom A C
LT-∘ G H = record { F = F G ∘F F H ; cartF = ∘-Cartesian (cartF G) (cartF H) }
  where open LT-Hom

record T-Algebra (FP : FiniteProduct o ℓ e) : Set (o ⊔ ℓ ⊔ e ⊔ suc (ℓ′ ⊔ e′)) where
  private
    module FP = FiniteProduct FP
  field
    Mod : Functor FP.T (Setoids ℓ′ e′)
    Cart : CartesianF FP.cart Setoids-Cartesian Mod


------------------------------------------------------------------------
-- The Agda standard library
--
-- Subsets of finite sets
------------------------------------------------------------------------

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

module Data.Fin.Subset where

open import Algebra
open import Algebra.FunctionProperties using (Op₁; Op₂)
import Algebra.Properties.BooleanAlgebra as BoolAlgProp
import Algebra.Properties.BooleanAlgebra.Expression as BAExpr
open import Data.Bool using (not; _∧_; _∨_; _≟_)
open import Data.Fin using (Fin; zero; suc)
open import Data.List.Base using (List; foldr; foldl)
open import Data.Nat using (ℕ)
open import Data.Product using (∃)
open import Data.Vec hiding (foldr; foldl)
import Data.Vec.Relation.Binary.Pointwise.Extensional as Pointwise
open import Relation.Nullary

------------------------------------------------------------------------
-- Definitions

-- Sides.

open import Data.Bool.Base public
  using () renaming (Bool to Side; true to inside; false to outside)

-- Partitions a finite set into two parts, the inside and the outside.

Subset : ℕ → Set
Subset = Vec Side

------------------------------------------------------------------------
-- Special subsets

-- The empty subset
⊥ : ∀ {n} → Subset n
⊥ = replicate outside

-- The full subset
⊤ : ∀ {n} → Subset n
⊤ = replicate inside

-- A singleton subset, containing just the given element.
⁅_⁆ : ∀ {n} → Fin n → Subset n
⁅ zero  ⁆ = inside  ∷ ⊥
⁅ suc i ⁆ = outside ∷ ⁅ i ⁆

------------------------------------------------------------------------
-- Membership and subset predicates

infix 4 _∈_ _∉_ _⊆_ _⊈_

_∈_ : ∀ {n} → Fin n → Subset n → Set
x ∈ p = p [ x ]= inside

_∉_ : ∀ {n} → Fin n → Subset n → Set
x ∉ p = ¬ (x ∈ p)

_⊆_ : ∀ {n} → Subset n → Subset n → Set
p ⊆ q = ∀ {x} → x ∈ p → x ∈ q

_⊈_ : ∀ {n} → Subset n → Subset n → Set
p ⊈ q = ¬ (p ⊆ q)

------------------------------------------------------------------------
-- Set operations

infixr 7 _∩_
infixr 6 _∪_

-- Complement
∁ : ∀ {n} → Op₁ (Subset n)
∁ p = map not p

-- Intersection
_∩_ : ∀ {n} → Op₂ (Subset n)
p ∩ q = zipWith _∧_ p q

-- Union
_∪_ : ∀ {n} → Op₂ (Subset n)
p ∪ q = zipWith _∨_ p q

-- N-ary union
⋃ : ∀ {n} → List (Subset n) → Subset n
⋃ = foldr _∪_ ⊥

-- N-ary intersection
⋂ : ∀ {n} → List (Subset n) → Subset n
⋂ = foldr _∩_ ⊤

-- Size
∣_∣ : ∀ {n} → Subset n → ℕ
∣ p ∣ = count (_≟ inside) p

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

Nonempty : ∀ {n} (p : Subset n) → Set
Nonempty p = ∃ λ f → f ∈ p

Empty : ∀ {n} (p : Subset n) → Set
Empty p = ¬ Nonempty p

Lift : ∀ {n ℓ} → (Fin n → Set ℓ) → (Subset n → Set ℓ)
Lift P p = ∀ {x} → x ∈ p → P x


module Data.List.Relation.Membership.Proofs where

import Lvl
open import Functional
open import Data.Boolean
open import Data.Boolean.Stmt
open import Data.List
open import Data.List.Functions hiding (skip)
open import Data.List.Relation.Membership
open import Data.List.Relation.Quantification hiding (use ; skip)
open import Data.List.Relation.Quantification.Proofs
import      Data.Tuple as Tuple
open import Logic
open import Logic.Predicate
open import Logic.Propositional
open import Numeral.Natural
open import Structure.Function
open import Structure.Relator.Properties
open import Structure.Relator
open import Structure.Setoid renaming (_≡_ to _≡ₛ_)
open import Syntax.Transitivity
open import Type

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

module _ ⦃ equiv : Equiv{ℓₑ}(T) ⦄ where
  private variable l l₁ l₂ : List(T)
  private variable a b c x : T

  instance
    [∈]-relatorₗ : UnaryRelator(_∈ l)
    [∈]-relatorₗ = intro p where
      p : Names.Substitution₁(_∈ l)
      p{x ⊰ _}     xy (• q) = • (symmetry(_≡ₛ_) xy 🝖 q)
      p{x ⊰ y ⊰ l} xy (⊰ q) = ⊰ p{y ⊰ l} xy q

  [∈]-self : AllElements(_∈ l)(l)
  [∈]-self {∅}     = ∅
  [∈]-self {x ⊰ l} = (• reflexivity(_≡ₛ_)) ⊰ AllElements-fn (⊰_) ([∈]-self {l})

  [∉]-empty : (a ∉ ∅)
  [∉]-empty ()

  [∈]-in-singleton : (a ∈ singleton(a))
  [∈]-in-singleton = use(reflexivity(_≡ₛ_))

  [∈]-singleton : (a ∈ singleton(b)) ↔ (a ≡ₛ b)
  [∈]-singleton = [↔]-intro L R where
    L : (a ∈ singleton(b)) ← (a ≡ₛ b)
    L p = substitute₁(_∈ _) (symmetry(_≡ₛ_) p) [∈]-in-singleton

    R : (a ∈ singleton(b)) → (a ≡ₛ b)
    R(use p) = p
    R(skip ())

  [∈][++] : (a ∈ (l₁ ++ l₂)) ↔ ((a ∈ l₁) ∨ (a ∈ l₂))
  [∈][++] = [↔]-intro L R where
    L : (a ∈ (l₁ ++ l₂)) ← ((a ∈ l₁) ∨ (a ∈ l₂))
    L {l₁ = ∅}      ([∨]-introᵣ p)     = p
    L {l₁ = x ⊰ l₁} ([∨]-introₗ (• p)) = • p
    L {l₁ = x ⊰ l₁} ([∨]-introₗ (⊰ p)) = ⊰ L {l₁ = l₁} ([∨]-introₗ p)
    L {l₁ = x ⊰ l₁} ([∨]-introᵣ p)     = ⊰ L {l₁ = l₁} ([∨]-introᵣ p)

    R : (a ∈ (l₁ ++ l₂)) → ((a ∈ l₁) ∨ (a ∈ l₂))
    R {l₁ = ∅}      p     = [∨]-introᵣ p
    R {l₁ = x ⊰ l₁} (• p) = [∨]-introₗ (• p)
    R {l₁ = x ⊰ l₁} (⊰ p) with R {l₁ = l₁} p
    ... | [∨]-introₗ q = [∨]-introₗ (⊰ q)
    ... | [∨]-introᵣ q = [∨]-introᵣ q

  [∈]-postpend : (a ∈ postpend a l)
  [∈]-postpend{l = ∅}     = use (reflexivity(_≡ₛ_))
  [∈]-postpend{l = _ ⊰ l} = skip([∈]-postpend{l = l})

  {-
  open import Data.Boolean.Proofs
  [∈]-filter : ∀{f} ⦃ func : Function(f) ⦄ → (a ∈ filter f(l)) ↔ ((a ∈ l) ∧ IsTrue(f(a)))
  [∈]-filter{l = ll}{f = f} = [↔]-intro (Tuple.uncurry L) (x ↦ [∧]-intro (R₁ x) (R₂{l = ll} x)) where
    postulate L : (a ∈ l) → IsTrue(f(a)) → (a ∈ filter f(l))
    {-L {a = a}{l = x ⊰ ∅}     (• p) t with _ ← substitute₁ ⦃ {![≡]-equiv {T = Bool}!} ⦄ (IsTrue) ⦃ {!!} ⦄ p t | 𝑇 ← f(x) = {!!}
    L {a = a}{l = x ⊰ y ⊰ l} (• p) _ = {!!}
    L {a = a}{l = x ⊰ y ⊰ l} (⊰ p) _ = {!!}-}

    postulate R₁ : (a ∈ filter f(l)) → (a ∈ l)
    -- R₁ {l = x ⊰ ∅} p = {!p!}
    -- R₁ {l = x ⊰ x₁ ⊰ l} p = {!!}

    postulate R₂ : (a ∈ filter f(l)) → IsTrue(f(a))
  -}

module _ ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄ ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄ where
  private variable f : A → B
  private variable l l₁ l₂ : List(T)
  private variable a b c x : T

  [∈]-map : ⦃ func-f : Function(f) ⦄ → (a ∈ l) → (f(a) ∈ (map f(l)))
  [∈]-map {f = f} (use p)  = use (congruence₁(f) p)
  [∈]-map         (skip p) = skip([∈]-map p)

{- TODO: Stuff below is supposed to be moved to Structure.Sets.Proofs

[∈][++]-expandₗ : (a ∈ l₂) → (a ∈ (l₁ ++ l₂))
[∈][++]-expandₗ {l₂ = l₂}{l₁ = l₁} = [↔]-to-[←] ([∈][++] {l₁ = l₁}{l₂ = l₂}) ∘ [∨]-introᵣ

[∈][++]-expandᵣ : (a ∈ l₁) → (a ∈ (l₁ ++ l₂))
[∈][++]-expandᵣ {l₁ = l₁}{l₂ = l₂} = [↔]-to-[←] ([∈][++] {l₁ = l₁}{l₂ = l₂}) ∘ [∨]-introₗ

[∈][⊰]-reorderₗ : (a ∈ (l₁ ++ (x ⊰ l₂))) → (a ∈ (x ⊰ (l₁ ++ l₂)))
[∈][⊰]-reorderₗ (a∈l₁++xl₂) = [∨]-elim left right ([↔]-to-[→] [∈]-[++] (a∈l₁++xl₂)) where
  left : (a ∈ l₁) → (a ∈ (x ⊰ (l₁ ++ l₂)))
  left (a∈l₁) = [∈][⊰]-expand ([∈][++]-expandᵣ {a}{l₁}{l₂} (a∈l₁))

  right : ∀{a} → (a ∈ (x ⊰ l₂)) → (a ∈ (x ⊰ (l₁ ++ l₂)))
  {-right ([∈]-id)              = use
  right ([∈][⊰]-expand (a∈l₂)) = [∈][⊰]-expand ([∈][++]-expandₗ {_}{l₁}{l₂} (a∈l₂))-}

-- [∈][⊰]-reorderᵣ : ∀{a x}{l₁ l₂} → (a ∈ (x ⊰ (l₁ ++ l₂))) → (a ∈ (l₁ ++ (x ⊰ l₂)))
-- [∈][⊰]-reorderᵣ {a}{x}{l₁}{l₂} ([∈]-id) =
-- [∈][⊰]-reorderᵣ {a}{x}{l₁}{l₂} ([∈][⊰]-expand (a∈l₁++l₂)) =

[∈]-in-middle : (a ∈ (l₁ ++ singleton(a) ++ l₂))
[∈]-in-middle{a}{l₁}{l₂} = [↔]-to-[←] ([∈]-[++] {a}{l₁ ++ singleton(a)}{l₂}) ([∨]-introₗ ([∈]-at-last{l = l₁}))

module _ where
  private variable ℓ₂ : Lvl.Level

  [⊆]-substitution : ∀{l₁ l₂ : List(T)} → (l₁ ⊆ l₂) → ∀{P : T → Stmt{ℓ₂}} → (∀{a} → (a ∈ l₂) → P(a)) → (∀{a} → (a ∈ l₁) → P(a))
  [⊆]-substitution (l₁⊆l₂) proof = proof ∘ (l₁⊆l₂)

  [⊇]-substitution : ∀{l₁ l₂ : List(T)} → (l₁ ⊇ l₂) → ∀{P : T → Stmt{ℓ₂}} → (∀{a} → (a ∈ l₁) → P(a)) → (∀{a} → (a ∈ l₂) → P(a))
  [⊇]-substitution (l₁⊇l₂) proof = proof ∘ (l₁⊇l₂)

  [≡]-substitutionₗ : ∀{l₁ l₂ : List(T)} → (l₁ ≡ l₂) → ∀{P : T → Stmt{ℓ₂}} → (∀{a} → (a ∈ l₁) → P(a)) → (∀{a} → (a ∈ l₂) → P(a))
  [≡]-substitutionₗ (l₁≡l₂) = [⊆]-substitution ([↔]-to-[←] (l₁≡l₂))

  [≡]-substitutionᵣ : ∀{l₁ l₂ : List(T)} → (l₁ ≡ l₂) → ∀{P : T → Stmt{ℓ₂}} → (∀{a} → (a ∈ l₂) → P(a)) → (∀{a} → (a ∈ l₁) → P(a))
  [≡]-substitutionᵣ (l₁≡l₂) = [⊆]-substitution ([↔]-to-[→] (l₁≡l₂))
-}

{-
open import Structure.Relator.Properties

instance
  [⊆]-reflexivity : Reflexivity(_⊆_)
  Reflexivity.proof [⊆]-reflexivity = id

instance
  [⊆]-antisymmetry : Antisymmetry(_⊆_)(_≡_)
  Antisymmetry.proof [⊆]-antisymmetry = swap [↔]-intro

instance
  [⊆]-transitivity : Transitivity(_⊆_)
  Transitivity.proof [⊆]-transitivity xy yz = yz ∘ xy

instance
  [⊆]-reflexivity : Reflexivity(_⊆_)

[≡]-reflexivity : ∀{L} → (L ≡ L)
-- [≡]-reflexivity = [↔]-intro [⊆]-reflexivity [⊆]-reflexivity

[≡]-symmetry : ∀{l₁ l₂} → (l₁ ≡ l₂) → (l₂ ≡ l₁)
[≡]-symmetry (l₁≡l₂) {x} with (l₁≡l₂){x}
... | [↔]-intro l r = [↔]-intro r l

[≡]-transitivity : ∀{l₁ l₂ L₃} → (l₁ ≡ l₂) → (l₂ ≡ L₃) → (l₁ ≡ L₃)
[≡]-transitivity (l₁≡l₂) (l₂≡L₃) {x} with [∧]-intro ((l₁≡l₂){x}) ((l₂≡L₃){x})
... | ([∧]-intro (lr₁) (lr₂)) = [↔]-transitivity  (lr₁) (lr₂)

-- [⊆]-application : ∀{l₁ l₂} → (l₁ ⊆ l₂) → ∀{f} → (map f(l₁))⊆(map f(l₂))
-- [⊆]-application proof fl₁ = [∈]-proof.application ∘ proof
-- (∀{x} → (x ∈ l₂) → (x ∈ l₁)) → ∀{f} → (∀{x} → (x ∈ map f(l₂)) → (x ∈ map f(l₁)))

{-
[≡]-included-in : ∀{L : List(T)}{x} → (x ∈ L) → ((x ⊰ L) ≡ L)
[≡]-included-in xL = [⊆]-antisymmetry (sub xL) (super xL) where
  super : ∀{L : List(T)}{x} → (x ∈ L) → ((x ⊰ L) ⊇ L)
  super [∈]-id  [∈]-id  = [∈]-id
  super [∈]-id  (skip p) = skip ?
  super (skip p) [∈]-id  = skip(use ?)
  super (skip p ) (skip q) = skip(skip ?)

  sub : ∀{L : List(T)}{x} → (x ∈ L) → ((x ⊰ L) ⊆ L)
  sub use  use          = use
  sub use  (skip ⦃ p ⦄) = p
  sub skip use          = skip
  sub skip (skip ⦃ p ⦄) = p
-}

postulate [≡]-included-subset : ∀{l₁ l₂ : List(T)} → (l₁ ⊆ l₂) → ((l₁ ++ l₂) ≡ l₂)

postulate [≡]-subset-[++] : ∀{L l₁ l₂ : List(T)} → (l₁ ⊆ L) → (l₂ ⊆ L) → (l₁ ++ l₂ ⊆ L)

[⊆]-with-[⊰] : ∀{l₁ l₂ : List(T)} → (l₁ ⊆ l₂) → ∀{b} → (l₁ ⊆ (b ⊰ l₂))
[⊆]-with-[⊰] (l₁⊆l₂) (x∈l₁) = [∈][⊰]-expand ((l₁⊆l₂) (x∈l₁))

[⊆]-with-[++]ₗ : ∀{l₁ l₂ : List(T)} → (l₁ ⊆ l₂) → ∀{L₃} → (l₁ ⊆ (L₃ ++ l₂))
-- [⊆]-with-[++]ₗ {l₁}{l₂} (l₁⊆l₂) {L₃} (x∈l₁) = [∈][++]-expandₗ {_}{L₃}{l₂} ((l₁⊆l₂) (x∈l₁))

[⊆]-with-[++]ᵣ : ∀{l₁ l₂ : List(T)} → (l₁ ⊆ l₂) → ∀{L₃} → (l₁ ⊆ (l₂ ++ L₃))
[⊆]-with-[++]ᵣ {l₁}{l₂} (l₁⊆l₂) {L₃} (x∈l₁) = [∈][++]-expandᵣ {_}{l₂}{L₃} ((l₁⊆l₂) (x∈l₁))

-- TODO: Does this work? It would be easier to "port" all (∈)-theorems to (⊆)-theorems then.
-- [∈]-to-[⊆]-property : ∀{l₂}{f : List(T) → List(T)} → (∀{a} → (a ∈ l₂) → (a ∈ f(l₂))) → (∀{l₁} → (l₁ ⊆ l₂) → (l₁ ⊆ f(l₂)))

-}

module _ where
  open import Relator.Equals as Id
  open import Relator.Equals.Proofs.Equiv

  non-empty-inclusion-existence : ∀{l : List(T)} → (l Id.≢ ∅) → ∃(_∈ l)
  non-empty-inclusion-existence {l = ∅}     p with () ← p(reflexivity(Id._≡_))
  non-empty-inclusion-existence {l = x ⊰ l} p = [∃]-intro x ⦃ •(reflexivity(Id._≡_)) ⦄


------------------------------------------------------------------------------
-- Twice funcion
------------------------------------------------------------------------------

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

module LTC-PCF.Twice where

open import LTC-PCF.Base

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

twice : (D → D) → D → D
twice f x = f (f x)

twice-succ : ∀ n → twice succ₁ n ≡ succ₁ (succ₁ n)
twice-succ n = refl


{-# OPTIONS --without-K #-}
open import HoTT.Base
open import HoTT.Equivalence
open import HoTT.Identity.Pi

module HoTT.Sigma.Universal where

Σ-univ : ∀ {i j k} {X : 𝒰 i} {A : X → 𝒰 j} (P : (x : X) → A x → 𝒰 k) →
         ((x : X) → Σ (A x) λ a → P x a) ≃
         (Σ ((x : X) → A x) λ g → (x : X) → P x (g x))
Σ-univ _ = let open Iso in iso→eqv λ where
  .f h → pr₁ ∘ h , pr₂ ∘ h
  .g h x → pr₁ h x , pr₂ h x
  .η h → funext (Σ-uniq ∘ h)
  .ε h → Σ-uniq h


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

module Categories.Enriched.Over.One where

open import Level

open import Categories.Category.Monoidal.Instance.One
open import Categories.Enriched.Category

TruthValue : (o ℓ e t : Level) → Set (o ⊔ ℓ ⊔ e ⊔ suc t)
TruthValue o ℓ e t = Category (One-Monoidal {o} {ℓ} {e}) t


module HasDecidableSalvation where

open import OscarPrelude
open import HasSalvation

record HasDecidableSalvation (A : Set) : Set₁
 where
  field
    ⦃ hasSalvation ⦄ : HasSalvation A
    ▷?_ : (x : A) → Dec $ ▷ x

open HasDecidableSalvation ⦃ … ⦄ public

{-# DISPLAY HasDecidableSalvation.▷?_ _ = ▷?_ #-}


module Functors.FullyFaithful where

open import Library
open import Categories
open import Functors
open import Naturals hiding (Iso)
open import Isomorphism

open Cat
open Fun

FullyFaithful : ∀{a b c d}{C : Cat {a}{b}}{D : Cat {c}{d}}
                (F : Fun C D) → Set (a ⊔ b ⊔ d)
FullyFaithful {C = C}{D = D} F =
  ∀ (X Y : Obj C) → Iso (Hom D (OMap F X) (OMap F Y)) (Hom C X Y)

Full : ∀{a b c d}{C : Cat {a}{b}}{D : Cat {c}{d}}
                (F : Fun C D) → Set _
Full {C = C}{D = D} F = ∀ {X Y}(h : Hom D (OMap F X) (OMap F Y)) →
  Σ (Hom C X Y) \ f -> HMap F f ≅ h

Faithful : ∀{a b c d}{C : Cat {a}{b}}{D : Cat {c}{d}}
                (F : Fun C D) → Set _
Faithful {C = C}{D = D} F = ∀{X Y}{f g : Hom C X Y} → HMap F f ≅ HMap F g → f ≅ g


module Oscar.Property.Reflexivity where

open import Oscar.Level

record Reflexivity {𝔬} {⋆ : Set 𝔬} {ℓ} (_≣_ : ⋆ → ⋆ → Set ℓ) : Set (𝔬 ⊔ ℓ) where
  field
    reflexivity : ∀ x → x ≣ x

open Reflexivity ⦃ … ⦄ public