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

open import lib.Basics
open import lib.types.FunctionSeq
open import lib.types.Nat
open import lib.types.Pointed
open import lib.types.Suspension.Core
open import lib.types.Suspension.Iterated

module lib.types.Suspension.IteratedEquivs where

Susp^-+ : ∀ {i} (m n : ℕ) {A : Type i}
  → Susp^ m (Susp^ n A) == Susp^ (m + n) A
Susp^-+ O n = idp
Susp^-+ (S m) n = ap Susp (Susp^-+ m n)

⊙Susp^-+ : ∀ {i} (m n : ℕ) {X : Ptd i}
  → ⊙Susp^ m (⊙Susp^ n X) == ⊙Susp^ (m + n) X
⊙Susp^-+ 0 n {X} = idp
⊙Susp^-+ (S m) n {X} = ap ⊙Susp (Susp^-+ m n)

de⊙-⊙Susp^-+ : ∀ {i} (m n : ℕ) {X : Ptd i}
  → ap de⊙ (⊙Susp^-+ m n {X}) == Susp^-+ m n {de⊙ X}
de⊙-⊙Susp^-+ 0 n {X} = idp
de⊙-⊙Susp^-+ (S m) n {X} = ∘-ap de⊙ ⊙Susp (Susp^-+ m n)

Susp^-+-0-r : ∀ {i} (m : ℕ) {A : Type i}
  → Susp^-+ m 0 ◃∙ ap (λ k → Susp^ k A) (+-unit-r m) ◃∎ =ₛ []
Susp^-+-0-r O {A} = =ₛ-in $
  ap (ap (λ k → Susp^ k A))
     (set-path ℕ-level (+-unit-r 0) idp)
Susp^-+-0-r (S m) {A} =
  ap Susp (Susp^-+ m 0) ◃∙
  ap (λ k → Susp^ k A) (+-unit-r (S m)) ◃∎
    =ₛ₁⟨ 1 & 1 & ap (ap (λ k → Susp^ k A)) $
                 set-path ℕ-level (+-unit-r (S m)) (ap S (+-unit-r m)) ⟩
  ap Susp (Susp^-+ m 0) ◃∙
  ap (λ k → Susp^ k A) (ap S (+-unit-r m)) ◃∎
    =ₛ₁⟨ 1 & 1 &
         ∘-ap (λ k → Susp^ k A) S (+-unit-r m) ∙
         ap-∘ Susp (λ k → Susp^ k A) (+-unit-r m) ⟩
  ap Susp (Susp^-+ m 0) ◃∙
  ap Susp (ap (λ k → Susp^ k A) (+-unit-r m)) ◃∎
    =ₛ⟨ ap-seq-=ₛ Susp (Susp^-+-0-r m) ⟩
  [] ∎ₛ

⊙Susp^-+-0-r : ∀ {i} (m : ℕ) {X : Ptd i}
  → ⊙Susp^-+ m 0 ◃∙ ap (λ k → ⊙Susp^ k X) (+-unit-r m) ◃∎ =ₛ []
⊙Susp^-+-0-r 0 {X} = =ₛ-in $
  ap (ap (λ k → ⊙Susp^ k X))
     (set-path ℕ-level (+-unit-r 0) idp)
⊙Susp^-+-0-r (S m) {X} =
  ap ⊙Susp (Susp^-+ m 0) ◃∙
  ap (λ k → ⊙Susp^ k X) (+-unit-r (S m)) ◃∎
    =ₛ₁⟨ 1 & 1 & ap (ap (λ k → ⊙Susp^ k X)) $
                 set-path ℕ-level (+-unit-r (S m)) (ap S (+-unit-r m)) ⟩
  ap ⊙Susp (Susp^-+ m 0) ◃∙
  ap (λ k → ⊙Susp^ k X) (ap S (+-unit-r m)) ◃∎
    =ₛ₁⟨ 1 & 1 &
         ∘-ap (λ k → ⊙Susp^ k X) S (+-unit-r m) ∙
         ap-∘ ⊙Susp (λ k → Susp^ k (de⊙ X)) (+-unit-r m) ⟩
  ap ⊙Susp (Susp^-+ m 0) ◃∙
  ap ⊙Susp (ap (λ k → Susp^ k (de⊙ X)) (+-unit-r m)) ◃∎
    =ₛ⟨ ap-seq-=ₛ ⊙Susp (Susp^-+-0-r m) ⟩
  [] ∎ₛ

Susp^-+-assoc-coh : ∀ {i} (m n o : ℕ) {A : Type i}
  → ap (Susp^ m) (Susp^-+ n o {A}) ◃∙
    Susp^-+ m (n + o) {A} ◃∎
    =ₛ
    Susp^-+ m n {Susp^ o A} ◃∙
    Susp^-+ (m + n) o ◃∙
    ap (λ k → Susp^ k A) (+-assoc m n o) ◃∎
Susp^-+-assoc-coh O n o {A} =
  ap (idf _) (Susp^-+ n o {A}) ◃∙
  idp ◃∎
    =ₛ₁⟨ 0 & 1 & ap-idf (Susp^-+ n o {A}) ⟩
  Susp^-+ n o {A} ◃∙
  idp ◃∎
    =ₛ₁⟨ 1 & 1 & ap (ap (λ k → Susp^ k A)) $
         set-path ℕ-level idp (+-assoc 0 n o) ⟩
  Susp^-+ n o {A} ◃∙
  ap (λ k → Susp^ k A) (+-assoc 0 n o) ◃∎
    =ₛ⟨ 0 & 0 & contract ⟩
  idp ◃∙
  Susp^-+ n o {A} ◃∙
  ap (λ k → Susp^ k A) (+-assoc 0 n o) ◃∎ ∎ₛ
Susp^-+-assoc-coh (S m) n o {A} =
  ap (Susp ∘ Susp^ m) (Susp^-+ n o {A}) ◃∙
  ap Susp (Susp^-+ m (n + o) {A}) ◃∎
    =ₛ₁⟨ 0 & 1 & ap-∘ Susp (Susp^ m) (Susp^-+ n o {A}) ⟩
  ap Susp (ap (Susp^ m) (Susp^-+ n o {A})) ◃∙
  ap Susp (Susp^-+ m (n + o) {A}) ◃∎
    =ₛ⟨ ap-seq-=ₛ Susp (Susp^-+-assoc-coh m n o) ⟩
  ap Susp (Susp^-+ m n) ◃∙
  ap Susp (Susp^-+ (m + n) o) ◃∙
  ap Susp (ap (λ k → Susp^ k A) (+-assoc m n o)) ◃∎
    =ₛ₁⟨ 2 & 1 & ∘-ap Susp (λ k → Susp^ k A) (+-assoc m n o) ∙
                 ap-∘ (λ k → Susp^ k A) S (+-assoc m n o) ⟩
  ap Susp (Susp^-+ m n) ◃∙
  ap Susp (Susp^-+ (m + n) o) ◃∙
  ap (λ k → Susp^ k A) (ap S (+-assoc m n o)) ◃∎
    =ₛ₁⟨ 2 & 1 & ap (ap (λ k → Susp^ k A)) $
                 set-path ℕ-level (ap S (+-assoc m n o)) (+-assoc (S m) n o) ⟩
  ap Susp (Susp^-+ m n) ◃∙
  ap Susp (Susp^-+ (m + n) o) ◃∙
  ap (λ k → Susp^ k A) (+-assoc (S m) n o) ◃∎ ∎ₛ

⊙Susp^-+-assoc-coh : ∀ {i} (m n o : ℕ) {X : Ptd i}
  → ap (⊙Susp^ m) (⊙Susp^-+ n o {X}) ◃∙
    ⊙Susp^-+ m (n + o) {X} ◃∎
    =ₛ
    ⊙Susp^-+ m n {⊙Susp^ o X} ◃∙
    ⊙Susp^-+ (m + n) o ◃∙
    ap (λ k → ⊙Susp^ k X) (+-assoc m n o) ◃∎
⊙Susp^-+-assoc-coh O n o {X} =
  ap (idf _) (⊙Susp^-+ n o) ◃∙
  idp ◃∎
    =ₛ₁⟨ 0 & 1 & ap-idf (⊙Susp^-+ n o) ⟩
  ⊙Susp^-+ n o ◃∙
  idp ◃∎
    =ₛ₁⟨ 1 & 1 & ap (ap (λ k → ⊙Susp^ k X)) $
                 set-path ℕ-level idp (+-assoc 0 n o) ⟩
  ⊙Susp^-+ n o ◃∙
  ap (λ k → ⊙Susp^ k X) (+-assoc 0 n o) ◃∎
    =ₛ⟨ 0 & 0 & contract ⟩
  idp ◃∙
  ⊙Susp^-+ n o ◃∙
  ap (λ k → ⊙Susp^ k X) (+-assoc 0 n o) ◃∎ ∎ₛ
⊙Susp^-+-assoc-coh (S m) n o {X} =
  ap (⊙Susp ∘ Susp^ m ∘ de⊙) (⊙Susp^-+ n o {X}) ◃∙
  ap ⊙Susp (Susp^-+ m (n + o) {de⊙ X}) ◃∎
    =ₛ₁⟨ 0 & 1 & ap-∘ (⊙Susp ∘ Susp^ m) de⊙ (⊙Susp^-+ n o {X}) ⟩
  ap (⊙Susp ∘ Susp^ m) (ap de⊙ (⊙Susp^-+ n o {X})) ◃∙
  ap ⊙Susp (Susp^-+ m (n + o) {de⊙ X}) ◃∎
    =ₛ₁⟨ 0 & 1 & ap (ap (⊙Susp ∘ Susp^ m)) (de⊙-⊙Susp^-+ n o {X}) ⟩
  ap (⊙Susp ∘ Susp^ m) (Susp^-+ n o {de⊙ X}) ◃∙
  ap ⊙Susp (Susp^-+ m (n + o) {de⊙ X}) ◃∎
    =ₛ₁⟨ 0 & 1 & ap-∘ ⊙Susp (Susp^ m) (Susp^-+ n o {de⊙ X}) ⟩
  ap ⊙Susp (ap (Susp^ m) (Susp^-+ n o {de⊙ X})) ◃∙
  ap ⊙Susp (Susp^-+ m (n + o) {de⊙ X}) ◃∎
    =ₛ⟨ ap-seq-=ₛ ⊙Susp (Susp^-+-assoc-coh m n o) ⟩
  ap ⊙Susp (Susp^-+ m n) ◃∙
  ap ⊙Susp (Susp^-+ (m + n) o) ◃∙
  ap ⊙Susp (ap (λ k → Susp^ k (de⊙ X)) (+-assoc m n o)) ◃∎
    =ₛ₁⟨ 2 & 1 & ∘-ap ⊙Susp (λ k → Susp^ k (de⊙ X)) (+-assoc m n o) ∙
                 ap-∘ (λ k → ⊙Susp^ k X) S (+-assoc m n o) ⟩
  ap ⊙Susp (Susp^-+ m n) ◃∙
  ap ⊙Susp (Susp^-+ (m + n) o) ◃∙
  ap (λ k → ⊙Susp^ k X) (ap S (+-assoc m n o)) ◃∎
    =ₛ₁⟨ 2 & 1 & ap (ap (λ k → ⊙Susp^ k X)) $
                 set-path ℕ-level (ap S (+-assoc m n o)) (+-assoc (S m) n o) ⟩
  ap ⊙Susp (Susp^-+ m n) ◃∙
  ap ⊙Susp (Susp^-+ (m + n) o) ◃∙
  ap (λ k → ⊙Susp^ k X) (+-assoc (S m) n o) ◃∎ ∎ₛ

Susp^-comm-seq : ∀ {i} (m n : ℕ) {A : Type i}
  → Susp^ m (Susp^ n A) =-= Susp^ n (Susp^ m A)
Susp^-comm-seq m n {A} =
  Susp^ m (Susp^ n A)
    =⟪ Susp^-+ m n ⟫
  Susp^ (m + n) A
    =⟪ ap (λ k → Susp^ k A) (+-comm m n) ⟫
  Susp^ (n + m) A
    =⟪ ! (Susp^-+ n m) ⟫
  Susp^ n (Susp^ m A) ∎∎

Susp^-comm : ∀ {i} (m n : ℕ) {A : Type i}
  → Susp^ m (Susp^ n A) == Susp^ n (Susp^ m A)
Susp^-comm m n {A} = ↯ (Susp^-comm-seq m n {A})

⊙Susp^-comm-seq : ∀ {i} (m n : ℕ) {X : Ptd i}
  → ⊙Susp^ m (⊙Susp^ n X) =-= ⊙Susp^ n (⊙Susp^ m X)
⊙Susp^-comm-seq m n {X} =
  ⊙Susp^ m (⊙Susp^ n X)
    =⟪ ⊙Susp^-+ m n ⟫
  ⊙Susp^ (m + n) X
    =⟪ ap (λ k → ⊙Susp^ k X) (+-comm m n) ⟫
  ⊙Susp^ (n + m) X
    =⟪ ! (⊙Susp^-+ n m) ⟫
  ⊙Susp^ n (⊙Susp^ m X) ∎∎

⊙Susp^-comm : ∀ {i} (m n : ℕ) {X : Ptd i}
  → ⊙Susp^ m (⊙Susp^ n X) == ⊙Susp^ n (⊙Susp^ m X)
⊙Susp^-comm m n {X} = ↯ (⊙Susp^-comm-seq m n {X})

de⊙-⊙Susp^-comm : ∀ {i} (m n : ℕ) {X : Ptd i}
  → ap de⊙ (⊙Susp^-comm m n {X}) == Susp^-comm m n {de⊙ X}
de⊙-⊙Susp^-comm m n {X} = =ₛ-out {t = Susp^-comm m n {de⊙ X} ◃∎} $
  ap de⊙ (⊙Susp^-comm m n {X}) ◃∎
    =ₛ⟨ ap-seq-∙ de⊙ (⊙Susp^-comm-seq m n {X}) ⟩
  ap de⊙ (⊙Susp^-+ m n) ◃∙
  ap de⊙ (ap (λ k → ⊙Susp^ k X) (+-comm m n)) ◃∙
  ap de⊙ (! (⊙Susp^-+ n m)) ◃∎
    =ₛ₁⟨ 0 & 1 & de⊙-⊙Susp^-+ m n ⟩
  Susp^-+ m n ◃∙
  ap de⊙ (ap (λ k → ⊙Susp^ k X) (+-comm m n)) ◃∙
  ap de⊙ (! (⊙Susp^-+ n m)) ◃∎
    =ₛ₁⟨ 1 & 1 & ∘-ap de⊙ (λ k → ⊙Susp^ k X) (+-comm m n) ⟩
  Susp^-+ m n ◃∙
  ap (λ k → Susp^ k (de⊙ X)) (+-comm m n) ◃∙
  ap de⊙ (! (⊙Susp^-+ n m)) ◃∎
    =ₛ₁⟨ 2 & 1 & ap-! de⊙ (⊙Susp^-+ n m) ⟩
  Susp^-+ m n ◃∙
  ap (λ k → Susp^ k (de⊙ X)) (+-comm m n) ◃∙
  ! (ap de⊙ (⊙Susp^-+ n m)) ◃∎
    =ₛ₁⟨ 2 & 1 & ap ! (de⊙-⊙Susp^-+ n m) ⟩
  Susp^-+ m n ◃∙
  ap (λ k → Susp^ k (de⊙ X)) (+-comm m n) ◃∙
  ! (Susp^-+ n m) ◃∎
    =ₛ⟨ contract ⟩
  Susp^-comm m n ◃∎ ∎ₛ

⊙Susp^-swap : ∀ {i} (m n : ℕ) {X : Ptd i}
  → ⊙Susp^ m (⊙Susp^ n X) ⊙→ ⊙Susp^ n (⊙Susp^ m X)
⊙Susp^-swap m n {X} = ⊙coe (⊙Susp^-comm m n {X})

