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

open import HoTT

-- Associativity of the join (work in progress)

module experimental.JoinAssoc {i j k} (A : Type i) (B : Type j) (C : Type k) where

  {- First map -}

  to : (A * B) * C → A * (B * C)
  to = To.f  module _ where

    to-left-glue : (ab : A × B) → left (fst ab) == right (left (snd ab)) :> A * (B * C)
    to-left-glue (a , b) = glue (a , left b)

    module ToLeft = PushoutRec left (right ∘ left) to-left-glue

    to-left : A * B → A * (B * C)
    to-left = ToLeft.f

    to-glue-left : (c : C) (a : A) → to-left (left a) == right (right c)
    to-glue-left c a = glue (a , right c)

    to-glue-right : (c : C) (b : B) → to-left (right b) == right (right c)
    to-glue-right c b = ap right (glue (b , c))

    to-glue-glue : (c : C) (ab : A × B) → to-glue-left c (fst ab) == to-glue-right c (snd ab) [ (λ x → to-left x == right (right c)) ↓ glue ab ]
    to-glue-glue c (a , b) = ↓-swap to-left right _ idp
      (ToLeft.glue-β (a , b) ◃ apd (λ x → glue (a , x)) (glue (b , c)))

    module ToGlue (c : C) = PushoutElim (to-glue-left c) (to-glue-right c) (to-glue-glue c)

    to-glue : (ab-c : (A * B) × C) → to-left (fst ab-c) == right (right (snd ab-c))
    to-glue (ab , c) = M.f ab where module M = ToGlue c

    module To = PushoutRec {d = *-span (A * B) C} to-left (right ∘ right) to-glue

  {- Second map -}

  from : A * (B * C) → (A * B) * C
  from = From.f  module MM where

    from-right-glue : (bc : B × C) → left (right (fst bc)) == right (snd bc)
    from-right-glue (b , c) = glue (right b , c)

    module FromRight = PushoutRec (left ∘ right) right from-right-glue

    from-right : B * C → (A * B) * C
    from-right = FromRight.f

    from-glue-left : (a : A) (b : B) → left (left a) == from-right (left b)
    from-glue-left a b = ap left (glue (a , b))

    from-glue-right : (a : A) (c : C) → left (left a) == from-right (right c)
    from-glue-right a c = glue (left a , c)

    from-glue-glue : (a : A) (bc : B × C) → from-glue-left a (fst bc) == from-glue-right a (snd bc) [ (λ x → left (left a) == from-right x) ↓ glue bc ]
    from-glue-glue a (b , c) = ↓-swap! left from-right _ idp
      (apd (λ x → glue (x , c)) (glue (a , b)) ▹! (FromRight.glue-β (b , c)))

    module FromGlue (a : A) = PushoutElim (from-glue-left a) (from-glue-right a) (from-glue-glue a)

    from-glue : (a-bc : A × (B * C)) → left (left (fst a-bc)) == from-right (snd a-bc)
    from-glue (a , bc) = M.f bc where module M = FromGlue a

    module From = PushoutRec {d = *-span A (B * C)} (left ∘ left) from-right from-glue

  open MM public

  {- First composite -}

  to-from-right-glue' : (b : B) (c : C) → ap (to ∘ from-right) (glue (b , c)) =-= ap right (glue (b , c))
  to-from-right-glue' b c =
    ap (λ z → to (from-right z)) (glue (b , c))     =⟪ ap-∘ to from-right (glue (b , c)) ⟫
    ap to (ap from-right (glue (b , c)))            =⟪ FromRight.glue-β (b , c) |in-ctx ap to ⟫
    ap to (glue ((right b , c) :> ((A * B) × C)))   =⟪ To.glue-β (right b , c)⟫
    ap right (glue (b , c)) ∎∎

  to-from-right-glue : (bc : B × C) → idp == idp [ (λ x → to (from (right x)) == right x) ↓ glue bc ]
  to-from-right-glue (b , c) = ↓-='-in (! (↯ to-from-right-glue' b c))

  module ToFromRight = PushoutElim (λ _ → idp) (λ _ → idp) to-from-right-glue

  to-from-right : (bc : B * C) → to (from (right bc)) == right bc
  to-from-right = ToFromRight.f

  to-from-glue-left' : (a : A) (b : B) → ap to (ap from (glue (a , left b))) =-= glue (a , left b)
  to-from-glue-left' a b =
    ap to (ap from (glue (a , left b)))   =⟪ From.glue-β (a , left b) |in-ctx ap to ⟫
    ap to (ap left (glue (a , b)))        =⟪ ∘-ap to left (glue (a , b)) ⟫
    ap to-left (glue (a , b))             =⟪ ToLeft.glue-β (a , b) ⟫
    glue (a , left b) ∎∎

  to-from-glue-left : (a : A) (b : B) → idp == to-from-right (left b) [ (λ x → to (from x) == x) ↓ glue (a , left b) ]
  to-from-glue-left a b = ↓-∘=idf-in to from (↯ to-from-glue-left' a b)

  to-from-glue-right' : (a : A) (c : C) → ap to (ap from (glue (a , right c))) =-= glue (a , right c)
  to-from-glue-right' a c =
    ap to (ap from (glue (a , right c)))   =⟪ From.glue-β (a , right c) |in-ctx ap to ⟫
    ap to (glue (left a , c))              =⟪ To.glue-β (left a , c) ⟫
    glue (a , right c) ∎∎

  to-from-glue-right : (a : A) (c : C) → idp == to-from-right (right c) [ (λ x → to (from x) == x) ↓ glue (a , right c) ]
  to-from-glue-right a c = ↓-∘=idf-in to from (↯ to-from-glue-right' a c)

  postulate  -- Not proved yet. Some of it is being worked on at JoinAssoc2
    *-assoc : ((A * B) * C) ≃ (A * (B * C))


------------------------------------------------------------------------
-- Nullary relations (some core definitions)
------------------------------------------------------------------------

-- The definitions in this file are reexported by Relation.Nullary.

module Relation.Nullary.Core where

open import Data.Empty

-- Negation.

infix 3 ¬_

¬_ : Set → Set
¬ P = P → ⊥

-- Decidable relations.

data Dec (P : Set) : Set where
  yes : ( p :   P) → Dec P
  no  : (¬p : ¬ P) → Dec P


------------------------------------------------------------------------
-- The Agda standard library
--
-- Transitive closures
------------------------------------------------------------------------

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

module Relation.Binary.Construct.Closure.Transitive where

open import Function
open import Function.Equivalence as Equiv using (_⇔_)
open import Level
open import Relation.Binary
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl)

------------------------------------------------------------------------
-- Transitive closure

infix 4 Plus

syntax Plus R x y = x [ R ]⁺ y

data Plus {a ℓ} {A : Set a} (_∼_ : Rel A ℓ) : Rel A (a ⊔ ℓ) where
  [_]     : ∀ {x y} (x∼y : x ∼ y) → x [ _∼_ ]⁺ y
  _∼⁺⟨_⟩_ : ∀ x {y z} (x∼⁺y : x [ _∼_ ]⁺ y) (y∼⁺z : y [ _∼_ ]⁺ z) →
            x [ _∼_ ]⁺ z

module _ {a ℓ} {A : Set a} {_∼_ : Rel A ℓ} where

 []-injective : ∀ {x y p q} → (x [ _∼_ ]⁺ y ∋ [ p ]) ≡ [ q ] → p ≡ q
 []-injective refl = refl

 -- See also ∼⁺⟨⟩-injectiveˡ and ∼⁺⟨⟩-injectiveʳ in
 -- Relation.Binary.Construct.Closure.Transitive.WithK.

-- "Equational" reasoning notation. Example:
--
--   lemma =
--     x  ∼⁺⟨ [ lemma₁ ] ⟩
--     y  ∼⁺⟨ lemma₂ ⟩∎
--     z  ∎

finally : ∀ {a ℓ} {A : Set a} {_∼_ : Rel A ℓ} x y →
          x [ _∼_ ]⁺ y → x [ _∼_ ]⁺ y
finally _ _ = id

syntax finally x y x∼⁺y = x ∼⁺⟨ x∼⁺y ⟩∎ y ∎

infixr 2 _∼⁺⟨_⟩_
infix  3 finally

-- Map.

map : ∀ {a a′ ℓ ℓ′} {A : Set a} {A′ : Set a′}
        {_R_ : Rel A ℓ} {_R′_ : Rel A′ ℓ′} {f : A → A′} →
      _R_ =[ f ]⇒ _R′_ → Plus _R_ =[ f ]⇒ Plus _R′_
map R⇒R′ [ xRy ]             = [ R⇒R′ xRy ]
map R⇒R′ (x ∼⁺⟨ xR⁺z ⟩ zR⁺y) =
  _ ∼⁺⟨ map R⇒R′ xR⁺z ⟩ map R⇒R′ zR⁺y

------------------------------------------------------------------------
-- Alternative definition of transitive closure

-- A generalisation of Data.List.Nonempty.List⁺.

infixr 5 _∷_ _++_
infix  4 Plus′

syntax Plus′ R x y = x ⟨ R ⟩⁺ y

data Plus′ {a ℓ} {A : Set a} (_∼_ : Rel A ℓ) : Rel A (a ⊔ ℓ) where
  [_] : ∀ {x y} (x∼y : x ∼ y) → x ⟨ _∼_ ⟩⁺ y
  _∷_ : ∀ {x y z} (x∼y : x ∼ y) (y∼⁺z : y ⟨ _∼_ ⟩⁺ z) → x ⟨ _∼_ ⟩⁺ z

-- Transitivity.

_++_ : ∀ {a ℓ} {A : Set a} {_∼_ : Rel A ℓ} {x y z} →
       x ⟨ _∼_ ⟩⁺ y → y ⟨ _∼_ ⟩⁺ z → x ⟨ _∼_ ⟩⁺ z
[ x∼y ]      ++ y∼⁺z = x∼y ∷ y∼⁺z
(x∼y ∷ y∼⁺z) ++ z∼⁺u = x∼y ∷ (y∼⁺z ++ z∼⁺u)

-- Plus and Plus′ are equivalent.

equivalent : ∀ {a ℓ} {A : Set a} {_∼_ : Rel A ℓ} {x y} →
             Plus _∼_ x y ⇔ Plus′ _∼_ x y
equivalent {_∼_ = _∼_} = Equiv.equivalence complete sound
  where
  complete : Plus _∼_ ⇒ Plus′ _∼_
  complete [ x∼y ]             = [ x∼y ]
  complete (x ∼⁺⟨ x∼⁺y ⟩ y∼⁺z) = complete x∼⁺y ++ complete y∼⁺z

  sound : Plus′ _∼_ ⇒ Plus _∼_
  sound [ x∼y ]      = [ x∼y ]
  sound (x∼y ∷ y∼⁺z) = _ ∼⁺⟨ [ x∼y ] ⟩ sound y∼⁺z


------------------------------------------------------------------------
-- Container combinators
------------------------------------------------------------------------

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

module Indexed-container.Combinators where

open import Equality.Propositional
open import Logical-equivalence using (_⇔_)
open import Prelude as P hiding (id; const) renaming (_∘_ to _⊚_)
open import Prelude.Size

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

open import Indexed-container
open import Relation

-- An identity combinator.
--
-- Taken from "Indexed containers" by Altenkirch, Ghani, Hancock,
-- McBride and Morris (JFP, 2015).

id : ∀ {i} {I : Type i} → Container I I
id = (λ _ → ↑ _ ⊤) ◁ λ {i} _ i′ → i ≡ i′

-- An unfolding lemma for ⟦ id ⟧.

⟦id⟧↔ : ∀ {k ℓ x} {I : Type ℓ} {X : Rel x I} {i} →
        Extensionality? k ℓ (ℓ ⊔ x) →
        ⟦ id ⟧ X i ↝[ k ] X i
⟦id⟧↔ {X = X} {i} ext =
  ↑ _ ⊤ × (λ i′ → i ≡ i′) ⊆ X  ↔⟨ drop-⊤-left-× (λ _ → Bijection.↑↔) ⟩
  (λ i′ → i ≡ i′) ⊆ X          ↔⟨⟩
  (∀ {i′} → i ≡ i′ → X i′)     ↔⟨ Bijection.implicit-Π↔Π ⟩
  (∀ i′ → i ≡ i′ → X i′)       ↝⟨ inverse-ext? (λ ext → ∀-intro _ ext) ext ⟩□
  X i                          □

-- An unfolding lemma for ⟦ id ⟧₂.

⟦id⟧₂↔ :
  ∀ {k ℓ x} {I : Type ℓ} {X : Rel x I} →
  Extensionality? k ℓ ℓ →
  ∀ (R : ∀ {i} → Rel₂ ℓ (X i)) {i} →
  (x y : ⟦ id ⟧ X i) →

  ⟦ id ⟧₂ R (x , y)
    ↝[ k ]
  proj₁ x ≡ proj₁ y × R (proj₂ x refl , proj₂ y refl)

⟦id⟧₂↔ ext R {i} x@(s , f) y@(t , g) =

  ⟦ id ⟧₂ R (x , y)                               ↔⟨⟩

  (∃ λ (eq : s ≡ t) →
   ∀ {o} (p : i ≡ o) →
   R (f p , g (subst (λ _ → i ≡ o) eq p)))        ↔⟨ ∃-cong (λ _ → Bijection.implicit-Π↔Π) ⟩

  (∃ λ (eq : s ≡ t) →
   ∀ o (p : i ≡ o) →
   R (f p , g (subst (λ _ → i ≡ o) eq p)))        ↝⟨ ∃-cong (λ _ → inverse-ext? (λ ext → ∀-intro _ ext) ext) ⟩

  (∃ λ (eq : s ≡ t) →
   R (f refl , g (subst (λ _ → i ≡ i) eq refl)))  ↝⟨ ∃-cong (λ eq → ≡⇒↝ _ (cong (λ eq → R (f refl , g eq)) (subst-const eq))) ⟩

  s ≡ t × R (f refl , g refl)                     □

-- A second unfolding lemma for ⟦ id ⟧₂.

⟦id⟧₂≡↔ :
  ∀ {ℓ} {I : Type ℓ} {X : Rel ℓ I} {i} →
  Extensionality ℓ ℓ →
  (x y : ⟦ id ⟧ X i) →
  ⟦ id ⟧₂ (uncurry _≡_) (x , y) ↔ x ≡ y
⟦id⟧₂≡↔ ext x@(s , f) y@(t , g) =

  ⟦ id ⟧₂ (uncurry _≡_) (x , y)  ↝⟨ ⟦id⟧₂↔ ext (uncurry _≡_) x y ⟩

  s ≡ t × f refl ≡ g refl        ↔⟨ ∃-cong (λ _ → Eq.≃-≡ (Eq.↔⇒≃ $ inverse $ ∀-intro _ ext)) ⟩

  s ≡ t × (λ _ → f) ≡ (λ _ → g)  ↔⟨ ∃-cong (λ _ → Eq.≃-≡ (Eq.↔⇒≃ Bijection.implicit-Π↔Π)) ⟩

  s ≡ t × (λ {_} → f) ≡ g        ↝⟨ ≡×≡↔≡ ⟩

  x ≡ y                          □

-- A constant combinator.

const : ∀ {i} {I : Type i} → Rel i I → Container I I
const X = X ◁ λ _ _ → ⊥

-- An unfolding lemma for ⟦ const ⟧.

⟦const⟧↔ : ∀ {k ℓ y} {I : Type ℓ} X {Y : Rel y I} {i} →
           Extensionality? k ℓ (ℓ ⊔ y) →
           ⟦ const X ⟧ Y i ↝[ k ] X i
⟦const⟧↔ {k} {ℓ} {I = I} X {Y} {i} ext =
  X i × (∀ {i} → ⊥ → Y i)  ↔⟨ ∃-cong (λ _ → Bijection.implicit-Π↔Π) ⟩
  X i × (∀ i → ⊥ → Y i)    ↝⟨ ∃-cong (λ _ → ∀-cong ext λ _ → Π⊥↔⊤ (lower-extensionality? k lzero ℓ ext)) ⟩
  X i × (I → ⊤)            ↔⟨ drop-⊤-right (λ _ → →-right-zero) ⟩
  X i                      □

-- An unfolding lemma for ⟦ const ⟧₂.

⟦const⟧₂↔ :
  ∀ {k ℓ y} {I : Type ℓ} {X} {Y : Rel y I} →
  Extensionality? k ℓ ℓ →
  ∀ (R : ∀ {i} → Rel₂ ℓ (Y i)) {i}
  (x y : ⟦ const X ⟧ Y i) →

  ⟦ const X ⟧₂ R (x , y)
    ↝[ k ]
  proj₁ x ≡ proj₁ y

⟦const⟧₂↔ {X = X} ext R x@(s , f) y@(t , g) =

  ⟦ const X ⟧₂ R (x , y)                                ↔⟨⟩

  (∃ λ (eq : s ≡ t) →
   ∀ {o} (p : ⊥) → R (f p , g (subst (λ _ → ⊥) eq p)))  ↔⟨ ∃-cong (λ _ → Bijection.implicit-Π↔Π) ⟩

  (∃ λ (eq : s ≡ t) →
   ∀ o (p : ⊥) → R (f p , g (subst (λ _ → ⊥) eq p)))    ↝⟨ ∃-cong (λ _ → ∀-cong ext λ _ → Π⊥↔⊤ ext) ⟩

  (∃ λ (eq : s ≡ t) → ∀ o → ⊤)                          ↔⟨ drop-⊤-right (λ _ → →-right-zero) ⟩

  s ≡ t                                                 □

  where
  open Container

-- A composition combinator.

infixr 9 _∘_

_∘_ : ∀ {ℓ} {I J K : Type ℓ} →
      Container J K → Container I J → Container I K
C ∘ D =
  ⟦ C ⟧ (Shape D)
    ◁
  (λ { (s , f) i →
       ∃ λ j → ∃ λ (p : Position C s j) → Position D (f p) i })
  where
  open Container

-- An unfolding lemma for ⟦ C ∘ D ⟧.

⟦∘⟧↔ : ∀ {fk ℓ x} {I J K : Type ℓ} {X : Rel x I} →
       Extensionality? fk ℓ (ℓ ⊔ x) →
       ∀ (C : Container J K) {D : Container I J} {k} →
       ⟦ C ∘ D ⟧ X k ↝[ fk ] ⟦ C ⟧ (⟦ D ⟧ X) k
⟦∘⟧↔ {X = X} ext C {D} {k} =

  ⟦ C ∘ D ⟧ X k                                                     ↔⟨⟩

  (∃ λ { (s , f) →
         ∀ {i} →
         (∃ λ j → ∃ λ (p : Position C s j) → Position D (f p) i) →
         X i })                                                     ↔⟨ inverse Σ-assoc ⟩

  (∃ λ s →
   ∃ λ (f : Position C s ⊆ Shape D) →
     ∀ {i} →
     (∃ λ j → ∃ λ (p : Position C s j) → Position D (f p) i) →
     X i)                                                           ↝⟨ (∃-cong λ _ → ∃-cong λ _ → implicit-∀-cong ext $
                                                                        from-isomorphism currying) ⟩
  (∃ λ s →
   ∃ λ (f : Position C s ⊆ Shape D) →
     ∀ {i} j →
     (∃ λ (p : Position C s j) → Position D (f p) i) →
     X i)                                                           ↔⟨ (∃-cong λ _ → ∃-cong λ _ → Bijection.implicit-Π↔Π) ⟩

  (∃ λ s →
   ∃ λ (f : Position C s ⊆ Shape D) →
     ∀ i j →
     (∃ λ (p : Position C s j) → Position D (f p) i) →
     X i)                                                           ↔⟨ (∃-cong λ _ → ∃-cong λ _ → Π-comm) ⟩

  (∃ λ s →
   ∃ λ (f : Position C s ⊆ Shape D) →
     ∀ j i →
     (∃ λ (p : Position C s j) → Position D (f p) i) →
     X i)                                                           ↔⟨ (∃-cong λ _ → ∃-cong λ _ → inverse Bijection.implicit-Π↔Π) ⟩

  (∃ λ s →
   ∃ λ (f : Position C s ⊆ Shape D) →
     ∀ {j} i →
     (∃ λ (p : Position C s j) → Position D (f p) i) →
     X i)                                                           ↔⟨ (∃-cong λ _ → inverse implicit-ΠΣ-comm) ⟩

  (∃ λ s → ∀ {j} →
   ∃ λ (f : Position C s j → Shape D j) →
     ∀ i →
     (∃ λ (p : Position C s j) → Position D (f p) i) →
     X i)                                                           ↝⟨ (∃-cong λ _ → implicit-∀-cong ext $ ∃-cong λ _ → ∀-cong ext λ _ →
                                                                        from-isomorphism currying) ⟩
  (∃ λ s → ∀ {j} →
   ∃ λ (f : Position C s j → Shape D j) →
     ∀ i → (p : Position C s j) → Position D (f p) i → X i)         ↝⟨ (∃-cong λ _ → implicit-∀-cong ext $ ∃-cong λ _ → from-isomorphism Π-comm) ⟩

  (∃ λ s → ∀ {j} →
   ∃ λ (f : Position C s j → Shape D j) →
     (p : Position C s j) → ∀ i → Position D (f p) i → X i)         ↝⟨ (∃-cong λ _ → implicit-∀-cong ext $ from-isomorphism $ inverse ΠΣ-comm) ⟩

  (∃ λ s → ∀ {j} → Position C s j →
   ∃ λ (s′ : Shape D j) → ∀ i → Position D s′ i → X i)              ↝⟨ (∃-cong λ _ → implicit-∀-cong ext $ ∀-cong ext λ _ → ∃-cong λ _ →
                                                                        from-isomorphism $ inverse Bijection.implicit-Π↔Π) ⟩
  (∃ λ s → ∀ {j} → Position C s j →
   ∃ λ (s′ : Shape D j) → Position D s′ ⊆ X)                        ↔⟨⟩

  ⟦ C ⟧ (⟦ D ⟧ X) k                                                 □

  where
  open Container

-- TODO: Define ⟦∘⟧₂↔ (an unfolding lemma for ⟦ C ∘ D ⟧₂).

-- A reindexing combinator.
--
-- Taken from "Indexed containers".

reindex₂ : ∀ {ℓ} {I O₁ O₂ : Type ℓ} →
           (O₂ → O₁) → Container I O₁ → Container I O₂
reindex₂ f (S ◁ P) = (S ⊚ f) ◁ P

-- An unfolding lemma for ⟦ reindex₂ f C ⟧.

⟦reindex₂⟧↔ : ∀ {ℓ x} {I O₁ O₂ : Type ℓ} (f : O₂ → O₁)
              (C : Container I O₁) {X : Rel x I} {o} →
              ⟦ reindex₂ f C ⟧ X o ↔ ⟦ C ⟧ X (f o)
⟦reindex₂⟧↔ f C = Bijection.id

-- An unfolding lemma for ⟦ reindex₂ f C ⟧₂.

⟦reindex₂⟧₂↔ :
  ∀ {ℓ x} {I O : Type ℓ} {X : Rel x I}
  (C : Container I O) (f : I → O) (R : ∀ {i} → Rel₂ ℓ (X i)) {i}
  (x y : ⟦ reindex₂ f C ⟧ X i) →

  ⟦ reindex₂ f C ⟧₂ R (x , y) ↔ ⟦ C ⟧₂ R (x , y)

⟦reindex₂⟧₂↔ C f R x@(s , g) y@(t , h) =

  ⟦ reindex₂ f C ⟧₂ R (x , y)                                     ↔⟨⟩

  (∃ λ (eq : s ≡ t) →
   ∀ {o} (p : Position (reindex₂ f C) s o) →
   R (g p , h (subst (λ s → Position (reindex₂ f C) s o) eq p)))  ↔⟨⟩

  (∃ λ (eq : s ≡ t) →
   ∀ {o} (p : Position C s o) →
   R (g p , h (subst (λ s → Position C s o) eq p)))               ↔⟨⟩

  ⟦ C ⟧₂ R (x , y)                                                □

  where
  open Container

-- Another reindexing combinator.

reindex₁ : ∀ {ℓ} {I₁ I₂ O : Type ℓ} →
           (I₁ → I₂) → Container I₁ O → Container I₂ O
reindex₁ f C =
  Shape C
    ◁
  (λ s i → ∃ λ i′ → f i′ ≡ i × Position C s i′)
  where
  open Container

-- An unfolding lemma for ⟦ reindex₁ f C ⟧.

⟦reindex₁⟧↔ : ∀ {k ℓ x} {I₁ I₂ O : Type ℓ} {f : I₁ → I₂} →
              Extensionality? k ℓ (ℓ ⊔ x) →
              ∀ (C : Container I₁ O) {X : Rel x I₂} {o} →
              ⟦ reindex₁ f C ⟧ X o ↝[ k ] ⟦ C ⟧ (X ⊚ f) o
⟦reindex₁⟧↔ {f = f} ext C {X} {o} =
  ⟦ reindex₁ f C ⟧ X o                                 ↔⟨ (∃-cong λ _ → Bijection.implicit-Π↔Π) ⟩

  (∃ λ (s : Shape C o) →
   ∀ i → (∃ λ i′ → f i′ ≡ i × Position C s i′) → X i)  ↝⟨ (∃-cong λ _ → ∀-cong ext λ _ → from-isomorphism currying) ⟩

  (∃ λ (s : Shape C o) →
   ∀ i i′ → f i′ ≡ i × Position C s i′ → X i)          ↝⟨ (∃-cong λ _ → ∀-cong ext λ _ → ∀-cong ext λ _ → from-isomorphism currying) ⟩

  (∃ λ (s : Shape C o) →
   ∀ i i′ → f i′ ≡ i → Position C s i′ → X i)          ↔⟨ (∃-cong λ _ → Π-comm) ⟩

  (∃ λ (s : Shape C o) →
   ∀ i i′ → f i ≡ i′ → Position C s i → X i′)          ↝⟨ (∃-cong λ _ → ∀-cong ext λ _ → inverse-ext? (λ ext → ∀-intro _ ext) ext) ⟩

  (∃ λ (s : Shape C o) →
   ∀ i → Position C s i → X (f i))                     ↔⟨ (∃-cong λ _ → inverse Bijection.implicit-Π↔Π) ⟩

  ⟦ C ⟧ (X ⊚ f) o                                      □
  where
  open Container

-- An unfolding lemma for ⟦ reindex₁ f C ⟧₂.

⟦reindex₁⟧₂↔ :
  ∀ {k ℓ x} {I O : Type ℓ} {X : Rel x O} →
  Extensionality? k ℓ ℓ →
  ∀ (C : Container I O) (f : I → O) (R : ∀ {o} → Rel₂ ℓ (X o)) {o}
  (x y : ⟦ reindex₁ f C ⟧ X o) →

  ⟦ reindex₁ f C ⟧₂ R (x , y)

    ↝[ k ]

  ⟦ C ⟧₂ R ( (proj₁ x , λ p → proj₂ x (_ , refl , p))
           , (proj₁ y , λ p → proj₂ y (_ , refl , p))
           )

⟦reindex₁⟧₂↔ ext C f R x@(s , g) y@(t , h) =

  ⟦ reindex₁ f C ⟧₂ R (x , y)                                             ↔⟨⟩

  (∃ λ (eq : s ≡ t) →
   ∀ {o} (p : ∃ λ o′ → f o′ ≡ o × Position C s o′) →
   R (g p , h (subst (λ s → ∃ λ o′ → f o′ ≡ o × Position C s o′) eq p)))  ↝⟨ (∃-cong λ eq → implicit-∀-cong ext $ ∀-cong ext λ _ →
                                                                              ≡⇒↝ _ $ cong (R ⊚ (g _ ,_) ⊚ h) $
                                                                              lemma eq) ⟩
  (∃ λ (eq : s ≡ t) →
   ∀ {o} (p : ∃ λ o′ → f o′ ≡ o × Position C s o′) →
   R ( g p
     , h ( proj₁ p
         , proj₁ (proj₂ p)
         , subst (λ s → Position C s (proj₁ p)) eq (proj₂ (proj₂ p))
         )
     ))                                                                   ↝⟨ (∃-cong λ _ → implicit-∀-cong ext $ from-isomorphism
                                                                              currying) ⟩
  (∃ λ (eq : s ≡ t) →
   ∀ {o} o′ (p : f o′ ≡ o × Position C s o′) →
   R ( g (o′ , p)
     , h (o′ , proj₁ p , subst (λ s → Position C s o′) eq (proj₂ p))
     ))                                                                   ↝⟨ (∃-cong λ _ → implicit-∀-cong ext $ ∀-cong ext λ _ → from-isomorphism
                                                                              currying) ⟩
  (∃ λ (eq : s ≡ t) →
   ∀ {o} o′ (≡o : f o′ ≡ o) (p : Position C s o′) →
   R ( g (o′ , ≡o , p)
     , h (o′ , ≡o , subst (λ s → Position C s o′) eq p)
     ))                                                                   ↔⟨ (∃-cong λ _ →
                                                                              Bijection.implicit-Π↔Π) ⟩
  (∃ λ (eq : s ≡ t) →
   ∀ o o′ (≡o : f o′ ≡ o) (p : Position C s o′) →
   R ( g (o′ , ≡o , p)
     , h (o′ , ≡o , subst (λ s → Position C s o′) eq p)
     ))                                                                   ↔⟨ (∃-cong λ _ →
                                                                              Π-comm) ⟩
  (∃ λ (eq : s ≡ t) →
   ∀ o o′ (≡o′ : f o ≡ o′) (p : Position C s o) →
   R ( g (o , ≡o′ , p)
     , h (o , ≡o′ , subst (λ s → Position C s o) eq p)
     ))                                                                   ↝⟨ (∃-cong λ _ → ∀-cong ext λ _ →
                                                                              inverse-ext? (λ ext → ∀-intro _ ext) ext) ⟩
  (∃ λ (eq : s ≡ t) →
   ∀ o (p : Position C s o) →
   R ( g (o , refl , p)
     , h (o , refl , subst (λ s → Position C s o) eq p)
     ))                                                                   ↔⟨ (∃-cong λ _ → inverse
                                                                              Bijection.implicit-Π↔Π) ⟩
  (∃ λ (eq : s ≡ t) →
   ∀ {o} (p : Position C s o) →
   R ( g (o , refl , p)
     , h (o , refl , subst (λ s → Position C s o) eq p)
     ))                                                                   ↔⟨⟩

  ⟦ C ⟧₂ R ((s , λ p → g (_ , refl , p)) , (t , λ p → h (_ , refl , p)))  □

  where
  open Container

  lemma = λ (eq : s ≡ t) {o} {p : ∃ λ o′ → f o′ ≡ o × Position C s o′} →

    subst (λ s → ∃ λ o′ → f o′ ≡ o × Position C s o′) eq p                ≡⟨ push-subst-pair′ {y≡z = eq} _ _ (subst-const eq) ⟩

    ( proj₁ p
    , subst (λ { (s , o′) → f o′ ≡ o × Position C s o′ })
            (Σ-≡,≡→≡ eq (subst-const eq)) (proj₂ p)
    )                                                                     ≡⟨⟩

    ( proj₁ p
    , subst (λ { (s , o′) → f o′ ≡ o × Position C s o′ })
            (Σ-≡,≡→≡ eq (trans (subst-const eq) refl)) (proj₂ p)
    )                                                                     ≡⟨ cong (λ eq → _ , subst (λ { (s , o′) → f o′ ≡ o × Position C s o′ })
                                                                                eq (proj₂ p)) $
                                                                             Σ-≡,≡→≡-subst-const eq refl ⟩
    ( proj₁ p
    , subst (λ { (s , o′) → f o′ ≡ o × Position C s o′ })
            (cong₂ _,_ eq refl) (proj₂ p)
    )                                                                     ≡⟨ cong (_ ,_) $
                                                                             push-subst-, {y≡z = cong₂ _,_ eq refl}
                                                                                ((_≡ o) ⊚ f ⊚ proj₂) (uncurry (Position C)) ⟩
    ( proj₁ p
    , subst ((_≡ o) ⊚ f ⊚ proj₂)   (cong₂ _,_ eq refl) (proj₁ (proj₂ p))
    , subst (uncurry (Position C)) (cong₂ _,_ eq refl) (proj₂ (proj₂ p))
    )                                                                     ≡⟨ cong (λ eq′ → _ , eq′
                                                                                , subst (uncurry (Position C)) (cong₂ _,_ eq refl) _) $
                                                                             subst-∘ ((_≡ o) ⊚ f) proj₂ (cong₂ _,_ eq refl) ⟩
    ( proj₁ p
    , subst ((_≡ o) ⊚ f)
            (cong proj₂ (cong₂ _,_ eq refl)) (proj₁ (proj₂ p))
    , subst (uncurry (Position C)) (cong (_, _) eq) (proj₂ (proj₂ p))
    )                                                                     ≡⟨ cong₂ (λ eq₁ eq₂ → _ , subst ((_≡ o) ⊚ f) eq₁ _ , eq₂)
                                                                             (cong-proj₂-cong₂-, eq refl)
                                                                             (sym $ subst-∘ (uncurry (Position C)) (_, _) eq) ⟩
    ( proj₁ p
    , subst ((_≡ o) ⊚ f) refl (proj₁ (proj₂ p))
    , subst (uncurry (Position C) ⊚ (_, _)) eq (proj₂ (proj₂ p))
    )                                                                     ≡⟨⟩

    ( proj₁ p
    , proj₁ (proj₂ p)
    , subst (λ s → Position C s (proj₁ p)) eq (proj₂ (proj₂ p))
    )                                                                     ∎

-- A combined reindexing combinator.
--
-- The application reindex swap is similar to the overline function
-- from Section 6.3.4.1 in Pous and Sangiorgi's "Enhancements of the
-- bisimulation proof method".

reindex : ∀ {ℓ} {I O : Type ℓ} →
          (I → O) → Container I O → Container O I
reindex f = reindex₂ f ⊚ reindex₁ f

-- An unfolding lemma for ⟦ reindex f C ⟧.

⟦reindex⟧↔ : ∀ {k ℓ x} {I O : Type ℓ} {f : I → O} →
             Extensionality? k ℓ (ℓ ⊔ x) →
             ∀ (C : Container I O) {X : Rel x O} {i} →
             ⟦ reindex f C ⟧ X i ↝[ k ] ⟦ C ⟧ (X ⊚ f) (f i)
⟦reindex⟧↔ {f = f} ext C {X} {i} =
  ⟦ reindex f C ⟧ X i                ↔⟨⟩
  ⟦ reindex₂ f (reindex₁ f C) ⟧ X i  ↔⟨⟩
  ⟦ reindex₁ f C ⟧ X (f i)           ↝⟨ ⟦reindex₁⟧↔ ext C ⟩□
  ⟦ C ⟧ (X ⊚ f) (f i)                □

-- An unfolding lemma for ⟦ reindex f C ⟧₂.

⟦reindex⟧₂↔ :
  ∀ {k ℓ x} {I O : Type ℓ} {X : Rel x O} →
  Extensionality? k ℓ ℓ →
  ∀ (C : Container I O) (f : I → O) (R : ∀ {o} → Rel₂ ℓ (X o)) {i}
  (x y : ⟦ reindex f C ⟧ X i) →

  ⟦ reindex f C ⟧₂ R (x , y)

    ↝[ k ]

  ⟦ C ⟧₂ R ( (proj₁ x , λ p → proj₂ x (_ , refl , p))
           , (proj₁ y , λ p → proj₂ y (_ , refl , p))
           )

⟦reindex⟧₂↔ ext C f R x y =

  ⟦ reindex f C ⟧₂ R (x , y)                           ↔⟨⟩

  ⟦ reindex₂ f (reindex₁ f C) ⟧₂ R (x , y)             ↔⟨⟩

  ⟦ reindex₁ f C ⟧₂ R (x , y)                          ↝⟨ ⟦reindex₁⟧₂↔ ext C f R x y ⟩□

  ⟦ C ⟧₂ R ( (proj₁ x , λ p → proj₂ x (_ , refl , p))
           , (proj₁ y , λ p → proj₂ y (_ , refl , p))
           )                                           □

-- If f is an involution, then ν (reindex f C) i is pointwise
-- logically equivalent to ν C i ⊚ f.

mutual

  ν-reindex⇔ :
    ∀ {ℓ} {I : Type ℓ} {C : Container I I} {f : I → I} →
    f ⊚ f ≡ P.id →
    ∀ {i x} → ν (reindex f C) i x ⇔ ν C i (f x)
  ν-reindex⇔ {C = C} {f} inv {i} {x} =
    ν (reindex f C) i x                     ↔⟨⟩
    ⟦ reindex f C ⟧ (ν′ (reindex f C) i) x  ↝⟨ ⟦reindex⟧↔ _ C ⟩
    ⟦ C ⟧ (ν′ (reindex f C) i ⊚ f) (f x)    ↝⟨ ⟦⟧-cong _ C (ν′-reindex⇔ inv) ⟩
    ⟦ C ⟧ (ν′ C i ⊚ f ⊚ f) (f x)            ↔⟨ ≡⇒↝ bijection $ cong (λ g → ⟦ C ⟧ (ν′ C i ⊚ g) (f x)) inv ⟩
    ⟦ C ⟧ (ν′ C i) (f x)                    ↔⟨⟩
    ν C i (f x)                             □

  ν′-reindex⇔ :
    ∀ {ℓ} {I : Type ℓ} {C : Container I I} {f : I → I} →
    f ⊚ f ≡ P.id →
    ∀ {i x} → ν′ (reindex f C) i x ⇔ ν′ C i (f x)
  ν′-reindex⇔ {C = C} {f} inv = record { to = to; from = from }
    where
    to : ∀ {i} → ν′ (reindex f C) i ⊆ ν′ C i ⊚ f
    force (to x) = _⇔_.to (ν-reindex⇔ inv) (force x)

    from : ∀ {i} → ν′ C i ⊚ f ⊆ ν′ (reindex f C) i
    force (from x) = _⇔_.from (ν-reindex⇔ inv) (force x)

-- A cartesian product combinator.
--
-- Similar to a construction in "Containers: Constructing strictly
-- positive types" by Abbott, Altenkirch and Ghani (see
-- Proposition 3.5).

