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

module lecture3 where

-- lecture 3
-- Plan: Complete last lecture.
--       Generalize some definitions to use universe levels.
--       Uses of Sigma, including examples like monoids.
--       Use of universes to prove that Β¬ (false ≑ true).
--       Characterization of equality in Ξ£ types.


open import lecture1 hiding (𝟘 ; πŸ™ ; ⋆ ; D ; _≣_ ; β„•)
open import lecture2 using (is-prime ; _*_ ; 𝟘 ; πŸ™ ; ⋆ ; _β‰₯_)
open import introduction using (β„• ; zero ; suc ; _+_)

-- Give Ξ£ a universe-polymorphic type

open import Agda.Primitive using (Level; lzero; lsuc; _βŠ”_)
                           renaming (Set to 𝓀)
                           public

variable i j k : Level

record Ξ£ {A : 𝓀 i} (B : A β†’ 𝓀 j) : 𝓀 (i βŠ” j) where
 constructor
  _,_
 field
  pr₁ : A
  prβ‚‚ : B pr₁

open Ξ£ public
infixr 1 _,_

Sigma : (A : 𝓀 i) (B : A β†’ 𝓀 j) β†’ 𝓀 (i βŠ” j)
Sigma {i} {j} A B = Ξ£ {i} {j} {A} B

syntax Sigma A (Ξ» x β†’ b) = Ξ£ x κž‰ A , b

infix -1 Sigma

_Γ—_ : 𝓀 i β†’ 𝓀 j β†’ 𝓀 (i βŠ” j)
A Γ— B = Ξ£ x κž‰ A , B

-- (x : X) β†’ A x
-- (x : X) Γ— A x

infixr 2 _Γ—_

-- More general type of negation:

Β¬_ : 𝓀 i β†’ 𝓀 i
Β¬ A = A β†’ 𝟘

-- Give the identity type more general universe assignments:

data _≑_ {X : 𝓀 i} : X β†’ X β†’ 𝓀 i where
 refl : (x : X) β†’ x ≑ x

_β‰’_ : {X : 𝓀 i} β†’ X β†’ X β†’ 𝓀 i
x β‰’ y = Β¬ (x ≑ y)

infix 0 _≑_

≑-elim : {X : 𝓀 i} (A : (x y : X) β†’ x ≑ y β†’ 𝓀 j)
       β†’ ((x : X) β†’ A x x (refl x))
       β†’ (x y : X) (p : x ≑ y) β†’ A x y p
≑-elim A f x x (refl x) = f x

≑-nondep-elim : {X : 𝓀 i} (A : X β†’ X β†’ 𝓀 j)
              β†’ ((x : X) β†’ A x x)
              β†’ (x y : X) β†’ x ≑ y β†’ A x y
≑-nondep-elim A = ≑-elim (Ξ» x y _ β†’ A x y)

trans : {A : 𝓀 i} {x y z : A} β†’ x ≑ y β†’ y ≑ z β†’ x ≑ z
trans p (refl y) = p

sym : {A : 𝓀 i} {x y : A} β†’ x ≑ y β†’ y ≑ x
sym (refl x) = refl x

ap : {A : 𝓀 i} {B : 𝓀 j} (f : A β†’ B) {x y : A} β†’ x ≑ y β†’ f x ≑ f y
ap f (refl x) = refl (f x)

apβ‚‚ : {A : 𝓀 i} {B : 𝓀 j} {C : 𝓀 k} (f : A β†’ B β†’ C) {x x' : A} {y y' : B}
    β†’ x ≑ x' β†’ y ≑ y' β†’ f x y ≑ f x' y'
apβ‚‚ f (refl x) (refl y) = refl (f x y)

transport : {X : 𝓀 i} (A : X β†’ 𝓀 j)
          β†’ {x y : X} β†’ x ≑ y β†’ A x β†’ A y
transport A (refl x) a = a

