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

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

module Number.Inclusions where

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Relation.Nullary.Base -- ¬_
open import Cubical.Relation.Binary.Base -- Rel

-- open import Data.Nat.Base using (ℕ) renaming (_≤_ to _≤ₙ_)
open import Cubical.Data.Nat using (ℕ; zero; suc) renaming (_+_ to _+ₙ_)
open import Cubical.Data.Nat.Order renaming (zero-≤ to z≤n; suc-≤-suc to s≤s; _≤_ to _≤ₙ_; _<_ to _<ₙ_)

open import Cubical.Data.Unit.Base -- Unit
open import Cubical.Data.Empty -- ⊥
open import Cubical.Data.Sum.Base renaming (_⊎_ to infixr 4 _⊎_)
open import Cubical.Data.Sigma.Base renaming (_×_ to infixr 4 _×_)
open import Cubical.Data.Empty renaming (elim to ⊥-elim) -- `⊥` and `elim`
open import Cubical.Data.Maybe.Base

-- open import Number.Structures ℝℓ ℝℓ'
open import Number.Bundles

-- Finₖ ℕ ℤ ℚ ℚ₀⁺ ℚ⁺ ℝ ℝ₀⁺ ℝ⁺
record IsRLatticeInclusion
  {ℓ ℓ' ℓₚ ℓₚ'}
  (F : RLattice {ℓ} {ℓₚ}) (G : RLattice {ℓ'} {ℓₚ'})
  (f : (RLattice.Carrier F) → (RLattice.Carrier G)) : Type (ℓ-max (ℓ-max ℓ ℓ') (ℓ-max ℓₚ ℓₚ'))
  where
  private
    module F = RLattice F
    module G = RLattice G
  field
    -- injectivity? might follow from preserves-#?
    reflects-≡    : ∀ x y → f x   ≡ f y →   x ≡     y
    -- lattice
    preserves-<   : ∀ x y →   x F.<   y → f x G.< f y
    preserves-≤   : ∀ x y →   x F.≤   y → f x G.≤ f y
    preserves-#   : ∀ x y →   x F.#   y → f x G.# f y
    reflects-<    : ∀ x y → f x G.< f y →   x F.<   y
    reflects-≤    : ∀ x y → f x G.≤ f y →   x F.≤   y
    reflects-#    : ∀ x y → f x G.# f y →   x F.#   y
    preserves-min : ∀ x y → f (F.min x y) ≡ G.min (f x) (f y)
    preserves-max : ∀ x y → f (F.max x y) ≡ G.max (f x) (f y)

-- ℕ ℤ ℚ ℚ₀⁺ ℚ⁺ ℝ ℝ₀⁺ ℝ⁺
-- ring without additive inverse
record IsROrderedCommSemiringInclusion
  {ℓ ℓ' ℓₚ ℓₚ'}
  (F : ROrderedCommSemiring {ℓ} {ℓₚ}) (G : ROrderedCommSemiring {ℓ'} {ℓₚ'})
  (f : (ROrderedCommSemiring.Carrier F) → (ROrderedCommSemiring.Carrier G)) : Type (ℓ-max (ℓ-max ℓ ℓ') (ℓ-max ℓₚ ℓₚ'))
  where
  private
    module F = ROrderedCommSemiring F
    module G = ROrderedCommSemiring G
  field
    isRLatticeInclusion : IsRLatticeInclusion (record {F}) (record {G}) f
    preserves-0   :         f  F.0f       ≡ G.0f
    preserves-1   :         f  F.1f       ≡ G.1f
    preserves-+   : ∀ x y → f (x F.+ y)   ≡ f x G.+  f y
    preserves-·   : ∀ x y → f (x F.· y)   ≡ f x G.·  f y
  open IsRLatticeInclusion isRLatticeInclusion public

  preserves-#0 : ∀ x →   x  F.# F.0f → f x  G.# G.0f
  preserves-0≤ : ∀ x → F.0f F.≤   x  → G.0f G.≤ f x
  preserves-0< : ∀ x → F.0f F.<   x  → G.0f G.< f x
  preserves-<0 : ∀ x →   x  F.< F.0f → f x  G.< G.0f
  preserves-≤0 : ∀ x →   x  F.≤ F.0f → f x  G.≤ G.0f

  preserves-#0 x q = transport (λ i → f x G.# preserves-0 i) (preserves-# _ _ q)
  preserves-0≤ x q = transport (λ i → preserves-0 i G.≤ f x) (preserves-≤ _ _ q)
  preserves-0< x q = transport (λ i → preserves-0 i G.< f x) (preserves-< _ _ q)
  preserves-<0 x q = transport (λ i → f x G.< preserves-0 i) (preserves-< _ _ q)
  preserves-≤0 x q = transport (λ i → f x G.≤ preserves-0 i) (preserves-≤ _ _ q)

-- ℤ ℚ ℝ
record IsROrderedCommRingInclusion
  {ℓ ℓ' ℓₚ ℓₚ'}
  (F : ROrderedCommRing {ℓ} {ℓₚ}) (G : ROrderedCommRing {ℓ'} {ℓₚ'})
  (f : (ROrderedCommRing.Carrier F) → (ROrderedCommRing.Carrier G)) : Type (ℓ-max (ℓ-max ℓ ℓ') (ℓ-max ℓₚ ℓₚ'))
  where
  private
    module F = ROrderedCommRing F
    module G = ROrderedCommRing G
  field
    isROrderedCommSemiringInclusion : IsROrderedCommSemiringInclusion (record {F}) (record {G}) f
    preserves-    : ∀ x   → f (  F.- x)   ≡     G.- (f x)
  open IsROrderedCommSemiringInclusion isROrderedCommSemiringInclusion public