abstract
  ⊙Susp^-comm-diag : ∀ {i} (m : ℕ) {X : Ptd i}
    → ⊙Susp^-comm m m {X} ◃∎ =ₛ []
  ⊙Susp^-comm-diag m {X} =
    ↯ (⊙Susp^-comm-seq m m {X}) ◃∎
      =ₛ⟨ expand (⊙Susp^-comm-seq m m {X}) ⟩
    ⊙Susp^-+ m m ◃∙
    ap (λ k → ⊙Susp^ k X) (+-comm m m) ◃∙
    ! (⊙Susp^-+ m m) ◃∎
      =ₛ₁⟨ 1 & 1 & ap (ap (λ k → ⊙Susp^ k X)) (set-path ℕ-level (+-comm m m) idp) ⟩
    ⊙Susp^-+ m m ◃∙
    idp ◃∙
    ! (⊙Susp^-+ m m) ◃∎
      =ₛ⟨ 1 & 1 & expand [] ⟩
    ⊙Susp^-+ m m ◃∙
    ! (⊙Susp^-+ m m) ◃∎
      =ₛ⟨ seq-!-inv-r (⊙Susp^-+ m m ◃∎) ⟩
    [] ∎ₛ

  Susp^-comm-! : ∀ {i} (m n : ℕ) {A : Type i}
    → ! (Susp^-comm m n {A}) == Susp^-comm n m
  Susp^-comm-! m n {A} = =ₛ-out $
    ! (↯ (Susp^-comm-seq m n {A})) ◃∎
      =ₛ⟨ !-∙-seq (Susp^-comm-seq m n {A}) ⟩
    ! (! (Susp^-+ n m)) ◃∙
    ! (ap (λ k → Susp^ k A) (+-comm m n)) ◃∙
    ! (Susp^-+ m n) ◃∎
      =ₛ₁⟨ 0 & 1 & !-! (Susp^-+ n m) ⟩
    Susp^-+ n m ◃∙
    ! (ap (λ k → Susp^ k A) (+-comm m n)) ◃∙
    ! (Susp^-+ m n) ◃∎
      =ₛ₁⟨ 1 & 1 & !-ap (λ k → Susp^ k A) (+-comm m n) ⟩
    Susp^-+ n m ◃∙
    ap (λ k → Susp^ k A) (! (+-comm m n)) ◃∙
    ! (Susp^-+ m n) ◃∎
      =ₛ₁⟨ 1 & 1 & ap (ap (λ k → Susp^ k A)) $
           set-path ℕ-level (! (+-comm m n)) (+-comm n m) ⟩
    Susp^-+ n m ◃∙
    ap (λ k → Susp^ k A) (+-comm n m) ◃∙
    ! (Susp^-+ m n) ◃∎ ∎ₛ

  ⊙Susp^-comm-! : ∀ {i} (m n : ℕ) {X : Ptd i}
    → ! (⊙Susp^-comm m n {X}) == ⊙Susp^-comm n m
  ⊙Susp^-comm-! m n {X} = =ₛ-out $
    ! (↯ (⊙Susp^-comm-seq m n {X})) ◃∎
      =ₛ⟨ !-∙-seq (⊙Susp^-comm-seq m n {X}) ⟩
    ! (! (⊙Susp^-+ n m)) ◃∙
    ! (ap (λ k → ⊙Susp^ k X) (+-comm m n)) ◃∙
    ! (⊙Susp^-+ m n) ◃∎
      =ₛ₁⟨ 0 & 1 & !-! (⊙Susp^-+ n m) ⟩
    ⊙Susp^-+ n m ◃∙
    ! (ap (λ k → ⊙Susp^ k X) (+-comm m n)) ◃∙
    ! (⊙Susp^-+ m n) ◃∎
      =ₛ₁⟨ 1 & 1 & !-ap (λ k → ⊙Susp^ k X) (+-comm m n) ⟩
    ⊙Susp^-+ n m ◃∙
    ap (λ k → ⊙Susp^ k X) (! (+-comm m n)) ◃∙
    ! (⊙Susp^-+ m n) ◃∎
      =ₛ₁⟨ 1 & 1 & ap (ap (λ k → ⊙Susp^ k X)) $
           set-path ℕ-level (! (+-comm m n)) (+-comm n m) ⟩
    ⊙Susp^-+ n m ◃∙
    ap (λ k → ⊙Susp^ k X) (+-comm n m) ◃∙
    ! (⊙Susp^-+ m n) ◃∎ ∎ₛ

  ⊙Susp^-comm-0-r : ∀ {i} (m : ℕ) (X : Ptd i)
    → ⊙Susp^-comm m 0 {X} == idp
  ⊙Susp^-comm-0-r m X = =ₛ-out $
    ⊙Susp^-+ m 0 ◃∙
    ap (λ k → ⊙Susp^ k X) (+-comm m 0) ◃∙
    ! (⊙Susp^-+ 0 m) ◃∎
      =ₛ⟨ 2 & 1 & expand [] ⟩
    ⊙Susp^-+ m 0 ◃∙
    ap (λ k → ⊙Susp^ k X) (+-comm m 0) ◃∎
      =ₛ₁⟨ 1 & 1 & ap (ap (λ k → ⊙Susp^ k X)) $
                  set-path ℕ-level (+-comm m 0) (+-unit-r m) ⟩
    ⊙Susp^-+ m 0 ◃∙
    ap (λ k → ⊙Susp^ k X) (+-unit-r m) ◃∎
      =ₛ⟨ ⊙Susp^-+-0-r m ⟩
    [] ∎ₛ

  ⊙Susp^-comm-0-l : ∀ {i} (n : ℕ) (X : Ptd i)
    → ⊙Susp^-comm 0 n {X} == idp
  ⊙Susp^-comm-0-l n X =
    ⊙Susp^-comm 0 n {X}
      =⟨ ! (⊙Susp^-comm-! n 0 {X}) ⟩
    ! (⊙Susp^-comm n 0 {X})
      =⟨ ap ! (⊙Susp^-comm-0-r n X) ⟩
    idp =∎

  ⊙Susp^-comm-S-r : ∀ {i} (m n : ℕ) {X : Ptd i}
    → ⊙Susp^-comm m (S n) {X} ◃∎ =ₛ ⊙Susp^-comm m 1 {⊙Susp^ n X} ◃∙ ap ⊙Susp (Susp^-comm m n) ◃∎
  ⊙Susp^-comm-S-r m n {X} =
    ⊙Susp^-comm m (S n) {X} ◃∎
      =ₛ⟨ expand (⊙Susp^-comm-seq m (S n) {X}) ⟩
    ⊙Susp^-+ m (S n) ◃∙
    ap (λ k → ⊙Susp^ k X) (+-comm m (S n)) ◃∙
    ! (⊙Susp^-+ (S n) m {X}) ◃∎
      =ₛ⟨ 0 & 0 & contract ⟩
    idp ◃∙
    ⊙Susp^-+ m (S n) ◃∙
    ap (λ k → ⊙Susp^ k X) (+-comm m (S n)) ◃∙
    ! (⊙Susp^-+ (S n) m {X}) ◃∎
      =ₛ⟨ 0 & 2 & ⊙Susp^-+-assoc-coh m 1 n ⟩
    ⊙Susp^-+ m 1 ◃∙
    ⊙Susp^-+ (m + 1) n ◃∙
    ap (λ k → ⊙Susp^ k X) (+-assoc m 1 n) ◃∙
    ap (λ k → ⊙Susp^ k X) (+-comm m (S n)) ◃∙
    ! (ap ⊙Susp (Susp^-+ n m)) ◃∎
      =ₛ⟨ 2 & 2 & ap-seq-=ₛ (λ k → ⊙Susp^ k X) $
          =ₛ-in {s = +-assoc m 1 n ◃∙ +-comm m (S n) ◃∎}
                {t = ap (_+ n) (+-comm m 1) ◃∙ ap S (+-comm m n) ◃∎} $
          set-path ℕ-level _ _ ⟩
    ⊙Susp^-+ m 1 ◃∙
    ⊙Susp^-+ (m + 1) n ◃∙
    ap (λ k → ⊙Susp^ k X) (ap (_+ n) (+-comm m 1)) ◃∙
    ap (λ k → ⊙Susp^ k X) (ap S (+-comm m n)) ◃∙
    ! (ap ⊙Susp (Susp^-+ n m)) ◃∎
      =ₛ₁⟨ 2 & 1 & ∘-ap (λ k → ⊙Susp^ k X) (_+ n) (+-comm m 1) ⟩
    ⊙Susp^-+ m 1 ◃∙
    ⊙Susp^-+ (m + 1) n ◃∙
    ap (λ k → ⊙Susp^ (k + n) X) (+-comm m 1) ◃∙
    ap (λ k → ⊙Susp^ k X) (ap S (+-comm m n)) ◃∙
    ! (ap ⊙Susp (Susp^-+ n m)) ◃∎
      =ₛ⟨ 1 & 2 & !ₛ $ homotopy-naturality
            (λ l → ⊙Susp^ l (⊙Susp^ n X))
            (λ l → ⊙Susp^ (l + n) X)
            (λ l → ⊙Susp^-+ l n)
            (+-comm m 1) ⟩
    ⊙Susp^-+ m 1 ◃∙
    ap (λ l → ⊙Susp^ l (⊙Susp^ n X)) (+-comm m 1) ◃∙
    ap ⊙Susp (Susp^-+ m n) ◃∙
    ap (λ k → ⊙Susp^ k X) (ap S (+-comm m n)) ◃∙
    ! (ap ⊙Susp (Susp^-+ n m)) ◃∎
      =ₛ⟨ 2 & 0 & contract ⟩
    ⊙Susp^-+ m 1 ◃∙
    ap (λ l → ⊙Susp^ l (⊙Susp^ n X)) (+-comm m 1) ◃∙
    idp ◃∙
    ap ⊙Susp (Susp^-+ m n) ◃∙
    ap (λ k → ⊙Susp^ k X) (ap S (+-comm m n)) ◃∙
    ! (ap ⊙Susp (Susp^-+ n m)) ◃∎
      =ₛ⟨ 0 & 3 & contract ⟩
    ⊙Susp^-comm m 1 ◃∙
    ap ⊙Susp (Susp^-+ m n) ◃∙
    ap (λ k → ⊙Susp^ k X) (ap S (+-comm m n)) ◃∙
    ! (ap ⊙Susp (Susp^-+ n m)) ◃∎
      =ₛ₁⟨ 2 & 1 & ∘-ap (λ k → ⊙Susp^ k X) S (+-comm m n) ∙
                   ap-∘ ⊙Susp (λ k → Susp^ k (de⊙ X)) (+-comm m n) ⟩
    ⊙Susp^-comm m 1 ◃∙
    ap ⊙Susp (Susp^-+ m n) ◃∙
    ap ⊙Susp (ap (λ k → Susp^ k (de⊙ X)) (+-comm m n)) ◃∙
    ! (ap ⊙Susp (Susp^-+ n m)) ◃∎
      =ₛ₁⟨ 3 & 1 & !-ap ⊙Susp (Susp^-+ n m) ⟩
    ⊙Susp^-comm m 1 ◃∙
    ap ⊙Susp (Susp^-+ m n) ◃∙
    ap ⊙Susp (ap (λ k → Susp^ k (de⊙ X)) (+-comm m n)) ◃∙
    ap ⊙Susp (! (Susp^-+ n m)) ◃∎
      =ₛ⟨ 1 & 3 & ∙-ap-seq ⊙Susp (Susp^-comm-seq m n) ⟩
    ⊙Susp^-comm m 1 ◃∙
    ap ⊙Susp (Susp^-comm m n) ◃∎ ∎ₛ

  ⊙Susp^-comm-S-l : ∀ {i} (m n : ℕ) {X : Ptd i}
    → ⊙Susp^-comm (S m) n {X} ◃∎ =ₛ ap ⊙Susp (Susp^-comm m n) ◃∙ ⊙Susp^-comm 1 n {⊙Susp^ m X} ◃∎
  ⊙Susp^-comm-S-l m n {X} =
    ⊙Susp^-comm (S m) n {X} ◃∎
      =ₛ₁⟨ ! (⊙Susp^-comm-! n (S m) {X}) ⟩
    ! (⊙Susp^-comm n (S m) {X}) ◃∎
      =ₛ⟨ !-=ₛ (⊙Susp^-comm-S-r n m {X}) ⟩
    ! (ap ⊙Susp (Susp^-comm n m)) ◃∙
    ! (⊙Susp^-comm n 1) ◃∎
      =ₛ₁⟨ 0 & 1 & !-ap ⊙Susp (Susp^-comm n m) ⟩
    ap ⊙Susp (! (Susp^-comm n m)) ◃∙
    ! (⊙Susp^-comm n 1) ◃∎
      =ₛ₁⟨ 0 & 1 & ap (ap ⊙Susp) (Susp^-comm-! n m) ⟩
    ap ⊙Susp (Susp^-comm m n) ◃∙
    ! (⊙Susp^-comm n 1) ◃∎
      =ₛ₁⟨ 1 & 1 & ⊙Susp^-comm-! n 1 ⟩
    ap ⊙Susp (Susp^-comm m n) ◃∙
    ⊙Susp^-comm 1 n ◃∎ ∎ₛ

  ⊙Susp^-comm-S-1 : ∀ {i} (m : ℕ) {X : Ptd i}
    → ⊙Susp^-comm (S m) 1 {X} == ap ⊙Susp (Susp^-comm m 1 {de⊙ X})
  ⊙Susp^-comm-S-1 m {X} = =ₛ-out $
    ⊙Susp^-comm (S m) 1 {X} ◃∎
      =ₛ⟨ ⊙Susp^-comm-S-l m 1 ⟩
    ap ⊙Susp (Susp^-comm m 1) ◃∙
    ⊙Susp^-comm 1 1 ◃∎
      =ₛ⟨ 1 & 1 & ⊙Susp^-comm-diag 1 ⟩
    ap ⊙Susp (Susp^-comm m 1) ◃∎ ∎ₛ

  ⊙Susp^-comm-1-S : ∀ {i} (n : ℕ) {X : Ptd i}
    → ⊙Susp^-comm 1 (S n) {X} == ap ⊙Susp (Susp^-comm 1 n {de⊙ X})
  ⊙Susp^-comm-1-S n {X} =
    ⊙Susp^-comm 1 (S n) {X}
      =⟨ ! (⊙Susp^-comm-! (S n) 1 {X}) ⟩
    ! (⊙Susp^-comm (S n) 1 {X})
      =⟨ ap ! (⊙Susp^-comm-S-1 n {X}) ⟩
    ! (ap ⊙Susp (Susp^-comm n 1 {de⊙ X}))
      =⟨ !-ap ⊙Susp (Susp^-comm n 1 {de⊙ X}) ⟩
    ap ⊙Susp (! (Susp^-comm n 1 {de⊙ X}))
      =⟨ ap (ap ⊙Susp) (Susp^-comm-! n 1 {de⊙ X}) ⟩
    ap ⊙Susp (Susp^-comm 1 n {de⊙ X}) =∎

  ⊙Susp^-comm-S-S : ∀ {i} (m n : ℕ) {X : Ptd i}
    → ⊙Susp^-comm (S m) (S n) {X} == ap ⊙Susp (Susp^-comm m (S n) ∙ Susp^-comm 1 n)
  ⊙Susp^-comm-S-S m n {X} = =ₛ-out $
    ⊙Susp^-comm (S m) (S n) {X} ◃∎
      =ₛ⟨ ⊙Susp^-comm-S-l m (S n) ⟩
    ap ⊙Susp (Susp^-comm m (S n)) ◃∙
    ⊙Susp^-comm 1 (S n) ◃∎
      =ₛ₁⟨ 1 & 1 & ⊙Susp^-comm-1-S n ⟩
    ap ⊙Susp (Susp^-comm m (S n)) ◃∙
    ap ⊙Susp (Susp^-comm 1 n) ◃∎
      =ₛ⟨ ∙-ap-seq ⊙Susp (Susp^-comm m (S n) ◃∙ Susp^-comm 1 n ◃∎) ⟩
    ap ⊙Susp (Susp^-comm m (S n) ∙ Susp^-comm 1 n) ◃∎ ∎ₛ