infixr 2 _⊗_

_⊗_ : ∀ {ℓ} {I O : Type ℓ} →
      Container I O → Container I O → Container I O
C₁ ⊗ C₂ =
  (λ o → Shape C₁ o × Shape C₂ o)
    ◁
  (λ { (s₁ , s₂) i → Position C₁ s₁ i ⊎ Position C₂ s₂ i })
  where
  open Container

-- An unfolding lemma for ⟦ C₁ ⊗ C₂ ⟧.

⟦⊗⟧↔ : ∀ {k ℓ x} {I O : Type ℓ} →
       Extensionality? k ℓ (ℓ ⊔ x) →
       ∀ (C₁ C₂ : Container I O) {X : Rel x I} {o} →
       ⟦ C₁ ⊗ C₂ ⟧ X o ↝[ k ] ⟦ C₁ ⟧ X o × ⟦ C₂ ⟧ X o
⟦⊗⟧↔ {k} {ℓ} ext C₁ C₂ {X} {o} =
  ⟦ C₁ ⊗ C₂ ⟧ X o                                                  ↔⟨⟩

  (∃ λ (s : Shape C₁ o × Shape C₂ o) →
   (λ i → Position C₁ (proj₁ s) i ⊎ Position C₂ (proj₂ s) i) ⊆ X)  ↔⟨ inverse Σ-assoc ⟩

  (∃ λ (s₁ : Shape C₁ o) →
   ∃ λ (s₂ : Shape C₂ o) →
   (λ i → Position C₁ s₁ i ⊎ Position C₂ s₂ i) ⊆ X)                ↝⟨ (∃-cong λ _ → ∃-cong λ _ → implicit-∀-cong ext $
                                                                       Π⊎↔Π×Π (lower-extensionality? k lzero ℓ ext)) ⟩
  (∃ λ (s₁ : Shape C₁ o) →
   ∃ λ (s₂ : Shape C₂ o) →
   ∀ {i} → (Position C₁ s₁ i → X i) × (Position C₂ s₂ i → X i))    ↔⟨ (∃-cong λ _ → ∃-cong λ _ → implicit-ΠΣ-comm) ⟩

  (∃ λ (s₁ : Shape C₁ o) →
   ∃ λ (s₂ : Shape C₂ o) →
   Position C₁ s₁ ⊆ X × Position C₂ s₂ ⊆ X)                        ↔⟨ (∃-cong λ _ → ∃-comm) ⟩

  (∃ λ (s₁ : Shape C₁ o) →
   Position C₁ s₁ ⊆ X
     ×
   ∃ λ (s₂ : Shape C₂ o) → Position C₂ s₂ ⊆ X)                     ↔⟨ Σ-assoc ⟩

  (∃ λ (s : Shape C₁ o) → Position C₁ s ⊆ X) ×
  (∃ λ (s : Shape C₂ o) → Position C₂ s ⊆ X)                       ↔⟨⟩

  ⟦ C₁ ⟧ X o × ⟦ C₂ ⟧ X o                                          □
  where
  open Container

