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

module PathInduction where

open import Base public

-- The rewriting relation
{-<rewrite>-}
postulate
  _↦_ : ∀ {i} {A : Type i} → A → A → Type i

{-# BUILTIN REWRITE _↦_ #-}
{-</>-}

-- We redefine concatenation of paths to use induction on both paths, in order
-- to make unification more powerful
infixr 80 _∙_
_∙_ : ∀ {i} {A : Type i} {a b c : A} (p : a == b) (q : b == c) → a == c
idp ∙ idp = idp

record Coh {i} (A : Type i) : Type i where
  field
    & : A
open Coh public

instance
  J→ : ∀ {i j k} {A : Type i} {B : A → Type j} {f : (a : A) → B a} {P : {g : (a : A) → B a} (h : (a : A) → f a == g a) → Type k}
    → Coh (P (λ a → idp)) → Coh ({g : (a : A) → B a} → (h : (a : A) → f a == g a) → P h)
  & (J→ {A = A} {B} {f} {P = P} d) h = transport P (λ= (app=-β h)) (J-aux (λ= h)) where

    J-aux : {g : (a : A) → B a} (h : f == g) → P (app= h)
    J-aux idp = & d

  J→! : ∀ {i j k} {A : Type i} {B : A → Type j} {f : (a : A) → B a} {P : {g : (a : A) → B a} (h : (a : A) → g a == f a) → Type k}
    → Coh (P (λ a → idp)) → Coh ({g : (a : A) → B a} → (h : (a : A) → g a == f a) → P h)
  & (J→! {A = A} {B} {f} {P = P} d) h = transport P (λ= (app=-β h)) (J-aux (λ= h)) where

    J-aux : {g : (a : A) → B a} (h : g == f) → P (app= h)
    J-aux idp = & d

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

 instance

  J- : {B : (a' : A) → a == a' → Type j}
    → Coh (B a idp) → Coh ({a' : A} (p : a == a') → B a' p)
  & (J- d) idp = & d

  J! : {B : (a' : A) → a' == a → Type j}
    → Coh (B a idp) → Coh ({a' : A} (p : a' == a) → B a' p)
  & (J! d) idp = & d

  J□ : {B : {b c d : A} {p : a == b} {q : a == c} {r : b == d} {s : c == d} → Square p q r s → Type j}
    → Coh (B ids) → Coh ({b c d : A} {p : a == b} {q : a == c} {r : b == d} {s : c == d} (sq : Square p q r s) → B sq)
  & (J□ {B = B} d) ids = & d

  J□i : {B : {b c d : A} {p : a == b} {q : a == c} {r : b == d} {s : c == d} → Square p q r s → Type j}
    → Coh (B ids) → Coh ({b c d : A} {p : a == b} {q : a == c} {r : b == d} {s : c == d} {sq : Square p q r s} → B sq)
  & (J□i {B = B} d) {sq = ids} = & d

  J□1 : {B : (p : a == a) → Square p idp idp idp → Type j}
    → Coh (B idp ids) → Coh ({p : a == a} (sq : Square p idp idp idp) → B p sq)
  & (J□1 {B = B} d) c = aux B (& d) c  where

    e : {a b c d : A} (q : a == c) (r : b == d) (s : c == d) → Square (q ∙ s ∙ ! r) q r s
    e idp idp idp = ids

    aux : {a b c d : A} {q : a == c} {r : b == d} {s : c == d} (B : (p : a == b) → Square p q r s → Type j)
       → B (q ∙ s ∙ ! r) (e q r s) → {p : a == b} (sq : Square p q r s) → B p sq
    aux B d ids = d

  J□2 : {B : (p : a == a) → Square idp p idp idp → Type j}
    → Coh (B idp ids) → Coh ({p : a == a} (sq : Square idp p idp idp) → B p sq)
  & (J□2 {B = B} d) c = aux B (& d) c  where

    e : {a b c d : A} (p : a == b) (r : b == d) (s : c == d) → Square p (p ∙ r ∙ ! s) r s
    e idp idp idp = ids

    aux : {a b c d : A} {p : a == b} {r : b == d} {s : c == d} (B : (q : a == c) → Square p q r s → Type j)
       → B (p ∙ r ∙ ! s) (e p r s) → {q : a == c} (sq : Square p q r s) → B q sq
    aux B d ids = d

  J□3 : {B : (p : a == a) → Square idp idp p idp → Type j}
    → Coh (B idp ids) → Coh ({p : a == a} (sq : Square idp idp p idp) → B p sq)
  & (J□3 {B = B} d) c = aux B (& d) c  where

    e : {a b c d : A} (p : a == b) (q : a == c) (s : c == d) → Square p q (! p ∙ q ∙ s) s
    e idp idp idp = ids

    aux : {a b c d : A} {p : a == b} {q : a == c} {s : c == d} (B : (r : b == d) → Square p q r s → Type j)
       → B (! p ∙ q ∙ s) (e p q s) → {r : b == d} (sq : Square p q r s) → B r sq
    aux B d ids = d

  J□4 : {B : (p : a == a) → Square idp idp idp p → Type j}
    → Coh (B idp ids) → Coh ({p : a == a} (sq : Square idp idp idp p) → B p sq)
  & (J□4 {B = B} d) c = aux B (& d) c  where

    e : {a b c d : A} (p : a == b) (q : a == c) (r : b == d) → Square p q r (! q ∙ p ∙ r)
    e idp idp idp = ids

    aux : {a b c d : A} {p : a == b} {q : a == c} {r : b == d} (B : (s : c == d) → Square p q r s → Type j)
       → B (! q ∙ p ∙ r) (e p q r) → {s : c == d} (sq : Square p q r s) → B s sq
    aux B d ids = d

instance
  idp-Coh : ∀ {i} {A : Type i} {a : A} → Coh (a == a)
  & idp-Coh = idp

  ids-Coh : ∀ {i} {A : Type i} {a : A} → Coh (Square {a₀₀ = a} idp idp idp idp)
  & ids-Coh = ids

  idc-Coh : ∀ {i} {A : Type i} {a : A} → Coh (Cube {a₀₀₀ = a} ids ids ids ids ids ids)
  & idc-Coh = idc

  -- Allows us to put the initial [a] in the [Coh]
  strip-a : ∀ {i j} {A : Type i} {P : A → A → Type j} → ((a : A) → Coh ({b : A} → P a b)) → Coh ({a b : A} → P a b)
  & (strip-a z) = & (z _)

  -- Allows us to put the initial [A] in the [Coh]
  strip-A : ∀ {i j} {P : Type i → Type j} → ((A : Type i) → Coh (P A)) → Coh ({A : Type i} → P A)
  & (strip-A z) = & (z _)

  -- Allows us to have implicit arguments
  implicit : ∀ {i j k} {A : Type i} {B : A → Type j} {C : (a : A) → B a → Type k} → Coh ({a : A} (b : B a) → C a b) → Coh ({a : A} {b : B a} → C a b)
  & (implicit d) = & d _

path-induction : ∀ {i} {A : Type i} {{a : A}} → A
path-induction {{a}} = a

-- Rules for cubes

instance
  idsidc1-Coh : ∀ {i} {A : Type i} {a : A} → Coh (Σ (Square (idp {a = a}) idp idp idp) (λ left → Cube left ids ids ids ids ids))
  & idsidc1-Coh = (ids , idc)

  idsidc2-Coh : ∀ {i} {A : Type i} {a : A} → Coh (Σ (Square (idp {a = a}) idp idp idp) (λ right → Cube ids right ids ids ids ids))
  & idsidc2-Coh = (ids , idc)

  idsidc6-Coh : ∀ {i} {A : Type i} {a : A} → Coh (Σ (Square (idp {a = a}) idp idp idp) (λ front → Cube ids ids ids ids ids front))
  & idsidc6-Coh = (ids , idc)

module _ {i j} {A : Type i} {a : A} where
 instance

  JCube1 : {B : (p : Square {a₀₀ = a} idp idp idp idp) → Cube p ids ids ids ids ids → Type j}
    → Coh (B ids idc) → Coh ({p : Square {a₀₀ = a} idp idp idp idp} (cube : Cube p ids ids ids ids ids) → B p cube)
  & (JCube1 {B = B} d) c = aux B (& d) c  where

    comp : Coh ({a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ : A}
           {p₀₋₁ : a₀₀₁ == a₀₁₁} {p₋₀₁ : a₀₀₁ == a₁₀₁}
           {p₋₁₁ : a₀₁₁ == a₁₁₁} {p₁₋₁ : a₁₀₁ == a₁₁₁}
           (right : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁)

           {a₀₀₀ : A} {p₀₀₋ : a₀₀₀ == a₀₀₁}
           {a₀₁₀ : A} {p₀₁₋ : a₀₁₀ == a₀₁₁}
           {a₁₀₀ : A} {p₁₀₋ : a₁₀₀ == a₁₀₁}
           {a₁₁₀ : A} {p₁₁₋ : a₁₁₀ == a₁₁₁}

           {p₀₋₀ : a₀₀₀ == a₀₁₀}
           (back : Square p₀₋₀ p₀₀₋ p₀₁₋ p₀₋₁)
           {p₋₀₀ : a₀₀₀ == a₁₀₀}
           (top : Square p₋₀₀ p₀₀₋ p₁₀₋ p₋₀₁)
           {p₋₁₀ : a₀₁₀ == a₁₁₀}
           (bottom : Square p₋₁₀ p₀₁₋ p₁₁₋ p₋₁₁)
           {p₁₋₀ : a₁₀₀ == a₁₁₀}
           (front : Square p₁₋₀ p₁₀₋ p₁₁₋ p₁₋₁)
           → Σ (Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀) (λ left → Cube left right back top bottom front))
    comp = path-induction

    aux :  {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ : A}
           {p₀₋₀ : a₀₀₀ == a₀₁₀} {p₋₀₀ : a₀₀₀ == a₁₀₀}
           {p₋₁₀ : a₀₁₀ == a₁₁₀} {p₁₋₀ : a₁₀₀ == a₁₁₀}
           -- missing left

           {p₀₋₁ : a₀₀₁ == a₀₁₁} {p₋₀₁ : a₀₀₁ == a₁₀₁}
           {p₋₁₁ : a₀₁₁ == a₁₁₁} {p₁₋₁ : a₁₀₁ == a₁₁₁}
           {right : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁}

           {p₀₀₋ : a₀₀₀ == a₀₀₁} {p₀₁₋ : a₀₁₀ == a₀₁₁}
           {p₁₀₋ : a₁₀₀ == a₁₀₁} {p₁₁₋ : a₁₁₀ == a₁₁₁}
           {back : Square p₀₋₀ p₀₀₋ p₀₁₋ p₀₋₁}
           {top : Square p₋₀₀ p₀₀₋ p₁₀₋ p₋₀₁}
           {bottom : Square p₋₁₀ p₀₁₋ p₁₁₋ p₋₁₁}
           {front : Square p₁₋₀ p₁₀₋ p₁₁₋ p₁₋₁}
           → (B : (left : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀) → Cube left right back top bottom front → Type j)
           → uncurry B (& comp right back top bottom front)
           → ({left : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀} (cube : Cube left right back top bottom front) → B left cube)
    aux B d idc = d

  JCube2 : {B : (p : Square {a₀₀ = a} idp idp idp idp) → Cube ids p ids ids ids ids → Type j}
    → Coh (B ids idc) → Coh ({p : Square {a₀₀ = a} idp idp idp idp} (cube : Cube ids p ids ids ids ids) → B p cube)
  & (JCube2 {B = B} d) c = aux B (& d) c  where

    comp : Coh ({a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ : A}
           {p₀₋₀ : a₀₀₀ == a₀₁₀} {p₋₀₀ : a₀₀₀ == a₁₀₀}
           {p₋₁₀ : a₀₁₀ == a₁₁₀} {p₁₋₀ : a₁₀₀ == a₁₁₀}
           (left : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀)

           {a₀₀₁ : A} {p₀₀₋ : a₀₀₀ == a₀₀₁}
           {a₀₁₁ : A} {p₀₁₋ : a₀₁₀ == a₀₁₁}
           {a₁₀₁ : A} {p₁₀₋ : a₁₀₀ == a₁₀₁}
           {a₁₁₁ : A} {p₁₁₋ : a₁₁₀ == a₁₁₁}

           {p₀₋₁ : a₀₀₁ == a₀₁₁}
           (back : Square p₀₋₀ p₀₀₋ p₀₁₋ p₀₋₁)
           {p₋₀₁ : a₀₀₁ == a₁₀₁}
           (top : Square p₋₀₀ p₀₀₋ p₁₀₋ p₋₀₁)
           {p₋₁₁ : a₀₁₁ == a₁₁₁}
           (bottom : Square p₋₁₀ p₀₁₋ p₁₁₋ p₋₁₁)
           {p₁₋₁ : a₁₀₁ == a₁₁₁}
           (front : Square p₁₋₀ p₁₀₋ p₁₁₋ p₁₋₁)
           → Σ (Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁) (λ right → Cube left right back top bottom front))
    comp = path-induction

    aux :  {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ : A}
           {p₀₋₀ : a₀₀₀ == a₀₁₀} {p₋₀₀ : a₀₀₀ == a₁₀₀}
           {p₋₁₀ : a₀₁₀ == a₁₁₀} {p₁₋₀ : a₁₀₀ == a₁₁₀}
           {left : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀}

           {p₀₋₁ : a₀₀₁ == a₀₁₁} {p₋₀₁ : a₀₀₁ == a₁₀₁}
           {p₋₁₁ : a₀₁₁ == a₁₁₁} {p₁₋₁ : a₁₀₁ == a₁₁₁}

           {p₀₀₋ : a₀₀₀ == a₀₀₁} {p₀₁₋ : a₀₁₀ == a₀₁₁}
           {p₁₀₋ : a₁₀₀ == a₁₀₁} {p₁₁₋ : a₁₁₀ == a₁₁₁}
           {back : Square p₀₋₀ p₀₀₋ p₀₁₋ p₀₋₁}
           {top : Square p₋₀₀ p₀₀₋ p₁₀₋ p₋₀₁}
           {bottom : Square p₋₁₀ p₀₁₋ p₁₁₋ p₋₁₁}
           {front : Square p₁₋₀ p₁₀₋ p₁₁₋ p₁₋₁}
           → (B : (right : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁) → Cube left right back top bottom front → Type j)
           → uncurry B (& comp left back top bottom front)
           → ({right : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁} (cube : Cube left right back top bottom front) → B right cube)
    aux B d idc = d

  JCube6 : {B : (p : Square {a₀₀ = a} idp idp idp idp) → Cube ids ids ids ids ids p → Type j}
    → Coh (B ids idc) → Coh ({p : Square {a₀₀ = a} idp idp idp idp} (cube : Cube ids ids ids ids ids p) → B p cube)
  & (JCube6 {B = B} d) c = aux B (& d) c  where

    comp : Coh ({a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ : A}
           {p₀₋₀ : a₀₀₀ == a₀₁₀} {p₋₀₀ : a₀₀₀ == a₁₀₀}
           {p₋₁₀ : a₀₁₀ == a₁₁₀} {p₁₋₀ : a₁₀₀ == a₁₁₀}
           (left : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀)

           {a₀₀₁ : A} {p₀₀₋ : a₀₀₀ == a₀₀₁}
           {a₀₁₁ : A} {p₀₁₋ : a₀₁₀ == a₀₁₁}
           {a₁₀₁ : A} {p₁₀₋ : a₁₀₀ == a₁₀₁}
           {a₁₁₁ : A} {p₁₁₋ : a₁₁₀ == a₁₁₁}

           {p₀₋₁ : a₀₀₁ == a₀₁₁}
           (back : Square p₀₋₀ p₀₀₋ p₀₁₋ p₀₋₁)
           {p₋₀₁ : a₀₀₁ == a₁₀₁}
           (top : Square p₋₀₀ p₀₀₋ p₁₀₋ p₋₀₁)
           {p₋₁₁ : a₀₁₁ == a₁₁₁}
           (bottom : Square p₋₁₀ p₀₁₋ p₁₁₋ p₋₁₁)
           {p₁₋₁ : a₁₀₁ == a₁₁₁}
           (right : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁)
           → Σ (Square p₁₋₀ p₁₀₋ p₁₁₋ p₁₋₁) (λ front → Cube left right back top bottom front))
    comp = path-induction

    aux :  {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ : A}
           {p₀₋₀ : a₀₀₀ == a₀₁₀} {p₋₀₀ : a₀₀₀ == a₁₀₀}
           {p₋₁₀ : a₀₁₀ == a₁₁₀} {p₁₋₀ : a₁₀₀ == a₁₁₀}
           {left : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀}

           {p₀₋₁ : a₀₀₁ == a₀₁₁} {p₋₀₁ : a₀₀₁ == a₁₀₁}
           {p₋₁₁ : a₀₁₁ == a₁₁₁} {p₁₋₁ : a₁₀₁ == a₁₁₁}
           {right : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁}

           {p₀₀₋ : a₀₀₀ == a₀₀₁} {p₀₁₋ : a₀₁₀ == a₀₁₁}
           {p₁₀₋ : a₁₀₀ == a₁₀₁} {p₁₁₋ : a₁₁₀ == a₁₁₁}
           {back : Square p₀₋₀ p₀₀₋ p₀₁₋ p₀₋₁}
           {top : Square p₋₀₀ p₀₀₋ p₁₀₋ p₋₀₁}
           {bottom : Square p₋₁₀ p₀₁₋ p₁₁₋ p₋₁₁}
           → (B : (front : Square p₁₋₀ p₁₀₋ p₁₁₋ p₁₋₁) → Cube left right back top bottom front → Type j)
           → uncurry B (& comp left back top bottom right)
           → ({front : Square p₁₋₀ p₁₀₋ p₁₁₋ p₁₋₁} (cube : Cube left right back top bottom front) → B front cube)
    aux B d idc = d

-- Flat cubes (cubes where the four lateral faces are actually only 2-dimensional paths
data FlatCube {i} {A : Type i} {a : A} :
  {b c d : A} {p p' : a == b} {q q' : a == c} {r r' : b == d} {s s' : c == d}
  → Square p q r s → Square p' q' r' s' → p == p' → q == q' → r == r' → s == s' → Type i where
  idfc : FlatCube ids ids idp idp idp idp

instance
  idfc-Coh : ∀ {i} {A : Type i} {a : A} → Coh (FlatCube {a = a} ids ids idp idp idp idp)
  & idfc-Coh = idfc

  JFlatCube1 : ∀ {i j} {A : Type i} {a : A} {B : (p : Square {a₀₀ = a} idp idp idp idp) → FlatCube p ids idp idp idp idp → Type j}
    → Coh (B ids idfc) → Coh ({p : Square {a₀₀ = a} idp idp idp idp} (cube : FlatCube p ids idp idp idp idp) → B p cube)
  & (JFlatCube1 {i} {j} {B = B} d) c = aux B (& d) c  where

    comp : {A : Type i} {a b c d : A} {p' : a == b} {q' : a == c} {r' : b == d} {s' : c == d} (sq' : Square p' q' r' s')
           {p : a == b} (p= : p == p') {q : a == c} (q= : q == q') {r : b == d} (r= : r == r') {s : c == d} (s= : s == s')
         → Square p q r s
    comp ids idp idp idp idp = ids

    fill : {A : Type i} {a b c d : A} {p' : a == b} {q' : a == c} {r' : b == d} {s' : c == d} (sq' : Square p' q' r' s')
           {p : a == b} (p= : p == p') {q : a == c} (q= : q == q') {r : b == d} (r= : r == r') {s : c == d} (s= : s == s')
         → FlatCube (comp sq' p= q= r= s=) sq' p= q= r= s=
    fill ids idp idp idp idp = idfc

    aux : {A : Type i} {a b c d : A} {p' : a == b} {q' : a == c} {r' : b == d} {s' : c == d} {sq' : Square p' q' r' s'}
          {p : a == b} {p= : p == p'} {q : a == c} {q= : q == q'} {r : b == d} {r= : r == r'} {s : c == d} {s= : s == s'}
         (B : (sq : Square p q r s) (fil : FlatCube sq sq' p= q= r= s=) → Type j)
          → B (comp sq' p= q= r= s=) (fill sq' p= q= r= s=)
          → {sq : Square p q r s} (fil : FlatCube sq sq' p= q= r= s=) → B sq fil
    aux B d idfc = d

  JFlatCube2 : ∀ {i j} {A : Type i} {a : A} {B : (p : Square {a₀₀ = a} idp idp idp idp) → FlatCube ids p idp idp idp idp → Type j}
    → Coh (B ids idfc) → Coh ({p : Square {a₀₀ = a} idp idp idp idp} (cube : FlatCube ids p idp idp idp idp) → B p cube)
  & (JFlatCube2 d) idfc = & d

ap-∙ : ∀ {i j} {A : Type i} {B : Type j} (f : A → B) {a b c : A} (p : a == b) (q : b == c) → ap f (p ∙ q) == ap f p ∙ ap f q
ap-∙ f idp idp = idp

ap-∙! : ∀ {i j} {A : Type i} {B : Type j} (f : A → B) {a b : A} (p : a == b) {c : A} (q : c == b) → ap f (p ∙ ! q) == ap f p ∙ ! (ap f q)
ap-∙! f idp idp = idp

ap-shape-∙! : ∀ {i j} {A : Type i} {B : Type j} (f : A → B) {a b c : A} {p : a == b} {q : a == c} {r : b == c}
  → p == q ∙ ! r → ap f p == ap f q ∙ ! (ap f r)
ap-shape-∙! f {q = idp} {r = idp} idp = idp

ap-!∙ : ∀ {i j} {A : Type i} {B : Type j} (f : A → B) {a b : A} (p : b == a) {c : A} (q : b == c) → ap f (! p ∙ q) == ! (ap f p) ∙ ap f q
ap-!∙ f idp idp = idp

∘-ap : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k} (g : B → C) (f : A → B)
  {x y : A} (p : x == y) → ap g (ap f p) == ap (g ∘ f) p
∘-ap f g p = ! (ap-∘ f g p)

∙idp : ∀ {i} {A : Type i} {a b : A} {p : a == b} → p ∙ idp == p
∙idp {p = idp} = idp

idp∙ : ∀ {i} {A : Type i} {a a' : A} {p : a == a'} → idp ∙ p == p
idp∙ {p = idp} = idp

!-inv-r : ∀ {i} {A : Type i} {a b : A} {p : a == b} → p ∙ ! p == idp
!-inv-r {p = idp} = idp

!-inv-l : ∀ {i} {A : Type i} {a b : A} {p : a == b} → ! p ∙ p == idp
!-inv-l {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 idp = hid-square

  vert-degen-square : {a a' : A} {p q : a == a'}
    → p == q → Square idp p q idp
  vert-degen-square idp = vid-square

  horiz-degen-path : {a a' : A} {p q : a == a'}
    → Square p idp idp q → p == q
  horiz-degen-path {p = idp} ids = idp

  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

  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 = ids} = idp

  horiz-degen-square-η : {a a' : A} {p q : a == a'} {r : p == q} → horiz-degen-path (horiz-degen-square r) == r
  horiz-degen-square-η {p = idp} {r = idp} = idp

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

  natural-square : (h : (a : A) → f a == g a)
    {x y : A} (p : x == y)
    → {fp : f x == f y} (fp= : ap f p == fp)
    → {gp : g x == g y} (gp= : ap g p == gp)
    → Square (h x) fp gp (h y)
  natural-square h idp idp idp = hid-square

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

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

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

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

  ↓-ap-in2 : {x y : A} {p : x == y} {u : C (f x)} {v : C (f y)}
    {fp : f x == f y} (fp= : ap f p == fp)
    → u == v [ C ∘ f ↓ p ]
    → u == v [ C ↓ fp ]
  ↓-ap-in2 {p = idp} idp idp = idp

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

  ↓-ap-in-coh : {X : Type i} {g : X → A} {x y : X} {p : x == y} {gp : g x == g y} {p-β : ap g p == gp} (h : (a : A) → C (f a))
    → ↓-ap-in C f (apd h gp) == ↓-ap-in2 C (f ∘ g) (ap-∘ f g p ∙ ap (ap f) p-β) (apd (h ∘ g) p)
  ↓-ap-in-coh {p = idp} {p-β = idp} h = idp

↓-PathOver-from-square : ∀ {i j} {A X : Type i} {P : A → Type j} {a b : X → A}
  {q : (x : X) → a x == b x} {f : (x : X) → P (a x)} {g : (x : X) → P (b x)}
  {x y : X} {p : x == y} {u : PathOver P (q x) (f x) (g x)} {v : PathOver P (q y) (f y) (g y)}
  {a-p : a x == a y} {ap= : ap a p == a-p}
  {b-p : b x == b y} {bp= : ap b p == b-p}
  → SquareOver P (natural-square q p ap= bp=) u (↓-ap-in2 P a {p = p} ap= (apd f p)) (↓-ap-in2 P b bp= (apd g p)) v
  → u == v [ (λ z → f z == g z [ P ↓ q z ]) ↓ p ]
↓-PathOver-from-square {p = idp} {ap= = idp} {bp= = idp} pq = coh pq  where

  coh : ∀ {i j} {A : Type i} {P : A → Type j} {a b : A} {q : a == b} {f : P a} {g : P b} {u v : f == g [ P ↓ q ]}
      → SquareOver P hid-square u idp idp v → u == v
  coh {q = idp} {u = idp} ids = idp

adapt-SquareOver : ∀ {i j} {A : Type i} {P : A → Type j} {a b c d : A}
  {p : a == b} {q : a == c} {r : b == d} {s : c == d} {sq : Square p q r s}
  {a' : P a} {b' : P b} {c' : P c} {d' : P d}
  {p' : a' == b' [ P ↓ p ]} {q' q'2 : a' == c' [ P ↓ q ]}
  {r' r'2 : b' == d' [ P ↓ r ]} {s' : c' == d' [ P ↓ s ]}
  (q'= : q' == q'2) (r'= : r' == r'2)
  → SquareOver P sq p' q' r' s'
  → SquareOver P sq p' q'2 r'2 s'
adapt-SquareOver {sq = ids} idp idp ids = ids

ap-square-natural-square : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k} (f : B → C) →
  Coh ({a b : A} (p : a == b) {u v : A → B} (g : (x : A) → u x == v x)
      {up : u a == u b} {up= : ap u p == up}
      {vp : v a == v b} {vp= : ap v p == vp}
      {fup : ap (λ z → f (u z)) p == ap f up} (fup= : ap-∘ f u p ∙ ap (ap f) up= == fup)
      {fvp : ap (λ z → f (v z)) p == ap f vp} (fvp= : ap-∘ f v p ∙ ap (ap f) vp= == fvp)
    → ap-square f (natural-square g p up= vp=) == natural-square (ap f ∘ g) p fup fvp)
ap-square-natural-square {i} {j} {k} f = path-induction

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

adapt-square : ∀ {i} {A : Type i} {a b c d : A} {p : a == b} {q : a == c} {r : b == d} {s : c == d} (sq : Square p q r s)
               {q' : a == c} (q= : q == q') {r' : b == d} (r= : r == r')
             → Square p q' r' s
adapt-square ids idp idp = ids

ap2-idf : ∀ {i} → Coh ({A : Type i} {x y : A} {p q : x == y} {r : p == q} → Square (ap (ap (λ z → z)) r) (ap-idf _) (ap-idf _) r)
ap2-idf = path-induction

ap-∘3 : ∀ {i j k l} {A : Type i} {B : Type j} {C : Type k} {D : Type l}
        (f : C → D) (g : B → C) (h : A → B) {a b : A} (p : a == b)
      → Square (ap-∘ f (g ∘ h) p) (ap-∘ (f ∘ g) h p) (ap (ap f) (ap-∘ g h p)) (ap-∘ f g (ap h p))
ap-∘3 f g h idp = ids

_∙□_ : ∀ {i} {A : Type i} {a b c d e f : A} {p : a == b} {q : a == c} {r : b == d} {s : c == d} {t : c == e} {u : d == f} {v : e == f}
         (sq1 : Square p q r s) (sq2 : Square s t u v)
       → Square p (q ∙ t) (r ∙ u) v
ids ∙□ ids = ids

_|∙_ : ∀ {i} {A : Type i} {a b c d : A} {p p' : a == b} {q : a == c} {r : b == d} {s : c == d}
         (p= : p == p') (sq1 : Square p' q r s)
       → Square p q r s
idp |∙ ids = ids

_∙|_ : ∀ {i} {A : Type i} {a b c d : A} {p : a == b} {q : a == c} {r : b == d} {s s' : c == d}
         (sq1 : Square p q r s) (s= : s == s')
       → Square p q r s'
ids ∙| idp = ids

infixr 80 _∙□_ _|∙_ _∙|_

_∙³x_ : ∀ {i} {A : Type i}
  {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ a₀₀₂ a₀₁₂ a₁₀₂ a₁₁₂ : A}
  {p₀₋₀ : a₀₀₀ == a₀₁₀} {p₋₀₀ : a₀₀₀ == a₁₀₀}
  {p₋₁₀ : a₀₁₀ == a₁₁₀} {p₁₋₀ : a₁₀₀ == a₁₁₀}
  {sq₋₋₀ : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀} -- left

  {p₀₋₁ : a₀₀₁ == a₀₁₁} {p₋₀₁ : a₀₀₁ == a₁₀₁}
  {p₋₁₁ : a₀₁₁ == a₁₁₁} {p₁₋₁ : a₁₀₁ == a₁₁₁}
  {sq₋₋₁ : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁} -- middle

  {p₀₋₂ : a₀₀₂ == a₀₁₂} {p₋₀₂ : a₀₀₂ == a₁₀₂}
  {p₋₁₂ : a₀₁₂ == a₁₁₂} {p₁₋₂ : a₁₀₂ == a₁₁₂}
  {sq₋₋₂ : Square p₀₋₂ p₋₀₂ p₋₁₂ p₁₋₂} -- right

  {p₀₀l : a₀₀₀ == a₀₀₁} {p₀₁l : a₀₁₀ == a₀₁₁}
  {p₁₀l : a₁₀₀ == a₁₀₁} {p₁₁l : a₁₁₀ == a₁₁₁}
  {sq₀₋l : Square p₀₋₀ p₀₀l p₀₁l p₀₋₁} -- backl
  {sq₋₀l : Square p₋₀₀ p₀₀l p₁₀l p₋₀₁} -- topl
  {sq₋₁l : Square p₋₁₀ p₀₁l p₁₁l p₋₁₁} -- bottoml
  {sq₁₋l : Square p₁₋₀ p₁₀l p₁₁l p₁₋₁} -- frontl

  {p₀₀r : a₀₀₁ == a₀₀₂} {p₀₁r : a₀₁₁ == a₀₁₂}
  {p₁₀r : a₁₀₁ == a₁₀₂} {p₁₁r : a₁₁₁ == a₁₁₂}
  {sq₀₋r : Square p₀₋₁ p₀₀r p₀₁r p₀₋₂} -- backr
  {sq₋₀r : Square p₋₀₁ p₀₀r p₁₀r p₋₀₂} -- topr
  {sq₋₁r : Square p₋₁₁ p₀₁r p₁₁r p₋₁₂} -- bottomr
  {sq₁₋r : Square p₁₋₁ p₁₀r p₁₁r p₁₋₂} -- frontr

  → Cube sq₋₋₀ sq₋₋₁ sq₀₋l sq₋₀l sq₋₁l sq₁₋l
  → Cube sq₋₋₁ sq₋₋₂ sq₀₋r sq₋₀r sq₋₁r sq₁₋r
  → Cube sq₋₋₀ sq₋₋₂ (sq₀₋l ∙□ sq₀₋r) (sq₋₀l ∙□ sq₋₀r)
         (sq₋₁l ∙□ sq₋₁r) (sq₁₋l ∙□ sq₁₋r)
idc ∙³x idc = idc

infixr 80 _∙³x_

x-degen-cube : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
  {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  {sq₋₋₀ sq₋₋₁ : Square p₀₋ p₋₀ p₋₁ p₁₋}
  → sq₋₋₀ == sq₋₋₁
  → Cube sq₋₋₀ sq₋₋₁ hid-square hid-square hid-square hid-square
x-degen-cube {sq₋₋₀ = ids} idp = idc

natural-cube-η∞ : ∀ {i j} {A : Type i} {B : Type j}
  {u : A → B}
  {r : (a : A) → u a == u a}
  (p : ∀ a → r a == idp)
  {x y : A} (q : x == y)
  {uq : u x == u y} {uq= : ap u q == uq}
  → Cube (horiz-degen-square (p x)) (horiz-degen-square (p y))
         (natural-square r q uq= uq=) vid-square vid-square vid-square
natural-cube-η∞ p idp {uq= = idp} = x-degen-cube idp

natural-square-∘ : ∀ {i} {A B C : Type i} {a b : C} (p : a == b) (k : C → A) →
         Coh ({f g : A → B} (h : (a : A) → f a == g a)
              {fkp : _} {fkp= : ap (f ∘ k) p == fkp}
              {gkp : _} {gkp= : ap (g ∘ k) p == gkp}
              {fkp2 : _} (fkp2= : ∘-ap f k p ∙ fkp= == fkp2)
              {gkp2 : _} (gkp2= : ∘-ap g k p ∙ gkp= == gkp2)
         → natural-square (h ∘ k) p fkp= gkp= == natural-square h (ap k p) fkp2 gkp2)
natural-square-∘ idp = path-induction

_-∙³_ : ∀ {i} {A : Type i}
  {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ : A}
  {p₀₋₀ : a₀₀₀ == a₀₁₀} {p₋₀₀ : a₀₀₀ == a₁₀₀}
  {p₋₁₀ : a₀₁₀ == a₁₁₀} {p₁₋₀ : a₁₀₀ == a₁₁₀}
  {sq₋₋₀ sq₋₋₀' : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀} -- left

  {p₀₋₁ : a₀₀₁ == a₀₁₁} {p₋₀₁ : a₀₀₁ == a₁₀₁}
  {p₋₁₁ : a₀₁₁ == a₁₁₁} {p₁₋₁ : a₁₀₁ == a₁₁₁}
  {sq₋₋₁ : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁} -- right

  {p₀₀ : a₀₀₀ == a₀₀₁} {p₀₁ : a₀₁₀ == a₀₁₁}
  {p₁₀ : a₁₀₀ == a₁₀₁} {p₁₁ : a₁₁₀ == a₁₁₁}
  {sq₀₋ : Square p₀₋₀ p₀₀ p₀₁ p₀₋₁} -- back
  {sq₋₀ : Square p₋₀₀ p₀₀ p₁₀ p₋₀₁} -- top
  {sq₋₁ : Square p₋₁₀ p₀₁ p₁₁ p₋₁₁} -- bottom
  {sq₁₋ : Square p₁₋₀ p₁₀ p₁₁ p₁₋₁} -- front

  → (sq₋₋₀ == sq₋₋₀')
  → Cube sq₋₋₀' sq₋₋₁ sq₀₋ sq₋₀ sq₋₁ sq₁₋
  → Cube sq₋₋₀  sq₋₋₁ sq₀₋ sq₋₀ sq₋₁ sq₁₋
idp -∙³ idc = idc

_-|∙³_ : ∀ {i} {A : Type i} → {a₀₀₀ a₀₁₀ : A}
  {a b p₀₋₀ p₁₋₀ : a₀₀₀ == a₀₁₀}
  {p : a == b} {q : a == p₀₋₀} {r : b == p₁₋₀}
  {sq₋₋₀ : p₀₋₀ == p₁₋₀} -- left

  (α : Square p q r sq₋₋₀)

  {a₀₀₁ : A} {p₀₀₋ : a₀₀₀ == a₀₀₁}
  {a₀₁₁ : A} {p₀₁₋ : a₀₁₀ == a₀₁₁}
  {a₁₀₁ : A} {p₁₀₋ : a₀₀₀ == a₁₀₁}
  {a₁₁₁ : A} {p₁₁₋ : a₀₁₀ == a₁₁₁}

  {p₀₋₁ : a₀₀₁ == a₀₁₁}
  {sq₀₋₋ : Square p₀₋₀ p₀₀₋ p₀₁₋ p₀₋₁} -- back
  {p₋₀₁ : a₀₀₁ == a₁₀₁}
  {sq₋₀₋ : Square idp p₀₀₋ p₁₀₋ p₋₀₁} -- top
  {p₋₁₁ : a₀₁₁ == a₁₁₁}
  {sq₋₁₋ : Square idp p₀₁₋ p₁₁₋ p₋₁₁} -- bottom
  {p₁₋₁ : a₁₀₁ == a₁₁₁}
  {sq₁₋₋ : Square p₁₋₀ p₁₀₋ p₁₁₋ p₁₋₁} -- front

  {sq₋₋₁ : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁} -- right
    → Cube (horiz-degen-square sq₋₋₀) sq₋₋₁ sq₀₋₋ sq₋₀₋ sq₋₁₋ sq₁₋₋
    → Cube (horiz-degen-square p) sq₋₋₁ (q |∙ sq₀₋₋ ) sq₋₀₋ sq₋₁₋ (r |∙ sq₁₋₋)
ids -|∙³ idc = idc

infixr 80 _-|∙³_

adapt-cube : ∀ {i} {A : Type i} {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ : A}
  {p₀₋₀ : a₀₀₀ == a₀₁₀} {p₋₀₀ : a₀₀₀ == a₁₀₀}
  {p₋₁₀ : a₀₁₀ == a₁₁₀} {p₁₋₀ : a₁₀₀ == a₁₁₀}
  {sq₋₋₀ : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀} -- left

  {p₀₋₁ : a₀₀₁ == a₀₁₁} {p₋₀₁ : a₀₀₁ == a₁₀₁}
  {p₋₁₁ : a₀₁₁ == a₁₁₁} {p₁₋₁ : a₁₀₁ == a₁₁₁}
  {sq₋₋₁ : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁} -- right

  {p₀₀₋ : a₀₀₀ == a₀₀₁} {p₀₁₋ : a₀₁₀ == a₀₁₁}
  {p₁₀₋ : a₁₀₀ == a₁₀₁} {p₁₁₋ : a₁₁₀ == a₁₁₁}
  {sq₀₋₋ : Square p₀₋₀ p₀₀₋ p₀₁₋ p₀₋₁} -- back
  {sq₋₀₋ : Square p₋₀₀ p₀₀₋ p₁₀₋ p₋₀₁} -- top
  {sq₋₁₋ : Square p₋₁₀ p₀₁₋ p₁₁₋ p₋₁₁} -- bottom
  {sq₁₋₋ : Square p₁₋₀ p₁₀₋ p₁₁₋ p₁₋₁} -- front
  (cube : Cube sq₋₋₀ sq₋₋₁ sq₀₋₋ sq₋₀₋ sq₋₁₋ sq₁₋₋ )

  {p₀₀₋' : a₀₀₀ == a₀₀₁} (p₀₀₋= : p₀₀₋ == p₀₀₋') {p₀₁₋' : a₀₁₀ == a₀₁₁} (p₀₁₋= : p₀₁₋ == p₀₁₋')
  {p₁₀₋' : a₁₀₀ == a₁₀₁} (p₁₀₋= : p₁₀₋ == p₁₀₋') {p₁₁₋' : a₁₁₀ == a₁₁₁} (p₁₁₋= : p₁₁₋ == p₁₁₋')
  {sq₀₋₋' : Square p₀₋₀ p₀₀₋' p₀₁₋' p₀₋₁} (sq₀₋₋= : adapt-square sq₀₋₋ p₀₀₋= p₀₁₋= == sq₀₋₋') -- back
  {sq₋₀₋' : Square p₋₀₀ p₀₀₋' p₁₀₋' p₋₀₁} (sq₋₀₋= : adapt-square sq₋₀₋ p₀₀₋= p₁₀₋= == sq₋₀₋') -- top
  {sq₋₁₋' : Square p₋₁₀ p₀₁₋' p₁₁₋' p₋₁₁} (sq₋₁₋= : adapt-square sq₋₁₋ p₀₁₋= p₁₁₋= == sq₋₁₋') -- bottom
  {sq₁₋₋' : Square p₁₋₀ p₁₀₋' p₁₁₋' p₁₋₁} (sq₁₋₋= : adapt-square sq₁₋₋ p₁₀₋= p₁₁₋= == sq₁₋₋') -- front

  → Cube sq₋₋₀ sq₋₋₁ sq₀₋₋' sq₋₀₋' sq₋₁₋' sq₁₋₋'
adapt-cube idc idp idp idp idp idp idp idp idp = idc

adapt-cube-idp : ∀ {i} {A : Type i} {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ : A}
  {p₀₋₀ : a₀₀₀ == a₀₁₀} {p₋₀₀ : a₀₀₀ == a₁₀₀}
  {p₋₁₀ : a₀₁₀ == a₁₁₀} {p₁₋₀ : a₁₀₀ == a₁₁₀}
  {sq₋₋₀ : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀} -- left

  {p₀₋₁ : a₀₀₁ == a₀₁₁} {p₋₀₁ : a₀₀₁ == a₁₀₁}
  {p₋₁₁ : a₀₁₁ == a₁₁₁} {p₁₋₁ : a₁₀₁ == a₁₁₁}
  {sq₋₋₁ : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁} -- right

  {p₀₀₋ : a₀₀₀ == a₀₀₁} {p₀₁₋ : a₀₁₀ == a₀₁₁}
  {p₁₀₋ : a₁₀₀ == a₁₀₁} {p₁₁₋ : a₁₁₀ == a₁₁₁}
  {sq₀₋₋ : Square p₀₋₀ p₀₀₋ p₀₁₋ p₀₋₁} -- back
  {sq₋₀₋ : Square p₋₀₀ p₀₀₋ p₁₀₋ p₋₀₁} -- top
  {sq₋₁₋ : Square p₋₁₀ p₀₁₋ p₁₁₋ p₋₁₁} -- bottom
  {sq₁₋₋ : Square p₁₋₀ p₁₀₋ p₁₁₋ p₁₋₁} -- front
  (cube : Cube sq₋₋₀ sq₋₋₁ sq₀₋₋ sq₋₀₋ sq₋₁₋ sq₁₋₋ )

  {sq₀₋₋' : Square p₀₋₀ p₀₀₋ p₀₁₋ p₀₋₁} (sq₀₋₋= : sq₀₋₋ == sq₀₋₋') -- back
  {sq₋₀₋' : Square p₋₀₀ p₀₀₋ p₁₀₋ p₋₀₁} (sq₋₀₋= : sq₋₀₋ == sq₋₀₋') -- top
  {sq₋₁₋' : Square p₋₁₀ p₀₁₋ p₁₁₋ p₋₁₁} (sq₋₁₋= : sq₋₁₋ == sq₋₁₋') -- bottom
  {sq₁₋₋' : Square p₁₋₀ p₁₀₋ p₁₁₋ p₁₋₁} (sq₁₋₋= : sq₁₋₋ == sq₁₋₋') -- front

  → Cube sq₋₋₀ sq₋₋₁ sq₀₋₋' sq₋₀₋' sq₋₁₋' sq₁₋₋'
adapt-cube-idp idc idp idp idp idp = idc

{- A SquareOver between paths can be represented as a cube -}
module _ {i j} {A : Type i} {B : Type j} {f g : A → B}
  where

  cube-to-↓-square : {a : A} {a= : f a == g a}
    {b : A} {p : a == b} {c : A} {q : a == c} {d : A} {r : b == d} {s : c == d}
    {sq : Square p q r s}
    {fp : _} {fp= : ap f p == fp}
    {fq : _} {fq= : ap f q == fq}
    {fr : _} {fr= : ap f r == fr}
    {fs : _} {fs= : ap f s == fs}
    {b= : f b == g b}
    (p= : Square fp a= b= (ap g p))
    {c= : f c == g c}
    {q= : Square fq a= c= (ap g q)}
    {q□ : PathOver (λ z → f z == g z) q a= c=}
    (q□= : q□ == ↓-='-from-square fq= idp (square-symmetry q=))
    {d= : f d == g d}
    {r= : Square b= fr (ap g r) d=}
    {r□ : PathOver (λ z → f z == g z) r b= d=}
    (r□= : r□ == ↓-='-from-square fr= idp r=)
    (s= : Square fs c= d= (ap g s))
    → Cube (ap-square f sq) (ap-square g sq) (fp= |∙ p=) (fq= |∙ q=) (fr= |∙ square-symmetry r=) (fs= |∙ s=)
    → SquareOver (λ z → f z == g z) sq (↓-='-from-square fp= idp (square-symmetry p=))
                                       q□
                                       r□
                                       (↓-='-from-square fs= idp (square-symmetry s=))
  cube-to-↓-square {sq = ids} {fp= = idp} {fq= = idp} {fr= = idp} {fs= = idp} p= idp idp s= cube = & coh cube (& coh2)  where

    coh : Coh ({A : Type j} {x y : A} {a= b= : x == y} {p= : Square idp a= b= idp} {c= : x == y} {q= : Square idp a= c= idp} {d= : x == y} {r= : Square b= idp idp d=} {s=' : Square idp c= d= idp}
        → Cube ids ids (idp |∙ p=) (idp |∙ q=) (idp |∙ square-symmetry r=) s='
        → {s= : Square idp c= d= idp} (s== : s= == s=')
        → Square (horiz-degen-path (square-symmetry p=))
                 (horiz-degen-path (square-symmetry q=))
                 (horiz-degen-path r=)
                 (horiz-degen-path (square-symmetry s=)))
    coh = path-induction

    coh2 : Coh ({A : Type j} {a b c d : A} {p : a == b} {q : a == c} {r : b == d} {s : c == d} {sq : Square p q r s} → sq == idp |∙ sq)
    coh2 = path-induction

x-degen-cube-in : ∀ {i} → Coh ({A : Type i} {a b c d : A}
  {p : a == b} {q : a == c}
  {r : b == d} {s : c == d}
  {sq sq' : Square p q r s}
  → sq == sq'
  → Cube sq sq' hid-square hid-square hid-square hid-square)
x-degen-cube-in = path-induction

x-degen-cube-out : ∀ {i} → Coh ({A : Type i} {a b c d : A}
  {p : a == b} {q : a == c}
  {r : b == d} {s : c == d}
  {sq sq' : Square p q r s}
  → Cube sq sq' hid-square hid-square hid-square hid-square
  → sq == sq')
x-degen-cube-out = path-induction

{- A pathover between squares can be represented as a cube -}
module _ {i j} {A : Type i} {B : Type j} {b₀₀ b₀₁ b₁₀ b₁₁ : A → B}
  {p₀₋ : (a : A) → b₀₀ a == b₀₁ a} {p₋₀ : (a : A) → b₀₀ a == b₁₀ a}
  {p₋₁ : (a : A) → b₀₁ a == b₁₁ a} {p₁₋ : (a : A) → b₁₀ a == b₁₁ a}
  where

  cube-to-↓-path : {x y : A} {q : x == y}
    {sqx : Square (p₀₋ x) (p₋₀ x) (p₋₁ x) (p₁₋ x)}
    {sqy : Square (p₀₋ y) (p₋₀ y) (p₋₁ y) (p₁₋ y)}
    {b₀₀q : b₀₀ x == b₀₀ y} (b₀₀q= : ap b₀₀ q == b₀₀q)
    {b₀₁q : b₀₁ x == b₀₁ y} (b₀₁q= : ap b₀₁ q == b₀₁q)
    {b₁₀q : b₁₀ x == b₁₀ y} (b₁₀q= : ap b₁₀ q == b₁₀q)
    {b₁₁q : b₁₁ x == b₁₁ y} (b₁₁q= : ap b₁₁ q == b₁₁q)
    → Cube sqx sqy
           (natural-square p₀₋ q b₀₀q= b₀₁q=) (natural-square p₋₀ q b₀₀q= b₁₀q=)
           (natural-square p₋₁ q b₀₁q= b₁₁q=) (natural-square p₁₋ q b₁₀q= b₁₁q=)
    → sqx == sqy [ (λ z → Square (p₀₋ z) (p₋₀ z) (p₋₁ z) (p₁₋ z)) ↓ q ]
  cube-to-↓-path {q = idp} idp idp idp idp cu = & x-degen-cube-out cu

_|∙³_ : ∀ {i} {A : Type i}
  {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ : A}
  {p₀₋₀ p₀₋₀' : a₀₀₀ == a₀₁₀} {p₋₀₀ p₋₀₀' : a₀₀₀ == a₁₀₀}
  {p₋₁₀ p₋₁₀' : a₀₁₀ == a₁₁₀} {p₁₋₀ p₁₋₀' : a₁₀₀ == a₁₁₀}
  {sq₋₋₀ : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀} -- left

  {p₀₋₀= : p₀₋₀ == p₀₋₀'} {p₋₀₀= : p₋₀₀ == p₋₀₀'}
  {p₋₁₀= : p₋₁₀ == p₋₁₀'} {p₁₋₀= : p₁₋₀ == p₁₋₀'}
  {sq₋₋₀' : Square p₀₋₀' p₋₀₀' p₋₁₀' p₁₋₀'} -- middle

  {p₀₋₁ : a₀₀₁ == a₀₁₁} {p₋₀₁ : a₀₀₁ == a₁₀₁}
  {p₋₁₁ : a₀₁₁ == a₁₁₁} {p₁₋₁ : a₁₀₁ == a₁₁₁}
  {sq₋₋₁ : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁} -- right

  {p₀₀₋ : a₀₀₀ == a₀₀₁} {p₀₁₋ : a₀₁₀ == a₀₁₁}
  {p₁₀₋ : a₁₀₀ == a₁₀₁} {p₁₁₋ : a₁₁₀ == a₁₁₁}
  {sq₀₋₋ : Square p₀₋₀' p₀₀₋ p₀₁₋ p₀₋₁} -- back
  {sq₋₀₋ : Square p₋₀₀' p₀₀₋ p₁₀₋ p₋₀₁} -- top
  {sq₋₁₋ : Square p₋₁₀' p₀₁₋ p₁₁₋ p₋₁₁} -- bottom
  {sq₁₋₋ : Square p₁₋₀' p₁₀₋ p₁₁₋ p₁₋₁} -- front

  → FlatCube sq₋₋₀ sq₋₋₀' p₀₋₀= p₋₀₀= p₋₁₀= p₁₋₀=
  → Cube sq₋₋₀' sq₋₋₁ sq₀₋₋ sq₋₀₋ sq₋₁₋ sq₁₋₋
  → Cube sq₋₋₀ sq₋₋₁ (p₀₋₀= |∙ sq₀₋₋) (p₋₀₀= |∙ sq₋₀₋) (p₋₁₀= |∙ sq₋₁₋) (p₁₋₀= |∙ sq₁₋₋)
idfc |∙³ idc = idc

_/∙³_ : ∀ {i} {A : Type i} {a b c d : A} {p p' : a == b} {q q' : a == c} {r r' : b == d} {s s' : c == d}
  {sq sq2 : Square p q r s} (sq= : sq == sq2)
  {sq' : Square p' q' r' s'} {p= : p == p'} {q= : q == q'} {r= : r == r'} {s= : s == s'}
  → FlatCube sq2 sq' p= q= r= s=
  → FlatCube sq sq' p= q= r= s=
idp /∙³ idfc = idfc

_∙³/_ : ∀ {i} {A : Type i} {a b c d : A} {p p' : a == b} {q q' : a == c} {r r' : b == d} {s s' : c == d}
  {sq : Square p q r s}
  {sq' : Square p' q' r' s'} {p= : p == p'} {q= : q == q'} {r= : r == r'} {s= : s == s'}
  → FlatCube sq sq' p= q= r= s=
  → {sq'2 : Square p' q' r' s'} → sq' == sq'2
  → FlatCube sq sq'2 p= q= r= s=
idfc ∙³/ idp = idfc

_∙fc_ : ∀ {i} {A : Type i} {a b c d : A} {p p' p'' : a == b} {q q' q'' : a == c} {r r' r'' : b == d} {s s' s'' : c == d}
  {sq : Square p q r s} {sq' : Square p' q' r' s'} {sq'' : Square p'' q'' r'' s''}
  {p= : p == p'} {q= : q == q'} {r= : r == r'} {s= : s == s'}
  {p=' : p' == p''} {q=' : q' == q''} {r=' : r' == r''} {s=' : s' == s''}
  → FlatCube sq  sq'  p=  q=  r=  s=
  → FlatCube sq' sq'' p=' q=' r=' s='
  → FlatCube sq  sq'' (p= ∙ p=') (q= ∙ q=') (r= ∙ r=') (s= ∙ s=')
idfc ∙fc idfc = idfc

infixr 80 _|∙³_ _-∙³_ _/∙³_ _∙fc_ _∙³/_

adapt-flatcube : ∀ {i} {A : Type i} {a b c d : A} {p p' : a == b} {q q' : a == c} {r r' : b == d} {s s' : c == d}
  {p= p=' : p == p'} (p== : p= == p=')
  {q= q=' : q == q'} (q== : q= == q=')
  {r= r=' : r == r'} (r== : r= == r=')
  {s= s=' : s == s'} (s== : s= == s=')
  {sq : Square p q r s} {sq' : Square p' q' r' s'}
  → FlatCube sq sq' p= q= r= s=
  → FlatCube sq sq' p=' q=' r=' s='
adapt-flatcube idp idp idp idp idfc = idfc

!² : ∀ {i} {A : Type i} {a b c d : A} {p : a == b} {q : a == c} {r : b == d} {s : c == d}
  → Square p q r s → Square s (! q) (! r) p
!² ids = ids

!³ : ∀ {i} {A : Type i}
  {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ : A}
  {p₀₋₀ : a₀₀₀ == a₀₁₀} {p₋₀₀ : a₀₀₀ == a₁₀₀}
  {p₋₁₀ : a₀₁₀ == a₁₁₀} {p₁₋₀ : a₁₀₀ == a₁₁₀}
  {sq₋₋₀ : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀} -- left

  {p₀₋₁ : a₀₀₁ == a₀₁₁} {p₋₀₁ : a₀₀₁ == a₁₀₁}
  {p₋₁₁ : a₀₁₁ == a₁₁₁} {p₁₋₁ : a₁₀₁ == a₁₁₁}
  {sq₋₋₁ : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁} -- right

  {p₀₀ : a₀₀₀ == a₀₀₁} {p₀₁ : a₀₁₀ == a₀₁₁}
  {p₁₀ : a₁₀₀ == a₁₀₁} {p₁₁ : a₁₁₀ == a₁₁₁}
  {sq₀₋ : Square p₀₋₀ p₀₀ p₀₁ p₀₋₁} -- back
  {sq₋₀ : Square p₋₀₀ p₀₀ p₁₀ p₋₀₁} -- top
  {sq₋₁ : Square p₋₁₀ p₀₁ p₁₁ p₋₁₁} -- bottom
  {sq₁₋ : Square p₁₋₀ p₁₀ p₁₁ p₁₋₁} -- front
  → Cube sq₋₋₀ sq₋₋₁ sq₀₋ sq₋₀ sq₋₁ sq₁₋
  → Cube sq₋₋₁ sq₋₋₀ (!² sq₀₋) (!² sq₋₀) (!² sq₋₁) (!² sq₁₋)
!³ idc = idc

natural-square-homotopy : ∀ {i j} {A : Type i} {B : Type j} {a : A}
  → Coh ({u v : A → B} {f g : (x : A) → u x == v x} (h : (x : A) → f x == g x)
      {b : A} (p : a == b)
      {up : u a == u b} {up= : ap u p == up}
      {vp : v a == v b} {vp= : ap v p == vp}
      → FlatCube (natural-square f p up= vp=) (natural-square g p up= vp=) (h a) idp idp (h b))
natural-square-homotopy = path-induction

natural-cube2 : ∀ {i j} {A : Type i} {B : Type j} {a : A} →
  Coh ({f g : A → B} (h : (a : A) → f a == g a) {b : A} {p : a == b} {c : A} {q : a == c} {d : A} {r : b == d}
  {s : c == d} (sq : Square p q r s)
  {fp : f a == f b} {fp= : ap f p == fp} {gp : g a == g b} {gp= : ap g p == gp}
  {fq : f a == f c} {fq= : ap f q == fq} {gq : g a == g c} {gq= : ap g q == gq}
  {fr : f b == f d} {fr= : ap f r == fr} {gr : g b == g d} {gr= : ap g r == gr}
  {fs : f c == f d} {fs= : ap f s == fs} {gs : g c == g d} {gs= : ap g s == gs}
  {fsq : Square fp fq fr fs} (fsq= : FlatCube (ap-square f sq) fsq fp= fq= fr= fs=)
  {gsq : Square gp gq gr gs} (gsq= : FlatCube (ap-square g sq) gsq gp= gq= gr= gs=)
  → Cube (natural-square h p fp= gp=) (natural-square h s fs= gs=) (natural-square h q fq= gq=) fsq gsq (natural-square h r fr= gr=))
natural-cube2 = path-induction

ap-square-idf : ∀ {i} {A : Type i} {a b c d : A} {p : a == b} {q : a == c} {r : b == d} {s : c == d}
  (sq : Square p q r s)
  → FlatCube (ap-square (λ z → z) sq) sq (ap-idf p) (ap-idf q) (ap-idf r) (ap-idf s)
ap-square-idf ids = idfc

hid-flatcube : ∀ {i} {A : Type i} {a b c d : A} {p : a == b} {q : a == c} {r : b == d} {s : c == d} (sq : Square p q r s)
  → FlatCube sq sq idp idp idp idp
hid-flatcube ids = idfc

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

  natural-square= : Coh ({f g : A → B} (h : (a : A) → f a == g a)
          {x y : A} {p p' : x == y} (p= : p == p')
          → {fp : f x == f y} {fp= : ap f p == fp} {fp' : f x == f y} {fp=' : ap f p' == fp'}
          → {gp : g x == g y} {gp= : ap g p == gp} {gp' : g x == g y} {gp=' : ap g p' == gp'}
          → {fp=fp' : fp == fp'} (fp=fp'= : Square (ap (ap f) p=) fp= fp=' fp=fp')
          → {gp=gp' : gp == gp'} (gp=gp'= : Square (ap (ap g) p=) gp= gp=' gp=gp')
          → FlatCube (natural-square h p fp= gp=) (natural-square h p' fp=' gp=') idp fp=fp' gp=gp' idp)
  natural-square= = path-induction

  -- More or less a special case of the previous one
  natural-square== : Coh ({f g : A → B} (h : (a : A) → f a == g a)
          {x y : A} (p : x == y)
          → {fp : f x == f y} {fp= : ap f p == fp} {fp' : f x == f y} {fp=' : ap f p == fp'}
          → {gp : g x == g y} {gp= : ap g p == gp} {gp' : g x == g y} {gp=' : ap g p == gp'}
          → {fpp' : fp == fp'} (fpp'= : ! fp= ∙ fp=' == fpp')
          → {gpp' : gp == gp'} (gpp'= : ! gp= ∙ gp=' == gpp')
          → FlatCube (natural-square h p fp= gp=) (natural-square h p fp=' gp=') idp fpp' gpp' idp)
  natural-square== = path-induction

∘-ap-square : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k} (g : B → C) (f : A → B)
  {a b c d : A} {p : a == b} {q : a == c} {r : b == d} {s : c == d} (sq : Square p q r s)
  → FlatCube (ap-square g (ap-square f sq)) (ap-square (g ∘ f) sq) (∘-ap g f p) (∘-ap g f q) (∘-ap g f r) (∘-ap g f s)
∘-ap-square g f ids = idfc

ap-square-∘ : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k} (g : B → C) (f : A → B)
  {a b c d : A} {p : a == b} {q : a == c} {r : b == d} {s : c == d} (sq : Square p q r s)
  → FlatCube (ap-square (g ∘ f) sq) (ap-square g (ap-square f sq)) (ap-∘ g f p) (ap-∘ g f q) (ap-∘ g f r) (ap-∘ g f s)
ap-square-∘ g f ids = idfc

-- Similar to [ap-square-natural-square]
natural-square-ap : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k} (f : B → C) →
  Coh ({a b : A} (p : a == b) {u v : A → B} (g : (x : A) → u x == v x)
      {fup : _} {fup= : ap (f ∘ u) p == fup}
      {fvp : _} {fvp= : ap (f ∘ v) p == fvp}
      {up : _} {up= : ap u p == up}
      {vp : _} {vp= : ap v p == vp}
      {apfup : ap f up == fup} (apfup= : Square (∘-ap f u p) (ap (ap f) up=) fup= apfup)
      {apfvp : ap f vp == fvp} (apfvp= : Square (∘-ap f v p) (ap (ap f) vp=) fvp= apfvp)
    → natural-square (ap f ∘ g) p fup= fvp= == adapt-square (ap-square f (natural-square g p up= vp=)) apfup apfvp)
natural-square-ap f = path-induction

cube-rotate : ∀ {i} {A : Type i}
  {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ : A}
  {p₀₋₀ : a₀₀₀ == a₀₁₀} {p₋₀₀ : a₀₀₀ == a₁₀₀}
  {p₋₁₀ : a₀₁₀ == a₁₁₀} {p₁₋₀ : a₁₀₀ == a₁₁₀}
  {sq₋₋₀ : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀} -- left

  {p₀₋₁ : a₀₀₁ == a₀₁₁} {p₋₀₁ : a₀₀₁ == a₁₀₁}
  {p₋₁₁ : a₀₁₁ == a₁₁₁} {p₁₋₁ : a₁₀₁ == a₁₁₁}
  {sq₋₋₁ : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁} -- right

  {p₀₀₋ : a₀₀₀ == a₀₀₁} {p₀₁₋ : a₀₁₀ == a₀₁₁}
  {p₁₀₋ : a₁₀₀ == a₁₀₁} {p₁₁₋ : a₁₁₀ == a₁₁₁}
  {sq₀₋₋ : Square p₀₋₀ p₀₀₋ p₀₁₋ p₀₋₁} -- back
  {sq₋₀₋ : Square p₋₀₀ p₀₀₋ p₁₀₋ p₋₀₁} -- top
  {sq₋₁₋ : Square p₋₁₀ p₀₁₋ p₁₁₋ p₋₁₁} -- bottom
  {sq₁₋₋ : Square p₁₋₀ p₁₀₋ p₁₁₋ p₁₋₁} -- front
  → Cube sq₋₋₀ sq₋₋₁ sq₀₋₋ sq₋₀₋ sq₋₁₋ sq₁₋₋
  → Cube sq₀₋₋ sq₁₋₋ sq₋₋₀ (square-symmetry sq₋₀₋) (square-symmetry sq₋₁₋) sq₋₋₁
cube-rotate idc = idc

horiz-degen-path-hid-square : ∀ {i} → Coh ({A : Type i} {x y : A} {p : x == y} → idp == horiz-degen-path (horiz-degen-square (idp {a = p})))
horiz-degen-path-hid-square = path-induction

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

  ↓-ap-in-=' : {x y : A} {p : x == y} (k : (x : A) → g (f x) == h (f x))
               {gfp : g (f x) == g (f y)} {gfp= : ap g (ap f p) == gfp}
    → ↓-ap-in (λ z → g z == h z) f (apd k p) == ↓-='-from-square gfp= idp (natural-square k p (ap-∘ g f p ∙ gfp=) (ap-∘ h f p))
  ↓-ap-in-=' {p = idp} k {gfp= = idp} = & horiz-degen-path-hid-square

module _ {i j} {A : Type i} {a : A} where
 instance
  JCubehorizdegensquare : {B : (p : idp {a = a} == idp) → Cube ids (horiz-degen-square p) ids ids ids ids → Type j}
    → Coh (B idp idc) → Coh ({p : idp == idp} (cube : Cube ids (horiz-degen-square p) ids ids ids ids) → B p cube)
  & (JCubehorizdegensquare {B} d) cube = B= (! horiz-degen-square-η) (! horiz-degen-square-β) horiz-degen-square-◂ cube (& (JCube2 {B = B'} d) cube) where

    B' : (p : Square {a₀₀ = a} idp idp idp idp) → Cube ids p ids ids ids ids → Type j
    B' p c = B (horiz-degen-path p) (c ∙³x & x-degen-cube-in (! horiz-degen-square-β))

    horiz-degen-square-◂ : ∀ {i} {A : Type i} {a a' : A} {p q : a == a'} {r : p == q} → ap horiz-degen-square (! (horiz-degen-square-η {r = r})) == ! horiz-degen-square-β
    horiz-degen-square-◂ {p = idp} {r = idp} = idp

    B= : {p' p : idp == idp} (p= : p == p') (p=' : horiz-degen-square p == horiz-degen-square p') (p== : ap horiz-degen-square p= == p=')
         (c : Cube ids (horiz-degen-square p) ids ids ids ids)
         → B p' (c ∙³x & x-degen-cube-in p=') → B p c
    B= idp _ idp c = transport (B _) (& eq c)  where

      eq : Coh ({sq : Square (idp {a = a}) idp idp idp} (c : Cube ids sq ids ids ids ids) → c ∙³x & x-degen-cube-in idp == c)
      eq = path-induction


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

-- adding eta/epsilon to PiPointed
-- separate file for presentation in paper

module PiPointedFrac where

open import Data.Empty
open import Data.Unit
open import Data.Sum
open import Data.Product
open import Relation.Binary.PropositionalEquality

open import Singleton

infixr 90 _#_
infixr 70 _×ᵤ_
infixr 60 _+ᵤ_
infixr 50 _⊚_
infix 100 !_

infixr 70 _∙×ᵤ_
infixr 60 _∙+ᵤl_
infixr 60 _∙+ᵤr_
infixr 70 _∙⊗_
infixr 60 _∙⊕ₗ_
infixr 60 _∙⊕ᵣ_
infixr 50 _∙⊚_
infix 100 !∙_

------------------------------------------------------------------------------
-- Pi

data 𝕌 : Set
⟦_⟧ : (A : 𝕌) → Set
data _⟷_ : 𝕌 → 𝕌 → Set
eval : {A B : 𝕌} → (A ⟷ B) → ⟦ A ⟧ → ⟦ B ⟧

data 𝕌 where
  𝟘       : 𝕌
  𝟙       : 𝕌
  _+ᵤ_    : 𝕌 → 𝕌 → 𝕌
  _×ᵤ_    : 𝕌 → 𝕌 → 𝕌

⟦ 𝟘 ⟧ = ⊥
⟦ 𝟙 ⟧ = ⊤
⟦ t₁ +ᵤ t₂ ⟧ = ⟦ t₁ ⟧ ⊎ ⟦ t₂ ⟧
⟦ t₁ ×ᵤ t₂ ⟧ = ⟦ t₁ ⟧ × ⟦ t₂ ⟧

data _⟷_ where
  unite₊l : {t : 𝕌} → 𝟘 +ᵤ t ⟷ t
  uniti₊l : {t : 𝕌} → t ⟷ 𝟘 +ᵤ t
  unite₊r : {t : 𝕌} → t +ᵤ 𝟘 ⟷ t
  uniti₊r : {t : 𝕌} → t ⟷ t +ᵤ 𝟘
  swap₊   : {t₁ t₂ : 𝕌} → t₁ +ᵤ t₂ ⟷ t₂ +ᵤ t₁
  assocl₊ : {t₁ t₂ t₃ : 𝕌} → t₁ +ᵤ (t₂ +ᵤ t₃) ⟷ (t₁ +ᵤ t₂) +ᵤ t₃
  assocr₊ : {t₁ t₂ t₃ : 𝕌} → (t₁ +ᵤ t₂) +ᵤ t₃ ⟷ t₁ +ᵤ (t₂ +ᵤ t₃)
  unite⋆l : {t : 𝕌} → 𝟙 ×ᵤ t ⟷ t
  uniti⋆l : {t : 𝕌} → t ⟷ 𝟙 ×ᵤ t
  unite⋆r : {t : 𝕌} → t ×ᵤ 𝟙 ⟷ t
  uniti⋆r : {t : 𝕌} → t ⟷ t ×ᵤ 𝟙
  swap⋆   : {t₁ t₂ : 𝕌} → t₁ ×ᵤ t₂ ⟷ t₂ ×ᵤ t₁
  assocl⋆ : {t₁ t₂ t₃ : 𝕌} → t₁ ×ᵤ (t₂ ×ᵤ t₃) ⟷ (t₁ ×ᵤ t₂) ×ᵤ t₃
  assocr⋆ : {t₁ t₂ t₃ : 𝕌} → (t₁ ×ᵤ t₂) ×ᵤ t₃ ⟷ t₁ ×ᵤ (t₂ ×ᵤ t₃)
  absorbr : {t : 𝕌} → 𝟘 ×ᵤ t ⟷ 𝟘
  absorbl : {t : 𝕌} → t ×ᵤ 𝟘 ⟷ 𝟘
  factorzr : {t : 𝕌} → 𝟘 ⟷ t ×ᵤ 𝟘
  factorzl : {t : 𝕌} → 𝟘 ⟷ 𝟘 ×ᵤ t
  dist    : {t₁ t₂ t₃ : 𝕌} → (t₁ +ᵤ t₂) ×ᵤ t₃ ⟷ (t₁ ×ᵤ t₃) +ᵤ (t₂ ×ᵤ t₃)
  factor  : {t₁ t₂ t₃ : 𝕌} → (t₁ ×ᵤ t₃) +ᵤ (t₂ ×ᵤ t₃) ⟷ (t₁ +ᵤ t₂) ×ᵤ t₃
  distl   : {t₁ t₂ t₃ : 𝕌} → t₁ ×ᵤ (t₂ +ᵤ t₃) ⟷ (t₁ ×ᵤ t₂) +ᵤ (t₁ ×ᵤ t₃)
  factorl : {t₁ t₂ t₃ : 𝕌 } → (t₁ ×ᵤ t₂) +ᵤ (t₁ ×ᵤ t₃) ⟷ t₁ ×ᵤ (t₂ +ᵤ t₃)
  id⟷     : {t : 𝕌} → t ⟷ t
  _⊚_     : {t₁ t₂ t₃ : 𝕌} → (t₁ ⟷ t₂) → (t₂ ⟷ t₃) → (t₁ ⟷ t₃)
  _⊕_     : {t₁ t₂ t₃ t₄ : 𝕌} → (t₁ ⟷ t₃) → (t₂ ⟷ t₄) → (t₁ +ᵤ t₂ ⟷ t₃ +ᵤ t₄)
  _⊗_     : {t₁ t₂ t₃ t₄ : 𝕌} → (t₁ ⟷ t₃) → (t₂ ⟷ t₄) → (t₁ ×ᵤ t₂ ⟷ t₃ ×ᵤ t₄)

!_ : {A B : 𝕌} → A ⟷ B → B ⟷ A
! unite₊l = uniti₊l
! uniti₊l = unite₊l
! unite₊r = uniti₊r
! uniti₊r = unite₊r
! swap₊ = swap₊
! assocl₊ = assocr₊
! assocr₊ = assocl₊
! unite⋆l = uniti⋆l
! uniti⋆l = unite⋆l
! unite⋆r = uniti⋆r
! uniti⋆r = unite⋆r
! swap⋆ = swap⋆
! assocl⋆ = assocr⋆
! assocr⋆ = assocl⋆
! absorbr = factorzl
! absorbl = factorzr
! factorzr = absorbl
! factorzl = absorbr
! dist = factor
! factor = dist
! distl = factorl
! factorl = distl
! id⟷ = id⟷
! (c₁ ⊚ c₂) = (! c₂) ⊚ (! c₁)
! (c₁ ⊕ c₂) = (! c₁) ⊕ (! c₂)
! (c₁ ⊗ c₂) = (! c₁) ⊗ (! c₂)

eval unite₊l (inj₂ v) = v
eval uniti₊l v  = inj₂ v
eval unite₊r (inj₁ v) = v
eval uniti₊r v  = inj₁ v
eval swap₊ (inj₁ v) = inj₂ v
eval swap₊ (inj₂ v) = inj₁ v
eval assocl₊ (inj₁ v) = inj₁ (inj₁ v)
eval assocl₊ (inj₂ (inj₁ v)) = inj₁ (inj₂ v)
eval assocl₊ (inj₂ (inj₂ v)) = inj₂ v
eval assocr₊ (inj₁ (inj₁ v)) = inj₁ v
eval assocr₊ (inj₁ (inj₂ v)) = inj₂ (inj₁ v)
eval assocr₊ (inj₂ v) = inj₂ (inj₂ v)
eval unite⋆l (tt , v) = v
eval uniti⋆l v = (tt , v)
eval unite⋆r (v , tt) = v
eval uniti⋆r v = (v , tt)
eval swap⋆ (v₁ , v₂)          = (v₂ , v₁)
eval assocl⋆ (v₁ , (v₂ , v₃)) = ((v₁ , v₂) , v₃)
eval assocr⋆ ((v₁ , v₂) , v₃) = (v₁ , (v₂ , v₃))
eval absorbl ()
eval absorbr ()
eval factorzl ()
eval factorzr ()
eval dist (inj₁ v₁ , v₃) = inj₁ (v₁ , v₃)
eval dist (inj₂ v₂ , v₃) = inj₂ (v₂ , v₃)
eval factor (inj₁ (v₁ , v₃)) = (inj₁ v₁ , v₃)
eval factor (inj₂ (v₂ , v₃)) = (inj₂ v₂ , v₃)
eval distl (v , inj₁ v₁) = inj₁ (v , v₁)
eval distl (v , inj₂ v₂) = inj₂ (v , v₂)
eval factorl (inj₁ (v , v₁)) = (v , inj₁ v₁)
eval factorl (inj₂ (v , v₂)) = (v , inj₂ v₂)
eval id⟷ v = v
eval (c₁ ⊚ c₂) v = eval c₂ (eval c₁ v)
eval (c₁ ⊕ c₂) (inj₁ v) = inj₁ (eval c₁ v)
eval (c₁ ⊕ c₂) (inj₂ v) = inj₂ (eval c₂ v)
eval (c₁ ⊗ c₂) (v₁ , v₂) = (eval c₁ v₁ , eval c₂ v₂)

ΠisRev : ∀ {A B} → (c : A ⟷ B) (a : ⟦ A ⟧) → eval (c ⊚ ! c) a ≡ a
ΠisRev unite₊l (inj₂ y) = refl
ΠisRev uniti₊l a = refl
ΠisRev unite₊r (inj₁ x) = refl
ΠisRev uniti₊r a = refl
ΠisRev swap₊ (inj₁ x) = refl
ΠisRev swap₊ (inj₂ y) = refl
ΠisRev assocl₊ (inj₁ x) = refl
ΠisRev assocl₊ (inj₂ (inj₁ x)) = refl
ΠisRev assocl₊ (inj₂ (inj₂ y)) = refl
ΠisRev assocr₊ (inj₁ (inj₁ x)) = refl
ΠisRev assocr₊ (inj₁ (inj₂ y)) = refl
ΠisRev assocr₊ (inj₂ y) = refl
ΠisRev unite⋆l (tt , y) = refl
ΠisRev uniti⋆l a = refl
ΠisRev unite⋆r (x , tt) = refl
ΠisRev uniti⋆r a = refl
ΠisRev swap⋆ (x , y) = refl
ΠisRev assocl⋆ (x , (y , z)) = refl
ΠisRev assocr⋆ ((x , y) , z) = refl
ΠisRev dist (inj₁ x , z) = refl
ΠisRev dist (inj₂ y , z) = refl
ΠisRev factor (inj₁ (x , z)) = refl
ΠisRev factor (inj₂ (y , z)) = refl
ΠisRev distl (x , inj₁ y) = refl
ΠisRev distl (x , inj₂ z) = refl
ΠisRev factorl (inj₁ (x , y)) = refl
ΠisRev factorl (inj₂ (x , z)) = refl
ΠisRev id⟷ a = refl
ΠisRev (c₁ ⊚ c₂) a rewrite ΠisRev c₂ (eval c₁ a) = ΠisRev c₁ a
ΠisRev (c₁ ⊕ c₂) (inj₁ x) rewrite ΠisRev c₁ x = refl
ΠisRev (c₁ ⊕ c₂) (inj₂ y) rewrite ΠisRev c₂ y = refl
ΠisRev (c₁ ⊗ c₂) (x , y) rewrite ΠisRev c₁ x | ΠisRev c₂ y = refl

------------------------------------------------------------------------------
-- Pointed types and singleton types

data ∙𝕌 : Set where
  _#_ : (t : 𝕌) → (v : ⟦ t ⟧) → ∙𝕌
  _∙×ᵤ_ : ∙𝕌 → ∙𝕌 → ∙𝕌
  _∙+ᵤl_ : ∙𝕌 → ∙𝕌 → ∙𝕌
  _∙+ᵤr_ : ∙𝕌 → ∙𝕌 → ∙𝕌
  Singᵤ : ∙𝕌 → ∙𝕌
  Recipᵤ : ∙𝕌 → ∙𝕌

∙⟦_⟧ : ∙𝕌 → Σ[ A ∈ Set ] A
∙⟦ t # v ⟧ = ⟦ t ⟧ , v
∙⟦ T₁ ∙×ᵤ T₂ ⟧ = zip _×_ _,_ ∙⟦ T₁ ⟧ ∙⟦ T₂ ⟧
∙⟦ T₁ ∙+ᵤl T₂ ⟧ = zip _⊎_ (λ x _ → inj₁ x) ∙⟦ T₁ ⟧ ∙⟦ T₂ ⟧
∙⟦ T₁ ∙+ᵤr T₂ ⟧ = zip _⊎_ (λ _ y → inj₂ y) ∙⟦ T₁ ⟧ ∙⟦ T₂ ⟧
∙⟦ Singᵤ T ⟧ = < uncurry Singleton , (λ y → proj₂ y , refl) > ∙⟦ T ⟧
∙⟦ Recipᵤ T ⟧ = < uncurry Recip , (λ _ _ → tt) > ∙⟦ T ⟧

∙𝟙 : ∙𝕌
∙𝟙 = 𝟙 # tt

data _∙⟶_ : ∙𝕌 → ∙𝕌 → Set where
  -- when we know the base type
  ∙c :  {t₁ t₂ : 𝕌} {v : ⟦ t₁ ⟧} →
        (c : t₁ ⟷ t₂) → t₁ # v ∙⟶ t₂ # (eval c v)
  ∙times# : {t₁ t₂ : 𝕌} {v₁ : ⟦ t₁ ⟧} {v₂ : ⟦ t₂ ⟧} →
            ((t₁ ×ᵤ t₂) # (v₁ , v₂)) ∙⟶ ((t₁ # v₁) ∙×ᵤ (t₂ # v₂))
  ∙#times : {t₁ t₂ : 𝕌} {v₁ : ⟦ t₁ ⟧} {v₂ : ⟦ t₂ ⟧} →
            ((t₁ # v₁) ∙×ᵤ (t₂ # v₂)) ∙⟶ ((t₁ ×ᵤ t₂) # (v₁ , v₂))
  -- some things need to be explicitly lifted
  ∙id⟷ : {T : ∙𝕌} → T ∙⟶ T
  _∙⊚_ : {T₁ T₂ T₃ : ∙𝕌} → (T₁ ∙⟶ T₂) → (T₂ ∙⟶ T₃) → (T₁ ∙⟶ T₃)
  ∙unite⋆l : {t : ∙𝕌} → ∙𝟙 ∙×ᵤ t ∙⟶ t
  ∙uniti⋆l : {t : ∙𝕌} → t ∙⟶ ∙𝟙 ∙×ᵤ t
  ∙unite⋆r : {t : ∙𝕌} → t ∙×ᵤ ∙𝟙 ∙⟶ t
  ∙uniti⋆r : {t : ∙𝕌} → t ∙⟶ t ∙×ᵤ ∙𝟙
  ∙swap⋆   : {T₁ T₂ : ∙𝕌} → T₁ ∙×ᵤ T₂ ∙⟶ T₂ ∙×ᵤ T₁
  ∙assocl⋆ : {T₁ T₂ T₃ : ∙𝕌} → T₁ ∙×ᵤ (T₂ ∙×ᵤ T₃) ∙⟶ (T₁ ∙×ᵤ T₂) ∙×ᵤ T₃
  ∙assocr⋆ : {T₁ T₂ T₃ : ∙𝕌} → (T₁ ∙×ᵤ T₂) ∙×ᵤ T₃ ∙⟶ T₁ ∙×ᵤ (T₂ ∙×ᵤ T₃)
  _∙⊗_ : {T₁ T₂ T₃ T₄ : ∙𝕌} → (T₁ ∙⟶ T₃) → (T₂ ∙⟶ T₄)
       → (T₁ ∙×ᵤ T₂ ∙⟶ T₃ ∙×ᵤ T₄)
  _∙⊕ₗ_ : {T₁ T₂ T₃ T₄ : ∙𝕌} → (T₁ ∙⟶ T₃) → (T₂ ∙⟶ T₄)
        → (T₁ ∙+ᵤl T₂ ∙⟶ T₃ ∙+ᵤl T₄)
  _∙⊕ᵣ_ : {T₁ T₂ T₃ T₄ : ∙𝕌} → (T₁ ∙⟶ T₃) → (T₂ ∙⟶ T₄)
        → (T₁ ∙+ᵤr T₂ ∙⟶ T₃ ∙+ᵤr T₄)
  -- monad
  return : (T : ∙𝕌) → T ∙⟶ Singᵤ T
  -- comonad
  extract : (T : ∙𝕌) → Singᵤ T ∙⟶ T
  -- eta/epsilon
  η : (T : ∙𝕌) → ∙𝟙 ∙⟶ (Singᵤ T ∙×ᵤ Recipᵤ T)
  ε : (T : ∙𝕌) → (Singᵤ T ∙×ᵤ Recipᵤ T) ∙⟶ ∙𝟙

tensor : {T₁ T₂ : ∙𝕌} → (Singᵤ T₁ ∙×ᵤ Singᵤ T₂) ∙⟶ Singᵤ (T₁ ∙×ᵤ T₂)
tensor {T₁} {T₂} = (extract T₁ ∙⊗ extract T₂) ∙⊚ return (T₁ ∙×ᵤ T₂)

untensor : {T₁ T₂ : ∙𝕌} → Singᵤ (T₁ ∙×ᵤ T₂) ∙⟶ (Singᵤ T₁ ∙×ᵤ Singᵤ T₂)
untensor {T₁} {T₂} = extract (T₁ ∙×ᵤ T₂) ∙⊚ (return T₁ ∙⊗ return T₂)

tensorl : {T₁ T₂ : ∙𝕌} → (Singᵤ T₁ ∙×ᵤ T₂) ∙⟶ Singᵤ (T₁ ∙×ᵤ T₂)
tensorl {T₁} {T₂} = (extract T₁ ∙⊗ ∙id⟷) ∙⊚ return (T₁ ∙×ᵤ T₂)

tensorr : {T₁ T₂ : ∙𝕌} → (T₁ ∙×ᵤ Singᵤ T₂) ∙⟶ Singᵤ (T₁ ∙×ᵤ T₂)
tensorr {T₁} {T₂} = (∙id⟷ ∙⊗ extract T₂) ∙⊚ return (T₁ ∙×ᵤ T₂)

cotensorl : {T₁ T₂ : ∙𝕌} → Singᵤ (T₁ ∙×ᵤ T₂) ∙⟶ (Singᵤ T₁ ∙×ᵤ T₂)
cotensorl {T₁} {T₂} = extract (T₁ ∙×ᵤ T₂) ∙⊚ (return T₁ ∙⊗ ∙id⟷)

cotensorr : {T₁ T₂ : ∙𝕌} → Singᵤ (T₁ ∙×ᵤ T₂) ∙⟶ (T₁ ∙×ᵤ Singᵤ T₂)
cotensorr {T₁} {T₂} = extract (T₁ ∙×ᵤ T₂) ∙⊚ (∙id⟷ ∙⊗ return T₂)

plusl : {T₁ T₂ : ∙𝕌} → (Singᵤ T₁ ∙+ᵤl T₂) ∙⟶ Singᵤ (T₁ ∙+ᵤl T₂)
plusl {T₁} {T₂} = (extract T₁ ∙⊕ₗ ∙id⟷) ∙⊚ return (T₁ ∙+ᵤl T₂)

plusr : {T₁ T₂ : ∙𝕌} → (T₁ ∙+ᵤr Singᵤ T₂) ∙⟶ Singᵤ (T₁ ∙+ᵤr T₂)
plusr {T₁} {T₂} = (∙id⟷ ∙⊕ᵣ extract T₂) ∙⊚ return (T₁ ∙+ᵤr T₂)

coplusl : {T₁ T₂ : ∙𝕌} → Singᵤ (T₁ ∙+ᵤl T₂) ∙⟶ (Singᵤ T₁ ∙+ᵤl T₂)
coplusl {T₁} {T₂} = extract (T₁ ∙+ᵤl T₂) ∙⊚ (return T₁ ∙⊕ₗ ∙id⟷)

coplusr : {T₁ T₂ : ∙𝕌} → Singᵤ (T₁ ∙+ᵤr T₂) ∙⟶ (T₁ ∙+ᵤr Singᵤ T₂)
coplusr {T₁} {T₂} = extract (T₁ ∙+ᵤr T₂) ∙⊚ (∙id⟷ ∙⊕ᵣ return T₂)

-- functor
∙Singᵤ : {T₁ T₂ : ∙𝕌} → (T₁ ∙⟶ T₂) → (Singᵤ T₁ ∙⟶ Singᵤ T₂)
∙Singᵤ {T₁} {T₂} c = extract T₁ ∙⊚ c ∙⊚ return T₂

join : {T₁ : ∙𝕌} → Singᵤ (Singᵤ T₁) ∙⟶ Singᵤ T₁
join {T₁} = extract (Singᵤ T₁)

duplicate : {T₁ : ∙𝕌} → Singᵤ T₁ ∙⟶ Singᵤ (Singᵤ T₁)
duplicate {T₁} = return (Singᵤ T₁)

!∙_ : {A B : ∙𝕌} → A ∙⟶ B → B ∙⟶ A
!∙ (∙c {t₁} {t₂} {v} c) = subst (λ x → t₂ # eval c v ∙⟶ t₁ # x) (ΠisRev c v) (∙c (! c))
!∙ ∙times# = ∙#times
!∙ ∙#times = ∙times#
!∙ ∙id⟷ = ∙id⟷
!∙ (c₁ ∙⊚ c₂) = (!∙ c₂) ∙⊚ (!∙ c₁)
!∙ ∙unite⋆l = ∙uniti⋆l
!∙ ∙uniti⋆l = ∙unite⋆l
!∙ ∙unite⋆r = ∙uniti⋆r
!∙ ∙uniti⋆r = ∙unite⋆r
!∙ ∙swap⋆ = ∙swap⋆
!∙ ∙assocl⋆ = ∙assocr⋆
!∙ ∙assocr⋆ = ∙assocl⋆
!∙ (c₁ ∙⊗ c₂) = (!∙ c₁) ∙⊗ (!∙ c₂)
!∙ (c₁ ∙⊕ₗ c₂) = (!∙ c₁) ∙⊕ₗ (!∙ c₂)
!∙ (c₁ ∙⊕ᵣ c₂) = (!∙ c₁) ∙⊕ᵣ (!∙ c₂)
!∙ return T = extract T
!∙ extract T = return T
!∙ η T = ε T
!∙ ε T = η T

∙eval : {T₁ T₂ : ∙𝕌} → (C : T₁ ∙⟶ T₂) →
  let (t₁ , v₁) = ∙⟦ T₁ ⟧
      (t₂ , v₂) = ∙⟦ T₂ ⟧
  in Σ (t₁ → t₂) (λ f → f v₁ ≡ v₂)
∙eval ∙id⟷ = (λ x → x) , refl
∙eval (∙c c) = eval c , refl
∙eval (C₁ ∙⊚ C₂) with ∙eval C₁ | ∙eval C₂
... | (f , p) | (g , q) = (λ x → g (f x)) , trans (cong g p) q
∙eval ∙unite⋆l = (λ {(tt , x) → x}) , refl
∙eval ∙uniti⋆l = (λ {x → (tt , x)}) , refl
∙eval ∙unite⋆r = (λ {(x , tt) → x}) , refl
∙eval ∙uniti⋆r = (λ {x → (x , tt)}) , refl
∙eval ∙swap⋆ = (λ {(x , y) → y , x}) , refl
∙eval ∙assocl⋆ = (λ {(x , (y , z)) → ((x , y) , z)}) , refl
∙eval ∙assocr⋆ = (λ {((x , y) , z) → (x , (y , z))}) , refl
∙eval (C₀ ∙⊗ C₁) with ∙eval C₀ | ∙eval C₁
... | (f , p) | (g , q) = (λ {(t₁ , t₂) → f t₁ , g t₂}) , cong₂ _,_ p q
∙eval (C₀ ∙⊕ₗ C₁) with ∙eval C₀ | ∙eval C₁
... | (f , p) | (g , q) = (λ { (inj₁ x) → inj₁ (f x)
                             ; (inj₂ y) → inj₂ (g y) })
                        , cong inj₁ p
∙eval (C₀ ∙⊕ᵣ C₁) with ∙eval C₀ | ∙eval C₁
... | (f , p) | (g , q) = (λ { (inj₁ x) → inj₁ (f x)
                             ; (inj₂ y) → inj₂ (g y) })
                        , cong inj₂ q
∙eval ∙times# = (λ x → x) , refl
∙eval ∙#times = (λ x → x) , refl
∙eval (return T) = (λ _ → proj₂ ∙⟦ T ⟧ , refl) , refl
∙eval (extract T) = (λ {(w , refl) → w}) , refl
∙eval (η T) = (λ tt → (proj₂ ∙⟦ T ⟧ , refl) , λ _ → tt) , refl
∙eval (ε T) = (λ { ((_ , refl) , f) → f (proj₂ ∙⟦ T ⟧ , refl)}) , refl

-- you don't need to prove this
∙ΠisRev : ∀ {T₁ T₂} → (c : T₁ ∙⟶ T₂) →
  let (t₁ , v₁) = ∙⟦ T₁ ⟧
      (t₂ , v₂) = ∙⟦ T₂ ⟧
      (f , pf) = ∙eval (c ∙⊚ !∙ c) in
  f v₁ ≡ v₁
∙ΠisRev c = proj₂ (∙eval (c ∙⊚ !∙ c))

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


open import Relation.Binary.Core

module PLRTree.Insert.Complete {A : Set}
                     (_≤_ : A → A → Set)
                     (tot≤ : Total _≤_) where

open import Data.Empty
open import Data.Sum renaming (_⊎_ to _∨_)
open import PLRTree {A}
open import PLRTree.Compound {A}
open import PLRTree.Insert _≤_ tot≤
open import PLRTree.Insert.Properties _≤_ tot≤
open import PLRTree.Complete {A}
open import PLRTree.Complete.Properties {A}
open import PLRTree.Equality {A}
open import PLRTree.Equality.Properties {A}

lemma-≃-⊥ : {l : PLRTree}(x : A) → l ≃ insert x l → ⊥
lemma-≃-⊥ {leaf} _ ()
lemma-≃-⊥ {node perfect x' l' r'} x l≃lᵢ
    with tot≤ x x' | l' | r' | l≃lᵢ
... | inj₁ x≤x' | leaf | leaf | ()
... | inj₁ x≤x' | leaf | node _ _ _ _ | ()
... | inj₁ x≤x' | node _ _ _ _ | leaf | ()
... | inj₁ x≤x' | node _ _ _ _ | node _ _ _ _ | ()
... | inj₂ x'≤x | leaf | leaf | ()
... | inj₂ x'≤x | leaf | node _ _ _ _ | ()
... | inj₂ x'≤x | node _ _ _ _ | leaf | ()
... | inj₂ x'≤x | node _ _ _ _ | node _ _ _ _ | ()
lemma-≃-⊥ {node left _ _ _} _ ()
lemma-≃-⊥ {node right _ _ _} _ ()

lemma-⋗-⊥ : {l : PLRTree}(x : A) → l ⋗ insert x l → ⊥
lemma-⋗-⊥ {leaf} _ ()
lemma-⋗-⊥ {node perfect x' l' r'} x l⋗lᵢ
    with tot≤ x x' | l' | r' | l⋗lᵢ
... | inj₁ x≤x' | leaf | leaf | ()
... | inj₁ x≤x' | leaf | node _ _ _ _ | ()
... | inj₁ x≤x' | node _ _ _ _ | leaf | ()
... | inj₁ x≤x' | node _ _ _ _ | node _ _ _ _ | ()
... | inj₂ x'≤x | leaf | leaf | ()
... | inj₂ x'≤x | leaf | node _ _ _ _ | ()
... | inj₂ x'≤x | node _ _ _ _ | leaf | ()
... | inj₂ x'≤x | node _ _ _ _ | node _ _ _ _ | ()
lemma-⋗-⊥ {node left _ _ _} _ ()
lemma-⋗-⊥ {node right _ _ _} _ ()

lemma-⋙-⊥ : {l r : PLRTree}(x : A) → l ⋙ r → l ⋗ insert x r → ⊥
lemma-⋙-⊥ x (⋙p l⋗r) l⋗rᵢ = lemma-≃-⊥ x (lemma-⋗* l⋗r l⋗rᵢ)
lemma-⋙-⊥ x (⋙l {l' = l''} y' y'' l'≃r' l''⋘r'' l'⋗r'') l⋗rᵢ
    with tot≤ x y''
... | inj₁ x≤y''
    with insert y'' l'' | lemma-insert-compound y'' l'' | l⋗rᵢ
... | node perfect _ _ _ | compound | ()
... | node left _ _ _ | compound | ()
... | node right _ _ _ | compound | ()
lemma-⋙-⊥ x (⋙l {l' = l''} y' y'' l'≃r' l''⋘r'' l'⋗r'') l⋗rᵢ | inj₂ y''≤x
    with insert x l'' | lemma-insert-compound x l'' | l⋗rᵢ
... | node perfect _ _ _ | compound | ()
... | node left _ _ _ | compound | ()
... | node right _ _ _ | compound | ()
lemma-⋙-⊥ x (⋙r {r' = r''} y' y'' l'≃r' l''⋙r'' l'≃l'') l⋗rᵢ
    with tot≤ x y''
... | inj₁ x≤y''
    with insert y'' r'' | lemma-insert-compound y'' r'' | l⋗rᵢ
... | node perfect _ _ _ | compound | ⋗nd .y' .x _ l''≃r''ᵢ l'⋗l'' = lemma-⋗refl-⊥ (lemma-⋗-≃ l'⋗l'' (sym≃ l'≃l''))
... | node left _ _ _ | compound | ()
... | node right _ _ _ | compound | ()
lemma-⋙-⊥ x (⋙r {r' = r''} y' y'' l'≃r' l''⋙r'' l'≃l'') l⋗rᵢ | inj₂ y''≤x
    with insert x r'' | lemma-insert-compound x r'' | l⋗rᵢ
... | node perfect _ _ _ | compound | ⋗nd .y' .y'' _ l''≃r''ᵢ l'⋗l'' = lemma-⋗refl-⊥ (lemma-⋗-≃ l'⋗l'' (sym≃ l'≃l''))
... | node left _ _ _ | compound | ()
... | node right _ _ _ | compound | ()

lemma-insert-≃ : {l r : PLRTree}{x : A} → Compound l → l ≃ r → insert x l ⋘ r
lemma-insert-≃ {node perfect y l r} {node perfect y' l' r'} {x} compound (≃nd .y .y' l≃r l'≃r' l≃l')
    with tot≤ x y | l | r | l≃r | l' | l≃l'
... | inj₁ x≤y | leaf | leaf | ≃lf | leaf | ≃lf = r⋘ x y' (⋙p (⋗lf y)) l'≃r' (⋗lf y)
... | inj₁ x≤y | node perfect z₁ _ _ | node perfect z₂ _ _ | ≃nd .z₁ .z₂ l₁≃r₁ l₂≃r₂ l₁≃l₂ | node perfect z₃ _ _ | ≃nd .z₁ .z₃ _ l₃≃r₃ l₁≃l₃
                                           = l⋘ x y' (lemma-insert-≃ compound (≃nd z₁ z₂ l₁≃r₁ l₂≃r₂ l₁≃l₂)) l'≃r' (≃nd z₂ z₃ l₂≃r₂ l₃≃r₃ (trans≃ (sym≃ l₁≃l₂) l₁≃l₃))
... | inj₂ y≤x | leaf | leaf | ≃lf | leaf | ≃lf = r⋘ y y' (⋙p (⋗lf x)) l'≃r' (⋗lf x)
... | inj₂ y≤x |  node perfect z₁ _ _ | node perfect z₂ _ _ | ≃nd .z₁ .z₂ l₁≃r₁ l₂≃r₂ l₁≃l₂ | node perfect z₃ _ _ | ≃nd .z₁ .z₃ _ l₃≃r₃ l₁≃l₃
                                           = l⋘ y y' (lemma-insert-≃ compound (≃nd z₁ z₂ l₁≃r₁ l₂≃r₂ l₁≃l₂)) l'≃r' (≃nd z₂ z₃ l₂≃r₂ l₃≃r₃ (trans≃ (sym≃ l₁≃l₂) l₁≃l₃))

lemma-insert-⋗' : {l r : PLRTree}(x : A) → l ⋗ r → Compound r → l ⋙ (insert x r)
lemma-insert-⋗' x (⋗nd {l} {r} {l'} {r'} y y' l≃r l'≃r' l⋗l') compound
    with tot≤ x y' | l' | r' | l'≃r' | l | l⋗l'
... | inj₁ x≤y' | leaf | leaf | ≃lf | node perfect x₁ leaf leaf | ⋗lf .x₁ = ⋙r y x l≃r (⋙p (⋗lf y')) (≃nd x₁ y' ≃lf ≃lf ≃lf)
... | inj₁ x≤y' | node perfect x₃ l₃ r₃ | node perfect x₄ l₄ r₄ | ≃nd .x₃ .x₄ l₃≃r₃ l₄≃r₄ l₃≃l₄ | node perfect x₁ l₁ r₁ | ⋗nd .x₁ .x₃ l₁≃r₁ _ l₁⋗l₃
    with tot≤ y' x₃ | l₃ | r₃ | l₃≃r₃ | l₁ | l₁⋗l₃
... | inj₁ y'≤x₃ | leaf | leaf | ≃lf | node perfect x'₁ leaf leaf | ⋗lf .x'₁
    with l₄ | l₃≃l₄
... | leaf | ≃lf =
                let _l'ᵢ⋘r' = r⋘ y' x₄ (⋙p (⋗lf x₃)) l₄≃r₄ (⋗lf x₃) ;
                     _l⋗r' = lemma-⋗-≃ (⋗nd x₁ y' l₁≃r₁ ≃lf (⋗lf x'₁)) (≃nd y' x₄ ≃lf l₄≃r₄ ≃lf)
                in ⋙l y x l≃r _l'ᵢ⋘r' _l⋗r'
lemma-insert-⋗' x (⋗nd y y' l≃r _ _) compound | inj₁ x≤y' | node perfect x₃ _ _ | node perfect x₄ _ _ | ≃nd .x₃ .x₄ _ l₄≃r₄ l₃≃l₄ | node perfect x₁ _ _ | ⋗nd .x₁ .x₃ l₁≃r₁ _ _ | inj₁ y'≤x₃ | node perfect x'₅ _ _ | node perfect x'₆ _ _ | ≃nd .x'₅ .x'₆  l'₅≃r'₅ l'₆≃r'₆ l'₅≃l'₆ | node perfect x'₁ _ _ | ⋗nd .x'₁ .x'₅ l'₁≃r'₁ _ l'₁⋗l'₅
    with lemma-⋙-⋗ (lemma-insert-⋗' x₃  (⋗nd x'₁ x'₅ l'₁≃r'₁ l'₅≃r'₅ l'₁⋗l'₅) compound) (lemma-⋗-≃ (⋗nd x'₁ x'₅ l'₁≃r'₁ l'₅≃r'₅ l'₁⋗l'₅) (≃nd x'₅ x'₆ l'₅≃r'₅ l'₆≃r'₆ l'₅≃l'₆))
... | inj₁ _l₃ᵢ⋘r₃ =
                let _l₁⋗l₃ = ⋗nd x'₁ x'₅ l'₁≃r'₁ l'₅≃r'₅ l'₁⋗l'₅ ;
                     _l₃≃r₃ = ≃nd x'₅ x'₆ l'₅≃r'₅ l'₆≃r'₆ l'₅≃l'₆ ;
                     _l'ᵢ⋘r' = l⋘ y' x₄ _l₃ᵢ⋘r₃  l₄≃r₄ (trans≃ (sym≃ _l₃≃r₃) l₃≃l₄) ;
                     _l⋗r' = lemma-⋗-≃ (⋗nd x₁ x₃ l₁≃r₁ _l₃≃r₃ _l₁⋗l₃) (≃nd x₃ x₄ _l₃≃r₃ l₄≃r₄ l₃≃l₄)
                in ⋙l y x l≃r _l'ᵢ⋘r' _l⋗r'
... | inj₂ _l₃ᵢ≃r₃
    with lemma-≃-⊥ x₃ (trans≃ (≃nd x'₅ x'₆ l'₅≃r'₅ l'₆≃r'₆ l'₅≃l'₆ ) (sym≃ _l₃ᵢ≃r₃))
... | ()
lemma-insert-⋗' x (⋗nd y y' l≃r _ _) compound | inj₁ x≤y' | node perfect x₃ _ _ | node perfect x₄ l₄ _ | ≃nd .x₃ .x₄ _ l₄≃r₄ l₃≃l₄ | node perfect x₁ _ _ | ⋗nd .x₁ .x₃ l₁≃r₁ _ l₁⋗l₃ | inj₂ x₃≤y' | leaf | leaf | ≃lf | node perfect x'₁ leaf leaf | ⋗lf .x'₁
    with l₄ | l₃≃l₄
... | leaf | ≃lf =
                let _l'ᵢ⋘r' = r⋘ x₃ x₄ (⋙p (⋗lf y')) l₄≃r₄ (⋗lf y') ;
                     _l⋗r' = lemma-⋗-≃ (⋗nd x₁ x₃ l₁≃r₁ ≃lf (⋗lf x'₁)) (≃nd x₃ x₄ ≃lf l₄≃r₄ ≃lf)
                in ⋙l y x l≃r _l'ᵢ⋘r' _l⋗r'
lemma-insert-⋗' x (⋗nd y y' l≃r _ _) compound | inj₁ x≤y' | node perfect x₃ _ _ | node perfect x₄ _ _ | ≃nd .x₃ .x₄ l₃≃r₃ l₄≃r₄ l₃≃l₄ | node perfect x₁ _ _ | ⋗nd .x₁ .x₃ l₁≃r₁ _ l₁⋗l₃ | inj₂ x₃≤y' | node perfect x'₅ _ _ | node perfect x'₆ _ _ | ≃nd .x'₅ .x'₆ l'₅≃r'₅ l'₆≃r'₆ l'₅≃l'₆ | node perfect x'₁ _ _ | ⋗nd .x'₁ .x'₅ l'₁≃r'₁ _ l'₁⋗l'₅
    with lemma-⋙-⋗ (lemma-insert-⋗' y'  (⋗nd x'₁ x'₅ l'₁≃r'₁ l'₅≃r'₅ l'₁⋗l'₅) compound) (lemma-⋗-≃ (⋗nd x'₁ x'₅ l'₁≃r'₁ l'₅≃r'₅ l'₁⋗l'₅) (≃nd x'₅ x'₆ l'₅≃r'₅ l'₆≃r'₆ l'₅≃l'₆))
... | inj₁ _l₃ᵢ⋘r₃ =
                let _l₁⋗l₃ = ⋗nd x'₁ x'₅ l'₁≃r'₁ l'₅≃r'₅ l'₁⋗l'₅ ;
                     _l₃≃r₃ = ≃nd x'₅ x'₆ l'₅≃r'₅ l'₆≃r'₆ l'₅≃l'₆ ;
                     _l'ᵢ⋘r' = l⋘ x₃ x₄ _l₃ᵢ⋘r₃  l₄≃r₄ (trans≃ (sym≃ _l₃≃r₃) l₃≃l₄) ;
                     _l⋗r' = lemma-⋗-≃ (⋗nd x₁ x₃ l₁≃r₁ _l₃≃r₃ _l₁⋗l₃) (≃nd x₃ x₄ _l₃≃r₃ l₄≃r₄ l₃≃l₄)
                in ⋙l y x l≃r _l'ᵢ⋘r' _l⋗r'
... | inj₂ _l₃ᵢ≃r₃
    with lemma-≃-⊥ y' (trans≃ (≃nd x'₅ x'₆ l'₅≃r'₅ l'₆≃r'₆ l'₅≃l'₆ ) (sym≃ _l₃ᵢ≃r₃))
... | ()
lemma-insert-⋗' x (⋗nd y y' l≃r l'≃r' l⋗l') compound | inj₂ y'≤x | leaf | leaf | ≃lf | node perfect x₁ leaf leaf | ⋗lf .x₁ = ⋙r y y' l≃r (⋙p (⋗lf x)) (≃nd x₁ x ≃lf ≃lf ≃lf)
lemma-insert-⋗' x (⋗nd y y' l≃r _ _) compound | inj₂ y'≤x | node perfect x₃ l₃ r₃ | node perfect x₄ l₄ _ | ≃nd .x₃ .x₄ l₃≃r₃ l₄≃r₄ l₃≃l₄ | node perfect x₁ l₁ _ | ⋗nd .x₁ .x₃ l₁≃r₁ _ l₁⋗l₃
    with tot≤ x x₃ | l₃ | r₃ | l₃≃r₃ | l₁ | l₁⋗l₃
... | inj₁ x≤x₃ | leaf | leaf | ≃lf | node perfect x'₁ leaf leaf | ⋗lf .x'₁
    with l₄ | l₃≃l₄
... | leaf | ≃lf =
                let _l'ᵢ⋘r' = r⋘ x x₄ (⋙p (⋗lf x₃)) l₄≃r₄ (⋗lf x₃) ;
                     _l⋗r' = lemma-⋗-≃ (⋗nd x₁ x l₁≃r₁ ≃lf (⋗lf x'₁)) (≃nd x x₄ ≃lf l₄≃r₄ ≃lf)
                in ⋙l y y' l≃r _l'ᵢ⋘r' _l⋗r'
lemma-insert-⋗' x (⋗nd y y' l≃r _ _) compound | inj₂ y'≤x | node perfect x₃ _ _ | node perfect x₄ _ _ | ≃nd .x₃ .x₄ _ l₄≃r₄ l₃≃l₄ | node perfect x₁ _ _ | ⋗nd .x₁ .x₃ l₁≃r₁ _ _ | inj₁ x≤x₃ | node perfect x'₅ _ _ | node perfect x'₆ _ _ | ≃nd .x'₅ .x'₆  l'₅≃r'₅ l'₆≃r'₆ l'₅≃l'₆ | node perfect x'₁ _ _ | ⋗nd .x'₁ .x'₅ l'₁≃r'₁ _ l'₁⋗l'₅
    with lemma-⋙-⋗ (lemma-insert-⋗' x₃ (⋗nd x'₁ x'₅ l'₁≃r'₁ l'₅≃r'₅ l'₁⋗l'₅) compound) (lemma-⋗-≃ (⋗nd x'₁ x'₅ l'₁≃r'₁ l'₅≃r'₅ l'₁⋗l'₅) (≃nd x'₅ x'₆ l'₅≃r'₅ l'₆≃r'₆ l'₅≃l'₆))
... | inj₁ _l₃ᵢ⋘r₃ =
                let _l₁⋗l₃ = ⋗nd x'₁ x'₅ l'₁≃r'₁ l'₅≃r'₅ l'₁⋗l'₅ ;
                     _l₃≃r₃ = ≃nd x'₅ x'₆ l'₅≃r'₅ l'₆≃r'₆ l'₅≃l'₆ ;
                     _l'ᵢ⋘r' = l⋘ x x₄ _l₃ᵢ⋘r₃ l₄≃r₄ (trans≃ (sym≃ _l₃≃r₃) l₃≃l₄) ;
                     _l⋗r' = lemma-⋗-≃ (⋗nd x₁ x₃ l₁≃r₁ _l₃≃r₃ _l₁⋗l₃) (≃nd x₃ x₄ _l₃≃r₃ l₄≃r₄ l₃≃l₄)
                in ⋙l y y' l≃r _l'ᵢ⋘r' _l⋗r'
... | inj₂ _l₃ᵢ≃r₃
    with lemma-≃-⊥ x₃ (trans≃ (≃nd x'₅ x'₆ l'₅≃r'₅ l'₆≃r'₆ l'₅≃l'₆ ) (sym≃ _l₃ᵢ≃r₃))
... | ()
lemma-insert-⋗' x (⋗nd y y' l≃r _ _) compound | inj₂ y'≤x | node perfect x₃ _ _ | node perfect x₄ l₄ _ | ≃nd .x₃ .x₄ _ l₄≃r₄ l₃≃l₄ | node perfect x₁ _ _ | ⋗nd .x₁ .x₃ l₁≃r₁ _ _ | inj₂ x₃≤x | leaf | leaf | ≃lf | node perfect x'₁ leaf leaf | ⋗lf .x'₁
    with l₄ | l₃≃l₄
... | leaf | ≃lf =
                let _l'ᵢ⋘r' = r⋘ x₃ x₄ (⋙p (⋗lf x)) l₄≃r₄ (⋗lf x) ;
                     _l⋗r' = lemma-⋗-≃ (⋗nd x₁ x₃ l₁≃r₁ ≃lf (⋗lf x'₁)) (≃nd x₃ x₄ ≃lf l₄≃r₄ ≃lf)
                in ⋙l y y' l≃r _l'ᵢ⋘r' _l⋗r'
lemma-insert-⋗' x (⋗nd y y' l≃r _ _) compound | inj₂ y'≤x | node perfect x₃ _ _ | node perfect x₄ _ _ | ≃nd .x₃ .x₄ _ l₄≃r₄ l₃≃l₄ | node perfect x₁ _ _ | ⋗nd .x₁ .x₃ l₁≃r₁ _ _ | inj₂ x₃≤x | node perfect x'₅ _ _ | node perfect x'₆ _ _ | ≃nd .x'₅ .x'₆ l'₅≃r'₅ l'₆≃r'₆ l'₅≃l'₆ | node perfect x'₁ _ _ | ⋗nd .x'₁ .x'₅ l'₁≃r'₁ _ l'₁⋗l'₅
    with  lemma-⋙-⋗ (lemma-insert-⋗' x (⋗nd x'₁ x'₅ l'₁≃r'₁ l'₅≃r'₅ l'₁⋗l'₅) compound) (lemma-⋗-≃ (⋗nd x'₁ x'₅ l'₁≃r'₁ l'₅≃r'₅ l'₁⋗l'₅) (≃nd x'₅ x'₆ l'₅≃r'₅ l'₆≃r'₆ l'₅≃l'₆))
... | inj₁ _l₃ᵢ⋘r₃ =
                let _l₁⋗l₃ = ⋗nd x'₁ x'₅ l'₁≃r'₁ l'₅≃r'₅ l'₁⋗l'₅ ;
                     _l₃≃r₃ = ≃nd x'₅ x'₆ l'₅≃r'₅ l'₆≃r'₆ l'₅≃l'₆ ;
                     _l'ᵢ⋘r' = l⋘ x₃ x₄ _l₃ᵢ⋘r₃  l₄≃r₄ (trans≃ (sym≃ _l₃≃r₃) l₃≃l₄) ;
                     _l⋗r' = lemma-⋗-≃ (⋗nd x₁ x₃ l₁≃r₁ _l₃≃r₃ _l₁⋗l₃) (≃nd x₃ x₄ _l₃≃r₃ l₄≃r₄ l₃≃l₄)
                in ⋙l y y' l≃r _l'ᵢ⋘r' _l⋗r'
... | inj₂ _l₃ᵢ≃r₃
    with lemma-≃-⊥ x (trans≃ (≃nd x'₅ x'₆ l'₅≃r'₅ l'₆≃r'₆ l'₅≃l'₆) (sym≃ _l₃ᵢ≃r₃))
... | ()

lemma-insert-⋗ : {l r : PLRTree}(x : A) → l ⋗ r → l ⋙ (insert x r) ∨ l ≃ (insert x r)
lemma-insert-⋗ x (⋗lf y) = inj₂ (≃nd y x ≃lf ≃lf ≃lf)
lemma-insert-⋗ x (⋗nd y y' l≃r l'≃r' l⋗l') = inj₁ (lemma-insert-⋗' x (⋗nd y y' l≃r l'≃r' l⋗l') compound)

mutual
  lemma-insert-⋘ : {l r : PLRTree}(x : A) → l ⋘ r → (insert x l) ⋘ r ∨ (insert x l) ⋗ r
  lemma-insert-⋘ x (x⋘ u v w)
      with tot≤ x u
  ... | inj₁ x≤u = inj₂ (⋗nd x w (≃nd v u ≃lf ≃lf ≃lf) ≃lf (⋗lf v))
  ... | inj₂ u≤x = inj₂ (⋗nd u w (≃nd v x ≃lf ≃lf ≃lf) ≃lf (⋗lf v))
  lemma-insert-⋘ x (l⋘ {l = l} y y' l⋘r l'≃r' r≃l')
      with tot≤ x y
  ... | inj₁ x≤y
      with insert y l | lemma-insert-compound y l | lemma-insert-⋘ y l⋘r
  ... | node left _ _ _ | compound | inj₁ lᵢ⋘r  = inj₁ (l⋘ x y' lᵢ⋘r l'≃r' r≃l')
  ... | node left _ _ _ | compound | inj₂ ()
  ... | node right _ _ _ | compound | inj₁ lᵢ⋙r  = inj₁ (l⋘ x y' lᵢ⋙r l'≃r' r≃l')
  ... | node right _ _ _ | compound | inj₂ ()
  ... | node perfect _ _ _ | compound | inj₂ lᵢ⋗r  = inj₁ (r⋘ x y' (⋙p lᵢ⋗r) l'≃r' (lemma-⋗-≃ lᵢ⋗r r≃l'))
  ... | node perfect _ _ _ | compound | inj₁ ()
  lemma-insert-⋘ x (l⋘ {l = l} y y' l⋘r l'≃r' r≃l') | inj₂ y≤x
      with insert x l | lemma-insert-compound x l | lemma-insert-⋘ x l⋘r
  ... | node left _ _ _ | compound | inj₁ lᵢ⋘r  = inj₁ (l⋘ y y' lᵢ⋘r l'≃r' r≃l')
  ... | node left _ _ _ | compound | inj₂ ()
  ... | node right _ _ _ | compound | inj₁ lᵢ⋘r  = inj₁ (l⋘ y y' lᵢ⋘r l'≃r' r≃l')
  ... | node right _ _ _ | compound | inj₂ ()
  ... | node perfect _ _ _ | compound | inj₂ lᵢ⋗r  = inj₁ (r⋘ y y' (⋙p lᵢ⋗r) l'≃r' (lemma-⋗-≃ lᵢ⋗r r≃l'))
  ... | node perfect _ _ _ | compound | inj₁ ()
  lemma-insert-⋘ x (r⋘ {r = r} y y' l⋙r l'≃r' l⋗l')
      with tot≤ x y
  ... | inj₁ x≤y
      with insert y r | lemma-insert-compound y r | lemma-insert-⋙ y l⋙r |  lemma-⋙-⊥ y l⋙r
  ... | node left _ _ _ | compound | inj₁ l⋙rᵢ | _ = inj₁ (r⋘ x y' l⋙rᵢ l'≃r' l⋗l')
  ... | node left _ _ _ | compound | inj₂ () | _
  ... | node right _ _ _ | compound | inj₁ l⋙rᵢ | _ = inj₁ (r⋘ x y' l⋙rᵢ l'≃r' l⋗l')
  ... | node right _ _ _ | compound | inj₂ () | _
  ... | node perfect _ _ _ | compound | inj₂ l≃rᵢ | _ = inj₂ (⋗nd x y' l≃rᵢ l'≃r' l⋗l')
  ... | node perfect _ _ _ | compound | inj₁ (⋙p l⋗rᵢ) | lemma-⋙-⊥'
      with lemma-⋙-⊥' l⋗rᵢ
  ... | ()
  lemma-insert-⋘ x (r⋘ {r = r} y y' l⋙r l'≃r' l⋗l') | inj₂ y'≤x
      with insert x r | lemma-insert-compound x r | lemma-insert-⋙ x l⋙r |  lemma-⋙-⊥ x l⋙r
  ... | node left _ _ _ | compound | inj₁ l⋙rᵢ | _ = inj₁ (r⋘ y y' l⋙rᵢ l'≃r' l⋗l')
  ... | node left _ _ _ | compound | inj₂ () | _
  ... | node right _ _ _ | compound | inj₁ l⋙rᵢ | _ = inj₁ (r⋘ y y' l⋙rᵢ l'≃r' l⋗l')
  ... | node right _ _ _ | compound | inj₂ () | _
  ... | node perfect _ _ _ | compound | inj₂ l≃rᵢ | _ = inj₂ (⋗nd y y' l≃rᵢ l'≃r' l⋗l')
  ... | node perfect _ _ _ | compound | inj₁ (⋙p l⋗rᵢ) | lemma-⋙-⊥'
      with lemma-⋙-⊥' l⋗rᵢ
  ... | ()

  lemma-insert-⋙ : {l r : PLRTree}(x : A) → l ⋙ r → l ⋙ (insert x r) ∨ l ≃ (insert x r)
  lemma-insert-⋙ x (⋙p l⋗r) = lemma-insert-⋗ x l⋗r
  lemma-insert-⋙ x (⋙l {l' = l'} y y' l≃r l'⋘r' l⋗r')
      with tot≤ x y'
  ... | inj₁ x≤y'
      with insert y' l' | lemma-insert-compound y' l' | lemma-insert-⋘ y' l'⋘r'
  ... | node left _ _ _ | compound | inj₁ l'ᵢ⋘r' = inj₁ (⋙l y x l≃r l'ᵢ⋘r' l⋗r')
  ... | node left _ _ _ | compound | inj₂ ()
  ... | node right _ _ _ | compound | inj₁ l'ᵢ⋙r' = inj₁ (⋙l y x l≃r l'ᵢ⋙r' l⋗r')
  ... | node right _ _ _ | compound | inj₂ ()
  ... | node perfect _ _ _ | compound | inj₂ l'ᵢ⋗r' = inj₁ (⋙r y x l≃r (⋙p l'ᵢ⋗r') (lemma-*⋗ l⋗r' l'ᵢ⋗r'))
  ... | node perfect _ _ _ | compound | inj₁ ()
  lemma-insert-⋙ x (⋙l {l' = l'} y y' l≃r l'⋘r' l⋗r') | inj₂ y'≤x
      with insert x l' | lemma-insert-compound x l' | lemma-insert-⋘ x l'⋘r'
  ... | node left _ _ _ | compound | inj₁ l'ᵢ⋘r' = inj₁ (⋙l y y' l≃r l'ᵢ⋘r' l⋗r')
  ... | node left _ _ _ | compound | inj₂ ()
  ... | node right _ _ _ | compound | inj₁ l'ᵢ⋘r' = inj₁ (⋙l y y' l≃r l'ᵢ⋘r' l⋗r')
  ... | node right _ _ _ | compound | inj₂ ()
  ... | node perfect _ _ _ | compound | inj₂ l'ᵢ⋗r' = inj₁ (⋙r y y' l≃r (⋙p l'ᵢ⋗r') (lemma-*⋗ l⋗r' l'ᵢ⋗r'))
  ... | node perfect _ _ _ | compound | inj₁ ()
  lemma-insert-⋙ x (⋙r {r' = r'} y y' l≃r l'⋙r' l≃l')
      with tot≤ x y'
  ... | inj₁ x≤y'
      with insert y' r' | lemma-insert-compound y' r' | lemma-insert-⋙ y' l'⋙r' |  lemma-⋙-⊥ y' l'⋙r'
  ... | node left _ _ _ | compound | inj₁ l'⋙r'ᵢ | _ = inj₁ (⋙r y x l≃r l'⋙r'ᵢ l≃l')
  ... | node left _ _ _ | compound | inj₂ () | _
  ... | node right _ _ _ | compound | inj₁ l'⋙r'ᵢ | _ = inj₁ (⋙r y x l≃r l'⋙r'ᵢ l≃l')
  ... | node right _ _ _ | compound | inj₂ () | _
  ... | node perfect _ _ _ | compound | inj₂ l'≃r'ᵢ | _ = inj₂ (≃nd y x l≃r l'≃r'ᵢ l≃l')
  ... | node perfect _ _ _ | compound | inj₁ (⋙p l'⋗r'ᵢ) | lemma-⋙-⊥'
      with lemma-⋙-⊥' l'⋗r'ᵢ
  ... | ()
  lemma-insert-⋙ x (⋙r {r' = r'} y y' l≃r l'⋙r' l≃l') | inj₂ y'≤x
      with insert x r' | lemma-insert-compound x r' | lemma-insert-⋙ x l'⋙r' |  lemma-⋙-⊥ x l'⋙r'
  ... | node left _ _ _ | compound | inj₁ l'⋙r'ᵢ | _ = inj₁ (⋙r y y' l≃r l'⋙r'ᵢ l≃l')
  ... | node left _ _ _ | compound | inj₂ () | _
  ... | node right _ _ _ | compound | inj₁ l'⋙r'ᵢ | _ = inj₁ (⋙r y y' l≃r l'⋙r'ᵢ l≃l')
  ... | node right _ _ _ | compound | inj₂ () | _
  ... | node perfect _ _ _ | compound | inj₂ l'≃r'ᵢ | _ = inj₂ (≃nd y y' l≃r l'≃r'ᵢ l≃l')
  ... | node perfect _ _ _ | compound | inj₁ (⋙p l'⋗r'ᵢ) | lemma-⋙-⊥'
      with lemma-⋙-⊥' l'⋗r'ᵢ
  ... | ()

lemma-insert-complete : {t : PLRTree}(x : A) → Complete t → Complete (insert x t)
lemma-insert-complete x leaf = perfect x leaf leaf ≃lf
lemma-insert-complete x (perfect {l} {r} y cl cr l≃r)
    with tot≤ x y | l | r | l≃r | lemma-insert-complete y cl | lemma-insert-complete x cl
... | inj₁ x≤y | leaf | leaf | ≃lf | _ | _ = right x (perfect y cr cr ≃lf) cr (⋙p (⋗lf y))
... | inj₁ x≤y | node perfect z' _ _ | node perfect z'' _ _ | ≃nd .z' .z'' l'≃r' l''≃r'' l'≃l'' | clᵢ | _ = left x clᵢ cr (lemma-insert-≃ compound (≃nd z' z'' l'≃r' l''≃r'' l'≃l''))
... | inj₂ y≤x | leaf | leaf | ≃lf | _ | _ = right y (perfect x cr cr ≃lf) cr (⋙p (⋗lf x))
... | inj₂ y≤x | node perfect z' _ _ | node perfect z'' _ _ | ≃nd .z' .z'' l'≃r' l''≃r'' l'≃l'' | _ | clᵢ = left y clᵢ cr (lemma-insert-≃ compound (≃nd z' z'' l'≃r' l''≃r'' l'≃l''))
lemma-insert-complete x (left {l} {r} y cl cr l⋘r)
    with tot≤ x y
... | inj₁ x≤y
    with insert y l | lemma-insert-complete y cl | lemma-insert-⋘ y l⋘r | lemma-insert-compound y l
... | node left _ _ _ | clᵢ | inj₁ lᵢ⋘r | compound = left x clᵢ cr lᵢ⋘r
... | node right _ _ _ | clᵢ | inj₁ lᵢ⋘r | compound = left x clᵢ cr lᵢ⋘r
... | node left _ _ _ | _ | inj₂ () | compound
... | node right _ _ _ | _ | inj₂ () | compound
... | node perfect _ _ _ | clᵢ | inj₂ lᵢ⋗r | compound = right x clᵢ cr (⋙p lᵢ⋗r)
... | node perfect x' l' r' | perfect .x' cl' cr' l'≃r' | inj₁ () | compound
lemma-insert-complete x (left {l} {r} y cl cr l⋘r) | inj₂ y≤x
    with insert x l |  lemma-insert-complete x cl | lemma-insert-⋘ x l⋘r | lemma-insert-compound x l
... | node left _ _ _ | clᵢ | inj₁ lᵢ⋘r | compound  = left y clᵢ cr lᵢ⋘r
... | node right _ _ _ | clᵢ | inj₁ lᵢ⋘r | compound  = left y clᵢ cr lᵢ⋘r
... | node left _ _ _ | _ | inj₂ () | compound
... | node right _ _ _ | _ | inj₂ () | compound
... | node perfect _ _ _ | clᵢ | inj₂ lᵢ⋗r | compound  = right y clᵢ cr (⋙p lᵢ⋗r)
... | node perfect x' l' r' | perfect .x' cl' cr' l'≃r' | inj₁ () | compound
lemma-insert-complete x (right {l} {r} y cl cr l⋙r)
    with tot≤ x y
... | inj₁ x≤y
    with insert y r | lemma-insert-complete y cr | lemma-insert-⋙ y l⋙r | lemma-insert-compound y r | lemma-⋙-⊥ y l⋙r
... | node left _ _ _ | crᵢ | inj₁ l⋙rᵢ | compound | _ = right x cl crᵢ l⋙rᵢ
... | node right _ _ _ | crᵢ | inj₁ l⋙rᵢ | compound | _ = right x cl crᵢ l⋙rᵢ
... | node left _ _ _ | _ | inj₂ () | compound | _
... | node right _ _ _ | _ | inj₂ () | compound | _
... | node perfect _ _ _ | crᵢ | inj₂ l≃rᵢ | compound | _ = perfect x cl crᵢ l≃rᵢ
... | node perfect x'' l'' r'' | perfect .x'' cl'' cr'' l''≃r'' | inj₁ (⋙p l⋗rᵢ) | compound |  lemma-⋙-⊥'
    with lemma-⋙-⊥' l⋗rᵢ
... | ()
lemma-insert-complete x (right {l} {r} y cl cr l⋙r) | inj₂ y≤x
    with insert x r |  lemma-insert-complete x cr | lemma-insert-⋙ x l⋙r | lemma-insert-compound x r | lemma-⋙-⊥ x l⋙r
... | node left _ _ _ | crᵢ | inj₁ l⋙rᵢ | compound | _ = right y cl crᵢ l⋙rᵢ
... | node right _ _ _ | crᵢ | inj₁ l⋙rᵢ | compound | _ = right y cl crᵢ l⋙rᵢ
... | node left _ _ _ | _ | inj₂ () | compound | _
... | node right _ _ _ | _ | inj₂ () | compound | _
... | node perfect _ _ _ | crᵢ | inj₂ l≃rᵢ | compound | _ = perfect y cl crᵢ l≃rᵢ
... | node perfect x'' l'' r'' | perfect .x'' cl'' cr'' l''≃r'' | inj₁ (⋙p l⋗rᵢ) | compound | lemma-⋙-⊥'
    with lemma-⋙-⊥' l⋗rᵢ
... | ()


------------------------------------------------------------------------------
-- ABP terms
------------------------------------------------------------------------------

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

module FOTC.Program.ABP.Terms where

open import FOTC.Base
open import FOTC.Base.Loop
open import FOTC.Data.Bool

------------------------------------------------------------------------------
-- N.B. We did not define @Bit = Bool@ due to the issue #11.
Bit : D → Set
Bit b = Bool b
{-# ATP definition Bit #-}

F T : D
F = false
T = true
{-# ATP definition F T #-}

postulate
  <_,_> : D → D → D
  ok    : D → D


------------------------------------------------------------------------
-- Full β-reduction in pure type systems (PTS)
------------------------------------------------------------------------

module Pts.Reduction.Full where

open import Data.Fin.Substitution
open import Data.Fin.Substitution.ExtraLemmas
open import Data.Star using (ε; _◅_; map; gmap; _⋆)
open import Data.Sum using ([_,_])
open import Data.Product using (_,_; ∃; _×_)
open import Function using (_∘_)
open import Relation.Binary
import Relation.Binary.EquivalenceClosure as EqClos
import Relation.Binary.PropositionalEquality as P
import Relation.Binary.SymmetricClosure as SymClos
open import Relation.Binary.Reduction
import Function.Equivalence as Equiv

open import Pts.Syntax
open import Pts.Reduction.Parallel as Par hiding (reduction; _⋄*_; Π-inj)

-- All remaining submodules are parametrized by a given set of sorts.
module _ {Sort : Set} where

  open Syntax       Sort
  open Substitution Sort using (_[_])

  ----------------------------------------------------------------------
  -- Full β-reduction and equivalence relations

  infixl 9  _·₁_ _·₂_
  infix  5  _→β_

  -- One-step β-reduction.
  data _→β_ {n} : Term n → Term n → Set where
    cont : ∀ a b c                    → (ƛ a b) · c →β b [ c ]
    Π₁   : ∀ {a₁ a₂} → a₁ →β a₂ → ∀ b →      Π a₁ b →β Π a₂ b
    Π₂   : ∀ {b₁ b₂} a → b₁ →β b₂     →      Π a b₁ →β Π a b₂
    ƛ₁   : ∀ {a₁ a₂} → a₁ →β a₂ → ∀ b →      ƛ a₁ b →β ƛ a₂ b
    ƛ₂   : ∀ {b₁ b₂} a → b₁ →β b₂     →      ƛ a b₁ →β ƛ a b₂
    _·₁_ : ∀ {a₁ a₂} → a₁ →β a₂ → ∀ b →      a₁ · b →β a₂ · b
    _·₂_ : ∀ {b₁ b₂} a → b₁ →β b₂     →      a · b₁ →β a · b₂

  reduction : Reduction Term
  reduction = record { _→1_ = _→β_ }

  -- Full beta reduction and equivalence.
  open Reduction reduction public renaming (_→*_ to _→β*_; _↔_ to _≡β_)

  ----------------------------------------------------------------------
  -- Substitutions in full β-reductions/equivalence
  --
  -- The applications _/→β_, _/→β*_ and _/≡β_ below may be considered
  -- substitution lemmas, i.e. they establish the commutativity of the
  -- respective reductions/equivalence with substitutions.

  -- Application of generic substitutions to the
  -- reductions/equivalence.
  record BetaSubstApp {T} (l : Lift T Term) : Set where
    open Lift l
    open SubstApp Sort l
    open P hiding ([_])

    -- Substitutions commute.
    field /-sub-↑ : ∀ {m n} a b (σ : Sub T m n) →
                    a [ b ] / σ ≡ (a / σ ↑) [ b / σ ]

    infixl 8 _/→β_

    -- Substitution commutes with one-step β-reduction.
    _/→β_ : ∀ {m n a b} → a →β b → (σ : Sub T m n) → a / σ →β b / σ
    cont a b c /→β σ =
      subst (_→β_ _) (sym (/-sub-↑ b c σ)) (cont (a / σ) (b / σ ↑) (c / σ))
    Π₁ a₁→a₂ b /→β σ = Π₁ (a₁→a₂ /→β σ) (b / σ ↑)
    Π₂ a b₁→b₂ /→β σ = Π₂ (a / σ) (b₁→b₂ /→β σ ↑)
    ƛ₁ a₁→a₂ b /→β σ = ƛ₁ (a₁→a₂ /→β σ) (b / σ ↑)
    ƛ₂ a b₁→b₂ /→β σ = ƛ₂ (a / σ) (b₁→b₂ /→β σ ↑)
    a₁→a₂ ·₁ b /→β σ = (a₁→a₂ /→β σ) ·₁ (b / σ)
    a ·₂ b₁→b₂ /→β σ = (a / σ) ·₂ (b₁→b₂ /→β σ)

    redSubstApp : RedSubstApp reduction (record { _/_ = _/_ })
    redSubstApp = record { _/→1_ = _/→β_ }

    open RedSubstApp redSubstApp public
      hiding (_/→1_) renaming (_/→*_ to _/→β*_; _/↔_ to _/≡β_)

  -- Term substitutions in reductions/equivalences.
  module BetaSubstitution where
    open Substitution Sort
      using (termSubst; weaken; sub-commutes; varLiftSubLemmas)

    -- Application of renamings to reductions/equivalences.
    varSubstApp : BetaSubstApp (TermSubst.varLift termSubst)
    varSubstApp = record { /-sub-↑ = /-sub-↑ }
      where open LiftSubLemmas varLiftSubLemmas
    private module V = BetaSubstApp varSubstApp

    -- Weakening of one-step β-reductions.
    weaken-→β : ∀ {n} {a b : Term n} → a →β b → weaken a →β weaken b
    weaken-→β a→b = a→b V./→β VarSubst.wk

    -- Weakening of β-reductions.
    weaken-→β* : ∀ {n} {a b : Term n} → a →β* b → weaken a →β* weaken b
    weaken-→β* = gmap weaken weaken-→β

    -- Weakening of β-equivalences.
    weaken-≡β : ∀ {n} {a b : Term n} → a ≡β b → weaken a ≡β weaken b
    weaken-≡β = EqClos.gmap weaken weaken-→β

    -- Application of term substitutions to reductions/equivalences.
    termSubstApp : BetaSubstApp (TermSubst.termLift termSubst)
    termSubstApp = record { /-sub-↑ = λ a _ _ → sub-commutes a }
    open BetaSubstApp termSubstApp public

  ----------------------------------------------------------------------
  -- Simple properties of the β-reductions/equivalence

  -- Inclusions.
  →β⇒→β* = →1⇒→* reduction
  →β*⇒≡β = →*⇒↔  reduction
  →β⇒≡β  = →1⇒↔  reduction

  -- β-reduction is a preorder.
  →β*-predorder = →*-predorder reduction

  -- Preorder reasoning for β-reduction.
  module →β*-Reasoning = →*-Reasoning reduction

  -- Terms together with β-equivalence form a setoid.
  ≡β-setoid = ↔-setoid reduction

  -- Equational reasoning for β-equivalence.
  module ≡β-Reasoning = ↔-Reasoning reduction

  ----------------------------------------------------------------------
  -- Relationships between β-reduction and parallel reduction

  -- One-step β-reduction implies one-step parallel reduction.
  →β⇒⇛ : ∀ {n} {a b : Term n} → a →β b → a ⇛ b
  →β⇒⇛ (cont a b c) = cont refl refl
  →β⇒⇛ (Π₁ a₁→a₂ b) = Π (→β⇒⇛ a₁→a₂) refl
  →β⇒⇛ (Π₂ a b₁→b₂) = Π refl (→β⇒⇛ b₁→b₂)
  →β⇒⇛ (ƛ₁ a₁→a₂ b) = ƛ (→β⇒⇛ a₁→a₂) refl
  →β⇒⇛ (ƛ₂ a b₁→b₂) = ƛ refl (→β⇒⇛ b₁→b₂)
  →β⇒⇛ (a₁→a₂ ·₁ b) = →β⇒⇛ a₁→a₂ · refl
  →β⇒⇛ (a ·₂ b₁→b₂) = refl · →β⇒⇛ b₁→b₂

  -- β-reduction implies parallel reduction.
  →β*⇒⇛* : ∀ {n} {a b : Term n} → a →β* b → a ⇛* b
  →β*⇒⇛* = map →β⇒⇛

  -- β-equivalence implies parallel equivalence.
  ≡β⇒≡p : ∀ {n} {a b : Term n} → a ≡β b → a ≡p b
  ≡β⇒≡p = EqClos.map →β⇒⇛

  open →*-Reasoning reduction

  -- One-step parallel reduction implies β-reduction.
  ⇛⇒→β* : ∀ {n} {a b : Term n} → a ⇛ b → a →β* b
  ⇛⇒→β* refl            = ε
  ⇛⇒→β* (Π {a₁} {a₂} {b₁} {b₂} a₁⇛a₂ b₁⇛b₂) = begin
    Π a₁ b₁   ⟶⋆⟨ gmap (λ a → Π a _) (λ a₁→a₂ → Π₁ a₁→a₂ _) (⇛⇒→β* a₁⇛a₂) ⟩
    Π a₂ b₁   ⟶⋆⟨ gmap (Π _) (Π₂ _) (⇛⇒→β* b₁⇛b₂) ⟩
    Π a₂ b₂   ∎
  ⇛⇒→β* (ƛ {a₁} {a₂} {b₁} {b₂} a₁⇛a₂ b₁⇛b₂) = begin
    ƛ a₁ b₁   ⟶⋆⟨ gmap (λ a → ƛ a _) (λ a₁→a₂ → ƛ₁ a₁→a₂ _) (⇛⇒→β* a₁⇛a₂) ⟩
    ƛ a₂ b₁   ⟶⋆⟨ gmap (ƛ _) (ƛ₂ _) (⇛⇒→β* b₁⇛b₂) ⟩
    ƛ a₂ b₂   ∎
  ⇛⇒→β* (_·_ {a₁} {a₂} {b₁} {b₂} a₁⇛a₂ b₁⇛b₂) = begin
    a₁ · b₁   ⟶⋆⟨ gmap (λ a → a · _) (λ a₁→a₂ → a₁→a₂ ·₁ _) (⇛⇒→β* a₁⇛a₂) ⟩
    a₂ · b₁   ⟶⋆⟨ gmap (_·_ _) (_·₂_ _) (⇛⇒→β* b₁⇛b₂) ⟩
    a₂ · b₂   ∎
  ⇛⇒→β* (cont {a} {b₁} {b₂} {c₁} {c₂} b₁⇛b₂ c₁⇛c₂) = begin
    (ƛ a b₁) · c₁   ⟶⋆⟨ gmap (λ b → (ƛ _ b) · _)
                             (λ b₁→b₂ → (ƛ₂ _ b₁→b₂) ·₁ _) (⇛⇒→β* b₁⇛b₂) ⟩
    (ƛ a b₂) · c₁   ⟶⋆⟨ gmap (_·_ _) (_·₂_ _) (⇛⇒→β* c₁⇛c₂) ⟩
    (ƛ a b₂) · c₂   ⟶⟨ cont a b₂ c₂ ⟩
    b₂ [ c₂ ]       ∎

  -- Parallel reduction implies β-reduction.
  ⇛*⇒→β* : ∀ {n} {a b : Term n} → a ⇛* b → a →β* b
  ⇛*⇒→β* a⇛*b = (⇛⇒→β* ⋆) a⇛*b

  -- Parallel equivalence implies β-equivalence.
  ≡p⇒≡β : ∀ {n} {a b : Term n} → a ≡p b → a ≡β b
  ≡p⇒≡β a≡b = ([ ⇛⇒≡β , sym ∘ ⇛⇒≡β ] ⋆) a≡b
    where
      open Setoid ≡β-setoid using (sym)

      ⇛⇒≡β : ∀ {n} {a b : Term n} → a ⇛ b → a ≡β b
      ⇛⇒≡β = →*⇒↔ reduction ∘ ⇛⇒→β*

  open Equiv using (_⇔_; equivalence)

  -- Full β-reduction is equivalent to parallel reduction.
  →β*-⇛*-equivalence : ∀ {n} {a b : Term n} → a →β* b ⇔ a ⇛* b
  →β*-⇛*-equivalence = equivalence →β*⇒⇛* ⇛*⇒→β*

  -- β-equivalence is equivalent to parallel equivalence.
  ≡β-≡p-equivalence : ∀ {n} {a b : Term n} → a ≡β b ⇔ a ≡p b
  ≡β-≡p-equivalence = equivalence ≡β⇒≡p ≡p⇒≡β

  -- Shorthand for single-variable substitutions lifted to β-redcution.
  _[→β_] : ∀ {n} a {b₁ b₂ : Term n} → b₁ →β b₂ → a [ b₁ ] →β* a [ b₂ ]
  a [→β b₁→b₂ ] = ⇛⇒→β* (a / sub (→β⇒⇛ b₁→b₂))
    where open ParSubstitution using (_/_; sub)

  open P using (_≡_)

  -- Shapes are preserved by full β-reduction.

  sort-→β* : ∀ {n s} {a : Term n} → sort s →β* a → sort s ≡ a
  sort-→β* ε = P.refl
  sort-→β* (() ◅ _)

  ƛ-→β* : ∀ {n} {a : Term n} {b c} → ƛ a b →β* c →
          ∃ λ a′ → ∃ λ b′ → a →β* a′ × b →β* b′ × ƛ a′ b′ ≡ c
  ƛ-→β* λab→*c =
    let a′ , b′ , a⇛a′ , b⇛b′ , λa′b′≡c = ƛ-⇛* (→β*⇒⇛* λab→*c)
    in a′ , b′ , ⇛*⇒→β* a⇛a′ , ⇛*⇒→β* b⇛b′ , λa′b′≡c

  Π-→β* : ∀ {n} {a : Term n} {b c} → Π a b →β* c →
          ∃ λ a′ → ∃ λ b′ → a →β* a′ × b →β* b′ × Π a′ b′ ≡ c
  Π-→β* Πab→*c =
    let a′ , b′ , a⇛a′ , b⇛b′ , Πa′b′≡c = Π-⇛* (→β*⇒⇛* Πab→*c)
    in a′ , b′ , ⇛*⇒→β* a⇛a′ , ⇛*⇒→β* b⇛b′ , Πa′b′≡c

  ----------------------------------------------------------------------
  -- Confluence (aka the Church-Rosser property) of full β-reduction
  --
  -- Full β-reduction is confluent, i.e.  i.e. for any pair a →β* b₁,
  -- a →β* b₂ of parallel reductions, there is a term c, such that
  --
  --                               →β*
  --                           a ------→ b₂
  --                           |         :
  --                       →β* |         : →β*
  --                           ↓   →β*   ↓
  --                           b₁ ·····→ c
  --
  -- commutes.

  -- Confluence of _→β*_ (aka the Church-Rosser property).
  _⋄*_ : ∀ {n} {a b₁ b₂ : Term n} →
         a →β* b₁ → a →β* b₂ → ∃ λ c → b₁ →β* c × b₂ →β* c
  a→*b₁ ⋄* a→*b₂ =
    let c , b₁⇛*c , b₂⇛*c = (→β*⇒⇛* a→*b₁) Par.⋄* (→β*⇒⇛* a→*b₂)
    in c , ⇛*⇒→β* b₁⇛*c , ⇛*⇒→β* b₂⇛*c

  -- Factorization of β-equivalence into β-reductions.
  ≡β⇒→β* : ∀ {n} {a b : Term n} → a ≡β b → ∃ λ c → a →β* c × b →β* c
  ≡β⇒→β* a≡b =
    let c , a⇛*c , b⇛*c = ≡p⇒⇛* (≡β⇒≡p a≡b)
    in c , ⇛*⇒→β* a⇛*c , ⇛*⇒→β* b⇛*c

  -- Π-injectivity (with respect to ≡β).
  Π-inj : ∀ {n} {a₁ a₂ : Term n} {b₁ b₂} → Π a₁ b₁ ≡β Π a₂ b₂ →
          a₁ ≡β a₂ × b₁ ≡β b₂
  Π-inj Πa₁b₁≡Πa₂b₂ =
    let a₁≡a₂ , b₁≡b₂ = Par.Π-inj (≡β⇒≡p Πa₁b₁≡Πa₂b₂)
    in ≡p⇒≡β a₁≡a₂ , ≡p⇒≡β b₁≡b₂

  -- β-equivalence on sorts implies syntactic equivalence.
  sort-≡β : ∀ {n s₁ s₂} → sort {n} s₁ ≡β sort s₂ → s₁ ≡ s₂
  sort-≡β s₁≡βs₂ = Par.sort-≡p (≡β⇒≡p s₁≡βs₂)


{-# OPTIONS --rewriting #-}

-- {-# OPTIONS -v rewriting:100 #-}

postulate
  _↦_ : ∀ {i} {A : Set i} → A → A → Set i

{-# BUILTIN REWRITE _↦_ #-}

postulate
  Unit : Set
  tt : Unit

module _ {i} (P : Unit → Set i) (tt* : P tt) where

  postulate
    Unit-elim : (x : Unit) → P x
    Unit-β : Unit-elim tt ↦ tt*
  {-# REWRITE Unit-β #-}


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

pathological : (e : 9999999999 ≡ 9999999999) → Set
pathological refl = Nat


module Structure.Operator.Vector.LinearMap where

open import Functional
open import Logic
open import Logic.Predicate
open import Logic.Propositional
import      Lvl
open import Structure.Function
open import Structure.Function.Domain
open import Structure.Function.Multi
open import Structure.Operator
open import Structure.Operator.Field.VectorSpace
open import Structure.Operator.Properties using (Distributivityₗ ; Distributivityᵣ)
open import Structure.Operator.Vector
open import Structure.Setoid
open import Type
open import Syntax.Function
open import Syntax.Transitivity

private variable ℓ ℓᵥ ℓᵥₗ ℓᵥᵣ ℓₛ ℓᵥₑ ℓᵥₑₗ ℓᵥₑᵣ ℓᵥₑ₁ ℓᵥₑ₂ ℓᵥₑ₃ ℓₛₑ : Lvl.Level
private variable V Vₗ Vᵣ V₁ V₂ V₃ S : Type{ℓ}
private variable _+ᵥ_ _+ᵥₗ_ _+ᵥᵣ_ _+ᵥ₁_ _+ᵥ₂_ _+ᵥ₃_ : V → V → V
private variable _⋅ₛᵥ_ _⋅ₛᵥₗ_ _⋅ₛᵥᵣ_ _⋅ₛᵥ₁_ _⋅ₛᵥ₂_ _⋅ₛᵥ₃_ : S → V → V
private variable _+ₛ_ _⋅ₛ_ : S → S → S

module _
  ⦃ equiv-Vₗ : Equiv{ℓᵥₑₗ}(Vₗ) ⦄
  ⦃ equiv-Vᵣ : Equiv{ℓᵥₑᵣ}(Vᵣ) ⦄
  ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄
  (vectorSpaceₗ : VectorSpace{V = Vₗ}{S = S}(_+ᵥₗ_)(_⋅ₛᵥₗ_)(_+ₛ_)(_⋅ₛ_))
  (vectorSpaceᵣ : VectorSpace{V = Vᵣ}{S = S}(_+ᵥᵣ_)(_⋅ₛᵥᵣ_)(_+ₛ_)(_⋅ₛ_))
  (f : Vₗ → Vᵣ)
  where

  record LinearMap : Type{Lvl.of(Vₗ) Lvl.⊔ ℓᵥₑₗ Lvl.⊔ ℓᵥₑᵣ Lvl.⊔ Lvl.of(S)} where
    constructor intro
    field
      ⦃ function ⦄ : Function(f)
      ⦃ preserves-[+ᵥ]  ⦄ : Preserving₂(f)(_+ᵥₗ_)(_+ᵥᵣ_)
      ⦃ preserves-[⋅ₛᵥ] ⦄ : ∀{s} → Preserving₁(f)(s ⋅ₛᵥₗ_)(s ⋅ₛᵥᵣ_)

_→ˡⁱⁿᵉᵃʳᵐᵃᵖ_ : ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄ → VectorSpaceVObject{ℓᵥ = ℓᵥₗ}{ℓᵥₑ = ℓᵥₑₗ}{S = S}(_+ₛ_)(_⋅ₛ_) → VectorSpaceVObject{ℓᵥ = ℓᵥᵣ}{ℓᵥₑ = ℓᵥₑᵣ}{S = S}(_+ₛ_)(_⋅ₛ_) → Stmt
V₁ →ˡⁱⁿᵉᵃʳᵐᵃᵖ V₂ = ∃(LinearMap(VectorSpaceVObject.vectorSpace(V₁)) (VectorSpaceVObject.vectorSpace(V₂)))

_↔ˡⁱⁿᵉᵃʳᵐᵃᵖ_ : ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄ → VectorSpaceVObject{ℓᵥ = ℓᵥₗ}{ℓᵥₑ = ℓᵥₑₗ}{S = S}(_+ₛ_)(_⋅ₛ_) → VectorSpaceVObject{ℓᵥ = ℓᵥᵣ}{ℓᵥₑ = ℓᵥₑᵣ}{S = S}(_+ₛ_)(_⋅ₛ_) → Stmt
V₁ ↔ˡⁱⁿᵉᵃʳᵐᵃᵖ V₂ = ∃(f ↦ Invertible(f) ∧ LinearMap(VectorSpaceVObject.vectorSpace(V₁)) (VectorSpaceVObject.vectorSpace(V₂))(f))

module _
  ⦃ equiv-V : Equiv{ℓᵥₑ}(V) ⦄
  ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄
  (vectorSpace : VectorSpace{V = V}{S = S}(_+ᵥ_)(_⋅ₛᵥ_)(_+ₛ_)(_⋅ₛ_))
  (f : V → V)
  where

  LinearOperator = LinearMap(vectorSpace)(vectorSpace) (f)

module _
  ⦃ equiv-V : Equiv{ℓᵥₑ}(V) ⦄
  ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄
  (vectorSpace : VectorSpace{V = V}{S = S}(_+ᵥ_)(_⋅ₛᵥ_)(_+ₛ_)(_⋅ₛ_))
  (f : V → S)
  where

  LinearFunctional = LinearMap(vectorSpace)(fieldVectorSpace(VectorSpace.scalarField(vectorSpace))) (f)

module _
  ⦃ equiv-V₁ : Equiv{ℓᵥₑ₁}(V₁) ⦄
  ⦃ equiv-V₂ : Equiv{ℓᵥₑ₂}(V₂) ⦄
  ⦃ equiv-V₃ : Equiv{ℓᵥₑ₃}(V₃) ⦄
  ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄
  (vectorSpace₁ : VectorSpace{V = V₁}{S = S}(_+ᵥ₁_)(_⋅ₛᵥ₁_)(_+ₛ_)(_⋅ₛ_))
  (vectorSpace₂ : VectorSpace{V = V₂}{S = S}(_+ᵥ₂_)(_⋅ₛᵥ₂_)(_+ₛ_)(_⋅ₛ_))
  (vectorSpace₃ : VectorSpace{V = V₃}{S = S}(_+ᵥ₃_)(_⋅ₛᵥ₃_)(_+ₛ_)(_⋅ₛ_))
  (f : V₁ → V₂ → V₃)
  where

  record BilinearMap : Type{Lvl.of(V₁) Lvl.⊔ Lvl.of(V₂) Lvl.⊔ ℓᵥₑ₁ Lvl.⊔ ℓᵥₑ₂ Lvl.⊔ ℓᵥₑ₃ Lvl.⊔ Lvl.of(S)} where
    constructor intro
    field
      ⦃ linearMap₁ ⦄ : ∀{y} → LinearMap vectorSpace₁ vectorSpace₃ (x ↦ f(x)(y))
      ⦃ linearMap₂ ⦄ : ∀{x} → LinearMap vectorSpace₂ vectorSpace₃ (y ↦ f(x)(y))

    open module LinearMapₗ{y} = LinearMap(linearMap₁{y}) renaming (function to functionₗ ; preserves-[+ᵥ] to preserves-[+ᵥ]ₗ ; preserves-[⋅ₛᵥ] to preserves-[⋅ₛᵥ]ₗ) public
    open module LinearMapᵣ{x} = LinearMap(linearMap₂{x}) renaming (function to functionᵣ ; preserves-[+ᵥ] to preserves-[+ᵥ]ᵣ ; preserves-[⋅ₛᵥ] to preserves-[⋅ₛᵥ]ᵣ) public

    binaryOperator : BinaryOperator(f)
    binaryOperator = functions-to-binaryOperator(f) ⦃ functionₗ ⦄ ⦃ functionᵣ ⦄

module _
  ⦃ equiv-V : Equiv{ℓᵥₑ}(V) ⦄
  ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄
  (vectorSpace : VectorSpace{V = V}{S = S}(_+ᵥ_)(_⋅ₛᵥ_)(_+ₛ_)(_⋅ₛ_))
  (_▫_ : V → V → V)
  where

  BilinearOperator = BilinearMap(vectorSpace)(vectorSpace)(vectorSpace) (_▫_)
  module BilinearOperator(bilinearOper : BilinearOperator) where
    -- TODO: Move the proof for distributivity from preserving
    [+ᵥ]-distributivityₗ : Distributivityₗ(_▫_)(_+ᵥ_)
    Distributivityₗ.proof [+ᵥ]-distributivityₗ {x}{y}{z} =
      x ▫ (y +ᵥ z)       🝖[ _≡_ ]-[ preserving₂(x ▫_)(_+ᵥ_)(_+ᵥ_) ⦃ LinearMap.preserves-[+ᵥ] (BilinearMap.linearMap₂ bilinearOper) ⦄ ]
      (x ▫ y) +ᵥ (x ▫ z) 🝖-end

    [+ᵥ]-distributivityᵣ : Distributivityᵣ(_▫_)(_+ᵥ_)
    Distributivityᵣ.proof [+ᵥ]-distributivityᵣ {x}{y}{z} =
      (x +ᵥ y) ▫ z       🝖[ _≡_ ]-[ preserving₂(_▫ z)(_+ᵥ_)(_+ᵥ_) ⦃ LinearMap.preserves-[+ᵥ] (BilinearMap.linearMap₁ bilinearOper) ⦄ ]
      (x ▫ z) +ᵥ (y ▫ z) 🝖-end


-- Andreas, 2015-02-07 Failed with-abstraction in rewrite-generated with.
-- {-# OPTIONS -v tc.rewrite.top:25 -v tc.with.top:25 -v tc.with.abstract:50 #-}

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

module Issue1420 where

open import Common.Equality

postulate
  ▶    : Set → Set
  ▷    : ▶ Set → Set
  next : ∀{A}   → A → ▶ A
  _∗_  : ∀{A B} → ▶(A → B) → ▶ A → ▶ B

  ▶-def : ∀ A → ▷ (next A) ≡ ▶ A

  next∗ : ∀{A B : Set} (f : A → B) (a : A) →
          (next f ∗ next a) ≡ next (f a)

  Name : Set

data Tm : Set where
  name  : Name → Tm

data R : Tm → Set where
  name : ∀{x : Name} → R (name x)

print : Tm → ▶ Tm
print (name x) = next (name x)

-- Manually expanded with
test : ∀ (t : Tm) → ▷ (next R ∗ (print t))
test (name x) with next R ∗ next (name x) | next∗ R (name x)
... | ._ | refl rewrite ▶-def (R (name x)) = next name

-- Original rewrite
fails : ∀ (t : Tm) → ▷ (next R ∗ (print t))
fails (name x) rewrite next∗ R (name x) | ▶-def (R (name x)) = next name

-- should succeed


------------------------------------------------------------------------
-- The Agda standard library
--
-- Trie, basic type and operations
------------------------------------------------------------------------

-- See README.Data.Trie.NonDependent for an example of using a trie to
-- build a lexer.

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

open import Relation.Binary using (Rel; StrictTotalOrder)

module Data.Trie {k e r} (S : StrictTotalOrder k e r) where

open import Level
open import Size
open import Data.List.Base using (List; []; _∷_; _++_)
import Data.List.NonEmpty as List⁺
open import Data.Maybe.Base as Maybe using (Maybe; just; nothing; maybe′)
open import Data.Product as Prod using (∃)
open import Data.These.Base as These using (These)
open import Function
open import Relation.Unary using (IUniversal; _⇒_)

open StrictTotalOrder S
  using (module Eq)
  renaming (Carrier to Key)

open import Data.List.Relation.Binary.Equality.Setoid Eq.setoid
open import Data.AVL.Value ≋-setoid using (Value)

------------------------------------------------------------------------
-- Definition

-- Trie is defined in terms of Trie⁺, the type of non-empty trie. This
-- guarantees that the trie is minimal: each path in the tree leads to
-- either a value or a number of non-empty sub-tries.

open import Data.Trie.NonEmpty S as Trie⁺ public
  using (Trie⁺; Tries⁺; Word; eat)

Trie : ∀ {v} (V : Value v) → Size → Set (v ⊔ k ⊔ e ⊔ r)
Trie V i = Maybe (Trie⁺ V i)

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

-- Functions acting on Trie are wrappers for functions acting on Tries.
-- Sometimes the empty case is handled in a special way (e.g. insertWith
-- calls singleton when faced with an empty Trie).

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

  private Val = Value.family V

------------------------------------------------------------------------
-- Lookup

  lookup : ∀ ks → Trie V ∞ → Maybe (These (Val ks) (Tries⁺ (eat V ks) ∞))
  lookup ks t = t Maybe.>>= Trie⁺.lookup ks

  lookupValue : ∀ ks → Trie V ∞ → Maybe (Val ks)
  lookupValue ks t = t Maybe.>>= Trie⁺.lookupValue ks

  lookupTries⁺ : ∀ ks → Trie V ∞ → Maybe (Tries⁺ (eat V ks) ∞)
  lookupTries⁺ ks t = t Maybe.>>= Trie⁺.lookupTries⁺ ks

  lookupTrie : ∀ k → Trie V ∞ → Trie (eat V (k ∷ [])) ∞
  lookupTrie k t = t Maybe.>>= Trie⁺.lookupTrie⁺ k

------------------------------------------------------------------------
-- Construction

  empty : Trie V ∞
  empty = nothing

  singleton : ∀ ks → Val ks → Trie V ∞
  singleton ks v = just (Trie⁺.singleton ks v)

  insertWith : ∀ ks → (Maybe (Val ks) → Val ks) → Trie V ∞ → Trie V ∞
  insertWith ks f (just t) = just (Trie⁺.insertWith ks f t)
  insertWith ks f nothing  = singleton ks (f nothing)

  insert : ∀ ks → Val ks → Trie V ∞ → Trie V ∞
  insert ks = insertWith ks ∘′ const

  fromList : List (∃ Val) → Trie V ∞
  fromList = Maybe.map Trie⁺.fromList⁺ ∘′ List⁺.fromList

  toList : Trie V ∞ → List (∃ Val)
  toList (just t) = List⁺.toList (Trie⁺.toList⁺ t)
  toList nothing  = []

------------------------------------------------------------------------
-- Modification

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

  private
    Val = Value.family V
    Wal = Value.family W

  map : ∀ {i} → ∀[ Val ⇒ Wal ] → Trie V i → Trie W i
  map = Maybe.map ∘′ Trie⁺.map V W

-- Deletion

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

  -- Use a function to decide how to modify the sub-Trie⁺ whose root is
  -- at the end of path ks.
  deleteWith : ∀ {i} (ks : Word) →
     (∀ {i} → Trie⁺ (eat V ks) i → Maybe (Trie⁺ (eat V ks) i)) →
     Trie V i → Trie V i
  deleteWith ks f t = t Maybe.>>= Trie⁺.deleteWith ks f

  -- Remove the whole node
  deleteTrie⁺ : ∀ {i} (ks : Word) → Trie V i → Trie V i
  deleteTrie⁺ ks t = t Maybe.>>= Trie⁺.deleteTrie⁺ ks

  -- Remove the value and keep the sub-Tries (if any)
  deleteValue : ∀ {i} (ks : Word) → Trie V i → Trie V i
  deleteValue ks t = t Maybe.>>= Trie⁺.deleteValue ks

  -- Remove the sub-Tries and keep the value (if any)
  deleteTries⁺ : ∀ {i} (ks : Word) → Trie V i → Trie V i
  deleteTries⁺ ks t = t Maybe.>>= Trie⁺.deleteTries⁺ ks