_βˆ™_ : {A : 𝓀 i} {x y z : A} β†’ x ≑ y β†’ y ≑ z β†’ x ≑ z
_βˆ™_ = trans

infixl 7 _βˆ™_

_⁻¹ : {A : 𝓀 i} {x y : A} β†’ x ≑ y β†’ y ≑ x
_⁻¹ = sym

infix  40 _⁻¹

-- The (sub)type of prime numbers

β„™ : 𝓀₀
β„™ = Ξ£ p κž‰ β„• , is-prime p

β„™-inclusion : β„™ β†’ β„•
β„™-inclusion = pr₁

-- We can prove that this map is left-cancellable, i.e. it satisfies
-- β„™-inclusion u ≑ β„™-inclusion u β†’ u ≑ v.
-- Moreover, this map is an embedding (we haven't defined this concept yet).

-- Not quite the type of composite numbers:

CN : 𝓀
CN = Ξ£ x κž‰ β„• , Ξ£ (y , z) κž‰ β„• Γ— β„• , x ≑ y * z

CN' : 𝓀
CN' = Ξ£ x κž‰ β„• , Ξ£ (y , z) κž‰ β„• Γ— β„• , (y β‰₯ 2) Γ— (z β‰₯ 2) Γ— (x ≑ y * z)

CN-projection : CN β†’ β„•
CN-projection = pr₁

-- This map is not left-cancellable, and hence can't be considered to
-- be an an inclusion.

counter-example : CN-projection (6 , (3 , 2) , refl 6)
                ≑ CN-projection (6 , (2 , 3) , refl 6)
counter-example = refl 6

-- But how do we prove that these two tuples are *different*? They
-- certainly do look different. We'll do this later.

-- We will need to define
--
-- CN = Ξ£ x κž‰ β„• , βˆ₯ Ξ£ (y , z) κž‰ β„• Γ— β„• , x ≑ y * z βˆ₯, or equivalently
-- CN = Ξ£ x κž‰ β„• , βˆƒ (y , z) κž‰ β„• Γ— β„• , x ≑ y * z βˆ₯
--
-- to really get a *subtype* of composite numbers.


-- Another use of Ξ£.
-- The type of monoids.

is-prop : 𝓀 i β†’ 𝓀 i
is-prop X = (x y : X) β†’ x ≑ y

is-set : 𝓀 i β†’ 𝓀 i
is-set X = (x y : X) β†’ is-prop (x ≑ y)

Mon : 𝓀 (lsuc i)
Mon {i} = Ξ£ X κž‰ 𝓀 i  -- data
            , is-set X  -- property (we show that)
            Γ— (Ξ£ 𝟏 κž‰ X ,  -- data (but...)
               Ξ£ _Β·_ κž‰ (X β†’ X β†’ X) -- data
                  , (((x : X) β†’ (x Β· 𝟏 ≑ x)) -- (1) property
                  Γ—  ((x : X) β†’ (𝟏 Β· x ≑ x)) -- (2) property
                  Γ—  ((x y z : X) β†’ (x Β· (y Β· z)) ≑ ((x Β· y) Β· z)))) -- (3) property

-- This can be defined using a record in Agda:

record Mon' : 𝓀 (lsuc i) where
 constructor mon
 field
  carrier        : 𝓀 i  -- X
  carrier-is-set : is-set carrier
  𝟏              : carrier
  _Β·_            : carrier β†’ carrier β†’ carrier
  left-unit-law  : (x : carrier) β†’ x Β· 𝟏 ≑ x
  right-unit-law : (x : carrier) β†’ 𝟏 Β· x ≑ x
  assoc-law      : (x y z : carrier) β†’ (x Β· (y Β· z)) ≑ ((x Β· y) Β· z)

Ξ± : Mon {i} β†’ Mon' {i}
α (X , X-is-set , 𝟏 , _·_ , l , r , a) = mon X X-is-set 𝟏 _·_ l r a

Ξ² : Mon' {i} β†’ Mon {i}
β (mon X X-is-set 𝟏 _·_ l r a) = (X , X-is-set , 𝟏 , _·_ , l , r , a)

Ξ²Ξ± : (M : Mon {i}) β†’ Ξ² (Ξ± M) ≑ M
Ξ²Ξ± = refl

Ξ±Ξ² : (M : Mon' {i}) β†’ Ξ± (Ξ² M) ≑ M
Ξ±Ξ² = refl

-- This kind of proof doesn't belong to the realm of MLTT:

false-is-not-true[not-an-MLTT-proof] : false β‰’ true
false-is-not-true[not-an-MLTT-proof] ()

-- Proof in MLTT, which requires a universe (Cf. Ulrik's 2nd HoTT
-- lecture):

_≣_ : Bool β†’ Bool β†’ 𝓀₀
true  ≣ true  = πŸ™
true  ≣ false = 𝟘
false ≣ true  = 𝟘
false ≣ false = πŸ™

≑-gives-≣ : {x y : Bool} β†’ x ≑ y β†’ x ≣ y
≑-gives-≣ (refl true)  = ⋆
≑-gives-≣ (refl false) = ⋆

false-is-not-true : Β¬ (false ≑ true)
false-is-not-true p = II
 where
  I : false ≣ true
  I = ≑-gives-≣ p

  II : 𝟘
  II = I

false-is-not-true' : Β¬ (false ≑ true)
false-is-not-true' = ≑-gives-≣

-- Notice that this proof is different from the one given by Ulrik in
-- the HoTT track. Exercise: implement Ulrik's proof in Agda.

-- Exercise: prove that Β¬ (0 ≑ 1) in the natural numbers in MLTT style
-- without using `()`.

-- contrapositives.

contrapositive : {A : 𝓀 i} {B : 𝓀 j} β†’ (A β†’ B) β†’ (Β¬ B β†’ Β¬ A)
contrapositive f g a = g (f a)

Ξ -Β¬-gives-Β¬-Ξ£ : {X : 𝓀 i} {A : X β†’ 𝓀 j}
              β†’ ((x : X) β†’ Β¬ A x)
              β†’ Β¬ (Ξ£ x κž‰ X , A x)
Ξ -Β¬-gives-Β¬-Ξ£ Ο• (x , a) = Ο• x a

Β¬-Ξ£-gives-Ξ -Β¬ : {X : 𝓀 i} {A : X β†’ 𝓀 j}
              β†’ Β¬ (Ξ£ x κž‰ X , A x)
              β†’ ((x : X) β†’ Β¬ A x)
Β¬-Ξ£-gives-Ξ -Β¬ Ξ³ x a = Ξ³ (x , a)


-- Equality in Ξ£ types.

from-Ξ£-≑' : {X : 𝓀 i} {A : X β†’ 𝓀 j}
            {(x , a) (y , b) : Ξ£ A}
          β†’ (x , a) ≑ (y , b)
          β†’ Ξ£ p κž‰ (x ≑ y) , (transport A p a ≑ b)
from-Ξ£-≑' (refl (x , a)) = (refl x , refl a)

to-Ξ£-≑' : {X : 𝓀 i} {A : X β†’ 𝓀 j}
          {(x , a) (y , b) : Ξ£ A}
        β†’ (Ξ£ p κž‰ (x ≑ y) , (transport A p a ≑ b))
        β†’ (x , a) ≑ (y , b)
to-Ξ£-≑' (refl x , refl a) = refl (x , a)

module _ {X : 𝓀 i} {A : 𝓀 j}
         {(x , a) (y , b) : X Γ— A} where

 from-Γ—-≑ : (x , a) ≑ (y , b)
          β†’ (x ≑ y) Γ— (a ≑ b)
 from-Γ—-≑ (refl (x , a)) = refl x , refl a


 to-Γ—-≑ : (x ≑ y) Γ— (a ≑ b)
        β†’ (x , a) ≑ (y , b)
 to-Γ—-≑ (refl x , refl a) = refl (x , a)

module _ {X : 𝓀 i} {A : X β†’ 𝓀 j}
         {(x , a) (y , b) : Ξ£ A} where

 -- x y : X
 -- a : A x
 -- b : A y

 from-Ξ£-≑ : (x , a) ≑ (y , b)
          β†’ Ξ£ p κž‰ (x ≑ y) , transport A p a ≑ b
 from-Ξ£-≑ (refl (x , a)) = refl x , refl a


 to-Ξ£-≑ : (Ξ£ p κž‰ (x ≑ y) , (transport A p a ≑ b))
        β†’ (x , a) ≑ (y , b)
 to-Ξ£-≑ (refl x , refl a) = refl (x , a)


 contra-from-Ξ£-≑ : Β¬ (Ξ£ p κž‰ (x ≑ y) , (transport A p a ≑ b))
                 β†’ (x , a) β‰’ (y , b)
 contra-from-Ξ£-≑ = contrapositive from-Ξ£-≑

 contra-to-Ξ£-≑ : (x , a) β‰’ (y , b)
               β†’ Β¬ (Ξ£ p κž‰ (x ≑ y) , (transport A p a ≑ b))
 contra-to-Ξ£-≑ = contrapositive to-Ξ£-≑

 to-Ξ£-β‰’ : ((p : x ≑ y) β†’ transport A p a β‰’ b)
        β†’ (x , a) β‰’ (y , b)
 to-Ξ£-β‰’ u = contra-from-Ξ£-≑ (Ξ -Β¬-gives-Β¬-Ξ£ u)

 from-Ξ£-β‰’ : (x , a) β‰’ (y , b)
          β†’ ((p : x ≑ y) β†’ transport A p a β‰’ b)
 from-Ξ£-β‰’ v = Β¬-Ξ£-gives-Ξ -Β¬ (contra-to-Ξ£-≑ v)

We now revisit the example above. How do we prove that aa and bb are different? It’s not easy. We use the above lemmas.

aa bb : CN
aa = (6 , (3 , 2) , refl 6)
bb = (6 , (2 , 3) , refl 6)

To prove that aa β‰’ bb, we need to know that β„• is a set! And this is difficult. See the module Hedbergs-Theorem for a complete proof.

For the moment we just assume that β„• is a set, and prove that 3 β‰’ 2 by cheating (produce a genuine MLTT proof as an exercise).

3-is-not-2 : 3 β‰’ 2
3-is-not-2 ()

example-revisited : is-set β„• β†’ aa β‰’ bb
example-revisited β„•-is-set = I
 where
  A : β„• β†’ 𝓀₀
  A x = Ξ£ (y , z) κž‰ β„• Γ— β„• , x ≑ y * z

  II : (p : 6 ≑ 6) β†’ transport A p ((3 , 2) , refl 6) β‰’  ((2 , 3) , refl 6)
  II p = VIII
   where
    III : p ≑ refl 6
    III = β„•-is-set 6 6 p (refl 6)

    IV : transport A p ((3 , 2) , refl 6) ≑ ((3 , 2) , refl 6)
    IV = ap (Ξ» - β†’ transport A - ((3 , 2) , refl 6)) III

    V : ((3 , 2) , refl 6) β‰’ ((2 , 3) , refl 6)
    V q = 3-is-not-2 VII
     where
      VI : (3 , 2) ≑ (2 , 3)
      VI = ap pr₁ q

      VII : 3 ≑ 2
      VII = ap pr₁ VI

    VIII : transport A p ((3 , 2) , refl 6) β‰’  ((2 , 3) , refl 6)
    VIII r = V IX
     where
      IX : ((3 , 2) , refl 6) ≑ ((2 , 3) , refl 6)
      IX = trans (IV ⁻¹) r

  I : aa β‰’ bb
  I = to-Ξ£-β‰’ II

If there is time, I will do some isomorphisms.