-- An unfolding lemma for ⟦ C₁ ⊗ C₂ ⟧₂.

⟦⊗⟧₂↔ :
  ∀ {k ℓ x} {I : Type ℓ} {X : Rel x I} →
  Extensionality? k ℓ ℓ →
  ∀ (C₁ C₂ : Container I I) (R : ∀ {i} → Rel₂ ℓ (X i)) {i}
  (x y : ⟦ C₁ ⊗ C₂ ⟧ X i) →

  let (x₁ , x₂) , f = x
      (y₁ , y₂) , g = y
  in

  ⟦ C₁ ⊗ C₂ ⟧₂ R (x , y)

    ↝[ k ]

  ⟦ C₁ ⟧₂ R ((x₁ , f ⊚ inj₁) , (y₁ , g ⊚ inj₁))
    ×
  ⟦ C₂ ⟧₂ R ((x₂ , f ⊚ inj₂) , (y₂ , g ⊚ inj₂))

⟦⊗⟧₂↔ ext C₁ C₂ R (x@(x₁ , x₂) , f) (y@(y₁ , y₂) , g) =

  ⟦ C₁ ⊗ C₂ ⟧₂ R ((x , f) , (y , g))                                      ↔⟨⟩

  (∃ λ (eq : x ≡ y) →
   ∀ {o} (p : Position (C₁ ⊗ C₂) x o) →
   R (f p , g (subst (λ s → Position (C₁ ⊗ C₂) s o) eq p)))               ↔⟨⟩

  (∃ λ (eq : x ≡ y) →
   ∀ {o} (p : Position C₁ x₁ o ⊎ Position C₂ x₂ o) →
   R ( f p
     , g (subst (λ { (s₁ , s₂) → Position C₁ s₁ o ⊎ Position C₂ s₂ o })
                eq p)
     ))                                                                   ↔⟨ inverse (Σ-cong ≡×≡↔≡ λ _ → Bijection.id) ⟩

  (∃ λ (eq : x₁ ≡ y₁ × x₂ ≡ y₂) →
   ∀ {o} (p : Position C₁ x₁ o ⊎ Position C₂ x₂ o) →
   R ( f p
     , g (subst (λ { (s₁ , s₂) → Position C₁ s₁ o ⊎ Position C₂ s₂ o })
                (cong₂ _,_ (proj₁ eq) (proj₂ eq)) p)
     ))                                                                   ↔⟨ inverse Σ-assoc ⟩

  (∃ λ (eq₁ : x₁ ≡ y₁) →
   ∃ λ (eq₂ : x₂ ≡ y₂) →
   ∀ {o} (p : Position C₁ x₁ o ⊎ Position C₂ x₂ o) →
   R ( f p
     , g (subst (λ { (s₁ , s₂) → Position C₁ s₁ o ⊎ Position C₂ s₂ o })
                (cong₂ _,_ eq₁ eq₂) p)
     ))                                                                   ↝⟨ (∃-cong λ _ → ∃-cong λ _ → implicit-∀-cong ext $ Π⊎↔Π×Π ext) ⟩

  (∃ λ (eq₁ : x₁ ≡ y₁) →
   ∃ λ (eq₂ : x₂ ≡ y₂) →
   ∀ {o} →
   ((p : Position C₁ x₁ o) →
    R ( f (inj₁ p)
      , g (subst (λ { (s₁ , s₂) → Position C₁ s₁ o ⊎ Position C₂ s₂ o })
                 (cong₂ _,_ eq₁ eq₂) (inj₁ p))
      ))
     ×
   ((p : Position C₂ x₂ o) →
    R ( f (inj₂ p)
      , g (subst (λ { (s₁ , s₂) → Position C₁ s₁ o ⊎ Position C₂ s₂ o })
                 (cong₂ _,_ eq₁ eq₂) (inj₂ p))
      )))                                                                 ↝⟨ (∃-cong λ eq₁ → ∃-cong λ eq₂ → implicit-∀-cong ext $
                                                                              (∀-cong ext λ _ → ≡⇒↝ _ $ cong (R ⊚ (f _ ,_)) $
                                                                               lemma₁ eq₁ eq₂)
                                                                                ×-cong
                                                                              (∀-cong ext λ _ → ≡⇒↝ _ $ cong (R ⊚ (f _ ,_)) $
                                                                               lemma₂ eq₁ eq₂)) ⟩
  (∃ λ (eq₁ : x₁ ≡ y₁) →
   ∃ λ (eq₂ : x₂ ≡ y₂) →
   ∀ {o} →
   ((p : Position C₁ x₁ o) →
    R (f (inj₁ p) , g (inj₁ (subst (λ s₁ → Position C₁ s₁ o) eq₁ p))))
     ×
   ((p : Position C₂ x₂ o) →
    R (f (inj₂ p) , g (inj₂ (subst (λ s₂ → Position C₂ s₂ o) eq₂ p)))))   ↔⟨ (∃-cong λ _ → ∃-cong λ _ → implicit-ΠΣ-comm) ⟩

  (∃ λ (eq₁ : x₁ ≡ y₁) →
   ∃ λ (eq₂ : x₂ ≡ y₂) →
   (∀ {o} (p : Position C₁ x₁ o) →
    R (f (inj₁ p) , g (inj₁ (subst (λ s₁ → Position C₁ s₁ o) eq₁ p))))
     ×
   (∀ {o} (p : Position C₂ x₂ o) →
    R (f (inj₂ p) , g (inj₂ (subst (λ s₂ → Position C₂ s₂ o) eq₂ p)))))   ↔⟨ (∃-cong λ _ → ∃-comm) ⟩

  (∃ λ (eq₁ : x₁ ≡ y₁) →
   (∀ {o} (p : Position C₁ x₁ o) →
    R (f (inj₁ p) , g (inj₁ (subst (λ s₁ → Position C₁ s₁ o) eq₁ p))))
     ×
   ∃ λ (eq₂ : x₂ ≡ y₂) →
   (∀ {o} (p : Position C₂ x₂ o) →
    R (f (inj₂ p) , g (inj₂ (subst (λ s₂ → Position C₂ s₂ o) eq₂ p)))))   ↔⟨ Σ-assoc ⟩

  (∃ λ (eq : x₁ ≡ y₁) →
   (∀ {o} (p : Container.Position C₁ x₁ o) →
    R ( f (inj₁ p)
      , g (inj₁ (subst (λ s₁ → Container.Position C₁ s₁ o) eq p)))
      ))
    ×
  (∃ λ (eq : x₂ ≡ y₂) →
   (∀ {o} (p : Container.Position C₂ x₂ o) →
    R ( f (inj₂ p)
      , g (inj₂ (subst (λ s₂ → Container.Position C₂ s₂ o) eq p))
      )))                                                                 ↔⟨⟩

  ⟦ C₁ ⟧₂ R ((x₁ , f ⊚ inj₁) , (y₁ , g ⊚ inj₁))
    ×
  ⟦ C₂ ⟧₂ R ((x₂ , f ⊚ inj₂) , (y₂ , g ⊚ inj₂))                           □

  where
  open Container

  lemma₁ = λ (eq₁ : x₁ ≡ y₁) (eq₂ : x₂ ≡ y₂) {o p} →

    g (subst (λ { (s₁ , s₂) → Position C₁ s₁ o ⊎ Position C₂ s₂ o })
             (cong₂ _,_ eq₁ eq₂) (inj₁ p))                            ≡⟨ cong g $ push-subst-inj₁ {y≡z = cong₂ _,_ eq₁ eq₂} _ _ ⟩

    g (inj₁ (subst (λ { (s₁ , s₂) → Position C₁ s₁ o })
                   (cong₂ _,_ eq₁ eq₂) p))                            ≡⟨ cong (g ⊚ inj₁) $ subst-∘ _ _ (cong₂ _,_ eq₁ eq₂) ⟩

    g (inj₁ (subst (λ s₁ → Position C₁ s₁ o)
                   (cong proj₁ (cong₂ _,_ eq₁ eq₂)) p))               ≡⟨ cong (g ⊚ inj₁) $ cong (flip (subst _) _) $ cong-proj₁-cong₂-, eq₁ eq₂ ⟩∎

    g (inj₁ (subst (λ s₁ → Position C₁ s₁ o) eq₁ p))                  ∎

  lemma₂ = λ (eq₁ : x₁ ≡ y₁) (eq₂ : x₂ ≡ y₂) {o p} →

    g (subst (λ { (s₁ , s₂) → Position C₁ s₁ o ⊎ Position C₂ s₂ o })
             (cong₂ _,_ eq₁ eq₂) (inj₂ p))                            ≡⟨ cong g $ push-subst-inj₂ {y≡z = cong₂ _,_ eq₁ eq₂} _ _ ⟩

    g (inj₂ (subst (λ { (s₁ , s₂) → Position C₂ s₂ o })
                   (cong₂ _,_ eq₁ eq₂) p))                            ≡⟨ cong (g ⊚ inj₂) $ subst-∘ _ _ (cong₂ _,_ eq₁ eq₂) ⟩

    g (inj₂ (subst (λ s₂ → Position C₂ s₂ o)
                   (cong proj₂ (cong₂ _,_ eq₁ eq₂)) p))               ≡⟨ cong (g ⊚ inj₂) $ cong (flip (subst _) _) $ cong-proj₂-cong₂-, eq₁ eq₂ ⟩∎

    g (inj₂ (subst (λ s₂ → Position C₂ s₂ o) eq₂ p))                  ∎

-- The greatest fixpoint ν (C₁ ⊗ C₂) i is contained in the
-- intersection ν C₁ i ∩ ν C₂ i.

ν-⊗⊆ :
  ∀ {ℓ} {I : Type ℓ} {C₁ C₂ : Container I I} {i} →
  ν (C₁ ⊗ C₂) i ⊆ ν C₁ i ∩ ν C₂ i
ν-⊗⊆ {C₁ = C₁} {C₂} {i} =
  ν (C₁ ⊗ C₂) i                                      ⊆⟨⟩
  ⟦ C₁ ⊗ C₂ ⟧ (ν′ (C₁ ⊗ C₂) i)                       ⊆⟨ ⟦⊗⟧↔ _ C₁ C₂ ⟩
  ⟦ C₁ ⟧ (ν′ (C₁ ⊗ C₂) i) ∩ ⟦ C₂ ⟧ (ν′ (C₁ ⊗ C₂) i)  ⊆⟨ Σ-map (map C₁ ν-⊗⊆₁′) (map C₂ ν-⊗⊆₂′) ⟩
  ⟦ C₁ ⟧ (ν′ C₁ i) ∩ ⟦ C₂ ⟧ (ν′ C₂ i)                ⊆⟨ P.id ⟩∎
  ν C₁ i ∩ ν C₂ i                                    ∎
  where
  ν-⊗⊆₁′ : ν′ (C₁ ⊗ C₂) i ⊆ ν′ C₁ i
  force (ν-⊗⊆₁′ x) = proj₁ (ν-⊗⊆ (force x))

  ν-⊗⊆₂′ : ν′ (C₁ ⊗ C₂) i ⊆ ν′ C₂ i
  force (ν-⊗⊆₂′ x) = proj₂ (ν-⊗⊆ (force x))

-- A disjoint union combinator.
--
-- Similar to a construction in "Containers: Constructing strictly
-- positive types" by Abbott, Altenkirch and Ghani (see
-- Proposition 3.5).

infixr 2 _⊕_

_⊕_ : ∀ {ℓ} {I O : Type ℓ} →
      Container I O → Container I O → Container I O
C₁ ⊕ C₂ =
  (λ o → Shape C₁ o ⊎ Shape C₂ o)
    ◁
  [ Position C₁ , Position C₂ ]
  where
  open Container

-- An unfolding lemma for ⟦ C₁ ⊕ C₂ ⟧.

⟦⊕⟧↔ : ∀ {ℓ x} {I O : Type ℓ}
       (C₁ C₂ : Container I O) {X : Rel x I} {o} →
       ⟦ C₁ ⊕ C₂ ⟧ X o ↔ ⟦ C₁ ⟧ X o ⊎ ⟦ C₂ ⟧ X o
⟦⊕⟧↔ C₁ C₂ {X} {o} =
  ⟦ C₁ ⊕ C₂ ⟧ X o                               ↔⟨⟩

  (∃ λ (s : Shape C₁ o ⊎ Shape C₂ o) →
   [ Position C₁ , Position C₂ ] s ⊆ X)         ↝⟨ ∃-⊎-distrib-right ⟩

  (∃ λ (s : Shape C₁ o) → Position C₁ s ⊆ X) ⊎
  (∃ λ (s : Shape C₂ o) → Position C₂ s ⊆ X)    ↔⟨⟩

  ⟦ C₁ ⟧ X o ⊎ ⟦ C₂ ⟧ X o                       □
  where
  open Container

-- An unfolding lemma for ⟦ C₁ ⊕ C₂ ⟧₂.

⟦⊕⟧₂↔ :
  ∀ {k ℓ x} {I : Type ℓ} {X : Rel x I} →
  Extensionality? k ℓ ℓ →
  ∀ (C₁ C₂ : Container I I) (R : ∀ {i} → Rel₂ ℓ (X i)) {i}
  (x y : ⟦ C₁ ⊕ C₂ ⟧ X i) →

  ⟦ C₁ ⊕ C₂ ⟧₂ R (x , y)

    ↝[ k ]

  (curry (⟦ C₁ ⟧₂ R) ⊎-rel curry (⟦ C₂ ⟧₂ R))
    (_↔_.to (⟦⊕⟧↔ C₁ C₂) x)
    (_↔_.to (⟦⊕⟧↔ C₁ C₂) y)

⟦⊕⟧₂↔ ext C₁ C₂ R (inj₁ x , f) (inj₁ y , g) =

  ⟦ C₁ ⊕ C₂ ⟧₂ R ((inj₁ x , f) , (inj₁ y , g))                   ↔⟨⟩

  (∃ λ (eq : inj₁ x ≡ inj₁ y) →
   ∀ {o} (p : Position C₁ x o) →
   R ( f p
     , g (subst (λ s → [_,_] {C = λ _ → Rel _ _}
                         (Position C₁) (Position C₂) s o) eq p)
     ))                                                          ↔⟨ inverse $ Σ-cong Bijection.≡↔inj₁≡inj₁ (λ _ → Bijection.id) ⟩

  (∃ λ (eq : x ≡ y) →
   ∀ {o} (p : Position C₁ x o) →
   R ( f p
     , g (subst (λ s → [_,_] {C = λ _ → Rel _ _}
                         (Position C₁) (Position C₂) s o)
                         (cong inj₁ eq) p)
     ))                                                          ↝⟨ (∃-cong λ eq → implicit-∀-cong ext $ ∀-cong ext λ _ →
                                                                     ≡⇒↝ _ $ cong (λ x → R (_ , g x)) $ sym $
                                                                     subst-∘ _ _ eq) ⟩
  (∃ λ (eq : x ≡ y) →
   ∀ {o} (p : Position C₁ x o) →
   R ( f p
     , g (subst (λ s → Position C₁ s o) eq p)
     ))                                                          ↔⟨⟩

  ⟦ C₁ ⟧₂ R ((x , f) , (y , g))                                  □

  where
  open Container

⟦⊕⟧₂↔ _ C₁ C₂ R (inj₁ x , f) (inj₂ y , g) =

  ⟦ C₁ ⊕ C₂ ⟧₂ R ((inj₁ x , f) , (inj₂ y , g))  ↔⟨⟩

  (∃ λ (eq : inj₁ x ≡ inj₂ y) → _)              ↔⟨ inverse $ Σ-cong (inverse Bijection.≡↔⊎) (λ _ → Bijection.id) ⟩

  (∃ λ (eq : ⊥) → _)                            ↔⟨ Σ-left-zero ⟩

  ⊥                                             □

⟦⊕⟧₂↔ _ C₁ C₂ R (inj₂ x , f) (inj₁ y , g) =

  ⟦ C₁ ⊕ C₂ ⟧₂ R ((inj₂ x , f) , (inj₁ y , g))  ↔⟨⟩

  (∃ λ (eq : inj₂ x ≡ inj₁ y) → _)              ↔⟨ inverse $ Σ-cong (inverse Bijection.≡↔⊎) (λ _ → Bijection.id) ⟩

  (∃ λ (eq : ⊥) → _)                            ↔⟨ Σ-left-zero ⟩

  ⊥                                             □

⟦⊕⟧₂↔ ext C₁ C₂ R (inj₂ x , f) (inj₂ y , g) =

  ⟦ C₁ ⊕ C₂ ⟧₂ R ((inj₂ x , f) , (inj₂ y , g))                   ↔⟨⟩

  (∃ λ (eq : inj₂ x ≡ inj₂ y) →
   ∀ {o} (p : Position C₂ x o) →
   R ( f p
     , g (subst (λ s → [_,_] {C = λ _ → Rel _ _}
                         (Position C₁) (Position C₂) s o) eq p)
     ))                                                          ↔⟨ inverse $ Σ-cong Bijection.≡↔inj₂≡inj₂ (λ _ → Bijection.id) ⟩

  (∃ λ (eq : x ≡ y) →
   ∀ {o} (p : Position C₂ x o) →
   R ( f p
     , g (subst (λ s → [_,_] {C = λ _ → Rel _ _}
                         (Position C₁) (Position C₂) s o)
                         (cong inj₂ eq) p)
     ))                                                          ↝⟨ (∃-cong λ eq → implicit-∀-cong ext $ ∀-cong ext λ _ →
                                                                     ≡⇒↝ _ $ cong (λ x → R (_ , g x)) $ sym $
                                                                     subst-∘ _ _ eq) ⟩
  (∃ λ (eq : x ≡ y) →
   ∀ {o} (p : Position C₂ x o) →
   R ( f p
     , g (subst (λ s → Position C₂ s o) eq p)
     ))                                                          ↔⟨⟩

  ⟦ C₂ ⟧₂ R ((x , f) , (y , g))                                  □

  where
  open Container

mutual

  -- A combinator that is similar to the function ⟷ from
  -- Section 6.3.4.1 in Pous and Sangiorgi's "Enhancements of the
  -- bisimulation proof method".

  ⟷[_] : ∀ {ℓ} {I : Type ℓ} →
         Container (I × I) (I × I) → Container (I × I) (I × I)
  ⟷[ C ] = C ⟷ C

  -- A generalisation of ⟷[_].

  infix 1 _⟷_

  _⟷_ : ∀ {ℓ} {I : Type ℓ} →
        (_ _ : Container (I × I) (I × I)) → Container (I × I) (I × I)
  C₁ ⟷ C₂ = C₁ ⊗ reindex swap C₂