abstract
  Susp^-+-natural : ∀ {i j} (m n : ℕ) {A : Type i} {B : Type j} (f : A → B)
    → coe (Susp^-+ m n) ∘ Susp^-fmap m (Susp^-fmap n f) ∼
      Susp^-fmap (m + n) f ∘ coe (Susp^-+ m n)
  Susp^-+-natural O n f sa = idp
  Susp^-+-natural (S m) n f sa =
    transport Susp (Susp^-+ m n) (Susp^-fmap (S m) (Susp^-fmap n f) sa)
      =⟨ transport-Susp (Susp^-+ m n) (Susp^-fmap (S m) (Susp^-fmap n f) sa) ⟩
    Susp-fmap (coe (Susp^-+ m n)) (Susp^-fmap (S m) (Susp^-fmap n f) sa)
      =⟨ ! (Susp-fmap-∘ (coe (Susp^-+ m n)) (Susp^-fmap m (Susp^-fmap n f)) sa) ⟩
    Susp-fmap (coe (Susp^-+ m n) ∘ Susp^-fmap m (Susp^-fmap n f)) sa
      =⟨ ap (λ f → Susp-fmap f sa) (λ= (Susp^-+-natural m n f)) ⟩
    Susp-fmap (Susp^-fmap (m + n) f ∘ coe (Susp^-+ m n)) sa
      =⟨ Susp-fmap-∘ (Susp^-fmap (m + n) f) (coe (Susp^-+ m n)) sa ⟩
    Susp^-fmap (S m + n) f (Susp-fmap (coe (Susp^-+ m n)) sa)
      =⟨ ap (Susp^-fmap (S m + n) f) (! (transport-Susp (Susp^-+ m n) sa)) ⟩
    Susp^-fmap (S m + n) f (transport Susp (Susp^-+ m n) sa) =∎

  ⊙Susp^-+-natural : ∀ {i j} (m n : ℕ) {X : Ptd i} {Y : Ptd j} (f : X ⊙→ Y)
    → ⊙coe (⊙Susp^-+ m n) ⊙∘ ⊙Susp^-fmap m (⊙Susp^-fmap n f) ==
      ⊙Susp^-fmap (m + n) f ⊙∘ ⊙coe (⊙Susp^-+ m n)
  ⊙Susp^-+-natural 0 n f = ⊙λ= (⊙∘-unit-l _)
  ⊙Susp^-+-natural (S m) n f =
    ⊙coe (ap ⊙Susp (Susp^-+ m n)) ⊙∘
    ⊙Susp^-fmap (S m) (⊙Susp^-fmap n f)
      =⟨ ap (_⊙∘ ⊙Susp^-fmap (S m) (⊙Susp^-fmap n f)) $
         ! (⊙transport-⊙coe ⊙Susp (Susp^-+ m n)) ∙
         ⊙transport-⊙Susp (Susp^-+ m n) ⟩
    ⊙Susp-fmap (coe (Susp^-+ m n)) ⊙∘
    ⊙Susp^-fmap (S m) (⊙Susp^-fmap n f)
      =⟨ ! $ ⊙Susp-fmap-∘ (coe (Susp^-+ m n)) (Susp^-fmap m (Susp^-fmap n (fst f))) ⟩
    ⊙Susp-fmap (coe (Susp^-+ m n) ∘ Susp^-fmap m (Susp^-fmap n (fst f)))
      =⟨ ap ⊙Susp-fmap (λ= (Susp^-+-natural m n (fst f))) ⟩
    ⊙Susp-fmap (Susp^-fmap (m + n) (fst f) ∘ coe (Susp^-+ m n))
      =⟨ ⊙Susp-fmap-∘ (Susp^-fmap (m + n) (fst f)) (coe (Susp^-+ m n)) ⟩
    ⊙Susp-fmap (Susp^-fmap (m + n) (fst f)) ⊙∘
    ⊙Susp-fmap (coe (Susp^-+ m n))
      =⟨ ap (⊙Susp-fmap (Susp^-fmap (m + n) (fst f)) ⊙∘_) $
         ! (⊙transport-⊙Susp (Susp^-+ m n)) ∙
         ⊙transport-⊙coe ⊙Susp (Susp^-+ m n) ⟩
    ⊙Susp-fmap (Susp^-fmap (m + n) (fst f)) ⊙∘
    ⊙coe (ap ⊙Susp (Susp^-+ m n)) =∎

  Susp^-+-natural' : ∀ {i j} (m n : ℕ) {A : Type i} {B : Type j} (f : A → B)
    → Susp^-fmap m (Susp^-fmap n f) ∘ coe (! (Susp^-+ m n)) ∼
      coe (! (Susp^-+ m n)) ∘ Susp^-fmap (m + n) f
  Susp^-+-natural' m n f sa =
    Susp^-fmap m (Susp^-fmap n f) (coe (! (Susp^-+ m n)) sa)
      =⟨ ap (λ p → coe p (Susp^-fmap m (Susp^-fmap n f) (coe (! (Susp^-+ m n)) sa))) $
         ! $ !-inv-r (Susp^-+ m n) ⟩
    coe (Susp^-+ m n ∙ ! (Susp^-+ m n))
        (Susp^-fmap m (Susp^-fmap n f) (coe (! (Susp^-+ m n)) sa))
      =⟨ coe-∙ (Susp^-+ m n) (! (Susp^-+ m n))
               (Susp^-fmap m (Susp^-fmap n f) (coe (! (Susp^-+ m n)) sa)) ⟩
    coe (! (Susp^-+ m n)) (coe (Susp^-+ m n) (Susp^-fmap m (Susp^-fmap n f) (coe (! (Susp^-+ m n)) sa)))
      =⟨ ap (coe (! (Susp^-+ m n))) $
         Susp^-+-natural m n f (coe (! (Susp^-+ m n)) sa) ⟩
    coe (! (Susp^-+ m n)) (Susp^-fmap (m + n) f (coe (Susp^-+ m n) (coe (! (Susp^-+ m n)) sa)))
      =⟨ ap (coe (! (Susp^-+ m n)) ∘ Susp^-fmap (m + n) f) $
         ! $ coe-∙ (! (Susp^-+ m n)) (Susp^-+ m n) sa ⟩
    coe (! (Susp^-+ m n)) (Susp^-fmap (m + n) f (coe (! (Susp^-+ m n) ∙ Susp^-+ m n) sa))
      =⟨ ap (λ p → coe (! (Susp^-+ m n)) (Susp^-fmap (m + n) f (coe p sa))) $
         !-inv-l (Susp^-+ m n) ⟩
    coe (! (Susp^-+ m n)) (Susp^-fmap (m + n) f sa) =∎

  ⊙Susp^-+-natural' : ∀ {i j} (m n : ℕ) {X : Ptd i} {Y : Ptd j} (f : X ⊙→ Y)
    → ⊙Susp^-fmap m (⊙Susp^-fmap n f) ⊙∘ ⊙coe (! (⊙Susp^-+ m n)) ==
      ⊙coe (! (⊙Susp^-+ m n)) ⊙∘ ⊙Susp^-fmap (m + n) f
  ⊙Susp^-+-natural' m n f =
    ⊙Susp^-fmap m (⊙Susp^-fmap n f) ⊙∘
    ⊙coe (! (⊙Susp^-+ m n))
      =⟨ ap (_⊙∘ ⊙coe (! (⊙Susp^-+ m n))) $
         ! $ ⊙λ= $ ⊙∘-unit-l (⊙Susp^-fmap m (⊙Susp^-fmap n f)) ⟩
    (⊙idf _ ⊙∘
     ⊙Susp^-fmap m (⊙Susp^-fmap n f)) ⊙∘
    ⊙coe (! (⊙Susp^-+ m n))
      =⟨ ap (_⊙∘ ⊙coe (! (⊙Susp^-+ m n))) $
         ap (_⊙∘ ⊙Susp^-fmap m (⊙Susp^-fmap n f)) $
         ap ⊙coe (! (!-inv-r (⊙Susp^-+ m n))) ∙
         =⊙∘-out (⊙coe-∙ (⊙Susp^-+ m n) (! (⊙Susp^-+ m n))) ⟩
    ((⊙coe (! (⊙Susp^-+ m n)) ⊙∘
      ⊙coe (⊙Susp^-+ m n)) ⊙∘
     ⊙Susp^-fmap m (⊙Susp^-fmap n f)) ⊙∘
    ⊙coe (! (⊙Susp^-+ m n))
      =⟨ ap (_⊙∘ ⊙coe (! (⊙Susp^-+ m n))) $ ⊙λ= $
         ⊙∘-assoc (⊙coe (! (⊙Susp^-+ m n)))
                  (⊙coe (⊙Susp^-+ m n))
                  (⊙Susp^-fmap m (⊙Susp^-fmap n f)) ⟩
    (⊙coe (! (⊙Susp^-+ m n)) ⊙∘
     ⊙coe (⊙Susp^-+ m n) ⊙∘
     ⊙Susp^-fmap m (⊙Susp^-fmap n f)) ⊙∘
    ⊙coe (! (⊙Susp^-+ m n))
      =⟨ ap (_⊙∘ ⊙coe (! (⊙Susp^-+ m n))) $
         ap (⊙coe (! (⊙Susp^-+ m n)) ⊙∘_) $
         ⊙Susp^-+-natural m n f ⟩
    (⊙coe (! (⊙Susp^-+ m n)) ⊙∘
     ⊙Susp^-fmap (m + n) f ⊙∘
     ⊙coe (⊙Susp^-+ m n)) ⊙∘
    ⊙coe (! (⊙Susp^-+ m n))
      =⟨ ⊙λ= $ ⊙∘-assoc
           (⊙coe (! (⊙Susp^-+ m n)))
           (⊙Susp^-fmap (m + n) f ⊙∘ ⊙coe (⊙Susp^-+ m n))
           (⊙coe (! (⊙Susp^-+ m n))) ⟩
    ⊙coe (! (⊙Susp^-+ m n)) ⊙∘
    (⊙Susp^-fmap (m + n) f ⊙∘
     ⊙coe (⊙Susp^-+ m n)) ⊙∘
    ⊙coe (! (⊙Susp^-+ m n))
      =⟨ ap (⊙coe (! (⊙Susp^-+ m n)) ⊙∘_) $ ⊙λ= $
         ⊙∘-assoc (⊙Susp^-fmap (m + n) f)
                  (⊙coe (⊙Susp^-+ m n))
                  (⊙coe (! (⊙Susp^-+ m n))) ⟩
    ⊙coe (! (⊙Susp^-+ m n)) ⊙∘
    ⊙Susp^-fmap (m + n) f ⊙∘
    ⊙coe (⊙Susp^-+ m n) ⊙∘
    ⊙coe (! (⊙Susp^-+ m n))
      =⟨ ap (⊙coe (! (⊙Susp^-+ m n)) ⊙∘_) $
         ap (⊙Susp^-fmap (m + n) f ⊙∘_) $
         ! (=⊙∘-out (⊙coe-∙ (! (⊙Susp^-+ m n)) (⊙Susp^-+ m n))) ∙
         ap ⊙coe (!-inv-l (⊙Susp^-+ m n)) ⟩
    ⊙coe (! (⊙Susp^-+ m n)) ⊙∘
    ⊙Susp^-fmap (m + n) f =∎

  Susp^-comm-natural : ∀ {i j} {A : Type i} {B : Type j} (m n : ℕ)
    (f : A → B)
    → coe (Susp^-comm m n) ∘ Susp^-fmap m (Susp^-fmap n f) ∼
      Susp^-fmap n (Susp^-fmap m f) ∘ coe (Susp^-comm m n)
  Susp^-comm-natural {A = A} {B = B} m n f s =
    coe (Susp^-comm m n) (Susp^-fmap m (Susp^-fmap n f) s)
      =⟨ coe-∙ (Susp^-+ m n)
               (ap (λ k → Susp^ k B) (+-comm m n) ∙ ! (Susp^-+ n m))
               (Susp^-fmap m (Susp^-fmap n f) s) ⟩
    coe (ap (λ k → Susp^ k B) (+-comm m n) ∙ ! (Susp^-+ n m))
        (coe (Susp^-+ m n) (Susp^-fmap m (Susp^-fmap n f) s))
      =⟨ ap (coe (ap (λ k → Susp^ k B) (+-comm m n) ∙ ! (Susp^-+ n m)))
            (Susp^-+-natural m n f s) ⟩
    coe (ap (λ k → Susp^ k B) (+-comm m n) ∙ ! (Susp^-+ n m))
        (Susp^-fmap (m + n) f (coe (Susp^-+ m n) s))
      =⟨ coe-∙ (ap (λ k → Susp^ k B) (+-comm m n))
               (! (Susp^-+ n m))
               (Susp^-fmap (m + n) f (coe (Susp^-+ m n) s)) ⟩
    coe (! (Susp^-+ n m))
        (transport (λ k → Susp^ k B) (+-comm m n)
          (Susp^-fmap (m + n) f (coe (Susp^-+ m n) s)))
      =⟨ ! $ ap (coe (! (Susp^-+ n m))) $
         app= (transp-naturality (λ {k} → Susp^-fmap k f) (+-comm m n))
              (coe (Susp^-+ m n) s) ⟩
    coe (! (Susp^-+ n m)) (Susp^-fmap (n + m) f
      (transport (λ k → Susp^ k A) (+-comm m n) (coe (Susp^-+ m n) s)))
      =⟨ ! $ Susp^-+-natural' n m f
           (transport (λ k → Susp^ k A) (+-comm m n) (coe (Susp^-+ m n) s)) ⟩
    Susp^-fmap n (Susp^-fmap m f)
      (coe (! (Susp^-+ n m)) (transport (λ k → Susp^ k A) (+-comm m n) (coe (Susp^-+ m n) s)))
      =⟨ ap (Susp^-fmap n (Susp^-fmap m f)) $ ! $
         coe-∙ (ap (λ k → Susp^ k A) (+-comm m n))
               (! (Susp^-+ n m))
               (coe (Susp^-+ m n) s) ⟩
    Susp^-fmap n (Susp^-fmap m f)
      (coe (ap (λ k → Susp^ k A) (+-comm m n) ∙ ! (Susp^-+ n m)) (coe (Susp^-+ m n) s))
      =⟨ ! $ ap (Susp^-fmap n (Susp^-fmap m f)) $
         coe-∙ (Susp^-+ m n) (ap (λ k → Susp^ k A) (+-comm m n) ∙ ! (Susp^-+ n m)) s ⟩
    Susp^-fmap n (Susp^-fmap m f) (coe (Susp^-comm m n) s) =∎

  ⊙Susp^-swap-natural : ∀ {i} {X Y : Ptd i} (m n : ℕ) (f : X ⊙→ Y)
    → ⊙Susp^-swap m n ◃⊙∘ ⊙Susp^-fmap m (⊙Susp^-fmap n f) ◃⊙idf
      =⊙∘
      ⊙Susp^-fmap n (⊙Susp^-fmap m f) ◃⊙∘ ⊙Susp^-swap m n ◃⊙idf
  ⊙Susp^-swap-natural {X = X} {Y = Y} m n f =
    ⊙Susp^-swap m n ◃⊙∘
    ⊙Susp^-fmap m (⊙Susp^-fmap n f) ◃⊙idf
      =⊙∘⟨ 0 & 1 & ⊙coe-∙ (⊙Susp^-+ m n)
                          (ap (λ k → ⊙Susp^ k Y) (+-comm m n) ∙ ! (⊙Susp^-+ n m)) ⟩
    ⊙coe (ap (λ k → ⊙Susp^ k Y) (+-comm m n) ∙ ! (⊙Susp^-+ n m)) ◃⊙∘
    ⊙coe (⊙Susp^-+ m n) ◃⊙∘
    ⊙Susp^-fmap m (⊙Susp^-fmap n f) ◃⊙idf
      =⊙∘⟨ 1 & 2 & =⊙∘-in {gs = ⊙Susp^-fmap (m + n) f ◃⊙∘ ⊙coe (⊙Susp^-+ m n) ◃⊙idf} $
                   ⊙Susp^-+-natural m n f ⟩
    ⊙coe (ap (λ k → ⊙Susp^ k Y) (+-comm m n) ∙ ! (⊙Susp^-+ n m)) ◃⊙∘
    ⊙Susp^-fmap (m + n) f ◃⊙∘
    ⊙coe (⊙Susp^-+ m n) ◃⊙idf
      =⊙∘⟨ 0 & 1 & ⊙coe-∙ (ap (λ k → ⊙Susp^ k Y) (+-comm m n)) (! (⊙Susp^-+ n m)) ⟩
    ⊙coe (! (⊙Susp^-+ n m)) ◃⊙∘
    ⊙coe (ap (λ k → ⊙Susp^ k Y) (+-comm m n)) ◃⊙∘
    ⊙Susp^-fmap (m + n) f ◃⊙∘
    ⊙coe (⊙Susp^-+ m n) ◃⊙idf
      =⊙∘₁⟨ 1 & 1 & ! $ ⊙transport-⊙coe (λ k → ⊙Susp^ k Y) (+-comm m n) ⟩
    ⊙coe (! (⊙Susp^-+ n m)) ◃⊙∘
    ⊙transport (λ k → ⊙Susp^ k Y) (+-comm m n) ◃⊙∘
    ⊙Susp^-fmap (m + n) f ◃⊙∘
    ⊙coe (⊙Susp^-+ m n) ◃⊙idf
      =⊙∘⟨ 1 & 2 & !⊙∘ $ ⊙transport-natural-=⊙∘ (+-comm m n) (λ k → ⊙Susp^-fmap k f) ⟩
    ⊙coe (! (⊙Susp^-+ n m)) ◃⊙∘
    ⊙Susp^-fmap (n + m) f ◃⊙∘
    ⊙transport (λ k → ⊙Susp^ k X) (+-comm m n) ◃⊙∘
    ⊙coe (⊙Susp^-+ m n) ◃⊙idf
      =⊙∘₁⟨ 2 & 1 & ⊙transport-⊙coe (λ k → ⊙Susp^ k X) (+-comm m n) ⟩
    ⊙coe (! (⊙Susp^-+ n m)) ◃⊙∘
    ⊙Susp^-fmap (n + m) f ◃⊙∘
    ⊙coe (ap (λ k → ⊙Susp^ k X) (+-comm m n)) ◃⊙∘
    ⊙coe (⊙Susp^-+ m n) ◃⊙idf
      =⊙∘⟨ 0 & 2 & =⊙∘-in {gs = ⊙Susp^-fmap n (⊙Susp^-fmap m f) ◃⊙∘
                                ⊙coe (! (⊙Susp^-+ n m)) ◃⊙idf} $
           ! $ ⊙Susp^-+-natural' n m f ⟩
    ⊙Susp^-fmap n (⊙Susp^-fmap m f) ◃⊙∘
    ⊙coe (! (⊙Susp^-+ n m)) ◃⊙∘
    ⊙coe (ap (λ k → ⊙Susp^ k X) (+-comm m n)) ◃⊙∘
    ⊙coe (⊙Susp^-+ m n) ◃⊙idf
      =⊙∘⟨ 1 & 2 & !⊙∘ $ ⊙coe-∙ (ap (λ k → ⊙Susp^ k X) (+-comm m n)) (! (⊙Susp^-+ n m)) ⟩
    ⊙Susp^-fmap n (⊙Susp^-fmap m f) ◃⊙∘
    ⊙coe (ap (λ k → ⊙Susp^ k X) (+-comm m n) ∙ ! (⊙Susp^-+ n m)) ◃⊙∘
    ⊙coe (⊙Susp^-+ m n) ◃⊙idf
      =⊙∘⟨ 1 & 2 & !⊙∘ $
           ⊙coe-∙ (⊙Susp^-+ m n)
                  (ap (λ k → ⊙Susp^ k X) (+-comm m n) ∙ ! (⊙Susp^-+ n m)) ⟩
    ⊙Susp^-fmap n (⊙Susp^-fmap m f) ◃⊙∘
    ⊙Susp^-swap m n ◃⊙idf ∎⊙∘

Susp^-Susp-split-iso : ∀ {i} (n : ℕ) (A : Type i)
  → Susp (Susp^ n A) ≃ Susp^ n (Susp A)
Susp^-Susp-split-iso O A = ide _
Susp^-Susp-split-iso (S n) A = Susp-emap (Susp^-Susp-split-iso n A)

⊙Susp^-Susp-split-iso : ∀ {i} (n : ℕ) (A : Type i)
  → ⊙Susp (Susp^ n A) ⊙≃ ⊙Susp^ n (⊙Susp A)
⊙Susp^-Susp-split-iso O A = ⊙ide _
⊙Susp^-Susp-split-iso (S n) A = ⊙Susp-emap (Susp^-Susp-split-iso n A)


