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

open import lib.Basics
open import lib.NType2
open import lib.Equivalence2
open import lib.path-seq.Rotations
open import lib.types.Unit
open import lib.types.Nat
open import lib.types.Pi
open import lib.types.Pointed
open import lib.types.Sigma
open import lib.types.Paths
open import lib.types.TLevel
open import lib.types.Truncation

module lib.NConnected where

is-connected : ∀ {i} → ℕ₋₂ → Type i → Type i
is-connected n A = is-contr (Trunc n A)

has-conn-fibers : ∀ {i j} {A : Type i} {B : Type j} → ℕ₋₂ → (A → B) → Type (lmax i j)
has-conn-fibers {A = A} {B = B} n f =
  Π B (λ b → is-connected n (hfiber f b))

{- all types are -2-connected -}
-2-conn : ∀ {i} (A : Type i) → is-connected -2 A
-2-conn A = Trunc-level

{- all inhabited types are -1-connected -}
inhab-conn : ∀ {i} {A : Type i} (a : A) → is-connected -1 A
inhab-conn a = has-level-in ([ a ] , prop-has-all-paths [ a ])

{- connectedness is a prop -}
is-connected-is-prop : ∀ {i} {n : ℕ₋₂} {A : Type i}
  → is-prop (is-connected n A)
is-connected-is-prop = is-contr-is-prop

