{-

Technical results about elementary transformations

-}
{-# OPTIONS --safe #-}
module Cubical.Algebra.Matrix.Elementaries where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function

open import Cubical.Data.Nat hiding (_+_ ; _·_)
open import Cubical.Data.Nat.Order
open import Cubical.Data.Empty as Empty
open import Cubical.Data.Bool
open import Cubical.Data.FinData renaming (znots to znotsFin ; snotz to snotzFin)

open import Cubical.Relation.Nullary

open import Cubical.Algebra.RingSolver.Reflection
open import Cubical.Algebra.Ring.BigOps
open import Cubical.Algebra.CommRing

open import Cubical.Algebra.Matrix
open import Cubical.Algebra.Matrix.CommRingCoefficient
open import Cubical.Algebra.Matrix.RowTransformation

private
  variable
    ℓ : Level
    A : Type ℓ
    m n k l : ℕ

module ElemTransformation (𝓡 : CommRing ℓ) where

  private
    R = 𝓡 .fst

  open CommRingStr     (𝓡 .snd) renaming ( is-set to isSetR )
  open KroneckerDelta  (CommRing→Ring 𝓡)
  open Sum             (CommRing→Ring 𝓡)

  open Coefficient           𝓡
  open LinearTransformation  𝓡

  open SimRel
  open Sim

  open isLinear
  open isLinear2×2

  -- Swapping the first row with another

  swapMat : Mat 2 2
  swapMat zero zero = 0r
  swapMat zero one  = 1r
  swapMat one  zero = 1r
  swapMat one  one  = 0r

  uniSwapMat : swapMat ⋆ swapMat ≡ 𝟙
  uniSwapMat t zero zero =
    (mul2 swapMat swapMat zero zero ∙ helper) t
    where helper : 0r · 0r + 1r · 1r ≡ 1r
          helper = solve 𝓡
  uniSwapMat t zero one  =
    (mul2 swapMat swapMat zero one  ∙ helper) t
    where helper : 0r · 1r + 1r · 0r ≡ 0r
          helper = solve 𝓡
  uniSwapMat t one  zero =
    (mul2 swapMat swapMat one  zero ∙ helper) t
    where helper : 1r · 0r + 0r · 1r ≡ 0r
          helper = solve 𝓡
  uniSwapMat t one  one  =
    (mul2 swapMat swapMat one  one  ∙ helper) t
    where helper : 1r · 1r + 0r · 0r ≡ 1r
          helper = solve 𝓡

  isInvSwapMat2 : isInv swapMat
  isInvSwapMat2 .fst = swapMat
  isInvSwapMat2 .snd .fst = uniSwapMat
  isInvSwapMat2 .snd .snd = uniSwapMat

  swapRow2 : Mat 2 n → Mat 2 n
  swapRow2 M zero = M one
  swapRow2 M one  = M zero

  isLinear2×2SwapRow2 : isLinear2×2 {n = n} swapRow2
  isLinear2×2SwapRow2 .transMat _ = swapMat
  isLinear2×2SwapRow2 .transEq M t zero j =
    ((mul2 swapMat M zero j) ∙ helper _ _) (~ t)
    where helper : (a b : R) → 0r · a + 1r · b ≡ b
          helper = solve 𝓡
  isLinear2×2SwapRow2 .transEq M t one  j =
    ((mul2 swapMat M one  j) ∙ helper _ _) (~ t)
    where helper : (a b : R) → 1r · a + 0r · b ≡ a
          helper = solve 𝓡

  swapRow : (i₀ : Fin m)(M : Mat (suc m) n) → Mat (suc m) n
  swapRow i M zero = M (suc i)
  swapRow zero M one  = M zero
  swapRow zero M (suc (suc i)) = M (suc (suc i))
  swapRow (suc i₀) M one   = M one
  swapRow (suc i₀) M (suc (suc i)) = swapRow i₀ (takeRowsᶜ M) (suc i)

  swapRowMat : (i₀ : Fin m) → Mat (suc m) (suc m)
  swapRowMat = trans2RowsMat swapMat

  swapRowEq : (i₀ : Fin m)(M : Mat (suc m) n) → swapRow i₀ M ≡ swapRowMat i₀ ⋆ M
  swapRowEq {m = suc m} zero M t zero j =
      (helper1 _ _
    ∙ (λ t → 0r · M zero j + ∑Mulr1 _ (λ i → M (suc i) j) zero (~ t))
    ∙ (λ t → 0r · M zero j + ∑ (λ i → helper2 (δ i zero) (M (suc i) j) t))) t
    where helper1 : (a b : R) → b ≡ 0r · a + b
          helper1 = solve 𝓡
          helper2 : (a b : R) → b · a ≡ (1r · a) · b
          helper2 = solve 𝓡
  swapRowEq {m = suc m} zero M t one  j =
      (helper _
    ∙ (λ t → (1r · 1r) · M zero j + ∑Mul0r (λ i → M (suc i) j) (~ t))) t
    where helper : (a : R) → a ≡ (1r · 1r) · a + 0r
          helper = solve 𝓡
  swapRowEq {m = suc m} zero M t (suc (suc i)) j =
      (helper _ _
    ∙ (λ t → (1r · 0r) · M zero j + ∑Mul1r _ (λ l → M (suc l) j) (suc i) (~ t))) t
    where helper : (a b : R) → b ≡ (1r · 0r) · a + b
          helper = solve 𝓡
  swapRowEq {m = suc m} (suc i₀) M t zero j =
      (helper1 _ _
    ∙ (λ t → 0r · M zero j + ∑Mul1r _ (λ i → M (suc i) j) (suc i₀) (~ t))
    ∙ (λ t → 0r · M zero j + ∑ (λ l → helper2 (δ (suc i₀) l) (M (suc l) j) t))) t
    where helper1 : (a b : R) → b ≡ 0r · a + b
          helper1 = solve 𝓡
          helper2 : (a b : R) → a · b ≡ (1r · a) · b
          helper2 = solve 𝓡
  swapRowEq {m = suc m} (suc i₀) M t one  j =
        (helper _ _ --helper1 _ _
      ∙ (λ t → (1r · 0r) · M zero j + ∑Mul1r _ (λ i → M (suc i) j) zero (~ t))) t
    where helper : (a b : R) → b ≡ (1r · 0r) · a + b
          helper = solve 𝓡
  swapRowEq {m = suc m} (suc i₀) M t (suc (suc i)) j =
     ((λ t → swapRowEq i₀ (takeRowsᶜ M) t (suc i) j)
    ∙ helper _ (M one j) _) t
    where helper : (a b c : R) → a + c ≡ a + (0r · b + c)
          helper = solve 𝓡

  isLinearSwapRow : (i : Fin m) → isLinear (swapRow {n = n} i)
  isLinearSwapRow i .transMat _ = swapRowMat i
  isLinearSwapRow i .transEq    = swapRowEq  i

  isInvSwapMat : (i : Fin m)(M : Mat (suc m) (suc n)) → isInv (isLinearSwapRow i .transMat M)
  isInvSwapMat i _ = isInvTrans2RowsMat _ i isInvSwapMat2

  -- Similarity defined by swapping

  record SwapFirstRow (i : Fin m)(M : Mat (suc m) (suc n)) : Type ℓ where
    field
      sim : Sim M
      swapEq : (j : Fin (suc n)) → M (suc i) j ≡ sim .result zero j

  record SwapFirstCol (j : Fin n)(M : Mat (suc m) (suc n)) : Type ℓ where
    field
      sim : Sim M
      swapEq : (i : Fin (suc m)) → M i (suc j) ≡ sim .result i zero

  record SwapPivot (i : Fin (suc m))(j : Fin (suc n))(M : Mat (suc m) (suc n)) : Type ℓ where
    field
      sim : Sim M
      swapEq : M i j ≡ sim .result zero zero

  open SwapFirstRow
  open SwapFirstCol
  open SwapPivot

  swapFirstRow : (i : Fin m)(M : Mat (suc m) (suc n)) → SwapFirstRow i M
  swapFirstRow i M .sim .result    = swapRow i M
  swapFirstRow i M .sim .simrel .transMatL = isLinearSwapRow i .transMat M
  swapFirstRow i M .sim .simrel .transMatR = 𝟙
  swapFirstRow i M .sim .simrel .transEq     = isLinearSwapRow i .transEq _ ∙ sym (⋆rUnit _)
  swapFirstRow i M .sim .simrel .isInvTransL = isInvSwapMat i M
  swapFirstRow i M .sim .simrel .isInvTransR = isInv𝟙
  swapFirstRow i M .swapEq j = refl

  swapFirstCol : (j : Fin n)(M : Mat (suc m) (suc n)) → SwapFirstCol j M
  swapFirstCol j M .sim .result    = (swapRow j (M ᵗ))ᵗ
  swapFirstCol j M .sim .simrel .transMatL = 𝟙
  swapFirstCol j M .sim .simrel .transMatR = (isLinearSwapRow j .transMat (M ᵗ))ᵗ
  swapFirstCol j M .sim .simrel .transEq =
    let P = isLinearSwapRow j .transMat (M ᵗ) in
      (λ t → (isLinearSwapRow j .transEq (M ᵗ) t)ᵗ)
    ∙ compᵗ P (M ᵗ)
    ∙ (λ t → idemᵗ M t ⋆ P ᵗ)
    ∙ (λ t → ⋆lUnit M (~ t) ⋆ P ᵗ)
  swapFirstCol j M .sim .simrel .isInvTransL = isInv𝟙
  swapFirstCol j M .sim .simrel .isInvTransR =
    isInvᵗ {M = isLinearSwapRow j .transMat (M ᵗ)} (isInvSwapMat j (M ᵗ))
  swapFirstCol j M .swapEq i t = M i (suc j)

  swapPivot : (i : Fin (suc m))(j : Fin (suc n))(M : Mat (suc m) (suc n)) → SwapPivot i j M
  swapPivot zero zero M .sim    = idSim M
  swapPivot zero zero M .swapEq = refl
  swapPivot (suc i) zero M .sim    = swapFirstRow i M .sim
  swapPivot (suc i) zero M .swapEq = refl
  swapPivot zero (suc j) M .sim    = swapFirstCol j M .sim
  swapPivot zero (suc j) M .swapEq = refl
  swapPivot (suc i) (suc j) M .sim = compSim (swapFirstRow i M .sim) (swapFirstCol j _ .sim)
  swapPivot (suc i) (suc j) M .swapEq = refl

  -- Add the first row to another

  addMat : Mat 2 2
  addMat zero zero = 1r
  addMat zero one  = 0r
  addMat one  zero = 1r
  addMat one  one  = 1r

  subMat : Mat 2 2
  subMat zero zero = 1r
  subMat zero one  = 0r
  subMat one  zero = - 1r
  subMat one  one  = 1r

  add⋆subMat : addMat ⋆ subMat ≡ 𝟙
  add⋆subMat t zero zero =
    (mul2 addMat subMat zero zero ∙ helper) t
    where helper : 1r · 1r + 0r · - 1r ≡ 1r
          helper = solve 𝓡
  add⋆subMat t zero one  =
    (mul2 addMat subMat zero one  ∙ helper) t
    where helper : 1r · 0r + 0r · 1r ≡ 0r
          helper = solve 𝓡
  add⋆subMat t one  zero =
    (mul2 addMat subMat one  zero ∙ helper) t
    where helper : 1r · 1r + 1r · - 1r ≡ 0r
          helper = solve 𝓡
  add⋆subMat t one  one  =
    (mul2 addMat subMat one  one  ∙ helper) t
    where helper : 1r · 0r + 1r · 1r ≡ 1r
          helper = solve 𝓡

  sub⋆addMat : subMat ⋆ addMat ≡ 𝟙
  sub⋆addMat t zero zero =
    (mul2 subMat addMat  zero zero ∙ helper) t
    where helper : 1r · 1r + 0r · 1r ≡ 1r
          helper = solve 𝓡
  sub⋆addMat t zero one  =
    (mul2 subMat addMat  zero one  ∙ helper) t
    where helper : 1r · 0r + 0r · 1r ≡ 0r
          helper = solve 𝓡
  sub⋆addMat t one  zero =
    (mul2 subMat addMat  one  zero ∙ helper) t
    where helper : - 1r · 1r + 1r · 1r ≡ 0r
          helper = solve 𝓡
  sub⋆addMat t one  one  =
    (mul2 subMat addMat  one  one  ∙ helper) t
    where helper : - 1r · 0r + 1r · 1r ≡ 1r
          helper = solve 𝓡

  isInvAddMat2 : isInv addMat
  isInvAddMat2 .fst = subMat
  isInvAddMat2 .snd .fst = add⋆subMat
  isInvAddMat2 .snd .snd = sub⋆addMat

  addRow2 : Mat 2 n → Mat 2 n
  addRow2 M zero  = M zero
  addRow2 M one j = M zero j + M one j

  isLinear2AddRow2 : isLinear2×2 {n = n} addRow2
  isLinear2AddRow2 .transMat _ = addMat
  isLinear2AddRow2 .transEq M t zero j =
    ((mul2 addMat M zero j) ∙ helper _ _) (~ t)
    where helper : (a b : R) → 1r · a + 0r · b ≡ a
          helper = solve 𝓡
  isLinear2AddRow2 .transEq M t one  j =
    ((mul2 addMat M one  j) ∙ helper _ _) (~ t)
    where helper : (a b : R) → 1r · a + 1r · b ≡ a + b
          helper = solve 𝓡

  -- Add the first row to all other rows

  addRows : Mat (suc m) n → Mat (suc m) n
  addRows M zero = M zero
  addRows M (suc i) j = M zero j + M (suc i) j

  private
    firstRowStayInvariant : (M : Mat (suc m) n) → M zero ≡ transRows addRow2 M zero
    firstRowStayInvariant = invRow₀ _ (λ _ → refl)

  addRowsEq : (M : Mat (suc m) n) → transRows addRow2 M ≡ addRows M
  addRowsEq M t zero = firstRowStayInvariant M (~ t)
  addRowsEq M t one j = M zero j + M one j
  addRowsEq M t (suc (suc i)) j = takeCombShufRows addRow2 (λ N → addRowsEq N t) M (suc (suc i)) j

  isLinearAddRows : isLinear (addRows {m = m} {n = suc n})
  isLinearAddRows =
    let isLinear = isLinearTransRows _ isLinear2AddRow2 _
    in  record
          { transMat = isLinear .transMat
          ; transEq  = (λ M → sym (addRowsEq M) ∙ isLinear .transEq M) }

  isInvAddRows : (M : Mat (suc m) (suc n)) → isInv (isLinearAddRows .transMat M)
  isInvAddRows = isInvTransRows _ _ (λ _ → isInvAddMat2)

-- Similarity defined by adding rows

  record AddFirstRow (M : Mat (suc m) (suc n)) : Type ℓ where
    field
      sim : Sim M
      inv₀  : M zero ≡ sim .result zero
      addEq : (i : Fin m)(j : Fin (suc n)) → M zero j + M (suc i) j ≡ sim .result (suc i) j

  open AddFirstRow

  addFirstRow : (M : Mat (suc m) (suc n)) → AddFirstRow M
  addFirstRow M .sim .result    = addRows M
  addFirstRow M .sim .simrel .transMatL = isLinearAddRows .transMat M
  addFirstRow M .sim .simrel .transMatR = 𝟙
  addFirstRow M .sim .simrel .transEq     = isLinearAddRows .transEq _ ∙ sym (⋆rUnit _)
  addFirstRow M .sim .simrel .isInvTransL = isInvAddRows M
  addFirstRow M .sim .simrel .isInvTransR = isInv𝟙
  addFirstRow M .inv₀      = refl
  addFirstRow M .addEq i j = refl


--------------------------------------------------------------------------------
-- This is part of Agda Inference Systems

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

open import Agda.Builtin.Equality
open import Data.Product
open import Data.Sum
open import Codata.Thunk
open import Size
open import Level
open import Relation.Unary using (_⊆_)

module is-lib.InfSys.Equivalence {𝓁} where

  private
    variable
      U : Set 𝓁

  open import is-lib.InfSys.Base {𝓁}
  open import is-lib.InfSys.Coinduction {𝓁}
  open import is-lib.InfSys.SCoinduction {𝓁}
  open IS

  {- Equivalence CoInd and SCoInd -}

  coind-size : ∀{𝓁c 𝓁p 𝓁n}{is : IS {𝓁c} {𝓁p} {𝓁n} U} → CoInd⟦ is ⟧ ⊆ λ u → ∀ {i} → SCoInd⟦ is ⟧ u i
  coind-size p-coind with CoInd⟦_⟧.unfold p-coind
  ... | rn , c , refl , pr = sfold (rn , c , refl , λ i → λ where .force → coind-size (pr i))

  size-coind : ∀{𝓁c 𝓁p 𝓁n}{is : IS {𝓁c} {𝓁p} {𝓁n} U} → (λ u → ∀ {i} → SCoInd⟦ is ⟧ u i) ⊆ CoInd⟦ is ⟧
  size-coind {is = is} p-scoind = coind[ is ] (λ u → ∀ {j} → SCoInd⟦ is ⟧ u j) scoind-postfix p-scoind


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

module Function.Injective where

open import Function.Injective.Base public


open import Prelude
open import Data.Nat using (_≤?_)
open import Data.Maybe using (Maybe; just; nothing; is-just)
open import Reflection using (_≟-Lit_; _≟-Name_)

open import RW.Language.RTerm
open import RW.Utils.Monads

module RW.Language.RTermUtils where

  open Monad {{...}}

  --   The complexity annotations might require
  --   a slight notational introduction.
  --
  --   If a variable name overlaps one in the corresponding type signature,
  --   this is intentional.
  --
  --   Sₜ is defined by (S t).
  --   #Fvₜ is defined by length (Fv t).
  --   Both measures are defined below.
  --

  --------------
  -- Measures --
  --------------

  -- The TERMINATING pragmas are required since Agda does not
  -- recognize a call to map as terminating.

  {-# TERMINATING #-}
  height : {A : Set} → RTerm A → ℕ
  height (ovar _)    = 0
  height (ivar _)    = 0
  height (rlit _)    = 0
  height (rlam t)    = 1 + height t
  height (rapp _ ts) = 1 + max* (map height ts)
    where
      max : ℕ → ℕ → ℕ
      max a b with a ≤? b
      ...| yes _ = b
      ...| no  _ = a

      max* : List ℕ → ℕ
      max* [] = 0
      max* (h ∷ t) = max h (max* t)

  {-# TERMINATING #-}
  S : {A : Set} → RTerm A → ℕ
  S (ovar _) = 1
  S (ivar _) = 1
  S (rlit _) = 1
  S (rlam t) = 1 + S t
  S (rapp n ts) = 1 + sum (map S ts)
    where open import Data.List using (sum)

  {-# TERMINATING #-}
  Fv : {A : Set} → RTerm A → List A
  Fv (ovar a) = a ∷ []
  Fv (ivar _) = []
  Fv (rlit _) = []
  Fv (rlam t) = Fv t
  Fv (rapp _ ts) = concatMap Fv ts
    where open import Data.List using (concatMap)

  -------------------------------------------------------
  -- Terms with Context
  --
  --   Holes will be represented by a nothing;
  pattern hole = ovar nothing

  isHole : ∀{a}{A : Set a} → RTerm (Maybe A) → Bool
  isHole (ovar nothing) = true
  isHole _              = false

  -- Term Intersection
  --
  -- Complexity analisys follows below.
  {-# TERMINATING #-}
  _∩_ : ∀{A} ⦃ eqA : Eq A ⦄
      → RTerm A → RTerm A → RTerm (Maybe A)
  _∩_ (rapp x ax) (rapp y ay) with x ≟-RTermName y
  ...| no  _ = ovar nothing
  ...| yes _ = rapp x (map (uncurry _∩_) (zip ax ay))
  _∩_ (ivar x) (ivar y) with x ≟-ℕ y
  ...| no  _ = ovar nothing
  ...| yes _ = ivar x
  _∩_ ⦃ eq _≟_ ⦄ (ovar x) (ovar y) with x ≟ y
  ...| no  _ = ovar nothing
  ...| yes _ = ovar (just x)
  _∩_ (rlit x) (rlit y) with x ≟-Lit y
  ...| no  _ = ovar nothing
  ...| yes _ = rlit x
  _∩_ (rlam x) (rlam y) = rlam (x ∩ y)
  _∩_ _ _ = ovar nothing

  -- The wors case for a intersection is, of course, both terms being
  -- equal. But in that case, (t ∩ t) is just a (fmap just), as we
  -- can see below.
  --
  -- Therefore, t ∩ t ∈ O(Sₜ)
  --
  -- In case we have two different terms, the smaller of
  -- them will make _∩_ halt. Therefore,
  --
  -- t ∩ u ∈ O(min(Sₜ , Sᵤ))
  --
  private
    mutual
      t∩t≡t : {A : Set}⦃ eqA : Eq A ⦄{t : RTerm A}
            → t ∩ t ≡ replace-A (ovar ∘ just) t
      t∩t≡t ⦃ eq _≟_ ⦄ {t = ovar x} with x ≟ x
      ...| yes x≡x = refl
      ...| no  x≢x = ⊥-elim (x≢x refl)
      t∩t≡t {t = ivar n} with n ≟-ℕ n
      ...| yes n≡n = refl
      ...| no  n≢n = ⊥-elim (n≢n refl)
      t∩t≡t {t = rlit l} with l ≟-Lit l
      ...| yes l≡l = refl
      ...| no  l≢l = ⊥-elim (l≢l refl)
      t∩t≡t {A} {t = rlam t}
        = trans (cong rlam (t∩t≡t {t = t}))
                (sym (lemma-replace-rlam {A = A} {f = ovar ∘ just} {t = t}))
      t∩t≡t {t = rapp n ts} with n ≟-RTermName n
      ...| no  n≢n = ⊥-elim (n≢n refl)
      ...| yes n≡n = cong (rapp n) t∩t≡t*

      t∩t≡t* : {A : Set}⦃ eqA : Eq A ⦄{ts : List (RTerm A)}
             → map (uncurry _∩_) (zip ts ts)
             ≡ map (replace-A (ovar ∘ just)) ts
      t∩t≡t* {ts = []} = refl
      t∩t≡t* {ts = t ∷ ts}
        rewrite sym (t∩t≡t {t = t}) = cong (_∷_ (t ∩ t)) (t∩t≡t* {ts = ts})

  -- Lifting holes.
  --
  --  Will translate every definition with only holes as arguments
  --  into a single hole.
  --
  --  The worst case for lifting holes is to find a term t
  --  with no holes. Therefore _↑ ∈ O(Sₜ).
  {-# TERMINATING #-}
  _↑ : ∀{a}{A : Set a} → RTerm (Maybe A) → RTerm (Maybe A)
  _↑ (rapp x []) = rapp x []
  _↑ (rapp x ax) with all isHole ax
  ...| true   = ovar nothing
  ...| false  = rapp x (map _↑ ax)
  _↑ (rlam x) = rlam (x ↑)
  _↑ t        = t

  -- It is commom to need only "linear" intersections;
  --
  -- _∩↑_ ∈ O(Sₜ + Sₜ) ≈ O(Sₜ)
  --
  _∩↑_ : ∀{A} ⦃ eqA : Eq A ⦄
       → RTerm A → RTerm A → RTerm (Maybe A)
  v ∩↑ u = (v ∩ u) ↑

  -- Casting
  ⊥2UnitCast : RTerm (Maybe ⊥) → RTerm Unit
  ⊥2UnitCast = replace-A (maybe ⊥-elim (ovar unit))

  -- Converting Holes to Abstractions
  --
  --  Will replace holes for "var 0",
  --  and increment every other non-captured variable.
  --
  {-# TERMINATING #-}
  holeElim : ℕ → RTerm Unit → RTerm ⊥
  holeElim d (ovar unit) = ivar zero
  holeElim d (ivar n) with suc n ≤? d
  ...| yes _ = ivar n
  ...| no  _ = ivar (suc n)
  holeElim d (rlit l) = rlit l
  holeElim d (rlam rt) = rlam (holeElim (suc d) rt)
  holeElim d (rapp n ts) = rapp n (map (holeElim d) ts)

  -- Specialized version for handling indexes.
  hole2Abs : RTerm Unit → RTerm ⊥
  hole2Abs = rlam ∘ holeElim 0

  hole2Absℕ : RTerm Unit → RTerm ℕ
  hole2Absℕ = replace-A ⊥-elim ∘ hole2Abs

  open import Data.String hiding (_++_)
  postulate
    err : ∀{a}{A : Set a} → String → A

  private
    joinInner : {A : Set} → List (Maybe (List A)) → Maybe (List A)
    joinInner [] = just []
    joinInner (nothing ∷ _) = nothing -- err "2"
    joinInner (just x ∷ xs) = maybe (λ l → just (x ++ l)) nothing (joinInner xs)

    lemma-joinInner : {A : Set}{x : List A}{l : List (Maybe (List A))}
                    → joinInner (just x ∷ l)
                    ≡ maybe (λ l → just (x ++ l)) nothing (joinInner l)
    lemma-joinInner = refl

  -- Term Subtraction
  --
  -- Compelxity analisys follows below.
  --
  {-# TERMINATING #-}
  _-_ : ∀{A} ⦃ eqA : Eq A ⦄ → RTerm (Maybe A) → RTerm A → Maybe (List (RTerm A))
  hole - t = return (t ∷ [])
  (rapp x ax) - (rapp y ay) with x ≟-RTermName y
  ...| no  _ = nothing -- err "1"
  ...| yes _ = joinInner (map (uncurry _-_) (zip ax ay))
  (rlam x) - (rlam y) = x - y
  x - y with x ≟-RTerm (replace-A (ovar ∘ just) y)
  ...| yes _ = just []
  ...| no  _ = nothing -- err "3"

  -- Similarly to _∩_, we will prove the worst case complexity
  -- based on lemma t-t≡Fvt.
  -- That is, looking at term subtraction, the wors possible case
  -- is that our roadmap (RTerm (Maybe A)) perfectly matches the
  -- term we are looking for, and has all occurences of ovars as holes.
  -- (a simple drawing might help to see this).
  --
  -- Well, when this is the case, our lemma tells us that
  -- subtraction is the same as getting the free variables
  -- and mapping ovar over them.
  --
  -- It is clear that we have some additional complexity on
  -- the function joinInner, but we will ignore this for
  -- the sake of simplicity, for now.
  -- If we consider that most of the lemmas do not have more than 10
  -- free variables, joinInner is of negligible run-time
  -- (TODO: dangerous afirmation!!)
  --
  -- We'll then say that _-_ ∈ O(#Fvₜ).
  --
  private
    fmap-nothing : {A : Set} → RTerm A → RTerm (Maybe A)
    fmap-nothing = replace-A (const $ ovar nothing)

    mutual
      t-t≡Fvt : {A : Set}⦃ eqA : Eq A ⦄(t : RTerm A)
              → (fmap-nothing t) - t
              ≡ just (map ovar (Fv t))
      t-t≡Fvt (ovar x) = refl
      t-t≡Fvt (ivar n) with n ≟-ℕ n
      ...| yes n≡n = refl
      ...| no  n≢n = ⊥-elim (n≢n refl)
      t-t≡Fvt (rlit l) with l ≟-Lit l
      ...| yes l≡l = refl
      ...| no  l≢l = ⊥-elim (l≢l refl)
      t-t≡Fvt (rlam t) = t-t≡Fvt t
      t-t≡Fvt (rapp n ts) with n ≟-RTermName n
      ...| yes n≡n = t-t≡Fvt* ts
      ...| no  n≢n = ⊥-elim (n≢n refl)

      t-t≡Fvt* : {A : Set}⦃ eqA : Eq A ⦄(ts : List (RTerm A))
               → joinInner (map (uncurry _-_) (zip (map fmap-nothing ts) ts))
               ≡ just (map ovar (concat (map Fv ts)))
      t-t≡Fvt* [] = refl
      t-t≡Fvt* (t ∷ ts)
        rewrite t-t≡Fvt t
        with joinInner (map (uncurry _-_) (zip (map fmap-nothing ts) ts))
           | t-t≡Fvt* ts
      t-t≡Fvt* (t ∷ ts) | nothing | ()
      t-t≡Fvt* (t ∷ ts) | just .(map ovar (foldr _++_ [] (map Fv ts)))
                        | refl
        = cong just (sym (map-++-commute ovar (Fv t) (concat (map Fv ts))))
        where open import Data.List.Properties using (map-++-commute)

  -- Term Subtraction, single result.
  --
  -- Disconsidering lazyness, (_-↓_ t) = fmap head ∘ (_-_ t)
  -- Therefore, _-↓_ ∈ O(#Fvₜ).
  --
  _-↓_ : ∀{A} ⦃ eqA : Eq A ⦄ → RTerm (Maybe A) → RTerm A → Maybe (RTerm A)
  t -↓ u with t - u
  ...| just []      = nothing
  ...| just (x ∷ _) = just x
  ...| nothing      = nothing

  -- Structural Manipulation

  {-# TERMINATING #-}
  map-ivar : {A : Set} → ℕ → (ℕ → RTerm A) → RTerm ⊥ → RTerm A
  map-ivar _ f (ovar ())
  map-ivar d f (ivar n) with d ≤? n
  ...| yes _ = f n
  ...| no  _ = ivar n
  map-ivar _ f (rlit l) = rlit l
  map-ivar d f (rlam t) = rlam (map-ivar (suc d) f t)
  map-ivar d f (rapp n ts) = rapp n (map (map-ivar d f) ts)

  -- Lift ivar's to ovar's
  lift-ivar : RTerm ⊥ → RTerm ℕ
  lift-ivar = map-ivar 0 ovar

  private
    last : {A : Set} → List A → Maybe A
    last [] = nothing
    last (x ∷ []) = just x
    last (_ ∷ xs) = last xs

    strip-last : {A : Set} → List A → List A
    strip-last [] = []
    strip-last (x ∷ []) = []
    strip-last (x ∷ xs) = x ∷ (strip-last xs)

    -- last argument
    larg : {B : Set} → RTerm B → Maybe (RTerm B)
    larg (rapp n []) = nothing
    larg (rapp n ts) = last ts
    larg _           = nothing

    dec : ℕ → ℕ
    dec zero = zero
    dec (suc x) = x

    strip-larg : {B : Set} → RTerm B → RTerm B
    strip-larg (rapp n ts) = rapp n (strip-last ts)
    strip-larg t           = t

    {-# TERMINATING #-}
    n-is-in : {B : Set} → ℕ → RTerm B → Bool
    n-is-in n (ivar k) = dec-elim (const true) (const false) (n ≟-ℕ k)
    n-is-in n (rapp _ ts) = foldr (λ h r → n-is-in n h or r) false ts
    n-is-in n (rlam t) = n-is-in (suc n) t
    n-is-in _ _ = false

  {-# TERMINATING #-}
  η : RTerm ⊥ → RTerm ⊥
  η (ovar x) = ovar x
  η (ivar n) = ivar n
  η (rlit l) = rlit l
  η (rlam t) with η t
  ...| t' with larg t'
  ...| just (ivar 0)
     = if n-is-in 0 (strip-larg t')
       then rlam t'
       else map-ivar 0 (ivar ∘ dec) (strip-larg t')
  ...| _             = rlam t'
  η (rapp n ts) = rapp n (map η ts)

  -- Models a binary application
  RBinApp : ∀{a} → Set a → Set _
  RBinApp A = RTermName × RTerm A × RTerm A

  -- Opens a term representing a binary application.
  forceBinary : ∀{a}{A : Set a}
              → RTerm A → Maybe (RBinApp A)
  forceBinary (rapp n (a₁ ∷ a₂ ∷ [])) = just (n , a₁ , a₂)
  forceBinary _                       = nothing

  -- Given a 'impl' chain, return it's result.
  typeResult : ∀{a}{A : Set a}
             → RTerm A → RTerm A
  typeResult (rapp impl (t1 ∷ t2 ∷ [])) = typeResult t2
  typeResult t = t

  -- Gives the length of a 'impl' chain.
  typeArity : ∀{a}{A : Set a} → RTerm A → ℕ
  typeArity (rapp impl (t1 ∷ t2 ∷ [])) = suc (typeArity t2)
  typeArity _                          = 0


module Numeral.Integer.Proofs where

import      Data.Either as Either
open import Data.Tuple  as Tuple using (_,_)
open import Logic
import      Lvl
open import Functional
open import Numeral.Integer
open import Numeral.Integer.Oper
open import Numeral.Integer.Sign
open import Numeral.Natural.Induction
open import Numeral.Natural as ℕ using (ℕ)
import      Numeral.Natural.Oper as ℕ
import      Numeral.Natural.Oper.Proofs as ℕ
import      Numeral.Natural.Relation.Order as ℕ
import      Numeral.Sign as Sign
import      Numeral.Sign.Oper0 as Sign
import      Numeral.Sign.Proofs as Sign
open import Lang.Inspect
open import Logic.IntroInstances
open import Logic.Propositional
open import Logic.Predicate
open import Relator.Equals
open import Relator.Equals.Proofs
open import Structure.Function
open import Structure.Function.Domain
open import Structure.Function.Domain.Proofs
open import Structure.Function.Multi
import      Structure.Function.Names as Names
open import Structure.Operator
open import Structure.Operator.Group
open import Structure.Operator.Monoid
import      Structure.Operator.Names as Names
open import Structure.Operator.Properties
open import Structure.Operator.Proofs
open import Structure.Operator.Ring
open import Structure.OrderedField
open import Structure.Relator.Properties
open import Syntax.Number
open import Syntax.Transitivity
open import Type

private variable ℓ : Lvl.Level

-- TODO: Prove the usual structures for ℤ

instance
  [+ₙ][𝐒]-preserving : Preserving₁(+ₙ_) ℕ.𝐒 𝐒
  [+ₙ][𝐒]-preserving = intro [≡]-intro

instance
  [+ₙ][+]-preserving : Preserving₂(+ₙ_) (ℕ._+_) (_+_)
  [+ₙ][+]-preserving = intro [≡]-intro

instance
  [+ₙ][⋅]-preserving : Preserving₂(+ₙ_) (ℕ._⋅_) (_⋅_)
  Preserving.proof [+ₙ][⋅]-preserving {ℕ.𝟎}   {ℕ.𝟎}   = [≡]-intro
  Preserving.proof [+ₙ][⋅]-preserving {ℕ.𝟎}   {ℕ.𝐒 y} = [≡]-intro
  Preserving.proof [+ₙ][⋅]-preserving {ℕ.𝐒 x} {ℕ.𝟎}   = [≡]-intro
  Preserving.proof [+ₙ][⋅]-preserving {ℕ.𝐒 x} {ℕ.𝐒 y} = [≡]-intro

-- [−₀]-preserving : Preserving₂(+ₙ_) (_−₀ₙ_) (_−₀_)
-- [/₀]-preserving : Preserving₂(+ₙ_) (_/₀ₙ_) (_/₀_)

instance
  [−ₙ][𝐒][𝐏]-preserving : Preserving₁(−ₙ_) ℕ.𝐒 𝐏
  Preserving.proof [−ₙ][𝐒][𝐏]-preserving {ℕ.𝟎}   = [≡]-intro
  Preserving.proof [−ₙ][𝐒][𝐏]-preserving {ℕ.𝐒 x} = [≡]-intro

instance
  [−ₙ][+]-preserving : Preserving₂(−ₙ_) (ℕ._+_) (_+_)
  Preserving.proof [−ₙ][+]-preserving {ℕ.𝟎}    {ℕ.𝟎}    = [≡]-intro
  Preserving.proof [−ₙ][+]-preserving {ℕ.𝟎}    {ℕ.𝐒(_)} = [≡]-intro
  Preserving.proof [−ₙ][+]-preserving {ℕ.𝐒(_)} {ℕ.𝟎}    = [≡]-intro
  Preserving.proof [−ₙ][+]-preserving {ℕ.𝐒(_)} {ℕ.𝐒(_)} = [≡]-intro

instance
  [−][𝐒][𝐏]-preserving : Preserving₁(−_) 𝐒 𝐏
  Preserving.proof [−][𝐒][𝐏]-preserving {+ₙ ℕ.𝟎}    = [≡]-intro
  Preserving.proof [−][𝐒][𝐏]-preserving {+ₙ ℕ.𝐒 x}  = [≡]-intro
  Preserving.proof [−][𝐒][𝐏]-preserving {−𝐒ₙ ℕ.𝟎}   = [≡]-intro
  Preserving.proof [−][𝐒][𝐏]-preserving {−𝐒ₙ ℕ.𝐒 x} = [≡]-intro

instance
  [−𝐒ₙ][𝐒][𝐏]-preserving : Preserving₁(−𝐒ₙ_) ℕ.𝐒 𝐏
  Preserving.proof [−𝐒ₙ][𝐒][𝐏]-preserving = [≡]-intro

instance
  [+𝐒ₙ][𝐒]-preserving : Preserving₁(+𝐒ₙ_) ℕ.𝐒 𝐒
  Preserving.proof [+𝐒ₙ][𝐒]-preserving = [≡]-intro

instance
  [−][+]-preserving : Preserving₂(−_) (_+_)(_+_)
  Preserving.proof [−][+]-preserving {x}{y} = p{x}{y} where
    [−ₙ]-distribute-[−] : ∀{x y} → (−(x −ₙ y) ≡ y −ₙ x)
    [−ₙ]-distribute-[−] {ℕ.𝟎}   {ℕ.𝟎}   = [≡]-intro
    [−ₙ]-distribute-[−] {ℕ.𝟎}   {ℕ.𝐒 x} = [≡]-intro
    [−ₙ]-distribute-[−] {ℕ.𝐒 x} {ℕ.𝟎}   = [≡]-intro
    [−ₙ]-distribute-[−] {ℕ.𝐒 x} {ℕ.𝐒 y} = [−ₙ]-distribute-[−] {x} {y}

    p : Names.Preserving₂(−_) (_+_)(_+_)
    p {+ₙ ℕ.𝟎}    {+ₙ ℕ.𝟎}        = [≡]-intro
    p {+ₙ ℕ.𝟎}    {+ₙ ℕ.𝐒 y}      = [≡]-intro
    p {+ₙ ℕ.𝐒 x}  {+ₙ ℕ.𝟎}        = [≡]-intro
    p {+ₙ ℕ.𝐒 x}  {+ₙ ℕ.𝐒 y}      = [≡]-intro
    p {+ₙ ℕ.𝟎}    {−𝐒ₙ ℕ.𝟎}       = [≡]-intro
    p {+ₙ ℕ.𝟎}    {−𝐒ₙ ℕ.𝐒 y}     = [≡]-intro
    p {+ₙ ℕ.𝐒 x}  {−𝐒ₙ y}         = [−ₙ]-distribute-[−] {x}{y}
    p {−𝐒ₙ x}     {+ₙ ℕ.𝐒 y}      = [−ₙ]-distribute-[−] {y}{x}
    p {−𝐒ₙ ℕ.𝟎}   {+ₙ ℕ.𝟎}        = [≡]-intro
    p {−𝐒ₙ ℕ.𝟎}   {−𝐒ₙ ℕ.𝟎}       = [≡]-intro
    p {−𝐒ₙ ℕ.𝟎}   {−𝐒ₙ ℕ.𝐒 y}     = [≡]-intro
    p {−𝐒ₙ ℕ.𝐒 x} {−𝐒ₙ ℕ.𝟎}       = [≡]-intro
    p {−𝐒ₙ ℕ.𝐒 x} {−𝐒ₙ ℕ.𝐒 y}     = [≡]-intro
    p {−𝐒ₙ ℕ.𝐒 x} {+ₙ ℕ.𝟎}        = [≡]-intro

instance
  [absₙ][⋅]-preserving : Preserving₂(absₙ)(_⋅_)(ℕ._⋅_)
  Preserving.proof [absₙ][⋅]-preserving {+ₙ ℕ.𝟎}    {+ₙ ℕ.𝟎}    = [≡]-intro
  Preserving.proof [absₙ][⋅]-preserving {+ₙ ℕ.𝟎}    {+ₙ ℕ.𝐒 y}  = [≡]-intro
  Preserving.proof [absₙ][⋅]-preserving {+ₙ ℕ.𝐒 x}  {+ₙ ℕ.𝟎}    = [≡]-intro
  Preserving.proof [absₙ][⋅]-preserving {+ₙ ℕ.𝐒 x}  {+ₙ ℕ.𝐒 y}  = [≡]-intro
  Preserving.proof [absₙ][⋅]-preserving {−𝐒ₙ x}     {−𝐒ₙ y}     = [≡]-intro
  Preserving.proof [absₙ][⋅]-preserving {+ₙ ℕ.𝟎}    {−𝐒ₙ ℕ.𝟎}   = [≡]-intro
  Preserving.proof [absₙ][⋅]-preserving {+ₙ ℕ.𝟎}    {−𝐒ₙ ℕ.𝐒 y} = [≡]-intro
  Preserving.proof [absₙ][⋅]-preserving {+ₙ ℕ.𝐒 x}  {−𝐒ₙ ℕ.𝟎}   = [≡]-intro
  Preserving.proof [absₙ][⋅]-preserving {+ₙ ℕ.𝐒 x}  {−𝐒ₙ ℕ.𝐒 y} = [≡]-intro
  Preserving.proof [absₙ][⋅]-preserving {−𝐒ₙ ℕ.𝟎}   {+ₙ ℕ.𝟎}    = [≡]-intro
  Preserving.proof [absₙ][⋅]-preserving {−𝐒ₙ ℕ.𝟎}   {+ₙ ℕ.𝐒 y}  = [≡]-intro
  Preserving.proof [absₙ][⋅]-preserving {−𝐒ₙ ℕ.𝐒 x} {+ₙ ℕ.𝟎}    = [≡]-intro
  Preserving.proof [absₙ][⋅]-preserving {−𝐒ₙ ℕ.𝐒 x} {+ₙ ℕ.𝐒 y}  = [≡]-intro

instance
  [sign0][⋅]-preserving : Preserving₂(sign0)(_⋅_)(Sign._⨯_)
  Preserving.proof [sign0][⋅]-preserving {+ₙ ℕ.𝟎}    {+ₙ ℕ.𝟎}    = [≡]-intro
  Preserving.proof [sign0][⋅]-preserving {+ₙ ℕ.𝟎}    {+ₙ ℕ.𝐒 y}  = [≡]-intro
  Preserving.proof [sign0][⋅]-preserving {+ₙ ℕ.𝐒 x}  {+ₙ ℕ.𝟎}    = [≡]-intro
  Preserving.proof [sign0][⋅]-preserving {+ₙ ℕ.𝐒 x}  {+ₙ ℕ.𝐒 y}  = [≡]-intro
  Preserving.proof [sign0][⋅]-preserving {−𝐒ₙ x}     {−𝐒ₙ y}     = [≡]-intro
  Preserving.proof [sign0][⋅]-preserving {+ₙ ℕ.𝟎}    {−𝐒ₙ ℕ.𝟎}   = [≡]-intro
  Preserving.proof [sign0][⋅]-preserving {+ₙ ℕ.𝟎}    {−𝐒ₙ ℕ.𝐒 y} = [≡]-intro
  Preserving.proof [sign0][⋅]-preserving {+ₙ ℕ.𝐒 x}  {−𝐒ₙ ℕ.𝟎}   = [≡]-intro
  Preserving.proof [sign0][⋅]-preserving {+ₙ ℕ.𝐒 x}  {−𝐒ₙ ℕ.𝐒 y} = [≡]-intro
  Preserving.proof [sign0][⋅]-preserving {−𝐒ₙ ℕ.𝟎}   {+ₙ ℕ.𝟎}    = [≡]-intro
  Preserving.proof [sign0][⋅]-preserving {−𝐒ₙ ℕ.𝟎}   {+ₙ ℕ.𝐒 y}  = [≡]-intro
  Preserving.proof [sign0][⋅]-preserving {−𝐒ₙ ℕ.𝐒 x} {+ₙ ℕ.𝟎}    = [≡]-intro
  Preserving.proof [sign0][⋅]-preserving {−𝐒ₙ ℕ.𝐒 x} {+ₙ ℕ.𝐒 y}  = [≡]-intro

[ℤ]-non-negative-induction : ∀{P : ℤ → Type{ℓ}} → P(𝟎) → (∀(n) → P(+ₙ(n)) → P(+𝐒ₙ(n))) → (∀{n} → P(+ₙ n))
[ℤ]-non-negative-induction {P = P} = [ℕ]-induction {φ = P ∘ +ₙ_}

[ℤ]-positive-induction : ∀{P : ℤ → Type{ℓ}} → P(+𝐒ₙ(ℕ.𝟎)) → (∀(n) → P(+𝐒ₙ(n)) → P(+𝐒ₙ(ℕ.𝐒(n)))) → (∀{n} → P(+𝐒ₙ n))
[ℤ]-positive-induction {P = P} [1] [+] {ℕ.𝟎}   = [1]
[ℤ]-positive-induction {P = P} [1] [+] {ℕ.𝐒 n} = [+] n ([ℤ]-positive-induction {P = P} [1] [+] {n})

[ℤ]-non-positive-induction : ∀{P : ℤ → Type{ℓ}} → P(𝟎) → (∀(n) → P(−ₙ(n)) → P(−𝐒ₙ(n))) → (∀{n} → P(−ₙ n))
[ℤ]-non-positive-induction {P = P} [0] [−] {ℕ.𝟎}   = [0]
[ℤ]-non-positive-induction {P = P} [0] [−] {ℕ.𝐒 n} = [−] n ([ℤ]-non-positive-induction {P = P} [0] [−] {n})

[ℤ]-negative-induction : ∀{P : ℤ → Type{ℓ}} → P(−𝐒ₙ(ℕ.𝟎)) → (∀(n) → P(−𝐒ₙ(n)) → P(−𝐒ₙ(ℕ.𝐒(n)))) → (∀{n} → P(−𝐒ₙ n))
[ℤ]-negative-induction {P = P} = [ℕ]-induction {φ = P ∘ −𝐒ₙ_}

-- An intuitive induction proof method on integers
[ℤ]-intuitive-induction : ∀{P : ℤ → Type{ℓ}} → (∀{n} → P(−ₙ n) → P(−𝐒ₙ(n))) → P(𝟎) → (∀{n} → P(+ₙ n) → P(+𝐒ₙ(n))) → (∀{n} → P(n))
[ℤ]-intuitive-induction {P = P} [−] [0] [+] {𝟎}           = [0]
[ℤ]-intuitive-induction {P = P} [−] [0] [+] {+𝐒ₙ(n)}      = [+] ([ℤ]-intuitive-induction {P = P} [−] [0] [+] {+ₙ n})
[ℤ]-intuitive-induction {P = P} [−] [0] [+] {−𝐒ₙ(ℕ.𝟎)}    = [−] ([0])
[ℤ]-intuitive-induction {P = P} [−] [0] [+] {−𝐒ₙ(ℕ.𝐒(n))} = [−] ([ℤ]-intuitive-induction {P = P} [−] [0] [+] {−𝐒ₙ(n)})

[−𝐒ₙ]-equality : ∀{n} → (−𝐒ₙ(n) ≡ −ₙ(ℕ.𝐒(n)))
[−𝐒ₙ]-equality = [≡]-intro

[+𝐒ₙ]-equality : ∀{n} → (+𝐒ₙ(n) ≡ +ₙ(ℕ.𝐒(n)))
[+𝐒ₙ]-equality = [≡]-intro

-- (−n)−1 = −(n+1)
[𝐏]-negative : ∀{n} → (𝐏(−ₙ n) ≡ −𝐒ₙ(n))
[𝐏]-negative {ℕ.𝟎}    = [≡]-intro
[𝐏]-negative {ℕ.𝐒(n)} = [≡]-intro

-- (−(n+1))+1 = −n
[𝐒][−𝐒ₙ]-negative-identity : ∀{n} → (𝐒(−𝐒ₙ(n)) ≡ −ₙ n)
[𝐒][−𝐒ₙ]-negative-identity {ℕ.𝟎}    = [≡]-intro
[𝐒][−𝐒ₙ]-negative-identity {ℕ.𝐒(n)} = [≡]-intro

instance
  [𝐒][𝐏]-inverse : Inverse(𝐒)(𝐏)
  Inverseᵣ.proof (Tuple.left [𝐒][𝐏]-inverse)  {+ₙ  ℕ.𝟎}   = [≡]-intro
  Inverseᵣ.proof (Tuple.left [𝐒][𝐏]-inverse)  {+ₙ  ℕ.𝐒 x} = [≡]-intro
  Inverseᵣ.proof (Tuple.left [𝐒][𝐏]-inverse)  {−𝐒ₙ ℕ.𝟎}   = [≡]-intro
  Inverseᵣ.proof (Tuple.left [𝐒][𝐏]-inverse)  {−𝐒ₙ ℕ.𝐒 x} = [≡]-intro
  Inverseᵣ.proof (Tuple.right [𝐒][𝐏]-inverse) {+ₙ  ℕ.𝟎}   = [≡]-intro
  Inverseᵣ.proof (Tuple.right [𝐒][𝐏]-inverse) {+ₙ  ℕ.𝐒 x} = [≡]-intro
  Inverseᵣ.proof (Tuple.right [𝐒][𝐏]-inverse) {−𝐒ₙ ℕ.𝟎}   = [≡]-intro
  Inverseᵣ.proof (Tuple.right [𝐒][𝐏]-inverse) {−𝐒ₙ ℕ.𝐒 x} = [≡]-intro

[−ₙ]-identityᵣ : ∀{x} → (x −ₙ ℕ.𝟎 ≡ +ₙ x)
[−ₙ]-identityᵣ = [≡]-intro

[−ₙ]-antiidentityₗ : ∀{x} → (ℕ.𝟎 −ₙ x ≡ −ₙ x)
[−ₙ]-antiidentityₗ {ℕ.𝟎}    = [≡]-intro
[−ₙ]-antiidentityₗ {ℕ.𝐒(_)} = [≡]-intro

[−ₙ][𝐒]-step : ∀{x y} → (ℕ.𝐒(x) −ₙ y ≡ 𝐒(x −ₙ y))
[−ₙ][𝐒]-step {ℕ.𝟎}   {ℕ.𝟎}    = [≡]-intro
[−ₙ][𝐒]-step {ℕ.𝟎}   {ℕ.𝐒(y)} = [−ₙ]-antiidentityₗ {y} 🝖 symmetry(_≡_) ([𝐒][−𝐒ₙ]-negative-identity{y})
[−ₙ][𝐒]-step {ℕ.𝐒(_)}{ℕ.𝟎}    = [≡]-intro
[−ₙ][𝐒]-step {ℕ.𝐒(x)}{ℕ.𝐒(y)} = [−ₙ][𝐒]-step {x}{y}

[−][−ₙ] : ∀{x} → (−(+ₙ x) ≡ −ₙ x)
[−][−ₙ] {ℕ.𝟎}    = [≡]-intro
[−][−ₙ] {ℕ.𝐒(_)} = [≡]-intro

instance
  [+ₙ]-injectivity : Injective(+ₙ_)
  Injective.proof [+ₙ]-injectivity [≡]-intro = [≡]-intro

instance
  [−𝐒ₙ]-injectivity : Injective(−𝐒ₙ_)
  Injective.proof [−𝐒ₙ]-injectivity [≡]-intro = [≡]-intro

instance
  [−ₙ]-injectivity : Injective(−ₙ_)
  Injective.proof [−ₙ]-injectivity {ℕ.𝟎}   {ℕ.𝟎}    xy        = [≡]-intro
  Injective.proof [−ₙ]-injectivity {ℕ.𝐒 x} {ℕ.𝐒 .x} [≡]-intro = [≡]-intro

instance
  [+𝐒ₙ]-injectivity : Injective(+𝐒ₙ_)
  Injective.proof [+𝐒ₙ]-injectivity [≡]-intro = [≡]-intro

[−ₙ]-self : ∀{x} → (x −ₙ x ≡ 𝟎)
[−ₙ]-self {ℕ.𝟎}    = [≡]-intro
[−ₙ]-self {ℕ.𝐒(x)} = [−ₙ]-self {x}

instance
  [+]-commutativity : Commutativity(_+_)
  [+]-commutativity = intro(\{x y} → p{x}{y}) where
    p : Names.Commutativity(_+_)
    p {+ₙ x}  {+ₙ y}  = congruence₁(+ₙ_) (commutativity(ℕ._+_) {x}{y})
    p {+ₙ _}  {−𝐒ₙ _} = [≡]-intro
    p {−𝐒ₙ _} {+ₙ _}  = [≡]-intro
    p {−𝐒ₙ x} {−𝐒ₙ y} = congruence₁(−𝐒ₙ_ ∘ ℕ.𝐒) (commutativity(ℕ._+_) {x}{y})

instance
  [+]-identityₗ : Identityₗ(_+_)(𝟎)
  Identityₗ.proof [+]-identityₗ {+ₙ _}  = [≡]-intro
  Identityₗ.proof [+]-identityₗ {−𝐒ₙ _} = [≡]-intro

instance
  [+]-identityᵣ : Identityᵣ(_+_)(𝟎)
  Identityᵣ.proof [+]-identityᵣ {+ₙ _}  = [≡]-intro
  Identityᵣ.proof [+]-identityᵣ {−𝐒ₙ _} = [≡]-intro

instance
  [+]-identity : Identity(_+_)(𝟎)
  [+]-identity = intro

instance
  [+]-inverseFunctionₗ : InverseFunctionₗ(_+_)(−_)
  InverseFunctionₗ.proof [+]-inverseFunctionₗ {+ₙ ℕ.𝟎}    = [≡]-intro
  InverseFunctionₗ.proof [+]-inverseFunctionₗ {+ₙ ℕ.𝐒(x)} = [−ₙ]-self {x}
  InverseFunctionₗ.proof [+]-inverseFunctionₗ {−𝐒ₙ(x)}    = [−ₙ]-self {x}

instance
  [+]-inverseFunctionᵣ : InverseFunctionᵣ(_+_)(−_)
  InverseFunctionᵣ.proof [+]-inverseFunctionᵣ {+ₙ ℕ.𝟎}    = [≡]-intro
  InverseFunctionᵣ.proof [+]-inverseFunctionᵣ {+ₙ ℕ.𝐒(x)} = [−ₙ]-self {x}
  InverseFunctionᵣ.proof [+]-inverseFunctionᵣ {−𝐒ₙ(x)}    = [−ₙ]-self {x}

instance
  [+]-inverseFunction : InverseFunction(_+_)(−_)
  [+]-inverseFunction = intro

instance
  [−]-involution : Involution(−_)
  Involution.proof [−]-involution {+ₙ ℕ.𝟎}    = [≡]-intro
  Involution.proof [−]-involution {+ₙ ℕ.𝐒(x)} = [≡]-intro
  Involution.proof [−]-involution {−𝐒ₙ x}     = [≡]-intro

instance
  [−]-injectivity : Injective(−_)
  Injective.proof [−]-injectivity {a}{b} p =
    a      🝖[ _≡_ ]-[ involution(−_) ]-sym
    −(− a) 🝖[ _≡_ ]-[ congruence₁(−_) p ]
    −(− b) 🝖[ _≡_ ]-[ involution(−_) ]
    b      🝖-end

instance
  [−]-surjectivity : Surjective(−_)
  Surjective.proof [−]-surjectivity {y} = [∃]-intro (− y) ⦃ involution(−_) ⦄

instance
  [−]-bijectivity : Bijective(−_)
  [−]-bijectivity = injective-surjective-to-bijective(−_)

instance
  abs-idempotent : Idempotent(abs)
  Idempotent.proof abs-idempotent {+ₙ x}  = [≡]-intro
  Idempotent.proof abs-idempotent {−𝐒ₙ x} = [≡]-intro

abs-injective-zero : ∀{n} → (abs(n) ≡ 𝟎) → (n ≡ 𝟎)
abs-injective-zero {𝟎} [≡]-intro = [≡]-intro

abs-[−] : ∀{n} → (abs(− n) ≡ abs(n))
abs-[−] {𝟎}      = [≡]-intro
abs-[−] {+𝐒ₙ(_)} = [≡]-intro
abs-[−] {−𝐒ₙ(_)} = [≡]-intro

abs-preserving : ∀{x} → (abs(x) ≡ +ₙ(absₙ(x)))
abs-preserving {𝟎}      = [≡]-intro
abs-preserving {+𝐒ₙ(_)} = [≡]-intro
abs-preserving {−𝐒ₙ(_)} = [≡]-intro

absₙ-zero : ∀{n} → (absₙ(n) ≡ ℕ.𝟎) → (n ≡ 𝟎)
absₙ-zero {𝟎}      ([≡]-intro) = [≡]-intro

[+][𝐒]-stepₗ : ∀{x y} → (𝐒(x) + y ≡ 𝐒(x + y))
[+][𝐒]-stepₗ {+ₙ x}       {+ₙ y}       = [≡]-intro
[+][𝐒]-stepₗ {+ₙ ℕ.𝟎   }  {−𝐒ₙ ℕ.𝟎   } = [≡]-intro
[+][𝐒]-stepₗ {+ₙ ℕ.𝟎   }  {−𝐒ₙ ℕ.𝐒(_)} = [≡]-intro
[+][𝐒]-stepₗ {+ₙ ℕ.𝐒(_)}  {−𝐒ₙ ℕ.𝟎   } = [≡]-intro
[+][𝐒]-stepₗ {+ₙ ℕ.𝐒(x)}  {−𝐒ₙ ℕ.𝐒(y)} = [−ₙ][𝐒]-step{x}{ℕ.𝐒(y)}
[+][𝐒]-stepₗ {−𝐒ₙ ℕ.𝟎   } {+ₙ ℕ.𝟎   }  = [≡]-intro
[+][𝐒]-stepₗ {−𝐒ₙ ℕ.𝐒(_)} {+ₙ ℕ.𝟎   }  = [≡]-intro
[+][𝐒]-stepₗ {−𝐒ₙ ℕ.𝟎   } {+ₙ ℕ.𝐒(_)}  = [≡]-intro
[+][𝐒]-stepₗ {−𝐒ₙ ℕ.𝐒(y)} {+ₙ ℕ.𝐒(x)}  = [−ₙ][𝐒]-step{x}{ℕ.𝐒(y)}
[+][𝐒]-stepₗ {−𝐒ₙ ℕ.𝟎   } {−𝐒ₙ ℕ.𝟎   } = [≡]-intro
[+][𝐒]-stepₗ {−𝐒ₙ ℕ.𝐒(_)} {−𝐒ₙ ℕ.𝟎   } = [≡]-intro
[+][𝐒]-stepₗ {−𝐒ₙ ℕ.𝟎   } {−𝐒ₙ ℕ.𝐒(_)} = [≡]-intro
[+][𝐒]-stepₗ {−𝐒ₙ ℕ.𝐒(y)} {−𝐒ₙ ℕ.𝐒(x)} = [≡]-intro

instance
  [𝐒]-preserving-[+]ₗ : ∀{y} → Preserving₁(𝐒) (_+ y)(_+ y)
  Preserving.proof ([𝐒]-preserving-[+]ₗ {y}) {x} = symmetry(_≡_) ([+][𝐒]-stepₗ {x}{y})

[+][𝐒]-stepᵣ : ∀{x y} → (x + 𝐒(y) ≡ 𝐒(x + y))
[+][𝐒]-stepᵣ {+ₙ x}      {+ₙ y}     = [≡]-intro
[+][𝐒]-stepᵣ {+ₙ ℕ.𝟎}    {−𝐒ₙ ℕ.𝟎}   = [≡]-intro
[+][𝐒]-stepᵣ {+ₙ ℕ.𝟎}    {−𝐒ₙ ℕ.𝐒 x} = [≡]-intro
[+][𝐒]-stepᵣ {+ₙ ℕ.𝐒 x}  {−𝐒ₙ ℕ.𝟎}   = [≡]-intro
[+][𝐒]-stepᵣ {+ₙ ℕ.𝐒 x}  {−𝐒ₙ ℕ.𝐒 y} = [+][𝐒]-stepᵣ {−𝐒ₙ y}{+ₙ x}
[+][𝐒]-stepᵣ {−𝐒ₙ ℕ.𝟎}   {+ₙ ℕ.𝟎}    = [≡]-intro
[+][𝐒]-stepᵣ {−𝐒ₙ ℕ.𝟎}   {+ₙ ℕ.𝐒 y}  = [≡]-intro
[+][𝐒]-stepᵣ {−𝐒ₙ ℕ.𝐒 x} {+ₙ ℕ.𝟎}    = [≡]-intro
[+][𝐒]-stepᵣ {−𝐒ₙ ℕ.𝐒 x} {+ₙ ℕ.𝐒 y}  = [+][𝐒]-stepᵣ {−𝐒ₙ x}{+ₙ y}
[+][𝐒]-stepᵣ {−𝐒ₙ ℕ.𝟎}   {−𝐒ₙ ℕ.𝟎}   = [≡]-intro
[+][𝐒]-stepᵣ {−𝐒ₙ ℕ.𝐒 x} {−𝐒ₙ ℕ.𝟎}   = [≡]-intro
[+][𝐒]-stepᵣ {−𝐒ₙ ℕ.𝟎}   {−𝐒ₙ ℕ.𝐒 y} = [≡]-intro
[+][𝐒]-stepᵣ {−𝐒ₙ ℕ.𝐒 x} {−𝐒ₙ ℕ.𝐒 y} = [≡]-intro

instance
  [𝐒]-preserving-[+]ᵣ : ∀{x} → Preserving₁(𝐒) (_+_ x)(_+_ x)
  Preserving.proof ([𝐒]-preserving-[+]ᵣ {x}) {y} = symmetry(_≡_) ([+][𝐒]-stepᵣ {x}{y})

[+][𝐏]-stepₗ : ∀{x y} → (𝐏(x) + y ≡ 𝐏(x + y))
[+][𝐏]-stepₗ {x}{y} =
  𝐏(x) + y                 🝖[ _≡_ ]-[ congruence₂(_+_) (congruence₁(𝐏) (involution(−_) {x})) (involution(−_) {y}) ]-sym
  𝐏(−(− x)) + (−(− y))     🝖[ _≡_ ]-[ congruence₂ₗ(_+_)(−(− y)) (preserving₁(−_)(𝐒)(𝐏) {− x}) ]-sym
  (− 𝐒(− x)) + (−(− y))    🝖[ _≡_ ]-[ preserving₂(−_)(_+_)(_+_) {𝐒(− x)}{− y} ]-sym
  −(𝐒(− x) + (− y))        🝖[ _≡_ ]-[ congruence₁(−_) ([+][𝐒]-stepₗ {− x}{− y}) ]
  −(𝐒((− x) + (− y)))      🝖[ _≡_ ]-[ preserving₁(−_)(𝐒)(𝐏) ]
  𝐏(−((− x) + (− y)))      🝖[ _≡_ ]-[ congruence₁(𝐏) (preserving₂(−_)(_+_)(_+_) {− x}{− y}) ]
  𝐏(((−(− x)) + (−(− y)))) 🝖[ _≡_ ]-[ congruence₁(𝐏) (congruence₂(_+_) (involution(−_) {x}) (involution(−_) {y})) ]
  𝐏(x + y)                 🝖-end

instance
  [𝐏]-preserving-[+]ₗ : ∀{y} → Preserving₁(𝐏) (_+ y)(_+ y)
  Preserving.proof ([𝐏]-preserving-[+]ₗ {y}) {x} = symmetry(_≡_) ([+][𝐏]-stepₗ {x}{y})

[+][𝐏]-stepᵣ : ∀{x y} → (x + 𝐏(y) ≡ 𝐏(x + y))
[+][𝐏]-stepᵣ {x}{y} =
  x + 𝐏(y)                 🝖[ _≡_ ]-[ congruence₂(_+_) (involution(−_) {x}) (congruence₁(𝐏) (involution(−_) {y})) ]-sym
  (−(− x)) + 𝐏(−(− y))     🝖[ _≡_ ]-[ congruence₂ᵣ(_+_)(−(− x)) (preserving₁(−_)(𝐒)(𝐏) {− y}) ]-sym
  (−(− x)) + (− 𝐒(− y))    🝖[ _≡_ ]-[ preserving₂(−_)(_+_)(_+_) {− x}{𝐒(− y)} ]-sym
  −((− x) + 𝐒(− y))        🝖[ _≡_ ]-[ congruence₁(−_) ([+][𝐒]-stepᵣ {− x}{− y}) ]
  −(𝐒((− x) + (− y)))      🝖[ _≡_ ]-[ preserving₁(−_)(𝐒)(𝐏) ]
  𝐏(−((− x) + (− y)))      🝖[ _≡_ ]-[ congruence₁(𝐏) (preserving₂(−_)(_+_)(_+_) {− x}{− y}) ]
  𝐏(((−(− x)) + (−(− y)))) 🝖[ _≡_ ]-[ congruence₁(𝐏) (congruence₂(_+_) (involution(−_) {x}) (involution(−_) {y})) ]
  𝐏(x + y)                 🝖-end

instance
  [𝐏]-preserving-[+]ᵣ : ∀{x} → Preserving₁(𝐏) (_+_ x)(_+_ x)
  Preserving.proof ([𝐏]-preserving-[+]ᵣ {x}) {y} = symmetry(_≡_) ([+][𝐏]-stepᵣ {x}{y})

[−]-of-[+𝐒ₙ] : ∀{x y} → (+𝐒ₙ x) − (+𝐒ₙ y) ≡ (+ₙ x) − (+ₙ y)
[−]-of-[+𝐒ₙ] {y = ℕ.𝟎}   = [≡]-intro
[−]-of-[+𝐒ₙ] {y = ℕ.𝐒 _} = [≡]-intro

[+ₙ][−₀][−]-preserving : ∀{x y} → (x ℕ.≥ y) → ((+ₙ(x ℕ.−₀ y)) ≡ ((+ₙ x) − (+ₙ y)))
[+ₙ][−₀][−]-preserving ℕ.min = [≡]-intro
[+ₙ][−₀][−]-preserving {ℕ.𝐒 x}{ℕ.𝐒 y} (ℕ.succ p) = [+ₙ][−₀][−]-preserving {x}{y} p 🝖 symmetry(_≡_) ([−]-of-[+𝐒ₙ] {x}{y})

[−ₙ]-on-[+]ₗ-redundancy : ∀{a b c} → ((a ℕ.+ b) −ₙ (a ℕ.+ c) ≡ b −ₙ c)
[−ₙ]-on-[+]ₗ-redundancy{ℕ.𝟎}  {b}{c} = [≡]-intro
[−ₙ]-on-[+]ₗ-redundancy{ℕ.𝐒 a}{b}{c} = [−ₙ]-on-[+]ₗ-redundancy{a}{b}{c}

instance
  [+]-associativity : Associativity(_+_)
  [+]-associativity = intro(\{x y z} → p{x}{y}{z}) where
    postulate p : Names.Associativity(_+_)
    {-p {x} {y} {𝟎}     =
      (x + y) + 𝟎 🝖[ _≡_ ]-[ identityᵣ(_+_)(𝟎) ]
      x + y       🝖[ _≡_ ]-[ congruence₂ᵣ(_+_)(x) (identityᵣ(_+_)(𝟎)) ]-sym
      x + (y + 𝟎) 🝖-end
    p {x} {y} {+𝐒ₙ z} =
      (x + y) + (+𝐒ₙ(z))   🝖[ _≡_ ]-[]
      (x + y) + 𝐒(+ₙ(z))   🝖[ _≡_ ]-[ [+][𝐒]-stepᵣ {x + y}{+ₙ(z)} ]
      𝐒((x + y) + (+ₙ(z))) 🝖[ _≡_ ]-[ congruence₁(𝐒) (p{x}{y}{+ₙ z}) ]
      𝐒(x + (y + (+ₙ(z)))) 🝖[ _≡_ ]-[ [+][𝐒]-stepᵣ {x}{y + (+ₙ z)} ]-sym
      x + 𝐒(y + (+ₙ(z)))   🝖[ _≡_ ]-[ congruence₂ᵣ(_+_)(x) ([+][𝐒]-stepᵣ {y}{+ₙ z}) ]-sym
      x + (y + 𝐒(+ₙ(z)))   🝖[ _≡_ ]-[]
      x + (y + (+𝐒ₙ(z)))   🝖-end
    p {x} {y} {−𝐒ₙ z} =
      (x + y) + (−𝐒ₙ(z))   🝖[ _≡_ ]-[ congruence₂ᵣ(_+_)(x + y) [𝐏]-negative ]-sym
      (x + y) + 𝐏(−ₙ(z))   🝖[ _≡_ ]-[ [+][𝐏]-stepᵣ {x + y}{−ₙ(z)} ]
      𝐏((x + y) + (−ₙ(z))) 🝖[ _≡_ ]-[ congruence₁(𝐏) (p{x}{y}{−ₙ z}) ]
      𝐏(x + (y + (−ₙ(z)))) 🝖[ _≡_ ]-[ [+][𝐏]-stepᵣ {x}{y + (−ₙ z)} ]-sym
      x + 𝐏(y + (−ₙ(z)))   🝖[ _≡_ ]-[ congruence₂ᵣ(_+_)(x) ([+][𝐏]-stepᵣ {y}{−ₙ z}) ]-sym
      x + (y + 𝐏(−ₙ(z)))   🝖[ _≡_ ]-[ congruence₂ᵣ(_+_)(x) (congruence₂ᵣ(_+_)(y) [𝐏]-negative) ]
      x + (y + (−𝐒ₙ(z)))   🝖-end
    -}

instance
  [+]-monoid : Monoid(_+_)
  [+]-monoid = intro

instance
  [+]-group : Group(_+_)
  [+]-group = intro

instance
  [+]-commutative-group : CommutativeGroup(_+_)
  [+]-commutative-group = intro

absₙ-of-[⋅] : ∀{x y} → (absₙ(x ⋅ y) ≡ absₙ(x) ℕ.⋅ absₙ(y))
absₙ-of-[⋅] {+ₙ ℕ.𝟎}    {+ₙ ℕ.𝟎}    = [≡]-intro
absₙ-of-[⋅] {+ₙ ℕ.𝟎}    {+ₙ ℕ.𝐒 y}  = [≡]-intro
absₙ-of-[⋅] {+ₙ ℕ.𝐒 x}  {+ₙ ℕ.𝟎}    = [≡]-intro
absₙ-of-[⋅] {+ₙ ℕ.𝐒 x}  {+ₙ ℕ.𝐒 y}  = [≡]-intro
absₙ-of-[⋅] {−𝐒ₙ x}     {−𝐒ₙ y}     = [≡]-intro
absₙ-of-[⋅] {+ₙ ℕ.𝟎}    {−𝐒ₙ ℕ.𝟎}   = [≡]-intro
absₙ-of-[⋅] {+ₙ ℕ.𝟎}    {−𝐒ₙ ℕ.𝐒 y} = [≡]-intro
absₙ-of-[⋅] {+ₙ ℕ.𝐒 x}  {−𝐒ₙ ℕ.𝟎}   = [≡]-intro
absₙ-of-[⋅] {+ₙ ℕ.𝐒 x}  {−𝐒ₙ ℕ.𝐒 y} = [≡]-intro
absₙ-of-[⋅] {−𝐒ₙ ℕ.𝟎}   {+ₙ ℕ.𝟎}    = [≡]-intro
absₙ-of-[⋅] {−𝐒ₙ ℕ.𝟎}   {+ₙ ℕ.𝐒 y}  = [≡]-intro
absₙ-of-[⋅] {−𝐒ₙ ℕ.𝐒 x} {+ₙ ℕ.𝟎}    = [≡]-intro
absₙ-of-[⋅] {−𝐒ₙ ℕ.𝐒 x} {+ₙ ℕ.𝐒 y}  = [≡]-intro

sign-of-[⋅] : ∀{x y} → (sign0(x ⋅ y) ≡ sign0(x) Sign.⨯ sign0(y))
sign-of-[⋅] {+ₙ ℕ.𝟎}    {+ₙ ℕ.𝟎}    = [≡]-intro
sign-of-[⋅] {+ₙ ℕ.𝟎}    {+ₙ ℕ.𝐒 y}  = [≡]-intro
sign-of-[⋅] {+ₙ ℕ.𝐒 x}  {+ₙ ℕ.𝟎}    = [≡]-intro
sign-of-[⋅] {+ₙ ℕ.𝐒 x}  {+ₙ ℕ.𝐒 y}  = [≡]-intro
sign-of-[⋅] {−𝐒ₙ x}     {−𝐒ₙ y}     = [≡]-intro
sign-of-[⋅] {+ₙ ℕ.𝟎}    {−𝐒ₙ ℕ.𝟎}   = [≡]-intro
sign-of-[⋅] {+ₙ ℕ.𝟎}    {−𝐒ₙ ℕ.𝐒 y} = [≡]-intro
sign-of-[⋅] {+ₙ ℕ.𝐒 x}  {−𝐒ₙ ℕ.𝟎}   = [≡]-intro
sign-of-[⋅] {+ₙ ℕ.𝐒 x}  {−𝐒ₙ ℕ.𝐒 y} = [≡]-intro
sign-of-[⋅] {−𝐒ₙ ℕ.𝟎}   {+ₙ ℕ.𝟎}    = [≡]-intro
sign-of-[⋅] {−𝐒ₙ ℕ.𝟎}   {+ₙ ℕ.𝐒 y}  = [≡]-intro
sign-of-[⋅] {−𝐒ₙ ℕ.𝐒 x} {+ₙ ℕ.𝟎}    = [≡]-intro
sign-of-[⋅] {−𝐒ₙ ℕ.𝐒 x} {+ₙ ℕ.𝐒 y}  = [≡]-intro

signed-inverse : ∀{x} → (signed0 (sign0 x) (absₙ x) ≡ x)
signed-inverse {+𝐒ₙ _} = [≡]-intro
signed-inverse {𝟎}     = [≡]-intro
signed-inverse {−𝐒ₙ _} = [≡]-intro

sign0-inverse : ∀{x}{y} → (sign0(signed0 x (ℕ.𝐒(y))) ≡ x)
sign0-inverse {Sign.➕} {y} = [≡]-intro
sign0-inverse {Sign.𝟎}  {y} = [≡]-intro
sign0-inverse {Sign.➖} {y} = [≡]-intro

absₙ-inverse : ∀{x}{y} → (x ≢ Sign.𝟎) → (absₙ(signed0 x y) ≡ y)
absₙ-inverse {Sign.➕} {ℕ.𝟎}   _ = [≡]-intro
absₙ-inverse {Sign.➕} {ℕ.𝐒 y} _ = [≡]-intro
absₙ-inverse {Sign.➖} {ℕ.𝟎}   _ = [≡]-intro
absₙ-inverse {Sign.➖} {ℕ.𝐒 y} _ = [≡]-intro
absₙ-inverse {Sign.𝟎} {ℕ.𝟎}    _ = [≡]-intro
absₙ-inverse {Sign.𝟎} {ℕ.𝐒 y}  p with () ← p [≡]-intro

absₙ-of-[−ₙ] : ∀{x} → (absₙ(−ₙ x) ≡ x)
absₙ-of-[−ₙ] {ℕ.𝟎}   = [≡]-intro
absₙ-of-[−ₙ] {ℕ.𝐒 x} = [≡]-intro

[⋅]-equality : ∀{x y z} → (x ⋅ y ≡ z) ↔ (sign0(x) Sign.⨯ sign0(y) ≡ sign0 z) ∧ (absₙ(x) ℕ.⋅ absₙ(y) ≡ absₙ(z))
[⋅]-equality {x}{y}{z} = [↔]-intro (Tuple.uncurry l) r where
  l : ∀{x y z} → (sign0(x) Sign.⨯ sign0(y) ≡ sign0 z) → (absₙ(x) ℕ.⋅ absₙ(y) ≡ absₙ(z)) → (x ⋅ y ≡ z)
  l{x}{y}{z} p q = congruence₂(signed0) p q 🝖 signed-inverse

  r : ∀{x y z} → (x ⋅ y ≡ z) → (sign0(x) Sign.⨯ sign0(y) ≡ sign0 z) ∧ (absₙ(x) ℕ.⋅ absₙ(y) ≡ absₙ(z))
  r{x}{y}{z} p = [∧]-intro (symmetry(_≡_) (preserving₂(sign0)(_⋅_)(Sign._⨯_)) 🝖 congruence₁(sign0) p) (symmetry(_≡_) (preserving₂(absₙ)(_⋅_)(ℕ._⋅_) {x}{y}) 🝖 congruence₁(absₙ) p)

instance
  [⋅]-identityₗ : Identityₗ(_⋅_)(𝟏)
  Identityₗ.proof [⋅]-identityₗ {x} with sign0 x | x
  ... | Sign.➕ | 𝟎     = [≡]-intro
  ... | Sign.➕ | +𝐒ₙ _ = [≡]-intro
  ... | Sign.➕ | −𝐒ₙ _ = [≡]-intro
  ... | Sign.𝟎 | 𝟎     = [≡]-intro
  ... | Sign.𝟎 | +𝐒ₙ _ = [≡]-intro
  ... | Sign.𝟎 | −𝐒ₙ _ = [≡]-intro
  ... | Sign.➖ | 𝟎     = [≡]-intro
  ... | Sign.➖ | +𝐒ₙ _ = [≡]-intro
  ... | Sign.➖ | −𝐒ₙ _ = [≡]-intro

instance
  [⋅]-identityᵣ : Identityᵣ(_⋅_)(𝟏)
  Identityᵣ.proof [⋅]-identityᵣ {x} with sign0 x | x
  ... | Sign.➕ | 𝟎     = [≡]-intro
  ... | Sign.➕ | +𝐒ₙ _ = [≡]-intro
  ... | Sign.➕ | −𝐒ₙ _ = [≡]-intro
  ... | Sign.𝟎 | 𝟎     = [≡]-intro
  ... | Sign.𝟎 | +𝐒ₙ _ = [≡]-intro
  ... | Sign.𝟎 | −𝐒ₙ _ = [≡]-intro
  ... | Sign.➖ | 𝟎     = [≡]-intro
  ... | Sign.➖ | +𝐒ₙ _ = [≡]-intro
  ... | Sign.➖ | −𝐒ₙ _ = [≡]-intro

instance
  [⋅]-commutativity : Commutativity(_⋅_)
  Commutativity.proof [⋅]-commutativity {x}{y} = congruence₂(signed0) (commutativity(Sign._⨯_)) (commutativity(ℕ._⋅_) {absₙ x}{absₙ y})

instance
  postulate [⋅]-associativity : Associativity(_⋅_)
  {-Associativity.proof [⋅]-associativity {x}{y}{z} =
    congruence₂(signed0)
      (congruence₂ₗ(Sign._⨯_)(sign0 z) sign0-inverse                                                  🝖 associativity(Sign._⨯_)                      🝖 symmetry(_≡_) (congruence₂ᵣ(Sign._⨯_)(sign0(x)) (sign-of-[⋅] {y}{z})))
      (congruence₂ₗ(ℕ._⋅_)   (absₙ(z)) (absₙ-inverse{sign0(x) Sign.⨯ sign0(y)}{absₙ(x) ℕ.⋅ absₙ(y)})  🝖 associativity(ℕ._⋅_){absₙ x}{absₙ y}{absₙ z} 🝖 symmetry(_≡_) (congruence₂ᵣ(ℕ._⋅_)   (absₙ (x)) (absₙ-of-[⋅] {y}{z})))
  -}

instance
  postulate [⋅][+]-distributivityₗ : Distributivityₗ(_⋅_)(_+_)
  {-[⋅][+]-distributivityₗ = intro p where
    p : Names.Distributivityₗ(_⋅_)(_+_)
    p {+ₙ ℕ.𝟎} {+ₙ ℕ.𝟎} {+ₙ ℕ.𝟎} = [≡]-intro
    p {+ₙ ℕ.𝟎} {+ₙ ℕ.𝟎} {+ₙ ℕ.𝐒 z} = [≡]-intro
    p {+ₙ ℕ.𝟎} {+ₙ ℕ.𝐒 y} {+ₙ ℕ.𝟎} = [≡]-intro
    p {+ₙ ℕ.𝟎} {+ₙ ℕ.𝐒 y} {+ₙ ℕ.𝐒 z} = [≡]-intro
    p {+ₙ ℕ.𝐒 x} {+ₙ ℕ.𝟎} {+ₙ ℕ.𝟎} = [≡]-intro
    p {+ₙ ℕ.𝐒 x} {+ₙ ℕ.𝟎} {+ₙ ℕ.𝐒 z} = [≡]-intro
    p {+ₙ ℕ.𝐒 x} {+ₙ ℕ.𝐒 y} {+ₙ ℕ.𝟎} = [≡]-intro
    p {+ₙ ℕ.𝐒 x} {+ₙ ℕ.𝐒 y} {+ₙ ℕ.𝐒 z} = {!!}
    p {+ₙ ℕ.𝟎} {+ₙ ℕ.𝟎} {−𝐒ₙ z} = [≡]-intro
    p {+ₙ ℕ.𝟎} {+ₙ ℕ.𝐒 y} {−𝐒ₙ z} = {!!}
    p {+ₙ ℕ.𝐒 x} {+ₙ ℕ.𝟎} {−𝐒ₙ z} = [≡]-intro
    p {+ₙ ℕ.𝐒 x} {+ₙ ℕ.𝐒 y} {−𝐒ₙ z} = {!!}
    p {+ₙ ℕ.𝟎} {−𝐒ₙ y} {+ₙ ℕ.𝟎} = [≡]-intro
    p {+ₙ ℕ.𝟎} {−𝐒ₙ y} {+ₙ ℕ.𝐒 z} = {!!}
    p {+ₙ ℕ.𝐒 x} {−𝐒ₙ y} {+ₙ ℕ.𝟎} = [≡]-intro
    p {+ₙ ℕ.𝐒 x} {−𝐒ₙ y} {+ₙ ℕ.𝐒 z} = {!!}
    p {+ₙ ℕ.𝟎} {−𝐒ₙ y} {−𝐒ₙ z} = [≡]-intro
    p {+ₙ ℕ.𝐒 x} {−𝐒ₙ y} {−𝐒ₙ z} = {!!}
    p {−𝐒ₙ x} {+ₙ ℕ.𝟎} {+ₙ ℕ.𝟎} = [≡]-intro
    p {−𝐒ₙ x} {+ₙ ℕ.𝟎} {+ₙ ℕ.𝐒 z} = [≡]-intro
    p {−𝐒ₙ x} {+ₙ ℕ.𝐒 y} {+ₙ ℕ.𝟎} = [≡]-intro
    p {−𝐒ₙ x} {+ₙ ℕ.𝐒 y} {+ₙ ℕ.𝐒 z} = {!!}
    p {−𝐒ₙ x} {+ₙ ℕ.𝟎} {−𝐒ₙ z} = [≡]-intro
    p {−𝐒ₙ x} {+ₙ ℕ.𝐒 y} {−𝐒ₙ z} = {!!}
    p {−𝐒ₙ x} {−𝐒ₙ y} {+ₙ ℕ.𝟎} = [≡]-intro
    p {−𝐒ₙ x} {−𝐒ₙ y} {+ₙ ℕ.𝐒 z} = {!!}
    p {−𝐒ₙ x} {−𝐒ₙ y} {−𝐒ₙ z} = {!!}-}
  {-
    x ⋅ (y + z)                                                                                🝖[ _≡_ ]-[]
    signed0 ((sign0 x) Sign.⨯ (sign0(y + z))) ((absₙ x) ℕ.⋅ (absₙ(y + z)))                                                          🝖[ _≡_ ]-[ {!congruence₂(signed0) ? ?!} ]
    signed0 ((sign0 x) Sign.⨯ sign0(y + z)) ((absₙ x) ℕ.⋅ (absₙ(y + z)))                                                          🝖[ _≡_ ]-[ {!!} ]
    (signed0 ((sign0 x) Sign.⨯ (sign0 y)) ((absₙ x) ℕ.⋅ (absₙ y))) + (signed0 ((sign0 x) Sign.⨯ (sign0 z)) ((absₙ x) ℕ.⋅ (absₙ z))) 🝖[ _≡_ ]-[]
    (x ⋅ y) + (x ⋅ z)                                                                                🝖-end
    where
      sign0-proof : ∀{x y z} → ((sign0 x) Sign.⨯ sign0(y + z) ≡ (sign0(x) + sign0(z)) Sign.⨯ (sign0(x) + sign0(z)))
  -}

instance
  postulate [⋅][+]-distributivityᵣ : Distributivityᵣ(_⋅_)(_+_)

instance
  postulate [⋅][−]-distributivityₗ : Distributivityₗ(_⋅_)(_−_)

instance
  postulate [⋅][−]-distributivityᵣ : Distributivityᵣ(_⋅_)(_−_)

instance
  [+][⋅]-rng : Rng(_+_)(_⋅_)
  [+][⋅]-rng = record{}

instance
  [+][⋅]-ring-unity : Unity(_+_)(_⋅_)
  Unity.[⋅]-identity-existence [+][⋅]-ring-unity = [∃]-intro 𝟏 ⦃ intro ⦄

instance
  [+][⋅]-ring : Ring(_+_)(_⋅_)
  [+][⋅]-ring = record{}

import      Numeral.Natural.Relation.Order as ℕ
import      Numeral.Natural.Relation.Order.Proofs as ℕ
import      Structure.Relator.Ordering as Structure
data _≤_ : ℤ → ℤ → Type{Lvl.𝟎} where
  pos : ∀{a b} → (a ℕ.≤ b) → ((+ₙ a) ≤ (+ₙ b))
  neg : ∀{a b} → (a ℕ.≥ b) → ((−𝐒ₙ a) ≤ (−𝐒ₙ b))
  mix : ∀{a b} → ((−𝐒ₙ a) ≤ (+ₙ b))

instance
  [≤]-reflexivity : Reflexivity(_≤_)
  Reflexivity.proof [≤]-reflexivity {+ₙ  x} = pos (reflexivity(ℕ._≤_))
  Reflexivity.proof [≤]-reflexivity {−𝐒ₙ x} = neg (reflexivity(ℕ._≤_))

instance
  [≤]-transitivity : Transitivity(_≤_)
  Transitivity.proof [≤]-transitivity (pos p) (pos q) = pos(transitivity(ℕ._≤_) p q)
  Transitivity.proof [≤]-transitivity (neg p) (neg q) = neg(transitivity(ℕ._≤_) q p)
  Transitivity.proof [≤]-transitivity (neg p) mix     = mix
  Transitivity.proof [≤]-transitivity mix     (pos q) = mix

instance
  [≤]-antisymmetry : Antisymmetry(_≤_)(_≡_)
  Antisymmetry.proof [≤]-antisymmetry (pos {ℕ.𝟎}   {ℕ.𝟎}   p) (pos q) = [≡]-intro
  Antisymmetry.proof [≤]-antisymmetry (neg {ℕ.𝟎}   {ℕ.𝟎}   p) (neg q) = [≡]-intro
  Antisymmetry.proof [≤]-antisymmetry (pos {ℕ.𝐒 a} {ℕ.𝐒 b} p) (pos q) = congruence₁(+ₙ_)  (antisymmetry(ℕ._≤_)(_≡_) p q)
  Antisymmetry.proof [≤]-antisymmetry (neg {ℕ.𝐒 a} {ℕ.𝐒 b} p) (neg q) = congruence₁(−𝐒ₙ_) (antisymmetry(ℕ._≤_)(_≡_) q p)

instance
  [≤]-converseTotal : ConverseTotal(_≤_)
  ConverseTotal.proof [≤]-converseTotal {+ₙ  x} {+ₙ  y} = Either.map pos pos (converseTotal(ℕ._≤_))
  ConverseTotal.proof [≤]-converseTotal {+ₙ  x} {−𝐒ₙ y} = Either.Right mix
  ConverseTotal.proof [≤]-converseTotal {−𝐒ₙ x} {+ₙ  y} = Either.Left  mix
  ConverseTotal.proof [≤]-converseTotal {−𝐒ₙ x} {−𝐒ₙ y} = Either.map neg neg (converseTotal(ℕ._≤_))

instance
  [≤]-weakPartialOrder : Structure.Weak.PartialOrder(_≤_)(_≡_)
  [≤]-weakPartialOrder = record{}

instance
  [≤]-totalOrder : Structure.Weak.TotalOrder(_≤_)(_≡_)
  [≤]-totalOrder = record{}

instance
  [+][⋅][≤]-orderedRing : Ordered(_+_)(_⋅_)(_≤_)
  Ordered.[≤][+]ₗ-preserve  [+][⋅][≤]-orderedRing = p where
    postulate p : ∀{x y z} → (x ≤ y) → ((x + z) ≤ (y + z))
    {-p {+ₙ x}    {+ₙ y}     {+ₙ  z} (pos xy) = pos {!!}
    p {−𝐒ₙ x}   {−𝐒ₙ y}    {−𝐒ₙ z} (neg xy) = neg {!!}
    p {+ₙ ℕ.𝟎}  {+ₙ ℕ.𝟎}   {−𝐒ₙ z} (pos xy) = reflexivity(_≤_)
    p {+ₙ ℕ.𝟎}  {+ₙ ℕ.𝐒 y} {−𝐒ₙ z} (pos xy) = {!!}
    p {+ₙ ℕ.𝐒 x} {+ₙ ℕ.𝐒 y}{−𝐒ₙ z} (pos xy) = {!!}
    p {.(−𝐒ₙ _)} {.(+ₙ _)} {+ₙ  z} mix = {!!}
    p {.(−𝐒ₙ _)} {.(+ₙ _)} {−𝐒ₙ z} mix = {!!}-}
  Ordered.[≤][⋅]-zero       [+][⋅][≤]-orderedRing = p where
    p : ∀{x y} → (𝟎 ≤ x) → (𝟎 ≤ y) → (𝟎 ≤ (x ⋅ y))
    p {+ₙ ℕ.𝟎}   {+ₙ ℕ.𝟎}   (pos px) (pos py) = pos py
    p {+ₙ ℕ.𝟎}   {+ₙ ℕ.𝐒 y} (pos px) (pos py) = pos px
    p {+ₙ ℕ.𝐒 x} {+ₙ ℕ.𝟎}   (pos px) (pos py) = pos py
    p {+ₙ ℕ.𝐒 x} {+ₙ ℕ.𝐒 y} (pos px) (pos py) = pos ℕ.[≤]-minimum


{-

This file contains:
    - the abelianization of groups as a HIT as proposed in https://arxiv.org/abs/2007.05833

The definition of the abelianization is not as a set-quotient, since the relation of
abelianization is cumbersome to work with.

-}
{-# OPTIONS --safe #-}
module Cubical.Algebra.Group.Abelianization.Properties where

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

open import Cubical.Data.Sigma

open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.Properties
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
  using (isPropIsGroupHom; compGroupHom; idGroupHom)

open import Cubical.Algebra.AbGroup.Base

open import Cubical.Algebra.Group.Abelianization.Base

private
  variable
    ℓ : Level

module _ (G : Group ℓ) where
  open GroupStr {{...}}
  open GroupTheory G
  private
    instance
      _ = snd G

  -- Some helpful lemmas, similar to those in Cubical/HITs/SetQuotients/Properties.agda
  elimProp : {B : Abelianization G → Type ℓ}
        → (Bprop : (x : Abelianization G) → isProp (B x))
        → (f : (g : fst G) → B (η g))
        → (x : Abelianization G)
        → B x
  elimProp Bprop f (η g) = f g
  elimProp {B = B} Bprop f (comm a b c i) =
    isProp→PathP (λ i → Bprop (comm a b c i)) (f (a · (b · c))) (f (a · (c · b))) i
  elimProp Bprop f (isset x y p q i j) =
    isOfHLevel→isOfHLevelDep
      2 (λ x → isProp→isSet (Bprop x)) (g x) (g y) (cong g p) (cong g q) (isset x y p q) i j
    where
    g = elimProp Bprop f

  elimProp2 : {C : Abelianization G → Abelianization G → Type ℓ}
        → (Cprop : (x y : Abelianization G) → isProp (C x y))
        → (f : (a b : fst G) → C (η a) (η b))
        → (x y : Abelianization G)
        → C x y
  elimProp2 Cprop f = elimProp (λ x → isPropΠ (λ y → Cprop x y))
                               (λ x → elimProp (λ y → Cprop (η x) y) (f x))

  elimProp3 : {D : Abelianization G → Abelianization G → Abelianization G → Type ℓ}
        → (Dprop : (x y z : Abelianization G) → isProp (D x y z))
        → ((a b c : fst G) → D (η a) (η b) (η c))
        → (x y z : Abelianization G)
        → D x y z
  elimProp3 Dprop f = elimProp (λ x → isPropΠ2 (λ y z → Dprop x y z))
                               (λ x → elimProp2 (λ y z → Dprop (η x) y z) (f x))

  elimContr : {B : Abelianization G → Type ℓ}
        → (Bcontr : ∀ (a : fst G) → isContr (B (η a)))
        → (x : Abelianization G)
        → B x
  elimContr Bcontr = elimProp (elimProp (λ _ → isPropIsProp) λ _ → isContr→isProp (Bcontr _))
                              λ _ → Bcontr _ .fst

  elimContr2 : {C : Abelianization G → Abelianization G → Type ℓ}
        → (Ccontr : ∀ (a b : fst G) → isContr (C (η a) (η b)))
        → (x y : Abelianization G)
        → C x y
  elimContr2 Ccontr = elimContr λ _ → isOfHLevelΠ 0
                     (elimContr λ _ → inhProp→isContr (Ccontr _ _) isPropIsContr)

  rec : {M : Type ℓ}
        (Mset : isSet M)
        (f : fst G → M)
        (fcomm : (a b c : fst G) → f (a · (b · c)) ≡ f (a · (c · b)))
      → Abelianization G → M
  rec Mset f fcomm (η g) = f g
  rec Mset f fcomm (comm a b c i) = fcomm a b c i
  rec Mset f fcomm (isset a b p q i j) = Mset (g a) (g b) (cong g p) (cong g q) i j
    where
    g = rec Mset f fcomm

  rec2 : {M : Type ℓ}
        (Mset : isSet M)
        (f : fst G → fst G → M)
        (fcomml : (a b c d : fst G) → f (a · (b · c)) d ≡ f (a · (c · b)) d)
        (fcommr : (a b c d : fst G) → f a (b · (c · d)) ≡ f a (b · (d · c)))
      → Abelianization G → Abelianization G → M
  rec2 Mset f fcomml fcommr =
    rec
      (isSetΠ (λ _ → Mset))
      (λ g → rec Mset (λ h → f g h) (fcommr g))
      (λ a b c → funExt (elimProp (λ _ → Mset _ _) (λ d → fcomml a b c d)))

module AbelianizationGroupStructure (G : Group ℓ) where
  open GroupStr {{...}}
  open GroupTheory G
  private
    instance
      _ = snd G

  {-
    Definition of the group structure on the abelianization. Here the generality of the comm
    relation is used.
  -}
  _·Ab_ : Abelianization G → Abelianization G → Abelianization G
  _·Ab_ =
    (rec2 G)
      isset
      (λ x y → η (x · y))
      (λ a b c d → η ((a · (b · c)) · d) ≡⟨ cong η (cong (λ x → (x · d)) (assoc _ _ _)) ⟩
                   η (((a · b) · c) · d) ≡⟨ cong η (sym (assoc (a · b) c d)) ⟩
                   η ((a · b) · (c · d)) ≡⟨ comm (a · b) c d ⟩
                   η ((a · b) · (d · c)) ≡⟨ cong η (sym (assoc _ _ _)) ⟩
                   η (a · (b · (d · c))) ≡⟨ cong η (cong (λ x → (a · x)) (assoc _ _ _)) ⟩
                   η (a · ((b · d) · c)) ≡⟨ comm a (b · d) c ⟩
                   η (a · (c · (b · d))) ≡⟨ cong η (cong (λ x → (a · x)) (assoc _ _ _)) ⟩
                   η (a · ((c · b) · d)) ≡⟨ cong η (assoc a (c · b) d) ⟩
                   η ((a · (c · b)) · d) ∎)
      (λ a b c d → η (a · (b · (c · d))) ≡⟨ cong η (assoc _ _ _) ⟩
                   η ((a · b) · (c · d)) ≡⟨ comm (a · b) c d ⟩
                   η ((a · b) · (d · c)) ≡⟨ cong η (sym (assoc _ _ _)) ⟩
                   η (a · (b · (d · c))) ∎)

  1Ab : Abelianization G
  1Ab = η 1g

  invAb : Abelianization G → Abelianization G
  invAb =
    (rec G)
      isset
      ((λ x → η (inv x)))
      (λ a b c → η (inv (a · (b · c)))         ≡⟨ cong η (invDistr a (b · c)) ⟩
      η ((inv (b · c)) · (inv a))              ≡⟨ cong (λ x → η (x · (inv a))) (invDistr b c) ⟩
      η (((inv c) · (inv b)) · (inv a))        ≡⟨ cong
                                                    η
                                                    ((sym (lid (((inv c) · (inv b)) · (inv a))))) ⟩
      η (1g · (((inv c) · (inv b)) · (inv a))) ≡⟨ comm 1g ((inv c) · (inv b)) (inv a) ⟩
      η (1g · ((inv a) · ((inv c) · (inv b)))) ≡⟨ cong η (lid ((inv a) · ((inv c) · (inv b)))) ⟩
      η ((inv a) · ((inv c) · (inv b)))        ≡⟨ comm (inv a) (inv c) (inv b) ⟩
      η ((inv a) · ((inv b) · (inv c)))        ≡⟨ cong
                                                    η
                                                    ((sym (lid ((inv a) · ((inv b) · (inv c)))))) ⟩
      η (1g · ((inv a) · ((inv b) · (inv c)))) ≡⟨ comm 1g (inv a) ((inv b) · (inv c)) ⟩
      η (1g · (((inv b) · (inv c)) · (inv a))) ≡⟨ cong η (lid (((inv b) · (inv c)) · (inv a))) ⟩
      η (((inv b) · (inv c)) · (inv a))        ≡⟨ cong
                                                    (λ x → η (x · (inv a)))
                                                    (sym (invDistr c b)) ⟩
      η ((inv (c · b)) · (inv a))              ≡⟨ cong η (sym (invDistr a (c · b))) ⟩
      η (inv (a · (c · b))) ∎)

  assocAb : (x y z : Abelianization G) → x ·Ab (y ·Ab z) ≡ (x ·Ab y) ·Ab z
  assocAb =
    (elimProp3 G)
      (λ x y z → isset (x ·Ab (y ·Ab z)) ((x ·Ab y) ·Ab z))
      (λ x y z → cong η (assoc x y z))

  ridAb : (x : Abelianization G) → x ·Ab 1Ab ≡ x
  ridAb =
    (elimProp G)
      (λ x → isset (x ·Ab 1Ab) x)
      (λ x → cong η (rid x))

  rinvAb : (x : Abelianization G) → x ·Ab (invAb x) ≡ 1Ab
  rinvAb =
    (elimProp G)
      (λ x → isset (x ·Ab (invAb x)) 1Ab)
      (λ x → (η x) ·Ab (invAb (η x)) ≡⟨ refl ⟩
             (η x) ·Ab (η (inv x))   ≡⟨ refl ⟩
             η (x · (inv x))         ≡⟨ cong η (fst (inverse x)) ⟩
             η 1g                    ≡⟨ refl ⟩
             1Ab ∎)

  commAb : (x y : Abelianization G) → x ·Ab y ≡ y ·Ab x
  commAb =
    (elimProp2 G)
      (λ x y → isset (x ·Ab y) (y ·Ab x))
      (λ x y → (η x) ·Ab (η y)  ≡⟨ refl ⟩
               η (x · y)        ≡⟨ cong η (sym (lid (x · y))) ⟩
               η (1g · (x · y)) ≡⟨ comm 1g x y ⟩
               η (1g · (y · x)) ≡⟨ cong η (lid (y · x)) ⟩
               η (y · x)        ≡⟨ refl ⟩
               (η y) ·Ab (η x) ∎)

  -- The proof that the abelianization is in fact an abelian group.
  asAbelianGroup : AbGroup ℓ
  asAbelianGroup = makeAbGroup 1Ab _·Ab_ invAb isset assocAb ridAb rinvAb commAb

  -- The proof that η can be seen as a group homomorphism
  ηAsGroupHom : GroupHom G (AbGroup→Group asAbelianGroup)
  ηAsGroupHom = f , fIsHom
    where
    f = λ x → η x
    fIsHom : IsGroupHom (snd G) f (snd (AbGroup→Group asAbelianGroup))
    IsGroupHom.pres· fIsHom = λ x y → refl
    IsGroupHom.pres1 fIsHom = refl
    IsGroupHom.presinv fIsHom = λ x → refl

AbelianizationAbGroup : (G : Group ℓ) → AbGroup ℓ
AbelianizationAbGroup G = AbelianizationGroupStructure.asAbelianGroup G

AbelianizationHom : (G : Group ℓ) → GroupHom G (AbGroup→Group (AbelianizationAbGroup G))
AbelianizationHom G = AbelianizationGroupStructure.ηAsGroupHom G

module UniversalProperty (G : Group ℓ) where
  open GroupStr {{...}}
  open GroupTheory G
  open AbelianizationGroupStructure G
  private
    instance
      _ = snd G
  abstract
    {- The proof of the universal property of the abelianization.

    G --η--> abelianization
    \         .
      \       .
        f   ∃! inducedHom
          \   .
            \ .
              H
    commuting diagram
    -}
    inducedHom : (H : AbGroup ℓ)
               → (f : GroupHom G (AbGroup→Group H))
               → AbGroupHom asAbelianGroup H
    inducedHom H f = g , gIsHom
      where open IsGroupHom
            instance
              _ : GroupStr (fst H)
              _ = snd (AbGroup→Group H)
            f' : fst G → fst H
            f' = fst f
            g : Abelianization G → fst H
            g = (rec G)
                  (isSetAbGroup H)
                  (λ x → (f') x)
                  (λ a b c → f' (a · b · c)           ≡⟨ (snd f).pres· a (b · c) ⟩
                             (f' a) · (f' (b · c))    ≡⟨ cong
                                                           (λ x → (f' a) · x)
                                                           ((snd f).pres· b c) ⟩
                             (f' a) · (f' b) · (f' c) ≡⟨ cong
                                                           (λ x → (f' a) · x)
                                                           ((snd H).AbGroupStr.comm (f' b) (f' c)) ⟩
                             (f' a) · (f' c) · (f' b) ≡⟨ cong
                                                           (λ x → (f' a) · x)
                                                           (sym ((snd f).pres· c b)) ⟩
                             (f' a) · (f' (c · b))    ≡⟨ sym ((snd f).pres· a (c · b)) ⟩
                             f' (a · c · b) ∎)
            gIsHom : IsGroupHom (snd (AbGroup→Group asAbelianGroup)) g (snd (AbGroup→Group H))
            pres· gIsHom =
              (elimProp2 G)
                (λ x y → isSetAbGroup H _ _)
                ((snd f).pres·)
            pres1 gIsHom = (snd f).pres1
            presinv gIsHom =
              (elimProp G)
                (λ x → isSetAbGroup H _ _)
                ((snd f).presinv)

    commutativity : (H : AbGroup ℓ)
                  → (f : GroupHom G (AbGroup→Group H))
                  → (compGroupHom ηAsGroupHom (inducedHom H f) ≡ f)
    commutativity H f =
        Σ≡Prop
          (λ _ → isPropIsGroupHom _ _)
          (λ i x → q x i)
      where q : (x : fst  G)
              → fst (compGroupHom ηAsGroupHom (inducedHom H f)) x ≡ fst f x
            q = (λ x → refl)

    uniqueness : (H : AbGroup ℓ)
               → (f : GroupHom G (AbGroup→Group H))
               → (g : AbGroupHom asAbelianGroup H)
               → (p : compGroupHom ηAsGroupHom g ≡ f)
               → (g ≡ inducedHom H f)
    uniqueness H f g p =
        Σ≡Prop
          (λ _ → isPropIsGroupHom _ _)
          (λ i x →  q x i)
      where q : (x : Abelianization G)
                →  fst g x ≡ fst (inducedHom H f) x
            q = (elimProp G)
                  (λ _ → isSetAbGroup H _ _)
                  (λ x → fst g (η x) ≡⟨ cong (λ f → f x) (cong fst p) ⟩
                         (fst f) x   ≡⟨ refl ⟩
                         fst (inducedHom H f) (η x)∎)


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

{-
  Ribbon is the explicit covering space construction.

  This construction is given by Daniel Grayson, Favonia (me)
  and Guillaume Brunerie together.
-}

open import Base
open import Homotopy.Pointed

-- A is the pointed base space.
-- Y is intended to be a (group-)set,
-- but can be an arbitrarily weird space.
module Homotopy.Cover.Ribbon {i} (A⋆ : pType i) {Y : Set i} where
  open pType A⋆ renaming (∣_∣ to A ; ⋆ to a)

  open import Homotopy.Truncation
  open import Homotopy.PathTruncation
  open import Homotopy.HomotopyGroups
  open import Algebra.GroupSets (fundamental-group A⋆)

  -- The HIT ribbon---reconstructed covering space
  private
    module Ribbon {act : action Y} where
      open action act

      private
        data #ribbon (a₂ : A) : Set i where
          #trace : Y →  a ≡₀ a₂ → #ribbon a₂

      ribbon : A → Set i
      ribbon = #ribbon

      -- A point in the fiber a₂.
      {-
        y is a point in the fiber a, and
        p is a path to transport y to fiber a₂.
      -}
      trace : ∀ {a₂} → Y → a ≡₀ a₂ → ribbon a₂
      trace = #trace

      {-
        A loop based at a can used as a group action
        or for concatination.  Both should be equivalent.

        And after pasting, make the type fiberwise a set.
      -}
      postulate -- HIT
        paste : ∀ {a₂} y loop (p : a ≡₀ a₂)
          → trace (y ∙ loop) p ≡ trace y (loop ∘₀ p)
        ribbon-is-set : ∀ a₂ → is-set (ribbon a₂)

      -- Standard dependent eliminator
      ribbon-rec : ∀ a₂ {j} (P : ribbon a₂ → Set j)
        ⦃ P-is-set : ∀ r → is-set (P r) ⦄
        (trace* : ∀ y p → P (trace y p))
        (paste* : ∀ y loop p → transport P (paste y loop p) (trace* (y ∙ loop) p)
                             ≡ trace* y (loop ∘₀ p))
        → (∀ r → P r)
      ribbon-rec a₂ P trace* paste* (#trace y p) = trace* y p

      -- Standard non-dependent eliminator
      ribbon-rec-nondep : ∀ a₂ {j} (P : Set j)
        ⦃ P-is-set : is-set P ⦄
        (trace* : ∀ (y : Y) (p : a ≡₀ a₂) → P)
        (paste* : ∀ y (loop : a ≡₀ a) p → trace* (y ∙ loop) p ≡ trace* y (loop ∘₀ p))
        → (ribbon a₂ → P)
      ribbon-rec-nondep a₂ P trace* paste* (#trace y p) = trace* y p

  open Ribbon public hiding (ribbon)

  module _ (act : action Y) where

    ribbon : A → Set i
    ribbon = Ribbon.ribbon {act}

    trans-trace : ∀ {a₁ a₂} (q : a₁ ≡ a₂) y p
      → transport ribbon q (trace y p) ≡ trace y (p ∘₀ proj q)
    trans-trace refl y p = ap (trace y) $ ! $ refl₀-right-unit p


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

--open import HoTT
open import homotopy.3x3.PushoutPushout
open import homotopy.3x3.Transpose
import homotopy.3x3.To as To
import homotopy.3x3.From as From
open import homotopy.3x3.Common

module homotopy.3x3.FromToInit {i} (d : Span^2 {i}) where

open Span^2 d
open M d hiding (Pushout^2)
open M (transpose d) using () renaming (module F₁∙ to F∙₁; f₁∙ to f∙₁;
                                        module F₃∙ to F∙₃; f₃∙ to f∙₃;
                                        v-h-span to h-v-span)
open M using (Pushout^2)

open To d
open From d

from-to-l-g : (c : A₀₂) → ap (from ∘ to ∘ left) (glue c) == ap left (glue c)
from-to-l-g c =
  ap (from ∘ i₀∙) (glue c)
       =⟨ ap-∘ from i₀∙ (glue c) ⟩
  ap from (ap i₀∙ (glue c))
       =⟨ I₀∙.glue-β c |in-ctx ap from ⟩
  ap from (glue (left c))
       =⟨ From.glue-β (left c) ⟩
  ap left (glue c) ∎

module FromToL = PushoutElim {d = span _ _ _ f₀₁ f₀₃} {P = λ a → from (to (left a)) == left a}
                 (λ a → idp) (λ b → idp) (λ c → ↓-='-in (! (from-to-l-g c)))

from-to-l : (a : A₀∙) → from (to (left a)) == left a
from-to-l = FromToL.f

from-to-r-g : (c : A₄₂) → ap (from ∘ to ∘ right) (glue c) == ap right (glue c)
from-to-r-g c =
  ap (from ∘ i₄∙) (glue c)
       =⟨ ap-∘ from i₄∙ (glue c) ⟩
  ap from (ap i₄∙ (glue c))
       =⟨ I₄∙.glue-β c |in-ctx ap from ⟩
  ap from (glue (right c))
       =⟨ From.glue-β (right c) ⟩
  ap right (glue c) ∎

module FromToR = PushoutElim {d = span _ _ _ f₄₁ f₄₃} {P = λ b → from (to (right b)) == right b}
                 (λ a → idp) (λ b → idp) (λ c → ↓-='-in (! (from-to-r-g c)))

from-to-r : (b : A₄∙) → from (to (right b)) == right b
from-to-r = FromToR.f

from-to-g-l : (a : A₂₀) → glue (left a) == ap from (ap to (glue (left a)))
from-to-g-l a =
  glue (left a)
       =⟨ ! (I∙₀.glue-β a) ⟩
  ap i∙₀ (glue a)
       =⟨ ap-∘ from left (glue a) ⟩
  ap from (ap left (glue a))
       =⟨ ! (To.glue-β (left a)) |in-ctx ap from ⟩
  ap from (ap to (glue (left a))) ∎

from-to-g-r : (b : A₂₄) → glue (right b) == ap from (ap to (glue (right b)))
from-to-g-r b =
  glue (right b)
       =⟨ ! (I∙₄.glue-β b) ⟩
   ap i∙₄ (glue b)
        =⟨ ap-∘ from right (glue b) ⟩
   ap from (ap right (glue b))
        =⟨ ! (To.glue-β (right b)) |in-ctx ap from ⟩
   ap from (ap to (glue (right b))) ∎


module Negative5 where

data Funny (A : Set) : Set where
  funny : A -> Funny (Funny A -> A) -> Funny A


{-
Problem #53
Given premises:
    (all x)[(F x) -> (some y)((F y) & (G x y))]    justification = 1.0

Ultimate epistemic interests:
    (all x)[(F x) -> (some y)(some z)((G x y) & (G y z))]    interest = 1.0
-}

open import Prelude

postulate
  U : Set
  F : U → Set
  G : U → U → Set

record Premise {x : U} (Fx : F x) : Set where
  field
    pY : U
    pF : F pY
    pG : G x pY

open Premise

record Conclusion {x : U} (Fx : F x) : Set where
  field
    cY : U
    cZ : U
    cGxy : G x cY
    cGyz : G cY cZ

open Conclusion

premise = ∀ x → (Fx : F x) → Premise Fx
conclusion = ∀ x → (Fx : F x) → Conclusion Fx

proof1 : premise → conclusion
proof1 p x Fx =
  record
  { cY = _
  ; cZ = _
  ; cGxy = pG p1
  ; cGyz = pG p2 }
  where
  p1 = p x Fx
  p2 = p (pY p1) (pF p1)

{-
postulate
  U : Set
  F : U → Set
  G : U → U → Set

∃ : ∀ {a b} {A : Set a} (B : A → Set b) → Set (a ⊔ b)
∃ = Σ _

premise = ∀ x → F x → ∃ λ y → (F y × G x y)
conclusion = ∀ x → F x → ∃ λ y → ∃ λ z → (G x y × G y z)

pY : premise → ∀ x → F x → _
pY p x Fx = fst (p x Fx)

pF : premise → ∀ x → F x → F y -- y is not in scope!
pF p x Fx = {!fst (snd (p x Fx))!}

pG : premise → ∀ x → F x → _
pG p x Fx = {!snd (snd (p x Fx))!}

proof1 : premise → conclusion
proof1 p x Fx = y , z , Gxy , Gyz
  where
    y : U
    y = {!!}

    z : U
    z = {!!}

    Gxy : G x y
    Gxy = {!!}

    Gyz : G y z
    Gyz = {!!}
-}


open import Nat
open import Prelude
open import Hazelnut-core

module Hazelnut-deterministic where
  -- theorem 2

  -- the same action applied to the same type makes the same resultant
  -- type.
  actdet1 : {t t' t'' : τ̂} {α : action} →
            (t + α +> t') →
            (t + α +> t'') →
            (t' == t'')
  actdet1 TMFirstChild TMFirstChild = refl
  actdet1 TMParent1 TMParent1 = refl
  actdet1 TMParent1 (TMZip1 ())
  actdet1 TMParent2 TMParent2 = refl
  actdet1 TMParent2 (TMZip2 ())
  actdet1 TMNextSib TMNextSib = refl
  actdet1 TMNextSib (TMZip1 ())
  actdet1 TMPrevSib TMPrevSib = refl
  actdet1 TMPrevSib (TMZip2 ())
  actdet1 TMDel TMDel = refl
  actdet1 TMConArrow TMConArrow = refl
  actdet1 TMConNum TMConNum = refl
  actdet1 (TMZip1 ()) TMParent1
  actdet1 (TMZip1 ()) TMNextSib
  actdet1 (TMZip1 p1) (TMZip1 p2) with actdet1 p1 p2
  ... | refl = refl
  actdet1 (TMZip2 ()) TMParent2
  actdet1 (TMZip2 ()) TMPrevSib
  actdet1 (TMZip2 p1) (TMZip2 p2) with actdet1 p1 p2
  ... | refl = refl

  -- all expressions only move to one other expression
  movedet : {e e' e'' : ê} {δ : direction} →
            (e + move δ +>e e') →
            (e + move δ +>e e'') →
            e' == e''
  movedet EMAscFirstChild EMAscFirstChild = refl
  movedet EMAscParent1 EMAscParent1 = refl
  movedet EMAscParent2 EMAscParent2 = refl
  movedet EMAscNextSib EMAscNextSib = refl
  movedet EMAscPrevSib EMAscPrevSib = refl
  movedet EMLamFirstChild EMLamFirstChild = refl
  movedet EMLamParent EMLamParent = refl
  movedet EMPlusFirstChild EMPlusFirstChild = refl
  movedet EMPlusParent1 EMPlusParent1 = refl
  movedet EMPlusParent2 EMPlusParent2 = refl
  movedet EMPlusNextSib EMPlusNextSib = refl
  movedet EMPlusPrevSib EMPlusPrevSib = refl
  movedet EMApFirstChild EMApFirstChild = refl
  movedet EMApParent1 EMApParent1 = refl
  movedet EMApParent2 EMApParent2 = refl
  movedet EMApNextSib EMApNextSib = refl
  movedet EMApPrevSib EMApPrevSib = refl
  movedet EMFHoleFirstChild EMFHoleFirstChild = refl
  movedet EMFHoleParent EMFHoleParent = refl

  -- if a move action on a synthetic action makes a new form, it's unique
  synthmovedet : {Γ : ·ctx} {e e' e'' : ê} {t' t'' : τ̇} {δ : direction} →
         (Γ ⊢ e => t' ~ move δ ~> e'' => t'') →
         (e + move δ +>e e') →
         e'' == e'
  synthmovedet (SAMove EMAscFirstChild) EMAscFirstChild = refl
  synthmovedet (SAMove EMAscParent1) EMAscParent1 = refl
  synthmovedet (SAMove EMAscParent2) EMAscParent2 = refl
  synthmovedet (SAMove EMAscNextSib) EMAscNextSib = refl
  synthmovedet (SAMove EMAscPrevSib) EMAscPrevSib = refl
  synthmovedet (SAMove EMLamFirstChild) EMLamFirstChild = refl
  synthmovedet (SAMove EMLamParent) EMLamParent = refl
  synthmovedet (SAMove EMPlusFirstChild) EMPlusFirstChild = refl
  synthmovedet (SAMove EMPlusParent1) EMPlusParent1 = refl
  synthmovedet (SAMove EMPlusParent2) EMPlusParent2 = refl
  synthmovedet (SAMove EMPlusNextSib) EMPlusNextSib = refl
  synthmovedet (SAMove EMPlusPrevSib) EMPlusPrevSib = refl
  synthmovedet (SAMove EMApFirstChild) EMApFirstChild = refl
  synthmovedet (SAMove EMApParent1) EMApParent1 = refl
  synthmovedet (SAMove EMApParent2) EMApParent2 = refl
  synthmovedet (SAMove EMApNextSib) EMApNextSib = refl
  synthmovedet (SAMove EMApPrevSib) EMApPrevSib = refl
  synthmovedet (SAMove EMFHoleFirstChild) EMFHoleFirstChild = refl
  synthmovedet (SAMove EMFHoleParent) EMFHoleParent = refl
  -- all these cases lead to absurdities after a few levels
  synthmovedet (SAZipAsc1 (AASubsume _ (SAMove ()) _)) EMAscParent1
  synthmovedet (SAZipAsc1 (AAMove ())) EMAscParent1
  synthmovedet (SAZipAsc1 (AASubsume _ (SAMove ()) _)) EMAscNextSib
  synthmovedet (SAZipAsc1 (AAMove ())) EMAscNextSib
  synthmovedet (SAZipAsc2 () _) EMAscParent2
  synthmovedet (SAZipAsc2 () _) EMAscPrevSib
  synthmovedet (SAZipAp1 _ (SAMove ()) (ASubsume _ _)) EMApParent1
  synthmovedet (SAZipAp1 _ (SAMove ()) (ALam _ _)) EMApParent1
  synthmovedet (SAZipAp1 _ (SAMove ()) _) EMApNextSib
  synthmovedet (SAZipAp2 _ (SAMove ()) _) EMApParent1
  synthmovedet (SAZipAp2 _ (SAMove ()) _) EMApNextSib
  synthmovedet (SAZipAp3 _ (AASubsume _ (SAMove ()) _)) EMApParent2
  synthmovedet (SAZipAp3 _ (AAMove ())) EMApParent2
  synthmovedet (SAZipAp3 _ (AASubsume _ (SAMove ()) _)) EMApPrevSib
  synthmovedet (SAZipAp3 _ (AAMove ())) EMApPrevSib
  synthmovedet (SAZipAp4 _ (AASubsume _ (SAMove ()) _)) EMApParent2
  synthmovedet (SAZipAp4 _ (AAMove ())) EMApParent2
  synthmovedet (SAZipAp4 _ (AASubsume _ (SAMove ()) _)) EMApPrevSib
  synthmovedet (SAZipAp4 _ (AAMove ())) EMApPrevSib
  synthmovedet (SAZipPlus1 (AASubsume _ (SAMove ()) _)) EMPlusParent1
  synthmovedet (SAZipPlus1 (AAMove ())) EMPlusParent1
  synthmovedet (SAZipPlus1 (AASubsume _ (SAMove ()) _)) EMPlusNextSib
  synthmovedet (SAZipPlus1 (AAMove ())) EMPlusNextSib
  synthmovedet (SAZipPlus2 (AASubsume _ (SAMove ()) _)) EMPlusParent2
  synthmovedet (SAZipPlus2 (AAMove ())) EMPlusParent2
  synthmovedet (SAZipPlus2 (AASubsume _ (SAMove ()) _)) EMPlusPrevSib
  synthmovedet (SAZipPlus2 (AAMove ())) EMPlusPrevSib
  synthmovedet (SAZipHole1 _ (SAMove ()) x) EMFHoleParent
  synthmovedet (SAZipHole2 _ (SAMove ())) EMFHoleParent

  -- these are all a bunch of small techincal lemmas for the cases below. i
  -- don't understand why some of them can't be inlined.
  lem1 : {Γ : ·ctx} {t1 t2 : τ̇} →
           Γ ⊢ <||> <= (t1 ==> t2) →
           (t1 ==> t2) ~ (<||> ==> <||>)
  lem1 (ASubsume SEHole TCHole1) = TCArr TCHole1 TCHole1

  lem3 : ∀{ Γ e t } → Γ ⊢ (e ·: t) <= t → Γ ⊢ e <= t
  lem3 (ASubsume (SAsc x) x₁) = x

  lem4 : ∀{ Γ e eh t t2 } →
         Γ ⊢ e ∘ (eh ◆e) => t →
         Γ ⊢ e => (t2 ==> t) →
         Γ ⊢ (eh ◆e) <= t2
  lem4 (SAp (SAsc x₁) x) (SAsc x₂) = x
  lem4 {Γ = G} (SAp (SVar x₁) x) (SVar x₂)
    with ctxunicity {Γ = G}  x₁ x₂
  ... | refl = x
  lem4 (SAp (SAp d1 x₁) x) (SAp d2 x₂)
    with synthunicity d1 d2
  ... | refl = x
  lem4 (SApHole () x) (SAsc x₁)
  lem4 {Γ = G} (SApHole (SVar x₁) x) (SVar x₂)
    with ctxunicity {Γ = G} x₁ x₂
  ... | ()
  lem4 (SApHole (SAp d1 x₁) x) (SAp d2 x₂)
    with synthunicity d1 d2
  ... | ()
  lem4 (SApHole (SApHole d1 x₁) x) (SAp d2 x₂)
    with synthunicity d1 d2
  ... | ()

  lem5 : ∀ {Γ e eh} →
        Γ ⊢ e => <||> →
        Γ ⊢ e ∘ (eh ◆e) => <||> →
        Γ ⊢ eh ◆e <= <||>
  lem5 d1 (SAp d2 x) with synthunicity d1 d2
  ... | ()
  lem5 d1 (SApHole d2 x) = x

  lem6 : ∀ {Γ e1 e2} →
         Γ ⊢ e1 ·+ e2 => num →
         Γ ⊢ e1 <= num × Γ ⊢ e2 <= num
  lem6 (SPlus x x₁) = x , x₁

  lem7 : ∀{Γ e t e' t'} →
         Γ ⊢ <| e |> => <||> →
         Γ ⊢ ▹ e ◃ => t ~ move parent ~> e' => t' →
         ⊥
  lem7 (SFHole _) (SAMove ())

  lem8a : ∀ {Γ e e' t} →
        Γ ⊢ ▹ e ◃ ~ move nextSib ~> e' ⇐ t → ⊥
  lem8a (AASubsume x (SAMove ()) x₂)
  lem8a (AAMove ())

  -- expressions in focus don't move to next sib
  lem8s : ∀ {Γ e e' t t'} →
        Γ ⊢ ▹ e ◃ => t ~ move nextSib ~> e' => t' → ⊥
  lem8s (SAMove ())

    -- expressions in focus don't move to prev sib
  lem9a : ∀ {Γ e e' t} →
        Γ ⊢ ▹ e ◃ ~ move prevSib ~> e' ⇐ t → ⊥
  lem9a (AASubsume x (SAMove ()) x₂)
  lem9a (AAMove ())

  -- expressions in focus don't move to prev sib
  lem9s : ∀ {Γ e e' t t'} →
        Γ ⊢ ▹ e ◃ => t ~ move prevSib ~> e' => t' → ⊥
  lem9s (SAMove ())

  lem10 : ∀{Γ x t1 t2 e} →
          Γ ⊢ ·λ x (e ◆e) <= (t1 ==> t2) →
          (Γ ,, (x , t1)) ⊢ e ◆e <= t2
  lem10 (ASubsume () x₂)
  lem10 (ALam x₁ d1) = d1

    -- expressions in focus don't move to parent
  lem11 : ∀ {Γ e e' t} →
        Γ ⊢ ▹ e ◃ ~ move parent ~> e' ⇐ t → ⊥
  lem11 (AASubsume x (SAMove ()) x₂)
  lem11 (AAMove ())

  -- if a type isn't compatible with hole to hole, it isn't compatible with
  -- any function type at all.
  lem12 : {t : τ̇} → (t ~̸ (<||> ==> <||>)) → ((t1 t2 : τ̇) → t ~̸ (t1 ==> t2))
  lem12 {num} p t1 t2 ()
  lem12 {<||>} p t1 t2 TCHole2 = p TCHole2
  lem12 {(t ==> t')} p t1 t2 x = p (TCArr TCHole1 TCHole1)

  mutual
    -- an action on an expression in a synthetic position produces one
    -- resultant expression and type.
    actdet2 : {Γ : ·ctx} {e e' e'' : ê} {t t' t'' : τ̇} {α : action} →
              (Γ ⊢ (e ◆e) => t) →
              (Γ ⊢ e => t ~ α ~> e'  => t') →
              (Γ ⊢ e => t ~ α ~> e'' => t'') →
              (e' == e'' × t' == t'')
    actdet2 wt (SAMove x) (SAMove x₁) = movedet x x₁ , refl
      -- every other case of move in the left is an absurdity after a
      -- couple of levels
    actdet2 wt (SAMove EMAscParent1) (SAZipAsc1 (AASubsume _ (SAMove ()) _))
    actdet2 wt (SAMove EMAscParent1) (SAZipAsc1 (AAMove ()))
    actdet2 wt (SAMove EMAscNextSib) (SAZipAsc1 (AASubsume _ (SAMove ()) _))
    actdet2 wt (SAMove EMAscNextSib) (SAZipAsc1 (AAMove ()))
    actdet2 wt (SAMove EMAscParent2) (SAZipAsc2 () x₂)
    actdet2 wt (SAMove EMAscPrevSib) (SAZipAsc2 () x₂)
    actdet2 wt (SAMove EMApParent1) (SAZipAp1 x₁ (SAMove ()) x₂)
    actdet2 wt (SAMove EMApNextSib) (SAZipAp1 x₁ (SAMove ()) x₂)
    actdet2 wt (SAMove EMApParent1) (SAZipAp2 x₁ (SAMove ()) x₂)
    actdet2 wt (SAMove EMApNextSib) (SAZipAp2 x₁ (SAMove ()) x₂)
    actdet2 wt (SAMove EMApParent2) (SAZipAp3 x₁ (AASubsume x (SAMove ()) x₃))
    actdet2 wt (SAMove EMApParent2) (SAZipAp3 x₁ (AAMove ()))
    actdet2 wt (SAMove EMApPrevSib) (SAZipAp3 x₁ (AASubsume x (SAMove ()) x₃))
    actdet2 wt (SAMove EMApPrevSib) (SAZipAp3 x₁ (AAMove ()))
    actdet2 wt (SAMove EMApParent2) (SAZipAp4 x₁ (AASubsume x (SAMove ()) x₃))
    actdet2 wt (SAMove EMApParent2) (SAZipAp4 x₁ (AAMove ()))
    actdet2 wt (SAMove EMApPrevSib) (SAZipAp4 x₁ (AASubsume x (SAMove ()) x₃))
    actdet2 wt (SAMove EMApPrevSib) (SAZipAp4 x₁ (AAMove ()))
    actdet2 wt (SAMove EMPlusParent1) (SAZipPlus1 (AASubsume x (SAMove ()) x₂))
    actdet2 wt (SAMove EMPlusParent1) (SAZipPlus1 (AAMove ()))
    actdet2 wt (SAMove EMPlusNextSib) (SAZipPlus1 (AASubsume x (SAMove ()) x₂))
    actdet2 wt (SAMove EMPlusNextSib) (SAZipPlus1 (AAMove ()))
    actdet2 wt (SAMove EMPlusParent2) (SAZipPlus2 (AASubsume x (SAMove ()) x₂))
    actdet2 wt (SAMove EMPlusParent2) (SAZipPlus2 (AAMove ()))
    actdet2 wt (SAMove EMPlusPrevSib) (SAZipPlus2 (AASubsume x (SAMove ()) x₂))
    actdet2 wt (SAMove EMPlusPrevSib) (SAZipPlus2 (AAMove ()))
    actdet2 wt (SAMove EMFHoleParent) (SAZipHole1 x₁ (SAMove ()) x₂)
    actdet2 wt (SAMove EMFHoleParent) (SAZipHole2 x₁ (SAMove ()))

    actdet2 wt SADel SADel = refl , refl

    actdet2 wt SAConAsc SAConAsc = refl , refl

    actdet2 {Γ = G} wt (SAConVar p) (SAConVar p₁)
      with ctxunicity {Γ = G} p p₁
    ... | refl = refl , refl

    actdet2 wt (SAConLam x₁) (SAConLam x₂) = refl , refl

    actdet2 wt SAConAp1 SAConAp1 = refl , refl
    actdet2 wt SAConAp1 (SAConAp3 x) = abort (lem12 x _ _ TCRefl)

    actdet2 wt SAConAp2 SAConAp2 = refl , refl
    actdet2 wt SAConAp2 (SAConAp3 x) = abort (x TCHole2)

    actdet2 wt (SAConAp3 x) SAConAp1 = abort (lem12 x _ _ TCRefl)
    actdet2 wt (SAConAp3 x) SAConAp2 = abort (x TCHole2)
    actdet2 wt (SAConAp3 x) (SAConAp3 x₁) = refl , refl

    actdet2 wt SAConArg SAConArg = refl , refl

    actdet2 wt SAConNumlit SAConNumlit = refl , refl

    actdet2 wt (SAConPlus1 x) (SAConPlus1 x₁) = refl , refl
    actdet2 wt (SAConPlus1 x) (SAConPlus2 x₁) = abort (x₁ x)

    actdet2 wt (SAConPlus2 x) (SAConPlus1 x₁) = abort (x x₁)
    actdet2 wt (SAConPlus2 x) (SAConPlus2 x₁) = refl , refl

    actdet2 wt (SAFinish x) (SAFinish x₁)
      with synthunicity x x₁
    ... | refl = refl , refl

    actdet2 wt (SAZipAsc1 (AASubsume _ (SAMove ()) _)) (SAMove EMAscParent1)
    actdet2 wt (SAZipAsc1 (AAMove ())) (SAMove EMAscParent1)
    actdet2 wt (SAZipAsc1 x) (SAMove EMAscNextSib) = abort (lem8a x)
    actdet2 {t = t} wt (SAZipAsc1 x) (SAZipAsc1 x₁) =
         ap1 (λ q → q ·:₁ t) (actdet3 (lem3 (ASubsume wt TCRefl)) x x₁) , refl

    actdet2 wt (SAZipAsc2 () x₁) (SAMove EMAscParent2)
    actdet2 wt (SAZipAsc2 () x₁) (SAMove EMAscPrevSib)
    actdet2 wt (SAZipAsc2 x x₁) (SAZipAsc2 x₂ x₃) with actdet1 x x₂
    ... | refl = refl , refl

    actdet2 wt (SAZipAp1 x (SAMove ()) x₁) (SAMove EMApParent1)
    actdet2 wt (SAZipAp1 x (SAMove ()) x₁) (SAMove EMApNextSib)
    actdet2 wt (SAZipAp1 x d1 x₁) (SAZipAp1 x₂ d2 x₃)
      with synthunicity x₂ x
    ... | refl with actdet2 x d1 d2 -- todo: double-barrelded with here ..
    ... | p1 , refl = (ap1 (λ q → q ∘₁ _) p1) , refl
    actdet2 wt (SAZipAp1 x d1 x₁) (SAZipAp2 x₂ d2 x₃)
      with synthunicity x x₂
    ... | refl with actdet2 x d1 d2 -- todo: .. and here
    actdet2 wt (SAZipAp1 _ _ _ ) (SAZipAp2 _ _ _) | refl | _ , ()

    actdet2 wt (SAZipAp2 x (SAMove ()) x₁) (SAMove EMApParent1)
    actdet2 wt (SAZipAp2 x (SAMove ()) x₁) (SAMove EMApNextSib)
    actdet2 wt (SAZipAp2 x d1 x₁) (SAZipAp1 x₂ d2 x₃)
      with synthunicity x x₂
    ... | refl with actdet2 x d1 d2
    actdet2 wt (SAZipAp2 x d1 x₁) (SAZipAp1 x₂ d2 x₃) | refl | p1 , ()
    actdet2 wt (SAZipAp2 x d1 _) (SAZipAp2 x₂ d2 _)
      with synthunicity x x₂
    ... | refl = (ap1 (λ q → q ∘₁ _) (π1 (actdet2 x₂ d1 d2))) , refl

    actdet2 wt (SAZipAp3 x (AASubsume x₁ (SAMove ()) x₃)) (SAMove EMApParent2)
    actdet2 wt (SAZipAp3 x (AAMove ())) (SAMove EMApParent2)
    actdet2 wt (SAZipAp3 x x₁) (SAMove EMApPrevSib) = abort (lem9a x₁)
    actdet2 wt (SAZipAp3 {eh = eh} x x₁) (SAZipAp3 x₂ x₃)
      with synthunicity x x₂
    ... | refl = ap1 (_∘₂_ _) (actdet3 (lem4 {eh = eh} wt x) x₁ x₃) , refl
    actdet2 wt (SAZipAp3 x x₁) (SAZipAp4 x₂ x₃)
      with synthunicity x x₂
    ... | ()

    actdet2 wt (SAZipAp4 x (AASubsume x₁ (SAMove ()) x₃)) (SAMove EMApParent2)
    actdet2 wt (SAZipAp4 x (AAMove ())) (SAMove EMApParent2)
    actdet2 wt (SAZipAp4 x (AASubsume x₁ x₂ x₃)) (SAMove EMApPrevSib) = abort (lem9s x₂)
    actdet2 wt (SAZipAp4 x (AAMove ())) (SAMove EMApPrevSib)
    actdet2 wt (SAZipAp4 x x₁) (SAZipAp3 x₂ x₃)
      with synthunicity x x₂
    ... | ()
    actdet2 wt (SAZipAp4 {eh = eh} x x₁ ) (SAZipAp4 x₂ x₃)
      with actdet3 (lem5 {eh = eh} x₂ wt) x₁ x₃
    ... | refl = refl , refl

    actdet2 wt (SAZipPlus1 (AASubsume x (SAMove ()) x₂)) (SAMove EMPlusParent1)
    actdet2 wt (SAZipPlus1 (AAMove ())) (SAMove EMPlusParent1)
    actdet2 wt (SAZipPlus1 (AASubsume x x₁ x₂)) (SAMove EMPlusNextSib) = abort (lem8s x₁)
    actdet2 wt (SAZipPlus1 (AAMove ())) (SAMove EMPlusNextSib)
    actdet2 wt (SAZipPlus1 x) (SAZipPlus1 x₁)
      with actdet3 (π1 (lem6 wt)) x x₁ -- todo: not sure why this needs to be a lemma
    ... | refl = refl , refl

    actdet2 wt (SAZipPlus2 (AASubsume x (SAMove ()) x₂)) (SAMove EMPlusParent2)
    actdet2 wt (SAZipPlus2 (AASubsume x x₁ x₂)) (SAMove EMPlusPrevSib) = abort (lem9s x₁)
    actdet2 wt (SAZipPlus2 (AAMove ())) (SAMove EMPlusParent2)
    actdet2 wt (SAZipPlus2 (AAMove ())) (SAMove EMPlusPrevSib)
    actdet2 wt (SAZipPlus2 x) (SAZipPlus2 x₁)
      with actdet3 (π2 (lem6 wt)) x x₁ -- .. or this one
    ... | refl = refl , refl

    actdet2 wt (SAZipHole1 x d1 x₁) (SAMove EMFHoleParent) = abort (lem7 wt d1)
    actdet2 wt (SAZipHole1 x d1 x₁) (SAZipHole1 x₂ d2 x₃)
      with synthunicity x x₂
    ... | refl with actdet2 x d1 d2
    ... | refl , refl = refl , refl
    actdet2 wt (SAZipHole1 x d1 x₁) (SAZipHole2 x₂ d2)
      with synthunicity x x₂
    ... | refl with actdet2 x d1 d2
    ... | p , _ = abort (x₁ p)

    actdet2 wt (SAZipHole2 x d1) (SAMove EMFHoleParent) = abort (lem7 wt d1)
    actdet2 wt (SAZipHole2 x d1) (SAZipHole1 x₁ d2 x₂)
      with synthunicity x x₁
    ... | refl with actdet2 x d1 d2
    ... | p , q  = abort (x₂ (! p))
    actdet2 wt (SAZipHole2 x d1) (SAZipHole2 x₁ d2)
      with synthunicity x x₁
    ... | refl with actdet2 x d1 d2
    ... | refl , refl = refl , refl

    -- an action on an expression in an analytic position produces one
    -- resultant expression and type.
    actdet3 : {Γ : ·ctx} {e e' e'' : ê} {t : τ̇} {α : action} →
              (Γ ⊢ (e ◆e) <= t) →
              (Γ ⊢ e ~ α ~> e' ⇐ t) →
              (Γ ⊢ e ~ α ~> e'' ⇐ t) →
              (e' == e'')
    actdet3 D1 (AASubsume x x₁ x₂) (AASubsume x₃ x₄ x₅)
     with synthunicity x x₃
    ... | refl = π1 (actdet2 x x₁ x₄)

    actdet3 D1 (AASubsume _ y _) (AAMove w) = synthmovedet y w
    actdet3 D1 (AASubsume _ SADel _) AADel = refl
    actdet3 D1 (AASubsume {p = p} x SAConAsc x₂) AAConAsc = abort (π1 p refl)
    actdet3 {Γ = G} (ASubsume x x₁) (AASubsume x₂ (SAConVar p) x₄) (AAConVar x₅ p₁)
     with ctxunicity {Γ = G} p p₁
    ... | refl = abort (x₅ x₄)
    actdet3 D1 (AASubsume {p = p} x₁ (SAConLam x₂) x₃) (AAConLam1 x₄) = abort (π2 p _ refl)
    actdet3 D1 (AASubsume x₁ (SAConLam x₃) x₂) (AAConLam2 x₄ x₅) = abort (x₅ x₂)
    actdet3 D1 (AASubsume x SAConNumlit x₂) (AAConNumlit x₃) = abort (x₃ x₂)
    actdet3 D1 (AASubsume x (SAFinish x₁) x₂) (AAFinish x₃) = refl
    actdet3 D1 (AASubsume x₁ (SAMove EMLamParent) x₂) (AAZipLam x₄ (AASubsume x₃ (SAMove ()) x₆))
    actdet3 D1 (AASubsume x₁ (SAMove EMLamParent) x₂) (AAZipLam x₄ (AAMove ()))

    actdet3 D1 (AAMove x) (AASubsume x₁ x₂ x₃) =  ! (synthmovedet x₂ x)
    actdet3 D1 (AAMove x) (AAMove x₁) = movedet x x₁
    actdet3 D1 (AAMove EMLamParent) (AAZipLam x₃ (AASubsume x₁ (SAMove ()) x₄))
    actdet3 D1 (AAMove EMLamParent) (AAZipLam x₃ (AAMove ()))

    actdet3 D1 AADel (AASubsume _ SADel _) = refl
    actdet3 D1 AADel AADel = refl

    actdet3 D1 AAConAsc (AASubsume {p = p} x SAConAsc x₂) = abort (π1 p refl)
    actdet3 D1 AAConAsc AAConAsc = refl

    actdet3 {Γ = G} D1 (AAConVar x₁ p) (AASubsume x₂ (SAConVar p₁) x₄)
     with ctxunicity {Γ = G} p p₁
    ... | refl = abort (x₁ x₄)
    actdet3 D1 (AAConVar x₁ p) (AAConVar x₂ p₁) = refl

    actdet3 D1 (AAConLam1 x₃) (AASubsume {p = p} SEHole (SAConLam x₅) x₆) = abort (π2 p _ refl)
    actdet3 D1 (AAConLam1 x₁) (AAConLam1 x₂) = refl
    actdet3 D1 (AAConLam1 x₃) (AAConLam2 x₄ x₅) = abort (x₅ (lem1 D1))

    actdet3 D1 (AAConLam2 x₁ x₂) (AASubsume x₃ (SAConLam x₄) x₅) = abort (x₂ x₅)
    actdet3 D1 (AAConLam2 x₁ x₂) (AAConLam1 x₃) = abort (x₂ (lem1 D1))
    actdet3 D1 (AAConLam2 x₁ x₂) (AAConLam2 x₃ x₄) = refl

    actdet3 D1 (AAConNumlit x) (AASubsume x₁ SAConNumlit x₃) = abort (x x₃)
    actdet3 D1 (AAConNumlit x) (AAConNumlit x₁) = refl

    actdet3 D1 (AAFinish x) (AASubsume x₁ (SAFinish x₂) x₃) = refl
    actdet3 D1 (AAFinish x) (AAFinish x₁) = refl

    actdet3 D1 (AAZipLam x₃ D2) (AASubsume x₁ (SAMove EMLamParent) x₄) = abort (lem11 D2)
    actdet3 D1 (AAZipLam x₃ (AASubsume x₁ (SAMove ()) x₄)) (AAMove EMLamParent)
    actdet3 D1 (AAZipLam x₃ (AAMove ())) (AAMove EMLamParent)
    actdet3 D1 (AAZipLam {e = e} x₃ D2) (AAZipLam x₁ D3)
      with actdet3 (lem10 {e = e} D1) D2 D3
    ... | refl = refl


{-# OPTIONS --universe-polymorphism #-}
module Categories.Grothendieck where

open import Relation.Binary using (Rel)
open import Data.Product using (Σ; _,_; proj₁; proj₂; _×_)

open import Categories.Support.Experimental
open import Categories.Support.PropositionalEquality
open import Categories.Support.IProduct
import Categories.Category as CCat
open CCat hiding (module Heterogeneous)
open import Categories.Functor using (Functor; module Functor; ≡⇒≣)
open import Categories.Agda
open import Categories.Categories
open import Categories.Congruence

-- TODO: don't use sigmas
-- Break into modules Strict and Weak using Sets and Setoids?
Elements : ∀ {o ℓ e o′} {C : Category o ℓ e} → Functor C (Sets o′) → Category _ _ _
Elements {o′ = o′} {C = C} F = record
  { Obj = Obj′
  ; _⇒_ = Hom′
  ; _≡_ = _≡′_
  ; _∘_ = _∘′_
  ; id = id , identity
  ; assoc = assoc
  ; identityˡ = identityˡ
  ; identityʳ = identityʳ
  ; equiv = record
    { refl = refl
    ; sym = sym
    ; trans = trans
    }
  ; ∘-resp-≡ = ∘-resp-≡
  }
  where
  open Category C
  open Equiv
  open Functor F

  Obj′ = Σ Obj F₀

  Hom′ : Rel Obj′ _
  Hom′ (c₁ , x₁) (c₂ , x₂) = Σ′ (c₁ ⇒ c₂) (λ f → F₁ f x₁ ≣ x₂)

  _≡′_ : ∀ {X Y} → Rel (Hom′ X Y) _
  (f , pf₁) ≡′ (g , pf₂) = f ≡ g

  _∘′_ : ∀ {X Y Z} → Hom′ Y Z → Hom′ X Y → Hom′ X Z
  _∘′_ {X} {Y} {Z} (f , pf₁) (g , pf₂) = (f ∘ g) , pf
    where
    -- This could be a lot prettier...
    .pf : F₁ (f ∘ g) (proj₂ X) ≣ proj₂ Z
    pf = ≣-trans homomorphism (≣-sym (≣-trans (≣-sym pf₁) (≣-cong (F₁ f) (≣-sym pf₂))))

Dom : ∀ {o ℓ e o′} {C : Category o ℓ e} → (F : Functor C (Sets o′)) -> Functor (Elements F) C
Dom {C = C} F = record {
                  F₀ = proj₁;
                  F₁ = proj₁′;
                  identity = Equiv.refl;
                  homomorphism = Equiv.refl;
                  F-resp-≡ = λ x → x }
  where
   open Category C

-- because we want the following function to reduce all the time, define it globally
private
  module _ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} (F : Functor C (Categories o′ ℓ′ e′)) where
    private
      module C = Category C
      module F = Functor F
      module Cat = Category (Categories o′ ℓ′ e′)

    ∘-eq : ∀ {cx xx cy cz} -> (f : cy C.⇒ cz) (g : cx C.⇒ cy) -> Functor.F₀ (F.F₁ f Cat.∘ F.F₁ g) xx ≣ Functor.F₀ (F.F₁ (f C.∘ g)) xx
    ∘-eq {cx} {xx} {cy} {cz} f g = ≣-relevant (≣-sym (≡⇒≣ (F.F₁ (f C.∘ g)) (F.F₁ f Cat.∘ F.F₁ g) (F.homomorphism {f = g} {g = f}) xx))

Grothendieck : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} → Functor C (Categories o′ ℓ′ e′) → Category _ _ _
Grothendieck {o′ = o′} {ℓ′} {e′} {C = C} F = record
  { Obj = Obj′
  ; _⇒_ = Hom′
  ; _≡_ = _≡′_
  ; _∘_ = _∘′_
  ; id = id′
  ; assoc = assoc′
  ; identityˡ = identityˡ′
  ; identityʳ = identityʳ′
  ; equiv = record {
     refl = refl , Het.refl;
     sym  = λ { (eq₁ , eq₂) → sym eq₁ , Het.sym eq₂};
     trans = λ { (xeq₁ , xeq₂) (yeq₁ , yeq₂) → trans xeq₁ yeq₁ , Het.trans xeq₂ yeq₂} }
  ; ∘-resp-≡ = ∘-resp-≡′
  }
  module Groth where
  open Functor F
  module Fc {c} where
    open Category (F₀ c) public
    open Equiv public
  open Category C
  open Equiv
  module Cat = Category (Categories o′ ℓ′ e′)
  module Cong {c} where
   open Congruence (TrivialCongruence (F₀ c)) public
  open Cong public using () renaming (coerce to coe)
  module Het {c} = Heterogeneous (TrivialCongruence (F₀ c))
  open Het using (▹_)
  module OHet {c} where
   open CCat.Heterogeneous (F₀ c) public
   ohet⇒het : ∀ {A B} {f : A Fc.⇒ B} -> ∀ {X Y} → {g : X Fc.⇒ Y} → f ∼ g -> f Het.∼ g
   ohet⇒het (≡⇒∼ x) = Het.≡⇒∼ ≣-refl ≣-refl x

  Obj′ = Σ Obj (\ c -> Category.Obj (F₀ c))

  Hom′ : Rel Obj′ _
  Hom′ (c₁ , x₁) (c₂ , x₂) = Σ (c₁ ⇒ c₂) (λ f → Functor.F₀ (F₁ f) x₁ Fc.⇒ x₂)

  _≡′_ : ∀ {X Y} → Rel (Hom′ X Y) _
  _≡′_ {c₁ , x₁} {c₂ , x₂} (f , α) (g , β) = f ≡ g × α Het.∼ β

  _∘′_ : ∀ {X Y Z} → Hom′ Y Z → Hom′ X Y → Hom′ X Z
  _∘′_ {cx , xx} {Y} {cz , xz} (f , α) (g , β) = (f ∘ g) , α Fc.∘ Cong.coerce (∘-eq F f g) ≣-refl (Functor.F₁ (F₁ f) β)

  id-eq : ∀ {c x} -> Functor.F₀ (Cat.id {F₀ c}) x ≣ Functor.F₀ (F₁ id) x
  id-eq {c} {x} = ≣-relevant (≣-sym (≡⇒≣ (F₁ id) Cat.id (identity {c}) x))

  id′ : {A : Obj′} → Hom′ A A
  id′ {c , x} = id , Cong.coerce id-eq ≣-refl Fc.id

  F-resp-∼ : ∀ {b c} -> (H : Functor (F₀ b) (F₀ c)) -> {A B A' B' : Category.Obj (F₀ b)} {α : A Fc.⇒ B }{β : A' Fc.⇒ B'} →
             (α Het.∼ β) → (Functor.F₁ H α Het.∼ Functor.F₁ H β)
  F-resp-∼ H (Heterogeneous.≡⇒∼ ≣-refl ≣-refl x) = Heterogeneous.≡⇒∼ ≣-refl ≣-refl (Functor.F-resp-≡ H x)

  .identityˡ′ : {A B : Obj′} {f : Hom′ A B} → (id′ ∘′ f) ≡′ f
  identityˡ′ {ca , xa} {cb , xb} {f , α} = identityˡ , (begin
    ▹ coe id-eq ≣-refl Fc.id Fc.∘ coe (∘-eq F id f) ≣-refl (Functor.F₁ (F₁ id) α)
      ↓⟨ Het.∘-resp-∼ (Het.sym (Het.coerce-resp-∼ id-eq ≣-refl)) F₁id[α]~α ⟩
    ▹ Fc.id Fc.∘ α
      ↓⟨ Het.≡⇒∼ ≣-refl ≣-refl Fc.identityˡ ⟩
    ▹ α
      ∎)
   where
    open Het.HetReasoning
    F₁id[α]~α : coe (∘-eq F id f) ≣-refl (Functor.F₁ (F₁ id) α) Het.∼ α
    F₁id[α]~α = begin
      ▹ coe (∘-eq F id f) ≣-refl (Functor.F₁ (F₁ id) α)
        ↑⟨ Het.coerce-resp-∼ (∘-eq F id f) ≣-refl ⟩
      ▹ Functor.F₁ (F₁ id) α
        ↓⟨ OHet.ohet⇒het (identity α) ⟩
      ▹ α
        ∎

  .identityʳ′ : {A B : Obj′} {f : Hom′ A B} → (f ∘′ id′) ≡′ f
  identityʳ′ {ca , xa} {cb , xb} {f , α} = identityʳ , (begin
    ▹ α Fc.∘ coe (∘-eq F f id) ≣-refl (Functor.F₁ (F₁ f) (coe id-eq ≣-refl Fc.id))
       ↓⟨ Het.∘-resp-∼ʳ F₁f[id]~id ⟩
    ▹ α Fc.∘ Fc.id
       ↓⟨ Het.≡⇒∼ ≣-refl ≣-refl Fc.identityʳ ⟩
    ▹ α
       ∎)
   where
    open Het.HetReasoning
    F₁f[id]~id : coe (∘-eq F f id) ≣-refl (Functor.F₁ (F₁ f) (coe id-eq ≣-refl Fc.id)) Het.∼ Fc.id
    F₁f[id]~id = begin
      ▹ coe (∘-eq F f id) ≣-refl (Functor.F₁ (F₁ f) (coe id-eq ≣-refl Fc.id))
        ↑⟨ Het.coerce-resp-∼ (∘-eq F f id) ≣-refl ⟩
      ▹ Functor.F₁ (F₁ f) (coe id-eq ≣-refl Fc.id)
        ↓⟨ F-resp-∼ (F₁ f) (Het.sym (Het.coerce-resp-∼ id-eq ≣-refl)) ⟩
      ▹ Functor.F₁ (F₁ f) (Category.id (F₀ ca))
        ↓⟨ Het.≡⇒∼ ≣-refl ≣-refl (Functor.identity (F₁ f)) ⟩
      ▹ Fc.id
        ∎

  .assoc′ : {A B C₁ D : Obj′} {f : Hom′ A B} {g : Hom′ B C₁} {h : Hom′ C₁ D} →
                 ((h ∘′ g) ∘′ f) ≡′ (h ∘′ (g ∘′ f))
  assoc′ {ca , xa} {cb , xb} {cc , xc} {cd , xd} {f , α} {g , β} {h , γ}
    = assoc , Het.trans (Het.≡⇒∼ ≣-refl ≣-refl Fc.assoc) (Het.∘-resp-∼ʳ F₁h[β]∘F₁h∘g[α]~F₁h[β∘F₁g[α]])
   where
    open Het.HetReasoning
    eq : Functor.F₀ (F₁ ((h ∘ g) ∘ f)) xa ≣ Functor.F₀ (F₁ (h ∘ g ∘ f)) xa
    eq = ≡⇒≣ (F₁ ((h ∘ g) ∘ f)) (F₁ (h ∘ g ∘ f)) (F-resp-≡ (assoc {f = f})) xa

    F₁h[β]∘F₁h∘g[α]~F₁h[β∘F₁g[α]] : (coe (∘-eq F h g) ≣-refl (Functor.F₁ (F₁ h) β) Fc.∘ coe (∘-eq F (h ∘ g) f) ≣-refl (Functor.F₁ (F₁ (h ∘ g)) α))
                                     Het.∼ (coe (∘-eq F h (g ∘ f)) ≣-refl (Functor.F₁ (F₁ h) (proj₂ ((g , β) ∘′ (f , α)))))
    F₁h[β]∘F₁h∘g[α]~F₁h[β∘F₁g[α]] = Het.sym (begin
      ▹ coe (∘-eq F h (g ∘ f)) ≣-refl (Functor.F₁ (F₁ h) (β Fc.∘ coe(∘-eq F g f) ≣-refl (Functor.F₁ (F₁ g) α)))
        ↑⟨ Het.coerce-resp-∼ (∘-eq F h (g ∘ f)) ≣-refl ⟩
      ▹ Functor.F₁ (F₁ h) (β Fc.∘ coe (∘-eq F g f) ≣-refl (Functor.F₁ (F₁ g) α))
        ↓⟨ Het.≡⇒∼ ≣-refl ≣-refl (Functor.homomorphism (F₁ h)) ⟩
      ▹ Functor.F₁ (F₁ h) β Fc.∘ (Functor.F₁ (F₁ h) (coe (∘-eq F g f) ≣-refl (Functor.F₁ (F₁ g) α)))
        ↓⟨ Het.∘-resp-∼ (Het.coerce-resp-∼ (∘-eq F h g) ≣-refl) F₁h[β]~F₁h∘g[α] ⟩
      ▹ coe (∘-eq F h g) ≣-refl (Functor.F₁ (F₁ h) β) Fc.∘ coe (∘-eq F (h ∘ g) f) ≣-refl (Functor.F₁ (F₁ (h ∘ g)) α)
        ∎)
     where
      F₁h[β]~F₁h∘g[α] : (Functor.F₁ (F₁ h) (coe (∘-eq F g f) ≣-refl (Functor.F₁ (F₁ g) α))) Het.∼ coe (∘-eq F (h ∘ g) f) ≣-refl (Functor.F₁ (F₁ (h ∘ g)) α)
      F₁h[β]~F₁h∘g[α] = begin
        ▹ Functor.F₁ (F₁ h) (coe (∘-eq F g f) ≣-refl (Functor.F₁ (F₁ g) α))
          ↓⟨ F-resp-∼ (F₁ h) (Het.sym (Het.coerce-resp-∼ (∘-eq F g f) ≣-refl)) ⟩
        ▹ Functor.F₁ (F₁ h) (Functor.F₁ (F₁ g) α)
          ↑⟨ OHet.ohet⇒het (homomorphism α) ⟩
        ▹ Functor.F₁ (F₁ (h ∘ g)) α
          ↓⟨ Het.coerce-resp-∼ (∘-eq F (h ∘ g) f) ≣-refl ⟩
        ▹ coe (∘-eq F (h ∘ g) f) ≣-refl (Functor.F₁ (F₁ (h ∘ g)) α)
          ∎

  .∘-resp-≡′ : {A B C₁ : Obj′} {f h : Hom′ B C₁} {g i : Hom′ A B} →
                     f ≡′ h → g ≡′ i → (f ∘′ g) ≡′ (h ∘′ i)
  ∘-resp-≡′ {a , ax} {b , bx} {c , cx} {f = f , α} {h , η} {g , γ} {i , ι} (f≡h , α~η) (g≡i , γ~ι) = ∘-resp-≡ f≡h g≡i , Het.∘-resp-∼ α~η
    (begin
     ▹ coe (∘-eq F f g) ≣-refl (Functor.F₁ (F₁ f) γ) ↑⟨ Het.coerce-resp-∼ (∘-eq F f g) ≣-refl ⟩
     ▹ Functor.F₁ (F₁ f) γ                           ↓⟨ OHet.ohet⇒het (F-resp-≡ f≡h γ) ⟩
     ▹ Functor.F₁ (F₁ h) γ                           ↓⟨ F-resp-∼ (F₁ h) γ~ι ⟩
     ▹ Functor.F₁ (F₁ h) ι                           ↓⟨ Het.coerce-resp-∼ (∘-eq F h i) ≣-refl ⟩
     ▹ coe (∘-eq F h i) ≣-refl (Functor.F₁ (F₁ h) ι) ∎)
   where
    open Het.HetReasoning

Gr = Grothendieck

DomGr : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} → (F : Functor C (Categories o′ ℓ′ e′)) → Functor (Grothendieck F) C
DomGr {C = C} F = record {
                    F₀ = proj₁;
                    F₁ = proj₁;
                    identity = C.Equiv.refl;
                    homomorphism = C.Equiv.refl;
                    F-resp-≡ = proj₁ }
  where
    module C = Category C

inGr : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} (F : Functor C (Categories o′ ℓ′ e′)) → ∀ c -> Functor (Functor.F₀ F c) (Gr F)
inGr {C = C} F c = record {
                     F₀ = _,_ c;
                     F₁ = λ f → C.id , GrF.coe GrF.id-eq ≣-refl f;
                     identity = Category.Equiv.refl (Grothendieck F);
                     homomorphism = C.Equiv.sym C.identityʳ , Het.trans (Het.sym (Het.coerce-resp-∼ GrF.id-eq ≣-refl))
                                                                (Het.∘-resp-∼ (Het.coerce-resp-∼ GrF.id-eq ≣-refl)
                                                                 (Het.trans
                                                                  (Het.trans (Het.coerce-resp-∼ GrF.id-eq ≣-refl)
                                                                   (Het.sym (GrF.OHet.ohet⇒het (F.identity _))))
                                                                  (Het.coerce-resp-∼ (∘-eq F C.id C.id) ≣-refl)));
                     F-resp-≡ = λ x → C.Equiv.refl , (Het.trans (Het.trans (Het.sym (Het.coerce-resp-∼ GrF.id-eq ≣-refl))
                              (Heterogeneous.≡⇒∼ ≣-refl ≣-refl x)) (Het.coerce-resp-∼ GrF.id-eq ≣-refl)) }
  where
    module C = Category C
    module F = Functor F
    module GrF = Groth F
    open GrF using (module Het; module Cong)


module Issue1148 where

foo : Set → Set
foo = {!!}


module UnknownNameInFixityDecl where

infix 40 _+_
infixr 60 _*_