-- {-# OPTIONS --show-implicit --show-irrelevant #-}
module Data.QuadTree.LensProofs.Valid-LensA where

open import Haskell.Prelude renaming (zero to Z; suc to S)
open import Data.Lens.Lens
open import Data.Logic
open import Data.QuadTree.InternalAgda
open import Agda.Primitive
open import Data.Lens.Proofs.LensLaws
open import Data.Lens.Proofs.LensPostulates
open import Data.Lens.Proofs.LensComposition
open import Data.QuadTree.Implementation.QuadrantLenses
open import Data.QuadTree.Implementation.Definition
open import Data.QuadTree.Implementation.ValidTypes
open import Data.QuadTree.Implementation.SafeFunctions
open import Data.QuadTree.Implementation.PublicFunctions
open import Data.QuadTree.Implementation.DataLenses

--- Lens laws for lensA

ValidLens-LensA-ViewSet :
    {t : Set} {{eqT : Eq t}} {dep : Nat}
    -> ViewSet (lensA {t} {dep})
ValidLens-LensA-ViewSet (CVQuadrant (Leaf x) {p1}) (CVQuadrant (Leaf v) {p2}) =
    begin
        view lensA (set lensA (CVQuadrant (Leaf x) {p1}) (CVQuadrant (Leaf v) {p2}))
    =⟨⟩
        getConst
            (lensA CConst
            (ifc (x == v && v == v && v == v)
                then CVQuadrant (Leaf x)
                else CVQuadrant (Node (Leaf x) (Leaf v) (Leaf v) (Leaf v))))
    =⟨ sym (propFnIfc (x == v && v == v && v == v) (λ x -> getConst (lensA CConst x))) ⟩
        (ifc (x == v && v == v && v == v)
        then (CVQuadrant (Leaf x))
        else (CVQuadrant (Leaf x)))
    =⟨ propIfcBranchesSame {c = (x == v && v == v && v == v)} (CVQuadrant (Leaf x)) ⟩
         (CVQuadrant (Leaf x))
    end
ValidLens-LensA-ViewSet (CVQuadrant (Node a b c d)) (CVQuadrant (Leaf v)) = refl
ValidLens-LensA-ViewSet (CVQuadrant (Leaf x) {p1}) (CVQuadrant (Node a b@(Leaf vb) c@(Leaf vc) d@(Leaf vd)) {p2}) =
    begin
        view lensA (set lensA (CVQuadrant (Leaf x) {p1}) (CVQuadrant (Node a b c d) {p2}))
    =⟨⟩
        getConst (lensA CConst (
            ifc (x == vb && vb == vc && vc == vd)
            then (CVQuadrant (Leaf x))
            else (CVQuadrant (Node (Leaf x) (Leaf vb) (Leaf vc) (Leaf vd)))
        ))
    =⟨ sym (propFnIfc (x == vb && vb == vc && vc == vd) (λ x -> getConst (lensA CConst x))) ⟩
        (ifc (x == vb && vb == vc && vc == vd)
        then (CVQuadrant (Leaf x))
        else (CVQuadrant (Leaf x)))
    =⟨ propIfcBranchesSame {c = (x == vb && vb == vc && vc == vd)} (CVQuadrant (Leaf x)) ⟩
        (CVQuadrant (Leaf x))
    end
ValidLens-LensA-ViewSet (CVQuadrant (Leaf x)) (CVQuadrant (Node a (Leaf x₁) (Leaf x₂) (Node d d₁ d₂ d₃))) = refl
ValidLens-LensA-ViewSet (CVQuadrant (Leaf x)) (CVQuadrant (Node a (Leaf x₁) (Node c c₁ c₂ c₃) d)) = refl
ValidLens-LensA-ViewSet (CVQuadrant (Leaf x)) (CVQuadrant (Node a (Node b b₁ b₂ b₃) c d)) = refl
ValidLens-LensA-ViewSet (CVQuadrant (Node toa tob toc tod)) (CVQuadrant (Node a b c d)) = refl

ValidLens-LensA-SetView :
    {t : Set} {{eqT : Eq t}} {dep : Nat}
    -> SetView (lensA {t} {dep})
ValidLens-LensA-SetView {t} {dep} qd@(CVQuadrant (Leaf x) {p}) =
    begin
        set lensA (view lensA qd) qd
    =⟨⟩
        ((ifc (x == x && x == x && x == x)
            then (CVQuadrant (Leaf x))
            else λ {{z}} -> (CVQuadrant (Node (Leaf x) (Leaf x) (Leaf x) (Leaf x)))))
    =⟨ ifcTrue (x == x && x == x && x == x) (andCombine (eqReflexivity x) (andCombine (eqReflexivity x) (eqReflexivity x))) ⟩
        CVQuadrant (Leaf x)
    end
ValidLens-LensA-SetView {t} {dep} cv@(CVQuadrant qd@(Node (Leaf a) (Leaf b) (Leaf c) (Leaf d)) {p}) =
    begin
        set lensA (view lensA cv) cv
    =⟨⟩
        (ifc (a == b && b == c && c == d) then (CVQuadrant (Leaf a)) else (CVQuadrant (Node (Leaf a) (Leaf b) (Leaf c) (Leaf d))))
    =⟨ ifcFalse (a == b && b == c && c == d) (notTrueToFalse (andSnd {depth qd <= S dep} {isCompressed qd} p)) ⟩
        (CVQuadrant (Node (Leaf a) (Leaf b) (Leaf c) (Leaf d)))
    end
ValidLens-LensA-SetView (CVQuadrant (Node (Leaf x) (Leaf x₁) (Leaf x₂) (Node qd₃ qd₄ qd₅ qd₆))) = refl
ValidLens-LensA-SetView (CVQuadrant (Node (Leaf x) (Leaf x₁) (Node qd₂ qd₄ qd₅ qd₆) qd₃)) = refl
ValidLens-LensA-SetView (CVQuadrant (Node (Leaf x) (Node qd₁ qd₄ qd₅ qd₆) qd₂ qd₃)) = refl
ValidLens-LensA-SetView (CVQuadrant (Node (Node qd qd₄ qd₅ qd₆) qd₁ qd₂ qd₃)) = refl

ValidLens-LensA-SetSet-Lemma : {t : Set} {{eqT : Eq t}} {dep : Nat}
    -> (x a b c d : VQuadrant t {dep})
    -> set lensA x (combine a b c d) ≡ (combine x b c d)
ValidLens-LensA-SetSet-Lemma {t} {dep} (CVQuadrant x@(Leaf xv)) (CVQuadrant a@(Leaf va)) (CVQuadrant b@(Leaf vb)) (CVQuadrant c@(Leaf vc)) (CVQuadrant d@(Leaf vd)) =
    begin
        (runIdentity (lensA (λ _ → CIdentity (CVQuadrant (Leaf xv)))
            (ifc va == vb && vb == vc && vc == vd
            then CVQuadrant (Leaf va)
            else CVQuadrant (Node (Leaf va) (Leaf vb) (Leaf vc) (Leaf vd)))))
    =⟨ sym $ propFnIfc (va == vb && vb == vc && vc == vd) (λ g -> (runIdentity (lensA (λ _ → CIdentity (CVQuadrant (Leaf xv) {andCombine (zeroLteAny dep) IsTrue.itsTrue})) g ) ) ) ⟩
        (ifc va == vb && vb == vc && vc == vd
            then ifc xv == va && va == va && va == va
                then CVQuadrant (Leaf xv)
                else CVQuadrant (Node (Leaf xv) (Leaf va) (Leaf va) (Leaf va))
            else ifc xv == vb && vb == vc && vc == vd
                then CVQuadrant (Leaf xv)
                else CVQuadrant (Node (Leaf xv) (Leaf vb) (Leaf vc) (Leaf vd)))
    =⟨ ifcTrueMap {c = va == vb && vb == vc && vc == vd}
            (λ p -> cong
                (λ q -> ifc xv == q && q == q && q == q
                    then CVQuadrant (Leaf xv) {andCombine (zeroLteAny (S dep)) IsTrue.itsTrue}
                    else (λ {{p}} -> CVQuadrant (Node (Leaf xv) (Leaf q) (Leaf q) (Leaf q)) {andCombine (zeroLteAny (dep)) (falseToNotTrue p)}) )
                (eqToEquiv va vb (andFst {va == vb} p))  ) ⟩

        (ifc va == vb && vb == vc && vc == vd
            then ifc xv == vb && vb == vb && vb == vb
                then CVQuadrant (Leaf xv) {andCombine (zeroLteAny (S dep)) IsTrue.itsTrue}
                else (λ {{p}} -> CVQuadrant (Node (Leaf xv) (Leaf vb) (Leaf vb) (Leaf vb)) {andCombine (zeroLteAny (dep)) (falseToNotTrue p)})
            else ifc xv == vb && vb == vc && vc == vd
                then CVQuadrant (Leaf xv)
                else CVQuadrant (Node (Leaf xv) (Leaf vb) (Leaf vc) (Leaf vd)))
    =⟨ ifcTrueMap {c = va == vb && vb == vc && vc == vd}
            (λ p -> cong
                (λ q -> ifc xv == vb && vb == q && q == q
                    then CVQuadrant (Leaf xv) {andCombine (zeroLteAny (S dep)) IsTrue.itsTrue}
                    else (λ {{p}} -> CVQuadrant (Node (Leaf xv) (Leaf vb) (Leaf q) (Leaf q)) {andCombine (zeroLteAny (dep)) (falseToNotTrue p)}) )
                (eqToEquiv vb vc (andFst $ andSnd {va == vb} p))  ) ⟩

        (ifc va == vb && vb == vc && vc == vd
            then ifc xv == vb && vb == vc && vc == vc
                then CVQuadrant (Leaf xv) {andCombine (zeroLteAny (S dep)) IsTrue.itsTrue}
                else (λ {{p}} -> CVQuadrant (Node (Leaf xv) (Leaf vb) (Leaf vc) (Leaf vc)) {andCombine (zeroLteAny (dep)) (falseToNotTrue p)})
            else ifc xv == vb && vb == vc && vc == vd
                then CVQuadrant (Leaf xv)
                else CVQuadrant (Node (Leaf xv) (Leaf vb) (Leaf vc) (Leaf vd)))
    =⟨ ifcTrueMap {c = va == vb && vb == vc && vc == vd}
            (λ p -> cong
                (λ q -> ifc xv == vb && vb == vc && vc == q
                    then CVQuadrant (Leaf xv) {andCombine (zeroLteAny (S dep)) IsTrue.itsTrue}
                    else (λ {{p}} -> CVQuadrant (Node (Leaf xv) (Leaf vb) (Leaf vc) (Leaf q)) {andCombine (zeroLteAny (dep)) (falseToNotTrue p)}) )
                (eqToEquiv vc vd (andSnd $ andSnd {va == vb} p))  ) ⟩

        (ifc va == vb && vb == vc && vc == vd
            then ifc xv == vb && vb == vc && vc == vd
                then CVQuadrant (Leaf xv) {andCombine (zeroLteAny (S dep)) IsTrue.itsTrue}
                else (λ {{p}} -> CVQuadrant (Node (Leaf xv) (Leaf vb) (Leaf vc) (Leaf vd)) {andCombine (zeroLteAny (dep)) (falseToNotTrue p)})
            else ifc xv == vb && vb == vc && vc == vd
                then CVQuadrant (Leaf xv)
                else CVQuadrant (Node (Leaf xv) (Leaf vb) (Leaf vc) (Leaf vd)))
    =⟨ propIfcBranchesSame {c = va == vb && vb == vc && vc == vd}
        (ifc xv == vb && vb == vc && vc == vd then CVQuadrant (Leaf xv) else CVQuadrant (Node (Leaf xv) (Leaf vb) (Leaf vc) (Leaf vd))) ⟩

        (ifc xv == vb && vb == vc && vc == vd
            then CVQuadrant (Leaf xv)
            else CVQuadrant (Node (Leaf xv) (Leaf vb) (Leaf vc) (Leaf vd)))
    end
ValidLens-LensA-SetSet-Lemma {t} {dep} cvx@(CVQuadrant x@(Node x1 x2 x3 x4) {p}) cva@(CVQuadrant a@(Leaf va)) cvb@(CVQuadrant b@(Leaf vb)) cvc@(CVQuadrant c@(Leaf vc)) cvd@(CVQuadrant d@(Leaf vd)) =
    begin
        runIdentity (lensA (λ _ → CIdentity cvx)
            (ifc va == vb && vb == vc && vc == vd
            then CVQuadrant (Leaf va)
            else CVQuadrant (Node (Leaf va) (Leaf vb) (Leaf vc) (Leaf vd))))
    =⟨ sym $ propFnIfc (va == vb && vb == vc && vc == vd) (λ g -> (runIdentity (lensA (λ _ → CIdentity cvx) g ) ) ) ⟩
        (ifc va == vb && vb == vc && vc == vd
        then CVQuadrant (Node x (Leaf va) (Leaf va) (Leaf va))
        else CVQuadrant (Node x (Leaf vb) (Leaf vc) (Leaf vd)))
    =⟨ ifcTrueMap {c = va == vb && vb == vc && vc == vd} (λ p -> cong (λ q -> combine cvx (cvq q) (cvq q) (cvq q)) (eqToEquiv va vb (andFst {va == vb} p)))   ⟩
        (ifc va == vb && vb == vc && vc == vd
        then CVQuadrant (Node x (Leaf vb) (Leaf vb) (Leaf vb))
        else CVQuadrant (Node x (Leaf vb) (Leaf vc) (Leaf vd)))
    =⟨ ifcTrueMap {c = va == vb && vb == vc && vc == vd} (λ p -> cong (λ q -> combine cvx cvb (cvq q) (cvq q)) (eqToEquiv vb vc (andFst $ andSnd {va == vb} p)))   ⟩
        (ifc va == vb && vb == vc && vc == vd
        then CVQuadrant (Node x (Leaf vb) (Leaf vc) (Leaf vc))
        else CVQuadrant (Node x (Leaf vb) (Leaf vc) (Leaf vd)))
    =⟨ ifcTrueMap {c = va == vb && vb == vc && vc == vd} (λ p -> cong (λ q -> combine cvx cvb cvc (cvq q)) (eqToEquiv vc vd (andSnd $ andSnd {va == vb} p)))   ⟩
        (ifc va == vb && vb == vc && vc == vd
        then CVQuadrant (Node x (Leaf vb) (Leaf vc) (Leaf vd))
        else CVQuadrant (Node x (Leaf vb) (Leaf vc) (Leaf vd)))
    =⟨ propIfcBranchesSame {c = va == vb && vb == vc && vc == vd} (CVQuadrant (Node x (Leaf vb) (Leaf vc) (Leaf vd))) ⟩
        CVQuadrant (Node x (Leaf vb) (Leaf vc) (Leaf vd))
    end where
        -- Construct a valid leaf from a value
        cvq : t -> VQuadrant t {dep}
        cvq q = CVQuadrant (Leaf q) {andCombine (zeroLteAny dep) IsTrue.itsTrue}
ValidLens-LensA-SetSet-Lemma (CVQuadrant _) (CVQuadrant (Leaf _)) (CVQuadrant (Leaf _)) (CVQuadrant (Leaf _)) (CVQuadrant (Node _ _ _ _)) = refl
ValidLens-LensA-SetSet-Lemma (CVQuadrant _) (CVQuadrant (Leaf _)) (CVQuadrant (Leaf _)) (CVQuadrant (Node _ _ _ _)) (CVQuadrant _) = refl
ValidLens-LensA-SetSet-Lemma (CVQuadrant _) (CVQuadrant (Leaf _)) (CVQuadrant (Node _ _ _ _)) (CVQuadrant _) (CVQuadrant _) = refl
ValidLens-LensA-SetSet-Lemma (CVQuadrant _) (CVQuadrant (Node _ _ _ _)) (CVQuadrant _) (CVQuadrant _) (CVQuadrant _) = refl

ValidLens-LensA-SetSet :
    {t : Set} {{eqT : Eq t}} {dep : Nat}
    -> SetSet (lensA {t} {dep})
ValidLens-LensA-SetSet a@(CVQuadrant qda) b@(CVQuadrant qdb) x@(CVQuadrant qdx@(Leaf xv)) =
    begin
        set lensA (CVQuadrant qdb) (combine (CVQuadrant qda) (CVQuadrant (Leaf xv)) (CVQuadrant (Leaf xv)) (CVQuadrant (Leaf xv)))
    =⟨ ValidLens-LensA-SetSet-Lemma (CVQuadrant qdb) (CVQuadrant qda) (CVQuadrant (Leaf xv)) (CVQuadrant (Leaf xv)) (CVQuadrant (Leaf xv)) ⟩
        combine (CVQuadrant qdb) (CVQuadrant (Leaf xv)) (CVQuadrant (Leaf xv)) (CVQuadrant (Leaf xv))
    end
ValidLens-LensA-SetSet (CVQuadrant qda) (CVQuadrant qdb) (CVQuadrant qdx@(Node xa xb xc xd)) =
    begin
        set lensA (CVQuadrant qdb) (combine (CVQuadrant qda) (CVQuadrant xb) (CVQuadrant xc) (CVQuadrant xd))
    =⟨ ValidLens-LensA-SetSet-Lemma (CVQuadrant qdb) (CVQuadrant qda) (CVQuadrant xb) (CVQuadrant xc) (CVQuadrant xd) ⟩
        combine (CVQuadrant qdb) (CVQuadrant xb) (CVQuadrant xc) (CVQuadrant xd)
    end

ValidLens-LensA : {t : Set} {{eqT : Eq t}} {dep : Nat}
    -> ValidLens (VQuadrant t {S dep}) (VQuadrant t {dep})
ValidLens-LensA = CValidLens lensA (ValidLens-LensA-ViewSet) (ValidLens-LensA-SetView) (ValidLens-LensA-SetSet)


module _ where

module A where

  infix 2 _↑
  infix 1 c

  data D : Set where
    ●  : D
    _↑ : D → D
    c  : {x y : D} → D

  syntax c {x = x} {y = y} = x ↓ y

module B where

  infix 3 c

  data D : Set where
    c : {y x : D} → D

  syntax c {y = y} {x = x} = y ↓ x

open A
open B

accepted : A.D → A.D
accepted (● ↑ ↓ x) = ● ↑ ↓ x
accepted _         = ● ↑ ↓ ●


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

open import lib.Base
open import lib.Function
open import lib.Equivalence
open import lib.Univalence
open import lib.NType
open import lib.PathGroupoid

{-
A proof of function extensionality from the univalence axiom.
-}

module lib.Funext {i} {A : Type i} where

-- Naive non dependent function extensionality

module FunextNonDep {j} {B : Type j} {f g : A → B} (h : f ∼ g)
  where

  private
    equiv-comp : {B C : Type j} (e : B ≃ C)
      → is-equiv (λ (g : A → B) → (λ x → –> e (g x)))
    equiv-comp {B} e =
      equiv-induction (λ {B} e → is-equiv (λ (g : A → B) → (λ x → –> e (g x))))
                      (λ A' → snd (ide (A → A'))) e

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

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

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

    abstract
      fst-is-equiv : is-equiv (λ (y : free-path-space-B) → fst y)
      fst-is-equiv =
        is-eq fst (λ z → (z , (z , idp))) (λ _ → idp)
          (λ x' → ap (λ x → (_ , x))
                        (contr-has-all-paths _ _))

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

      d==e : d == e
      d==e = equiv-is-inj comp-fst-is-equiv _ _ idp

  λ=-nondep : f == g
  λ=-nondep = ap (λ f' x → fst (snd (f' x))) d==e