-- An unfolding lemma for ⟦ C₁ ⟷ C₂ ⟧.

⟦⟷⟧↔ :
  ∀ {k ℓ x} {I : Type ℓ} →
  Extensionality? k ℓ (ℓ ⊔ x) →
  ∀ (C₁ C₂ : Container (I × I) (I × I)) {X : Rel₂ x I} {i} →
  ⟦ C₁ ⟷ C₂ ⟧ X i
    ↝[ k ]
  ⟦ C₁ ⟧ X i × (⟦ C₂ ⟧ (X ⁻¹) ⁻¹) i
⟦⟷⟧↔ ext C₁ C₂ {X} {i} =
  ⟦ C₁ ⟷ C₂ ⟧ X i                       ↔⟨⟩
  ⟦ C₁ ⊗ reindex swap C₂ ⟧ X i          ↝⟨ ⟦⊗⟧↔ ext C₁ (reindex swap C₂) ⟩
  ⟦ C₁ ⟧ X i × ⟦ reindex swap C₂ ⟧ X i  ↝⟨ ∃-cong (λ _ → ⟦reindex⟧↔ ext C₂) ⟩□
  ⟦ C₁ ⟧ X i × (⟦ C₂ ⟧ (X ⁻¹) ⁻¹) i     □

-- An unfolding lemma for ⟦ C₁ ⟷ C₂ ⟧₂.

⟦⟷⟧₂↔ :
  ∀ {k ℓ x} {I : Type ℓ} {X : Rel₂ x I} →
  Extensionality? k ℓ ℓ →
  ∀ (C₁ C₂ : Container (I × I) (I × I)) (R : ∀ {i} → Rel₂ ℓ (X i)) {i}
  (x y : ⟦ C₁ ⟷ C₂ ⟧ X i) →

  let (s₁ , s₂) , f = x
      (t₁ , t₂) , g = y
  in

  ⟦ C₁ ⟷ C₂ ⟧₂ R (x , y)

    ↝[ k ]

  ⟦ C₁ ⟧₂ R ((s₁ , f ⊚ inj₁) , (t₁ , g ⊚ inj₁))
    ×
  ⟦ C₂ ⟧₂ R ( (s₂ , λ p → f (inj₂ (_ , refl , p)))
            , (t₂ , λ p → g (inj₂ (_ , refl , p)))
            )

⟦⟷⟧₂↔ ext C₁ C₂ R x@((s₁ , s₂) , f) y@((t₁ , t₂) , g) =

  ⟦ C₁ ⟷ C₂ ⟧₂ R (x , y)                                      ↔⟨⟩

  ⟦ C₁ ⊗ reindex swap C₂ ⟧₂ R (x , y)                         ↝⟨ ⟦⊗⟧₂↔ ext C₁ (reindex swap C₂) R _ (_ , g) ⟩

  ⟦ C₁ ⟧₂ R ((s₁ , f ⊚ inj₁) , (t₁ , g ⊚ inj₁))
    ×
  ⟦ reindex swap C₂ ⟧₂ R ((s₂ , f ⊚ inj₂) , (t₂ , g ⊚ inj₂))  ↝⟨ ∃-cong (λ _ → ⟦reindex⟧₂↔ ext C₂ _ R _ (_ , g ⊚ inj₂)) ⟩□

  ⟦ C₁ ⟧₂ R ((s₁ , f ⊚ inj₁) , (t₁ , g ⊚ inj₁))
    ×
  ⟦ C₂ ⟧₂ R ( (s₂ , λ p → f (inj₂ (_ , refl , p)))
            , (t₂ , λ p → g (inj₂ (_ , refl , p)))
            )                                                 □

-- The greatest fixpoint ν (C₁ ⟷ C₂) i is contained in the
-- intersection ν C₁ i ∩ ν C₂ i ⁻¹.

ν-↔⊆ : ∀ {ℓ} {I : Type ℓ} {C₁ C₂ : Container (I × I) (I × I)} {i} →
       ν (C₁ ⟷ C₂) i ⊆ ν C₁ i ∩ ν C₂ i ⁻¹
ν-↔⊆ {C₁ = C₁} {C₂} {i} =
  ν (C₁ ⟷ C₂) i                   ⊆⟨⟩
  ν (C₁ ⊗ reindex swap C₂) i      ⊆⟨ ν-⊗⊆ ⟩
  ν C₁ i ∩ ν (reindex swap C₂) i  ⊆⟨ Σ-map P.id (_⇔_.to (ν-reindex⇔ refl)) ⟩∎
  ν C₁ i ∩ ν C₂ i ⁻¹              ∎

-- The following three lemmas correspond to the second part of
-- Exercise 6.3.24 in Pous and Sangiorgi's "Enhancements of the
-- bisimulation proof method".

-- Post-fixpoints of the container reindex₂ swap id ⊗ C are
-- post-fixpoints of ⟷[ C ].

⊆reindex₂-swap-⊗→⊆⟷ :
  ∀ {ℓ r} {I : Type ℓ} {C : Container (I × I) (I × I)} {R : Rel₂ r I} →
  R ⊆ ⟦ reindex₂ swap id ⊗ C ⟧ R → R ⊆ ⟦ ⟷[ C ] ⟧ R
⊆reindex₂-swap-⊗→⊆⟷ {C = C} {R} R⊆ =
  R                          ⊆⟨ (λ x → lemma₁ x , lemma₂ x) ⟩
  ⟦ C ⟧ R ∩ R ⁻¹             ⊆⟨ Σ-map P.id lemma₃ ⟩
  ⟦ C ⟧ R ∩ ⟦ C ⟧ (R ⁻¹) ⁻¹  ⊆⟨ _⇔_.from (⟦⟷⟧↔ _ C C) ⟩∎
  ⟦ ⟷[ C ] ⟧ R               ∎
  where
  lemma₀ =
    R                                 ⊆⟨ R⊆ ⟩
    ⟦ reindex₂ swap id ⊗ C ⟧ R        ⊆⟨ ⟦⊗⟧↔ _ (reindex₂ swap id) C ⟩∎
    ⟦ reindex₂ swap id ⟧ R ∩ ⟦ C ⟧ R  ∎

  lemma₁ =
    R                                 ⊆⟨ lemma₀ ⟩
    ⟦ reindex₂ swap id ⟧ R ∩ ⟦ C ⟧ R  ⊆⟨ proj₂ ⟩∎
    ⟦ C ⟧ R                           ∎

  lemma₂ =
    R                                 ⊆⟨ lemma₀ ⟩
    ⟦ reindex₂ swap id ⟧ R ∩ ⟦ C ⟧ R  ⊆⟨ proj₁ ⟩
    ⟦ reindex₂ swap id ⟧ R            ⊆⟨ P.id ⟩
    ⟦ id ⟧ R ⁻¹                       ⊆⟨ _⇔_.to (⟦id⟧↔ _) ⟩∎
    R ⁻¹                              ∎

  lemma₃ =
    R             ⊆⟨ lemma₁ ⟩
    ⟦ C ⟧ R       ⊆⟨ map C lemma₂ ⟩∎
    ⟦ C ⟧ (R ⁻¹)  ∎

-- The symmetric closure of a post-fixpoint of ⟷[ C ] is a
-- post-fixpoint of reindex₂ swap id ⊗ C.

⊆⟷→∪-swap⊆reindex₂-swap-⊗ :
  ∀ {ℓ r} {I : Type ℓ} {C : Container (I × I) (I × I)} {R : Rel₂ r I} →
  R ⊆ ⟦ ⟷[ C ] ⟧ R →
  R ∪ R ⁻¹ ⊆ ⟦ reindex₂ swap id ⊗ C ⟧ (R ∪ R ⁻¹)
⊆⟷→∪-swap⊆reindex₂-swap-⊗ {C = C} {R} R⊆ =
  R ∪ R ⁻¹                                            ⊆⟨ (λ x → lemma₁ x , lemma₂ x) ⟩
  ⟦ reindex₂ swap id ⟧ (R ∪ R ⁻¹) ∩ ⟦ C ⟧ (R ∪ R ⁻¹)  ⊆⟨ _⇔_.from (⟦⊗⟧↔ _ (reindex₂ swap id) C) ⟩∎
  ⟦ reindex₂ swap id ⊗ C ⟧ (R ∪ R ⁻¹)                 ∎
  where
  lemma₁ =
    R ∪ R ⁻¹                         ⊆⟨ [ inj₂ , inj₁ ] ⟩
    R ⁻¹ ∪ R                         ⊆⟨ P.id ⟩
    R ⁻¹ ∪ R ⁻¹ ⁻¹                   ⊆⟨ P.id ⟩
    (R ∪ R ⁻¹) ⁻¹                    ⊆⟨ _⇔_.from (⟦id⟧↔ _) ⟩
    ⟦ id ⟧ (R ∪ R ⁻¹) ⁻¹             ⊆⟨ P.id ⟩∎
    ⟦ reindex₂ swap id ⟧ (R ∪ R ⁻¹)  ∎

  lemma₂ =
    R ∪ R ⁻¹                                               ⊆⟨ ⊎-map R⊆ R⊆ ⟩
    ⟦ ⟷[ C ] ⟧ R ∪ ⟦ ⟷[ C ] ⟧ R ⁻¹                         ⊆⟨ ⊎-map (_⇔_.to (⟦⟷⟧↔ _ C C)) (_⇔_.to (⟦⟷⟧↔ _ C C)) ⟩
    ⟦ C ⟧ R ∩ ⟦ C ⟧ (R ⁻¹) ⁻¹ ∪ ⟦ C ⟧ R ⁻¹ ∩ ⟦ C ⟧ (R ⁻¹)  ⊆⟨ ⊎-map proj₁ proj₂ ⟩
    ⟦ C ⟧ R ∪ ⟦ C ⟧ (R ⁻¹)                                 ⊆⟨ [ map C inj₁ , map C inj₂ ] ⟩∎
    ⟦ C ⟧ (R ∪ R ⁻¹)                                       ∎

-- The greatest fixpoint of ⟷[ C ] is pointwise logically equivalent
-- to the greatest fixpoint of reindex₂ swap id ⊗ C.
--
-- Note that this proof is not necessarily size-preserving. TODO:
-- Figure out if the proof can be made size-preserving.

ν-⟷⇔ :
  ∀ {ℓ} {I : Type ℓ} {C : Container (I × I) (I × I)} {p} →
  ν ⟷[ C ] ∞ p ⇔ ν (reindex₂ swap id ⊗ C) ∞ p
ν-⟷⇔ {C = C} = record
  { to =
      let R = ν ⟷[ C ] ∞ in                           $⟨ (λ {_} → ν-out _) ⟩
      R ⊆ ⟦ ⟷[ C ] ⟧ R                                ↝⟨ ⊆⟷→∪-swap⊆reindex₂-swap-⊗ ⟩
      R ∪ R ⁻¹ ⊆ ⟦ reindex₂ swap id ⊗ C ⟧ (R ∪ R ⁻¹)  ↝⟨ unfold _ ⟩
      R ∪ R ⁻¹ ⊆ ν (reindex₂ swap id ⊗ C) ∞           ↝⟨ (λ hyp {_} x → hyp (inj₁ x)) ⟩□
      R ⊆ ν (reindex₂ swap id ⊗ C) ∞                  □

  ; from =
      let R = ν (reindex₂ swap id ⊗ C) ∞ in  $⟨ (λ {_} → ν-out _) ⟩
      R ⊆ ⟦ reindex₂ swap id ⊗ C ⟧ R         ↝⟨ ⊆reindex₂-swap-⊗→⊆⟷ ⟩
      R ⊆ ⟦ ⟷[ C ] ⟧ R                       ↝⟨ unfold _ ⟩□
      R ⊆ ν ⟷[ C ] ∞                         □
  }