-- ℚ ℝ
record IsROrderedFieldInclusion
  {ℓ ℓ' ℓₚ ℓₚ'}
  (F : ROrderedField {ℓ} {ℓₚ}) (G : ROrderedField {ℓ'} {ℓₚ'})
  (f : (ROrderedField.Carrier F) → (ROrderedField.Carrier G)) : Type (ℓ-max (ℓ-max ℓ ℓ') (ℓ-max ℓₚ ℓₚ'))
  where
  private
    module F = ROrderedField F
    module G = ROrderedField G
  field
    isROrderedCommRingInclusion : IsROrderedCommRingInclusion (record {F}) (record {G}) f
    preserves-⁻¹  : ∀ x → (p : x F.# F.0f) → (q : f x G.# G.0f) → f (F._⁻¹ x {{p}}) ≡ G._⁻¹ (f x) {{q}}
  open IsROrderedCommRingInclusion isROrderedCommRingInclusion public

-- ℚ ℝ ℂ
record IsRFieldInclusion
  {ℓ ℓ' ℓₚ ℓₚ'}
  (F : RField {ℓ} {ℓₚ}) (G : RField {ℓ'} {ℓₚ'})
  (f : (RField.Carrier F) → (RField.Carrier G)) : Type (ℓ-max (ℓ-max ℓ ℓ') (ℓ-max ℓₚ ℓₚ'))
  where
  private
    module F = RField F
    module G = RField G
  field
    -- CommSemiringInclusion
    preserves-0   :         f  F.0f       ≡ G.0f
    preserves-1   :         f  F.1f       ≡ G.1f
    preserves-+   : ∀ x y → f (x F.+ y)   ≡ f x G.+  f y
    preserves-·   : ∀ x y → f (x F.· y)   ≡ f x G.·  f y
    -- other
    reflects-≡    : ∀ x y → f x   ≡ f y →   x ≡     y
    preserves-#   : ∀ x y →   x F.#   y → f x G.# f y
    reflects-#    : ∀ x y → f x G.# f y →   x F.#   y
    -- TODO: properties

  preserves-#0 : ∀ x →   x  F.# F.0f → f x  G.# G.0f
  preserves-#0 x q = transport (λ i → f x G.# preserves-0 i) (preserves-# _ _ q)

-- ℕ ℤ ℚ ℝ ℂ
record IsRCommSemiringInclusion
  {ℓ ℓ' ℓₚ ℓₚ'}
  (F : RCommSemiring {ℓ} {ℓₚ}) (G : RCommSemiring {ℓ'} {ℓₚ'})
  (f : (RCommSemiring.Carrier F) → (RCommSemiring.Carrier G)) : Type (ℓ-max (ℓ-max ℓ ℓ') (ℓ-max ℓₚ ℓₚ'))
  where
  private
    module F = RCommSemiring F
    module G = RCommSemiring G
  field
    -- CommSemiringInclusion
    preserves-0   :         f  F.0f       ≡ G.0f
    preserves-1   :         f  F.1f       ≡ G.1f
    preserves-+   : ∀ x y → f (x F.+ y)   ≡ f x G.+  f y
    preserves-·   : ∀ x y → f (x F.· y)   ≡ f x G.·  f y
    -- other
    reflects-≡    : ∀ x y → f x   ≡ f y →   x ≡     y
    preserves-#   : ∀ x y →   x F.#   y → f x G.# f y
    reflects-#    : ∀ x y → f x G.# f y →   x F.#   y
    -- TODO: properties

-- ℤ ℚ ℝ ℂ
record IsRCommRingInclusion
  {ℓ ℓ' ℓₚ ℓₚ'}
  (F : RCommRing {ℓ} {ℓₚ}) (G : RCommRing {ℓ'} {ℓₚ'})
  (f : (RCommRing.Carrier F) → (RCommRing.Carrier G)) : Type (ℓ-max (ℓ-max ℓ ℓ') (ℓ-max ℓₚ ℓₚ'))
  where
  private
    module F = RCommRing F
    module G = RCommRing G
  field
    -- CommSemiringInclusion
    preserves-0   :         f  F.0f       ≡ G.0f
    preserves-1   :         f  F.1f       ≡ G.1f
    preserves-+   : ∀ x y → f (x F.+ y)   ≡ f x G.+  f y
    preserves-·   : ∀ x y → f (x F.· y)   ≡ f x G.·  f y
    -- other
    reflects-≡    : ∀ x y → f x   ≡ f y →   x ≡     y
    preserves-#   : ∀ x y →   x F.#   y → f x G.# f y
    reflects-#    : ∀ x y → f x G.# f y →   x F.#   y
    -- TODO: properties


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of membership of vectors based on propositional equality.
------------------------------------------------------------------------

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

module Data.Vec.Membership.Propositional.Properties where

open import Data.Fin.Base using (Fin; zero; suc)
open import Data.Product as Prod using (_,_; ∃; _×_; -,_)
open import Data.Vec hiding (here; there)
open import Data.Vec.Relation.Unary.Any using (here; there)
open import Data.List.Base using ([]; _∷_)
open import Data.List.Relation.Unary.Any using (here; there)
open import Data.Vec.Relation.Unary.Any using (Any; here; there)
open import Data.Vec.Membership.Propositional
open import Data.List.Membership.Propositional
  using () renaming (_∈_ to _∈ₗ_)
open import Level using (Level)
open import Function using (_∘_; id)
open import Relation.Unary using (Pred)
open import Relation.Binary.PropositionalEquality using (refl)

private
  variable
    a b p : Level
    A : Set a
    B : Set b

------------------------------------------------------------------------
-- lookup

∈-lookup : ∀ {n} i (xs : Vec A n) → lookup xs i ∈ xs
∈-lookup zero    (x ∷ xs) = here refl
∈-lookup (suc i) (x ∷ xs) = there (∈-lookup i xs)

------------------------------------------------------------------------
-- map

∈-map⁺ : (f : A → B) → ∀ {m v} {xs : Vec A m} → v ∈ xs → f v ∈ map f xs
∈-map⁺ f (here refl)  = here refl
∈-map⁺ f (there x∈xs) = there (∈-map⁺ f x∈xs)

------------------------------------------------------------------------
-- _++_

∈-++⁺ˡ : ∀ {m n v} {xs : Vec A m} {ys : Vec A n} → v ∈ xs → v ∈ xs ++ ys
∈-++⁺ˡ (here refl)  = here refl
∈-++⁺ˡ (there x∈xs) = there (∈-++⁺ˡ x∈xs)

∈-++⁺ʳ : ∀ {m n v} (xs : Vec A m) {ys : Vec A n} → v ∈ ys → v ∈ xs ++ ys
∈-++⁺ʳ []       x∈ys = x∈ys
∈-++⁺ʳ (x ∷ xs) x∈ys = there (∈-++⁺ʳ xs x∈ys)

------------------------------------------------------------------------
-- tabulate

∈-tabulate⁺ : ∀ {n} (f : Fin n → A) i → f i ∈ tabulate f
∈-tabulate⁺ f zero    = here refl
∈-tabulate⁺ f (suc i) = there (∈-tabulate⁺ (f ∘ suc) i)

------------------------------------------------------------------------
-- allFin

∈-allFin⁺ : ∀ {n} (i : Fin n) → i ∈ allFin n
∈-allFin⁺ = ∈-tabulate⁺ id

------------------------------------------------------------------------
-- allPairs

∈-allPairs⁺ : ∀ {m n x y} {xs : Vec A m} {ys : Vec B n} →
             x ∈ xs → y ∈ ys → (x , y) ∈ allPairs xs ys
∈-allPairs⁺ {xs = x ∷ xs} (here refl)  = ∈-++⁺ˡ ∘ ∈-map⁺ (x ,_)
∈-allPairs⁺ {xs = x ∷ _}  (there x∈xs) =
  ∈-++⁺ʳ (map (x ,_) _) ∘ ∈-allPairs⁺ x∈xs

------------------------------------------------------------------------
-- toList

∈-toList⁺ : ∀ {n} {v : A} {xs : Vec A n} → v ∈ xs → v ∈ₗ toList xs
∈-toList⁺ (here refl) = here refl
∈-toList⁺ (there x∈)  = there (∈-toList⁺ x∈)

∈-toList⁻ : ∀ {n} {v : A} {xs : Vec A n} → v ∈ₗ toList xs → v ∈ xs
∈-toList⁻ {xs = x ∷ xs} (here refl)  = here refl
∈-toList⁻ {xs = x ∷ xs} (there v∈xs) = there (∈-toList⁻ v∈xs)

------------------------------------------------------------------------
-- fromList

∈-fromList⁺ : ∀ {v : A} {xs} → v ∈ₗ xs → v ∈ fromList xs
∈-fromList⁺ (here refl) = here refl
∈-fromList⁺ (there x∈)  = there (∈-fromList⁺ x∈)

∈-fromList⁻ : ∀ {v : A} {xs} → v ∈ fromList xs → v ∈ₗ xs
∈-fromList⁻ {xs = _ ∷ _} (here refl)  = here refl
∈-fromList⁻ {xs = _ ∷ _} (there v∈xs) = there (∈-fromList⁻ v∈xs)

------------------------------------------------------------------------
-- Relationship to Any

module _ {P : Pred A p} where

  fromAny : ∀ {n} {xs : Vec A n} → Any P xs → ∃ λ x → x ∈ xs × P x
  fromAny (here px) = -, here refl , px
  fromAny (there v) = Prod.map₂ (Prod.map₁ there) (fromAny v)

  toAny : ∀ {n x} {xs : Vec A n} → x ∈ xs → P x → Any P xs
  toAny (here refl) px = here px
  toAny (there v)   px = there (toAny v px)


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

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

module Codata.Colist where

open import Level using (Level)
open import Size
open import Data.Unit
open import Data.Nat.Base
open import Data.Product using (_×_ ; _,_)
open import Data.These.Base using (These; this; that; these)
open import Data.Maybe.Base using (Maybe; nothing; just)
open import Data.List.Base using (List; []; _∷_)
open import Data.List.NonEmpty as List⁺ using (List⁺; _∷_)
open import Data.Vec.Base as Vec using (Vec; []; _∷_)
open import Data.Vec.Bounded as Vec≤ using (Vec≤)
open import Function

open import Codata.Thunk using (Thunk; force)
open import Codata.Conat as Conat using (Conat ; zero ; suc)
open import Codata.Cowriter as CW using (Cowriter; _∷_)
open import Codata.Delay as Delay using (Delay ; now ; later)
open import Codata.Stream using (Stream ; _∷_)

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

private
  variable
    a b c w : Level
    i : Size
    A : Set a
    B : Set b
    C : Set c
    W : Set w

data Colist (A : Set a) (i : Size) : Set a where
  []  : Colist A i
  _∷_ : A → Thunk (Colist A) i → Colist A i

------------------------------------------------------------------------
-- Relationship to Cowriter.

fromCowriter : Cowriter W A i → Colist W i
fromCowriter CW.[ _ ] = []
fromCowriter (w ∷ ca) = w ∷ λ where .force → fromCowriter (ca .force)

toCowriter : Colist A i → Cowriter A ⊤ i
toCowriter []       = CW.[ _ ]
toCowriter (a ∷ as) = a ∷ λ where .force → toCowriter (as .force)

------------------------------------------------------------------------
-- Basic functions.

[_] : A → Colist A ∞
[ a ] = a ∷ λ where .force → []

length : Colist A i → Conat i
length []       = zero
length (x ∷ xs) = suc λ where .force → length (xs .force)

replicate : Conat i → A → Colist A i
replicate zero    a = []
replicate (suc n) a = a ∷ λ where .force → replicate (n .force) a

infixr 5 _++_ _⁺++_
_++_ : Colist A i → Colist A i → Colist A i
[]       ++ ys = ys
(x ∷ xs) ++ ys = x ∷ λ where .force → xs .force ++ ys

lookup : ℕ → Colist A ∞ → Maybe A
lookup n       []       = nothing
lookup zero    (a ∷ as) = just a
lookup (suc n) (a ∷ as) = lookup n (as .force)

colookup : Conat i → Colist A i → Delay (Maybe A) i
colookup n       []       = now nothing
colookup zero    (a ∷ as) = now (just a)
colookup (suc n) (a ∷ as) =
  later λ where .force → colookup (n .force) (as .force)

take : (n : ℕ) → Colist A ∞ → Vec≤ A n
take zero    xs       = Vec≤.[]
take n       []       = Vec≤.[]
take (suc n) (x ∷ xs) = x Vec≤.∷ take n (xs .force)

cotake : Conat i → Stream A i → Colist A i
cotake zero    xs       = []
cotake (suc n) (x ∷ xs) = x ∷ λ where .force → cotake (n .force) (xs .force)

drop : ℕ → Colist A ∞ → Colist A ∞
drop zero    xs       = xs
drop (suc n) []       = []
drop (suc n) (x ∷ xs) = drop n (xs .force)

fromList : List A → Colist A ∞
fromList []       = []
fromList (x ∷ xs) = x ∷ λ where .force → fromList xs

fromList⁺ : List⁺ A → Colist A ∞
fromList⁺ = fromList ∘′ List⁺.toList

_⁺++_ : List⁺ A → Thunk (Colist A) i → Colist A i
(x ∷ xs) ⁺++ ys = x ∷ λ where .force → fromList xs ++ ys .force

concat : Colist (List⁺ A) i → Colist A i
concat []         = []
concat (as ∷ ass) = as ⁺++ λ where .force → concat (ass .force)

fromStream : Stream A i → Colist A i
fromStream = cotake Conat.infinity

module ChunksOf (n : ℕ) where

  chunksOf : Colist A ∞ → Cowriter (Vec A n) (Vec≤ A n) i
  chunksOfAcc : ∀ m →
    -- We have two continuations but we are only ever going to use one.
    -- If we had linear types, we'd write the type using the & conjunction here.
    (k≤ : Vec≤ A m → Vec≤ A n) →
    (k≡ : Vec A m → Vec A n) →
    -- Finally we chop up the input stream.
    Colist A ∞ → Cowriter (Vec A n) (Vec≤ A n) i

  chunksOf = chunksOfAcc n id id

  chunksOfAcc zero    k≤ k≡ as       = k≡ [] ∷ λ where .force → chunksOf as
  chunksOfAcc (suc k) k≤ k≡ []       = CW.[ k≤ Vec≤.[] ]
  chunksOfAcc (suc k) k≤ k≡ (a ∷ as) =
    chunksOfAcc k (k≤ ∘ (a Vec≤.∷_)) (k≡ ∘ (a ∷_)) (as .force)

open ChunksOf using (chunksOf) public

-- Test to make sure that the values are kept in the same order
_ : chunksOf 3 (fromList (1 ∷ 2 ∷ 3 ∷ 4 ∷ []))
  ≡ (1 ∷ 2 ∷ 3 ∷ []) ∷ _
_ = refl

map : (A → B) → Colist A i → Colist B i
map f []       = []
map f (a ∷ as) = f a ∷ λ where .force → map f (as .force)

unfold : (A → Maybe (A × B)) → A → Colist B i
unfold next seed with next seed
... | nothing          = []
... | just (seed′ , b) = b ∷ λ where .force → unfold next seed′

scanl : (B → A → B) → B → Colist A i → Colist B i
scanl c n []       = n ∷ λ where .force → []
scanl c n (a ∷ as) = n ∷ λ where .force → scanl c (c n a) (as .force)

alignWith : (These A B → C) → Colist A i → Colist B i → Colist C i
alignWith f []         bs       = map (f ∘′ that) bs
alignWith f as@(_ ∷ _) []       = map (f ∘′ this) as
alignWith f (a ∷ as)   (b ∷ bs) =
  f (these a b) ∷ λ where .force → alignWith f (as .force) (bs .force)

zipWith : (A → B → C) → Colist A i → Colist B i → Colist C i
zipWith f []       bs       = []
zipWith f as       []       = []
zipWith f (a ∷ as) (b ∷ bs) =
  f a b ∷ λ where .force → zipWith f (as .force) (bs .force)

align : Colist A i → Colist B i → Colist (These A B) i
align = alignWith id

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

ap : Colist (A → B) i → Colist A i → Colist B i
ap = zipWith _$′_


kk : ∀ {ℓ} → Set ℓ
kk = {!∀ B → B!}


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

open import lib.Basics
open import lib.types.Bool
open import lib.types.Group
open import lib.types.Nat
open import lib.types.Pi
open import lib.types.Sigma
open import lib.types.Coproduct
open import lib.types.Truncation
open import lib.groups.Homomorphism
open import lib.groups.Isomorphism
open import lib.groups.SubgroupProp
open import lib.groups.Lift
open import lib.groups.Unit

module lib.groups.GroupProduct where

{- binary product -}
×-group-struct : ∀ {i j} {A : Type i} {B : Type j}
  (GS : GroupStructure A) (HS : GroupStructure B)
  → GroupStructure (A × B)
×-group-struct {A = A} {B = B} GS HS = record {M} where
  module G = GroupStructure GS
  module H = GroupStructure HS
  module M where
    ident : A × B
    ident = G.ident , H.ident

    inv : A × B → A × B
    inv (g , h) = G.inv g , H.inv h

    comp : A × B → A × B → A × B
    comp (g₁ , h₁) (g₂ , h₂) = G.comp g₁ g₂ , H.comp h₁ h₂

    abstract
      unit-l : ∀ ab → comp ident ab == ab
      unit-l (g , h) = pair×= (G.unit-l g) (H.unit-l h)

      assoc : ∀ ab₁ ab₂ ab₃ → comp (comp ab₁ ab₂) ab₃ == comp ab₁ (comp ab₂ ab₃)
      assoc (g₁ , h₁) (g₂ , h₂) (g₃ , h₃) =
        pair×= (G.assoc g₁ g₂ g₃) (H.assoc h₁ h₂ h₃)

      inv-l : ∀ ab → comp (inv ab) ab == ident
      inv-l (g , h) = pair×= (G.inv-l g) (H.inv-l h)

infix 80 _×ᴳ_
_×ᴳ_ : ∀ {i j} → Group i → Group j → Group (lmax i j)
_×ᴳ_ (group A A-level A-struct) (group B B-level B-struct) =
  group (A × B) (×-level A-level B-level) (×-group-struct A-struct B-struct)

{- general product -}
Π-group-struct : ∀ {i j} {I : Type i} {A : I → Type j}
  (FS : (i : I) → GroupStructure (A i))
  → GroupStructure (Π I A)
Π-group-struct FS = record {
  ident = ident ∘ FS;
  inv = λ f i → inv (FS i) (f i);
  comp = λ f g i → comp (FS i) (f i) (g i);
  unit-l = λ f → (λ= (λ i → unit-l (FS i) (f i)));
  assoc = λ f g h → (λ= (λ i → assoc (FS i) (f i) (g i) (h i)));
  inv-l = λ f → (λ= (λ i → inv-l (FS i) (f i)))}
  where open GroupStructure

Πᴳ : ∀ {i j} (I : Type i) (F : I → Group j) → Group (lmax i j)
Πᴳ I F = group (Π I (El ∘ F)) (Π-level (λ i → El-level (F i)))
               (Π-group-struct (group-struct ∘ F))
  where open Group

{- functorial behavior of [Πᴳ] -}
Πᴳ-emap-r : ∀ {i j k} (I : Type i) {F : I → Group j} {G : I → Group k}
  → (∀ i → F i ≃ᴳ G i) → Πᴳ I F ≃ᴳ Πᴳ I G
Πᴳ-emap-r I {F} {G} iso = ≃-to-≃ᴳ (Π-emap-r (GroupIso.f-equiv ∘ iso))
  (λ f g → λ= λ i → GroupIso.pres-comp (iso i) (f i) (g i))

{- the product of abelian groups is abelian -}
×ᴳ-is-abelian : ∀ {i j} (G : Group i) (H : Group j)
  → is-abelian G → is-abelian H → is-abelian (G ×ᴳ H)
×ᴳ-is-abelian G H aG aH (g₁ , h₁) (g₂ , h₂) = pair×= (aG g₁ g₂) (aH h₁ h₂)

×ᴳ-abgroup : ∀ {i j} → AbGroup i → AbGroup j → AbGroup (lmax i j)
×ᴳ-abgroup (G , aG) (H , aH) = G ×ᴳ H , ×ᴳ-is-abelian G H aG aH

Πᴳ-is-abelian : ∀ {i j} {I : Type i} {F : I → Group j}
  → (∀ i → is-abelian (F i)) → is-abelian (Πᴳ I F)
Πᴳ-is-abelian aF f₁ f₂ = λ= (λ i → aF i (f₁ i) (f₂ i))

{- defining a homomorphism into a product -}
×ᴳ-fanout : ∀ {i j k} {G : Group i} {H : Group j} {K : Group k}
  → (G →ᴳ H) → (G →ᴳ K) → (G →ᴳ H ×ᴳ K)
×ᴳ-fanout (group-hom h h-comp) (group-hom k k-comp) =
  group-hom
    (λ x → (h x , k x))
    (λ x y → pair×= (h-comp x y) (k-comp x y))

Πᴳ-fanout : ∀ {i j k} {I : Type i} {G : Group j} {F : I → Group k}
  → ((i : I) → G →ᴳ F i) → (G →ᴳ Πᴳ I F)
Πᴳ-fanout h = group-hom
  (λ x i → GroupHom.f (h i) x)
  (λ x y → λ= (λ i → GroupHom.pres-comp (h i) x y))

×ᴳ-fanout-pre∘ : ∀ {i j k l}
  {G : Group i} {H : Group j} {K : Group k} {J : Group l}
  (φ : G →ᴳ H) (ψ : G →ᴳ K) (χ : J →ᴳ G)
  → ×ᴳ-fanout φ ψ ∘ᴳ χ == ×ᴳ-fanout (φ ∘ᴳ χ) (ψ ∘ᴳ χ)
×ᴳ-fanout-pre∘ φ ψ χ = group-hom= idp

{- projection homomorphisms -}
×ᴳ-fst : ∀ {i j} {G : Group i} {H : Group j} → (G ×ᴳ H →ᴳ G)
×ᴳ-fst = group-hom fst (λ _ _ → idp)

×ᴳ-snd : ∀ {i j} {G : Group i} {H : Group j} → (G ×ᴳ H →ᴳ H)
×ᴳ-snd = group-hom snd (λ _ _ → idp)

×ᴳ-snd-is-surj : ∀ {i j} {G : Group i} {H : Group j}
  → is-surjᴳ (×ᴳ-snd {G = G} {H = H})
×ᴳ-snd-is-surj {G = G} h = [ (Group.ident G , h) , idp ]

Πᴳ-proj : ∀ {i j} {I : Type i} {F : I → Group j} (i : I)
  → (Πᴳ I F →ᴳ F i)
Πᴳ-proj i = group-hom (λ f → f i) (λ _ _ → idp)

{- injection homomorphisms -}
module _ {i j} {G : Group i} {H : Group j} where

  ×ᴳ-inl : G →ᴳ G ×ᴳ H
  ×ᴳ-inl = ×ᴳ-fanout (idhom G) cst-hom

  ×ᴳ-inr : H →ᴳ G ×ᴳ H
  ×ᴳ-inr = ×ᴳ-fanout (cst-hom {H = G}) (idhom H)

×ᴳ-diag : ∀ {i} {G : Group i} → (G →ᴳ G ×ᴳ G)
×ᴳ-diag = ×ᴳ-fanout (idhom _) (idhom _)

{- when G is abelian, we can define a map H×K → G as a sum of maps
 - H → G and K → G (that is, the product behaves as a sum)         -}
module _ {i j k} {G : Group i} {H : Group j} {K : Group k}
  (G-abelian : is-abelian G) where

  private
    module G = Group G
    module H = Group H
    module K = Group K

    abstract
      interchange : (g₁ g₂ g₃ g₄ : G.El) →
        G.comp (G.comp g₁ g₂) (G.comp g₃ g₄)
        == G.comp (G.comp g₁ g₃) (G.comp g₂ g₄)
      interchange g₁ g₂ g₃ g₄ =
        (g₁ □ g₂) □ (g₃ □ g₄)
           =⟨ G.assoc g₁ g₂ (g₃ □ g₄) ⟩
         g₁ □ (g₂ □ (g₃ □ g₄))
           =⟨ G-abelian g₃ g₄ |in-ctx (λ w → g₁ □ (g₂ □ w)) ⟩
         g₁ □ (g₂ □ (g₄ □ g₃))
           =⟨ ! (G.assoc g₂ g₄ g₃) |in-ctx (λ w → g₁ □ w) ⟩
         g₁ □ ((g₂ □ g₄) □ g₃)
           =⟨ G-abelian (g₂ □ g₄) g₃ |in-ctx (λ w → g₁ □ w) ⟩
         g₁ □ (g₃ □ (g₂ □ g₄))
           =⟨ ! (G.assoc g₁ g₃ (g₂ □ g₄)) ⟩
         (g₁ □ g₃) □ (g₂ □ g₄) =∎
         where
          infix 80 _□_
          _□_ = G.comp

  ×ᴳ-fanin : (H →ᴳ G) → (K →ᴳ G) → (H ×ᴳ K →ᴳ G)
  ×ᴳ-fanin φ ψ = group-hom (λ {(h , k) → G.comp (φ.f h) (ψ.f k)}) lemma
    where
      module φ = GroupHom φ
      module ψ = GroupHom ψ
      abstract
        lemma : preserves-comp (Group.comp (H ×ᴳ K)) G.comp
                  (λ {(h , k) → G.comp (φ.f h) (ψ.f k)})
        lemma (h₁ , k₁) (h₂ , k₂) =
          G.comp (φ.f (H.comp h₁ h₂)) (ψ.f (K.comp k₁ k₂))
            =⟨ φ.pres-comp h₁ h₂ |in-ctx (λ w → G.comp w (ψ.f (K.comp k₁ k₂))) ⟩
          G.comp (G.comp (φ.f h₁) (φ.f h₂)) (ψ.f (K.comp k₁ k₂))
            =⟨ ψ.pres-comp k₁ k₂
               |in-ctx (λ w → G.comp (G.comp (φ.f h₁) (φ.f h₂)) w)  ⟩
          G.comp (G.comp (φ.f h₁) (φ.f h₂)) (G.comp (ψ.f k₁) (ψ.f k₂))
            =⟨ interchange (φ.f h₁) (φ.f h₂) (ψ.f k₁) (ψ.f k₂) ⟩
          G.comp (G.comp (φ.f h₁) (ψ.f k₁)) (G.comp (φ.f h₂) (ψ.f k₂)) =∎

abstract
  ×ᴳ-fanin-η : ∀ {i j} (G : Group i) (H : Group j)
    (aGH : is-abelian (G ×ᴳ H))
    → idhom (G ×ᴳ H) == ×ᴳ-fanin aGH (×ᴳ-inl {G = G}) (×ᴳ-inr {G = G})
  ×ᴳ-fanin-η G H aGH = group-hom= $ λ= λ {(g , h) →
    ! (pair×= (Group.unit-r G g) (Group.unit-l H h))}

  ×ᴳ-fanin-pre∘ : ∀ {i j k l}
    {G : Group i} {H : Group j} {K : Group k} {L : Group l}
    (aK : is-abelian K) (aL : is-abelian L)
    (φ : K →ᴳ L) (ψ : G →ᴳ K) (χ : H →ᴳ K)
    → ×ᴳ-fanin aL (φ ∘ᴳ ψ) (φ ∘ᴳ χ) == φ ∘ᴳ (×ᴳ-fanin aK ψ χ)
  ×ᴳ-fanin-pre∘ aK aL φ ψ χ = group-hom= $ λ= λ {(g , h) →
    ! (GroupHom.pres-comp φ (GroupHom.f ψ g) (GroupHom.f χ h))}

{- define a homomorphism [G₁ × G₂ → H₁ × H₂] from homomorphisms
 - [G₁ → H₁] and [G₂ → H₂] -}
×ᴳ-fmap : ∀ {i j k l} {G₁ : Group i} {G₂ : Group j}
  {H₁ : Group k} {H₂ : Group l}
  → (G₁ →ᴳ H₁) → (G₂ →ᴳ H₂) → (G₁ ×ᴳ G₂ →ᴳ H₁ ×ᴳ H₂)
×ᴳ-fmap {G₁ = G₁} {G₂} {H₁} {H₂} φ ψ = group-hom (×-fmap φ.f ψ.f) lemma
  where
    module φ = GroupHom φ
    module ψ = GroupHom ψ
    abstract
      lemma : preserves-comp (Group.comp (G₁ ×ᴳ G₂)) (Group.comp (H₁ ×ᴳ H₂))
                (λ {(h₁ , h₂) → (φ.f h₁ , ψ.f h₂)})
      lemma (h₁ , h₂) (h₁' , h₂') = pair×= (φ.pres-comp h₁ h₁') (ψ.pres-comp h₂ h₂')

×ᴳ-emap : ∀ {i j k l} {G₁ : Group i} {G₂ : Group j}
  {H₁ : Group k} {H₂ : Group l}
  → (G₁ ≃ᴳ H₁) → (G₂ ≃ᴳ H₂) → (G₁ ×ᴳ G₂ ≃ᴳ H₁ ×ᴳ H₂)
×ᴳ-emap (φ , φ-is-equiv) (ψ , ψ-is-equiv) =
  ×ᴳ-fmap φ ψ , ×-isemap φ-is-equiv ψ-is-equiv

{- equivalences in Πᴳ -}

Πᴳ-emap-l : ∀ {i j k} {A : Type i} {B : Type j} (F : B → Group k)
            → (e : A ≃ B) → Πᴳ A (F ∘ –> e) ≃ᴳ Πᴳ B F
Πᴳ-emap-l {A = A} {B = B} F e = ≃-to-≃ᴳ (Π-emap-l (Group.El ∘ F) e) lemma
  where abstract lemma = λ f g → λ= λ b → transp-El-pres-comp F (<–-inv-r e b) (f (<– e b)) (g (<– e b))

{- 0ᴳ is a unit for product -}
×ᴳ-unit-l : ∀ {i} (G : Group i) → 0ᴳ ×ᴳ G ≃ᴳ G
×ᴳ-unit-l _ = ×ᴳ-snd {G = 0ᴳ} , is-eq snd (λ g → (unit , g)) (λ _ → idp) (λ _ → idp)

×ᴳ-unit-r : ∀ {i} (G : Group i) → G ×ᴳ 0ᴳ ≃ᴳ G
×ᴳ-unit-r _ = ×ᴳ-fst , is-eq fst (λ g → (g , unit)) (λ _ → idp) (λ _ → idp)

{- A product Πᴳ indexed by Bool is the same as a binary product -}
module _ {i j k} {A : Type i} {B : Type j} (F : A ⊔ B → Group k) where

  Πᴳ₁-⊔-iso-×ᴳ : Πᴳ (A ⊔ B) F ≃ᴳ Πᴳ A (F ∘ inl) ×ᴳ Πᴳ B (F ∘ inr)
  Πᴳ₁-⊔-iso-×ᴳ = ≃-to-≃ᴳ (Π₁-⊔-equiv-× (Group.El ∘ F)) (λ _ _ → idp)

{- Commutativity of ×ᴳ -}
×ᴳ-comm : ∀ {i j} (H : Group i) (K : Group j) → H ×ᴳ K ≃ᴳ K ×ᴳ H
×ᴳ-comm H K =
  group-hom (λ {(h , k) → (k , h)}) (λ _ _ → idp) ,
  is-eq _ (λ {(k , h) → (h , k)}) (λ _ → idp) (λ _ → idp)

{- Associativity of ×ᴳ -}
×ᴳ-assoc : ∀ {i j k} (G : Group i) (H : Group j) (K : Group k)
  → ((G ×ᴳ H) ×ᴳ K) ≃ᴳ (G ×ᴳ (H ×ᴳ K))
×ᴳ-assoc G H K =
  group-hom (λ {((g , h) , k) → (g , (h , k))}) (λ _ _ → idp) ,
  is-eq _ (λ {(g , (h , k)) → ((g , h) , k)}) (λ _ → idp) (λ _ → idp)

module _ {i} where

  infixl 80 _^ᴳ_
  _^ᴳ_ : Group i → ℕ → Group i
  H ^ᴳ O = Lift-group {j = i} 0ᴳ
  H ^ᴳ (S n) = H ×ᴳ (H ^ᴳ n)

  ^ᴳ-+ : (H : Group i) (m n : ℕ) → H ^ᴳ (m + n) ≃ᴳ (H ^ᴳ m) ×ᴳ (H ^ᴳ n)
  ^ᴳ-+ H O n = ×ᴳ-emap (lift-iso {G = 0ᴳ}) (idiso (H ^ᴳ n)) ∘eᴳ ×ᴳ-unit-l (H ^ᴳ n) ⁻¹ᴳ
  ^ᴳ-+ H (S m) n = ×ᴳ-assoc H (H ^ᴳ m) (H ^ᴳ n) ⁻¹ᴳ ∘eᴳ ×ᴳ-emap (idiso H) (^ᴳ-+ H m n)

module _ where
  Πᴳ-is-trivial : ∀ {i j} (I : Type i) (F : I → Group j)
    → (∀ (i : I) → is-trivialᴳ (F i)) → is-trivialᴳ (Πᴳ I F)
  Πᴳ-is-trivial I F F-is-trivial = λ f → λ= λ i → F-is-trivial i (f i)

module _ {j} {F : Unit → Group j} where
  Πᴳ₁-Unit : Πᴳ Unit F ≃ᴳ F unit
  Πᴳ₁-Unit = ≃-to-≃ᴳ Π₁-Unit (λ _ _ → idp)


{-# OPTIONS --erased-cubical --save-metas #-}

module Erased-cubical-Pattern-matching-Erased where

open import Agda.Builtin.String
open import Erased-cubical-Pattern-matching-Cubical

-- If c₁ and c₂ are treated as erased, then f might be compiled to
-- something akin to ⊥-elim. However, the main module uses
-- --cubical, not --erased-cubical, so f should not be compiled in
-- that way.

f : D → String
f c₁ = "Success\n"
f c₂ = "Failure\n"


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

open import HoTT
open import homotopy.WedgeExtension
import homotopy.SuspAdjointLoop as SAL

module homotopy.Freudenthal where

{- lemma (move this where?) -}
private
  move1-left-on-left : ∀ {i} {A : Type i} {x y : A} (p : x == y) (q : x == y)
    → ((! q) ∙ p == idp → p == q)
  move1-left-on-left p idp h = h

module FreudenthalEquiv
  {i} (n k : ℕ₋₂) (kle : k ≤T S n +2+ S n)
  (X : Ptd i) {{cX : is-connected (S (S n)) (de⊙ X)}} where

  Q : Susp (de⊙ X) → Type i
  Q x = Trunc k (north == x)

  ⊙up : X ⊙→ ⊙Ω (⊙Susp (de⊙ X))
  ⊙up = SAL.η _

  up = fst ⊙up

  Codes-mer-args : args {a₀ = pt X} {b₀ = [_] {n = k} (pt X)}
  Codes-mer-args = record {n = S n; m = S n;
    P = λ _ _ → (Trunc k (de⊙ X) , raise-level-≤T kle Trunc-level);
    f = [_]; g = idf _; p = idp}

  module CodesExt =
    WedgeExt {a₀ = pt X} {b₀ = [_] {n = k} (pt X)} Codes-mer-args

  Codes-mer : de⊙ X → Trunc k (de⊙ X) → Trunc k (de⊙ X)
  Codes-mer = CodesExt.ext

  Codes-mer-β-l : (λ a → Codes-mer a [ pt X ]) == [_]
  Codes-mer-β-l = λ= CodesExt.β-l

  Codes-mer-β-r : (λ b → Codes-mer (pt X) b) == idf _
  Codes-mer-β-r = λ= $ CodesExt.β-r

  Codes-mer-coh : app= Codes-mer-β-l (pt X) == app= Codes-mer-β-r [ pt X ]
  Codes-mer-coh =
    app= Codes-mer-β-l (pt X)
      =⟨ app=-β CodesExt.β-l (pt X) ⟩
    CodesExt.β-l (pt X)
      =⟨ ! (move1-left-on-left _ _ CodesExt.coh) ⟩
    CodesExt.β-r [ pt X ]
      =⟨ ! (app=-β CodesExt.β-r [ pt X ]) ⟩
    app= Codes-mer-β-r [ pt X ] ∎

  Codes-mer-is-equiv : (x : de⊙ X) → is-equiv (Codes-mer x)
  Codes-mer-is-equiv =
    conn-extend (pointed-conn-out {n = S n} (de⊙ X) (pt X))
      (λ x' → (is-equiv (Codes-mer x') , is-equiv-level))
      (λ tt → transport is-equiv (! (Codes-mer-β-r)) (idf-is-equiv _))

  Codes-mer-equiv : (x : de⊙ X) → Trunc k (de⊙ X) ≃ Trunc k (de⊙ X)
  Codes-mer-equiv x = (Codes-mer x , Codes-mer-is-equiv x)

  Codes-mer-inv-x₀ : <– (Codes-mer-equiv (pt X)) == idf _
  Codes-mer-inv-x₀ =
       ap is-equiv.g (conn-extend-β
          (pointed-conn-out (de⊙ X) (pt X))
          (λ x' → (is-equiv (Codes-mer x') , is-equiv-level))
          _ unit)
     ∙ lemma (! (Codes-mer-β-r)) (snd $ ide _)
    where lemma : ∀ {i j} {A : Type i} {B : Type j} {f g : A → B}
            (α : f == g) (e : is-equiv f)
            → is-equiv.g (transport is-equiv α e) == is-equiv.g e
          lemma idp e = idp

  module CodesRec = SuspRec (Trunc k (de⊙ X)) (Trunc k (de⊙ X)) (ua ∘ Codes-mer-equiv)

  Codes : Susp (de⊙ X) → Type i
  Codes = CodesRec.f

  Codes-has-level : (x : Susp (de⊙ X)) → has-level k (Codes x)
  Codes-has-level = Susp-elim Trunc-level Trunc-level
                      (λ _ → prop-has-all-paths-↓)

  {-
    favonia:

    This equation should be true: [⊙Trunc-fmap ⊙up = (decodeN , decodeN-pt)].
    Maybe there is a way to refactor the following code so that
    pointedness is handled more elegantly.
  -}

  decodeN : Codes north → Trunc k (north' (de⊙ X) == north)
  decodeN = Trunc-fmap up

  decodeN-pt : decodeN [ pt X ] == [ idp ]
  decodeN-pt = snd (⊙Trunc-fmap ⊙up)

  decodeS : Codes south → Q south
  decodeS = Trunc-fmap merid

  encode₀ : {x : Susp (de⊙ X)} → north == x → Codes x
  encode₀ α = transport Codes α [ pt X ]

  encode : {x : Susp (de⊙ X)} → Trunc k (north == x) → Codes x
  encode {x} tα = Trunc-rec {{Codes-has-level x}} encode₀ tα

  ⊙decodeN : ⊙Trunc k X ⊙→ ⊙Trunc k (⊙Ω (⊙Susp (de⊙ X)))
  ⊙decodeN = decodeN , ap [_] (!-inv-r (merid (pt X)))

  ⊙encodeN : ⊙Trunc k (⊙Ω (⊙Susp (de⊙ X))) ⊙→ ⊙Trunc k X
  ⊙encodeN = encode , idp

  abstract
    encode-decodeN : (c : Codes north) → encode (decodeN c) == c
    encode-decodeN = Trunc-elim
      {{λ _ → =-preserves-level Trunc-level}}
      (λ x →
        encode (decodeN [ x ])
          =⟨ idp ⟩
        coe (ap Codes (merid x ∙ ! (merid (pt X)))) [ pt X ]
          =⟨ ap-∙ Codes (merid x) (! (merid (pt X))) |in-ctx (λ w → coe w [ pt X ]) ⟩
        coe (ap Codes (merid x) ∙ ap Codes (! (merid (pt X)))) [ pt X ]
          =⟨ coe-∙ (ap Codes (merid x)) (ap Codes (! (merid (pt X)))) [ pt X ] ⟩
        coe (ap Codes (! (merid (pt X)))) (coe (ap Codes (merid x)) [ pt X ])
          =⟨ SuspRec.merid-β _ _ (ua ∘ Codes-mer-equiv) x
            |in-ctx (λ w → coe (ap Codes (! (merid (pt X)))) (coe w [ pt X ])) ⟩
        coe (ap Codes (! (merid (pt X)))) (coe (ua (Codes-mer-equiv x)) [ pt X ])
          =⟨ coe-β (Codes-mer-equiv x) [ pt X ]
            |in-ctx (λ w → coe (ap Codes (! (merid (pt X)))) w) ⟩
        coe (ap Codes (! (merid (pt X)))) (Codes-mer x [ pt X ])
          =⟨ app= Codes-mer-β-l x
            |in-ctx (λ w → coe (ap Codes (! (merid (pt X)))) w) ⟩
        coe (ap Codes (! (merid (pt X)))) [ x ]
          =⟨ coe-ap-! Codes (merid (pt X)) [ x ] ⟩
        coe! (ap Codes (merid (pt X))) [ x ]
          =⟨ SuspRec.merid-β _ _ (ua ∘ Codes-mer-equiv) (pt X)
            |in-ctx (λ w → coe! w [ x ]) ⟩
        coe! (ua (Codes-mer-equiv (pt X))) [ x ]
          =⟨ coe!-β (Codes-mer-equiv (pt X)) [ x ] ⟩
        <– (Codes-mer-equiv (pt X)) [ x ]
          =⟨ app= Codes-mer-inv-x₀ [ x ] ⟩
        [ x ] ∎)

  decode : {x : Susp (de⊙ X)} → Codes x → Q x
  decode {x} = Susp-elim
    {P = λ y → Codes y → Q y}
    decodeN decodeS
    (λ x' → ↓-→-from-transp (λ= (STS x')))
    x
    where
    abstract
      coh : {s₁ s₂ : Susp (de⊙ X)} (p : s₁ == s₂)
        → (ap (λ s → s ∙ p) (!-inv-r p))
          == ∙-assoc p (! p) p ∙ ap (λ s → p ∙ s) (!-inv-l p) ∙ ∙-unit-r p
      coh idp = idp

      P : de⊙ X → de⊙ X → (S (n +2+ (S n))) -Type (lmax i i)
      P = λ x₁ x₂ →
        ((transport Q (merid x₁) (Trunc-fmap up [ x₂ ])
          == Trunc-fmap merid (transport Codes (merid x₁) [ x₂ ])),
         =-preserves-level (raise-level-≤T kle Trunc-level))

      f : (a : de⊙ X) → fst (P a (pt X))
      f a =
        transport Q (merid a) [ up (pt X) ]
          =⟨ transport-Trunc' (north ==_) (merid a) (up (pt X)) ⟩
        [ transport (north ==_) (merid a) (up (pt X)) ]
          =⟨ ap [_] $ transp-cst=idf {A = Susp (de⊙ X)} (merid a) (up (pt X)) ⟩
        [ (merid (pt X) ∙ ! (merid (pt X))) ∙ merid a ]
          =⟨ ap [_] $ ap (λ s → s ∙ merid a) (!-inv-r (merid (pt X))) ⟩
        [ merid a ]
          =⟨ idp ⟩
        Trunc-fmap merid [ a ]
          =⟨ ap (Trunc-fmap merid) (! (app= Codes-mer-β-l a)) ⟩
        Trunc-fmap merid (Codes-mer a [ pt X ])
          =⟨ ap (Trunc-fmap merid) (! (coe-β (Codes-mer-equiv a) [ pt X ])) ⟩
        Trunc-fmap merid (coe (ua (Codes-mer-equiv a)) [ pt X ])
          =⟨ ! (SuspRec.merid-β _ _ (ua ∘ Codes-mer-equiv) a)
            |in-ctx (λ w → Trunc-fmap merid (coe w [ pt X ])) ⟩
        Trunc-fmap merid (transport Codes (merid a) [ pt X ]) ∎

      g : (b : de⊙ X) → fst (P (pt X) b)
      g b =
        transport Q (merid (pt X)) [ up b ]
          =⟨ transport-Trunc' (north ==_) (merid (pt X)) (up b) ⟩
        [ transport (north ==_) (merid (pt X)) (up b) ]
          =⟨ ap [_] $ transp-cst=idf {A = Susp (de⊙ X)} (merid (pt X)) (up b)  ⟩
        [ (merid b ∙ ! (merid (pt X))) ∙ merid (pt X) ]
          =⟨ ap [_] $ ∙-assoc (merid b) (! (merid (pt X))) (merid (pt X))
                      ∙ ap (λ s → merid b ∙ s) (!-inv-l (merid (pt X)))
                      ∙ ∙-unit-r (merid b) ⟩
        [ merid b ]
          =⟨ idp ⟩
        Trunc-fmap merid [ b ]
          =⟨ ap (Trunc-fmap merid) (! (app= Codes-mer-β-r [ b ])) ⟩
        Trunc-fmap merid (Codes-mer (pt X) [ b ])
          =⟨ ap (Trunc-fmap merid) (! (coe-β (Codes-mer-equiv (pt X)) [ b ])) ⟩
        Trunc-fmap merid (coe (ua (Codes-mer-equiv (pt X))) [ b ])
          =⟨ ! (SuspRec.merid-β _ _ (ua ∘ Codes-mer-equiv) (pt X))
            |in-ctx (λ w → Trunc-fmap merid (coe w [ b ])) ⟩
        Trunc-fmap merid (transport Codes (merid (pt X)) [ b ]) ∎

      p : f (pt X) == g (pt X)
      p = ap2
        (λ p₁ p₂ →
          transport Q (merid (pt X)) [ up (pt X) ]
            =⟨ transport-Trunc' (north ==_) (merid (pt X)) (up (pt X)) ⟩
          [ transport (north ==_) (merid (pt X)) (up (pt X)) ]
            =⟨ ap [_] $ transp-cst=idf {A = Susp (de⊙ X)} (merid (pt X)) (up (pt X)) ⟩
          [ (merid (pt X) ∙ ! (merid (pt X))) ∙ merid (pt X) ]
            =⟨ ap [_] p₁ ⟩
          [ merid (pt X) ]
            =⟨ idp ⟩
          Trunc-fmap merid [ pt X ]
            =⟨ ap (Trunc-fmap merid) (! p₂) ⟩
          Trunc-fmap merid (Codes-mer (pt X) [ pt X ])
            =⟨ ap (Trunc-fmap merid) (! (coe-β (Codes-mer-equiv (pt X)) [ pt X ])) ⟩
          Trunc-fmap merid (coe (ua (Codes-mer-equiv (pt X))) [ pt X ])
            =⟨ ! (SuspRec.merid-β _ _ (ua ∘ Codes-mer-equiv) (pt X))
              |in-ctx (λ w → Trunc-fmap merid (coe w [ pt X ])) ⟩
          Trunc-fmap merid (transport Codes (merid (pt X)) [ pt X ]) ∎)
        (coh (merid (pt X))) Codes-mer-coh

      STS-args : args {a₀ = pt X} {b₀ = pt X}
      STS-args =
        record {n = S n; m = S n; P = P; f = f; g = g; p = p}

      STS : (x' : de⊙ X) (c : Codes north) →
        transport Q (merid x') (Trunc-fmap up c)
        == Trunc-fmap merid (transport Codes (merid x') c)
      STS x' = Trunc-elim {{λ _ → =-preserves-level Trunc-level}}
                          (WedgeExt.ext STS-args x')

  abstract
    decode-encode : {x : Susp (de⊙ X)} (tα : Q x)
      → decode {x} (encode {x} tα) == tα
    decode-encode {x} = Trunc-elim
      {P = λ tα → decode {x} (encode {x} tα) == tα}
      {{λ _ → =-preserves-level Trunc-level}}
      (J (λ y p → decode {y} (encode {y} [ p ]) == [ p ])
         (ap [_] (!-inv-r (merid (pt X)))))

  eq : Trunc k (de⊙ X) ≃ Trunc k (north' (de⊙ X) == north)
  eq = equiv decodeN encode decode-encode encode-decodeN

  ⊙eq : ⊙Trunc k X ⊙≃ ⊙Trunc k (⊙Ω (⊙Susp (de⊙ X)))
  ⊙eq = ≃-to-⊙≃ eq (snd ⊙decodeN)

  abstract
    ⊙decodeN-⊙encodeN : ⊙decodeN ⊙∘ ⊙encodeN == ⊙idf _
    ⊙decodeN-⊙encodeN =
      ⊙λ=' {X = ⊙Trunc k (⊙Ω (⊙Susp (de⊙ X)))}
           {Y = ⊙Trunc k (⊙Ω (⊙Susp (de⊙ X)))}
           decode-encode $
      ↓-idf=cst-in $
      ! (∙-unit-r (ap [_] (!-inv-r (merid (pt X)))))

    ⊙<–-⊙eq : ⊙<– ⊙eq == ⊙encodeN
    ⊙<–-⊙eq =
      –>-is-inj (post⊙∘-equiv {Z = ⊙Trunc k (⊙Ω (⊙Susp (de⊙ X)))} ⊙eq) (⊙<– ⊙eq) ⊙encodeN $
      ⊙decodeN ⊙∘ ⊙<– ⊙eq
        =⟨ ⊙<–-inv-r ⊙eq ⟩
      ⊙idf _
        =⟨ ! ⊙decodeN-⊙encodeN ⟩
      ⊙decodeN ⊙∘ ⊙encodeN =∎

  path : Trunc k (de⊙ X) == Trunc k (north' (de⊙ X) == north)
  path = ua eq

  ⊙path : ⊙Trunc k X == ⊙Trunc k (⊙Ω (⊙Susp (de⊙ X)))
  ⊙path = ⊙ua ⊙eq

{- timjb: it is probably easier to show the naturality of ⊙decodeN
   and deduce the naturality of ⊙encodeN from that than to show
   the naturality of ⊙encodeN directly (as done below) -}
module FreudenthalEquivNatural
  {i} (n k : ℕ₋₂) (kle : k ≤T S n +2+ S n)
  {X Y : Ptd i} (f : X ⊙→ Y)
  {{cX : is-connected (S (S n)) (de⊙ X)}}
  {{cY : is-connected (S (S n)) (de⊙ Y)}} where

  private
    module FX = FreudenthalEquiv n k kle X {{cX}}
    module FY = FreudenthalEquiv n k kle Y {{cY}}

  Codes-mer-map : ∀ (x : de⊙ X) (tx : Trunc k (de⊙ X))
    → Trunc-fmap (fst f) (FX.Codes-mer x tx) ==
      FY.Codes-mer (fst f x) (Trunc-fmap (fst f) tx)
  Codes-mer-map =
    WedgeExt.ext {A = de⊙ X} {a₀ = pt X} {B = Trunc k (de⊙ X)} {b₀ = [ pt X ]} $
    record
    { n = S n; m = S n
    ; P = λ x tx → (P x tx , P-level x tx)
    ; f = λ x → ↯ (f-seq x)
    ; g = λ tx → ↯ (g-seq tx)
    ; p = =ₛ-out p
    }
    where
    P : de⊙ X → Trunc k (de⊙ X) → Type i
    P x tx =
      Trunc-fmap (fst f) (FX.Codes-mer x tx) ==
      FY.Codes-mer (fst f x) (Trunc-fmap (fst f) tx)
    P-level : ∀ x tx → has-level (S n +2+ S n) (P x tx)
    P-level x tx = =-preserves-level (raise-level-≤T kle Trunc-level)
    f-seq : ∀ x → Trunc-fmap (fst f) (FX.Codes-mer x [ pt X ]) =-=
                  FY.Codes-mer (fst f x) (Trunc-fmap (fst f) [ pt X ])
    f-seq x =
      Trunc-fmap (fst f) (FX.Codes-mer x [ pt X ])
        =⟪ ap (Trunc-fmap (fst f)) (FX.CodesExt.β-l x) ⟫
      [ fst f x ]
        =⟪ ! (FY.CodesExt.β-l (fst f x)) ⟫
      FY.Codes-mer (fst f x) [ pt Y ]
        =⟪ ap (FY.Codes-mer (fst f x) ∘ [_]) (! (snd f)) ⟫
      FY.Codes-mer (fst f x) [ fst f (pt X) ] ∎∎
    g-seq : ∀ tx → Trunc-fmap (fst f) (FX.Codes-mer (pt X) tx) =-=
                   FY.Codes-mer (fst f (pt X)) (Trunc-fmap (fst f) tx)
    g-seq tx =
      Trunc-fmap (fst f) (FX.Codes-mer (pt X) tx)
        =⟪ ap (Trunc-fmap (fst f)) (FX.CodesExt.β-r tx) ⟫
      Trunc-fmap (fst f) tx
        =⟪ ! (FY.CodesExt.β-r (Trunc-fmap (fst f) tx)) ⟫
      FY.Codes-mer (pt Y) (Trunc-fmap (fst f) tx)
        =⟪ ap (λ y → FY.Codes-mer y (Trunc-fmap (fst f) tx)) (! (snd f)) ⟫
      FY.Codes-mer (fst f (pt X)) (Trunc-fmap (fst f) tx) ∎∎
    p : f-seq (pt X) =ₛ g-seq [ pt X ]
    p =
      ap (Trunc-fmap (fst f)) (FX.CodesExt.β-l (pt X)) ◃∙
      ! (FY.CodesExt.β-l (fst f (pt X))) ◃∙
      ap (FY.Codes-mer (fst f (pt X)) ∘ [_]) (! (snd f)) ◃∎
        =ₛ⟨ 0 & 1 & ap-seq-=ₛ (Trunc-fmap (fst f)) $
                    pre-rotate-out {p = FX.CodesExt.β-l (pt X)} {q = []} {r = FX.CodesExt.β-r [ pt X ] ◃∎} $
                    =ₛ-in $ ! $ FX.CodesExt.coh ⟩
      ap (Trunc-fmap (fst f)) (FX.CodesExt.β-r [ pt X ]) ◃∙
      ! (FY.CodesExt.β-l (fst f (pt X))) ◃∙
      ap (FY.Codes-mer (fst f (pt X)) ∘ [_]) (! (snd f)) ◃∎
        =ₛ⟨ 1 & 1 & pre-rotate-in $
            homotopy-naturality
              [_]
              (λ y → FY.Codes-mer y [ pt Y ])
              (! ∘ FY.CodesExt.β-l)
              (! (snd f)) ⟩
      ap (Trunc-fmap (fst f)) (FX.CodesExt.β-r [ pt X ]) ◃∙
      ! (ap [_] (! (snd f))) ◃∙
      ! (FY.CodesExt.β-l (pt Y)) ◃∙
      ap (λ y → FY.Codes-mer y [ pt Y ]) (! (snd f)) ◃∙
      ap (FY.Codes-mer (fst f (pt X)) ∘ [_]) (! (snd f)) ◃∎
        =ₛ⟨ 3 & 2 & ap-comm-=ₛ (λ y y' → FY.Codes-mer y [ y' ]) (! (snd f)) (! (snd f)) ⟩
      ap (Trunc-fmap (fst f)) (FX.CodesExt.β-r [ pt X ]) ◃∙
      ! (ap [_] (! (snd f))) ◃∙
      ! (FY.CodesExt.β-l (pt Y)) ◃∙
      ap (λ y → FY.Codes-mer (pt Y) [ y ]) (! (snd f)) ◃∙
      ap (λ y → FY.Codes-mer y [ fst f (pt X) ]) (! (snd f)) ◃∎
        =ₛ⟨ 2 & 1 & !-=ₛ $
            pre-rotate-out {p = FY.CodesExt.β-l (pt Y)} {q = []} {r = FY.CodesExt.β-r [ pt Y ] ◃∎} $
            =ₛ-in $ ! $ FY.CodesExt.coh ⟩
      ap (Trunc-fmap (fst f)) (FX.CodesExt.β-r [ pt X ]) ◃∙
      ! (ap [_] (! (snd f))) ◃∙
      ! (FY.CodesExt.β-r [ pt Y ]) ◃∙
      ap (λ y → FY.Codes-mer (pt Y) [ y ]) (! (snd f)) ◃∙
      ap (λ y → FY.Codes-mer y [ fst f (pt X) ]) (! (snd f)) ◃∎
        =ₛ⟨ 1 & 3 & !ₛ $ pre-rotate-in $
            homotopy-naturality
              [_]
              (FY.Codes-mer (pt Y) ∘ [_])
              (! ∘ FY.CodesExt.β-r ∘ [_])
              (! (snd f)) ⟩
      ap (Trunc-fmap (fst f)) (FX.CodesExt.β-r [ pt X ]) ◃∙
      ! (FY.CodesExt.β-r (Trunc-fmap (fst f) [ pt X ])) ◃∙
      ap (λ y → FY.Codes-mer y [ fst f (pt X) ]) (! (snd f)) ◃∎ ∎ₛ

  Codes-fmap : ∀ {x : Susp (de⊙ X)}
    → FX.Codes x
    → FY.Codes (Susp-fmap (fst f) x)
  Codes-fmap {x} =
    Susp-elim
      {P = λ x → FX.Codes x → FY.Codes (Susp-fmap (fst f) x)}
      (Trunc-fmap (fst f))
      (Trunc-fmap (fst f))
      (λ x → ↓-→-from-transp $ λ= $
        Trunc-elim {{λ tx → =-preserves-level Trunc-level}} $ λ x' →
        transport (FY.Codes ∘ Susp-fmap (fst f)) (merid x) [ fst f x' ]
          =⟨ ap (λ q → coe q [ fst f x' ]) (ap-∘ FY.Codes (Susp-fmap (fst f)) (merid x)) ⟩
        transport FY.Codes (ap (Susp-fmap (fst f)) (merid x)) [ fst f x' ]
          =⟨ ap (λ p → transport FY.Codes p [ fst f x' ]) $
             SuspFmap.merid-β (fst f) x ⟩
        transport FY.Codes (merid (fst f x)) [ fst f x' ]
          =⟨ ap (λ p → coe p [ fst f x' ]) (FY.CodesRec.merid-β (fst f x)) ⟩
        coe (ua (FY.Codes-mer-equiv (fst f x))) [ fst f x' ]
          =⟨ coe-β (FY.Codes-mer-equiv (fst f x)) [ fst f x' ] ⟩
        FY.Codes-mer (fst f x) [ fst f x' ]
          =⟨ ! (Codes-mer-map x [ x' ])  ⟩
        Trunc-fmap (fst f) (FX.Codes-mer x [ x' ])
          =⟨ ap (Trunc-fmap (fst f)) (! (coe-β (FX.Codes-mer-equiv x) [ x' ])) ⟩
        Trunc-fmap (fst f) (coe (ua (FX.Codes-mer-equiv x)) [ x' ])
          =⟨ ap (λ p → Trunc-fmap (fst f) (coe p [ x' ])) (! (FX.CodesRec.merid-β x)) ⟩
        Trunc-fmap (fst f) (transport FX.Codes (merid x) [ x' ]) =∎)
      x

  encode-natural : ∀ {x : Susp (de⊙ X)}
    (tα : Trunc k (north == x))
    → FY.encode (Trunc-fmap (ap (Susp-fmap (fst f))) tα)
      ==
      Codes-fmap {x} (FX.encode tα)
  encode-natural {x} =
    Trunc-elim {{λ tα → =-preserves-level (FY.Codes-has-level (Susp-fmap (fst f) x))}} $
    J (λ x p → FY.encode (Trunc-fmap (ap (Susp-fmap (fst f))) [ p ]) == Codes-fmap {x} (FX.encode [ p ])) $
    ! (ap [_] (snd f))

  ⊙encodeN-natural :
    FY.⊙encodeN ◃⊙∘
    ⊙Trunc-fmap (⊙Ω-fmap (⊙Susp-fmap (fst f))) ◃⊙idf
    =⊙∘
    ⊙Trunc-fmap f ◃⊙∘
    FX.⊙encodeN ◃⊙idf
  ⊙encodeN-natural =
    =⊙∘-in $
    ⊙λ=' {X = ⊙Trunc k (⊙Ω (⊙Susp (de⊙ X)))} {Y = ⊙Trunc k Y} (encode-natural {north}) $
    ↓-idf=cst-in {p = ! (ap [_] (snd f))} $
    ! $ !-inv-l (ap [_] (snd f))

{- Used to prove stability in iterated suspensions -}
module FreudenthalIso
  {i} (n : ℕ₋₂) (k : ℕ) (kle : ⟨ S k ⟩ ≤T S n +2+ S n)
  (X : Ptd i) {{_ : is-connected (S (S n)) (de⊙ X)}} where

  open FreudenthalEquiv n ⟨ S k ⟩ kle X public

  hom : Ω^S-group k (⊙Trunc ⟨ S k ⟩ X)
     →ᴳ Ω^S-group k (⊙Trunc ⟨ S k ⟩ (⊙Ω (⊙Susp (de⊙ X))))
  hom = Ω^S-group-fmap k (decodeN , decodeN-pt)

  iso : Ω^S-group k (⊙Trunc ⟨ S k ⟩ X)
     ≃ᴳ Ω^S-group k (⊙Trunc ⟨ S k ⟩ (⊙Ω (⊙Susp (de⊙ X))))
  iso = Ω^S-group-emap k ⊙eq


------------------------------------------------------------------------------
-- The division specification
------------------------------------------------------------------------------

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

module LTC-PCF.Program.Division.Specification where

open import LTC-PCF.Base
open import LTC-PCF.Data.Nat
open import LTC-PCF.Data.Nat.Inequalities

------------------------------------------------------------------------------
-- Specification: The division is total and the result is correct.
divSpec : D → D → D → Set
divSpec i j q = N q ∧ (∃[ r ] N r ∧ r < j ∧ i ≡ j * q + r)


{-# OPTIONS --no-termination-check --universe-polymorphism #-}

module PiF where

open import Level
open import Data.Empty
open import Data.Unit
open import Data.Bool
open import Data.Sum hiding (map)
open import Data.Product hiding (map)

open import Relation.Binary.PropositionalEquality hiding (sym; [_])

open import Singleton

infixr 30 _⟷_
infixr 30 _⟺_
infixr 20 _◎_

------------------------------------------------------------------------------
-- A universe of our value types

mutual
  data BF : Set zero where
    ZEROF  : BF
    ONEF   : BF
    PLUSF  : BF → BF → BF
    TIMESF : BF → BF → BF
    RECIP  : BF → BF

--data VF : Set where
--  unitF :

-- data hasType :

-- normalize : (b : BF) → (hasType v b) → normalform v b

-- fractional types are un-interpreted

data Reciprocal (A : Set) : Set where
  rec : (b : A) → ((x : Singleton b) → ⊤) → Reciprocal A

data Recip (A : Set) : Set where
  recip : (a : A) → Recip A

⟦_⟧F : BF → Set zero
⟦ ZEROF ⟧F         = ⊥
⟦ ONEF ⟧F          = ⊤
⟦ PLUSF b1 b2 ⟧F   = ⟦ b1 ⟧F ⊎ ⟦ b2 ⟧F
⟦ TIMESF b1 b2 ⟧F  = ⟦ b1 ⟧F × ⟦ b2 ⟧F
⟦ RECIP b ⟧F  = -- Σ ⟦ b ⟧F (λ v → ((x : Singleton v) → ⊤))
                Reciprocal ⟦ b ⟧F

------------------------------------------------------------------------------
-- Primitive isomorphisms

data _⟷_ : BF → BF → Set where
  -- (+,0) commutative monoid
  unite₊  : { b : BF } → PLUSF ZEROF b ⟷ b
  uniti₊  : { b : BF } → b ⟷ PLUSF ZEROF b
  swap₊   : { b₁ b₂ : BF } → PLUSF b₁ b₂ ⟷ PLUSF b₂ b₁
  assocl₊ : { b₁ b₂ b₃ : BF } → PLUSF b₁ (PLUSF b₂ b₃) ⟷ PLUSF (PLUSF b₁ b₂) b₃
  assocr₊ : { b₁ b₂ b₃ : BF } → PLUSF (PLUSF b₁ b₂) b₃ ⟷ PLUSF b₁ (PLUSF b₂ b₃)
  -- (*,1) commutative monoid
  unite⋆  : { b : BF } → TIMESF ONEF b ⟷ b
  uniti⋆  : { b : BF } → b ⟷ TIMESF ONEF b
  swap⋆   : { b₁ b₂ : BF } → TIMESF b₁ b₂ ⟷ TIMESF b₂ b₁
  assocl⋆ : { b₁ b₂ b₃ : BF } → TIMESF b₁ (TIMESF b₂ b₃) ⟷ TIMESF (TIMESF b₁ b₂) b₃
  assocr⋆ : { b₁ b₂ b₃ : BF } → TIMESF (TIMESF b₁ b₂) b₃ ⟷ TIMESF b₁ (TIMESF b₂ b₃)
  -- * distributes over +
  dist    : { b₁ b₂ b₃ : BF } →
            TIMESF (PLUSF b₁ b₂) b₃ ⟷ PLUSF (TIMESF b₁ b₃) (TIMESF b₂ b₃)
  factor  : { b₁ b₂ b₃ : BF } →
            PLUSF (TIMESF b₁ b₃) (TIMESF b₂ b₃) ⟷ TIMESF (PLUSF b₁ b₂) b₃
  -- id
  id⟷    : { b : BF } → b ⟷ b

adjointP : { b₁ b₂ : BF } → (b₁ ⟷ b₂) → (b₂ ⟷ b₁)
adjointP unite₊    = uniti₊
adjointP uniti₊    = unite₊
adjointP swap₊     = swap₊
adjointP assocl₊   = assocr₊
adjointP assocr₊   = assocl₊
adjointP unite⋆    = uniti⋆
adjointP uniti⋆    = unite⋆
adjointP swap⋆     = swap⋆
adjointP assocl⋆   = assocr⋆
adjointP assocr⋆   = assocl⋆
adjointP dist      = factor
adjointP factor    = dist
adjointP id⟷      = id⟷

evalP : { b₁ b₂ : BF } → (b₁ ⟷ b₂) → ⟦ b₁ ⟧F → ⟦ b₂ ⟧F
evalP unite₊ (inj₁ ())
evalP unite₊ (inj₂ v) = v
evalP uniti₊ v = inj₂ v
evalP swap₊ (inj₁ v) = inj₂ v
evalP swap₊ (inj₂ v) = inj₁ v
evalP assocl₊ (inj₁ v) = inj₁ (inj₁ v)
evalP assocl₊ (inj₂ (inj₁ v)) = inj₁ (inj₂ v)
evalP assocl₊ (inj₂ (inj₂ v)) = inj₂ v
evalP assocr₊ (inj₁ (inj₁ v)) = inj₁ v
evalP assocr₊ (inj₁ (inj₂ v)) = inj₂ (inj₁ v)
evalP assocr₊ (inj₂ v) = inj₂ (inj₂ v)
evalP unite⋆ (tt , v) = v
evalP uniti⋆ v = (tt , v)
evalP swap⋆ (v₁ , v₂) = (v₂ , v₁)
evalP assocl⋆ (v₁ , (v₂ , v₃)) = ((v₁ , v₂) , v₃)
evalP assocr⋆ ((v₁ , v₂) , v₃) = (v₁ , (v₂ , v₃))
evalP dist (inj₁ v₁ , v₃) = inj₁ (v₁ , v₃)
evalP dist (inj₂ v₂ , v₃) = inj₂ (v₂ , v₃)
evalP factor (inj₁ (v₁ , v₃)) = (inj₁ v₁ , v₃)
evalP factor (inj₂ (v₂ , v₃)) = (inj₂ v₂ , v₃)
evalP id⟷ v = v

-- normalize values in BF to x * 1/y and then decide equality of normalized values

-- _≡B_ {b₁ = ONEF} {b₂ = ONEF} tt tt = true
--_≡B_ {b₁ = TIMESF d c} {b₂ = TIMESF c d} (v₁ , v₃) (v₄ , v₂) =
--  _≡B_ {b₁ = d} {b₂ = d} v₁ v₂ ∧ _≡B_ {b₁ = c} {b₂ = c} v₃ v₄
  -- zero??

-- Backwards evaluator

bevalP : { b₁ b₂ : BF } → (b₁ ⟷ b₂) → ⟦ b₂ ⟧F → ⟦ b₁ ⟧F
bevalP c v = evalP (adjointP c) v

------------------------------------------------------------------------------
-- Closure combinators

data _⟺_ : BF → BF → Set where
  iso    : { b₁ b₂ : BF } → (b₁ ⟷ b₂) → (b₁ ⟺ b₂)
  sym    : { b₁ b₂ : BF } → (b₁ ⟺ b₂) → (b₂ ⟺ b₁)
  _◎_    : { b₁ b₂ b₃ : BF } → (b₁ ⟺ b₂) → (b₂ ⟺ b₃) → (b₁ ⟺ b₃)
  _⊕_    : { b₁ b₂ b₃ b₄ : BF } →
           (b₁ ⟺ b₃) → (b₂ ⟺ b₄) → (PLUSF b₁ b₂ ⟺ PLUSF b₃ b₄)
  _⊗_    : { b₁ b₂ b₃ b₄ : BF } →
           (b₁ ⟺ b₃) → (b₂ ⟺ b₄) → (TIMESF b₁ b₂ ⟺ TIMESF b₃ b₄)
  refe⋆  : { b : BF } → RECIP (RECIP b) ⟺ b
  refi⋆  : { b : BF } → b ⟺ RECIP (RECIP b)
  rile⋆  : { b : BF } → TIMESF b (TIMESF b (RECIP b)) ⟺ b
  rili⋆  : { b : BF } → b ⟺ TIMESF b (TIMESF b (RECIP b))

--

adjoint : { b₁ b₂ : BF } → (b₁ ⟺ b₂) → (b₂ ⟺ b₁)
adjoint (iso c) = iso (adjointP c)
adjoint (sym c)   = c
adjoint (c₁ ◎ c₂) = adjoint c₂ ◎ adjoint c₁
adjoint (c₁ ⊕ c₂) = adjoint c₁ ⊕ adjoint c₂
adjoint (c₁ ⊗ c₂) = adjoint c₁ ⊗ adjoint c₂
adjoint refe⋆ = refi⋆
adjoint refi⋆ = refe⋆
adjoint rile⋆ = rili⋆
adjoint rili⋆ = rile⋆

--

-- (Context a b c d) represents a combinator (c <-> d) with a hole
-- requiring something of type (a <-> b). When we use these contexts,
-- it is always the case that the (c <-> a) part of the computation
-- has ALREADY been done and that we are about to evaluate (a <-> b)
-- using a given 'a'. The continuation takes the output 'b' and
-- produces a 'd'.

data Context : BF → BF → BF → BF → Set where
  emptyC : {a b : BF} → Context a b a b
  seqC₁ : {a b c i o : BF} → (b ⟺ c) → Context a c i o → Context a b i o
  seqC₂ : {a b c i o : BF} → (a ⟺ b) → Context a c i o → Context b c i o
  leftC : {a b c d i o : BF} →
          (c ⟺ d) → Context (PLUSF a c) (PLUSF b d) i o → Context a b i o
  rightC : {a b c d i o : BF} →
           (a ⟺ b) → Context (PLUSF a c) (PLUSF b d) i o → Context c d i o
  -- the (i <-> a) part of the computation is completely done; so we must store
  -- the value of type [[ c ]] as part of the context
  fstC : {a b c d i o : BF} →
         ⟦ c ⟧F → (c ⟺ d) → Context (TIMESF a c) (TIMESF b d) i o → Context a b i o
  -- the (i <-> c) part of the computation and the (a <-> b) part of
  -- the computation are completely done; so we must store the value
  -- of type [[ b ]] as part of the context
  sndC : {a b c d i o : BF} →
         (a ⟺ b) → ⟦ b ⟧F → Context (TIMESF a c) (TIMESF b d) i o → Context c d i o

-- Evaluation

mutual

  -- The (c <-> a) part of the computation has been done.
  -- We have an 'a' and we are about to do the (a <-> b) computation.
  -- We get a 'b' and examine the context to get the 'd'
  eval_c : { a b c : BF } → (a ⟺ b) → ⟦ a ⟧F → Context a b c c → ⟦ c ⟧F
  eval_c (iso f) v C = eval_k (iso f) (evalP f v) C
  eval_c (sym c) v C = eval_c (adjoint c) v C
  eval_c (f ◎ g) v C = eval_c f v (seqC₁ g C)
  eval_c (f ⊕ g) (inj₁ v) C = eval_c f v (leftC g C)
  eval_c (f ⊕ g) (inj₂ v) C = eval_c g v (rightC f C)
  eval_c (f ⊗ g) (v₁ , v₂) C = eval_c f v₁ (fstC v₂ g C)
  eval_c refe⋆ (rec (rec v _) _)  C = eval_k refe⋆ v C
  eval_c refi⋆ v C = eval_k refi⋆ (rec (rec v (λ x → tt)) ff) C
    where ff = λ x → tt
  eval_c rile⋆ (v₁ , (v₂ , rec v₃ _)) C = eval_k rile⋆ v₁ C
  eval_c rili⋆ v C = eval_k rili⋆ (v , (v , {!!})) C

  -- The (c <-> a) part of the computation has been done.
  -- The (a <-> b) part of the computation has been done.
  -- We need to examine the context to get the 'd'.
  -- We rebuild the combinator on the way out.
  eval_k : { a b c : BF } → (a ⟺ b) → ⟦ b ⟧F → Context a b c c → ⟦ c ⟧F
  eval_k f v emptyC = v
  eval_k f v (seqC₁ g C) = eval_c g v (seqC₂ f C)
  eval_k g v (seqC₂ f C) = eval_k (f ◎ g) v C
  eval_k f v (leftC g C) = eval_k (f ⊕ g) (inj₁ v) C
  eval_k g v (rightC f C) = eval_k (f ⊕ g) (inj₂ v) C
  eval_k f v₁ (fstC v₂ g C) = eval_c g v₂ (sndC f v₁ C)
  eval_k g v₂ (sndC f v₁ C) = eval_k (f ⊗ g) (v₁ , v₂) C

  -- Backwards evaluator

  -- The (d <-> b) part of the computation has been done.
  -- We have a 'b' and we are about to do the (a <-> b) computation backwards.
  -- We get an 'a' and examine the context to get the 'c'
  beval_c : { a b c : BF } → (a ⟺ b) → ⟦ b ⟧F → Context a b c c → ⟦ c ⟧F
  beval_c (iso f) v C = beval_k (iso f) (bevalP f v) C
  beval_c (sym c) v C = beval_c (adjoint c) v C
  beval_c (f ◎ g) v C = beval_c g v (seqC₂ f C)
  beval_c (f ⊕ g) (inj₁ v) C = beval_c f v (leftC g C)
  beval_c (f ⊕ g) (inj₂ v) C = beval_c g v (rightC f C)
  beval_c (f ⊗ g) (v₁ , v₂) C = beval_c g v₂ (sndC f v₁ C)
  beval_c refe⋆ v C = beval_k refe⋆ {!!} C
  beval_c refi⋆ _ C = beval_k refi⋆ {!!} C
  beval_c rile⋆ v C = beval_k rile⋆ (v , (v , {!!})) C
  beval_c rili⋆ (v₁ , (v₂ , _)) C = {!!}

  -- The (d <-> b) part of the computation has been done.
  -- The (a <-> b) backwards computation has been done.
  -- We have an 'a' and examine the context to get the 'c'
  beval_k : { a b c : BF } → (a ⟺ b) → ⟦ a ⟧F → Context a b c c → ⟦ c ⟧F
  beval_k f v emptyC = v
  beval_k g v (seqC₂ f C) = beval_c f v (seqC₁ g C)
  beval_k f v (seqC₁ g C) = beval_k (f ◎ g) v C
  beval_k f v (leftC g C) = beval_k (f ⊕ g) (inj₁ v) C
  beval_k g v (rightC f C) = beval_k (f ⊕ g) (inj₂ v) C
  beval_k g v₂ (sndC f v₁ C) = beval_c f v₁ (fstC v₂ g C)
  beval_k f v₁ (fstC v₂ g C) = beval_k (f ⊗ g) (v₁ , v₂) C

------------------------------------------------------------------------------
-- Top level eval

eval : { a : BF } → (a ⟺ a) → ⟦ a ⟧F → ⟦ a ⟧F
eval f v = eval_c f v emptyC

--

BOOL : BF
BOOL = PLUSF ONEF ONEF

test1 : ⟦ BOOL ⟧F
test1 = eval {BOOL} (iso swap₊) (inj₁ tt)


------------------------------------------------------------------------
-- Some lemmas used by the other modules in this directory
------------------------------------------------------------------------

module Hinze.Lemmas where

open import Stream.Programs
open import Stream.Equality

open import Codata.Musical.Notation hiding (∞)
open import Relation.Binary.PropositionalEquality
open import Function using (_∘_; flip)

------------------------------------------------------------------------
-- Some lemmas from Section 2.3 of Hinze's paper

-- See also Stream.Equality.≊-η.

⋎-∞ : ∀ {A} (x : A) → x ∞ ⋎ x ∞ ≊ x ∞
⋎-∞ x = refl ≺ ♯ ⋎-∞ x

⋎-map : ∀ {A B} (⊟ : A → B) s t →
        ⊟ · s ⋎ ⊟ · t ≊ ⊟ · (s ⋎ t)
⋎-map ⊟ s t with whnf s
⋎-map ⊟ s t | x ≺ s′ = refl ≺ ♯ ⋎-map ⊟ t s′

abide-law : ∀ {A B C} (⊞ : A → B → C) s₁ s₂ t₁ t₂ →
            s₁ ⟨ ⊞ ⟩ s₂ ⋎ t₁ ⟨ ⊞ ⟩ t₂ ≊ (s₁ ⋎ t₁) ⟨ ⊞ ⟩ (s₂ ⋎ t₂)
abide-law ⊞ s₁ s₂ t₁ t₂ with whnf s₁ | whnf s₂
abide-law ⊞ s₁ s₂ t₁ t₂ | x₁ ≺ s₁′ | x₂ ≺ s₂′ =
  refl ≺ ♯ abide-law ⊞ t₁ t₂ s₁′ s₂′

------------------------------------------------------------------------
-- Other lemmas

tailP-cong : ∀ {A} (xs ys : Prog A) →
             xs ≊ ys → tailP xs ≊ tailP ys
tailP-cong xs ys xs≈ys with whnf xs | whnf ys | ≅⇒≃ xs≈ys
tailP-cong xs ys xs≈ys | x ≺ xs′ | y ≺ ys′ | x≡y ≺ xs≈ys′ = xs≈ys′

map-fusion : ∀ {A B C} (f : B → C) (g : A → B) xs →
             f · g · xs ≊ (f ∘ g) · xs
map-fusion f g xs with whnf xs
map-fusion f g xs | x ≺ xs′ = refl ≺ ♯ map-fusion f g xs′

zip-const-is-map : ∀ {A B C} (_∙_ : A → B → C) xs y →
                   xs ⟨ _∙_ ⟩ y ∞ ≊ (λ x → x ∙ y) · xs
zip-const-is-map _∙_ xs y with whnf xs
zip-const-is-map _∙_ xs y | x ≺ xs′ =
  refl ≺ ♯ zip-const-is-map _∙_ xs′ y

zip-flip : ∀ {A B C} (∙ : A → B → C) s t →
           s ⟨ ∙ ⟩ t ≊ t ⟨ flip ∙ ⟩ s
zip-flip ∙ s t with whnf s | whnf t
zip-flip ∙ s t | x ≺ s′ | y ≺ t′ = refl ≺ ♯ zip-flip ∙ s′ t′

zip-⋎-const : ∀ {A B C} (∙ : A → B → C) s t x →
              (s ⋎ t) ⟨ ∙ ⟩ x ∞ ≊ s ⟨ ∙ ⟩ x ∞ ⋎ t ⟨ ∙ ⟩ x ∞
zip-⋎-const _∙_ s t x =
  (s ⋎ t) ⟨ _∙_ ⟩ x ∞
                                         ≊⟨ zip-const-is-map _ (s ⋎ t) _ ⟩
  (λ y → y ∙ x) · (s ⋎ t)
                                         ≊⟨ ≅-sym (⋎-map (λ y → y ∙ x) s t) ⟩
  (λ y → y ∙ x) · s ⋎ (λ y → y ∙ x) · t
                                         ≊⟨ ≅-sym (⋎-cong (s ⟨ _∙_ ⟩ x ∞) ((λ y → y ∙ x) · s)
                                                          (zip-const-is-map _∙_ s x)
                                                      _ _ (zip-const-is-map _∙_ t x)) ⟩
  s ⟨ _∙_ ⟩ x ∞ ⋎ t ⟨ _∙_ ⟩ x ∞
                                         ∎

zip-const-⋎ : ∀ {A B C} (∙ : A → B → C) x s t →
              x ∞ ⟨ ∙ ⟩ (s ⋎ t) ≊ x ∞ ⟨ ∙ ⟩ s ⋎ x ∞ ⟨ ∙ ⟩ t
zip-const-⋎ ∙ x s t =
  x ∞ ⟨ ∙ ⟩ (s ⋎ t)
                                       ≊⟨ zip-flip ∙ (x ∞) (s ⋎ t) ⟩
  (s ⋎ t) ⟨ flip ∙ ⟩ x ∞
                                       ≊⟨ zip-⋎-const (flip ∙) s t x ⟩
  s ⟨ flip ∙ ⟩ x ∞ ⋎ t ⟨ flip ∙ ⟩ x ∞
                                       ≊⟨ ≅-sym (⋎-cong (x ∞ ⟨ ∙ ⟩ s) (s ⟨ flip ∙ ⟩ x ∞)
                                                        (zip-flip ∙ (x ∞) s)
                                                    _ _ (zip-flip ∙ (x ∞) t)) ⟩
  x ∞ ⟨ ∙ ⟩ s ⋎ x ∞ ⟨ ∙ ⟩ t
                                       ∎


-- Note that the flag --guardedness-preserving-type-constructors is
-- not (should not be) enabled in this module.

module TypeConstructorsWhichPreserveGuardedness1 where

open import Common.Coinduction

record ⊤ : Set where

data _⊎_ (A B : Set) : Set where
  inj₁ : A → A ⊎ B
  inj₂ : B → A ⊎ B

record ∃ {A : Set} (B : A → Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

data Rec (A : ∞ Set) : Set where
  fold : ♭ A → Rec A

module ℕ₁ where

  -- Without the flag, the following is non-terminating,
  -- hence, not reduced.
  {-# NON_TERMINATING #-}
  ℕ : Set
  ℕ = ⊤ ⊎ Rec (♯ ℕ)

  zero : ℕ
  zero = inj₁ _  -- yields a type error since ℕ does not reduce

  suc : ℕ → ℕ
  suc n = inj₂ (fold n)

  ℕ-rec : (P : ℕ → Set) →
          P zero →
          (∀ n → P n → P (suc n)) →
          ∀ n → P n
  ℕ-rec P z s (inj₁ _)        = z
  ℕ-rec P z s (inj₂ (fold n)) = s n (ℕ-rec P z s n)

module ℕ₂ where

  data ℕC : Set where
    ′zero : ℕC
    ′suc  : ℕC

  mutual

    ℕ : Set
    ℕ = ∃ λ (c : ℕC) → ℕ′ c

    ℕ′ : ℕC → Set
    ℕ′ ′zero = ⊤
    ℕ′ ′suc  = Rec (♯ ℕ)

  zero : ℕ
  zero = (′zero , _)

  suc : ℕ → ℕ
  suc n = (′suc , fold n)

  ℕ-rec : (P : ℕ → Set) →
          P zero →
          (∀ n → P n → P (suc n)) →
          ∀ n → P n
  ℕ-rec P z s (′zero , _)      = z
  ℕ-rec P z s (′suc  , fold n) = s n (ℕ-rec P z s n)


-- Andreas, 2017-11-01, issue #2824
-- allow built-in pragmas in parametrized modules

data Nat : Set where
  zero : Nat
  suc : Nat → Nat

module M (A : Set) where

  {-# BUILTIN NATURAL Nat #-}

  test = 5


{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.Ints.QuoInt where

open import Cubical.HITs.Ints.QuoInt.Base public

-- open import Cubical.HITs.Ints.QuoInt.Properties public


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

module Classical where

open import Prelude
open import Relation.Nullary.Stable using (Stable) public
open import Relation.Nullary.Decidable.Properties using (Dec→Stable) public

Classical : Type a → Type a
Classical A = ¬ ¬ A

pure : A → Classical A
pure x k = k x

_>>=_ : Classical A → (A → Classical B) → Classical B
xs >>= f = λ k → xs λ x → f x k

_<*>_ : Classical (A → B) → Classical A → Classical B
fs <*> xs = λ k → fs λ f → xs λ x → k (f x)

lem : {A : Type a} → Classical (Dec A)
lem k = k (no (k ∘ yes))


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

open import Types
open import Paths
open import HLevel
open import Equivalences
open import Univalence

module Funext {i} {A : Set i} where

-- Naive non dependent function extensionality

module FunextNonDep {j} {B : Set j} {f g : A → B} (h : (x : A) → f x ≡ g x)
  where

  private
    equiv-comp : {B C : Set j} (f : B ≃ C)
      → is-equiv (λ (g : A → B) → (λ x → f ☆ (g x)))
    equiv-comp f =
      equiv-induction (λ {B} f → is-equiv (λ (g : A → B) → (λ x → f ☆ (g x))))
                      (λ A' y → id-is-equiv (A → A') y) f

    free-path-space-B : Set j
    free-path-space-B = Σ B (λ x → Σ B (λ y → x ≡ y))

    d : A → free-path-space-B
    d x = (f x , (f x , refl))

    e : A → free-path-space-B
    e x = (f x , (g x , h x))

    abstract
      π₁-is-equiv : is-equiv (λ (y : free-path-space-B) → π₁ y)
      π₁-is-equiv =
        iso-is-eq π₁ (λ z → (z , (z , refl))) (λ _ → refl)
          (λ x' → Σ-eq refl
                    (Σ-eq (π₂ (π₂ x'))
                      (trans-cst≡id (π₂ (π₂ x')) refl)))

      comp-π₁-is-equiv : is-equiv (λ (f : A → free-path-space-B)
                                     → (λ x → π₁ (f x)))
      comp-π₁-is-equiv = equiv-comp ((λ (y : free-path-space-B) → π₁ y),
                                     π₁-is-equiv)

      d≡e : d ≡ e
      d≡e = equiv-is-inj (_ , comp-π₁-is-equiv) _ _ refl

  funext-nondep : f ≡ g
  funext-nondep = ap (λ f' x → π₁ (π₂ (f' x))) d≡e

open FunextNonDep

-- Weak function extensionality (a product of contractible types is
-- contractible)
module WeakFunext {j} {P : A → Set j} (e : (x : A) → is-contr (P x)) where

  P-is-unit : P ≡ (λ x → unit)
  P-is-unit = funext-nondep (λ x → eq-to-path (contr-equiv-unit (e x)))

  abstract
    weak-funext : is-contr (Π A P)
    weak-funext = transport (λ Q → is-contr (Π A Q)) (! P-is-unit)
                            ((λ x → tt) , (λ y → funext-nondep (λ x → refl)))

open WeakFunext

-- Naive dependent function extensionality

module FunextDep {j} {P : A → Set j} {f g : Π A P} (h : (x : A) → f x ≡ g x)
  where

  Q : A → Set j
  Q x = Σ (P x) (λ y → y ≡ f x)

  abstract
    Q-is-contr : (x : A) → is-contr (Q x)
    Q-is-contr x = pathto-is-contr (f x)

    ΠAQ-is-contr : is-contr (Π A Q)
    ΠAQ-is-contr = weak-funext Q-is-contr

  Q-f : Π A Q
  Q-f x = (f x , refl)

  Q-g : Π A Q
  Q-g x = (g x , ! (h x))

  abstract
    Q-f≡Q-g : Q-f ≡ Q-g
    Q-f≡Q-g = contr-has-all-paths ΠAQ-is-contr Q-f Q-g

  funext-p : f ≡ g
  funext-p = ap (λ u x → π₁ (u x)) Q-f≡Q-g

open FunextDep

happly : ∀ {j} {P : A → Set j} {f g : Π A P} (p : f ≡ g) → ((x : A) → f x ≡ g x)
happly p x = ap (λ u → u x) p

-- Strong function extensionality

module StrongFunextDep {j} {P : A → Set j} where

  abstract
    funext-refl : (f : Π A P)
      → funext-p (λ x → refl {a = f x}) ≡ refl
    funext-refl f = ap (ap (λ u x → π₁ (u x)))
      (contr-has-all-paths (≡-is-truncated _
                           (ΠAQ-is-contr (λ x → refl)))
                           (Q-f≡Q-g (λ x → refl)) refl)

  abstract
    funext-happly-p : {f g : Π A P} (p : f ≡ g)
      → funext-p (happly p) ≡ p
    funext-happly-p {f} refl = funext-refl f

  abstract
    happly-path : {f : Π A P} {u v : (x : A) → Q (λ x → refl {a = f x}) x}
      (p : u ≡ v) (x : A)
      → happly (ap (λ u x → π₁ (u x)) p) x ≡ π₂ (u x) ∘ ! (π₂ (v x))
    happly-path {u = u} refl x = ! (opposite-right-inverse (π₂ (u x)))

  abstract
    happly-funext-p : {f g : Π A P} (h : (x : A) → f x ≡ g x)
      → happly (funext-p h) ≡ h
    happly-funext-p h = funext-p (λ x → happly-path (Q-f≡Q-g h) x
                                              ∘ opposite-opposite (h x))

  happly-is-equiv : {f g : Π A P} → is-equiv (happly {f = f} {g = g})
  happly-is-equiv = iso-is-eq _ funext-p happly-funext-p funext-happly-p

  funext-is-equiv-p : {f g : Π A P}
    → is-equiv (funext-p {f = f} {g = g})
  funext-is-equiv-p = iso-is-eq _ happly funext-happly-p happly-funext-p

open StrongFunextDep

-- We only export the following

module _ {j} {P : A → Set j} {f g : Π A P} where

  abstract
    funext : (h : (x : A) → f x ≡ g x) → f ≡ g
    funext = FunextDep.funext-p

    funext-happly : (p : f ≡ g) → funext (happly p) ≡ p
    funext-happly p = funext-happly-p p

    happly-funext : (h : (x : A) → f x ≡ g x)
      → happly (funext h) ≡ h
    happly-funext h = happly-funext-p h

    funext-is-equiv : is-equiv funext
    funext-is-equiv = StrongFunextDep.funext-is-equiv-p

  funext-equiv : ((x : A) → f x ≡ g x) ≃ (f ≡ g)
  funext-equiv = (funext , funext-is-equiv)

  happly-equiv : (f ≡ g) ≃ ((x : A) → f x ≡ g x)
  happly-equiv = (happly , happly-is-equiv)


module FStream.Containers where

------------------------------------------------------------------------
-- Containers & their extension
------------------------------------------------------------------------

open import Data.Fin
open import Data.Maybe
open import Data.Unit

open import Library

ListC : Container ℓ₀
Shape    ListC   = ℕ
Position ListC n = Fin n

StateC : ∀ {ℓ} → Set ℓ → Container ℓ
Shape (StateC S) = S → S
Position (StateC S) _ = S

StreamC : Container ℓ₀
Shape StreamC = ⊤
Position StreamC = const ℕ

ReaderC : Set → Container ℓ₀
Shape (ReaderC R) = ⊤
Position (ReaderC R) _ = R

runReader : {R A : Set} → ⟦ ReaderC R ⟧ A → R → A
runReader (proj₁ , proj₂) r = proj₂ r

ask : ∀ {R} → ⟦ ReaderC R ⟧ R
proj₁ ask = tt
proj₂ ask x = x

returnReader : ∀ {ℓ} {A : Set ℓ} {R : Set} → A → ⟦ ReaderC R ⟧ A
returnReader a = tt , (λ _ → a)

ExceptC : Set → Container ℓ₀
Shape (ExceptC E) = Maybe E
Position (ExceptC E₁) (just x) = ⊥
Position (ExceptC E₁) nothing = ⊤

-- TODO Use stdlib
IdC : Container ℓ₀
Shape IdC = ⊤
Position IdC tt = ⊤


-- Andreas, 2015-06-29, issue reported by Nisse

-- {-# OPTIONS -v tc.polarity:20 -v tc.pos:10 #-}
-- {-# OPTIONS -v tc.conv.elim:25 --show-implicit #-}

data ⊥ : Set where

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

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

record _∼_ (A B : Set₁) : Set₁ where
  field
    to               : A → B
    from             : B → A
    right-inverse-of : ∀ x → x ≡ to (from x)

mutual

  record R (c : ⊥) : Set₂ where
    field
      P : F c → Set₁
      Q : {I J : F c} → S c I J → P I → P J → Set₁

    Q′ : ∀ {I J} → S c I J → P I → P J → Set₁
    Q′ s x y = subst P (_∼_.to (S∼≡ c) s) x ≡ y

    field

      Q∼Q′ : ∀ {I J} (s : S c I J) {x y} → Q s x y ∼ Q′ s x y

  F : ⊥ → Set₁
  F ()

  S : (c : ⊥) → F c → F c → Set₁
  S ()

  S∼≡ : (c : ⊥) {I J : F c} → S c I J ∼ (I ≡ J)
  S∼≡ ()

s : ∀ c I → S c I I
s c I = _∼_.from (S∼≡ c) (refl I)

q : ∀ c e I x → R.Q e (s c I) x x
q c e I x =
  _∼_.from (R.Q∼Q′ e (s c I))
           (subst (λ eq → subst (R.P e) eq x ≡ x)
                  (_∼_.right-inverse-of (S∼≡ c) (refl I))
                  (refl x))

-- ERROR WAS (due to faulty positivity analysis for projections):
-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/TypeChecking/Conversion.hs:770


{-# OPTIONS --cubical-compatible --show-implicit #-}
-- {-# OPTIONS -v tc.data:100 #-}
module WithoutK9 where

module Eq {A : Set} (x : A) where

  data _≡_ : A → Set where
    refl : _≡_ x

open Eq

module Bad {A : Set} {x : A} where

  module E = Eq x

  weak-K : {y : A} (p q : E._≡_ y) (α β : p ≡ q) → α ≡ β
  weak-K refl .refl refl refl = refl


------------------------------------------------------------------------
-- The Agda standard library
--
-- Strings
------------------------------------------------------------------------

module Data.String where

open import Data.List as List using (_∷_; []; List)
open import Data.Vec as Vec using (Vec)
open import Data.Colist as Colist using (Colist)
open import Data.Char as Char using (Char)
open import Data.Bool using (Bool; true; false)
open import Function
open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Relation.Binary
open import Relation.Binary.List.StrictLex as StrictLex
import Relation.Binary.On as On
open import Relation.Binary.PropositionalEquality as PropEq using (_≡_)
open import Relation.Binary.PropositionalEquality.TrustMe

import Data.String.Core as Core
open Core public using (String)
open Core

-- Possibly infinite strings.

Costring : Set
Costring = Colist Char

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

infixr 5 _++_

_++_ : String → String → String
_++_ = primStringAppend

toList : String → List Char
toList = primStringToList

fromList : List Char → String
fromList = primStringFromList

toList∘fromList : ∀ s → toList (fromList s) ≡ s
toList∘fromList s = trustMe

fromList∘toList : ∀ s → fromList (toList s) ≡ s
fromList∘toList s = trustMe

toVec : (s : String) → Vec Char (List.length (toList s))
toVec s = Vec.fromList (toList s)

toCostring : String → Costring
toCostring = Colist.fromList ∘ toList

unlines : List String → String
unlines []       = ""
unlines (x ∷ xs) = x ++ "\n" ++ unlines xs

show : String → String
show = primShowString

-- Informative equality test.

_≟_ : Decidable {A = String} _≡_
s₁ ≟ s₂ with primStringEquality s₁ s₂
... | true  = yes trustMe
... | false = no whatever
  where postulate whatever : _

-- Boolean equality test.
--
-- Why is the definition _==_ = primStringEquality not used? One
-- reason is that the present definition can sometimes improve type
-- inference, at least with the version of Agda that is current at the
-- time of writing: see unit-test below.

infix 4 _==_

_==_ : String → String → Bool
s₁ == s₂ = ⌊ s₁ ≟ s₂ ⌋

private

  -- The following unit test does not type-check (at the time of
  -- writing) if _==_ is replaced by primStringEquality.

  data P : (String → Bool) → Set where
    p : (c : String) → P (_==_ c)

  unit-test : P (_==_ "")
  unit-test = p _

setoid : Setoid _ _
setoid = PropEq.setoid String

decSetoid : DecSetoid _ _
decSetoid = PropEq.decSetoid _≟_

-- Lexicographic ordering of strings.

strictTotalOrder : StrictTotalOrder _ _ _
strictTotalOrder =
  On.strictTotalOrder
    (StrictLex.<-strictTotalOrder Char.strictTotalOrder)
    toList


module New.FunctionLemmas where

open import New.Changes

module BinaryValid
  {A : Set} {{CA : ChAlg A}}
  {B : Set} {{CB : ChAlg B}}
  {C : Set} {{CC : ChAlg C}}
  (f : A → B → C) (df : A → Ch A → B → Ch B → Ch C)
  where

  binary-valid-preserve-hp =
    ∀ a da (ada : valid a da)
      b db (bdb : valid b db)
    → valid (f a b) (df a da b db)

  binary-valid-eq-hp =
    ∀ a da (ada : valid a da)
      b db (bdb : valid b db)
    → (f ⊕ df) (a ⊕ da) (b ⊕ db) ≡ f a b ⊕ df a da b db

  binary-valid :
    binary-valid-preserve-hp →
    binary-valid-eq-hp →
    valid f df
  binary-valid ext-valid proof a da ada =
      (λ b db bdb → ext-valid a da ada b db bdb , lem2 b db bdb)
    , ext lem1
    where
      lem1 : ∀ b → f (a ⊕ da) b ⊕ df (a ⊕ da) (nil (a ⊕ da)) b (nil b) ≡
        f a b ⊕ df a da b (nil b)
      lem1 b
        rewrite sym (update-nil b)
        | proof a da ada b (nil b) (nil-valid b)
        | update-nil b = refl
      lem2 : ∀ b (db : Ch B) (bdb : valid b db) →
        f a (b ⊕ db) ⊕ df a da (b ⊕ db) (nil (b ⊕ db)) ≡
        f a b ⊕ df a da b db
      lem2 b db bdb
        rewrite sym (proof a da ada (b ⊕ db) (nil (b ⊕ db)) (nil-valid (b ⊕ db)))
        | update-nil (b ⊕ db) = proof a da ada b db bdb

module TernaryValid
  {A : Set} {{CA : ChAlg A}}
  {B : Set} {{CB : ChAlg B}}
  {C : Set} {{CC : ChAlg C}}
  {D : Set} {{CD : ChAlg D}}
  (f : A → B → C → D) (df : A → Ch A → B → Ch B → C → Ch C → Ch D)
  where

  ternary-valid-preserve-hp =
    ∀ a da (ada : valid a da)
      b db (bdb : valid b db)
      c dc (cdc : valid c dc)
    → valid (f a b c) (df a da b db c dc)

  -- These are explicit definitions only to speed up typechecking.
  CA→B→C→D : ChAlg (A → B → C → D)
  CA→B→C→D = funCA
  f⊕df = (_⊕_ {{CA→B→C→D}} f df)

  -- Already this definition takes a while to typecheck.
  ternary-valid-eq-hp =
    ∀ a (da : Ch A {{CA}}) (ada : valid {{CA}} a da)
      b (db : Ch B {{CB}}) (bdb : valid {{CB}} b db)
      c (dc : Ch C {{CC}}) (cdc : valid {{CC}} c dc)
    → f⊕df (a ⊕ da) (b ⊕ db) (c ⊕ dc) ≡ f a b c ⊕ df a da b db c dc

  ternary-valid :
    ternary-valid-preserve-hp →
    ternary-valid-eq-hp →
    valid f df
  ternary-valid ext-valid proof a da ada =
    binary-valid
      (λ b db bdb c dc cdc → ext-valid a da ada b db bdb c dc cdc)
      lem2
    , ext (λ b → ext (lem1 b))
    where
      open BinaryValid (f a) (df a da)
      lem1 : ∀ b c → f⊕df (a ⊕ da) b c ≡ (f a ⊕ df a da) b c
      lem1 b c
        rewrite sym (update-nil b)
        | sym (update-nil c)
        |
          proof
            a da ada
            b (nil b) (nil-valid b)
            c (nil c) (nil-valid c)
        | update-nil b
        | update-nil c = refl
        -- rewrite
        --   sym
        --   (proof
        --     (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))
        --     b (nil b) (nil-valid b)
        --     c (nil c) (nil-valid c))
        -- | update-nil (a ⊕ da)
        -- | update-nil b
        -- | update-nil c = {! !}
      lem2 : ∀ b db (bdb : valid b db)
               c dc (cdc : valid c dc) →
                 (f a ⊕ df a da) (b ⊕ db) (c ⊕ dc)
               ≡ f a b c ⊕ df a da b db c dc
      lem2 b db bdb c dc cdc
        rewrite sym
          (proof
            a da ada
            (b ⊕ db) (nil (b ⊕ db)) (nil-valid (b ⊕ db))
            (c ⊕ dc) (nil (c ⊕ dc)) (nil-valid (c ⊕ dc))
          )
        | update-nil (b ⊕ db)
        | update-nil (c ⊕ dc) = proof a da ada b db bdb c dc cdc


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

module Fragment.Equational.Theory where

open import Fragment.Equational.Theory.Base public


open import Function
open import Relation.Nullary
open import Relation.Binary hiding (_⇒_)
open import Relation.Binary.PropositionalEquality hiding ([_])
open import Data.Sum
open import Data.Product

delim : ∀ {α β} {A : Set α} {B : Dec A -> Set β}
      -> (d : Dec A) -> (∀ x -> B (yes x)) -> (∀ c -> B (no c)) -> B d
delim (yes x) f g = f x
delim (no  c) f g = g c

drec = λ {α β} {A : Set α} {B : Set β} -> delim {A = A} {B = λ _ -> B}

dcong₂ : ∀ {α β γ} {A : Set α} {B : Set β} {C : Set γ} {x y v w}
       -> (f : A -> B -> C)
       -> (∀ {x y} -> f x v ≡ f y w -> x ≡ y × v ≡ w)
       -> Dec (x ≡ y)
       -> Dec (v ≡ w)
       -> Dec (f x v ≡ f y w)
dcong₂ f inj d₁ d₂ = drec d₁
    (λ p₁ -> drec d₂
      (λ p₂ -> yes (cong₂ f p₁ p₂))
      (λ c  -> no (c ∘ proj₂ ∘ inj)))
    (λ c  -> no (c ∘ proj₁ ∘ inj))

infixl 5 _▻_
infixr 6 _⇒_
infix  4 _≟ᵗ_ _≟ᶜ_ _∈_ _⊂[_]_ _⊂?_ _⊢_
infixr 6 vs_
infixr 5 ƛ_
infixl 7 _·_

data Type : Set where
  ⋆   : Type
  _⇒_ : Type -> Type -> Type

data Con : Set where
  ε   : Con
  _▻_ : Con -> Type -> Con

data _∈_ σ : Con -> Set where
  vz  : ∀ {Γ}   -> σ ∈ Γ ▻ σ
  vs_ : ∀ {Γ τ} -> σ ∈ Γ     -> σ ∈ Γ ▻ τ

data _⊢_ Γ : Type -> Set where
  var : ∀ {σ}   -> σ ∈ Γ     -> Γ ⊢ σ
  ƛ_  : ∀ {σ τ} -> Γ ▻ σ ⊢ τ -> Γ ⊢ σ ⇒ τ
  _·_ : ∀ {σ τ} -> Γ ⊢ σ ⇒ τ -> Γ ⊢ σ     -> Γ ⊢ τ

⇒-inj : ∀ {σ₁ σ₂ τ₁ τ₂} -> σ₁ ⇒ τ₁ ≡ σ₂ ⇒ τ₂ -> σ₁ ≡ σ₂ × τ₁ ≡ τ₂
⇒-inj refl = refl , refl

▻-inj : ∀ {Γ₁ Γ₂ σ₁ σ₂} -> Γ₁ ▻ σ₁ ≡ Γ₂ ▻ σ₂ -> Γ₁ ≡ Γ₂ × σ₁ ≡ σ₂
▻-inj refl = refl , refl

_≟ᵗ_ : Decidable (_≡_ {A = Type})
⋆         ≟ᵗ ⋆         = yes refl
(σ₁ ⇒ τ₁) ≟ᵗ (σ₂ ⇒ τ₂) = dcong₂ _⇒_ ⇒-inj (σ₁ ≟ᵗ σ₂) (τ₁ ≟ᵗ τ₂)
⋆         ≟ᵗ (σ₂ ⇒ τ₂) = no λ()
(σ₁ ⇒ τ₁) ≟ᵗ ⋆         = no λ()

_≟ᶜ_ : Decidable (_≡_ {A = Con})
ε     ≟ᶜ ε     = yes refl
Γ ▻ σ ≟ᶜ Δ ▻ τ = dcong₂ _▻_ ▻-inj (Γ ≟ᶜ Δ) (σ ≟ᵗ τ)
ε     ≟ᶜ Δ ▻ τ = no λ()
Γ ▻ σ ≟ᶜ ε     = no λ()

data _⊂[_]_ : Con -> Type -> Con -> Set where
  stop : ∀ {Γ σ}     -> Γ ⊂[ σ ] Γ ▻ σ
  skip : ∀ {Γ Δ σ τ} -> Γ ⊂[ σ ] Δ     -> Γ ⊂[ σ ] Δ ▻ τ

sub : ∀ {Γ Δ σ} -> Γ ⊂[ σ ] Δ -> σ ∈ Δ
sub  stop    = vz
sub (skip p) = vs (sub p)

⊂-inj : ∀ {Γ Δ σ τ} -> Γ ⊂[ σ ] Δ ▻ τ -> Γ ⊂[ σ ] Δ ⊎ Γ ≡ Δ × σ ≡ τ
⊂-inj  stop    = inj₂ (refl , refl)
⊂-inj (skip p) = inj₁ p

_⊂?_ : ∀ {σ} -> Decidable _⊂[ σ ]_
_⊂?_     Γ  ε      = no λ()
_⊂?_ {σ} Γ (Δ ▻ τ) with λ c₁ -> drec (Γ ⊂? Δ) (yes ∘ skip) (λ c₂ -> no ([ c₂ , c₁ ] ∘ ⊂-inj))
... | r with σ ≟ᵗ τ
... | no  c₁ = r (c₁ ∘ proj₂)
... | yes p₁ rewrite p₁ with Γ ≟ᶜ Δ
... | no  c₁ = r (c₁ ∘ proj₁)
... | yes p₂ rewrite p₂ = yes stop

⊢_ : Type -> Set
⊢ σ = ∀ {Γ} -> Γ ⊢ σ

⟦_⟧ᵗ : Type -> Set
⟦ ⋆     ⟧ᵗ = ⊢ ⋆
⟦ σ ⇒ τ ⟧ᵗ = ⟦ σ ⟧ᵗ -> ⟦ τ ⟧ᵗ

mutual
  ↑ : ∀ {σ} -> ⊢ σ -> ⟦ σ ⟧ᵗ
  ↑ {⋆}     t = t
  ↑ {σ ⇒ τ} f = λ x -> ↑ (f · ↓ x)

  ↓ : ∀ {σ} -> ⟦ σ ⟧ᵗ -> ⊢ σ
  ↓ {⋆}     t = t
  ↓ {σ ⇒ τ} f = λ {Γ} -> ƛ (↓ (f (varˢ Γ σ)))

  varˢ : ∀ Γ σ -> ⟦ σ ⟧ᵗ
  varˢ Γ σ = ↑ (λ {Δ} -> var (diff Δ Γ σ)) where
    diff : ∀ Δ Γ σ -> σ ∈ Δ
    diff Δ Γ σ = drec (Γ ⊂? Δ) sub ⊥ where postulate ⊥ : _

data ⟦_⟧ᶜ : Con -> Set where
  Ø   : ⟦ ε ⟧ᶜ
  _▷_ : ∀ {Γ σ} -> ⟦ Γ ⟧ᶜ -> ⟦ σ ⟧ᵗ -> ⟦ Γ ▻ σ ⟧ᶜ

lookupᵉ : ∀ {Γ σ} -> σ ∈ Γ -> ⟦ Γ ⟧ᶜ -> ⟦ σ ⟧ᵗ
lookupᵉ  vz    (ρ ▷ x) = x
lookupᵉ (vs v) (ρ ▷ x) = lookupᵉ v ρ

idᵉ : ∀ {Γ} -> ⟦ Γ ⟧ᶜ
idᵉ {ε}     = Ø
idᵉ {Γ ▻ σ} = idᵉ ▷ varˢ Γ σ

⟦_⟧ : ∀ {Γ σ} -> Γ ⊢ σ -> ⟦ Γ ⟧ᶜ -> ⟦ σ ⟧ᵗ
⟦ var v ⟧ ρ = lookupᵉ v ρ
⟦ ƛ b   ⟧ ρ = λ x -> ⟦ b ⟧ (ρ ▷ x)
⟦ f · x ⟧ ρ = ⟦ f ⟧ ρ (⟦ x ⟧ ρ)

eval : ∀ {Γ σ} -> Γ ⊢ σ -> ⟦ σ ⟧ᵗ
eval t = ⟦ t ⟧ idᵉ

norm : ∀ {Γ σ} -> Γ ⊢ σ -> Γ ⊢ σ
norm t = ↓ (eval t)

Term : Type -> Set
Term σ = ε ⊢ σ

I : Term (⋆ ⇒ ⋆)
I = ↓ id

K : Term (⋆ ⇒ ⋆ ⇒ ⋆)
K = ↓ const

S : Term ((⋆ ⇒ ⋆ ⇒ ⋆) ⇒ (⋆ ⇒ ⋆) ⇒ ⋆ ⇒ ⋆)
S = ↓ _ˢ_

B : Term ((⋆ ⇒ ⋆) ⇒ (⋆ ⇒ ⋆) ⇒ ⋆ ⇒ ⋆)
B = ↓ _∘′_

C : Term ((⋆ ⇒ ⋆ ⇒ ⋆) ⇒ ⋆ ⇒ ⋆ ⇒ ⋆)
C = ↓ flip

W : Term ((⋆ ⇒ ⋆ ⇒ ⋆) ⇒ ⋆ ⇒ ⋆)
W = ↓ λ f x -> f x x

P : Term ((⋆ ⇒ ⋆ ⇒ ⋆) ⇒ (⋆ ⇒ ⋆) ⇒ ⋆ ⇒ ⋆ ⇒ ⋆)
P = ↓ _on_

O : Term (((⋆ ⇒ ⋆) ⇒ ⋆) ⇒ (⋆ ⇒ ⋆) ⇒ ⋆)
O = ↓ λ g f -> f (g f)

test₁ : norm (ε ▻ ⋆ ⇒ ⋆ ▻ ⋆ ⊢ ⋆ ∋ (ƛ var (vs vs vz) · var vz) · var vz) ≡ var (vs vz) · var vz
test₁ = refl

test₂ : S ≡ ƛ ƛ ƛ var (vs vs vz) · var vz · (var (vs vz) · var vz)
test₂ = refl


{-

This file contains:

Properties of FreeGroupoid:
- Induction principle for the FreeGroupoid on hProps
- ∥freeGroupoid∥₂ is a Group
- FreeGroup A ≡ ∥ FreeGroupoid A ∥₂

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

module Cubical.HITs.FreeGroupoid.Properties where

open import Cubical.HITs.FreeGroupoid.Base
open import Cubical.HITs.FreeGroup renaming (elimProp to freeGroupElimProp)

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.BiInvertible
open import Cubical.Foundations.Univalence using (ua)
open import Cubical.HITs.SetTruncation renaming (rec to recTrunc)

open import Cubical.Algebra.Group
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.Monoid.Base
open import Cubical.Algebra.Semigroup.Base

private
  variable
    ℓ ℓ' : Level
    A : Type ℓ

-- The induction principle for the FreeGroupoid for hProps
elimProp : ∀ {B : FreeGroupoid A → Type ℓ'}
         → ((x : FreeGroupoid A) → isProp (B x))
         → ((a : A) → B (η a))
         → ((g1 g2 : FreeGroupoid A) → B g1 → B g2 → B (g1 · g2))
         → (B ε)
         → ((g : FreeGroupoid A) → B g → B (inv g))
         → (x : FreeGroupoid A)
         → B x
elimProp {B = B} Bprop η-ind ·-ind ε-ind inv-ind = induction where
  induction : ∀ g → B g
  induction (η a) = η-ind a
  induction (g1 · g2) = ·-ind g1 g2 (induction g1) (induction g2)
  induction ε = ε-ind
  induction (inv g) = inv-ind g (induction g)
  induction (assoc g1 g2 g3 i) = path i where
    p1 : B g1
    p1 = induction g1
    p2 : B g2
    p2 = induction g2
    p3 : B g3
    p3 = induction g3
    path : PathP (λ i → B (assoc g1 g2 g3 i)) (·-ind g1 (g2 · g3) p1 (·-ind g2 g3 p2 p3))
                                              (·-ind (g1 · g2) g3 (·-ind g1 g2 p1 p2) p3)
    path = isProp→PathP (λ i → Bprop (assoc g1 g2 g3 i)) (·-ind g1 (g2 · g3) p1 (·-ind g2 g3 p2 p3))
                                                         (·-ind (g1 · g2) g3 (·-ind g1 g2 p1 p2) p3)
  induction (idr g i) = path i where
    p : B g
    p = induction g
    pε : B ε
    pε = induction ε
    path : PathP (λ i → B (idr g i)) p (·-ind g ε p pε)
    path = isProp→PathP (λ i → Bprop (idr g i)) p (·-ind g ε p pε)
  induction (idl g i) = path i where
    p : B g
    p = induction g
    pε : B ε
    pε = induction ε
    path : PathP (λ i → B (idl g i)) p (·-ind ε g pε p)
    path = isProp→PathP (λ i → Bprop (idl g i)) p (·-ind ε g pε p)
  induction (invr g i) = path i where
    p : B g
    p = induction g
    pinv : B (inv g)
    pinv = inv-ind g p
    pε : B ε
    pε = induction ε
    path : PathP (λ i → B (invr g i)) (·-ind g (inv g) p pinv) pε
    path = isProp→PathP (λ i → Bprop (invr g i)) (·-ind g (inv g) p pinv) pε
  induction (invl g i) = path i where
    p : B g
    p = induction g
    pinv : B (inv g)
    pinv = inv-ind g p
    pε : B ε
    pε = induction ε
    path : PathP (λ i → B (invl g i)) (·-ind (inv g) g pinv p) pε
    path = isProp→PathP (λ i → Bprop (invl g i)) (·-ind (inv g) g pinv p) pε

-- The truncation of the FreeGroupoid is a group and is equal to FreeGroup

∥freeGroupoid∥₂IsSet : isSet ∥ FreeGroupoid A ∥₂
∥freeGroupoid∥₂IsSet = squash₂

_∣·∣₂_ : ∥ FreeGroupoid A ∥₂ → ∥ FreeGroupoid A ∥₂ → ∥ FreeGroupoid A ∥₂
_∣·∣₂_ = rec2 ∥freeGroupoid∥₂IsSet (λ g1 g2 → ∣ g1 · g2 ∣₂)

∥freeGroupoid∥₂IsSemiGroup : ∀ {ℓ}{A : Type ℓ} → IsSemigroup _∣·∣₂_
∥freeGroupoid∥₂IsSemiGroup {A = A} = issemigroup ∥freeGroupoid∥₂IsSet |assoc∣₂ where
  inuctionBase : ∀ g1 g2 g3 → ∣ g1 ∣₂ ∣·∣₂ (∣ g2 ∣₂ ∣·∣₂ ∣ g3 ∣₂) ≡ (∣ g1 ∣₂ ∣·∣₂ ∣ g2 ∣₂) ∣·∣₂ ∣ g3 ∣₂
  inuctionBase g1 g2 g3 = cong (λ x → ∣ x ∣₂) (assoc g1 g2 g3)
  Bset : ∀ x y z → isSet (x ∣·∣₂ (y ∣·∣₂ z) ≡ (x ∣·∣₂ y) ∣·∣₂ z)
  Bset x y z = isProp→isSet (squash₂ (x ∣·∣₂ (y ∣·∣₂ z)) ((x ∣·∣₂ y) ∣·∣₂ z))
  |assoc∣₂ : (x y z : ∥ FreeGroupoid A ∥₂) → x ∣·∣₂ (y ∣·∣₂ z) ≡ (x ∣·∣₂ y) ∣·∣₂ z
  |assoc∣₂ = elim3 Bset inuctionBase

∣ε∣₂ : ∥ FreeGroupoid A ∥₂
∣ε∣₂ = ∣ ε ∣₂

∥freeGroupoid∥₂IsMonoid : IsMonoid {A = ∥ FreeGroupoid A ∥₂} ∣ε∣₂ _∣·∣₂_
∥freeGroupoid∥₂IsMonoid = ismonoid ∥freeGroupoid∥₂IsSemiGroup
  (λ x → elim (λ g → isProp→isSet (squash₂ (g ∣·∣₂ ∣ε∣₂) g)) (λ g → cong (λ g' → ∣ g' ∣₂) (sym (idr g))) x)
  (λ x → elim (λ g → isProp→isSet (squash₂ (∣ε∣₂ ∣·∣₂ g) g)) (λ g → cong (λ g' → ∣ g' ∣₂) (sym (idl g))) x)

∣inv∣₂ : ∥ FreeGroupoid A ∥₂ → ∥ FreeGroupoid A ∥₂
∣inv∣₂ = map inv

∥freeGroupoid∥₂IsGroup : IsGroup {G = ∥ FreeGroupoid A ∥₂} ∣ε∣₂ _∣·∣₂_ ∣inv∣₂
∥freeGroupoid∥₂IsGroup = isgroup ∥freeGroupoid∥₂IsMonoid
  (λ x → elim (λ g → isProp→isSet (squash₂ (g ∣·∣₂ (∣inv∣₂ g)) ∣ε∣₂)) (λ g → cong (λ g' → ∣ g' ∣₂) (invr g)) x)
  (λ x → elim (λ g → isProp→isSet (squash₂ ((∣inv∣₂ g) ∣·∣₂ g) ∣ε∣₂)) (λ g → cong (λ g' → ∣ g' ∣₂) (invl g)) x)

∥freeGroupoid∥₂GroupStr : GroupStr ∥ FreeGroupoid A ∥₂
∥freeGroupoid∥₂GroupStr = groupstr ∣ε∣₂ _∣·∣₂_ ∣inv∣₂ ∥freeGroupoid∥₂IsGroup

∥freeGroupoid∥₂Group : Type ℓ → Group ℓ
∥freeGroupoid∥₂Group A = ∥ FreeGroupoid A ∥₂ , ∥freeGroupoid∥₂GroupStr

forgetfulHom : GroupHom (freeGroupGroup A) (∥freeGroupoid∥₂Group A)
forgetfulHom = rec (λ a → ∣ η a ∣₂)

forgetfulHom⁻¹ : GroupHom (∥freeGroupoid∥₂Group A) (freeGroupGroup A)
forgetfulHom⁻¹ = invf , isHom where
  invf : ∥ FreeGroupoid A ∥₂ → FreeGroup A
  invf = recTrunc freeGroupIsSet aux where
    aux : FreeGroupoid A → FreeGroup A
    aux (η a)              = η a
    aux (g1 · g2)          = (aux g1) · (aux g2)
    aux ε                  = ε
    aux (inv g)            = inv (aux g)
    aux (assoc g1 g2 g3 i) = assoc (aux g1) (aux g2) (aux g3) i
    aux (idr g i)          = idr (aux g) i
    aux (idl g i)          = idl (aux g) i
    aux (invr g i)         = invr (aux g) i
    aux (invl g i)         = invl (aux g) i
  isHom : IsGroupHom {A = ∥ FreeGroupoid A ∥₂} {B = FreeGroup A} ∥freeGroupoid∥₂GroupStr invf freeGroupGroupStr
  IsGroupHom.pres· isHom x y = elim2 (λ x y → isProp→isSet (freeGroupIsSet (invf (x ∣·∣₂ y)) ((invf x) · (invf y)))) ind x y where
    ind : ∀ g1 g2 → invf (∣ g1 ∣₂ ∣·∣₂ ∣ g2 ∣₂) ≡ (invf ∣ g1 ∣₂) · (invf ∣ g2 ∣₂)
    ind g1 g2 = refl
  IsGroupHom.pres1 isHom = refl
  IsGroupHom.presinv isHom x = elim (λ x → isProp→isSet (freeGroupIsSet (invf (∣inv∣₂ x)) (inv (invf x)))) ind x where
    ind : ∀ g → invf (∣inv∣₂ ∣ g ∣₂) ≡ inv (invf ∣ g ∣₂)
    ind g = refl

freeGroupTruncIdempotentBiInvEquiv : BiInvEquiv (FreeGroup A) ∥ FreeGroupoid A ∥₂
freeGroupTruncIdempotentBiInvEquiv = biInvEquiv f invf rightInv invf leftInv where
  f : FreeGroup A → ∥ FreeGroupoid A ∥₂
  f = fst forgetfulHom
  invf : ∥ FreeGroupoid A ∥₂ → FreeGroup A
  invf = fst forgetfulHom⁻¹
  rightInv : ∀ (x : ∥ FreeGroupoid A ∥₂) → f (invf x) ≡ x
  rightInv x = elim (λ x → isProp→isSet (squash₂ (f (invf x)) x)) ind x where
    ind : ∀ (g : FreeGroupoid A) → f (invf ∣ g ∣₂) ≡ ∣ g ∣₂
    ind g = elimProp Bprop η-ind ·-ind ε-ind inv-ind g where
      Bprop : ∀ g → isProp (f (invf ∣ g ∣₂) ≡ ∣ g ∣₂)
      Bprop g = squash₂ (f (invf ∣ g ∣₂)) ∣ g ∣₂
      η-ind : ∀ a → f (invf ∣ η a ∣₂) ≡ ∣ η a ∣₂
      η-ind a = refl
      ·-ind : ∀ g1 g2 → f (invf ∣ g1 ∣₂) ≡ ∣ g1 ∣₂ → f (invf ∣ g2 ∣₂) ≡ ∣ g2 ∣₂ → f (invf ∣ g1 · g2 ∣₂) ≡ ∣ g1 · g2 ∣₂
      ·-ind g1 g2 ind1 ind2 =
        f (invf ∣ g1 · g2 ∣₂)
        ≡⟨ cong f (IsGroupHom.pres· (snd forgetfulHom⁻¹) ∣ g1 ∣₂ ∣ g2 ∣₂) ⟩
        f ((invf ∣ g1 ∣₂) · (invf ∣ g2 ∣₂))
        ≡⟨ IsGroupHom.pres· (snd forgetfulHom) (invf ∣ g1 ∣₂) (invf ∣ g2 ∣₂) ⟩
        (f (invf ∣ g1 ∣₂)) ∣·∣₂ (f (invf ∣ g2 ∣₂))
        ≡⟨ cong (λ x → x ∣·∣₂ (f (invf ∣ g2 ∣₂))) ind1 ⟩
        ∣ g1 ∣₂ ∣·∣₂ (f (invf ∣ g2 ∣₂))
        ≡⟨ cong (λ x → ∣ g1 ∣₂ ∣·∣₂ x) ind2 ⟩
        ∣ g1 · g2 ∣₂ ∎
      ε-ind : f (invf ∣ ε ∣₂) ≡ ∣ ε ∣₂
      ε-ind  = refl
      inv-ind : ∀ g → f (invf ∣ g ∣₂) ≡ ∣ g ∣₂ → f (invf ∣ inv g ∣₂) ≡ ∣ inv g ∣₂
      inv-ind g ind =
        f (invf ∣ inv g ∣₂)
        ≡⟨ refl ⟩
        f (invf (∣inv∣₂ ∣ g ∣₂))
        ≡⟨ cong f (IsGroupHom.presinv (snd forgetfulHom⁻¹) ∣ g ∣₂) ⟩
        f (inv (invf ∣ g ∣₂))
        ≡⟨ IsGroupHom.presinv (snd forgetfulHom) (invf ∣ g ∣₂) ⟩
        ∣inv∣₂ (f (invf ∣ g ∣₂))
        ≡⟨ cong ∣inv∣₂ ind ⟩
        ∣inv∣₂ ∣ g ∣₂
        ≡⟨ refl ⟩
        ∣ inv g ∣₂ ∎
  leftInv : ∀ (g : FreeGroup A) → invf (f g) ≡ g
  leftInv g = freeGroupElimProp Bprop η-ind ·-ind ε-ind inv-ind g where
      Bprop : ∀ g → isProp (invf (f g) ≡ g)
      Bprop g = freeGroupIsSet (invf (f g)) g
      η-ind : ∀ a → invf (f (η a)) ≡ (η a)
      η-ind a = refl
      ·-ind : ∀ g1 g2 → invf (f g1) ≡ g1 → invf (f g2) ≡ g2 → invf (f (g1 · g2)) ≡ g1 · g2
      ·-ind g1 g2 ind1 ind2 =
        invf (f (g1 · g2))
        ≡⟨ cong invf (IsGroupHom.pres· (snd forgetfulHom) g1 g2) ⟩
        invf ((f g1) ∣·∣₂ (f g2))
        ≡⟨ IsGroupHom.pres· (snd forgetfulHom⁻¹) (f g1) (f g2) ⟩
        (invf (f g1)) · (invf (f g2))
        ≡⟨ cong (λ x → x · (invf (f g2))) ind1 ⟩
        g1 · (invf (f g2))
        ≡⟨ cong (λ x → g1 · x) ind2 ⟩
        g1 · g2 ∎
      ε-ind : invf (f ε) ≡ ε
      ε-ind  = refl
      inv-ind : ∀ g → invf (f g) ≡ g → invf (f (inv g)) ≡ inv g
      inv-ind g ind =
        invf (f (inv g))
        ≡⟨ cong invf (IsGroupHom.presinv (snd forgetfulHom) g) ⟩
        invf (∣inv∣₂ (f g))
        ≡⟨ IsGroupHom.presinv (snd forgetfulHom⁻¹) (f g) ⟩
        inv (invf (f g))
        ≡⟨ cong inv ind ⟩
        inv g ∎

freeGroupTruncIdempotent≃ : FreeGroup A ≃ ∥ FreeGroupoid A ∥₂
freeGroupTruncIdempotent≃ = biInvEquiv→Equiv-right freeGroupTruncIdempotentBiInvEquiv

freeGroupTruncIdempotent : FreeGroup A ≡ ∥ FreeGroupoid A ∥₂
freeGroupTruncIdempotent = ua freeGroupTruncIdempotent≃


{-

Definition of what it means to be a notion of relational structure

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Foundations.RelationalStructure where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Structure
open import Cubical.Foundations.Univalence
open import Cubical.Functions.FunExtEquiv
open import Cubical.Data.Sigma
open import Cubical.HITs.PropositionalTruncation as Trunc
open import Cubical.HITs.SetQuotients
open import Cubical.Relation.Binary.Base
open import Cubical.Relation.ZigZag.Base

open BinaryRelation

private
  variable
    ℓ ℓ' ℓ'' ℓ''' : Level

-- A notion of structured relation for a structure S assigns a relation on S X and S Y to every relation on X
-- and Y. We require the output to be proposition-valued when the input is proposition-valued.
StrRel : (S : Type ℓ → Type ℓ') (ℓ'' : Level) → Type (ℓ-max (ℓ-suc (ℓ-max ℓ ℓ'')) ℓ')
StrRel {ℓ = ℓ} S ℓ'' = ∀ {A B} (R : Rel A B ℓ) → Rel (S A) (S B) ℓ''

-- Given a type A and relation R, a quotient structure is a structure on the set quotient A/R such that
-- the graph of [_] : A → A/R is a structured relation
InducedQuotientStr : (S : Type ℓ → Type ℓ') (ρ : StrRel S ℓ'')
  (A : TypeWithStr ℓ S) (R : Rel (typ A) (typ A) ℓ)
  → Type (ℓ-max ℓ' ℓ'')
InducedQuotientStr S ρ A R =
  Σ[ s ∈ S (typ A / R) ] ρ (graphRel [_]) (A .snd) s

-- A structured equivalence relation R on a structured type A should induce a structure on A/R
InducesQuotientStr : (S : Type ℓ → Type ℓ') (ρ : StrRel S ℓ'') → Type _
InducesQuotientStr {ℓ = ℓ} S ρ =
  (A : TypeWithStr ℓ S) (R : EquivPropRel (typ A) ℓ)
  → ρ (R .fst .fst) (A .snd) (A .snd)
  → ∃![ s ∈ S (typ A / R .fst .fst) ] ρ (graphRel [_]) (A .snd) s

-- The inverse of a structured relation should be structured
isSymmetricStrRel : {S : Type ℓ → Type ℓ'} (ρ : StrRel S ℓ'') → Type _
isSymmetricStrRel {ℓ = ℓ} {S = S} ρ =
  {X Y : Type ℓ} (R : PropRel X Y ℓ)
  {sx : S X} {sy : S Y}
  → ρ (R .fst) sx sy
  → ρ (invPropRel R .fst) sy sx

-- The composite of structured relations should be structured
isTransitiveStrRel : {S : Type ℓ → Type ℓ'} (ρ : StrRel S ℓ'') → Type _
isTransitiveStrRel {ℓ = ℓ} {S = S} ρ =
  {X Y Z : Type ℓ}
  (R₀ : PropRel X Y ℓ) (R₁ : PropRel Y Z ℓ)
  {sx : S X} {sy : S Y} {sz : S Z}
  → ρ (R₀ .fst) sx sy
  → ρ (R₁ .fst) sy sz
  → ρ (compPropRel R₀ R₁ .fst) sx sz

-- The type of structures on a prop-valued relation should be a prop
preservesPropsStrRel : {S : Type ℓ → Type ℓ'} (ρ : StrRel S ℓ'') → Type _
preservesPropsStrRel {ℓ = ℓ} {S = S} ρ =
  {X Y : Type ℓ} {R : Rel X Y ℓ}
  → (∀ x y → isProp (R x y))
  → (sx : S X) (sy : S Y)
  → isProp (ρ R sx sy)

record SuitableStrRel (S : Type ℓ → Type ℓ') (ρ : StrRel S ℓ'') : Type (ℓ-max (ℓ-max (ℓ-suc ℓ) ℓ') ℓ'')
  where
  field
    quo : InducesQuotientStr S ρ
    symmetric : isSymmetricStrRel ρ
    transitive : isTransitiveStrRel ρ
    prop : preservesPropsStrRel ρ

open SuitableStrRel

-- We can also ask for a notion of structured relations to agree with some notion of structured equivalences.
StrRelMatchesEquiv : {S : Type ℓ → Type ℓ'}
  → StrRel S ℓ'' → StrEquiv S ℓ''' → Type _
StrRelMatchesEquiv {S = S} ρ ι =
  (A B : TypeWithStr _ S) (e : typ A ≃ typ B) →
  ρ (graphRel (e .fst)) (A .snd) (B .snd) ≃ ι A B e

-- Given a suitable notion of structured relation, if we have a structured quasi equivalence relation R
-- between structured types A and B, we get induced structures on the quotients A/(R ∙ R⁻¹) and B/(R⁻¹ ∙ R),
-- and the induced equivalence e : A/(R ∙ R⁻¹) ≃ B/(R⁻¹ ∙ R) is structured with respect to those quotient
-- structures.

quotientPropRel : ∀ {ℓ} {A : Type ℓ} (R : Rel A A ℓ) → PropRel A (A / R) ℓ
quotientPropRel R .fst a t = [ a ] ≡ t
quotientPropRel R .snd _ _ = squash/ _ _

record QERDescends (S : Type ℓ → Type ℓ') (ρ : StrRel S ℓ'')
  (A B : TypeWithStr ℓ S) (R : QuasiEquivRel (typ A) (typ B) ℓ) : Type (ℓ-max ℓ' ℓ'')
  where
  private
    module E = QER→Equiv R

  field
    quoᴸ : InducedQuotientStr S ρ A E.Rᴸ
    quoᴿ : InducedQuotientStr S ρ B E.Rᴿ
    rel : ρ (graphRel (E.Thm .fst)) (quoᴸ .fst) (quoᴿ .fst)

open QERDescends
open isQuasiEquivRel

structuredQER→structuredEquiv : {S : Type ℓ → Type ℓ'} (ρ : StrRel S ℓ'')
  (θ : SuitableStrRel S ρ)
  (A B : TypeWithStr ℓ S) (R : QuasiEquivRel (typ A) (typ B) ℓ)
  → ρ (R .fst .fst) (A .snd) (B .snd)
  → QERDescends S ρ A B R
structuredQER→structuredEquiv ρ θ (X , s) (Y , t) R r .quoᴸ =
  θ .quo (X , s) (QER→EquivRel R)
    (subst (λ R' → ρ R' s s) correction
      (θ .transitive (R .fst) (invPropRel (R .fst)) r (θ .symmetric (R .fst) r)))
    .fst
  where
  correction : compPropRel (R .fst) (invPropRel (R .fst)) .fst ≡ QER→EquivRel R .fst .fst
  correction =
    funExt₂ λ x₀ x₁ →
      (hPropExt squash (R .fst .snd _ _)
        (Trunc.rec (R .fst .snd _ _) (λ {(y , r , r') → R .snd .zigzag r r' (R .snd .fwdRel _)}))
        (λ r → ∣ _ , r , R .snd .fwdRel _ ∣))

structuredQER→structuredEquiv ρ θ (X , s) (Y , t) R r .quoᴿ =
  θ .quo (Y , t) (QER→EquivRel (invQER R))
    (subst (λ R' → ρ R' t t) correction
      (θ .transitive (invPropRel (R .fst)) (R .fst) (θ .symmetric (R .fst) r) r))
    .fst
  where
  correction : compPropRel (invPropRel (R .fst)) (R .fst) .fst ≡ QER→EquivRel (invQER R) .fst .fst
  correction =
    funExt₂ λ y₀ y₁ →
      (hPropExt squash (R .fst .snd _ _)
        (Trunc.rec (R .fst .snd _ _) (λ {(x , r , r') → R .snd .zigzag (R .snd .bwdRel _) r' r}))
        (λ r → ∣ _ , r , R .snd .bwdRel _ ∣))

structuredQER→structuredEquiv ρ θ (X , s) (Y , t) R r .rel =
  subst (λ R' → ρ R' (quol .fst) (quor .fst)) correction
    (θ .transitive (compPropRel (invPropRel (quotientPropRel E.Rᴸ)) (R .fst)) (quotientPropRel E.Rᴿ)
      (θ .transitive (invPropRel (quotientPropRel E.Rᴸ)) (R .fst)
        (θ .symmetric (quotientPropRel E.Rᴸ) (quol .snd))
        r)
      (quor .snd))
  where
  module E = QER→Equiv R
  quol = structuredQER→structuredEquiv ρ θ (X , s) (Y , t) R r .quoᴸ
  quor = structuredQER→structuredEquiv ρ θ (X , s) (Y , t) R r .quoᴿ
  [R] = compPropRel (compPropRel (invPropRel (quotientPropRel E.Rᴸ)) (R .fst)) (quotientPropRel E.Rᴿ)

  correction : [R] .fst ≡ graphRel (E.Thm .fst)
  correction =
    funExt₂ λ qx qy →
      (hPropExt squash (squash/ _ _)
        (Trunc.rec (squash/ _ _)
          (λ {(y , qr , py) →
            Trunc.rec
              (squash/ _ _)
              (λ {(x , px , r) →
                cong (E.Thm .fst) (sym px)
                ∙ eq/ (R .snd .fwd x) y (R .snd .zigzag (R .snd .bwdRel y) r (R .snd .fwdRel x))
                ∙ py})
              qr}))
        (elimProp
          {B = λ qx →
            E.Thm .fst qx ≡ qy → [R] .fst qx qy}
          (λ _ → isPropΠ λ _ → squash)
          (λ x p → ∣ _ , ∣ _ , refl , R .snd .fwdRel x ∣ , p ∣)
          qx))


{-# OPTIONS --universe-polymorphism #-}
{-# OPTIONS --universe-polymorphism #-}
open import Level
open import Categories.Category
open import Categories.Product

-- Parameterize over the categories in whose product we are working
module Categories.Product.Properties
    {o ℓ e o′ ℓ′ e′}
    (C : Category o ℓ e)
    (D : Category o′ ℓ′ e′)
    where

C×D : Category _ _ _
C×D = Product C D
module C×D = Category C×D

import Categories.Product.Projections
open Categories.Product.Projections C D

open import Categories.Functor

open import Relation.Binary using (module IsEquivalence)
open import Relation.Binary.PropositionalEquality as PropEq
    using ()
    renaming (_≡_ to _≣_)

∏₁※∏₂≣id : (∏₁ ※ ∏₂) ≣ id
∏₁※∏₂≣id = PropEq.refl

∏₁※∏₂-identity : (∏₁ ※ ∏₂) ≡ id
∏₁※∏₂-identity h = refl
    where open Heterogeneous C×D

※-distrib' :
    ∀ {o₁ ℓ₁ e₁ o₂ ℓ₂ e₂}
    → {A : Category o₁ ℓ₁ e₁}
    → {B : Category o₂ ℓ₂ e₂}
    → {F : Functor B C}
    → {G : Functor B D}
    → {H : Functor A B}
    → ((F ∘ H) ※ (G ∘ H)) ≣ ((F ※ G) ∘ H)
※-distrib' = PropEq.refl

※-distrib :
    ∀ {o₁ ℓ₁ e₁ o₂ ℓ₂ e₂}
    → {A : Category o₁ ℓ₁ e₁}
    → {B : Category o₂ ℓ₂ e₂}
    → (F : Functor B C)
    → (G : Functor B D)
    → (H : Functor A B)
    → ((F ∘ H) ※ (G ∘ H)) ≡ ((F ※ G) ∘ H)
※-distrib F G H h = refl
    where open Heterogeneous C×D

∏₁※∏₂-distrib :
    ∀ {o₁ ℓ₁ e₁}{A : Category o₁ ℓ₁ e₁}
    → (F : Functor A C×D)
    → ((∏₁ ∘ F) ※ (∏₂ ∘ F)) ≡ F
∏₁※∏₂-distrib F h = refl
    where open Heterogeneous C×D

module Lemmas where
    open Heterogeneous C×D
    open import Data.Product

    lem₁ : {x₁ y₁ x₂ y₂ : Category.Obj C}
        → {x₃ y₃ : Category.Obj D}
        → (f₁ : C [ x₁ , y₁ ])
        → (f₂ : C [ x₂ , y₂ ])
        → (g : D [ x₃ , y₃ ])
        → C   [ f₁ ∼ f₂ ]
        → C×D [ (f₁ , g) ∼ (f₂ , g) ]
    lem₁ f₁ f₂ g (≡⇒∼ f₁≡f₂) = ≡⇒∼ (f₁≡f₂ , Category.Equiv.refl D)

    lem₂ : {x₁ y₁ x₂ y₂ : Category.Obj D}
        → {x₃ y₃ : Category.Obj C}
        → (f : C [ x₃ , y₃ ])
        → (g₁ : D [ x₁ , y₁ ])
        → (g₂ : D [ x₂ , y₂ ])
        → D   [ g₁ ∼ g₂ ]
        → C×D [ (f , g₁) ∼ (f , g₂) ]
    lem₂ f g₁ g₂ (≡⇒∼ g₁≡g₂) = ≡⇒∼ (Category.Equiv.refl C , g₁≡g₂)
open Lemmas

※-preserves-≡ˡ :
    ∀ {o₁ ℓ₁ e₁}
    → {A : Category o₁ ℓ₁ e₁}
    → (F₁ : Functor A C)
    → (F₂ : Functor A C)
    → (G  : Functor A D)
    → (F₁ ≡ F₂) → ((F₁ ※ G) ≡ (F₂ ※ G))
※-preserves-≡ˡ F₁ F₂ G F₁≡F₂ h =
    lem₁ (Functor.F₁ F₁ h) (Functor.F₁ F₂ h) (Functor.F₁ G  h) (F₁≡F₂ h)

※-preserves-≡ʳ :
    ∀ {o₁ ℓ₁ e₁}
    → {A : Category o₁ ℓ₁ e₁}
    → (F  : Functor A C)
    → (G₁ : Functor A D)
    → (G₂ : Functor A D)
    → (G₁ ≡ G₂) → ((F ※ G₁) ≡ (F ※ G₂))
※-preserves-≡ʳ F G₁ G₂ G₁≡G₂ h =
    lem₂ (Functor.F₁ F h) (Functor.F₁ G₁ h) (Functor.F₁ G₂ h) (G₁≡G₂ h)
    where open Heterogeneous C×D

.※-preserves-≡ :
    ∀ {o₁ ℓ₁ e₁}
    → {A : Category o₁ ℓ₁ e₁}
    → (F : Functor A C)
    → (G : Functor A C)
    → (H : Functor A D)
    → (I : Functor A D)
    → (F ≡ G) → (H ≡ I) → ((F ※ H) ≡ (G ※ I))
※-preserves-≡ {A = A} F G H I F≡G H≡I
    = trans {i = F ※ H}{j = G ※ H}{k = G ※ I}
        (※-preserves-≡ˡ F G H F≡G)
        (※-preserves-≡ʳ G H I H≡I)
    where open IsEquivalence (equiv {C = A}{D = C×D})

.※-universal :
    ∀ {o₁ ℓ₁ e₁}{A : Category o₁ ℓ₁ e₁}
    → {F : Functor A C}
    → {G : Functor A D}
    → {I : Functor A C×D}
    → (∏₁ ∘ I ≡ F)
    → (∏₂ ∘ I ≡ G)
    → ((F ※ G) ≡ I)
※-universal {_}{_}{_}{A}{F}{G}{I} p₁ p₂ =
    trans {i = F ※ G}{j = (∏₁ ∘ I) ※ (∏₂ ∘ I)}{k = I}
        (sym {i = (∏₁ ∘ I) ※ (∏₂ ∘ I)}{j = F ※ G}
            (※-preserves-≡ (∏₁ ∘ I) F (∏₂ ∘ I) G p₁ p₂))
        (∏₁※∏₂-distrib I)
    where open IsEquivalence (equiv {C = A}{D = C×D})

※-commute₁ :
    ∀ {o₁ ℓ₁ e₁}{A : Category o₁ ℓ₁ e₁}
    → {F : Functor A C}
    → {G : Functor A D}
    → (∏₁ ∘ (F ※ G) ≡ F)
※-commute₁ h = refl
    where open Heterogeneous C

※-commute₂ :
    ∀ {o₁ ℓ₁ e₁}{A : Category o₁ ℓ₁ e₁}
    → {F : Functor A C}
    → {G : Functor A D}
    → (∏₂ ∘ (F ※ G) ≡ G)
※-commute₂ h = refl
    where open Heterogeneous D


-- {-# OPTIONS --no-coverage #-}
-- {-# OPTIONS -v tc.cover:20 #-}

open import Common.Bool
open import Common.Equality

_∨_ : Bool → Bool → Bool
a ∨ b = if a then true else b

module Works where
  data Term : Bool → Set where
    I   : Term false
    App : ∀ a b c → a ∨ b ≡ c → Term a → Term b → Term c

  -- The following clause works for the coverage checker:

  test : Term false → Set
  test (App false false .false refl I x) = Bool

module Fails where

  data Term : Bool -> Set where
    I   : Term false
    App : ∀ a b c → Term a → Term b → a ∨ b ≡ c → Term c

  -- If we put the equality proof later in App, it fails:

  test : Term false → Set
  test (App false false .false I x refl) = Bool
  -- The following checks, until you split at p.
  -- test (App false false .false I x p) = {!p!}