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

open import lib.Base
open import lib.Equivalence
open import lib.NType
open import lib.PathFunctor
open import lib.PathGroupoid
open import lib.PathOver
open import lib.Univalence

module lib.cubical.Square where

{-
  *--1--*
  |     |
  0     3
  |     |
  *--2--*
-}

data Square {i} {A : Type i} {a₀₀ : A} : {a₀₁ a₁₀ a₁₁ : A}
  → a₀₀ == a₀₁ → a₀₀ == a₁₀ → a₀₁ == a₁₁ → a₁₀ == a₁₁ → Type i
  where
  ids : Square idp idp idp idp

hid-square : ∀ {i} {A : Type i} {a₀₀ a₀₁ : A} {p : a₀₀ == a₀₁}
  → Square p idp idp p
hid-square {p = idp} = ids

vid-square : ∀ {i} {A : Type i} {a₀₀ a₁₀ : A} {p : a₀₀ == a₁₀}
  → Square idp p p idp
vid-square {p = idp} = ids

square-to-disc : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  → Square p₀₋ p₋₀ p₋₁ p₁₋
  → p₀₋ ∙ p₋₁ == p₋₀ ∙ p₁₋
square-to-disc ids = idp

disc-to-square : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  → p₀₋ ∙ p₋₁ == p₋₀ ∙ p₁₋
  → Square p₀₋ p₋₀ p₋₁ p₁₋
disc-to-square {p₀₋ = idp} {p₋₀ = idp} {p₋₁ = idp} {p₁₋ = .idp} idp = ids

square-to-disc-β : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  (α : p₀₋ ∙ p₋₁ == p₋₀ ∙ p₁₋)
  → square-to-disc (disc-to-square {p₀₋ = p₀₋} {p₋₀ = p₋₀} α) == α
square-to-disc-β {p₀₋ = idp} {p₋₀ = idp} {p₋₁ = idp} {p₁₋ = .idp} idp = idp

disc-to-square-β : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
  → disc-to-square (square-to-disc sq) == sq
disc-to-square-β ids = idp

square-disc-equiv : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  → (Square p₀₋ p₋₀ p₋₁ p₁₋) ≃ (p₀₋ ∙ p₋₁ == p₋₀ ∙ p₁₋)
square-disc-equiv =
  equiv square-to-disc disc-to-square square-to-disc-β disc-to-square-β

