{-

This file contains:

- Properties of groupoid truncations

-}
{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.GroupoidTruncation.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.HITs.GroupoidTruncation.Base

recGroupoidTrunc : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} (gB : isGroupoid B) → (A → B) → (∥ A ∥₁ → B)
recGroupoidTrunc gB f ∣ x ∣₁ = f x
recGroupoidTrunc gB f (squash₁ _ _ _ _ r s i j k) =
  gB _ _ _ _
    (λ m n → recGroupoidTrunc gB f (r m n))
    (λ m n → recGroupoidTrunc gB f (s m n))
    i j k

groupoidTruncFib : ∀ {ℓ ℓ'} {A : Type ℓ} (P : A → Type ℓ')
              {a b : A} (sPb : isGroupoid (P b))
              {p q : a ≡ b} {r s : p ≡ q} (u : r ≡ s) {a1 : P a} {b1 : P b}
              {p1 : PathP (λ i → P (p i)) a1 b1}
              {q1 : PathP (λ i → P (q i)) a1 b1}
              (r1 : PathP (λ i → PathP (λ j → P (r i j)) a1 b1) p1 q1)
              (s1 : PathP (λ i → PathP (λ j → P (s i j)) a1 b1) p1 q1)
            → PathP (λ i → PathP (λ j → PathP (λ k → P (u i j k)) a1 b1) p1 q1) r1 s1
groupoidTruncFib P {a} {b} sPb u {a1} {b1} {p1} {q1} r1 s1 i j k =
  hcomp (λ l → λ { (i = i0) → r1 j k
                 ; (i = i1) → s1 j k
                 ; (j = i0) → p1 k
                 ; (j = i1) → q1 k
                 ; (k = i0) → a1
                 ; (k = i1) → sPb b1 b1 refl refl (λ i j → Lb i j i1) refl l i j
                 })
        (Lb i j k)
  where
  L : (i j : I) → P b
  L i j = comp (λ k → P (u i j k))
               (λ k → λ { (i = i0) → r1 j k
                        ; (i = i1) → s1 j k
                        ; (j = i0) → p1 k
                        ; (j = i1) → q1 k })
               a1
  Lb : PathP (λ i → PathP (λ j → PathP (λ k → P (u i j k)) a1 (L i j)) p1 q1) r1 s1
  Lb i j k = fill (λ k → P (u i j k))
                  (λ k → λ { (i = i0) → r1 j k
                           ; (i = i1) → s1 j k
                           ; (j = i0) → p1 k
                           ; (j = i1) → q1 k })
                  (inS a1) k

groupoidTruncElim : ∀ {ℓ ℓ'} (A : Type ℓ) (B : ∥ A ∥₁ → Type ℓ')
                    (bG : (x : ∥ A ∥₁) → isGroupoid (B x))
                    (f : (x : A) → B ∣ x ∣₁) (x : ∥ A ∥₁) → B x
groupoidTruncElim A B bG f (∣ x ∣₁) = f x
groupoidTruncElim A B bG f (squash₁ x y p q r s i j k) =
  groupoidTruncFib B (bG y)
                   (squash₁ x y p q r s)
                   (λ i j → groupoidTruncElim A B bG f (r i j))
                   (λ i j → groupoidTruncElim A B bG f (s i j))
                   i j k


{-# OPTIONS --safe #-}
module Cubical.HITs.Sn.Properties where

open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Path
open import Cubical.Foundations.Function
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Univalence
open import Cubical.HITs.S1 renaming (_·_ to _*_)
open import Cubical.Data.Nat hiding (elim)
open import Cubical.Data.Sigma
open import Cubical.HITs.Sn.Base
open import Cubical.HITs.Susp
open import Cubical.HITs.Truncation
-- open import Cubical.Homotopy.Loopspace
open import Cubical.Homotopy.Connected
open import Cubical.HITs.Join
open import Cubical.Data.Bool

private
  variable
    ℓ : Level

IsoSucSphereSusp : (n : ℕ) → Iso (S₊ (suc n)) (Susp (S₊ n))
IsoSucSphereSusp zero = S¹IsoSuspBool
IsoSucSphereSusp (suc n) = idIso

-- Elimination principles for spheres
sphereElim : (n : ℕ) {A : (S₊ (suc n)) → Type ℓ} → ((x : S₊ (suc n)) → isOfHLevel (suc n) (A x))
          → A (ptSn (suc n))
          → (x : S₊ (suc n)) → A x
sphereElim zero hlev pt = toPropElim hlev pt
sphereElim (suc n) hlev pt north = pt
sphereElim (suc n) {A = A} hlev pt south = subst A (merid (ptSn (suc n))) pt
sphereElim (suc n) {A = A} hlev pt (merid a i) =
  sphereElim n {A = λ a → PathP (λ i → A (merid a i)) pt (subst A (merid (ptSn (suc n))) pt)}
               (λ a → isOfHLevelPathP' (suc n) (hlev south) _ _)
               (λ i → transp (λ j → A (merid (ptSn (suc n)) (i ∧ j))) (~ i) pt)
               a i

sphereElim2 : ∀ {ℓ} (n : ℕ) {A : (S₊ (suc n)) → (S₊ (suc n)) → Type ℓ}
          → ((x y : S₊ (suc n)) → isOfHLevel (suc n) (A x y))
          → A (ptSn (suc n)) (ptSn (suc n))
          → (x y : S₊ (suc n)) → A x y
sphereElim2 n hlev pt = sphereElim n (λ _ → isOfHLevelΠ (suc n) λ _ → hlev _ _)
                                     (sphereElim n (hlev _ ) pt)

private
  compPath-lem : ∀ {ℓ} {A : Type ℓ} {x y z : A} (p : x ≡ y) (q : z ≡ y)
              → PathP (λ i → (p ∙ sym q) i ≡ y) p q
  compPath-lem {y = y} p q i j =
    hcomp (λ k → λ { (i = i0) → p j
                    ; (i = i1) → q (~ k ∨ j)
                    ; (j = i1) → y })
          (p (j ∨ i))

sphereToPropElim : (n : ℕ) {A : (S₊ (suc n)) → Type ℓ} → ((x : S₊ (suc n)) → isProp (A x))
          → A (ptSn (suc n))
          → (x : S₊ (suc n)) → A x
sphereToPropElim zero = toPropElim
sphereToPropElim (suc n) hlev pt north = pt
sphereToPropElim (suc n) {A = A} hlev pt south = subst A (merid (ptSn (suc n))) pt
sphereToPropElim (suc n) {A = A} hlev pt (merid a i) =
  isProp→PathP {B = λ i → A (merid a i)} (λ _ → hlev _) pt (subst A (merid (ptSn (suc n))) pt) i

-- Elimination rule for fibrations (x : Sⁿ) → (y : Sᵐ) → A x y of h-Level (n + m).
-- The following principle is just the special case of the "Wedge Connectivity Lemma"
-- for spheres (See Cubical.Homotopy.WedgeConnectivity or chapter 8.6 in the HoTT book).
-- We prove it directly here for three reasons:
-- (i) it should perform better
-- (ii) we get a slightly stronger statement for spheres: one of the homotopies will, by design, be refl
-- (iii) the fact that the two homotopies only differ by (composition with) the homotopy leftFunction(base) ≡ rightFunction(base)
-- is close to trivial

wedgeconFun : (n m : ℕ) {A : (S₊ (suc n)) → (S₊ (suc m)) → Type ℓ}
          → ((x : S₊ (suc n)) (y : S₊ (suc m)) → isOfHLevel ((suc n) + (suc m)) (A x y))
          → (f : (x : _) → A (ptSn (suc n)) x)
          → (g : (x : _) → A x (ptSn (suc m)))
          → (g (ptSn (suc n)) ≡ f (ptSn (suc m)))
          → (x : S₊ (suc n)) (y : S₊ (suc m)) → A x y
wedgeconLeft : (n m : ℕ) {A : (S₊ (suc n)) → (S₊ (suc m)) → Type ℓ}
             → (hLev : ((x : S₊ (suc n)) (y : S₊ (suc m)) → isOfHLevel ((suc n) + (suc m)) (A x y)))
             → (f : (x : _) → A (ptSn (suc n)) x)
             → (g : (x : _) → A x (ptSn (suc m)))
             → (hom : g (ptSn (suc n)) ≡ f (ptSn (suc m)))
             → (x : _) → wedgeconFun n m hLev f g hom (ptSn (suc n)) x ≡ f x
wedgeconRight : (n m : ℕ) {A : (S₊ (suc n)) → (S₊ (suc m)) → Type ℓ}
             → (hLev : ((x : S₊ (suc n)) (y : S₊ (suc m)) → isOfHLevel ((suc n) + (suc m)) (A x y)))
             → (f : (x : _) → A (ptSn (suc n)) x)
             → (g : (x : _) → A x (ptSn (suc m)))
             → (hom : g (ptSn (suc n)) ≡ f (ptSn (suc m)))
             → (x : _) → wedgeconFun n m hLev f g hom x (ptSn (suc m)) ≡ g x
wedgeconFun zero zero {A = A} hlev f g hom = F
  where
  helper : SquareP (λ i j → A (loop i) (loop j)) (cong f loop) (cong f loop)
                        (λ i → hcomp (λ k → λ { (i = i0) → hom k
                                                ; (i = i1) → hom k })
                                      (g (loop i)))
                         λ i → hcomp (λ k → λ { (i = i0) → hom k
                                                ; (i = i1) → hom k })
                                       (g (loop i))
  helper = toPathP (isOfHLevelPathP' 1 (hlev _ _) _ _ _ _)

  F : (x y : S¹) → A x y
  F base y = f y
  F (loop i) base = hcomp (λ k → λ { (i = i0) → hom k
                                    ; (i = i1) → hom k })
                          (g (loop i))
  F (loop i) (loop j) = helper i j

wedgeconFun zero (suc m) {A = A} hlev f g hom = F₀
  module _ where
  transpLemma₀ : (x : S₊ (suc m)) → transport (λ i₁ → A base (merid x i₁)) (g base) ≡ f south
  transpLemma₀ x = cong (transport (λ i₁ → A base (merid x i₁)))
                                  hom
              ∙ (λ i → transp (λ j → A base (merid x (i ∨ j))) i
                               (f (merid x i)))

  pathOverMerid₀ : (x : S₊ (suc m)) → PathP (λ i₁ → A base (merid x i₁))
                                            (g base)
                                            (transport (λ i₁ → A base (merid (ptSn (suc m)) i₁))
                                                       (g base))
  pathOverMerid₀ x i = hcomp (λ k → λ { (i = i0) → g base
                                      ; (i = i1) → (transpLemma₀ x ∙ sym (transpLemma₀ (ptSn (suc m)))) k})
                            (transp (λ i₁ → A base (merid x (i₁ ∧ i))) (~ i)
                                    (g base))

  pathOverMeridId₀ : pathOverMerid₀ (ptSn (suc m)) ≡ λ i → transp (λ i₁ → A base (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i)
                                                                 (g base)
  pathOverMeridId₀  =
       (λ j i → hcomp (λ k → λ {(i = i0) → g base
                               ; (i = i1) → rCancel (transpLemma₀ (ptSn (suc m))) j k})
                      (transp (λ i₁ → A base (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i)
                              (g base)))
     ∙ λ j i → hfill (λ k → λ { (i = i0) → g base
                                ; (i = i1) → transport (λ i₁ → A base (merid (ptSn (suc m)) i₁))
                                                        (g base)})
                      (inS (transp (λ i₁ → A base (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i)
                                   (g base))) (~ j)

  indStep₀ : (x : _) (a : _) → PathP (λ i → A x (merid a i))
                                             (g x)
                                             (subst (λ y → A x y) (merid (ptSn (suc m)))
                                                    (g x))
  indStep₀ = wedgeconFun zero m (λ _ _ → isOfHLevelPathP' (2 + m) (hlev _ _) _ _)
                              pathOverMerid₀
                              (λ a i → transp (λ i₁ → A a (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i)
                                               (g a))
                              (sym pathOverMeridId₀)

  F₀ : (x : S¹) (y : Susp (S₊ (suc m))) → A x y
  F₀ x north = g x
  F₀ x south = subst (λ y → A x y) (merid (ptSn (suc m))) (g x)
  F₀ x (merid a i) = indStep₀ x a i
wedgeconFun (suc n) m {A = A} hlev f g hom = F₁
  module _ where
  transpLemma₁ : (x : S₊ (suc n)) → transport (λ i₁ → A (merid x i₁) (ptSn (suc m))) (f (ptSn (suc m))) ≡ g south
  transpLemma₁ x = cong (transport (λ i₁ → A (merid x i₁) (ptSn (suc m))))
                       (sym hom)
                ∙ (λ i → transp (λ j → A (merid x (i ∨ j)) (ptSn (suc m))) i
                                 (g (merid x i)))

  pathOverMerid₁ : (x : S₊ (suc n)) → PathP (λ i₁ → A (merid x i₁) (ptSn (suc m)))
                                            (f (ptSn (suc m)))
                                            (transport (λ i₁ → A (merid (ptSn (suc n)) i₁) (ptSn (suc m)))
                                                       (f (ptSn (suc m))))
  pathOverMerid₁ x i = hcomp (λ k → λ { (i = i0) → f (ptSn (suc m))
                                      ; (i = i1) → (transpLemma₁ x ∙ sym (transpLemma₁ (ptSn (suc n)))) k })
                            (transp (λ i₁ → A (merid x (i₁ ∧ i)) (ptSn (suc m))) (~ i)
                                    (f (ptSn (suc m))))

  pathOverMeridId₁ : pathOverMerid₁ (ptSn (suc n)) ≡ λ i → transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) (ptSn (suc m))) (~ i)
                                                                 (f (ptSn (suc m)))
  pathOverMeridId₁ =
        (λ j i → hcomp (λ k → λ { (i = i0) → f (ptSn (suc m))
                                  ; (i = i1) → rCancel (transpLemma₁ (ptSn (suc n))) j k })
                        (transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) (ptSn (suc m))) (~ i)
                                (f (ptSn (suc m)))))
       ∙ λ j i → hfill (λ k → λ { (i = i0) → f (ptSn (suc m))
                                  ; (i = i1) → transport (λ i₁ → A (merid (ptSn (suc n)) i₁) (ptSn (suc m)))
                                                          (f (ptSn (suc m))) })
                        (inS (transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) (ptSn (suc m))) (~ i)
                                     (f (ptSn (suc m))))) (~ j)

  indStep₁ : (a : _) (y : _) → PathP (λ i → A (merid a i) y)
                                             (f y)
                                             (subst (λ x → A x y) (merid (ptSn (suc n)))
                                                    (f y))
  indStep₁ = wedgeconFun n m (λ _ _ → isOfHLevelPathP' (suc (n + suc m)) (hlev _ _) _ _)
                           (λ a i → transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) a) (~ i)
                                            (f a))
                           pathOverMerid₁
                           pathOverMeridId₁

  F₁ : (x : Susp (S₊ (suc n))) (y : S₊ (suc m))  → A x y
  F₁ north y = f y
  F₁ south y = subst (λ x → A x y) (merid (ptSn (suc n))) (f y)
  F₁ (merid a i) y = indStep₁ a y i
wedgeconRight zero zero {A = A} hlev f g hom = right
  where
  right : (x : S¹) → _
  right base = sym hom
  right (loop i) j = hcomp (λ k → λ { (i = i0) → hom (~ j ∧ k)
                                     ; (i = i1) → hom (~ j ∧ k)
                                     ; (j = i1) → g (loop i) })
                           (g (loop i))
wedgeconRight zero (suc m) {A = A} hlev f g hom x = refl
wedgeconRight (suc n) m {A = A} hlev f g hom = right
  where
  lem : (x : _) → indStep₁ n m hlev f g hom x (ptSn (suc m)) ≡ _
  lem = wedgeconRight n m (λ _ _ → isOfHLevelPathP' (suc (n + suc m)) (hlev _ _) _ _)
                           (λ a i → transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) a) (~ i)
                                            (f a))
                           (pathOverMerid₁ n m hlev f g hom)
                           (pathOverMeridId₁ n m hlev f g hom)

  right : (x : Susp (S₊ (suc n))) → _ ≡ g x
  right north = sym hom
  right south = cong (subst (λ x → A x (ptSn (suc m)))
                            (merid (ptSn (suc n))))
                            (sym hom)
              ∙ λ i → transp (λ j → A (merid (ptSn (suc n)) (i ∨ j)) (ptSn (suc m))) i
                              (g (merid (ptSn (suc n)) i))
  right (merid a i) j =
    hcomp (λ k → λ { (i = i0) → hom (~ j)
                    ; (i = i1) → transpLemma₁ n m hlev f g hom (ptSn (suc n)) j
                    ; (j = i0) → lem a (~ k) i
                    ; (j = i1) → g (merid a i)})
          (hcomp (λ k →  λ { (i = i0) → hom (~ j)
                            ; (i = i1) → compPath-lem (transpLemma₁ n m hlev f g hom a) (transpLemma₁ n m hlev f g hom (ptSn (suc n))) k j
                            ; (j = i1) → g (merid a i)})
                 (hcomp (λ k → λ { (i = i0) → hom (~ j)
                                  ; (j = i0) → transp (λ i₂ → A (merid a (i₂ ∧ i)) (ptSn (suc m))) (~ i)
                                                       (f (ptSn (suc m)))
                                  ; (j = i1) → transp (λ j → A (merid a (i ∧ (j ∨ k))) (ptSn (suc m))) (k ∨ ~ i)
                                                       (g (merid a (i ∧ k))) })
                        (transp (λ i₂ → A (merid a (i₂ ∧ i)) (ptSn (suc m))) (~ i)
                                (hom (~ j)))))