open FunextNonDep using (λ=-nondep)

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

  P-is-Unit : P == (λ x → Lift Unit)
  P-is-Unit = λ=-nondep (λ x → ua (contr-equiv-LiftUnit (e x)))

  abstract
    weak-λ= : is-contr (Π A P)
    weak-λ= = transport (λ Q → is-contr (Π A Q)) (! P-is-Unit)
                            (has-level-in ((λ x → lift unit) , (λ y → λ=-nondep (λ x → idp))))

-- Naive dependent function extensionality

module FunextDep {j} {P : A → Type j} {f g : Π A P} (h : f ∼ g)
  where

  open WeakFunext

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

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

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

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

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

  abstract
    Q-f==Q-g : Q-f == Q-g
    Q-f==Q-g = contr-has-all-paths Q-f Q-g

  λ= : f == g
  λ= = ap (λ u x → fst (u x)) Q-f==Q-g

-- Strong function extensionality

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

  open FunextDep

  app= : ∀ {f g : Π A P} (p : f == g) → f ∼ g
  app= p x = ap (λ u → u x) p

  λ=-idp : (f : Π A P)
    → idp == λ= (λ x → idp {a = f x})
  λ=-idp f = ap (ap (λ u x → fst (u x)))
    (contr-has-all-paths {{=-preserves-level
                           (ΠAQ-is-contr (λ x → idp))}}
                         idp (Q-f==Q-g (λ x → idp)))

  λ=-η : {f g : Π A P} (p : f == g)
    → p == λ= (app= p)
  λ=-η {f} idp = λ=-idp f

  app=-β : {f g : Π A P} (h : f ∼ g) (x : A)
    → app= (λ= h) x == h x
  app=-β h = app=-path (Q-f==Q-g h)  where

    app=-path : {f : Π A P} {u v : (x : A) → Q (λ x → idp {a = f x}) x}
      (p : u == v) (x : A)
      → app= (ap (λ u x → fst (u x)) p) x == ! (snd (u x)) ∙ snd (v x)
    app=-path {u = u} idp x = ! (!-inv-l (snd (u x)))

  app=-is-equiv : {f g : Π A P} → is-equiv (app= {f = f} {g = g})
  app=-is-equiv = is-eq _ λ= (λ h → λ= (app=-β h)) (! ∘ λ=-η)

  λ=-is-equiv : {f g : Π A P}
    → is-equiv (λ= {f = f} {g = g})
  λ=-is-equiv = is-eq _ app= (! ∘ λ=-η) (λ h → λ= (app=-β h))

-- We only export the following

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

  app= : f == g → f ∼ g
  app= p x = ap (λ u → u x) p

  abstract
    λ= : f ∼ g → f == g
    λ= = FunextDep.λ=

    app=-β : (p : f ∼ g) (x : A) → app= (λ= p) x == p x
    app=-β = StrongFunextDep.app=-β

    λ=-η : (p : f == g) → p == λ= (app= p)
    λ=-η = StrongFunextDep.λ=-η

  λ=-equiv : (f ∼ g) ≃ (f == g)
  λ=-equiv = (λ= , λ=-is-equiv) where
    abstract
      λ=-is-equiv : is-equiv λ=
      λ=-is-equiv = StrongFunextDep.λ=-is-equiv

  app=-equiv : (f == g) ≃ (f ∼ g)
  app=-equiv = (app= , app=-is-equiv) where
    abstract
      app=-is-equiv : is-equiv app=
      app=-is-equiv = StrongFunextDep.app=-is-equiv


-- Solver for cartesian category
-- Normalisation is based on https://arxiv.org/abs/math/9911059

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

open import Categories.Category
open import Categories.Category.Cartesian

module Experiment.Categories.Solver.Category.Cartesian
  {o ℓ e} {𝒞 : Category o ℓ e} (cartesian : Cartesian 𝒞) where

open import Level
open import Relation.Binary using (Rel; REL)

import Categories.Morphism.Reasoning as MR

open Category 𝒞
open Cartesian cartesian
open HomReasoning
open MR 𝒞

private
  variable
    A B C D E F : Obj

infixr 9 _:∘_
infixr 7 _:×_
infix 11 :⟨_,_⟩

data Sig : Set o where
  ∥_∥  : Obj → Sig
  :⊤   : Sig
  _:×_ : Sig → Sig → Sig

⟦_⟧Sig : Sig → Obj
⟦ ∥ A ∥    ⟧Sig = A
⟦ :⊤       ⟧Sig = ⊤
⟦ S₁ :× S₂ ⟧Sig = ⟦ S₁ ⟧Sig × ⟦ S₂ ⟧Sig

private
  variable
    S T U V : Sig

-- Expression for cartesian category
data Expr : Rel Sig (o ⊔ ℓ) where
  :id    : Expr S S
  _:∘_   : Expr T U → Expr S T → Expr S U
  :π₁    : Expr (S :× T) S
  :π₂    : Expr (S :× T) T
  :⟨_,_⟩ : Expr U S → Expr U T → Expr U (S :× T)
  ∥_∥    : A ⇒ B → Expr ∥ A ∥ ∥ B ∥
  ∥_!∥   : A ⇒ ⊤ → Expr ∥ A ∥ :⊤

-- Atomised expression
data AExpr : REL Sig Obj (o ⊔ ℓ) where
  :π₁   : AExpr (∥ A ∥ :× T) A
  :π₂   : AExpr (S :× ∥ B ∥) B
  _:∘π₁ : AExpr S A → AExpr (S :× T) A
  _:∘π₂ : AExpr T A → AExpr (S :× T) A

-- Normalised expression
data NExpr : Rel Sig (o ⊔ ℓ) where
  :id    : NExpr ∥ A ∥ ∥ A ∥
  :!N    : NExpr S :⊤
  ⟪_⟫    : AExpr S A → NExpr S ∥ A ∥
  :⟨_,_⟩ : NExpr U S → NExpr U T → NExpr U (S :× T)
  ∥_∥∘_  : B ⇒ C → NExpr S ∥ B ∥ → NExpr S ∥ C ∥

-- Semantics
⟦_⟧ : Expr S T → ⟦ S ⟧Sig ⇒ ⟦ T ⟧Sig
⟦ :id          ⟧ = id
⟦ e₁ :∘ e₂     ⟧ = ⟦ e₁ ⟧ ∘ ⟦ e₂ ⟧
⟦ :π₁          ⟧ = π₁
⟦ :π₂          ⟧ = π₂
⟦ :⟨ e₁ , e₂ ⟩ ⟧ = ⟨ ⟦ e₁ ⟧ , ⟦ e₂ ⟧ ⟩
⟦ ∥ f ∥        ⟧ = f
⟦ ∥ g !∥       ⟧ = g

⟦_⟧A : AExpr S B → ⟦ S ⟧Sig ⇒ B
⟦ :π₁      ⟧A = π₁
⟦ :π₂      ⟧A = π₂
⟦ e :∘π₁   ⟧A = ⟦ e ⟧A ∘ π₁
⟦ e :∘π₂   ⟧A = ⟦ e ⟧A ∘ π₂

⟦_⟧N : NExpr S T → ⟦ S ⟧Sig ⇒ ⟦ T ⟧Sig
⟦ :id          ⟧N = id
⟦ :!N          ⟧N = !
⟦ ⟪ e ⟫        ⟧N = ⟦ e ⟧A
⟦ :⟨ e₁ , e₂ ⟩ ⟧N = ⟨ ⟦ e₁ ⟧N , ⟦ e₂ ⟧N ⟩
⟦ ∥ f ∥∘ e     ⟧N = f ∘ ⟦ e ⟧N

_∘AN_ : AExpr T A → NExpr S T → NExpr S ∥ A ∥
:π₁       ∘AN :⟨ e₂ , e₃ ⟩ = e₂
:π₂       ∘AN :⟨ e₂ , e₃ ⟩ = e₃
(e₁ :∘π₁) ∘AN :⟨ e₂ , e₃ ⟩ = e₁ ∘AN e₂
(e₁ :∘π₂) ∘AN :⟨ e₂ , e₃ ⟩ = e₁ ∘AN e₃

_∘π₁N : NExpr S U → NExpr (S :× T) U
:id          ∘π₁N = ⟪ :π₁ ⟫
:!N          ∘π₁N = :!N
⟪ e ⟫        ∘π₁N = ⟪ e :∘π₁ ⟫
:⟨ e₁ , e₂ ⟩ ∘π₁N = :⟨ e₁ ∘π₁N , e₂ ∘π₁N ⟩
(∥ f ∥∘ e)   ∘π₁N = ∥ f ∥∘ (e ∘π₁N)

_∘π₂N : NExpr T U → NExpr (S :× T) U
:id          ∘π₂N = ⟪ :π₂ ⟫
:!N          ∘π₂N = :!N
⟪ e ⟫        ∘π₂N = ⟪ e :∘π₂ ⟫
:⟨ e₁ , e₂ ⟩ ∘π₂N = :⟨ e₁ ∘π₂N , e₂ ∘π₂N ⟩
(∥ f ∥∘ e)   ∘π₂N = ∥ f ∥∘ (e ∘π₂N)

_∘N_ : NExpr T U → NExpr S T → NExpr S U
:id          ∘N e₂ = e₂
:!N          ∘N e₂ = :!N
⟪ e₁ ⟫       ∘N e₂ = e₁ ∘AN e₂
:⟨ e₁ , e₂ ⟩ ∘N e₃ = :⟨ e₁ ∘N e₃ , e₂ ∘N e₃ ⟩
(∥ f ∥∘ e₁)  ∘N e₂ = ∥ f ∥∘ (e₁ ∘N e₂)

π₁N : ∀ S T → NExpr (S :× T) S
π₂N : ∀ S T → NExpr (S :× T) T
π₁N ∥ _ ∥      T = ⟪ :π₁ ⟫
π₁N :⊤         T = :!N
π₁N (S₁ :× S₂) T = :⟨ (π₁N S₁ S₂) ∘π₁N , (π₂N S₁ S₂) ∘π₁N ⟩
π₂N S ∥ _ ∥      = ⟪ :π₂ ⟫
π₂N S :⊤         = :!N
π₂N S (T₁ :× T₂) = :⟨ (π₁N T₁ T₂) ∘π₂N , (π₂N T₁ T₂) ∘π₂N ⟩

idN : ∀ S → NExpr S S
idN ∥ _ ∥    = :id
idN :⊤       = :!N
idN (S :× T) = :⟨ π₁N S T , π₂N S T ⟩

-- expand id, π₁ and π₂
normalise : Expr S T → NExpr S T
normalise :id          = idN _
normalise (e₁ :∘ e₂)   = normalise e₁ ∘N normalise e₂
normalise :π₁          = π₁N _ _
normalise :π₂          = π₂N _ _
normalise :⟨ e₁ , e₂ ⟩ = :⟨ normalise e₁ , normalise e₂ ⟩
normalise ∥ f ∥        = ∥ f ∥∘ :id
normalise ∥ g !∥       = :!N

∘AN-homo : (e₁ : AExpr T A) (e₂ : NExpr S T) → ⟦ e₁ ∘AN e₂ ⟧N ≈ ⟦ e₁ ⟧A ∘ ⟦ e₂ ⟧N
∘AN-homo :π₁       :⟨ e₂ , e₃ ⟩ = ⟺ project₁
∘AN-homo :π₂       :⟨ e₂ , e₃ ⟩ = ⟺ project₂
∘AN-homo (e₁ :∘π₁) :⟨ e₂ , e₃ ⟩ = ∘AN-homo e₁ e₂ ○ pushʳ (⟺ project₁)
∘AN-homo (e₁ :∘π₂) :⟨ e₂ , e₃ ⟩ = ∘AN-homo e₁ e₃ ○ pushʳ (⟺ project₂)

∘N-homo : (e₁ : NExpr T U) (e₂ : NExpr S T) → ⟦ e₁ ∘N e₂ ⟧N ≈ ⟦ e₁ ⟧N ∘ ⟦ e₂ ⟧N
∘N-homo :id          e₂ = ⟺ identityˡ
∘N-homo :!N          e₂ = !-unique _
∘N-homo ⟪ e₁ ⟫       e₂ = ∘AN-homo e₁ e₂
∘N-homo :⟨ e₁ , e₂ ⟩ e₃ = ⟨⟩-cong₂ (∘N-homo e₁ e₃) (∘N-homo e₂ e₃) ○ ⟺ ⟨⟩∘
∘N-homo (∥ f ∥∘ e₁)  e₂ = pushʳ (∘N-homo e₁ e₂)

∘π₁N-homo : ∀ (e : NExpr S U) → ⟦ (_∘π₁N {T = T}) e ⟧N ≈ ⟦ e ⟧N ∘ π₁
∘π₁N-homo :id          = ⟺ identityˡ
∘π₁N-homo :!N          = !-unique _
∘π₁N-homo ⟪ e ⟫        = refl
∘π₁N-homo :⟨ e₁ , e₂ ⟩ = ⟨⟩-cong₂ (∘π₁N-homo e₁) (∘π₁N-homo e₂) ○ ⟺ ⟨⟩∘
∘π₁N-homo (∥ f ∥∘ e)   = pushʳ (∘π₁N-homo e)

∘π₂N-homo : ∀ (e : NExpr T U) → ⟦ (_∘π₂N {S = S}) e ⟧N ≈ ⟦ e ⟧N ∘ π₂
∘π₂N-homo :id          = ⟺ identityˡ
∘π₂N-homo :!N          = !-unique _
∘π₂N-homo ⟪ e ⟫        = refl
∘π₂N-homo :⟨ e₁ , e₂ ⟩ = ⟨⟩-cong₂ (∘π₂N-homo e₁) (∘π₂N-homo e₂) ○ ⟺ ⟨⟩∘
∘π₂N-homo (∥ f ∥∘ e)   = pushʳ (∘π₂N-homo e)

private
  ∘π₁N′ : ∀ S T → NExpr S U → NExpr (S :× T) U
  ∘π₁N′ _ _ = _∘π₁N
  ∘π₂N′ : ∀ S T → NExpr T U → NExpr (S :× T) U
  ∘π₂N′ _ _ = _∘π₂N

π₁N-homo : ∀ S T → ⟦ π₁N S T ⟧N ≈ π₁
π₂N-homo : ∀ S T → ⟦ π₂N S T ⟧N ≈ π₂
π₁N-homo ∥ A ∥      T = refl
π₁N-homo :⊤         T = !-unique _
π₁N-homo (S₁ :× S₂) T = begin
  ⟨ ⟦ ∘π₁N′ (S₁ :× S₂) T (π₁N S₁ S₂) ⟧N , ⟦ ∘π₁N′ (S₁ :× S₂) T (π₂N S₁ S₂) ⟧N ⟩
    ≈⟨ ⟨⟩-cong₂ (∘π₁N-homo (π₁N S₁ S₂)) (∘π₁N-homo (π₂N S₁ S₂)) ⟩
  ⟨ ⟦ π₁N S₁ S₂ ⟧N ∘ π₁ , ⟦ π₂N S₁ S₂ ⟧N ∘ π₁ ⟩
    ≈˘⟨ ⟨⟩∘ ⟩
  ⟨ ⟦ π₁N S₁ S₂ ⟧N , ⟦ π₂N S₁ S₂ ⟧N ⟩ ∘ π₁
    ≈⟨ ⟨⟩-cong₂ (π₁N-homo S₁ S₂) (π₂N-homo S₁ S₂) ⟩∘⟨refl ⟩
  ⟨ π₁ , π₂ ⟩ ∘ π₁
    ≈⟨ elimˡ η ⟩
  π₁
    ∎
π₂N-homo S ∥ A ∥      = refl
π₂N-homo S :⊤         = !-unique _
π₂N-homo S (T₁ :× T₂) = begin
  ⟨ ⟦ ∘π₂N′ S (T₁ :× T₂) (π₁N T₁ T₂) ⟧N , ⟦ ∘π₂N′ S (T₁ :× T₂) (π₂N T₁ T₂) ⟧N ⟩
    ≈⟨ ⟨⟩-cong₂ (∘π₂N-homo (π₁N T₁ T₂)) (∘π₂N-homo (π₂N T₁ T₂)) ⟩
  ⟨ ⟦ π₁N T₁ T₂ ⟧N ∘ π₂ , ⟦ π₂N T₁ T₂ ⟧N ∘ π₂ ⟩
    ≈˘⟨ ⟨⟩∘ ⟩
  ⟨ ⟦ π₁N T₁ T₂ ⟧N , ⟦ π₂N T₁ T₂ ⟧N ⟩ ∘ π₂
    ≈⟨ ⟨⟩-cong₂ (π₁N-homo T₁ T₂) (π₂N-homo T₁ T₂) ⟩∘⟨refl ⟩
  ⟨ π₁ , π₂ ⟩ ∘ π₂
    ≈⟨ elimˡ η ⟩
  π₂
    ∎

idN-homo : ∀ S → ⟦ idN S ⟧N ≈ id
idN-homo ∥ _ ∥      = refl
idN-homo :⊤         = !-unique id
idN-homo (S₁ :× S₂) = ⟨⟩-cong₂ (π₁N-homo S₁ S₂) (π₂N-homo S₁ S₂) ○ η

