open import Function                              using (_∘_)
open import Category.Monad                        using (module RawMonad)
open import Data.Fin                              using (Fin; suc; zero)
open import Data.Fin.Properties                   renaming (_≟_ to _≟-Fin_)
open import Data.List    as List                  using (List; _∷_; [])
open import Data.List.Properties                  renaming (∷-injective to ∷-inj)
open import Data.Maybe   as Maybe                 using (Maybe; just; nothing)
open import Data.Nat                              using (ℕ; suc; zero)
open import Data.Product as Prod                  using (∃; _×_; _,_; proj₁; proj₂)
open import Relation.Nullary                      using (Dec; yes; no)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong; cong₂)

module Unification
  (Name    : Set) (_≟-Name_    : (x y : Name)    → Dec (x ≡ y))
  (Literal : Set) (_≟-Literal_ : (x y : Literal) → Dec (x ≡ y))
  where

  open RawMonad {{...}} using (_<$>_; _>>=_; return)

  private
    instance
      MaybeMonad = Maybe.monad

  data Term (n : ℕ) : Set where
    var : (x : Fin n) → Term n
    con : (s : Name) (ts : List (Term n)) → Term n
    lit : (l : Literal) → Term n
--  ext : (x : Fin (suc n)) (t : Term (suc n)) → Term n

  var-inj : ∀ {n x₁ x₂} → var {n} x₁ ≡ var {n} x₂ → x₁ ≡ x₂
  var-inj refl = refl

  con-inj : ∀ {n s₁ s₂ ts₁ ts₂} → con {n} s₁ ts₁ ≡ con {n} s₂ ts₂ → s₁ ≡ s₂ × ts₁ ≡ ts₂
  con-inj refl = (refl , refl)

  lit-inj : ∀ {n x₁ x₂} → lit {n} x₁ ≡ lit {n} x₂ → x₁ ≡ x₂
  lit-inj refl = refl

  mutual
    _≟-Term_ : ∀ {n} → (t₁ t₂ : Term n) → Dec (t₁ ≡ t₂)
    _≟-Term_ (var _)  (lit _)   = no (λ ())
    _≟-Term_ (var _)  (con _ _) = no (λ ())
    _≟-Term_ (var x₁) (var x₂) with x₁ ≟-Fin x₂
    ... | yes x₁=x₂ = yes (cong var x₁=x₂)
    ... | no  x₁≠x₂ = no (x₁≠x₂ ∘ var-inj)
    _≟-Term_ (con _ _)    (var _)   = no (λ ())
    _≟-Term_ (con _ _)    (lit _)   = no (λ ())
    _≟-Term_ (con s₁ ts₁) (con s₂ ts₂) with s₁ ≟-Name s₂
    ... | no  s₁≠s₂ = no (s₁≠s₂ ∘ proj₁ ∘ con-inj)
    ... | yes s₁=s₂ rewrite s₁=s₂ with ts₁ ≟-Terms ts₂
    ... | no  ts₁≠ts₂ = no (ts₁≠ts₂ ∘ proj₂ ∘ con-inj)
    ... | yes ts₁=ts₂ = yes (cong (con s₂) ts₁=ts₂)
    _≟-Term_ (lit _)  (var _)   = no (λ ())
    _≟-Term_ (lit _)  (con _ _) = no (λ ())
    _≟-Term_ (lit x₁) (lit x₂) with x₁ ≟-Literal x₂
    ... | yes x₁=x₂ = yes (cong lit x₁=x₂)
    ... | no  x₁≠x₂ = no (x₁≠x₂ ∘ lit-inj)

    _≟-Terms_ : ∀ {n} (xs ys : List (Term n)) → Dec (xs ≡ ys)
    _≟-Terms_ [] [] = yes refl
    _≟-Terms_ [] (_  ∷ _) = no (λ ())
    _≟-Terms_ (_ ∷ _) [] = no (λ ())
    _≟-Terms_ (x ∷ xs) (y ∷ ys) with x ≟-Term y
    ... | no  x≠y = no (x≠y ∘ proj₁ ∘ ∷-inj)
    ... | yes x=y with xs ≟-Terms ys
    ... | no  xs≠ys = no (xs≠ys ∘ proj₂ ∘ ∷-inj)
    ... | yes xs=ys = yes (cong₂ _∷_ x=y xs=ys)

  -- defining thick and thin
  thin : {n : ℕ} → Fin (suc n) → Fin n → Fin (suc n)
  thin  zero    y      = suc y
  thin (suc x)  zero   = zero
  thin (suc x) (suc y) = suc (thin x y)

  thick : {n : ℕ} → (x y : Fin (suc n)) → Maybe (Fin n)
  thick          zero    zero   = nothing
  thick          zero   (suc y) = just y
  thick {zero}  (suc ()) _
  thick {suc n} (suc x)  zero   = just zero
  thick {suc n} (suc x) (suc y) = suc <$> thick x y

  -- defining replacement function (written _◂ in McBride, 2003)
  replace : ∀ {n m} → (Fin n → Term m) → Term n → Term m
  replace _ (lit l) = lit l
  replace f (var i) = f i
  replace f (con s ts) = con s (replaceChildren f ts)
    where
      replaceChildren : ∀ {n m} → (Fin n → Term m) → (List (Term n) → List (Term m))
      replaceChildren f []       = []
      replaceChildren f (x ∷ xs) = replace f x ∷ (replaceChildren f xs)

  -- defining replacement composition
  _◇_ : ∀ {m n l} (f : Fin m → Term n) (g : Fin l → Term m) → Fin l → Term n
  _◇_ f g = replace f ∘ g

  -- defining an occurs check (**check** in McBride, 2003)
  check : ∀ {n} (x : Fin (suc n)) (t : Term (suc n)) → Maybe (Term n)
  check _  (lit l)    = just (lit l)
  check x₁ (var x₂)   = var <$> thick x₁ x₂
  check x₁ (con s ts) = con s <$> checkChildren x₁ ts
    where
      checkChildren : ∀ {n} (x : Fin (suc n)) (ts : List (Term (suc n))) → Maybe (List (Term n))
      checkChildren x₁ [] = just []
      checkChildren x₁ (t ∷ ts) = check x₁ t >>= λ t' →
        checkChildren x₁ ts >>= λ ts' → return (t' ∷ ts')

  -- datatype for substitutions (AList in McBride, 2003)
  data Subst : ℕ → ℕ → Set where
    nil  : ∀ {n}   → Subst n n
    snoc : ∀ {m n} → (s : Subst m n) → (t : Term m) → (x : Fin (suc m)) → Subst (suc m) n

  -- substitutes t for x (**for** in McBride, 2003)
  _for_ : ∀ {n} (t : Term n) (x : Fin (suc n)) → Fin (suc n) → Term n
  _for_ t x y with thick x y
  _for_ t x y | just y' = var y'
  _for_ t x y | nothing = t

  -- substitution application (**sub** in McBride, 2003)
  sub : ∀ {m n} → Subst m n → Fin m → Term n
  sub nil = var
  sub (snoc s t x) = (sub s) ◇ (t for x)

  -- composes two substitutions
  _++_ : ∀ {l m n} → Subst m n → Subst l m → Subst l n
  s₁ ++ nil = s₁
  s₁ ++ (snoc s₂ t x) = snoc (s₁ ++ s₂) t x

  flexRigid : ∀ {n} → Fin n → Term n → Maybe (∃ (Subst n))
  flexRigid {zero} () t
  flexRigid {suc n} x t with check x t
  flexRigid {suc n} x t | nothing = nothing
  flexRigid {suc n} x t | just t' = just (n , snoc nil t' x)

  flexFlex : ∀ {n} → (x y : Fin n) → ∃ (Subst n)
  flexFlex {zero} () j
  flexFlex {suc n} x y with thick x y
  flexFlex {suc n} x y | nothing = (suc n , nil)
  flexFlex {suc n} x y | just  z = (n , snoc nil (var z) x)

  mutual
    unifyAcc : ∀ {m} → (t₁ t₂ : Term m) → ∃ (Subst m) → Maybe (∃ (Subst m))
    unifyAcc (lit x₁) (lit x₂) (n , nil) with x₁ ≟-Literal x₂
    ... | yes x₁=x₂ rewrite x₁=x₂ = just (n , nil)
    ... | no  x₁≠x₂ = nothing
    unifyAcc (con s ts) (lit x) (n , nil) = nothing
    unifyAcc (lit x) (con s ts) (n , nil) = nothing
    unifyAcc (con s₁ ts₁) (con  s₂ ts₂) acc with s₁ ≟-Name s₂
    ... | yes s₁=s₂ rewrite s₁=s₂ = unifyAccChildren ts₁ ts₂ acc
    ... | no  s₁≠s₂ = nothing
    unifyAcc (var x₁) (var x₂) (n , nil) = just (flexFlex x₁ x₂)
    unifyAcc t (var x) (n , nil) = flexRigid x t
    unifyAcc (var x) t (n , nil) = flexRigid x t
    unifyAcc t₁ t₂ (n , snoc s t′ x) =
      ( λ s → proj₁ s , snoc (proj₂ s) t′ x )
        <$> unifyAcc (replace (t′ for x) t₁) (replace (t′ for x) t₂) (n , s)

    unifyAccChildren : ∀ {n} → (ts₁ ts₂ : List (Term n)) → ∃ (Subst n) → Maybe (∃ (Subst n))
    unifyAccChildren []         []       acc = just acc
    unifyAccChildren []         _        _   = nothing
    unifyAccChildren _          []       _   = nothing
    unifyAccChildren (t₁ ∷ ts₁) (t₂ ∷ ts₂) acc = unifyAcc t₁ t₂ acc >>= unifyAccChildren ts₁ ts₂

  unify : ∀ {m} → (t₁ t₂ : Term m) → Maybe (∃ (Subst m))
  unify {m} t₁ t₂ = unifyAcc t₁ t₂ (m , nil)


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

-- Mentioned in passing here:
-- https://ncatlab.org/nlab/show/slice+2-category

open import Categories.Bicategory using (Bicategory)

module Categories.Bicategory.Construction.LaxSlice
       {o ℓ e t}
       (𝒞 : Bicategory o ℓ e t)
       where

open import Data.Product using (_,_)
open import Function using (_$_)
open import Level using (_⊔_)

open import Categories.Bicategory.Extras 𝒞
open Shorthands
open import Categories.Category using () renaming (Category to 1Category)
open import Categories.Functor using (Functor)
open Functor using (F₀)
open import Categories.Functor.Bifunctor using (Bifunctor)
open import Categories.Functor.Construction.Constant using (const)
import Categories.Morphism.Reasoning as MR
open import Categories.NaturalTransformation.NaturalIsomorphism using (NaturalIsomorphism; niHelper)

record SliceObj (X : Obj) : Set (t ⊔ o) where
  constructor sliceobj
  field
    {Y} : Obj
    arr : Y ⇒₁ X