-- Andreas, 2013-02-21 issue seems to have been fixed along with issue 796
-- {-# OPTIONS -v tc.decl:10 #-}
module Issue4 where

open import Common.Equality

abstract

  abstract -- a second abstract seems to have no effect

    T : Set -> Set
    T A = A

  see-through : ∀ {A} → T A ≡ A
  see-through = refl

  data Ok (A : Set) : Set where
    ok : T (Ok A) → Ok A

opaque : ∀ {A} → T A ≡ A
opaque = see-through

data Bad (A : Set) : Set where
  bad : T (Bad A) -> Bad A


-- Copyright:  (c) 2016 Ertugrul Söylemez
-- License:    BSD3
-- Maintainer: Ertugrul Söylemez <esz@posteo.de>

module Algebra.Group where

open import Algebra.Group.Group public
open import Algebra.Group.Monoid public
open import Algebra.Group.Semigroup public


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

open import lib.Basics
open import lib.NType2
open import lib.types.Empty
open import lib.types.Group
open import lib.types.Int
open import lib.types.List
open import lib.types.Nat
open import lib.types.Pi
open import lib.types.Sigma

module lib.types.Word {i} where

module _ (A : Type i) where

  PlusMinus : Type i
  PlusMinus = Coprod A A

  Word : Type i
  Word = List PlusMinus

module _ {A : Type i} where

  flip : PlusMinus A → PlusMinus A
  flip (inl a) = inr a
  flip (inr a) = inl a

  flip-flip : ∀ x → flip (flip x) == x
  flip-flip (inl x) = idp
  flip-flip (inr x) = idp

  Word-flip : Word A → Word A
  Word-flip = map flip

  Word-flip-flip : ∀ w → Word-flip (Word-flip w) == w
  Word-flip-flip nil = idp
  Word-flip-flip (x :: l) = ap2 _::_ (flip-flip x) (Word-flip-flip l)

  Word-inverse : Word A → Word A
  Word-inverse = reverse ∘ Word-flip

  Word-inverse-inverse : ∀ w → Word-inverse (Word-inverse w) == w
  Word-inverse-inverse w =
    Word-inverse (Word-inverse w)
      =⟨ reverse-map flip (Word-inverse w) ⟩
    Word-flip (reverse (reverse (Word-flip w)))
      =⟨ ap Word-flip (reverse-reverse (Word-flip w)) ⟩
    Word-flip (Word-flip w)
      =⟨ Word-flip-flip w ⟩
    w =∎

  Word-exp : A → ℤ → Word A
  Word-exp a (pos 0) = nil
  Word-exp a (pos (S n)) = inl a :: Word-exp a (pos n)
  Word-exp a (negsucc 0) = inr a :: nil
  Word-exp a (negsucc (S n)) = inr a :: Word-exp a (negsucc n)

module _ {A : Type i} {j} (G : Group j) where
  private
    module G = Group G

  module _ (f : A → G.El) where
    PlusMinus-extendᴳ : PlusMinus A → G.El
    PlusMinus-extendᴳ (inl a) = f a
    PlusMinus-extendᴳ (inr a) = G.inv (f a)

    PlusMinus-extendᴳ-flip : ∀ x → PlusMinus-extendᴳ (flip x) == G.inv (PlusMinus-extendᴳ x)
    PlusMinus-extendᴳ-flip (inl a) = idp
    PlusMinus-extendᴳ-flip (inr a) = ! (G.inv-inv (f a))

    Word-extendᴳ : Word A → G.El
    Word-extendᴳ = foldr' G.comp G.ident ∘ map PlusMinus-extendᴳ

  abstract
    Word-extendᴳ-++ : ∀ f l₁ l₂
      → Word-extendᴳ f (l₁ ++ l₂) == G.comp (Word-extendᴳ f l₁) (Word-extendᴳ f l₂)
    Word-extendᴳ-++ f nil l₂ = ! $ G.unit-l _
    Word-extendᴳ-++ f (x₁ :: nil) nil = ! (G.unit-r _)
    Word-extendᴳ-++ f (x₁ :: nil) (x₂ :: l₂) = idp
    Word-extendᴳ-++ f (x₁ :: l₁@(_ :: _)) l₂ =
      G.comp (PlusMinus-extendᴳ f x₁) (Word-extendᴳ f (l₁ ++ l₂))
        =⟨ ap (G.comp (PlusMinus-extendᴳ f x₁)) (Word-extendᴳ-++ f l₁ l₂) ⟩
      G.comp (PlusMinus-extendᴳ f x₁) (G.comp (Word-extendᴳ f l₁) (Word-extendᴳ f l₂))
        =⟨ ! (G.assoc _ _ _) ⟩
      G.comp (G.comp (PlusMinus-extendᴳ f x₁) (Word-extendᴳ f l₁)) (Word-extendᴳ f l₂) =∎

module _ {A : Type i} {j} (G : AbGroup j) where
  private
    module G = AbGroup G

  abstract
    PlusMinus-extendᴳ-comp : ∀ (f g : A → G.El) x
      → PlusMinus-extendᴳ G.grp (λ a → G.comp (f a) (g a)) x
      == G.comp (PlusMinus-extendᴳ G.grp f x) (PlusMinus-extendᴳ G.grp g x)
    PlusMinus-extendᴳ-comp f g (inl a) = idp
    PlusMinus-extendᴳ-comp f g (inr a) = G.inv-comp (f a) (g a) ∙ G.comm (G.inv (g a)) (G.inv (f a))

    Word-extendᴳ-comp : ∀ (f g : A → G.El) l
      → Word-extendᴳ G.grp (λ a → G.comp (f a) (g a)) l
      == G.comp (Word-extendᴳ G.grp f l) (Word-extendᴳ G.grp g l)
    Word-extendᴳ-comp f g nil = ! (G.unit-l G.ident)
    Word-extendᴳ-comp f g (x :: nil) = PlusMinus-extendᴳ-comp f g x
    Word-extendᴳ-comp f g (x :: l@(_ :: _)) =
      G.comp (PlusMinus-extendᴳ G.grp (λ a → G.comp (f a) (g a)) x)
             (Word-extendᴳ G.grp (λ a → G.comp (f a) (g a)) l)
        =⟨ ap2 G.comp (PlusMinus-extendᴳ-comp f g x) (Word-extendᴳ-comp f g l) ⟩
      G.comp (G.comp (PlusMinus-extendᴳ G.grp f x) (PlusMinus-extendᴳ G.grp g x))
             (G.comp (Word-extendᴳ G.grp f l) (Word-extendᴳ G.grp g l))
        =⟨ G.interchange (PlusMinus-extendᴳ G.grp f x) (PlusMinus-extendᴳ G.grp g x)
                         (Word-extendᴳ G.grp f l) (Word-extendᴳ G.grp g l) ⟩
      G.comp (G.comp (PlusMinus-extendᴳ G.grp f x) (Word-extendᴳ G.grp f l))
             (G.comp (PlusMinus-extendᴳ G.grp g x) (Word-extendᴳ G.grp g l)) =∎

module RelationRespectingFunctions (A : Type i) {m} (R : Rel (Word A) m) {j} (G : Group j) where

  private
    module G = Group G

  respects-rel : (A → G.El) → Type (lmax (lmax i j) m)
  respects-rel f = ∀ {l₁ l₂} → R l₁ l₂ → Word-extendᴳ G f l₁ == Word-extendᴳ G f l₂

  abstract
    respects-rel-is-prop : ∀ f → is-prop (respects-rel f)
    respects-rel-is-prop f =
      Πi-level $ λ l₁ →
      Πi-level $ λ l₂ →
      Π-level  $ λ r →
      has-level-apply G.El-level _ _

  record RelationRespectingFunction : Type (lmax (lmax i j) m) where
    constructor rel-res-fun
    field
      f : A → G.El
      respects : respects-rel f

  RelationRespectingFunction= : {lf lg : RelationRespectingFunction}
    → RelationRespectingFunction.f lf == RelationRespectingFunction.f lg
    → lf == lg
  RelationRespectingFunction= {rel-res-fun f f-respect} {rel-res-fun .f g-respect} idp =
    ap (rel-res-fun f) (prop-path (respects-rel-is-prop f) f-respect g-respect)

{- For the empty relation, this is exactly the type of functions -}
module _ (A : Type i) {j} (G : Group j) where

  private
    module G = Group G
  open RelationRespectingFunctions A empty-rel G

  every-function-respects-empty-rel : ∀ (f : A → G.El) → RelationRespectingFunction
  every-function-respects-empty-rel f = rel-res-fun f (λ {_} {_} ())

  every-function-respects-empty-rel-equiv : (A → G.El) ≃ RelationRespectingFunction
  every-function-respects-empty-rel-equiv =
    equiv every-function-respects-empty-rel
          RelationRespectingFunction.f
          (λ lf → RelationRespectingFunction= idp)
          (λ f → idp)


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.List where

open import Cubical.Data.List.Base       public
open import Cubical.Data.List.Properties public


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

open import HoTT
open import cohomology.Theory
open import groups.ExactSequence
open import groups.HomSequence

module cw.cohomology.GridLongExactSequence {i} (CT : CohomologyTheory i)
  {X Y Z : Ptd i} (n : ℤ) (f : X ⊙→ Y) (g : Y ⊙→ Z) where

open CohomologyTheory CT
open import cohomology.PtdMapSequence CT
open import cw.cohomology.CofiberGrid (fst f) (fst g)
open import cw.cohomology.GridPtdMap f g

{-
  X --> Y ----> Z
        |       |
        v       v
       Y/X --> Z/X
        | this  |
        v   one v
        1 ---> Z/Y
-}

private
  ⊙D-span : ⊙Span
  ⊙D-span = ⊙span Y/X Z Y (⊙cfcod' f) g

  ⊙D : Ptd i
  ⊙D = ⊙Pushout ⊙D-span

  Y/X-to-D : Y/X ⊙→ ⊙D
  Y/X-to-D = B/A-to-D , idp

  open import cohomology.LongExactSequence CT n Y/X-to-D

  ⊙E : Ptd i
  ⊙E = ⊙Cofiber (⊙left ⊙D-span)

  Z/Y-to-E : Z/Y ⊙→ ⊙E
  Z/Y-to-E = C/B-to-E , idp

  Z/X-to-D : Z/X ⊙→ ⊙D
  Z/X-to-D = C/A-to-D , idp

grid-co∂ : C n Y/X →ᴳ C (succ n) Z/Y
grid-co∂ = record {f = CEl-fmap (succ n) Z/Y-to-E ∘ GroupHom.f co∂ ; pres-comp = lemma} where
  abstract lemma = ∘-pres-comp (C-fmap (succ n) Z/Y-to-E) co∂

C-grid-cofiber-seq : HomSequence (C n Z/X) (C (succ n) Y/X)
C-grid-cofiber-seq =
  C n Z/X         →⟨ C-fmap n Y/X-to-Z/X        ⟩ᴳ
  C n Y/X         →⟨ grid-co∂                   ⟩ᴳ
  C (succ n) Z/Y  →⟨ C-fmap (succ n) Z/X-to-Z/Y ⟩ᴳ
  C (succ n) Z/X  →⟨ C-fmap (succ n) Y/X-to-Z/X ⟩ᴳ
  C (succ n) Y/X  ⊣|ᴳ

private
  C-cofiber-seq-to-C-grid-cofiber-seq :
    HomSeqMap C-cofiber-seq C-grid-cofiber-seq
      (C-fmap n Z/X-to-D) (idhom _)
  C-cofiber-seq-to-C-grid-cofiber-seq =
    C-fmap n Z/X-to-D         ↓⟨ comm-sqrᴳ (λ d → ! (C-fmap-idf n _)
                                                ∙ (C-comm-square n B/A-to-C/A-comm-square □$ᴳ d)) ⟩ᴳ
    idhom _                   ↓⟨ comm-sqrᴳ (λ _ → idp) ⟩ᴳ
    C-fmap (succ n) Z/Y-to-E  ↓⟨ C-comm-square (succ n) C/A-to-C/B-comm-square ⟩ᴳ
    C-fmap (succ n) Z/X-to-D  ↓⟨ comm-sqrᴳ (λ d → ! (C-fmap-idf (succ n) _)
                                                ∙ (C-comm-square (succ n) B/A-to-C/A-comm-square □$ᴳ d)) ⟩ᴳ
    idhom _                   ↓|ᴳ

  C-cofiber-seq-equiv-C-grid-cofiber-seq :
    HomSeqEquiv C-cofiber-seq C-grid-cofiber-seq
      (C-fmap n Z/X-to-D) (idhom _)
  C-cofiber-seq-equiv-C-grid-cofiber-seq =
    C-cofiber-seq-to-C-grid-cofiber-seq ,
      CEl-isemap n Z/X-to-D C/A-to-D-is-equiv ,
      idf-is-equiv _ ,
      CEl-isemap (succ n) Z/Y-to-E C/B-to-E-is-equiv ,
      CEl-isemap (succ n) Z/X-to-D C/A-to-D-is-equiv ,
      idf-is-equiv _

abstract
  C-grid-cofiber-seq-is-exact : is-exact-seq C-grid-cofiber-seq
  C-grid-cofiber-seq-is-exact = seq-equiv-preserves-exact
    C-cofiber-seq-equiv-C-grid-cofiber-seq C-cofiber-seq-is-exact

C-grid-cofiber-exact-seq : ExactSequence (C n Z/X) (C (succ n) Y/X)
C-grid-cofiber-exact-seq = C-grid-cofiber-seq , C-grid-cofiber-seq-is-exact


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

data Id (A : Set) : Set where
  mkId : A → Id A

data Monad (M : Set → Set) : Set where

postulate
  return : ∀ {M} {{Mon : Monad M}} {A} → A → M A
  _>>=_  : ∀ {M} {{Mon : Monad M}} {A B} → M A → (A → M B) → M B
  State : (S A : Set) → Set

  instance
    MonadState : ∀ {S} → Monad (State S)
    MonadId : Monad Id

-- Yields
--   _M Nat == State Nat Nat,
-- which inert improvement solves by
--   _M x := State (_S x) (_A x)
--     with _S Nat == Nat
--          _A Nat == Nat
-- This allows instance search to pick the right instance.
rz : State Nat Nat
rz = return zero

postulate
  StateT : (S : Set) (M : Set → Set) (A : Set) → Set

  instance
    MonadStateT : ∀ {S M} → Monad M → Monad (StateT S M)

stateT₁ : ∀ {M} {{Mon : Monad M}} → StateT Nat M Nat
stateT₁ = return zero

stateT₂ : ∀ {M} {{Mon : Monad M}} → StateT Nat M Nat
stateT₂ = return zero >>= λ n → return (suc n)

postulate
  _<$_ : ∀ {A B M} {{Mon : Monad M}} → A → M B → M A

record ⊤ : Set where
  constructor tt

foo : Id ⊤
foo = _ <$ return zero


open import Agda.Builtin.Equality

data D (A : Set) : Set where

{-# INJECTIVE D #-}

test : {A₁ A₂ : Set} → D A₁ ≡ D A₂ → A₁ ≡ A₂
test refl = refl

postulate f : Set → Set

{-# INJECTIVE f #-}

test₂ : {A₁ A₂ : Set} → f A₁ ≡ f A₂ → A₁ ≡ A₂
test₂ refl = refl


------------------------------------------------------------------------
-- A small definition of a dependently typed language, using the
-- technique from McBride's "Outrageous but Meaningful Coincidences"
------------------------------------------------------------------------

-- Inlining saves a lot of memory. Test with +RTS -M100M
-- The inlining of zero and suc in raw-category at the end is the most
-- important.

{-# OPTIONS --type-in-type #-}

module _ where

open import Agda.Builtin.Equality
open import Agda.Builtin.Unit
open import Agda.Builtin.Sigma

------------------------------------------------------------------------
-- Prelude

data ⊥ : Set where

⊥-elim : ⊥ → {A : Set} → A
⊥-elim ()

data Either (A B : Set) : Set where
  left  : A → Either A B
  right : B → Either A B

uncurry : {A : Set} {B : A → Set} {C : Σ A B → Set} →
          ((x : A) (y : B x) → C (x , y)) →
          ((p : Σ A B) → C p)
uncurry f p = f (fst p) (snd p)

infixr 2 _×_
_×_ : Set → Set → Set
_×_ A B = Σ A (λ _ → B)

------------------------------------------------------------------------
-- A universe

data U : Set

El : U → Set

data U where
  set   : U
  el    : Set → U
  sigma : (a : U) → (El a → U) → U
  pi    : (a : U) → (El a → U) → U

El set         = Set
El (el A)      = A
El (sigma a b) = Σ (El a) (λ x → El (b x))
El (pi a b)    = (x : El a) → El (b x)

-- Abbreviations.

fun : U → U → U
fun a b = pi a (λ _ → b)

times : U → U → U
times a b = sigma a (λ _ → b)

-- -- Example.

------------------------------------------------------------------------
-- Contexts

-- Contexts.

data Ctxt : Set

-- Types.

Ty : Ctxt → Set

-- Environments.

Env : Ctxt → Set

data Ctxt where
  empty : Ctxt
  snoc  : (G : Ctxt) → Ty G → Ctxt

Ty G = Env G → U

Env empty      = ⊤
Env (snoc G s) = Σ (Env G) (λ g → El (s g))

-- Variables (deBruijn indices).

Var : ∀ G → Ty G → Set
Var empty      t = ⊥
Var (snoc G s) t =
  Either ((λ g → s (fst g)) ≡ t)
         (Σ _ (λ u → (λ g → u (fst g)) ≡ t × Var G u))

zero : ∀ {G s} → Var (snoc G s) (λ g → s (fst g))
zero = left refl

suc : ∀ {G s t} → (x : Var G t) → Var (snoc G s) (λ g → t (fst g))
suc x = right (_ , refl , x)

-- A lookup function.

lookup : ∀ G (s : Ty G) → Var G s → (g : Env G) → El (s g)
lookup empty      _ absurd     _ = ⊥-elim absurd
lookup (snoc vs v) _ (left refl) g = snd g
lookup (snoc vs v) t (right (_ , refl , x))  g = lookup _ _ x (fst g)

------------------------------------------------------------------------
-- A language

-- Syntax for types.

data Type (G : Ctxt) (s : Ty G) : Set

-- Terms.

data Term (G : Ctxt) (s : Ty G) : Set

-- The semantics of a term.

eval : ∀ {G s} → Term G s → (g : Env G) → El (s g)

data Type G s where
  set''   : s ≡ (λ _ → set) → Type G s
  el''    : (x : Term G (λ _ → set)) →
            (λ g → el (eval {s = λ _ → set} x g)) ≡ s →
            Type G s
  sigma'' : {t : _} {u : _} →
            Type G t →
            Type (snoc G t) u →
            (λ g → sigma (t g) (λ v → u (g , v))) ≡ s →
            Type G s
  pi''    : {t : _} {u : _} →
            Type G t →
            Type (snoc G t) u →
            (λ g → pi (t g) (λ v → u (g , v))) ≡ s →
            Type G s

data Term G s where
  var   : Var G s → Term G s
  lam'' : {t : _} {u : _} →
          Term (snoc G t) (uncurry u) →
          (λ g → pi (t g) (λ v → u g v)) ≡ s →
          Term G s
  app'' : {t : _} {u : (g : Env G) → El (t g) → U} →
          Term G (λ g → pi (t g) (λ v → u g v)) →
          (t2 : Term G t) →
          (λ g → u g (eval t2 g)) ≡ s →
          Term G s

eval (var x)            g = lookup _ _ x g
eval (lam'' t refl)     g = λ v → eval t (g , v)
eval (app'' t1 t2 refl) g = eval t1 g (eval t2 g)

-- Abbreviations.

set' : {G : Ctxt} → Type G (λ _ → set)
set' = set'' refl

el' : {G : Ctxt}
      (x : Term G (λ _ → set)) →
      Type G (λ g → el (eval {G} {λ _ → set} x g))
el' x = el'' x refl

sigma' : {G : Ctxt} {t : Env G → U} {u : Env (snoc G t) → U} →
         Type G t →
         Type (snoc G t) u →
         Type G (λ g → sigma (t g) (λ v → u (g , v)))
sigma' s t = sigma'' s t refl

pi' : {G : _} {t : _} {u : _} →
      Type G t →
      Type (snoc G t) u →
      Type G (λ g → pi (t g) (λ v → u (g , v)))
pi' s t = pi'' s t refl

lam : {G : _} {t : _} {u : _} →
      Term (snoc G t) (uncurry u) →
      Term G (λ g → pi (t g) (λ v → u g v))
lam t = lam'' t refl

app : {G : _} {t : _} {u : (g : Env G) → El (t g) → U} →
      Term G (λ g → pi (t g) (λ v → u g v)) →
      (t2 : Term G t) →
      Term G (λ g → u g (eval t2 g))
app t1 t2 = app'' t1 t2 refl

-- Example.

raw-categoryU : U
raw-categoryU =
  sigma set (λ obj →
  sigma (fun (el obj) (fun (el obj) set)) (λ hom →
  times
    (pi (el obj) (λ x → el (hom x x)))
    (pi (el obj) (λ x → el (hom x x)))))

raw-category : Type empty (λ _ → raw-categoryU)
raw-category =
     -- Objects.
   sigma' set'
     -- Morphisms.
  (sigma' (pi' (el' (var zero)) (pi' (el' (var (suc zero))) set'))
     -- Identity.
  (sigma' (pi' (el' (var (suc zero)))
               (el' (app (app (var (suc zero)) (var zero)) (var zero))))
          (pi' (el' (var (suc (suc zero))))
               (el' (app (app (var (suc (suc zero))) (var zero)) (var zero))))))


module Oscar.Class.Substitute where

open import Oscar.Class.Substitution
open import Oscar.Data.Equality
open import Oscar.Function
open import Oscar.Relation
open import Oscar.Level

record Substitute {a} {A : Set a} {b} (B : A → Set b) {c} (C : A → Set c) {d} (D : A → Set d) : Set (a ⊔ b ⊔ c ⊔ d) where
  field
    ⦃ substitution ⦄ : Substitution B C
    _◃_ : ∀ {m n} → (B m → C n) → m ⟨ D ⟩→ n
    ◃-identity : ∀ {m} → (x : D m) → ε ◃ x ≡ x
    ◃-associativity : ∀ {l m n} (f : B l → C m) (g : B m → C n) (t : D l) → (g ◇ f) ◃ t ≡ g ◃ (f ◃ t)
    ◃-extensionality : ∀ {m n} {f g : B m → C n} → f ≡̇ g → f ◃_ ≡̇ g ◃_

open Substitute ⦃ … ⦄ public

{-# DISPLAY Substitute._◃_ _ = _◃_ #-}

instance Substitute-id : ∀ {a} {A : Set a} {bcd} {BCD : A → Set bcd} → Substitute BCD BCD BCD
Substitute.substitution Substitute-id = Substitution-id
Substitute._◃_ Substitute-id = id
Substitute.◃-identity Substitute-id _ = refl
Substitute.◃-associativity Substitute-id _ _ _ = refl
Substitute.◃-extensionality Substitute-id f≡̇g = f≡̇g

-- record Substitution {a} {A : Set a} {b} (B : A → Set b) {c} (C : A → Set c) {d} (D : A → Set d) : Set (a ⊔ b ⊔ c ⊔ d) where
--   field
--     _◃_ : ∀ {m n} → (B m → C n) → m ⟨ D ⟩→ n
--     ε : ∀ {m} → B m → C m
--     ◃-identity : ∀ {m} → (x : D m) → ε ◃ x ≡ x
--     _◇_ : ∀ {l m n} → (g : B m → C n) (f : B l → C m) → B l → C n
--     ◃-associativity : ∀ {l m n} → {f : B m → C n} {g : B l → C m} (t : D l) → (f ◇ g) ◃ t ≡ f ◃ (g ◃ t)
--     ◃-extensionality : ∀ {m n} {f g : B m → C n} → f ≡̇ g → f ◃_ ≡̇ g ◃_

-- {-
--   Unifies : ∀ {m} (s t : A m) → Property m
--   Unifies s t f = f ◃ s ≡ f ◃ t
-- -}

-- open Substitution ⦃ … ⦄ public

-- -- record Substitution {a} {A : Set a} {b} (S : A → A → Set b) {c} (C : A → Set c) : Set (a ⊔ b ⊔ c) where
-- --   field
-- --     _◃_ : ∀ {m n} → S m n → m ⟨ C ⟩→ n
-- --     ε : ∀ {m} → S m m
-- --     ◃-identity : ∀ {m} → (x : C m) → ε ◃ x ≡ x
-- --     _◇_ : ∀ {l m n} → S m n → S l m → S l n

-- --   field
-- --     ◃-associativity : ∀ {l m n} → {f : S m n} {g : S l m} (t : C l) → (f ◇ g) ◃ t ≡ f ◃ (g ◃ t)
-- --     ◃-extensionality : ∀ {m n} {f g : S m n} → f ≡ g → f ◃_ ≡̇ g ◃_

-- -- open Substitution ⦃ … ⦄ public

-- -- -- record Substitution {a} {A : Set a} {b} (B : A → Set b) {c} (C : A → Set c) : Set (a ⊔ b ⊔ c) where
-- -- --   field
-- -- --     _◃_ : ∀ {m n} → (B m → C n) → m ⟨ C ⟩→ n
-- -- --     ε : ∀ {m} → B m → C m
-- -- --     ◃-identity : ∀ {m} → (x : C m) → ε ◃ x ≡ x

-- -- --   _◇_ : ∀ {l m n} → (f : B m → C n) (g : B l → C m) → B l → C n
-- -- --   _◇_ f g = (f ◃_) ∘ g

-- -- --   field
-- -- --     ◃-associativity : ∀ {l m n} → {f : B m → C n} {g : B l → C m} (t : C l) → (f ◇ g) ◃ t ≡ f ◃ (g ◃ t)
-- -- --     ◃-extensionality : ∀ {m n} {f g : B m → C n} → f ≡̇ g → f ◃_ ≡̇ g ◃_

-- -- -- {-
-- -- --   Unifies : ∀ {m} (s t : A m) → Property m
-- -- --   Unifies s t f = f ◃ s ≡ f ◃ t
-- -- -- -}

-- -- -- open Substitution ⦃ … ⦄ public

-- -- -- instance Substitution⋆ : ∀ {a} {A : Set a} {bc} {BC : A → Set bc} → Substitution BC BC
-- -- -- Substitution._◃_ Substitution⋆ = id
-- -- -- Substitution.ε Substitution⋆ = id
-- -- -- Substitution.◃-identity Substitution⋆ _ = refl
-- -- -- Substitution.◃-associativity Substitution⋆ _ = refl
-- -- -- Substitution.◃-extensionality Substitution⋆ f≡̇g x = f≡̇g x


module Numeral.Natural.Oper.Summation.Proofs where

import      Lvl
open import Data.List
open import Data.List.Functions
open import Data.List.Equiv.Id
open import Numeral.Natural
open import Structure.Function
open import Structure.Operator.Field
open import Structure.Operator.Monoid
open import Structure.Operator
open import Structure.Setoid
open import Type

private variable ℓ ℓₑ : Lvl.Level
private variable T A B : Type{ℓ}
private variable _▫_ : T → T → T

open        Data.List.Functions.LongOper
open import Data.List.Proofs
open import Functional as Fn using (_$_ ; _∘_ ; const)
import      Function.Equals as Fn
open import Lang.Instance
import      Numeral.Natural.Oper.Summation
open import Numeral.Natural.Oper.Summation.Range
open import Numeral.Natural.Oper.Summation.Range.Proofs
open import Numeral.Natural.Relation.Order
import      Structure.Function.Names as Names
open import Structure.Operator.Properties
open import Structure.Operator.Proofs.Util
open import Structure.Relator.Properties
open import Syntax.Function
open import Syntax.Transitivity

module _ ⦃ equiv : Equiv{ℓₑ}(T) ⦄ ⦃ monoid : Monoid{T = T}(_▫_) ⦄ where
  open Numeral.Natural.Oper.Summation {I = ℕ} ⦃ monoid = monoid ⦄
  open Monoid(monoid) using (id) renaming (binary-operator to [▫]-binary-operator)
  open import Relator.Equals.Proofs.Equiv {T = ℕ}

  private variable f g : ℕ → T
  private variable x a b c k n : ℕ
  private variable r r₁ r₂ : List(ℕ)

  ∑-empty : (∑(∅) f ≡ id)
  ∑-empty = reflexivity(Equiv._≡_ equiv)

  ∑-prepend : (∑(prepend x r) f ≡ f(x) ▫ ∑(r) f)
  ∑-prepend = reflexivity(Equiv._≡_ equiv)

  ∑-postpend : (∑(postpend x r) f ≡ ∑(r) f ▫ f(x))
  ∑-postpend {x = x} {r = ∅} {f = f} =
    ∑(postpend x empty) f 🝖[ _≡_ ]-[]
    ∑(prepend x empty) f  🝖[ _≡_ ]-[]
    f(x) ▫ (∑(empty) f)   🝖[ _≡_ ]-[]
    f(x) ▫ id             🝖[ _≡_ ]-[ identityᵣ(_▫_)(id) ]
    f(x)                  🝖[ _≡_ ]-[ identityₗ(_▫_)(id) ]-sym
    id ▫ f(x)             🝖[ _≡_ ]-[]
    (∑(empty) f) ▫ f(x)   🝖-end
  ∑-postpend {x = x} {r = r₀ ⊰ r} {f = f} =
    f(r₀) ▫ ∑(postpend x r) f  🝖[ _≡_ ]-[ congruence₂ᵣ(_▫_)(f(r₀)) (∑-postpend {x = x}{r = r}{f = f}) ]
    f(r₀) ▫ (∑(r) f ▫ f(x))    🝖[ _≡_ ]-[ associativity(_▫_) {f(r₀)}{∑(r) f}{f(x)} ]-sym
    (f(r₀) ▫ ∑(r) f) ▫ f(x)    🝖-end

  ∑-compose : ∀{f : ℕ → T}{g : ℕ → ℕ} → (∑(r) (f ∘ g) ≡ ∑(map g r) f)
  ∑-compose {r = r}{f = f}{g = g} =
    ∑(r) (f ∘ g)                  🝖[ _≡_ ]-[]
    foldᵣ(_▫_) id (map(f ∘ g) r)   🝖[ _≡_ ]-[ congruence₁(foldᵣ(_▫_) id) ⦃ foldᵣ-function ⦄ (map-preserves-[∘] {f = f}{g = g}{x = r}) ]
    foldᵣ(_▫_) id (map f(map g r)) 🝖[ _≡_ ]-[]
    ∑(map g r) f                  🝖-end

  ∑-singleton : (∑(singleton(a)) f ≡ f(a))
  ∑-singleton = identityᵣ ⦃ equiv ⦄ (_▫_)(id)

  ∑-concat : (∑(r₁ ++ r₂) f ≡ ∑(r₁) f ▫ ∑(r₂) f)
  ∑-concat {empty}        {r₂} {f} = symmetry(_≡_) (identityₗ(_▫_)(id))
  ∑-concat {prepend x r₁} {r₂} {f} =
    f(x) ▫ ∑(r₁ ++ r₂) f      🝖[ _≡_ ]-[ congruence₂ᵣ(_▫_)(f(x)) (∑-concat {r₁}{r₂}{f}) ]
    f(x) ▫ (∑(r₁) f ▫ ∑ r₂ f) 🝖[ _≡_ ]-[ associativity(_▫_) {x = f(x)}{y = ∑(r₁) f}{z = ∑(r₂) f} ]-sym
    (f(x) ▫ ∑(r₁) f) ▫ ∑ r₂ f 🝖-end

  ∑-const-id : (∑(r) (const id) ≡ id)
  ∑-const-id {empty}       = reflexivity(Equiv._≡_ equiv)
  ∑-const-id {prepend x r} =
    ∑(prepend x r) (const id) 🝖[ _≡_ ]-[]
    id ▫ (∑(r) (const id))    🝖[ _≡_ ]-[ identityₗ(_▫_)(id) ]
    ∑(r) (const id)           🝖[ _≡_ ]-[ ∑-const-id {r} ]
    id                        🝖-end

module _ ⦃ equiv : Equiv{ℓₑ}(T) ⦄ where
  private variable f g : ℕ → T
  private variable k n : ℕ
  private variable x a b c : T
  private variable r r₁ r₂ : List(ℕ)
  private variable _+_ _⋅_ : T → T → T

  module _ ⦃ monoid : Monoid(_+_) ⦄ ⦃ comm : Commutativity(_+_) ⦄ where
    open Numeral.Natural.Oper.Summation {I = ℕ} ⦃ monoid = monoid ⦄
    open Monoid(monoid) using (id) renaming (binary-operator to [+]-binary-operator)
    open import Relator.Equals.Proofs.Equiv {T = ℕ}

    ∑-add : (∑(r) f + ∑(r) g ≡ ∑(r) (x ↦ f(x) + g(x)))
    ∑-add {∅}      {f} {g} = identityₗ(_+_)(id)
    ∑-add {r₀ ⊰ r} {f} {g} =
      ∑(prepend r₀ r) f + ∑(prepend r₀ r) g    🝖[ _≡_ ]-[]
      (f(r₀) + ∑(r) f) + (g(r₀) + ∑(r) g)      🝖[ _≡_ ]-[ One.associate-commute4 {a = f(r₀)}{b = ∑(r) f}{c = g(r₀)}{d = ∑(r) g} (commutativity(_+_){∑(r) f}{g(r₀)}) ]
      (f(r₀) + g(r₀)) + (∑(r) f + ∑(r) g)      🝖[ _≡_ ]-[ congruence₂ᵣ(_+_)(f(r₀) + g(r₀)) (∑-add {r} {f} {g}) ]
      (f(r₀) + g(r₀)) + ∑(r) (x ↦ f(x) + g(x)) 🝖[ _≡_ ]-[]
      ∑(prepend r₀ r) (x ↦ f(x) + g(x))        🝖-end

  module _ ⦃ monoid : Monoid(_+_) ⦄ ⦃ distₗ : Distributivityₗ(_⋅_)(_+_) ⦄ ⦃ absorᵣ : Absorberᵣ(_⋅_)(Monoid.id monoid) ⦄ where
    open Numeral.Natural.Oper.Summation {I = ℕ} ⦃ monoid = monoid ⦄
    open Monoid(monoid) using (id) renaming (binary-operator to [+]-binary-operator)
    open import Relator.Equals.Proofs.Equiv {T = ℕ}

    ∑-scalar-multₗ : (∑(r) (x ↦ c ⋅ f(x)) ≡ c ⋅ (∑(r) f))
    ∑-scalar-multₗ {empty}        {c} {f} = symmetry(_≡_) (absorberᵣ(_⋅_)(id))
    ∑-scalar-multₗ {prepend r₀ r} {c} {f} =
      (c ⋅ f(r₀)) + ∑(r) (x ↦ c ⋅ f(x)) 🝖[ _≡_ ]-[ congruence₂ᵣ(_+_)(c ⋅ f(r₀)) (∑-scalar-multₗ {r}{c}{f}) ]
      (c ⋅ f(r₀)) + (c ⋅ (∑(r) f))      🝖[ _≡_ ]-[ distributivityₗ(_⋅_)(_+_) {c}{f(r₀)}{∑(r) f} ]-sym
      c ⋅ (f(r₀) + (∑(r) f))            🝖-end

  module _ ⦃ monoid : Monoid(_+_) ⦄ ⦃ distᵣ : Distributivityᵣ(_⋅_)(_+_) ⦄ ⦃ absorₗ : Absorberₗ(_⋅_)(Monoid.id monoid) ⦄ where
    open Numeral.Natural.Oper.Summation {I = ℕ} ⦃ monoid = monoid ⦄
    open Monoid(monoid) using (id) renaming (binary-operator to [+]-binary-operator)
    open import Relator.Equals.Proofs.Equiv {T = ℕ}

    ∑-scalar-multᵣ : (∑(r) (x ↦ f(x) ⋅ c) ≡ (∑(r) f) ⋅ c)
    ∑-scalar-multᵣ {empty}        {f} {c} = symmetry(_≡_) (absorberₗ(_⋅_)(id))
    ∑-scalar-multᵣ {prepend r₀ r} {f} {c} =
      (f(r₀) ⋅ c) + ∑(r) (x ↦ f(x) ⋅ c) 🝖[ _≡_ ]-[ congruence₂ᵣ(_+_)(f(r₀) ⋅ c) (∑-scalar-multᵣ {r}{f}{c}) ]
      (f(r₀) ⋅ c) + ((∑(r) f) ⋅ c)      🝖[ _≡_ ]-[ distributivityᵣ(_⋅_)(_+_) {f(r₀)}{∑(r) f}{c} ]-sym
      (f(r₀) + (∑(r) f)) ⋅ c            🝖-end

  module _ ⦃ field-structure : Field(_+_)(_⋅_) ⦄ where
    open Field(field-structure)
    open Numeral.Natural.Oper.Summation {I = ℕ} ⦃ monoid = [+]-monoid ⦄

open import Relator.Equals hiding (_≡_)
open import Relator.Equals.Proofs.Equiv
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.Proofs
open import Numeral.Natural.Oper.Proofs.Structure
open Numeral.Natural.Oper.Summation {I = ℕ} ⦃ monoid = [+]-monoid ⦄ -- TODO: Generalize all the proofs

private variable f g : ℕ → ℕ
private variable x a b c k n : ℕ
private variable r r₁ r₂ : List(ℕ)

∑-const : (∑(r) (const c) ≡ c ⋅ length(r))
∑-const {empty}      {c} = reflexivity(_≡_)
∑-const {prepend x r}{c} = congruence₂ᵣ(_+_)(c) (∑-const {r}{c})

-- TODO: Σ-const-id is a generalization of this
∑-zero : (∑(r) (const 𝟎) ≡ 𝟎)
∑-zero {r} = ∑-const {r}{𝟎}

-- TODO: map-binaryOperator is on the equality setoid, which blocks the generalization of this
instance
  ∑-binaryOperator : BinaryOperator ⦃ equiv-A₂ = Fn.[⊜]-equiv ⦄ (∑)
  BinaryOperator.congruence ∑-binaryOperator {r₁}{r₂}{f}{g} rr fg =
    ∑(r₁) f  🝖[ _≡_ ]-[]
    foldᵣ(_+_) 𝟎 (map f(r₁))  🝖[ _≡_ ]-[ congruence₁(foldᵣ(_+_) 𝟎) (congruence₂(map) ⦃ map-binaryOperator ⦄ fg rr) ]
    foldᵣ(_+_) 𝟎 (map g(r₂))  🝖[ _≡_ ]-[]
    ∑(r₂) g  🝖-end

∑-mult : ∀{r₁ r₂}{f g} → ((∑(r₁) f) ⋅ (∑(r₂) g) ≡ ∑(r₁) (x ↦ ∑(r₂) (y ↦ f(x) ⋅ g(y))))
∑-mult {empty}        {_} {f} {g} = [≡]-intro
∑-mult {prepend x₁ r₁} {empty} {f} {g} =
  𝟎                                                 🝖[ _≡_ ]-[ ∑-zero {r = prepend x₁ r₁} ]-sym
  ∑(prepend x₁ r₁) (x ↦ 𝟎)                          🝖[ _≡_ ]-[ congruence₂ᵣ(∑)(prepend x₁ r₁) (Fn.intro(\{x} → ∑-empty {f = y ↦ f(x) ⋅ g(y)})) ]-sym
  ∑(prepend x₁ r₁) (x ↦ ∑(empty) (y ↦ f(x) ⋅ g(y))) 🝖-end
∑-mult {prepend x₁ r₁} {prepend x₂ r₂} {f} {g} =
  (∑(prepend x₁ r₁) f) ⋅ (∑(prepend x₂ r₂) g)                                                               🝖[ _≡_ ]-[]
  (f(x₁) + (∑(r₁) f)) ⋅ (g(x₂) + (∑(r₂) g))                                                                 🝖[ _≡_ ]-[ OneTypeTwoOp.cross-distribute {a = f(x₁)}{b = ∑(r₁) f}{c = g(x₂)}{d = ∑(r₂) g} ]
  ((f(x₁) ⋅ g(x₂)) + ((∑(r₁) f) ⋅ g(x₂))) + ((f(x₁) ⋅ (∑(r₂) g)) + ((∑(r₁) f) ⋅ (∑(r₂) g)))                 🝖[ _≡_ ]-[ One.associate-commute4 {a = f(x₁) ⋅ g(x₂)}{b = (∑(r₁) f) ⋅ g(x₂)}{c = f(x₁) ⋅ (∑(r₂) g)}{d = (∑(r₁) f) ⋅ (∑(r₂) g)} (commutativity(_+_) {(∑(r₁) f) ⋅ g(x₂)}{f(x₁) ⋅ (∑(r₂) g)}) ]
  ((f(x₁) ⋅ g(x₂)) + (f(x₁) ⋅ (∑(r₂) g))) + (((∑(r₁) f) ⋅ g(x₂)) + ((∑(r₁) f) ⋅ (∑(r₂) g)))                 🝖[ _≡_ ]-[ congruence₂ᵣ(_+_) ((f(x₁) ⋅ g(x₂)) + (f(x₁) ⋅ (∑(r₂) g))) p ]
  ((f(x₁) ⋅ g(x₂)) + (f(x₁) ⋅ (∑(r₂) g))) + (∑(r₁) (x ↦ (f(x) ⋅ g(x₂)) + (∑(r₂) (y ↦ f(x) ⋅ g(y)))))        🝖[ _≡_ ]-[ congruence₂ₗ(_+_) (∑(r₁) (x ↦ (f(x) ⋅ g(x₂)) + (∑(r₂) (y ↦ f(x) ⋅ g(y))))) (congruence₂ᵣ(_+_)(f(x₁) ⋅ g(x₂)) (∑-scalar-multₗ {r = r₂}{c = f(x₁)}{f = g})) ]-sym
  ((f(x₁) ⋅ g(x₂)) + (∑(r₂) (y ↦ f(x₁) ⋅ g(y)))) + (∑(r₁) (x ↦ (f(x) ⋅ g(x₂)) + (∑(r₂) (y ↦ f(x) ⋅ g(y))))) 🝖[ _≡_ ]-[]
  (∑(prepend x₂ r₂) (y ↦ f(x₁) ⋅ g(y))) + (∑(r₁) (x ↦ ∑(prepend x₂ r₂) (y ↦ f(x) ⋅ g(y))))                  🝖[ _≡_ ]-[]
  ∑(prepend x₁ r₁) (x ↦ ∑(prepend x₂ r₂) (y ↦ f(x) ⋅ g(y)))                                                 🝖-end
  where
    p =
      ((∑(r₁) f) ⋅ g(x₂)) + ((∑(r₁) f) ⋅ (∑(r₂) g))                 🝖[ _≡_ ]-[ distributivityₗ(_⋅_)(_+_) {x = ∑(r₁) f}{y = g(x₂)}{z = ∑(r₂) g} ]-sym
      (∑(r₁) f) ⋅ (g(x₂) + (∑(r₂) g))                               🝖[ _≡_ ]-[ ∑-scalar-multᵣ {r = r₁}{f = f}{c = g(x₂) + (∑(r₂) g)} ]-sym
      ∑(r₁) (x ↦ f(x) ⋅ (g(x₂) + (∑(r₂) g)))                        🝖[ _≡_ ]-[ congruence₂ᵣ(∑) r₁ (Fn.intro(\{x} → distributivityₗ(_⋅_)(_+_) {x = f(x)}{y = g(x₂)}{z = ∑(r₂) g})) ]
      ∑(r₁) (x ↦ (f(x) ⋅ g(x₂)) + (f(x) ⋅ (∑(r₂) g)))               🝖[ _≡_ ]-[ congruence₂ᵣ(∑) r₁ (Fn.intro(\{x} → congruence₂ᵣ(_+_) (f(x) ⋅ g(x₂)) (∑-scalar-multₗ {r = r₂}{c = f(x)}{f = g}))) ]-sym
      ∑(r₁) (x ↦ (f(x) ⋅ g(x₂)) + (∑(r₂) (y ↦ f(x) ⋅ g(y))))        🝖-end

∑-swap-nested : ∀{f : ℕ → ℕ → _}{r₁ r₂} → (∑(r₁) (a ↦ ∑(r₂) (b ↦ f(a)(b))) ≡ ∑(r₂) (b ↦ ∑(r₁) (a ↦ f(a)(b))))
∑-swap-nested {f} {empty}         {empty}         = [≡]-intro
∑-swap-nested {f} {empty}         {prepend x  r₂} =
  ∑(∅)(a ↦ ∑(x ⊰ r₂) (b ↦ f(a)(b)))  🝖[ _≡_ ]-[]
  𝟎                                  🝖[ _≡_ ]-[ ∑-zero {x ⊰ r₂} ]-sym
  ∑(x ⊰ r₂) (b ↦ 𝟎)                  🝖[ _≡_ ]-[]
  ∑(x ⊰ r₂) (b ↦ ∑(∅) (a ↦ f(a)(b))) 🝖-end
∑-swap-nested {f} {prepend x  r₁} {empty}         =
  ∑(x ⊰ r₁) (a ↦ ∑(∅) (b ↦ f(a)(b))) 🝖[ _≡_ ]-[]
  ∑(x ⊰ r₁) (b ↦ 𝟎)                  🝖[ _≡_ ]-[ ∑-zero {x ⊰ r₁} ]
  𝟎                                  🝖[ _≡_ ]-[]
  ∑(∅) (b ↦ ∑(x ⊰ r₁) (a ↦ f(a)(b))) 🝖-end
∑-swap-nested {f} {prepend x₁ r₁} {prepend x₂ r₂} =
  ∑(x₁ ⊰ r₁) (a ↦ ∑(x₂ ⊰ r₂) (b ↦ f(a)(b)))                                                       🝖[ _≡_ ]-[]
  ∑(x₁ ⊰ r₁) (a ↦ f(a)(x₂) + ∑(r₂) (b ↦ f(a)(b)))                                                 🝖[ _≡_ ]-[]
  (f(x₁)(x₂) + ∑(r₂) (b ↦ f(x₁)(b))) + ∑(r₁) (a ↦ f(a)(x₂) + ∑(r₂) (b ↦ f(a)(b)))                 🝖[ _≡_ ]-[]
  (f(x₁)(x₂) + ∑(r₂) (b ↦ f(x₁)(b))) + (∑(r₁) (a ↦ f(a)(x₂) + ∑(r₂) (b ↦ f(a)(b))))               🝖[ _≡_ ]-[ associativity(_+_) {x = f(x₁)(x₂)}{y = ∑(r₂) (b ↦ f(x₁)(b))} ]
  f(x₁)(x₂) + (∑(r₂) (b ↦ f(x₁)(b)) + (∑(r₁) (a ↦ f(a)(x₂) + ∑(r₂) (b ↦ f(a)(b)))))               🝖[ _≡_ ]-[]
  f(x₁)(x₂) + (∑(r₂) (b ↦ f(x₁)(b)) + (∑(r₁) (a ↦ ∑(x₂ ⊰ r₂) (b ↦ f(a)(b)))))                     🝖[ _≡_ ]-[ congruence₂ᵣ(_+_)(f(x₁)(x₂)) (congruence₂ᵣ(_+_)(∑(r₂) (b ↦ f(x₁)(b))) (∑-swap-nested {f}{r₁}{x₂ ⊰ r₂})) ]
  f(x₁)(x₂) + (∑(r₂) (b ↦ f(x₁)(b)) + (∑(x₂ ⊰ r₂) (b ↦ ∑(r₁) (a ↦ f(a)(b)))))                     🝖[ _≡_ ]-[]
  f(x₁)(x₂) + (∑(r₂) (b ↦ f(x₁)(b)) + (∑(r₁) (a ↦ f(a)(x₂)) + (∑(r₂) (b ↦ ∑(r₁) (a ↦ f(a)(b)))))) 🝖[ _≡_ ]-[ congruence₂ᵣ(_+_)(f(x₁)(x₂)) (symmetry(_≡_) (associativity(_+_) {x = ∑(r₂) (b ↦ f(x₁)(b))}{y = ∑(r₁) (a ↦ f(a)(x₂))})) ]
  f(x₁)(x₂) + ((∑(r₂) (b ↦ f(x₁)(b)) + ∑(r₁) (a ↦ f(a)(x₂))) + (∑(r₂) (b ↦ ∑(r₁) (a ↦ f(a)(b))))) 🝖[ _≡_ ]-[ congruence₂ᵣ(_+_)(f(x₁)(x₂)) (congruence₂(_+_) (commutativity(_+_) {∑(r₂) (b ↦ f(x₁)(b))}{∑(r₁) (a ↦ f(a)(x₂))}) (symmetry(_≡_) (∑-swap-nested {f}{r₁}{r₂}))) ]
  f(x₁)(x₂) + ((∑(r₁) (a ↦ f(a)(x₂)) + ∑(r₂) (b ↦ f(x₁)(b))) + ∑(r₁) (a ↦ ∑(r₂) (b ↦ f(a)(b))))   🝖[ _≡_ ]-[ congruence₂ᵣ(_+_)(f(x₁)(x₂)) (associativity(_+_) {x = ∑(r₁) (a ↦ f(a)(x₂))}{y = ∑(r₂) (b ↦ f(x₁)(b))}) ]
  f(x₁)(x₂) + (∑(r₁) (a ↦ f(a)(x₂)) + (∑(r₂) (b ↦ f(x₁)(b)) + ∑(r₁) (a ↦ ∑(r₂) (b ↦ f(a)(b)))))   🝖[ _≡_ ]-[]
  f(x₁)(x₂) + (∑(r₁) (a ↦ f(a)(x₂)) + (∑(x₁ ⊰ r₁) (a ↦ ∑(r₂) (b ↦ f(a)(b)))))                     🝖[ _≡_ ]-[ congruence₂ᵣ(_+_)(f(x₁)(x₂)) (congruence₂ᵣ(_+_)(∑(r₁) (a ↦ f(a)(x₂))) (∑-swap-nested {f}{x₁ ⊰ r₁}{r₂})) ]
  f(x₁)(x₂) + (∑(r₁) (a ↦ f(a)(x₂)) + (∑(r₂) (b ↦ ∑(x₁ ⊰ r₁) (a ↦ f(a)(b)))))                     🝖[ _≡_ ]-[]
  f(x₁)(x₂) + (∑(r₁) (a ↦ f(a)(x₂)) + (∑(r₂) (b ↦ f(x₁)(b) + ∑(r₁) (a ↦ f(a)(b)))))               🝖[ _≡_ ]-[ associativity(_+_) {x = f(x₁)(x₂)}{y = ∑(r₁) (a ↦ f(a)(x₂))} ]-sym
  (f(x₁)(x₂) + ∑(r₁) (a ↦ f(a)(x₂))) + (∑(r₂) (b ↦ f(x₁)(b) + ∑(r₁) (a ↦ f(a)(b))))               🝖[ _≡_ ]-[]
  ∑(x₂ ⊰ r₂) (b ↦ f(x₁)(b) + ∑(r₁) (a ↦ f(a)(b)))                                                 🝖[ _≡_ ]-[]
  ∑(x₂ ⊰ r₂) (b ↦ ∑(x₁ ⊰ r₁) (a ↦ f(a)(b)))                                                       🝖-end

∑-zero-range : (∑(a ‥ a) f ≡ 𝟎)
∑-zero-range {a}{f} = congruence₁ (r ↦ ∑(r) f) (Range-empty{a})

∑-single-range : (∑(a ‥ 𝐒(a)) f ≡ f(a))
∑-single-range {𝟎}  {f} = reflexivity(_≡_)
∑-single-range {𝐒 a}{f} =
  ∑ (map 𝐒(a ‥ 𝐒(a))) f       🝖[ _≡_ ]-[ ∑-compose ⦃ monoid = [+]-monoid ⦄ {r = a ‥ 𝐒(a)}{f}{𝐒} ]-sym
  ∑ (a ‥ 𝐒(a)) (x ↦ f(𝐒(x)))  🝖[ _≡_ ]-[ ∑-single-range {a}{f ∘ 𝐒} ]
  f(𝐒(a))                     🝖-end

∑-step-range : (∑(𝐒(a) ‥ 𝐒(b)) f ≡ ∑(a ‥ b) (f ∘ 𝐒))
∑-step-range {a}{b}{f} = symmetry(_≡_) (∑-compose {r = a ‥ b}{f = f}{g = 𝐒})

∑-stepₗ-range : ⦃ _ : (a < b) ⦄ → (∑(a ‥ b) f ≡ f(a) + ∑(𝐒(a) ‥ b) f)
∑-stepₗ-range {𝟎}   {𝐒 b} {f} ⦃ succ ab ⦄ = reflexivity(_≡_)
∑-stepₗ-range {𝐒 a} {𝐒 b} {f} ⦃ succ ab ⦄ =
  ∑(𝐒(a) ‥ 𝐒(b)) f                                🝖[ _≡_ ]-[ ∑-step-range {a}{b}{f} ]
  ∑(a ‥ b) (f ∘ 𝐒)                                🝖[ _≡_ ]-[ ∑-stepₗ-range {a}{b}{f ∘ 𝐒} ]
  (f ∘ 𝐒)(a) + ∑(𝐒(a) ‥ b) (f ∘ 𝐒)                🝖[ _≡_ ]-[ congruence₂(_+_) (reflexivity(_≡_) {x = f(𝐒(a))}) (symmetry(_≡_) (∑-step-range {𝐒 a}{b}{f})) ]
  f(𝐒(a)) + ∑(𝐒(𝐒(a)) ‥ 𝐒(b)) f                   🝖-end
  where instance _ = ab

-- ∑-stepᵣ-range : ⦃ _ : (a < 𝐒(b)) ⦄ → (∑(a ‥ 𝐒(b)) f ≡ ∑(a ‥ b) f + f(b))
-- ∑-stepᵣ-range = ?

-- ∑-add-range : (∑(a ‥ a + b) f ≡ ∑(𝟎 ‥ b) (f ∘ (_+ a)))

∑-trans-range : ⦃ ab : (a ≤ b) ⦄ ⦃ bc : (b < c) ⦄ → (∑(a ‥ b) f + ∑(b ‥ c) f ≡ ∑(a ‥ c) f)
∑-trans-range {a}{b}{c} {f} =
  ∑(a ‥ b) f + ∑(b ‥ c) f 🝖[ _≡_ ]-[ ∑-concat{r₁ = a ‥ b}{r₂ = b ‥ c}{f = f} ]-sym
  ∑((a ‥ b) ++ (b ‥ c)) f 🝖[ _≡_ ]-[ congruence₁(r ↦ ∑(r) f) (Range-concat{a}{b}{c}) ]
  ∑(a ‥ c) f              🝖-end

-- TODO: Formulate ∑({(x,y). a ≤ x ≤ y ≤ b}) f ≡ ∑(a ‥ b) (x ↦ ∑(a ‥ x) (y ↦ f(x)(y))) ≡ ∑(a ‥ b) (x ↦ ∑(x ‥ b) (y ↦ f(x)(y))) ≡ ... and first prove a theorem stating that the order of a list does not matter
-- ∑-nested-dependent-range : ∀{f : ℕ → ℕ → _}{a b} → ?

∑-of-succ : (∑(r) (𝐒 ∘ f) ≡ (∑(r) f) + length(r))
∑-of-succ {empty}      {f} = [≡]-intro
∑-of-succ {prepend x r}{f} =
  ∑(x ⊰ r) (𝐒 ∘ f)                 🝖[ _≡_ ]-[]
  𝐒(f(x)) + ∑(r) (𝐒 ∘ f)           🝖[ _≡_ ]-[]
  𝐒(f(x) + ∑(r) (𝐒 ∘ f))           🝖[ _≡_ ]-[ congruence₁(𝐒) (congruence₂ᵣ(_+_)(f(x)) (∑-of-succ {r}{f})) ]
  𝐒(f(x) + ((∑(r) f) + length(r))) 🝖[ _≡_ ]-[ congruence₁(𝐒) (symmetry(_≡_) (associativity(_+_) {x = f(x)}{y = ∑(r) f}{z = length(r)})) ]
  𝐒((f(x) + (∑(r) f)) + length(r)) 🝖[ _≡_ ]-[]
  𝐒((∑(x ⊰ r) f) + length(r))      🝖[ _≡_ ]-[]
  (∑(x ⊰ r) f) + 𝐒(length(r))      🝖[ _≡_ ]-[]
  (∑(x ⊰ r) f) + length(x ⊰ r)     🝖-end

∑-even-sum : (∑(𝟎 ‥₌ n) (k ↦ 2 ⋅ k) ≡ n ⋅ 𝐒(n))
∑-even-sum {𝟎}   = [≡]-intro
∑-even-sum {𝐒 n} =
  ∑(𝟎 ‥₌ 𝐒(n)) (k ↦ 2 ⋅ k)                       🝖[ _≡_ ]-[]
  (2 ⋅ 𝟎) + ∑(1 ‥₌ 𝐒(n)) (k ↦ 2 ⋅ k)             🝖[ _≡_ ]-[]
  𝟎 + ∑(1 ‥₌ 𝐒(n)) (k ↦ 2 ⋅ k)                   🝖[ _≡_ ]-[]
  ∑(1 ‥₌ 𝐒(n)) (k ↦ 2 ⋅ k)                       🝖[ _≡_ ]-[]
  ∑(map 𝐒(𝟎 ‥₌ n)) (k ↦ 2 ⋅ k)                   🝖[ _≡_ ]-[ ∑-step-range {a = 𝟎}{b = 𝐒 n}{f = 2 ⋅_} ]
  ∑(𝟎 ‥₌ n) (k ↦ 2 ⋅ 𝐒(k))                       🝖[ _≡_ ]-[]
  ∑(𝟎 ‥₌ n) (k ↦ 2 + (2 ⋅ k))                    🝖[ _≡_ ]-[ ∑-add {r = 0 ‥₌ n}{f = const 2}{g = 2 ⋅_} ]-sym
  ∑(𝟎 ‥₌ n) (const(2)) + ∑(𝟎 ‥₌ n) (k ↦ (2 ⋅ k)) 🝖[ _≡_ ]-[ congruence₂(_+_) (∑-const {r = 0 ‥₌ n}{c = 2}) (∑-even-sum {n}) ]
  (2 ⋅ length(𝟎 ‥₌ n)) + (n ⋅ 𝐒(n))              🝖[ _≡_ ]-[ congruence₂ₗ(_+_)(n ⋅ 𝐒(n)) (congruence₂ᵣ(_⋅_)(2) (Range-length-zero {𝐒(n)})) ]
  (2 ⋅ 𝐒(n)) + (n ⋅ 𝐒(n))                        🝖[ _≡_ ]-[ distributivityᵣ(_⋅_)(_+_) {x = 2}{y = n}{z = 𝐒(n)} ]-sym
  (2 + n) ⋅ 𝐒(n)                                 🝖[ _≡_ ]-[]
  𝐒(𝐒(n)) ⋅ 𝐒(n)                                 🝖[ _≡_ ]-[ commutativity(_⋅_) {𝐒(𝐒(n))}{𝐒(n)} ]
  𝐒(n) ⋅ 𝐒(𝐒(n))                                 🝖[ _≡_ ]-end

∑-odd-sum : (∑(𝟎 ‥ n) (k ↦ 𝐒(2 ⋅ k)) ≡ n ^ 2)
∑-odd-sum {𝟎}   = [≡]-intro
∑-odd-sum {𝐒 n} =
  ∑(𝟎 ‥ 𝐒(n)) (k ↦ 𝐒(2 ⋅ k))               🝖[ _≡_ ]-[]
  ∑(𝟎 ‥₌ n) (k ↦ 𝐒(2 ⋅ k))                 🝖[ _≡_ ]-[ ∑-of-succ {r = 𝟎 ‥ 𝐒(n)}{f = 2 ⋅_} ]
  ∑(𝟎 ‥₌ n) (k ↦ 2 ⋅ k) + length(𝟎 ‥ 𝐒(n)) 🝖[ _≡_ ]-[ congruence₂(_+_) (∑-even-sum {n}) (Range-length-zero {𝐒(n)}) ]
  (n ⋅ 𝐒(n)) + 𝐒(n)                        🝖[ _≡_ ]-[ [⋅]-with-[𝐒]ₗ {x = n}{y = 𝐒(n)} ]-sym
  𝐒(n) ⋅ 𝐒(n)                              🝖[ _≡_ ]-[]
  𝐒(n) ^ 2                                 🝖-end

open import Numeral.Natural.Combinatorics

module _ where
  open import Data.List.Relation.Membership using (_∈_ ; use ; skip)

  mapDep : ∀{ℓ₁ ℓ₂}{A : Type{ℓ₁}}{B : Type{ℓ₂}} → (l : List(A)) → ((elem : A) → ⦃ _ : (elem ∈ l) ⦄ → B) → List(B)
  mapDep ∅ _ = ∅
  mapDep (elem ⊰ l) f = (f elem ⦃ use [≡]-intro ⦄) ⊰ (mapDep l (\x → f x ⦃ _∈_.skip infer ⦄))

  -- ∑dep : (r : List(ℕ)) → ((i : ℕ) → ⦃ _ : (i ∈ r) ⦄ → ℕ) → ℕ

  -- ∑dep-test : ∑dep ∅ id ≡ 0

-- Also called: The binomial theorem
{-
binomial-power : ∀{n}{a b} → ((a + b) ^ n ≡ ∑(𝟎 ‥₌ n) (i ↦ 𝑐𝐶(n)(i) ⋅ (a ^ (n −₀ i)) ⋅ (b ^ i)))
binomial-power {𝟎}   {a} {b} =
  (a + b) ^ 𝟎                                         🝖[ _≡_ ]-[]
  1                                                   🝖[ _≡_ ]-[]
  1 ⋅ 1 ⋅ 1                                           🝖[ _≡_ ]-[]
  𝑐𝐶(𝟎)(𝟎) ⋅ (a ^ 𝟎) ⋅ (b ^ 𝟎)                        🝖[ _≡_ ]-[]
  𝑐𝐶(𝟎)(𝟎) ⋅ (a ^ (𝟎 −₀ 𝟎)) ⋅ (b ^ 𝟎)                 🝖[ _≡_ ]-[]
  ∑(𝟎 ‥₌ 𝟎) (i ↦ 𝑐𝐶(𝟎)(i) ⋅ (a ^ (𝟎 −₀ i)) ⋅ (b ^ 𝟎)) 🝖-end
binomial-power {𝐒 n} {a} {b} = {!!}
{-  (a + b) ^ 𝐒(n)                                                                                🝖[ _≡_ ]-[]
  (a + b) ⋅ ((a + b) ^ n)                                                                                🝖[ _≡_ ]-[ congruence₂ᵣ(_⋅_)(a + b) (binomial-power{n}{a}{b}) ]
  (a + b) ⋅ (∑(𝟎 ‥₌ n) (i ↦ 𝑐𝐶(n)(i) ⋅ (a ^ i) ⋅ (b ^ (n −₀ i))))                                                           🝖[ _≡_ ]-[ {!!} ]
  (a ⋅ (∑(𝟎 ‥₌ n) (i ↦ 𝑐𝐶(n)(i) ⋅ (a ^ i) ⋅ (b ^ (n −₀ i))))) + (b ⋅ (∑(𝟎 ‥₌ n) (i ↦ 𝑐𝐶(n)(i) ⋅ (a ^ i) ⋅ (b ^ (n −₀ i))))) 🝖[ _≡_ ]-[ {!!} ]

  a ⋅ (b ^ 𝐒(n)) ⋅ ∑(𝟎 ‥₌ n) (i ↦ 𝑐𝐶(𝐒(n))(𝐒(i)) ⋅ (a ^ i) ⋅ (b ^ (n −₀ i)))                                                🝖[ _≡_ ]-[ {!!} ]
  (b ^ 𝐒(n)) ⋅ ∑(𝟎 ‥₌ n) (i ↦ 𝑐𝐶(𝐒(n))(𝐒(i)) ⋅ a ⋅ (a ^ i) ⋅ (b ^ (n −₀ i)))                                                🝖[ _≡_ ]-[ {!!} ]
  (b ^ 𝐒(n)) ⋅ ∑(𝟎 ‥₌ n) (i ↦ 𝑐𝐶(𝐒(n))(𝐒(i)) ⋅ (a ^ 𝐒(i)) ⋅ (b ^ (n −₀ i)))                                                 🝖[ _≡_ ]-[]
  (b ^ 𝐒(n)) ⋅ ∑(𝟎 ‥₌ n) (i ↦ 𝑐𝐶(𝐒(n))(𝐒(i)) ⋅ (a ^ 𝐒(i)) ⋅ (b ^ (𝐒(n) −₀ 𝐒(i))))                                            🝖[ _≡_ ]-[ {!!} ]
  (b ^ 𝐒(n)) ⋅ ∑(1 ‥₌ 𝐒(n)) (i ↦ 𝑐𝐶(𝐒(n))(i) ⋅ (a ^ i) ⋅ (b ^ (𝐒(n) −₀ i)))                                  🝖[ _≡_ ]-[]
  (1 ⋅ 1 ⋅ (b ^ 𝐒(n))) ⋅ ∑(1 ‥₌ 𝐒(n)) (i ↦ 𝑐𝐶(𝐒(n))(i) ⋅ (a ^ i) ⋅ (b ^ (𝐒(n) −₀ i)))                        🝖[ _≡_ ]-[]
  (𝑐𝐶(𝐒(n))(𝟎) ⋅ (a ^ 𝟎) ⋅ (b ^ (𝐒(n) −₀ 𝟎))) ⋅ ∑(1 ‥₌ 𝐒(n)) (i ↦ 𝑐𝐶(𝐒(n))(i) ⋅ (a ^ i) ⋅ (b ^ (𝐒(n) −₀ i))) 🝖[ _≡_ ]-[ {!!} ]
  ∑(𝟎 ‥₌ 𝐒(n)) (i ↦ 𝑐𝐶(𝐒(n))(i) ⋅ (a ^ i) ⋅ (b ^ (𝐒(n) −₀ i)))                                               🝖-end-}
  where
    left : _ ≡ _
    left =
      a ⋅ (∑(𝟎 ‥₌ n) (i ↦ 𝑐𝐶(n)(i) ⋅ (a ^ (n −₀ i)) ⋅ (b ^ i)))                                               🝖[ _≡_ ]-[ {!!} ]
      ∑(𝟎 ‥₌ n) (i ↦ a ⋅ 𝑐𝐶(n)(i) ⋅ (a ^ (n −₀ i)) ⋅ (b ^ i))                                                 🝖[ _≡_ ]-[ {!!} ]
      ∑(𝟎 ‥₌ n) (i ↦ 𝑐𝐶(n)(i) ⋅ (a ⋅ (a ^ (n −₀ i))) ⋅ (b ^ i))                                               🝖[ _≡_ ]-[ {!!} ]
      (𝑐𝐶(n)(𝟎) ⋅ (a ⋅ (a ^ (n −₀ 𝟎))) ⋅ (b ^ 𝟎)) + ∑(1 ‥₌ n) (i ↦ 𝑐𝐶(n)(i) ⋅ (a ⋅ (a ^ (n −₀ i))) ⋅ (b ^ i)) 🝖[ _≡_ ]-[ {!!} ]
      (1 ⋅ (a ^ 𝐒(n)) ⋅ 1) + ∑(1 ‥₌ n) (i ↦ 𝑐𝐶(n)(i) ⋅ (a ⋅ (a ^ (n −₀ i))) ⋅ (b ^ i))                        🝖[ _≡_ ]-[ {!!} ]
      (1 ⋅ (a ^ 𝐒(n))) + ∑(1 ‥₌ n) (i ↦ 𝑐𝐶(n)(i) ⋅ (a ⋅ (a ^ (n −₀ i))) ⋅ (b ^ i))                            🝖-end
-- TODO: Maybe need another variant of ∑ where the index has a proof of it being in the range? And it is in this case used for a ⋅ (a ^ (n −₀ i)) ≡ a ^ (𝐒(n) −₀ i)
-}


{-# OPTIONS --prop --rewriting --confluence-check #-}

open import Agda.Builtin.Nat
open import Agda.Builtin.Equality

{-# BUILTIN REWRITE _≡_ #-}

data _≐_ {ℓ} {A : Set ℓ} (x : A) : A → Prop ℓ where
  refl : x ≐ x

postulate
  subst : ∀ {ℓ ℓ′} {A : Set ℓ} (P : A → Set ℓ′)
        → (x y : A) → x ≐ y → P x → P y
  subst-rew : ∀ {ℓ ℓ′} {A : Set ℓ} (P : A → Set ℓ′)
            → {x : A} (e : x ≐ x) (p : P x) → subst P x x e p ≡ p
{-# REWRITE subst-rew #-}

data Box (A : Prop) : Set where
  box : A -> Box A

foo : (A : Prop)(x y : A)(P : Box A → Set)(p : P (box x)) → subst P (box x) (box y) refl p ≐ p
foo A x y P p = refl -- refl does not type check


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

open import Categories.Category.Monoidal
open import Categories.Functor.Monoidal

module Categories.NaturalTransformation.NaturalIsomorphism.Monoidal
  where

open import Level
open import Data.Product using (_,_)
open import Relation.Binary using (IsEquivalence; Setoid)

open import Categories.Category.Product
import Categories.Category.Monoidal.Reasoning as MonoidalReasoning
import Categories.Category.Monoidal.Utilities as MonoidalUtilities
open import Categories.Functor hiding (id)
open import Categories.Functor.Monoidal.Properties using () renaming
  ( idF-Monoidal to idFˡ  ; idF-StrongMonoidal to idFˢ
  ; ∘-Monoidal   to _∘Fˡ_ ; ∘-StrongMonoidal   to _∘Fˢ_
  )
import Categories.Morphism.Reasoning as MorphismReasoning
import Categories.NaturalTransformation.Monoidal as NT
open import Categories.NaturalTransformation.NaturalIsomorphism as NI
  using (NaturalIsomorphism)

open NaturalIsomorphism using (F⇒G; F⇐G)

-- Monoidal natural isomorphisms between lax monoidal functors.

module Lax where
  open NT.Lax hiding (id)

  module _ {o ℓ e o′ ℓ′ e′}
           {C : MonoidalCategory o ℓ e} {D : MonoidalCategory o′ ℓ′ e′}
           (F G : MonoidalFunctor C D) where

    private
      module C = MonoidalCategory C
      module D = MonoidalCategory D
      module F = MonoidalFunctor F renaming (F to U)
      module G = MonoidalFunctor G renaming (F to U)

    IsMonoidalNaturalIsomorphism : NaturalIsomorphism F.U G.U → Set (o ⊔ ℓ′ ⊔ e′)
    IsMonoidalNaturalIsomorphism α = IsMonoidalNaturalTransformation F G (F⇒G α)

    record MonoidalNaturalIsomorphism : Set (o ⊔ ℓ ⊔ ℓ′ ⊔ e′) where
      field
        U              : NaturalIsomorphism F.U G.U
        F⇒G-isMonoidal : IsMonoidalNaturalIsomorphism U

      open NaturalIsomorphism              U              public
      open IsMonoidalNaturalTransformation F⇒G-isMonoidal public

      open D using (module Equiv)
      open MorphismReasoning D.U using (switch-fromtoˡ; conjugate-from)
      open MonoidalUtilities D.monoidal using (_⊗ᵢ_)

      F⇐G-isMonoidal : IsMonoidalNaturalTransformation G F (F⇐G U)
      F⇐G-isMonoidal = record
        { ε-compat      = Equiv.sym (switch-fromtoˡ FX≅GX ε-compat)
        ; ⊗-homo-compat =
            conjugate-from (FX≅GX ⊗ᵢ FX≅GX) FX≅GX (Equiv.sym ⊗-homo-compat)
        }

      F⇒G-monoidal : MonoidalNaturalTransformation F G
      F⇒G-monoidal = record { U = F⇒G U ; isMonoidal = F⇒G-isMonoidal }

      F⇐G-monoidal : MonoidalNaturalTransformation G F
      F⇐G-monoidal = record { U = F⇐G U ; isMonoidal = F⇐G-isMonoidal }

    infix 4 _≃_

    _≃_ = MonoidalNaturalIsomorphism

  open MonoidalNaturalTransformation using (isMonoidal)
  open MonoidalNaturalIsomorphism

  -- Identity and compositions

  module _ {o ℓ e o′ ℓ′ e′}
           {C : MonoidalCategory o ℓ e} {D : MonoidalCategory o′ ℓ′ e′} where

    infixr 9 _ⓘᵥ_

    id : {F : MonoidalFunctor C D} → F ≃ F
    id = record { U = NI.refl ; F⇒G-isMonoidal = isMonoidal NT.Lax.id }

    _ⓘᵥ_ : {F G H : MonoidalFunctor C D} → G ≃ H → F ≃ G → F ≃ H
    _ⓘᵥ_ α β = record
      { U              = U α NI.ⓘᵥ U β
      ; F⇒G-isMonoidal = isMonoidal (F⇒G-monoidal α ∘ᵥ F⇒G-monoidal β)
      }

    isEquivalence : IsEquivalence _≃_
    isEquivalence = record
      { refl  = id
      ; sym   = λ α → record
        { U              = NI.sym (U α)
        ; F⇒G-isMonoidal = F⇐G-isMonoidal α
        }
      ; trans = λ α β → β ⓘᵥ α
      }

  module _ {o ℓ e o′ ℓ′ e′ o″ ℓ″ e″}
           {C : MonoidalCategory o ℓ e} {D : MonoidalCategory o′ ℓ′ e′}
           {E : MonoidalCategory o″ ℓ″ e″} where

    infixr 9 _ⓘₕ_ _ⓘˡ_ _ⓘʳ_

    _ⓘₕ_ : {F G : MonoidalFunctor C D} {H I : MonoidalFunctor D E} →
            H ≃ I → F ≃ G → (H ∘Fˡ F) ≃ (I ∘Fˡ G)
    _ⓘₕ_ α β = record
      { U              = U α NI.ⓘₕ U β
      ; F⇒G-isMonoidal = isMonoidal (F⇒G-monoidal α ∘ₕ F⇒G-monoidal β)
      }

    _ⓘˡ_ : {F G : MonoidalFunctor C D}
           (H : MonoidalFunctor D E) → F ≃ G → (H ∘Fˡ F) ≃ (H ∘Fˡ G)
    H ⓘˡ α = id {F = H} ⓘₕ α

    _ⓘʳ_ : {G H : MonoidalFunctor D E} →
           G ≃ H → (F : MonoidalFunctor C D) → (G ∘Fˡ F) ≃ (H ∘Fˡ F)
    α ⓘʳ F = α ⓘₕ id {F = F}

  -- Left and right unitors.

  module _ {o ℓ e o′ ℓ′ e′}
           {C : MonoidalCategory o ℓ e} {D : MonoidalCategory o′ ℓ′ e′}
           {F : MonoidalFunctor C D} where
    private
      module C = MonoidalCategory C
      module D = MonoidalCategory D
      module F = MonoidalFunctor F
    open D hiding (U; id; unitorˡ; unitorʳ)
    open MorphismReasoning D.U using (id-comm-sym)
    open MonoidalReasoning D.monoidal

    unitorˡ : idFˡ D ∘Fˡ F ≃ F
    unitorˡ = record
      { U = NI.unitorˡ
      ; F⇒G-isMonoidal = record
        { ε-compat      = identityˡ ○ identityʳ
        ; ⊗-homo-compat = λ {X Y} → begin
            D.id D.∘ F.⊗-homo.η (X , Y) D.∘ D.id  ≈⟨ identityˡ ⟩
            F.⊗-homo.η (X , Y) D.∘ D.id           ≈˘⟨ refl⟩∘⟨ ⊗.identity ⟩
            F.⊗-homo.η (X , Y) D.∘ D.id ⊗₁ D.id   ∎
        }
      }

    unitorʳ : F ∘Fˡ idFˡ C ≃ F
    unitorʳ = record
      { U               = NI.unitorʳ
      ; F⇒G-isMonoidal  = record
        { ε-compat      = begin
            D.id ∘ F.₁ C.id ∘ F.ε  ≈⟨ identityˡ ⟩
            F.₁ C.id ∘ F.ε         ≈⟨ F.identity ⟩∘⟨refl ⟩
            D.id ∘ F.ε             ≈⟨ identityˡ ⟩
            F.ε ∎
        ; ⊗-homo-compat = λ {X Y} → begin
            D.id D.∘ F.₁ C.id ∘ F.⊗-homo.η (X , Y)  ≈⟨ identityˡ ⟩
            F.₁ C.id ∘ F.⊗-homo.η (X , Y)           ≈⟨ F.identity ⟩∘⟨refl ⟩
            D.id ∘ F.⊗-homo.η (X , Y)               ≈⟨ id-comm-sym ⟩
            F.⊗-homo.η (X , Y) D.∘ D.id             ≈˘⟨ refl⟩∘⟨ ⊗.identity ⟩
            F.⊗-homo.η (X , Y) D.∘ D.id ⊗₁ D.id     ∎
        }
      }

  -- Associator.

  module _ {o ℓ e o′ ℓ′ e′ o″ ℓ″ e″ o‴ ℓ‴ e‴}
           {B : MonoidalCategory o ℓ e} {C : MonoidalCategory o′ ℓ′ e′}
           {D : MonoidalCategory o″ ℓ″ e″} {E : MonoidalCategory o‴ ℓ‴ e‴}
           {F : MonoidalFunctor B C} {G : MonoidalFunctor C D}
           {H : MonoidalFunctor D E} where
    private
      module D = MonoidalCategory D
      module E = MonoidalCategory E
      module F = MonoidalFunctor F
      module G = MonoidalFunctor G
      module H = MonoidalFunctor H
    open E hiding (U; id; associator)
    open MorphismReasoning E.U
    open MonoidalReasoning E.monoidal

    associator : (H ∘Fˡ G) ∘Fˡ F ≃ H ∘Fˡ (G ∘Fˡ F)
    associator = record
      { U               = NI.associator (F.F) (G.F) (H.F)
      ; F⇒G-isMonoidal  = record
        { ε-compat      = begin
            E.id ∘ H.₁ (G.₁ F.ε) ∘ H.₁ G.ε ∘ H.ε  ≈⟨ identityˡ ⟩
            H.₁ (G.₁ F.ε) ∘ H.₁ G.ε ∘ H.ε         ≈˘⟨ pushˡ H.homomorphism ⟩
            H.₁ (G.₁ F.ε D.∘ G.ε) ∘ H.ε           ∎
        ; ⊗-homo-compat = λ {X Y} → begin
            E.id ∘ H.₁ (G.₁ (F.⊗-homo.η (X , Y))) ∘
            H.₁ (G.⊗-homo.η (F.F₀ X , F.F₀ Y)) ∘
            H.⊗-homo.η (G.F₀ (F.F₀ X) , G.F₀ (F.F₀ Y))
          ≈⟨ identityˡ ⟩
            H.₁ (G.₁ (F.⊗-homo.η (X , Y))) ∘
            H.₁ (G.⊗-homo.η (F.F₀ X , F.F₀ Y)) ∘
            H.⊗-homo.η (G.F₀ (F.F₀ X) , G.F₀ (F.F₀ Y))
          ≈˘⟨ pushˡ H.homomorphism ⟩
            H.₁ (G.₁ (F.⊗-homo.η (X , Y)) D.∘ G.⊗-homo.η (F.F₀ X , F.F₀ Y)) ∘
            H.⊗-homo.η (G.F₀ (F.F₀ X) , G.F₀ (F.F₀ Y))
          ≈˘⟨ identityʳ ⟩
            (H.₁ (G.₁ (F.⊗-homo.η (X , Y)) D.∘ G.⊗-homo.η (F.F₀ X , F.F₀ Y)) ∘
            H.⊗-homo.η (G.F₀ (F.F₀ X) , G.F₀ (F.F₀ Y))) ∘ E.id
          ≈˘⟨ refl⟩∘⟨ ⊗.identity ⟩
            (H.₁ (G.₁ (F.⊗-homo.η (X , Y)) D.∘ G.⊗-homo.η (F.F₀ X , F.F₀ Y)) ∘
             H.⊗-homo.η (G.F₀ (F.F₀ X) , G.F₀ (F.F₀ Y))) ∘
            E.id ⊗₁ E.id
          ∎
        }
      }

-- Monoidal natural isomorphisms between strong monoidal functors.

module Strong where
  open NT.Strong using (IsMonoidalNaturalTransformation)
  open StrongMonoidalFunctor renaming (F to UF; monoidalFunctor to laxF)

  module _ {o ℓ e o′ ℓ′ e′}
           {C : MonoidalCategory o ℓ e} {D : MonoidalCategory o′ ℓ′ e′}
           (F G : StrongMonoidalFunctor C D) where

    IsMonoidalNaturalIsomorphism : NaturalIsomorphism (UF F) (UF G) →
                                   Set (o ⊔ ℓ′ ⊔ e′)
    IsMonoidalNaturalIsomorphism α = IsMonoidalNaturalTransformation F G (F⇒G α)

    -- NOTE. This record contains the same data as the lax version,
    -- but the type arguments are different.  This helps type
    -- inference by providing the right constraints.

    record MonoidalNaturalIsomorphism : Set (o ⊔ ℓ ⊔ ℓ′ ⊔ e′) where
      field
        U              : NaturalIsomorphism (UF F) (UF G)
        F⇒G-isMonoidal : IsMonoidalNaturalIsomorphism U

      laxNI : Lax.MonoidalNaturalIsomorphism (laxF F) (laxF G)
      laxNI = record { U = U ; F⇒G-isMonoidal = F⇒G-isMonoidal }
      open Lax.MonoidalNaturalIsomorphism laxNI public
        hiding (U; F⇒G-isMonoidal)

    infix 4 _≃_

    _≃_ = MonoidalNaturalIsomorphism

  open MonoidalNaturalIsomorphism

  module _ {o ℓ e o′ ℓ′ e′}
           {C : MonoidalCategory o ℓ e} {D : MonoidalCategory o′ ℓ′ e′} where

    infixr 9 _ⓘᵥ_

    -- Since they contain the same data, we can strengthen a lax
    -- monoidal isomorphism to a strong one.

    strengthen : {F G : StrongMonoidalFunctor C D} →
                 (laxF F) Lax.≃ (laxF G) → F ≃ G
    strengthen α = record { U = L.U ; F⇒G-isMonoidal = L.F⇒G-isMonoidal }
      where module L = Lax.MonoidalNaturalIsomorphism α

    -- Identity and compositions

    id : {F : StrongMonoidalFunctor C D} → F ≃ F
    id = strengthen Lax.id

    _ⓘᵥ_ : {F G H : StrongMonoidalFunctor C D} → G ≃ H → F ≃ G → F ≃ H
    α ⓘᵥ β = strengthen (laxNI α Lax.ⓘᵥ laxNI β)

    isEquivalence : IsEquivalence _≃_
    isEquivalence = record
      { refl  = λ {F} → id {F}
      ; sym   = λ α → record
        { U              = NI.sym (U α)
        ; F⇒G-isMonoidal = F⇐G-isMonoidal α
        }
      ; trans = λ {F} {G} {H} α β → _ⓘᵥ_ {F} {G} {H} β α
      }

  module _ {o ℓ e o′ ℓ′ e′ o″ ℓ″ e″}
           {C : MonoidalCategory o ℓ e} {D : MonoidalCategory o′ ℓ′ e′}
           {E : MonoidalCategory o″ ℓ″ e″} where

    open Lax.MonoidalNaturalIsomorphism

    infixr 9 _ⓘₕ_ _ⓘˡ_ _ⓘʳ_

    _ⓘₕ_ : {F G : StrongMonoidalFunctor C D} {H I : StrongMonoidalFunctor D E} →
            H ≃ I → F ≃ G → (H ∘Fˢ F) ≃ (I ∘Fˢ G)
    -- FIXME: this definition is clearly equivalent to
    --
    --   α ⓘₕ β = strengthen (laxNI α Lax.ⓘₕ laxNI β)
    --
    -- but the latter takes an unreasonably long time to typecheck,
    -- while the unfolded version typechecks almost immediately.
    α ⓘₕ β = record
      { U               = L.U
      ; F⇒G-isMonoidal  = record
        { ε-compat      = L.ε-compat
        ; ⊗-homo-compat = L.⊗-homo-compat }
        }
      where
        module L = Lax.MonoidalNaturalIsomorphism (laxNI α Lax.ⓘₕ laxNI β)

    _ⓘˡ_ : {F G : StrongMonoidalFunctor C D}
           (H : StrongMonoidalFunctor D E) → F ≃ G → (H ∘Fˢ F) ≃ (H ∘Fˢ G)
    H ⓘˡ α = id {F = H} ⓘₕ α

    _ⓘʳ_ : {G H : StrongMonoidalFunctor D E} →
           G ≃ H → (F : StrongMonoidalFunctor C D) → (G ∘Fˢ F) ≃ (H ∘Fˢ F)
    α ⓘʳ F = α ⓘₕ id {F = F}

  -- Left and right unitors.

  module _ {o ℓ e o′ ℓ′ e′}
           {C : MonoidalCategory o ℓ e} {D : MonoidalCategory o′ ℓ′ e′}
           {F : StrongMonoidalFunctor C D} where

    unitorˡ : idFˢ D ∘Fˢ F ≃ F
    -- FIXME: Again, this unfolded definition typechecks considerably
    -- faster than the equivalent
    --
    --   strengthen (Lax.unitorʳ {F = laxF F})
    unitorˡ = record
      { U               = L.U
      ; F⇒G-isMonoidal  = record
        { ε-compat      = L.ε-compat
        ; ⊗-homo-compat = L.⊗-homo-compat
        }
      }
      where module L = Lax.MonoidalNaturalIsomorphism (Lax.unitorˡ {F = laxF F})

    unitorʳ : F ∘Fˢ idFˢ C ≃ F
    -- FIXME: ... same here ...
    unitorʳ = record
      { U               = L.U
      ; F⇒G-isMonoidal  = record
        { ε-compat      = L.ε-compat
        ; ⊗-homo-compat = L.⊗-homo-compat
        }
      }
      where module L = Lax.MonoidalNaturalIsomorphism (Lax.unitorʳ {F = laxF F})

  -- Associator.

  module _ {o ℓ e o′ ℓ′ e′ o″ ℓ″ e″ o‴ ℓ‴ e‴}
           {B : MonoidalCategory o ℓ e} {C : MonoidalCategory o′ ℓ′ e′}
           {D : MonoidalCategory o″ ℓ″ e″} {E : MonoidalCategory o‴ ℓ‴ e‴}
           {F : StrongMonoidalFunctor B C} {G : StrongMonoidalFunctor C D}
           {H : StrongMonoidalFunctor D E} where

    associator : (H ∘Fˢ G) ∘Fˢ F ≃ H ∘Fˢ (G ∘Fˢ F)
    -- FIXME: ... and here.  Though, for this one, even the unfolded
    -- version takes a lot of time.
    associator = record
      { U               = L.U
      ; F⇒G-isMonoidal  = record
        { ε-compat      = L.ε-compat
        ; ⊗-homo-compat = L.⊗-homo-compat
        }
      }
      where
        α = Lax.associator {F = laxF F} {laxF G} {laxF H}
        module L = Lax.MonoidalNaturalIsomorphism α