correct : ∀ (e : Expr S T) → ⟦ normalise e ⟧N ≈ ⟦ e ⟧
correct {S} :id          = idN-homo S
correct (e₁ :∘ e₂)       = begin
  ⟦ normalise e₁ ∘N normalise e₂ ⟧N     ≈⟨ ∘N-homo (normalise e₁) (normalise e₂) ⟩
  ⟦ normalise e₁ ⟧N ∘ ⟦ normalise e₂ ⟧N ≈⟨ correct e₁ ⟩∘⟨ correct e₂ ⟩
  ⟦ e₁ ⟧ ∘ ⟦ e₂ ⟧                       ∎
correct {S :× T} {S} :π₁ = π₁N-homo S T
correct {S :× T} {T} :π₂ = π₂N-homo S T
correct :⟨ e₁ , e₂ ⟩     = ⟨⟩-cong₂ (correct e₁) (correct e₂)
correct ∥ f ∥            = identityʳ
correct ∥ g !∥           = !-unique g

solve : (e₁ e₂ : Expr S T) →
        ⟦ normalise e₁ ⟧N ≈ ⟦ normalise e₂ ⟧N → ⟦ e₁ ⟧ ≈ ⟦ e₂ ⟧
solve e₁ e₂ eq = begin
  ⟦ e₁ ⟧            ≈˘⟨ correct e₁ ⟩
  ⟦ normalise e₁ ⟧N ≈⟨ eq ⟩
  ⟦ normalise e₂ ⟧N ≈⟨ correct e₂ ⟩
  ⟦ e₂ ⟧            ∎

-- Combinators

∥-∥ : ∀ {f : A ⇒ B} → Expr ∥ A ∥ ∥ B ∥
∥-∥ {f = f} = ∥ f ∥

:! : Expr ∥ A ∥ :⊤
:! = ∥ ! !∥

:swap : Expr (S :× T) (T :× S)
:swap = :⟨ :π₂ , :π₁ ⟩

:assocˡ : Expr ((S :× T) :× U) (S :× T :× U)
:assocˡ = :⟨ :π₁ :∘ :π₁ , :⟨ :π₂ :∘ :π₁ , :π₂ ⟩ ⟩

:assocʳ : Expr (S :× T :× U) ((S :× T) :× U)
:assocʳ = :⟨ :⟨ :π₁ , :π₁ :∘ :π₂ ⟩ , :π₂ :∘ :π₂ ⟩

infixr 8 _:⁂_

_:⁂_ : Expr S T → Expr U V → Expr (S :× U) (T :× V)
e₁ :⁂ e₂ = :⟨ e₁ :∘ :π₁ , e₂ :∘ :π₂ ⟩

:first : Expr S T → Expr (S :× U) (T :× U)
:first e = e :⁂ :id

:second : Expr T U → Expr (S :× T) (S :× U)
:second e = :id :⁂ e


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommSemiring.Instances.UpperNat where
{-
  based on:
  https://github.com/DavidJaz/Cohesion/blob/master/UpperNaturals.agda

  and the slides here (for arithmetic operation):
  https://felix-cherubini.de/myers-slides-II.pdf
-}

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels

open import Cubical.Functions.Logic
open import Cubical.Functions.Embedding

open import Cubical.Algebra.CommMonoid
open import Cubical.Algebra.OrderedCommMonoid
open import Cubical.Algebra.OrderedCommMonoid.PropCompletion
open import Cubical.Algebra.OrderedCommMonoid.Instances
open import Cubical.Algebra.CommSemiring

open import Cubical.Data.Nat using (ℕ; ·-distribˡ)
open import Cubical.Data.Nat.Order
open import Cubical.Data.Empty hiding (⊥)
open import Cubical.Data.Sigma

open import Cubical.HITs.Truncation
open import Cubical.HITs.PropositionalTruncation as PT

private
  variable
    ℓ : Level

{- The Upper Naturals
   An upper natural is an upward closed proposition on natural numbers.
   The interpretation is that an upper natural is a natural ``defined by its upper bounds'', in the
   sense that for the proposition N holding of a natural n means that n is an upper bound of N.
   The important bit about upper naturals is that they satisfy the well-ordering principle,
   constructively (no proof of that is given here).

   Example Application:
   The degree of a polynomial P=∑_{i=0}^{n} aᵢ · Xⁱ may be defined as an upper natural:

     deg(P) :≡ (λ n → all non-zero indices have index smaller n)

     Or: deg(∑_{i=0}^{n} aᵢ · Xⁱ) = λ (k : ℕ) → ∀ (k+1 ≤ i ≤ n) aᵢ≡0

   This works even if a constructive definition of polynomial is used.

   However the upper naturals are a bit too unconstraint and do not even form a semiring,
   since they include 'infinity' elements like the proposition that is always false.

   This is different for the subtype of *bounded* upper naturals ℕ↑b.
-}