module SliceHom (A : Obj) where

  record Slice⇒₁ (X Y : SliceObj A) : Set (o ⊔ ℓ) where
    constructor slicearr₁
    private
      module X = SliceObj X
      module Y = SliceObj Y

    field
      {h} : X.Y ⇒₁ Y.Y
      Δ   : X.arr ⇒₂ (Y.arr ∘₁ h)

  record Slice⇒₂ {X Y : SliceObj A} (J K : Slice⇒₁ X Y) : Set (ℓ ⊔ e) where
    constructor slicearr₂
    private
      module Y = SliceObj Y
      module J = Slice⇒₁ J
      module K = Slice⇒₁ K

    field
      {ϕ} : J.h ⇒₂ K.h
      E   : K.Δ ≈ (Y.arr ▷ ϕ ∘ᵥ J.Δ)

  _∘ᵥ/_ : ∀ {X Y : SliceObj A}{J K L : Slice⇒₁ X Y} → Slice⇒₂ K L → Slice⇒₂ J K → Slice⇒₂ J L
  _∘ᵥ/_ {X}{Y}{J}{K}{L} (slicearr₂ {ϕ = ϕ} E) (slicearr₂ {ϕ = ψ} F) = slicearr₂ {ϕ = ϕ ∘ᵥ ψ} $ begin
      L.Δ                             ≈⟨ E ⟩
      (Y.arr ▷ ϕ ∘ᵥ K.Δ)              ≈⟨ refl⟩∘⟨ F ⟩
      Y.arr ▷ ϕ ∘ᵥ (Y.arr ▷ ψ ∘ᵥ J.Δ) ≈⟨ pullˡ ∘ᵥ-distr-▷ ⟩
      Y.arr ▷ (ϕ ∘ᵥ ψ) ∘ᵥ J.Δ         ∎
    where module X = SliceObj X
          module Y = SliceObj Y
          module J = Slice⇒₁ J
          module K = Slice⇒₁ K
          module L = Slice⇒₁ L
          open 1Category (hom X.Y A)
          open HomReasoning
          open Equiv
          open MR (hom X.Y A)

  SliceHomCat : SliceObj A → SliceObj A → 1Category (o ⊔ ℓ) (ℓ ⊔ e) e
  SliceHomCat X Y = record
    { Obj = Slice⇒₁ X Y
    ; _⇒_ = Slice⇒₂
    ; _≈_ = λ (slicearr₂ {ϕ} _) (slicearr₂ {ψ} _) → ϕ ≈ ψ
    ; id = slice-id _
    ; _∘_ = _∘ᵥ/_
    ; assoc = hom.assoc
    ; sym-assoc = hom.sym-assoc
    ; identityˡ = hom.identityˡ
    ; identityʳ = hom.identityʳ
    ; identity² = hom.identity²
    ; equiv = record { refl = refl ; sym = sym ; trans = trans }
    ; ∘-resp-≈ = hom.∘-resp-≈
    }
    where
      open hom.Equiv
      module X = SliceObj X
      module Y = SliceObj Y

      slice-id : ∀ (J : Slice⇒₁ X Y) → Slice⇒₂ J J
      slice-id J = slicearr₂ $ begin
        J.Δ                 ≈˘⟨ identity₂ˡ ⟩
        id₂ ∘ᵥ J.Δ          ≈˘⟨ ▷id₂ ⟩∘⟨refl ⟩
        (Y.arr ▷ id₂) ∘ J.Δ ∎
        where module J = Slice⇒₁ J
              open 1Category (hom X.Y A)
              open HomReasoning

  _⊚₀/_ : ∀ {X Y Z : SliceObj A} → Slice⇒₁ Y Z → Slice⇒₁ X Y → Slice⇒₁ X Z
  _⊚₀/_ {X}{Y}{Z} J K = slicearr₁ ((α⇒ ∘ᵥ J.Δ ◁ K.h) ∘ᵥ K.Δ)
    where module K = Slice⇒₁ K
          module J = Slice⇒₁ J

  _⊚₁/_ : ∀ {X Y Z : SliceObj A} → {J J' : Slice⇒₁ Y Z} → {K K' : Slice⇒₁ X Y} → Slice⇒₂ J J' → Slice⇒₂ K K' → Slice⇒₂ (J ⊚₀/ K) (J' ⊚₀/ K')
  _⊚₁/_ {X}{Y}{Z}{J'}{J}{K'}{K} δ γ = slicearr₂ $ begin
    (α⇒ ∘ᵥ J.Δ ◁ K.h) ∘ᵥ K.Δ                                                  ≈⟨ (refl⟩∘⟨ γ.E) ⟩
    (α⇒ ∘ᵥ J.Δ ◁ K.h) ∘ᵥ (Y.arr ▷ γ.ϕ ∘ᵥ K'.Δ)                                ≈⟨ ((refl⟩∘⟨ δ.E ⟩⊚⟨refl) ⟩∘⟨refl) ⟩
    (α⇒ ∘ᵥ (Z.arr ▷ δ.ϕ ∘ᵥ J'.Δ) ◁ K.h) ∘ᵥ (Y.arr ▷ γ.ϕ ∘ᵥ K'.Δ)              ≈˘⟨ (((refl⟩∘⟨ ∘ᵥ-distr-◁ ) ⟩∘⟨refl)) ⟩
    (α⇒ ∘ᵥ ((Z.arr ▷ δ.ϕ) ◁ K.h ∘ᵥ J'.Δ ◁ K.h)) ∘ᵥ (Y.arr ▷ γ.ϕ ∘ᵥ K'.Δ)      ≈⟨ pullʳ (center (sym ◁-▷-exchg)) ⟩
    α⇒ ∘ᵥ (Z.arr ▷ δ.ϕ) ◁ K.h ∘ᵥ (Z.arr ⊚₀ J'.h ▷ γ.ϕ ∘ᵥ J'.Δ ◁ K'.h) ∘ᵥ K'.Δ ≈⟨ pushʳ ( pullˡ (pullˡ (sym ⊚.homomorphism)) ) ⟩
    (α⇒ ∘ᵥ (Z.arr ▷ δ.ϕ ∘ᵥ id₂) ⊚₁ (id₂ ∘ᵥ γ.ϕ) ∘ᵥ J'.Δ ◁ K'.h) ∘ᵥ K'.Δ       ≈⟨ ((refl⟩∘⟨ (identity₂ʳ ⟩⊚⟨ identity₂ˡ ⟩∘⟨refl)) ⟩∘⟨refl) ⟩
    (α⇒ ∘ᵥ ((Z.arr ▷ δ.ϕ) ⊚₁ γ.ϕ) ∘ᵥ J'.Δ ◁ K'.h) ∘ᵥ K'.Δ                     ≈⟨ pushˡ (pullˡ (⊚-assoc.⇒.commute ((id₂ , δ.ϕ) , γ.ϕ))) ⟩
    (Z.arr ▷ δ.ϕ ⊚₁ γ.ϕ ∘ᵥ α⇒) ∘ᵥ J'.Δ ◁ K'.h ∘ᵥ K'.Δ                         ≈⟨ pullʳ (sym assoc) ⟩
    (Z.arr ▷ δ.ϕ ⊚₁ γ.ϕ) ∘ᵥ ((α⇒ ∘ᵥ J'.Δ ◁ K'.h) ∘ᵥ K'.Δ)                     ∎
    where module X = SliceObj X
          module Y = SliceObj Y
          module Z = SliceObj Z
          module J = Slice⇒₁ J
          module J' = Slice⇒₁ J'
          module K = Slice⇒₁ K
          module K' = Slice⇒₁ K'
          module γ = Slice⇒₂ γ
          module δ = Slice⇒₂ δ
          open 1Category (hom X.Y A)
          open HomReasoning
          open MR (hom X.Y A)
          open Equiv

  id/ : ∀ {X : SliceObj A} → Slice⇒₁ X X
  id/ = slicearr₁ ρ⇐

  _⊚/_ : ∀ {X Y Z : SliceObj A} → Bifunctor (SliceHomCat Y Z) (SliceHomCat X Y) (SliceHomCat X Z)
  _⊚/_ {X}{Y}{Z} = record
    { F₀ = λ (J , K) → J ⊚₀/ K
    ; F₁ = λ (δ , γ) → δ ⊚₁/ γ
      ; identity = ⊚.identity
      ; homomorphism = ⊚.homomorphism
      ; F-resp-≈ = ⊚.F-resp-≈
      }
      where module X = SliceObj X
            module Y = SliceObj Y
            module Z = SliceObj Z

  α⇒/ : ∀ {W X Y Z}(J : Slice⇒₁ Y Z) (K : Slice⇒₁ X Y) (L : Slice⇒₁ W X) → Slice⇒₂ ((J ⊚₀/ K) ⊚₀/ L) (J ⊚₀/ (K ⊚₀/ L))
  α⇒/ {W}{X}{Y}{Z} J K L = slicearr₂ $ begin
    (α⇒ ∘ᵥ J.Δ ◁ K.h ⊚₀ L.h) ∘ᵥ ((α⇒ ∘ᵥ K.Δ ◁ L.h) ∘ᵥ L.Δ  )                  ≈⟨ pullʳ (center⁻¹ (sym α⇒-◁-∘₁) refl) ⟩
    α⇒ ∘ᵥ (α⇒ ∘ᵥ J.Δ ◁ K.h ◁ L.h) ∘ᵥ K.Δ ◁ L.h ∘ᵥ L.Δ                         ≈⟨ pullˡ (pullˡ (sym pentagon)) ⟩
    ((Z.arr ▷ α⇒ ∘ᵥ α⇒ ∘ᵥ α⇒ ◁ L.h) ∘ᵥ J.Δ ◁ K.h ◁ L.h) ∘ᵥ (K.Δ ◁ L.h ∘ᵥ L.Δ) ≈⟨ pullˡ (pushˡ (pull-last ∘ᵥ-distr-◁ )) ⟩
    (Z.arr ▷ α⇒ ∘ᵥ (α⇒ ∘ᵥ ((α⇒ ∘ᵥ J.Δ ◁ K.h) ◁ L.h)) ∘ᵥ K.Δ ◁ L.h) ∘ᵥ L.Δ     ≈⟨ pushˡ (pushʳ (pullʳ ∘ᵥ-distr-◁)) ⟩
    ((Z.arr ▷ α⇒ ∘ᵥ α⇒)) ∘ᵥ (((α⇒ ∘ᵥ J.Δ ◁ K.h) ∘ᵥ K.Δ) ◁ L.h) ∘ᵥ L.Δ         ≈⟨ pullʳ (pushʳ refl) ⟩
    Z.arr ▷ α⇒ ∘ᵥ ((α⇒ ∘ᵥ (((α⇒ ∘ᵥ J.Δ ◁ K.h)) ∘ᵥ K.Δ) ◁ L.h) ∘ᵥ L.Δ)         ∎
    where module W = SliceObj W
          module X = SliceObj X
          module Y = SliceObj Y
          module Z = SliceObj Z
          module J = Slice⇒₁ J
          module K = Slice⇒₁ K
          module L = Slice⇒₁ L
          open 1Category (hom W.Y A)
          open HomReasoning
          open MR (hom W.Y A)
          open hom.Equiv

  λ⇒/ : ∀ {X Y} (J : Slice⇒₁ X Y) → Slice⇒₂ (id/ ⊚₀/ J) J
  λ⇒/ {X}{Y} J = slicearr₂ $ begin
    J.Δ                                   ≈⟨ introˡ id₂◁ ⟩
    (id₂ ◁ J.h) ∘ᵥ J.Δ                    ≈˘⟨ (unitʳ.iso.isoʳ (Y.arr , _) ⟩⊚⟨refl ⟩∘⟨refl) ⟩
    ((ρ⇒ ∘ᵥ ρ⇐) ◁ J.h) ∘ᵥ J.Δ             ≈˘⟨ (∘ᵥ-distr-◁ ⟩∘⟨refl) ⟩
    (ρ⇒ ◁ J.h ∘ᵥ ρ⇐ ◁ J.h) ∘ᵥ J.Δ         ≈⟨ pushˡ (sym triangle ⟩∘⟨ refl) ⟩
    (Y.arr ▷ λ⇒ ∘ᵥ α⇒) ∘ᵥ ρ⇐ ◁ J.h ∘ᵥ J.Δ ≈⟨ pullʳ (sym assoc) ⟩
    Y.arr ▷ λ⇒ ∘ᵥ (α⇒ ∘ᵥ ρ⇐ ◁ J.h) ∘ᵥ J.Δ ∎
    where module X = SliceObj X
          module Y = SliceObj Y
          module J = Slice⇒₁ J
          open 1Category (hom X.Y A)
          open HomReasoning
          open MR (hom X.Y A)
          open hom.Equiv

  ρ⇒/ : ∀{X}{Y} (J : Slice⇒₁ X Y) → Slice⇒₂ (J ⊚₀/ id/) J
  ρ⇒/ {X}{Y} J = slicearr₂ $ begin
    J.Δ                                     ≈⟨ introʳ (unitʳ.iso.isoʳ _) ⟩
    J.Δ ∘ᵥ ρ⇒ ∘ᵥ ρ⇐                         ≈⟨ pullˡ (sym ρ⇒-∘ᵥ-◁) ⟩
    (ρ⇒ ∘ᵥ J.Δ ◁ id₁) ∘ᵥ ρ⇐                 ≈⟨ unitorʳ-coherence  ⟩∘⟨refl ⟩∘⟨refl ⟩
    ((Y.arr ▷ ρ⇒ ∘ᵥ α⇒) ∘ᵥ J.Δ ◁ id₁) ∘ᵥ ρ⇐ ≈⟨ pushˡ assoc ⟩
    Y.arr ▷ ρ⇒ ∘ᵥ (α⇒ ∘ᵥ J.Δ ◁ id₁) ∘ᵥ ρ⇐   ∎
    where module X = SliceObj X
          module Y = SliceObj Y
          module J = Slice⇒₁ J
          open 1Category (hom X.Y A)
          open HomReasoning
          open MR (hom X.Y A)
          open hom.Equiv

  slice-inv : ∀ {X}{Y}{J : Slice⇒₁ X Y}{K} (α : Slice⇒₂ J K) → (f : Slice⇒₁.h K ⇒₂ Slice⇒₁.h J) → (f ∘ᵥ (Slice⇒₂.ϕ α) ≈ id₂) → Slice⇒₂ K J
  slice-inv {X}{Y}{J}{K} α f p = slicearr₂ $ begin
    J.Δ                               ≈⟨ introˡ ▷id₂ ⟩
    (Y.arr ▷ id₂) ∘ᵥ J.Δ              ≈˘⟨ (refl⟩⊚⟨ p ⟩∘⟨refl) ⟩
    (Y.arr ▷ (f ∘ᵥ α.ϕ)) ∘ᵥ J.Δ       ≈˘⟨ (∘ᵥ-distr-▷ ⟩∘⟨refl) ⟩
    (Y.arr ▷ f ∘ᵥ Y.arr ▷ α.ϕ) ∘ᵥ J.Δ ≈⟨ pullʳ (sym α.E) ⟩
    Y.arr ▷ f ∘ᵥ K.Δ                  ∎
    where module X = SliceObj X
          module Y = SliceObj Y
          module J = Slice⇒₁ J
          module K = Slice⇒₁ K
          module α = Slice⇒₂ α
          open 1Category (hom X.Y A)
          open HomReasoning
          open MR (hom X.Y A)
          open hom.Equiv

LaxSlice : Obj → Bicategory (o ⊔ ℓ) (ℓ ⊔ e) e (o ⊔ t)
LaxSlice A   = record
  { enriched = record
    { Obj = SliceObj A
    ; hom = SliceHomCat
    ; id = const id/
    ; ⊚ = _⊚/_
    ; ⊚-assoc = niHelper (record
      { η       = λ ((J , K) , L) → α⇒/ J K L
      ; η⁻¹     = λ ((J , K) , L) → slice-inv (α⇒/ J K L) α⇐ (⊚-assoc.iso.isoˡ _)
      ; commute = λ f → ⊚-assoc.⇒.commute _
      ; iso = λ _ → record { isoˡ = ⊚-assoc.iso.isoˡ _ ; isoʳ = ⊚-assoc.iso.isoʳ _ }
      })
    ; unitˡ = niHelper (record
      { η       = λ (_ , J) → λ⇒/ J
      ; η⁻¹     = λ (_ , J) → slice-inv (λ⇒/ J) λ⇐ (unitˡ.iso.isoˡ _)
      ; commute = λ _ → λ⇒-∘ᵥ-▷
      ; iso     = λ _ → record { isoˡ = unitˡ.iso.isoˡ _ ; isoʳ = unitˡ.iso.isoʳ _ }
      })
    ; unitʳ = niHelper (record
         { η       = λ (J , _) → ρ⇒/ J
         ; η⁻¹     = λ (J , _) → slice-inv (ρ⇒/ J) ρ⇐ (unitʳ.iso.isoˡ _)
         ; commute = λ _ → ρ⇒-∘ᵥ-◁
         ; iso     = λ _ → record { isoˡ = unitʳ.iso.isoˡ _ ; isoʳ = unitʳ.iso.isoʳ _ } })
    }
  ; triangle = triangle
  ; pentagon = pentagon
  }
  where open SliceHom A


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

module Data.Fin where

open import Data.Fin.Core public
  using (Fin; Fin-Number; fsuc; fzero)


{-# OPTIONS --safe #-}
module Cubical.Data.Int.Properties where

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Transport
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence

open import Cubical.Data.Empty
open import Cubical.Data.Nat
  hiding   (+-assoc ; +-comm ; ·-comm)
  renaming (_·_ to _·ℕ_; _+_ to _+ℕ_ ; ·-assoc to ·ℕ-assoc)
open import Cubical.Data.Bool
open import Cubical.Data.Sum
open import Cubical.Data.Int.Base

open import Cubical.Relation.Nullary
open import Cubical.Relation.Nullary.DecidableEq

sucPred : ∀ i → sucℤ (predℤ i) ≡ i
sucPred (pos zero)    = refl
sucPred (pos (suc n)) = refl
sucPred (negsuc n)    = refl

predSuc : ∀ i → predℤ (sucℤ i) ≡ i
predSuc (pos n)          = refl
predSuc (negsuc zero)    = refl
predSuc (negsuc (suc n)) = refl

injPos : ∀ {a b : ℕ} → pos a ≡ pos b → a ≡ b
injPos {a} h = subst T h refl
  where
  T : ℤ → Type₀
  T (pos x)    = a ≡ x
  T (negsuc _) = ⊥

injNegsuc : ∀ {a b : ℕ} → negsuc a ≡ negsuc b → a ≡ b
injNegsuc {a} h = subst T h refl
  where
  T : ℤ → Type₀
  T (pos _) = ⊥
  T (negsuc x) = a ≡ x

posNotnegsuc : ∀ (a b : ℕ) → ¬ (pos a ≡ negsuc b)
posNotnegsuc a b h = subst T h 0
  where
  T : ℤ → Type₀
  T (pos _)    = ℕ
  T (negsuc _) = ⊥

negsucNotpos : ∀ (a b : ℕ) → ¬ (negsuc a ≡ pos b)
negsucNotpos a b h = subst T h 0
  where
  T : ℤ → Type₀
  T (pos _)    = ⊥
  T (negsuc _) = ℕ

discreteℤ : Discrete ℤ
discreteℤ (pos n) (pos m) with discreteℕ n m
... | yes p = yes (cong pos p)
... | no p  = no (λ x → p (injPos x))
discreteℤ (pos n) (negsuc m) = no (posNotnegsuc n m)
discreteℤ (negsuc n) (pos m) = no (negsucNotpos n m)
discreteℤ (negsuc n) (negsuc m) with discreteℕ n m
... | yes p = yes (cong negsuc p)
... | no p  = no (λ x → p (injNegsuc x))

isSetℤ : isSet ℤ
isSetℤ = Discrete→isSet discreteℤ

-pos : ∀ n → - (pos n) ≡ neg n
-pos zero    = refl
-pos (suc n) = refl

-neg : ∀ n → - (neg n) ≡ pos n
-neg zero    = refl
-neg (suc n) = refl

-Involutive : ∀ z → - (- z) ≡ z
-Involutive (pos n)    = cong -_ (-pos n) ∙ -neg n
-Involutive (negsuc n) = refl

sucℤ+pos : ∀ n m → sucℤ (m +pos n) ≡ (sucℤ m) +pos n
sucℤ+pos zero m = refl
sucℤ+pos (suc n) m = cong sucℤ (sucℤ+pos n m)

predℤ+negsuc : ∀ n m → predℤ (m +negsuc n) ≡ (predℤ m) +negsuc n
predℤ+negsuc zero m = refl
predℤ+negsuc (suc n) m = cong predℤ (predℤ+negsuc n m)

sucℤ+negsuc : ∀ n m → sucℤ (m +negsuc n) ≡ (sucℤ m) +negsuc n
sucℤ+negsuc zero m = (sucPred _) ∙ (sym (predSuc _))
sucℤ+negsuc (suc n) m =      _ ≡⟨ sucPred _ ⟩
  m +negsuc n                    ≡[ i ]⟨ predSuc m (~ i) +negsuc n ⟩
  (predℤ (sucℤ m)) +negsuc n ≡⟨ sym (predℤ+negsuc n (sucℤ m)) ⟩
  predℤ (sucℤ m +negsuc n) ∎

predℤ+pos : ∀ n m → predℤ (m +pos n) ≡ (predℤ m) +pos n
predℤ+pos zero m = refl
predℤ+pos (suc n) m =     _ ≡⟨ predSuc _ ⟩
  m +pos n                    ≡[ i ]⟨ sucPred m (~ i) + pos n ⟩
  (sucℤ (predℤ m)) +pos n ≡⟨ sym (sucℤ+pos n (predℤ m))⟩
  (predℤ m) +pos (suc n)    ∎

predℤ-pos : ∀ n → predℤ(- (pos n)) ≡ negsuc n
predℤ-pos zero = refl
predℤ-pos (suc n) = refl

predℤ+ : ∀ m n → predℤ (m + n) ≡ (predℤ m) + n
predℤ+ m (pos n) = predℤ+pos n m
predℤ+ m (negsuc n) = predℤ+negsuc n m

+predℤ : ∀ m n → predℤ (m + n) ≡ m + (predℤ n)
+predℤ m (pos zero) = refl
+predℤ m (pos (suc n)) = (predSuc (m + pos n)) ∙ (cong (_+_ m) (sym (predSuc (pos n))))
+predℤ m (negsuc n) = refl

sucℤ+ : ∀ m n → sucℤ (m + n) ≡ (sucℤ m) + n
sucℤ+ m (pos n) = sucℤ+pos n m
sucℤ+ m (negsuc n) = sucℤ+negsuc n m

+sucℤ : ∀ m n → sucℤ (m + n) ≡  m + (sucℤ n)
+sucℤ m (pos n) = refl
+sucℤ m (negsuc zero) = sucPred _
+sucℤ m (negsuc (suc n)) = (sucPred (m +negsuc n)) ∙ (cong (_+_ m) (sym (sucPred (negsuc n))))

pos0+ : ∀ z → z ≡ pos 0 + z
pos0+ (pos zero) = refl
pos0+ (pos (suc n)) = cong sucℤ (pos0+ (pos n))
pos0+ (negsuc zero) = refl
pos0+ (negsuc (suc n)) = cong predℤ (pos0+ (negsuc n))

negsuc0+ : ∀ z → predℤ z ≡ negsuc 0 + z
negsuc0+ (pos zero) = refl
negsuc0+ (pos (suc n)) = (sym (sucPred (pos n))) ∙ (cong sucℤ (negsuc0+ _))
negsuc0+ (negsuc zero) = refl
negsuc0+ (negsuc (suc n)) = cong predℤ (negsuc0+ (negsuc n))

ind-comm : {A : Type₀} (_∙_ : A → A → A) (f : ℕ → A) (g : A → A)
           (p : ∀ {n} → f (suc n) ≡ g (f n))
           (g∙ : ∀ a b → g (a ∙ b) ≡ g a ∙ b)
           (∙g : ∀ a b → g (a ∙ b) ≡ a ∙ g b)
           (base : ∀ z → z ∙ f 0 ≡ f 0 ∙ z)
         → ∀ z n → z ∙ f n ≡ f n ∙ z
ind-comm _∙_ f g p g∙ ∙g base z 0 = base z
ind-comm _∙_ f g p g∙ ∙g base z (suc n) =
  z ∙ f (suc n) ≡[ i ]⟨ z ∙ p {n} i ⟩
  z ∙ g (f n)   ≡⟨ sym ( ∙g z (f n)) ⟩
  g (z ∙ f n)   ≡⟨ cong g IH ⟩
  g (f n ∙ z)   ≡⟨ g∙ (f n) z ⟩
  g (f n) ∙ z   ≡[ i ]⟨ p {n} (~ i) ∙ z ⟩
  f (suc n) ∙ z ∎
  where
  IH = ind-comm _∙_ f g p g∙ ∙g base z n

ind-assoc : {A : Type₀} (_·_ : A → A → A) (f : ℕ → A)
        (g : A → A) (p : ∀ a b → g (a · b) ≡ a · (g b))
        (q : ∀ {c} → f (suc c) ≡ g (f c))
        (base : ∀ m n → (m · n) · (f 0) ≡ m · (n · (f 0)))
        (m n : A) (o : ℕ)
      → m · (n · (f o)) ≡ (m · n) · (f o)
ind-assoc _·_ f g p q base m n 0 = sym (base m n)
ind-assoc _·_ f g p q base m n (suc o) =
    m · (n · (f (suc o))) ≡[ i ]⟨ m · (n · q {o} i) ⟩
    m · (n · (g (f o)))   ≡[ i ]⟨ m · (p n (f o) (~ i)) ⟩
    m · (g (n · (f o)))   ≡⟨ sym (p m (n · (f o)))⟩
    g (m · (n · (f o)))   ≡⟨ cong g IH ⟩
    g ((m · n) · (f o))   ≡⟨ p (m · n) (f o) ⟩
    (m · n) · (g (f o))   ≡[ i ]⟨ (m · n) · q {o} (~ i) ⟩
    (m · n) · (f (suc o)) ∎
    where
    IH = ind-assoc _·_ f g p q base m n o

+Comm : ∀ m n → m + n ≡ n + m
+Comm m (pos n) = ind-comm _+_ pos sucℤ refl sucℤ+ +sucℤ pos0+ m n
+Comm m (negsuc n) = ind-comm _+_ negsuc predℤ refl predℤ+ +predℤ negsuc0+ m n

+Assoc : ∀ m n o → m + (n + o) ≡ (m + n) + o
+Assoc m n (pos o) = ind-assoc _+_ pos sucℤ +sucℤ refl (λ _ _ → refl) m n o
+Assoc m n (negsuc o) = ind-assoc _+_ negsuc predℤ +predℤ refl +predℤ m n o

-- Compose sucPathℤ with itself n times. Transporting along this
-- will be addition, transporting with it backwards will be subtraction.
-- Use this to define _+'_ for which is easier to prove
-- isEquiv (λ n → n +' m) since _+'_ is defined by transport

sucPathℤ : ℤ ≡ ℤ
sucPathℤ = ua (sucℤ , isoToIsEquiv (iso sucℤ predℤ sucPred predSuc))

addEq : ℕ → ℤ ≡ ℤ
addEq zero = refl
addEq (suc n) = (addEq n) ∙ sucPathℤ

predPathℤ : ℤ ≡ ℤ
predPathℤ = ua (predℤ , isoToIsEquiv (iso predℤ sucℤ predSuc sucPred))

subEq : ℕ → ℤ ≡ ℤ
subEq zero = refl
subEq (suc n) = (subEq n) ∙ predPathℤ

_+'_ : ℤ → ℤ → ℤ
m +' pos n    = transport (addEq n) m
m +' negsuc n = transport (subEq (suc n)) m

+'≡+ : _+'_ ≡ _+_
+'≡+ i m (pos zero) = m
+'≡+ i m (pos (suc n)) = sucℤ (+'≡+ i m (pos n))
+'≡+ i m (negsuc zero) = predℤ m
+'≡+ i m (negsuc (suc n)) = predℤ (+'≡+ i m (negsuc n)) --
  -- compPath (λ i → (+'≡+ i (predℤ m) (negsuc n))) (sym (predℤ+negsuc n m)) i

isEquivAddℤ' : (m : ℤ) → isEquiv (λ n → n +' m)
isEquivAddℤ' (pos n)    = isEquivTransport (addEq n)
isEquivAddℤ' (negsuc n) = isEquivTransport (subEq (suc n))

isEquivAddℤ : (m : ℤ) → isEquiv (λ n → n + m)
isEquivAddℤ = subst (λ add → (m : ℤ) → isEquiv (λ n → add n m)) +'≡+ isEquivAddℤ'

-- below is an alternate proof of isEquivAddℤ for comparison
-- We also have two useful lemma here.

minusPlus : ∀ m n → (n - m) + m ≡ n
minusPlus (pos zero) n = refl
minusPlus (pos 1) = sucPred
minusPlus (pos (suc (suc m))) n =
  sucℤ ((n +negsuc (suc m)) +pos (suc m)) ≡⟨ sucℤ+pos (suc m) _ ⟩
  sucℤ (n +negsuc (suc m)) +pos (suc m)   ≡[ i ]⟨ sucPred (n +negsuc m) i +pos (suc m) ⟩
  (n - pos (suc m)) +pos (suc m)            ≡⟨ minusPlus (pos (suc m)) n ⟩
  n ∎
minusPlus (negsuc zero) = predSuc
minusPlus (negsuc (suc m)) n =
  predℤ (sucℤ (sucℤ (n +pos m)) +negsuc m) ≡⟨ predℤ+negsuc m _ ⟩
  predℤ (sucℤ (sucℤ (n +pos m))) +negsuc m ≡[ i ]⟨ predSuc (sucℤ (n +pos m)) i +negsuc m ⟩
  sucℤ (n +pos m) +negsuc m                    ≡⟨ minusPlus (negsuc m) n ⟩
  n ∎

plusMinus : ∀ m n → (n + m) - m ≡ n
plusMinus (pos zero) n = refl
plusMinus (pos (suc m)) = minusPlus (negsuc m)
plusMinus (negsuc m) = minusPlus (pos (suc m))

private
  alternateProof : (m : ℤ) → isEquiv (λ n → n + m)
  alternateProof m = isoToIsEquiv (iso (λ n → n + m)
                                       (λ n → n - m)
                                       (minusPlus m)
                                       (plusMinus m))

-Cancel : ∀ z → z - z ≡ 0
-Cancel z = cong (_- z) (pos0+ z) ∙ plusMinus z (pos zero)

pos+ : ∀ m n → pos (m +ℕ n) ≡ pos m + pos n
pos+ zero zero = refl
pos+ zero (suc n)    =
  pos (zero +ℕ suc n)    ≡⟨ +Comm (pos (suc n)) (pos zero) ⟩
  pos zero + pos (suc n) ∎
pos+ (suc m) zero    =
  pos (suc (m +ℕ zero))  ≡⟨ cong pos (cong suc (+-zero m)) ⟩
  pos (suc m) + pos zero ∎
pos+ (suc m) (suc n) =
  pos (suc m +ℕ suc n)            ≡⟨ cong pos (cong suc (+-suc m n)) ⟩
  sucℤ (pos (suc (m +ℕ n)))     ≡⟨ cong sucℤ (cong sucℤ (pos+ m n)) ⟩
  sucℤ (sucℤ (pos m + pos n)) ≡⟨ sucℤ+ (pos m) (sucℤ (pos n)) ⟩
  pos (suc m) + pos (suc n)       ∎

negsuc+ : ∀ m n → negsuc (m +ℕ n) ≡ negsuc m - pos n
negsuc+ zero zero       = refl
negsuc+ zero (suc n)    =
  negsuc (zero +ℕ suc n)    ≡⟨ negsuc0+ (negsuc n) ⟩
  negsuc zero + negsuc n    ≡⟨ cong (negsuc zero +_) (-pos (suc n)) ⟩
  negsuc zero - pos (suc n) ∎
negsuc+ (suc m) zero    =
  negsuc (suc m +ℕ zero)    ≡⟨ cong negsuc (cong suc (+-zero m)) ⟩
  negsuc (suc m) - pos zero ∎
negsuc+ (suc m) (suc n) =
  negsuc (suc m +ℕ suc n)        ≡⟨ cong negsuc (sym (+-suc m (suc n))) ⟩
  negsuc (m +ℕ suc (suc n))      ≡⟨ negsuc+ m (suc (suc n)) ⟩
  negsuc m - pos (suc (suc n))   ≡⟨ sym (+predℤ (negsuc m) (negsuc n)) ⟩
  predℤ (negsuc m + negsuc n ) ≡⟨ predℤ+ (negsuc m) (negsuc n) ⟩
  negsuc (suc m) - pos (suc n)   ∎

neg+ : ∀ m n → neg (m +ℕ n) ≡ neg m + neg n
neg+ zero zero       = refl
neg+ zero (suc n)    = neg (zero +ℕ suc n)    ≡⟨ +Comm (neg (suc n)) (pos zero) ⟩
                       neg zero + neg (suc n) ∎
neg+ (suc m) zero    = neg (suc (m +ℕ zero))  ≡⟨ cong neg (cong suc (+-zero m)) ⟩
                       neg (suc m) + neg zero ∎
neg+ (suc m) (suc n) = neg (suc m +ℕ suc n)      ≡⟨ negsuc+ m (suc n) ⟩
                       neg (suc m) + neg (suc n) ∎

ℕ-AntiComm : ∀ m n → m ℕ- n ≡ - (n ℕ- m)
ℕ-AntiComm zero zero       = refl
ℕ-AntiComm zero (suc n)    = refl
ℕ-AntiComm (suc m) zero    = refl
ℕ-AntiComm (suc m) (suc n) = suc m ℕ- suc n  ≡⟨ ℕ-AntiComm m n ⟩
                          - (suc n ℕ- suc m) ∎

pos- : ∀ m n → m ℕ- n ≡ pos m - pos n
pos- zero zero       = refl
pos- zero (suc n)    = zero ℕ- suc n          ≡⟨ +Comm (negsuc n) (pos zero) ⟩
                       pos zero - pos (suc n) ∎
pos- (suc m) zero    = refl
pos- (suc m) (suc n) =
  suc m ℕ- suc n                       ≡⟨ pos- m n ⟩
  pos m - pos n                        ≡⟨ sym (sucPred (pos m - pos n)) ⟩
  sucℤ (predℤ (pos m - pos n))     ≡⟨ cong sucℤ (+predℤ (pos m) (- pos n)) ⟩
  sucℤ (pos m + predℤ (- (pos n))) ≡⟨ cong sucℤ (cong (pos m +_) (predℤ-pos n)) ⟩
  sucℤ (pos m + negsuc n)            ≡⟨ sucℤ+negsuc n (pos m) ⟩
  pos (suc m) - pos (suc n)            ∎

-AntiComm : ∀ m n → m - n ≡ - (n - m)
-AntiComm (pos n) (pos m)       = pos n - pos m   ≡⟨ sym (pos- n m) ⟩
                                   n ℕ- m         ≡⟨ ℕ-AntiComm n m ⟩
                                - (m ℕ- n)        ≡⟨ cong -_ (pos- m n) ⟩
                                - (pos m - pos n) ∎
-AntiComm (pos n) (negsuc m)    =
     pos n - negsuc m     ≡⟨ +Comm (pos n) (pos (suc m)) ⟩
     pos (suc m) + pos n  ≡⟨ sym (pos+ (suc m) n) ⟩
     pos (suc m +ℕ n)     ≡⟨ sym (-neg (suc m +ℕ n)) ⟩
  -  neg (suc m +ℕ n)     ≡⟨ cong -_ (neg+ (suc m) n) ⟩
  - (neg (suc m) + neg n) ≡⟨ cong -_ (cong (negsuc m +_) (sym (-pos n))) ⟩
  - (negsuc m - pos n)    ∎
-AntiComm (negsuc n) (pos m)    =
     negsuc n - pos m     ≡⟨ sym (negsuc+ n m) ⟩
     negsuc (n +ℕ m)      ≡⟨ cong -_ (pos+ (suc n) m) ⟩
  - (pos (suc n) + pos m) ≡⟨ cong -_ (+Comm (pos (suc n)) (pos m)) ⟩
  - (pos m - negsuc n)    ∎
-AntiComm (negsuc n) (negsuc m) =
     negsuc n - negsuc m        ≡⟨ +Comm (negsuc n) (pos (suc m)) ⟩
     pos (suc m) + negsuc n     ≡⟨ sym (pos- (suc m) (suc n)) ⟩
     suc m ℕ- suc n             ≡⟨ ℕ-AntiComm (suc m) (suc n) ⟩
  - (suc n ℕ- suc m)            ≡⟨ cong -_ (pos- (suc n) (suc m)) ⟩
  - (pos (suc n) - pos (suc m)) ≡⟨ cong -_ (+Comm (pos (suc n)) (negsuc m)) ⟩
  - (negsuc m - negsuc n)       ∎

-Dist+ : ∀ m n → - (m + n) ≡ (- m) + (- n)
-Dist+ (pos n) (pos m)       =
   - (pos n + pos m)     ≡⟨ cong -_ (sym (pos+ n m)) ⟩
   -  pos (n +ℕ m)       ≡⟨ -pos (n +ℕ m) ⟩
      neg (n +ℕ m)       ≡⟨ neg+ n m ⟩
      neg n + neg m      ≡⟨ cong (neg n +_) (sym (-pos m)) ⟩
      neg n + (- pos m)  ≡⟨ cong (_+ (- pos m)) (sym (-pos n)) ⟩
  (-  pos n) + (- pos m) ∎
-Dist+ (pos n) (negsuc m)    =
   - (pos n + negsuc m)     ≡⟨ sym (-AntiComm (pos (suc m)) (pos n)) ⟩
      pos (suc m) - pos n   ≡⟨ +Comm (pos (suc m)) (- pos n) ⟩
  (-  pos n) + (- negsuc m) ∎
-Dist+ (negsuc n) (pos m)    =
   - (negsuc n + pos m)     ≡⟨ cong -_ (+Comm (negsuc n) (pos m)) ⟩
   - (pos m + negsuc n)     ≡⟨ sym (-AntiComm (- negsuc n) (pos m)) ⟩
  (-  negsuc n) + (- pos m) ∎
-Dist+ (negsuc n) (negsuc m) =
   - (negsuc n + negsuc m)     ≡⟨ cong -_ (sym (neg+ (suc n) (suc m))) ⟩
   -  neg (suc n +ℕ suc m)     ≡⟨ pos+ (suc n) (suc m) ⟩
  (-  negsuc n) + (- negsuc m) ∎

-- multiplication

pos·negsuc : (n m : ℕ) → pos n · negsuc m ≡ - (pos n · pos (suc m))
pos·negsuc zero m = refl
pos·negsuc (suc n) m =
     (λ i → negsuc m + (pos·negsuc n m i))
   ∙ sym (-Dist+ (pos (suc m)) (pos n · pos (suc m)))

negsuc·pos : (n m : ℕ) → negsuc n · pos m ≡ - (pos (suc n) · pos m)
negsuc·pos zero m = refl
negsuc·pos (suc n) m =
    cong ((- pos m) +_) (negsuc·pos n m)
  ∙ sym (-Dist+ (pos m) (pos m + (pos n · pos m)))

negsuc·negsuc : (n m : ℕ) → negsuc n · negsuc m ≡ pos (suc n) · pos (suc m)
negsuc·negsuc zero m = refl
negsuc·negsuc (suc n) m = cong (pos (suc m) +_) (negsuc·negsuc n m)

·Comm : (x y : ℤ) → x · y ≡ y · x
·Comm (pos n) (pos m) = lem n m
  where
  lem : (n m : ℕ) → (pos n · pos m) ≡ (pos m · pos n)
  lem zero zero = refl
  lem zero (suc m) i = +Comm (lem zero m i) (pos zero) i
  lem (suc n) zero i = +Comm (pos zero) (lem n zero i) i
  lem (suc n) (suc m) =
       (λ i → pos (suc m) + (lem n (suc m) i))
    ∙∙ +Assoc (pos (suc m)) (pos n) (pos m · pos n)
    ∙∙ (λ i → sucℤ+ (pos m) (pos n) (~ i)  + (pos m · pos n))
    ∙∙ (λ i → +Comm (pos m) (pos (suc n)) i + (pos m · pos n))
    ∙∙ sym (+Assoc (pos (suc n)) (pos m) (pos m · pos n))
    ∙∙ (λ i → pos (suc n) + (pos m + (lem n m (~ i))))
    ∙∙ λ i → pos (suc n) + (lem (suc n) m i)
·Comm (pos n) (negsuc m) =
     pos·negsuc n m
  ∙∙ cong -_ (·Comm (pos n) (pos (suc m)))
  ∙∙ sym (negsuc·pos m n)
·Comm (negsuc n) (pos m) =
  sym (pos·negsuc m n
  ∙∙ cong -_ (·Comm (pos m) (pos (suc n)))
  ∙∙ sym (negsuc·pos n m))
·Comm (negsuc n) (negsuc m) =
  negsuc·negsuc n m ∙∙ ·Comm (pos (suc n)) (pos (suc m)) ∙∙ sym (negsuc·negsuc m n)

·Rid : (x : ℤ) → x · 1 ≡ x
·Rid x = ·Comm x 1

private
  distrHelper : (x y z w : ℤ) → (x + y) + (z + w) ≡ ((x + z) + (y + w))
  distrHelper x y z w =
      +Assoc (x + y) z w
   ∙∙ cong (_+ w) (sym (+Assoc x y z) ∙∙ cong (x +_) (+Comm y z) ∙∙ +Assoc x z y)
   ∙∙ sym (+Assoc (x + z) y w)

·DistR+ : (x y z : ℤ) → x · (y + z) ≡ x · y + x · z
·DistR+ (pos zero) y z = refl
·DistR+ (pos (suc n)) y z =
     cong ((y + z) +_) (·DistR+ (pos n) y z)
   ∙ distrHelper y z (pos n · y) (pos n · z)
·DistR+ (negsuc zero) y z = -Dist+ y z
·DistR+ (negsuc (suc n)) y z =
    cong₂ _+_ (-Dist+ y z) (·DistR+ (negsuc n) y z)
  ∙ distrHelper (- y) (- z) (negsuc n · y) (negsuc n · z)

·DistL+ : (x y z : ℤ) → (x + y) · z ≡ x · z + y · z
·DistL+ x y z = ·Comm (x + y) z ∙∙ ·DistR+ z x y ∙∙ cong₂ _+_ (·Comm z x) (·Comm z y)

-DistL· : (b c : ℤ) → - (b · c) ≡ - b · c
-DistL· (pos zero) c = refl
-DistL· (pos (suc n)) (pos m) = sym (negsuc·pos n m)
-DistL· (pos (suc zero)) (negsuc m) =
    -Dist+ (negsuc m) (pos zero · negsuc m)
  ∙ cong (pos (suc m) +_) (-DistL· (pos zero) (negsuc m))
-DistL· (pos (suc (suc n))) (negsuc m) =
    -Dist+ (negsuc m) (pos (suc n) · negsuc m)
  ∙ cong (pos (suc m) +_) (-DistL· (pos (suc n)) (negsuc m))
-DistL· (negsuc zero) c = -Involutive c
-DistL· (negsuc (suc n)) c =
   -Dist+ (- c) (negsuc n · c)
 ∙∙ cong (_+ (- (negsuc n · c))) (-Involutive c)
 ∙∙ cong (c +_) (-DistL· (negsuc n) c)

-DistR· : (b c : ℤ) → - (b · c) ≡ b · - c
-DistR· b c = cong (-_) (·Comm b c) ∙∙ -DistL· c b ∙∙ ·Comm (- c) b

·Assoc : (a b c : ℤ) → (a · (b · c)) ≡ ((a · b) · c)
·Assoc (pos zero) b c = refl
·Assoc (pos (suc n)) b c =
      cong ((b · c) +_) (·Assoc (pos n) b c)
   ∙∙ cong₂ _+_ (·Comm b c) (·Comm (pos n · b) c)
   ∙∙ sym (·DistR+ c b (pos n · b))
    ∙ sym (·Comm _ c)
·Assoc (negsuc zero) = -DistL·
·Assoc (negsuc (suc n)) b c =
     cong ((- (b · c)) +_) (·Assoc (negsuc n) b c)
  ∙∙ cong (_+ ((negsuc n · b) · c)) (-DistL· b c)
  ∙∙ sym (·DistL+ (- b) (negsuc n · b) c)

minus≡0- : (x : ℤ) → - x ≡ (0 - x)
minus≡0- x = +Comm (- x) 0

-- Absolute values
abs→⊎ : (x : ℤ) (n : ℕ) → abs x ≡ n → (x ≡ pos n) ⊎ (x ≡ - pos n)
abs→⊎ x n = J (λ n _ → (x ≡ pos n) ⊎ (x ≡ - pos n)) (help x)
  where
  help : (x : ℤ) → (x ≡ pos (abs x)) ⊎ (x ≡ - pos (abs x))
  help (pos n) = inl refl
  help (negsuc n) = inr refl

⊎→abs : (x : ℤ) (n : ℕ) → (x ≡ pos n) ⊎ (x ≡ - pos n) → abs x ≡ n
⊎→abs (pos n₁) n (inl x₁) = cong abs x₁
⊎→abs (negsuc n₁) n (inl x₁) = cong abs x₁
⊎→abs x zero (inr x₁) = cong abs x₁
⊎→abs x (suc n) (inr x₁) = cong abs x₁


-- This code is based on https://github.com/agda/agda-stdlib/pull/800/files

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

module Experiment.Categories.Solver.Category.Reflection where

open import Data.Nat
open import Data.List
open import Data.Maybe using (Maybe; nothing; just; maybe)
open import Data.Product
open import Data.Bool
open import Function using (_⟨_⟩_)
open import Agda.Builtin.Reflection as Builtin

open import Categories.Category

open import Experiment.Categories.Solver.Category hiding (solve)

_==_ = Builtin.primQNameEquality
{-# INLINE _==_ #-}

_>>=_ = bindTC
{-# INLINE _>>=_ #-}

infixr 5 _⟨∷⟩_ _⟅∷⟆_
pattern _⟨∷⟩_ x xs = arg (arg-info visible relevant) x ∷ xs
pattern _⟅∷⟆_ x xs = arg (arg-info hidden  relevant) x ∷ xs

infixr 5 _⋯⟅∷⟆_
_⋯⟅∷⟆_ : ℕ → List (Arg Term) → List (Arg Term)
zero  ⋯⟅∷⟆ xs = xs
suc i ⋯⟅∷⟆ xs = unknown ⟅∷⟆ i ⋯⟅∷⟆ xs
{-# INLINE _⋯⟅∷⟆_ #-}

getName : Term → Maybe Name
getName (con c args) = just c
getName (def f args) = just f
getName _            = nothing

getArgs : Term → Maybe (Term × Term)
getArgs (def _ xs) = go xs
  where
  go : List (Arg Term) → Maybe (Term × Term)
  go (x ⟨∷⟩ y ⟨∷⟩ []) = just (x , y)
  go (x ∷ xs)         = go xs
  go _                = nothing
getArgs _ = nothing

record CategoryNames : Set where
  field
    is-∘  : Name → Bool
    is-id : Name → Bool

findCategoryNames : Term → TC CategoryNames
findCategoryNames cat = do
  ∘-name ← normalise (quote Category._∘_ ⟨ def ⟩ 2 ⋯⟅∷⟆ cat ⟨∷⟩ [])
  id-name ← normalise (quote Category.id ⟨ def ⟩ 2 ⋯⟅∷⟆ cat ⟨∷⟩ [])
  returnTC record
    { is-∘  = buildMatcher (quote Category._∘_) (getName ∘-name)
    ; is-id = buildMatcher (quote Category.id) (getName id-name)
    }
  where
    buildMatcher : Name → Maybe Name → Name → Bool
    buildMatcher n = maybe (λ m x → n == x ∨ m == x) (n ==_)

:id′ : Term
:id′ = quote :id ⟨ con ⟩ []

∥_∥′ : Term → Term
∥_∥′ t = quote ∥_∥ ⟨ con ⟩ (t ⟨∷⟩ [])

module _ (names : CategoryNames) where
  open CategoryNames names

  :∘′ : List (Arg Term) → Term
  E′ : Term → Term

  :∘′ (x ⟨∷⟩ y ⟨∷⟩ []) = quote _:∘_ ⟨ con ⟩ E′ x ⟨∷⟩ E′ y ⟨∷⟩ []
  :∘′ (x ∷ xs)          = :∘′ xs
  :∘′ _                 = unknown

  E′ t@(def n xs) = if is-∘ n
    then :∘′ xs
    else if is-id n
      then :id′
      else ∥ t ∥′
  E′ t@(con n xs) = if is-∘ n
    then :∘′ xs
    else if is-id n
     then :id′
     else ∥ t ∥′
  E′ t = ∥ t ∥′

constructSoln : Term → CategoryNames → Term → Term → Term
constructSoln cat names lhs rhs =
  quote Category.Equiv.trans ⟨ def ⟩ 2 ⋯⟅∷⟆ cat ⟨∷⟩
  (quote Category.Equiv.sym ⟨ def ⟩ 2 ⋯⟅∷⟆ cat ⟨∷⟩
     (quote ⟦e⟧N≈⟦e⟧ ⟨ def ⟩ 2 ⋯⟅∷⟆ cat ⟨∷⟩ E′ names lhs ⟨∷⟩ []) ⟨∷⟩ [])
  ⟨∷⟩
  (quote ⟦e⟧N≈⟦e⟧ ⟨ def ⟩ 2 ⋯⟅∷⟆ cat ⟨∷⟩ E′ names rhs ⟨∷⟩ []) ⟨∷⟩
  []

macro
  solve : Term → Term → TC _
  solve cat = λ hole → do
    hole′ ← inferType hole >>= normalise
    names ← findCategoryNames cat
    just (lhs , rhs) ← returnTC (getArgs hole′)
      where nothing → typeError (termErr hole′ ∷ [])
    let soln = constructSoln cat names lhs rhs
    unify hole soln

-- Example
module _ {o l e} (C : Category o l e) where
  open Category C
  _ : ∀ {A B C D} {f : A ⇒ B} {g : B ⇒ C} {h : C ⇒ D} →
      (h ∘ id ∘ g) ∘ f ≈ id ∘ h ∘ (g ∘ f ∘ id)
  _ = solve C

  _ : ∀ {A} {f g h i j : A ⇒ A} →
      id ∘ (f ∘ id ∘ g) ∘ id ∘ (h ∘ id ∘ i) ∘ id ∘ j ≈ f ∘ (g ∘ h) ∘ (i ∘ j)
  _ = solve C


------------------------------------------------------------------------------
-- Totality properties respect to OrdTree
------------------------------------------------------------------------------

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

module FOTC.Program.SortList.Properties.Totality.OrdTreeI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Data.Bool
open import FOTC.Data.Bool.PropertiesI
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesI
open import FOTC.Data.Nat.List.Type
open import FOTC.Data.Nat.Type
open import FOTC.Program.SortList.SortList
open import FOTC.Program.SortList.Properties.Totality.BoolI
open import FOTC.Program.SortList.Properties.Totality.TreeI

------------------------------------------------------------------------------
-- Subtrees

-- If (node t₁ i t₂) is ordered then t₁ is ordered.
leftSubTree-OrdTree : ∀ {t₁ i t₂} → Tree t₁ → N i → Tree t₂ →
                      OrdTree (node t₁ i t₂) → OrdTree t₁
leftSubTree-OrdTree {t₁} {i} {t₂} Tt₁ Ni Tt₂ TOnode =
  ordTree t₁
    ≡⟨ &&-list₂-t₁ (ordTree-Bool Tt₁)
                   (&&-Bool (ordTree-Bool Tt₂)
                            (&&-Bool (le-TreeItem-Bool Tt₁ Ni)
                                     (le-ItemTree-Bool Ni Tt₂)))
                   (trans (sym (ordTree-node t₁ i t₂)) TOnode)
    ⟩
  true ∎

-- If (node t₁ i t₂) is ordered then t₂ is ordered.
rightSubTree-OrdTree : ∀ {t₁ i t₂} → Tree t₁ → N i → Tree t₂ →
                       OrdTree (node t₁ i t₂) → OrdTree t₂
rightSubTree-OrdTree {t₁} {i} {t₂} Tt₁ Ni Tt₂ TOnode =
  ordTree t₂
    ≡⟨ &&-list₂-t₁
       (ordTree-Bool Tt₂)
         (&&-Bool (le-TreeItem-Bool Tt₁ Ni)
                  (le-ItemTree-Bool Ni Tt₂))
         (&&-list₂-t₂ (ordTree-Bool Tt₁)
                      (&&-Bool (ordTree-Bool Tt₂)
                               (&&-Bool (le-TreeItem-Bool Tt₁ Ni)
                                        (le-ItemTree-Bool Ni Tt₂)))
                      (trans (sym (ordTree-node t₁ i t₂)) TOnode))
    ⟩
  true ∎

------------------------------------------------------------------------------
-- Helper functions

toTree-OrdTree-helper₁ : ∀ {i₁ i₂ t} → N i₁ → N i₂ → i₁ > i₂ →
                         Tree t →
                         ≤-TreeItem t i₁ →
                         ≤-TreeItem (toTree · i₂ · t) i₁
toTree-OrdTree-helper₁ {i₁} {i₂} .{nil} Ni₁ Ni₂ i₁>i₂ tnil _ =
  le-TreeItem (toTree · i₂ · nil) i₁
    ≡⟨ subst (λ t → le-TreeItem (toTree · i₂ · nil) i₁ ≡ le-TreeItem t i₁)
             (toTree-nil i₂)
             refl
    ⟩
  le-TreeItem (tip i₂) i₁
    ≡⟨ le-TreeItem-tip i₂ i₁ ⟩
  le i₂ i₁
    ≡⟨ x<y→x≤y Ni₂ Ni₁ i₁>i₂ ⟩
  true ∎

toTree-OrdTree-helper₁ {i₁} {i₂} Ni₁ Ni₂ i₁>i₂ (ttip {j} Nj) t≤i₁ =
  case prf₁ prf₂ (x>y∨x≤y Nj Ni₂)
  where
  prf₁ : j > i₂ → ≤-TreeItem (toTree · i₂ · tip j) i₁
  prf₁ j>i₂ =
    le-TreeItem (toTree · i₂ · tip j) i₁
      ≡⟨ subst (λ t → le-TreeItem (toTree · i₂ · tip j) i₁ ≡
                      le-TreeItem t i₁)
               (toTree-tip i₂ j)
               refl
      ⟩
    le-TreeItem (if (le j i₂)
                   then (node (tip j) i₂ (tip i₂))
                   else (node (tip i₂) j (tip j))) i₁
      ≡⟨ subst (λ t → le-TreeItem
                      (if (le j i₂)
                         then (node (tip j) i₂ (tip i₂))
                         else (node (tip i₂) j (tip j))) i₁ ≡
                      le-TreeItem (if t
                                     then (node (tip j) i₂ (tip i₂))
                                     else (node (tip i₂) j (tip j))) i₁)
               (x>y→x≰y Nj Ni₂ j>i₂)
               refl
      ⟩
    le-TreeItem (if false
                   then (node (tip j) i₂ (tip i₂))
                   else (node (tip i₂) j (tip j))) i₁
      ≡⟨ subst (λ t → le-TreeItem (if false
                                     then (node (tip j) i₂ (tip i₂))
                                     else (node (tip i₂) j (tip j))) i₁ ≡
                      le-TreeItem t i₁)
               (if-false (node (tip i₂) j (tip j)))
               refl
      ⟩
    le-TreeItem (node (tip i₂) j (tip j)) i₁
      ≡⟨ le-TreeItem-node (tip i₂) j (tip j) i₁ ⟩
    le-TreeItem (tip i₂) i₁ && le-TreeItem (tip j) i₁
      ≡⟨ subst (λ t → le-TreeItem (tip i₂) i₁ && le-TreeItem (tip j) i₁ ≡
                      t && le-TreeItem (tip j) i₁)
               (le-TreeItem-tip i₂ i₁)
               refl
      ⟩
    le i₂ i₁ && le-TreeItem (tip j) i₁
       ≡⟨ subst (λ t → le i₂ i₁ && le-TreeItem (tip j) i₁ ≡
                       t && le-TreeItem (tip j) i₁)
                (x<y→x≤y Ni₂ Ni₁ i₁>i₂)
                refl
       ⟩
    true && le-TreeItem (tip j) i₁
      ≡⟨ subst (λ t → true && le-TreeItem (tip j) i₁ ≡ true && t)
               (le-TreeItem-tip j i₁)
               refl
      ⟩
    true && le j i₁
      ≡⟨ subst (λ t → true && le j i₁ ≡ true && t)
               -- j ≤ i₁ because by hypothesis we have (tip j) ≤ i₁.
               (trans (sym (le-TreeItem-tip j i₁)) t≤i₁)
               refl
      ⟩
    true && true
      ≡⟨ t&&x≡x true ⟩
    true ∎

  prf₂ : j ≤ i₂ → ≤-TreeItem (toTree · i₂ · tip j) i₁
  prf₂ j≤i₂ =
    le-TreeItem (toTree · i₂ · tip j) i₁
      ≡⟨ subst (λ t → le-TreeItem (toTree · i₂ · tip j) i₁ ≡
                      le-TreeItem t i₁)
               (toTree-tip i₂ j)
               refl
      ⟩
    le-TreeItem (if (le j i₂)
                   then (node (tip j) i₂ (tip i₂))
                   else (node (tip i₂) j (tip j))) i₁
      ≡⟨ subst (λ t → le-TreeItem
                      (if (le j i₂)
                         then (node (tip j) i₂ (tip i₂))
                         else (node (tip i₂) j (tip j))) i₁ ≡
                      le-TreeItem (if t
                                     then (node (tip j) i₂ (tip i₂))
                                     else (node (tip i₂) j (tip j))) i₁)
               j≤i₂
               refl
      ⟩
    le-TreeItem (if true
                   then (node (tip j) i₂ (tip i₂))
                   else (node (tip i₂) j (tip j))) i₁
      ≡⟨ subst (λ t → le-TreeItem (if true
                                     then (node (tip j) i₂ (tip i₂))
                                     else (node (tip i₂) j (tip j))) i₁ ≡
                      le-TreeItem t i₁)
               (if-true (node (tip j) i₂ (tip i₂)))
               refl
         ⟩
    le-TreeItem (node (tip j) i₂ (tip i₂)) i₁
      ≡⟨ le-TreeItem-node (tip j) i₂ (tip i₂) i₁ ⟩
    le-TreeItem (tip j) i₁ && le-TreeItem (tip i₂) i₁
      ≡⟨ subst (λ t → le-TreeItem (tip j) i₁ && le-TreeItem (tip i₂) i₁ ≡
                      t && le-TreeItem (tip i₂) i₁)
               (le-TreeItem-tip j i₁)
               refl
      ⟩
    le j i₁ && le-TreeItem (tip i₂) i₁
      ≡⟨ subst (λ t → le j i₁ && le-TreeItem (tip i₂) i₁ ≡
                      t && le-TreeItem (tip i₂) i₁)
               -- j ≤ i₁ because by hypothesis we have (tip j) ≤ i₁.
               (trans (sym (le-TreeItem-tip j i₁)) t≤i₁)
               refl
      ⟩
    true && le-TreeItem (tip i₂) i₁
      ≡⟨ subst (λ t → true && le-TreeItem (tip i₂) i₁ ≡ true && t)
               (le-TreeItem-tip i₂ i₁)
               refl
      ⟩
    true && le i₂ i₁
      ≡⟨ subst (λ t → true && le i₂ i₁ ≡ true && t)
               (x<y→x≤y Ni₂ Ni₁ i₁>i₂)
               refl
      ⟩
    true && true
      ≡⟨ t&&x≡x true ⟩
    true ∎

toTree-OrdTree-helper₁ {i₁} {i₂} Ni₁ Ni₂ i₁>i₂
                       (tnode {t₁} {j} {t₂} Tt₁ Nj Tt₂) t≤i₁ =
  case prf₁ prf₂ (x>y∨x≤y Nj Ni₂)
  where
  prf₁ : j > i₂ → ≤-TreeItem (toTree · i₂ · node t₁ j t₂) i₁
  prf₁ j>i₂ =
    le-TreeItem (toTree · i₂ · node t₁ j t₂) i₁
      ≡⟨ subst (λ t → le-TreeItem (toTree · i₂ · node t₁ j t₂) i₁ ≡
                      le-TreeItem t i₁)
               (toTree-node i₂ t₁ j t₂)
               refl
      ⟩
    le-TreeItem (if (le j i₂)
                   then (node t₁ j (toTree · i₂ · t₂))
                   else (node (toTree · i₂ · t₁) j t₂)) i₁
      ≡⟨ subst (λ t → le-TreeItem
                        (if (le j i₂)
                           then (node t₁ j (toTree · i₂ · t₂))
                           else (node (toTree · i₂ · t₁) j t₂)) i₁ ≡
                      le-TreeItem
                        (if t
                           then (node t₁ j (toTree · i₂ · t₂))
                           else (node (toTree · i₂ · t₁) j t₂)) i₁)
               (x>y→x≰y Nj Ni₂ j>i₂)
               refl
      ⟩
    le-TreeItem (if false
                   then (node t₁ j (toTree · i₂ · t₂))
                   else (node (toTree · i₂ · t₁) j t₂)) i₁
      ≡⟨ subst (λ t → le-TreeItem (if false
                                     then (node t₁ j (toTree · i₂ · t₂))
                                     else (node (toTree · i₂ · t₁) j t₂)) i₁ ≡
                      le-TreeItem t i₁)
               (if-false (node (toTree · i₂ · t₁) j t₂))
               refl
      ⟩
    le-TreeItem (node (toTree · i₂ · t₁) j t₂) i₁
      ≡⟨ le-TreeItem-node (toTree · i₂ · t₁) j t₂ i₁ ⟩
    le-TreeItem (toTree · i₂ · t₁) i₁ && le-TreeItem t₂ i₁
      ≡⟨ subst (λ t → le-TreeItem (toTree · i₂ · t₁) i₁ &&
                      le-TreeItem t₂ i₁                 ≡
                      t                                &&
                      le-TreeItem t₂ i₁)
               -- Inductive hypothesis.
               (toTree-OrdTree-helper₁ Ni₁ Ni₂ i₁>i₂ Tt₁
                 (&&-list₂-t₁ (le-TreeItem-Bool Tt₁ Ni₁)
                              (le-TreeItem-Bool Tt₂ Ni₁)
                              (trans (sym (le-TreeItem-node t₁ j t₂ i₁)) t≤i₁)))
               refl
      ⟩
    true && le-TreeItem t₂ i₁
      ≡⟨ subst (λ t → true && le-TreeItem t₂ i₁ ≡ true && t)
               -- t₂ ≤ i₁ because by hypothesis we have (node t₁ j t₂) ≤ i₁.
               (&&-list₂-t₂ (le-TreeItem-Bool Tt₁ Ni₁)
                            (le-TreeItem-Bool Tt₂ Ni₁)
                            (trans (sym (le-TreeItem-node t₁ j t₂ i₁)) t≤i₁))
               refl
      ⟩
    true && true
      ≡⟨ t&&x≡x true ⟩
    true ∎

  prf₂ : j ≤ i₂ → ≤-TreeItem (toTree · i₂ · node t₁ j t₂) i₁
  prf₂ j≤i₂ =
    le-TreeItem (toTree · i₂ · node t₁ j t₂) i₁
      ≡⟨ subst (λ t → le-TreeItem (toTree · i₂ · node t₁ j t₂) i₁ ≡
                      le-TreeItem t i₁)
               (toTree-node i₂ t₁ j t₂)
               refl
      ⟩
    le-TreeItem (if (le j i₂)
                   then (node t₁ j (toTree · i₂ · t₂))
                   else (node (toTree · i₂ · t₁) j t₂)) i₁
      ≡⟨ subst (λ t → le-TreeItem
                        (if (le j i₂)
                           then (node t₁ j (toTree · i₂ · t₂))
                           else (node (toTree · i₂ · t₁) j t₂)) i₁ ≡
                      le-TreeItem
                        (if t
                           then (node t₁ j (toTree · i₂ · t₂))
                           else (node (toTree · i₂ · t₁) j t₂)) i₁)
               (j≤i₂)
               refl
      ⟩
    le-TreeItem (if true
                   then (node t₁ j (toTree · i₂ · t₂))
                   else (node (toTree · i₂ · t₁) j t₂)) i₁
      ≡⟨ subst (λ t → le-TreeItem (if true
                                     then (node t₁ j (toTree · i₂ · t₂))
                                     else (node (toTree · i₂ · t₁) j t₂)) i₁ ≡
                      le-TreeItem t i₁)
               (if-true (node t₁ j (toTree · i₂ · t₂)))
               refl
      ⟩
    le-TreeItem (node t₁ j (toTree · i₂ · t₂)) i₁
      ≡⟨ le-TreeItem-node t₁ j (toTree · i₂ · t₂) i₁ ⟩
    le-TreeItem t₁ i₁ && le-TreeItem (toTree · i₂ · t₂) i₁
      ≡⟨ subst (λ t → le-TreeItem t₁ i₁ && le-TreeItem (toTree · i₂ · t₂) i₁ ≡
                      t &&  le-TreeItem (toTree · i₂ · t₂) i₁)
               -- t₁ ≤ i₁ because by hypothesis we have (node t₁ j t₂) ≤ i₁.
               (&&-list₂-t₁ (le-TreeItem-Bool Tt₁ Ni₁)
                            (le-TreeItem-Bool Tt₂ Ni₁)
                            (trans (sym (le-TreeItem-node t₁ j t₂ i₁)) t≤i₁))
               refl
      ⟩
    true && le-TreeItem (toTree · i₂ · t₂) i₁
      ≡⟨ subst (λ t → true && le-TreeItem (toTree · i₂ · t₂) i₁ ≡
                      true && t)
               -- Inductive hypothesis.
               (toTree-OrdTree-helper₁ Ni₁ Ni₂ i₁>i₂ Tt₂
                 (&&-list₂-t₂ (le-TreeItem-Bool Tt₁ Ni₁)
                              (le-TreeItem-Bool Tt₂ Ni₁)
                              (trans (sym (le-TreeItem-node t₁ j t₂ i₁)) t≤i₁)))
               refl
      ⟩
    true && true
      ≡⟨ t&&x≡x true ⟩
    true ∎

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

toTree-OrdTree-helper₂ : ∀ {i₁ i₂ t} → N i₁ → N i₂ → i₁ ≤ i₂ →
                         Tree t →
                         ≤-ItemTree i₁ t →
                         ≤-ItemTree i₁ (toTree · i₂ · t)
toTree-OrdTree-helper₂ {i₁} {i₂} .{nil} _ _ i₁≤i₂ tnil _ =
  le-ItemTree i₁ (toTree · i₂ · nil)
    ≡⟨ subst (λ t → le-ItemTree i₁ (toTree · i₂ · nil) ≡ le-ItemTree i₁ t)
             (toTree-nil i₂)
             refl
    ⟩
  le-ItemTree i₁ (tip i₂)
    ≡⟨ le-ItemTree-tip i₁ i₂ ⟩
  le i₁ i₂
    ≡⟨ i₁≤i₂ ⟩
  true ∎

toTree-OrdTree-helper₂ {i₁} {i₂} Ni₁ Ni₂ i₁≤i₂ (ttip {j} Nj) i₁≤t =
  case prf₁ prf₂ (x>y∨x≤y Nj Ni₂)
  where
  prf₁ : j > i₂ → ≤-ItemTree i₁ (toTree · i₂ · tip j)
  prf₁ j>i₂ =
    le-ItemTree i₁ (toTree · i₂ · tip j)
      ≡⟨ subst (λ t → le-ItemTree i₁ (toTree · i₂ · tip j) ≡
                      le-ItemTree i₁ t)
               (toTree-tip i₂ j)
               refl
      ⟩
    le-ItemTree i₁ (if (le j i₂)
                      then (node (tip j) i₂ (tip i₂))
                      else (node (tip i₂) j (tip j)))
      ≡⟨ subst (λ t → le-ItemTree i₁ (if (le j i₂)
                                        then (node (tip j) i₂ (tip i₂))
                                        else (node (tip i₂) j (tip j))) ≡
                      le-ItemTree i₁ (if t
                                        then (node (tip j) i₂ (tip i₂))
                                        else (node (tip i₂) j (tip j))))
             (x>y→x≰y Nj Ni₂ j>i₂)
             refl
       ⟩
    le-ItemTree i₁ (if false
                      then (node (tip j) i₂ (tip i₂))
                      else (node (tip i₂) j (tip j)))
    ≡⟨ subst (λ t → le-ItemTree i₁ (if false
                                      then (node (tip j) i₂ (tip i₂))
                                      else (node (tip i₂) j (tip j))) ≡
                    le-ItemTree i₁ t)
                (if-false (node (tip i₂) j (tip j)))
                refl
       ⟩
    le-ItemTree i₁ (node (tip i₂) j (tip j))
      ≡⟨ le-ItemTree-node i₁ (tip i₂) j (tip j) ⟩
    le-ItemTree i₁ (tip i₂) && le-ItemTree i₁ (tip j)
      ≡⟨ subst (λ t → le-ItemTree i₁ (tip i₂) && le-ItemTree i₁ (tip j) ≡
                      t && le-ItemTree i₁ (tip j))
               (le-ItemTree-tip i₁ i₂)
               refl
      ⟩
    le i₁ i₂ && le-ItemTree i₁ (tip j)
       ≡⟨ subst (λ t → le i₁ i₂ && le-ItemTree i₁ (tip j) ≡
                       t && le-ItemTree i₁ (tip j))
                i₁≤i₂
                refl
        ⟩
    true && le-ItemTree i₁ (tip j)
      ≡⟨ subst (λ t → true && le-ItemTree i₁ (tip j) ≡ true && t)
               (le-ItemTree-tip i₁ j)
               refl
      ⟩
    true && le i₁ j
      ≡⟨ subst (λ t → true && le i₁ j ≡ true && t)
               -- i₁ ≤ j because by hypothesis we have i₁ ≤ (tip j).
               (trans (sym (le-ItemTree-tip i₁ j)) i₁≤t)
               refl
      ⟩
    true && true
      ≡⟨ t&&x≡x true ⟩
    true ∎

  prf₂ : j ≤ i₂ → ≤-ItemTree i₁ (toTree · i₂ · tip j)
  prf₂ j≤i₂ =
    le-ItemTree i₁ (toTree · i₂ · tip j)
      ≡⟨ subst (λ t → le-ItemTree i₁ (toTree · i₂ · tip j) ≡
                      le-ItemTree i₁ t)
               (toTree-tip i₂ j)
               refl
      ⟩
    le-ItemTree i₁ (if (le j i₂)
                      then (node (tip j) i₂ (tip i₂))
                      else (node (tip i₂) j (tip j)))
      ≡⟨ subst (λ t → le-ItemTree i₁ (if (le j i₂)
                                        then (node (tip j) i₂ (tip i₂))
                                        else (node (tip i₂) j (tip j))) ≡
                      le-ItemTree i₁ (if t
                                        then (node (tip j) i₂ (tip i₂))
                                        else (node (tip i₂) j (tip j))))
               j≤i₂
               refl
        ⟩
    le-ItemTree i₁ (if true
                      then (node (tip j) i₂ (tip i₂))
                      else (node (tip i₂) j (tip j)))
      ≡⟨ subst (λ t → le-ItemTree i₁ (if true
                                        then (node (tip j) i₂ (tip i₂))
                                        else (node (tip i₂) j (tip j))) ≡
                      le-ItemTree i₁ t)
               (if-true (node (tip j) i₂ (tip i₂)))
               refl
      ⟩
    le-ItemTree i₁ (node (tip j) i₂ (tip i₂))
      ≡⟨ le-ItemTree-node i₁ (tip j) i₂ (tip i₂) ⟩
    le-ItemTree i₁ (tip j) && le-ItemTree i₁ (tip i₂)
      ≡⟨ subst (λ t → le-ItemTree i₁ (tip j) && le-ItemTree i₁ (tip i₂) ≡
                      t && le-ItemTree i₁ (tip i₂))
               (le-ItemTree-tip i₁ j)
               refl
      ⟩
    le i₁ j && le-ItemTree i₁ (tip i₂)
       ≡⟨ subst (λ t → le i₁ j && le-ItemTree i₁ (tip i₂) ≡
                       t && le-ItemTree i₁ (tip i₂))
          -- i₁ ≤ j because by hypothesis we have i₁ ≤ (tip j).
                (trans (sym (le-ItemTree-tip i₁ j)) i₁≤t)
                refl
       ⟩
    true && le-ItemTree i₁ (tip i₂)
      ≡⟨ subst (λ t → true && le-ItemTree i₁ (tip i₂) ≡ true && t)
               (le-ItemTree-tip i₁ i₂)
               refl
      ⟩
      true && le i₁ i₂
      ≡⟨ subst (λ t → true && le i₁ i₂ ≡ true && t)
               i₁≤i₂
               refl
      ⟩
    true && true
      ≡⟨ t&&x≡x true ⟩
    true ∎

toTree-OrdTree-helper₂ {i₁} {i₂} Ni₁ Ni₂ i₁≤i₂
                       (tnode {t₁} {j} {t₂} Tt₁ Nj Tt₂) i₁≤t =
  case prf₁ prf₂ (x>y∨x≤y Nj Ni₂)
  where
  prf₁ : j > i₂ → ≤-ItemTree i₁ (toTree · i₂ · node t₁ j t₂)
  prf₁ j>i₂ =
    le-ItemTree i₁ (toTree · i₂ · node t₁ j t₂)
      ≡⟨ subst (λ t → le-ItemTree i₁ (toTree · i₂ · node t₁ j t₂) ≡
                      le-ItemTree i₁ t)
               (toTree-node i₂ t₁ j t₂)
               refl
      ⟩
    le-ItemTree i₁ (if (le j i₂)
                      then (node t₁ j (toTree · i₂ · t₂))
                      else (node (toTree · i₂ · t₁) j t₂))
    ≡⟨ subst (λ t → le-ItemTree i₁ (if (le j i₂)
                                      then (node t₁ j (toTree · i₂ · t₂))
                                      else (node (toTree · i₂ · t₁) j t₂)) ≡
                    le-ItemTree i₁ (if t
                                      then (node t₁ j (toTree · i₂ · t₂))
                                      else (node (toTree · i₂ · t₁) j t₂)))
                (x>y→x≰y Nj Ni₂ j>i₂)
                refl
       ⟩
    le-ItemTree i₁ (if false
                      then (node t₁ j (toTree · i₂ · t₂))
                      else (node (toTree · i₂ · t₁) j t₂))
      ≡⟨ subst (λ t → le-ItemTree i₁ (if false
                                        then (node t₁ j (toTree · i₂ · t₂))
                                        else (node (toTree · i₂ · t₁) j t₂)) ≡
                      le-ItemTree i₁ t)
               (if-false (node (toTree · i₂ · t₁) j t₂))
               refl
      ⟩
    le-ItemTree i₁ (node (toTree · i₂ · t₁) j t₂)
      ≡⟨ le-ItemTree-node i₁ (toTree · i₂ · t₁) j t₂ ⟩
      le-ItemTree i₁ (toTree · i₂ · t₁) && le-ItemTree i₁ t₂
      ≡⟨ subst (λ t → le-ItemTree i₁ (toTree · i₂ · t₁) && le-ItemTree i₁ t₂ ≡
                      t && le-ItemTree i₁ t₂)
               -- Inductive hypothesis.
               (toTree-OrdTree-helper₂ Ni₁ Ni₂ i₁≤i₂ Tt₁
                 (&&-list₂-t₁ (le-ItemTree-Bool Ni₁ Tt₁)
                              (le-ItemTree-Bool Ni₁ Tt₂)
                              (trans (sym (le-ItemTree-node i₁ t₁ j t₂)) i₁≤t)))
               refl
      ⟩
    true && le-ItemTree i₁ t₂
      ≡⟨ subst (λ t → true && le-ItemTree i₁ t₂ ≡ true && t)
               -- i₁ ≤ t₂ because by hypothesis we have i₁ ≤ (node t₁ j t₂).
               (&&-list₂-t₂ (le-ItemTree-Bool Ni₁ Tt₁)
                            (le-ItemTree-Bool Ni₁ Tt₂)
                            (trans (sym (le-ItemTree-node i₁ t₁ j t₂)) i₁≤t))
               refl
      ⟩
    true && true
      ≡⟨ t&&x≡x true ⟩
    true ∎

  prf₂ : j ≤ i₂ → ≤-ItemTree i₁ (toTree · i₂ · node t₁ j t₂)
  prf₂ j≤i₂ =
    le-ItemTree i₁ (toTree · i₂ · node t₁ j t₂)
      ≡⟨ subst (λ t → le-ItemTree i₁ (toTree · i₂ · node t₁ j t₂) ≡
                      le-ItemTree i₁ t)
               (toTree-node i₂ t₁ j t₂)
               refl
      ⟩
    le-ItemTree i₁ (if (le j i₂)
                      then (node t₁ j (toTree · i₂ · t₂))
                      else (node (toTree · i₂ · t₁) j t₂))
    ≡⟨ subst (λ t → le-ItemTree i₁ (if (le j i₂)
                                      then (node t₁ j (toTree · i₂ · t₂))
                                      else (node (toTree · i₂ · t₁) j t₂)) ≡
                    le-ItemTree i₁ (if t
                                      then (node t₁ j (toTree · i₂ · t₂))
                                      else (node (toTree · i₂ · t₁) j t₂)))
                j≤i₂
                refl
       ⟩
    le-ItemTree i₁ (if true
                      then (node t₁ j (toTree · i₂ · t₂))
                      else (node (toTree · i₂ · t₁) j t₂))
      ≡⟨ subst (λ t → le-ItemTree i₁ (if true
                                        then (node t₁ j (toTree · i₂ · t₂))
                                        else (node (toTree · i₂ · t₁) j t₂)) ≡
                      le-ItemTree i₁ t)
               (if-true (node t₁ j (toTree · i₂ · t₂)))
               refl
      ⟩
    le-ItemTree i₁ (node t₁ j (toTree · i₂ · t₂))
      ≡⟨ le-ItemTree-node i₁ t₁ j (toTree · i₂ · t₂) ⟩
    le-ItemTree i₁ t₁ && le-ItemTree i₁ (toTree · i₂ · t₂)
      ≡⟨ subst (λ t → le-ItemTree i₁ t₁ && le-ItemTree i₁ (toTree · i₂ · t₂) ≡
                      t && le-ItemTree i₁ (toTree · i₂ · t₂))
               -- i₁ ≤ t₁ because by hypothesis we have i₁ ≤ (node t₁ j t₂).
               (&&-list₂-t₁ (le-ItemTree-Bool Ni₁ Tt₁)
                            (le-ItemTree-Bool Ni₁ Tt₂)
                            (trans (sym (le-ItemTree-node i₁ t₁ j t₂)) i₁≤t))
               refl
      ⟩
    true && le-ItemTree i₁ (toTree · i₂ · t₂)
      ≡⟨ subst (λ t → true && le-ItemTree i₁ (toTree · i₂ · t₂) ≡ true && t)
               -- Inductive hypothesis.
               (toTree-OrdTree-helper₂ Ni₁ Ni₂ i₁≤i₂ Tt₂
                 (&&-list₂-t₂ (le-ItemTree-Bool Ni₁ Tt₁)
                              (le-ItemTree-Bool Ni₁ Tt₂)
                              (trans (sym (le-ItemTree-node i₁ t₁ j t₂)) i₁≤t)))
               refl
      ⟩
    true && true
      ≡⟨ t&&x≡x true ⟩
    true ∎


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

module Data.Binary.Addition.Properties where

open import Prelude
open import Data.Binary.Definition
open import Data.Binary.Addition
open import Data.Binary.Conversion
import Data.Nat as ℕ
import Data.Nat.Properties as ℕ
open import Path.Reasoning
open import Data.Binary.Isomorphism

+-cong : ∀ xs ys → ⟦ xs + ys ⇓⟧ ≡ ⟦ xs ⇓⟧ ℕ.+ ⟦ ys ⇓⟧
add₁-cong : ∀ xs ys → ⟦ add₁ xs ys ⇓⟧ ≡ 1 ℕ.+ ⟦ xs ⇓⟧ ℕ.+ ⟦ ys ⇓⟧
add₂-cong : ∀ xs ys → ⟦ add₂ xs ys ⇓⟧ ≡ 2 ℕ.+ ⟦ xs ⇓⟧ ℕ.+ ⟦ ys ⇓⟧

lemma₁ : ∀ xs ys → ⟦ add₁ xs ys ⇓⟧ ℕ.* 2 ≡ ⟦ xs ⇓⟧ ℕ.* 2 ℕ.+ (2 ℕ.+ ⟦ ys ⇓⟧ ℕ.* 2)
lemma₁ xs ys =
  ⟦ add₁ xs ys ⇓⟧ ℕ.* 2 ≡⟨ cong (ℕ._* 2) (add₁-cong xs ys) ⟩
  2 ℕ.+ (⟦ xs ⇓⟧ ℕ.+ ⟦ ys ⇓⟧) ℕ.* 2 ≡⟨ cong (2 ℕ.+_ ) (ℕ.+-*-distrib ⟦ xs ⇓⟧ ⟦ ys ⇓⟧ 2) ⟩
  2 ℕ.+ ⟦ xs ⇓⟧ ℕ.* 2 ℕ.+ ⟦ ys ⇓⟧ ℕ.* 2 ≡⟨ cong (ℕ._+ (⟦ ys ⇓⟧ ℕ.* 2)) (ℕ.+-comm 2 (⟦ xs ⇓⟧ ℕ.* 2)) ⟩
  ⟦ xs ⇓⟧ ℕ.* 2 ℕ.+ 2 ℕ.+ ⟦ ys ⇓⟧ ℕ.* 2 ≡⟨ ℕ.+-assoc (⟦ xs ⇓⟧ ℕ.* 2) 2 (⟦ ys ⇓⟧ ℕ.* 2) ⟩
  ⟦ xs ⇓⟧ ℕ.* 2 ℕ.+ (2 ℕ.+ ⟦ ys ⇓⟧ ℕ.* 2) ∎

lemma₂ : ∀ xs ys → ⟦ add₁ xs ys ⇓⟧ ℕ.* 2 ≡ (1 ℕ.+ ⟦ xs ⇓⟧ ℕ.* 2) ℕ.+ (1 ℕ.+ ⟦ ys ⇓⟧ ℕ.* 2)
lemma₂ xs ys =
  ⟦ add₁ xs ys ⇓⟧ ℕ.* 2 ≡⟨ cong (ℕ._* 2) (add₁-cong xs ys) ⟩
  (1 ℕ.+ ⟦ xs ⇓⟧ ℕ.+ ⟦ ys ⇓⟧) ℕ.* 2 ≡⟨ ℕ.+-*-distrib (1 ℕ.+ ⟦ xs ⇓⟧) ⟦ ys ⇓⟧ 2 ⟩
  2 ℕ.+ ⟦ xs ⇓⟧ ℕ.* 2 ℕ.+ ⟦ ys ⇓⟧ ℕ.* 2 ≡˘⟨ ℕ.+-suc (1 ℕ.+ ⟦ xs ⇓⟧ ℕ.* 2) (⟦ ys ⇓⟧ ℕ.* 2) ⟩
  (1 ℕ.+ ⟦ xs ⇓⟧ ℕ.* 2) ℕ.+ (1 ℕ.+ ⟦ ys ⇓⟧ ℕ.* 2) ∎

lemma₃ : ∀ xs ys → ⟦ add₂ xs ys ⇓⟧ ℕ.* 2 ≡ suc (suc (⟦ xs ⇓⟧ ℕ.* 2 ℕ.+ suc (suc (⟦ ys ⇓⟧ ℕ.* 2))))
lemma₃ xs ys =
  ⟦ add₂ xs ys ⇓⟧ ℕ.* 2 ≡⟨ cong (ℕ._* 2) (add₂-cong xs ys) ⟩
  (2 ℕ.+ ⟦ xs ⇓⟧ ℕ.+ ⟦ ys ⇓⟧) ℕ.* 2 ≡˘⟨ cong (ℕ._* 2) (ℕ.+-suc (1 ℕ.+ ⟦ xs ⇓⟧) ⟦ ys ⇓⟧) ⟩
  ((1 ℕ.+ ⟦ xs ⇓⟧) ℕ.+ (1 ℕ.+ ⟦ ys ⇓⟧)) ℕ.* 2 ≡⟨ ℕ.+-*-distrib (1 ℕ.+ ⟦ xs ⇓⟧) (1 ℕ.+ ⟦ ys ⇓⟧) 2 ⟩
  suc (suc (⟦ xs ⇓⟧ ℕ.* 2 ℕ.+ suc (suc (⟦ ys ⇓⟧ ℕ.* 2)))) ∎

add₁-cong 0ᵇ ys = inc-suc ys
add₁-cong (1ᵇ xs) 0ᵇ = cong (2 ℕ.+_) (sym (ℕ.+-idʳ (⟦ xs ⇓⟧ ℕ.* 2)))
add₁-cong (2ᵇ xs) 0ᵇ = cong suc (cong (ℕ._* 2) (inc-suc xs) ; cong (2 ℕ.+_) (sym (ℕ.+-idʳ (⟦ xs ⇓⟧ ℕ.* 2))))
add₁-cong (1ᵇ xs) (1ᵇ ys) = cong suc (lemma₂ xs ys)
add₁-cong (1ᵇ xs) (2ᵇ ys) = cong (2 ℕ.+_) (lemma₁ xs ys)
add₁-cong (2ᵇ xs) (1ᵇ ys) = cong (2 ℕ.+_) (lemma₂ xs ys)
add₁-cong (2ᵇ xs) (2ᵇ ys) = cong (1 ℕ.+_) (lemma₃ xs ys)

add₂-cong 0ᵇ 0ᵇ = refl
add₂-cong 0ᵇ (1ᵇ ys) = cong (1 ℕ.+_) (cong (ℕ._* 2) (inc-suc ys))
add₂-cong 0ᵇ (2ᵇ ys) = cong (2 ℕ.+_) (cong (ℕ._* 2) (inc-suc ys))
add₂-cong (1ᵇ xs) 0ᵇ = cong (1 ℕ.+_) ((cong (ℕ._* 2) (inc-suc xs)) ; cong (2 ℕ.+_) (sym (ℕ.+-idʳ _)))
add₂-cong (2ᵇ xs) 0ᵇ = cong (2 ℕ.+_) ((cong (ℕ._* 2) (inc-suc xs)) ; cong (2 ℕ.+_) (sym (ℕ.+-idʳ _)))
add₂-cong (1ᵇ xs) (1ᵇ ys) = cong (2 ℕ.+_ ) (lemma₂ xs ys)
add₂-cong (1ᵇ xs) (2ᵇ ys) = cong (1 ℕ.+_) (lemma₃ xs ys)
add₂-cong (2ᵇ xs) (1ᵇ ys) = cong (1 ℕ.+_) (lemma₃ xs ys ; ℕ.+-suc (2 ℕ.+ ⟦ xs ⇓⟧ ℕ.* 2) (1 ℕ.+ ⟦ ys ⇓⟧ ℕ.* 2))
add₂-cong (2ᵇ xs) (2ᵇ ys) = cong (2 ℕ.+_) (lemma₃ xs ys)

+-cong 0ᵇ ys = refl
+-cong (1ᵇ xs) 0ᵇ = cong suc (sym (ℕ.+-idʳ (⟦ xs ⇓⟧ ℕ.* 2)))
+-cong (2ᵇ xs) 0ᵇ = cong (suc ∘ suc) (sym (ℕ.+-idʳ (⟦ xs ⇓⟧ ℕ.* 2)))
+-cong (1ᵇ xs) (1ᵇ ys) =
  2 ℕ.+ ⟦ xs + ys ⇓⟧ ℕ.* 2 ≡⟨ cong (λ xy → 2 ℕ.+ xy ℕ.* 2) (+-cong xs ys) ⟩
  2 ℕ.+ (⟦ xs ⇓⟧ ℕ.+ ⟦ ys ⇓⟧) ℕ.* 2 ≡⟨ cong (2 ℕ.+_) (ℕ.+-*-distrib ⟦ xs ⇓⟧ ⟦ ys ⇓⟧ 2) ⟩
  2 ℕ.+ (⟦ xs ⇓⟧ ℕ.* 2 ℕ.+ ⟦ ys ⇓⟧ ℕ.* 2) ≡˘⟨ cong suc (ℕ.+-suc (⟦ xs ⇓⟧ ℕ.* 2) (⟦ ys ⇓⟧ ℕ.* 2)) ⟩
  1 ℕ.+ ⟦ xs ⇓⟧ ℕ.* 2 ℕ.+ (1 ℕ.+ ⟦ ys ⇓⟧ ℕ.* 2) ∎
+-cong (1ᵇ xs) (2ᵇ ys) = cong suc (lemma₁ xs ys)
+-cong (2ᵇ xs) (1ᵇ ys) = cong suc (lemma₂ xs ys)
+-cong (2ᵇ xs) (2ᵇ ys) = cong (2 ℕ.+_) (lemma₁ xs ys)

+-cong˘ : ∀ xs ys → ⟦ xs ℕ.+ ys ⇑⟧ ≡ ⟦ xs ⇑⟧ + ⟦ ys ⇑⟧
+-cong˘ xs ys =
  ⟦ xs ℕ.+ ys ⇑⟧ ≡˘⟨ cong ⟦_⇑⟧ (cong₂ ℕ._+_ (𝔹-rightInv xs) (𝔹-rightInv ys)) ⟩
  ⟦ ⟦ ⟦ xs ⇑⟧ ⇓⟧ ℕ.+ ⟦ ⟦ ys ⇑⟧ ⇓⟧ ⇑⟧ ≡˘⟨ cong ⟦_⇑⟧ (+-cong ⟦ xs ⇑⟧ ⟦ ys ⇑⟧) ⟩
  ⟦ ⟦ ⟦ xs ⇑⟧ + ⟦ ys ⇑⟧ ⇓⟧ ⇑⟧ ≡⟨ 𝔹-leftInv (⟦ xs ⇑⟧ + ⟦ ys ⇑⟧) ⟩
  ⟦ xs ⇑⟧ + ⟦ ys ⇑⟧ ∎


module Issue278 where

abstract
  module A where
    Foo : Set₁
    Foo = Set
  module B where
    open A
    Foo≡Set : Foo ≡ Set
    Foo≡Set = refl


-- Andreas, 2014-10-08, issue reported by Andrea Vezzosi

{-# OPTIONS --copatterns #-}

import Common.Level
open import Common.Product

postulate Nat : Set

record Cxt : Set₁ where
  constructor Con  -- essential
  field
    CSet : Set
    CRel : (e0 e1 : CSet) → Set

record Type (Γ : Cxt) : Set₁ where
  open Cxt
  field
    TSet : (e : CSet Γ) → Set
    TRel : (e : CSet Γ) →
           ([e] : CRel Γ e e) →
           (t : TSet e) → Set

open Type

module Works where

  T : (Γ : Cxt) → (a : Type Γ) → Type Γ
  TSet (T Γ a) γ             = Nat × TSet a γ
  TRel (T Γ a) γ [e] (n , b) = TRel a γ [e] b

module Works2 where

  T : (Γ : Cxt) → (a : Type Γ) → Type Γ
  TSet (T Γ a) γ                     = Nat × TSet a γ
  TRel (T (Con S R) a) γ [e] (n , b) = TRel a γ [e] b

module Fails2 where

  T : (Γ : Cxt) → (a : Type Γ) → Type Γ
  TSet (T (Con S R) a) γ     = Nat × TSet a γ
  TRel (T Γ a) γ [e] (n , b) = TRel a γ [e] b

module Fails where

  T : (Γ : Cxt) → (a : Type Γ) → Type Γ
  TSet (T (Con S R) a) γ             = Nat × TSet a γ
  TRel (T (Con S R) a) γ [e] (n , b) = TRel a γ [e] b

-- All version should work!


{-

Add axioms (i.e., propositions) to a structure S without changing the definition of structured equivalence.

X ↦ Σ[ s ∈ S X ] (P X s) where (P X s) is a proposition for all X and s.

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Structures.Axioms where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Path
open import Cubical.Foundations.SIP
open import Cubical.Data.Sigma

private
  variable
    ℓ ℓ₁ ℓ₁' ℓ₂ : Level

AxiomsStructure : (S : Type ℓ → Type ℓ₁)
  (axioms : (X : Type ℓ) → S X → Type ℓ₂)
  → Type ℓ → Type (ℓ-max ℓ₁ ℓ₂)
AxiomsStructure S axioms X = Σ[ s ∈ S X ] (axioms X s)

AxiomsEquivStr : {S : Type ℓ → Type ℓ₁} (ι : StrEquiv S ℓ₁')
  (axioms : (X : Type ℓ) → S X → Type ℓ₂)
  → StrEquiv (AxiomsStructure S axioms) ℓ₁'
AxiomsEquivStr ι axioms (X , (s , a)) (Y , (t , b)) e = ι (X , s) (Y , t) e

axiomsUnivalentStr : {S : Type ℓ → Type ℓ₁}
  (ι : (A B : TypeWithStr ℓ S) → A .fst ≃ B .fst → Type ℓ₁')
  {axioms : (X : Type ℓ) → S X → Type ℓ₂}
  (axioms-are-Props : (X : Type ℓ) (s : S X) → isProp (axioms X s))
  (θ : UnivalentStr S ι)
  → UnivalentStr (AxiomsStructure S axioms) (AxiomsEquivStr ι axioms)
axiomsUnivalentStr {S = S} ι {axioms = axioms} axioms-are-Props θ {X , s , a} {Y , t , b} e =
  ι (X , s) (Y , t) e
    ≃⟨ θ e ⟩
  PathP (λ i → S (ua e i)) s t
    ≃⟨ invEquiv (Σ-contractSnd λ _ → isOfHLevelPathP' 0 (axioms-are-Props _ _) _ _) ⟩
  Σ[ p ∈ PathP (λ i → S (ua e i)) s t ] PathP (λ i → axioms (ua e i) (p i)) a b
    ≃⟨ ΣPath≃PathΣ ⟩
  PathP (λ i → AxiomsStructure S axioms (ua e i)) (s , a) (t , b)
  ■

inducedStructure : {S : Type ℓ → Type ℓ₁}
  {ι : (A B : TypeWithStr ℓ S) → A .fst ≃ B .fst → Type ℓ₁'}
  (θ : UnivalentStr S ι)
  {axioms : (X : Type ℓ) → S X → Type ℓ₂}
  (A : TypeWithStr ℓ (AxiomsStructure S axioms)) (B : TypeWithStr ℓ S)
  → (typ A , str A .fst) ≃[ ι ] B
  → TypeWithStr ℓ (AxiomsStructure S axioms)
inducedStructure θ {axioms} A B eqv =
  B .fst , B .snd , subst (uncurry axioms) (sip θ _ _ eqv) (A .snd .snd)

transferAxioms : {S : Type ℓ → Type ℓ₁}
  {ι : (A B : TypeWithStr ℓ S) → A .fst ≃ B .fst → Type ℓ₁'}
  (θ : UnivalentStr S ι)
  {axioms : (X : Type ℓ) → S X → Type ℓ₂}
  (A : TypeWithStr ℓ (AxiomsStructure S axioms)) (B : TypeWithStr ℓ S)
  → (typ A , str A .fst) ≃[ ι ] B
  → axioms (fst B) (snd B)
transferAxioms θ {axioms} A B eqv =
  subst (uncurry axioms) (sip θ _ _ eqv) (A .snd .snd)


-- We apply the theory of quasi equivalence relations (QERs) to finite multisets and association lists.
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Relation.ZigZag.Applications.MultiSet where

open import Cubical.Core.Everything
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.RelationalStructure
open import Cubical.Foundations.Structure
open import Cubical.Foundations.SIP
open import Cubical.Foundations.Univalence
open import Cubical.Data.Unit
open import Cubical.Data.Empty as ⊥
open import Cubical.Data.Nat
open import Cubical.Data.List hiding ([_])
open import Cubical.Data.Sigma
open import Cubical.HITs.SetQuotients
open import Cubical.HITs.FiniteMultiset as FMS hiding ([_] ; _++_)
open import Cubical.HITs.FiniteMultiset.CountExtensionality
open import Cubical.HITs.PropositionalTruncation
open import Cubical.Relation.Nullary
open import Cubical.Relation.ZigZag.Base

open import Cubical.Structures.MultiSet
open import Cubical.Structures.Relational.Auto
open import Cubical.Structures.Relational.Macro

-- we define simple association lists without any higher constructors
data AList {ℓ} (A : Type ℓ) : Type ℓ where
  ⟨⟩ : AList A
  ⟨_,_⟩∷_ : A → ℕ → AList A → AList A

infixr 5 ⟨_,_⟩∷_

private
  variable
    ℓ : Level

-- We have a CountStructure on List and AList and use these to get a QER between the two
module Lists&ALists {A : Type ℓ} (discA : Discrete A) where

  multisetShape : Type ℓ → Type ℓ
  multisetShape X = X × (A → X → X) × (X → X → X) × (A → X → Const[ ℕ , isSetℕ ])

  module S = RelMacro ℓ (autoRelDesc multisetShape)

  addIfEq : (a x : A) → ℕ → ℕ → ℕ
  addIfEq a x m n with discA a x
  ... | yes _ = m + n
  ... | no _ = n

  module _ {a x : A} {n : ℕ} where

    addIfEq≡ : {m : ℕ} → a ≡ x → addIfEq a x m n ≡ m + n
    addIfEq≡ a≡x with discA a x
    ... | yes _ = refl
    ... | no a≢x = ⊥.rec (a≢x a≡x)

    addIfEq≢ : {m : ℕ} → ¬ (a ≡ x) → addIfEq a x m n ≡ n
    addIfEq≢ a≢x with discA a x
    ... | yes a≡x = ⊥.rec (a≢x a≡x)
    ... | no _ = refl

    addIfEq0 : addIfEq a x 0 n ≡ n
    addIfEq0 with discA a x
    ... | yes _ = refl
    ... | no _ = refl

    addIfEq+ : {m : ℕ} (n' : ℕ) → addIfEq a x m (n + n') ≡ addIfEq a x m n + n'
    addIfEq+ n' with discA a x
    ... | yes _ = +-assoc _ n n'
    ... | no _ = refl

  module L where
    emp : List A
    emp = []

    insert : A → List A → List A
    insert x xs = x ∷ xs

    union : List A → List A → List A
    union xs ys = xs ++ ys

    count : A → List A → ℕ
    count a [] = zero
    count a (x ∷ xs) = addIfEq a x 1 (count a xs)

    structure : S.structure (List A)
    structure = emp , insert , union , count

    countUnion : ∀ a xs ys → count a (union xs ys) ≡ count a xs + count a ys
    countUnion a [] ys = refl
    countUnion a (x ∷ xs) ys =
      cong (addIfEq a x 1) (countUnion a xs ys)
      ∙ addIfEq+ (count a ys)

  module AL where
    emp : AList A
    emp = ⟨⟩

    insert* : ℕ → A → AList A → AList A
    insert* m a ⟨⟩ = ⟨ a , m ⟩∷ ⟨⟩
    insert* m a (⟨ y , n ⟩∷ ys) with (discA a y)
    ... | yes _ = ⟨ y , m + n ⟩∷ ys
    ... | no _ = ⟨ y , n ⟩∷ insert* m a ys

    insert : A → AList A → AList A
    insert = insert* 1

    union : AList A → AList A → AList A
    union ⟨⟩ ys = ys
    union (⟨ x , n ⟩∷ xs) ys = insert* n x (union xs ys)

    count : A → AList A → ℕ
    count a ⟨⟩ = zero
    count a (⟨ y , n ⟩∷ ys) = addIfEq a y n (count a ys)

    structure : S.structure (AList A)
    structure = emp , insert , union , count

    countInsert* : ∀ m a x ys → count a (insert* m x ys) ≡ addIfEq a x m (count a ys)
    countInsert* m a x ⟨⟩ = refl
    countInsert* m a x (⟨ y , n ⟩∷ ys) with discA a x | discA a y | discA x y
    ... | yes a≡x | yes a≡y | yes x≡y = addIfEq≡ a≡y ∙ sym (+-assoc m n _)
    ... | yes a≡x | yes a≡y | no x≢y = ⊥.rec (x≢y (sym a≡x ∙ a≡y))
    ... | yes a≡x | no a≢y | yes x≡y = ⊥.rec (a≢y (a≡x ∙ x≡y))
    ... | yes a≡x | no a≢y | no x≢y =  addIfEq≢ a≢y ∙ countInsert* m a x ys ∙ addIfEq≡ a≡x
    ... | no a≢x | yes a≡y | yes x≡y = ⊥.rec (a≢x (a≡y ∙ sym x≡y))
    ... | no a≢x | yes a≡y | no x≢y = addIfEq≡ a≡y ∙ cong (n +_) (countInsert* m a x ys ∙ addIfEq≢ a≢x)
    ... | no a≢x | no a≢y | yes x≡y = addIfEq≢ a≢y
    ... | no a≢x | no a≢y | no x≢y = addIfEq≢ a≢y ∙ countInsert* m a x ys ∙ addIfEq≢ a≢x

    countInsert = countInsert* 1

    countUnion : ∀ a xs ys → count a (union xs ys) ≡ count a xs + count a ys
    countUnion a ⟨⟩ ys = refl
    countUnion a (⟨ x , n ⟩∷ xs) ys =
      countInsert* n a x (union xs ys)
      ∙ cong (addIfEq a x n) (countUnion a xs ys)
      ∙ addIfEq+ (count a ys)

  -- now for the QER between List and Alist

  R : List A → AList A → Type ℓ
  R xs ys = ∀ a → L.count a xs ≡ AL.count a ys

  φ : List A → AList A
  φ [] = ⟨⟩
  φ (x ∷ xs) = AL.insert x (φ xs)

  ψ : AList A → List A
  ψ ⟨⟩ = []
  ψ (⟨ x , zero ⟩∷ xs) = ψ xs
  ψ (⟨ x , suc n ⟩∷ xs) = x ∷ ψ (⟨ x , n ⟩∷ xs)

  η : ∀ xs → R xs (φ xs)
  η [] a = refl
  η (x ∷ xs) a = cong (addIfEq a x 1) (η xs a) ∙ sym (AL.countInsert a x (φ xs))

  -- for the other direction we need a little helper function
  ε : ∀ y → R (ψ y) y
  ε' : (x : A) (n : ℕ) (xs : AList A) (a : A)
    → L.count a (ψ (⟨ x , n ⟩∷ xs)) ≡ AL.count a (⟨ x , n ⟩∷ xs)

  ε ⟨⟩ a = refl
  ε (⟨ x , n ⟩∷ xs) a = ε' x n xs a

  ε' x zero xs a = ε xs a ∙ sym addIfEq0
  ε' x (suc n) xs a with discA a x
  ... | yes a≡x = cong suc (ε' x n xs a ∙ addIfEq≡ a≡x)
  ... | no  a≢x = ε' x n xs a ∙ addIfEq≢ a≢x

  -- Induced quotients and equivalence

  open isQuasiEquivRel

  -- R is a QER
  QuasiR : QuasiEquivRel _ _ ℓ
  QuasiR .fst .fst = R
  QuasiR .fst .snd _ _ = isPropΠ λ _ → isSetℕ _ _
  QuasiR .snd .zigzag r r' r'' a = (r a) ∙∙ sym (r' a) ∙∙ (r'' a)
  QuasiR .snd .fwd a = ∣ φ a , η a ∣
  QuasiR .snd .bwd b = ∣ ψ b , ε b ∣

  isStructuredInsert : (x : A) {xs : List A} {ys : AList A}
    → R xs ys → R (L.insert x xs) (AL.insert x ys)
  isStructuredInsert x {xs} {ys} r a =
    cong (addIfEq a x 1) (r a) ∙ sym (AL.countInsert a x ys)

  isStructuredUnion :
    {xs : List A} {ys : AList A} (r : R xs ys)
    {xs' : List A} {ys' : AList A} (r' : R xs' ys')
    → R (L.union xs xs') (AL.union ys ys')
  isStructuredUnion {xs} {ys} r {xs'} {ys'} r' a =
    L.countUnion a xs xs' ∙ cong₂ _+_ (r a) (r' a) ∙ sym (AL.countUnion a ys ys')

  -- R is structured
  isStructuredR : S.relation R L.structure AL.structure
  isStructuredR .fst a = refl
  isStructuredR .snd .fst = isStructuredInsert
  isStructuredR .snd .snd .fst {xs} {ys} = isStructuredUnion {xs} {ys}
  isStructuredR .snd .snd .snd a r = r a

  module E = QER→Equiv QuasiR
  open E renaming (Rᴸ to Rᴸ; Rᴿ to Rᴬᴸ)

  List/Rᴸ = (List A) / Rᴸ
  AList/Rᴬᴸ = (AList A) / Rᴬᴸ

  List/Rᴸ≃AList/Rᴬᴸ : List/Rᴸ ≃ AList/Rᴬᴸ
  List/Rᴸ≃AList/Rᴬᴸ = E.Thm

  main : QERDescends _ S.relation (List A , L.structure) (AList A , AL.structure) QuasiR
  main = structuredQER→structuredEquiv S.suitable _ _ QuasiR isStructuredR

  open QERDescends

  LQstructure : S.structure List/Rᴸ
  LQstructure = main .quoᴸ .fst

  ALQstructure : S.structure AList/Rᴬᴸ
  ALQstructure = main .quoᴿ .fst

  -- We get a path between structure over the equivalence from the fact that the QER is structured
  List/Rᴸ≡AList/Rᴬᴸ :
    Path (TypeWithStr ℓ S.structure) (List/Rᴸ , LQstructure) (AList/Rᴬᴸ , ALQstructure)
  List/Rᴸ≡AList/Rᴬᴸ =
    sip S.univalent _ _
      (E.Thm , S.matches (List/Rᴸ , LQstructure) (AList/Rᴬᴸ , ALQstructure) E.Thm .fst (main .rel))

  -- Deriving associativity of union for association list multisets

  LQunion = LQstructure .snd .snd .fst
  ALQunion = ALQstructure .snd .snd .fst

  hasAssociativeUnion : TypeWithStr ℓ S.structure → Type ℓ
  hasAssociativeUnion (_ , _ , _ , _⊔_ , _) =
    ∀ xs ys zs → (xs ⊔ ys) ⊔ zs ≡ xs ⊔ (ys ⊔ zs)

  LQassoc : hasAssociativeUnion (List/Rᴸ , LQstructure)
  LQassoc = elimProp3 (λ _ _ _ → squash/ _ _) (λ xs ys zs i → [ ++-assoc xs ys zs i ])

  ALQassoc : hasAssociativeUnion (AList/Rᴬᴸ , ALQstructure)
  ALQassoc = subst hasAssociativeUnion List/Rᴸ≡AList/Rᴬᴸ LQassoc

  -- We now show that List/Rᴸ≃FMSet

  _∷/_ : A → List/Rᴸ → List/Rᴸ
  _∷/_ = LQstructure .snd .fst

  multisetShape' : Type ℓ → Type ℓ
  multisetShape' X = X × (A → X → X) × (A → X → Const[ ℕ , isSetℕ ])

  FMSstructure : S.structure (FMSet A)
  FMSstructure = [] , _∷_ , FMS._++_ , FMScount discA

  infixr 5 _∷/_

  FMSet→List/Rᴸ : FMSet A → List/Rᴸ
  FMSet→List/Rᴸ = FMS.Rec.f squash/ [ [] ] _∷/_ β
    where
    δ : ∀ c a b xs → L.count c (a ∷ b ∷ xs) ≡ L.count c (b ∷ a ∷ xs)
    δ c a b xs with discA c a | discA c b
    δ c a b xs | yes _        | yes _ = refl
    δ c a b xs | yes _        | no  _ = refl
    δ c a b xs | no  _        | yes _ = refl
    δ c a b xs | no  _        | no  _ = refl

    γ : ∀ a b xs → Rᴸ (a ∷ b ∷ xs) (b ∷ a ∷ xs)
    γ a b xs =
      ∣ φ (a ∷ b ∷ xs) , η (a ∷ b ∷ xs) , (λ c → δ c b a xs ∙ η (a ∷ b ∷ xs) c) ∣

    β : ∀ a b [xs] → a ∷/ b ∷/ [xs] ≡ b ∷/ a ∷/ [xs]
    β a b = elimProp (λ _ → squash/ _ _) (λ xs → eq/ _ _ (γ a b xs))

  -- The inverse is induced by the standard projection of lists into finite multisets,
  -- which is a morphism of CountStructures
  -- Moreover, we need 'count-extensionality' for finite multisets
  List→FMSet : List A → FMSet A
  List→FMSet [] = []
  List→FMSet (x ∷ xs) = x ∷ List→FMSet xs

  List→FMSet-count : ∀ a xs → L.count a xs ≡ FMScount discA a (List→FMSet xs)
  List→FMSet-count a [] = refl
  List→FMSet-count a (x ∷ xs) with discA a x
  ...                         | yes _ = cong suc (List→FMSet-count a xs)
  ...                         | no  _ = List→FMSet-count a xs

  List/Rᴸ→FMSet : List/Rᴸ → FMSet A
  List/Rᴸ→FMSet [ xs ] = List→FMSet xs
  List/Rᴸ→FMSet (eq/ xs ys r i) = path i
    where
    countsAgree : ∀ a → L.count a xs ≡ L.count a ys
    countsAgree a = cong (LQstructure .snd .snd .snd a) (eq/ xs ys r)

    θ : ∀ a → FMScount discA a (List→FMSet xs) ≡ FMScount discA a (List→FMSet ys)
    θ a = sym (List→FMSet-count a xs) ∙∙ countsAgree a ∙∙ List→FMSet-count a ys

    path : List→FMSet xs ≡ List→FMSet ys
    path = FMScountExt.Thm discA _ _ θ
  List/Rᴸ→FMSet (squash/ xs/ xs/' p q i j) =
    trunc (List/Rᴸ→FMSet xs/) (List/Rᴸ→FMSet xs/') (cong List/Rᴸ→FMSet p) (cong List/Rᴸ→FMSet q) i j

  List/Rᴸ→FMSet-insert : (x : A) (ys : List/Rᴸ) → List/Rᴸ→FMSet (x ∷/ ys) ≡ x ∷ List/Rᴸ→FMSet ys
  List/Rᴸ→FMSet-insert x = elimProp (λ _ → FMS.trunc _ _) λ xs → refl

  List→FMSet-union : (xs ys : List A)
    → List→FMSet (xs ++ ys) ≡ FMS._++_ (List→FMSet xs) (List→FMSet ys)
  List→FMSet-union [] ys = refl
  List→FMSet-union (x ∷ xs) ys = cong (x ∷_) (List→FMSet-union xs ys)

  List/Rᴸ≃FMSet : List/Rᴸ ≃ FMSet A
  List/Rᴸ≃FMSet = isoToEquiv (iso List/Rᴸ→FMSet FMSet→List/Rᴸ τ σ)
    where
    σ' : (xs : List A) → FMSet→List/Rᴸ (List/Rᴸ→FMSet [ xs ]) ≡ [ xs ]
    σ' [] = refl
    σ' (x ∷ xs) = cong (x ∷/_) (σ' xs)

    σ : section FMSet→List/Rᴸ List/Rᴸ→FMSet
    σ = elimProp (λ _ → squash/ _ _) σ'

    τ' : ∀ x {xs} → List/Rᴸ→FMSet (FMSet→List/Rᴸ xs) ≡ xs → List/Rᴸ→FMSet (FMSet→List/Rᴸ (x ∷ xs)) ≡ x ∷ xs
    τ' x {xs} p = List/Rᴸ→FMSet-insert x (FMSet→List/Rᴸ xs) ∙ cong (x ∷_) p

    τ : retract FMSet→List/Rᴸ List/Rᴸ→FMSet
    τ = FMS.ElimProp.f (FMS.trunc _ _) refl τ'

  List/Rᴸ≃FMSet-EquivStr : S.equiv (List/Rᴸ , LQstructure) (FMSet A , FMSstructure) List/Rᴸ≃FMSet
  List/Rᴸ≃FMSet-EquivStr .fst = refl
  List/Rᴸ≃FMSet-EquivStr .snd .fst a xs = List/Rᴸ→FMSet-insert a xs
  List/Rᴸ≃FMSet-EquivStr .snd .snd .fst = elimProp2 (λ _ _ → trunc _ _) List→FMSet-union
  List/Rᴸ≃FMSet-EquivStr .snd .snd .snd a =
    elimProp (λ _ → isSetℕ _ _) (List→FMSet-count a)

  {-
  Putting everything together we get:
                ≃
  List/Rᴸ ------------> AList/Rᴬᴸ
    |
    |≃
    |
    ∨
                ≃
  FMSet A ------------> AssocList A
  We thus get that AList/Rᴬᴸ≃AssocList.
  Constructing such an equivalence directly requires count extensionality for association lists,
  which should be even harder to prove than for finite multisets.
  This strategy should work for all implementations of multisets with HITs.
  We just have to show that:
   ∙ The HIT is equivalent to FMSet (like AssocList)
   ∙ There is a QER between lists and the basic data type of the HIT
     with the higher constructors removed (like AList)
  Then we get that this HIT is equivalent to the corresponding set quotient that identifies elements
  that give the same count on each a : A.
  TODO: Show that all the equivalences are indeed isomorphisms of multisets not only of CountStructures!
  -}


{-# OPTIONS --cubical-compatible --rewriting #-}

module Generalize where

open import Agda.Primitive

-- Generalization in definitions

module Definitions where

  variable
    ℓ : Level
    A B C : Set ℓ
    A₀ B₀  : Set
    a b c : A

  -- Function signature

  id : A → A
  id x = x

  -- Module signature
  module M (a : A) where
    identity = a

  -- Data parameters and constructors

  data Eq (a : A) : A → Setω where
    refl  : Eq a a
    trans : Eq a b → Eq b c → Eq a c

  record R (a : A) : Set₁ where
    field
      fld : B₀

    open M a

    alias = fld

    K : B → C → B
    K x _ = x

    field
      fld₁ : B₀

-- Original content (postulates only)

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

infix 4 _≡_

{-# BUILTIN REWRITE _≡_ #-}

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

postulate   Con     :                       Set
postulate   Ty      : (Γ : Con) →           Set
postulate   Tms     : (Γ Δ : Con) →         Set
postulate   Tm      : (Γ : Con)(A : Ty Γ) → Set

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

variable    {Γ Δ Θ} :              Con
postulate   •       :              Con       -- • is \bub
postulate   _▹_     : ∀ Γ → Ty Γ → Con       -- ▹ is \tw2
infixl 5    _▹_

variable    {A B C} :                  Ty _
postulate   _∘ᵀ_    : Ty Δ → Tms Γ Δ → Ty Γ
infixl 6    _∘ᵀ_

variable    {σ δ ν} :                                 Tms _ _
postulate   _∘_     : Tms Θ Δ → Tms Γ Θ →             Tms Γ Δ
infixr 7    _∘_
postulate   id      :                                 Tms Γ Γ
postulate   ε       :                                 Tms Γ •
postulate   _,_     : (σ : Tms Γ Δ) → Tm Γ (A ∘ᵀ σ) → Tms Γ (Δ ▹ A)
infixl 5    _,_
postulate   π₁      : Tms Γ (Δ ▹ A) →                 Tms Γ Δ

variable    {t u v} :                          Tm _ _
postulate   π₂      : (σ : Tms Γ (Δ ▹ A)) →    Tm Γ (A ∘ᵀ π₁ σ)
postulate   _∘ᵗ_    : Tm Δ A → (σ : Tms Γ Δ) → Tm Γ (A ∘ᵀ σ)
infixl 6    _∘ᵗ_

postulate   ass     :   (σ ∘ δ) ∘ ν ≡ σ ∘ δ ∘ ν
{-# REWRITE ass #-}
postulate   idl     :        id ∘ δ ≡ δ
{-# REWRITE idl #-}
postulate   idr     :        δ ∘ id ≡ δ
{-# REWRITE idr #-}
postulate   εη      :             δ ≡ ε  -- can't rewrite, so we specialize this in the next two cases
postulate   εηid    :            id ≡ ε
{-# REWRITE εηid #-}
postulate   εη∘     :         ε ∘ δ ≡ ε
{-# REWRITE εη∘ #-}
postulate   ,β₁     :    π₁ (δ , t) ≡ δ
{-# REWRITE ,β₁ #-}
postulate   ,β₂     :    π₂ (δ , t) ≡ t
{-# REWRITE ,β₂ #-}
postulate   ,η      : (π₁ δ , π₂ δ) ≡ δ
{-# REWRITE ,η #-}
postulate   [id]ᵀ   :       A ∘ᵀ id ≡ A
{-# REWRITE [id]ᵀ #-}
postulate   [∘]ᵀ    :   A ∘ᵀ δ ∘ᵀ σ ≡ A ∘ᵀ δ ∘ σ
{-# REWRITE [∘]ᵀ #-}
postulate   ,∘      :   (δ , t) ∘ σ ≡ δ ∘ σ , t ∘ᵗ σ
{-# REWRITE ,∘ #-}

postulate   [∘]ᵗ    :   t ∘ᵗ σ ∘ᵗ δ ≡ t ∘ᵗ σ ∘ δ
{-# REWRITE [∘]ᵗ #-}
postulate   π₁∘     :      π₁ δ ∘ σ ≡ π₁ (δ ∘ σ)
{-# REWRITE π₁∘ #-}
postulate   π₂∘     :     π₂ δ ∘ᵗ σ ≡ π₂ (δ ∘ σ)
{-# REWRITE π₂∘ #-}
postulate   ∘id     :       t ∘ᵗ id ≡ t
{-# REWRITE ∘id #-}

_↑_ : ∀ σ A → Tms (Γ ▹ A ∘ᵀ σ) (Δ ▹ A)
σ ↑ A = σ ∘ π₁ id , π₂ id

⟨_⟩ : Tm Γ A → Tms Γ (Γ ▹ A)
⟨ t ⟩ = id , t

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

postulate   U       : Ty Γ
variable    {a b c} : Tm _ U
postulate   El      : Tm Γ U → Ty Γ
postulate   U[]     : U ∘ᵀ σ ≡ U
{-# REWRITE U[] #-}
postulate   El[]    : El a ∘ᵀ σ ≡ El (a ∘ᵗ σ)
{-# REWRITE El[] #-}

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

postulate   Π       : (a : Tm Γ U) → Ty (Γ ▹ El a) → Ty Γ
postulate   Π[]     : Π a B ∘ᵀ σ ≡ Π (a ∘ᵗ σ) (B ∘ᵀ σ ↑ El a)
{-# REWRITE Π[] #-}
postulate   app     : Tm Γ (Π a B) → Tm (Γ ▹ El a) B
postulate   app[]   : app t ∘ᵗ (σ ↑ El a) ≡ app (t ∘ᵗ σ)
{-# REWRITE app[] #-}


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

module Diatonic where

open import Data.Bool           using (Bool; false; true; if_then_else_; _∧_)
open import Data.Empty          using (⊥)
open import Data.Fin            using (Fin; toℕ; #_; _≟_) renaming (zero to fz; suc to fs)
open import Data.Integer        using (ℤ; +_; -[1+_]; _+_)
open import Data.Integer.DivMod using (_modℕ_)
open import Data.Nat            using (ℕ; zero; suc; _∸_) renaming (_+_ to _+ℕ_; _≡ᵇ_ to _==_)
open import Data.Nat.DivMod     using (_mod_)
open import Data.Unit           using (⊤)
open import Data.Vec            using (Vec; []; _∷_; head; foldl; take; reverse; lookup; updateAt)

open import Function            using (_∘_)

open import Interval            using (Upi; maj3; min3)
open import Pitch               using (Pitch; s7; PC; pitchToClass)

data Mode : Set where
  major : Mode
  minor : Mode

DiatonicDegree : Set
DiatonicDegree = Fin s7

infix 4 _≡ᵈ_
_≡ᵈ_ : DiatonicDegree → DiatonicDegree → Bool
d ≡ᵈ e = toℕ d == toℕ e
-- round down
pitchClass→Degree : Mode → PC → DiatonicDegree

pitchClass→Degree major (fz)                                                        = # 0
pitchClass→Degree major ((fs fz))                                                   = # 0
pitchClass→Degree major ((fs (fs fz)))                                              = # 1
pitchClass→Degree major ((fs (fs (fs fz))))                                         = # 1
pitchClass→Degree major ((fs (fs (fs (fs fz)))))                                    = # 2
pitchClass→Degree major ((fs (fs (fs (fs (fs fz))))))                               = # 3
pitchClass→Degree major ((fs (fs (fs (fs (fs (fs fz)))))))                          = # 3
pitchClass→Degree major ((fs (fs (fs (fs (fs (fs (fs fz))))))))                     = # 4
pitchClass→Degree major ((fs (fs (fs (fs (fs (fs (fs (fs fz)))))))))                = # 4
pitchClass→Degree major ((fs (fs (fs (fs (fs (fs (fs (fs (fs fz))))))))))           = # 5
pitchClass→Degree major ((fs (fs (fs (fs (fs (fs (fs (fs (fs (fs fz)))))))))))      = # 5
pitchClass→Degree major ((fs (fs (fs (fs (fs (fs (fs (fs (fs (fs (fs fz)))))))))))) = # 6

pitchClass→Degree minor (fz)                                                        = # 0
pitchClass→Degree minor ((fs fz))                                                   = # 0
pitchClass→Degree minor ((fs (fs fz)))                                              = # 1
pitchClass→Degree minor ((fs (fs (fs fz))))                                         = # 2
pitchClass→Degree minor ((fs (fs (fs (fs fz)))))                                    = # 2
pitchClass→Degree minor ((fs (fs (fs (fs (fs fz))))))                               = # 3
pitchClass→Degree minor ((fs (fs (fs (fs (fs (fs fz)))))))                          = # 3
pitchClass→Degree minor ((fs (fs (fs (fs (fs (fs (fs fz))))))))                     = # 4
pitchClass→Degree minor ((fs (fs (fs (fs (fs (fs (fs (fs fz)))))))))                = # 5
pitchClass→Degree minor ((fs (fs (fs (fs (fs (fs (fs (fs (fs fz))))))))))           = # 5
pitchClass→Degree minor ((fs (fs (fs (fs (fs (fs (fs (fs (fs (fs fz)))))))))))      = # 6
pitchClass→Degree minor ((fs (fs (fs (fs (fs (fs (fs (fs (fs (fs (fs fz)))))))))))) = # 6

degree→PC : Mode → DiatonicDegree → PC

degree→PC major fz                               = (# 0)
degree→PC major (fs fz)                          = (# 2)
degree→PC major (fs (fs fz))                     = (# 4)
degree→PC major (fs (fs (fs fz)))                = (# 5)
degree→PC major (fs (fs (fs (fs fz))))           = (# 7)
degree→PC major (fs (fs (fs (fs (fs fz)))))      = (# 9)
degree→PC major (fs (fs (fs (fs (fs (fs fz)))))) = (# 11)

degree→PC minor fz                               = (# 0)
degree→PC minor (fs fz)                          = (# 2)
degree→PC minor (fs (fs fz))                     = (# 3)
degree→PC minor (fs (fs (fs fz)))                = (# 5)
degree→PC minor (fs (fs (fs (fs fz))))           = (# 7)
degree→PC minor (fs (fs (fs (fs (fs fz)))))      = (# 8)
degree→PC minor (fs (fs (fs (fs (fs (fs fz)))))) = (# 10)

pitch→DegreeCMajor : Pitch → DiatonicDegree
pitch→DegreeCMajor = pitchClass→Degree major ∘ pitchToClass

d1 d2 d3 d4 d5 d6 d7 : DiatonicDegree
d1 = # 0
d2 = # 1
d3 = # 2
d4 = # 3
d5 = # 4
d6 = # 5
d7 = # 6

data Accidental : Set where
  ♭3 : ℕ → Accidental -- 3+n flats
  𝄫  : Accidental
  ♭  : Accidental
  ♮  : Accidental
  ♯  : Accidental
  𝄪  : Accidental
  ♯3 : ℕ → Accidental -- 3+n sharps

-- pitch class letter name with accidental
data PCL : Set where
  A : Accidental → PCL
  B : Accidental → PCL
  C : Accidental → PCL
  D : Accidental → PCL
  E : Accidental → PCL
  F : Accidental → PCL
  G : Accidental → PCL

-- Accidental modifier.
accMod : Accidental → ℤ
accMod (♭3 n) = -[1+ (n +ℕ 2) ]
accMod 𝄫      = -[1+ 1 ]
accMod ♭      = -[1+ 0 ]
accMod ♮      = + 0
accMod ♯      = + 1
accMod 𝄪      = + 2
accMod (♯3 n) = + (n +ℕ 3)

flatten : (a : Accidental) → Accidental
flatten (♭3 n)       = ♭3 (suc n)
flatten 𝄫            = ♭3 zero
flatten ♭            = 𝄫
flatten ♮            = ♭
flatten ♯            = ♮
flatten 𝄪            = ♯
flatten (♯3 zero)    = 𝄪
flatten (♯3 (suc n)) = ♯3 n

sharpen : Accidental → Accidental
sharpen (♭3 (suc n)) = ♭3 n
sharpen (♭3 zero)    = 𝄫
sharpen 𝄫            = ♭
sharpen ♭            = ♮
sharpen ♮            = ♯
sharpen ♯            = 𝄪
sharpen 𝄪            = ♯3 zero
sharpen (♯3 n)       = ♯3 (suc n)

-- Convert raw PCL letter to ℕ (in range [0,11]); C normalized to 0
letter→ℕ : PCL → ℕ
letter→ℕ (A _) = 9
letter→ℕ (B _) = 11
letter→ℕ (C _) = 0
letter→ℕ (D _) = 2
letter→ℕ (E _) = 4
letter→ℕ (F _) = 5
letter→ℕ (G _) = 7

accidental : PCL → Accidental
accidental (A x) = x
accidental (B x) = x
accidental (C x) = x
accidental (D x) = x
accidental (E x) = x
accidental (F x) = x
accidental (G x) = x

modifyAccidental : (Accidental → Accidental) → PCL →  PCL
modifyAccidental f (A x) = A (f x)
modifyAccidental f (B x) = B (f x)
modifyAccidental f (C x) = C (f x)
modifyAccidental f (D x) = D (f x)
modifyAccidental f (E x) = E (f x)
modifyAccidental f (F x) = F (f x)
modifyAccidental f (G x) = G (f x)

-- Convert PCL to PC with C♮ normalized to 0.
pclToC : PCL → PC
pclToC pc = ((((+ (letter→ℕ pc)) + accMod (accidental pc)) modℕ 12) mod 12)

data Key : Set where
  key : PCL → Mode → Key

keyMode : Key → Mode
keyMode (key _ mode) = mode

data Step : Set where
  half  : Step
  whole : Step

stepUp : Step → PCL → PCL

stepUp half  (A x) = B (flatten x)
stepUp half  (B x) = C x
stepUp half  (C x) = D (flatten x)
stepUp half  (D x) = E (flatten x)
stepUp half  (E x) = F x
stepUp half  (F x) = G (flatten x)
stepUp half  (G x) = A (flatten x)

stepUp whole (A x) = B x
stepUp whole (B x) = C (sharpen x)
stepUp whole (C x) = D x
stepUp whole (D x) = E x
stepUp whole (E x) = F (sharpen x)
stepUp whole (F x) = G x
stepUp whole (G x) = A x

scaleSteps : Mode → Vec Step s7
scaleSteps major = whole ∷ whole ∷ half ∷ whole ∷ whole ∷ whole ∷ half ∷ []
scaleSteps minor = whole ∷ half ∷ whole ∷ whole ∷ half ∷ whole ∷ whole ∷ []

scaleNotes : Key → Vec PCL s7
scaleNotes (key pc m) =
  let f : {n : ℕ} → Vec PCL (suc n) → Step → Vec PCL (suc (suc n))
      f pcs step = stepUp step (head pcs) ∷ pcs
  in reverse (foldl (Vec PCL ∘ suc) f (pc ∷ []) (take 6 (scaleSteps m)))

data Root : Set where
  I   : Root
  II  : Root
  III : Root
  IV  : Root
  V   : Root
  VI  : Root
  VII : Root

data Quality : Set where
  maj : Quality
  min : Quality
  aug : Quality
  dim : Quality

_dd+_ : DiatonicDegree → ℕ → DiatonicDegree
d dd+ n = (toℕ d +ℕ n) mod s7

thirdUp : DiatonicDegree → DiatonicDegree
thirdUp d = d dd+ 2

data Triad : Set where
  triad : Root → Quality → Triad

root→DiatonicDegree : Root → DiatonicDegree
root→DiatonicDegree I   = d1
root→DiatonicDegree II  = d2
root→DiatonicDegree III = d3
root→DiatonicDegree IV  = d4
root→DiatonicDegree V   = d5
root→DiatonicDegree VI  = d6
root→DiatonicDegree VII = d7

diatonicDegree→Root : DiatonicDegree → Root
diatonicDegree→Root fz                               = I
diatonicDegree→Root (fs fz)                          = II
diatonicDegree→Root (fs (fs fz))                     = III
diatonicDegree→Root (fs (fs (fs fz)))                = IV
diatonicDegree→Root (fs (fs (fs (fs fz))))           = V
diatonicDegree→Root (fs (fs (fs (fs (fs fz)))))      = VI
diatonicDegree→Root (fs (fs (fs (fs (fs (fs fz)))))) = VII

rootQuality : Mode → Root → Quality

rootQuality major I   = maj
rootQuality major II  = min
rootQuality major III = min
rootQuality major IV  = maj
rootQuality major V   = maj
rootQuality major VI  = min
rootQuality major VII = dim

rootQuality minor I   = min
rootQuality minor II  = dim
rootQuality minor III = maj
rootQuality minor IV  = min
rootQuality minor V   = min
rootQuality minor VI  = maj
rootQuality minor VII = maj

root→PC : Key → Root → PC
root→PC (key _ mode) = degree→PC mode ∘ root→DiatonicDegree

diatonicDegree→PCL : Key → DiatonicDegree → PCL
diatonicDegree→PCL k dd = lookup (scaleNotes k) dd

root→PCL : Key → Root → PCL
root→PCL k = diatonicDegree→PCL k ∘ root→DiatonicDegree

-- Lower interval is first.
triadQuality : Upi → Upi → Quality
triadQuality i1 i2 =
  if      (i1 == maj3) ∧ (i2 == min3) then maj
  else if (i1 == min3) ∧ (i2 == maj3) then min
  else if (i1 == min3) ∧ (i2 == min3) then dim
  else if (i1 == maj3) ∧ (i2 == maj3) then aug
  else maj -- should not happen

makeTriad : Mode → Root → Triad
makeTriad m r =
  let d1 = root→DiatonicDegree r
      d2 = thirdUp d1
      d3 = thirdUp d2
      p1 = degree→PC m d1
      p2 = degree→PC m d2
      p3 = degree→PC m d3
      i1 = toℕ p2 ∸ toℕ p1 -- TODO: See if want to use ℤ
      i2 = toℕ p3 ∸ toℕ p2
  in triad r (triadQuality i1 i2)

diatonic7thNotes : Key → Root → Vec PCL 4
diatonic7thNotes k root =
  let d1 = root→DiatonicDegree root
      d2 = thirdUp d1
      d3 = thirdUp d2
      d4 = thirdUp d3
      ns = scaleNotes k
  in lookup ns d1 ∷ lookup ns d2 ∷ lookup ns d3 ∷ lookup ns d4 ∷ []

triadNotes : Key → Root → Vec PCL 3
triadNotes k = take 3 ∘ diatonic7thNotes k

_V/_ : Key → Root → Vec PCL 3
k V/ r = triadNotes (key (root→PCL k r) major) V

_V⁷/_ : Key → Root → Vec PCL 4
k V⁷/ r = diatonic7thNotes (key (root→PCL k r) major) V

_viiᵒ⁷/_ : Key → Root → Vec PCL 4
k viiᵒ⁷/ r = updateAt (# 3) (modifyAccidental flatten) (diatonic7thNotes (key (root→PCL k r) major) VII)

----------

a1 = triadNotes (key (G ♭) major) III
a2 = diatonic7thNotes (key (G ♯) major) V
a3 = diatonic7thNotes (key (E ♮) major) V
a4 = diatonic7thNotes (key (B ♭) major) VI
a5 = scaleNotes (key (G ♯) major)
a6 = scaleNotes (key (G ♭) major)
a7 = scaleNotes (key (B ♮) minor)
a8 = (key (G ♮) major) V/ V
a9 = (key (B ♭) major) V⁷/ II

a10 = (key (F ♯) minor) viiᵒ⁷/ III


open import Prelude hiding (_≤_)
open import Data.Nat.Properties
open import Induction.Nat

module Implicits.Resolution.GenericFinite.Examples.Haskell
  where

open import Implicits.Resolution.GenericFinite.TerminationCondition
open import Implicits.Resolution.GenericFinite.Resolution
open import Implicits.Resolution.GenericFinite.Algorithm
open import Implicits.Syntax
open import Implicits.Syntax.Type.Unification
open import Implicits.Resolution.Termination
open import Implicits.Substitutions

haskellCondition : TerminationCondition
haskellCondition = record
  { TCtx = ∃ Type
  ; _<_  = _hρ<_
  ; _<?_  = λ { (_ , x) (_ , y) → x hρ<? y }
  ; step = λ Φ Δ a b τ → , a
  ; wf-< = hρ<-well-founded
  }

open ResolutionRules haskellCondition public
open ResolutionAlgorithm haskellCondition public

module Deterministic⊆HaskellFinite where
  open import Implicits.Resolution.Deterministic.Resolution as D
  open import Data.Nat hiding (_<_)
  open import Data.Nat.Properties
  open import Relation.Binary using (module DecTotalOrder)
  open import Extensions.ListFirst
  open DecTotalOrder decTotalOrder using () renaming (refl to ≤-refl; trans to ≤-trans)
  module F = ResolutionRules haskellCondition
  module M = MetaTypeMetaSubst

  lem₆ : ∀ {ν μ} (a : Type ν) (b : Type (suc μ)) c → (, a) hρ< (, b) → (, a) hρ< (, b tp[/tp c ])
  lem₆ a b c p = ≤-trans p (h||a/s|| b (TypeSubst.sub c))
    where open SubstSizeLemmas

  lem₅ : ∀ {ν μ} {Δ : ICtx ν} {b τ} (a : Type μ) → Δ ⊢ b ↓ τ → (, a) hρ< (, b) → (, a) hρ< (, simpl τ)
  lem₅ {τ = τ} a (i-simp .τ) q = q
  lem₅ a (i-iabs _ p) q = lem₅ a p q
  lem₅ a (i-tabs {ρ = b} c p) q = lem₅ a p (lem₆ a b c q)

  -- Oliveira's termination condition is part of the well-formdness of types
  -- So we assume here that ⊢term x holds for all types x
  mutual
    lem : ∀ {ν} {Δ : ICtx ν} {a r g} →
          (∀ {ν} (a : Type ν) → ⊢term a) →
          (, simpl a) hρ≤ g → Δ D.⊢ r ↓ a → Δ F., g ⊢ r ↓ a
    lem all-⊢term q (i-simp a) = i-simp a
    lem {a = a} {g = g}all-⊢term q (i-iabs {ρ₁ = ρ₁} {ρ₂ = ρ₂} ⊢ρ₁ ρ₂↓a) with all-⊢term (ρ₁ ⇒ ρ₂)
    lem {a = a} {g = g} all-⊢term q (i-iabs {ρ₁ = ρ₁} {ρ₂ = ρ₂} ⊢ρ₁ ρ₂↓a) | term-iabs _ _ a-hρ<-b _ =
      i-iabs ρ₁<g (complete' (, ρ₁) all-⊢term ⊢ρ₁ ≤-refl) (lem all-⊢term q ρ₂↓a)
      where
        ρ₁<g : (, ρ₁) hρ< g
        ρ₁<g = ≤-trans (lem₅ ρ₁ ρ₂↓a a-hρ<-b) q
    lem all-⊢term q (i-tabs b p) = i-tabs b (lem all-⊢term q p)

    complete' : ∀ {ν} {a : Type ν} {Δ : ICtx ν} → (g : ∃ Type) →
              (∀ {ν} (a : Type ν) → ⊢term a) → Δ D.⊢ᵣ a → (, a) hρ≤ g →
              Δ F., g ⊢ᵣ a
    complete' g all-⊢term (r-simp x p) q = r-simp (proj₁ $ first⟶∈ x) (lem all-⊢term q p)
    complete' g all-⊢term (r-iabs ρ₁ p) q = r-iabs ρ₁ (complete' g all-⊢term p q)
    complete' g all-⊢term (r-tabs p) q = r-tabs (complete' g all-⊢term p q)

  complete : ∀ {ν} {a : Type ν} {Δ : ICtx ν} →
            (∀ {ν} (a : Type ν) → ⊢term a) → Δ D.⊢ᵣ a → Δ F., (, a) ⊢ᵣ a
  complete all-⊢term p = complete' _ all-⊢term p ≤-refl


{-# OPTIONS --no-unicode #-}

data Two : Set where
  tt ff : Two

data Foo : Set where
  foo : Foo -> Foo -> Foo

test1 : Foo → Two
test1 x₀ = {!!}

test : Foo -> Foo → Two
test x1 = {!!}