{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.ZCohomology.CohomologyRings.Unit where

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

open import Cubical.Data.Nat renaming (_+_ to _+n_ ; _·_ to _·n_)
open import Cubical.Data.Int
open import Cubical.Data.Vec
open import Cubical.Data.FinData

open import Cubical.Algebra.Group
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.Group.Instances.Int renaming (ℤGroup to ℤG)
open import Cubical.Algebra.DirectSum.DirectSumHIT.Base

open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.Instances.Int renaming (ℤCommRing to ℤCR)
open import Cubical.Algebra.CommRing.FGIdeal
open import Cubical.Algebra.CommRing.QuotientRing
open import Cubical.Algebra.CommRing.Instances.Polynomials.MultivariatePoly
open import Cubical.Algebra.CommRing.Instances.Polynomials.MultivariatePoly-Quotient
open import Cubical.Algebra.CommRing.Instances.Polynomials.MultivariatePoly-notationZ
open import Cubical.Algebra.Polynomials.Multivariate.EquivCarac.A[X]X-A

open import Cubical.HITs.Truncation
open import Cubical.HITs.SetQuotients as SQ renaming (_/_ to _/sq_)
open import Cubical.HITs.PropositionalTruncation as PT

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.GroupStructure
open import Cubical.ZCohomology.RingStructure.CupProduct
open import Cubical.ZCohomology.RingStructure.CohomologyRing
open import Cubical.ZCohomology.Groups.Unit

open Iso

module Equiv-Unit-Properties where

  open CommRingStr (snd ℤCR) using ()
    renaming
    ( 0r        to 0ℤ
    ; 1r        to 1ℤ
    ; _+_       to _+ℤ_
    ; -_        to -ℤ_
    ; _·_       to _·ℤ_
    ; +Assoc    to +ℤAssoc
    ; +IdL      to +ℤIdL
    ; +IdR      to +ℤIdR
    ; +Comm     to +ℤComm
    ; ·Assoc    to ·ℤAssoc
    ; ·IdL      to ·ℤIdL
    ; ·IdR      to ·ℤIdR
    ; ·DistR+   to ·ℤDistR+
    ; is-set    to isSetℤ     )

  open RingStr (snd (H*R Unit)) using ()
    renaming
    ( 0r        to 0H*
    ; 1r        to 1H*
    ; _+_       to _+H*_
    ; -_        to -H*_
    ; _·_       to _cup_
    ; +Assoc    to +H*Assoc
    ; +IdL      to +H*IdL
    ; +IdR      to +H*IdR
    ; +Comm     to +H*Comm
    ; ·Assoc    to ·H*Assoc
    ; ·IdL      to ·H*IdL
    ; ·IdR      to ·H*IdR
    ; ·DistR+   to ·H*DistR+
    ; is-set    to isSetH*     )

  open CommRingStr (snd ℤ[X]) using ()
    renaming
    ( 0r        to 0Pℤ
    ; 1r        to 1Pℤ
    ; _+_       to _+Pℤ_
    ; -_        to -Pℤ_
    ; _·_       to _·Pℤ_
    ; +Assoc    to +PℤAssoc
    ; +IdL      to +PℤIdL
    ; +IdR      to +PℤIdR
    ; +Comm     to +PℤComm
    ; ·Assoc    to ·PℤAssoc
    ; ·IdL      to ·PℤIdL
    ; ·IdR      to ·PℤIdR
    ; ·DistR+   to ·PℤDistR+
    ; is-set    to isSetPℤ     )

  open CommRingStr (snd ℤ[X]/X) using ()
    renaming
    ( 0r        to 0PℤI
    ; 1r        to 1PℤI
    ; _+_       to _+PℤI_
    ; -_        to -PℤI_
    ; _·_       to _·PℤI_
    ; +Assoc    to +PℤIAssoc
    ; +IdL      to +PℤIIdL
    ; +IdR      to +PℤIIdR
    ; +Comm     to +PℤIComm
    ; ·Assoc    to ·PℤIAssoc
    ; ·IdL      to ·PℤIIdL
    ; ·IdR      to ·PℤIIdR
    ; ·DistR+   to ·PℤIDistR+
    ; is-set    to isSetPℤI     )

-----------------------------------------------------------------------------
-- Direct Sens on ℤ[x]

  ℤ[x]→H*-Unit : ℤ[x] → H* Unit
  ℤ[x]→H*-Unit = DS-Rec-Set.f _ _ _ _ isSetH*
                  0H*
                  base-trad
                  _+H*_
                  +H*Assoc
                  +H*IdR
                  +H*Comm
                  base-neutral-eq
                  base-add-eq
               where
               base-trad : _
               base-trad (zero ∷ []) a = base zero (inv (fst H⁰-Unit≅ℤ) a)
               base-trad (suc n ∷ []) a = 0H*

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

               base-add-eq : _
               base-add-eq (zero ∷ []) a b = base-add _ _ _
               base-add-eq (suc n ∷ []) a b = +H*IdR _

  ℤ[x]→H*-Unit-pres1Pℤ : ℤ[x]→H*-Unit (1Pℤ) ≡ 1H*
  ℤ[x]→H*-Unit-pres1Pℤ = refl

  ℤ[x]→H*-Unit-pres+ : (x y : ℤ[x]) → ℤ[x]→H*-Unit (x +Pℤ y) ≡ ℤ[x]→H*-Unit x +H* ℤ[x]→H*-Unit y
  ℤ[x]→H*-Unit-pres+ x y = refl

-- -- Proving the morphism on the cup product

  T0 : (z : ℤ) → coHom 0 Unit
  T0 = λ z → inv (fst H⁰-Unit≅ℤ) z

  T0g : IsGroupHom (ℤG .snd) (fst (invGroupIso H⁰-Unit≅ℤ) .fun) (coHomGr 0 Unit .snd)
  T0g = snd (invGroupIso H⁰-Unit≅ℤ)

    -- idea : control of the unfolding + simplification of T0 on the left
  pres·-base-case-00 : (a : ℤ) → (b : ℤ) →
                        T0 (a ·ℤ b) ≡ (T0 a) ⌣ (T0 b)
  pres·-base-case-00 (pos zero)       b = (IsGroupHom.pres1 T0g)
  pres·-base-case-00 (pos (suc n))    b = ((IsGroupHom.pres· T0g b (pos n ·ℤ b)))
                                          ∙ (cong (λ X → (T0 b) +ₕ X) (pres·-base-case-00 (pos n) b))
  pres·-base-case-00 (negsuc zero)    b = IsGroupHom.presinv T0g b
  pres·-base-case-00 (negsuc (suc n)) b = cong T0 (+ℤComm (-ℤ b) (negsuc n ·ℤ b)) -- ·ℤ and ·₀ are defined asymetrically !
                                          ∙ IsGroupHom.pres· T0g (negsuc n ·ℤ b) (-ℤ b)
                                          ∙ cong₂ _+ₕ_ (pres·-base-case-00 (negsuc n) b)
                                                         (IsGroupHom.presinv T0g b)

  pres·-base-case-int : (n : ℕ) → (a : ℤ) → (m : ℕ) → (b : ℤ) →
                ℤ[x]→H*-Unit (base (n ∷ []) a ·Pℤ base (m ∷ []) b)
              ≡ ℤ[x]→H*-Unit (base (n ∷ []) a) cup ℤ[x]→H*-Unit (base (m ∷ []) b)
  pres·-base-case-int zero    a zero    b = cong (base 0) (pres·-base-case-00 a b)
  pres·-base-case-int zero    a (suc m) b = refl
  pres·-base-case-int (suc n) a m       b = refl

  pres·-base-case-vec : (v : Vec ℕ 1) → (a : ℤ) → (v' : Vec ℕ 1) → (b : ℤ) →
                ℤ[x]→H*-Unit (base v a ·Pℤ base v' b)
              ≡ ℤ[x]→H*-Unit (base v a) cup ℤ[x]→H*-Unit (base v' b)
  pres·-base-case-vec (n ∷ []) a (m ∷ []) b = pres·-base-case-int n a m b

  ℤ[x]→H*-Unit-pres· : (x y : ℤ[x]) → ℤ[x]→H*-Unit (x ·Pℤ y) ≡ ℤ[x]→H*-Unit x cup ℤ[x]→H*-Unit y
  ℤ[x]→H*-Unit-pres· = DS-Ind-Prop.f _ _ _ _
                         (λ x p q i y j → isSetH* _ _ (p y) (q y) i j)
                         (λ y → refl)
                         base-case
                         λ {U V} ind-U ind-V y → cong₂ _+H*_ (ind-U y) (ind-V y)
    where
    base-case : _
    base-case (n ∷ []) a = DS-Ind-Prop.f _ _ _ _ (λ _ → isSetH* _ _)
                           (sym (RingTheory.0RightAnnihilates (H*R Unit) _))
                           (λ v' b → pres·-base-case-vec (n ∷ []) a v' b)
                           λ {U V} ind-U ind-V → (cong₂ _+H*_ ind-U ind-V) ∙ sym (·H*DistR+ _ _ _)

    -- raising to the product
  ℤ[x]→H*-Unit-cancelX : (k : Fin 1) → ℤ[x]→H*-Unit (<X> k) ≡ 0H*
  ℤ[x]→H*-Unit-cancelX zero = refl

  ℤ[X]→H*-Unit : RingHom (CommRing→Ring ℤ[X]) (H*R Unit)
  fst ℤ[X]→H*-Unit = ℤ[x]→H*-Unit
  snd ℤ[X]→H*-Unit = makeIsRingHom ℤ[x]→H*-Unit-pres1Pℤ ℤ[x]→H*-Unit-pres+ ℤ[x]→H*-Unit-pres·

  ℤ[X]/X→H*R-Unit : RingHom (CommRing→Ring ℤ[X]/X) (H*R Unit)
  ℤ[X]/X→H*R-Unit = Quotient-FGideal-CommRing-Ring.inducedHom ℤ[X] (H*R Unit) ℤ[X]→H*-Unit <X> ℤ[x]→H*-Unit-cancelX

  ℤ[x]/x→H*-Unit : ℤ[x]/x → H* Unit
  ℤ[x]/x→H*-Unit = fst ℤ[X]/X→H*R-Unit

-----------------------------------------------------------------------------
-- Converse Sens on ℤ[X]

  H*-Unit→ℤ[x] : H* Unit → ℤ[x]
  H*-Unit→ℤ[x] = DS-Rec-Set.f _ _ _ _ isSetPℤ
                  0Pℤ
                  base-trad
                  _+Pℤ_
                  +PℤAssoc
                  +PℤIdR
                  +PℤComm
                  base-neutral-eq
                  base-add-eq
               where
               base-trad : (n : ℕ) → coHom n Unit → ℤ[x]
               base-trad zero a = base (0 ∷ []) (fun (fst H⁰-Unit≅ℤ) a)
               base-trad (suc n) a = 0Pℤ

               base-neutral-eq : _
               base-neutral-eq zero = base-neutral _
               base-neutral-eq (suc n) = refl

               base-add-eq : _
               base-add-eq zero a b = base-add _ _ _
                                      ∙ cong (base (0 ∷ [])) (sym (IsGroupHom.pres· (snd H⁰-Unit≅ℤ) a b))
               base-add-eq (suc n) a b = +PℤIdR _

  H*-Unit→ℤ[x]-pres+ : (x y : H* Unit) → H*-Unit→ℤ[x] ( x +H* y) ≡ H*-Unit→ℤ[x] x +Pℤ H*-Unit→ℤ[x] y
  H*-Unit→ℤ[x]-pres+ x y = refl

  H*-Unit→ℤ[x]/x : H* Unit → ℤ[x]/x
  H*-Unit→ℤ[x]/x = [_] ∘ H*-Unit→ℤ[x]

  H*-Unit→ℤ[x]/x-pres+ : (x y : H* Unit) → H*-Unit→ℤ[x]/x (x +H* y) ≡ (H*-Unit→ℤ[x]/x x) +PℤI (H*-Unit→ℤ[x]/x y)
  H*-Unit→ℤ[x]/x-pres+ x y = cong [_] (H*-Unit→ℤ[x]-pres+ x y)

-----------------------------------------------------------------------------
-- Section

  e-sect : (x : H* Unit) → ℤ[x]/x→H*-Unit (H*-Unit→ℤ[x]/x x) ≡ x
  e-sect = DS-Ind-Prop.f _ _ _ _ (λ _ → isSetH* _ _)
           refl
           base-case
           λ {U V} ind-U ind-V → cong ℤ[x]/x→H*-Unit (H*-Unit→ℤ[x]/x-pres+ U V)
                                  ∙ IsRingHom.pres+ (snd ℤ[X]/X→H*R-Unit) (H*-Unit→ℤ[x]/x U) (H*-Unit→ℤ[x]/x V)
                                  ∙ cong₂ _+H*_ ind-U ind-V
           where
           base-case : _
           base-case zero a = cong (base 0) (leftInv (fst H⁰-Unit≅ℤ) a)
           base-case (suc n) a = (sym (base-neutral (suc n)))
                                 ∙ (cong (base (suc n)) ((isContr→isProp (isContrHⁿ-Unit n) _ a)))

-----------------------------------------------------------------------------
-- Retraction

  e-retr : (x : ℤ[x]/x) → H*-Unit→ℤ[x]/x (ℤ[x]/x→H*-Unit x) ≡ x
  e-retr = SQ.elimProp (λ _ → isSetPℤI _ _)
           (DS-Ind-Prop.f _ _ _ _ (λ _ → isSetPℤI _ _)
           refl
           base-case
           λ {U V} ind-U ind-V → cong₂ _+PℤI_ ind-U ind-V)
           where
           base-case : _
           base-case (zero ∷ []) a = refl
           base-case (suc n ∷ []) a = eq/ 0Pℤ (base (suc n ∷ []) a) ∣ ((λ x → base (n ∷ []) (-ℤ a)) , foo) ∣₁
             where
             foo : (0Pℤ +Pℤ base (suc n ∷ []) (- a)) ≡ (base (n +n 1 ∷ []) (- a · pos 1) +Pℤ 0Pℤ)
             foo = (0Pℤ +Pℤ base (suc n ∷ []) (- a)) ≡⟨ +PℤIdL _ ⟩
                   base (suc n ∷ []) (- a) ≡⟨ cong₂ base (cong (λ X → X ∷ []) (sym ((+-suc n 0)
                                              ∙ (cong suc (+-zero n))))) (sym (·ℤIdR _)) ⟩
                   base (n +n suc 0 ∷ []) (- a ·ℤ 1ℤ) ≡⟨ refl ⟩
                   base (n +n 1 ∷ []) (- a · pos 1) ≡⟨ sym (+PℤIdR _) ⟩
                   (base (n +n 1 ∷ []) (- a · pos 1) +Pℤ 0Pℤ) ∎

-----------------------------------------------------------------------------
-- Computation of the Cohomology Ring

module _ where

  open Equiv-Unit-Properties
  open RingEquivs

  Unit-CohomologyRingP : RingEquiv (CommRing→Ring ℤ[X]/X) (H*R Unit)
  fst Unit-CohomologyRingP = isoToEquiv is
    where
    is : Iso ℤ[x]/x (H* Unit)
    fun is = ℤ[x]/x→H*-Unit
    inv is = H*-Unit→ℤ[x]/x
    rightInv is = e-sect
    leftInv is = e-retr
  snd Unit-CohomologyRingP = snd ℤ[X]/X→H*R-Unit

  CohomologyRing-UnitP : RingEquiv (H*R Unit) (CommRing→Ring ℤ[X]/X)
  CohomologyRing-UnitP = invRingEquiv Unit-CohomologyRingP

  Unit-CohomologyRingℤ : RingEquiv (CommRing→Ring ℤCR) (H*R Unit)
  Unit-CohomologyRingℤ = compRingEquiv (invRingEquiv Equiv-ℤ[X]/X-ℤ) Unit-CohomologyRingP

  CohomologyRing-Unitℤ : RingEquiv (H*R Unit) (CommRing→Ring ℤCR)
  CohomologyRing-Unitℤ = compRingEquiv CohomologyRing-UnitP Equiv-ℤ[X]/X-ℤ


------------------------------------------------------------------------
-- The Agda standard library
--
-- Maps from keys to values, based on AVL trees
-- This modules provides a simpler map interface, without a dependency
-- between the key and value types.
------------------------------------------------------------------------

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

open import Relation.Binary using (StrictTotalOrder)

module Data.AVL.Map
  {a ℓ₁ ℓ₂} (strictTotalOrder : StrictTotalOrder a ℓ₁ ℓ₂)
  where

open import Data.Bool.Base using (Bool)
open import Data.List.Base using (List)
open import Data.Maybe.Base using (Maybe)
open import Data.Product using (_×_)
open import Level using (_⊔_)

import Data.AVL strictTotalOrder as AVL
open StrictTotalOrder strictTotalOrder renaming (Carrier to Key)

------------------------------------------------------------------------
-- The map type

Map : ∀ {v} → (V : Set v) → Set (a ⊔ v ⊔ ℓ₂)
Map v = AVL.Tree (AVL.const v)

------------------------------------------------------------------------
-- Repackaged functions

module _ {v} {V : Set v} where

  empty : Map V
  empty = AVL.empty

  singleton : Key → V → Map V
  singleton = AVL.singleton

  insert : Key → V → Map V → Map V
  insert = AVL.insert

  insertWith : Key → (Maybe V → V) → Map V → Map V
  insertWith = AVL.insertWith

  delete : Key → Map V → Map V
  delete = AVL.delete

  lookup : Key → Map V → Maybe V
  lookup = AVL.lookup

module _ {v w} {V : Set v} {W : Set w} where

  map : (V → W) → Map V → Map W
  map f = AVL.map f

module _ {v} {V : Set v} where

  infix 4 _∈?_

  _∈?_ : Key → Map V → Bool
  _∈?_ = AVL._∈?_

  headTail : Map V → Maybe ((Key × V) × Map V)
  headTail = AVL.headTail

  initLast : Map V → Maybe (Map V × (Key × V))
  initLast = AVL.initLast

  fromList : List (Key × V) → Map V
  fromList = AVL.fromList

  toList : Map V → List (Key × V)
  toList = AVL.toList

module _ {v w} {V : Set v} {W : Set w} where

  unionWith : (V → Maybe W → W) →
              Map V → Map W → Map W
  unionWith f = AVL.unionWith f

module _ {v} {V : Set v} where

  union : Map V → Map V → Map V
  union = AVL.union

  unionsWith : (V → Maybe V → V) → List (Map V) → Map V
  unionsWith f = AVL.unionsWith f

  unions : List (Map V) → Map V
  unions = AVL.unions


{-# OPTIONS --without-K --termination-depth=2 #-}

open import HoTT
open import cw.CW

module cw.Sphere where

CWSphere-skel : ∀ n → Skeleton {lzero} n

CWSphere : ℕ → Type₀
CWSphere n = ⟦ CWSphere-skel n ⟧

Sphere-to-CWSphere : (n : ℕ) → Sphere n → CWSphere n

CWSphere-skel O = Bool
CWSphere-skel (S n) =
  (CWSphere-skel n , Bool , cst (Sphere-to-CWSphere n))

{-
  mapping:

  hub true <-> north
  hub false <-> south
  incl _ -> north
  spoke true x -> idp
  spoke fales x -> merid x
  ! spoke true x ∙ spoke false x  <- merid x
-}

private
  module PosToCW n = SuspensionRec
    {C = CWSphere (S n)}
    (hub true) (hub false)
    (λ x → (! (spoke true x)) ∙' spoke false x)

Sphere-to-CWSphere O = idf _
Sphere-to-CWSphere (S n) = PosToCW.f n

{-
  Now proving the equivalence
-}

private
  CWSphere-to-Sphere-incl : ∀ n → CWSphere n → Sphere (S n)
  CWSphere-to-Sphere-incl _ _ = north

  CWSphere-to-Sphere-hub : ∀ n → Bool → Sphere (S n)
  CWSphere-to-Sphere-hub _ true = north
  CWSphere-to-Sphere-hub _ false = south

  CWSphere-to-Sphere-spoke : ∀ n (b : Bool) (x : Sphere n)
    → CWSphere-to-Sphere-incl n (Sphere-to-CWSphere n x)
    == CWSphere-to-Sphere-hub n b
  CWSphere-to-Sphere-spoke _ true _ = idp
  CWSphere-to-Sphere-spoke _ false x = merid x

  module PosFromCW n = AttachedRec
    {attaching = cst (Sphere-to-CWSphere n)}
    (CWSphere-to-Sphere-incl n)
    (CWSphere-to-Sphere-hub n)
    (CWSphere-to-Sphere-spoke n)

CWSphere-to-Sphere : ∀ n → CWSphere n → Sphere n
CWSphere-to-Sphere O = idf _
CWSphere-to-Sphere (S n) = PosFromCW.f n

private
  from-to : ∀ n x → CWSphere-to-Sphere n (Sphere-to-CWSphere n x) == x
from-to O _ = idp
from-to (S n) = SuspensionElim.f idp idp path
  where
    to = Sphere-to-CWSphere (S n)
    from = CWSphere-to-Sphere (S n)
    module To = PosToCW n
    module From = PosFromCW n

    path : ∀ x → idp == idp [ (λ x → from (to x) == x) ↓ merid x ]
    path x = ↓-app=idf-in $ ! $
      ap (from ∘ to) (merid x) ∙ idp
        =⟨ ∙-unit-r $ ap (from ∘ to) (merid x) ⟩
      ap (from ∘ to) (merid x)
        =⟨ ap-∘ from to (merid x) ⟩
      ap from (ap to (merid x))
        =⟨ To.merid-β x |in-ctx ap from ⟩
      ap from (! (spoke true x) ∙' spoke false x)
        =⟨ ap-∙' from (! (spoke true x)) (spoke false x) ⟩
      ap from (! (spoke true x)) ∙' ap from (spoke false x)
        =⟨ ap-! from (spoke true x) |in-ctx (λ p → p ∙' ap from (spoke false x)) ⟩
      ! (ap from (spoke true x)) ∙' ap from (spoke false x)
        =⟨ From.spoke-β true x |in-ctx (λ p → ! p ∙' ap from (spoke false x)) ⟩
      idp ∙' ap from (spoke false x)
        =⟨ From.spoke-β false x |in-ctx (idp ∙'_) ⟩
      idp ∙' merid x
        ∎

Sphere-to-CWSphere-is-equiv : ∀ n → is-equiv (Sphere-to-CWSphere n)
private
  to-from : ∀ n x → Sphere-to-CWSphere n (CWSphere-to-Sphere n x) == x
Sphere-to-CWSphere-is-equiv n = is-eq _ (CWSphere-to-Sphere n) (to-from n) (from-to n)

to-from O _ = idp
to-from (S n) = AttachedElim.f to-from-incl to-from-hub to-from-spoke
  where
    to = Sphere-to-CWSphere (S n)
    from = CWSphere-to-Sphere (S n)
    module To = PosToCW n
    module From = PosFromCW n

    to-from-incl : ∀ (c : CWSphere n)
      → to (from (incl c)) == incl c
    to-from-incl c =
        ! (spoke true (CWSphere-to-Sphere n c))
      ∙ ap incl (is-equiv.f-g (Sphere-to-CWSphere-is-equiv n) c)

    to-from-hub : ∀ b → to (from (hub b)) == hub b
    to-from-hub true = idp
    to-from-hub false = idp

    to-from-incl-to : ∀ (x : Sphere n)
      → to-from-incl (Sphere-to-CWSphere n x) == ! (spoke true x)
    to-from-incl-to x =
      ! (spoke true (CWSphere-to-Sphere n (Sphere-to-CWSphere n x)))
      ∙ ap incl (is-equiv.f-g (Sphere-to-CWSphere-is-equiv n) (Sphere-to-CWSphere n x))
        =⟨ ! $ is-equiv.adj (Sphere-to-CWSphere-is-equiv n) x
          |in-ctx (λ p → ! (spoke true (CWSphere-to-Sphere n (Sphere-to-CWSphere n x))) ∙ ap incl p) ⟩
      ! (spoke true (CWSphere-to-Sphere n (Sphere-to-CWSphere n x)))
      ∙ ap incl (ap (Sphere-to-CWSphere n) (is-equiv.g-f (Sphere-to-CWSphere-is-equiv n) x))
        =⟨ ! $ ap-∘ incl (Sphere-to-CWSphere n) (is-equiv.g-f (Sphere-to-CWSphere-is-equiv n) x)
          |in-ctx (λ p → ! (spoke true (CWSphere-to-Sphere n (Sphere-to-CWSphere n x))) ∙ p) ⟩
      ! (spoke true (CWSphere-to-Sphere n (Sphere-to-CWSphere n x)))
      ∙ ap (incl ∘ Sphere-to-CWSphere n) (is-equiv.g-f (Sphere-to-CWSphere-is-equiv n) x)
          =⟨ htpy-natural-cst=app (λ x → ! (spoke true x)) (is-equiv.g-f (Sphere-to-CWSphere-is-equiv n) x) ⟩
      ! (spoke true x)
          ∎

    to-from-spoke : ∀ (b : Bool) (x : Sphere n)
      → to-from-incl (Sphere-to-CWSphere n x) == to-from-hub b
          [ (λ x → to (from x) == x) ↓ spoke b x ]
    to-from-spoke true x = ↓-app=idf-in $
      to-from-incl (Sphere-to-CWSphere n x) ∙' spoke true x
        =⟨ to-from-incl-to x |in-ctx (λ p → p ∙' spoke true x) ⟩
      ! (spoke true x) ∙' spoke true x
        =⟨ !-inv'-l (spoke true x) ⟩
      idp
        =⟨ ! $ From.spoke-β true x |in-ctx (λ p → ap to p ∙ idp) ⟩
      ap to (ap from (spoke true x)) ∙ idp
        =⟨ ∘-ap to from (spoke true x) |in-ctx (λ p → p ∙ idp) ⟩
      ap (to ∘ from) (spoke true x) ∙ idp
        ∎
    to-from-spoke false x = ↓-app=idf-in $
      to-from-incl (Sphere-to-CWSphere n x) ∙' spoke false x
        =⟨ to-from-incl-to x |in-ctx (λ p → p ∙' spoke false x) ⟩
      ! (spoke true x) ∙' spoke false x
        =⟨ ! $ To.merid-β x ⟩
      ap to (merid x)
        =⟨ ! $ From.spoke-β false x |in-ctx (ap to) ⟩
      ap to (ap from (spoke false x))
        =⟨ ∘-ap to from (spoke false x) ⟩
      ap (to ∘ from) (spoke false x)
        =⟨ ! $ ∙-unit-r _ ⟩
      ap (to ∘ from) (spoke false x) ∙ idp
        ∎

Sphere-equiv-CWSphere : ∀ n → Sphere n ≃ CWSphere n
Sphere-equiv-CWSphere n = _ , Sphere-to-CWSphere-is-equiv n

CWSphere-has-dec-cells : ∀ n → has-dec-cells (CWSphere-skel n)
CWSphere-has-dec-cells 0 = Bool-has-dec-eq
CWSphere-has-dec-cells (S n) = CWSphere-has-dec-cells n , Bool-has-dec-eq

CWSphere-is-aligned : ∀ n → is-aligned (CWSphere-skel n)
CWSphere-is-aligned 0 = lift tt
CWSphere-is-aligned 1 = lift tt
CWSphere-is-aligned 2 = lift tt , (λ _ → true , spoke true true)
CWSphere-is-aligned (S (S (S n))) =
  CWSphere-is-aligned (S (S n)) , (λ _ → hub true , spoke true north)


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use the
-- Relation.Binary.Reasoning.Setoid module directly.
------------------------------------------------------------------------

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

open import Relation.Binary

module Relation.Binary.EqReasoning {s₁ s₂} (S : Setoid s₁ s₂) where

open import Relation.Binary.Reasoning.Setoid S public


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

open import Fragment.Algebra.Signature

module Fragment.Algebra.Free (Σ : Signature) where

open import Fragment.Algebra.Free.Base Σ public
open import Fragment.Algebra.Free.Properties Σ public
open import Fragment.Algebra.Free.Monad Σ public
open import Fragment.Algebra.Free.Evaluation Σ public


------------------------------------------------------------------------------
-- The FOTC co-inductive natural numbers type
------------------------------------------------------------------------------

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

-- N.B. This module is re-exported by FOTC.Data.Conat.

-- Adapted from (Sander 1992).

module FOTC.Data.Conat.Type where

open import FOTC.Base

------------------------------------------------------------------------------
-- The FOTC co-inductive natural numbers type (co-inductive predicate
-- for total co-inductive natural)

-- Functional for the NatF predicate.
-- NatF : (D → Set) → D → Set
-- NatF A n = n = zero ∨ (∃[ n' ] n = succ n' ∧ A n')

-- Conat is the greatest fixed-point of NatF (by Conat-out and
-- Conat-coind).

postulate Conat : D → Set

-- Conat is a post-fixed point of NatF, i.e.
--
-- Conat ≤ NatF Conat.
postulate
  Conat-out : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
{-# ATP axiom Conat-out #-}

-- Conat is the greatest post-fixed point of NatF, i.e.
--
-- ∀ A. A ≤ NatF A ⇒ A ≤ Conat.
--
-- N.B. This is an axiom schema. Because in the automatic proofs we
-- *must* use an instance, we do not add this postulate as an ATP
-- axiom.
postulate
  Conat-coind :
    (A : D → Set) →
    -- A is post-fixed point of NatF.
    (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
    -- Conat is greater than A.
    ∀ {n} → A n → Conat n

------------------------------------------------------------------------------
-- References
--
-- Sander, Herbert P. (1992). A Logic of Functional Programs with an
-- Application to Concurrency. PhD thesis. Department of Computer
-- Sciences: Chalmers University of Technology and University of
-- Gothenburg.


{-

This file contains:

- Eliminator for propositional truncation

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.PropositionalTruncation.Properties where

open import Cubical.Core.Everything

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

open import Cubical.Data.Sigma

open import Cubical.HITs.PropositionalTruncation.Base

private
  variable
    ℓ : Level
    A B C : Type ℓ

∥∥-isPropDep : (P : A → Type ℓ) → isOfHLevelDep 1 (λ x → ∥ P x ∥)
∥∥-isPropDep P = isOfHLevel→isOfHLevelDep 1 (λ _ → squash)

rec : {P : Type ℓ} → isProp P → (A → P) → ∥ A ∥ → P
rec Pprop f ∣ x ∣ = f x
rec Pprop f (squash x y i) = Pprop (rec Pprop f x) (rec Pprop f y) i

rec2 : {P : Type ℓ} → isProp P → (A → B → P) → ∥ A ∥ → ∥ B ∥ → P
rec2 Pprop f ∣ x ∣ ∣ y ∣ = f x y
rec2 Pprop f ∣ x ∣ (squash y z i) = Pprop (rec2 Pprop f ∣ x ∣ y) (rec2 Pprop f ∣ x ∣ z) i
rec2 Pprop f (squash x y i) z = Pprop (rec2 Pprop f x z) (rec2 Pprop f y z) i

-- Old version
-- rec2 : ∀ {P : Type ℓ} → isProp P → (A → A → P) → ∥ A ∥ → ∥ A ∥ → P
-- rec2 Pprop f = rec (isProp→ Pprop) (λ a → rec Pprop (f a))

elim : {P : ∥ A ∥ → Type ℓ} → ((a : ∥ A ∥) → isProp (P a))
     → ((x : A) → P ∣ x ∣) → (a : ∥ A ∥) → P a
elim Pprop f ∣ x ∣ = f x
elim Pprop f (squash x y i) =
  isOfHLevel→isOfHLevelDep 1 Pprop
    (elim Pprop f x) (elim Pprop f y) (squash x y) i

elim2 : {P : ∥ A ∥ → ∥ A ∥ → Type ℓ}
        (Bset : ((x y : ∥ A ∥) → isProp (P x y)))
        (f : (a b : A) → P ∣ a ∣ ∣ b ∣)
        (x y : ∥ A ∥) → P x y
elim2 Pprop f = elim (λ _ → isPropΠ (λ _ → Pprop _ _))
                     (λ a → elim (λ _ → Pprop _ _) (f a))

elim3 : {P : ∥ A ∥ → ∥ A ∥ → ∥ A ∥ → Type ℓ}
        (Bset : ((x y z : ∥ A ∥) → isProp (P x y z)))
        (g : (a b c : A) → P (∣ a ∣) ∣ b ∣ ∣ c ∣)
        (x y z : ∥ A ∥) → P x y z
elim3 Pprop g = elim2 (λ _ _ → isPropΠ (λ _ → Pprop _ _ _))
                      (λ a b → elim (λ _ → Pprop _ _ _) (g a b))

propTruncIsProp : isProp ∥ A ∥
propTruncIsProp x y = squash x y

propTruncIdempotent≃ : isProp A → ∥ A ∥ ≃ A
propTruncIdempotent≃ {A = A} hA = isoToEquiv f
  where
  f : Iso ∥ A ∥ A
  Iso.fun f        = rec hA (idfun A)
  Iso.inv f x      = ∣ x ∣
  Iso.rightInv f _ = refl
  Iso.leftInv f    = elim (λ _ → isProp→isSet propTruncIsProp _ _) (λ _ → refl)

propTruncIdempotent : isProp A → ∥ A ∥ ≡ A
propTruncIdempotent hA = ua (propTruncIdempotent≃ hA)

-- We could also define the eliminator using the recursor
elim' : {P : ∥ A ∥ → Type ℓ} → ((a : ∥ A ∥) → isProp (P a)) →
        ((x : A) → P ∣ x ∣) → (a : ∥ A ∥) → P a
elim' {P = P} Pprop f a =
  rec (Pprop a) (λ x → transp (λ i → P (squash ∣ x ∣ a i)) i0 (f x)) a

map : (A → B) → (∥ A ∥ → ∥ B ∥)
map f = rec squash (∣_∣ ∘ f)

map2 : (A → B → C) → (∥ A ∥ → ∥ B ∥ → ∥ C ∥)
map2 f = rec (isPropΠ λ _ → squash) (map ∘ f)

-- The propositional truncation can be eliminated into non-propositional
-- types as long as the function used in the eliminator is 'coherently
-- constant.' The details of this can be found in the following paper:
--
--   https://arxiv.org/pdf/1411.2682.pdf
module SetElim (Bset : isSet B) where
  Bset' : isSet' B
  Bset' = isSet→isSet' Bset

  rec→Set : (f : A → B) (kf : 2-Constant f) → ∥ A ∥ → B
  helper  : (f : A → B) (kf : 2-Constant f) → (t u : ∥ A ∥)
          → rec→Set f kf t ≡ rec→Set f kf u

  rec→Set f kf ∣ x ∣ = f x
  rec→Set f kf (squash t u i) = helper f kf t u i

  helper f kf ∣ x ∣ ∣ y ∣ = kf x y
  helper f kf (squash t u i) v
    = Bset' (helper f kf t v) (helper f kf u v) (helper f kf t u) refl i
  helper f kf t (squash u v i)
    = Bset' (helper f kf t u) (helper f kf t v) refl (helper f kf u v) i

  kcomp : (f : ∥ A ∥ → B) → 2-Constant (f ∘ ∣_∣)
  kcomp f x y = cong f (squash ∣ x ∣ ∣ y ∣)

  Fset : isSet (A → B)
  Fset = isSetΠ (const Bset)

  Kset : (f : A → B) → isSet (2-Constant f)
  Kset f = isSetΠ (λ _ → isSetΠ (λ _ → isProp→isSet (Bset _ _)))

  setRecLemma
    : (f : ∥ A ∥ → B)
    → rec→Set (f ∘ ∣_∣) (kcomp f) ≡ f
  setRecLemma f i t
    = elim {P = λ t → rec→Set (f ∘ ∣_∣) (kcomp f) t ≡ f t}
        (λ t → Bset _ _) (λ x → refl) t i

  mkKmap : (∥ A ∥ → B) → Σ (A → B) 2-Constant
  mkKmap f = f ∘ ∣_∣ , kcomp f

  fib : (g : Σ (A → B) 2-Constant) → fiber mkKmap g
  fib (g , kg) = rec→Set g kg , refl

  eqv : (g : Σ (A → B) 2-Constant) → ∀ fi → fib g ≡ fi
  eqv g (f , p) =
    Σ≡Prop (λ f → isOfHLevelΣ 2 Fset Kset _ _)
      (cong (uncurry rec→Set) (sym p) ∙ setRecLemma f)

  trunc→Set≃ : (∥ A ∥ → B) ≃ (Σ (A → B) 2-Constant)
  trunc→Set≃ .fst = mkKmap
  trunc→Set≃ .snd .equiv-proof g = fib g , eqv g

  -- The strategy of this equivalence proof follows the paper more closely.
  -- It is used further down for the groupoid version, because the above
  -- strategy does not generalize so easily.
  e : B → Σ (A → B) 2-Constant
  e b = const b , λ _ _ → refl

  eval : A → (γ : Σ (A → B) 2-Constant) → B
  eval a₀ (g , _) = g a₀

  e-eval : ∀ (a₀ : A) γ → e (eval a₀ γ) ≡ γ
  e-eval a₀ (g , kg) i .fst a₁ = kg a₀ a₁ i
  e-eval a₀ (g , kg) i .snd a₁ a₂ = Bset' refl (kg a₁ a₂) (kg a₀ a₁) (kg a₀ a₂) i

  e-isEquiv : A → isEquiv (e {A = A})
  e-isEquiv a₀ = isoToIsEquiv (iso e (eval a₀) (e-eval a₀) λ _ → refl)

  preEquiv₁ : ∥ A ∥ → B ≃ Σ (A → B) 2-Constant
  preEquiv₁ t = e , rec (isPropIsEquiv e) e-isEquiv t

  preEquiv₂ : (∥ A ∥ → Σ (A → B) 2-Constant) ≃ Σ (A → B) 2-Constant
  preEquiv₂ = isoToEquiv (iso to const (λ _ → refl) retr)
    where
    to : (∥ A ∥ → Σ (A → B) 2-Constant) → Σ (A → B) 2-Constant
    to f .fst x = f ∣ x ∣ .fst x
    to f .snd x y i = f (squash ∣ x ∣ ∣ y ∣ i) .snd x y i

    retr : retract to const
    retr f i t .fst x = f (squash ∣ x ∣ t i) .fst x
    retr f i t .snd x y
      = Bset'
          (λ j → f (squash ∣ x ∣ ∣ y ∣ j) .snd x y j)
          (f t .snd x y)
          (λ j → f (squash ∣ x ∣ t j) .fst x)
          (λ j → f (squash ∣ y ∣ t j) .fst y)
          i

  trunc→Set≃₂ : (∥ A ∥ → B) ≃ Σ (A → B) 2-Constant
  trunc→Set≃₂ = compEquiv (equivΠCod preEquiv₁) preEquiv₂

open SetElim public using (rec→Set; trunc→Set≃)

elim→Set
  : {P : ∥ A ∥ → Type ℓ}
  → (∀ t → isSet (P t))
  → (f : (x : A) → P ∣ x ∣)
  → (kf : ∀ x y → PathP (λ i → P (squash ∣ x ∣ ∣ y ∣ i)) (f x) (f y))
  → (t : ∥ A ∥) → P t
elim→Set {A = A} {P = P} Pset f kf t
  = rec→Set (Pset t) g gk t
  where
  g : A → P t
  g x = transp (λ i → P (squash ∣ x ∣ t i)) i0 (f x)

  gk : 2-Constant g
  gk x y i = transp (λ j → P (squash (squash ∣ x ∣ ∣ y ∣ i) t j)) i0 (kf x y i)

RecHProp : (P : A → hProp ℓ) (kP : ∀ x y → P x ≡ P y) → ∥ A ∥ → hProp ℓ
RecHProp P kP = rec→Set isSetHProp P kP

module GpdElim (Bgpd : isGroupoid B) where
  Bgpd' : isGroupoid' B
  Bgpd' = isGroupoid→isGroupoid' Bgpd

  module _ (f : A → B) (3kf : 3-Constant f) where
    open 3-Constant 3kf

    rec→Gpd : ∥ A ∥ → B
    pathHelper : (t u : ∥ A ∥) → rec→Gpd t ≡ rec→Gpd u
    triHelper₁
      : (t u v : ∥ A ∥)
      → Square (pathHelper t u) (pathHelper t v) refl (pathHelper u v)
    triHelper₂
      : (t u v : ∥ A ∥)
      → Square (pathHelper t v) (pathHelper u v) (pathHelper t u) refl

    rec→Gpd ∣ x ∣ = f x
    rec→Gpd (squash t u i) = pathHelper t u i

    pathHelper ∣ x ∣ ∣ y ∣ = link x y
    pathHelper (squash t u j) v = triHelper₂ t u v j
    pathHelper ∣ x ∣ (squash u v j) = triHelper₁ ∣ x ∣ u v j

    triHelper₁ ∣ x ∣ ∣ y ∣ ∣ z ∣ = coh₁ x y z
    triHelper₁ (squash s t i) u v
      = Bgpd'
          (triHelper₁ s u v)
          (triHelper₁ t u v)
          (triHelper₂ s t u)
          (triHelper₂ s t v)
          (λ i → refl)
          (λ i → pathHelper u v)
          i
    triHelper₁ ∣ x ∣ (squash t u i) v
      = Bgpd'
          (triHelper₁ ∣ x ∣ t v)
          (triHelper₁ ∣ x ∣ u v)
          (triHelper₁ ∣ x ∣ t u)
          (λ i → pathHelper ∣ x ∣ v)
          (λ i → refl)
          (triHelper₂ t u v)
          i
    triHelper₁ ∣ x ∣ ∣ y ∣ (squash u v i)
      = Bgpd'
          (triHelper₁ ∣ x ∣ ∣ y ∣ u)
          (triHelper₁ ∣ x ∣ ∣ y ∣ v)
          (λ i → link x y)
          (triHelper₁ ∣ x ∣ u v)
          (λ i → refl)
          (triHelper₁ ∣ y ∣ u v)
          i

    triHelper₂ ∣ x ∣ ∣ y ∣ ∣ z ∣ = coh₂ x y z
    triHelper₂ (squash s t i) u v
      = Bgpd'
          (triHelper₂ s u v)
          (triHelper₂ t u v)
          (triHelper₂ s t v)
          (λ i → pathHelper u v)
          (triHelper₂ s t u)
          (λ i → refl)
          i
    triHelper₂ ∣ x ∣ (squash t u i) v
      = Bgpd'
          (triHelper₂ ∣ x ∣ t v)
          (triHelper₂ ∣ x ∣ u v)
          (λ i → pathHelper ∣ x ∣ v)
          (triHelper₂ t u v)
          (triHelper₁ ∣ x ∣ t u)
          (λ i → refl)
          i
    triHelper₂ ∣ x ∣ ∣ y ∣ (squash u v i)
      = Bgpd'
          (triHelper₂ ∣ x ∣ ∣ y ∣ u)
          (triHelper₂ ∣ x ∣ ∣ y ∣ v)
          (triHelper₁ ∣ x ∣ u v)
          (triHelper₁ ∣ y ∣ u v)
          (λ i → link x y)
          (λ i → refl)
          i

  preEquiv₁ : (∥ A ∥ → Σ (A → B) 3-Constant) ≃ Σ (A → B) 3-Constant
  preEquiv₁ = isoToEquiv (iso fn const (λ _ → refl) retr)
    where
    open 3-Constant

    fn : (∥ A ∥ → Σ (A → B) 3-Constant) → Σ (A → B) 3-Constant
    fn f .fst x = f ∣ x ∣ .fst x
    fn f .snd .link x y i = f (squash ∣ x ∣ ∣ y ∣ i) .snd .link x y i
    fn f .snd .coh₁ x y z i j
      = f (squash ∣ x ∣ (squash ∣ y ∣ ∣ z ∣ i) j) .snd .coh₁ x y z i j

    retr : retract fn const
    retr f i t .fst x = f (squash ∣ x ∣ t i) .fst x
    retr f i t .snd .link x y j
      = f (squash (squash ∣ x ∣ ∣ y ∣ j) t i) .snd .link x y j
    retr f i t .snd .coh₁ x y z
      = Bgpd'
          (λ k j → f (cb k j i0) .snd .coh₁ x y z k j )
          (λ k j → f (cb k j i1) .snd .coh₁ x y z k j)
          (λ k j → f (cb i0 j k) .snd .link x y j)
          (λ k j → f (cb i1 j k) .snd .link x z j)
          (λ _ → refl)
          (λ k j → f (cb j i1 k) .snd .link y z j)
          i
      where
      cb : I → I → I → ∥ _ ∥
      cb i j k = squash (squash ∣ x ∣ (squash ∣ y ∣ ∣ z ∣ i) j) t k

  e : B → Σ (A → B) 3-Constant
  e b .fst _ = b
  e b .snd = record
           { link = λ _ _ _ → b
           ; coh₁ = λ _ _ _ _ _ → b
           }

  eval : A → Σ (A → B) 3-Constant → B
  eval a₀ (g , _) = g a₀

  module _ where
    open 3-Constant
    e-eval : ∀(a₀ : A) γ → e (eval a₀ γ) ≡ γ
    e-eval a₀ (g , 3kg) i .fst x = 3kg .link a₀ x i
    e-eval a₀ (g , 3kg) i .snd .link x y = λ j → 3kg .coh₁ a₀ x y j i
    e-eval a₀ (g , 3kg) i .snd .coh₁ x y z
      = Bgpd'
          (λ _ _ → g a₀)
          (3kg .coh₁ x y z)
          (λ k j → 3kg .coh₁ a₀ x y j k)
          (λ k j → 3kg .coh₁ a₀ x z j k)
          (λ _ → refl)
          (λ k j → 3kg .coh₁ a₀ y z j k)
          i

  e-isEquiv : A → isEquiv (e {A = A})
  e-isEquiv a₀ = isoToIsEquiv (iso e (eval a₀) (e-eval a₀) λ _ → refl)

  preEquiv₂ : ∥ A ∥ → B ≃ Σ (A → B) 3-Constant
  preEquiv₂ t = e , rec (isPropIsEquiv e) e-isEquiv t

  trunc→Gpd≃ : (∥ A ∥ → B) ≃ Σ (A → B) 3-Constant
  trunc→Gpd≃ = compEquiv (equivΠCod preEquiv₂) preEquiv₁

open GpdElim using (rec→Gpd; trunc→Gpd≃) public

squashᵗ
  : ∀(x y z : A)
  → Square (squash ∣ x ∣ ∣ y ∣) (squash ∣ x ∣ ∣ z ∣) refl (squash ∣ y ∣ ∣ z ∣)
squashᵗ x y z i = squash ∣ x ∣ (squash ∣ y ∣ ∣ z ∣ i)

elim→Gpd
  : (P : ∥ A ∥ → Type ℓ)
  → (∀ t → isGroupoid (P t))
  → (f : (x : A) → P ∣ x ∣)
  → (kf : ∀ x y → PathP (λ i → P (squash ∣ x ∣ ∣ y ∣ i)) (f x) (f y))
  → (3kf : ∀ x y z
         → SquareP (λ i j → P (squashᵗ x y z i j)) (kf x y) (kf x z) refl (kf y z))
  → (t : ∥ A ∥) → P t
elim→Gpd {A = A} P Pgpd f kf 3kf t = rec→Gpd (Pgpd t) g 3kg t
  where
  g : A → P t
  g x = transp (λ i → P (squash ∣ x ∣ t i)) i0 (f x)

  open 3-Constant

  3kg : 3-Constant g
  3kg .link x y i
    = transp (λ j → P (squash (squash ∣ x ∣ ∣ y ∣ i) t j)) i0 (kf x y i)
  3kg .coh₁ x y z i j
    = transp (λ k → P (squash (squashᵗ x y z i j) t k)) i0 (3kf x y z i j)

RecHSet : (P : A → TypeOfHLevel ℓ 2) → 3-Constant P → ∥ A ∥ → TypeOfHLevel ℓ 2
RecHSet P 3kP = rec→Gpd (isOfHLevelTypeOfHLevel 2) P 3kP


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

open import lib.Basics
open import lib.types.Truncation
open import lib.types.Fin
open import lib.types.Nat
open import lib.types.Empty
open import lib.types.Unit
open import lib.types.Coproduct
open import lib.types.Sigma
open import lib.types.Paths
open import lib.NConnected

open import Util.Misc
open import Util.Finite
open import Util.Coproducts

open import Graphs.Definition
open import Graphs.Properties

open import Coequalizers.Definition
open import Coequalizers.PreserveEquivalence
open import Coequalizers.EdgeCoproduct
open import Coequalizers.Misc
open import Graphs.SubTrees

{- We show that graphs with finite vertex set have spanning trees. -}
module Graphs.SpanningTreeFinite {i : ULevel} where

module _ (E : Type i) (V : Type i) ⦃ gph : Graph E V ⦄ where

instance
  noedges : {j : ULevel} {V : Type j} → Graph ⊥ V -- defines the trivial coequalizer V / ⊥
  noedges = record { π₀ = ⊥-elim ; π₁ = ⊥-elim }

noedge-triv : {j : ULevel} {V : Type j} → V / ⊥ ≃ V
noedge-triv {V = V} = f , (record { g = c[_] ; f-g = f-g ; g-f = g-f ; adj = adj })
  where
    f : V / ⊥ → V
    f = Coeq-rec (idf V) (λ _ → idp)

    f-g : (v : V) → (f (c[ v ]) == v)
    f-g v = idp

    g-f : (z : V / ⊥) → (c[ (f z) ] == z)
    g-f = Coeq-elim _ (λ _ → idp) ⊥-elim

    adj : (z : V / ⊥) → ap f (g-f z) == idp
    adj = Coeq-elim _ (λ _ → idp) ⊥-elim

{- A spanning tree is a subtree where the inclusion of vertex sets is an
   equivalence and the inclusion of edge sets is complemented.
-}
record SpanningTree {j k l : ULevel} (E : Type i) (V : Type j) ⦃ gph : Graph E V ⦄
    (E' : Type k) (V' : Type l) : Type (lmax (lmax i j) (lmax l k)) where
  field
    is-st : SubTree E V E' V'
  open SubTree is-st public
  field
    all-vertices : is-equiv inU
    is-complemented : E ≃ E' ⊔ Σ E (λ e → ¬ (hfiber inD e))
    inD-comm : inD ∼ (<– is-complemented) ∘ inl

module ExtendSpanningTree {j k l : ULevel} (E : Type i) (V : Type j) ⦃ gph : Graph E V ⦄
  (E' : Type k) (V' : Type l) (spantree : SpanningTree E V E' V') where

  open SpanningTree spantree

  ¬E' = Σ E (λ e → ¬ (hfiber (SubTree.inD is-st) e))

  instance
    gph-coprod : Graph (E' ⊔ ¬E') V'
    gph-coprod = record { π₀ = ⊔-rec π₀ λ e → is-equiv.g all-vertices (π₀ (<– is-complemented (inr e)))
                       ; π₁ = ⊔-rec π₁ λ e → is-equiv.g all-vertices (π₁ (<– is-complemented (inr e))) }

  inU-equiv : V' ≃ V
  inU-equiv = (inU , all-vertices)

  spantree-equiv : V / E ≃ V' / (E' ⊔ ¬E')
  spantree-equiv = (Coeq-emap inU-equiv (is-complemented ⁻¹)
                   (λ { (inl e') → ! (comm₀ e') ∙ ap π₀ (inD-comm e') ; (inr x) → <–-inv-r inU-equiv _})
                   λ { (inl e') → ! (comm₁ e') ∙ ap π₁ (inD-comm e') ; (inr x) → <–-inv-r inU-equiv _}) ⁻¹

composepp : {j k l : ULevel} {E' : Type j} {E : Type k} {V : Type l} ( inc : E' → E ) ⦃ gph : Graph E V ⦄ → Graph E' V
composepp inc ⦃ gph = gph ⦄ = record { π₀ = P.π₀ ∘ inc ; π₁ = P.π₁ ∘ inc }
    where
      module P = Graph gph

Fin-equiv-Unit : Fin 1 ≃ ⊤
Fin-equiv-Unit =
  Fin 1
    ≃⟨ Fin-equiv-Coprod ⟩
  Fin 0 ⊔ ⊤
    ≃⟨ ⊔-emap Fin-equiv-Empty (ide ⊤) ⟩
  ⊥ ⊔ ⊤
    ≃⟨ ⊔₁-Empty ⊤ ⟩
  ⊤
    ≃∎

compose-equiv-subtree-l : {j k l m n : ULevel} {E : Type i} {V : Type j} ⦃ gph : Graph E V ⦄
  (D : Type k) (U : Type l) (D' : Type m) (U' : Type n) → (D' ≃ D) → (U' ≃ U) →
  SubTree E V D U → SubTree E V D' U'

compose-equiv-subtree-l D U D' U' equivD equivU (subtree inD inU D-inj U-inj U-dec comm₀ comm₁) =
  subtree (inD ∘ –> equivD) (inU ∘ –> equivU) (∘-is-inj D-inj (–>-is-inj equivD)) (∘-is-inj U-inj (–>-is-inj equivU))
          (λ v → ⊔-rec (λ {(u , p) → inl ((<– equivU u) , (ap inU (<–-inv-r equivU u) ∙ p))})
                          (λ f → inr (λ {(u , p) → f ((–> equivU u) , p) })) (U-dec v))
          (λ d → comm₀ (–> equivD d) ∙ ap inU (! (<–-inv-r equivU _)))
          (λ d → comm₁ (–> equivD d) ∙ ap inU (! (<–-inv-r equivU _)))
  where
    instance
      gph' : Graph D' U'
      gph' = record { π₀ = λ d → <– equivU (π₀ (–> equivD d)) ; π₁ = λ d → <– equivU (π₁ (–> equivD d)) }

      c : is-contr (U' / D')
      c = equiv-preserves-level ((Coeq-emap equivU equivD (λ d → <–-inv-r equivU _) λ d → <–-inv-r equivU _) ⁻¹)

{- Since the vertex set is finite, we can build the spanning tree up a step at a time. -}
build-spanning-tree : (E : Type i) (n : ℕ) ⦃ gph : Graph E (Fin (S n)) ⦄ ⦃ conn : gph-is-connected gph ⦄ →
  (k : ℕ) → (k < S n) → ∥ SubTree E (Fin (S n)) (Fin k) (Fin (S k)) ∥

build-spanning-tree E n O l =
  [ compose-equiv-subtree-l _ _ _ _ Fin-equiv-Empty Fin-equiv-Unit t ]
  where
    instance
      ic : is-contr (⊤ / ⊥)
      ic = equiv-preserves-level (noedge-triv ⁻¹)

    t : SubTree E (Fin (S n)) ⊥ ⊤
    t = subtree ⊥-elim (λ _ → 0 , l) ⊥-elim (λ {unit unit _ → idp}) (λ v → ⊔-fmap (λ p → unit , (! p)) (λ {f (unit , p) → f (! p)}) (Fin-has-dec-eq v (0 , l)))
                ⊥-elim ⊥-elim

build-spanning-tree E n (S k) l =
  do
    ih ← (build-spanning-tree E n k (<-trans ltS l))
    let x = Fin-smaller-is-smaller l (SubTree.inU ih)
    t ← (extend-subtree E (Fin (S n)) Fin-has-dec-eq ih (fst x) (snd x))
    [ compose-equiv-subtree-l _ _ _ _ (⊔-sym ∘e Fin-equiv-Coprod) Fin-equiv-Coprod t ]

spanning-tree : (E : Type i) (Edec : has-dec-eq E) (n : ℕ) ⦃ gph : Graph E (Fin (S n)) ⦄ ⦃ conn : gph-is-connected gph ⦄ →
  ∥ SpanningTree E (Fin (S n)) (Fin n) (Fin (S n)) ∥

spanning-tree E Edec n = Trunc-fmap from-subtree (build-spanning-tree E _ _ ltS)
  where
    from-subtree : SubTree E (Fin (S n)) (Fin n) (Fin (S n)) → SpanningTree E (Fin (S n)) (Fin n) (Fin (S n))
    from-subtree st@(subtree ⦃ gphDU ⦄ inD inU D-inj U-inj U-dec comm₀ comm₁) =
      record
        { is-st = st
        ; all-vertices = Fin-inj-to-equiv inU U-inj
        ; is-complemented = dec-img-to-⊔ inD D-inj (Fin-hfiber-dec Edec inD) ⁻¹
        ; inD-comm = λ _ → idp
        }


------------------------------------------------------------------------
-- Closure properties for Compatible and Size-preserving
------------------------------------------------------------------------

{-# OPTIONS --sized-types #-}

module Up-to.Closure where

open import Equality.Propositional
open import Logical-equivalence using (_⇔_)
open import Prelude as P
open import Prelude.Size

open import Bijection equality-with-J using (_↔_)
open import Function-universe equality-with-J hiding (id; _∘_)

import Bisimilarity
open import Indexed-container hiding (Bisimilarity)
open import Indexed-container.Combinators hiding (id; _∘_)
open import Labelled-transition-system
import Labelled-transition-system.CCS
open import Relation
import Similarity
import Similarity.CCS as SC
open import Up-to

private
  module CCS {ℓ} (Name : Type ℓ) where
    open Labelled-transition-system.CCS Name public
    open module B = Bisimilarity CCS public
    open module S = Similarity CCS public using (Similarity)

------------------------------------------------------------------------
-- Closure properties for Compatible

-- The results in this section are closely related to
-- Proposition 6.3.21 in Pous and Sangiorgi's "Enhancements of the
-- bisimulation proof method".

-- The function flip Compatible F is closed under _⊗_, assuming that F
-- is monotone.

Compatible-⊗ :
  ∀ {ℓ} {I : Type ℓ} {C₁ C₂ : Container I I} {F : Trans ℓ I} →
  Monotone F →
  Compatible C₁ F → Compatible C₂ F → Compatible (C₁ ⊗ C₂) F
Compatible-⊗ {C₁ = C₁} {C₂} {F} mono comp₁ comp₂ {R = R} =
  F (⟦ C₁ ⊗ C₂ ⟧ R)            ⊆⟨ mono (⟦⊗⟧↔ _ C₁ C₂) ⟩
  F (⟦ C₁ ⟧ R ∩ ⟦ C₂ ⟧ R)      ⊆⟨ (λ x → mono proj₁ x , mono proj₂ x) ⟩
  F (⟦ C₁ ⟧ R) ∩ F (⟦ C₂ ⟧ R)  ⊆⟨ Σ-map comp₁ comp₂ ⟩
  ⟦ C₁ ⟧ (F R) ∩ ⟦ C₂ ⟧ (F R)  ⊆⟨ _⇔_.from (⟦⊗⟧↔ _ C₁ C₂) ⟩∎
  ⟦ C₁ ⊗ C₂ ⟧ (F R)            ∎

-- The function flip Compatible F is closed under reindex₁ f, assuming
-- that F is monotone and f-symmetric.

Compatible-reindex₁ :
  ∀ {ℓ} {I : Type ℓ} {C : Container I I} {F : Trans ℓ I} {f : I → I} →
  Monotone F → Symmetric f F →
  Compatible C F → Compatible (reindex₁ f C) F
Compatible-reindex₁ {C = C} {F} {f} mono hyp comp {R = R} =
  F (⟦ reindex₁ f C ⟧ R)  ⊆⟨ mono (⟦reindex₁⟧↔ _ C) ⟩
  F (⟦ C ⟧ (R ∘ f))       ⊆⟨ comp ⟩
  ⟦ C ⟧ (F (R ∘ f))       ⊆⟨ map C (hyp _) ⟩
  ⟦ C ⟧ (F R ∘ f)         ⊆⟨ _⇔_.from (⟦reindex₁⟧↔ _ C) ⟩∎
  ⟦ reindex₁ f C ⟧ (F R)  ∎

-- The function flip Compatible F is closed under reindex₂ f, assuming
-- that F is f-symmetric.

Compatible-reindex₂ :
  ∀ {ℓ} {I : Type ℓ} {C : Container I I} {F : Trans ℓ I} {f : I → I} →
  Symmetric f F →
  Compatible C F → Compatible (reindex₂ f C) F
Compatible-reindex₂ {C = C} {F} {f} hyp comp {R = R} =
  F (⟦ reindex₂ f C ⟧ R)  ⊆⟨⟩
  F (⟦ C ⟧ R ∘ f)         ⊆⟨ hyp _ ⟩
  F (⟦ C ⟧ R) ∘ f         ⊆⟨ comp ⟩
  ⟦ C ⟧ (F R) ∘ f         ⊆⟨ id ⟩∎
  ⟦ reindex₂ f C ⟧ (F R)  ∎

-- The function flip Compatible F is closed under reindex f, assuming
-- that F is monotone and f-symmetric.

Compatible-reindex :
  ∀ {ℓ} {I : Type ℓ} {C : Container I I} {F : Trans ℓ I} {f : I → I} →
  Monotone F → Symmetric f F →
  Compatible C F → Compatible (reindex f C) F
Compatible-reindex {C = C} {F} {f} mono hyp =
  Compatible C F                            ↝⟨ Compatible-reindex₁ mono hyp ⟩
  Compatible (reindex₁ f C) F               ↝⟨ Compatible-reindex₂ hyp ⟩
  Compatible (reindex₂ f (reindex₁ f C)) F  ↔⟨⟩
  Compatible (reindex f C) F                □

-- The function flip Compatible F is closed under _⟷_, assuming that F
-- is monotone and symmetric.

Compatible-⟷ :
  ∀ {ℓ} {I : Type ℓ}
    {C₁ C₂ : Container (I × I) (I × I)} {F : Trans₂ ℓ I} →
  Monotone F → Symmetric swap F →
  Compatible C₁ F → Compatible C₂ F → Compatible (C₁ ⟷ C₂) F
Compatible-⟷ {C₁ = C₁} {C₂} {F} mono sym = curry (
  Compatible C₁ F × Compatible C₂ F                 ↝⟨ Σ-map id (Compatible-reindex mono sym) ⟩
  Compatible C₁ F × Compatible (reindex swap C₂) F  ↝⟨ uncurry (Compatible-⊗ mono) ⟩
  Compatible (C₁ ⊗ reindex swap C₂) F               ↔⟨⟩
  Compatible (C₁ ⟷ C₂) F                            □)

-- An instance of the result above: If F is monotone and symmetric,
-- and compatible for strong similarity for some LTS, then F is
-- compatible for strong bisimilarity for this LTS.

compatible-for-similarity→compatible-for-bisimilarity :
  ∀ {ℓ} {lts : LTS ℓ} {F} →
  Monotone F → Symmetric swap F →
  Compatible (Similarity.StepC lts) F →
  Compatible (Bisimilarity.StepC lts) F
compatible-for-similarity→compatible-for-bisimilarity mono sym comp =
  Compatible-⟷ mono sym comp comp

------------------------------------------------------------------------
-- Closure properties for Size-preserving

-- The function flip Size-preserving F is closed under reindex,
-- assuming that F is f-symmetric for an involutory function f.
--
-- Note that the assumptions are different from the ones asked for in
-- Compatible-reindex: monotonicity of F has been replaced by the
-- assumption that f is an involution.

Size-preserving-reindex :
  ∀ {ℓ} {I : Type ℓ} {C : Container I I} {F : Trans ℓ I} {f : I → I} →
  f ∘ f ≡ id → Symmetric f F →
  Size-preserving C F → Size-preserving (reindex f C) F
Size-preserving-reindex {C = C} {F} {f}
                        inv hyp pres {R = R} {i = i} R⊆ =

  F R                        ⊆⟨ (λ {x} → subst (λ g → F (R ∘ g) x) (sym inv)) ⟩
  F (R ∘ f ∘ f)              ⊆⟨ hyp _ ⟩
  F (R ∘ f) ∘ f              ⊆⟨ pres (

      R ∘ f                       ⊆⟨ R⊆ ⟩
      ν (reindex f C) i ∘ f       ⊆⟨ _⇔_.to (ν-reindex⇔ inv) ⟩
      ν C i ∘ f ∘ f               ⊆⟨ (λ {x} → subst (λ g → ν C i (g x)) inv) ⟩∎
      ν C i                       ∎) ⟩

  ν C i ∘ f                  ⊆⟨ _⇔_.from (ν-reindex⇔ inv) ⟩∎
  ν (reindex f C) i          ∎

-- Some negative results:
--
-- * For inhabited name types it is not in general the case that a
--   monotone and symmetric function F that is size-preserving for
--   similarity for CCS is also size-preserving for bisimilarity for
--   CCS.
--
-- * It is not in general the case that if F is monotone and
--   symmetric, and size-preserving for strong similarity for some
--   LTS, then F is size-preserving for strong bisimilarity for this
--   LTS.
--
-- * The function flip Size-preserving F is not closed under _⟷_ for
--   all F, not even those that are monotone and symmetric.
--
-- * Furthermore flip Size-preserving F is not closed under _⊗_ for
--   all F, not even those that are monotone.

¬-Size-preserving-⟷/⊗ :
  ∀ {ℓ} →
  ({Name : Type ℓ} →
   let open CCS Name in
   Name →
   ¬ ({F : Trans₂ ℓ (Proc ∞)} →
      Monotone F → Symmetric swap F →
      Size-preserving S.StepC F →
      Size-preserving B.StepC F))
    ×
  ¬ (∀ {lts : LTS ℓ} {F} →
     Monotone F → Symmetric swap F →
     Size-preserving (Similarity.StepC lts) F →
     Size-preserving (Bisimilarity.StepC lts) F)
    ×
  ¬ ({I : Type ℓ} {C₁ C₂ : Container (I × I) (I × I)}
     {F : Trans₂ ℓ I} →
     Monotone F → Symmetric swap F →
     Size-preserving C₁ F → Size-preserving C₂ F →
     Size-preserving (C₁ ⟷ C₂) F)
    ×
  ¬ ({I : Type ℓ} {C₁ C₂ : Container I I} {F : Trans ℓ I} →
     Monotone F →
     Size-preserving C₁ F → Size-preserving C₂ F →
     Size-preserving (C₁ ⊗ C₂) F)
¬-Size-preserving-⟷/⊗ {ℓ} =
    Lemmas.contradiction₂
  , Lemmas.contradiction₃ (lift tt)
  , Lemmas.contradiction₄ (lift tt)
  , Lemmas.contradiction₅ (lift tt)
  where
  module Lemmas {Name : Type ℓ} (a : Name) where
    open CCS Name public

    ≤≥≁ = SC.≤≥≁ a

    m₁ = proj₁ ≤≥≁
    m₂ = proj₁ (proj₂ ≤≥≁)

    F : Trans₂ ℓ (Proc ∞)
    F R = R ∪ (_≡ (m₁ , m₂)) ∪ (_≡ (m₂ , m₁))

    mono : Monotone F
    mono R⊆S = ⊎-map R⊆S id

    symm : Symmetric swap F
    symm R =
      F (R ⁻¹)                                      ⊆⟨⟩
      R ⁻¹ ∪ (_≡ (m₁ , m₂))    ∪ (_≡ (m₂ , m₁))     ⊆⟨ ⊎-map id P.[ inj₂ ∘ lemma , inj₁ ∘ lemma ] ⟩
      R ⁻¹ ∪ (_≡ (m₁ , m₂)) ⁻¹ ∪ (_≡ (m₂ , m₁)) ⁻¹  ⊆⟨ id ⟩∎
      F R ⁻¹                                        ∎
      where
      lemma : {p₁ p₂ : Proc ∞ × Proc ∞} → p₁ ≡ swap p₂ → swap p₁ ≡ p₂
      lemma refl = refl

    pres : Size-preserving S.StepC F
    pres {R = R} {i = i} R⊆ =
      F R                                  ⊆⟨⟩
      R ∪ (_≡ (m₁ , m₂)) ∪ (_≡ (m₂ , m₁))  ⊆⟨ [ R⊆ , helper ] ⟩∎
      Similarity i                         ∎
      where
      helper : ∀ {p} → p ≡ (m₁ , m₂) ⊎ p ≡ (m₂ , m₁) → Similarity i p
      helper (inj₁ refl) = proj₁ (proj₂ (proj₂ ≤≥≁))
      helper (inj₂ refl) = proj₁ (proj₂ (proj₂ (proj₂ ≤≥≁)))

    contradiction =
      Size-preserving B.StepC F            ↝⟨ (λ hyp → _⇔_.to (monotone→⇔ _ mono) hyp) ⟩
      F (Bisimilarity ∞) ⊆ Bisimilarity ∞  ↝⟨ _$ inj₂ (inj₁ refl) ⟩
      m₁ ∼ m₂                              ↝⟨ proj₂ (proj₂ (proj₂ (proj₂ ≤≥≁))) ⟩□
      ⊥                                    □

    contradiction₂ =
      ({F : Trans₂ ℓ (Proc ∞)} →
       Monotone F → Symmetric swap F →
       Size-preserving S.StepC F →
       Size-preserving B.StepC F)       ↝⟨ (λ closed → closed mono symm pres) ⟩

      Size-preserving B.StepC F         ↝⟨ contradiction ⟩□

      ⊥                                 □

    contradiction₃ =
      (∀ {lts : LTS ℓ} {F} →
       Monotone F → Symmetric swap F →
       Size-preserving (Similarity.StepC lts) F →
       Size-preserving (Bisimilarity.StepC lts) F)        ↝⟨ (λ closed mono sym pres → closed mono sym pres) ⟩

      ({F : Trans₂ ℓ (Proc ∞)} →
       Monotone F → Symmetric swap F →
       Size-preserving S.StepC F →
       Size-preserving B.StepC F)                         ↝⟨ contradiction₂ ⟩□

      ⊥                                                   □

    contradiction₄ =
      ({I : Type ℓ} {C₁ C₂ : Container (I × I) (I × I)}
       {F : Trans₂ ℓ I} →
       Monotone F → Symmetric swap F →
       Size-preserving C₁ F → Size-preserving C₂ F →
       Size-preserving (C₁ ⟷ C₂) F)                       ↝⟨ (λ closed mono symm pres → closed mono symm pres pres) ⟩

      (∀ {lts : LTS ℓ} {F} →
       Monotone F → Symmetric swap F →
       Size-preserving (Similarity.StepC lts) F →
       Size-preserving (Bisimilarity.StepC lts) F)        ↝⟨ contradiction₃ ⟩□

      ⊥                                                   □

    contradiction₅ =
      ({I : Type ℓ} {C₁ C₂ : Container I I}
       {F : Trans ℓ I} →
       Monotone F →
       Size-preserving C₁ F → Size-preserving C₂ F →
       Size-preserving (C₁ ⊗ C₂) F)                   ↝⟨ (λ closed → closed mono pres) ⟩

      (Size-preserving (reindex swap S.StepC) F →
       Size-preserving B.StepC F)                     ↝⟨ _$ Size-preserving-reindex refl symm pres ⟩

      Size-preserving B.StepC F                       ↝⟨ contradiction ⟩□

      ⊥                                               □


{-# OPTIONS --without-K #-}
module Explore.Subset where

open import Relation.Binary.PropositionalEquality

-- TODO


module SystemF.Substitutions.Lemmas where

open import Prelude hiding (module Fin; id)

open import SystemF.WellTyped
open import SystemF.Substitutions

open import Data.Fin as Fin using ()
open import Data.Fin.Substitution
open import Data.Fin.Substitution.Lemmas
open import Data.Vec hiding ([_])

open import Extensions.Substitution
open import Extensions.Vec
open import Data.Vec.Properties

import Category.Applicative.Indexed as Applicative
open Applicative.Morphism using (op-<$>)

module TypeLemmas where
  open TypeSubst using (module Lifted; module TypeApp)
  open import Data.Fin.Substitution.Lemmas
  open import Data.Fin.Substitution.Lemmas public using (module VarLemmas)
  open import Data.Star using (Star; ε; _◅_)

  typeLemmas : TermLemmas Type
  typeLemmas = record { termSubst = TypeSubst.typeSubst; app-var = refl ; /✶-↑✶ = Lemma./✶-↑✶ }
    where
      module Lemma {T₁ T₂} {lift₁ : Lift T₁ Type} {lift₂ : Lift T₂ Type} where

        open Lifted lift₁ using () renaming (_↑✶_ to _↑✶₁_; _/✶_ to _/✶₁_)
        open Lifted lift₂ using () renaming (_↑✶_ to _↑✶₂_; _/✶_ to _/✶₂_)

        /✶-↑✶ : ∀ {m n} (σs₁ : Subs T₁ m n) (σs₂ : Subs T₂ m n) →
                          (∀ k x → tvar x /✶₁ σs₁ ↑✶₁ k ≡ tvar x /✶₂ σs₂ ↑✶₂ k) →
                          ∀ k t → t /✶₁ σs₁ ↑✶₁ k ≡ t /✶₂ σs₂ ↑✶₂ k
        /✶-↑✶ ρs₁ ρs₂ hyp k (tvar x) = hyp k x
        /✶-↑✶ ρs₁ ρs₂ hyp k (tc c) = begin
            (tc c) /✶₁ ρs₁ ↑✶₁ k
          ≡⟨ TypeApp.tc-/✶-↑✶ _ k ρs₁ ⟩
            (tc c)
          ≡⟨ sym $ TypeApp.tc-/✶-↑✶ _ k ρs₂ ⟩
            (tc c) /✶₂ ρs₂ ↑✶₂ k ∎
        /✶-↑✶ ρs₁ ρs₂ hyp k (a ⟶ b) = begin
            (a ⟶  b) /✶₁ ρs₁ ↑✶₁ k
          ≡⟨ TypeApp.⟶-/✶-↑✶ _ k ρs₁ ⟩
            (a /✶₁ ρs₁ ↑✶₁ k) ⟶ (b /✶₁ ρs₁ ↑✶₁ k)
          ≡⟨ cong₂ _⟶_ (/✶-↑✶ ρs₁ ρs₂ hyp k a) (/✶-↑✶ ρs₁ ρs₂ hyp k b) ⟩
            (a /✶₂ ρs₂ ↑✶₂ k) ⟶ (b /✶₂ ρs₂ ↑✶₂ k)
          ≡⟨ sym (TypeApp.⟶-/✶-↑✶ _ k ρs₂) ⟩
            (a ⟶ b) /✶₂ ρs₂ ↑✶₂ k
          ∎
        /✶-↑✶ ρs₁ ρs₂ hyp k (a →' b) = begin
            (a →' b) /✶₁ ρs₁ ↑✶₁ k
          ≡⟨ TypeApp.→'-/✶-↑✶ _ k ρs₁ ⟩
            (a /✶₁ ρs₁ ↑✶₁ k) →' (b /✶₁ ρs₁ ↑✶₁ k)
          ≡⟨ cong₂ _→'_ (/✶-↑✶ ρs₁ ρs₂ hyp k a) (/✶-↑✶ ρs₁ ρs₂ hyp k b) ⟩
            (a /✶₂ ρs₂ ↑✶₂ k) →' (b /✶₂ ρs₂ ↑✶₂ k)
          ≡⟨ sym (TypeApp.→'-/✶-↑✶ _ k ρs₂) ⟩
            (a →' b) /✶₂ ρs₂ ↑✶₂ k
          ∎
        /✶-↑✶ ρs₁ ρs₂ hyp k (∀' a) = begin
          (∀' a) /✶₁ ρs₁ ↑✶₁ k        ≡⟨ TypeApp.∀'-/✶-↑✶ _ k ρs₁ ⟩
          ∀' (a /✶₁ ρs₁ ↑✶₁ (1 + k))  ≡⟨ cong ∀' (/✶-↑✶ ρs₁ ρs₂ hyp (1 + k) a) ⟩
          ∀' (a /✶₂ ρs₂ ↑✶₂ (1 + k))  ≡⟨ sym (TypeApp.∀'-/✶-↑✶ _ k ρs₂) ⟩
          (∀' a) /✶₂ ρs₂ ↑✶₂ k        ∎

  module tpl = TermLemmas typeLemmas

  -- The above lemma /✶-↑✶ specialized to single substitutions
  /-↑⋆ : ∀ {T₁ T₂} {lift₁ : Lift T₁ Type} {lift₂ : Lift T₂ Type} →
         let open Lifted lift₁ using () renaming (_↑⋆_ to _↑⋆₁_; _/_ to _/₁_)
             open Lifted lift₂ using () renaming (_↑⋆_ to _↑⋆₂_; _/_ to _/₂_)
         in
         ∀ {n k} (ρ₁ : Sub T₁ n k) (ρ₂ : Sub T₂ n k) →
         (∀ i x → tvar x /₁ ρ₁ ↑⋆₁ i ≡ tvar x /₂ ρ₂ ↑⋆₂ i) →
          ∀ i a → a /₁ ρ₁ ↑⋆₁ i ≡ a /₂ ρ₂ ↑⋆₂ i
  /-↑⋆ ρ₁ ρ₂ hyp i a = tpl./✶-↑✶ (ρ₁ ◅ ε) (ρ₂ ◅ ε) hyp i a

  open AdditionalLemmas typeLemmas public
  open tpl public

  /Var-/ : ∀ {ν μ} (t : Type ν) (s : Sub Fin ν μ) → t /Var s ≡ t / (map tvar s)
  /Var-/ (tc c) s = refl
  /Var-/ (tvar n) s = lookup⋆map s tvar n
  /Var-/ (a →' b) s = cong₂ _→'_ (/Var-/ a s) (/Var-/ b s)
  /Var-/ (a ⟶ b) s = cong₂ _⟶_ (/Var-/ a s) (/Var-/ b s)
  /Var-/ (∀' t) s = begin
    ∀' (t /Var (s Var.↑))
      ≡⟨ cong ∀' $ /Var-/ t (s Var.↑) ⟩
    ∀' (t / (map tvar $ s Var.↑))
      ≡⟨ cong (λ u → ∀' (t / u)) (map-var-↑ refl) ⟩
    ∀' t / (map tvar s) ∎

  a-/Var-varwk↑-/-sub0≡a : ∀ {n} (a : Type (suc n)) → (a /Var Var.wk Var.↑) / sub (tvar zero) ≡ a
  a-/Var-varwk↑-/-sub0≡a a = begin
    (a /Var Var.wk Var.↑) / (sub $ tvar zero)
      ≡⟨ cong (λ u → u / (sub $ tvar zero)) (/Var-/ a $ Var.wk Var.↑) ⟩
    (a / (map tvar $ Var.wk Var.↑)) / sub (tvar zero)
      ≡⟨ cong (λ u → (a / u) / (sub $ tvar zero)) (map-var-↑ map-var-varwk≡wk) ⟩
    (a / wk ↑) / (sub $ tvar zero)
      ≡⟨ a/wk↑/sub0≡a a ⟩
    a ∎

-- Lemmas about type substitutions in terms.
module TermTypeLemmas where
  open TermTypeSubst public

  private module T = TypeLemmas
  private module TS = TypeSubst
  private module V = VarLemmas

  /-↑⋆ :
    ∀ {T₁ T₂} {lift₁ : Lift T₁ Type} {lift₂ : Lift T₂ Type} →
    let open TS.Lifted lift₁ using () renaming (_↑⋆_ to _↑⋆₁_; _/_ to _/tp₁_)
        open   Lifted lift₁ using () renaming (_/_  to _/₁_)
        open TS.Lifted lift₂ using () renaming (_↑⋆_ to _↑⋆₂_; _/_ to _/tp₂_)
        open   Lifted lift₂ using () renaming (_/_  to _/₂_)
    in
    ∀ {n k} (ρ₁ : Sub T₁ n k) (ρ₂ : Sub T₂ n k) →
    (∀ i x → tvar x /tp₁ ρ₁ ↑⋆₁ i ≡ tvar x /tp₂ ρ₂ ↑⋆₂ i) →
     ∀ i {m} (t : Term (i + n) m)  → t /₁ ρ₁ ↑⋆₁ i ≡ t /₂ ρ₂ ↑⋆₂ i
  /-↑⋆ ρ₁ ρ₂ hyp i (var x)      = refl
  /-↑⋆ ρ₁ ρ₂ hyp i (Λ t)        = cong Λ      (/-↑⋆ ρ₁ ρ₂ hyp (1 + i) t)
  /-↑⋆ ρ₁ ρ₂ hyp i (λ' a t)     =
    cong₂ λ'     (T./-↑⋆ ρ₁ ρ₂ hyp i a)       (/-↑⋆ ρ₁ ρ₂ hyp i t)
  /-↑⋆ ρ₁ ρ₂ hyp i (t [ b ])    =
    cong₂ _[_]     (/-↑⋆ ρ₁ ρ₂ hyp i t)     (T./-↑⋆ ρ₁ ρ₂ hyp i b)
  /-↑⋆ ρ₁ ρ₂ hyp i (s · t)      =
    cong₂ _·_      (/-↑⋆ ρ₁ ρ₂ hyp i s)       (/-↑⋆ ρ₁ ρ₂ hyp i t)

  /-wk : ∀ {m n} (t : Term m n) → t / TypeSubst.wk ≡ weaken t
  /-wk t = /-↑⋆ TypeSubst.wk VarSubst.wk (λ k x → begin
    tvar x T./ T.wk T.↑⋆ k ≡⟨ T.var-/-wk-↑⋆ k x ⟩
    tvar (Fin.lift k suc x) ≡⟨ cong tvar (sym (V.var-/-wk-↑⋆ k x)) ⟩
    tvar (lookup x (V.wk V.↑⋆ k)) ≡⟨ refl ⟩
    tvar x TS./Var V.wk V.↑⋆ k ∎) 0 t

module CtxLemmas where
  open CtxSubst public

  private module Tp  = TypeLemmas
  private module Var = VarSubst

  -- Term variable substitution (renaming) commutes with type
  -- substitution.
  /Var-/ : ∀ {m ν n l} (ρ : Sub Fin m n) (Γ : Ctx ν n) (σ : Sub Type ν l) →
           (ρ /Var Γ) / σ ≡ ρ /Var (Γ / σ)
  /Var-/ ρ Γ σ = begin
      (ρ /Var Γ) / σ
    ≡⟨ sym (map-∘ _ _ ρ) ⟩
      map (λ x → (lookup x Γ) Tp./ σ) ρ
    ≡⟨ map-cong (λ x → sym (Tp.lookup-⊙ x)) ρ ⟩
      map (λ x → lookup x (Γ / σ)) ρ
    ∎

  -- Term variable substitution (renaming) commutes with weakening of
  -- typing contexts with an additional type variable.
  /Var-weaken : ∀ {m n k} (ρ : Sub Fin m k) (Γ : Ctx n k) →
                weaken (ρ /Var Γ) ≡ ρ /Var (weaken Γ)
  /Var-weaken ρ Γ = begin
    (ρ /Var Γ) / Tp.wk   ≡⟨ /Var-/ ρ Γ Tp.wk ⟩
    ρ /Var (weaken Γ)    ∎

  -- Term variable substitution (renaming) commutes with term variable
  -- lookup in typing context.
  /Var-lookup : ∀ {m n k} (x : Fin m) (ρ : Sub Fin m k) (Γ : Ctx n k) →
                lookup x (ρ /Var Γ) ≡ lookup (lookup x ρ) Γ
  /Var-lookup x ρ Γ = op-<$> (lookup-morphism x) _ _

  -- Term variable substitution (renaming) commutes with weakening of
  -- typing contexts with an additional term variable.
  /Var-∷ : ∀ {m n k} (a : Type n) (ρ : Sub Fin m k) (Γ : Ctx n k) →
           a ∷ (ρ /Var Γ) ≡ (ρ Var.↑) /Var (a ∷ Γ)
  /Var-∷ a []      Γ = refl
  /Var-∷ a (x ∷ ρ) Γ = cong (_∷_ a) (cong (_∷_ (lookup x Γ)) (begin
    map (λ x → lookup x Γ) ρ                   ≡⟨ refl ⟩
    map (λ x → lookup (suc x) (a ∷ Γ)) ρ       ≡⟨ map-∘ _ _ ρ ⟩
    map (λ x → lookup x (a ∷ Γ)) (map suc ρ)   ∎))

  -- Invariants of term variable substitution (renaming)
  idVar-/Var   : ∀ {m n} (Γ : Ctx n m) → Γ ≡ (Var.id /Var Γ)
  wkVar-/Var-∷ : ∀ {m n} (Γ : Ctx n m) (a : Type n) → Γ ≡ (Var.wk /Var (a ∷ Γ))

  idVar-/Var []      = refl
  idVar-/Var (a ∷ Γ) = cong (_∷_ a) (wkVar-/Var-∷ Γ a)

  wkVar-/Var-∷ Γ a = begin
    Γ ≡⟨ idVar-/Var Γ ⟩
    Var.id /Var Γ ≡⟨ map-∘ _ _ VarSubst.id ⟩
    Var.wk /Var (a ∷ Γ) ∎

  ctx-weaken-sub-vanishes : ∀ {ν n} {Γ : Ctx ν n} {a} → (ctx-weaken Γ) ctx/ (Tp.sub a) ≡ Γ
  ctx-weaken-sub-vanishes {Γ = Γ} {a} = begin
    (Γ ctx/ Tp.wk) ctx/ (Tp.sub a)
      ≡⟨ sym $ map-∘ (λ s → s tp/tp Tp.sub a) (λ s → s tp/tp Tp.wk) Γ ⟩
    (map (λ s → s tp/tp Tp.wk tp/tp (Tp.sub a)) Γ)
      ≡⟨ map-cong (TypeLemmas.wk-sub-vanishes) Γ ⟩
    (map (λ s → s) Γ) ≡⟨ map-id Γ ⟩
    Γ ∎

private
  ⊢subst : ∀ {m n} {Γ₁ Γ₂ : Ctx n m} {t₁ t₂ : Term n m} {a₁ a₂ : Type n} →
    Γ₁ ≡ Γ₂ → t₁ ≡ t₂ → a₁ ≡ a₂ → Γ₁ ⊢ t₁ ∈ a₁ → Γ₂ ⊢ t₂ ∈ a₂
  ⊢subst refl refl refl hyp = hyp

  ⊢substCtx : ∀ {m n} {Γ₁ Γ₂ : Ctx n m} {t : Term n m} {a : Type n} →
    Γ₁ ≡ Γ₂ → Γ₁ ⊢ t ∈ a → Γ₂ ⊢ t ∈ a
  ⊢substCtx refl hyp = hyp

  ⊢substTp : ∀ {m n} {Γ : Ctx n m} {t : Term n m} {a₁ a₂ : Type n} →
    a₁ ≡ a₂ → Γ ⊢ t ∈ a₁ → Γ ⊢ t ∈ a₂
  ⊢substTp refl hyp = hyp

module WtTypeLemmas where
  open TypeLemmas hiding (_/_; var; weaken)
  private
    module Tp = TypeLemmas
    module TmTp = TermTypeLemmas
    module C  = CtxLemmas

  infixl 8 _/_

  -- Type substitutions lifted to well-typed terms
  _/_ : ∀ {m n k} {Γ : Ctx n m} {t : Term n m} {a : Type n} →
        Γ ⊢ t ∈ a → (σ : Sub Type n k) → Γ C./ σ ⊢ t TmTp./ σ ∈ a Tp./ σ
  var x             / σ = ⊢substTp (lookup-⊙ x) (var x)
  _/_ {Γ = Γ} (Λ ⊢t)  σ = Λ (⊢substCtx eq (⊢t / σ ↑))
    where
      eq : (ctx-weaken Γ) C./ (σ Tp.↑) ≡ ctx-weaken (Γ C./ σ)
      eq = begin
        (map (λ s → s tp/tp Tp.wk) Γ) C./ (σ Tp.↑)
          ≡⟨ cong (λ a → a C./ (σ Tp.↑)) (map-cong (λ a → Tp./-wk {t = a}) Γ) ⟩
        (map Tp.weaken Γ) ⊙ (σ Tp.↑)
          ≡⟨ sym $ map-weaken-⊙ Γ σ ⟩
        map Tp.weaken (Γ ⊙ σ)
          ≡⟨ (map-cong (λ a → sym $ Tp./-wk {t = a}) (Γ ⊙ σ)) ⟩
        ctx-weaken (Γ C./ σ) ∎
  λ' a ⊢t           / σ = λ' (a Tp./ σ) (⊢t / σ)
  _[_] {a = a} ⊢t b / σ = ⊢substTp (sym (sub-commutes a)) ((⊢t / σ) [ b Tp./ σ ])
  ⊢s · ⊢t           / σ = (⊢s / σ) · (⊢t / σ)

  -- Weakening of terms with additional type variables lifted to
  -- well-typed terms.
  weaken : ∀ {m n} {Γ : Ctx n m} {t : Term n m} {a : Type n} →
           Γ ⊢ t ∈ a → ctx-weaken Γ ⊢ TmTp.weaken t ∈ Tp.weaken a
  weaken {t = t} {a = a} ⊢t = ⊢subst refl (TmTp./-wk t) (/-wk {t = a}) (⊢t / wk)

  -- Weakening of terms with additional type variables lifted to
  -- collections of well-typed terms.
  weakenAll : ∀ {m n k} {Γ : Ctx n m} {ts : Vec (Term n m) k}
                {as : Vec (Type n) k} → Γ ⊢ⁿ ts ∈ as →
                ctx-weaken Γ ⊢ⁿ map TmTp.weaken ts ∈ map Tp.weaken as
  weakenAll {ts = []}    {[]}    []         = []
  weakenAll {ts = _ ∷ _} {_ ∷ _} (⊢t ∷ ⊢ts) = weaken ⊢t ∷ weakenAll ⊢ts

  -- Shorthand for single-variable type substitutions in well-typed
  -- terms.
  _[/_] : ∀ {m n} {Γ : Ctx (1 + n) m} {t a} →
          Γ ⊢ t ∈ a → (b : Type n) → Γ C./ sub b ⊢ t TmTp./ sub b ∈ a Tp./ sub b
  ⊢t [/ b ] = ⊢t / sub b

  tm[/tp]-preserves : ∀ {ν n} {Γ : Ctx ν n} {t τ} → Γ ⊢ Λ t ∈ ∀' τ → ∀ a → Γ ⊢ (t tm[/tp a ]) ∈ τ tp[/tp a ]
  tm[/tp]-preserves {Γ = Γ} {t} {τ} (Λ p) a = ctx-subst C.ctx-weaken-sub-vanishes (p / (Tp.sub a))
    where
      ctx-subst = Prelude.subst (λ c → c ⊢ t tm[/tp a ] ∈ τ tp[/tp a ])

module WtTermLemmas where
  private
    module Tp  = TypeLemmas
    module TmTp  = TermTypeLemmas
    module TmTm  = TermTermSubst
    module Var = VarSubst
    module C   = CtxLemmas
    TmSub = TmTm.TermSub Term

  infix 4 _⇒_⊢_

  -- Well-typed term substitutions are collections of well-typed terms.
  _⇒_⊢_ : ∀ {ν m k} → Ctx ν m → Ctx ν k → TmSub ν m k → Set
  Γ ⇒ Δ ⊢ ρ = Δ ⊢ⁿ ρ ∈ Γ

  infixl 8  _/_ _/Var_
  infix  10 _↑

  -- Application of term variable substitutions (renaming) lifted to
  -- well-typed terms.
  _/Var_ : ∀ {m n k} {Γ : Ctx n k} {t : Term n m} {a : Type n}
             (ρ : Sub Fin m k) → ρ C./Var Γ ⊢ t ∈ a → Γ ⊢ t TmTm./Var ρ ∈ a
  _/Var_ {Γ = Γ} ρ (var x)   =
    ⊢substTp (sym (C./Var-lookup x ρ Γ)) (var (lookup x ρ))
  _/Var_ {Γ = Γ} ρ (Λ ⊢t)    =
    Λ    (ρ      /Var ⊢substCtx (C./Var-weaken ρ Γ) ⊢t)
  _/Var_ {Γ = Γ} ρ (λ' a ⊢t) =
    λ' a (ρ Var.↑ /Var ⊢substCtx (C./Var-∷ a ρ Γ) ⊢t)
  ρ /Var (⊢t [ b ])          = (ρ /Var ⊢t) [ b ]
  ρ /Var (⊢s · ⊢t)           = (ρ /Var ⊢s) · (ρ /Var ⊢t)

  -- Weakening of terms with additional term variables lifted to
  -- well-typed terms.
  weaken : ∀ {m n} {Γ : Ctx n m} {t : Term n m} {a b : Type n} →
           Γ ⊢ t ∈ a → b ∷ Γ ⊢ TmTm.weaken t ∈ a
  weaken {Γ = Γ} {b = b} ⊢t =
    Var.wk /Var ⊢substCtx (C.wkVar-/Var-∷ Γ b) ⊢t

  -- Weakening of terms with additional term variables lifted to
  -- collections of well-typed terms.
  weakenAll : ∀ {m n k} {Γ : Ctx n m} {ts : Vec (Term n m) k}
                {as : Vec (Type n) k} {b : Type n} →
              Γ ⊢ⁿ ts ∈ as → (b ∷ Γ) ⊢ⁿ map TmTm.weaken ts ∈ as
  weakenAll {ts = []}    {[]}    []         = []
  weakenAll {ts = _ ∷ _} {_ ∷ _} (⊢t ∷ ⊢ts) = weaken ⊢t ∷ weakenAll ⊢ts

  -- Lifting of well-typed term substitutions.
  _↑ : ∀ {m n k} {Γ : Ctx n m} {Δ : Ctx n k} {ρ b} →
       Γ ⇒ Δ ⊢ ρ → b ∷ Γ ⇒ b ∷ Δ ⊢ ρ TmTm.↑
  ⊢ρ ↑ = var zero ∷ weakenAll ⊢ρ

  -- The well-typed identity substitution.
  id : ∀ {m n} {Γ : Ctx n m} → Γ ⇒ Γ ⊢ TmTm.id
  id {zero}  {Γ = []}    = []
  id {suc m} {Γ = a ∷ Γ} = id ↑

  -- Well-typed weakening (as a substitution).
  wk : ∀ {m n} {Γ : Ctx n m} {a} → Γ ⇒ a ∷ Γ ⊢ TmTm.wk
  wk = weakenAll id

  -- A well-typed substitution which only replaces the first variable.
  sub : ∀ {m n} {Γ : Ctx n m} {t a} → Γ ⊢ t ∈ a → a ∷ Γ ⇒ Γ ⊢ TmTm.sub t
  sub ⊢t = ⊢t ∷ id

  -- Application of term substitutions lifted to well-typed terms
  _/_ : ∀ {m n k} {Γ : Ctx n m} {Δ : Ctx n k} {t a ρ} →
        Γ ⊢ t ∈ a → Γ ⇒ Δ ⊢ ρ → Δ ⊢ t TmTm./ ρ ∈ a
  var x       / ⊢ρ = lookup-⊢ x ⊢ρ
  _/_ {Γ = Γ} {Δ = Δ} {ρ = ρ} (Λ ⊢t) ⊢ρ = Λ (⊢t / weaken-⊢p)
    where
      weaken-⊢p : ctx-weaken Γ ⇒ ctx-weaken Δ ⊢ map TmTp.weaken ρ
      weaken-⊢p = (Prelude.subst
        (λ G → G ⇒ ctx-weaken Δ ⊢ map TmTp.weaken ρ) Tp.map-weaken (WtTypeLemmas.weakenAll ⊢ρ))
  λ' a ⊢t     / ⊢ρ = λ' a (⊢t / ⊢ρ ↑)
  (⊢t [ a ])  / ⊢ρ = (⊢t / ⊢ρ) [ a ]
  (⊢s · ⊢t)   / ⊢ρ = (⊢s / ⊢ρ) · (⊢t / ⊢ρ)

  -- Shorthand for well-typed single-variable term substitutions.
  _[/_] : ∀ {m n} {Γ : Ctx n m} {s t a b} →
          b ∷ Γ ⊢ s ∈ a → Γ ⊢ t ∈ b → Γ ⊢ s TmTm./ TmTm.sub t ∈ a
  ⊢s [/ ⊢t ] = ⊢s / sub ⊢t

  tm[/tm]-preserves : ∀ {ν n} {Γ : Ctx ν n} {t u a b} →
                      b ∷ Γ ⊢ t ∈ a → Γ ⊢ u ∈ b → Γ ⊢ (t tm[/tm u ]) ∈ a
  tm[/tm]-preserves ⊢s ⊢t = ⊢s / sub ⊢t

open WtTypeLemmas public using ()
  renaming (weaken to ⊢tp-weaken)
open WtTermLemmas public using ()
  renaming (_/_ to _⊢/tp_; _[/_] to _⊢[/_]; weaken to ⊢weaken)


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

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

{- Finite additivity is provable (and in a stronger form) without using
 - the additivity axiom. We have

         Cⁿ(X ∨ Y) == Cⁿ(X) × Cⁿ(Y)

 - and over this path
 -   ∙ Cⁿ(winl) corresponds to fst : Cⁿ(X) × Cⁿ(Y) → Cⁿ(X),
 -   ∙ Cⁿ(winr) corresponds to snd : Cⁿ(X) × Cⁿ(Y) → Cⁿ(Y),
 -   ∙ Cⁿ(Wedge-rec winl* winr* wglue*) : Cⁿ(Z) → Cⁿ(X ∨ Y)
       corresponds to Cⁿ(winl*) × Cⁿ(winr*).
 -   ∙ Cⁿ(f) : Cⁿ(X ∨ Y) → Cⁿ(Z)
       corresponds to Cⁿ(projl ∘ f) + Cⁿ(projr ∘ f) : Cⁿ(X) × Cⁿ(Y) → Cⁿ(Z)
 -}

module cohomology.Wedge {i} (CT : CohomologyTheory i) (n : ℤ) where

open CohomologyTheory CT

module _ (X Y : Ptd i) where

  open import homotopy.WedgeCofiber X Y

  open import cohomology.PtdMapSequence CT

  private
    abstract
      βl : ∀ x → CEl-fmap n ⊙winl (CEl-fmap n (⊙projl {X = X} {Y}) x) == x
      βl = CEl-fmap-inverse n ⊙winl ⊙projl λ _ → idp

      βr : ∀ y → CEl-fmap n ⊙winr (CEl-fmap n (⊙projr {X = X} {Y}) y) == y
      βr = CEl-fmap-inverse n ⊙winr ⊙projr λ _ → idp

      C-projr-C-winl-is-exact : is-exact (C-fmap n (⊙projr {X = X} {Y})) (C-fmap n ⊙winl)
      C-projr-C-winl-is-exact = equiv-preserves'-exact
        (C-comm-square n cfcod-winl-projr-comm-sqr)
        (C-comm-square n $ comm-sqr λ _ → idp)
        (snd (C-emap n CofWinl.⊙eq))
        (C-isemap n (⊙idf _) (idf-is-equiv _))
        (C-isemap n (⊙idf _) (idf-is-equiv _))
        (C-exact n ⊙winl)

      C-projl-C-winr-is-exact : is-exact (C-fmap n (⊙projl {X = X} {Y})) (C-fmap n ⊙winr)
      C-projl-C-winr-is-exact = equiv-preserves'-exact
        (C-comm-square n cfcod-winr-projl-comm-sqr)
        (C-comm-square n $ comm-sqr λ _ → idp)
        (snd (C-emap n CofWinr.⊙eq))
        (C-isemap n (⊙idf _) (idf-is-equiv _))
        (C-isemap n (⊙idf _) (idf-is-equiv _))
        (C-exact n ⊙winr)

  import groups.ProductRepr
    (C-fmap n (⊙projl {X = X} {Y})) (C-fmap n ⊙projr)
    (C-fmap n ⊙winl) (C-fmap n ⊙winr) βl βr
    C-projl-C-winr-is-exact
    C-projr-C-winl-is-exact as PR

  C-Wedge : C n (X ⊙∨ Y) ≃ᴳ C n X ×ᴳ C n Y
  C-Wedge = PR.iso

  {-
       projl
      *-----*
   id |     | C-W
      *-----*
        inl
  -}
  C-projl-inl-comm-sqr : CommSquareᴳ
    (C-fmap n ⊙projl) ×ᴳ-inl
    (idhom _) (–>ᴳ C-Wedge)
  C-projl-inl-comm-sqr = PR.i₁-inl-comm-sqr

  {-
       projr
      *-----*
   id |     | C-W
      *-----*
        inr
  -}
  C-projr-inr-comm-sqr : CommSquareᴳ
    (C-fmap n ⊙projr) ×ᴳ-inr
    (idhom _) (–>ᴳ C-Wedge)
  C-projr-inr-comm-sqr = PR.i₂-inr-comm-sqr

  abstract
    C-Wedge-rec-comm-sqr : ∀ {Z : Ptd i} (winl* : X ⊙→ Z) (winr* : Y ⊙→ Z)
      → CommSquareᴳ
          (C-fmap n (⊙Wedge-rec winl* winr*))
          (×ᴳ-fanout (C-fmap n winl*) (C-fmap n winr*))
          (idhom _) (–>ᴳ C-Wedge)
    C-Wedge-rec-comm-sqr winl* winr* = comm-sqrᴳ λ z → pair×=
      ( ∘-CEl-fmap n ⊙winl (⊙Wedge-rec winl* winr*) z
      ∙ CEl-fmap-base-indep n (λ _ → idp) z)
      ( ∘-CEl-fmap n ⊙winr (⊙Wedge-rec winl* winr*) z
      ∙ CEl-fmap-base-indep n (λ _ → idp) z)

    C-Wedge-rec-comm-sqr' : ∀ {Z : Ptd i} (winl* : X ⊙→ Z) (winr* : Y ⊙→ Z)
      → CommSquareᴳ
          (×ᴳ-fanout (C-fmap n winl*) (C-fmap n winr*))
          (C-fmap n (⊙Wedge-rec winl* winr*))
          (idhom _) (<–ᴳ C-Wedge)
    C-Wedge-rec-comm-sqr' winl* winr* = comm-sqrᴳ λ z →
      ! (ap (GroupIso.g C-Wedge) (C-Wedge-rec-comm-sqr winl* winr* □$ᴳ z))
      ∙ GroupIso.g-f C-Wedge (CEl-fmap n (⊙Wedge-rec winl* winr*) z)

    C-Wedge-out-η-comm-sqr : {Z : Ptd i} (φ : C n (⊙Wedge X Y) →ᴳ C n Z)
      → CommSquareᴳ φ
          (×ᴳ-fanin (C-is-abelian n _) (φ ∘ᴳ C-fmap n ⊙projl)
                                       (φ ∘ᴳ C-fmap n ⊙projr))
          (–>ᴳ C-Wedge) (idhom _)
    C-Wedge-out-η-comm-sqr φ = comm-sqrᴳ λ x∨y →
        ap (GroupHom.f φ) (! (GroupIso.g-f C-Wedge x∨y))
      ∙ ! (×ᴳ-fanin-pre∘ (C-is-abelian n _) (C-is-abelian n _)
             φ (C-fmap n ⊙projl) (C-fmap n ⊙projr) _)

    C-Wedge-out-η-comm-sqr' : {Z : Ptd i} (φ : C n (⊙Wedge X Y) →ᴳ C n Z)
      → CommSquareᴳ
          (×ᴳ-fanin (C-is-abelian n _) (φ ∘ᴳ C-fmap n ⊙projl)
                                       (φ ∘ᴳ C-fmap n ⊙projr))
          φ (<–ᴳ C-Wedge) (idhom _)
    C-Wedge-out-η-comm-sqr' {Z} φ = comm-sqrᴳ λ z →
      ×ᴳ-fanin-pre∘ (C-is-abelian n _) (C-is-abelian n _)
        φ (C-fmap n ⊙projl) (C-fmap n ⊙projr) _

    C-Wedge-in-comm-sqr : {Z : Ptd i} (f : Z ⊙→ ⊙Wedge X Y)
      → CommSquareᴳ (C-fmap n f)
          (×ᴳ-fanin (C-is-abelian n _) (C-fmap n (⊙projl ⊙∘ f))
                                       (C-fmap n (⊙projr ⊙∘ f)))
          (–>ᴳ C-Wedge) (idhom _)
    C-Wedge-in-comm-sqr f = comm-sqrᴳ λ x∨y →
        (C-Wedge-out-η-comm-sqr (C-fmap n f) □$ᴳ x∨y)
      ∙ ap2 (Group.comp (C n _))
          (∘-C-fmap n f ⊙projl _)
          (∘-C-fmap n f ⊙projr _)

    C-Wedge-in-comm-sqr' : {Z : Ptd i} (f : Z ⊙→ ⊙Wedge X Y)
      → CommSquareᴳ
          (×ᴳ-fanin (C-is-abelian n _) (C-fmap n (⊙projl ⊙∘ f))
                                       (C-fmap n (⊙projr ⊙∘ f)))
          (C-fmap n f) (<–ᴳ C-Wedge) (idhom _)
    C-Wedge-in-comm-sqr' f = comm-sqrᴳ λ z →
        ap2 (Group.comp (C n _))
          (C-fmap-∘ n ⊙projl f _)
          (C-fmap-∘ n ⊙projr f _)
      ∙ (C-Wedge-out-η-comm-sqr' (C-fmap n f) □$ᴳ z)

module _ (X : Ptd i) where

  abstract
    C-fold-comm-sqr : CommSquareᴳ
      (C-fmap n ⊙fold) ×ᴳ-diag
      (idhom (C n X)) (–>ᴳ (C-Wedge X X))
    C-fold-comm-sqr = comm-sqrᴳ λ x →
      GroupIso.f (C-Wedge X X) (CEl-fmap n ⊙fold x)
        =⟨ C-Wedge-rec-comm-sqr X X (⊙idf X) (⊙idf X) □$ᴳ x ⟩
      (CEl-fmap n (⊙idf X) x , CEl-fmap n (⊙idf X) x)
        =⟨ pair×= (CEl-fmap-idf n x) (CEl-fmap-idf n x) ⟩
      (x , x)
        =∎

    C-fold-comm-sqr' : CommSquareᴳ
      ×ᴳ-diag (C-fmap n ⊙fold)
      (idhom (C n X)) (<–ᴳ (C-Wedge X X))
    C-fold-comm-sqr' = comm-sqrᴳ λ x →
      ! (ap (GroupIso.g (C-Wedge X X)) (C-fold-comm-sqr □$ᴳ x))
      ∙ GroupIso.g-f (C-Wedge X X) (CEl-fmap n ⊙fold x)


open import ExtractSac as ES using ()
open import Extract (ES.kompile-fun)

open import Data.Nat as N using (ℕ; zero; suc; _≤_; _≥_; _<_; _>_; s≤s; z≤n; _∸_)
import      Data.Nat.DivMod as N
open import Data.Nat.Properties as N
open import Data.List as L using (List; []; _∷_)
open import Data.Vec as V using (Vec; []; _∷_)
import      Data.Vec.Properties as V
open import Data.Fin as F using (Fin; zero; suc; #_)
import      Data.Fin.Properties as F
open import Data.Product as Prod using (Σ; _,_; curry; uncurry) renaming (_×_ to _×ₜ_)
open import Data.String

open import Relation.Binary.PropositionalEquality

open import Structures
open import Function

open import Array.Base
open import Array.Properties

open import APL2
open import Agda.Builtin.Float

open import Reflection
open import ReflHelper

pattern I0 = (zero ∷ [])
pattern I1 = (suc zero ∷ [])
pattern I2 = (suc (suc zero) ∷ [])
pattern I3 = (suc (suc (suc zero)) ∷ [])

-- backin←{(d w in)←⍵⋄⊃+/,w{(⍴in)↑(-⍵+⍴d)↑⍺×d}¨⍳⍴w}
backin : ∀ {n s s₁} → (inp : Ar Float n s)
                     → (w : Ar Float n s₁)
                     → {≥ : ▴ s ≥a ▴ s₁}
                     → (d : Ar Float n $ ▾ ((s - s₁){≥} + 1))
                     → Ar Float n s
backin {n}{s}{s₁} inp w d = let
      ixs = ι ρ w
      use-ixs i,pf = let
        i , pf = i,pf
        iv = a→ix i (ρ w) pf
        wᵢ = sel w (subst-ix (λ i → V.lookup∘tabulate _ i) iv)
        --x = pre-pad i 0.0 (d ×ᵣ wᵢ)
        x = (i + ρ d) -↑⟨ 0.0 ⟩ (d ×ᵣ wᵢ)
        y = (ρ inp) ↑⟨ 0.0 ⟩ x
        in y
      s = reduce-1d _+ᵣ_ (cst 0.0) (, use-ixs ̈ ixs)
  in subst-ar (λ i → V.lookup∘tabulate _ i) s

kbin = kompile backin (quote _≥a_ ∷ quote reduce-1d ∷ quote _↑⟨_⟩_ ∷ quote _-↑⟨_⟩_ ∷ quote a→ix ∷ []) []
rkbin = frefl backin (quote _≥a_ ∷ quote reduce-1d ∷ quote _↑⟨_⟩_ ∷ quote _-↑⟨_⟩_ ∷ quote a→ix ∷ [])

fin-id : ∀ {n} → Fin n → Fin n
fin-id x = x

s-w+1≤s : ∀ {s w} → s ≥ w → s > 0 → w > 0 → s N.∸ w N.+ 1 ≤ s
s-w+1≤s {suc s} {suc w} (s≤s s≥w) s>0 w>0 rewrite (+-comm (s ∸ w) 1) = s≤s (m∸n≤m s w)
helper : ∀ {n} {sI sw : Vec ℕ n}
       → s→a sI ≥a s→a sw
       → (cst 0) <a s→a sI
       → (cst 0) <a s→a sw
       → (iv : Ix 1 (n ∷ []))
       → V.lookup sI (ix-lookup iv zero) ≥
         V.lookup (V.tabulate (λ i → V.lookup sI i ∸ V.lookup sw i N.+ 1))
         (ix-lookup iv zero)
helper {sI = sI} {sw} sI≥sw sI>0 sw>0 (x ∷ [])
       rewrite (V.lookup∘tabulate (λ i → V.lookup sI i ∸ V.lookup sw i N.+ 1) x) =
       s-w+1≤s (sI≥sw (x ∷ [])) (sI>0 (x ∷ [])) (sw>0 (x ∷ []))

a≤b⇒b≡c⇒a≤c : ∀ {a b c} → a ≤ b → b ≡ c → a ≤ c
a≤b⇒b≡c⇒a≤c a≤b refl = a≤b
-- sI - (sI - sw + 1) + 1 = sw
shape-same : ∀ {n} {sI sw : Vec ℕ n}
           → s→a sI ≥a s→a sw
           → (cst 0) <a s→a sI
           → (cst 0) <a s→a sw
           → (i : Fin n)
           → V.lookup
             (V.tabulate
              (λ i₁ →
                 V.lookup sI i₁ ∸
                 V.lookup (V.tabulate (λ i₂ → V.lookup sI i₂ ∸ V.lookup sw i₂ N.+ 1)) i₁
                 N.+ 1))
             i
             ≡ V.lookup sw i
shape-same {suc n} {x ∷ sI} {y ∷ sw} I≥w I>0 w>0 zero =
  begin
    x ∸ (x ∸ y N.+ 1) N.+ 1 ≡⟨ sym $ +-∸-comm  {m = x} 1 {o = (x ∸ y N.+ 1)}  (s-w+1≤s (I≥w I0) (I>0 I0) (w>0 I0)) ⟩
    x N.+ 1 ∸ (x ∸ y N.+ 1) ≡⟨ cong (x N.+ 1 ∸_) (sym $ +-∸-comm {m = x} 1 {o = y} (I≥w I0)) ⟩
    x N.+ 1 ∸ (x N.+ 1 ∸ y) ≡⟨ m∸[m∸n]≡n {m = x N.+ 1} {n = y} (a≤b⇒b≡c⇒a≤c (≤-step $ I≥w I0) (+-comm 1 x)) ⟩
    y
  ∎
  where open ≡-Reasoning
shape-same {suc n} {x ∷ sI} {x₁ ∷ sw} I≥w I>0 w>0 (suc i) =
  shape-same {sI = sI} {sw = sw} (λ { (i ∷ []) → I≥w (suc i ∷ []) })
                                 (λ { (i ∷ []) → I>0 (suc i ∷ []) })
                                 (λ { (i ∷ []) → w>0 (suc i ∷ []) }) i

{-backmulticonv ← {
  (d_out weights in bias) ← ⍵
  d_in ← +⌿d_out {backin ⍺ ⍵ in} ⍤((⍴⍴in), (⍴⍴in)) ⊢ weights
  d_w ← {⍵ conv in} ⍤(⍴⍴in) ⊢ d_out
  d_bias ← backbias ⍤(⍴⍴in) ⊢ d_out
  d_in d_w d_bias
}-}
backmulticonv : ∀ {n m}{sI sw so}
              → (W : Ar (Ar Float n sw) m so)
              → (I : Ar Float n sI)
              → (B : Ar Float m so)
                -- We can get rid of these two expressions if we rewrite
                -- the convolution to accept s+1 ≥ w, and not s ≥ w.
              → {>I : (cst 0) <a s→a sI}
              → {>w : (cst 0) <a s→a sw}
              → {≥ : s→a sI ≥a s→a sw}
              → (δo : Ar (Ar Float n (a→s $ (s→a sI - s→a sw) {≥} + 1)) m so)
              → {- (typeOf W) ×ₜ-}  (typeOf I) --×ₜ (typeOf B)
backmulticonv {n} {sI = sI} {sw} {so} W I B {sI>0} {sw>0} {sI≥sw} δo = let
    δI = reduce-1d _+ᵣ_ (cst 0.0) (, (W ̈⟨ (λ x y → backin I x {sI≥sw} y) ⟩ δo))
    {-
    δW = (λ x → (x conv I) {≥ = λ { iv@(i ∷ []) → subst₂ _≤_ (sym $ V.lookup∘tabulate _ i) refl
                                                  $ s-w+1≤s (sI≥sw iv) (sI>0 iv) (sw>0 iv) } }) ̈ δo
    δB = backbias ̈ δo
    -}
  in --(imap (λ iv → subst-ar (shape-same {sI = sI} {sw = sw} sI≥sw sI>0 sw>0) (sel δW iv)) ,
     δI {-,
     imap (λ iv → ▾ (sel δB iv))) -}
  where open import Example-04
        open import Example-03

kbckmconv = kompile backmulticonv (quote _≥a_ ∷ quote _<a_ ∷ quote reduce-1d ∷ quote _↑⟨_⟩_ ∷ quote _-↑⟨_⟩_ ∷ quote a→ix ∷ quote _conv_ ∷ []) []
  where open import Example-04

conv-fns : List (String ×ₜ Name)
conv-fns = ("blog" , quote blog)
         ∷ ("backbias" , quote backbias)
         ∷ ("logistic" , quote logistic)
         ∷ ("meansqerr" , quote meansqerr)
         ∷ ("backavgpool" , quote backavgpool)
         ∷ ("avgpool" , quote avgpool)
         ∷ ("conv" , quote _conv_)
         ∷ ("multiconv" , quote multiconv)
         ∷ ("backin", quote backin)
         ∷ ("backmulticonv" , quote backmulticonv)
         ∷ []
  where open import Example-03
        open import Example-04

--   * test-zhang
--   * train-zhang


{- Copyright © 1992–2002 The University of Glasgow
Copyright © 2015 Benjamin Barenblat

Licensed under the Apache License, Version 2.0 (the ‘License’); you may not use
this file except in compliance with the License.  You may obtain a copy of the
License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software distributed
under the License is distributed on an ‘AS IS’ BASIS, WITHOUT WARRANTIES OR
CONDITIONS OF ANY KIND, either express or implied.  See the License for the
specific language governing permissions and limitations under the License. -}

module B.Prelude.Functor where

import Category.Monad as Monad
import Category.Functor
import Data.List
import Data.Maybe
open import Function using (_∘_)

open Category.Functor
  using (RawFunctor)
  public

open Category.Functor.RawFunctor ⦃...⦄
  using (_<$>_)
  public

instance
  Functor-List : ∀ {ℓ} → RawFunctor (Data.List.List {ℓ})
  Functor-List = Monad.RawMonad.rawFunctor Data.List.monad

  Functor-Maybe : ∀ {ℓ} → RawFunctor (Data.Maybe.Maybe {ℓ})
  Functor-Maybe = Monad.RawMonad.rawFunctor Data.Maybe.monad

  Functor-Function : ∀ {ℓ} {r : Set ℓ} → RawFunctor {ℓ} (λ s → (r → s))
  Functor-Function {r} =
    -- I could say _<$>_ = _∘_ here, but that makes type checking much more
    -- challenging.
    record { _<$>_ = λ f g → f ∘ g }

  -- TODO: Do proper instance for dependent pairs


{-# OPTIONS --without-K #-}
{-# OPTIONS --type-in-type #-}
module pisearch where
open import Type hiding (★_)
open import Function.NP
open import Data.Product
open import Data.Sum
open import Data.Bool.NP
open import Search.Type
open import Search.Searchable.Product
open import Search.Searchable
open import sum

fromFun-searchInd : ∀ {A} {sA : Search A} → SearchInd sA → FromFun sA
fromFun-searchInd indA = indA (λ s → Data s _) _,_

open import Relation.Binary.PropositionalEquality hiding ([_])
ToFrom : ∀ {A} (sA : Search A)
           (toFunA : ToFun sA)
           (fromFunA : FromFun sA)
         → ★
ToFrom {A} sA toFunA fromFunA = ∀ {B} (f : Π A B) x → toFunA (fromFunA f) x ≡ f x

FromTo : ∀ {A} (sA : Search A)
           (toFunA : ToFun sA)
           (fromFunA : FromFun sA)
         → ★
FromTo sA toFunA fromFunA = ∀ {B} (d : Data sA B) → fromFunA (toFunA d) ≡ d

module Σ-props {A} {B : A → ★}
                (μA : Searchable A) (μB : ∀ {x} → Searchable (B x)) where
    sA = search μA
    sB : ∀ {x} → Search (B x)
    sB {x} = search (μB {x})
    fromFunA : FromFun sA
    fromFunA = fromFun-searchInd (search-ind μA)
    fromFunB : ∀ {x} → FromFun (sB {x})
    fromFunB {x} = fromFun-searchInd (search-ind (μB {x}))
    module ToFrom
             (toFunA : ToFun sA)
             (toFunB : ∀ {x} → ToFun (sB {x}))
             (toFromA : ToFrom sA toFunA fromFunA)
             (toFromB : ∀ {x} → ToFrom (sB {x}) toFunB fromFunB) where
        toFrom-Σ : ToFrom (ΣSearch sA (λ {x} → sB {x})) (toFun-Σ sA sB toFunA toFunB) (fromFun-Σ sA sB fromFunA fromFunB)
        toFrom-Σ f (x , y) rewrite toFromA (fromFunB ∘ curry f) x = toFromB (curry f x) y

    {- we need a search-ind-ext...
    module FromTo
                 (toFunA : ToFun sA)
                 (toFunB : ∀ {x} → ToFun (sB {x}))
                 (toFromA : FromTo sA toFunA fromFunA)
                 (toFromB : ∀ {x} → FromTo (sB {x}) toFunB fromFunB) where
        toFrom-Σ : FromTo (ΣSearch sA (λ {x} → sB {x})) (toFun-Σ sA sB toFunA toFunB) (fromFun-Σ sA sB fromFunA fromFunB)
        toFrom-Σ t = {!toFromA!} -- {!(λ x → toFromB (toFunA t x))!}
    -}

toFun-× : ∀ {A B} (sA : Search A) (sB : Search B) → ToFun sA → ToFun sB → ToFun (sA ×Search sB)
toFun-× sA sB toFunA toFunB = toFun-Σ sA sB toFunA toFunB

fromFun-× : ∀ {A B} (sA : Search A) (sB : Search B) → FromFun sA → FromFun sB → FromFun (sA ×Search sB)
fromFun-× sA sB fromFunA fromFunB = fromFun-Σ sA sB fromFunA fromFunB

toFun-Bit : ToFun (search μBit)
toFun-Bit (f , t) false = f
toFun-Bit (f , t) true  = t

fromFun-Bit : FromFun (search μBit)
fromFun-Bit f = f false , f true

toFun-⊎ : ∀ {A B} (sA : Search A) (sB : Search B) → ToFun sA → ToFun sB → ToFun (sA +Search sB)
toFun-⊎ sA sB toFunA toFunB (x , y) = [ toFunA x , toFunB y ]

fromFun-⊎ : ∀ {A B} (sA : Search A) (sB : Search B) → FromFun sA → FromFun sB → FromFun (sA +Search sB)
fromFun-⊎ sA sB fromFunA fromFunB f = fromFunA (f ∘ inj₁) , fromFunB (f ∘ inj₂)

toPair-searchInd : ∀ {A} {sA : Search A} → SearchInd sA → ToPair sA
toPair-searchInd indA = indA ToPair (λ P0 P1 → [ P0 , P1 ]) (λ η → _,_ η)

-- toFun-searchInd : ∀ {A} {sA : Search A} → SearchInd sA → ToFun sA
-- toFun-searchInd {A} {sA} indA {B} t = ?