Square-level : ∀ {n : ℕ₋₂} {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  → has-level (S (S n)) A
  → has-level n (Square p₀₋ p₋₀ p₋₁ p₁₋)
Square-level {n} A-level =
  transport (has-level n) (! (ua square-disc-equiv)) $
  has-level-apply (has-level-apply A-level _ _) _ _

ap-square : ∀ {i j} {A : Type i} {B : Type j} (f : A → B)
  {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  → Square p₀₋ p₋₀ p₋₁ p₁₋
  → Square (ap f p₀₋) (ap f p₋₀) (ap f p₋₁) (ap f p₁₋)
ap-square f ids = ids

ap-square-hid : ∀ {i j} {A : Type i} {B : Type j} {f : A → B}
  {a₀ a₁ : A} {p : a₀ == a₁}
  → ap-square f (hid-square {p = p}) == hid-square
ap-square-hid {p = idp} = idp

ap-square-vid : ∀ {i j} {A : Type i} {B : Type j} {f : A → B}
  {a₀ a₁ : A} {p : a₀ == a₁}
  → ap-square f (vid-square {p = p}) == vid-square
ap-square-vid {p = idp} = idp

module _ {i} {A : Type i} where

  horiz-degen-square : {a a' : A} {p q : a == a'}
    → p == q → Square p idp idp q
  horiz-degen-square {p = idp} α = disc-to-square α

  horiz-degen-path : {a a' : A} {p q : a == a'}
    → Square p idp idp q → p == q
  horiz-degen-path {p = idp} sq = square-to-disc sq

  horiz-degen-path-β : {a a' : A} {p q : a == a'} (α : p == q)
    → horiz-degen-path (horiz-degen-square α) == α
  horiz-degen-path-β {p = idp} α = square-to-disc-β α

  horiz-degen-square-β : {a a' : A} {p q : a == a'} (sq : Square p idp idp q)
    → horiz-degen-square (horiz-degen-path sq) == sq
  horiz-degen-square-β {p = idp} sq = disc-to-square-β sq

  vert-degen-square : {a a' : A} {p q : a == a'}
    → p == q → Square idp p q idp
  vert-degen-square {p = idp} α = disc-to-square (! α)

  vert-degen-path : {a a' : A} {p q : a == a'}
    → Square idp p q idp → p == q
  vert-degen-path {p = idp} sq = ! (square-to-disc sq)

  vert-degen-path-β : {a a' : A} {p q : a == a'} (α : p == q)
    → vert-degen-path (vert-degen-square α) == α
  vert-degen-path-β {p = idp} α = ap ! (square-to-disc-β (! α)) ∙ !-! α

  vert-degen-square-β : {a a' : A} {p q : a == a'} (sq : Square idp p q idp)
    → vert-degen-square (vert-degen-path sq) == sq
  vert-degen-square-β {p = idp} sq =
    ap disc-to-square (!-! (square-to-disc sq)) ∙ disc-to-square-β sq

  horiz-degen-square-idp : {a a' : A} {p : a == a'}
    → horiz-degen-square (idp {a = p}) == hid-square
  horiz-degen-square-idp {p = idp} = idp

  vert-degen-square-idp : {a a' : A} {p : a == a'}
    → vert-degen-square (idp {a = p}) == vid-square
  vert-degen-square-idp {p = idp} = idp

ap-horiz-degen-square : ∀ {i j} {A : Type i} {B : Type j} (f : A → B)
  {a a' : A} {p q : a == a'} (r : p == q)
  → ap-square f (horiz-degen-square r) == horiz-degen-square (ap (ap f) r)
ap-horiz-degen-square f {p = idp} r@idp = idp

ap-vert-degen-square : ∀ {i j} {A : Type i} {B : Type j} (f : A → B)
  {a a' : A} {p q : a == a'} (r : p == q)
  → ap-square f (vert-degen-square r) == vert-degen-square (ap (ap f) r)
ap-vert-degen-square f {p = idp} r@idp = idp

{- Flipping squares -}
module _ {i} {A : Type i} where

  square-symmetry : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    → Square p₀₋ p₋₀ p₋₁ p₁₋ → Square p₋₀ p₀₋ p₁₋ p₋₁
  square-symmetry ids = ids

  square-sym-inv : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    → square-symmetry (square-symmetry sq) == sq
  square-sym-inv ids = idp

  !□h : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    → Square p₀₋ p₋₀ p₋₁ p₁₋
    → Square p₁₋ (! p₋₀) (! p₋₁) p₀₋
  !□h ids = ids

  !□v : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    → Square p₀₋ p₋₀ p₋₁ p₁₋
    → Square (! p₀₋) p₋₁ p₋₀ (! p₁₋)
  !□v ids = ids

  !□v-horiz-degen-square : {a a' : A} {p q : a == a'}
    (r : p == q)
    → !□v (horiz-degen-square r) == horiz-degen-square (ap ! r)
  !□v-horiz-degen-square {p = idp} r@idp = idp

  !□v-vert-degen-square : {a a' : A} {p q : a == a'}
    (r : p == q)
    → !□v (vert-degen-square r) == vert-degen-square (! r)
  !□v-vert-degen-square {p = idp} r@idp = idp

ap-square-symmetry : ∀ {i j} {A : Type i} {B : Type j} (f : A → B)
  {a₀₀ a₀₁ a₁₀ a₁₁ : A} {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
  {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
  → ap-square f (square-symmetry sq) == square-symmetry (ap-square f sq)
ap-square-symmetry f ids = idp

horiz-degen-square-symmetry : ∀ {i} {A : Type i}
  {a a' : A} {p q : a == a'} (r : p == q)
  → square-symmetry (horiz-degen-square r) == vert-degen-square r
horiz-degen-square-symmetry {p = idp} α@idp = idp

{- Alternate induction principles -}

square-left-J : ∀ {i j} {A : Type i} {a₀₀ a₀₁ : A} {p₀₋ : a₀₀ == a₀₁}
  (P : {a₁₀ a₁₁ : A} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
       (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
       → Type j)
  (r : P hid-square)
  {a₁₀ a₁₁ : A} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
  → P sq
square-left-J P r ids = r

square-top-J : ∀ {i j} {A : Type i} {a₀₀ a₁₀ : A} {p₋₀ : a₀₀ == a₁₀}
  (P : {a₀₁ a₁₁ : A} {p₀₋ : a₀₀ == a₀₁} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
       (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
       → Type j)
  (r : P vid-square)
  {a₀₁ a₁₁ : A} {p₀₋ : a₀₀ == a₀₁} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
  → P sq
square-top-J P r ids = r

square-bot-J : ∀ {i j} {A : Type i} {a₀₁ a₁₁ : A} {p₋₁ : a₀₁ == a₁₁}
  (P : {a₀₀ a₁₀ : A} {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₁₋ : a₁₀ == a₁₁}
       (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
       → Type j)
  (r : P vid-square)
  {a₀₀ a₁₀ : A} {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₁₋ : a₁₀ == a₁₁}
  (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
  → P sq
square-bot-J P r ids = r

square-right-J : ∀ {i j} {A : Type i} {a₁₀ a₁₁ : A} {p₁₋ : a₁₀ == a₁₁}
  (P : {a₀₀ a₀₁ : A} {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁}
       (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
       → Type j)
  (r : P hid-square)
  {a₀₀ a₀₁ : A} {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁}
  (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
  → P sq
square-right-J P r ids = r

module _ where
  private
    lemma : ∀ {i j} {A : Type i} {a₀ : A}
      (P : {a₁ : A} {p q : a₀ == a₁} → p == q → Type j)
      (r : P (idp {a = idp}))
      {a₁ : A} {p q : a₀ == a₁} (α : p == q)
      → P α
    lemma P r {p = idp} idp = r

  horiz-degen-J : ∀ {i j} {A : Type i} {a₀ : A}
    (P : {a₁ : A} {p q : a₀ == a₁} → Square p idp idp q → Type j)
    (r : P ids)
    {a₁ : A} {p q : a₀ == a₁} (sq : Square p idp idp q)
    → P sq
  horiz-degen-J P r sq = transport P
    (horiz-degen-square-β sq)
    (lemma (P ∘ horiz-degen-square) r (horiz-degen-path sq))

  vert-degen-J : ∀ {i j} {A : Type i} {a₀ : A}
    (P : {a₁ : A} {p q : a₀ == a₁} → Square idp p q idp → Type j)
    (r : P ids)
    {a₁ : A} {p q : a₀ == a₁} (sq : Square idp p q idp)
    → P sq
  vert-degen-J P r sq = transport P
    (vert-degen-square-β sq)
    (lemma (P ∘ vert-degen-square) r (vert-degen-path sq))

{- Square filling -}
module _ {i} {A : Type i} where
  fill-square-left : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    (p₋₀ : a₀₀ == a₁₀) (p₋₁ : a₀₁ == a₁₁) (p₁₋ : a₁₀ == a₁₁)
    → Σ (a₀₀ == a₀₁) (λ p₀₋ → Square p₀₋ p₋₀ p₋₁ p₁₋)
  fill-square-left idp idp p = (p , hid-square)

  fill-square-top : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    (p₀₋ : a₀₀ == a₀₁) (p₋₁ : a₀₁ == a₁₁) (p₁₋ : a₁₀ == a₁₁)
    → Σ (a₀₀ == a₁₀) (λ p₋₀ → Square p₀₋ p₋₀ p₋₁ p₁₋)
  fill-square-top idp p idp = (p , vid-square)

  fill-square-bot : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    (p₀₋ : a₀₀ == a₀₁) (p₋₀ : a₀₀ == a₁₀) (p₁₋ : a₁₀ == a₁₁)
    → Σ (a₀₁ == a₁₁) (λ p₋₁ → Square p₀₋ p₋₀ p₋₁ p₁₋)
  fill-square-bot idp p idp = (p , vid-square)

  fill-square-right : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    (p₀₋ : a₀₀ == a₀₁) (p₋₀ : a₀₀ == a₁₀) (p₋₁ : a₀₁ == a₁₁)
    → Σ (a₁₀ == a₁₁) (λ p₁₋ → Square p₀₋ p₋₀ p₋₁ p₁₋)
  fill-square-right p idp idp = (p , hid-square)

module _  {i j} {A : Type i} {B : Type j} {f : A → B} {b : B} where

  ↓-cst=app-from-square : {x y : A} {p : x == y}
    {u : b == f x} {v : b == f y}
    → Square u idp (ap f p) v
    → u == v [ (λ z → b == f z) ↓ p ]
  ↓-cst=app-from-square {p = idp} sq = horiz-degen-path sq

  ↓-cst=app-to-square : {x y : A} {p : x == y}
    {u : b == f x} {v : b == f y}
    → u == v [ (λ z → b == f z) ↓ p ]
    → Square u idp (ap f p) v
  ↓-cst=app-to-square {p = idp} α = horiz-degen-square α

  ↓-app=cst-from-square : {x y : A} {p : x == y}
    {u : f x == b} {v : f y == b}
    → Square u (ap f p) idp v
    → u == v [ (λ z → f z == b) ↓ p ]
  ↓-app=cst-from-square {p = idp} sq = horiz-degen-path sq

  ↓-app=cst-to-square : {x y : A} {p : x == y}
    {u : f x == b} {v : f y == b}
    → u == v [ (λ z → f z == b) ↓ p ]
    → Square u (ap f p) idp v
  ↓-app=cst-to-square {p = idp} α = horiz-degen-square α

module _  {i} {A : Type i} {f : A → A} where

  ↓-idf=app-from-square : {x y : A} {p : x == y}
    {u : x == f x} {v : y == f y}
    → Square u p (ap f p) v
    → u == v [ (λ z → z == f z) ↓ p ]
  ↓-idf=app-from-square {p = idp} sq = horiz-degen-path sq

  ↓-idf=app-to-square : {x y : A} {p : x == y}
    {u : x == f x} {v : y == f y}
    → u == v [ (λ z → z == f z) ↓ p ]
    → Square u p (ap f p) v
  ↓-idf=app-to-square {p = idp} α = horiz-degen-square α

  ↓-app=idf-from-square : {x y : A} {p : x == y}
    {u : f x == x} {v : f y == y}
    → Square u (ap f p) p v
    → u == v [ (λ z → f z == z) ↓ p ]
  ↓-app=idf-from-square {p = idp} sq = horiz-degen-path sq

  ↓-app=idf-to-square : {x y : A} {p : x == y}
    {u : f x == x} {v : f y == y}
    → u == v [ (λ z → f z == z) ↓ p ]
    → Square u (ap f p) p v
  ↓-app=idf-to-square {p = idp} α = horiz-degen-square α

module _  {i j} {A : Type i} {B : Type j} (g : B → A) (f : A → B) where

  ↓-∘=idf-from-square : {x y : A} {p : x == y}
    {u : g (f x) == x} {v : g (f y) == y}
    → Square u (ap g (ap f p)) p v
    → (u == v [ (λ z → g (f z) == z) ↓ p ])
  ↓-∘=idf-from-square {p = idp} sq = horiz-degen-path sq

  ↓-∘=idf-to-square : {x y : A} {p : x == y}
    {u : g (f x) == x} {v : g (f y) == y}
    → (u == v [ (λ z → g (f z) == z) ↓ p ])
    → Square u (ap g (ap f p)) p v
  ↓-∘=idf-to-square {p = idp} α = horiz-degen-square α

_⊡v_ : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ a₀₂ a₁₂ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  {q₀₋ : a₀₁ == a₀₂} {q₋₂ : a₀₂ == a₁₂} {q₁₋ : a₁₁ == a₁₂}
  → Square p₀₋ p₋₀ p₋₁ p₁₋ → Square q₀₋ p₋₁ q₋₂ q₁₋
  → Square (p₀₋ ∙ q₀₋) p₋₀ q₋₂ (p₁₋ ∙ q₁₋)
ids ⊡v sq = sq

_⊡v'_ : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ a₀₂ a₁₂ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  {q₀₋ : a₀₁ == a₀₂} {q₋₂ : a₀₂ == a₁₂} {q₁₋ : a₁₁ == a₁₂}
  → Square p₀₋ p₋₀ p₋₁ p₁₋ → Square q₀₋ p₋₁ q₋₂ q₁₋
  → Square (p₀₋ ∙' q₀₋) p₋₀ q₋₂ (p₁₋ ∙' q₁₋)
sq ⊡v' ids = sq

_∙v⊡_ : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ p₋₀' : a₀₀ == a₁₀}
  {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  → p₋₀ == p₋₀'
  → Square p₀₋ p₋₀' p₋₁ p₁₋
  → Square p₀₋ p₋₀ p₋₁ p₁₋
idp ∙v⊡ sq = sq

_⊡v∙_ : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₋₀ : a₀₀ == a₁₀} {p₀₋ : a₀₀ == a₀₁}
  {p₋₁ p₋₁' : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  → Square p₀₋ p₋₀ p₋₁ p₁₋
  → p₋₁ == p₋₁'
  → Square p₀₋ p₋₀ p₋₁' p₁₋
sq ⊡v∙ idp = sq

_⊡h_ : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ a₂₀ a₂₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  {q₋₀ : a₁₀ == a₂₀} {q₋₁ : a₁₁ == a₂₁} {q₂₋ : a₂₀ == a₂₁}
  → Square p₀₋ p₋₀ p₋₁ p₁₋
  → Square p₁₋ q₋₀ q₋₁ q₂₋
  → Square p₀₋ (p₋₀ ∙ q₋₀) (p₋₁ ∙ q₋₁) q₂₋
ids ⊡h sq = sq

_⊡h'_ : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ a₂₀ a₂₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  {q₋₀ : a₁₀ == a₂₀} {q₋₁ : a₁₁ == a₂₁} {q₂₋ : a₂₀ == a₂₁}
  → Square p₀₋ p₋₀ p₋₁ p₁₋
  → Square p₁₋ q₋₀ q₋₁ q₂₋
  → Square p₀₋ (p₋₀ ∙' q₋₀) (p₋₁ ∙' q₋₁) q₂₋
sq ⊡h' ids = sq

_∙h⊡_ : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ p₀₋' : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
  {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  → p₀₋ == p₀₋'
  → Square p₀₋' p₋₀ p₋₁ p₁₋
  → Square p₀₋ p₋₀ p₋₁ p₁₋
idp ∙h⊡ sq = sq

_⊡h∙_ : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
  {p₋₁ : a₀₁ == a₁₁} {p₁₋ p₁₋' : a₁₀ == a₁₁}
  → Square p₀₋ p₋₀ p₋₁ p₁₋
  → p₁₋ == p₁₋'
  → Square p₀₋ p₋₀ p₋₁ p₁₋'
sq ⊡h∙ idp = sq

infixr 80 _⊡v_ _⊡v'_ _⊡h_ _⊡h'_

infixr 80 _∙v⊡_ _∙h⊡_
infixl 85 _⊡v∙_ _⊡h∙_

∙h⊡-hid-square-⊡h∙ : ∀ {i} {A : Type i} {a₀₀ a₀₁ : A} {p p' : a₀₀ == a₀₁}
  (q : p' == p)
  → ! q ∙h⊡ hid-square ⊡h∙ q == hid-square
∙h⊡-hid-square-⊡h∙ q@idp = idp

∙v⊡-assoc : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₋₀ p₋₀' p₋₀'' : a₀₀ == a₁₀} {p₀₋ : a₀₀ == a₀₁}
  {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  (q : p₋₀ == p₋₀')
  (r : p₋₀' == p₋₀'')
  (sq : Square p₀₋ p₋₀'' p₋₁ p₁₋)
  → (q ∙ r) ∙v⊡ sq == q ∙v⊡ (r ∙v⊡ sq)
∙v⊡-assoc q@idp r sq = idp

⊡v∙-assoc : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₋₀ : a₀₀ == a₁₀} {p₀₋ : a₀₀ == a₀₁}
  {p₋₁ p₋₁' p₋₁'' : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
  (q : p₋₁ == p₋₁')
  (r : p₋₁' == p₋₁'')
  → (sq ⊡v∙ q) ⊡v∙ r == sq ⊡v∙ (q ∙ r)
⊡v∙-assoc sq q@idp r = idp

⊡h∙-assoc : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₋₀ : a₀₀ == a₁₀} {p₀₋ : a₀₀ == a₀₁}
  {p₋₁ : a₀₁ == a₁₁} {p₁₋ p₁₋' p₁₋'' : a₁₀ == a₁₁}
  (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
  (q : p₁₋ == p₁₋')
  (r : p₁₋' == p₁₋'')
  → (sq ⊡h∙ q) ⊡h∙ r == sq ⊡h∙ (q ∙ r)
⊡h∙-assoc sq q@idp r = idp

∙v⊡-⊡h∙-comm : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₋₀ p₋₀' : a₀₀ == a₁₀} {p₀₋ : a₀₀ == a₀₁}
  {p₋₁ : a₀₁ == a₁₁} {p₁₋ p₁₋' : a₁₀ == a₁₁}
  (q : p₋₀ == p₋₀')
  (sq : Square p₀₋ p₋₀' p₋₁ p₁₋)
  (r : p₁₋ == p₁₋')
  → (q ∙v⊡ sq) ⊡h∙ r == q ∙v⊡ (sq ⊡h∙ r)
∙v⊡-⊡h∙-comm q@idp sq r = idp

⊡v∙-⊡h∙-comm : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₋₀ : a₀₀ == a₁₀} {p₀₋ : a₀₀ == a₀₁}
  {p₋₁ p₋₁' : a₀₁ == a₁₁} {p₁₋ p₁₋' : a₁₀ == a₁₁}
  (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
  (q : p₋₁ == p₋₁')
  (r : p₁₋ == p₁₋')
  → (sq ⊡v∙ q) ⊡h∙ r == (sq ⊡h∙ r) ⊡v∙ q
⊡v∙-⊡h∙-comm sq q@idp r = idp

∙v⊡-⊡v∙-comm : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₋₀ p₋₀' : a₀₀ == a₁₀} {p₀₋ : a₀₀ == a₀₁}
  {p₋₁ p₋₁' : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  (q : p₋₀ == p₋₀')
  (sq : Square p₀₋ p₋₀' p₋₁ p₁₋)
  (r : p₋₁ == p₋₁')
  → (q ∙v⊡ sq) ⊡v∙ r == q ∙v⊡ (sq ⊡v∙ r)
∙v⊡-⊡v∙-comm q@idp sq r = idp

∙h⊡-⊡h∙-comm : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₋₀ : a₀₀ == a₁₀} {p₀₋ p₀₋' : a₀₀ == a₀₁}
  {p₋₁ : a₀₁ == a₁₁} {p₁₋ p₁₋' : a₁₀ == a₁₁}
  (q : p₀₋ == p₀₋')
  (sq : Square p₀₋' p₋₀ p₋₁ p₁₋)
  (r : p₁₋ == p₁₋')
  → (q ∙h⊡ sq) ⊡h∙ r == q ∙h⊡ (sq ⊡h∙ r)
∙h⊡-⊡h∙-comm q@idp sq r = idp

⊡h-⊡v∙-comm : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ a₂₀ a₂₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ p₋₁' : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  {q₋₀ : a₁₀ == a₂₀} {q₋₁ q₋₁' : a₁₁ == a₂₁} {q₂₋ : a₂₀ == a₂₁}
  (p-sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
  (q-sq : Square p₁₋ q₋₀ q₋₁ q₂₋)
  (r : p₋₁ == p₋₁')
  (s : q₋₁ == q₋₁')
  → (p-sq ⊡h q-sq) ⊡v∙ (ap2 _∙_ r s) == (p-sq ⊡v∙ r) ⊡h (q-sq ⊡v∙ s)
⊡h-⊡v∙-comm p-sq q-sq r@idp s@idp = idp

module _ {i j} {A : Type i} {B : Type j} (f : A → B) where

  ap-square-∙v⊡ : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₋₀ p₋₀' : a₀₀ == a₁₀} {p₀₋ : a₀₀ == a₀₁}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (q : p₋₀ == p₋₀')
    (sq : Square p₀₋ p₋₀' p₋₁ p₁₋)
    → ap (ap f) q ∙v⊡ ap-square f sq == ap-square f (q ∙v⊡ sq)
  ap-square-∙v⊡ q@idp sq = idp

  ap-square-⊡v∙ : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₋₀ : a₀₀ == a₁₀} {p₀₋ : a₀₀ == a₀₁}
    {p₋₁ p₋₁' : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    (q : p₋₁ == p₋₁')
    → ap-square f sq ⊡v∙ ap (ap f) q == ap-square f (sq ⊡v∙ q)
  ap-square-⊡v∙ sq q@idp = idp

module _ {i j} {A : Type i} {B : Type j} {f g : A → B} where

  ↓-='-to-square : {x y : A} {p : x == y} {u : f x == g x} {v : f y == g y}
    → u == v [ (λ z → f z == g z) ↓ p ]
    → Square u (ap f p) (ap g p) v
  ↓-='-to-square {p = idp} α = horiz-degen-square α

  ↓-='-from-square : {x y : A} {p : x == y} {u : f x == g x} {v : f y == g y}
    → Square u (ap f p) (ap g p) v
    → u == v [ (λ z → f z == g z) ↓ p ]
  ↓-='-from-square {p = idp} sq = horiz-degen-path sq

  ↓-='-square-comp : {x y z : A} {p : x == y} {q : y == z}
    {u : f x == g x} {v : f y == g y} {w : f z == g z}
    → Square u (ap f p) (ap g p) v
    → Square v (ap f q) (ap g q) w
    → Square u (ap f (p ∙ q)) (ap g (p ∙ q)) w
  ↓-='-square-comp {p = idp} {q = idp} sq₁ sq₂ =
    horiz-degen-square (horiz-degen-path sq₁ ∙ horiz-degen-path sq₂)

  ↓-='-from-square-comp : {x y z : A} {p : x == y} {q : y == z}
    {u : f x == g x} {v : f y == g y} {w : f z == g z}
    (sq₁ : Square u (ap f p) (ap g p) v)
    (sq₂ : Square v (ap f q) (ap g q) w)
    → ↓-='-from-square (↓-='-square-comp sq₁ sq₂) ==
      ↓-='-from-square sq₁ ∙ᵈ ↓-='-from-square sq₂
  ↓-='-from-square-comp {p = idp} {q = idp} sq₁ sq₂ =
    horiz-degen-path-β _

  private
    custom-square-over :
      {x y z : A} {p : x == y} {q : y == z} {r : x == z}
      (comp : r == p ∙ q)
      {u : f x == g x} {v : f y == g y} {w : f z == g z}
      (p-sq : Square u (ap f p) (ap g p) v)
      (q-sq : Square v (ap f q) (ap g q) w)
      (r-sq : Square u (ap f r) (ap g r) w)
      → r-sq ⊡v∙ ap (ap g) comp ==
        ap (ap f) comp ∙v⊡ ↓-='-square-comp p-sq q-sq
      → r-sq == ↓-='-square-comp p-sq q-sq
          [ (λ s → Square u (ap f s) (ap g s) w) ↓ comp ]
    custom-square-over {p = idp} {q = idp} {r = .idp} idp p-sq q-sq r-sq e = e

  ↓-='-from-square-comp-path :
    {x y z : A} {p : x == y} {q : y == z} {r : x == z}
    (comp : r == p ∙ q)
    {u : f x == g x} {v : f y == g y} {w : f z == g z}
    (p-sq : Square u (ap f p) (ap g p) v)
    (q-sq : Square v (ap f q) (ap g q) w)
    (r-sq : Square u (ap f r) (ap g r) w)
    → r-sq ⊡v∙ ap (ap g) comp ==
      ap (ap f) comp ∙v⊡ ↓-='-square-comp p-sq q-sq
    → ↓-='-from-square r-sq == ↓-='-from-square p-sq ∙ᵈ ↓-='-from-square q-sq
        [ (λ p → u == w [ (λ x → f x == g x) ↓ p ]) ↓ comp ]
  ↓-='-from-square-comp-path comp p-sq q-sq r-sq e =
    ap↓ ↓-='-from-square (custom-square-over comp p-sq q-sq r-sq e) ▹
    ↓-='-from-square-comp p-sq q-sq

↓-='-from-square-! : ∀ {i j} {A : Type i} {B : Type j} {f g : A → B}
  {x y : A} {p : x == y} {u : f x == g x} {v : f y == g y}
  (sq : Square u (ap f p) (ap g p) v)
  → ap↓ ! (↓-='-from-square sq) == ↓-='-from-square (!□v sq)
↓-='-from-square-! {p = idp} sq =
  ap ! (horiz-degen-path sq)
    =⟨ ! (horiz-degen-path-β (ap ! (horiz-degen-path sq))) ⟩
  horiz-degen-path (horiz-degen-square (ap ! (horiz-degen-path sq)))
    =⟨ ap horiz-degen-path (! (!□v-horiz-degen-square (horiz-degen-path sq))) ⟩
  horiz-degen-path (!□v (horiz-degen-square (horiz-degen-path sq)))
    =⟨ ap (horiz-degen-path ∘ !□v) (horiz-degen-square-β sq) ⟩
  horiz-degen-path (!□v sq) =∎

↓-='-from-square-post-∘ : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k}
  {f g : A → B} {h : B → C}
  {x y : A} {p : x == y} {u : f x == g x} {v : f y == g y}
  → (sq : Square u (ap f p) (ap g p) v)
  → ap↓ (ap h) (↓-='-from-square sq)
    ==
    ↓-='-from-square (ap-∘ h f p ∙v⊡ ap-square h sq ⊡v∙ ∘-ap h g p)
↓-='-from-square-post-∘ {h = h} {p = idp} sq =
  ap (ap h) (horiz-degen-path sq)
    =⟨ ! (horiz-degen-path-β (ap (ap h) (horiz-degen-path sq))) ⟩
  horiz-degen-path (horiz-degen-square (ap (ap h) (horiz-degen-path sq)))
    =⟨ ap horiz-degen-path (! (ap-horiz-degen-square h (horiz-degen-path sq))) ⟩
  horiz-degen-path (ap-square h (horiz-degen-square (horiz-degen-path sq)))
    =⟨ ap (horiz-degen-path ∘ ap-square h) (horiz-degen-square-β sq) ⟩
  horiz-degen-path (ap-square h sq) =∎

module _ {i j} {A : Type i} {B : Type j} where

  natural-square : {f₁ f₂ : A → B} (h : ∀ a → f₁ a == f₂ a)
    {a₁ a₂ : A} (q : a₁ == a₂)
    → Square (h a₁) (ap f₁ q) (ap f₂ q) (h a₂)
  natural-square h idp = hid-square

  natural-square-path : {f₁ f₂ : A → B} (h h' : ∀ a → f₁ a == f₂ a)
    (H : ∀ a → h' a == h a)
    {a₁ a₂ : A} (q : a₁ == a₂)
    → ! (H a₁) ∙h⊡ natural-square h' q ⊡h∙ H a₂ == natural-square h q
  natural-square-path h h' H {a₁} idp = ∙h⊡-hid-square-⊡h∙ (H a₁)

  natural-square-idp : {f₁ : A → B} {a₁ a₂ : A} (q : a₁ == a₂)
    → natural-square {f₁ = f₁} (λ _ → idp) q == vid-square
  natural-square-idp idp = idp

  natural-square-cst : ∀ (b₁ b₂ : B) (h : A → b₁ == b₂)
    {a₁ a₂ : A} (q : a₁ == a₂)
    → ! (ap-cst b₁ q) ∙v⊡ natural-square {f₁ = λ a → b₁} {f₂ = λ a → b₂} h q ⊡v∙ ap-cst b₂ q
      ==
      horiz-degen-square (ap h q)
  natural-square-cst b₁ b₂ h q@idp = ! horiz-degen-square-idp

  {- Used for getting square equivalents of glue-β terms -}
  natural-square-β : {f₁ f₂ : A → B} (h : (a : A) → f₁ a == f₂ a)
    {x y : A} (q : x == y)
    {sq : Square (h x) (ap f₁ q) (ap f₂ q) (h y)}
    → apd h q == ↓-='-from-square sq
    → natural-square h q == sq
  natural-square-β _ idp α =
    ! horiz-degen-square-idp ∙ ap horiz-degen-square α ∙ horiz-degen-square-β _

module _ {i j k} {A : Type i} {B : Type j} {C : Type k} where

  natural-square-ap : (g : B → C)
    {f₁ f₂ : A → B} (h : ∀ a → f₁ a == f₂ a)
    {a₁ a₂ : A} (q : a₁ == a₂)
    → natural-square (ap g ∘ h) q
      ==
      ap-∘ g f₁ q ∙v⊡
      ap-square g (natural-square h q) ⊡v∙
      ∘-ap g f₂ q
  natural-square-ap g h q@idp = ! ap-square-hid

  natural-square-symmetry : (f : A → B → C)
    {a₁ a₂ : A} (p : a₁ == a₂)
    {b₁ b₂ : B} (q : b₁ == b₂)
    → square-symmetry (natural-square (λ b → ap (λ a → f a b) p) q)
      ==
      natural-square (λ a → ap (f a) q) p
  natural-square-symmetry f p@idp q@idp = idp

module _ {i} {A : Type i} where

  horiz-degen-path-⊡h : {a a' : A} {p q r : a == a'}
    (sq₁ : Square p idp idp q)
    (sq₂ : Square q idp idp r)
    → horiz-degen-path (sq₁ ⊡h sq₂) ==
      horiz-degen-path sq₁ ∙ horiz-degen-path sq₂
  horiz-degen-path-⊡h {p = idp} {q = .idp} ids sq₂ = idp

  vert-degen-square-⊡v∙ : {a a' : A} {p q r : a == a'}
    → (s : p == q) (t : q == r)
    → vert-degen-square s ⊡v∙ t == vert-degen-square (s ∙ t)
  vert-degen-square-⊡v∙ idp idp = idp

  vert-degen-square-∙v⊡ : {a a' : A} {p q r : a == a'}
    → (s : p == q) (t : q == r)
    → s ∙v⊡ vert-degen-square t == vert-degen-square (s ∙ t)
  vert-degen-square-∙v⊡ idp idp = idp

  vert-degen-square-⊡h : {a a' a'' : A}
    {p p' : a == a'} {q q' : a' == a''}
    (s : p == p') (t : q == q')
    → vert-degen-square s ⊡h vert-degen-square t ==
      vert-degen-square (ap2 _∙_ s t)
  vert-degen-square-⊡h {p = idp} idp idp = idp

module _ {i j} {A : Type i} {B : Type j} {f g : A → B} where

  ↓-='-square-comp' : {x y z : A} {p : x == y} {q : y == z}
    {u : f x == g x} {v : f y == g y} {w : f z == g z}
    → Square u (ap f p) (ap g p) v
    → Square v (ap f q) (ap g q) w
    → Square u (ap f (p ∙ q)) (ap g (p ∙ q)) w
  ↓-='-square-comp' {p = p} {q = q} sq₁ sq₂ =
    ap-∙ f p q ∙v⊡ ((sq₁ ⊡h sq₂) ⊡v∙ ∙-ap g p q)

  ↓-='-square-comp'=↓-='-square-comp : {x y z : A} {p : x == y} {q : y == z}
    {u : f x == g x} {v : f y == g y} {w : f z == g z}
    → (sq₁ : Square u (ap f p) (ap g p) v)
    → (sq₂ : Square v (ap f q) (ap g q) w)
    → ↓-='-square-comp' sq₁ sq₂ == ↓-='-square-comp sq₁ sq₂
  ↓-='-square-comp'=↓-='-square-comp {p = idp} {q = idp} sq₁ sq₂ =
    ↓-='-square-comp' sq₁ sq₂
      =⟨ idp ⟩
    sq₁ ⊡h sq₂
      =⟨ ! (horiz-degen-square-β (sq₁ ⊡h sq₂)) ⟩
    horiz-degen-square (horiz-degen-path (sq₁ ⊡h sq₂))
      =⟨ ap horiz-degen-square (horiz-degen-path-⊡h sq₁ sq₂) ⟩
    horiz-degen-square (horiz-degen-path sq₁ ∙ horiz-degen-path sq₂) =∎

module _ {i} {A : Type i} where

  {- TODO rest of these -}

  ⊡h-unit-l : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    → hid-square ⊡h sq == sq
  ⊡h-unit-l ids = idp

  ⊡h-unit-r : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    → sq ⊡h hid-square == ∙-unit-r _ ∙v⊡ (sq ⊡v∙ ! (∙-unit-r _))
  ⊡h-unit-r ids = idp

  ⊡h'-unit-l : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    → hid-square ⊡h' sq == ∙'-unit-l _ ∙v⊡ (sq ⊡v∙ ! (∙'-unit-l _))
  ⊡h'-unit-l ids = idp

  ⊡h-unit-l-unique : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq' : Square p₀₋ idp idp p₀₋) (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    → sq' ⊡h sq == sq
    → sq' == hid-square
  ⊡h-unit-l-unique sq' ids p = ! (⊡h-unit-r sq') ∙ p

module _ {i} {A : Type i} where
  !□h-inv-l : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    → (!□h sq) ⊡h sq == !-inv-l p₋₀ ∙v⊡ (hid-square ⊡v∙ ! (!-inv-l p₋₁))
  !□h-inv-l ids = idp

  !□h-inv-r : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    → sq ⊡h (!□h sq) == !-inv-r p₋₀ ∙v⊡ (hid-square ⊡v∙ ! (!-inv-r p₋₁))
  !□h-inv-r ids = idp

  !□v-inv-l : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    → (!□v sq) ⊡v sq == !-inv-l p₀₋ ∙h⊡ (vid-square ⊡h∙ ! (!-inv-l p₁₋))
  !□v-inv-l ids = idp

  !□v-inv-r : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    → sq ⊡v (!□v sq) == !-inv-r p₀₋ ∙h⊡ (vid-square ⊡h∙ ! (!-inv-r p₁₋))
  !□v-inv-r ids = idp

module _ {i} {A : Type i} where
  square-left-unique : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ p₀₋' : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    → Square p₀₋ p₋₀ p₋₁ p₁₋ → Square p₀₋' p₋₀ p₋₁ p₁₋
    → p₀₋ == p₀₋'
  square-left-unique {p₋₀ = idp} {p₋₁ = idp} sq₁ sq₂ =
    horiz-degen-path (sq₁ ⊡h (!□h sq₂))

  square-top-unique : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ p₋₀' : a₀₀ == a₁₀}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    → Square p₀₋ p₋₀ p₋₁ p₁₋ → Square p₀₋ p₋₀' p₋₁ p₁₋
    → p₋₀ == p₋₀'
  square-top-unique {p₀₋ = idp} {p₁₋ = idp} sq₁ sq₂ =
    vert-degen-path (sq₁ ⊡v (!□v sq₂))

  square-bot-unique : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
    {p₋₁ p₋₁' : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    → Square p₀₋ p₋₀ p₋₁ p₁₋ → Square p₀₋ p₋₀ p₋₁' p₁₋
    → p₋₁ == p₋₁'
  square-bot-unique {p₀₋ = idp} {p₁₋ = idp} sq₁ sq₂ =
    vert-degen-path ((!□v sq₁) ⊡v sq₂)

  square-right-unique : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ p₁₋' : a₁₀ == a₁₁}
    → Square p₀₋ p₋₀ p₋₁ p₁₋ → Square p₀₋ p₋₀ p₋₁ p₁₋'
    → p₁₋ == p₁₋'
  square-right-unique {p₋₀ = idp} {p₋₁ = idp} sq₁ sq₂ =
    horiz-degen-path ((!□h sq₁) ⊡h sq₂)

module _ {i} {A : Type i} where

  {- XXX naminig -}
  connection : {a₀ a₁ : A} {q : a₀ == a₁}
    → Square idp idp q q
  connection {q = idp} = ids

  {- XXX naminig -}
  connection2 : {a₀ a₁ a₂ : A} {p : a₀ == a₁} {q : a₁ == a₂}
    → Square p p q q
  connection2 {p = idp} {q = idp} = ids

  lb-square : {a₀ a₁ : A} (p : a₀ == a₁)
    → Square p idp (! p) idp
  lb-square idp = ids

  bl-square : {a₀ a₁ : A} (p : a₀ == a₁)
    → Square (! p) idp p idp
  bl-square idp = ids

  br-square : {a₀ a₁ : A} (p : a₀ == a₁)
    → Square idp idp p p
  br-square idp = ids

  rb-square = br-square

  rt-square : {a₀ a₁ : A} (p : a₀ == a₁)
    → Square idp (! p) idp p
  rt-square idp = ids

  tr-square : {a₀ a₁ : A} (p : a₀ == a₁)
    → Square idp p idp (! p)
  tr-square idp = ids

  lt-square : {a₀ a₁ : A} (p : a₀ == a₁)
    → Square p p idp idp
  lt-square idp = ids

  tl-square = lt-square

  tr-square-∙v⊡-⊡h∙ : {a₀ a₁ : A} {p p' : a₀ == a₁} (r : p == p')
    → ! r ∙v⊡ tr-square p ⊡h∙ ap ! r == tr-square p'
  tr-square-∙v⊡-⊡h∙ r@idp = idp

  tr-square-! : {a₀ a₁ : A} (p : a₀ == a₁)
    → tr-square (! p) ⊡h∙ !-! p == rt-square p
  tr-square-! p@idp = idp

module _ {i} {j} {A : Type i} {B : Type j} (f : A → B) where

  ap-tr-square : {a₀ a₁ : A} (p : a₀ == a₁)
    → ap-square f (tr-square p) ⊡h∙ ap-! f p == tr-square (ap f p)
  ap-tr-square p@idp = idp


module Itse.Checking where

open import Itse.Grammar
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Data.Unit
open import Data.Bool
open import Data.List hiding (lookup)
open import Data.Product
open import Data.Maybe

{-
# Checking

-}

{-
## Context

-}

data Context : Set
Closure : Set

infixr 6 _⦂_,_ [_],_

data Context where
  ∅ : Context
  _⦂_,_ : ∀ {e} → Name e → Expr (TypeOf e) → Context → Context
  [_],_ : Closure → Context → Context

{-
## Closure

-}

Closure = List (∃[ e ] (Name e × Expr e × Expr (TypeOf e)))

lookup-μ : ∀ {e} → Name e → Closure → Maybe (Expr e × Expr (TypeOf e))
lookup-μ {p} ξ []                    = nothing
lookup-μ {p} ξ ((p , υ , α , A) ∷ μ) with ξ ≟-Name υ
lookup-μ {p} ξ ((p , υ , α , A) ∷ μ)    | yes refl = just (α , A)
lookup-μ {p} ξ ((p , υ , α , A) ∷ μ)    | no  _    = lookup-μ ξ μ
lookup-μ {p} ξ ((t , _)         ∷ μ) = lookup-μ ξ μ
lookup-μ {t} x []                    = nothing
lookup-μ {t} x ((p , _)         ∷ μ) = lookup-μ x μ
lookup-μ {t} x ((t , y , a , α) ∷ μ) with x ≟-Name y
lookup-μ {t} x ((t , y , a , α) ∷ μ)    | yes refl = just (a , α)
lookup-μ {t} x ((t , y , a , α) ∷ μ)    | no  _    = lookup-μ x μ

lookup : ∀ {e} → Name e → Context → Maybe (Expr e × Expr (TypeOf e))
lookup x ∅ = nothing
lookup x (_ ⦂ _ , Γ) = lookup x Γ
lookup x ([ μ  ], Γ) = lookup-μ x μ

{-
## Substitution

-}

infix 6 ⟦_↦_⟧_

⟦_↦_⟧_ : ∀ {e e′} → Name e → Expr e → Expr e′ → Expr e′
⟦_↦_⟧_ = {!!}

{-
## Wellformed-ness

-}

infix 5 _⊢wf _⊢_ok _⊢_⦂_

data _⊢wf : Context → Set
data _⊢_ok : Context → Closure → Set
data _⊢_⦂_ : ∀ {e} → Context → Expr e → Expr (TypeOf e) → Set

data _⊢wf where

  ∅⊢wf :
    ∅ ⊢wf

  judgeₚ : ∀ {Γ} {X : Kind} {ξ} →
    Γ ⊢wf →
    Γ ⊢ X ⦂ `□ₛ →
    ----
    ξ ⦂ X , Γ ⊢wf

  judgeₜ : ∀ {Γ} {ξ : Type} {x : Nameₜ} →
    Γ ⊢wf →
    Γ ⊢ ξ ⦂ `●ₖ →
    ----
    x ⦂ ξ , Γ ⊢wf

  closure : ∀ {Γ} {μ} →
    Γ ⊢wf →
    Γ ⊢ μ ok →
    [ μ ], Γ ⊢wf

-- Closure = List (∃[ e ] ∃[ e≢k ] (Name e × Expr e × Expr (TypeOf e {e≢k})))
data _⊢_ok where

  -- type :
  --   Γ ⊢ μ ok →
  --   [ μ ], Γ ⊢

data _⊢_⦂_ where

  -- sorting (well-formed kinds)

  ●ₖ : ∀ {Γ} →
    Γ ⊢ `●ₖ ⦂ `□ₛ

  λₖₚ-intro : ∀ {Γ} {ξ} {X A} →
    ξ ⦂ X , Γ ⊢ A ⦂ `□ₛ →
    Γ ⊢ X ⦂ `□ₛ →
    ----
    Γ ⊢ `λₖₚ[ ξ ⦂ X ] A ⦂ `□ₛ

  λₖₜ-intro : ∀ {Γ} {ξ} {A} {x} →
    x ⦂ ξ , Γ ⊢ A ⦂ `□ₛ →
    Γ ⊢ ξ ⦂ `●ₖ →
    ----
    Γ ⊢ `λₖₜ[ x ⦂ ξ ] A ⦂ `□ₛ

  -- kinding

  λₚₚ-intro : ∀ {Γ} {X} {β} {ξ} →
    Γ ⊢ X ⦂ `□ₛ →
    ξ ⦂ X , Γ ⊢ β ⦂ `●ₖ →
    ----
    Γ ⊢ `λₚₚ[ ξ ⦂ X ] β ⦂ `λₖₚ[ ξ ⦂ X ] `●ₖ

  λₚₜ-intro : ∀ {Γ} {ξ} {β} {x} →
    Γ ⊢ ξ ⦂ `●ₖ →
    x ⦂ ξ , Γ ⊢ β ⦂ `●ₖ →
    ----
    Γ ⊢ `λₚₜ[ x ⦂ ξ ] β ⦂ `λₖₜ[ x ⦂ ξ ] `●ₖ

  λₚₚ-elim : ∀ {Γ} {A B} {ξ φ α} →
    Γ ⊢ φ ⦂ `λₖₚ[ ξ ⦂ A ] B →
    Γ ⊢ α ⦂ A →
    ----
    Γ ⊢ φ `∙ₚₚ α ⦂ B

  λₚₜ-elim : ∀ {Γ} {B} {φ α} {a} {x} →
    Γ ⊢ φ ⦂ `λₖₜ[ x ⦂ α ] B →
    Γ ⊢ a ⦂ α →
    ----
    Γ ⊢ φ `∙ₚₜ a ⦂ B

  -- typing

  λₜₚ-intro : ∀ {Γ} {X} {α} {a} {ξ} →
    Γ ⊢ X ⦂ `□ₛ →
    ξ ⦂ X , Γ ⊢ a ⦂ α →
    ----
    Γ ⊢ `λₜₚ[ ξ ⦂ X ] a ⦂ `λₚₚ[ ξ ⦂ X ] α

  λₜₜ-intro : ∀ {Γ} {α ξ} {a} {x} →
    Γ ⊢ α ⦂ `●ₖ →
    x ⦂ ξ , Γ ⊢ a ⦂ α →
    ----
    Γ ⊢ `λₜₜ[ x ⦂ ξ ] a ⦂ `λₚₜ[ x ⦂ ξ ] α

  λₜₚ-elim : ∀ {Γ} {A} {α β} {f} {ξ} →
    Γ ⊢ f ⦂ `λₚₚ[ ξ ⦂ A ] β →
    Γ ⊢ α ⦂ A →
    ----
    Γ ⊢ f `∙ₜₚ α ⦂ β

  λₜₜ-elim : ∀ {Γ} {α β} {f a x} →
    Γ ⊢ f ⦂ `λₚₜ[ x ⦂ α ] β →
    Γ ⊢ a ⦂ α →
    ----
    Γ ⊢ f `∙ₜₜ a ⦂ β

  -- "SelfGen"
  ι-intro : ∀ {Γ} {α} {a} {x} →
    Γ ⊢ a ⦂ ⟦ x ↦ a ⟧ α →
    Γ ⊢ `ι[ x ] α ⦂ `●ₖ →
    ----
    Γ ⊢ a ⦂ `ι[ x ] α

  -- "SelfInst"
  ι-elim : ∀ {Γ} {α} {a} {x} →
    Γ ⊢ a ⦂ `ι[ x ] α →
    ----
    Γ ⊢ a ⦂ ⟦ x ↦ a ⟧ α


-- Andreas, 2017-01-21, issue #2424

-- {-# OPTIONS -v tc.cover:40 #-}
-- {-# OPTIONS -v interaction.case:40 #-}

postulate Nat : Set

data List : Set₁ where
  _∷_ : (x : Set) (xs : List) → List

test : (As : List) (x : Nat) → Set
test As x = {!As!} -- C-c C-c

-- Expected output:
--   test (x₁ ∷ As) x = {!!}


open import Agda.Builtin.Nat

record R : Set₁ where
  field f : Nat

open R ⦃ ... ⦄

foo : Nat → R
foo n .f = {!n!} -- C-c C-c makes clause disappear


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

module Dodo.Binary.Union where

-- Stdlib imports
open import Level using (Level; _⊔_)
open import Data.Sum using (_⊎_; inj₁; inj₂; swap)
open import Relation.Binary using (REL)
-- Local imports
open import Dodo.Binary.Equality

-- # Definitions

infixl 19 _∪₂_

_∪₂_ : {a b ℓ₁ ℓ₂ : Level} {A : Set a} {B : Set b}
  → REL A B ℓ₁
  → REL A B ℓ₂
  → REL A B (ℓ₁ ⊔ ℓ₂)
_∪₂_ p q x y = p x y ⊎ q x y

-- # Properties

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

  ∪₂-idem : (R ∪₂ R) ⇔₂ R
  ∪₂-idem = ⇔: ⊆-proof ⊇-proof
    where
    ⊆-proof : (R ∪₂ R) ⊆₂' R
    ⊆-proof _ _ (inj₁ Rxy) = Rxy
    ⊆-proof _ _ (inj₂ Rxy) = Rxy
    ⊇-proof : R ⊆₂' (R ∪₂ R)
    ⊇-proof _ _ = inj₁

module _ {a b ℓ₁ ℓ₂ : Level} {A : Set a} {B : Set b}
    {P : REL A B ℓ₁} {Q : REL A B ℓ₂} where

  ∪₂-comm : (P ∪₂ Q) ⇔₂ (Q ∪₂ P)
  ∪₂-comm = ⇔: (λ _ _ → swap) (λ _ _ → swap)

module _ {a b ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a} {B : Set b} {P : REL A B ℓ₁}
    {Q : REL A B ℓ₂} {R : REL A B ℓ₃} where

  ∪₂-assoc : (P ∪₂ Q) ∪₂ R ⇔₂ P ∪₂ (Q ∪₂ R)
  ∪₂-assoc = ⇔: ⊆-proof ⊇-proof
    where
    ⊆-proof : ((P ∪₂ Q) ∪₂ R) ⊆₂' (P ∪₂ (Q ∪₂ R))
    ⊆-proof _ _ (inj₁ (inj₁ Pxy)) = inj₁ Pxy
    ⊆-proof _ _ (inj₁ (inj₂ Qxy)) = inj₂ (inj₁ Qxy)
    ⊆-proof _ _ (inj₂ Rxy)        = inj₂ (inj₂ Rxy)
    ⊇-proof : (P ∪₂ (Q ∪₂ R)) ⊆₂' ((P ∪₂ Q) ∪₂ R)
    ⊇-proof _ _ (inj₁ Pxy)        = inj₁ (inj₁ Pxy)
    ⊇-proof _ _ (inj₂ (inj₁ Qxy)) = inj₁ (inj₂ Qxy)
    ⊇-proof _ _ (inj₂ (inj₂ Rxy)) = inj₂ Rxy

-- # Operations

-- ## Operations: ⊆₂

module _ {a b ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a} {B : Set b}
    {P : REL A B ℓ₁} {Q : REL A B ℓ₂} {R : REL A B ℓ₃} where

  ∪₂-combine-⊆₂ : P ⊆₂ Q → R ⊆₂ Q → (P ∪₂ R) ⊆₂ Q
  ∪₂-combine-⊆₂ (⊆: P⊆Q) (⊆: R⊆Q) = ⊆: (λ{x y → λ{(inj₁ Px) → P⊆Q x y Px; (inj₂ Rx) → R⊆Q x y Rx}})

module _ {a b ℓ₁ ℓ₂ : Level} {A : Set a} {B : Set b}
    {P : REL A B ℓ₁} {Q : REL A B ℓ₂} where

  ∪₂-introˡ : P ⊆₂ (Q ∪₂ P)
  ∪₂-introˡ = ⊆: λ{_ _ → inj₂}

  ∪₂-introʳ : P ⊆₂ (P ∪₂ Q)
  ∪₂-introʳ = ⊆: λ{_ _ → inj₁}

module _ {a b ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a} {B : Set b}
    {P : REL A B ℓ₁} {Q : REL A B ℓ₂} {R : REL A B ℓ₃} where

  ∪₂-introˡ-⊆₂ : P ⊆₂ R → P ⊆₂ (Q ∪₂ R)
  ∪₂-introˡ-⊆₂ (⊆: P⊆R) = ⊆: (λ x y Pxy → inj₂ (P⊆R x y Pxy))

  ∪₂-introʳ-⊆₂ : P ⊆₂ Q → P ⊆₂ (Q ∪₂ R)
  ∪₂-introʳ-⊆₂ (⊆: P⊆Q) = ⊆: (λ x y Pxy → inj₁ (P⊆Q x y Pxy))

  ∪₂-elimˡ-⊆₂ : (P ∪₂ Q) ⊆₂ R → Q ⊆₂ R
  ∪₂-elimˡ-⊆₂ (⊆: [P∪Q]⊆R) = ⊆: (λ x y Qxy → [P∪Q]⊆R x y (inj₂ Qxy))

  ∪₂-elimʳ-⊆₂ : (P ∪₂ Q) ⊆₂ R → P ⊆₂ R
  ∪₂-elimʳ-⊆₂ (⊆: [P∪Q]⊆R) = ⊆: (λ x y Pxy → [P∪Q]⊆R x y (inj₁ Pxy))

module _ {a b ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a} {B : Set b}
    {P : REL A B ℓ₁} {Q : REL A B ℓ₂} {R : REL A B ℓ₃} where

  ∪₂-substˡ-⊆₂ : P ⊆₂ Q → (P ∪₂ R) ⊆₂ (Q ∪₂ R)
  ∪₂-substˡ-⊆₂ (⊆: P⊆Q) = ⊆: (λ{x y → λ{(inj₁ Pxy) → inj₁ (P⊆Q x y Pxy); (inj₂ Rxy) → inj₂ Rxy}})

  ∪₂-substʳ-⊆₂ : P ⊆₂ Q → (R ∪₂ P) ⊆₂ (R ∪₂ Q)
  ∪₂-substʳ-⊆₂ (⊆: P⊆Q) = ⊆: (λ{x y → λ{(inj₁ Rxy) → inj₁ Rxy; (inj₂ Pxy) → inj₂ (P⊆Q x y Pxy)}})

-- ## Operations: ⇔₂

module _ {a b ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a} {B : Set b}
    {P : REL A B ℓ₁} {Q : REL A B ℓ₂} {R : REL A B ℓ₃} where

  ∪₂-substˡ : P ⇔₂ Q → (P ∪₂ R) ⇔₂ (Q ∪₂ R)
  ∪₂-substˡ = ⇔₂-compose ∪₂-substˡ-⊆₂ ∪₂-substˡ-⊆₂

  ∪₂-substʳ : P ⇔₂ Q → (R ∪₂ P) ⇔₂ (R ∪₂ Q)
  ∪₂-substʳ = ⇔₂-compose ∪₂-substʳ-⊆₂ ∪₂-substʳ-⊆₂


-- Intuitionistic propositional calculus.
-- Hilbert-style formalisation of syntax.
-- Nested terms.

module IPC.Syntax.Hilbert where

open import IPC.Syntax.Common public

-- Derivations.

infix 3 _⊢_
data _⊢_ (Γ : Cx Ty) : Ty → Set where
  var   : ∀ {A}     → A ∈ Γ → Γ ⊢ A
  app   : ∀ {A B}   → Γ ⊢ A ▻ B → Γ ⊢ A → Γ ⊢ B
  ci    : ∀ {A}     → Γ ⊢ A ▻ A
  ck    : ∀ {A B}   → Γ ⊢ A ▻ B ▻ A
  cs    : ∀ {A B C} → Γ ⊢ (A ▻ B ▻ C) ▻ (A ▻ B) ▻ A ▻ C
  cpair : ∀ {A B}   → Γ ⊢ A ▻ B ▻ A ∧ B
  cfst  : ∀ {A B}   → Γ ⊢ A ∧ B ▻ A
  csnd  : ∀ {A B}   → Γ ⊢ A ∧ B ▻ B
  unit  : Γ ⊢ ⊤
  cboom : ∀ {C}     → Γ ⊢ ⊥ ▻ C
  cinl  : ∀ {A B}   → Γ ⊢ A ▻ A ∨ B
  cinr  : ∀ {A B}   → Γ ⊢ B ▻ A ∨ B
  ccase : ∀ {A B C} → Γ ⊢ A ∨ B ▻ (A ▻ C) ▻ (B ▻ C) ▻ C

infix 3 _⊢⋆_
_⊢⋆_ : Cx Ty → Cx Ty → Set
Γ ⊢⋆ ∅     = 𝟙
Γ ⊢⋆ Ξ , A = Γ ⊢⋆ Ξ × Γ ⊢ A

-- Monotonicity with respect to context inclusion.

mono⊢ : ∀ {A Γ Γ′} → Γ ⊆ Γ′ → Γ ⊢ A → Γ′ ⊢ A
mono⊢ η (var i)   = var (mono∈ η i)
mono⊢ η (app t u) = app (mono⊢ η t) (mono⊢ η u)
mono⊢ η ci        = ci
mono⊢ η ck        = ck
mono⊢ η cs        = cs
mono⊢ η cpair     = cpair
mono⊢ η cfst      = cfst
mono⊢ η csnd      = csnd
mono⊢ η unit      = unit
mono⊢ η cboom     = cboom
mono⊢ η cinl      = cinl
mono⊢ η cinr      = cinr
mono⊢ η ccase     = ccase

mono⊢⋆ : ∀ {Γ″ Γ Γ′} → Γ ⊆ Γ′ → Γ ⊢⋆ Γ″ → Γ′ ⊢⋆ Γ″
mono⊢⋆ {∅}      η ∙        = ∙
mono⊢⋆ {Γ″ , A} η (ts , t) = mono⊢⋆ η ts , mono⊢ η t

-- Shorthand for variables.

v₀ : ∀ {A Γ} → Γ , A ⊢ A
v₀ = var i₀

v₁ : ∀ {A B Γ} → Γ , A , B ⊢ A
v₁ = var i₁

v₂ : ∀ {A B C Γ} → Γ , A , B , C ⊢ A
v₂ = var i₂

-- Reflexivity.

refl⊢⋆ : ∀ {Γ} → Γ ⊢⋆ Γ
refl⊢⋆ {∅}     = ∙
refl⊢⋆ {Γ , A} = mono⊢⋆ weak⊆ refl⊢⋆ , v₀

-- Deduction theorem.

lam : ∀ {A B Γ} → Γ , A ⊢ B → Γ ⊢ A ▻ B
lam (var top)     = ci
lam (var (pop i)) = app ck (var i)
lam (app t u)     = app (app cs (lam t)) (lam u)
lam ci            = app ck ci
lam ck            = app ck ck
lam cs            = app ck cs
lam cpair         = app ck cpair
lam cfst          = app ck cfst
lam csnd          = app ck csnd
lam unit          = app ck unit
lam cboom         = app ck cboom
lam cinl          = app ck cinl
lam cinr          = app ck cinr
lam ccase         = app ck ccase

lam⋆ : ∀ {Ξ Γ A} → Γ ⧺ Ξ ⊢ A → Γ ⊢ Ξ ▻⋯▻ A
lam⋆ {∅}     = I
lam⋆ {Ξ , B} = lam⋆ {Ξ} ∘ lam

lam⋆₀ : ∀ {Γ A} → Γ ⊢ A → ∅ ⊢ Γ ▻⋯▻ A
lam⋆₀ {∅}     = I
lam⋆₀ {Γ , B} = lam⋆₀ ∘ lam

-- Detachment theorem.

det : ∀ {A B Γ} → Γ ⊢ A ▻ B → Γ , A ⊢ B
det t = app (mono⊢ weak⊆ t) v₀

det⋆ : ∀ {Ξ Γ A} → Γ ⊢ Ξ ▻⋯▻ A → Γ ⧺ Ξ ⊢ A
det⋆ {∅}     = I
det⋆ {Ξ , B} = det ∘ det⋆ {Ξ}

det⋆₀ : ∀ {Γ A} → ∅ ⊢ Γ ▻⋯▻ A → Γ ⊢ A
det⋆₀ {∅}     = I
det⋆₀ {Γ , B} = det ∘ det⋆₀

-- Cut and multicut.

cut : ∀ {A B Γ} → Γ ⊢ A → Γ , A ⊢ B → Γ ⊢ B
cut t u = app (lam u) t

multicut : ∀ {Ξ A Γ} → Γ ⊢⋆ Ξ → Ξ ⊢ A → Γ ⊢ A
multicut {∅}     ∙        u = mono⊢ bot⊆ u
multicut {Ξ , B} (ts , t) u = app (multicut ts (lam u)) t

-- Transitivity.

trans⊢⋆ : ∀ {Γ″ Γ′ Γ} → Γ ⊢⋆ Γ′ → Γ′ ⊢⋆ Γ″ → Γ ⊢⋆ Γ″
trans⊢⋆ {∅}      ts ∙        = ∙
trans⊢⋆ {Γ″ , A} ts (us , u) = trans⊢⋆ ts us , multicut ts u

-- Contraction.

ccont : ∀ {A B Γ} → Γ ⊢ (A ▻ A ▻ B) ▻ A ▻ B
ccont = lam (lam (app (app v₁ v₀) v₀))

cont : ∀ {A B Γ} → Γ , A , A ⊢ B → Γ , A ⊢ B
cont t = det (app ccont (lam (lam t)))

-- Exchange, or Schönfinkel’s C combinator.

cexch : ∀ {A B C Γ} → Γ ⊢ (A ▻ B ▻ C) ▻ B ▻ A ▻ C
cexch = lam (lam (lam (app (app v₂ v₀) v₁)))

exch : ∀ {A B C Γ} → Γ , A , B ⊢ C → Γ , B , A ⊢ C
exch t = det (det (app cexch (lam (lam t))))

-- Composition, or Schönfinkel’s B combinator.

ccomp : ∀ {A B C Γ} → Γ ⊢ (B ▻ C) ▻ (A ▻ B) ▻ A ▻ C
ccomp = lam (lam (lam (app v₂ (app v₁ v₀))))

comp : ∀ {A B C Γ} → Γ , B ⊢ C → Γ , A ⊢ B → Γ , A ⊢ C
comp t u = det (app (app ccomp (lam t)) (lam u))

-- Useful theorems in functional form.

pair : ∀ {A B Γ} → Γ ⊢ A → Γ ⊢ B → Γ ⊢ A ∧ B
pair t u = app (app cpair t) u

fst : ∀ {A B Γ} → Γ ⊢ A ∧ B → Γ ⊢ A
fst t = app cfst t

snd : ∀ {A B Γ} → Γ ⊢ A ∧ B → Γ ⊢ B
snd t = app csnd t

boom : ∀ {C Γ} → Γ ⊢ ⊥ → Γ ⊢ C
boom t = app cboom t

inl : ∀ {A B Γ} → Γ ⊢ A → Γ ⊢ A ∨ B
inl t = app cinl t

inr : ∀ {A B Γ} → Γ ⊢ B → Γ ⊢ A ∨ B
inr t = app cinr t

case : ∀ {A B C Γ} → Γ ⊢ A ∨ B → Γ , A ⊢ C → Γ , B ⊢ C → Γ ⊢ C
case t u v = app (app (app ccase t) (lam u)) (lam v)

-- Closure under context concatenation.

concat : ∀ {A B Γ} Γ′ → Γ , A ⊢ B → Γ′ ⊢ A → Γ ⧺ Γ′ ⊢ B
concat Γ′ t u = app (mono⊢ (weak⊆⧺₁ Γ′) (lam t)) (mono⊢ weak⊆⧺₂ u)

-- Convertibility.

data _⋙_ {Γ : Cx Ty} : ∀ {A} → Γ ⊢ A → Γ ⊢ A → Set where
  refl⋙     : ∀ {A} → {t : Γ ⊢ A}
                     → t ⋙ t

  trans⋙    : ∀ {A} → {t t′ t″ : Γ ⊢ A}
                     → t ⋙ t′ → t′ ⋙ t″
                     → t ⋙ t″

  sym⋙      : ∀ {A} → {t t′ : Γ ⊢ A}
                     → t ⋙ t′
                     → t′ ⋙ t

  congapp⋙  : ∀ {A B} → {t t′ : Γ ⊢ A ▻ B} → {u u′ : Γ ⊢ A}
                       → t ⋙ t′ → u ⋙ u′
                       → app t u ⋙ app t′ u′

  congi⋙    : ∀ {A} → {t t′ : Γ ⊢ A}
                     → t ⋙ t′
                     → app ci t ⋙ app ci t′

  congk⋙    : ∀ {A B} → {t t′ : Γ ⊢ A} → {u u′ : Γ ⊢ B}
                       → t ⋙ t′ → u ⋙ u′
                       → app (app ck t) u ⋙ app (app ck t′) u′

  congs⋙    : ∀ {A B C} → {t t′ : Γ ⊢ A ▻ B ▻ C} → {u u′ : Γ ⊢ A ▻ B} → {v v′ : Γ ⊢ A}
                         → t ⋙ t′ → u ⋙ u′ → v ⋙ v′
                         → app (app (app cs t) u) v ⋙ app (app (app cs t′) u′) v′

  congpair⋙ : ∀ {A B} → {t t′ : Γ ⊢ A} → {u u′ : Γ ⊢ B}
                       → t ⋙ t′ → u ⋙ u′
                       → app (app cpair t) u ⋙ app (app cpair t′) u′

  congfst⋙  : ∀ {A B} → {t t′ : Γ ⊢ A ∧ B}
                       → t ⋙ t′
                       → app cfst t ⋙ app cfst t′

  congsnd⋙  : ∀ {A B} → {t t′ : Γ ⊢ A ∧ B}
                       → t ⋙ t′
                       → app csnd t ⋙ app csnd t′

  congboom⋙ : ∀ {C} → {t t′ : Γ ⊢ ⊥}
                     → t ⋙ t′
                     → app (cboom {C = C}) t ⋙ app cboom t′

  conginl⋙  : ∀ {A B} → {t t′ : Γ ⊢ A}
                       → t ⋙ t′
                       → app (cinl {A = A} {B}) t ⋙ app cinl t′

  conginr⋙  : ∀ {A B} → {t t′ : Γ ⊢ B}
                       → t ⋙ t′
                       → app (cinr {A = A} {B}) t ⋙ app cinr t′

  congcase⋙ : ∀ {A B C} → {t t′ : Γ ⊢ A ∨ B} → {u u′ : Γ ⊢ A ▻ C} → {v v′ : Γ ⊢ B ▻ C}
                         → t ⋙ t′ → u ⋙ u′ → v ⋙ v′
                         → app (app (app ccase t) u) v ⋙ app (app (app ccase t′) u′) v′

  -- TODO: Verify this.
  beta▻ₖ⋙   : ∀ {A B} → {t : Γ ⊢ A} → {u : Γ ⊢ B}
                       → app (app ck t) u ⋙ t

  -- TODO: Verify this.
  beta▻ₛ⋙   : ∀ {A B C} → {t : Γ ⊢ A ▻ B ▻ C} → {u : Γ ⊢ A ▻ B} → {v : Γ ⊢ A}
                         → app (app (app cs t) u) v ⋙ app (app t v) (app u v)

  -- TODO: What about eta for ▻?

  beta∧₁⋙   : ∀ {A B} → {t : Γ ⊢ A} → {u : Γ ⊢ B}
                       → app cfst (app (app cpair t) u) ⋙ t

  beta∧₂⋙   : ∀ {A B} → {t : Γ ⊢ A} → {u : Γ ⊢ B}
                       → app csnd (app (app cpair t) u) ⋙ u

  eta∧⋙     : ∀ {A B} → {t : Γ ⊢ A ∧ B}
                       → t ⋙ app (app cpair (app cfst t)) (app csnd t)

  eta⊤⋙    : ∀ {t : Γ ⊢ ⊤} → t ⋙ unit

  -- TODO: Verify this.
  beta∨₁⋙   : ∀ {A B C} → {t : Γ ⊢ A} → {u : Γ ⊢ A ▻ C} → {v : Γ ⊢ B ▻ C}
               → app (app (app ccase (app cinl t)) u) v ⋙ app u t

  -- TODO: Verify this.
  beta∨₂⋙   : ∀ {A B C} → {t : Γ ⊢ B} → {u : Γ ⊢ A ▻ C} → {v : Γ ⊢ B ▻ C}
               → app (app (app ccase (app cinr t)) u) v ⋙ app v t

  -- TODO: What about eta and commuting conversions for ∨? What about ⊥?


------------------------------------------------------------------------
-- Monads
------------------------------------------------------------------------

-- Note that currently the monad laws are not included here.

module Category.Monad where

open import Data.Function
open import Category.Monad.Indexed
open import Data.Unit

RawMonad : (Set → Set) → Set₁
RawMonad M = RawIMonad {⊤} (λ _ _ → M)

RawMonadZero : (Set → Set) → Set₁
RawMonadZero M = RawIMonadZero {⊤} (λ _ _ → M)

RawMonadPlus : (Set → Set) → Set₁
RawMonadPlus M = RawIMonadPlus {⊤} (λ _ _ → M)

module RawMonad {M : Set → Set} (Mon : RawMonad M) where
  open RawIMonad Mon public

module RawMonadZero {M : Set → Set} (Mon : RawMonadZero M) where
  open RawIMonadZero Mon public

module RawMonadPlus {M : Set → Set} (Mon : RawMonadPlus M) where
  open RawIMonadPlus Mon public


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

open import HoTT
open import homotopy.EM1HSpace
open import homotopy.EilenbergMacLane
open import homotopy.EilenbergMacLane1
open import homotopy.EM1HSpace
open import homotopy.EM1HSpaceAssoc

module homotopy.EilenbergMacLaneFunctor where

open EMExplicit

module _ {i j} {G : Group i} {H : Group j} (φ : G →ᴳ H) where

  private
    module φ = GroupHom φ

    EM₁-fmap-hom : G →ᴳ Ω^S-group 0 (⊙EM₁ H)
    EM₁-fmap-hom = group-hom f f-preserves-comp
      where
        f : Group.El G → embase' H == embase
        f g = emloop (φ.f g)
        f-preserves-comp : ∀ g₁ g₂ → f (Group.comp G g₁ g₂) == f g₁ ∙ f g₂
        f-preserves-comp g₁ g₂ =
          emloop (φ.f (Group.comp G g₁ g₂))
            =⟨ ap emloop (φ.pres-comp g₁ g₂) ⟩
          emloop (Group.comp H (φ.f g₁) (φ.f g₂))
            =⟨ emloop-comp' H (φ.f g₁) (φ.f g₂) ⟩
          emloop (φ.f g₁) ∙ emloop (φ.f g₂) =∎

    module EM₁FmapRec =
      EM₁Level₁Rec {G = G} {C = EM₁ H}
                  {{EM₁-level₁ H {⟨-2⟩}}}
                  embase
                  EM₁-fmap-hom

  abstract
    EM₁-fmap : EM₁ G → EM₁ H
    EM₁-fmap = EM₁FmapRec.f

    EM₁-fmap-embase-β : EM₁-fmap embase ↦ embase
    EM₁-fmap-embase-β = EM₁FmapRec.embase-β
    {-# REWRITE EM₁-fmap-embase-β #-}

    EM₁-fmap-emloop-β : ∀ g → ap EM₁-fmap (emloop g) == emloop (φ.f g)
    EM₁-fmap-emloop-β = EM₁FmapRec.emloop-β

  ⊙EM₁-fmap : ⊙EM₁ G ⊙→ ⊙EM₁ H
  ⊙EM₁-fmap = EM₁-fmap , idp

module _ {i j k} {G : Group i} {H : Group j} {K : Group k} (ψ : H →ᴳ K) (φ : G →ᴳ H) where

  EM₁-fmap-∘ : EM₁-fmap (ψ ∘ᴳ φ) ∼ EM₁-fmap ψ ∘ EM₁-fmap φ
  EM₁-fmap-∘ =
    EM₁-set-elim
      {P = λ x → EM₁-fmap (ψ ∘ᴳ φ) x == EM₁-fmap ψ (EM₁-fmap φ x)}
      {{λ x → has-level-apply (EM₁-level₁ K) _ _}}
      idp $
    λ g → ↓-='-in' $
    ap (EM₁-fmap ψ ∘ EM₁-fmap φ) (emloop g)
      =⟨ ap-∘ (EM₁-fmap ψ) (EM₁-fmap φ) (emloop g) ⟩
    ap (EM₁-fmap ψ) (ap (EM₁-fmap φ) (emloop g))
      =⟨ ap (ap (EM₁-fmap ψ)) (EM₁-fmap-emloop-β φ g) ⟩
    ap (EM₁-fmap ψ) (emloop (GroupHom.f φ g))
      =⟨ EM₁-fmap-emloop-β ψ (GroupHom.f φ g) ⟩
    emloop (GroupHom.f (ψ ∘ᴳ φ) g)
      =⟨ ! (EM₁-fmap-emloop-β (ψ ∘ᴳ φ) g) ⟩
    ap (EM₁-fmap (ψ ∘ᴳ φ)) (emloop g) =∎

  ⊙EM₁-fmap-∘ : ⊙EM₁-fmap (ψ ∘ᴳ φ) ⊙∼ ⊙EM₁-fmap ψ ⊙∘ ⊙EM₁-fmap φ
  ⊙EM₁-fmap-∘ = EM₁-fmap-∘ , idp

module _ {i} (G : Group i) where

  EM₁-fmap-idhom : EM₁-fmap (idhom G) ∼ idf (EM₁ G)
  EM₁-fmap-idhom =
    EM₁-set-elim
      {P = λ x → EM₁-fmap (idhom G) x == x}
      {{λ x → has-level-apply (EM₁-level₁ G) (EM₁-fmap (idhom G) x) x}}
      idp $
    λ g → ↓-='-in' $ ! $
    ap (EM₁-fmap (idhom G)) (emloop g)
      =⟨ EM₁-fmap-emloop-β (idhom G) g ⟩
    emloop g
      =⟨ ! (ap-idf (emloop g)) ⟩
    ap (idf (EM₁ G)) (emloop g) =∎

  ⊙EM₁-fmap-idhom : ⊙EM₁-fmap (idhom G) ⊙∼ ⊙idf (⊙EM₁ G)
  ⊙EM₁-fmap-idhom = EM₁-fmap-idhom , idp

module _ {i j} (G : Group i) (H : Group j) where

  EM₁-fmap-cst-hom : EM₁-fmap (cst-hom {G = G} {H = H}) ∼ cst embase
  EM₁-fmap-cst-hom =
    EM₁-set-elim
      {P = λ x → EM₁-fmap cst-hom x == embase}
      {{λ x → has-level-apply (EM₁-level₁ H) (EM₁-fmap cst-hom x) embase}}
      idp $
    λ g → ↓-app=cst-in' $ ! $
    ap (EM₁-fmap cst-hom) (emloop g)
      =⟨ EM₁-fmap-emloop-β cst-hom g ⟩
    emloop (Group.ident H)
      =⟨ emloop-ident ⟩
    idp =∎

  ⊙EM₁-fmap-cst-hom : ⊙EM₁-fmap (cst-hom {G = G} {H = H}) ⊙∼ ⊙cst
  ⊙EM₁-fmap-cst-hom = EM₁-fmap-cst-hom , idp

module _ {i j} (G : AbGroup i) (H : AbGroup j) (φ : G →ᴬᴳ H) where

  ⊙EM-fmap : ∀ n → ⊙EM G n ⊙→ ⊙EM H n
  ⊙EM-fmap = EMImplicitMap.⊙EM-fmap (⊙EM₁-fmap φ) (EM₁HSpace.H-⊙EM₁ G) (EM₁HSpace.H-⊙EM₁ H)

  EM-fmap : ∀ n → EM G n → EM H n
  EM-fmap n = fst (⊙EM-fmap n)

module _ {i} (G H : AbGroup i) (φ : AbGroup.grp G →ᴳ AbGroup.grp H) where

  private
    module SN = SpectrumNatural
      {X = ⊙EM₁ (AbGroup.grp G)} {Y = ⊙EM₁ (AbGroup.grp H)}
      (⊙EM₁-fmap φ)
      {{EM₁-conn}} {{EM₁-conn}}
      {{EM₁-level₁ (AbGroup.grp G)}} {{EM₁-level₁ (AbGroup.grp H)}}
      (EM₁HSpace.H-⊙EM₁ G) (EM₁HSpace.H-⊙EM₁ H)

  abstract
    {-
      checking this definition is very slow for some
      mysterious reason (unification maybe?)
    -}
    ⊙–>-spectrum-natural : ∀ (n : ℕ)
      → ⊙–> (spectrum H n) ◃⊙∘
        ⊙Ω-fmap (⊙EM-fmap G H φ (S n)) ◃⊙idf
        =⊙∘
        ⊙EM-fmap G H φ n ◃⊙∘
        ⊙–> (spectrum G n) ◃⊙idf
    ⊙–>-spectrum-natural n =
      ⊙–> (spectrum H n) ◃⊙∘
      ⊙Ω-fmap (⊙EM-fmap G H φ (S n)) ◃⊙idf
        =⊙∘₁⟨ 0 & 1 & ap ⊙–> (spectrum-def H n) ⟩
      ⊙–> (Spectrum.spectrum H n) ◃⊙∘
      ⊙Ω-fmap (⊙EM-fmap G H φ (S n)) ◃⊙idf
        =⊙∘⟨ SN.⊙–>-spectrum-natural n ⟩
      ⊙EM-fmap G H φ n ◃⊙∘
      ⊙–> (Spectrum.spectrum G n) ◃⊙idf
        =⊙∘₁⟨ 1 & 1 & ap ⊙–> (! (spectrum-def G n)) ⟩
      ⊙EM-fmap G H φ n ◃⊙∘
      ⊙–> (spectrum G n) ◃⊙idf ∎⊙∘

    {-
      derived from `⊙–>-spectrum-natural` instead of from
      `SN.⊙<–-spectrum-natural n` since that circumvents
      the slowness issue for this definition.
    -}
    ⊙<–-spectrum-natural : ∀ (n : ℕ)
      → ⊙<– (spectrum H n) ◃⊙∘
        ⊙EM-fmap G H φ n ◃⊙idf
        =⊙∘
        ⊙Ω-fmap (⊙EM-fmap G H φ (S n)) ◃⊙∘
        ⊙<– (spectrum G n) ◃⊙idf
    ⊙<–-spectrum-natural n =
      ⊙<– (spectrum H n) ◃⊙∘
      ⊙EM-fmap G H φ n ◃⊙idf
        =⊙∘⟨ 2 & 0 & !⊙∘ $ ⊙<–-inv-r-=⊙∘ (spectrum G n) ⟩
      ⊙<– (spectrum H n) ◃⊙∘
      ⊙EM-fmap G H φ n ◃⊙∘
      ⊙–> (spectrum G n) ◃⊙∘
      ⊙<– (spectrum G n) ◃⊙idf
        =⊙∘⟨ 1 & 2 & !⊙∘ $ ⊙–>-spectrum-natural n ⟩
      ⊙<– (spectrum H n) ◃⊙∘
      ⊙–> (spectrum H n) ◃⊙∘
      ⊙Ω-fmap (⊙EM-fmap G H φ (S n)) ◃⊙∘
      ⊙<– (spectrum G n) ◃⊙idf
        =⊙∘⟨ 0 & 2 & ⊙<–-inv-l-=⊙∘ (spectrum H n) ⟩
      ⊙Ω-fmap (⊙EM-fmap G H φ (S n)) ◃⊙∘
      ⊙<– (spectrum G n) ◃⊙idf ∎⊙∘

module _ {i j k} (G : AbGroup i) (H : AbGroup j) (K : AbGroup k) (ψ : H →ᴬᴳ K) (φ : G →ᴬᴳ H) where

  private
    module G = AbGroup G
    module H = AbGroup H
    module K = AbGroup K

  ⊙EM-fmap-∘ : ∀ n → ⊙EM-fmap G K (ψ ∘ᴳ φ) n == ⊙EM-fmap H K ψ n ⊙∘ ⊙EM-fmap G H φ n
  ⊙EM-fmap-∘ O =
    ⊙Ω-fmap (⊙EM₁-fmap (ψ ∘ᴳ φ))
      =⟨ ap ⊙Ω-fmap (⊙λ= (⊙EM₁-fmap-∘ ψ φ)) ⟩
    ⊙Ω-fmap (⊙EM₁-fmap ψ ⊙∘ ⊙EM₁-fmap φ)
      =⟨ ⊙Ω-fmap-∘ (⊙EM₁-fmap ψ) (⊙EM₁-fmap φ) ⟩
    ⊙Ω-fmap (⊙EM₁-fmap ψ) ⊙∘ ⊙Ω-fmap (⊙EM₁-fmap φ) =∎
  ⊙EM-fmap-∘ (S n) =
    ⊙Trunc-fmap (⊙Susp^-fmap n (⊙EM₁-fmap (ψ ∘ᴳ φ)))
      =⟨ ap (⊙Trunc-fmap ∘ ⊙Susp^-fmap n) (⊙λ= (⊙EM₁-fmap-∘ ψ φ)) ⟩
    ⊙Trunc-fmap (⊙Susp^-fmap n (⊙EM₁-fmap ψ ⊙∘ ⊙EM₁-fmap φ))
      =⟨ ap ⊙Trunc-fmap (⊙Susp^-fmap-∘ n (⊙EM₁-fmap ψ) (⊙EM₁-fmap φ)) ⟩
    ⊙Trunc-fmap (⊙Susp^-fmap n (⊙EM₁-fmap ψ) ⊙∘ ⊙Susp^-fmap n (⊙EM₁-fmap φ))
      =⟨ ! (⊙λ= (⊙Trunc-fmap-⊙∘ (⊙Susp^-fmap n (⊙EM₁-fmap ψ)) (⊙Susp^-fmap n (⊙EM₁-fmap φ)))) ⟩
    ⊙Trunc-fmap (⊙Susp^-fmap n (⊙EM₁-fmap ψ)) ⊙∘ ⊙Trunc-fmap (⊙Susp^-fmap n (⊙EM₁-fmap φ)) =∎

  EM-fmap-∘ : ∀ n → EM-fmap G K (ψ ∘ᴳ φ) n == EM-fmap H K ψ n ∘ EM-fmap G H φ n
  EM-fmap-∘ n = ap fst (⊙EM-fmap-∘ n)

module _ {i} (G : AbGroup i) where

  private
    module G = AbGroup G
  open EM₁HSpace G using (mult; mult-emloop-β)

  EM₁-neg : EM₁ G.grp → EM₁ G.grp
  EM₁-neg = EM₁-fmap (inv-hom G)

  ⊙EM₁-neg : ⊙EM₁ G.grp ⊙→ ⊙EM₁ G.grp
  ⊙EM₁-neg = ⊙EM₁-fmap (inv-hom G)

  abstract
    EM₁-neg-emloop-β : ∀ g → ap EM₁-neg (emloop g) == ! (emloop g)
    EM₁-neg-emloop-β g =
      ap EM₁-neg (emloop g)
        =⟨ EM₁-fmap-emloop-β (inv-hom G) g ⟩
      emloop (G.inv g)
        =⟨ emloop-inv g ⟩
      ! (emloop g) =∎

    EM₁-neg-! : ∀ (p : embase' G.grp == embase)
      → ap EM₁-neg p == ! p
    EM₁-neg-! p =
      transport (λ q → ap EM₁-neg q == ! q)
                (<–-inv-r (emloop-equiv G.grp) p) $
      EM₁-neg-emloop-β (<– (emloop-equiv G.grp) p)

    ⊙Ω-fmap-⊙EM₁-neg : ⊙Ω-fmap ⊙EM₁-neg == ⊙Ω-!
    ⊙Ω-fmap-⊙EM₁-neg = ⊙λ=' EM₁-neg-! $ prop-has-all-paths-↓
      {{has-level-apply (has-level-apply (EM₁-level₁ G.grp {n = -2}) _ _) _ _}}

    EM₁-neg-inv-l : ∀ (x : EM₁ G.grp)
      → mult (EM₁-neg x) x == embase
    EM₁-neg-inv-l =
      EM₁-set-elim
        {P = λ x → mult (EM₁-neg x) x == embase}
        {{λ x → has-level-apply (EM₁-level₁ G.grp) _ _}}
        idp $ λ g →
      ↓-='-in-=ₛ $ !ₛ $
      ap (λ x → mult (EM₁-neg x) x) (emloop g) ◃∙
      idp ◃∎
        =ₛ⟨ 1 & 1 & expand [] ⟩
      ap (λ x → mult (EM₁-neg x) x) (emloop g) ◃∎
        =ₛ₁⟨ ! (ap2-diag (λ x y → mult (EM₁-neg x) y) (emloop g)) ⟩
      ap2 (λ x y → mult (EM₁-neg x) y) (emloop g) (emloop g) ◃∎
        =ₛ⟨ ap2-out (λ x y → mult (EM₁-neg x) y) (emloop g) (emloop g) ⟩
      ap (λ x → mult (EM₁-neg x) embase) (emloop g) ◃∙
      ap (λ y → y) (emloop g) ◃∎
        =ₛ₁⟨ 1 & 1 & ap-idf (emloop g) ⟩
      ap (λ x → mult (EM₁-neg x) embase) (emloop g) ◃∙
      emloop g ◃∎
        =ₛ₁⟨ 0 & 1 & ap-∘ (λ x → mult x embase) EM₁-neg (emloop g) ⟩
      ap (λ x → mult x embase) (ap EM₁-neg (emloop g)) ◃∙
      emloop g ◃∎
        =ₛ₁⟨ 0 & 1 & ap (ap (λ x → mult x embase)) (EM₁-neg-emloop-β g) ⟩
      ap (λ x → mult x embase) (! (emloop g)) ◃∙
      emloop g ◃∎
        =ₛ₁⟨ 0 & 1 & ap-! (λ x → mult x embase) (emloop g) ⟩
      ! (ap (λ x → mult x embase) (emloop g)) ◃∙
      emloop g ◃∎
        =ₛ₁⟨ 0 & 1 & ap ! (mult-emloop-β g embase) ⟩
      ! (emloop g) ◃∙
      emloop g ◃∎
        =ₛ₁⟨ !-inv-l (emloop g) ⟩
      idp ◃∎
        =ₛ₁⟨ 1 & 0 & ! (ap-cst embase (emloop g)) ⟩
      idp ◃∙
      ap (cst embase) (emloop g) ◃∎ ∎ₛ

    EM₁-neg-inv-r : ∀ (x : EM₁ G.grp)
      → mult x (EM₁-neg x) == embase
    EM₁-neg-inv-r =
      EM₁-set-elim
        {P = λ x → mult x (EM₁-neg x) == embase}
        {{λ x → has-level-apply (EM₁-level₁ G.grp) _ _}}
        idp $ λ g →
      ↓-='-in-=ₛ $ !ₛ $
      ap (λ x → mult x (EM₁-neg x)) (emloop g) ◃∙
      idp ◃∎
        =ₛ⟨ 1 & 1 & expand [] ⟩
      ap (λ x → mult x (EM₁-neg x)) (emloop g) ◃∎
        =ₛ₁⟨ ! (ap2-diag (λ x y → mult x (EM₁-neg y)) (emloop g)) ⟩
      ap2 (λ x y → mult x (EM₁-neg y)) (emloop g) (emloop g) ◃∎
        =ₛ⟨ ap2-out (λ x y → mult x (EM₁-neg y)) (emloop g) (emloop g) ⟩
      ap (λ x → mult x embase) (emloop g) ◃∙
      ap EM₁-neg (emloop g) ◃∎
        =ₛ₁⟨ 0 & 1 & mult-emloop-β g embase ⟩
      emloop g ◃∙
      ap EM₁-neg (emloop g) ◃∎
        =ₛ₁⟨ 1 & 1 & EM₁-neg-emloop-β g ⟩
      emloop g ◃∙
      ! (emloop g) ◃∎
        =ₛ₁⟨ !-inv-r (emloop g) ⟩
      idp ◃∎
        =ₛ₁⟨ 1 & 0 & ! (ap-cst embase (emloop g)) ⟩
      idp ◃∙
      ap (λ _ → embase) (emloop g) ◃∎ ∎ₛ

  EM-neg : ∀ (n : ℕ) → EM G n → EM G n
  EM-neg n = EM-fmap G G (inv-hom G) n

  ⊙EM-neg : ∀ (n : ℕ) → ⊙EM G n ⊙→ ⊙EM G n
  ⊙EM-neg n = ⊙EM-fmap G G (inv-hom G) n

  private
    -- superseded by Susp-flip-EM-neg
    EM-neg-2=Trunc-fmap-Susp-flip : EM-neg 2 ∼ Trunc-fmap Susp-flip
    EM-neg-2=Trunc-fmap-Susp-flip =
      Trunc-elim {{λ t → =-preserves-level (EM-level G 2)}} $
      Susp-elim
        {P = λ s → EM-neg 2 [ s ]₂ == Trunc-fmap Susp-flip [ s ]₂}
        (ap [_]₂ (merid embase))
        (ap [_]₂ (! (merid embase))) $
      λ x → ↓-='-in-=ₛ $
      ap [_]₂ (merid embase) ◃∙
      ap (Trunc-fmap Susp-flip ∘ [_]₂) (merid x) ◃∎
        =ₛ₁⟨ 1 & 1 & ap-∘ [_]₂ Susp-flip (merid x) ⟩
      ap [_]₂ (merid embase) ◃∙
      ap [_]₂ (ap Susp-flip (merid x)) ◃∎
        =ₛ₁⟨ 1 & 1 & ap (ap [_]₂) (SuspFlip.merid-β x) ⟩
      ap [_]₂ (merid embase) ◃∙
      ap [_]₂ (! (merid x)) ◃∎
        =ₛ₁⟨ 0 & 1 & ap (ap [_]₂) (! (!-! (merid embase))) ⟩
      ap [_]₂ (! (! (merid embase))) ◃∙
      ap [_]₂ (! (merid x)) ◃∎
        =ₛ⟨ ap-seq-=ₛ [_]₂ (∙-!-seq (merid x ◃∙ ! (merid embase) ◃∎)) ⟩
      ap [_]₂ (! (η x)) ◃∎
        =ₛ₁⟨ ap-! [_]₂ (η x) ⟩
      ! (ap [_]₂ (η x)) ◃∎
        =ₛ₁⟨ cancels-inverse (ap [_]₂ (η x)) (ap [_]₂ (η (EM₁-neg x))) $
             ap [_]₂ (η x) ∙ ap [_]₂ (η (EM₁-neg x))
               =⟨ ∙-ap [_]₂ (η x) (η (EM₁-neg x)) ⟩
             ap [_]₂ (η x ∙ η (EM₁-neg x))
               =⟨ ap (<– (=ₜ-equiv [ north ]₂ [ north ]₂)) $
                  ! $ comp x (EM₁-neg x) ⟩
             ap [_]₂ (η (mult x (EM₁-neg x)))
               =⟨ ap (ap [_]₂ ∘ η) (EM₁-neg-inv-r x) ⟩
             ap [_]₂ (η embase)
               =⟨ ap (ap [_]₂) (!-inv-r (merid embase)) ⟩
             idp =∎ ⟩
      ap [_]₂ (η (EM₁-neg x)) ◃∎
        =ₛ⟨ ap-seq-∙ [_]₂ (merid (EM₁-neg x) ◃∙ ! (merid embase) ◃∎) ⟩
      ap [_]₂ (merid (EM₁-neg x)) ◃∙
      ap [_]₂ (! (merid embase)) ◃∎
        =ₛ₁⟨ 0 & 1 & ap (ap [_]₂) (! (SuspFmap.merid-β EM₁-neg x)) ⟩
      ap [_]₂ (ap (Susp-fmap EM₁-neg) (merid x)) ◃∙
      ap [_]₂ (! (merid embase)) ◃∎
        =ₛ₁⟨ 0 & 1 & ∘-ap [_]₂ (Susp-fmap EM₁-neg) (merid x) ⟩
      ap (EM-neg 2 ∘ [_]₂) (merid x) ◃∙
      ap [_]₂ (! (merid embase)) ◃∎ ∎ₛ
      where
      open EM₁HSpaceAssoc G using (η; H-⊙EM₁; H-⊙EM₁-assoc; H-EM₁-assoc-coh-unit-l-r-pentagon)
      open import homotopy.Pi2HSuspCompose H-⊙EM₁ H-⊙EM₁-assoc H-EM₁-assoc-coh-unit-l-r-pentagon
        using (comp)
      cancels-inverse : ∀ {i} {A : Type i} {x y : A}
        (p : x == y) (q : y == x) → p ∙ q == idp → ! p == q
      cancels-inverse p@idp q@.idp idp = idp

    ⊙EM-neg-2=⊙Trunc-fmap-⊙Susp-flip : ⊙EM-neg 2 == ⊙Trunc-fmap (⊙Susp-flip (⊙EM₁ G.grp))
    ⊙EM-neg-2=⊙Trunc-fmap-⊙Susp-flip =
      ⊙λ=' {X = ⊙EM G 2} {Y = ⊙EM G 2} EM-neg-2=Trunc-fmap-Susp-flip $
      ↓-idf=cst-in $
      =ₛ-out $ !ₛ $
      ap [_]₂ (merid embase) ◃∙
      ap [_]₂ (! (merid embase)) ◃∎
        =ₛ⟨ ap-seq-=ₛ [_]₂ (seq-!-inv-r (merid (embase' G.grp) ◃∎)) ⟩
      [] ∎ₛ

    ⊙to-alt-EM : ∀ n → ⊙EM G (S (S n)) ⊙≃ ⊙Trunc (⟨ n ⟩₋₂ +2+ 2) (⊙Susp^ n (⊙EM G 2))
    ⊙to-alt-EM n =
      (⊙Susp^-⊙Trunc-equiv (⊙Susp (EM₁ G.grp)) 2 n) ⊙⁻¹ ⊙∘e
      ⊙coe-equiv (ap (⊙Trunc (⟨ n ⟩₋₂ +2+ 2)) (! (⊙Susp^-+ n 1))) ⊙∘e
      ⊙coe-equiv (ap (λ l → ⊙Trunc (⟨ n ⟩₋₂ +2+ 2) (⊙Susp^ l (⊙EM₁ G.grp))) (+-comm 1 n)) ⊙∘e
      ⊙coe-equiv (ap (λ k → ⊙Trunc k (⊙Susp^ (S n) (⊙EM₁ G.grp))) (+2+-comm 2 ⟨ n ⟩₋₂))

    ⊙–>-⊙to-alt-EM : ∀ n →
      ⊙–> (⊙to-alt-EM n) ◃⊙idf
      =⊙∘
      ⊙<– (⊙Susp^-⊙Trunc-equiv (⊙Susp (EM₁ G.grp)) 2 n) ◃⊙∘
      ⊙Trunc-fmap {n = ⟨ n ⟩₋₂ +2+ 2} (⊙coe (! (⊙Susp^-+ n 1))) ◃⊙∘
      ⊙transport (λ l → ⊙Trunc (⟨ n ⟩₋₂ +2+ 2) (⊙Susp^ l (⊙EM₁ G.grp))) (+-comm 1 n) ◃⊙∘
      ⊙transport (λ k → ⊙Trunc k (⊙Susp^ (S n) (⊙EM₁ G.grp))) (+2+-comm 2 ⟨ n ⟩₋₂) ◃⊙idf
    ⊙–>-⊙to-alt-EM n =
      ⊙–> (⊙to-alt-EM n) ◃⊙idf
        =⊙∘⟨ =⊙∘-in idp ⟩
      ⊙<– (⊙Susp^-⊙Trunc-equiv (⊙Susp (EM₁ G.grp)) 2 n) ◃⊙∘
      ⊙coe (ap (⊙Trunc (⟨ n ⟩₋₂ +2+ 2)) (! (⊙Susp^-+ n 1))) ◃⊙∘
      ⊙coe (ap (λ l → ⊙Trunc (⟨ n ⟩₋₂ +2+ 2) (⊙Susp^ l (⊙EM₁ G.grp))) (+-comm 1 n)) ◃⊙∘
      ⊙coe (ap (λ k → ⊙Trunc k (⊙Susp^ (S n) (⊙EM₁ G.grp))) (+2+-comm 2 ⟨ n ⟩₋₂)) ◃⊙idf
        =⊙∘₁⟨ 1 & 1 & ! (⊙transport-⊙coe (⊙Trunc (⟨ n ⟩₋₂ +2+ 2)) (! (⊙Susp^-+ n 1))) ∙
                      ⊙transport-⊙Trunc (! (⊙Susp^-+ n 1)) ⟩
      ⊙<– (⊙Susp^-⊙Trunc-equiv (⊙Susp (EM₁ G.grp)) 2 n) ◃⊙∘
      ⊙Trunc-fmap {n = ⟨ n ⟩₋₂ +2+ 2} (⊙coe (! (⊙Susp^-+ n 1))) ◃⊙∘
      ⊙coe (ap (λ l → ⊙Trunc (⟨ n ⟩₋₂ +2+ 2) (⊙Susp^ l (⊙EM₁ G.grp))) (+-comm 1 n)) ◃⊙∘
      ⊙coe (ap (λ k → ⊙Trunc k (⊙Susp^ (S n) (⊙EM₁ G.grp))) (+2+-comm 2 ⟨ n ⟩₋₂)) ◃⊙idf
        =⊙∘₁⟨ 2 & 1 & ! $ ⊙transport-⊙coe (λ l → ⊙Trunc (⟨ n ⟩₋₂ +2+ 2) (⊙Susp^ l (⊙EM₁ G.grp))) (+-comm 1 n) ⟩
      ⊙<– (⊙Susp^-⊙Trunc-equiv (⊙Susp (EM₁ G.grp)) 2 n) ◃⊙∘
      ⊙Trunc-fmap {n = ⟨ n ⟩₋₂ +2+ 2} (⊙coe (! (⊙Susp^-+ n 1))) ◃⊙∘
      ⊙transport (λ l → ⊙Trunc (⟨ n ⟩₋₂ +2+ 2) (⊙Susp^ l (⊙EM₁ G.grp))) (+-comm 1 n) ◃⊙∘
      ⊙coe (ap (λ k → ⊙Trunc k (⊙Susp^ (S n) (⊙EM₁ G.grp))) (+2+-comm 2 ⟨ n ⟩₋₂)) ◃⊙idf
        =⊙∘₁⟨ 3 & 1 & ! $ ⊙transport-⊙coe (λ k → ⊙Trunc k (⊙Susp^ (S n) (⊙EM₁ G.grp))) (+2+-comm 2 ⟨ n ⟩₋₂) ⟩
      ⊙<– (⊙Susp^-⊙Trunc-equiv (⊙Susp (EM₁ G.grp)) 2 n) ◃⊙∘
      ⊙Trunc-fmap {n = ⟨ n ⟩₋₂ +2+ 2} (⊙coe (! (⊙Susp^-+ n 1))) ◃⊙∘
      ⊙transport (λ l → ⊙Trunc (⟨ n ⟩₋₂ +2+ 2) (⊙Susp^ l (⊙EM₁ G.grp))) (+-comm 1 n) ◃⊙∘
      ⊙transport (λ k → ⊙Trunc k (⊙Susp^ (S n) (⊙EM₁ G.grp))) (+2+-comm 2 ⟨ n ⟩₋₂) ◃⊙idf ∎⊙∘

  ⊙EM-neg=⊙Trunc-fmap-⊙Susp-flip : ∀ (n : ℕ)
    → ⊙EM-neg (S (S n)) == ⊙Trunc-fmap (⊙Susp-flip (⊙Susp^ n (⊙EM₁ G.grp)))
  ⊙EM-neg=⊙Trunc-fmap-⊙Susp-flip n =
    equiv-is-inj
      (post⊙∘-is-equiv (⊙to-alt-EM n))
      (⊙EM-neg (S (S n)))
      (⊙Trunc-fmap (⊙Susp-flip (⊙Susp^ n (⊙EM₁ G.grp)))) $
    =⊙∘-out {fs = ⊙–> (⊙to-alt-EM n) ◃⊙∘ ⊙EM-neg (S (S n)) ◃⊙idf}
            {gs = ⊙–> (⊙to-alt-EM n) ◃⊙∘ ⊙Trunc-fmap (⊙Susp-flip (⊙Susp^ n (⊙EM₁ G.grp))) ◃⊙idf} $
    ⊙–> (⊙to-alt-EM n) ◃⊙∘
    ⊙EM-neg (S (S n)) ◃⊙idf
      =⊙∘⟨ 0 & 1 & ⊙–>-⊙to-alt-EM n ⟩
    ⊙<– (⊙Susp^-⊙Trunc-equiv (⊙Susp (EM₁ G.grp)) 2 n) ◃⊙∘
    ⊙Trunc-fmap {n = ⟨ n ⟩₋₂ +2+ 2} (⊙coe (! (⊙Susp^-+ n 1))) ◃⊙∘
    ⊙transport (λ l → ⊙Trunc (⟨ n ⟩₋₂ +2+ 2) (⊙Susp^ l (⊙EM₁ G.grp))) (+-comm 1 n) ◃⊙∘
    ⊙transport (λ k → ⊙Trunc k (⊙Susp^ (S n) (⊙EM₁ G.grp))) (+2+-comm 2 ⟨ n ⟩₋₂) ◃⊙∘
    ⊙EM-neg (S (S n)) ◃⊙idf
      =⊙∘⟨ 3 & 2 & !⊙∘ $ ⊙transport-natural-=⊙∘
             (+2+-comm 2 ⟨ n ⟩₋₂)
             (λ k → ⊙Trunc-fmap {n = k} (⊙Susp^-fmap (S n) ⊙EM₁-neg)) ⟩
    ⊙<– (⊙Susp^-⊙Trunc-equiv (⊙Susp (EM₁ G.grp)) 2 n) ◃⊙∘
    ⊙Trunc-fmap {n = ⟨ n ⟩₋₂ +2+ 2} (⊙coe (! (⊙Susp^-+ n 1))) ◃⊙∘
    ⊙transport (λ l → ⊙Trunc (⟨ n ⟩₋₂ +2+ 2) (⊙Susp^ l (⊙EM₁ G.grp))) (+-comm 1 n) ◃⊙∘
    ⊙Trunc-fmap (⊙Susp^-fmap (S n) ⊙EM₁-neg) ◃⊙∘
    ⊙transport (λ k → ⊙Trunc k (⊙Susp^ (S n) (⊙EM₁ G.grp))) (+2+-comm 2 ⟨ n ⟩₋₂) ◃⊙idf
      =⊙∘⟨ 2 & 2 & !⊙∘ $ ⊙transport-natural-=⊙∘
             (+-comm 1 n)
             (λ l → ⊙Trunc-fmap (⊙Susp^-fmap l ⊙EM₁-neg)) ⟩
    ⊙<– (⊙Susp^-⊙Trunc-equiv (⊙Susp (EM₁ G.grp)) 2 n) ◃⊙∘
    ⊙Trunc-fmap {n = ⟨ n ⟩₋₂ +2+ 2} (⊙coe (! (⊙Susp^-+ n 1))) ◃⊙∘
    ⊙Trunc-fmap (⊙Susp^-fmap (n + 1) ⊙EM₁-neg) ◃⊙∘
    ⊙transport (λ l → ⊙Trunc (⟨ n ⟩₋₂ +2+ 2) (⊙Susp^ l (⊙EM₁ G.grp))) (+-comm 1 n) ◃⊙∘
    ⊙transport (λ k → ⊙Trunc k (⊙Susp^ (S n) (⊙EM₁ G.grp))) (+2+-comm 2 ⟨ n ⟩₋₂) ◃⊙idf
      =⊙∘⟨ 1 & 2 & ⊙Trunc-fmap-seq-=⊙∘ $
           =⊙∘-in {fs = ⊙coe (! (⊙Susp^-+ n 1)) ◃⊙∘ ⊙Susp^-fmap (n + 1) ⊙EM₁-neg ◃⊙idf}
                  {gs = ⊙Susp^-fmap n (⊙Susp-fmap EM₁-neg) ◃⊙∘ ⊙coe (! (⊙Susp^-+ n 1)) ◃⊙idf} $
           ! $ ⊙Susp^-+-natural' n 1 ⊙EM₁-neg ⟩
    ⊙<– (⊙Susp^-⊙Trunc-equiv (⊙Susp (EM₁ G.grp)) 2 n) ◃⊙∘
    ⊙Trunc-fmap (⊙Susp^-fmap n (⊙Susp-fmap EM₁-neg)) ◃⊙∘
    ⊙Trunc-fmap {n = ⟨ n ⟩₋₂ +2+ 2} (⊙coe (! (⊙Susp^-+ n 1))) ◃⊙∘
    ⊙transport (λ l → ⊙Trunc (⟨ n ⟩₋₂ +2+ 2) (⊙Susp^ l (⊙EM₁ G.grp))) (+-comm 1 n) ◃⊙∘
    ⊙transport (λ k → ⊙Trunc k (⊙Susp^ (S n) (⊙EM₁ G.grp))) (+2+-comm 2 ⟨ n ⟩₋₂) ◃⊙idf
      =⊙∘⟨ 0 & 2 & ⊙Susp^-⊙Trunc-equiv-natural' (⊙Susp-fmap EM₁-neg) 2 n ⟩
    ⊙Trunc-fmap (⊙Susp^-fmap n (⊙EM-neg 2)) ◃⊙∘
    ⊙<– (⊙Susp^-⊙Trunc-equiv (⊙Susp (EM₁ G.grp)) 2 n) ◃⊙∘
    ⊙Trunc-fmap {n = ⟨ n ⟩₋₂ +2+ 2} (⊙coe (! (⊙Susp^-+ n 1))) ◃⊙∘
    ⊙transport (λ l → ⊙Trunc (⟨ n ⟩₋₂ +2+ 2) (⊙Susp^ l (⊙EM₁ G.grp))) (+-comm 1 n) ◃⊙∘
    ⊙transport (λ k → ⊙Trunc k (⊙Susp^ (S n) (⊙EM₁ G.grp))) (+2+-comm 2 ⟨ n ⟩₋₂) ◃⊙idf
      =⊙∘₁⟨ 0 & 1 & ap (⊙Trunc-fmap ∘ ⊙Susp^-fmap n) $
                    ⊙EM-neg-2=⊙Trunc-fmap-⊙Susp-flip ⟩
    ⊙Trunc-fmap (⊙Susp^-fmap n (⊙Trunc-fmap (⊙Susp-flip (⊙EM₁ G.grp)))) ◃⊙∘
    ⊙<– (⊙Susp^-⊙Trunc-equiv (⊙Susp (EM₁ G.grp)) 2 n) ◃⊙∘
    ⊙Trunc-fmap {n = ⟨ n ⟩₋₂ +2+ 2} (⊙coe (! (⊙Susp^-+ n 1))) ◃⊙∘
    ⊙transport (λ l → ⊙Trunc (⟨ n ⟩₋₂ +2+ 2) (⊙Susp^ l (⊙EM₁ G.grp))) (+-comm 1 n) ◃⊙∘
    ⊙transport (λ k → ⊙Trunc k (⊙Susp^ (S n) (⊙EM₁ G.grp))) (+2+-comm 2 ⟨ n ⟩₋₂) ◃⊙idf
      =⊙∘⟨ 0 & 2 & !⊙∘ $ ⊙Susp^-⊙Trunc-equiv-natural' (⊙Susp-flip _) 2 n ⟩
    ⊙<– (⊙Susp^-⊙Trunc-equiv (⊙Susp (EM₁ G.grp)) 2 n) ◃⊙∘
    ⊙Trunc-fmap (⊙Susp^-fmap n (⊙Susp-flip (⊙EM₁ G.grp))) ◃⊙∘
    ⊙Trunc-fmap {n = ⟨ n ⟩₋₂ +2+ 2} (⊙coe (! (⊙Susp^-+ n 1))) ◃⊙∘
    ⊙transport (λ l → ⊙Trunc (⟨ n ⟩₋₂ +2+ 2) (⊙Susp^ l (⊙EM₁ G.grp))) (+-comm 1 n) ◃⊙∘
    ⊙transport (λ k → ⊙Trunc k (⊙Susp^ (S n) (⊙EM₁ G.grp))) (+2+-comm 2 ⟨ n ⟩₋₂) ◃⊙idf
      =⊙∘₁⟨ 3 & 1 & p ⟩
    ⊙<– (⊙Susp^-⊙Trunc-equiv (⊙Susp (EM₁ G.grp)) 2 n) ◃⊙∘
    ⊙Trunc-fmap (⊙Susp^-fmap n (⊙Susp-flip (⊙EM₁ G.grp))) ◃⊙∘
    ⊙Trunc-fmap {n = ⟨ n ⟩₋₂ +2+ 2} (⊙coe (! (⊙Susp^-+ n 1))) ◃⊙∘
    ⊙Trunc-fmap (⊙coe (ap (λ l → ⊙Susp^ l (⊙EM₁ G.grp)) (+-comm 1 n))) ◃⊙∘
    ⊙transport (λ k → ⊙Trunc k (⊙Susp^ (S n) (⊙EM₁ G.grp))) (+2+-comm 2 ⟨ n ⟩₋₂) ◃⊙idf
      =⊙∘⟨ 1 & 3 & ⊙Trunc-fmap-seq-=⊙∘ $
           ⊙Susp^-fmap n (⊙Susp-flip (⊙EM₁ G.grp)) ◃⊙∘
           ⊙coe (! (⊙Susp^-+ n 1)) ◃⊙∘
           ⊙coe (ap (λ l → ⊙Susp^ l (⊙EM₁ G.grp)) (+-comm 1 n)) ◃⊙idf
             =⊙∘⟨ 3 & 0 & ⊙contract ⟩
           ⊙Susp^-fmap n (⊙Susp-flip (⊙EM₁ G.grp)) ◃⊙∘
           ⊙coe (! (⊙Susp^-+ n 1)) ◃⊙∘
           ⊙coe (ap (λ l → ⊙Susp^ l (⊙EM₁ G.grp)) (+-comm 1 n)) ◃⊙∘
           ⊙coe (⊙Susp^-+ 1 n {⊙EM₁ G.grp}) ◃⊙idf
             =⊙∘⟨ 1 & 3 & !⊙∘ $ ⊙coe-seq-∙ (⊙Susp^-comm-seq 1 n) ⟩
           ⊙Susp^-fmap n (⊙Susp-flip (⊙EM₁ G.grp)) ◃⊙∘
           ⊙coe (⊙Susp^-comm 1 n) ◃⊙idf
             =⊙∘⟨ ⊙Susp^-comm-flip 0 n (⊙EM₁ G.grp) ⟩
           ⊙coe (⊙Susp^-comm 1 n) ◃⊙∘
           ⊙Susp-flip (⊙Susp^ 0 (⊙Susp^ n (⊙EM₁ G.grp))) ◃⊙idf
             =⊙∘⟨ 0 & 1 & ⊙coe-seq-∙ (⊙Susp^-comm-seq 1 n) ⟩
           ⊙coe (! (⊙Susp^-+ n 1)) ◃⊙∘
           ⊙coe (ap (λ l → ⊙Susp^ l (⊙EM₁ G.grp)) (+-comm 1 n)) ◃⊙∘
           ⊙coe (⊙Susp^-+ 1 n {⊙EM₁ G.grp}) ◃⊙∘
           ⊙Susp-flip (⊙Susp^ 0 (⊙Susp^ n (⊙EM₁ G.grp))) ◃⊙idf
             =⊙∘⟨ 2 & 1 & ⊙expand ⊙idf-seq ⟩
           ⊙coe (! (⊙Susp^-+ n 1)) ◃⊙∘
           ⊙coe (ap (λ l → ⊙Susp^ l (⊙EM₁ G.grp)) (+-comm 1 n)) ◃⊙∘
           ⊙Susp-flip (⊙Susp^ 0 (⊙Susp^ n (⊙EM₁ G.grp))) ◃⊙idf ∎⊙∘ ⟩
    ⊙<– (⊙Susp^-⊙Trunc-equiv (⊙Susp (EM₁ G.grp)) 2 n) ◃⊙∘
    ⊙Trunc-fmap (⊙coe (! (⊙Susp^-+ n 1))) ◃⊙∘
    ⊙Trunc-fmap (⊙coe (ap (λ l → ⊙Susp^ l (⊙EM₁ G.grp)) (+-comm 1 n))) ◃⊙∘
    ⊙Trunc-fmap (⊙Susp-flip (⊙Susp^ n (⊙EM₁ G.grp))) ◃⊙∘
    ⊙transport (λ k → ⊙Trunc k (⊙Susp^ (S n) (⊙EM₁ G.grp))) (+2+-comm 2 ⟨ n ⟩₋₂) ◃⊙idf
      =⊙∘⟨ 3 & 2 & ⊙transport-natural-=⊙∘
                     (+2+-comm 2 ⟨ n ⟩₋₂)
                     (λ k → ⊙Trunc-fmap {n = k} (⊙Susp-flip (⊙Susp^ n (⊙EM₁ G.grp)))) ⟩
    ⊙<– (⊙Susp^-⊙Trunc-equiv (⊙Susp (EM₁ G.grp)) 2 n) ◃⊙∘
    ⊙Trunc-fmap (⊙coe (! (⊙Susp^-+ n 1))) ◃⊙∘
    ⊙Trunc-fmap (⊙coe (ap (λ l → ⊙Susp^ l (⊙EM₁ G.grp)) (+-comm 1 n))) ◃⊙∘
    ⊙transport (λ k → ⊙Trunc k (⊙Susp^ (S n) (⊙EM₁ G.grp))) (+2+-comm 2 ⟨ n ⟩₋₂) ◃⊙∘
    ⊙Trunc-fmap (⊙Susp-flip (⊙Susp^ n (⊙EM₁ G.grp))) ◃⊙idf
      =⊙∘₁⟨ 2 & 1 & ! p ⟩
    ⊙<– (⊙Susp^-⊙Trunc-equiv (⊙Susp (EM₁ G.grp)) 2 n) ◃⊙∘
    ⊙Trunc-fmap (⊙coe (! (⊙Susp^-+ n 1))) ◃⊙∘
    ⊙transport (λ l → ⊙Trunc (⟨ n ⟩₋₂ +2+ 2) (⊙Susp^ l (⊙EM₁ G.grp))) (+-comm 1 n) ◃⊙∘
    ⊙transport (λ k → ⊙Trunc k (⊙Susp^ (S n) (⊙EM₁ G.grp))) (+2+-comm 2 ⟨ n ⟩₋₂) ◃⊙∘
    ⊙Trunc-fmap (⊙Susp-flip (⊙Susp^ n (⊙EM₁ G.grp))) ◃⊙idf
      =⊙∘⟨ 0 & 4 & !⊙∘ $ ⊙–>-⊙to-alt-EM n ⟩
    ⊙–> (⊙to-alt-EM n) ◃⊙∘
    ⊙Trunc-fmap (⊙Susp-flip (⊙Susp^ n (⊙EM₁ G.grp))) ◃⊙idf ∎⊙∘
    where
    p : ⊙transport (λ l → ⊙Trunc (⟨ n ⟩₋₂ +2+ 2) (⊙Susp^ l (⊙EM₁ G.grp))) (+-comm 1 n) ==
        ⊙Trunc-fmap (⊙coe (ap (λ l → ⊙Susp^ l (⊙EM₁ G.grp)) (+-comm 1 n)))
    p =
      ⊙transport-⊙coe (λ l → ⊙Trunc (⟨ n ⟩₋₂ +2+ 2) (⊙Susp^ l (⊙EM₁ G.grp))) (+-comm 1 n) ∙
      ap ⊙coe (ap-∘ (⊙Trunc (⟨ n ⟩₋₂ +2+ 2)) (λ l → ⊙Susp^ l (⊙EM₁ G.grp)) (+-comm 1 n)) ∙
      ! (⊙transport-⊙coe (⊙Trunc (⟨ n ⟩₋₂ +2+ 2)) (ap (λ l → ⊙Susp^ l (⊙EM₁ G.grp)) (+-comm 1 n))) ∙
      ⊙transport-⊙Trunc (ap (λ l → ⊙Susp^ l (⊙EM₁ G.grp)) (+-comm 1 n))

module _ {i} (G : AbGroup i) where

  private
    module G = AbGroup G

  ⊙EM-fmap-idhom : ∀ (n : ℕ)
    → ⊙EM-fmap G G (idhom G.grp) n == ⊙idf (⊙EM G n)
  ⊙EM-fmap-idhom O =
    ⊙Ω-fmap (⊙EM₁-fmap (idhom G.grp))
      =⟨ ap ⊙Ω-fmap (⊙λ= (⊙EM₁-fmap-idhom G.grp)) ⟩
    ⊙Ω-fmap (⊙idf (⊙EM₁ G.grp))
      =⟨ ⊙Ω-fmap-idf ⟩
    ⊙idf _ =∎
  ⊙EM-fmap-idhom (S n) =
    ⊙Trunc-fmap (⊙Susp^-fmap n (⊙EM₁-fmap (idhom G.grp)))
      =⟨ ap (⊙Trunc-fmap ∘ ⊙Susp^-fmap n) (⊙λ= (⊙EM₁-fmap-idhom G.grp)) ⟩
    ⊙Trunc-fmap (⊙Susp^-fmap n (⊙idf (⊙EM₁ G.grp)))
      =⟨ ap ⊙Trunc-fmap (=⊙∘-out (⊙Susp^-fmap-idf n (⊙EM₁ G.grp))) ⟩
    ⊙Trunc-fmap (⊙idf (⊙Susp^ n (⊙EM₁ G.grp)))
      =⟨ ⊙λ= ⊙Trunc-fmap-⊙idf ⟩
    ⊙idf _ =∎

  EM-fmap-idhom : ∀ (n : ℕ)
    → EM-fmap G G (idhom G.grp) n == idf (EM G n)
  EM-fmap-idhom n = ap fst (⊙EM-fmap-idhom n)

module _ {i} {j} (G : AbGroup i) (H : AbGroup j) where

  ⊙EM-fmap-cst-hom : ∀ (n : ℕ)
    → ⊙EM-fmap G H cst-hom n == ⊙cst
  ⊙EM-fmap-cst-hom O =
    ⊙Ω-fmap (⊙EM₁-fmap cst-hom)
      =⟨ ap ⊙Ω-fmap (⊙λ= (⊙EM₁-fmap-cst-hom (AbGroup.grp G) (AbGroup.grp H))) ⟩
    ⊙Ω-fmap ⊙cst
      =⟨ ⊙Ω-fmap-cst ⟩
    ⊙cst =∎
  ⊙EM-fmap-cst-hom (S n) =
    ⊙Trunc-fmap (⊙Susp^-fmap n (⊙EM₁-fmap cst-hom))
      =⟨ ap (⊙Trunc-fmap ∘ ⊙Susp^-fmap n) (⊙λ= (⊙EM₁-fmap-cst-hom (AbGroup.grp G) (AbGroup.grp H))) ⟩
    ⊙Trunc-fmap (⊙Susp^-fmap n ⊙cst)
      =⟨ ap ⊙Trunc-fmap (⊙Susp^-fmap-cst n) ⟩
    ⊙Trunc-fmap ⊙cst
      =⟨ ⊙λ= ⊙Trunc-fmap-cst ⟩
    ⊙cst =∎

  EM-fmap-cst-hom : ∀ (n : ℕ)
    → EM-fmap G H cst-hom n == cst (pt (⊙EM H n))
  EM-fmap-cst-hom n = ap fst (⊙EM-fmap-cst-hom n)

transport-EM : ∀ {i} {G H : AbGroup i}
  (p : G == H) (n : ℕ)
  → transport (λ K → EM K n) p == EM-fmap G H (coeᴬᴳ p) n
transport-EM {G = G} idp n = ! $
  EM-fmap G G (coeᴳ idp) n
    =⟨ ap (λ φ → EM-fmap G G φ n) (coeᴳ-idp (AbGroup.grp G)) ⟩
  EM-fmap G G (idhom (AbGroup.grp G)) n
    =⟨ EM-fmap-idhom G n ⟩
  idf (EM G n) =∎

transport-EM-uaᴬᴳ : ∀ {i} (G H : AbGroup i)
  (iso : G ≃ᴬᴳ H) (n : ℕ)
  → transport (λ K → EM K n) (uaᴬᴳ G H iso) == EM-fmap G H (–>ᴳ iso) n
transport-EM-uaᴬᴳ G H iso n =
  transport (λ K → EM K n) (uaᴬᴳ G H iso)
    =⟨ transport-EM (uaᴬᴳ G H iso) n ⟩
  EM-fmap G H (coeᴬᴳ (uaᴬᴳ G H iso)) n
    =⟨ ap (λ p → EM-fmap G H p n) (coeᴬᴳ-β G H iso) ⟩
  EM-fmap G H (–>ᴳ iso) n =∎

⊙transport-⊙EM : ∀ {i} {G H : AbGroup i}
  (p : G == H) (n : ℕ)
  → ⊙transport (λ K → ⊙EM K n) p == ⊙EM-fmap G H (coeᴬᴳ p) n
⊙transport-⊙EM {G = G} p@idp n = ! $
  ⊙EM-fmap G G (coeᴳ idp) n
    =⟨ ap (λ φ → ⊙EM-fmap G G φ n) (coeᴳ-idp (AbGroup.grp G)) ⟩
  ⊙EM-fmap G G (idhom (AbGroup.grp G)) n
    =⟨ ⊙EM-fmap-idhom G n ⟩
  ⊙idf (⊙EM G n) =∎

⊙transport-⊙EM-uaᴬᴳ : ∀ {i} (G H : AbGroup i)
  (iso : G ≃ᴬᴳ H) (n : ℕ)
  → ⊙transport (λ K → ⊙EM K n) (uaᴬᴳ G H iso) == ⊙EM-fmap G H (–>ᴳ iso) n
⊙transport-⊙EM-uaᴬᴳ G H iso n =
  ⊙transport (λ K → ⊙EM K n) (uaᴬᴳ G H iso)
    =⟨ ⊙transport-⊙EM (uaᴬᴳ G H iso) n ⟩
  ⊙EM-fmap G H (coeᴬᴳ (uaᴬᴳ G H iso)) n
    =⟨ ap (λ p → ⊙EM-fmap G H p n) (coeᴬᴳ-β G H iso) ⟩
  ⊙EM-fmap G H (–>ᴳ iso) n =∎


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

module Util where

open import Agda.Primitive       using (Level)
open import Data.Fin             using (Fin; #_) renaming (suc to fsuc)
open import Data.Bool            using (Bool; true; false; if_then_else_)
open import Data.List            using (List; concat; replicate; []; _∷_)
open import Data.Maybe           using (Maybe; just; nothing)
open import Data.Nat             using (ℕ; suc; _*_; _<ᵇ_)
open import Data.Product         using (_×_; _,_)
open import Data.Vec             using (Vec; _∷_; []) renaming (concat to cat; replicate to rep)
open import Function             using (_∘_)
open import Relation.Nullary     using (yes; no; ¬_)
open import Relation.Unary       using (Pred; Decidable)

repeat : {ℓ : Level} {A : Set ℓ} → (n : ℕ) → List A → List A
repeat n = concat ∘ replicate n

repeatV : {ℓ : Level} {A : Set ℓ} {k : ℕ} → (n : ℕ) → Vec A k → Vec A (n * k)
repeatV n = cat ∘ rep {n = n}

-- return index of first element that satisfies predicate or last element if none do
findIndex : {a ℓ : Level} {A : Set a} {n : ℕ} {P : Pred A ℓ} → Decidable P → Vec A (suc n) → Fin (suc n)
findIndex _ (x ∷ [])     = # 0
findIndex P (x ∷ y ∷ ys) with P x
... | yes _ = # 0
... | no  _ = fsuc (findIndex P (y ∷ ys))

-- Returns a list of all adjacent pairs in the original list.
pairs : {ℓ : Level} {A : Set ℓ} → List A → List (A × A)
pairs []           = []
pairs (x ∷ [])     = []
pairs (x ∷ y ∷ xs) = (x , y) ∷ pairs (y ∷ xs)

-- Basic Boolean Filter and Elem
filter : {ℓ : Level} {A : Set ℓ} → (A → Bool) → List A → List A
filter f []       = []
filter f (x ∷ xs) = if f x then x ∷ filter f xs else filter f xs

infix 4 _∈_via_
_∈_via_ : {ℓ : Level} {A : Set ℓ} → A → List A → (A → A → Bool) → Bool
x ∈ []     via f = false
x ∈ y ∷ ys via f = if f x y then true else x ∈ ys via f

concatMaybe : {ℓ : Level} {A : Set ℓ} → List (Maybe A) → List A
concatMaybe []             = []
concatMaybe (nothing ∷ xs) = concatMaybe xs
concatMaybe (just x  ∷ xs) = x ∷ concatMaybe xs

listMin : {ℓ : Level} {A : Set ℓ} → (A → ℕ) → List A → Maybe A
listMin f [] = nothing
listMin f (x ∷ xs) with listMin f xs
... | nothing = just x
... | just y  = if f x <ᵇ f y then just x else just y


module Data.Bit where

open import Data.Nat.Literal using (Number; ℕ-num; Fin-num)
open import Data.Nat using (ℕ ; suc; zero; ⌊_/2⌋)
                     renaming (_*_ to ℕ*; _+_ to ℕ+; _≤_ to ℕ≤; _^_ to ℕ^)
open import Data.Int.Literal using (Negative)
open import Data.Fin using (Fin; suc; zero; raise)
                     renaming (toℕ to finToℕ; fromℕ to finFromℕ)
open import Data.Product using (_×_; _,_; proj₁; proj₂)
open import Data.Vec using (Vec; []; _∷_; _++_; replicate; insert; head; tail)
                     renaming (map to mapVec)
open import Data.Unit using (⊤)
open import Data.Empty using (⊥)
open import Level using (_⊔_)
open import Data.Bool using (Bool; false; true) renaming (_∧_ to Bool-∧)
open import Data.Maybe using (Maybe; just; nothing; map)

record WithCarry {a} {c} (A : Set a) (C : Set c) : Set (a ⊔ c) where
  constructor _with-carry:_
  field
    result : A
    carry : C

open WithCarry public

record Overflowing {a} (A : Set a) : Set a where
  constructor _overflow:_
  field
    result : A
    overflow : Bool

open Overflowing public

data Bit : Set where
  b0 : Bit
  b1 : Bit

infixl 8 _-_ _+_
infixl 7 _<<_ _>>_
infixl 6 _∧_ _&_
infixl 5 _⊕_ _^_
infixl 4 _∨_ _~|_
infixl 3 _↔_ _==_
infixl 1 _with-carry:_

fromBool : Bool → Bit
fromBool false = b0
fromBool true = b1

toBool : Bit → Bool
toBool b0 = false
toBool b1 = true

! : Bit → Bit
! b0 = b1
! b1 = b0

_∧_ : Bit → Bit → Bit
b0 ∧ _ = b0
b1 ∧ q = q

_∨_ : Bit → Bit → Bit
b0 ∨ q = q
b1 ∨ _ = b1

_⊕_ : Bit → Bit → Bit
b0 ⊕ q = q
b1 ⊕ q = ! q

_↔_ : Bit → Bit → Bit
b0 ↔ q = ! q
b1 ↔ q = q

maj3 : Bit → Bit → Bit → Bit
maj3 p q r = p ∧ q ∨ p ∧ r ∨ q ∧ r

half-add : Bit → Bit → WithCarry Bit Bit
half-add p q = p ⊕ q with-carry: p ∧ q

full-add : Bit → Bit → Bit → WithCarry Bit Bit
full-add p q r = p ⊕ q ⊕ r with-carry: maj3 p q r

full-addₙ : {n : ℕ} →
            Vec Bit n →
            Vec Bit n →
            Bit →
            WithCarry (Vec Bit n) (Vec Bit 2)
full-addₙ [] [] r = [] with-carry: b0 ∷ r ∷ []
full-addₙ (p ∷ []) (q ∷ []) r = result s ∷ [] with-carry: r ∷ carry s ∷ [] where
  s = full-add p q r
full-addₙ (p ∷ ps) (q ∷ qs) r = result s ∷ result ss with-carry: carry ss  where
  s = full-add p q r
  ss = full-addₙ ps qs (carry s)

!ₙ : {n : ℕ} → Vec Bit n → Vec Bit n
!ₙ = mapVec !

_+_ : {n : ℕ} → Vec Bit n → Vec Bit n → WithCarry (Vec Bit n) (Vec Bit 2)
ps + qs = full-addₙ ps qs b0

_-_ : {n : ℕ} → Vec Bit n → Vec Bit n → WithCarry (Vec Bit n) (Vec Bit 2)
ps - qs = full-addₙ ps (!ₙ qs) b1

inc : {n : ℕ} → Vec Bit n → WithCarry (Vec Bit n) (Vec Bit 2)
inc ps = full-addₙ ps (replicate b0) b1

dec : {n : ℕ} → Vec Bit n → WithCarry (Vec Bit n) (Vec Bit 2)
dec ps = full-addₙ ps (replicate b1) b0

_>>_ : {m : ℕ} → Vec Bit m → Fin m → WithCarry (Vec Bit m) (Vec Bit m)
ps >> zero = ps with-carry: replicate b0
_>>_ {suc m} (p ∷ ps) (suc i) = new-result with-carry: new-carry
  where
    qs : WithCarry (Vec Bit m) (Vec Bit m)
    qs = ps >> i
    new-result : Vec Bit (suc m)
    new-result = insert (result qs) (finFromℕ m) b0
    new-carry : Vec Bit (suc m)
    new-carry = insert (carry qs) (finFromℕ m) p

_<<_ : {m : ℕ} → Vec Bit m → Fin m → WithCarry (Vec Bit m) (Vec Bit m)
_<<_ {m} ps i = proj₂ (do-shift ps) where
  do-shift : {n : ℕ} → Vec Bit n → Fin m × WithCarry (Vec Bit n) (Vec Bit n)
  do-shift [] = i , ([] with-carry: [])
  do-shift {suc n} (p ∷ ps) = ret (proj₁ pair) where
    pair : Fin m × WithCarry (Vec Bit n) (Vec Bit n)
    pair = do-shift ps
    qs : WithCarry (Vec Bit n) (Vec Bit n)
    qs = proj₂ pair
    ret : Fin m → Fin m × WithCarry (Vec Bit (suc n)) (Vec Bit (suc n))
    ret zero = zero , (b0 ∷ result qs with-carry: p ∷ carry qs)
    ret (suc j) = raise 1 j , (p ∷ result qs with-carry: b0 ∷ carry qs)

_>>>_ : {m : ℕ} → Vec Bit m → Fin m → WithCarry (Vec Bit m) (Vec Bit m)
ps >>> zero = ps with-carry: replicate b0
_>>>_ {suc m} (p ∷ ps) (suc i) = new-result with-carry: new-carry where
  qs : WithCarry (Vec Bit m) (Vec Bit m)
  qs = ps >> i
  new-result : Vec Bit (suc m)
  new-result = insert (result qs) (finFromℕ m) p
  new-carry : Vec Bit (suc m)
  new-carry = b0 ∷ carry qs

_<<<_ : {m : ℕ} → Vec Bit m → Fin m → WithCarry (Vec Bit m) (Vec Bit m)
ps <<< zero = ps with-carry: replicate b0
_<<<_ {suc m} (p ∷ ps) (suc i) = new-result with-carry: new-carry where
  qs : WithCarry (Vec Bit m) (Vec Bit m)
  qs = ps << i
  new-result : Vec Bit (suc m)
  new-result = p ∷ result qs
  new-carry : Vec Bit (suc m)
  new-carry = insert (result qs) (finFromℕ m) b0

_&_ : {n : ℕ} → Vec Bit n → Vec Bit n → Vec Bit n
[] & [] = []
(p ∷ ps) & (q ∷ qs) = p ∧ q ∷ ps & qs

_~|_ : {n : ℕ} → Vec Bit n → Vec Bit n → Vec Bit n
[] ~| [] = []
(p ∷ ps) ~| (q ∷ qs) = (p ∨ q) ∷ (ps ~| qs)

_^_ : {n : ℕ} → Vec Bit n → Vec Bit n → Vec Bit n
[] ^ [] = []
(p ∷ ps) ^ (q ∷ qs) = (p ⊕ q) ∷ (ps ^ qs)

~ : {n : ℕ} → Vec Bit n → WithCarry (Vec Bit n) (Vec Bit 2)
~ n = inc (!ₙ n)

toℕ : Bit → ℕ
toℕ b0 = 0
toℕ b1 = 1

toFin : {n : ℕ} → Bit → Fin (suc (suc n))
toFin b0 = 0
toFin b1 = 1

toℕₙ : {n : ℕ} → Vec Bit n → ℕ
toℕₙ [] = 0
toℕₙ (p ∷ ps) = ℕ+ (toℕ p) (ℕ* 2 (toℕₙ ps))

tryToFinₙ : {m n : ℕ} → Vec Bit m → Maybe (Fin n)
tryToFinₙ {_} {n} ps = tryℕ n (toℕₙ ps) where
  tryℕ : (k : ℕ) → ℕ → Maybe (Fin k)
  tryℕ zero _ = nothing
  tryℕ (suc _) zero = just zero
  tryℕ (suc m) (suc n) = map suc (tryℕ m n)

ℕ-mod2 : ℕ → Bit
ℕ-mod2 zero = b0
ℕ-mod2 (suc zero) = b1
ℕ-mod2 (suc (suc n)) = ℕ-mod2 n

instance
  Bit-num : Number Bit
  Bit-num .Number.Constraint n = constrain n where
    constrain : ℕ → Set
    constrain zero = ⊤
    constrain (suc zero) = ⊤
    constrain  _ = ⊥
  Bit-num .Number.fromNat n ⦃ p ⦄ = fromNat n p where
    fromNat : (m : ℕ) → (Number.Constraint Bit-num) m → Bit
    fromNat zero _ = b0
    fromNat (suc zero) _ = b1
    fromNat (suc (suc _)) ()

instance
  Bits-num : {m : ℕ} → Number (Vec Bit m)
  Bits-num {m} .Number.Constraint n = ℕ≤ (suc n) (ℕ^ 2 m)
  Bits-num {m} .Number.fromNat n  = fromNat m n where
    fromNat : (m : ℕ) → ℕ → Vec Bit m
    fromNat zero _ = []
    fromNat (suc m) n = ℕ-mod2 n ∷ fromNat m ⌊ n /2⌋

instance
  Bits-neg : {m : ℕ} → Negative (Vec Bit (suc m))
  Bits-neg {m} .Negative.Constraint n = ℕ≤ n (ℕ^ 2 m)
  Bits-neg {m} .Negative.fromNeg n  = number where
    iterateBits : (m : ℕ) → ℕ → Vec Bit m × Bit
    iterateBits zero _ = [] , b0 where
    iterateBits (suc m) n = newVec , newSign where
      subRes : Vec Bit m × Bit
      subRes = iterateBits m ⌊ n /2⌋
      newVec : Vec Bit (suc m)
      newVec = ℕ-mod2 n ∷ proj₁ subRes
      newSign : Bit
      newSign = ℕ-mod2 n ∨ proj₂ subRes
    iteration : Vec Bit (suc m) × Bit
    iteration = iterateBits (suc m) n
    preNumber : Vec Bit (suc m)
    preNumber = proj₁ iteration
    signBit : Bit
    signBit = proj₂ iteration
    number : Vec Bit (suc m)
    number = (head preNumber ∨ signBit) ∷ tail preNumber

_==_ : {n : ℕ} → Vec Bit n → Vec Bit n → Bool
[] == [] = true
p ∷ ps == q ∷ qs = Bool-∧ (toBool (p ↔ q)) (ps == qs)


-- TODO
-- Basic Tarski-style semantics, for soundness only.

module BasicT.Semantics.BasicTarski where

open import BasicT.Syntax.Common public

-- Tarski models.

record Model : Set₁ where
  infix 3 ⊩ᵅ_
  field
    -- Forcing for atomic propositions.
    ⊩ᵅ_ : Atom → Set

open Model {{…}} public

-- Forcing in a particular model.

module _ {{_ : Model}} where
  infix 3 ⊩_
  ⊩_ : Ty → Set
  ⊩ α P   = ⊩ᵅ P
  ⊩ A ▻ B = ⊩ A → ⊩ B
  ⊩ A ∧ B = ⊩ A × ⊩ B
  ⊩ ⊤    = 𝟙
  ⊩ BOOL  = 𝔹
  ⊩ NAT   = ℕ

  infix 3 ⊩⋆_
  ⊩⋆_ : Cx Ty → Set
  ⊩⋆ ∅     = 𝟙
  ⊩⋆ Ξ , A = ⊩⋆ Ξ × ⊩ A

-- Entailment, or forcing in all models.

infix 3 ⊨_
⊨_ : Ty → Set₁
⊨ A = ∀ {{_ : Model}} → ⊩ A

-- Forcing in a particular model, for sequents.

module _ {{_ : Model}} where
  infix 3 ⊩_⇒_
  ⊩_⇒_ : Cx Ty → Ty → Set
  ⊩ Γ ⇒ A = ⊩⋆ Γ → ⊩ A

  infix 3 ⊩_⇒⋆_
  ⊩_⇒⋆_ : Cx Ty → Cx Ty → Set
  ⊩ Γ ⇒⋆ Ξ = ⊩⋆ Γ → ⊩⋆ Ξ

-- Entailment, or forcing in all models, for sequents.

infix 3 _⊨_
_⊨_ : Cx Ty → Ty → Set₁
Γ ⊨ A = ∀ {{_ : Model}} → ⊩ Γ ⇒ A

infix 3 _⊨⋆_
_⊨⋆_ : Cx Ty → Cx Ty → Set₁
Γ ⊨⋆ Ξ = ∀ {{_ : Model}} → ⊩ Γ ⇒⋆ Ξ

-- Additional useful equipment, for sequents.

module _ {{_ : Model}} where
  lookup : ∀ {A Γ} → A ∈ Γ → ⊩ Γ ⇒ A
  lookup top     (γ , a) = a
  lookup (pop i) (γ , b) = lookup i γ

  ⟦λ⟧ : ∀ {A B Γ} → ⊩ Γ , A ⇒ B → ⊩ Γ ⇒ A ▻ B
  ⟦λ⟧ f γ = λ a → f (γ , a)

  _⟦$⟧_ : ∀ {A B Γ} → ⊩ Γ ⇒ A ▻ B → ⊩ Γ ⇒ A → ⊩ Γ ⇒ B
  (f ⟦$⟧ g) γ = f γ $ g γ

  ⟦S⟧ : ∀ {A B C Γ} → ⊩ Γ ⇒ A ▻ B ▻ C → ⊩ Γ ⇒ A ▻ B → ⊩ Γ ⇒ A → ⊩ Γ ⇒ C
  ⟦S⟧ f g a γ = S (f γ) (g γ) (a γ)

  _⟦,⟧_ : ∀ {A B Γ} → ⊩ Γ ⇒ A → ⊩ Γ ⇒ B → ⊩ Γ ⇒ A ∧ B
  (a ⟦,⟧ b) γ = a γ , b γ

  ⟦π₁⟧ : ∀ {A B Γ} → ⊩ Γ ⇒ A ∧ B → ⊩ Γ ⇒ A
  ⟦π₁⟧ s γ = π₁ (s γ)

  ⟦π₂⟧ : ∀ {A B Γ} → ⊩ Γ ⇒ A ∧ B → ⊩ Γ ⇒ B
  ⟦π₂⟧ s γ = π₂ (s γ)


-- Context extension of presheaves
module SOAS.Families.Delta {T : Set} where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Sorting
open import SOAS.Construction.Structure
open import SOAS.Families.Core {T}

-- | General context extension by a context Θ

module Unsorted where

  -- Concatenate Θ to the context of a family
  δ : Ctx → Family → Family
  δ Θ X Γ = X (Θ ∔ Γ)

  δF : Ctx → Functor 𝔽amilies 𝔽amilies
  δF Θ = record { F₀ = δ Θ ; F₁ = λ f → f ; identity = refl
                 ; homomorphism = refl ; F-resp-≈ = λ z → z }

  -- | Context extension by a single type τ, a special case of δ with ⌊ τ ⌋
  δ₁ : T → Family → Family
  δ₁ τ = δ ⌈ τ ⌋

  δ₁F_ : T → Functor 𝔽amilies 𝔽amilies
  δ₁F τ = δF ⌈ τ ⌋

private
  variable
    Γ Δ : Ctx
    α : T

module Sorted where
  -- Concatenate Θ to the context of a family
  δ : Ctx → Familyₛ → Familyₛ
  δ Θ 𝒳 α Γ = 𝒳 α (Θ ∔ Γ)

  δF : Ctx → Functor 𝔽amiliesₛ 𝔽amiliesₛ
  δF Θ = record { F₀ = δ Θ ; F₁ = λ f → f ; identity = refl
                 ; homomorphism = refl ; F-resp-≈ = λ z → z }

  -- | Context extension by a single type τ, a special case of δ with ⌊ τ ⌋
  δ₁ : T → Familyₛ → Familyₛ
  δ₁ τ = δ ⌈ τ ⌋

  δ₁F_ : T → Functor 𝔽amiliesₛ 𝔽amiliesₛ
  δ₁F τ = δF ⌈ τ ⌋


-- 2010-10-14

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

module FakeProjectionsDoNotPreserveGuardedness where

-- Coinduction is only available with universe polymorphism

postulate
  Level : Set
  zero : Level
  suc  : (i : Level) → Level
  _⊔_ : Level → Level → Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}
{-# BUILTIN LEVELMAX  _⊔_   #-}

infixl 6 _⊔_

-- Coinduction

infix 1000 ♯_

postulate
  ∞  : ∀ {a} (A : Set a) → Set a
  ♯_ : ∀ {a} {A : Set a} → A → ∞ A
  ♭  : ∀ {a} {A : Set a} → ∞ A → A

{-# BUILTIN INFINITY ∞  #-}
{-# BUILTIN SHARP    ♯_ #-}
{-# BUILTIN FLAT     ♭  #-}

-- Products

infixr 4 _,_
infixr 2 _×_

-- fake product with projections
postulate
  _×_   : (A B : Set) → Set
  _,_   : {A B : Set}(a : A)(b : B) → A × B
  proj₁ : {A B : Set}(p : A × B) → A
  proj₂ : {A B : Set}(p : A × B) → B

-- Streams

infixr 5 _∷_

data Stream (A : Set) : Set where
  _∷_ : (x : A) (xs : ∞ (Stream A)) → Stream A

mutual

  repeat : {A : Set}(a : A) → Stream A
  repeat a = a ∷ proj₂ (repeat' a)

  repeat' : {A : Set}(a : A) → A × ∞ (Stream A)
  repeat' a = a , ♯ repeat a


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

open import HoTT
open import homotopy.Bouquet
open import homotopy.PushoutSplit
open import homotopy.DisjointlyPointedSet
open import cw.CW

module cw.WedgeOfCells {i} {n} (skel : Skeleton {i} (S n)) where

Xₙ/Xₙ₋₁ : Type i
Xₙ/Xₙ₋₁ = Cofiber (cw-incl-last skel)

⊙Xₙ/Xₙ₋₁ : Ptd i
⊙Xₙ/Xₙ₋₁ = ⊙[ Xₙ/Xₙ₋₁ , cfbase ]

private
  cells : Type i
  cells = cells-last skel

  attaching : cells → (Sphere n → ⟦ skel ⟧₋₁)
  attaching = attaching-last skel

  {- this is also a cofiber -}
  BigWedgeSusp : Type i
  BigWedgeSusp = Attached {A = ⊤} {B = cells} {C = Sphere n} (λ _ _ → unit)

  ⊙BigWedgeSusp : Ptd i
  ⊙BigWedgeSusp = ⊙[ BigWedgeSusp , cfbase ]

private
  module SphereToBigWedgeSusp (a : cells) = SuspRec {A = Sphere n}
    (cfbase :> BigWedgeSusp) (cfcod a) (λ s → cfglue (a , s))

  module BouquetToBigWedgeSusp =
    BigWedgeRec {A = cells} {X = Bouquet-family cells (S n)}
    cfbase SphereToBigWedgeSusp.f (λ _ → idp)

  module BigWedgeSuspEquivQuotient = PushoutLSplit (uncurry attaching) (λ _ → unit) fst

Bouquet-to-Xₙ/Xₙ₋₁ : Bouquet cells (S n) → Xₙ/Xₙ₋₁
Bouquet-to-Xₙ/Xₙ₋₁ = BigWedgeSuspEquivQuotient.split ∘ BouquetToBigWedgeSusp.f

abstract
  Bouquet-to-Xₙ/Xₙ₋₁-in-merid-β : ∀ (a : cells) x
    → ap (Bouquet-to-Xₙ/Xₙ₋₁ ∘ bwin a) (merid x)
    == cfglue (attaching a x) ∙' ap cfcod (spoke a x)
  Bouquet-to-Xₙ/Xₙ₋₁-in-merid-β a x =
      ap-∘ BigWedgeSuspEquivQuotient.split (SphereToBigWedgeSusp.f a) (merid x)
    ∙ ap (ap BigWedgeSuspEquivQuotient.split) (SphereToBigWedgeSusp.merid-β a x)
    ∙ BigWedgeSuspEquivQuotient.split-glue-β (a , x)

private
  Bouquet-to-BigWedgeSusp-is-equiv : is-equiv BouquetToBigWedgeSusp.f
  Bouquet-to-BigWedgeSusp-is-equiv = is-eq to from to-from from-to
    where
    to = BouquetToBigWedgeSusp.f

    module From = AttachedRec {A = ⊤}
      (λ _ → bwbase :> Bouquet cells (S n))
      (λ a → bwin a south) (λ a s → bwglue a ∙ ap (bwin a) (merid s))
    from = From.f

    abstract
      from-to : ∀ b → from (to b) == b
      from-to = BigWedge-elim
        idp
        (λ a → Susp-elim (bwglue a) idp
          (λ s → ↓-='-from-square $
            ( ap-∘ from (SphereToBigWedgeSusp.f a) (merid s)
            ∙ ap (ap from) (SphereToBigWedgeSusp.merid-β a s)
            ∙ From.spoke-β a s)
            ∙v⊡ (tl-square (bwglue a) ⊡h vid-square)))
        (λ a → ↓-∘=idf-from-square from to $
          ap (ap from) (BouquetToBigWedgeSusp.glue-β a) ∙v⊡ br-square (bwglue a))

      to-from : ∀ c → to (from c) == c
      to-from = Attached-elim
        (λ _ → idp) (λ a → idp)
        (λ a s → ↓-∘=idf-in' to from $
            ap (ap to) (From.spoke-β a s)
          ∙ ap-∙ to (bwglue a) (ap (bwin a) (merid s))
          ∙ ap2 _∙_ (BouquetToBigWedgeSusp.glue-β a)
                    ( ∘-ap to (bwin a) (merid s)
                    ∙ SphereToBigWedgeSusp.merid-β a s))

  Bouquet-equiv-BigWedgeSusp : Bouquet cells (S n) ≃ BigWedgeSusp
  Bouquet-equiv-BigWedgeSusp = BouquetToBigWedgeSusp.f , Bouquet-to-BigWedgeSusp-is-equiv

Bouquet-equiv-Xₙ/Xₙ₋₁ : Bouquet cells (S n) ≃ Xₙ/Xₙ₋₁
Bouquet-equiv-Xₙ/Xₙ₋₁ = BigWedgeSuspEquivQuotient.split-equiv ∘e Bouquet-equiv-BigWedgeSusp

Bouquet-⊙equiv-Xₙ/Xₙ₋₁ : ⊙Bouquet cells (S n) ⊙≃ ⊙Xₙ/Xₙ₋₁
Bouquet-⊙equiv-Xₙ/Xₙ₋₁ = ≃-to-⊙≃ Bouquet-equiv-Xₙ/Xₙ₋₁ idp


{-# OPTIONS --cubical #-}
module _ where

module _ where
  import Agda.Primitive
  open import Agda.Primitive.Cubical public

  postulate
    Path' : ∀ {ℓ} {A :     Set ℓ} → A    → A    → Set ℓ
    PathP : ∀ {ℓ} (A : I → Set ℓ) → A i0 → A i1 → Set ℓ

  {-# BUILTIN PATH         Path'     #-}
  {-# BUILTIN PATHP        PathP     #-}

  infix 4 _≡_
  _≡_ : ∀ {ℓ} {A : Set ℓ} → A → A → Set ℓ
  _≡_ {A = A} = PathP (λ _ → A)

  Path = _≡_

  refl : ∀ {a} {A : Set a} {x : A} → x ≡ x
  refl {x = x} = \ _ → x

testPath : ∀ {A : Set} {b a : A} (let H : Path b b; H = _) → ∀ i → H i ≡ b
testPath i = refl


module Issue314 where

postulate A : Set

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

postulate lemma : (x y : A) → x ≡ y

Foo : A → Set₁
Foo x with lemma x _
Foo x | refl = Set

-- Bug.agda:12,9-13
-- Failed to solve the following constraints:
--   x == _23 x : A
-- when checking that the pattern refl has type x ≡ _23 x


------------------------------------------------------------------------
-- The Agda standard library
--
-- Functors
------------------------------------------------------------------------

-- Note that currently the functor laws are not included here.

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

module Category.Functor where

open import Function
open import Level

open import Relation.Binary.PropositionalEquality

record RawFunctor {ℓ} (F : Set ℓ → Set ℓ) : Set (suc ℓ) where
  infixl 4 _<$>_ _<$_
  infixl 1 _<&>_

  field
    _<$>_ : ∀ {A B} → (A → B) → F A → F B

  _<$_ : ∀ {A B} → A → F B → F A
  x <$ y = const x <$> y

  _<&>_ : ∀ {A B} → F A → (A → B) → F B
  _<&>_ = flip _<$>_

-- A functor morphism from F₁ to F₂ is an operation op such that
-- op (F₁ f x) ≡ F₂ f (op x)

record Morphism {ℓ} {F₁ F₂ : Set ℓ → Set ℓ}
                (fun₁ : RawFunctor F₁)
                (fun₂ : RawFunctor F₂) : Set (suc ℓ) where
  open RawFunctor
  field
    op     : ∀{X} → F₁ X → F₂ X
    op-<$> : ∀{X Y} (f : X → Y) (x : F₁ X) →
             op (fun₁ ._<$>_ f x) ≡ fun₂ ._<$>_ f (op x)


{-# OPTIONS -v treeless.opt.final:20 -v 0 #-}
module Word where

open import Agda.Builtin.Nat
open import Agda.Builtin.Bool
open import Agda.Builtin.Word renaming (primWord64ToNat to toNat)
open import Agda.Builtin.Equality
open import Agda.Builtin.Unit
open import Agda.Builtin.IO
open import Agda.Builtin.FromNat
open import Agda.Builtin.String
open import Agda.Builtin.Strict

instance
  NumWord : Number Word64
  Number.Constraint NumWord _ = ⊤
  fromNat {{NumWord}} n = primWord64FromNat n

  NumNat : Number Nat
  Number.Constraint NumNat _ = ⊤
  fromNat {{NumNat}} n = n

natOp : (Nat → Nat → Nat) → Word64 → Word64 → Word64
natOp f a b = fromNat (f (toNat a) (toNat b))
{-# INLINE natOp #-}

_^_ : Nat → Nat → Nat
a ^ zero = 1
a ^ suc n = a * a ^ n

2⁶⁴ : Nat
2⁶⁴ = 2 ^ 64
{-# STATIC 2⁶⁴ #-}

addWord : Word64 → Word64 → Word64
addWord = natOp _+_

subWord : Word64 → Word64 → Word64
subWord = natOp λ a b → a + 2⁶⁴ - b

mulWord : Word64 → Word64 → Word64
mulWord = natOp _*_

{-# INLINE addWord #-}
{-# INLINE subWord #-}
{-# INLINE mulWord #-}

-- div/mod

data ⊥ : Set where

NonZero : Nat → Set
NonZero zero    = ⊥
NonZero (suc _) = ⊤

div : (a b : Nat) {{nz : NonZero b}} → Nat
div a 0 {{}}
div a (suc b) = div-helper 0 b a b

mod : (a b : Nat) {{nz : NonZero b}} → Nat
mod a 0 {{}}
mod a (suc b) = mod-helper 0 b a b

{-# INLINE div #-}
{-# INLINE mod #-}

NonZeroWord : Word64 → Set
NonZeroWord a = NonZero (toNat a)

divWord : (a b : Word64) {{nz : NonZeroWord b}} → Word64
divWord a b = fromNat (div (toNat a) (toNat b))

modWord : (a b : Word64) {{nz : NonZeroWord b}} → Word64
modWord a b = fromNat (mod (toNat a) (toNat b))

{-# INLINE divWord #-}
{-# INLINE modWord #-}

-- Comparison --

eqWord : Word64 → Word64 → Bool
eqWord a b = toNat a == toNat b

ltWord : Word64 → Word64 → Bool
ltWord a b = toNat a < toNat b

{-# INLINE eqWord #-}
{-# INLINE ltWord #-}

postulate
  showWord : Word64 → String
  putStrLn : String → IO ⊤

{-# FOREIGN GHC import qualified Data.Text.IO #-}
{-# COMPILE GHC showWord = Data.Text.pack . show #-}
{-# COMPILE GHC putStrLn = Data.Text.IO.putStrLn #-}

{-# COMPILE JS showWord = function(x) { return x.toString(); } #-}
{-# COMPILE JS putStrLn = function (x) { return function(cb) { process.stdout.write(x + "\n"); cb(0); }; } #-}

2^63 : Word64
2^63 = addWord 1 (divWord (subWord 0 1) 2)

test : Word64
test = addWord (addWord 2^63 100)
               (addWord 2^63 1)

prf : test ≡ 101
prf = refl

prf' : eqWord test 101 ≡ true
prf' = refl

main : IO ⊤
main = putStrLn (showWord test)

-- Some checks for treeless optimisations

ltDouble : Word64 → Word64 → Bool
ltDouble x y = ltWord (mulWord 2 x) y

lt4x : Word64 → Word64 → Bool
lt4x x y = primForce (mulWord 2 x) ltDouble y


module Issue23 where

postulate
  ℝ   : Set
  r₀  : ℝ
  _+_ : ℝ → ℝ → ℝ
  -_  : ℝ → ℝ

_-_ : ℝ → ℝ → ℝ
x - y = x + (- y)

infixl 4 _≡_

-- Equality.
data _≡_ : ℝ → ℝ → Set where
  refl : (x : ℝ) → x ≡ x

postulate ─-neut : {x : ℝ} → r₀ - x ≡ - x
{-# ATP prove ─-neut #-}


module BadRefl where

open import AgdaPrelude

plus =
  natElim
    ( \ _ -> Nat -> Nat )           -- motive
    ( \ n -> n )                    -- case for Zero
    ( \ p rec n -> Succ (rec n) )   -- case for Succ

-- the other direction requires induction on N:
postulate pNPlus0isN : (n : Nat) -> Eq Nat (plus n Zero) n

-- the other direction requires induction on N:
succPlus : (n : Nat) -> Eq Nat  (Succ n) (plus (Succ n) Zero)
succPlus =
  (\n -> pNPlus0isN (Succ n))