module ConstructionUnbounded where
  ℕ↑-+ = PropCompletion ℕ≤+
  ℕ↑-· = PropCompletion ℕ≤·

  open OrderedCommMonoidStr (snd ℕ↑-+)
    hiding (_≤_; MonotoneL; MonotoneR)
    renaming (·Assoc to +Assoc; ·Comm to +Comm; ·IdR to +Rid;
              _·_ to _+_; ε to 0↑)

  open OrderedCommMonoidStr (snd ℕ≤·)
   using (MonotoneL; MonotoneR)

  open OrderedCommMonoidStr (snd ℕ≤+)
   hiding (_≤_)
   renaming (_·_ to _+ℕ_;
             MonotoneL to +MonotoneL; MonotoneR to +MonotoneR;
             ·Comm to ℕ+Comm)

  open OrderedCommMonoidStr ⦃...⦄
    using (_·_ ; ·Assoc ; ·Comm )
    renaming (·IdR to ·Rid)

  private
    instance
      _ : OrderedCommMonoidStr _ _
      _  = snd ℕ↑-·
      _ : OrderedCommMonoidStr _ _
      _ = snd ℕ≤·

  ℕ↑ : Type₁
  ℕ↑ = fst ℕ↑-+

  open PropCompletion ℓ-zero ℕ≤+
    using (typeAt; pathFromImplications)

  open <-Reasoning using (_≤⟨_⟩_)

  +LDist· : (x y z : ℕ↑) →
            x · (y + z) ≡ (x · y) + (x · z)
  +LDist· x y z =
    pathFromImplications
      (x · (y + z)) ((x · y) + (x · z))
      (⇒) ⇐
    where
      ⇒ : (n : ℕ) → typeAt n (x · (y + z))  → typeAt n ((x · y) + (x · z))
      ⇒ n = PT.rec
             isPropPropTrunc
             λ {((a , b) , xa , (y+zb , a·b≤n)) →
                 PT.rec
                   isPropPropTrunc
                   (λ {((a' , b') , ya' , (zb' , a'+b'≤b))
                     → ∣ ((a · a') , (a · b')) ,
                          ∣ (a , a') , (xa , (ya' , ≤-refl)) ∣₁ ,
                          (∣ (a , b') , (xa , (zb' , ≤-refl)) ∣₁ ,
                          subst (_≤ n) (sym (·-distribˡ a a' b'))
                            (≤-trans (MonotoneL {z = a} a'+b'≤b) a·b≤n)) ∣₁ })
                   y+zb}

      ⇐ : (n : ℕ) → _
      ⇐ n =
        PT.rec
          isPropPropTrunc
          λ {((a , b) , x·ya , (x·zb , a+b≤n))
          → PT.rec
              isPropPropTrunc
              (λ {((a' , b') , a'x , (b'y , a'·b'≤a))
              → PT.rec
                  isPropPropTrunc
                  (λ {((a″ , b″) , a″x , (zb″ , a″·b″≤b))
                  → ∣ ≤CaseInduction {n = a'} {m = a″}
                        (λ a'≤a″ →
                          (a' , (b' +ℕ b″)) , a'x ,

                          (∣ (b' , b″) , (b'y , (zb″ , ≤-refl)) ∣₁ ,
                           (a' · (b' +ℕ b″)       ≤⟨ subst
                                                       (_≤ (a' · b') +ℕ (a' · b″))
                                                       (·-distribˡ a' b' b″) ≤-refl ⟩
                           (a' · b') +ℕ (a' · b″) ≤⟨ +MonotoneR a'·b'≤a ⟩
                            a +ℕ (a' · b″)        ≤⟨ +MonotoneL
                                                       (≤-trans (MonotoneR a'≤a″) a″·b″≤b) ⟩
                            a+b≤n ))
                        )
                        (λ a″≤a' →
                         (a″ , (b' +ℕ b″)) , (a″x ,
                         (∣ (b' , b″) , (b'y , (zb″ , ≤-refl)) ∣₁ ,
                           ((a″ · (b' +ℕ b″))      ≤⟨ subst
                                                        (_≤ (a″ · b') +ℕ (a″ · b″))
                                                        (·-distribˡ a″ b' b″) ≤-refl ⟩
                            (a″ · b') +ℕ (a″ · b″) ≤⟨ +MonotoneR
                                                        ((a″ · b') ≤⟨ MonotoneR a″≤a' ⟩ a'·b'≤a) ⟩
                            a +ℕ (a″ · b″)         ≤⟨ +MonotoneL a″·b″≤b  ⟩
                            a+b≤n)))
                        )
                    ∣₁})
                  x·zb})
              x·ya}

module ConstructionBounded where
  ℕ↑-+b = BoundedPropCompletion ℕ≤+
  ℕ↑-·b = BoundedPropCompletion ℕ≤·

  open OrderedCommMonoidStr (snd ℕ≤+)
    renaming (_·_ to _+ℕ_; ·IdR to +IdR; ·Comm to ℕ+Comm)
  open OrderedCommMonoidStr (snd ℕ↑-+b)
    renaming (_·_ to _+_; ε to 0↑)

  open OrderedCommMonoidStr (snd ℕ↑-·b)
    using (_·_)

  open PropCompletion ℓ-zero ℕ≤+
    using (typeAt; pathFromImplications)

  ℕ↑b : Type₁
  ℕ↑b = fst ℕ↑-+b

  AnnihilL : (x : ℕ↑b) → 0↑ · x ≡ 0↑
  AnnihilL x =
    Σ≡Prop (λ s → PropCompletion.isPropIsBounded ℓ-zero ℕ≤+ s)
           (pathFromImplications (fst (0↑ · x)) (fst 0↑) (⇒) ⇐)
    where
     ⇒ : (n : ℕ) → typeAt n (fst (0↑ · x)) → typeAt n (fst 0↑)
     ⇒ n _ = n , ℕ+Comm n 0
     ⇐ : (n : ℕ) → typeAt n (fst 0↑) → typeAt n (fst (0↑ · x))
     ⇐ n _ =
       PT.rec
         isPropPropTrunc
         (λ {(m , mIsUpperBound) → ∣ (0 , m) , ((0 , refl) , (mIsUpperBound , n ,  +IdR n)) ∣₁})
         (snd x)

  asCommSemiring : CommSemiring (ℓ-suc ℓ-zero)
  fst asCommSemiring = ℕ↑b
  CommSemiringStr.0r (snd asCommSemiring) = 0↑
  CommSemiringStr.1r (snd asCommSemiring) = OrderedCommMonoidStr.ε (snd ℕ↑-·b)
  CommSemiringStr._+_ (snd asCommSemiring) = _+_
  CommSemiringStr._·_ (snd asCommSemiring) = _·_
  IsCommSemiring.+IsCommMonoid (CommSemiringStr.isCommSemiring (snd asCommSemiring)) =
    OrderedCommMonoidStr.isCommMonoid (snd ℕ↑-+b)
  IsCommSemiring.·IsCommMonoid (CommSemiringStr.isCommSemiring (snd asCommSemiring)) =
    OrderedCommMonoidStr.isCommMonoid (snd ℕ↑-·b)
  IsCommSemiring.·LDist+ (CommSemiringStr.isCommSemiring (snd asCommSemiring)) =
    λ x y z → Σ≡Prop (λ s → PropCompletion.isPropIsBounded ℓ-zero ℕ≤+ s)
                     (ConstructionUnbounded.+LDist· (fst x) (fst y) (fst z))
  IsCommSemiring.AnnihilL (CommSemiringStr.isCommSemiring (snd asCommSemiring)) = AnnihilL


postulate
  List      : Set
  List-like : Set → Set

instance
  postulate
    List-is-list-like : List-like List

postulate
  to-List : ∀ {F : Set} ⦃ list-like : ∀ {X : Set} → List-like F ⦄ → F → List
  F       : Set

f : ⦃ list-like : List-like F ⦄ → List
f = to-List _


module Rat where

open import Data.Empty
open import Data.Unit
import Data.Sign as S
open import Data.String
open import Data.Nat as ℕ using (ℕ; zero; suc)
open import Data.Nat.Coprimality renaming (sym to symCoprime)
open import Data.Nat.GCD
open import Data.Nat.Show renaming (show to ℕshow)
open import Data.Nat.Divisibility
open import Data.Integer hiding (_-_ ; -_)
  renaming (_+_ to _ℤ+_ ; _*_ to _ℤ*_ ; _≟_ to _ℤ≟_ ; show to ℤshow)
open import Data.Integer.Properties
open import Data.Rational
open import Data.Product
open import Relation.Nullary.Decidable
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

infix  8 -_ 1/_
infixl 7 _*_ _/_
infixl 6 _-_ _+_

------------------------------------------------------------------------------
-- Two lemmas to help with operations on rationals

NonZero : ℕ → Set
NonZero 0       = ⊥
NonZero (suc _) = ⊤

-- normalize takes two natural numbers, say 6 and 21 and their gcd 3, and
-- returns them normalized as 2 and 7 and a proof that they are coprime

normalize : ∀ {m n g} → {n≢0 : NonZero n} → {g≢0 : NonZero g} →
            GCD m n g → Σ[ p ∈ ℕ ] Σ[ q ∈ ℕ ] False (q ℕ.≟ 0) × Coprime p q
normalize {m} {n} {0} {_} {()} _
normalize {m} {n} {ℕ.suc g} {_} {_} G with Bézout.identity G
normalize {m} {.0} {ℕ.suc g} {()} {_}
  (GCD.is (divides p m≡pg' , divides 0 refl) _) | _
normalize {m} {n} {ℕ.suc g} {_} {_}
  (GCD.is (divides p m≡pg' , divides (ℕ.suc q) n≡qg') _) | Bézout.+- x y eq =
    (p , ℕ.suc q , tt , Bézout-coprime {p} {ℕ.suc q} {g} (Bézout.+- x y
               (begin
                 ℕ.suc g ℕ.+ y ℕ.* (ℕ.suc q ℕ.* ℕ.suc g)
               ≡⟨ cong (λ h → ℕ.suc g ℕ.+ y ℕ.* h) (sym n≡qg') ⟩
                 ℕ.suc g ℕ.+ y ℕ.* n
               ≡⟨ eq ⟩
                 x ℕ.* m
               ≡⟨ cong (λ h → x ℕ.* h) m≡pg' ⟩
                 x ℕ.* (p ℕ.* ℕ.suc g) ∎)))
normalize {m} {n} {ℕ.suc g} {_} {_}
  (GCD.is (divides p m≡pg' , divides (ℕ.suc q) n≡qg') _) | Bézout.-+ x y eq =
    (p , ℕ.suc q , tt , Bézout-coprime {p} {ℕ.suc q} {g} (Bézout.-+ x y
               (begin
                 ℕ.suc g ℕ.+ x ℕ.* (p ℕ.* ℕ.suc g)
               ≡⟨ cong (λ h → ℕ.suc g ℕ.+ x ℕ.* h) (sym m≡pg') ⟩
                 ℕ.suc g ℕ.+ x ℕ.* m
               ≡⟨ eq ⟩
                 y ℕ.* n
               ≡⟨ cong (λ h → y ℕ.* h) n≡qg' ⟩
                 y ℕ.* (ℕ.suc q ℕ.* ℕ.suc g) ∎)))

-- a version of gcd that returns a proof that the result is non-zero given
-- that one of the inputs is non-zero

gcd≢0 : (m n : ℕ) → {m≢0 : NonZero m} → ∃ λ d → GCD m n d × NonZero d
gcd≢0 m  n {m≢0} with gcd m n
gcd≢0 m  n {m≢0} | (0 , GCD.is (0|m , _) _) with 0∣⇒≡0 0|m
gcd≢0 .0 n {()}  | (0 , GCD.is (0|m , _) _) | refl
gcd≢0 m  n {_}   | (ℕ.suc d , G) = (ℕ.suc d , G , tt)

------------------------------------------------------------------------------
-- Operations on rationals: unary -, reciprocal, multiplication, addition

-- unary negation
--
-- Andreas Abel says: Agda's type-checker is incomplete when it has to handle
-- types with leading hidden quantification, such as the ones of Coprime m n
-- and c.  A work around is to use hidden abstraction explicitly.  In your
-- case, giving λ {i} -> c works.  Not pretty, but unavoidable until we
-- improve on the current heuristics. I recorded this as a bug
-- http://code.google.com/p/agda/issues/detail?id=1079

-_ : ℚ → ℚ
-_ p with ℚ.numerator p | ℚ.denominator-1 p | toWitness (ℚ.isCoprime p)
... | -[1+ n ]  | d | c = (+ ℕ.suc n ÷ ℕ.suc d) {fromWitness (λ {i} → c)}
... | + 0       | d | _ = p
... | + ℕ.suc n | d | c = (-[1+ n ]  ÷ ℕ.suc d) {fromWitness (λ {i} → c)}

-- reciprocal: requires a proof that the numerator is not zero

1/_ : (p : ℚ) → {n≢0 : NonZero ∣ ℚ.numerator p ∣} → ℚ
1/_ p {n≢0} with ℚ.numerator p | ℚ.denominator-1 p | toWitness (ℚ.isCoprime p)
1/_ p {()} | + 0 | d | c
... | + (ℕ.suc n) | d | c =
  ((S.+ ◃ ℕ.suc d) ÷ ℕ.suc n)
  {fromWitness (λ {i} →
    subst (λ h → Coprime h (ℕ.suc n))
          (sym (abs-◃ S.+ (ℕ.suc d)))
          (symCoprime c))}
... | -[1+ n ] | d | c =
  ((S.- ◃ ℕ.suc d) ÷ ℕ.suc n)
  {fromWitness (λ {i} →
    subst (λ h → Coprime h (ℕ.suc n))
          (sym (abs-◃ S.- (ℕ.suc d)))
          (symCoprime c))}

-- multiplication

private

  helper* : (n₁ : ℤ) → (d₁ : ℕ) → (n₂ : ℤ) → (d₂ : ℕ) →
            {n≢0 : NonZero ∣ n₁ ℤ* n₂ ∣} →
            {d≢0 : NonZero (d₁ ℕ.* d₂)} →
            ℚ
  helper* n₁ d₁ n₂ d₂ {n≢0} {d≢0} =
    let n = n₁ ℤ* n₂
        d = d₁ ℕ.* d₂
        (g , G , g≢0) = gcd≢0 ∣ n ∣ d {n≢0}
        (nn , nd , nd≢0 , nc) = normalize {∣ n ∣} {d} {g} {d≢0} {g≢0} G
    in ((sign n ◃ nn) ÷ nd)
       {fromWitness (λ {i} →
          subst (λ h → Coprime h nd) (sym (abs-◃ (sign n) nn)) nc)}
       {nd≢0}

_*_ : ℚ → ℚ → ℚ
p₁ * p₂ with ℚ.numerator p₁ | ℚ.numerator p₂
... | + 0  | _    = + 0 ÷ 1
... | _    | + 0  = + 0 ÷ 1
... | + ℕ.suc n₁ | + ℕ.suc n₂ =
  helper* (+ ℕ.suc n₁) (ℕ.suc (ℚ.denominator-1 p₁))
          (+ ℕ.suc n₂) (ℕ.suc (ℚ.denominator-1 p₂))
... | + ℕ.suc n₁ | -[1+ n₂ ] =
  helper* (+ ℕ.suc n₁) (ℕ.suc (ℚ.denominator-1 p₁))
          -[1+ n₂ ] (ℕ.suc (ℚ.denominator-1 p₂))
... | -[1+ n₁ ] | + ℕ.suc n₂ =
  helper* -[1+ n₁ ] (ℕ.suc (ℚ.denominator-1 p₁))
          (+ ℕ.suc n₂) (ℕ.suc (ℚ.denominator-1 p₂))
... | -[1+ n₁ ] | -[1+ n₂ ] =
  helper* -[1+ n₁ ] (ℕ.suc (ℚ.denominator-1 p₁))
          -[1+ n₂ ] (ℕ.suc (ℚ.denominator-1 p₂))

-- addition

private

  helper+ : (n : ℤ) → (d : ℕ) → {d≢0 : NonZero d} → ℚ
  helper+ (+ 0) d {d≢0} = + 0 ÷ 1
  helper+ (+ ℕ.suc n) d {d≢0} =
    let (g , G , g≢0) = gcd≢0 ∣ + ℕ.suc n ∣ d {tt}
        (nn , nd , nd≢0 , nc) = normalize {∣ + ℕ.suc n ∣} {d} {g} {d≢0} {g≢0} G
    in ((S.+ ◃ nn) ÷ nd)
       {fromWitness (λ {i} →
          subst (λ h → Coprime h nd) (sym (abs-◃ S.+ nn)) nc)}
       {nd≢0}
  helper+ -[1+ n ] d {d≢0} =
    let (g , G , g≢0) = gcd≢0 ∣ -[1+ n ] ∣ d {tt}
        (nn , nd , nd≢0 , nc) = normalize {∣ -[1+ n ] ∣} {d} {g} {d≢0} {g≢0} G
    in ((S.- ◃ nn) ÷ nd)
       {fromWitness (λ {i} →
          subst (λ h → Coprime h nd) (sym (abs-◃ S.- nn)) nc)}
       {nd≢0}

_+_ : ℚ → ℚ → ℚ
p₁ + p₂ =
  let n₁ = ℚ.numerator p₁
      d₁ = ℕ.suc (ℚ.denominator-1 p₁)
      n₂ = ℚ.numerator p₂
      d₂ = ℕ.suc (ℚ.denominator-1 p₂)
      n = (n₁ ℤ* + d₂) ℤ+ (n₂ ℤ* + d₁)
      d = d₁ ℕ.* d₂
  in helper+ n d

-- subtraction and division

_-_ : ℚ → ℚ → ℚ
p₁ - p₂ = p₁ + (- p₂)

_/_ : (p₁ p₂ : ℚ) → {n≢0 : NonZero ∣ ℚ.numerator p₂ ∣} → ℚ
_/_ p₁ p₂ {n≢0} = p₁ * (1/_ p₂ {n≢0})

-- conventional printed representation

show : ℚ → String
show p = ℤshow (ℚ.numerator p) ++ "/" ++ ℕshow (ℕ.suc (ℚ.denominator-1 p))

------------------------------------------------------------------------------
-- A few constants and some small tests

0ℚ 1ℚ : ℚ
0ℚ = + 0 ÷ 1
1ℚ = + 1 ÷ 1

private

  p₀ p₁ p₂ p₃ : ℚ
  p₀ = + 1 ÷ 2
  p₁ = + 1 ÷ 3
  p₂ = -[1+ 2 ] ÷ 4
  p₃ = + 3 ÷ 4

  test₀ = show p₂
  test₁ = show (- p₂)
  test₂ = show (1/ p₂)
  test₃ = show (p₀ + p₀)
  test₄ = show (p₁ * p₂)

------------------------------------------------------------------------------


------------------------------------------------------------------------
-- The Agda standard library
--
-- The unit type
------------------------------------------------------------------------

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

module Data.Unit where

import Relation.Binary.PropositionalEquality as PropEq

------------------------------------------------------------------------
-- Re-export contents of base module

open import Data.Unit.Base public

------------------------------------------------------------------------
-- Re-export query operations

open import Data.Unit.Properties public
  using (_≟_; _≤?_)

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

-- Version 1.1

setoid = Data.Unit.Properties.≡-setoid
{-# WARNING_ON_USAGE setoid
"Warning: setoid was deprecated in v1.1.
Please use ≡-setoid from Data.Unit.Properties instead."
#-}
decSetoid = Data.Unit.Properties.≡-decSetoid
{-# WARNING_ON_USAGE decSetoid
"Warning: decSetoid was deprecated in v1.1.
Please use ≡-decSetoid from Data.Unit.Properties instead."
#-}
total = Data.Unit.Properties.≡-total
{-# WARNING_ON_USAGE total
"Warning: total was deprecated in v1.1.
Please use ≡-total from Data.Unit.Properties instead"
#-}
poset = Data.Unit.Properties.≡-poset
{-# WARNING_ON_USAGE poset
"Warning: poset was deprecated in v1.1.
Please use ≡-poset from Data.Unit.Properties instead."
#-}
decTotalOrder = Data.Unit.Properties.≡-decTotalOrder
{-# WARNING_ON_USAGE decTotalOrder
"Warning: decTotalOrder was deprecated in v1.1.
Please use ≡-decTotalOrder from Data.Unit.Properties instead."
#-}
preorder = PropEq.preorder ⊤
{-# WARNING_ON_USAGE decTotalOrder
"Warning: preorder was deprecated in v1.1.
Please use ≡-preorder from Data.Unit.Properties instead."
#-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Code for converting Vec A n → B to and from n-ary functions
------------------------------------------------------------------------

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

module Data.Vec.N-ary where

open import Data.Nat.Base hiding (_⊔_)
open import Data.Product as Prod
open import Data.Vec
open import Function
open import Function.Equivalence using (_⇔_; equivalence)
open import Level using (Level; _⊔_)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary.Decidable

------------------------------------------------------------------------
-- N-ary functions

N-ary-level : Level → Level → ℕ → Level
N-ary-level ℓ₁ ℓ₂ zero    = ℓ₂
N-ary-level ℓ₁ ℓ₂ (suc n) = ℓ₁ ⊔ N-ary-level ℓ₁ ℓ₂ n

N-ary : ∀ {ℓ₁ ℓ₂} (n : ℕ) → Set ℓ₁ → Set ℓ₂ → Set (N-ary-level ℓ₁ ℓ₂ n)
N-ary zero    A B = B
N-ary (suc n) A B = A → N-ary n A B

------------------------------------------------------------------------
-- Conversion

curryⁿ : ∀ {n a b} {A : Set a} {B : Set b} →
         (Vec A n → B) → N-ary n A B
curryⁿ {zero}  f = f []
curryⁿ {suc n} f = λ x → curryⁿ (f ∘ _∷_ x)

_$ⁿ_ : ∀ {n a b} {A : Set a} {B : Set b} → N-ary n A B → (Vec A n → B)
f $ⁿ []       = f
f $ⁿ (x ∷ xs) = f x $ⁿ xs

------------------------------------------------------------------------
-- Quantifiers

-- Universal quantifier.

∀ⁿ : ∀ n {a ℓ} {A : Set a} →
     N-ary n A (Set ℓ) → Set (N-ary-level a ℓ n)
∀ⁿ zero    P = P
∀ⁿ (suc n) P = ∀ x → ∀ⁿ n (P x)

-- Universal quantifier with implicit (hidden) arguments.

∀ⁿʰ : ∀ n {a ℓ} {A : Set a} →
     N-ary n A (Set ℓ) → Set (N-ary-level a ℓ n)
∀ⁿʰ zero    P = P
∀ⁿʰ (suc n) P = ∀ {x} → ∀ⁿʰ n (P x)

-- Existential quantifier.

∃ⁿ : ∀ n {a ℓ} {A : Set a} →
     N-ary n A (Set ℓ) → Set (N-ary-level a ℓ n)
∃ⁿ zero    P = P
∃ⁿ (suc n) P = ∃ λ x → ∃ⁿ n (P x)

------------------------------------------------------------------------
-- N-ary function equality

Eq : ∀ {a b c ℓ} {A : Set a} {B : Set b} {C : Set c} n →
     REL B C ℓ → REL (N-ary n A B) (N-ary n A C) (N-ary-level a ℓ n)
Eq n _∼_ f g = ∀ⁿ n (curryⁿ {n = n} λ xs → (f $ⁿ xs) ∼ (g $ⁿ xs))

-- A variant where all the arguments are implicit (hidden).

Eqʰ : ∀ {a b c ℓ} {A : Set a} {B : Set b} {C : Set c} n →
      REL B C ℓ → REL (N-ary n A B) (N-ary n A C) (N-ary-level a ℓ n)
Eqʰ n _∼_ f g = ∀ⁿʰ n (curryⁿ {n = n} λ xs → (f $ⁿ xs) ∼ (g $ⁿ xs))

------------------------------------------------------------------------
-- Some lemmas

-- The functions curryⁿ and _$ⁿ_ are inverses.

left-inverse : ∀ {n a b} {A : Set a} {B : Set b} (f : Vec A n → B) →
               ∀ xs → (curryⁿ f $ⁿ xs) ≡ f xs
left-inverse f []       = refl
left-inverse f (x ∷ xs) = left-inverse (f ∘ _∷_ x) xs

right-inverse : ∀ {a b} {A : Set a} {B : Set b} n (f : N-ary n A B) →
                Eq n _≡_ (curryⁿ (_$ⁿ_ {n} f)) f
right-inverse zero    f = refl
right-inverse (suc n) f = λ x → right-inverse n (f x)

-- ∀ⁿ can be expressed in an "uncurried" way.

uncurry-∀ⁿ : ∀ n {a ℓ} {A : Set a} {P : N-ary n A (Set ℓ)} →
             ∀ⁿ n P ⇔ (∀ (xs : Vec A n) → P $ⁿ xs)
uncurry-∀ⁿ n {a} {ℓ} {A} = equivalence (⇒ n) (⇐ n)
  where
  ⇒ : ∀ n {P : N-ary n A (Set ℓ)} →
      ∀ⁿ n P → (∀ (xs : Vec A n) → P $ⁿ xs)
  ⇒ zero    p []       = p
  ⇒ (suc n) p (x ∷ xs) = ⇒ n (p x) xs

  ⇐ : ∀ n {P : N-ary n A (Set ℓ)} →
      (∀ (xs : Vec A n) → P $ⁿ xs) → ∀ⁿ n P
  ⇐ zero    p = p []
  ⇐ (suc n) p = λ x → ⇐ n (p ∘ _∷_ x)

-- ∃ⁿ can be expressed in an "uncurried" way.

uncurry-∃ⁿ : ∀ n {a ℓ} {A : Set a} {P : N-ary n A (Set ℓ)} →
             ∃ⁿ n P ⇔ (∃ λ (xs : Vec A n) → P $ⁿ xs)
uncurry-∃ⁿ n {a} {ℓ} {A} = equivalence (⇒ n) (⇐ n)
  where
  ⇒ : ∀ n {P : N-ary n A (Set ℓ)} →
      ∃ⁿ n P → (∃ λ (xs : Vec A n) → P $ⁿ xs)
  ⇒ zero    p       = ([] , p)
  ⇒ (suc n) (x , p) = Prod.map (_∷_ x) id (⇒ n p)

  ⇐ : ∀ n {P : N-ary n A (Set ℓ)} →
      (∃ λ (xs : Vec A n) → P $ⁿ xs) → ∃ⁿ n P
  ⇐ zero    ([] , p)     = p
  ⇐ (suc n) (x ∷ xs , p) = (x , ⇐ n (xs , p))

-- Conversion preserves equality.

curryⁿ-cong : ∀ {n a b c ℓ} {A : Set a} {B : Set b} {C : Set c}
              (_∼_ : REL B C ℓ) (f : Vec A n → B) (g : Vec A n → C) →
              (∀ xs → f xs ∼ g xs) →
              Eq n _∼_ (curryⁿ f) (curryⁿ g)
curryⁿ-cong {zero}  _∼_ f g hyp = hyp []
curryⁿ-cong {suc n} _∼_ f g hyp = λ x →
  curryⁿ-cong _∼_ (f ∘ _∷_ x) (g ∘ _∷_ x) (λ xs → hyp (x ∷ xs))

curryⁿ-cong⁻¹ : ∀ {n a b c ℓ} {A : Set a} {B : Set b} {C : Set c}
                (_∼_ : REL B C ℓ) (f : Vec A n → B) (g : Vec A n → C) →
                Eq n _∼_ (curryⁿ f) (curryⁿ g) →
                ∀ xs → f xs ∼ g xs
curryⁿ-cong⁻¹ _∼_ f g hyp []       = hyp
curryⁿ-cong⁻¹ _∼_ f g hyp (x ∷ xs) =
  curryⁿ-cong⁻¹ _∼_ (f ∘ _∷_ x) (g ∘ _∷_ x) (hyp x) xs

appⁿ-cong : ∀ {n a b c ℓ} {A : Set a} {B : Set b} {C : Set c}
            (_∼_ : REL B C ℓ) (f : N-ary n A B) (g : N-ary n A C) →
            Eq n _∼_ f g →
            (xs : Vec A n) → (f $ⁿ xs) ∼ (g $ⁿ xs)
appⁿ-cong _∼_ f g hyp []       = hyp
appⁿ-cong _∼_ f g hyp (x ∷ xs) = appⁿ-cong _∼_ (f x) (g x) (hyp x) xs

appⁿ-cong⁻¹ : ∀ {n a b c ℓ} {A : Set a} {B : Set b} {C : Set c}
              (_∼_ : REL B C ℓ) (f : N-ary n A B) (g : N-ary n A C) →
              ((xs : Vec A n) → (f $ⁿ xs) ∼ (g $ⁿ xs)) →
              Eq n _∼_ f g
appⁿ-cong⁻¹ {zero}  _∼_ f g hyp = hyp []
appⁿ-cong⁻¹ {suc n} _∼_ f g hyp = λ x →
  appⁿ-cong⁻¹ _∼_ (f x) (g x) (λ xs → hyp (x ∷ xs))

-- Eq and Eqʰ are equivalent.

Eq-to-Eqʰ : ∀ {a b c ℓ} {A : Set a} {B : Set b} {C : Set c}
            n (_∼_ : REL B C ℓ) {f : N-ary n A B} {g : N-ary n A C} →
            Eq n _∼_ f g → Eqʰ n _∼_ f g
Eq-to-Eqʰ zero    _∼_ eq = eq
Eq-to-Eqʰ (suc n) _∼_ eq = Eq-to-Eqʰ n _∼_ (eq _)

Eqʰ-to-Eq : ∀ {a b c ℓ} {A : Set a} {B : Set b} {C : Set c}
            n (_∼_ : REL B C ℓ) {f : N-ary n A B} {g : N-ary n A C} →
            Eqʰ n _∼_ f g → Eq n _∼_ f g
Eqʰ-to-Eq zero    _∼_ eq = eq
Eqʰ-to-Eq (suc n) _∼_ eq = λ _ → Eqʰ-to-Eq n _∼_ eq


{-# OPTIONS --cubical --no-import-sorts --allow-unsolved-metas #-}

module Number.Coercions where

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

open import Cubical.Data.Unit.Base -- Unit
open import Cubical.Data.Empty -- ⊥
open import Cubical.Data.Empty renaming (elim to ⊥-elim) -- `⊥` and `elim`

open import Number.Postulates
open import Number.Inclusions
open import Number.Base
open import MoreNatProperties

open ℕⁿ
open ℤᶻ
open ℚᶠ
open ℝʳ
open ℂᶜ

open PatternsProp

module Coerce-ℕ↪ℤ where
  open ℤ
  open IsROrderedCommSemiringInclusion -- ℕ↪ℤinc
  private f = ℕ↪ℤ
  abstract
    coerce-ℕ↪ℤ : ∀{p} → (x : Number (isNat , p)) → PositivityKindInterpretation isInt (coerce-PositivityKind isNat isInt p) (ℕ↪ℤ (num x))
    coerce-ℕ↪ℤ {⁇x⁇} (x ,, q) = lift tt
    coerce-ℕ↪ℤ {x#0} (x ,, q) = preserves-#0 ℕ↪ℤinc _ q -- transport (λ i → f x # preserves-0 i) (preserves-# _ _ q)
    coerce-ℕ↪ℤ {0≤x} (x ,, q) = preserves-0≤ ℕ↪ℤinc _ q -- transport (λ i → preserves-0 i ≤ f x) (preserves-≤ _ _ q)
    coerce-ℕ↪ℤ {0<x} (x ,, q) = preserves-0< ℕ↪ℤinc _ q -- transport (λ i → preserves-0 i < f x) (preserves-< _ _ q)
    coerce-ℕ↪ℤ {x≤0} (x ,, q) = preserves-≤0 ℕ↪ℤinc _ q -- transport (λ i → f x ≤ preserves-0 i) (preserves-≤ _ _ q)

module Coerce-ℕ↪ℚ where
  open ℚ
  open IsROrderedCommSemiringInclusion -- ℕ↪ℚinc
  private f = ℕ↪ℚ
  abstract
    coerce-ℕ↪ℚ : ∀{p} → (x : Number (isNat , p)) → PositivityKindInterpretation isRat (coerce-PositivityKind isNat isRat p) (ℕ↪ℚ (num x))
    coerce-ℕ↪ℚ {⁇x⁇} (x ,, q) = lift tt
    coerce-ℕ↪ℚ {x#0} (x ,, q) = preserves-#0 ℕ↪ℚinc _ q -- transport (λ i → f x # preserves-0 i) (preserves-# _ _ q)
    coerce-ℕ↪ℚ {0≤x} (x ,, q) = preserves-0≤ ℕ↪ℚinc _ q -- transport (λ i → preserves-0 i ≤ f x) (preserves-≤ _ _ q)
    coerce-ℕ↪ℚ {0<x} (x ,, q) = preserves-0< ℕ↪ℚinc _ q -- transport (λ i → preserves-0 i < f x) (preserves-< _ _ q)
    coerce-ℕ↪ℚ {x≤0} (x ,, q) = preserves-≤0 ℕ↪ℚinc _ q -- transport (λ i → f x ≤ preserves-0 i) (preserves-≤ _ _ q)

module Coerce-ℕ↪ℝ where
  open ℝ
  open IsROrderedCommSemiringInclusion -- ℕ↪ℝinc
  private f = ℕ↪ℝ
  abstract
    coerce-ℕ↪ℝ : ∀{p} → (x : Number (isNat , p)) → PositivityKindInterpretation isReal (coerce-PositivityKind isNat isReal p) (ℕ↪ℝ (num x))
    coerce-ℕ↪ℝ {⁇x⁇} (x ,, q) = lift tt
    coerce-ℕ↪ℝ {x#0} (x ,, q) = preserves-#0 ℕ↪ℝinc _ q -- transport (λ i → f x # preserves-0 i) (preserves-# _ _ q)
    coerce-ℕ↪ℝ {0≤x} (x ,, q) = preserves-0≤ ℕ↪ℝinc _ q -- transport (λ i → preserves-0 i ≤ f x) (preserves-≤ _ _ q)
    coerce-ℕ↪ℝ {0<x} (x ,, q) = preserves-0< ℕ↪ℝinc _ q -- transport (λ i → preserves-0 i < f x) (preserves-< _ _ q)
    coerce-ℕ↪ℝ {x≤0} (x ,, q) = preserves-≤0 ℕ↪ℝinc _ q -- transport (λ i → f x ≤ preserves-0 i) (preserves-≤ _ _ q)

module Coerce-ℕ↪ℂ where
  open ℂ
  open Isℕ↪ℂ -- ℕ↪ℂinc
  private f = ℕ↪ℂ
  abstract
    coerce-ℕ↪ℂ : ∀{p} → (x : Number (isNat , p)) → PositivityKindInterpretation isComplex (coerce-PositivityKind isNat isComplex p) (ℕ↪ℂ (num x))
    coerce-ℕ↪ℂ {⁇x⁇} (x ,, q) = lift tt
    coerce-ℕ↪ℂ {x#0} (x ,, q) = transport (λ i → f x # preserves-0 ℕ↪ℂinc i) (preserves-# ℕ↪ℂinc _ _ q)
    coerce-ℕ↪ℂ {0≤x} (x ,, q) = lift tt
    coerce-ℕ↪ℂ {0<x} (x ,, q) = transport (λ i → f x # preserves-0 ℕ↪ℂinc i) (preserves-# ℕ↪ℂinc _ _ (ℕ.#-sym _ _ (ℕ.<-implies-# _ _ q)))
    coerce-ℕ↪ℂ {x≤0} (x ,, q) = lift tt

module Coerce-ℤ↪ℚ where
  open ℚ
  open IsROrderedCommRingInclusion -- ℤ↪ℚinc
  private f = ℤ↪ℚ
  abstract
    coerce-ℤ↪ℚ : ∀{p} → (x : Number (isInt , p)) → PositivityKindInterpretation isRat (coerce-PositivityKind isInt isRat p) (ℤ↪ℚ (num x))
    coerce-ℤ↪ℚ {⁇x⁇} (x ,, q) = lift tt
    coerce-ℤ↪ℚ {x#0} (x ,, q) = preserves-#0 ℤ↪ℚinc _ q -- transport (λ i → f x # preserves-0 i) (preserves-# _ _ q)
    coerce-ℤ↪ℚ {0≤x} (x ,, q) = preserves-0≤ ℤ↪ℚinc _ q -- transport (λ i → preserves-0 i ≤ f x) (preserves-≤ _ _ q)
    coerce-ℤ↪ℚ {0<x} (x ,, q) = preserves-0< ℤ↪ℚinc _ q -- transport (λ i → preserves-0 i < f x) (preserves-< _ _ q)
    coerce-ℤ↪ℚ {x<0} (x ,, q) = preserves-<0 ℤ↪ℚinc _ q -- transport (λ i → f x < preserves-0 i) (preserves-< _ _ q)
    coerce-ℤ↪ℚ {x≤0} (x ,, q) = preserves-≤0 ℤ↪ℚinc _ q -- transport (λ i → f x ≤ preserves-0 i) (preserves-≤ _ _ q)

module Coerce-ℤ↪ℝ where
  open ℝ
  open IsROrderedCommRingInclusion --  ℤ↪ℝinc
  private f = ℤ↪ℝ
  abstract
    coerce-ℤ↪ℝ : ∀{p} → (x : Number (isInt , p)) → PositivityKindInterpretation isReal (coerce-PositivityKind isInt isReal p) (ℤ↪ℝ (num x))
    coerce-ℤ↪ℝ {⁇x⁇} (x ,, q) = lift tt
    coerce-ℤ↪ℝ {x#0} (x ,, q) = preserves-#0 ℤ↪ℝinc _ q -- transport (λ i → f x # preserves-0 i) (preserves-# _ _ q)
    coerce-ℤ↪ℝ {0≤x} (x ,, q) = preserves-0≤ ℤ↪ℝinc _ q -- transport (λ i → preserves-0 i ≤ f x) (preserves-≤ _ _ q)
    coerce-ℤ↪ℝ {0<x} (x ,, q) = preserves-0< ℤ↪ℝinc _ q -- transport (λ i → preserves-0 i < f x) (preserves-< _ _ q)
    coerce-ℤ↪ℝ {x<0} (x ,, q) = preserves-<0 ℤ↪ℝinc _ q -- transport (λ i → f x < preserves-0 i) (preserves-< _ _ q)
    coerce-ℤ↪ℝ {x≤0} (x ,, q) = preserves-≤0 ℤ↪ℝinc _ q -- transport (λ i → f x ≤ preserves-0 i) (preserves-≤ _ _ q)

module Coerce-ℤ↪ℂ where
  open ℂ
  open Isℤ↪ℂ -- ℤ↪ℂinc
  private f = ℤ↪ℂ
  abstract
    coerce-ℤ↪ℂ : ∀{p} → (x : Number (isInt , p)) → PositivityKindInterpretation isComplex (coerce-PositivityKind isInt isComplex p) (ℤ↪ℂ (num x))
    coerce-ℤ↪ℂ {⁇x⁇} (x ,, q) = lift tt
    coerce-ℤ↪ℂ {x#0} (x ,, q) = transport (λ i → f x # preserves-0 ℤ↪ℂinc i) (preserves-# ℤ↪ℂinc _ _ q)
    coerce-ℤ↪ℂ {0≤x} (x ,, q) = lift tt
    coerce-ℤ↪ℂ {0<x} (x ,, q) = transport (λ i → f x # preserves-0 ℤ↪ℂinc i) (preserves-# ℤ↪ℂinc _ _ (ℤ.#-sym _ _ (ℤ.<-implies-# _ _ q)))
    coerce-ℤ↪ℂ {x<0} (x ,, q) = transport (λ i → f x # preserves-0 ℤ↪ℂinc i) (preserves-# ℤ↪ℂinc _ _              (ℤ.<-implies-# _ _ q) )
    coerce-ℤ↪ℂ {x≤0} (x ,, q) = lift tt

module Coerce-ℚ↪ℝ where
  open ℝ
  open IsROrderedFieldInclusion -- ℚ↪ℝinc
  private f = ℚ↪ℝ
  abstract
    coerce-ℚ↪ℝ : ∀{p} → (x : Number (isRat , p)) → PositivityKindInterpretation isReal (coerce-PositivityKind isRat isReal p) (ℚ↪ℝ (num x))
    coerce-ℚ↪ℝ {⁇x⁇} (x ,, q) = lift tt
    coerce-ℚ↪ℝ {x#0} (x ,, q) = preserves-#0 ℚ↪ℝinc _ q -- transport (λ i → f x # preserves-0 i) (preserves-# _ _ q)
    coerce-ℚ↪ℝ {0≤x} (x ,, q) = preserves-0≤ ℚ↪ℝinc _ q -- transport (λ i → preserves-0 i ≤ f x) (preserves-≤ _ _ q)
    coerce-ℚ↪ℝ {0<x} (x ,, q) = preserves-0< ℚ↪ℝinc _ q -- transport (λ i → preserves-0 i < f x) (preserves-< _ _ q)
    coerce-ℚ↪ℝ {x<0} (x ,, q) = preserves-<0 ℚ↪ℝinc _ q -- transport (λ i → f x < preserves-0 i) (preserves-< _ _ q)
    coerce-ℚ↪ℝ {x≤0} (x ,, q) = preserves-≤0 ℚ↪ℝinc _ q -- transport (λ i → f x ≤ preserves-0 i) (preserves-≤ _ _ q)

module Coerce-ℚ↪ℂ where
  open ℂ
  open IsRFieldInclusion -- ℚ↪ℂinc
  private f = ℚ↪ℂ
  abstract
    coerce-ℚ↪ℂ : ∀{p} → (x : Number (isRat , p)) → PositivityKindInterpretation isComplex (coerce-PositivityKind isRat isComplex p) (ℚ↪ℂ (num x))
    coerce-ℚ↪ℂ {⁇x⁇} (x ,, q) = lift tt
    coerce-ℚ↪ℂ {x#0} (x ,, q) = preserves-#0 ℚ↪ℂinc _ q -- transport (λ i → f x # preserves-0 ℚ↪ℂinc i) (preserves-# ℚ↪ℂinc _ _ q)
    coerce-ℚ↪ℂ {0≤x} (x ,, q) = lift tt
    coerce-ℚ↪ℂ {0<x} (x ,, q) = transport (λ i → f x # preserves-0 ℚ↪ℂinc i) (preserves-# ℚ↪ℂinc _ _ (ℚ.#-sym _ _ (ℚ.<-implies-# _ _ q)))
    coerce-ℚ↪ℂ {x<0} (x ,, q) = transport (λ i → f x # preserves-0 ℚ↪ℂinc i) (preserves-# ℚ↪ℂinc _ _              (ℚ.<-implies-# _ _ q) )
    coerce-ℚ↪ℂ {x≤0} (x ,, q) = lift tt

module Coerce-ℝ↪ℂ where
  -- open ℂ
  open IsRFieldInclusion -- ℝ↪ℂinc
  private f = ℝ↪ℂ
  abstract
    coerce-ℝ↪ℂ : ∀{p} → (x : Number (isReal , p)) → PositivityKindInterpretation isComplex (coerce-PositivityKind isReal isComplex p) (ℝ↪ℂ (num x))
    coerce-ℝ↪ℂ {⁇x⁇} (x ,, q) = lift tt
    coerce-ℝ↪ℂ {x#0} (x ,, q) = preserves-#0 ℝ↪ℂinc _ q -- transport (λ i → f x # preserves-0 ℝ↪ℂinc i) (preserves-# ℝ↪ℂinc _ _ q)
    coerce-ℝ↪ℂ {0≤x} (x ,, q) = lift tt
    coerce-ℝ↪ℂ {0<x} (x ,, q) = transport (λ i → f x ℂ.# preserves-0 ℝ↪ℂinc i) (preserves-# ℝ↪ℂinc _ _ (ℝ.#-sym _ _ (ℝ.<-implies-# _ _ q)))
    coerce-ℝ↪ℂ {x<0} (x ,, q) = transport (λ i → f x ℂ.# preserves-0 ℝ↪ℂinc i) (preserves-# ℝ↪ℂinc _ _              (ℝ.<-implies-# _ _ q) )
    coerce-ℝ↪ℂ {x≤0} (x ,, q) = lift tt

-- NOTE: typechecking of this module is very slow
--       the cause might be opening of the ten `IsXInclusion` instances
--       it could be related to https://github.com/agda/agda/issues/1646 (Exponential module chain leads to infeasible scope checking)
--       YES: this is the case. After shifting the module arguments from `open` into the code, checking became instant again

-- does this make anything faster?
open Coerce-ℕ↪ℤ public
open Coerce-ℕ↪ℚ public
open Coerce-ℕ↪ℝ public
open Coerce-ℕ↪ℂ public
open Coerce-ℤ↪ℚ public
open Coerce-ℤ↪ℝ public
open Coerce-ℤ↪ℂ public
open Coerce-ℚ↪ℝ public
open Coerce-ℚ↪ℂ public
open Coerce-ℝ↪ℂ public

coerce : (from : NumberKind)
       → (to   : NumberKind)
       → from ≤ₙₗ to
       → ∀{p}
       → Number (from ,                               p)
       → Number (to   , coerce-PositivityKind from to p)
coerce isNat     isNat     q {p} x = x
coerce isInt     isInt     q {p} x = x
coerce isRat     isRat     q {p} x = x
coerce isReal    isReal    q {p} x = x
coerce isComplex isComplex q {p} x = x
coerce isNat     isInt     q {p} x = (ℕ↪ℤ (num x) ,, coerce-ℕ↪ℤ x)
coerce isNat     isRat     q {p} x = (ℕ↪ℚ (num x) ,, coerce-ℕ↪ℚ x)
coerce isNat     isReal    q {p} x = (ℕ↪ℝ (num x) ,, coerce-ℕ↪ℝ x)
coerce isNat     isComplex q {p} x = (ℕ↪ℂ (num x) ,, coerce-ℕ↪ℂ x)
coerce isInt     isRat     q {p} x = (ℤ↪ℚ (num x) ,, coerce-ℤ↪ℚ x)
coerce isInt     isReal    q {p} x = (ℤ↪ℝ (num x) ,, coerce-ℤ↪ℝ x)
coerce isInt     isComplex q {p} x = (ℤ↪ℂ (num x) ,, coerce-ℤ↪ℂ x)
coerce isRat     isReal    q {p} x = (ℚ↪ℝ (num x) ,, coerce-ℚ↪ℝ x)
coerce isRat     isComplex q {p} x = (ℚ↪ℂ (num x) ,, coerce-ℚ↪ℂ x)
coerce isReal    isComplex q {p} x = (ℝ↪ℂ (num x) ,, coerce-ℝ↪ℂ x)
--coerce x         y         = nothing
coerce isInt     isNat  r@(k , q) {p} x = ⊥-elim {A = λ _ → Number (isNat  , p)} (k+x+sy≢x _ _ _ q)
coerce isRat     isNat  r@(k , q) {p} x = ⊥-elim {A = λ _ → Number (isNat  , p)} (k+x+sy≢x _ _ _ q)
coerce isRat     isInt  r@(k , q) {p} x = ⊥-elim {A = λ _ → Number (isInt  , p)} (k+x+sy≢x _ _ _ q)
coerce isReal    isNat  r@(k , q) {p} x = ⊥-elim {A = λ _ → Number (isNat  , p)} (k+x+sy≢x _ _ _ q)
coerce isReal    isInt  r@(k , q) {p} x = ⊥-elim {A = λ _ → Number (isInt  , p)} (k+x+sy≢x _ _ _ q)
coerce isReal    isRat  r@(k , q) {p} x = ⊥-elim {A = λ _ → Number (isRat  , p)} (k+x+sy≢x _ _ _ q)
coerce isComplex isNat  r@(k , q) {p} x = ⊥-elim {A = λ _ → Number (isNat  , coerce-PositivityKind isComplex isNat  p)} (k+x+sy≢x _ _ _ q)
coerce isComplex isInt  r@(k , q) {p} x = ⊥-elim {A = λ _ → Number (isInt  , coerce-PositivityKind isComplex isInt  p)} (k+x+sy≢x _ _ _ q)
coerce isComplex isRat  r@(k , q) {p} x = ⊥-elim {A = λ _ → Number (isRat  , coerce-PositivityKind isComplex isRat  p)} (k+x+sy≢x _ _ _ q)
coerce isComplex isReal r@(k , q) {p} x = ⊥-elim {A = λ _ → Number (isReal , coerce-PositivityKind isComplex isReal p)} (k+x+sy≢x _ _ _ q)