{- "induction principle" for n-connected maps (where codomain is n-type) -}
module ConnExtend {i j k} {A : Type i} {B : Type j} {n : ℕ₋₂}
                  {h : A → B} (c : has-conn-fibers n h)
                  (P : B → n -Type k) where

  private
    helper : Π A (fst ∘ P ∘ h)
      → (b : B) → Trunc n (Σ A (λ a → h a == b)) → (fst (P b))
    helper t b r =
      Trunc-rec {{snd (P b)}}
        (λ x → transport (λ y → fst (P y)) (snd x) (t (fst x)))
        r

  restr : Π B (fst ∘ P) → Π A (fst ∘ P ∘ h)
  restr t = t ∘ h

  abstract
    ext : Π A (fst ∘ P ∘ h) → Π B (fst ∘ P)
    ext f b = helper f b (contr-center (c b))

  private
    abstract
      ext-β' : (f : Π A (fst ∘ P ∘ h)) (a : A) → restr (ext f) a == f a
      ext-β' f a =
        transport
          (λ r →  Trunc-rec {{snd (P (h a))}} _ r == f a)
          (! (contr-path(c (h a)) [ (a , idp) ]))
          idp

  abstract
    restr-β : (t : Π B (fst ∘ P)) (b : B) → ext (restr t) b == t b
    restr-β t b =
      Trunc-elim
        {{λ r → =-preserves-level {x = helper (t ∘ h) b r} (snd (P b))}}
        (λ x → lemma (fst x) b (snd x))
        (contr-center (c b))
      where
      lemma : ∀ xl → ∀ b → (p : h xl == b) →
        helper (t ∘ h) b [ (xl , p) ] == t b
      lemma xl ._ idp = idp

  restr-is-equiv : is-equiv restr
  restr-is-equiv = is-eq restr ext (λ= ∘ ext-β') (λ= ∘ restr-β)

  restr-equiv : Π B (fst ∘ P) ≃ Π A (fst ∘ P ∘ h)
  restr-equiv = restr , restr-is-equiv

  ext-β : (f : Π A (fst ∘ P ∘ h)) (a : A) → restr (ext f) a == f a
  ext-β f = app= (is-equiv.f-g restr-is-equiv f)

  abstract
    restr-β-ext-β-adj : (t : Π B (fst ∘ P)) (a : A)
      → ext-β (restr t) a == restr-β t (h a)
    restr-β-ext-β-adj t a =
      ext-β (restr t) a
        =⟨ ! (ap (λ s → app= s a) (is-equiv.adj restr-is-equiv t)) ⟩
      app= (ap restr (λ= (restr-β t))) a
        =⟨ ∘-ap (_$ a) restr (λ= (restr-β t)) ⟩
      app= (λ= (restr-β t)) (h a)
        =⟨ app=-β (restr-β t) (h a) ⟩
      restr-β t (h a) =∎

open ConnExtend using () renaming
  (ext to conn-extend;
   ext-β to conn-extend-β;
   restr-is-equiv to pre∘-conn-is-equiv) public

module ⊙ConnExtend {i j k} {X : Ptd i} {Y : Ptd j} {Z : Ptd k} {n : ℕ₋₂}
                   (h : X ⊙→ Y) (c : has-conn-fibers n (fst h))
                   (Z-level : has-level n (de⊙ Z)) where

  open ConnExtend c (λ _ → de⊙ Z , Z-level) public

  ⊙restr : Y ⊙→ Z → X ⊙→ Z
  ⊙restr = _⊙∘ h

  ext-pt-seq : (f : X ⊙→ Z) → ext (fst f) (pt Y) =-= pt Z
  ext-pt-seq f =
    ext (fst f) (pt Y)
      =⟪ ! (ap (ext (fst f)) (snd h)) ⟫
    ext (fst f) (fst h (pt X))
      =⟪ ext-β (fst f) (pt X) ⟫
    fst f (pt X)
      =⟪ snd f ⟫
    pt Z ∎∎

  ext-pt : (f : X ⊙→ Z) → ext (fst f) (pt Y) == pt Z
  ext-pt f = ↯ (ext-pt-seq f)

  ⊙ext : X ⊙→ Z → Y ⊙→ Z
  ⊙ext f = ext (fst f) , ext-pt f

  abstract
    ⊙ext-β : (f : X ⊙→ Z) → ⊙restr (⊙ext f) == f
    ⊙ext-β f =
      ⊙λ=' (ext-β (fst f)) $
      ↓-idf=cst-in $ =ₛ-out $
      ap (fst (⊙ext f)) (snd h) ◃∙ ext-pt-seq f
        =ₛ⟨ 0 & 2 & seq-!-inv-r (ap (fst (⊙ext f)) (snd h) ◃∎) ⟩
      ext-β (fst f) (pt X) ◃∙ snd f ◃∎ ∎ₛ

    ⊙restr-β : (t : Y ⊙→ Z) → ⊙ext (⊙restr t) == t
    ⊙restr-β t =
      ⊙λ=' (restr-β (fst t)) $
      ↓-idf=cst-in $ =ₛ-out $
      ext-pt-seq (⊙restr t)
        =ₛ₁⟨ 1 & 1 & restr-β-ext-β-adj (fst t) (pt X) ⟩
      ! (ap (ext (fst (⊙restr t))) (snd h)) ◃∙
      restr-β (fst t) (fst h (pt X)) ◃∙
      snd (⊙restr t) ◃∎
        =ₛ⟨ 2 & 1 & expand (ap (fst t) (snd h) ◃∙ snd t ◃∎) ⟩
      ! (ap (ext (fst (⊙restr t))) (snd h)) ◃∙
      restr-β (fst t) (fst h (pt X)) ◃∙
      ap (fst t) (snd h) ◃∙
      snd t ◃∎
        =ₛ⟨ 0 & 3 & !ₛ $ pre-rotate-in $
            homotopy-naturality
              (ext (fst (⊙restr t)))
              (fst t)
              (restr-β (fst t))
              (snd h) ⟩
      restr-β (fst t) (pt Y) ◃∙ snd t ◃∎ ∎ₛ

  ⊙restr-is-equiv : is-equiv ⊙restr
  ⊙restr-is-equiv = is-eq ⊙restr ⊙ext ⊙ext-β ⊙restr-β

  ⊙restr-equiv : (Y ⊙→ Z) ≃ (X ⊙→ Z)
  ⊙restr-equiv = ⊙restr , ⊙restr-is-equiv

open ⊙ConnExtend using () renaming
  (⊙ext to ⊙conn-extend;
   ⊙restr-is-equiv to pre⊙∘-conn-is-equiv) public

{- generalized "almost induction principle" for maps into ≥n-types
   TODO: rearrange this to use ≤T?                                 -}
conn-extend-general : ∀ {i j} {A : Type i} {B : Type j} {n k : ℕ₋₂}
  → {f : A → B} → has-conn-fibers n f
  → ∀ {l} (P : B → (k +2+ n) -Type l)
  → ∀ t → has-level k (Σ (Π B (fst ∘ P)) (λ s → (s ∘ f) == t))
conn-extend-general {k = ⟨-2⟩} c P t =
  equiv-is-contr-map (pre∘-conn-is-equiv c P) t
conn-extend-general {B = B} {n = n} {k = S k'} {f = f} c P t = has-level-in
  λ {(g , p) (h , q) →
    equiv-preserves-level (e g h p q)
      {{conn-extend-general {k = k'} c (Q g h) (app= (p ∙ ! q))}} }
  where
    Q : (g h : Π B (fst ∘ P)) → B → (k' +2+ n) -Type _
    Q g h b = ((g b == h b) , has-level-apply (snd (P b)) _ _)

    app=-pre∘ : ∀ {i j k} {A : Type i} {B : Type j} {C : B → Type k}
      (f : A → B) {g h : Π B C} (p : g == h)
      → app= (ap (λ k → k ∘ f) p) == app= p ∘ f
    app=-pre∘ f idp = idp

    move-right-on-right-econv : ∀ {i} {A : Type i} {x y z : A}
      (p : x == y) (q : x == z) (r : y == z)
      → (p == q ∙ ! r) ≃ (p ∙ r == q)
    move-right-on-right-econv {x = x} p idp idp =
      (_ , pre∙-is-equiv (∙-unit-r p))

    lemma : ∀ g h p q → (H : g ∼ h)
      → ((H ∘ f) == app= (p ∙ ! q))
         ≃ (ap (λ v → v ∘ f) (λ= H) ∙ q == p)
    lemma g h p q H =
      move-right-on-right-econv (ap (λ v → v ∘ f) (λ= H)) p q
      ∘e transport (λ w → (w == app= (p ∙ ! q))
                      ≃ (ap (λ v → v ∘ f) (λ= H) == p ∙ ! q))
                   (app=-pre∘ f (λ= H) ∙ ap (λ k → k ∘ f) (λ= $ app=-β H))
                   (ap-equiv app=-equiv _ _ ⁻¹)

    e : ∀ g h p q  →
      (Σ (g ∼ h) (λ r → (r ∘ f) == app= (p ∙ ! q)))
      ≃ ((g , p) == (h , q))
    e g h p q =
      ((=Σ-econv _ _ ∘e Σ-emap-r (λ u → ↓-app=cst-econv ∘e !-equiv))
      ∘e (Σ-emap-l _ λ=-equiv)) ∘e Σ-emap-r (lemma g h p q)

conn-in : ∀ {i j} {A : Type i} {B : Type j} {n : ℕ₋₂} {h : A → B}
  → (∀ (P : B → n -Type (lmax i j))
     → Σ (Π A (fst ∘ P ∘ h) → Π B (fst ∘ P))
         (λ u → ∀ (t : Π A (fst ∘ P ∘ h)) → u t ∘ h ∼ t))
  → has-conn-fibers n h
conn-in {A = A} {B = B} {h = h} sec b =
  let s = sec (λ b → (Trunc _ (hfiber h b) , Trunc-level))
  in has-level-in (fst s (λ a → [ a , idp ]) b ,
      Trunc-elim (λ k → transport
                   (λ v → fst s (λ a → [ a , idp ]) (fst v) == [ fst k , snd v ])
                   (contr-path (pathfrom-is-contr (h (fst k))) (b , snd k))
                   (snd s (λ a → [ a , idp ]) (fst k))))

abstract
  pointed-conn-in : ∀ {i} {n : ℕ₋₂} (A : Type i) (a₀ : A)
    → has-conn-fibers {A = ⊤} n (cst a₀) → is-connected (S n) A
  pointed-conn-in {n = n} A a₀ c = has-level-in
    ([ a₀ ] ,
     Trunc-elim
       (λ a → Trunc-rec
             (λ x → ap [_] (snd x)) (contr-center $ c a)))

abstract
  pointed-conn-out : ∀ {i} {n : ℕ₋₂} (A : Type i) (a₀ : A)
    {{_ : is-connected (S n) A}} → has-conn-fibers {A = ⊤} n (cst a₀)
  pointed-conn-out {n = n} A a₀ {{c}} a = has-level-in
    (point ,
     λ y → ! (cancel point)
           ∙ (ap out $ contr-has-all-paths (into point) (into y))
           ∙ cancel y)
    where
      into-aux : Trunc n (Σ ⊤ (λ _ → a₀ == a)) → Trunc n (a₀ == a)
      into-aux = Trunc-fmap snd

      into : Trunc n (Σ ⊤ (λ _ → a₀ == a))
        → [_] {n = S n} a₀ == [ a ]
      into = <– (=ₜ-equiv [ a₀ ] [ a ]) ∘ into-aux

      out-aux : Trunc n (a₀ == a) → Trunc n (Σ ⊤ (λ _ → a₀ == a))
      out-aux = Trunc-fmap (λ p → (tt , p))

      out : [_] {n = S n} a₀ == [ a ] → Trunc n (Σ ⊤ (λ _ → a₀ == a))
      out = out-aux ∘ –> (=ₜ-equiv [ a₀ ] [ a ])

      cancel : (x : Trunc n (Σ ⊤ (λ _ → a₀ == a))) → out (into x) == x
      cancel x =
        out (into x)
          =⟨ ap out-aux (<–-inv-r (=ₜ-equiv [ a₀ ] [ a ]) (into-aux x)) ⟩
        out-aux (into-aux x)
          =⟨ Trunc-fmap-∘ _ _ x ⟩
        Trunc-fmap (λ q → (tt , (snd q))) x
          =⟨ Trunc-elim {P = λ x → Trunc-fmap (λ q → (tt , snd q)) x == x}
               (λ _ → idp) x ⟩
        x =∎

      point : Trunc n (Σ ⊤ (λ _ → a₀ == a))
      point = out $ contr-has-all-paths [ a₀ ] [ a ]

prop-over-connected :  ∀ {i j} {A : Type i} {a : A} {{p : is-connected 0 A}}
  → (P : A → hProp j)
  → fst (P a) → Π A (fst ∘ P)
prop-over-connected P x = conn-extend (pointed-conn-out _ _) P (λ _ → x)

{- Connectedness of a truncated type -}
instance
  Trunc-preserves-conn : ∀ {i} {A : Type i} {n : ℕ₋₂} {m : ℕ₋₂}
    → is-connected n A → is-connected n (Trunc m A)
  Trunc-preserves-conn {n = ⟨-2⟩} _ = Trunc-level
  Trunc-preserves-conn {A = A} {n = S n} {m} c = lemma (contr-center c) (contr-path c)
    where
    lemma : (x₀ : Trunc (S n) A) → (∀ x → x₀ == x) → is-connected (S n) (Trunc m A)
    lemma = Trunc-elim
      (λ a → λ p → has-level-in ([ [ a ] ] ,
        Trunc-elim
          (Trunc-elim
            {{λ _ → =-preserves-level
                      (Trunc-preserves-level (S n) Trunc-level)}}
            (λ x → <– (=ₜ-equiv [ [ a ] ] [ [ x ] ])
               (Trunc-fmap (ap [_])
                 (–> (=ₜ-equiv [ a ] [ x ]) (p [ x ])))))))

{- Connectedness of a Σ-type -}
abstract
 instance
  Σ-conn : ∀ {i} {j} {A : Type i} {B : A → Type j} {n : ℕ₋₂}
    → is-connected n A → (∀ a → is-connected n (B a))
    → is-connected n (Σ A B)
  Σ-conn {A = A} {B = B} {n = ⟨-2⟩} cA cB = -2-conn (Σ A B)
  Σ-conn {A = A} {B = B} {n = S m} cA cB =
    Trunc-elim
      {P = λ ta → (∀ tx → ta == tx) → is-connected (S m) (Σ A B)}
      (λ a₀ pA →
        Trunc-elim
          {P = λ tb → (∀ ty → tb == ty) → is-connected (S m) (Σ A B)}
          (λ b₀ pB → has-level-in
            ([ a₀ , b₀ ] ,
              Trunc-elim
                {P = λ tp → [ a₀ , b₀ ] == tp}
                (λ {(r , s) →
                  Trunc-rec
                    (λ pa → Trunc-rec
                      (λ pb → ap [_] (pair= pa (from-transp! B pa pb)))
                      (–> (=ₜ-equiv [ b₀ ] [ transport! B pa s ])
                          (pB [ transport! B pa s ])))
                    (–> (=ₜ-equiv [ a₀ ] [ r ]) (pA [ r ]))})))
          (contr-center (cB a₀)) (contr-path (cB a₀)))
      (contr-center cA) (contr-path cA)

  ×-conn : ∀ {i} {j} {A : Type i} {B : Type j} {n : ℕ₋₂}
    → is-connected n A → is-connected n B
    → is-connected n (A × B)
  ×-conn cA cB = Σ-conn cA (λ _ → cB)

{- connectedness of a path space -}
abstract
 instance
  path-conn : ∀ {i} {A : Type i} {x y : A} {n : ℕ₋₂}
    → is-connected (S n) A → is-connected n (x == y)
  path-conn {x = x} {y = y} cA =
    equiv-preserves-level (=ₜ-equiv [ x ] [ y ])
      {{has-level-apply (contr-is-prop cA) [ x ] [ y ]}}

{- an n-Type which is n-connected is contractible -}
connected-at-level-is-contr : ∀ {i} {A : Type i} {n : ℕ₋₂}
  {{pA : has-level n A}} {{cA : is-connected n A}} → is-contr A
connected-at-level-is-contr {{pA}} {{cA}} =
  equiv-preserves-level (unTrunc-equiv _) {{cA}}

{- if A is n-connected and m ≤ n, then A is m-connected -}
connected-≤T : ∀ {i} {m n : ℕ₋₂} {A : Type i}
  → m ≤T n → {{_ : is-connected n A}} → is-connected m A
connected-≤T {m = m} {n = n} {A = A} leq =
  transport is-contr (ua (Trunc-fuse-≤ A leq)) (Trunc-preserves-level m ⟨⟩)

{- Equivalent types have the same connectedness -}
equiv-preserves-conn : ∀ {i j} {A : Type i} {B : Type j} {n : ℕ₋₂} (e : A ≃ B)
  {{_ : is-connected n A}} → is-connected n B
equiv-preserves-conn {n = n} e = equiv-preserves-level (Trunc-emap e)

trunc-proj-conn : ∀ {i} (A : Type i) (n : ℕ₋₂)
  → has-conn-fibers n ([_] {n = n} {A = A})
trunc-proj-conn A n =
  conn-in $ λ P →
  Trunc-elim {P = fst ∘ P} {{snd ∘ P}} , λ t a → idp

{- Composite of two connected functions is connected -}
∘-conn : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k}
  → {n : ℕ₋₂} → (f : A → B) → (g : B → C)
  → has-conn-fibers n f
  → has-conn-fibers n g
  → has-conn-fibers n (g ∘ f)
∘-conn {n = n} f g cf cg =
  conn-in (λ P → conn-extend cg P ∘ conn-extend cf (P ∘ g) , lemma P)
    where
      lemma : ∀ P h x → conn-extend cg P (conn-extend cf (P ∘ g) h) (g (f x)) == h x
      lemma P h x =
        conn-extend cg P (conn-extend cf (P ∘ g) h) (g (f x))
          =⟨ conn-extend-β cg P (conn-extend cf (P ∘ g) h) (f x) ⟩
        conn-extend cf (P ∘ g) h (f x)
          =⟨ conn-extend-β cf (P ∘ g) h x ⟩
        h x
          =∎


module Syntax.Type where

open import Type

-- Assures that a value has a certain type
type-ascript : ∀{ℓ} → (T : Type{ℓ}) → T → T
type-ascript T x = x
{-# INLINE type-ascript #-}

_:-[_] = type-ascript
infixr 0.98 _:-[_]
{-# INLINE _:-[_] #-}

infixl 10 type-ascript
syntax type-ascript T x = x :of: T


{-

Defines groups and adds some smart constructors

-}
{-# OPTIONS --safe #-}
module Cubical.Algebra.Group.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Structure
open import Cubical.Data.Sigma
open import Cubical.Algebra.Monoid
open import Cubical.Algebra.Semigroup

private
  variable
    ℓ : Level

record IsGroup {G : Type ℓ}
               (1g : G) (_·_ : G → G → G) (inv : G → G) : Type ℓ where

  constructor isgroup

  field
    isMonoid  : IsMonoid 1g _·_
    inverse   : (x : G) → (x · inv x ≡ 1g) × (inv x · x ≡ 1g)

  open IsMonoid isMonoid public

  infixl 6 _-_

  -- Useful notation for additive groups
  _-_ : G → G → G
  x - y = x · inv y

  invl : (x : G) → inv x · x ≡ 1g
  invl x = inverse x .snd

  invr : (x : G) → x · inv x ≡ 1g
  invr x = inverse x .fst

record GroupStr (G : Type ℓ) : Type ℓ where

  constructor groupstr

  field
    1g      : G
    _·_     : G → G → G
    inv     : G → G
    isGroup : IsGroup 1g _·_ inv

  infixr 7 _·_

  open IsGroup isGroup public

Group : ∀ ℓ → Type (ℓ-suc ℓ)
Group ℓ = TypeWithStr ℓ GroupStr

Group₀ : Type₁
Group₀ = Group ℓ-zero

group : (G : Type ℓ) (1g : G) (_·_ : G → G → G) (inv : G → G) (h : IsGroup 1g _·_ inv) → Group ℓ
group G 1g _·_ inv h = G , groupstr 1g _·_ inv h

isSetGroup : (G : Group ℓ) → isSet ⟨ G ⟩
isSetGroup G = GroupStr.isGroup (snd G) .IsGroup.isMonoid .IsMonoid.isSemigroup .IsSemigroup.is-set

makeIsGroup : {G : Type ℓ} {e : G} {_·_ : G → G → G} { inv : G → G}
              (is-setG : isSet G)
              (assoc : (x y z : G) → x · (y · z) ≡ (x · y) · z)
              (rid : (x : G) → x · e ≡ x)
              (lid : (x : G) → e · x ≡ x)
              (rinv : (x : G) → x · inv x ≡ e)
              (linv : (x : G) → inv x · x ≡ e)
            → IsGroup e _·_ inv
IsGroup.isMonoid (makeIsGroup is-setG assoc rid lid rinv linv) = makeIsMonoid is-setG assoc rid lid
IsGroup.inverse (makeIsGroup is-setG assoc rid lid rinv linv) = λ x → rinv x , linv x

makeGroup : {G : Type ℓ} (e : G) (_·_ : G → G → G) (inv : G → G)
            (is-setG : isSet G)
            (assoc : (x y z : G) → x · (y · z) ≡ (x · y) · z)
            (rid : (x : G) → x · e ≡ x)
            (lid : (x : G) → e · x ≡ x)
            (rinv : (x : G) → x · inv x ≡ e)
            (linv : (x : G) → inv x · x ≡ e)
          → Group ℓ
makeGroup e _·_ inv is-setG assoc rid lid rinv linv = _ , helper
  where
  helper : GroupStr _
  GroupStr.1g helper = e
  GroupStr._·_ helper = _·_
  GroupStr.inv helper = inv
  GroupStr.isGroup helper = makeIsGroup is-setG assoc rid lid rinv linv

makeGroup-right : {A : Type ℓ}
  → (1g : A)
  → (_·_ : A → A → A)
  → (inv : A → A)
  → (set : isSet A)
  → (assoc : ∀ a b c → a · (b · c) ≡ (a · b) · c)
  → (rUnit : ∀ a → a · 1g ≡ a)
  → (rCancel : ∀ a → a · inv a ≡ 1g)
  → Group ℓ
makeGroup-right 1g _·_ inv set assoc rUnit rCancel =
  makeGroup 1g _·_ inv set assoc rUnit lUnit rCancel lCancel
  where
    abstract
      lCancel : ∀ a → inv a · a ≡ 1g
      lCancel a =
        inv a · a
          ≡⟨ sym (rUnit _)  ⟩
        (inv a · a) · 1g
          ≡⟨ cong (_·_ _) (sym (rCancel (inv a))) ⟩
        (inv a · a) · (inv a · (inv (inv a)))
          ≡⟨ assoc _ _ _ ⟩
        ((inv a · a) · (inv a)) · (inv (inv a))
          ≡⟨ cong (λ □ → □ · _) (sym (assoc _ _ _)) ⟩
        (inv a · (a · inv a)) · (inv (inv a))
          ≡⟨ cong (λ □ → (inv a · □) · (inv (inv a))) (rCancel a) ⟩
        (inv a · 1g) · (inv (inv a))
          ≡⟨ cong (λ □ → □ · (inv (inv a))) (rUnit (inv a)) ⟩
        inv a · (inv (inv a))
          ≡⟨ rCancel (inv a) ⟩
        1g
          ∎

      lUnit : ∀ a → 1g · a ≡ a
      lUnit a =
        1g · a
          ≡⟨ cong (λ b → b · a) (sym (rCancel a)) ⟩
        (a · inv a) · a
          ≡⟨ sym (assoc _ _ _) ⟩
        a · (inv a · a)
          ≡⟨ cong (a ·_) (lCancel a) ⟩
        a · 1g
          ≡⟨ rUnit a ⟩
        a
          ∎

makeGroup-left : {A : Type ℓ}
  → (1g : A)
  → (_·_ : A → A → A)
  → (inv : A → A)
  → (set : isSet A)
  → (assoc : ∀ a b c → a · (b · c) ≡ (a · b) · c)
  → (lUnit : ∀ a → 1g · a ≡ a)
  → (lCancel : ∀ a → (inv a) · a ≡ 1g)
  → Group ℓ
makeGroup-left 1g _·_ inv set assoc lUnit lCancel =
  makeGroup 1g _·_ inv set assoc rUnit lUnit rCancel lCancel
  where
    abstract
      rCancel : ∀ a → a · inv a ≡ 1g
      rCancel a =
        a · inv a
          ≡⟨ sym (lUnit _)  ⟩
        1g · (a · inv a)
          ≡⟨ cong (λ b → b · (a · inv a)) (sym (lCancel (inv a))) ⟩
        (inv (inv a) · inv a) · (a · inv a)
          ≡⟨ sym (assoc (inv (inv a)) (inv a) _) ⟩
        inv (inv a) · (inv a · (a · inv a))
          ≡⟨ cong (inv (inv a) ·_) (assoc (inv a) a (inv a)) ⟩
        (inv (inv a)) · ((inv a · a) · (inv a))
          ≡⟨ cong (λ b → (inv (inv a)) · (b · (inv a))) (lCancel a) ⟩
        inv (inv a) · (1g · inv a)
          ≡⟨ cong (inv (inv a) ·_) (lUnit (inv a)) ⟩
        inv (inv a) · inv a
          ≡⟨ lCancel (inv a) ⟩
        1g
          ∎

      rUnit : ∀ a → a · 1g ≡ a
      rUnit a =
        a · 1g
          ≡⟨ cong (a ·_) (sym (lCancel a)) ⟩
        a · (inv a · a)
          ≡⟨ assoc a (inv a) a ⟩
        (a · inv a) · a
          ≡⟨ cong (λ b → b · a) (rCancel a) ⟩
        1g · a
          ≡⟨ lUnit a ⟩
        a
          ∎


module Day3 where

open import Data.String as String
open import Data.Maybe
open import Foreign.Haskell using (Unit)
open import Data.List as List hiding (fromMaybe)
open import Data.Nat
open import Data.Nat.DivMod
open import Data.Nat.Properties
import Data.Nat.Show as ℕs
open import Data.Char
open import Data.Vec as Vec renaming (_>>=_ to _VV=_ ; toList to VecToList)
open import Data.Product
open import Relation.Nullary
open import Data.Nat.Properties
open import Data.Bool.Base
open import AocIO
open import AocUtil
open import AocVec
open import Relation.Binary.PropositionalEquality
open import EvenOdd

printUsage : String → IO Unit
printUsage name = printString ("Usage: " String.++ name String.++ " NUMBER\n(NUMBER > 0)")

sqr : (l : ℕ) → Σ[ k ∈ ℕ ] (k ≡ l * l)
sqr l = l * l , refl

first-larger-odd-square : {m : ℕ} → (n : ℕ) → suc m ≡ n → Σ[ k ∈ ℕ ] (n ≤ (k * k) × Odd k)
first-larger-odd-square {m} n n-is-suc = helper 1 m n-is-suc oddOne
  where
    helper : (m diff : ℕ) → (m + diff) ≡ n → Odd m → Σ[ k ∈ ℕ ] (n ≤ (k * k) × Odd k)
    helper m (suc (suc diff)) p m-is-odd with sqr m
    ... | (m² , m²≡m*m) with n ≤? m²
    ... | yes n≤m² rewrite m²≡m*m = m , n≤m² , m-is-odd
    ... | no _ = helper (suc (suc m)) diff rewr-p (oddSuc m-is-odd)
      where
        rewr-p : suc (suc m + diff) ≡ n
        rewr-p with (+-suc m diff) | (+-suc m (suc diff))
        ... | s | t rewrite (sym s) | t = p
    helper m zero p m-is-odd rewrite (+-identityʳ m) with (sqr m)
    ... | (m² , q) = m , (my-proof n refl) , m-is-odd
      where
        my-proof : (k : ℕ) → k ≡ n → n ≤ m * m
        my-proof k p₁ rewrite sym p₁ with k
        ... | zero = z≤n
        ... | suc kk rewrite p with (m≤m+n kk (kk * suc kk))
        ... | kk≤kk+junk = s≤s kk≤kk+junk
    helper zero (suc zero) p ()
    helper (suc zero) (suc zero) p m-is-odd rewrite sym p = 3 , (s≤s (s≤s z≤n) , oddSuc oddOne)
    helper (suc (suc m)) (suc zero) p m-is-odd = (suc (suc m)) , my-proof n refl , m-is-odd
      where
        my-proof : (k : ℕ) → k ≡ n → n ≤ suc (suc (m + suc (suc (m + m * suc (suc m)))))
        my-proof k p₁ rewrite sym p₁ with k
        ... | zero = z≤n
        -- we replace with p and get an expression 1 + m ≤ suc (suc m + junk)
        -- +-comm m 1 turns 1 + m into suc m
        -- sym +-suc turns m + suc junk into suc (m + junk) to match the number on the other side
        -- finally we cancel suc on both sides and use m ≤ m + junk
        ... | suc kk rewrite sym p | +-comm m 1 | +-suc m (suc (m + m * suc (suc m))) = s≤s (s≤s (s≤s (m≤m+n m (suc (m + m * suc (suc m))))))

oddness : ∀ {n} → Odd n → ℕ
oddness oddOne = 1
oddness (oddSuc v) = suc (oddness v)

ring-for-square# : {m : ℕ} → (n : ℕ) → suc m ≡ n → Σ[ k ∈ ℕ ] Odd k × ℕ
ring-for-square# zero ()
ring-for-square# (suc n) p with (first-larger-odd-square (suc n) (cong suc refl))
... | k , proj₄ , k-odd = k , k-odd , (oddness k-odd)

ring-corners : {m : ℕ} → Odd m → ℕ × ℕ × ℕ × ℕ × ℕ
ring-corners oddOne = 1 , (1 , (1 , 1 , 1))
ring-corners {(suc (suc n))} (oddSuc _)  = (n * n) , ((proj₁ first-corner) , ((proj₁ second-corner) , ((proj₁ third-corner) , (proj₁ fourth-corner))))
  where
    first-corner : Σ[ k ∈ ℕ ] k ≡ suc ((n * n) + n)
    first-corner = suc (n * n + n) , refl
    second-corner : Σ[ k ∈ ℕ ] k ≡ suc (suc ((n * n) + n + n))
    second-corner = (suc (suc (n * n + n + n))) , refl
    third-corner : Σ[ k ∈ ℕ ] k ≡ suc (suc (suc ((n * n) + n + n + n)))
    third-corner = suc (suc (suc (n * n + n + n + n))) , refl
    fourth-corner : Σ[ k ∈ ℕ ] k ≡ suc (suc (n + suc (suc (n + n * suc (suc n)))))
    fourth-corner = sqr (suc (suc n))
    ring-length : Σ[ k ∈ ℕ ] k ≡ (2 * (suc (suc n))) + (2 * n)
    ring-length = (2 * (suc (suc n)) + 2 * n) , refl
    -- proof that fourth-corner = ring-length + prev-fourth-corner
    ring-length-proof : {m l : ℕ} → m ≡ suc (suc (n + suc (suc (n + n * suc (suc n))))) → l ≡ (2 * (suc (suc n))) + (2 * n) →  l + (n * n) ≡ m
    ring-length-proof p q rewrite p | q = cong suc (cong suc my-proof)
      where
        halp : n + n + (n + n) ≡ n + n + n + n
        halp = begin
           n + n + (n + n)
           ≡⟨ sym (+-assoc (n + n) n n) ⟩
           n + n + n + n ∎
          where
            open ≡-Reasoning
        halp-again : n * n + (n + n + n + n) ≡ n * n + n + n + n + n
        halp-again with +-assoc (n * n) (n + n + n) n
        ... | p₁  rewrite sym p₁ with +-assoc (n * n) (n + n) n
        ... | p₂ rewrite sym p₂ with +-assoc (n * n) n n
        ... | p₃ rewrite sym p₃ = refl
        my-proof : n + suc (suc (n + 0)) + (n + (n + 0)) + n * n ≡ n + suc (suc (n + n * suc (suc n)))
        my-proof rewrite +-identityʳ n | +-*-suc n (suc n) | +-*-suc n n with +-comm n (suc (suc n)) | +-comm n (suc (suc (n + (n + (n + n * n)))))
        ... | p₁ | p₂ rewrite p₁ | p₂ with +-comm n (n + n * n) | +-comm n (n + n * n + n) | +-comm n (n * n) | +-comm (n + n + (n + n)) (n * n)
        ... | p₃ | p₄ | p₅ | p₆ rewrite p₃ | p₄ | p₅ | p₆ | halp | halp-again = cong suc (cong suc refl)
    -- Here I'd like a proof that the distance between the corners add up to the length

abs-diff : (n m : ℕ) → ℕ
abs-diff zero m = m
abs-diff (suc n) zero = suc n
abs-diff (suc n) (suc m) = abs-diff n m

min-5 : (a b c d e : ℕ) → ℕ
min-5 a b c d e with a ⊓ b | c ⊓ d
... | min-ab | min-cd with min-ab ⊓ min-cd
... | min-abcd = min-abcd ⊓ e

dist-to-closest-ring-corner : {k : ℕ} → (n : ℕ) → suc k ≡ n → ℕ
dist-to-closest-ring-corner zero ()
dist-to-closest-ring-corner (suc k) p with (ring-for-square# (suc k) p) | (suc k)
... | corner-root , corner-root-odd , ring# | n with ring-corners corner-root-odd
... | c₀ , c₁ , c₂ , c₃ , c₄ with abs-diff n c₀ | abs-diff n c₁ | abs-diff n c₂ | abs-diff n c₃ | abs-diff n c₄
... | n-c₀ | n-c₁ | n-c₂ | n-c₃ | n-c₄ = min-5 n-c₀ n-c₁ n-c₂ n-c₃ n-c₄

dist-to-center : {k : ℕ} → (n : ℕ) → suc k ≡ n → ℕ
dist-to-center zero ()
dist-to-center (suc k) p with (ring-for-square# (suc k) p) | (suc k)
... | corner-root , corner-root-odd , ring# | n with dist-to-closest-ring-corner (suc k) refl
... | dist = abs-diff dist (2 * (pred ring#))

infixr 5 _+++_

_+++_ : String → String → String
_+++_ s1 s2 = s1 String.++ " " String.++ s2

print-corners : {k : ℕ} → (n : ℕ) → suc k ≡ n → IO Unit
print-corners zero ()
print-corners (suc k) p with (ring-for-square# (suc k) p) | (suc k)
... | corner-root , corner-root-odd , ring# | n with ring-corners corner-root-odd
... | c₀ , c₁ , c₂ , c₃ , c₄ with abs-diff n c₀ | abs-diff n c₁ | abs-diff n c₂ | abs-diff n c₃ | abs-diff n c₄
... | n-c₀ | n-c₁ | n-c₂ | n-c₃ | n-c₄ with ℕs.show n-c₀ | ℕs.show n-c₁ | ℕs.show n-c₂ | ℕs.show n-c₃ | ℕs.show n-c₄ | ℕs.show corner-root | ℕs.show ring#
... | s0 | s1 | s2 | s3 | s4 | s5 | s6 = printString (s0 +++ s1 +++ s2 +++ s3 +++ s4 +++ "==" +++ s5 +++ s6)

main : IO Unit
main = mainBuilder main'
  where
    main' : String → (List String) → IO Unit
    main' name (numS ∷ []) with (unsafeParseNat (String.toList numS))
    ... | 0 = printUsage name
    ... | (suc n) =  printString (ℕs.show (dist-to-center (suc n) (cong suc refl)))
    main' name _ = printUsage name


------------------------------------------------------------------------
-- The Agda standard library
--
-- Extensional pointwise lifting of relations to vectors
------------------------------------------------------------------------

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

module Data.Vec.Relation.Binary.Pointwise.Extensional where

open import Data.Fin using (zero; suc)
open import Data.Nat using (zero; suc)
open import Data.Vec as Vec hiding ([_]; head; tail; map)
open import Data.Vec.Relation.Binary.Pointwise.Inductive as Inductive
  using ([]; _∷_)
  renaming (Pointwise to IPointwise)
open import Level using (_⊔_)
open import Function using (_∘_)
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence as Equiv
  using (_⇔_; ⇔-setoid; equivalence; module Equivalence)
open import Level using (_⊔_) renaming (zero to ℓ₀)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Binary.Construct.Closure.Transitive as Plus
  hiding (equivalent; map)
open import Relation.Nullary
import Relation.Nullary.Decidable as Dec

record Pointwise {a b ℓ} {A : Set a} {B : Set b} (_∼_ : REL A B ℓ)
                 {n} (xs : Vec A n) (ys : Vec B n) : Set (a ⊔ b ⊔ ℓ)
                 where
  constructor ext
  field app : ∀ i → lookup xs i ∼ lookup ys i

------------------------------------------------------------------------
-- Operations

head : ∀ {a b ℓ} {A : Set a} {B : Set b} {_∼_ : REL A B ℓ}
       {n x y xs} {ys : Vec B n} →
       Pointwise _∼_ (x ∷ xs) (y ∷ ys) → x ∼ y
head (ext app) = app zero

tail : ∀ {a b ℓ} {A : Set a} {B : Set b} {_∼_ : REL A B ℓ}
       {n x y xs} {ys : Vec B n} →
       Pointwise _∼_ (x ∷ xs) (y ∷ ys) → Pointwise _∼_ xs ys
tail (ext app) = ext (app ∘ suc)

map : ∀ {a b ℓ} {A : Set a} {B : Set b} {_∼_ _∼′_ : REL A B ℓ} {n} →
      _∼_ ⇒ _∼′_ → Pointwise _∼_ ⇒ Pointwise _∼′_ {n}
map ∼⇒∼′ xs∼ys = ext (∼⇒∼′ ∘ Pointwise.app xs∼ys)

gmap : ∀ {a b ℓ} {A : Set a} {B : Set b}
       {_∼_ : Rel A ℓ} {_∼′_ : Rel B ℓ} {f : A → B} {n} →
       _∼_ =[ f ]⇒ _∼′_ →
       Pointwise _∼_ =[ Vec.map {n = n} f ]⇒ Pointwise _∼′_
gmap {_}          ∼⇒∼′ {[]}      {[]}      xs∼ys = ext λ()
gmap {_∼′_ = _∼′_} ∼⇒∼′ {x ∷ xs} {y ∷ ys} xs∼ys = ext λ
  { zero    → ∼⇒∼′ (head xs∼ys)
  ; (suc i) → Pointwise.app (gmap {_∼′_ = _∼′_} ∼⇒∼′ (tail xs∼ys)) i
  }

------------------------------------------------------------------------
-- The inductive and extensional definitions are equivalent.

module _ {a b ℓ} {A : Set a} {B : Set b} {_∼_ : REL A B ℓ} where

  extensional⇒inductive : ∀ {n} {xs : Vec A n} {ys : Vec B n} →
                           Pointwise _∼_ xs ys → IPointwise _∼_ xs ys
  extensional⇒inductive {zero} {[]}       {[]}      xs∼ys = []
  extensional⇒inductive {suc n} {x ∷ xs} {y ∷ ys} xs∼ys =
    (head xs∼ys) ∷ extensional⇒inductive (tail xs∼ys)

  inductive⇒extensional : ∀ {n} {xs : Vec A n} {ys : Vec B n} →
                           IPointwise _∼_ xs ys → Pointwise _∼_ xs ys
  inductive⇒extensional []             = ext λ()
  inductive⇒extensional (x∼y ∷ xs∼ys) = ext λ
    { zero    → x∼y
    ; (suc i) → Pointwise.app (inductive⇒extensional xs∼ys) i
    }

  equivalent : ∀ {n} {xs : Vec A n} {ys : Vec B n} →
               Pointwise _∼_ xs ys ⇔ IPointwise _∼_ xs ys
  equivalent = equivalence extensional⇒inductive inductive⇒extensional

------------------------------------------------------------------------
-- Relational properties

refl : ∀ {a ℓ} {A : Set a} {_∼_ : Rel A ℓ} →
       ∀ {n} → Reflexive _∼_ → Reflexive (Pointwise _∼_ {n = n})
refl ∼-rfl = ext (λ _ → ∼-rfl)

sym : ∀ {a b ℓ} {A : Set a} {B : Set b} {P : REL A B ℓ} {Q : REL B A ℓ}
      {n} → Sym P Q → Sym (Pointwise P) (Pointwise Q {n = n})
sym sm xs∼ys = ext λ i → sm (Pointwise.app xs∼ys i)

trans : ∀ {a b c ℓ} {A : Set a} {B : Set b} {C : Set c}
        {P : REL A B ℓ} {Q : REL B C ℓ} {R : REL A C ℓ} {n} →
        Trans P Q R →
        Trans (Pointwise P) (Pointwise Q) (Pointwise R {n = n})
trans trns xs∼ys ys∼zs = ext λ i →
  trns (Pointwise.app xs∼ys i) (Pointwise.app ys∼zs i)

decidable : ∀ {a b ℓ} {A : Set a} {B : Set b} {_∼_ : REL A B ℓ} →
            Decidable _∼_ → ∀ {n} → Decidable (Pointwise _∼_ {n = n})
decidable dec xs ys = Dec.map
  (Setoid.sym (⇔-setoid _) equivalent)
  (Inductive.decidable dec xs ys)

isEquivalence : ∀ {a ℓ} {A : Set a} {_∼_ : Rel A ℓ} →
                ∀ {n} → IsEquivalence _∼_ →
                IsEquivalence (Pointwise _∼_ {n = n})
isEquivalence equiv = record
  { refl  = refl  Eq.refl
  ; sym   = sym   Eq.sym
  ; trans = trans Eq.trans
  } where module Eq = IsEquivalence equiv

isDecEquivalence : ∀ {a ℓ} {A : Set a} {_∼_ : Rel A ℓ} →
                   ∀ {n} → IsDecEquivalence _∼_ →
                   IsDecEquivalence (Pointwise _∼_ {n = n})
isDecEquivalence decEquiv = record
  { isEquivalence = isEquivalence DecEq.isEquivalence
  ; _≟_           = decidable DecEq._≟_
  } where module DecEq = IsDecEquivalence decEquiv

------------------------------------------------------------------------
-- Pointwise _≡_ is equivalent to _≡_.

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

  Pointwise-≡⇒≡ : ∀ {n} {xs ys : Vec A n} →
                     Pointwise _≡_ xs ys → xs ≡ ys
  Pointwise-≡⇒≡ {zero}  {[]}      {[]}      (ext app) = P.refl
  Pointwise-≡⇒≡ {suc n} {x ∷ xs} {y ∷ ys} xs∼ys =
    P.cong₂ _∷_ (head xs∼ys) (Pointwise-≡⇒≡ (tail xs∼ys))

  ≡⇒Pointwise-≡ : ∀ {n} {xs ys : Vec A n} →
                     xs ≡ ys → Pointwise _≡_ xs ys
  ≡⇒Pointwise-≡ P.refl = refl P.refl

  Pointwise-≡↔≡ : ∀ {n} {xs ys : Vec A n} →
                Pointwise _≡_ xs ys ⇔ xs ≡ ys
  Pointwise-≡↔≡ {ℓ} {A} =
    Equiv.equivalence Pointwise-≡⇒≡ ≡⇒Pointwise-≡

------------------------------------------------------------------------
-- Pointwise and Plus commute when the underlying relation is
-- reflexive.
module _ {a ℓ} {A : Set a} {_∼_ : Rel A ℓ} where

  ⁺∙⇒∙⁺ : ∀ {n} {xs ys : Vec A n} →
          Plus (Pointwise _∼_) xs ys → Pointwise (Plus _∼_) xs ys
  ⁺∙⇒∙⁺ [ ρ≈ρ′ ]            = ext (λ x → [ Pointwise.app ρ≈ρ′ x ])
  ⁺∙⇒∙⁺ (ρ ∼⁺⟨ ρ≈ρ′ ⟩ ρ′≈ρ″) =  ext (λ x →
    _ ∼⁺⟨ Pointwise.app (⁺∙⇒∙⁺ ρ≈ρ′ ) x ⟩
         Pointwise.app (⁺∙⇒∙⁺ ρ′≈ρ″) x)

  ∙⁺⇒⁺∙ : ∀ {n} {xs ys : Vec A n} → Reflexive _∼_ →
          Pointwise (Plus _∼_) xs ys → Plus (Pointwise _∼_) xs ys
  ∙⁺⇒⁺∙ rfl =
    Plus.map (_⟨$⟩_ (Equivalence.from equivalent)) ∘
    helper ∘
    _⟨$⟩_ (Equivalence.to equivalent)
    where
    helper : ∀ {n} {xs ys : Vec A n} →
             IPointwise (Plus _∼_) xs ys → Plus (IPointwise _∼_) xs ys
    helper []                                                  = [ [] ]
    helper (_∷_ {x = x} {y = y} {xs = xs} {ys = ys} x∼y xs∼ys) =
      x ∷ xs  ∼⁺⟨ Plus.map (_∷ Inductive.refl rfl) x∼y ⟩
      y ∷ xs  ∼⁺⟨ Plus.map (rfl ∷_) (helper xs∼ys) ⟩∎
      y ∷ ys  ∎

-- ∙⁺⇒⁺∙ cannot be defined if the requirement of reflexivity
-- is dropped.
private

 module Counterexample where

  data D : Set where
    i j x y z : D

  data _R_ : Rel D ℓ₀ where
    iRj : i R j
    xRy : x R y
    yRz : y R z

  xR⁺z : x [ _R_ ]⁺ z
  xR⁺z =
    x  ∼⁺⟨ [ xRy ] ⟩
    y  ∼⁺⟨ [ yRz ] ⟩∎
    z  ∎

  ix : Vec D 2
  ix = i ∷ x ∷ []

  jz : Vec D 2
  jz = j ∷ z ∷ []

  ix∙⁺jz : IPointwise (Plus _R_) ix jz
  ix∙⁺jz = [ iRj ] ∷ xR⁺z ∷ []

  ¬ix⁺∙jz : ¬ Plus′ (IPointwise _R_) ix jz
  ¬ix⁺∙jz [ iRj ∷ () ∷ [] ]
  ¬ix⁺∙jz ((iRj ∷ xRy ∷ []) ∷ [ () ∷ yRz ∷ [] ])
  ¬ix⁺∙jz ((iRj ∷ xRy ∷ []) ∷ (() ∷ yRz ∷ []) ∷ _)

  counterexample :
    ¬ (∀ {n} {xs ys : Vec D n} →
         Pointwise (Plus _R_) xs ys →
         Plus (Pointwise _R_) xs ys)
  counterexample ∙⁺⇒⁺∙ =
    ¬ix⁺∙jz (Equivalence.to Plus.equivalent ⟨$⟩
               Plus.map (_⟨$⟩_ (Equivalence.to equivalent))
                 (∙⁺⇒⁺∙ (Equivalence.from equivalent ⟨$⟩ ix∙⁺jz)))

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

-- Version 0.15

Pointwise-≡ = Pointwise-≡↔≡
{-# WARNING_ON_USAGE Pointwise-≡
"Warning: Pointwise-≡ was deprecated in v0.15.
Please use Pointwise-≡↔≡ instead."
#-}


open import Nat
open import Prelude
open import contexts
open import dynamics-core
open import lemmas-matching
open import synth-unicity

module elaboration-unicity where
  mutual
    elaboration-unicity-synth : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {d1 d2 : ihexp} {Δ1 Δ2 : hctx} →
                            Γ ⊢ e ⇒ τ1 ~> d1 ⊣ Δ1 →
                            Γ ⊢ e ⇒ τ2 ~> d2 ⊣ Δ2 →
                            τ1 == τ2 × d1 == d2 × Δ1 == Δ2
    elaboration-unicity-synth ESNum ESNum = refl , refl , refl
    elaboration-unicity-synth (ESPlus apt1 dis1 x₁ x₂) (ESPlus apt2 dis2 x₃ x₄)
      with elaboration-unicity-ana x₁ x₃ | elaboration-unicity-ana x₂ x₄
    ... | refl , refl , refl | refl , refl , refl = refl , refl , refl
    elaboration-unicity-synth (ESAsc x) (ESAsc x₁)
      with elaboration-unicity-ana x x₁
    ... | refl , refl , refl = refl , refl , refl
    elaboration-unicity-synth (ESVar {Γ = Γ} x₁) (ESVar x₂) = ctxunicity {Γ = Γ} x₁ x₂ , refl , refl
    elaboration-unicity-synth (ESLam apt1 d1) (ESLam apt2 d2)
      with elaboration-unicity-synth d1 d2
    ... | ih1 , ih2 , ih3 = ap1 _ ih1  , ap1 _ ih2 , ih3
    elaboration-unicity-synth (ESAp _ _ x x₁ x₂ x₃) (ESAp _ _ x₄ x₅ x₆ x₇)
      with synthunicity x x₄
    ... | refl with ▸arr-unicity x₁ x₅
    ... | refl with elaboration-unicity-ana x₂ x₆
    ... | refl , refl , refl with elaboration-unicity-ana x₃ x₇
    ... | refl , refl , refl = refl , refl , refl
    elaboration-unicity-synth ESEHole ESEHole = refl , refl , refl
    elaboration-unicity-synth (ESNEHole _ d1) (ESNEHole _ d2)
      with elaboration-unicity-synth d1 d2
    ... | ih1 , ih2 , ih3 = refl , ap1 _ ih2 , ap1 _ ih3
    elaboration-unicity-synth (ESPair x x₁ wt1 wt2) (ESPair x₂ x₃ wt3 wt4)
      with elaboration-unicity-synth wt1 wt3 | elaboration-unicity-synth wt2 wt4
    ... | refl , refl , refl | refl , refl , refl = refl , refl , refl
    elaboration-unicity-synth (ESFst wt1 x₁ d1) (ESFst wt2 x₄ d2)
      with synthunicity wt1 wt2
    ... | refl with ▸prod-unicity x₁ x₄
    ... | refl with elaboration-unicity-ana d1 d2
    ... | refl , refl , refl = refl , refl , refl
    elaboration-unicity-synth (ESSnd wt1 x₁ d1) (ESSnd wt2 x₄ d2)
      with synthunicity wt1 wt2
    ... | refl with ▸prod-unicity x₁ x₄
    ... | refl with elaboration-unicity-ana d1 d2
    ... | refl , refl , refl = refl , refl , refl

    elaboration-unicity-ana : {Γ : tctx} {e : hexp} {τ τ1 τ2 : htyp} {d1 d2 : ihexp} {Δ1 Δ2 : hctx} →
                          Γ ⊢ e ⇐ τ ~> d1 :: τ1 ⊣ Δ1  →
                          Γ ⊢ e ⇐ τ ~> d2 :: τ2 ⊣ Δ2 →
                          d1 == d2 × τ1 == τ2 × Δ1 == Δ2
    elaboration-unicity-ana (EALam x₁ m D1) (EALam x₂ m2 D2)
      with ▸arr-unicity m m2
    ... | refl with elaboration-unicity-ana D1 D2
    ... | refl , refl , refl = refl , refl , refl
    elaboration-unicity-ana (EALam x₁ m D1) (EASubsume x₂ x₃ () x₅)
    elaboration-unicity-ana (EASubsume x₁ x₂ () x₄) (EALam x₅ m D2)
    elaboration-unicity-ana (EASubsume x x₁ x₂ x₃) (EASubsume x₄ x₅ x₆ x₇)
      with elaboration-unicity-synth x₂ x₆
    ... | refl , refl , refl = refl , refl , refl
    elaboration-unicity-ana (EASubsume x x₁ () x₃) (EAInl x₄ wt2)
    elaboration-unicity-ana (EASubsume x x₁ () x₃) (EAInr x₄ wt2)
    elaboration-unicity-ana (EASubsume x x₁ () x₃) (EACase x₄ x₅ x₆ x₇ x₈ x₉ x₁₀ x₁₁ x₁₂ x₁₃ wt2 wt3)
    elaboration-unicity-ana (EASubsume x x₁ x₂ x₃) EAEHole = abort (x _ refl)
    elaboration-unicity-ana (EASubsume x x₁ x₂ x₃) (EANEHole _ x₄) = abort (x₁ _ _ refl)
    elaboration-unicity-ana (EAInl x x₁) (EAInl y y₁)
      with ▸sum-unicity x y
    ... | refl with elaboration-unicity-ana x₁ y₁
    ... | refl , refl , refl = refl , refl , refl
    elaboration-unicity-ana (EAInl x wt1) (EASubsume x₁ x₂ () x₄)
    elaboration-unicity-ana (EAInr x x₁) (EAInr y y₁)
      with ▸sum-unicity x y
    ... | refl with elaboration-unicity-ana x₁ y₁
    ... | refl , refl , refl = refl , refl , refl
    elaboration-unicity-ana (EAInr x wt1) (EASubsume x₁ x₂ () x₄)
    elaboration-unicity-ana (EACase x x₁ x₂ x₃ x₄ x₅ x₆ x₇ x₈ x₉ wt1 wt2) (EASubsume x₁₀ x₁₁ () x₁₃)
    elaboration-unicity-ana (EACase x x₁ x₂ x₃ x₄ x₅ x₆ x₇ x₈ x₉ x₁₀ x₁₁) (EACase y y₁ y₂ y₃ y₄ y₅ y₆ y₇ y₈ y₉ y₁₀ y₁₁)
      with elaboration-unicity-synth x₈ y₈
    ... | refl , refl , refl with ▸sum-unicity x₉ y₉
    ... | refl with elaboration-unicity-ana x₁₀ y₁₀
    ... | refl , refl , refl with elaboration-unicity-ana x₁₁ y₁₁
    ... | refl , refl , refl = refl , refl , refl
    elaboration-unicity-ana EAEHole (EASubsume x x₁ x₂ x₃) = abort (x _ refl)
    elaboration-unicity-ana EAEHole EAEHole = refl , refl , refl
    elaboration-unicity-ana (EANEHole _ x) (EASubsume x₁ x₂ x₃ x₄) = abort (x₂ _ _ refl)
    elaboration-unicity-ana (EANEHole _ x) (EANEHole _ x₁)
      with elaboration-unicity-synth x x₁
    ... | refl , refl , refl = refl , refl , refl


------------------------------------------------------------------------
-- Unary and binary relations
------------------------------------------------------------------------

{-# OPTIONS --safe #-}

module Relation where

open import Equality.Propositional
open import Prelude

open import Bijection equality-with-J as Bijection using (_↔_)
open import Equality.Decision-procedures equality-with-J
import Equality.Groupoid equality-with-J as EG
open import Function-universe equality-with-J hiding (id; _∘_)
open import Groupoid equality-with-J

-- Unary relations.

Rel : ∀ {ℓ₁} ℓ₂ → Type ℓ₁ → Type (ℓ₁ ⊔ lsuc ℓ₂)
Rel ℓ A = A → Type ℓ

-- Homogeneous binary relations.

Rel₂ : ∀ {ℓ₁} ℓ₂ → Type ℓ₁ → Type (ℓ₁ ⊔ lsuc ℓ₂)
Rel₂ ℓ A = Rel ℓ (A × A)

-- One kind of unary relation transformer.

Trans : ∀ {a} ℓ → Type a → Type (a ⊔ lsuc ℓ)
Trans ℓ A = Rel ℓ A → Rel ℓ A

-- One kind of binary relation transformer.

Trans₂ : ∀ {a} ℓ → Type a → Type (a ⊔ lsuc ℓ)
Trans₂ ℓ A = Trans ℓ (A × A)

-- The converse of a binary relation.

infixr 10 _⁻¹

_⁻¹ : ∀ {a ℓ} {A : Type a} → Rel₂ ℓ A → Rel₂ ℓ A
R ⁻¹ = R ∘ swap

-- Composition of binary relations.

infixr 9 _⊙_

_⊙_ : ∀ {a ℓ₁ ℓ₂} {A : Type a} →
      Rel₂ ℓ₁ A → Rel₂ ℓ₂ A → Rel₂ (a ⊔ ℓ₁ ⊔ ℓ₂) A
(R ⊙ S) (x , z) = ∃ λ y → R (x , y) × S (y , z)

-- Composition of a relation with itself, with the base case as a
-- parameter.

composition : ∀ {a} {A : Type a} →
              Rel₂ a A → Rel₂ a A → ℕ → Rel₂ a A
composition R S zero    = R
composition R S (suc n) = S ⊙ composition R S n

-- Composition of a binary relation with itself, with the relation
-- itself as the base case.

infix 10 _^^[1+_]

_^^[1+_] : ∀ {a} {A : Type a} →
           Rel₂ a A → ℕ → Rel₂ a A
R ^^[1+ n ] = composition R R n

-- Composition of a binary relation with itself, with equality as the
-- base case.

infix 10 _^^_

_^^_ : ∀ {a} {A : Type a} →
       Rel₂ a A → ℕ → Rel₂ a A
R ^^ n = composition (uncurry _≡_) R n

-- Intersection of relations.

infixr 8 _∩_

_∩_ : ∀ {a ℓ₁ ℓ₂} {A : Type a} →
      Rel ℓ₁ A → Rel ℓ₂ A → Rel (ℓ₁ ⊔ ℓ₂) A
R ∩ S = λ x → R x × S x

-- Union of relations.

infixr 7 _∪_

_∪_ : ∀ {a ℓ₁ ℓ₂} {A : Type a} →
      Rel ℓ₁ A → Rel ℓ₂ A → Rel (ℓ₁ ⊔ ℓ₂) A
R ∪ S = λ x → R x ⊎ S x

-- Reflexive closure of binary relations.

_⁼ : ∀ {a ℓ} {A : Type a} →
     Rel₂ ℓ A → Rel₂ (a ⊔ ℓ) A
R ⁼ = R ∪ uncurry _≡_

-- Transitive closure of binary relations.

_⁺ : ∀ {a} {A : Type a} →
     Rel₂ a A → Rel₂ a A
(R ⁺) x = ∃ λ n → (R ^^[1+ n ]) x

-- Reflexive transitive closure of binary relations.

_* : ∀ {a} {A : Type a} →
     Rel₂ a A → Rel₂ a A
(R *) x = ∃ λ n → (R ^^ n) x

-- Repeated composition of a function with itself.

infix 10 _^[_]_

_^[_]_ : ∀ {a} {A : Type a} → (A → A) → ℕ → A → A
f ^[ zero  ] x = x
f ^[ suc n ] x = f (f ^[ n ] x)

-- Unions of families of relation transformers.

⋃ : ∀ {a b} ℓ {A : Type a} {B : Type b} →
    (A → Trans (a ⊔ ℓ) B) → Trans (a ⊔ ℓ) B
⋃ _ F R = λ b → ∃ λ a → F a R b

-- An analogue of ⋃ₙ Fⁿ.

infix 10 _^ω_

_^ω_ : ∀ {a ℓ} {A : Type a} → Trans ℓ A → Trans ℓ A
_^ω_ F = ⋃ _ (F ^[_]_)

-- Relation containment.

infix 4 _⊆_

_⊆_ : ∀ {a ℓ₁ ℓ₂} {A : Type a} →
      Rel ℓ₁ A → Rel ℓ₂ A → Type (a ⊔ ℓ₁ ⊔ ℓ₂)
R ⊆ S = ∀ {x} → R x → S x

-- "Equational" reasoning combinators.

infix  -1 finally-⊆
infixr -2 _⊆⟨_⟩_ _⊆⟨⟩_

_⊆⟨_⟩_ : ∀ {a p q r} {A : Type a}
         (P : Rel p A) {Q : Rel q A} {R : Rel r A} →
         P ⊆ Q → Q ⊆ R → P ⊆ R
_ ⊆⟨ P⊆Q ⟩ Q⊆R = Q⊆R ∘ P⊆Q

_⊆⟨⟩_ : ∀ {a p q} {A : Type a}
        (P : Rel p A) {Q : Rel q A} →
        P ⊆ Q → P ⊆ Q
_ ⊆⟨⟩ P⊆Q = P⊆Q

finally-⊆ : ∀ {a p q} {A : Type a}
            (P : Rel p A) (Q : Rel q A) →
            P ⊆ Q → P ⊆ Q
finally-⊆ _ _ P⊆Q = P⊆Q

syntax finally-⊆ P Q P⊆Q = P ⊆⟨ P⊆Q ⟩∎ Q ∎

-- Preservation lemmas for _⊆_.

infix 4 _⊆-cong-→_

⊆-cong :
  ∀ {k a r₁ r₂ s₁ s₂} {A : Type a}
    {R₁ : Rel r₁ A} {S₁ : Rel s₁ A}
    {R₂ : Rel r₂ A} {S₂ : Rel s₂ A} →
  Extensionality? ⌊ k ⌋-sym (a ⊔ r₁ ⊔ r₂) (r₁ ⊔ r₂ ⊔ s₁ ⊔ s₂) →
  (∀ {x} → R₁ x ↝[ ⌊ k ⌋-sym ] R₂ x) →
  (∀ {x} → S₁ x ↝[ ⌊ k ⌋-sym ] S₂ x) →
  R₁ ⊆ S₁ ↝[ ⌊ k ⌋-sym ] R₂ ⊆ S₂
⊆-cong {k} {a} {r₁} {r₂} ext R₁↝R₂ S₁↝S₂ =
  implicit-∀-cong
    (lower-extensionality? ⌊ k ⌋-sym (r₁ ⊔ r₂) lzero ext) $
  →-cong (lower-extensionality? ⌊ k ⌋-sym a (r₁ ⊔ r₂) ext)
         R₁↝R₂ S₁↝S₂

_⊆-cong-→_ :
  ∀ {a r₁ r₂ s₁ s₂} {A : Type a}
    {R₁ : Rel r₁ A} {S₁ : Rel s₁ A}
    {R₂ : Rel r₂ A} {S₂ : Rel s₂ A} →
  R₂ ⊆ R₁ → S₁ ⊆ S₂ → R₁ ⊆ S₁ → R₂ ⊆ S₂
R₂→R₁ ⊆-cong-→ S₁→S₂ = implicit-∀-cong _ $ →-cong-→ R₂→R₁ S₁→S₂

⊆-congʳ :
  ∀ {k a r s₁ s₂} {A : Type a}
    {R : Rel r A} {S₁ : Rel s₁ A} {S₂ : Rel s₂ A} →
  Extensionality? k (a ⊔ r) (r ⊔ s₁ ⊔ s₂) →
  (∀ {x} → S₁ x ↝[ k ] S₂ x) →
  R ⊆ S₁ ↝[ k ] R ⊆ S₂
⊆-congʳ {k} {a} {r} ext S₁↝S₂ =
  implicit-∀-cong (lower-extensionality? k r lzero ext) $
  ∀-cong (lower-extensionality? k a r ext) λ _ →
  S₁↝S₂

-- Relation containment (_⊆_) is not antisymmetric (with respect to
-- propositional equality) if the index type is inhabited.

⊆-not-antisymmetric :
  ∀ {ℓ x} {X : Type x} →
  X →
  ¬ ({R S : Rel ℓ X} → R ⊆ S → S ⊆ R → R ≡ S)
⊆-not-antisymmetric {ℓ} {X = X} x antisym = Bool.true≢false true≡false
  where
  R S : Rel ℓ X
  R = λ _ → ↑ _ ⊤
  S = λ _ → ↑ _ Bool

  R≡S : R ≡ S
  R≡S = antisym (λ _ → lift true) _

  ⊤≡Bool : ↑ _ ⊤ ≡ ↑ _ Bool
  ⊤≡Bool = cong (_$ x) R≡S

  ⊤↔Bool : ⊤ ↔ Bool
  ⊤↔Bool =
    ⊤         ↝⟨ inverse Bijection.↑↔ ⟩
    ↑ _ ⊤     ↝⟨ ≡⇒↝ _ ⊤≡Bool ⟩
    ↑ _ Bool  ↝⟨ Bijection.↑↔ ⟩□
    Bool      □

  true≡false : true ≡ false
  true≡false =
    true                                   ≡⟨ sym $ _↔_.right-inverse-of ⊤↔Bool _ ⟩
    _↔_.to ⊤↔Bool (_↔_.from ⊤↔Bool true)   ≡⟨⟩
    _↔_.to ⊤↔Bool tt                       ≡⟨⟩
    _↔_.to ⊤↔Bool (_↔_.from ⊤↔Bool false)  ≡⟨ _↔_.right-inverse-of ⊤↔Bool _ ⟩∎
    false                                  ∎

-- Monotonicity of relation transformers.

Monotone :
  ∀ {a ℓ} {A : Type a} →
  Trans ℓ A → Type (a ⊔ lsuc ℓ)
Monotone F = ∀ {R S} → R ⊆ S → F R ⊆ F S

-- A relation transformer is extensive if the input is always
-- contained in the output.

Extensive : ∀ {ℓ} {I : Type ℓ} → Trans ℓ I → Type (lsuc ℓ)
Extensive G = ∀ R → R ⊆ G R

-- A definition that turns into a notion of symmetry if the first
-- argument is instantiated with the swap function. In that case this
-- definition is similar to one of those given by Pous and Sangiorgi
-- in Section 6.3.4.1 of "Enhancements of the bisimulation proof
-- method".

Symmetric : ∀ {ℓ} {I : Type ℓ} → (I → I) → Trans ℓ I → Type (lsuc ℓ)
Symmetric f F = ∀ R → F (R ∘ f) ⊆ F R ∘ f

-- If f is an involution, then the inclusion in Symmetric f F holds
-- also in the other direction.

involution→other-symmetry :
  ∀ {ℓ} {I : Type ℓ} (F : Trans ℓ I) {f : I → I} →
  f ∘ f ≡ id → Symmetric f F → ∀ R → F R ∘ f ⊆ F (R ∘ f)
involution→other-symmetry F {f} inv symm R =
  F R ∘ f            ⊆⟨ (λ {x} → subst (λ g → F (R ∘ g) (f x)) (sym inv)) ⟩
  F (R ∘ f ∘ f) ∘ f  ⊆⟨ symm _ ⟩
  F (R ∘ f) ∘ f ∘ f  ⊆⟨ (λ {x} → subst (λ g → F (R ∘ f) (g x)) inv) ⟩∎
  F (R ∘ f)          ∎

-- Composition is associative.

⊙-assoc : ∀ {a ℓ₁ ℓ₂ ℓ₃} {A : Type a} →
          (R₁ : Rel₂ ℓ₁ A) {R₂ : Rel₂ ℓ₂ A} (R₃ : Rel₂ ℓ₃ A) →
          ∀ p → (R₁ ⊙ (R₂ ⊙ R₃)) p ↔ ((R₁ ⊙ R₂) ⊙ R₃) p
⊙-assoc R₁ {R₂} R₃ (a , d) =
  (∃ λ b → R₁ (a , b) × ∃ λ c → R₂ (b , c) × R₃ (c , d))    ↝⟨ ∃-cong (λ _ → ∃-comm) ⟩
  (∃ λ b → ∃ λ c → R₁ (a , b) × R₂ (b , c) × R₃ (c , d))    ↝⟨ ∃-comm ⟩
  (∃ λ c → ∃ λ b → R₁ (a , b) × R₂ (b , c) × R₃ (c , d))    ↝⟨ ∃-cong (λ _ → ∃-cong λ _ → Σ-assoc) ⟩
  (∃ λ c → ∃ λ b → (R₁ (a , b) × R₂ (b , c)) × R₃ (c , d))  ↝⟨ ∃-cong (λ _ → Σ-assoc) ⟩□
  (∃ λ c → (∃ λ b → R₁ (a , b) × R₂ (b , c)) × R₃ (c , d))  □

-- Several forms of composition preserve several kinds of functions.

⊙-cong :
  ∀ {k a r₁ r₂ s₁ s₂} {A : Type a} →
    {R₁ : Rel₂ r₁ A} {R₂ : Rel₂ r₂ A} →
    {S₁ : Rel₂ s₁ A} {S₂ : Rel₂ s₂ A} →
  (∀ p → R₁ p ↝[ k ] R₂ p) →
  (∀ p → S₁ p ↝[ k ] S₂ p) →
  ∀ p → (R₁ ⊙ S₁) p ↝[ k ] (R₂ ⊙ S₂) p
⊙-cong {R₁ = R₁} {R₂} {S₁} {S₂} R₁↝R₂ S₁↝S₂ (x , z) =
  (∃ λ y → R₁ (x , y) × S₁ (y , z))  ↝⟨ ∃-cong (λ _ → R₁↝R₂ _ ×-cong S₁↝S₂ _) ⟩□
  (∃ λ y → R₂ (x , y) × S₂ (y , z))  □

composition-cong :
  ∀ {k a} {A : Type a} {R₁ R₂ S₁ S₂ : Rel₂ a A} →
  (∀ p → R₁ p ↝[ k ] R₂ p) →
  (∀ p → S₁ p ↝[ k ] S₂ p) →
  ∀ n p → composition R₁ S₁ n p ↝[ k ] composition R₂ S₂ n p
composition-cong R₁↝R₂ S₁↝S₂ = λ where
  zero    → R₁↝R₂
  (suc n) → ⊙-cong S₁↝S₂ (composition-cong R₁↝R₂ S₁↝S₂ n)

^^[1+]-cong :
  ∀ {k a} {A : Type a} {R₁ R₂ : Rel₂ a A} →
  (∀ p → R₁ p ↝[ k ] R₂ p) →
  ∀ n p → (R₁ ^^[1+ n ]) p ↝[ k ] (R₂ ^^[1+ n ]) p
^^[1+]-cong R₁↝R₂ = composition-cong R₁↝R₂ R₁↝R₂

^^-cong :
  ∀ {k a} {A : Type a} {R₁ R₂ : Rel₂ a A} →
  (∀ p → R₁ p ↝[ k ] R₂ p) →
  ∀ n p → (R₁ ^^ n) p ↝[ k ] (R₂ ^^ n) p
^^-cong R₁↝R₂ = composition-cong (λ _ → _ □) R₁↝R₂

⁺-cong :
  ∀ {k a} {A : Type a} {R₁ R₂ : Rel₂ a A} →
  (∀ p → R₁ p ↝[ k ] R₂ p) →
  ∀ p → (R₁ ⁺) p ↝[ k ] (R₂ ⁺) p
⁺-cong R₁↝R₂ p = ∃-cong λ n → ^^[1+]-cong R₁↝R₂ n p

*-cong :
  ∀ {k a} {A : Type a} {R₁ R₂ : Rel₂ a A} →
  (∀ p → R₁ p ↝[ k ] R₂ p) →
  ∀ p → (R₁ *) p ↝[ k ] (R₂ *) p
*-cong R₁↝R₂ p = ∃-cong λ n → ^^-cong R₁↝R₂ n p

-- Two lemmas relating composition and _⊙_.

composition-⊙-comm :
  ∀ {k a} {A : Type a} {R S : Rel₂ a A} →
  (∀ p → (R ⊙ S) p ↝[ k ] (S ⊙ R) p) →
  ∀ n p → (composition R S n ⊙ S) p ↝[ k ] (S ⊙ composition R S n) p
composition-⊙-comm             hyp zero    = hyp
composition-⊙-comm {R = R} {S} hyp (suc n) = λ p →
  ((S ⊙ composition R S n) ⊙ S) p  ↔⟨ inverse $ ⊙-assoc S S _ ⟩
  (S ⊙ (composition R S n ⊙ S)) p  ↝⟨ ⊙-cong (λ p → S p □) (composition-⊙-comm hyp n) _ ⟩□
  (S ⊙ (S ⊙ composition R S n)) p  □

composition⊙composition :
  ∀ {k a} {A : Type a} {R S : Rel₂ a A} m n₁ {n₂} →
  (∀ p → (R ⊙ composition R S n₁) p ↝[ k ] composition R S n₂ p) →
  ∀ p → (composition R S m ⊙ composition R S n₁) p ↝[ k ]
        composition R S (m + n₂) p
composition⊙composition {R = R} {S} = λ where
  zero n₁ {n₂} hyp p →
    (R ⊙ composition R S n₁) p  ↝⟨ hyp _ ⟩
    composition R S n₂ p        □
  (suc m) n₁ {n₂} hyp p →
    ((S ⊙ composition R S m) ⊙ composition R S n₁) p  ↔⟨ inverse $ ⊙-assoc S (composition R S n₁) _ ⟩
    (S ⊙ (composition R S m ⊙ composition R S n₁)) p  ↝⟨ ⊙-cong (λ p → S p □) (composition⊙composition m n₁ hyp) _ ⟩□
    (S ⊙ composition R S (m + n₂)) p            □

-- The transitive closure is transitive.

⁺-trans : ∀ {a} {A : Type a} {R : Rel₂ a A} {x y z} →
          (R ⁺) (x , y) → (R ⁺) (y , z) → (R ⁺) (x , z)
⁺-trans (m , xR¹⁺ᵐy) (n , yR¹⁺ⁿz) =
    m + suc n
  , composition⊙composition m n (λ _ → id) _ (_ , xR¹⁺ᵐy , yR¹⁺ⁿz)

-- The reflexive transitive closure is transitive.

*-trans : ∀ {a} {A : Type a} {R : Rel₂ a A} {x y z} →
          (R *) (x , y) → (R *) (y , z) → (R *) (x , z)
*-trans {R = R} (m , xRᵐy) (n , yRⁿz) =
  m + n , composition⊙composition m n lemma _ (_ , xRᵐy , yRⁿz)
  where
  lemma : ∀ p → (uncurry _≡_ ⊙ (R ^^ n)) p → (R ^^ n) p
  lemma _ (_ , refl , r) = r

-- Lemmas relating different forms of composition and swap.

⊙-swap :
  ∀ {k a r s} {A : Type a} {R : Rel₂ r A} {S : Rel₂ s A} →
  (∀ p → R p ↝[ k ] R (swap p)) →
  (∀ p → S p ↝[ k ] S (swap p)) →
  ∀ p → (R ⊙ S) p ↝[ k ] (S ⊙ R) (swap p)
⊙-swap {R = R} {S} R↝ S↝ (x , z) =
  (∃ λ y → R (x , y) × S (y , z))  ↝⟨ ∃-cong (λ _ → R↝ _ ×-cong S↝ _) ⟩
  (∃ λ y → R (y , x) × S (z , y))  ↔⟨ ∃-cong (λ _ → ×-comm) ⟩□
  (∃ λ y → S (z , y) × R (y , x))  □

composition-swap :
  ∀ {k a} {A : Type a} {R S : Rel₂ a A} →
  (∀ p → R p ↝[ k ] R (swap p)) →
  (∀ p → S p ↝[ k ] S (swap p)) →
  (∀ p → (R ⊙ S) p ↝[ k ] (S ⊙ R) p) →
  ∀ n p → composition R S n p ↝[ k ] composition R S n (swap p)
composition-swap {R = R} {S} R↝ S↝ hyp = λ where
  zero    p → R p         ↝⟨ R↝ _ ⟩□
              R (swap p)  □
  (suc n) p → (S ⊙ composition R S n) p         ↝⟨ ⊙-swap S↝ (composition-swap R↝ S↝ hyp n) _ ⟩
              (composition R S n ⊙ S) (swap p)  ↝⟨ composition-⊙-comm hyp n _ ⟩□
              (S ⊙ composition R S n) (swap p)  □

^^[1+]-swap :
  ∀ {k a} {A : Type a} {R : Rel₂ a A} →
  (∀ p → R p ↝[ k ] R (swap p)) →
  ∀ n p → (R ^^[1+ n ]) p ↝[ k ] (R ^^[1+ n ]) (swap p)
^^[1+]-swap R↝ = composition-swap R↝ R↝ (λ _ → _ □)

^^-swap :
  ∀ {k a} {A : Type a} {R : Rel₂ a A} →
  (∀ p → R p ↝[ k ] R (swap p)) →
  ∀ n p → (R ^^ n) p ↝[ k ] (R ^^ n) (swap p)
^^-swap {R = R} R↝ = composition-swap lemma₁ R↝ lemma₂
  where
  lemma₁ = λ { (x , y) →
    x ≡ y  ↔⟨ Groupoid.⁻¹-bijection (EG.groupoid _) ⟩□
    y ≡ x  □ }

  lemma₂ = λ { (x , z) →
    (∃ λ y → x ≡ y × R (y , z))  ↔⟨ ∃-cong (λ _ → ×-comm) ⟩
    (∃ λ y → R (y , z) × x ≡ y)  ↝⟨ ∃-cong (λ _ → ∃-cong λ _ → lemma₁ _) ⟩
    (∃ λ y → R (y , z) × y ≡ x)  ↔⟨ inverse $ ∃-intro _ _ ⟩
    R (x , z)                    ↔⟨ ∃-intro _ _ ⟩□
    (∃ λ y → R (x , y) × y ≡ z)  □}

⁺-swap :
  ∀ {k a} {A : Type a} {R : Rel₂ a A} →
  (∀ p → R p ↝[ k ] R (swap p)) →
  ∀ p → (R ⁺) p ↝[ k ] (R ⁺) (swap p)
⁺-swap {R = R} R↝ p =
  (R ⁺) p                           ↔⟨⟩
  (∃ λ n → (R ^^[1+ n ]) p)         ↝⟨ ∃-cong (λ n → ^^[1+]-swap R↝ n _) ⟩
  (∃ λ n → (R ^^[1+ n ]) (swap p))  ↔⟨⟩
  (R ⁺) (swap p)                    □

*-swap :
  ∀ {k a} {A : Type a} {R : Rel₂ a A} →
  (∀ p → R p ↝[ k ] R (swap p)) →
  ∀ p → (R *) p ↝[ k ] (R *) (swap p)
*-swap {R = R} R↝ p =
  (R *) p                      ↔⟨⟩
  (∃ λ n → (R ^^ n) p)         ↝⟨ ∃-cong (λ n → ^^-swap R↝ n _) ⟩
  (∃ λ n → (R ^^ n) (swap p))  ↔⟨⟩
  (R *) (swap p)               □

-- ⋃ constructs least upper bounds.

⊆-⋃ : ∀ {a b ℓ} {A : Type a} {B : Type b}
      (F : A → Trans (a ⊔ ℓ) B) a →
      ∀ R → F a R ⊆ ⋃ ℓ F R
⊆-⋃ {ℓ = ℓ} F a R =
  F a R                    ⊆⟨ a ,_ ⟩
  (λ x → ∃ λ a → F a R x)  ⊆⟨ id ⟩∎
  ⋃ ℓ F R                  ∎

⋃-⊆ : ∀ {a b ℓ} {A : Type a} {B : Type b}
      (F : A → Trans (a ⊔ ℓ) B) (G : Trans (a ⊔ ℓ) B) →
      (∀ {a} R → F a R ⊆ G R) →
      ∀ R → ⋃ ℓ F R ⊆ G R
⋃-⊆ {ℓ = ℓ} F G hyp R =
  ⋃ ℓ F R                  ⊆⟨⟩
  (λ x → ∃ λ a → F a R x)  ⊆⟨ hyp _ ∘ proj₂ ⟩∎
  G R                      ∎


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

open import lib.Basics
open import lib.types.Paths
open import lib.types.Pi
open import lib.types.Sigma

module lib.types.Pointed where

Ptd : ∀ i → Type (lsucc i)
Ptd i = Σ (Type i) (λ A → A)

Ptd₀ = Ptd lzero

⊙[_,_] : ∀ {i} (A : Type i) (a : A) → Ptd i
⊙[_,_] = _,_

_⊙→_ : ∀ {i j} → Ptd i → Ptd j → Ptd (lmax i j)
(A , a₀) ⊙→ (B , b₀) = ⊙[ Σ (A → B) (λ f → f a₀ == b₀) , ((λ _ → b₀), idp) ]

infixr 0 _⊙→_

_⊙×_ : ∀ {i j} → Ptd i → Ptd j → Ptd (lmax i j)
(A , a₀) ⊙× (B , b₀) = (A × B , (a₀ , b₀))

⊙fst : ∀ {i j} {X : Ptd i} {Y : Ptd j} → fst (X ⊙× Y ⊙→ X)
⊙fst = (fst , idp)

⊙snd : ∀ {i j} {X : Ptd i} {Y : Ptd j} → fst (X ⊙× Y ⊙→ Y)
⊙snd = (snd , idp)

⊙diag : ∀ {i} {X : Ptd i} → fst (X ⊙→ X ⊙× X)
⊙diag = ((λ x → (x , x)) , idp)

pair⊙→ : ∀ {i j k l} {X : Ptd i} {Y : Ptd j} {Z : Ptd k} {W : Ptd l}
  → fst (X ⊙→ Y) → fst (Z ⊙→ W)
  → fst ((X ⊙× Z) ⊙→ (Y ⊙× W))
pair⊙→ (f , fpt) (g , gpt) =
  ((λ {(x , z) → (f x , g z)}) , pair×= fpt gpt)

infixr 4 _⊙∘_

⊙idf : ∀ {i} (X : Ptd i) → fst (X ⊙→ X)
⊙idf A = ((λ x → x) , idp)

⊙cst : ∀ {i j} {X : Ptd i} {Y : Ptd j} → fst (X ⊙→ Y)
⊙cst {Y = Y} = ((λ x → snd Y) , idp)

_⊙∘_ : ∀ {i j k} {X : Ptd i} {Y : Ptd j} {Z : Ptd k}
  (g : fst (Y ⊙→ Z)) (f : fst (X ⊙→ Y)) → fst (X ⊙→ Z)
(g , gpt) ⊙∘ (f , fpt) = (g ∘ f) , (ap g fpt ∙ gpt)

⊙∘-unit-l : ∀ {i j} {X : Ptd i} {Y : Ptd j} (f : fst (X ⊙→ Y))
  → ⊙idf Y ⊙∘ f == f
⊙∘-unit-l (f , idp) = idp

⊙∘-assoc : ∀ {i j k l} {X : Ptd i} {Y : Ptd j} {Z : Ptd k} {W : Ptd l}
  (h : fst (Z ⊙→ W)) (g : fst (Y ⊙→ Z)) (f : fst (X ⊙→ Y))
  → ((h ⊙∘ g) ⊙∘ f) == (h ⊙∘ (g ⊙∘ f))
⊙∘-assoc (h , hpt) (g , gpt) (f , fpt) = pair= idp (lemma fpt gpt hpt)
  where
  lemma : ∀ {x₁ x₂} (fpt : x₁ == x₂) → ∀ gpt → ∀ hpt →
          ap (h ∘ g) fpt ∙ ap h gpt ∙ hpt == ap h (ap g fpt ∙ gpt) ∙ hpt
  lemma idp gpt hpt = idp

{- Obtaining equality of pointed types from an equivalence -}
⊙ua : ∀ {i} {A B : Type i} {a₀ : A} {b₀ : B}
  (e : A ≃ B) → –> e a₀ == b₀ → ⊙[ A , a₀ ] == ⊙[ B , b₀ ]
⊙ua e p = pair= (ua e) (↓-idf-ua-in e p)

{- ⊙→ preserves hlevel -}
⊙→-level : ∀ {i j} {X : Ptd i} {Y : Ptd j} {n : ℕ₋₂}
  → has-level n (fst Y) → has-level n (fst (X ⊙→ Y))
⊙→-level pY = Σ-level (Π-level (λ _ → pY)) (λ _ → =-preserves-level _ pY)

{- function extensionality for pointed functions -}
⊙λ= : ∀ {i j} {X : Ptd i} {Y : Ptd j} {f g : fst (X ⊙→ Y)}
  (p : ∀ x → fst f x == fst g x) (α : snd f == p (snd X) ∙ snd g)
  → f == g
⊙λ= {g = g} p α =
  pair= (λ= p) (↓-app=cst-in (α ∙ ap (λ w → w ∙ snd g) (! (app=-β p _))))

{- Obtaining pointed maps from an pointed equivalence -}
module _ {i j} {X : Ptd i} {Y : Ptd j} (e : fst X ≃ fst Y)
  (p : –> e (snd X) == snd Y) where

  ⊙–> : fst (X ⊙→ Y)
  ⊙–> = (–> e , p)

  ⊙<– : fst (Y ⊙→ X)
  ⊙<– = (<– e , ap (<– e) (! p) ∙ <–-inv-l e (snd X))


------------------------------------------------------------------------------
-- Conversion rules for the greatest common divisor
------------------------------------------------------------------------------

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

module FOTC.Program.GCD.Total.ConversionRulesI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Program.GCD.Total.GCD

------------------------------------------------------------------------------
private
  -- Before to prove some properties for the gcd it is convenient to
  -- descompose the behavior of the function step by step.

  -- Initially, we define the possible states (gcd-s₁, gcd-s₂,
  -- ...). Then we write down the proof for the execution step from
  -- the state p to the state q, e.g.
  --
  -- proof₂₋₃ : ∀ m n → gcd-s₂ m n → gcd-s₃ m n.

  -- The functions gcd-00, gcd-S0, gcd-0S, gcd-Sm>Sn and gcd-Sm≯Sn
  -- show the use of the states gcd-s₁, gcd-s₂, ..., and the proofs
  -- associated with the execution steps.

  ----------------------------------------------------------------------------
  -- The steps

  -- Initially, the equation gcd-eq is used.
  gcd-s₁ : D → D → D
  gcd-s₁ m n = if (iszero₁ n)
                 then m
                 else (if (iszero₁ m)
                         then n
                         else (if (gt m n)
                                 then gcd (m ∸ n) n
                                 else gcd m (n ∸ m)))

  -- First if_then_else_ (iszero₁ n).
  gcd-s₂ : D → D → D → D
  gcd-s₂ m n b = if b
                   then m
                   else (if (iszero₁ m)
                           then n
                           else (if (gt m n)
                                   then gcd (m ∸ n) n
                                   else gcd m (n ∸ m)))

  -- First if_then_else_ when iszero₁ n = true.
  gcd-s₃ : D → D
  gcd-s₃ m = m

  -- First if_then_else_ when iszero₁ n = false.
  gcd-s₄ : D → D → D
  gcd-s₄ m n = if (iszero₁ m)
                 then n
                 else (if (gt m n) then gcd (m ∸ n) n else gcd m (n ∸ m))

   -- Second if_then_else_ (iszero₁ m).
  gcd-s₈ : D → D → D → D
  gcd-s₈ m n b = if b
                   then n
                   else (if (gt m n) then gcd (m ∸ n) n else gcd m (n ∸ m))

  -- Second if_then_else_, when iszero₁ m = true.
  gcd-s₉ : D → D
  gcd-s₉ n = n

  -- Second if_then_else_, when iszero₁ m = false.
  gcd-s₁₀ : D → D → D
  gcd-s₁₀ m n = if (gt m n) then gcd (m ∸ n) n else gcd m (n ∸ m)

  -- Third if_then_else_ (gt m n).
  gcd-s₁₁ : D → D → D → D
  gcd-s₁₁ m n b = if b then gcd (m ∸ n) n else gcd m (n ∸ m)

  -- Third if_then_else_ when gt m n = true.
  gcd-s₁₂ : D → D → D
  gcd-s₁₂ m n = gcd (m ∸ n) n

  -- Fourth if_then_else_ when gt m n = false.
  gcd-s₁₃ : D → D → D
  gcd-s₁₃ m n = gcd m (n ∸ m)

  ----------------------------------------------------------------------------
  -- The execution steps

  {-

  To prove the execution steps, e.g.

  proof₃₋₄ : ∀ m n → gcd-s₃ m n → gcd_s₄ m n)

  we usually need to prove that

                         C [m] ≡ C [n] (1)

  given that
                             m ≡ n,    (2)

  where (2) is a conversion rule usually.
  We prove (1) using

  subst : ∀ {x y} (D : A → Set) → x ≡ y → P x → P y

  where
   • P is given by λ m → C [m ] ≡ C [n],
   • x ≡ y is given n ≡ m (actually, we use sym (m ≡ n)) and
   • P x is given by C [n] ≡ C [n] (i.e. refl).
  -}

  proof₀₋₁ : ∀ m n → gcd m n ≡ gcd-s₁ m n
  proof₀₋₁ = gcd-eq

  -- 25 April 2014. Failed with Andreas' --without-K.
  proof₁₋₂ : ∀ m n b → iszero₁ n ≡ b → gcd-s₁ m n ≡ gcd-s₂ m n b
  proof₁₋₂ m n .(iszero₁ n) refl = refl

  proof₂₋₃ : ∀ m n → gcd-s₂ m n true ≡ gcd-s₃ m
  proof₂₋₃ m _ = if-true (gcd-s₃ m)

  proof₂₋₄ : ∀ m n → gcd-s₂ m n false ≡ gcd-s₄ m n
  proof₂₋₄ m n = if-false (gcd-s₄ m n)

  proof₄₋₈ : ∀ m n b → iszero₁ m ≡ b → gcd-s₄ m n ≡ gcd-s₈ m n b
  proof₄₋₈ m n .(iszero₁ m) refl = refl

  proof₈₋₉ : ∀ m n → gcd-s₈ m n true ≡ gcd-s₉ n
  proof₈₋₉ _ n = if-true n

  proof₈₋₁₀ : ∀ m n → gcd-s₈ m n false ≡ gcd-s₁₀ m n
  proof₈₋₁₀ m n = if-false (gcd-s₁₀ m n)

  proof₁₀₋₁₁ : ∀ m n b → gt m n ≡ b → gcd-s₁₀ m n ≡ gcd-s₁₁ m n b
  proof₁₀₋₁₁ m n .(lt n m) refl = refl

  proof₁₁₋₁₂ : ∀ m n → gcd-s₁₁ m n true ≡ gcd-s₁₂ m n
  proof₁₁₋₁₂ m n = if-true (gcd (m ∸ n) n)

  proof₁₁₋₁₃ : ∀ m n → gcd-s₁₁ m n false ≡ gcd-s₁₃ m n
  proof₁₁₋₁₃ m n = if-false (gcd m (n ∸ m))

------------------------------------------------------------------------------
-- The five equations for gcd

-- First equation.
gcd-00 : gcd zero zero ≡ zero
gcd-00 =
  gcd zero zero         ≡⟨ proof₀₋₁ zero zero ⟩
  gcd-s₁ zero zero      ≡⟨ proof₁₋₂ zero zero true iszero-0 ⟩
  gcd-s₂ zero zero true ≡⟨ proof₂₋₃ zero zero ⟩
  zero                  ∎

-- Second equation.
gcd-S0 : ∀ n → gcd (succ₁ n) zero ≡ succ₁ n
gcd-S0 n =
  gcd (succ₁ n) zero         ≡⟨ proof₀₋₁ (succ₁ n) zero ⟩
  gcd-s₁ (succ₁ n) zero      ≡⟨ proof₁₋₂ (succ₁ n) zero true iszero-0 ⟩
  gcd-s₂ (succ₁ n) zero true ≡⟨ proof₂₋₃ (succ₁ n) zero ⟩
  succ₁ n                    ∎

-- Third equation.
gcd-0S : ∀ n → gcd zero (succ₁ n) ≡ succ₁ n
gcd-0S n =
  gcd zero (succ₁ n)          ≡⟨ proof₀₋₁ zero (succ₁ n) ⟩
  gcd-s₁ zero (succ₁ n)       ≡⟨ proof₁₋₂ zero (succ₁ n) false (iszero-S n) ⟩
  gcd-s₂ zero (succ₁ n) false ≡⟨ proof₂₋₄ zero (succ₁ n) ⟩
  gcd-s₄ zero (succ₁ n)       ≡⟨ proof₄₋₈ zero (succ₁ n) true iszero-0 ⟩
  gcd-s₈ zero (succ₁ n) true  ≡⟨ proof₈₋₉  zero (succ₁ n) ⟩
  succ₁ n                     ∎

-- Fourth equation.
gcd-S>S : ∀ m n → succ₁ m > succ₁ n →
          gcd (succ₁ m) (succ₁ n) ≡ gcd (succ₁ m ∸ succ₁ n) (succ₁ n)

gcd-S>S m n Sm>Sn =
  gcd (succ₁ m) (succ₁ n)           ≡⟨ proof₀₋₁ (succ₁ m) (succ₁ n) ⟩
  gcd-s₁ (succ₁ m) (succ₁ n)        ≡⟨ proof₁₋₂ (succ₁ m) (succ₁ n) false (iszero-S n) ⟩
  gcd-s₂ (succ₁ m) (succ₁ n) false  ≡⟨ proof₂₋₄ (succ₁ m) (succ₁ n) ⟩
  gcd-s₄ (succ₁ m) (succ₁ n)        ≡⟨ proof₄₋₈ (succ₁ m) (succ₁ n) false (iszero-S m) ⟩
  gcd-s₈ (succ₁ m) (succ₁ n) false  ≡⟨ proof₈₋₁₀ (succ₁ m) (succ₁ n) ⟩
  gcd-s₁₀ (succ₁ m) (succ₁ n)       ≡⟨ proof₁₀₋₁₁ (succ₁ m) (succ₁ n) true Sm>Sn ⟩
  gcd-s₁₁ (succ₁ m) (succ₁ n) true  ≡⟨ proof₁₁₋₁₂ (succ₁ m) (succ₁ n) ⟩
  gcd (succ₁ m ∸ succ₁ n) (succ₁ n) ∎

-- Fifth equation.
gcd-S≯S : ∀ m n → succ₁ m ≯ succ₁ n →
          gcd (succ₁ m) (succ₁ n) ≡ gcd (succ₁ m) (succ₁ n ∸ succ₁ m)
gcd-S≯S m n Sm≯Sn =
  gcd (succ₁ m) (succ₁ n)           ≡⟨ proof₀₋₁ (succ₁ m) (succ₁ n) ⟩
  gcd-s₁ (succ₁ m) (succ₁ n)        ≡⟨ proof₁₋₂ (succ₁ m) (succ₁ n) false (iszero-S n) ⟩
  gcd-s₂ (succ₁ m) (succ₁ n) false  ≡⟨ proof₂₋₄ (succ₁ m) (succ₁ n) ⟩
  gcd-s₄ (succ₁ m) (succ₁ n)        ≡⟨ proof₄₋₈ (succ₁ m) (succ₁ n) false (iszero-S m) ⟩
  gcd-s₈ (succ₁ m) (succ₁ n) false  ≡⟨ proof₈₋₁₀ (succ₁ m) (succ₁ n) ⟩
  gcd-s₁₀ (succ₁ m) (succ₁ n)       ≡⟨ proof₁₀₋₁₁ (succ₁ m) (succ₁ n) false Sm≯Sn ⟩
  gcd-s₁₁ (succ₁ m) (succ₁ n) false ≡⟨ proof₁₁₋₁₃ (succ₁ m) (succ₁ n) ⟩
  gcd (succ₁ m) (succ₁ n ∸ succ₁ m) ∎


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

module Cubical.Foundations.Logic where

import Cubical.Data.Empty as ⊥
open import Cubical.Data.Sum as ⊎ using (_⊎_)
open import Cubical.Data.Unit
open import Cubical.Data.Sigma

open import Cubical.Foundations.Prelude as FP
open import Cubical.Functions.Embedding
open import Cubical.Functions.Fibration as Fib
open import Cubical.Foundations.Equiv

open import Cubical.HITs.PropositionalTruncation as PropTrunc

open import Cubical.Foundations.HLevels using (hProp; isPropΠ; isPropΠ2; isSetΠ; isSetHProp; isOfHLevelΣ; isPropΣ) public
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Function
open import Cubical.Foundations.Univalence using (ua)

open import Cubical.Relation.Nullary hiding (¬_)

infix 10 ¬_
infixr 8 _⊔_
infixr 8 _⊔′_
infixr 8 _⊓_
infixr 8 _⊓′_
infixr 6 _⇒_
infixr 4 _⇔_
infix 30 _≡ₚ_
infix 30 _≢ₚ_

infix 2 ∃[]-syntax
infix 2 ∃[∶]-syntax

infix 2 ∀[∶]-syntax
infix 2 ∀[]-syntax

infix 2 ⇒∶_⇐∶_
infix 2 ⇐∶_⇒∶_

--------------------------------------------------------------------------------
-- The type hProp of mere propositions
-- the definition hProp is given in Foundations.HLevels
-- hProp ℓ = Σ (Type ℓ) isProp

private
  variable
    ℓ ℓ' ℓ'' : Level
    P Q R : hProp ℓ
    A B C : Type ℓ

[_] : hProp ℓ → Type ℓ
[_] = fst

isProp[] : (A : hProp ℓ) → isProp [ A ]
isProp[] = snd

∥_∥ₚ : Type ℓ → hProp ℓ
∥ A ∥ₚ = ∥ A ∥ , propTruncIsProp

_≡ₚ_ : (x y : A) → hProp _
x ≡ₚ y = ∥ x ≡ y ∥ₚ

hProp≡ : [ P ] ≡ [ Q ] → P ≡ Q
hProp≡ p = Σ≡Prop (\ _ → isPropIsProp) p

--------------------------------------------------------------------------------
-- Logical implication of mere propositions

_⇒_ : (A : hProp ℓ) → (B : hProp ℓ') → hProp _
A ⇒ B = ([ A ] → [ B ]) , isPropΠ λ _ → isProp[] B

⇔toPath : [ P ⇒ Q ] → [ Q ⇒ P ] → P ≡ Q
⇔toPath {P = P} {Q = Q} P⇒Q Q⇒P = hProp≡ (isoToPath
  (iso P⇒Q Q⇒P (λ b → isProp[] Q (P⇒Q (Q⇒P b)) b) λ a → isProp[] P (Q⇒P (P⇒Q a)) a))

pathTo⇒ : P ≡ Q → [ P ⇒ Q ]
pathTo⇒ p x = subst fst  p x

pathTo⇐ : P ≡ Q → [ Q ⇒ P ]
pathTo⇐ p x = subst fst (sym p) x

substₚ : {x y : A} (B : A → hProp ℓ) → [ x ≡ₚ y ⇒ B x ⇒ B y ]
substₚ {x = x} {y = y} B = PropTrunc.elim (λ _ → isPropΠ λ _ → isProp[] (B y)) (subst (fst ∘ B))

--------------------------------------------------------------------------------
-- Mixfix notations for ⇔-toPath
-- see ⊔-identityˡ and ⊔-identityʳ for the difference

⇒∶_⇐∶_ : [ P ⇒ Q ] → [ Q ⇒ P ] → P ≡ Q
⇒∶_⇐∶_ = ⇔toPath

⇐∶_⇒∶_ : [ Q ⇒ P ] → [ P ⇒ Q ] → P ≡ Q
⇐∶ g ⇒∶ f  = ⇔toPath f g
--------------------------------------------------------------------------------
-- False and True

⊥ : hProp _
⊥ = ⊥.⊥ , λ ()

⊤ : hProp _
⊤ = Unit , (λ _ _ _ → tt)

--------------------------------------------------------------------------------
-- Pseudo-complement of mere propositions

¬_ : hProp ℓ → hProp _
¬ A = ([ A ] → ⊥.⊥) , isPropΠ λ _ → ⊥.isProp⊥

_≢ₚ_ : (x y : A) → hProp _
x ≢ₚ y = ¬ x ≡ₚ y

--------------------------------------------------------------------------------
-- Disjunction of mere propositions

_⊔′_ : Type ℓ → Type ℓ' → Type _
A ⊔′ B = ∥ A ⊎ B ∥

_⊔_ : hProp ℓ → hProp ℓ' → hProp _
P ⊔ Q = ∥ [ P ] ⊎ [ Q ] ∥ₚ

inl : A → A ⊔′ B
inl x = ∣ ⊎.inl x ∣

inr : B → A ⊔′ B
inr x = ∣ ⊎.inr x ∣

⊔-elim : (P : hProp ℓ) (Q : hProp ℓ') (R : [ P ⊔ Q ] → hProp ℓ'')
  → (∀ x → [ R (inl x) ]) → (∀ y → [ R (inr y) ]) → (∀ z → [ R z ])
⊔-elim _ _ R P⇒R Q⇒R = PropTrunc.elim (snd ∘ R) (⊎.elim P⇒R Q⇒R)

--------------------------------------------------------------------------------
-- Conjunction of mere propositions
_⊓′_ : Type ℓ → Type ℓ' → Type _
A ⊓′ B = A × B

_⊓_ : hProp ℓ → hProp ℓ' → hProp _
A ⊓ B = [ A ] ⊓′ [ B ] , isOfHLevelΣ 1 (isProp[] A) (\ _ → isProp[] B)

⊓-intro : (P : hProp ℓ) (Q : [ P ] → hProp ℓ') (R : [ P ] → hProp ℓ'')
       → (∀ a → [ Q a ]) → (∀ a → [ R a ]) → (∀ (a : [ P ]) → [ Q a ⊓ R a ] )
⊓-intro _ _ _ = \ f g a → f a , g a

--------------------------------------------------------------------------------
-- Logical bi-implication of mere propositions

_⇔_ : hProp ℓ → hProp ℓ' → hProp _
A ⇔ B = (A ⇒ B) ⊓ (B ⇒ A)

--------------------------------------------------------------------------------
-- Universal Quantifier

∀[∶]-syntax : (A → hProp ℓ) → hProp _
∀[∶]-syntax {A = A} P = (∀ x → [ P x ]) , isPropΠ (isProp[] ∘ P)

∀[]-syntax : (A → hProp ℓ) → hProp _
∀[]-syntax {A = A} P = (∀ x → [ P x ]) , isPropΠ (isProp[] ∘ P)

syntax ∀[∶]-syntax {A = A} (λ a → P) = ∀[ a ∶ A ] P
syntax ∀[]-syntax (λ a → P)          = ∀[ a ] P
--------------------------------------------------------------------------------
-- Existential Quantifier

∃[]-syntax : (A → hProp ℓ) → hProp _
∃[]-syntax {A = A} P = ∥ Σ A ([_] ∘ P) ∥ₚ

∃[∶]-syntax : (A → hProp ℓ) → hProp _
∃[∶]-syntax {A = A} P = ∥ Σ A ([_] ∘ P) ∥ₚ

syntax ∃[∶]-syntax {A = A} (λ x → P) = ∃[ x ∶ A ] P
syntax ∃[]-syntax (λ x → P) = ∃[ x ] P
--------------------------------------------------------------------------------
-- Decidable mere proposition

Decₚ : (P : hProp ℓ) → hProp ℓ
Decₚ P = Dec [ P ] , isPropDec (isProp[] P)

--------------------------------------------------------------------------------
-- Negation commutes with truncation

∥¬A∥≡¬∥A∥ : (A : Type ℓ) → ∥ (A → ⊥.⊥) ∥ₚ ≡ (¬ ∥ A ∥ₚ)
∥¬A∥≡¬∥A∥ _ =
  ⇒∶ (λ ¬A A → PropTrunc.elim (λ _ → ⊥.isProp⊥)
    (PropTrunc.elim (λ _ → isPropΠ λ _ → ⊥.isProp⊥) (λ ¬p p → ¬p p) ¬A) A)
  ⇐∶ λ ¬p → ∣ (λ p → ¬p ∣ p ∣) ∣

--------------------------------------------------------------------------------
-- (hProp, ⊔, ⊥) is a bounded ⊔-semilattice

⊔-assoc : (P : hProp ℓ) (Q : hProp ℓ') (R : hProp ℓ'')
  → P ⊔ (Q ⊔ R) ≡ (P ⊔ Q) ⊔ R
⊔-assoc P Q R =
  ⇒∶ ⊔-elim P (Q ⊔ R) (λ _ → (P ⊔ Q) ⊔ R)
    (inl ∘ inl)
    (⊔-elim Q R (λ _ → (P ⊔ Q) ⊔ R) (inl ∘ inr) inr)

  ⇐∶ assoc2
  where
    assoc2 : (A ⊔′ B) ⊔′ C → A ⊔′ (B ⊔′ C)
    assoc2 ∣ ⊎.inr a ∣              = ∣ ⊎.inr ∣ ⊎.inr a ∣ ∣
    assoc2 ∣ ⊎.inl ∣ ⊎.inr b ∣ ∣  = ∣ ⊎.inr ∣ ⊎.inl b ∣ ∣
    assoc2 ∣ ⊎.inl ∣ ⊎.inl c ∣ ∣  = ∣ ⊎.inl c ∣
    assoc2 ∣ ⊎.inl (squash x y i) ∣ = propTruncIsProp (assoc2 ∣ ⊎.inl x ∣) (assoc2 ∣ ⊎.inl y ∣) i
    assoc2 (squash x y i)             = propTruncIsProp (assoc2 x) (assoc2 y) i

⊔-idem : (P : hProp ℓ) → P ⊔ P ≡ P
⊔-idem P =
  ⇒∶ (⊔-elim P P (\ _ → P) (\ x → x) (\ x → x))
  ⇐∶ inl

⊔-comm : (P : hProp ℓ) (Q : hProp ℓ') → P ⊔ Q ≡ Q ⊔ P
⊔-comm P Q =
  ⇒∶ (⊔-elim P Q (\ _ → (Q ⊔ P)) inr inl)
  ⇐∶ (⊔-elim Q P (\ _ → (P ⊔ Q)) inr inl)

⊔-identityˡ : (P : hProp ℓ) → ⊥ ⊔ P ≡ P
⊔-identityˡ P =
  ⇒∶ (⊔-elim ⊥ P (λ _ → P) (λ ()) (λ x → x))
  ⇐∶ inr

⊔-identityʳ : (P : hProp ℓ) → P ⊔ ⊥ ≡ P
⊔-identityʳ P = ⇔toPath (⊔-elim P ⊥ (λ _ → P) (λ x → x) λ ()) inl

--------------------------------------------------------------------------------
-- (hProp, ⊓, ⊤) is a bounded ⊓-lattice

⊓-assoc : (P : hProp ℓ) (Q : hProp ℓ') (R : hProp ℓ'')
  → P ⊓ Q ⊓ R ≡ (P ⊓ Q) ⊓ R
⊓-assoc _ _ _ =
  ⇒∶ (λ {(x , (y , z)) →  (x , y) , z})
  ⇐∶ (λ {((x , y) , z) → x , (y , z) })

⊓-comm : (P : hProp ℓ) (Q : hProp ℓ') → P ⊓ Q ≡ Q ⊓ P
⊓-comm _ _ = ⇔toPath (\ p → p .snd , p .fst) (\ p → p .snd , p .fst)

⊓-idem : (P : hProp ℓ) → P ⊓ P ≡ P
⊓-idem _ = ⇔toPath fst (λ x → x , x)

⊓-identityˡ : (P : hProp ℓ) → ⊤ ⊓ P ≡ P
⊓-identityˡ _ = ⇔toPath snd λ x → tt , x

⊓-identityʳ : (P : hProp ℓ) → P ⊓ ⊤ ≡ P
⊓-identityʳ _ = ⇔toPath fst λ x → x , tt

--------------------------------------------------------------------------------
-- Distributive laws

⇒-⊓-distrib : (P : hProp ℓ) (Q : hProp ℓ')(R : hProp ℓ'')
  → P ⇒ (Q ⊓ R) ≡ (P ⇒ Q) ⊓ (P ⇒ R)
⇒-⊓-distrib _ _ _ =
  ⇒∶ (λ f → (fst ∘ f) , (snd ∘ f))
  ⇐∶ (λ { (f , g) x → f x , g x})

⊓-⊔-distribˡ : (P : hProp ℓ) (Q : hProp ℓ')(R : hProp ℓ'')
  → P ⊓ (Q ⊔ R) ≡ (P ⊓ Q) ⊔ (P ⊓ R)
⊓-⊔-distribˡ P Q R =
  ⇒∶ (λ { (x , a) → ⊔-elim Q R (λ _ → (P ⊓ Q) ⊔ (P ⊓ R))
        (λ y → ∣ ⊎.inl (x , y) ∣ )
        (λ z → ∣ ⊎.inr (x , z) ∣ ) a })

  ⇐∶ ⊔-elim (P ⊓ Q) (P ⊓ R) (λ _ → P ⊓ Q ⊔ R)
       (λ y → fst y , inl (snd y))
       (λ z → fst z , inr (snd z))

⊔-⊓-distribˡ : (P : hProp ℓ) (Q : hProp ℓ')(R : hProp ℓ'')
  → P ⊔ (Q ⊓ R) ≡ (P ⊔ Q) ⊓ (P ⊔ R)
⊔-⊓-distribˡ P Q R =
  ⇒∶ ⊔-elim P (Q ⊓ R) (λ _ → (P ⊔ Q) ⊓ (P ⊔ R) )
    (\ x → inl x , inl x) (\ p → inr (p .fst) , inr (p .snd))

  ⇐∶ (λ { (x , y) → ⊔-elim P R (λ _ → P ⊔ Q ⊓ R) inl
      (λ z → ⊔-elim P Q (λ _ → P ⊔ Q ⊓ R) inl (λ y → inr (y , z)) x) y })

⊓-∀-distrib :  (P : A → hProp ℓ) (Q : A → hProp ℓ')
  → (∀[ a ∶ A ] P a) ⊓ (∀[ a ∶ A ] Q a) ≡ (∀[ a ∶ A ] (P a ⊓ Q a))
⊓-∀-distrib P Q =
  ⇒∶ (λ {(p , q) a → p a , q a})
  ⇐∶ λ pq → (fst ∘ pq ) , (snd ∘ pq)

--------------------------------------------------------------------------------
-- Introduce the "powerset" of a type in the style of Escardó's lecture notes:
-- https://www.cs.bham.ac.uk/~mhe/HoTT-UF-in-Agda-Lecture-Notes/HoTT-UF-Agda.html#propositionalextensionality

ℙ : ∀ {ℓ} → Type ℓ → Type (ℓ-suc ℓ)
ℙ {ℓ} X = X → hProp ℓ

infix 5 _∈_
_∈_ : {X : Type ℓ} → X → ℙ X → Type ℓ
x ∈ A = [ A x ]

_⊆_ : {X : Type ℓ} → ℙ X → ℙ X → Type ℓ
A ⊆ B = ∀ x → x ∈ A → x ∈ B

∈-isProp : {X : Type ℓ} (A : ℙ X) (x : X) → isProp (x ∈ A)
∈-isProp A = isProp[] ∘ A

⊆-isProp : {X : Type ℓ} (A B : ℙ X) → isProp (A ⊆ B)
⊆-isProp A B = isPropΠ2 (λ x _ → ∈-isProp B x)

⊆-refl : {X : Type ℓ} (A : ℙ X) → A ⊆ A
⊆-refl A x = idfun (x ∈ A)

⊆-refl-consequence : {X : Type ℓ} (A B : ℙ X)
                   → A ≡ B → (A ⊆ B) × (B ⊆ A)
⊆-refl-consequence {X} A B p = subst (λ B → (A ⊆ B)) p (⊆-refl A) , subst (λ A → (B ⊆ A)) (sym p) (⊆-refl B)

⊆-extensionality : {X : Type ℓ} (A B : ℙ X)
                 → (A ⊆ B) × (B ⊆ A) → A ≡ B
⊆-extensionality A B (φ , ψ) i x = ⇔toPath {P = (A x)} {Q = (B x)} (φ x) (ψ x) i

powersets-are-sets : {X : Type ℓ} → isSet (ℙ X)
powersets-are-sets {X = X} = isSetΠ (λ _ → isSetHProp)

⊆-extensionalityEquiv : {X : Type ℓ} (A B : ℙ X)
                      → (A ⊆ B) × (B ⊆ A) ≃ (A ≡ B)
⊆-extensionalityEquiv A B = isoToEquiv (iso (⊆-extensionality A B)
                                            (⊆-refl-consequence A B)
                                            (λ _ → powersets-are-sets A B _ _)
                                            (λ _ → isPropΣ (⊆-isProp A B) (λ _ → ⊆-isProp B A) _ _))

-- We show that the powerset is the subtype classifier
-- i.e. ℙ X ≃ Σ[A ∈ Type ℓ] (A ↪ X)
Embedding→Subset : {X : Type ℓ} → Σ[ A ∈ Type ℓ ] (A ↪ X) → ℙ X
Embedding→Subset (_ , f , isPropFiber) x = fiber f x , isPropFiber x

Subset→Embedding : {X : Type ℓ} → ℙ X → Σ[ A ∈ Type ℓ ] (A ↪ X)
Subset→Embedding {X = X} A = D , f , ψ
 where
  D = Σ[ x ∈ X ] x ∈ A

  f : D → X
  f d = d .fst

  ψ : hasPropFibers f
  ψ x ((y , y∈A) , y≡x) ((z , z∈A) , z≡x) = ΣPathP (r , q)
   where
    p : y ≡ z
    p = y≡x ∙ sym z≡x

    r : (y , y∈A) ≡ (z , z∈A)
    r = Σ≡Prop (∈-isProp A) p

    q : PathP (λ i → p i ≡ x) y≡x z≡x
    q i j = hcomp (λ k → λ { (j = i1) → x
                           ; (i = i0) → y≡x j
                           ; (i = i1) → z≡x (~ k ∨ j) })
                  (y≡x (i ∨ j))

Subset→Embedding→Subset : {X : Type ℓ} → section (Embedding→Subset {ℓ} {X}) (Subset→Embedding {ℓ} {X})
Subset→Embedding→Subset _ = funExt λ x → Σ≡Prop (λ _ → FP.isPropIsProp) (ua (Fib.FiberIso.fiberEquiv _ x))

Embedding→Subset→Embedding : {X : Type ℓ} → retract (Embedding→Subset {ℓ} {X}) (Subset→Embedding {ℓ} {X})
Embedding→Subset→Embedding {ℓ = ℓ} {X = X} (A , f , ψ) = cong (Σ-assoc-≃ .fst) p
 where
 χ = Subset→Embedding (Embedding→Subset (A , f , ψ)) .snd .snd

 p : (((Σ[ x ∈ X ] fiber f x) , fst) , χ) ≡ ((A , f) , ψ)
 p = Σ≡Prop (λ _ → hasPropFibersIsProp) ((equivToIso (Fib.fibrationEquiv X ℓ)) .Iso.leftInv (A , f))

Subset≃Embedding : {X : Type ℓ} → ℙ X ≃ (Σ[ A ∈ Type ℓ ] (A ↪ X))
Subset≃Embedding = isoToEquiv (iso Subset→Embedding Embedding→Subset Embedding→Subset→Embedding Subset→Embedding→Subset)

Subset≡Embedding : {X : Type ℓ} → ℙ X ≡ (Σ[ A ∈ Type ℓ ] (A ↪ X))
Subset≡Embedding = ua Subset≃Embedding


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

module Categories.Groupoid.Coproduct where

open import Level
open import Data.Sum

open import Categories.Category
open import Categories.Groupoid
open import Categories.Morphisms
import Categories.Coproduct as CoproductC

Coproduct : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′}
          → Groupoid C → Groupoid D → Groupoid (CoproductC.Coproduct C D)
Coproduct C D = record
  { _⁻¹ = λ { {inj₁ _} {inj₁ _} → λ { {lift f} → lift (C._⁻¹ f) }
            ; {inj₁ _} {inj₂ _} (lift ())
            ; {inj₂ _} {inj₁ _} (lift ())
            ; {inj₂ _} {inj₂ _} → λ { {lift f} → lift (D._⁻¹ f) }
            }
  ; iso = λ { {inj₁ _} {inj₁ _} → record { isoˡ = lift (Iso.isoˡ C.iso)
                                         ; isoʳ = lift (Iso.isoʳ C.iso) }
            ; {inj₁ _} {inj₂ _} {lift ()}
            ; {inj₂ _} {inj₁ _} {lift ()}
            ; {inj₂ _} {inj₂ _} → record { isoˡ = lift (Iso.isoˡ D.iso)
                                         ; isoʳ = lift (Iso.isoʳ D.iso) }
            }
  }
  where
  module C = Groupoid C
  module D = Groupoid D


module Source.Examples where

open import Source.Size
open import Source.Size.Substitution.Theory
open import Source.Term
open import Source.Type
open import Util.Prelude

import Source.Size.Substitution.Canonical as SC

{-
liftℕ : ∀ n < ⋆. ∀ m < n. Nat m → Nat n
liftℕ ≔ Λ n < ⋆. Λ m < n. λ i : Nat m.
  caseNat[Nat n] m i
    zero n
    (Λ k < m. λ i′ : Nat k. suc n k i′)
-}
liftNat : ∀ {Δ} → Term Δ
liftNat = Λₛ ⋆ , Λₛ v0 , Λ (Nat v0) ,
  caseNat (Nat v1) v0 (var 0)
    (zero v1)
    (Λₛ v0 , Λ (Nat v0) , suc v2 v0 (var 0))

liftNat⊢ : ∀ {Δ Γ}
  → Δ , Γ ⊢ liftNat ∶ Π ⋆ , Π v0 , Nat v0 ⇒ Nat v1
liftNat⊢
  = absₛ
      (absₛ
        (abs
          (caseNat (<-trans (var refl) (var refl))
            (var zero)
            (zero (var refl))
            (absₛ
              (abs
                (suc (var refl) (<-trans (var refl) (var refl)) (var zero)))
              refl)
            refl))
        refl)
      refl

{-
half : ∀ n < ⋆. Nat n → Nat n
half ≔ λ n < ⋆. fix[Nat ∙ → Nat ∙]
  (Λ n < ⋆. λ rec : (∀ m < n. Nat m → Nat m). λ i : Nat n.
    caseNat[Nat n] n i
      (zero n)
      (Λ m < n. λ i′ : Nat m. caseNat[Nat n] m i′
        (zero n)
        (Λ k < m. λ i″ : Nat k. suc n k (rec k i″))))
  n
-}
half : ∀ {Δ} → Term Δ
half = Λₛ ⋆ , fix (Nat v0 ⇒ Nat v0)
  (Λₛ ⋆ , Λ (Π v0 , Nat v0 ⇒ Nat v0) ,
    Λ Nat v0 , caseNat (Nat v0) v0 (var 0)
      (zero v0)
      (Λₛ v0 , Λ (Nat v0) , caseNat (Nat v1) v0 (var 0)
        (zero v1)
        (Λₛ v0 , Λ (Nat v0) , suc v2 v0 (var 3 ·ₛ v0 · var 0))))
  v0

half⊢ : ∀ {Δ Γ} → Δ , Γ ⊢ half ∶ Π ⋆ , Nat v0 ⇒ Nat v0
half⊢
  = absₛ
      (fix (var refl)
        (absₛ
          (abs
            (abs
              (caseNat (var refl) (var zero) (zero (var refl))
                (absₛ
                  (abs
                    (caseNat (<-trans (var refl) (var refl))
                      (var zero)
                      (zero (var refl))
                      (absₛ
                        (abs
                          (suc (var refl) (<-trans (var refl) (var refl))
                            (app
                              (appₛ (<-trans (var refl) (var refl))
                                (var (suc (suc (suc zero))))
                                refl)
                              (var zero))))
                        refl)
                      refl))
                  refl)
                refl)))
          refl)
        refl
        refl)
      refl

{-
suc∞ : Nat ∞ → Nat ∞
suc∞ ≔ λ i : Nat ∞. caseNat[Nat ∞] ∞ i
  (suc ∞ 0 (zero 0))
  (Λ m < ∞. λ i′ : Nat m. suc ∞ (↑ m) (suc (↑ m) m i′))
-}
suc∞ : ∀ {Δ} → Term Δ
suc∞ = Λ (Nat ∞) , caseNat (Nat ∞) ∞ (var 0)
  (suc ∞ zero (zero zero))
  (Λₛ ∞ , Λ (Nat v0) , suc ∞ (suc v0) (suc (suc v0) v0 (var 0)))

suc∞⊢ : ∀ {Δ Γ} → Δ , Γ ⊢ suc∞ ∶ Nat ∞ ⇒ Nat ∞
suc∞⊢
  = abs
      (caseNat <suc (var zero) (suc <suc zero<∞ (zero (<-trans zero<∞ <suc)))
        (absₛ
          (abs
            (suc <suc (suc<∞ (var refl))
              (suc (<-trans (suc<∞ (var refl)) <suc) <suc
                (var zero))))
          refl)
        refl)

{-
plus : ∀ n < ⋆. Nat n → Nat ∞ → Nat ∞
plus ≔ Λ n < ⋆. fix[Nat ∙ → Nat ∞ → Nat ∞]
  (Λ n < ⋆. λ rec : (∀ m < n. Nat m → Nat ∞ → Nat ∞).
    λ i : Nat n. λ j : Nat ∞. caseNat[Nat ∞] n i
      j
      (Λ m < n. λ i′ : Nat m. suc∞ (rec m i′ j)))
  n
-}
plus : ∀ {Δ} → Term Δ
plus = Λₛ ⋆ , fix (Nat v0 ⇒ Nat ∞ ⇒ Nat ∞)
  (Λₛ ⋆ , Λ (Π v0 , Nat v0 ⇒ Nat ∞ ⇒ Nat ∞) ,
    Λ (Nat v0) , Λ (Nat ∞) , caseNat (Nat ∞) v0 (var 1)
      (var 0)
      (Λₛ v0 , Λ (Nat v0) , suc∞ · (var 3 ·ₛ v0 · var 0 · var 1)))
  v0

plus⊢ : ∀ {Δ Γ} → Δ , Γ ⊢ plus ∶ Π ⋆ , Nat v0 ⇒ Nat ∞ ⇒ Nat ∞
plus⊢
  = absₛ
      (fix (var refl)
        (absₛ
          (abs
            (abs
              (abs
                (caseNat (var refl) (var (suc zero)) (var zero)
                  (absₛ
                    (abs
                      (app
                        suc∞⊢
                        (app
                          (app
                            (appₛ (var refl)
                              (var (suc (suc (suc zero))))
                              refl)
                            (var zero))
                          (var (suc zero)))))
                    refl)
                  refl))))
          refl)
        refl
        refl)
      refl

{-
zeros : ∀ n < ⋆. Stream n
zeros ≔ Λ n < ⋆. fix[Stream ∙]
  (Λ n < ⋆. λ rec : (∀ m < n. Stream m).
    cons (zero ∞) n rec)
  n
-}
zeros : ∀ {Δ} → Term Δ
zeros = Λₛ ⋆ , fix (Stream v0)
  (Λₛ ⋆ , Λ (Π v0 , Stream v0) , cons (zero ∞) v0 (var 0))
  v0

zeros⊢ : ∀ {Δ Γ} → Δ , Γ ⊢ zeros ∶ Π ⋆ , Stream v0
zeros⊢
  = absₛ
      (fix (var refl)
        (absₛ
          (abs
            (cons (var refl) (zero <suc) (var zero)))
          refl)
        refl
        refl)
      refl

{-
map : (Nat ∞ → Nat ∞) → ∀ n < ⋆. Stream n → Stream n
map ≔ λ f : Nat ∞ → Nat ∞. Λ n < ⋆. fix[Stream ∙ → Stream ∙]
  (Λ n < ⋆. λ rec : (∀ m < n. Stream m → Stream m). λ xs : Stream n.
    cons (f (head n xs)) n (Λ m < n. rec m (tail n xs m)))
  n
-}
map : ∀ {Δ} → Term Δ
map = Λ (Nat ∞ ⇒ Nat ∞) , Λₛ ⋆ , fix (Stream v0 ⇒ Stream v0)
  (Λₛ ⋆ , Λ (Π v0 , Stream v0 ⇒ Stream v0) , Λ Stream v0 ,
    cons (var 2 · head v0 (var 0)) v0
      (Λₛ v0 , var 1 ·ₛ v0 · tail v1 (var 0) v0))
  v0

map⊢ : ∀ {Δ Γ} → Δ , Γ ⊢ map ∶ (Nat ∞ ⇒ Nat ∞) ⇒ (Π ⋆ , Stream v0 ⇒ Stream v0)
map⊢
  = abs
      (absₛ
        (fix (var refl)
          (absₛ
            (abs
              (abs
                (cons
                  (var refl)
                  (app (var (suc (suc zero))) (head (var refl) (var zero)))
                  (absₛ (app (appₛ (var refl) (var (suc zero)) refl)
                      (tail (var refl) (var refl) (var zero)))
                  refl))))
            refl)
          refl
          refl)
        refl)


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

open import HoTT
open import groups.Cokernel
open import groups.Exactness
open import groups.ExactSequence
open import cohomology.Theory

open import cw.CW
open import cw.WedgeOfCells

module cw.cohomology.reconstructed.TipCoboundary {i} (OT : OrdinaryTheory i)
  (⊙skel : ⊙Skeleton {i} 1) where

open OrdinaryTheory OT
open import cohomology.LongExactSequence cohomology-theory 0 (⊙cw-incl-last ⊙skel)
open import cw.cohomology.WedgeOfCells OT ⊙skel
open import cw.cohomology.reconstructed.TipAndAugment OT (⊙cw-init ⊙skel)

CX₁/X₀-is-abelian = CXₙ/Xₙ₋₁-is-abelian 1

cw-co∂-head' : CX₀ 0 →ᴳ CXₙ/Xₙ₋₁ 1
cw-co∂-head' = co∂

⊙cw-∂-head'-before-Susp : ⊙Xₙ/Xₙ₋₁ (⊙Skeleton.skel ⊙skel) ⊙→ ⊙Susp (⊙cw-head ⊙skel)
⊙cw-∂-head'-before-Susp = ⊙∂-before-Susp

cw-∂-head'-before-Susp : Xₙ/Xₙ₋₁ (⊙Skeleton.skel ⊙skel) → Susp (cw-head (⊙Skeleton.skel ⊙skel))
cw-∂-head'-before-Susp = ∂-before-Susp

abstract
  cw-∂-head'-before-Susp-glue-β : ∀ x → ap cw-∂-head'-before-Susp (cfglue x) == merid x
  cw-∂-head'-before-Susp-glue-β = ∂-before-Susp-glue-β

cw-co∂-head : C2×CX₀ 0 →ᴳ CXₙ/Xₙ₋₁ 1
cw-co∂-head = record {f = GroupHom.f cw-co∂-head' ∘ snd; pres-comp = lemma}
  where abstract lemma = ∘ᴳ-pres-comp cw-co∂-head' (×ᴳ-snd {G = C2 0} {H = CX₀ 0})

abstract
  -- This relies on the [lemma] above being non-abstract within this scope.
  co∂-head-incl-exact : is-exact cw-co∂-head (C-fmap 1 (⊙cfcod' (⊙cw-incl-last ⊙skel)))
  co∂-head-incl-exact = pre∘-is-exact
    (×ᴳ-snd {G = C2 0} {H = CX₀ 0})
    (×ᴳ-snd-is-surj {G = C2 0} {H = CX₀ 0})
    (exact-seq-index 1 C-cofiber-exact-seq)

module CokerCo∂Head where
  grp = Coker cw-co∂-head CX₁/X₀-is-abelian
  open Group grp public


open import Mockingbird.Forest using (Forest)

-- Curry’s Lively Bird Forest
module Mockingbird.Problems.Chapter14 {b ℓ} (forest : Forest {b} {ℓ}) where

open import Data.Product using (_×_; _,_; ∃-syntax; proj₁; proj₂)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Function using (_$_; _⇔_; Equivalence; mk⇔)
open import Level using (_⊔_)
open import Relation.Binary using (_Respects_)
open import Relation.Nullary using (¬_)
open import Relation.Unary using (Pred)

open import Mockingbird.Forest.Birds forest
import Mockingbird.Problems.Chapter09 forest as Chapter₉

open Forest forest

module _ {s} (Sings : Pred Bird s)
         (respects : Sings Respects _≈_)
         -- This law of excluded middle is not stated in the problem as one of
         -- the laws, but in the solution given in the book, it is used.
         (LEM : ∀ x → Sings x ⊎ ¬ Sings x)
         (P : Bird) where

  module _ (law₁ : ∀ {x y} → Sings y → Sings (P ∙ x ∙ y))
           (law₂ : ∀ {x y} → ¬ (Sings x) → Sings (P ∙ x ∙ y))
           (law₃ : ∀ {x y} → Sings x → Sings (P ∙ x ∙ y) → Sings y)
           (law₄ : ∀ x → ∃[ y ] Sings y ⇔ Sings (P ∙ y ∙ x)) where

    problem₁ : ∀ x → Sings x
    problem₁ x = law₃ (proj₂ (law₄-⇐ x) Pyx-sings) Pyx-sings
      where
        -- If y sings on all days on which x sings, then Pxy sings on all days.
        lemma-Pxy : ∀ y x → (Sings y → Sings x) → Sings (P ∙ y ∙ x)
        lemma-Pxy y x y-sings⇒x-sings with LEM y
        ... | inj₁ y-sings = law₁ (y-sings⇒x-sings y-sings)
        ... | inj₂ ¬y-sings = law₂ ¬y-sings

        law₄-⇒ : ∀ x → ∃[ y ] (Sings y → Sings (P ∙ y ∙ x))
        law₄-⇒ x =
          let (y , p) = law₄ x
          in (y , Equivalence.f p)

        law₄-⇐ : ∀ x → ∃[ y ] (Sings (P ∙ y ∙ x) → Sings y)
        law₄-⇐ x =
          let (y , p) = law₄ x
          in (y , Equivalence.g p)

        y = proj₁ $ law₄ x

        y-sings⇒x-sings : Sings y → Sings x
        y-sings⇒x-sings y-sings = law₃ y-sings $ proj₂ (law₄-⇒ x) y-sings

        Pyx-sings : Sings (P ∙ y ∙ x)
        Pyx-sings = lemma-Pxy y x y-sings⇒x-sings

  module _ (law₁ : ∀ {x y} → Sings y → Sings (P ∙ x ∙ y))
           (law₂ : ∀ {x y} → ¬ Sings (x) → Sings (P ∙ x ∙ y))
           (law₃ : ∀ {x y} → Sings x → Sings (P ∙ x ∙ y) → Sings y)
           ⦃ _ : HasCardinal ⦄ ⦃ _ : HasLark ⦄ where

    problem₂ : ∀ x → Sings x
    problem₂ = problem₁ law₁ law₂ law₃ $ λ x →
      let -- There exists a bird of which CPx is fond.
          (y , isFond) = Chapter₉.problem₂₅ (C ∙ P ∙ x)

          Pyx≈y : P ∙ y ∙ x ≈ y
          Pyx≈y = begin
            P ∙ y ∙ x      ≈˘⟨ isCardinal P x y ⟩
            C ∙ P ∙ x ∙ y  ≈⟨ isFond ⟩
            y              ∎

          law₄ : Sings y ⇔ Sings (P ∙ y ∙ x)
          law₄ = mk⇔ (respects (sym Pyx≈y)) (respects Pyx≈y)
      in (y , law₄)

  module _ (law₁ : ∀ {x y} → Sings y → Sings (P ∙ x ∙ y))
           (law₂ : ∀ {x y} → ¬ Sings (x) → Sings (P ∙ x ∙ y))
           (law₃ : ∀ {x y} → Sings x → Sings (P ∙ x ∙ y) → Sings y) where

    problem₃ : ∃[ A ] (∀ x y z → A ∙ x ∙ y ∙ z ≈ x ∙ (z ∙ z) ∙ y) → ∀ x → Sings x
    problem₃ (A , Axyz≈x[zz]y) = problem₁ law₁ law₂ law₃ $ λ x →
      let y = A ∙ P ∙ x ∙ (A ∙ P ∙ x)

          y≈Pyx : y ≈ P ∙ y ∙ x
          y≈Pyx = begin
            y                                  ≈⟨⟩
            A ∙ P ∙ x ∙ (A ∙ P ∙ x)            ≈⟨ Axyz≈x[zz]y P x (A ∙ P ∙ x) ⟩
            P ∙ (A ∙ P ∙ x ∙ (A ∙ P ∙ x)) ∙ x  ≈⟨⟩
            (P ∙ y ∙ x                         ∎)

          law₄ : Sings y ⇔ Sings (P ∙ y ∙ x)
          law₄ = mk⇔ (respects y≈Pyx) (respects (sym y≈Pyx))
      in (y , law₄)

-- -- TODO: bonus exercises


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.Polynomials.Multivariate.Equiv.Poly1-Poly where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism

open import Cubical.Data.Nat renaming (_+_ to _+n_; _·_ to _·n_)
open import Cubical.Data.Vec renaming ( [] to <> ; _∷_ to _::_)

open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing

open import Cubical.Algebra.Polynomials.Univariate.Base
open import Cubical.Algebra.Polynomials.Univariate.Properties
open import Cubical.Algebra.CommRing.Instances.UnivariatePoly

open import Cubical.Algebra.Polynomials.Multivariate.Base
open import Cubical.Algebra.Polynomials.Multivariate.Properties
open import Cubical.Algebra.CommRing.Instances.MultivariatePoly

private variable
  ℓ : Level

module Equiv-Poly1-Poly: (A' : CommRing ℓ) where
  private
    A = fst A'

  open PolyMod A'
    renaming
    ( Poly               to Poly:
    ; isSetPoly          to isSetPoly:
    )

  open PolyModTheory A'
    renaming
    ( 0P                 to 0P:
    ; Poly-              to Poly:-
    ; _Poly+_            to _Poly:+_
    ; Poly+Lid           to Poly:+Lid
    ; Poly+Rid           to Poly:+Rid
    ; Poly+Assoc         to Poly:+Assoc
    ; Poly+Inverses      to Poly:+Inverses
    ; Poly+Comm          to Poly:+Comm
    ; _Poly*_            to _Poly:*_
    ; 1P                 to 1P:
    ; 0PRightAnnihilates to 0PRightAnnihilates:
    ; 0PLeftAnnihilates  to 0PLeftAnnihilates:
    ; Poly*Lid           to Poly:*Lid
    ; Poly*Rid           to Poly:*Rid
    ; Poly*Associative   to Poly:*Assoc
    ; Poly*Commutative   to Poly:*Comm
    ; prod-Xn-0P         to prod-Xn-0P:
    )

  open Nth-Poly-structure A' 1

-- Notation P, Q, R... for Poly 1
-- x, y, w... for Poly:
-- a,b,c... for A

-----------------------------------------------------------------------------
-- direct

  trad-base : (v : Vec ℕ 1) → A → Poly:
  trad-base (n :: <>) a = prod-Xn n [ a ]

  trad-base-neutral : (v : Vec ℕ 1) → trad-base v 0r ≡ []
  trad-base-neutral (n :: <>) = cong (prod-Xn n) drop0 ∙ prod-Xn-0P: n

  trad-base-add : (v : Vec ℕ 1) → (a b : A) → (trad-base v a) Poly:+ (trad-base v b) ≡ trad-base v (a + b)
  trad-base-add (n :: <>) a b = prod-Xn-sum n (a ∷ []) (b ∷ [])

  Poly1→Poly: : Poly A' 1 → Poly:
  Poly1→Poly: = Poly-Rec-Set.f A' 1 Poly: isSetPoly:
                 []
                 trad-base
                 (λ x y → x Poly:+ y)
                 Poly:+Assoc
                 Poly:+Rid
                 Poly:+Comm
                 trad-base-neutral
                 trad-base-add

  Poly1→Poly:-gmorph : (P Q : Poly A' 1) → Poly1→Poly: (P Poly+ Q) ≡ (Poly1→Poly: P) Poly:+ (Poly1→Poly: Q)
  Poly1→Poly:-gmorph P Q = refl

-----------------------------------------------------------------------------
-- converse

  Poly:→Poly1-int : (n : ℕ) → Poly: → Poly A' 1
  Poly:→Poly1-int n [] = 0P
  Poly:→Poly1-int n (a ∷ x) = (base (n :: <>) a) Poly+ Poly:→Poly1-int (suc n) x
  Poly:→Poly1-int n (drop0 i) = ((cong (λ X → X Poly+ 0P) (base-0P (n :: <>))) ∙ (Poly+-Rid 0P)) i

  Poly:→Poly1 : Poly: → Poly A' 1
  Poly:→Poly1 x = Poly:→Poly1-int 0 x

  Poly:→Poly1-int-gmorph : (x y : Poly:) → (n : ℕ) → Poly:→Poly1-int n (x Poly:+ y) ≡ (Poly:→Poly1-int n x) Poly+ (Poly:→Poly1-int n y)
  Poly:→Poly1-int-gmorph = ElimProp.f
                        (λ x → (y : Poly:) → (n : ℕ) → Poly:→Poly1-int n (x Poly:+ y) ≡ (Poly:→Poly1-int n x Poly+ Poly:→Poly1-int n y))
                        (λ y n → (cong (Poly:→Poly1-int n) (Poly:+Lid y)) ∙ (sym (Poly+-Lid (Poly:→Poly1-int n y))))
                        (λ a x ind-x → ElimProp.f
                                        (λ y → (n : ℕ) → Poly:→Poly1-int n ((a ∷ x) Poly:+ y) ≡ (Poly:→Poly1-int n (a ∷ x) Poly+ Poly:→Poly1-int n y))
                                        (λ n → sym (Poly+-Rid (Poly:→Poly1-int n (a ∷ x))))
                                        (λ b y ind-y n → sym (
                                                          (Poly-com-adv (base (n :: <>) a) (Poly:→Poly1-int (suc n) x) (base (n :: <>) b) (Poly:→Poly1-int (suc n) y))
                                                          ∙
                                                          (cong₂ _Poly+_ (base-Poly+ (n :: <>) a b) (sym (ind-x y (suc n))))) )
                                        λ {y} p q i n j → trunc
                                                          (Poly:→Poly1-int n ((a ∷ x) Poly:+ y))
                                                          (Poly:→Poly1-int n (a ∷ x) Poly+ Poly:→Poly1-int n y)
                                                          (p n) (q n) i j )
                        λ {x} p q i y n j → trunc (Poly:→Poly1-int n (x Poly:+ y)) (Poly:→Poly1-int n x Poly+ Poly:→Poly1-int n y) (p y n) (q y n) i j

  Poly:→Poly1-gmorph : (x y : Poly:) → Poly:→Poly1 (x Poly:+ y) ≡ (Poly:→Poly1 x) Poly+ (Poly:→Poly1 y)
  Poly:→Poly1-gmorph x y = Poly:→Poly1-int-gmorph x y 0

-----------------------------------------------------------------------------
-- section

  e-sect-int : (x : Poly:) → (n : ℕ) → Poly1→Poly: (Poly:→Poly1-int n x) ≡ prod-Xn n x
  e-sect-int = ElimProp.f
               (λ z → (n : ℕ) → Poly1→Poly: (Poly:→Poly1-int n z) ≡ prod-Xn n z)
               (λ n → sym (prod-Xn-0P: n))
               (λ a x ind-x n → ((prod-Xn n [ a ] ) Poly:+ (Poly1→Poly: (Poly:→Poly1-int (suc n) x)))
                                    ≡⟨ cong (λ X → prod-Xn n [ a ] Poly:+ X) (ind-x (suc n)) ⟩
                                 (prod-Xn n (a ∷ []) Poly:+ ( 0r ∷ prod-Xn n x))
                                    ≡⟨ prod-Xn-∷ n a x ⟩
                                 prod-Xn n (a ∷ x) ∎)
               (λ {x} p q i n j → isSetPoly: (Poly1→Poly: (Poly:→Poly1-int n x)) (prod-Xn n x) (p n) (q n) i j)

  e-sect : (x : Poly:) → Poly1→Poly: (Poly:→Poly1 x) ≡ x
  e-sect x = e-sect-int x 0

-----------------------------------------------------------------------------
-- retraction

  idde : (m n : ℕ) → (a : A) → Poly:→Poly1-int n (prod-Xn m [ a ]) ≡ base ((n +n m) :: <>) a
  idde zero n a = Poly+-Rid (base (n :: <>) a) ∙ cong (λ X → base (X :: <>) a) (sym (+-zero n))
  idde (suc m) n a = cong (λ X → X Poly+ Poly:→Poly1-int (suc n) (prod-Xn m (a ∷ []))) (base-0P (n :: <>))
                     ∙ Poly+-Lid (Poly:→Poly1-int (suc n) (prod-Xn m (a ∷ [])))
                     ∙ idde m (suc n) a
                     ∙ cong (λ X → base (X :: <>) a) (sym (+-suc n m))

  idde-v : (v : Vec ℕ 1) → (a : A) → Poly:→Poly1-int 0 (trad-base v a) ≡ base v a
  idde-v (n :: <>) a = (idde n 0 a)

  e-retr : (P : Poly A' 1) → Poly:→Poly1 (Poly1→Poly: P) ≡ P
  e-retr = Poly-Ind-Prop.f A' 1
           (λ P → Poly:→Poly1 (Poly1→Poly: P) ≡ P)
           (λ _ → trunc _ _)
           refl
           (λ v a → idde-v v a)
           λ {P Q} ind-P ind-Q → cong Poly:→Poly1 (Poly1→Poly:-gmorph P Q)
                                 ∙
                                 Poly:→Poly1-gmorph (Poly1→Poly: P) (Poly1→Poly: Q)
                                 ∙
                                 cong₂ _Poly+_ ind-P ind-Q

-----------------------------------------------------------------------------
-- Ring morphism

  map-1P : Poly1→Poly: 1P ≡ 1P:
  map-1P = refl

  trad-base-prod : (v v' : Vec ℕ 1) → (a a' : A) → trad-base (v +n-vec v') (a · a') ≡
                                                      (trad-base v a Poly:* trad-base v' a')
  trad-base-prod (k :: <>) (l :: <>) a a' = sym ((prod-Xn-prod k l  [ a ]  [ a' ]) ∙ cong (λ X → prod-Xn (k +n l) [ X ]) (+Rid (a · a')))

  Poly1→Poly:-rmorph : (P Q : Poly A' 1) → Poly1→Poly: (P Poly* Q) ≡ (Poly1→Poly: P) Poly:* (Poly1→Poly: Q)
  Poly1→Poly:-rmorph = Poly-Ind-Prop.f A' 1
                        (λ P → (Q : Poly A' 1) → Poly1→Poly: (P Poly* Q) ≡ (Poly1→Poly: P Poly:* Poly1→Poly: Q))
                        (λ P p q i Q j → isSetPoly: (Poly1→Poly: (P Poly* Q)) (Poly1→Poly: P Poly:* Poly1→Poly: Q) (p Q) (q Q) i j)
                        (λ Q → refl)
                        (λ v a → Poly-Ind-Prop.f A' 1
                                  (λ P → Poly1→Poly: (base v a Poly* P) ≡ (Poly1→Poly: (base v a) Poly:* Poly1→Poly: P))
                                  (λ _ → isSetPoly: _ _)
                                  (sym (0PLeftAnnihilates: (trad-base v a)))
                                  (λ v' a' → trad-base-prod v v' a a')
                                  λ {U V} ind-U ind-V → (cong₂ _Poly:+_ ind-U ind-V)
                                                         ∙ sym (Poly*LDistrPoly+ (Poly1→Poly: (base v a)) (Poly1→Poly: U) (Poly1→Poly: V)))
                        λ {U V} ind-U ind-V Q → (cong₂ _Poly:+_ (ind-U Q) (ind-V Q))
                                                 ∙ sym (Poly*RDistrPoly+ (Poly1→Poly: U) (Poly1→Poly: V) (Poly1→Poly: Q))

-- -----------------------------------------------------------------------------
-- -- Ring Equivalences

module _ (A' : CommRing ℓ) where

  open Equiv-Poly1-Poly: A'

  CRE-Poly1-Poly: : CommRingEquiv (PolyCommRing A' 1) (UnivariatePoly A')
  fst CRE-Poly1-Poly: = isoToEquiv is
    where
    is : Iso _ _
    Iso.fun is = Poly1→Poly:
    Iso.inv is = Poly:→Poly1
    Iso.rightInv is = e-sect
    Iso.leftInv is = e-retr
  snd CRE-Poly1-Poly: = makeIsRingHom map-1P Poly1→Poly:-gmorph Poly1→Poly:-rmorph