wedgeconLeft zero zero {A = A} hlev f g hom x = refl
wedgeconLeft zero (suc m) {A = A} hlev f g hom = help
  where
  left₁ : (x : _) → indStep₀ m hlev f g hom base x ≡ _
  left₁ = wedgeconLeft zero m (λ _ _ → isOfHLevelPathP' (2 + m) (hlev _ _) _ _)
                              (pathOverMerid₀ m hlev f g hom)
                              (λ a i → transp (λ i₁ → A a (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i)
                                               (g a))
                              (sym (pathOverMeridId₀ m hlev f g hom))

  help : (x : S₊ (suc (suc m))) → _
  help north = hom
  help south = cong (subst (A base) (merid (ptSn (suc m)))) hom
             ∙ λ i → transp (λ j → A base (merid (ptSn (suc m)) (i ∨ j))) i
                             (f (merid (ptSn (suc m)) i))
  help (merid a i) j =
    hcomp (λ k → λ { (i = i0) → hom j
                    ; (i = i1) → transpLemma₀ m hlev f g hom (ptSn (suc m)) j
                    ; (j = i0) → left₁ a (~ k) i
                    ; (j = i1) → f (merid a i)})
          (hcomp (λ k →  λ { (i = i0) → hom j
                            ; (i = i1) → compPath-lem (transpLemma₀ m hlev f g hom a)
                                                       (transpLemma₀ m hlev f g hom (ptSn (suc m))) k j
                            ; (j = i1) → f (merid a i)})
                 (hcomp (λ k → λ { (i = i0) → hom j
                                  ; (j = i0) → transp (λ i₂ → A base (merid a (i₂ ∧ i))) (~ i)
                                                       (g base)
                                  ; (j = i1) → transp (λ j → A base (merid a (i ∧ (j ∨ k)))) (k ∨ ~ i)
                                                       (f (merid a (i ∧ k)))})
                        (transp (λ i₂ → A base (merid a (i₂ ∧ i))) (~ i)
                                (hom j))))
wedgeconLeft (suc n) m {A = A} hlev f g hom _ = refl

---------- Connectedness -----------

sphereConnected : (n : HLevel) → isConnected (suc n) (S₊ n)
sphereConnected n = ∣ ptSn n ∣ , elim (λ _ → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _)
                                     (λ a → sym (spoke ∣_∣ (ptSn n)) ∙ spoke ∣_∣ a)

-- The fact that path spaces of Sn are connected can be proved directly for Sⁿ.
-- (Unfortunately, this does not work for higher paths)
pathIdTruncSⁿ : (n : ℕ) (x y : S₊ (suc n))
             → Path (hLevelTrunc (2 + n) (S₊ (suc n))) ∣ x ∣ ∣ y ∣
             → hLevelTrunc (suc n) (x ≡ y)
pathIdTruncSⁿ n = sphereElim n (λ _ → isOfHLevelΠ (suc n) λ _ → isOfHLevelΠ (suc n)  λ _ → isOfHLevelTrunc (suc n))
                     (sphereElim n (λ _ → isOfHLevelΠ (suc n)  λ _ → isOfHLevelTrunc (suc n))
                       λ _ → ∣ refl ∣)

pathIdTruncSⁿ⁻ : (n : ℕ) (x y : S₊ (suc n))
             → hLevelTrunc (suc n) (x ≡ y)
             → Path (hLevelTrunc (2 + n) (S₊ (suc n))) ∣ x ∣ ∣ y ∣
pathIdTruncSⁿ⁻ n x y = rec (isOfHLevelTrunc (2 + n) _ _)
                           (J (λ y _ → Path (hLevelTrunc (2 + n) (S₊ (suc n))) ∣ x ∣ ∣ y ∣) refl)

pathIdTruncSⁿretract : (n : ℕ) (x y : S₊ (suc n)) → (p : hLevelTrunc (suc n) (x ≡ y)) → pathIdTruncSⁿ n x y (pathIdTruncSⁿ⁻ n x y p) ≡ p
pathIdTruncSⁿretract n =
  sphereElim n (λ _ → isOfHLevelΠ (suc n) λ _ → isOfHLevelΠ (suc n) λ _ → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _)
    λ y → elim (λ _ → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _)
      (J (λ y p → pathIdTruncSⁿ n (ptSn (suc n)) y (pathIdTruncSⁿ⁻ n (ptSn (suc n)) y ∣ p ∣) ≡ ∣ p ∣)
         (cong (pathIdTruncSⁿ n (ptSn (suc n)) (ptSn (suc n))) (transportRefl refl) ∙ pm-help n))
  where
  pm-help : (n : ℕ) → pathIdTruncSⁿ n (ptSn (suc n)) (ptSn (suc n)) refl  ≡ ∣ refl ∣
  pm-help zero = refl
  pm-help (suc n) = refl

isConnectedPathSⁿ : (n : ℕ) (x y : S₊ (suc n)) → isConnected (suc n) (x ≡ y)
isConnectedPathSⁿ n x y =
  isContrRetract
   (pathIdTruncSⁿ⁻ n x y)
   (pathIdTruncSⁿ n x y)
   (pathIdTruncSⁿretract n x y)
     ((isContr→isProp (sphereConnected (suc n)) ∣ x ∣ ∣ y ∣)
      , isProp→isSet (isContr→isProp (sphereConnected (suc n))) _ _ _)

-- Equivalence Sⁿ*Sᵐ≃Sⁿ⁺ᵐ⁺¹
IsoSphereJoin : (n m : ℕ)
  → Iso (join (S₊ n) (S₊ m)) (S₊ (suc (n + m)))
IsoSphereJoin zero m =
  compIso join-comm
    (compIso (invIso Susp-iso-joinBool)
             (invIso (IsoSucSphereSusp m)))
IsoSphereJoin (suc n) m =
  compIso (Iso→joinIso
            (subst (λ x → Iso (S₊ (suc x)) (join (S₊ n) Bool))
                   (+-comm n 0) (invIso (IsoSphereJoin n 0)))
            idIso)
          (compIso (equivToIso joinAssocDirect)
            (compIso (Iso→joinIso idIso
                      (compIso join-comm
                       (compIso (invIso Susp-iso-joinBool)
                                (invIso (IsoSucSphereSusp m)))))
                (compIso
                  (IsoSphereJoin n (suc m))
                    (pathToIso λ i → S₊ (suc (+-suc n m i))))))

-- Some lemmas on the H
rUnitS¹ : (x : S¹) → x * base ≡ x
rUnitS¹ base = refl
rUnitS¹ (loop i₁) = refl

commS¹ : (a x : S¹) → a * x ≡ x * a
commS¹ = wedgeconFun _ _ (λ _ _ → isGroupoidS¹ _ _)
         (sym ∘ rUnitS¹)
         rUnitS¹
         refl

SuspS¹-hom : (a x : S¹)
  → Path (Path (hLevelTrunc 4 (S₊ 2)) _ _)
          (cong ∣_∣ₕ (merid (a * x) ∙ sym (merid base)))
          (cong ∣_∣ₕ (merid a ∙ sym (merid base))
        ∙ (cong ∣_∣ₕ (merid x ∙ sym (merid base))))
SuspS¹-hom = wedgeconFun _ _ (λ _ _ → isOfHLevelTrunc 4 _ _ _ _)
           (λ x → lUnit _
                 ∙ cong (_∙ cong ∣_∣ₕ (merid x ∙ sym (merid base)))
                        (cong (cong ∣_∣ₕ) (sym (rCancel (merid base)))))
           (λ x → (λ i → cong ∣_∣ₕ (merid (rUnitS¹ x i) ∙ sym (merid base)))
               ∙∙ rUnit _
               ∙∙ cong (cong ∣_∣ₕ (merid x ∙ sym (merid base)) ∙_)
                       (cong (cong ∣_∣ₕ) (sym (rCancel (merid base)))))
           (sym (l (cong ∣_∣ₕ (merid base ∙ sym (merid base)))
                (cong (cong ∣_∣ₕ) (sym (rCancel (merid base))))))
  where
  l : ∀ {ℓ} {A : Type ℓ} {x : A} (p : x ≡ x) (P : refl ≡ p)
    → lUnit p ∙ cong (_∙ p) P ≡ rUnit p ∙ cong (p ∙_) P
  l p = J (λ p P → lUnit p ∙ cong (_∙ p) P ≡ rUnit p ∙ cong (p ∙_) P) refl

rCancelS¹ : (x : S¹) → ptSn 1 ≡ x * (invLooper x)
rCancelS¹ base = refl
rCancelS¹ (loop i) j =
  hcomp (λ r → λ {(i = i0) → base ; (i = i1) → base ; (j = i0) → base})
        base

SuspS¹-inv : (x : S¹) → Path (Path (hLevelTrunc 4 (S₊ 2)) _ _)
                         (cong ∣_∣ₕ (merid (invLooper x) ∙ sym (merid base)))
                         (cong ∣_∣ₕ (sym (merid x ∙ sym (merid base))))
SuspS¹-inv x = (lUnit _
       ∙∙ cong (_∙ cong ∣_∣ₕ (merid (invLooper x) ∙ sym (merid base)))
               (sym (lCancel (cong ∣_∣ₕ (merid x ∙ sym (merid base)))))
                  ∙∙ sym (assoc _ _ _))
       ∙∙ cong (sym (cong ∣_∣ₕ (merid x ∙ sym (merid base))) ∙_) lem
       ∙∙ (assoc _ _ _
       ∙∙ cong (_∙ (cong ∣_∣ₕ (sym (merid x ∙ sym (merid base)))))
               (lCancel (cong ∣_∣ₕ (merid x ∙ sym (merid base))))
       ∙∙ sym (lUnit _))
  where
  lem : cong ∣_∣ₕ (merid x ∙ sym (merid base))
      ∙ cong ∣_∣ₕ (merid (invLooper x) ∙ sym (merid base))
     ≡ cong ∣_∣ₕ (merid x ∙ sym (merid base))
     ∙ cong ∣_∣ₕ (sym (merid x ∙ sym (merid base)))
  lem = sym (SuspS¹-hom x (invLooper x))
     ∙ ((λ i → cong ∣_∣ₕ (merid (rCancelS¹ x (~ i)) ∙ sym (merid base)))
     ∙ cong (cong ∣_∣ₕ) (rCancel (merid base))) ∙ sym (rCancel _)


{-# OPTIONS --without-K --safe #-}
module Categories.Functor.Properties where

-- Properties valid of all Functors
open import Level
open import Data.Product using (proj₁; proj₂; _,_; _×_; Σ)
open import Function.Surjection using (Surjective)
open import Function.Equivalence using (Equivalence)
open import Function.Equality using (Π; _⟶_; _⟨$⟩_; cong)
open import Relation.Binary using (_Preserves_⟶_)
open import Relation.Nullary

open import Categories.Category
open import Categories.Functor
import Categories.Morphism as Morphism
import Categories.Morphism.Reasoning as Reas
open import Categories.Morphism.IsoEquiv as IsoEquiv
open import Categories.Morphism.Isomorphism

private
  variable
    o ℓ e o′ ℓ′ e′ : Level
    C D : Category o ℓ e

Contravariant : ∀ (C : Category o ℓ e) (D : Category o′ ℓ′ e′) → Set _
Contravariant C D = Functor (Category.op C) D

Faithful : Functor C D → Set _
Faithful {C = C} {D = D} F = ∀ {X Y} → (f g : C [ X , Y ]) → D [ F₁ f ≈ F₁ g ] → C [ f ≈ g ]
  where open Functor F

Full : Functor C D → Set _
Full {C = C} {D = D} F = ∀ {X Y} → Surjective {To = D.hom-setoid {F₀ X} {F₀ Y}} G
  where
    module C = Category C
    module D = Category D
    open Functor F
    G : ∀ {X Y} → (C.hom-setoid {X} {Y}) ⟶ D.hom-setoid {F₀ X} {F₀ Y}
    G = record { _⟨$⟩_ = F₁ ; cong = F-resp-≈ }

FullyFaithful : Functor C D → Set _
FullyFaithful F = Full F × Faithful F

-- Note that this is a constructive version of Essentially Surjective, which is
-- quite a strong assumption.
EssentiallySurjective : Functor C D → Set _
EssentiallySurjective {C = C} {D = D} F = (d : Category.Obj D) → Σ C.Obj (λ c → Functor.F₀ F c ≅ d)
  where
  open Morphism D
  module C = Category C

-- a series of [ Functor ]-respects-Thing combinators (with respects -> resp)

module _ (F : Functor C D) where
  private
    module C = Category C using (Obj; _∘_; _⇒_; id; module HomReasoning)
    module D = Category D
    module IsoC = IsoEquiv C
    module IsoD = IsoEquiv D
  open C hiding (_∘_)
  open Functor F
  open Morphism

  private
    variable
      A B E : Obj
      f g h i : A ⇒ B

  [_]-resp-∘ : C [ C [ f ∘ g ] ≈ h ] → D [ D [ F₁ f ∘ F₁ g ] ≈ F₁ h ]
  [_]-resp-∘ {f = f} {g = g} {h = h} eq = begin
    F₁ f D.∘ F₁ g    ≈˘⟨ homomorphism ⟩
    F₁ (C [ f ∘ g ]) ≈⟨ F-resp-≈ eq ⟩
    F₁ h             ∎
    where open D.HomReasoning

  [_]-resp-square : Definitions.CommutativeSquare C f g h i →
                    Definitions.CommutativeSquare D (F₁ f) (F₁ g) (F₁ h) (F₁ i)
  [_]-resp-square {f = f} {g = g} {h = h} {i = i} sq = begin
    D [ F₁ h ∘ F₁ f ]  ≈˘⟨ homomorphism ⟩
    F₁ (C [ h ∘ f ])   ≈⟨ F-resp-≈ sq ⟩
    F₁ (C [ i ∘ g ])   ≈⟨ homomorphism ⟩
    D [ F₁ i ∘ F₁ g ]  ∎
    where open D.HomReasoning

  [_]-resp-Iso : Iso C f g → Iso D (F₁ f) (F₁ g)
  [_]-resp-Iso {f = f} {g = g} iso = record
    { isoˡ = begin
      F₁ g D.∘ F₁ f    ≈⟨ [ isoˡ ]-resp-∘ ⟩
      F₁ C.id          ≈⟨ identity ⟩
      D.id             ∎
    ; isoʳ = begin
      F₁ f D.∘ F₁ g    ≈⟨ [ isoʳ ]-resp-∘ ⟩
      F₁ C.id          ≈⟨ identity ⟩
      D.id             ∎
    }
    where open Iso iso
          open D.HomReasoning

  [_]-resp-≅ : F₀ Preserves _≅_ C ⟶ _≅_ D
  [_]-resp-≅ i≅j = record
    { from       = F₁ from
    ; to         = F₁ to
    ; iso        = [ iso ]-resp-Iso
    }
    where open _≅_ i≅j

  [_]-resp-≃ : ∀ {f g :  _≅_ C A B} → f IsoC.≃ g → [ f ]-resp-≅ IsoD.≃ [ g ]-resp-≅
  [_]-resp-≃ ⌞ eq ⌟ = ⌞ F-resp-≈ eq ⌟

  homomorphismᵢ : ∀ {f : _≅_ C B E} {g : _≅_ C A B} → [ _∘ᵢ_ C f g ]-resp-≅ IsoD.≃ (_∘ᵢ_ D [ f ]-resp-≅ [ g ]-resp-≅ )
  homomorphismᵢ = ⌞ homomorphism ⌟

  -- Uses a strong version of Essential Surjectivity.
  EssSurj×Full×Faithful⇒Invertible : EssentiallySurjective F → Full F → Faithful F → Functor D C
  EssSurj×Full×Faithful⇒Invertible surj full faith = record
    { F₀ = λ d → proj₁ (surj d)
    ; F₁ = λ {A} {B} f →
      let (a , sa) = surj A in
      let (b , sb) = surj B in
      let module S = Surjective (full {a} {b}) in
      S.from ⟨$⟩ (_≅_.to sb) ∘ f ∘ (_≅_.from sa)
    ; identity = λ {A} →
      let ff = from full
          (a , sa) = surj A in begin
      ff ⟨$⟩ _≅_.to sa ∘ D.id ∘ _≅_.from sa ≈⟨ cong ff (E.refl⟩∘⟨ D.identityˡ) ⟩
      ff ⟨$⟩ _≅_.to sa ∘ _≅_.from sa        ≈⟨ cong ff (_≅_.isoˡ sa) ⟩
      ff ⟨$⟩ D.id                           ≈˘⟨ cong ff identity ⟩
      ff ⟨$⟩ F₁ C.id                        ≈⟨ faith _ _ (right-inverse-of full (F₁ C.id)) ⟩
      C.id ∎
    ; homomorphism = λ {X} {Y} {Z} {f} {g} →
      let
          (x , sx) = surj X
          (y , sy) = surj Y
          (z , sz) = surj Z
          fsx      = from sx
          tsz      = to sz
          ff {T₁} {T₂} = from (full {T₁} {T₂}) in
      faith _ _ (E.begin
      F₁ (ff ⟨$⟩ tsz ∘ (g ∘ f) ∘ fsx)                             E.≈⟨ right-inverse-of full _ ⟩
      (tsz ∘ (g ∘ f) ∘ fsx)                                      E.≈⟨ pullˡ (E.refl⟩∘⟨ (E.refl⟩∘⟨ introˡ (isoʳ sy))) ⟩
      (tsz ∘ g ∘ ((from sy ∘ to sy) ∘ f)) ∘ fsx                  E.≈⟨ pushʳ (E.refl⟩∘⟨ D.assoc) E.⟩∘⟨refl ⟩
      ((tsz ∘ g) ∘ (from sy ∘ (to sy ∘ f))) ∘ fsx                E.≈⟨ D.sym-assoc E.⟩∘⟨refl ⟩
      (((tsz ∘ g) ∘ from sy) ∘ (to sy ∘ f)) ∘ fsx                E.≈⟨ D.assoc ⟩
      ((tsz ∘ g) ∘ from sy) ∘ ((to sy ∘ f) ∘ fsx)                E.≈⟨ D.assoc E.⟩∘⟨ D.assoc  ⟩
      (tsz ∘ g ∘ from sy) ∘ (to sy ∘ f ∘ fsx)                    E.≈˘⟨ right-inverse-of full _ E.⟩∘⟨ right-inverse-of full _ ⟩
      F₁ (ff ⟨$⟩ tsz ∘ g ∘ from sy) ∘ F₁ (ff ⟨$⟩ to sy ∘ f ∘ fsx)  E.≈˘⟨ homomorphism ⟩
      F₁ ((ff ⟨$⟩ tsz ∘ g ∘ from sy) C.∘ (ff ⟨$⟩ to sy ∘ f ∘ fsx)) E.∎)
    ; F-resp-≈ = λ f≈g → cong (from full) (D.∘-resp-≈ʳ (D.∘-resp-≈ˡ f≈g))
    }
    where
    open Morphism._≅_
    open Morphism D
    open Reas D
    open Category D
    open Surjective
    open C.HomReasoning
    module E = D.HomReasoning

-- Functor Composition is Associative and the unit laws are found in
-- NaturalTransformation.NaturalIsomorphism, reified as associator, unitorˡ and unitorʳ.


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

{- In this module, we derive the truncations of
  * a truncated type,
  * the unit type,
  * dependent sums (and product types),
  * path spaces
  given truncations of their components.

  More commonly later on, we will be given a truncation operator Tr
  that returns a truncation for any given input type (at a fixed level).
  Instead of trying to show, say,

    Tr (Σ A (B ∘ cons (Tr A))) ≃ Σ (Tr A) (Tr ∘ B),

  directly, it turns out to be much easier to just *derive* the truncation on
  the left-hand side from Tr A and Tr ∘ B and then use unicity of truncation to
  deduce the above equivalence. Significant parts of the unicity proof would be
  duplicated in any direct proof of equivalence, while this approach allows us
  to avoid a number of manual elimination and propositional reduction steps. -}
module Universe.Trunc.TypeConstructors where

open import lib.Basics
open import lib.NType2
open import lib.Equivalences2
open import lib.types.Unit
open import lib.types.Nat hiding (_+_)
open import lib.types.Pi
open import lib.types.Sigma
open import lib.types.Paths

open import Universe.Utility.General
open import Universe.Utility.TruncUniverse

open import Universe.Trunc.Universal
open import Universe.Trunc.Basics

open trunc-ty
open trunc-props

module trunc-self {i} {n : ℕ₋₂} (A : n -Type i) where
  trunc : ∀ {j} → trunc-ty n ⟦ A ⟧ j
  trunc = record
    { type = A
    ; cons = idf _
    ; univ = λ _ → snd (ide _) }

module trunc-⊤ {n : ℕ₋₂} = trunc-self {n = n} ⊤-≤

-- *** Lemma 6.9 ***
{- The truncation of a dependent sum type (where the family depends
   only on the truncation of the first component) is the dependent sums
   of the truncations. -}
module trunc-Σ {ia ib j} {n : ℕ₋₂} {A : Type ia}
               (TrA : trunc-ty n A (ia ⊔ ib ⊔ j))
               {B : ⟦ type TrA ⟧ → Type ib}
               (TrB : (ta : ⟦ type TrA ⟧) → trunc-ty n (B ta) (ib ⊔ j)) where

  trunc : trunc-ty n (Σ A (B ∘ cons TrA)) (ib ⊔ j)
  trunc = record
    { type = Σ-≤ (type TrA) (type ∘ TrB)
    ; cons = λ {(a , b) → (cons TrA a , cons (TrB (cons TrA a)) b)}
    ; univ = snd ∘ e } where

    e : (U : n -Type _) → _
    e U =
      (⟦ Σ-≤ (type TrA) (type ∘ TrB) ⟧         → ⟦ U ⟧)  ≃⟨ curry-equiv ⟩
      ((ta : ⟦ type TrA ⟧) → ⟦ type (TrB ta) ⟧ → ⟦ U ⟧)  ≃⟨ equiv-Π-r eb ⟩
      ((ta : ⟦ type TrA ⟧) → B ta              → ⟦ U ⟧)  ≃⟨ ea ⟩
      ((a : A)             → B (cons TrA a)    → ⟦ U ⟧)  ≃⟨ curry-equiv ⁻¹ ⟩
      (Σ A (B ∘ cons TrA)                      → ⟦ U ⟧)  ≃∎ where

      ea = dup {j = ib ⊔ j} TrA (λ ta → B ta →-≤ U)
      eb = λ ta → up {j = ib ⊔ j} (TrB ta) U

-- Products are a special case of dependent sums.
module trunc-× {ia ib j} {n : ℕ₋₂} {A : Type ia} {B : Type ib}
               (TrA : trunc-ty n A (ia ⊔ ib ⊔ j))
               (TrB : trunc-ty n B (ib ⊔ j)) =
  trunc-Σ {j = j} TrA (λ _ → TrB)

-- *** Lemma 6.10 ***
{- The n-truncation of a path space is the path space of the (n+1)-truncation.
   The use of the encode-decode method is the reason why we have to assume
   elimination into Type (lsucc i): large recursion is used to define
   the type of codes. -}
module trunc-path {i j} {n : ℕ₋₂} {A : Type i} (TrA : trunc-ty (S n) A (lsucc (i ⊔ j))) where
  private
    l : ULevel
    l = i ⊔ j

    TrAA : trunc-ty (S n) (A × A) (lsucc l)
    TrAA = trunc-×.trunc {j = lsucc l} TrA TrA

    module MA  = trunc-props {j = lsucc l} {k = l} TrA
    module MAA = trunc-props {j = lsucc l} {k = l} TrAA
--    module MAL = trunc-elim {j = _} TrAA

  {- There is some Yoneda hidden here that would enable us to express the final
     equivalence e neatly as a sequence of trivial steps like in trunc-Σ;
     unfortunately we lack the necessary category theoretic framework
     in this code base. -}
  module code (U : n -Type l) where
    abstract
      {- Large recursion used here.
         Since we cannot talk about the truncation of a₀ == a₁ yet,
         we instead talk about the continuation type (a₀ == a₁ → U) → U
         for any n-type U instead. -}
      code : ⟦ type TrAA ⟧ → n -Type l
      code = rec {j = lsucc l} TrAA (n -Type-≤ l)
                 (λ {(a₀ , a₁) → (a₀ == a₁ → ⟦ U ⟧) →-≤ U})

      code-β : {a₀ a₁ : A} → ⟦ code (cons TrAA (a₀ , a₁)) ⟧
                           ≃ ((a₀ == a₁ → ⟦ U ⟧) → ⟦ U ⟧)
      code-β = coe-equiv (ap ⟦_⟧ (rec-β TrAA _))

    -- We can encode a path in the truncation, ...
    encode : {ta₀ ta₁ : ⟦ type TrA ⟧} → ta₀ == ta₁ → ⟦ code (ta₀ , ta₁) ⟧
    encode idp = MA.elim (λ ta → raise (code (ta , ta)))
                         (λ _ → <– code-β (λ f → f idp)) _

    --- ...reducing when coming from a path in the original type.
    encode-β : {a₀ a₁ : A} (p : a₀ == a₁) (f : a₀ == a₁ → ⟦ U ⟧)
             → –> code-β (encode (ap (cons TrA) p)) f == f p
    encode-β idp = app= (ap (–> code-β) (MA.elim-β _) ∙ <–-inv-r code-β _)

    -- We can decode into the U-continuation of a path in the truncation, ...
    decode : {ta₀ ta₁ : ⟦ type TrA ⟧}
           → ⟦ code (ta₀ , ta₁) ⟧ → (ta₀ == ta₁ → ⟦ U ⟧) → ⟦ U ⟧
    decode = MAA.elim
      (λ {(ta₀ , ta₁) → _ →-≤ (ta₀ == ta₁ → ⟦ U ⟧) →-≤ raise U})
      (λ _ c g → –> code-β c (g ∘ ap (cons TrA))) _ where

    -- ...reducing
    decode-β : {a₀ a₁ : A} (c : ⟦ code (cons TrAA (a₀ , a₁)) ⟧)
               (g : cons TrA a₀ == cons TrA a₁ → ⟦ U ⟧)
             → decode c g == –> code-β c (g ∘ ap (cons TrA))
    decode-β = app= ∘ app= (MAA.elim-β _)

    -- encoding followed by decoding produces the expected continuation
    decode-encode : {ta₀ ta₁ : ⟦ type TrA ⟧} (q : ta₀ == ta₁)
                    (g : ta₀ == ta₁ → ⟦ U ⟧) → decode (encode q) g == g q
    decode-encode idp = MA.elim
      (λ ta → Π-≤ (ta == ta → ⟦ U ⟧)
                  (λ g → Path-≤ (raise U) (decode (encode idp) g) (g idp)))
      (λ _ g → decode-β (encode idp) g ∙ encode-β idp (g ∘ ap (cons TrA))) _

  trunc : (a₀ a₁ : A) → trunc-ty n (a₀ == a₁) l
  trunc a₀ a₁ = record
    { type = Path-< (type TrA) (cons TrA a₀) (cons TrA a₁)
    ; cons = ap (cons TrA)
    ; univ = snd ∘ e } where

    e : (U : _) → (cons TrA a₀ == cons TrA a₁ → ⟦ U ⟧) ≃ (a₀ == a₁ → ⟦ U ⟧)
    e U = equiv u v u-v v-u where
      open code U

      u : (cons TrA a₀ == cons TrA a₁ → ⟦ U ⟧) → a₀ == a₁ → ⟦ U ⟧
      u g = g ∘ ap (cons TrA)

      v : (a₀ == a₁ → ⟦ U ⟧) → cons TrA a₀ == cons TrA a₁ → ⟦ U ⟧
      v f q = –> code-β (encode q) f

      u-v : (f : a₀ == a₁ → ⟦ U ⟧) → u (v f) == f
      u-v f = λ= (λ p → encode-β p f)

      v-u : (g : cons TrA a₀ == cons TrA a₁ → ⟦ U ⟧) → v (u g) == g
      v-u g = λ= (λ q → ! (decode-β (encode q) g) ∙ decode-encode q g)


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

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

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

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

  private
    fib : (p : PathP (λ i → ∀ x → B x i) f g) → fiber funExt p
    fib p = (funExt⁻ p , refl)

    funExt-fiber-isContr : ∀ p → (fi : fiber funExt p) → fib p ≡ fi
    funExt-fiber-isContr p (h , eq) i = (funExt⁻ (eq (~ i)) , λ j → eq (~ i ∨ j))

  funExt-isEquiv : isEquiv funExt
  equiv-proof funExt-isEquiv p = (fib p , funExt-fiber-isContr p)

  funExtEquiv : (∀ x → PathP (B x) (f x) (g x)) ≃ PathP (λ i → ∀ x → B x i) f g
  funExtEquiv = (funExt , funExt-isEquiv)

  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

    fib : (p : PathP (λ i → ∀ x y → C x y i) f g) → fiber funExt₂ p
    fib p = (appl₂ p , refl)

    funExt₂-fiber-isContr : ∀ p → (fi : fiber funExt₂ p) → fib p ≡ fi
    funExt₂-fiber-isContr p (h , eq) i = (appl₂ (eq (~ i)) , λ j → eq (~ i ∨ j))

  funExt₂-isEquiv : isEquiv funExt₂
  equiv-proof funExt₂-isEquiv p = (fib p , funExt₂-fiber-isContr p)

  funExt₂Equiv : (∀ x y → PathP (C x y) (f x y) (g x y)) ≃ (PathP (λ i → ∀ x y → C x y i) f g)
  funExt₂Equiv = (funExt₂ , funExt₂-isEquiv)

  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

    fib : (p : PathP (λ i → ∀ x y z → D x y z i) f g) → fiber funExt₃ p
    fib p = (appl₃ p , refl)

    funExt₃-fiber-isContr : ∀ p → (fi : fiber funExt₃ p) → fib p ≡ fi
    funExt₃-fiber-isContr p (h , eq) i = (appl₃ (eq (~ i)) , λ j → eq (~ i ∨ j))

  funExt₃-isEquiv : isEquiv funExt₃
  equiv-proof funExt₃-isEquiv p = (fib p , funExt₃-fiber-isContr p)

  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)
  funExt₃Equiv = (funExt₃ , funExt₃-isEquiv)

  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 : (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
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


{-# OPTIONS --no-unicode #-}

module Issue2749 where

-- testing ascii only lambda and arrow
id : {A : Set} -> A -> A
id = {!!}

-- testing ascii only double braces
it : {A : Set} {{a : A}} → A → A
it = {!!}

data B : Set where
  mkB : B → B → B

-- testing ascii only suffixes
left : B → B
left b1 = {!!}

open import Agda.Builtin.Equality

-- testing ascii only forall
allq : (∀ m n → m ≡ n) ≡ {!!}
allq = refl


open import Categories
open import Functors
open import RMonads

module RMonads.CatofRAdj.TermRAdjObj {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 Naturals
open import RAdjunctions
open import RMonads.CatofRAdj M
open import Categories.Terminal
open import RMonads.REM M
open import RMonads.REM.Adjunction M
open import RAdjunctions.RAdj2RMon

open Cat
open Fun
open NatT
open RAdj

lemX : R REMAdj ○ L REMAdj ≅ TFun M
lemX = FunctorEq _ _ refl refl

EMObj : Obj CatofAdj
EMObj  = record {
  E       = EM;
  adj     = REMAdj;
  law     = lemX;
  ηlaw    = idl D;
  bindlaw = λ{X}{Y}{f} →
    cong bind
         (stripsubst (Hom D (OMap J X))
                     f
                     (fcong Y (cong OMap (sym lemX))))} where open RMonad M


module Category where

open import Logic.Equivalence
open import Logic.Relations

open Equivalence using () renaming (_==_ to eq)

record Cat : Set2 where
  field
    Obj     : Set1
    _─→_    : Obj -> Obj -> Set
    id      : {A : Obj} -> A ─→ A
    _∘_     : {A B C : Obj} -> B ─→ C -> A ─→ B -> A ─→ C
    Eq      : {A B : Obj} -> Equivalence (A ─→ B)
    cong    : {A B C : Obj}{f₁ f₂ : B ─→ C}{g₁ g₂ : A ─→ B} ->
              eq Eq f₁ f₂ -> eq Eq g₁ g₂ -> eq Eq (f₁ ∘ g₁) (f₂ ∘ g₂)
    idLeft  : {A B : Obj}{f : A ─→ B} -> eq Eq (id ∘ f) f
    idRight : {A B : Obj}{f : A ─→ B} -> eq Eq (f ∘ id) f
    assoc   : {A B C D : Obj}{f : C ─→ D}{g : B ─→ C}{h : A ─→ B} ->
              eq Eq ((f ∘ g) ∘ h) (f ∘ (g ∘ h))

module Category (ℂ : Cat) where

  private module CC = Cat ℂ
  open CC public hiding (_─→_; _∘_)

  private module Eq {A B : Obj} = Equivalence (Eq {A}{B})
  open Eq public hiding (_==_)

  infix	 20 _==_
  infixr 30 _─→_
  infixr 90 _∘_

  _─→_ = CC._─→_

  _==_ : {A B : Obj} -> Rel (A ─→ B)
  _==_ = Eq._==_

  _∘_ : {A B C : Obj} -> B ─→ C -> A ─→ B -> A ─→ C
  _∘_ = CC._∘_

  congL : {A B C : Obj}{f₁ f₂ : B ─→ C}{g : A ─→ B} ->
	  f₁ == f₂ -> f₁ ∘ g == f₂ ∘ g
  congL p = cong p (refl _)

  congR : {A B C : Obj}{f : B ─→ C}{g₁ g₂ : A ─→ B} ->
	  g₁ == g₂ -> f ∘ g₁ == f ∘ g₂
  congR p = cong (refl _) p

module Poly-Cat where

  infix  20 _==_
  infixr 30 _─→_ _─→'_
  infixr 90 _∘_

  private module C = Category

  -- Objects
  data Obj (ℂ : Cat) : Set1 where
--     obj : C.Obj ℂ -> Obj ℂ

--   obj⁻¹ : {ℂ : Cat} -> Obj ℂ -> C.Obj ℂ
--   obj⁻¹ {ℂ} (obj A) = A

  postulate X : Set

  -- Arrows
  data _─→_ {ℂ : Cat}(A B : Obj ℂ) : Set where
    arr : X -> A ─→ B -- C._─→_ ℂ (obj⁻¹ A) (obj⁻¹ B) -> A ─→ B

  postulate
    ℂ : Cat
    A : Obj ℂ
    B : Obj ℂ

  foo : A ─→ B -> X
  foo (arr f) = ?

--   arr⁻¹ : {ℂ : Cat}{A B : Obj ℂ} -> A ─→ B -> C._─→_ ℂ (obj⁻¹ A) (obj⁻¹ B)
--   arr⁻¹ {ℂ}{A}{B} (arr f) = f

open Poly-Cat
open Category hiding (Obj; _─→_)

{-
  id : {ℂ : Cat}{A : Obj ℂ} -> A ─→ A
  id {ℂ} = arr (Pr.id ℂ)

  _∘_ : {ℂ : Cat}{A B C : Obj ℂ} -> B ─→ C -> A ─→ B -> A ─→ C
  _∘_ {ℂ} (arr f) (arr g) = arr (Pr.compose ℂ f g)

  data _==_ {ℂ : Cat}{A B : Obj ℂ}(f g : A ─→ B) : Set where
    eqArr : Pr.equal ℂ (arr⁻¹ f) (arr⁻¹ g) -> f == g

  refl : {ℂ : Cat}{A B : Obj ℂ}{f : A ─→ B} -> f == f
  refl {ℂ} = eqArr (Pr.refl ℂ)

  sym : {ℂ : Cat}{A B : Obj ℂ}{f g : A ─→ B} -> f == g -> g == f
  sym {ℂ} (eqArr fg) = eqArr (Pr.sym ℂ fg)

  trans : {ℂ : Cat}{A B : Obj ℂ}{f g h : A ─→ B} -> f == g -> g == h -> f == h
  trans {ℂ} (eqArr fg) (eqArr gh) = eqArr (Pr.trans ℂ fg gh)

  cong : {ℂ : Cat}{A B C : Obj ℂ}{f₁ f₂ : B ─→ C}{g₁ g₂ : A ─→ B} ->
	 f₁ == f₂ -> g₁ == g₂ -> f₁ ∘ g₁ == f₂ ∘ g₂
  cong {ℂ} {f₁ = arr _}{f₂ = arr _}{g₁ = arr _}{g₂ = arr _}
	   (eqArr p) (eqArr q) = eqArr (Pr.cong ℂ p q)

  congL : {ℂ : Cat}{A B C : Obj ℂ}{f₁ f₂ : B ─→ C}{g : A ─→ B} ->
	  f₁ == f₂ -> f₁ ∘ g == f₂ ∘ g
  congL p = cong p refl

  congR : {ℂ : Cat}{A B C : Obj ℂ}{f : B ─→ C}{g₁ g₂ : A ─→ B} ->
	  g₁ == g₂ -> f ∘ g₁ == f ∘ g₂
  congR q = cong refl q

  Eq : {ℂ : Cat}{A B : Obj ℂ} -> Equivalence (A ─→ B)
  Eq = equiv _==_ (\x -> refl) (\x y -> sym) (\x y z -> trans)

  idL : {ℂ : Cat}{A B : Obj ℂ}{f : A ─→ B} -> id ∘ f == f
  idL {ℂ}{f = arr _} = eqArr (Pr.idL ℂ)

  idR : {ℂ : Cat}{A B : Obj ℂ}{f : A ─→ B} -> f ∘ id == f
  idR {ℂ}{f = arr _} = eqArr (Pr.idR ℂ)

  assoc : {ℂ : Cat}{A B C D : Obj ℂ}{f : C ─→ D}{g : B ─→ C}{h : A ─→ B} ->
	  (f ∘ g) ∘ h == f ∘ (g ∘ h)
  assoc {ℂ}{f = arr _}{g = arr _}{h = arr _} = eqArr (Pr.assoc ℂ)
-}


module heap.libraryNat where

open import Data.Nat renaming (_⊔_ to _⊔n_; _≟_ to _≟ℕ_) hiding ( _<_ )
open import Data.Bool
open import Data.Fin hiding (pred)
open import Data.Unit
open import Data.Empty
open import Function
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

{-
--- WARNING USES TODO
postulate TODO : {A : Set} → A
-}

_==b_ : ℕ → ℕ → Bool
zero ==b zero = true
zero ==b suc a' = false
suc a ==b zero = false
suc a ==b suc a' = a ==b a'

transferℕ  : (P : ℕ → Set)
            → (a a' : ℕ) → T (a ==b a')
            → P a → P a'
transferℕ P zero zero aa' q = q
transferℕ P zero (suc a') () q
transferℕ P (suc a) zero () q
transferℕ P (suc a) (suc a') aa' q = transferℕ (P ∘ suc) a a' aa' q

_<ℕb_ : ℕ → ℕ → Bool
_ <ℕb zero = false
zero <ℕb suc a' = true
suc a <ℕb suc a' = a <ℕb a'

_<ℕ_ : ℕ → ℕ → Set
n <ℕ m = T (n <ℕb m)

_≦ℕb_ : ℕ → ℕ → Bool
zero ≦ℕb _ = true
suc a ≦ℕb zero = false
suc a ≦ℕb suc a' = a ≦ℕb a'

_≧ℕb_ : ℕ → ℕ → Bool
n ≧ℕb m = m ≦ℕb n

<ℕb-suc : {a b : ℕ} → T (a <ℕb b) → T (a <ℕb suc b)
<ℕb-suc{zero} = λ _ → tt
<ℕb-suc{_}{zero} ()
<ℕb-suc{suc a}{suc b} = <ℕb-suc{a}{b}

<ℕb-suc' : {a b : ℕ} → T (a ≦ℕb b) → T (a <ℕb suc b)
<ℕb-suc' {zero} {zero} ab = ab
<ℕb-suc' {zero} {suc b} ab = ab
<ℕb-suc' {suc a} {zero} ab = ab
<ℕb-suc' {suc a} {suc b} ab = <ℕb-suc'{a}{b} ab

n<sucnLem : {n m : ℕ} → T  (n ==b m) → T (n <ℕb suc m)
n<sucnLem {zero} {zero} nm = tt
n<sucnLem {zero} {suc m} ()
n<sucnLem {suc n} {zero} ()
n<sucnLem {suc n} {suc m} nm = n<sucnLem {n} {m} nm

n<mImpliesn/=m : (n m : ℕ) → T (m <ℕb n) → ¬ T (n ==b m)
n<mImpliesn/=m zero m ()
n<mImpliesn/=m (suc n) zero p ()
n<mImpliesn/=m (suc n) (suc m) p q = n<mImpliesn/=m n m p q

le : {n m : ℕ} → ¬ (n ==b m) ≡ false → T (n ==b m)
le{zero}{zero} p = tt
le {zero} {suc n} p = p refl
le {suc n} {zero} p = p refl
le {suc n} {suc m} p = le{n}{m} p

refl==b : {n : ℕ} → T (n ==b n)
refl==b {zero} = tt
refl==b {suc n} = refl==b {n}

symb : (n m : ℕ) → T (n ==b m) → T (m ==b n)
symb zero zero p = tt
symb zero (suc m) ()
symb (suc n) zero ()
symb (suc n) (suc m) p = symb n m p

neqsymb : (n m : ℕ) → ¬ T (n ==b m) → ¬ T (m ==b n)
neqsymb n m p q = p (symb m n q)

n<ℕbsucn : {n : ℕ} → T (n <ℕb suc n)
n<ℕbsucn {zero} = tt
n<ℕbsucn {suc n} = n<ℕbsucn{n}

n≦ℕbsucn : {n : ℕ} → T (n ≦ℕb suc n)
n≦ℕbsucn {zero} = tt
n≦ℕbsucn {suc n} = n≦ℕbsucn {n}

¬n<ℕbn : {n : ℕ} → ¬ (T (n <ℕb n))
¬n<ℕbn {zero} ()
¬n<ℕbn {suc n} p = ¬n<ℕbn {n} p

refl≦ℕb : (n : ℕ) → T (n ≦ℕb n)
refl≦ℕb zero = tt
refl≦ℕb (suc n) = refl≦ℕb n

trans≦ℕb : (n m k : ℕ) → T (n ≦ℕb m) → T (m ≦ℕb k) → T (n ≦ℕb k)
trans≦ℕb zero m k nm mk = tt
trans≦ℕb (suc n) zero k () mk
trans≦ℕb (suc n) (suc m) zero nm ()
trans≦ℕb (suc n) (suc m) (suc k) nm mk = trans≦ℕb n m k nm mk

⊔isMaxl : {n m : ℕ} →   T (n ≦ℕb (n ⊔n m ))
⊔isMaxl {zero} {m} = tt
⊔isMaxl {suc n} {zero} = refl≦ℕb (suc n)
⊔isMaxl {suc n} {suc m} = ⊔isMaxl {n} {m}

⊔isMaxr : {n m : ℕ} →   T (m ≦ℕb (n ⊔n m ))
⊔isMaxr {n} {zero}  = tt
⊔isMaxr {zero} {suc m}  = refl≦ℕb (suc m)
⊔isMaxr {suc n} {suc m} = ⊔isMaxr {n} {m}

⊔zero : {n : ℕ} → (n ⊔n zero) ≡ n
⊔zero {zero} = refl
⊔zero {suc n} = refl

⊔isMaxl' : {n m k : ℕ} →   T (n ≦ℕb m ) → T (n ≦ℕb (m ⊔n k ))
⊔isMaxl' {zero} {m} {k} = λ _ → tt
⊔isMaxl' {suc n} {zero} {k} = λ ()
⊔isMaxl' {suc n} {suc m} {zero} = λ z → z
⊔isMaxl' {suc n} {suc m} {suc k} = ⊔isMaxl'{n}{m}

⊔isMax<l : {n m k : ℕ} →   T ((n ⊔n m) <ℕb k) → T (n <ℕb k)
⊔isMax<l {n} {m} {zero} p = p
⊔isMax<l {zero} {m} {suc k} p = tt
⊔isMax<l {suc n} {zero} {suc k} p = p
⊔isMax<l {suc n} {suc m} {suc k} p = ⊔isMax<l {n} {m} {k} p

⊔isMax<r : {n m k : ℕ} →   T ((n ⊔n m) <ℕb k) → T (m <ℕb k)
⊔isMax<r {n} {zero} {zero} p = p
⊔isMax<r {n} {zero} {suc k} p = tt
⊔isMax<r {zero} {suc m} {k} p = p
⊔isMax<r {suc n} {suc m} {zero} p = p
⊔isMax<r {suc n} {suc m} {suc k} p = ⊔isMax<r{n}{m}{k} p

sucinvertible : {n m : ℕ} → suc n ≡ suc m → n ≡ m
sucinvertible {n} {m} = cong pred

¬n≡m→¬sucn≡sucm : {n m : ℕ} → ¬ (n ≡ m) → ¬ (suc n ≡ suc m)
¬n≡m→¬sucn≡sucm {n} {m} p q = p (sucinvertible q)

<impliesnoteq : {n m : ℕ} → T (n  <ℕb m) → ¬ (n ≡ m)
<impliesnoteq {n} {zero} p = λ _ → p
<impliesnoteq {zero} {suc m} p = λ ()
<impliesnoteq {suc n} {suc m} p = ¬n≡m→¬sucn≡sucm {n}{m} (<impliesnoteq{n}{m} p)

<impliesNot= = <impliesnoteq

-- {- Fin n related lemmata -}

-- fromℕ< : ∀ {n m} → n <ℕ m → Fin m
-- fromℕ< {_} {zero} ()
-- fromℕ< {zero} {suc m} p = zero
-- fromℕ< {suc n} {suc m} p = suc (fromℕ< {n} {m} p)

update : {A : Set} (f : ℕ → A) (n : ℕ) (a : A) → ℕ → A
update {A} f n a m = aux  (n ≟ℕ m)
    module updateaux where
           aux : Dec (n ≡ m)
                 →  A
           aux (yes _) = a
           aux (no _) = f m

updateLem : {A : Set}(Q : A → Set)(f : ℕ → A)(n : ℕ)(a : A)
            → (m :  ℕ)
            → ¬ (n ≡ m)
            → Q (f m)
            → Q (update f n a m)
updateLem {A} Q f n a m nm Qfm = aux (n ≟ℕ m)
     module  updateLemaux where
        aux : (x : Dec (n ≡ m)) → Q(updateaux.aux f n a m x)
        aux (yes p) = ⊥-elim (nm p)
        aux (no ¬p) = Qfm

updateLem2 : {A : Set}(f : ℕ → A)(n : ℕ)(a : A)(m : ℕ)
            → (n ≡ m)
            → update f n a m ≡ a
updateLem2 {A} f n a m nm = aux (n ≟ℕ m)
     module  updateLem2aux where
        aux : (x : Dec (n ≡ m)) → updateaux.aux f n a m x ≡ a
        aux (yes p) = refl
        aux (no ¬p) = ⊥-elim (¬p nm)

updateLem3 : {A : Set}(f : ℕ → A)(n : ℕ)(a : A)(m : ℕ)
            → ¬ (n ≡ m)
            → update f n a m ≡ f m
updateLem3 f n a m nm = updateLem (λ a' → a' ≡ f m) f n a m nm refl

leqEmbedLem : (P : ℕ → Set) → (l : (n : ℕ) → P n → P (suc n))
              → (n m : ℕ) → T (n ≦ℕb m) → P n → P m
leqEmbedLem P l zero zero nm p = p
leqEmbedLem P l zero (suc m) nm p = l m (leqEmbedLem P l zero m tt p)
leqEmbedLem P l (suc n) zero () p
leqEmbedLem P l (suc n) (suc m) nm p = leqEmbedLem (P ∘ suc) (l ∘ suc) n m nm p


{-# OPTIONS --safe #-}
module tmp where

open import Relation.Nullary
open import Data.List public

data Suf {X : Set} : List X → List X → Set where
  sinit : ∀ l → Suf l l
  scons : ∀ x l l' → Suf l l' → Suf (x ∷ l) l'

lemma : ∀ {X} (x : X) l l' → Suf l (x ∷ l') → Suf l l'
lemma x .(x ∷ l') l' (sinit .(x ∷ l')) = scons x l' l' (sinit l')
lemma x .(x₁ ∷ l) l' (scons x₁ l .(x ∷ l') H) = scons x₁ l l' (lemma x l l' H)

less-is-not-more : ∀ {X} x (l : List X) → ¬ Suf l (x ∷ l)
less-is-not-more x [] = λ ()
less-is-not-more x (x₁ ∷ l) (scons .x₁ .l .(x ∷ x₁ ∷ l) H) = less-is-not-more x₁ l (lemma x l (x₁ ∷ l) H)


------------------------------------------------------------------------
-- The Agda standard library
--
-- The Maybe type and some operations
------------------------------------------------------------------------

-- The definitions in this file are reexported by Data.Maybe.

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

module Data.Maybe.Base where

open import Level
open import Data.Bool.Base using (Bool; true; false; not)
open import Data.Unit.Base using (⊤)
open import Data.These using (These; this; that; these)
open import Data.Product as Prod using (_×_; _,_)
open import Function
open import Relation.Nullary

------------------------------------------------------------------------
-- Definition

data Maybe {a} (A : Set a) : Set a where
  just    : (x : A) → Maybe A
  nothing : Maybe A

------------------------------------------------------------------------
-- Some operations

boolToMaybe : Bool → Maybe ⊤
boolToMaybe true  = just _
boolToMaybe false = nothing

is-just : ∀ {a} {A : Set a} → Maybe A → Bool
is-just (just _) = true
is-just nothing  = false

is-nothing : ∀ {a} {A : Set a} → Maybe A → Bool
is-nothing = not ∘ is-just

decToMaybe : ∀ {a} {A : Set a} → Dec A → Maybe A
decToMaybe (yes x) = just x
decToMaybe (no _)  = nothing

-- A dependent eliminator.

maybe : ∀ {a b} {A : Set a} {B : Maybe A → Set b} →
        ((x : A) → B (just x)) → B nothing → (x : Maybe A) → B x
maybe j n (just x) = j x
maybe j n nothing  = n

-- A non-dependent eliminator.

maybe′ : ∀ {a b} {A : Set a} {B : Set b} → (A → B) → B → Maybe A → B
maybe′ = maybe

-- A defaulting mechanism

fromMaybe : ∀ {a} {A : Set a} → A → Maybe A → A
fromMaybe = maybe′ id

-- A safe variant of "fromJust". If the value is nothing, then the
-- return type is the unit type.

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

  From-just : Maybe A → Set a
  From-just (just _) = A
  From-just nothing  = Lift a ⊤

  from-just : (x : Maybe A) → From-just x
  from-just (just x) = x
  from-just nothing  = _

-- Functoriality: map.

map : ∀ {a b} {A : Set a} {B : Set b} → (A → B) → Maybe A → Maybe B
map f = maybe (just ∘ f) nothing

-- Alternative: <∣>

_<∣>_ : ∀ {a} {A : Set a} → Maybe A → Maybe A → Maybe A
just x  <∣> my = just x
nothing <∣> my = my

------------------------------------------------------------------------
-- Aligning and zipping

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

  alignWith : (These A B → C) → Maybe A → Maybe B → Maybe C
  alignWith f (just a) (just b) = just (f (these a b))
  alignWith f (just a) nothing  = just (f (this a))
  alignWith f nothing  (just b) = just (f (that b))
  alignWith f nothing  nothing  = nothing

  zipWith : (A → B → C) → Maybe A → Maybe B → Maybe C
  zipWith f (just a) (just b) = just (f a b)
  zipWith _ _ _ = nothing

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

  align : Maybe A → Maybe B → Maybe (These A B)
  align = alignWith id

  zip : Maybe A → Maybe B → Maybe (A × B)
  zip = zipWith _,_

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

-- Injections.

  thisM : A → Maybe B → These A B
  thisM a = maybe′ (these a) (this a)

  thatM : Maybe A → B → These A B
  thatM = maybe′ these that


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

open import Base
open import Algebra.Groups
open import Integers
open import Homotopy.Truncation
open import Homotopy.Pointed
open import Homotopy.PathTruncation
open import Homotopy.Connected

-- Definitions and properties of homotopy groups
module Homotopy.HomotopyGroups {i} where

-- Loop space
Ω : (X : pType i) → pType i
Ω X = ⋆[ ⋆ X ≡ ⋆ X , refl ]

Ω-pregroup : (X : pType i) → pregroup i
Ω-pregroup X = record
  { carrier       = (⋆ X) ≡ (⋆ X)
  ; _∙_           = _∘_
  ; e             = refl
  ; _′            = !
  ; assoc         = concat-assoc
  ; right-unit    = refl-right-unit
  ; left-unit     = λ _ → refl
  ; right-inverse = opposite-right-inverse
  ; left-inverse  = opposite-left-inverse
  }

Ωⁿ-pregroup : (n : ℕ) ⦃ ≢0 : n ≢ O ⦄ (X : pType i) → pregroup i
Ωⁿ-pregroup O ⦃ ≢0 ⦄ X = abort-nondep (≢0 refl)
Ωⁿ-pregroup 1 X = Ω-pregroup X
Ωⁿ-pregroup (S (S n)) X = Ωⁿ-pregroup (S n) (Ω X)

-- Homotopy groups
πⁿ-group : (n : ℕ) ⦃ >0 : n ≢ O ⦄ (X : pType i) → group i
πⁿ-group n X = π₀-pregroup (Ωⁿ-pregroup n X)

fundamental-group : (X : pType i) → group i
fundamental-group X = πⁿ-group 1 ⦃ ℕ-S≢O 0 ⦄ X

-- Homotopy groups of loop space
πⁿ-group-from-πⁿΩ : (n : ℕ) ⦃ ≢0 : n ≢ 0 ⦄ (X : pType i)
  → πⁿ-group (S n) X ≡ πⁿ-group n (Ω X)
πⁿ-group-from-πⁿΩ O ⦃ ≢0 ⦄ X = abort-nondep (≢0 refl)
πⁿ-group-from-πⁿΩ 1 X = refl
πⁿ-group-from-πⁿΩ (S (S n)) X = refl

-- Homotopy groups of spaces of a given h-level
abstract
  truncated-πⁿ-group : (n : ℕ) ⦃ ≢0 : n ≢ 0 ⦄ (X : pType i)
    (p : is-truncated (n -1) ∣ X ∣)
    → πⁿ-group n X ≡ unit-group
  truncated-πⁿ-group O ⦃ ≢0 ⦄ X p = abort-nondep (≢0 refl)
  truncated-πⁿ-group 1 X p =
    unit-group-unique _
      (proj refl ,
      π₀-extend ⦃ p = λ x → truncated-is-truncated-S _ (π₀-is-set _ _ _) ⦄
        (λ x → ap proj (π₁ (p _ _ _ _))))
  truncated-πⁿ-group (S (S n)) X p =
    truncated-πⁿ-group (S n) (Ω X) (λ x y → p _ _ x y)

Ωⁿ : (n : ℕ) (X : pType i) → pType i
Ωⁿ 0 X = X
Ωⁿ (S n) X = Ω (Ωⁿ n X)

πⁿ : (n : ℕ) (X : pType i) → pType i
πⁿ n X = τ⋆ ⟨0⟩ (Ωⁿ n X)

other-πⁿ : (n : ℕ) (X : pType i) → pType i
other-πⁿ n X = Ωⁿ n (τ⋆ ⟨ n ⟩ X)

ap-Ω-equiv : (X Y : pType i) (e : X ≃⋆ Y)
  → Ω X ≃⋆ Ω Y
ap-Ω-equiv X Y e = transport (λ u → Ω X ≃⋆ Ω u) (pType-eq e) (id-equiv⋆ _)

τ⋆Ω-is-Ωτ⋆S : (n : ℕ₋₂) (X : pType i)
  → τ⋆ n (Ω X) ≃⋆ Ω (τ⋆ (S n) X)
τ⋆Ω-is-Ωτ⋆S n X = (τ-path-equiv-path-τ-S , refl)

τ⋆kΩⁿ-is-Ωⁿτ⋆n+k : (k n : ℕ) (X : pType i)
  → τ⋆ ⟨ k ⟩ (Ωⁿ n X) ≃⋆ Ωⁿ n (τ⋆ ⟨ n + k ⟩ X)
τ⋆kΩⁿ-is-Ωⁿτ⋆n+k k O X = id-equiv⋆ _
τ⋆kΩⁿ-is-Ωⁿτ⋆n+k k (S n) X =
  equiv-compose⋆ (τ⋆Ω-is-Ωτ⋆S _ _) (ap-Ω-equiv _ _
    (equiv-compose⋆ (τ⋆kΩⁿ-is-Ωⁿτ⋆n+k (S k) n _)
      (transport (λ u → Ωⁿ n (τ⋆ ⟨ n + S k ⟩ X) ≃⋆ Ωⁿ n (τ⋆ ⟨ u ⟩ X))
        (+S-is-S+ n k) (id-equiv⋆ _))))

πⁿ-is-other-πⁿ : (n : ℕ) (X : pType i) → πⁿ n X ≃⋆ other-πⁿ n X
πⁿ-is-other-πⁿ n X =
  transport (λ u → πⁿ n X ≃⋆ Ωⁿ n (τ⋆ ⟨ u ⟩ X)) (+0-is-id n)
    (τ⋆kΩⁿ-is-Ωⁿτ⋆n+k 0 n X)

contr-is-contr-Ω : (X : pType i) → (is-contr⋆ X → is-contr⋆ (Ω X))
contr-is-contr-Ω X p = ≡-is-truncated ⟨-2⟩ p

contr-is-contr-Ωⁿ : (n : ℕ) (X : pType i) → (is-contr⋆ X) → is-contr⋆ (Ωⁿ n X)
contr-is-contr-Ωⁿ O X p = p
contr-is-contr-Ωⁿ (S n) X p = contr-is-contr-Ω _ (contr-is-contr-Ωⁿ n X p)

connected-other-πⁿ : (k n : ℕ) (lt : k < S n) (X : pType i)
  → (is-connected⋆ ⟨ n ⟩ X → is-contr⋆ (other-πⁿ k X))
connected-other-πⁿ k n lt X p =
  contr-is-contr-Ωⁿ k _ (connected⋆-lt k n lt X p)

connected-πⁿ : (k n : ℕ) (lt : k < S n) (X : pType i)
  → (is-connected⋆ ⟨ n ⟩ X → is-contr⋆ (πⁿ k X))
connected-πⁿ k n lt X p =
  equiv-types-truncated _ (π₁ (πⁿ-is-other-πⁿ k X) ⁻¹)
                       (connected-other-πⁿ k n lt X p)


{-# OPTIONS --safe #-}
module Cubical.Algebra.MonoidSolver.CommSolver where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Structure

open import Cubical.Data.FinData
open import Cubical.Data.Nat using (ℕ; _+_; iter)
open import Cubical.Data.Vec

open import Cubical.Algebra.CommMonoid

open import Cubical.Algebra.MonoidSolver.MonoidExpression

private
  variable
    ℓ : Level

module Eval (M : CommMonoid ℓ) where
  open CommMonoidStr (snd M)
  open CommMonoidTheory M

  Env : ℕ → Type ℓ
  Env n = Vec ⟨ M ⟩ n

  -- evaluation of an expression (without normalization)
  ⟦_⟧ : ∀{n} → Expr ⟨ M ⟩ n → Env n → ⟨ M ⟩
  ⟦ ε⊗ ⟧ v      = ε
  ⟦ ∣ i ⟧ v     = lookup i v
  ⟦ e₁ ⊗ e₂ ⟧ v = ⟦ e₁ ⟧ v · ⟦ e₂ ⟧ v

  -- a normalform is a vector of multiplicities, counting the occurances of each variable in an expression
  NormalForm : ℕ → Type _
  NormalForm n = Vec ℕ n

  _⊞_ : {n : ℕ} → NormalForm n → NormalForm n → NormalForm n
  x ⊞ y = zipWith _+_ x y

  emptyForm : {n : ℕ} → NormalForm n
  emptyForm = replicate 0

  -- e[ i ] is the i-th unit vector
  e[_] : {n : ℕ} → Fin n → NormalForm n
  e[ Fin.zero ]    = 1 ∷ emptyForm
  e[ (Fin.suc j) ] = 0 ∷ e[ j ]

  -- normalization of an expression
  normalize : {n : ℕ} → Expr ⟨ M ⟩ n → NormalForm n
  normalize (∣ i)     = e[ i ]
  normalize ε⊗        = emptyForm
  normalize (e₁ ⊗ e₂) = (normalize e₁) ⊞ (normalize e₂)

  -- evaluation of normalform
  eval : {n : ℕ} → NormalForm n → Env n → ⟨ M ⟩
  eval [] v = ε
  eval (x ∷ xs) (v ∷ vs) = iter x (λ w → v · w) (eval xs vs)

  -- some calculations
  emptyFormEvaluatesToε : {n : ℕ} (v : Env n) → eval emptyForm v ≡ ε
  emptyFormEvaluatesToε [] = refl
  emptyFormEvaluatesToε (v ∷ vs) = emptyFormEvaluatesToε vs

  UnitVecEvaluatesToVar : ∀{n} (i : Fin n) (v : Env n) →  eval e[ i ] v ≡ lookup i v
  UnitVecEvaluatesToVar zero (v ∷ vs) =
    v · eval emptyForm vs ≡⟨ cong₂ _·_ refl (emptyFormEvaluatesToε vs) ⟩
    v · ε                 ≡⟨ ·IdR _ ⟩
    v                     ∎
  UnitVecEvaluatesToVar (suc i) (v ∷ vs) = UnitVecEvaluatesToVar i vs

  evalIsHom : ∀ {n} (x y : NormalForm n) (v : Env n)
            → eval (x ⊞ y) v ≡ (eval x v) · (eval y v)
  evalIsHom [] [] v = sym (·IdL _)
  evalIsHom (x ∷ xs) (y ∷ ys) (v ∷ vs) =
    lemma x y (evalIsHom xs ys vs)
      where
      lemma : ∀ x y {a b c}(p : a ≡ b · c)
            → iter (x + y) (v ·_) a ≡ iter x (v ·_) b · iter y (v ·_) c
      lemma 0 0 p = p
      lemma 0 (ℕ.suc y) p = (cong₂ _·_ refl (lemma 0 y p)) ∙ commAssocl _ _ _
      lemma (ℕ.suc x) y p = (cong₂ _·_ refl (lemma x y p)) ∙ ·Assoc _ _ _

module EqualityToNormalform (M : CommMonoid ℓ) where
  open Eval M
  open CommMonoidStr (snd M)

  -- proof that evaluation of an expression is invariant under normalization
  isEqualToNormalform : {n : ℕ}
                      → (e : Expr ⟨ M ⟩ n)
                      → (v : Env n)
                      → eval (normalize e) v ≡ ⟦ e ⟧ v
  isEqualToNormalform ε⊗ v = emptyFormEvaluatesToε v
  isEqualToNormalform (∣ i) v = UnitVecEvaluatesToVar i v
  isEqualToNormalform (e₁ ⊗ e₂) v =
    eval ((normalize e₁) ⊞ (normalize e₂)) v          ≡⟨ evalIsHom (normalize e₁) (normalize e₂) v ⟩
    (eval (normalize e₁) v) · (eval (normalize e₂) v) ≡⟨ cong₂ _·_ (isEqualToNormalform e₁ v) (isEqualToNormalform e₂ v) ⟩
    ⟦ e₁ ⟧ v · ⟦ e₂ ⟧ v                               ∎

  solve : {n : ℕ}
        → (e₁ e₂ : Expr ⟨ M ⟩ n)
        → (v : Env n)
        → (p : eval (normalize e₁) v ≡ eval (normalize e₂) v)
        → ⟦ e₁ ⟧ v ≡ ⟦ e₂ ⟧ v
  solve e₁ e₂ v p =
    ⟦ e₁ ⟧ v              ≡⟨ sym (isEqualToNormalform e₁ v) ⟩
    eval (normalize e₁) v ≡⟨ p ⟩
    eval (normalize e₂) v ≡⟨ isEqualToNormalform e₂ v ⟩
    ⟦ e₂ ⟧ v              ∎

solve : (M : CommMonoid ℓ)
        {n : ℕ} (e₁ e₂ : Expr ⟨ M ⟩ n) (v : Eval.Env M n)
        (p :  Eval.eval M (Eval.normalize M e₁) v ≡ Eval.eval M (Eval.normalize M e₂) v)
        → _
solve M = EqualityToNormalform.solve M


open import Prelude

module Implicits.Substitutions.Type where

open import Implicits.Syntax.Type

open import Data.Fin.Substitution
open import Data.Star as Star hiding (map)
open import Data.Star.Properties
open import Data.Vec

module TypeApp {T} (l : Lift T Type) where
  open Lift l hiding (var)

  infixl 8 _/_

  mutual
    _simple/_ : ∀ {m n} → SimpleType m → Sub T m n → Type n
    tc c simple/ σ = simpl (tc c)
    tvar x simple/ σ = lift (lookup x σ)
    (a →' b) simple/ σ = simpl ((a / σ) →' (b / σ))

    _/_ : ∀ {m n} → Type m → Sub T m n → Type n
    (simpl c) / σ = (c simple/ σ)
    (a ⇒ b)  / σ = (a / σ) ⇒ (b / σ)
    (∀' a)   / σ = ∀' (a / σ ↑)

  open Application (record { _/_ = _/_ }) using (_/✶_)

  →'-/✶-↑✶ : ∀ k {m n a b} (ρs : Subs T m n) →
             (simpl (a →' b)) /✶ ρs ↑✶ k ≡ simpl ((a /✶ ρs ↑✶ k) →' (b /✶ ρs ↑✶ k))
  →'-/✶-↑✶ k ε        = refl
  →'-/✶-↑✶ k (r ◅ ρs) = cong₂ _/_ (→'-/✶-↑✶ k ρs) refl

  ⇒-/✶-↑✶ : ∀ k {m n a b} (ρs : Subs T m n) →
             (a ⇒ b) /✶ ρs ↑✶ k ≡ (a /✶ ρs ↑✶ k) ⇒ (b /✶ ρs ↑✶ k)
  ⇒-/✶-↑✶ k ε        = refl
  ⇒-/✶-↑✶ k (r ◅ ρs) = cong₂ _/_ (⇒-/✶-↑✶ k ρs) refl

  tc-/✶-↑✶ : ∀ k {c m n} (ρs : Subs T m n) →
             (simpl (tc c)) /✶ ρs ↑✶ k ≡ simpl (tc c)
  tc-/✶-↑✶ k ε        = refl
  tc-/✶-↑✶ k (r ◅ ρs) = cong₂ _/_ (tc-/✶-↑✶ k ρs) refl

  ∀'-/✶-↑✶ : ∀ k {m n a} (ρs : Subs T m n) →
             (∀' a) /✶ ρs ↑✶ k ≡ ∀' (a /✶ ρs ↑✶ (suc k))
  ∀'-/✶-↑✶ k ε = refl
  ∀'-/✶-↑✶ k (x ◅ ρs) = cong₂ _/_ (∀'-/✶-↑✶ k ρs) refl

typeSubst : TermSubst Type
typeSubst = record { var = (λ n → simpl (tvar n)); app = TypeApp._/_ }

open TermSubst typeSubst public hiding (var)
open TypeApp termLift public using (_simple/_)
open TypeApp varLift public using () renaming (_simple/_ to _simple/Var_)

infix 8 _[/_]

-- Shorthand for single-variable type substitutions
_[/_] : ∀ {n} → Type (suc n) → Type n → Type n
a [/ b ] = a / sub b

-- shorthand for type application
infixl 8 _∙_
_∙_ : ∀ {ν} → (a : Type ν) → {is∀ : is-∀' a} → Type ν → Type ν
_∙_ (simpl (tvar n)) {is∀ = ()} _
_∙_ (simpl (tc c)) b = simpl (tc c)
_∙_ (simpl (_ →' _)) {is∀ = ()} _
_∙_ (∀' x) b = x [/ b ]
_∙_ (_ ⇒ _) {is∀ = ()} _

stp-weaken : ∀ {ν} → SimpleType ν → SimpleType (suc ν)
stp-weaken (tc x) = tc x
stp-weaken (tvar n) = tvar (suc n)
stp-weaken (a →' b) = weaken a →' weaken b


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.RingSolver.CommRingHornerForms where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Nat using (ℕ)
open import Cubical.Data.FinData
open import Cubical.Data.Vec
open import Cubical.Data.Bool using (Bool; true; false; if_then_else_; _and_)

open import Cubical.Algebra.RingSolver.RawRing
open import Cubical.Algebra.RingSolver.RawAlgebra renaming (⟨_⟩ to ⟨_⟩ₐ)
open import Cubical.Algebra.RingSolver.AlmostRing renaming (⟨_⟩ to ⟨_⟩ᵣ)

private
  variable
    ℓ ℓ′ : Level

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

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

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

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

  or, to be precise about the evaluation order:

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

-}

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

module _ (A : RawAlgebra ℤAsRawRing ℓ′) where
  open RawRing ℤAsRawRing
  isZero : {n : ℕ} → IteratedHornerForms A n
                   → Bool
  isZero (const (pos ℕ.zero)) = true
  isZero (const (pos (ℕ.suc _))) = false
  isZero (const (negsuc _)) = false
  isZero 0H = true
  isZero (P ·X+ P₁) = false

eval : {A : RawAlgebra ℤAsRawRing ℓ′}
       (n : ℕ) (P : IteratedHornerForms A n)
       → Vec ⟨ A ⟩ₐ n → ⟨ A ⟩ₐ
eval {A = A} ℕ.zero (const r) [] = RawAlgebra.scalar A r
eval {A = A} .(ℕ.suc _) 0H (_ ∷ _) = RawAlgebra.0r A
eval {A = A} (ℕ.suc n) (P ·X+ Q) (x ∷ xs) =
     let open RawAlgebra A
         P' = (eval (ℕ.suc n) P (x ∷ xs))
         Q' = eval n Q xs
     in if (isZero A P)
        then Q'
        else P' · x + Q'

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

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

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

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

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

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

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

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

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

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

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

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

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


{-# OPTIONS --universe-polymorphism #-}

module AutoMisc where

-- prelude

postulate
  Level : Set
  lzero : Level
  lsuc  : (i : Level) → Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO lzero  #-}
{-# BUILTIN LEVELSUC  lsuc   #-}

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

trans : ∀ {a} {A : Set a} → {x y z : A} → x ≡ y → y ≡ z → x ≡ z
trans refl refl = refl

sym : ∀ {a} {A : Set a} → {x y : A} → x ≡ y → y ≡ x
sym refl = refl

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

data _IsRelatedTo_ {a : Level} {Carrier : Set a} (x y : Carrier) : Set a where
  relTo : (x∼y : x ≡ y) → x IsRelatedTo y

begin_ : {a : Level} {Carrier : Set a} → {x y : Carrier} → x IsRelatedTo y → x ≡ y
begin relTo x∼y = x∼y

_∎ : {a : Level} {Carrier : Set a} → (x : Carrier) → x IsRelatedTo x
_∎ _ = relTo refl

_≡⟨_⟩_ : {a : Level} {Carrier : Set a} → (x : Carrier) {y z : Carrier} → x ≡ y → y IsRelatedTo z → x IsRelatedTo z
_ ≡⟨ x∼y ⟩ relTo y∼z = relTo (trans x∼y y∼z)

data ℕ : Set where
  zero : ℕ
  suc  : (n : ℕ) → ℕ

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

data ⊥ : Set where

¬ : Set → Set
¬ A = A → ⊥

data Π (A : Set) (F : A → Set) : Set where
  fun : ((a : A) → F a) → Π A F

data Σ (A : Set) (F : A → Set) : Set where
  ΣI : (a : A) → (F a) → Σ A F

data Fin : ℕ → Set where
  zero : ∀ {n} → Fin (suc n)
  suc  : ∀ {n} → Fin n → Fin (suc n)

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

_++_ : {X : Set} → List X → List X → List X
[] ++ ys = ys
(x ∷ xs) ++ ys = x ∷ (xs ++ ys)

data Vec (X : Set) : ℕ → Set where
  []  : Vec X zero
  _∷_ : ∀ {n} → X → Vec X n → Vec X (suc n)

module AdditionCommutative where

 lemma : ∀ n m → (n + suc m) ≡ suc (n + m)
 lemma n m = {!!}

 lemma' : ∀ n m → (n + suc m) ≡ suc (n + m)
 lemma' zero m = refl
 lemma' (suc n) m = cong suc (lemma' n m)

 addcommut : ∀ n m → (n + m) ≡ (m + n)
 addcommut n m = {!!}

module Drink where

 postulate RAA : (A : Set) → (¬ A → ⊥) → A

 drink : (A : Set) → (a : A)
            → (Drink : A → Set) → Σ A (λ x → (Drink x) → Π A Drink)
 drink A a Drink = {!!}

module VecMap where

 map : {X Y : Set} → {n : ℕ} → (X → Y) → Vec X n → Vec Y n
 map f xs = {!!}

module Disproving where

 p : {X : Set} → (xs ys : List X) → (xs ++ ys) ≡ (ys ++ xs)
 p = {!!}


module Data.Bin.Bijection where

  open import Relation.Binary.PropositionalEquality as PropEq hiding (inspect)
  open import Function.Inverse renaming (_∘_ to _∙_)
  import Function.Surjection
  open Function.Surjection using (module Surjection; module Surjective)
  open import Function.Equality using (_⟶_)
  open import Data.Nat using (ℕ; _*_; _+_)
  open import Data.Bin using (toℕ; Bin; fromBits; 2+_; 0b; 1b)
  open import Data.Product
  open import Data.Digit using (Bit; toDigits; fromDigits)

  ℕ-setoid = PropEq.setoid ℕ
  Bin-setoid = PropEq.setoid Bin

  import Data.Fin
  pattern 1+ x = Data.Nat.suc x

  fromℕ : ℕ → Bin
  fromℕ x = fromBits (proj₁ (toDigits 2 x))

-- hard to prove now
--  fromℕeq' : {n : ℕ} → fromℕ n ≡ fromℕ' n
--  fromℕeq' {x} with toDigits 2 x
--  fromℕeq' .{fromDigits d} | d , refl = {!!}

  fromℕ⟶ : ℕ-setoid ⟶ Bin-setoid
  fromℕ⟶ = record
    { _⟨$⟩_ = fromℕ
    ; cong = PropEq.cong fromℕ
    }

  toℕ⟶ : Bin-setoid ⟶ ℕ-setoid
  toℕ⟶ = record
    { _⟨$⟩_ = toℕ
    ; cong = PropEq.cong toℕ
    }

  open import Data.Digit using(Bit)
  open import Data.Bin using (fromBits; toBits; _1#; 0#; 0b; 1b)
  open import Data.List using (_∷_; []; _++_)
  open import Data.Fin using (suc; zero) renaming (toℕ to bitToℕ)

  open import Data.Bin.BitListBijection
    using (_≈_; All-zero; module All-zero; All-zero-respects-equivalence)
    renaming (setoid to bits-setoid; bijection-to-ℕ to Bits-bijection-ℕ)

  open _≈_
  open All-zero
  open import Relation.Binary using (module Setoid)
  module Bits = Setoid bits-setoid

  open import Data.Product using (_,_; proj₂; proj₁)
  open import Function using (_∘_)

  open Data.List using(List)

  fromBits-zero : ∀ {l} → All-zero l → fromBits l ≡ 0#
  fromBits-zero [] = PropEq.refl
  fromBits-zero (All-zero.cons {t} z) with fromBits t | fromBits-zero z
  fromBits-zero (All-zero.cons z) | .0# | refl = PropEq.refl

  fromBitsCong : ∀ {i j} → i ≈ j → fromBits i ≡ fromBits j
  fromBitsCong (both-zero a-zero b-zero) =
     PropEq.trans (fromBits-zero a-zero)
      (PropEq.sym (fromBits-zero b-zero))
  fromBitsCong (heads-match h at bt eq) with fromBits at | fromBits bt | fromBitsCong eq
  fromBitsCong (heads-match Data.Bin.0b at bt eq) | 0# | .0# | refl = PropEq.refl
  fromBitsCong (heads-match Data.Bin.1b at bt eq) | 0# | .0# | refl = PropEq.refl
  fromBitsCong (heads-match (Data.Bin.2+ ()) at bt eq) | 0# | .0# | refl
  fromBitsCong (heads-match h at bt eq) | bs 1# | .(bs 1#) | refl = PropEq.refl

  fromBits⟶ : bits-setoid ⟶ Bin-setoid
  fromBits⟶ = record
    { _⟨$⟩_ = fromBits
    ; cong = fromBitsCong
    }

  toBits⟶ : Bin-setoid ⟶ bits-setoid
  toBits⟶ = record
    { _⟨$⟩_ = toBits
    ; cong = λ { {i} .{_} PropEq.refl → Bits.refl }
    }

  open import Data.Product using (_×_)

  #1-inj : ∀ {a b} → a 1# ≡ b 1# → a ≡ b
  #1-inj refl = refl

  fromToBits-inverse : ∀ a → fromBits (toBits a) ≡ a
  fromToBits-inverse 0# = refl
  fromToBits-inverse ([] 1#) = refl
  fromToBits-inverse ((h ∷ t) 1#) with fromBits (toBits (t 1#)) | fromToBits-inverse (t 1#)
  ... | 0# | ()
  ... | l 1# | eq = PropEq.cong (λ x → (h ∷ x) 1#) (#1-inj eq)

  qqq : ∀ {xs} → (0b ∷ []) ≈ xs → [] ≈ xs
  qqq (both-zero a-zero b-zero) = both-zero [] b-zero
  qqq (heads-match .0b .[] bt x) = both-zero [] (cons (All-zero-respects-equivalence x []))

  toFromBits-inverse : ∀ a → (toBits (fromBits a)) ≈ a
  toFromBits-inverse [] = both-zero (cons []) []
  toFromBits-inverse (x ∷ xs) with fromBits xs | toFromBits-inverse xs
  toFromBits-inverse (0b ∷ xs) | 0# | w =
    heads-match 0b [] xs (qqq w)
  toFromBits-inverse (1b ∷ xs) | 0# | w =
    heads-match 1b [] xs (qqq w)
  toFromBits-inverse ((2+ ()) ∷ xs) | 0# | w
  toFromBits-inverse (x ∷ xs) | bs 1# | w =
    heads-match x (bs ++ suc 0b ∷ []) xs w

  fromBits-inj : ∀ {x y} → fromBits x ≡ fromBits y → x ≈ y
  fromBits-inj eq =
    Bits.trans (Bits.sym (toFromBits-inverse _))
    (Bits.trans (Setoid.reflexive bits-setoid (cong toBits eq)) (toFromBits-inverse _))

  open import Function.Inverse using (Inverse; _InverseOf_)

  inverseFB : toBits⟶ InverseOf fromBits⟶
  inverseFB = record
    {
      left-inverse-of = toFromBits-inverse;
      right-inverse-of = fromToBits-inverse
    }

  Bits-inverse-Bin : Inverse bits-setoid Bin-setoid
  Bits-inverse-Bin = record
    { inverse-of = inverseFB
    }

  fromℕ-inverse : Inverse ℕ-setoid Bin-setoid
  fromℕ-inverse =
    Bits-inverse-Bin
    ∙ Function.Inverse.sym (Function.Inverse.fromBijection Bits-bijection-ℕ)

  bijection-is-reasonable1 :
    Function.Equality._⟨$⟩_ (Inverse.to fromℕ-inverse) ≡ fromℕ
  bijection-is-reasonable1 = PropEq.refl

  bijection-is-reasonable2 :
    Function.Equality._⟨$⟩_ (Inverse.from fromℕ-inverse) ≡ toℕ
  bijection-is-reasonable2 = PropEq.refl

  toℕ-inverse = Function.Inverse.sym fromℕ-inverse
  toℕ-bijection = Inverse.bijection toℕ-inverse
  fromℕ-bijection = Inverse.bijection fromℕ-inverse

  toℕ-inj = Inverse.injective toℕ-inverse
  fromℕ-inj = Inverse.injective fromℕ-inverse
  fromToℕ-inverse = Inverse.left-inverse-of toℕ-inverse
  toFromℕ-inverse = Inverse.right-inverse-of toℕ-inverse


-- {-# OPTIONS --verbose tc.records.ifs:15 #-}
-- {-# OPTIONS --verbose tc.constr.findInScope:15 #-}
-- {-# OPTIONS --verbose tc.term.args.ifs:15 #-}
-- {-# OPTIONS --verbose cta.record.ifs:15 #-}
-- {-# OPTIONS --verbose tc.section.apply:25 #-}
-- {-# OPTIONS --verbose tc.mod.apply:100 #-}
-- {-# OPTIONS --verbose scope.rec:15 #-}
-- {-# OPTIONS --verbose tc.rec.def:15 #-}

module 07-subclasses where

module Imports where
  module L where
    open import Agda.Primitive public
      using (Level; _⊔_) renaming (lzero to zero; lsuc to suc)

  -- extract from Function
  id : ∀ {a} {A : Set a} → A → A
  id x = x

  _$_ : ∀ {a b} {A : Set a} {B : A → Set b} →
        ((x : A) → B x) → ((x : A) → B x)
  f $ x = f x

  _∘_ : ∀ {a b c}
          {A : Set a} {B : A → Set b} {C : {x : A} → B x → Set c} →
        (∀ {x} (y : B x) → C y) → (g : (x : A) → B x) →
        ((x : A) → C (g x))
  f ∘ g = λ x → f (g x)

  -- extract from Data.Bool
  infixr 5 _∨_
  data Bool : Set where
    true  : Bool
    false : Bool

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

  _∨_ : Bool → Bool → Bool
  true  ∨ b = true
  false ∨ b = b

  -- extract from Relation.Nullary.Decidable and friends
  infix 3 ¬_

  data ⊥ : Set where

  ¬_ : ∀ {ℓ} → Set ℓ → Set ℓ
  ¬ P = P → ⊥

  data Dec {p} (P : Set p) : Set p where
    yes : ( p :   P) → Dec P
    no  : (¬p : ¬ P) → Dec P
  ⌊_⌋ : ∀ {p} {P : Set p} → Dec P → Bool
  ⌊ yes _ ⌋ = true
  ⌊ no  _ ⌋ = false

  -- extract from Relation.Binary.PropositionalEquality
  data _≡_ {a} {A : Set a} (x : A) : A → Set a where
    refl : x ≡ x

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

  -- extract from Data.Nat
  data ℕ : Set where
    zero : ℕ
    suc  : (n : ℕ) → ℕ

  {-# BUILTIN NATURAL ℕ    #-}

  pred : ℕ → ℕ
  pred zero    = zero
  pred (suc n) = n

  _≟_ : (x y : ℕ) → Dec (x ≡ y)
  zero  ≟ zero   = yes refl
  suc m ≟ suc n  with m ≟ n
  suc m ≟ suc .m | yes refl = yes refl
  suc m ≟ suc n  | no prf   = no (prf ∘ cong pred)
  zero  ≟ suc n  = no λ()
  suc m ≟ zero   = no λ()

open Imports

-- Begin of actual example!

record Eq (A : Set) : Set where
  field eq : A → A → Bool

primEqBool : Bool → Bool → Bool
primEqBool true = id
primEqBool false = not

eqBool : Eq Bool
eqBool = record { eq = primEqBool }

primEqNat : ℕ → ℕ → Bool
primEqNat a b = ⌊ a ≟ b ⌋

primLtNat : ℕ → ℕ → Bool
primLtNat 0 _ = true
primLtNat (suc a) (suc b) = primLtNat a b
primLtNat _ _ = false

neq : {t : Set} → {{eqT : Eq t}} → t → t → Bool
neq a b = not $ eq a b
  where open Eq {{...}}

record Ord₁ (A : Set) : Set where
  field _<_ : A → A → Bool
        eqA : Eq A

ord₁Nat : Ord₁ ℕ
ord₁Nat = record { _<_ = primLtNat; eqA = eqNat }
  where eqNat : Eq ℕ
        eqNat = record { eq = primEqNat }

record Ord₂ {A : Set} (eqA : Eq A) : Set where
  field _<_ : A → A → Bool

ord₂Nat : Ord₂ (record { eq = primEqNat })
ord₂Nat = record { _<_ = primLtNat }

record Ord₃ (A : Set) : Set where
  field _<_ : A → A → Bool
        eqA : Eq A
  open Eq eqA public

ord₃Nat : Ord₃ ℕ
ord₃Nat = record { _<_ = primLtNat; eqA = eqNat }
  where eqNat : Eq ℕ
        eqNat = record { eq = primEqNat }

record Ord₄ {A : Set} (eqA : Eq A) : Set where
  field _<_ : A → A → Bool
  open Eq eqA public

ord₄Nat : Ord₄ (record { eq = primEqNat })
ord₄Nat = record { _<_ = primLtNat }

module test₁ where
  open Ord₁ {{...}}
  open Eq {{...}}

  eqNat : Eq _
  eqNat = eqA

  test₁ = 5 < 3
  test₂ = eq 5 3
  test₃ = eq true false
  test₄ : {A : Set} → {{ ordA : Ord₁ A }} → A → A → Bool
  test₄ a b = a < b ∨ eq a b
    where
      eqA' : Eq _
      eqA' = eqA

module test₂ where
  open Ord₂ {{...}}
  open Eq {{...}}

  eqNat : Eq ℕ
  eqNat = record { eq = primEqNat }

  test₁ = 5 < 3
  test₂ = eq 5 3
  test₃ = eq true false
  test₄ : {A : Set} → {eqA : Eq A} → {{ ordA : Ord₂ eqA }} → A → A → Bool
  test₄ {eqA = _} a b = a < b ∨ eq a b

module test₃ where
  open Ord₃ {{...}}
  open Eq {{...}} renaming (eq to eq')

  test₁ = 5 < 3
  test₂ = eq 5 3
  test₃ = eq' true false
  test₄ : {A : Set} → {{ ordA : Ord₃ A }} → A → A → Bool
  test₄ a b = a < b ∨ eq a b

module test₄ where
  open Ord₄ {{...}}
  open Eq {{...}} renaming (eq to eq')

  test₁ = 5 < 3
  test₂ = eq 5 3
  test₃ = eq' true false
  test₄ : {A : Set} → {eqA : Eq A} → {{ ordA : Ord₄ eqA }} → A → A → Bool
  test₄ a b = a < b ∨ eq a b

module test₄′ where
  open Ord₄ {{...}} hiding (eq)
  open Eq {{...}}

  eqNat : Eq ℕ
  eqNat = record { eq = primEqNat }

  test₁ = 5 < 3
  test₂ = eq 5 3
  test₃ = eq true false
  test₄ : {A : Set} → {eqA : Eq A} → {{ ordA : Ord₄ eqA }} → A → A → Bool
  test₄ {eqA = _} a b = a < b ∨ eq a b


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

open import LogicalFormulae
open import Numbers.Naturals.Semiring -- for length
open import Numbers.Naturals.Order
open import Semirings.Definition
open import Maybe

module Lists.Lists where

open import Lists.Definition public
open import Lists.Length public
open import Lists.Concat public
open import Lists.Map.Map public
open import Lists.Reversal.Reversal public
open import Lists.Monad public
open import Lists.Filter.AllTrue public
open import Lists.Fold.Fold public

replicate : {a : _} {A : Set a} (n : ℕ) (x : A) → List A
replicate zero x = []
replicate (succ n) x = x :: replicate n x

head : {a : _} {A : Set a} (l : List A) (pr : 0 <N length l) → A
head [] (le x ())
head (x :: l) pr = x

lengthRev : {a : _} {A : Set a} (l : List A) → length (rev l) ≡ length l
lengthRev [] = refl
lengthRev (x :: l) rewrite lengthConcat (rev l) (x :: []) | lengthRev l | Semiring.commutative ℕSemiring (length l) 1 = refl

listLast : {a : _} {A : Set a} (l : List A) → Maybe A
listLast [] = no
listLast (x :: []) = yes x
listLast (x :: y :: l) = listLast (y :: l)

listZip : {a b c : _} {A : Set a} {B : Set b} {C : Set c} (f : A → B → C) → (f1 : A → C) → (f2 : B → C) →(l1 : List A) (l2 : List B) → List C
listZip f f1 f2 [] l2 = map f2 l2
listZip f f1 f2 (x :: l1) [] = map f1 (x :: l1)
listZip f f1 f2 (x :: l1) (y :: l2) = (f x y) :: listZip f f1 f2 l1 l2

contains : {a : _} {A : Set a} (l : List A) (needle : A) → Set a
contains [] needle = False'
contains (x :: l) needle = (x ≡ needle) || contains l needle

containsMap : {a b : _} {A : Set a} {B : Set b} (f : A → B) (l : List A) (needle : A) → (contains l needle) → contains (map f l) (f needle)
containsMap f (x :: l) needle (inl cont) = inl (applyEquality f cont)
containsMap f (x :: l) needle (inr cont) = inr (containsMap f l needle cont)

containsAppend : {a : _} {A : Set a} (l1 l2 : List A) (needle : A) → (contains (l1 ++ l2) needle) → (contains l1 needle) || (contains l2 needle)
containsAppend [] l2 needle cont = inr cont
containsAppend (x :: l1) l2 needle (inl pr) = inl (inl pr)
containsAppend (x :: l1) l2 needle (inr pr) with containsAppend l1 l2 needle pr
containsAppend (x :: l1) l2 needle (inr pr) | inl ans = inl (inr ans)
containsAppend (x :: l1) l2 needle (inr pr) | inr ans = inr ans

containsAppend' : {a : _} {A : Set a} (l1 l2 : List A) (needle : A) → (contains l1 needle) || (contains l2 needle) → contains (l1 ++ l2) needle
containsAppend' (x :: l1) l2 needle (inl (inl pr)) = inl pr
containsAppend' (x :: l1) l2 needle (inl (inr pr)) = inr (containsAppend' l1 l2 needle (inl pr))
containsAppend' [] l2 needle (inr pr) = pr
containsAppend' (x :: l1) l2 needle (inr pr) = inr (containsAppend' l1 l2 needle (inr pr))

containsCons : {a : _} {A : Set a} (x : A) (l : List A) (needle : A) → (contains (x :: l) needle) → (x ≡ needle) || (contains l needle)
containsCons x l needle pr = pr

containsCons' : {a : _} {A : Set a} (x : A) (l : List A) (needle : A) → (x ≡ needle) || (contains l needle) → (contains (x :: l) needle)
containsCons' x l needle pr = pr

containsDecidable : {a : _} {A : Set a} (decidableEquality : (x y : A) → (x ≡ y) || ((x ≡ y) → False)) → (l : List A) → (needle : A) → (contains l needle) || ((contains l needle) → False)
containsDecidable decide [] needle = inr λ ()
containsDecidable decide (x :: l) needle with decide x needle
containsDecidable decide (x :: l) .x | inl refl = inl (inl refl)
containsDecidable decide (x :: l) needle | inr x!=n with containsDecidable decide l needle
containsDecidable decide (x :: l) needle | inr x!=n | inl isIn = inl (inr isIn)
containsDecidable decide (x :: l) needle | inr x!=n | inr notIn = inr t
  where
    t : ((x ≡ needle) || contains l needle) → False
    t (inl x) = x!=n x
    t (inr x) = notIn x

filter' : {a b : _} {A : Set a} {pred : A → Set b} → (dec : (a : A) → pred a || (pred a → False)) → List A → List A
filter' dec [] = []
filter' dec (x :: l) with dec x
... | inl _ = x :: filter' dec l
... | inr _ = filter' dec l


-- Andreas, 2015-10-28 adapted from test case by
-- Ulf, 2014-02-06, shrunk from Wolfram Kahl's report

open import Common.Equality
open import Common.Unit
open import Common.Nat

postulate
  prop : ∀ x → x ≡ unit

record StrictTotalOrder : Set where
  field compare : Unit
open StrictTotalOrder

module M (Key : StrictTotalOrder) where

    postulate
      intersection′-₁ : ∀ x → x ≡ compare Key

    to-∈-intersection′  : Nat → Unit → Unit → Set
    to-∈-intersection′ zero x h = Unit
    to-∈-intersection′ (suc n) x h with intersection′-₁ x
    to-∈-intersection′ (suc n) ._ h  | refl with prop h
    to-∈-intersection′ (suc n) ._ ._ | refl    | refl = to-∈-intersection′ n unit unit


module Structure.Sets.Names where

open import Data.Boolean
open import Data.Boolean.Stmt
open import Functional
import      Lvl
open import Logic
open import Logic.Propositional
open import Logic.Predicate
open import Structure.Function
open import Structure.Relator
open import Structure.Setoid using (Equiv) renaming (_≡_ to _≡ₛ_ ; _≢_ to _≢ₛ_)
open import Type
open import Type.Properties.Inhabited

private variable ℓ ℓ₁ ℓ₂ ℓ₃ ℓ₄ ℓ₅ ℓ₆ ℓ₇ ℓ₈ ℓ₉ ℓ₁₀ ℓₑ ℓₑ₁ ℓₑ₂ ℓₑ₃ ℓₑₑ ℓₑₑₗ ℓₑₑᵣ ℓₑᵢ ℓₑₒ ℓₑₛ ℓₗ ℓₗ₁ ℓₗ₂ ℓₗ₃ ℓᵣ ℓₒ ℓᵣₑₗ ℓₛ : Lvl.Level
private variable A B C S S₁ S₂ Sₒ Sᵢ Sₗ Sᵣ E E₁ E₂ Eₗ Eᵣ I O : Type{ℓ}
private variable _∈ₒ_ _∈ᵢ_ : E → S → Stmt{ℓₗ}
private variable _∈ₗ_ : E → Sₗ → Stmt{ℓₗ}
private variable _∈ᵣ_ : E → Sᵣ → Stmt{ℓᵣ}

-- Derivable relation symbols from the subset relation.
module From-[⊆] (_⊆_ : Sₗ → Sᵣ → Stmt{ℓₗ}) where
  -- Superset.
  -- (A ⊇ B) means that every element in the set B is also in the set A (A contains the contents of B).
  _⊇_ = swap(_⊆_)

  -- Non-subset.
  _⊈_ = (¬_) ∘₂ (_⊆_)

  -- Non-superset.
  _⊉_ = (¬_) ∘₂ (_⊇_)

-- Derivable relation symbols from two membership relations.
module From-[∈][∈] (_∈ₗ_ : E → Sₗ → Stmt{ℓₗ}) (_∈ᵣ_ : E → Sᵣ → Stmt{ℓᵣ}) where
  -- Subset.
  -- (A ⊆ B) means that every element in the set A is also in the set B (A is a part of B).
  -- Alternative definition:
  --   A ↦ B ↦ ∀ₗ(x ↦ ((_→ᶠ_) on₂ (x ∈_)) A B)
  _⊆_ = \A B → ∀{x} → (x ∈ₗ A) → (x ∈ᵣ B)

  -- Set equality.
  -- (A ≡ B) means that the sets A and B contains the same elements.
  _≡_ = \A B → ∀{x} → (x ∈ₗ A) ↔ (x ∈ᵣ B)

  open From-[⊆] (_⊆_) public

-- Derivable relation symbols from the membership relation.
module From-[∈] (_∈_ : E → S → Stmt{ℓₗ}) where
  -- Containment.
  -- (a ∋ x) means that the set a contains the element x.
  _∋_ = swap(_∈_)

  -- Not element of.
  _∉_ = (¬_) ∘₂ (_∈_)

  -- Non-containment.
  _∌_ = (¬_) ∘₂ (_∋_)

  open From-[∈][∈] (_∈_)(_∈_) public

module From-[∋] (_∋_ : S → E → Stmt{ℓₗ}) where
  _∈_ = swap(_∋_)

  open From-[∈] (_∈_) hiding (_∋_) public

module Relations (_∈_ : E → S → Stmt{ℓₗ}) where
  -- The property of a set being empty.
  Empty : S → Type
  Empty(s) = ∀ₗ(x ↦ ¬(x ∈ s))

  -- The property of a set being non-empty.
  NonEmpty : S → Type
  NonEmpty(s) = ∃(_∈ s)

  -- The property of a set being the universal set (containing all elements).
  Universal : S → Type
  Universal(s) = ∀ₗ(_∈ s)

  -- The property of two sets being disjoint (not sharing any elements).
  Disjoint : S → S → Type
  Disjoint s₁ s₂ = ∀ₗ(x ↦ ((x ∈ s₁) → (x ∈ s₂) → ⊥))

module One (_∈_ : E → S → Stmt{ℓₗ}) where
  open From-[∈] (_∈_)

  -- The empty set containing no elements.
  -- No elements are in the empty set.
  -- Standard set notation: ∅ = {}.
  EmptyMembership     = \(∅)
                      → ∀{x} → (x ∉ ∅)

  -- The universal set containing all elements.
  -- Every element is in the universal set.
  -- Standard set notation: 𝐔 = {x. ⊤}.
  UniversalMembership = \(𝐔)
                      → ∀{x} → (x ∈ 𝐔)

  module _ {I : Type{ℓ}} ⦃ equiv-I : Equiv{ℓₑᵢ}(I) ⦄ ⦃ equiv-E : Equiv{ℓₑₑ}(E) ⦄ where
  -- The image of a function containing the elements that the function points to.
  -- The elements of the form f(x) for any x.
  -- Standard set notation: ⊶ f = {f(x). (x: I)}.
    ImageMembership = \(⊶ : (f : I → E) → ⦃ func : Function(f) ⦄ → S)
                    → ∀{f} ⦃ func : Function(f) ⦄ → ∀{y} → (y ∈ (⊶ f)) ↔ ∃(x ↦ f(x) ≡ₛ y)

  module _ ⦃ equiv-E : Equiv{ℓₑₑ}(E) ⦄ {O : Type{ℓ}} ⦃ equiv-O : Equiv{ℓₑₒ}(O) ⦄ where
    -- The fiber of a function together with one of its values containing the elements that point to this value.
    -- Standard set notation: fiber f(y) = {x. f(x) ≡ y}
    FiberMembership = \(fiber : (f : E → O) → ⦃ func : Function(f) ⦄ → (O → S))
                    → ∀{f} ⦃ func : Function(f) ⦄ {y}{x} → (x ∈ fiber f(y)) ↔ (f(x) ≡ₛ y)

  module _ ⦃ equiv-E : Equiv{ℓₑₑ}(E) ⦄ where
    -- The singleton set of a single element containing only this element.
    -- Standard set notation: singleton(x) = {x}
    SingletonMembership = \(singleton : E → S)
                        → ∀{y}{x} → (x ∈ singleton(y)) ↔ (x ≡ₛ y)

    -- The pair set of two elements containing only the two elements.
    -- Standard set notation: pair x y = {x,y}
    PairMembership      = \(pair : E → E → S)
                        → ∀{y₁ y₂}{x} → (x ∈ pair y₁ y₂) ↔ ((x ≡ₛ y₁) ∨ (x ≡ₛ y₂))

    module _ {ℓ} where
      -- Set comprehension with a predicate containing all elements that satisfy this predicate.
      -- Also called: Unrestricted set comprehension, set-builder notation.
      -- Standard set notation: comp(P) = {x. P(x)}
      ComprehensionMembership = \(comp : (P : E → Stmt{ℓ}) ⦃ unaryRelator : UnaryRelator(P) ⦄ → S)
                              → ∀{P} ⦃ unaryRelator : UnaryRelator(P) ⦄ {x} → (x ∈ comp(P)) ↔ P(x)
open One public

module Two (_∈ₗ_ : E → Sₗ → Stmt{ℓₗ}) (_∈ᵣ_ : E → Sᵣ → Stmt{ℓᵣ}) where
  private module Def = From-[∈][∈] (_∈ₗ_)(_∈ᵣ_)

  SubsetMembership      = \{ℓᵣₑₗ} (_⊆_ : Sₗ → Sᵣ → Stmt{ℓᵣₑₗ})
                        → ∀{a b} → (a ⊆ b) ↔ (a Def.⊆ b)
  SetEqualityMembership = \{ℓᵣₑₗ} (_≡_ : Sₗ → Sᵣ → Stmt{ℓᵣₑₗ})
                        → ∀{a b} → (a ≡ b) ↔ (a Def.≡ b)
open Two public

module TwoSame (_∈ₗ_ : E → Sₗ → Stmt{ℓₗ}) (_∈ᵣ_ : E → Sᵣ → Stmt{ℓᵣ}) where
  -- The set complement of a set containing all elements not in this set.
  -- Standard set notation: ∁ A =  {x. x ∉ A}
  ComplementMembership  = \(∁ : Sₗ → Sᵣ)
                        → ∀{A}{x} → (x ∈ᵣ (∁ A)) ↔ ¬(x ∈ₗ A)

  module _ ⦃ equiv-E : Equiv{ℓₑₑ}(E) ⦄ where
    AddMembership       = \(add : E → Sₗ → Sᵣ)
                        → ∀{y}{a}{x} → (x ∈ᵣ add y a) ↔ ((x ∈ₗ a) ∨ (x ≡ₛ y))
    RemoveMembership    = \(remove : E → Sₗ → Sᵣ)
                        → ∀{y}{a}{x} → (x ∈ᵣ remove y a) ↔ ((x ∈ₗ a) ∧ (x ≢ₛ y))

    module _ {ℓ} where
      -- The filtering of a set with a predicate containing all elements in the set that satisfy the predicate.
      -- It is the subset where all elements satisfy the predicate.
      -- Standard set notation: filter P(A) =  {(x∊A). P(x)}
      FilterMembership = \(filter : (P : E → Stmt{ℓ}) ⦃ unaryRelator : UnaryRelator(P) ⦄ → (Sₗ → Sᵣ))
                       → ∀{A}{P} ⦃ unaryRelator : UnaryRelator(P) ⦄ {x} → (x ∈ᵣ filter P(A)) ↔ ((x ∈ₗ A) ∧ P(x))
  -- The filtering of a set with a boolean predicate containing all elements in the set that satisfy the predicate.
  -- Standard set notation: boolFilter P(A) =  {(x∊A). P(x) ≡ 𝑇}
  BooleanFilterMembership = \(boolFilter : (E → Bool) → (Sₗ → Sᵣ))
                          → ∀{A}{P}{x} → (x ∈ᵣ boolFilter P(A)) ↔ ((x ∈ₗ A) ∧ IsTrue(P(x)))

  IndexedBigUnionMembership        = \{ℓ}{I : Type{ℓ}} (⋃ᵢ : (I → Sₗ) → Sᵣ)
                                   → ∀{Ai}{x} → (x ∈ᵣ (⋃ᵢ Ai)) ↔ ∃(i ↦ (x ∈ₗ Ai(i)))
  IndexedBigIntersectionMembership = \{ℓ}{I : Type{ℓ}} (⋂ᵢ : (I → Sₗ) → Sᵣ)
                                   → ∀{Ai} → (◊ I) → ∀{x} → (x ∈ᵣ (⋂ᵢ Ai)) ↔ (∀{i} → (x ∈ₗ Ai(i)))
open TwoSame public

module TwoDifferent (_∈ₗ_ : Eₗ → Sₗ → Stmt{ℓₗ}) (_∈ᵣ_ : Eᵣ → Sᵣ → Stmt{ℓᵣ}) where
  module _ ⦃ equiv-Eₗ : Equiv{ℓₑₑₗ}(Eₗ) ⦄ ⦃ equiv-Eᵣ : Equiv{ℓₑₑᵣ}(Eᵣ) ⦄ where
    -- The image of a function and a set containing the elements that the function points to from the set (the domain is restricted to the set).
    -- The elements of the form f(x) for any x in A.
    -- Standard set notation: map f(A) = {f(x). x ∈ A}.
    MapMembership = \(map : (f : Eₗ → Eᵣ) ⦃ func : Function(f) ⦄ → (Sₗ → Sᵣ))
                  → ∀{f} ⦃ func : Function(f) ⦄ {A}{y} → (y ∈ᵣ map f(A)) ↔ ∃(x ↦ (x ∈ₗ A) ∧ (f(x) ≡ₛ y))

    -- The inverse image of a function together with a set containing the elements that point to elements in the set.
    -- Standard set notation: unmap f(A) = {x. f(x) ∈ A}
    UnmapMembership = \(unmap : (f : Eₗ → Eᵣ) ⦃ func : Function(f) ⦄ → (Sᵣ → Sₗ))
                    → ∀{f} ⦃ func : Function(f) ⦄ {A}{x} → (x ∈ₗ unmap f(A)) ↔ (f(x) ∈ᵣ A)
open TwoDifferent public

module Three (_∈ₗ_ : E → Sₗ → Stmt{ℓₗ}) (_∈ᵣ_ : E → Sᵣ → Stmt{ℓᵣ}) (_∈ₒ_ : E → Sₒ → Stmt{ℓₒ}) where
  -- The union of two sets containing the elements that are in at least one of the sets.
  -- Standard set notation: A ∪ B = {x. (x ∈ A) ∨ (x ∈ B)}
  UnionMembership     = \(_∪_ : Sₗ → Sᵣ → Sₒ)
                      → (∀{A B}{x} → (x ∈ₒ (A ∪ B)) ↔ ((x ∈ₗ A) ∨ (x ∈ᵣ B)))

  -- The intersection of two sets containing the elements that are in at both of the sets.
  -- Standard set notation: A ∪ B = {x. (x ∈ A) ∨ (x ∈ B)}
  IntersectMembership = \(_∩_ : Sₗ → Sᵣ → Sₒ)
                      → (∀{A B}{x} → (x ∈ₒ (A ∩ B)) ↔ ((x ∈ₗ A) ∧ (x ∈ᵣ B)))

  -- The relative complement of two sets containing the elements that are in the left set but not in the right.
  -- Standard set notation: A ∖ B = {x. (x ∈ A) ∧ (x ∉ B)}
  WithoutMembership   = \(_∖_ : Sₗ → Sᵣ → Sₒ)
                      → (∀{A B}{x} → (x ∈ₒ (A ∖ B)) ↔ ((x ∈ₗ A) ∧ ¬(x ∈ᵣ B)))
open Three public

module ThreeNestedTwoDifferent (_∈ₒ_ : Sₗ → Sₒ → Stmt{ℓₒ}) where
  module _ (_⊆_ : Sₗ → Sᵣ → Stmt{ℓₛ}) where
    -- The power set of a set containing all subsets of a set.
    -- Standard set notation: ℘(y) = {x. x ⊆ y}
    PowerMembership = \(℘ : Sᵣ → Sₒ)
                    → ∀{y}{x} → (x ∈ₒ ℘(y)) ↔ (x ⊆ y)
open ThreeNestedTwoDifferent public

module ThreeTwoNested (_∈ₗ_ : E → Sₗ → Stmt{ℓₗ}) (_∈ᵣ_ : Sₗ → Sᵣ → Stmt{ℓᵣ}) (_∈ₒ_ : E → Sₒ → Stmt{ℓₒ}) where
  BigUnionMembership      = \(⋃ : Sᵣ → Sₒ)
                          → ∀{A}{x} → (x ∈ₒ (⋃ A)) ↔ ∃(a ↦ (a ∈ᵣ A) ∧ (x ∈ₗ a))
  BigIntersectionMembership = \(⋂ : Sᵣ → Sₒ)
                            → ∀{A} → ∃(_∈ᵣ A) → ∀{x} → (x ∈ₒ (⋂ A)) ↔ (∀{a} → (a ∈ᵣ A) → (x ∈ₗ a))
  BigIntersectionMembershipWithEmpty = \(⋂ : Sᵣ → Sₒ)
                                     → ∀{A}{x} → (x ∈ₒ (⋂ A)) ↔ ∃(a ↦ (a ∈ᵣ A) ∧ (x ∈ₗ a)) ∧ (∀{a} → (a ∈ᵣ A) → (x ∈ₗ a))
  BigIntersectionMembershipWithUniversal = \(⋂ : Sᵣ → Sₒ)
                                         → ∀{A}{x} → (x ∈ₒ (⋂ A)) ↔ (∀{a} → (a ∈ᵣ A) → (x ∈ₗ a))
open ThreeTwoNested public