{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.GradedRing.DirectSumFun where

{-
   This file give a graded ring construction in the case of the fun direct sum.
   Because of the current proofs this is done only in the case where
   - Idx is ℕ and for a monoid on it
   - For the usual ∸ of the Nat library

   The proof consists in :
   - Defining a _prod_ operation on the structure
   - Proving the underlying equivalence respect it
   - Transporting the proof of RingStr
   - Deducing an equivalence proof
-}

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

open import Cubical.Relation.Nullary

open import Cubical.Data.Empty as ⊥
open import Cubical.Data.Nat renaming (_+_ to _+ℕ_ ; _∸_ to _-ℕ_ )
open import Cubical.Data.Nat.Order
open import Cubical.Data.Sigma
open import Cubical.Data.Sum

open import Cubical.Algebra.Monoid
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.AbGroup
open import Cubical.Algebra.DirectSum.Equiv-DSHIT-DSFun
open import Cubical.Algebra.DirectSum.DirectSumHIT.Base
open import Cubical.Algebra.DirectSum.DirectSumHIT.Properties
open import Cubical.Algebra.DirectSum.DirectSumFun.Base
open import Cubical.Algebra.AbGroup.Instances.NProd
open import Cubical.Algebra.AbGroup.Instances.DirectSumFun
open import Cubical.Algebra.Ring
open import Cubical.Algebra.GradedRing.Base
open import Cubical.Algebra.GradedRing.DirectSumHIT
open import Cubical.Algebra.CommRing

open import Cubical.HITs.PropositionalTruncation as PT

private variable
  ℓ ℓ' : Level

open AbGroupStr
open AbGroupTheory

-----------------------------------------------------------------------------
-- Def, notation, lemma

module _

  -- monoid
  (_+n_ : ℕ → ℕ → ℕ) -- need to instantiate on +'
  (isM : IsMonoid 0 _+n_)
  (_+≡_ : (n m : ℕ) →  n +n m ≡ n +ℕ m) -- needed for the behaviour under -ℕ
  --
  (G : ℕ → Type ℓ)
  (Gstr : (n : ℕ) → AbGroupStr (G n))
  where

  sameFiber+ : {i n : ℕ} → i ≤ n → i +ℕ (n -ℕ i) ≡ n
  sameFiber+ {zero} {zero} p = refl
  sameFiber+ {zero} {suc n} p = refl
  sameFiber+ {suc i} {zero} p = ⊥.rec (¬-<-zero p)
  sameFiber+ {suc i} {suc n} p = cong suc (sameFiber+ (pred-≤-pred p))

  sameFiber : {i n : ℕ} → (i ≤ n) → i +n (n -ℕ i) ≡ n
  sameFiber {i} {n} p = (i +≡ (n -ℕ i)) ∙ sameFiber+ p

  open SubstLemma ℕ G Gstr
  open IsMonoid isM using ()
    renaming
    ( ·Assoc to +nAssoc
    ; ·IdR   to +nIdR
    ; ·IdL   to +nIdL   )

  open AbGroupStr (snd (NProd-AbGroup G Gstr)) using ()
    renaming
    ( 0g     to 0Fun
    ; _+_    to _+Fun_
    ; is-set to isSetFun )

  module _
    (1⋆      : G 0)
    (_⋆_     : {k l : ℕ} → G k → G l → G (k +n l))
    (0-⋆     : {k l : ℕ} → (b : G l) → (0g (Gstr k)) ⋆ b ≡ 0g (Gstr (k +n l)))
    (⋆-0     : {k l : ℕ} → (a : G k) → a ⋆ (0g (Gstr l)) ≡ 0g (Gstr (k +n l)))
    (⋆Assoc  : {k l m : ℕ} → (a : G k) → (b : G l) → (c : G m) →
                _≡_ {A = Σ[ k ∈ ℕ ] G k} ((k +n (l +n m)) , (a ⋆ (b ⋆ c))) (((k +n l) +n m) , ((a ⋆ b) ⋆ c)))
    (⋆IdR    : {k : ℕ} → (a : G k) → _≡_ {A = Σ[ k ∈ ℕ ] G k} ( k +n 0 , a ⋆ 1⋆ ) (k , a))
    (⋆IdL    : {l : ℕ} → (b : G l) → _≡_ {A = Σ[ k ∈ ℕ ] G k} ( 0 +n l , 1⋆ ⋆ b ) (l , b))
    (⋆DistR+ : {k l : ℕ} → (a : G k) → (b c : G l) →
               a ⋆ ((Gstr l) ._+_ b c) ≡ Gstr (k +n l) ._+_ (a ⋆ b) (a ⋆ c))
    (⋆DistL+ : {k l : ℕ} → (a b : G k) → (c : G l) →
               ((Gstr k) ._+_ a b) ⋆ c ≡ Gstr (k +n l) ._+_ (a ⋆ c) (b ⋆ c))
    where

-----------------------------------------------------------------------------
-- Definition of 1

    -- import for pres
    open Equiv-Properties G Gstr using
      ( substG
      ; fun-trad
      ; fun-trad-eq
      ; fun-trad-neq
      ; ⊕HIT→Fun
      ; ⊕HIT→⊕Fun
      ; ⊕HIT→⊕Fun-pres+)

    1Fun : (n : ℕ) → G n
    1Fun zero = 1⋆
    1Fun (suc n) = 0g (Gstr (suc n))

    1⊕Fun : ⊕Fun G Gstr
    1⊕Fun = 1Fun , ∣ 0 , helper ∣₁
      where
      helper : AlmostNullProof G Gstr 1Fun 0
      helper zero r = ⊥.rec (¬-<-zero r)
      helper (suc n) r = refl

    ⊕HIT→Fun-pres1 : (n : ℕ) → ⊕HIT→Fun (base 0 1⋆) n ≡ 1Fun n
    ⊕HIT→Fun-pres1 zero with discreteℕ 0 0
    ... | yes p = cong (λ X → subst G X 1⋆) (isSetℕ _ _ _ _) ∙ transportRefl _
    ... | no ¬p = ⊥.rec (¬p refl)
    ⊕HIT→Fun-pres1 (suc n) with discreteℕ (suc n) 0
    ... | yes p = ⊥.rec (snotz p)
    ... | no ¬p = refl

    ⊕HIT→⊕Fun-pres1 : ⊕HIT→⊕Fun (base 0 1⋆) ≡ 1⊕Fun
    ⊕HIT→⊕Fun-pres1 = ΣPathTransport→PathΣ _ _
                       ((funExt (λ n → ⊕HIT→Fun-pres1 n)) , (squash₁ _ _))

-----------------------------------------------------------------------------
-- Definition of the ring product

    sumFun : (i n : ℕ) → (i ≤ n) → (f g : (n : ℕ) → G n) → G n
    sumFun zero n r f g = subst G (sameFiber r) ((f 0) ⋆ (g (n -ℕ 0)))
    sumFun (ℕ.suc i) n r f g = Gstr n ._+_ (subst G (sameFiber r) ((f (suc i)) ⋆ (g (n -ℕ suc i))))
                                            (sumFun i n (≤-trans ≤-sucℕ r) f g)

    _prodFun_ : (f g : (n : ℕ) → G n) → (n : ℕ) → G n
    _prodFun_ f g n = sumFun n n ≤-refl f g

    -- Proof that it is an almost null sequence
    prodAn : (f g : (n : ℕ) → G n) → AlmostNull G Gstr f → AlmostNull G Gstr g → AlmostNull G Gstr (f prodFun g)
    prodAn f g (k , nf) (l , ng) = (k +ℕ l) , λ n pp → sumF0 n n pp ≤-refl
      where
      sumF0 : (i n : ℕ) → (pp : k +ℕ l < n) → (r : i ≤ n) → sumFun i n r f g ≡ 0g (Gstr n)
      sumF0 zero n pp r = cong (subst G (sameFiber r))
                               (cong (λ X → f 0 ⋆ X) (ng (n -ℕ zero) (<-k+-trans pp)) ∙ ⋆-0 _) ∙ subst0g _
      sumF0 (suc i) n pp r with splitℕ-≤ (suc i) k
      ... | inl x = cong₂ (Gstr n ._+_)
                        (cong (subst G (sameFiber r))
                              (cong (λ X → f (suc i) ⋆ X) (ng (n -ℕ suc i)
                                    -- Goal  : l < n - suc i
                                    -- Proof : l = k + l - k < n - k < n - suc i
                                    (subst (λ X → X < n -ℕ suc i) (∸+ l k)
                                            (≤<-trans (≤-∸-≥ (k +ℕ l) (suc i) k x)
                                            (<-∸-< (k +ℕ l) n (suc i) pp (≤<-trans x (<-+k-trans pp))))))
                              ∙ ⋆-0 (f (suc i))))
                        (sumF0 i n pp (≤-trans ≤-sucℕ r))
                  ∙ +IdR (Gstr n) _
                  ∙ subst0g _

      ... | inr x = cong₂ (Gstr n ._+_)
                          (cong (subst G (sameFiber r))
                                (cong (λ X → X ⋆ g (n -ℕ (suc i))) (nf (suc i) x)
                                ∙ 0-⋆ _))
                          (sumF0 i n pp (≤-trans ≤-sucℕ r))
                    ∙ +IdR (Gstr n) _
                    ∙ subst0g _

    _prodF_ : ⊕Fun G Gstr → ⊕Fun G Gstr → ⊕Fun G Gstr
    _prodF_(f , Anf) (g , Ang) = (f prodFun g) , helper Anf Ang
      where
      helper :  AlmostNullP G Gstr f →  AlmostNullP G Gstr g →  AlmostNullP G Gstr (f prodFun g)
      helper = PT.rec2 squash₁ (λ x y → ∣ (prodAn f g x y) ∣₁)

-----------------------------------------------------------------------------
-- Some Ring properties that are needed

    -- lemma for 0 case
    prodFunAnnihilL : (f : (n : ℕ) → G n) → 0Fun prodFun f ≡ 0Fun
    prodFunAnnihilL f = funExt (λ n → sumF0 n n ≤-refl)
      where
      sumF0 : (i n : ℕ) → (r : i ≤ n) → sumFun i n r 0Fun f ≡ 0g (Gstr n)
      sumF0 zero n r = cong (subst G (sameFiber r)) (0-⋆ _) ∙ subst0g _
      sumF0 (suc i) n r = cong₂ (Gstr n ._+_)
                                (cong (subst G (sameFiber r)) (0-⋆ _))
                                (sumF0 i n (≤-trans ≤-sucℕ r))
                          ∙ +IdR (Gstr n) _
                          ∙ subst0g _

    prodFunAnnihilR : (f : (n : ℕ) → (G n)) → f prodFun 0Fun ≡ 0Fun
    prodFunAnnihilR f = funExt (λ n → sumF0 n n ≤-refl)
      where
      sumF0 : (i n : ℕ) → (r : i ≤ n) → sumFun i n r f 0Fun ≡ 0g (Gstr n)
      sumF0 zero n r = cong (subst G (sameFiber r)) (⋆-0 _) ∙ subst0g _
      sumF0 (suc i) n r = cong₂ (Gstr n ._+_)
                                (cong (subst G (sameFiber r)) (⋆-0 _))
                                (sumF0 i n (≤-trans ≤-sucℕ r))
                          ∙ +IdR (Gstr n) _
                          ∙ subst0g _

    prodFunDistR : (f g h : (n : ℕ) → G n) → f prodFun (g +Fun h) ≡ (f prodFun g) +Fun (f prodFun h)
    prodFunDistR f g h = funExt (λ n → sumFAssoc n n ≤-refl)
     where
     sumFAssoc : (i n : ℕ) → (r : i ≤ n) → sumFun i n r f (g +Fun h) ≡ (Gstr n) ._+_ (sumFun i n r f g) (sumFun i n r f h)
     sumFAssoc zero n r = cong (subst G (sameFiber r)) (⋆DistR+ _ _ _)
                          ∙ sym (subst+ _ _ _)
     sumFAssoc (suc i) n r = cong₂ (Gstr n ._+_)
                                   (cong (subst G (sameFiber r)) (⋆DistR+ _ _ _) ∙ sym (subst+ _ _ _))
                                   (sumFAssoc i n (≤-trans ≤-sucℕ r))
                             ∙ comm-4 ((G n) , (Gstr n)) _ _ _ _

    prodFunDistL : (f g h : (n : ℕ) → G n) → (f +Fun g) prodFun h ≡ (f prodFun h) +Fun (g prodFun h)
    prodFunDistL f g h = funExt (λ n → sumFAssoc n n ≤-refl)
     where
     sumFAssoc : (i n : ℕ) → (r : i ≤ n) → sumFun i n r (f +Fun g) h ≡ (Gstr n) ._+_ (sumFun i n r f h) (sumFun i n r g h)
     sumFAssoc zero n r = cong (subst G (sameFiber r)) (⋆DistL+ _ _ _)
                          ∙ sym (subst+ _ _ _)
     sumFAssoc (suc i) n r = cong₂ (Gstr n ._+_)
                                   (cong (subst G (sameFiber r)) (⋆DistL+ _ _ _) ∙ sym (subst+ _ _ _))
                                   (sumFAssoc i n (≤-trans ≤-sucℕ r))
                             ∙ comm-4 ((G n) , (Gstr n)) _ _ _ _

-----------------------------------------------------------------------------
-- Preserving the product

   -- A substitution lemma
    subst⋆ : {m n k l : ℕ} → (p : m ≡ n) → (q : k ≡ l) → (r : m +n k ≡ n +n l) →
                  (a : G m) → (b : G k) → subst G p a ⋆ subst G q b ≡ subst G r (a ⋆ b)
    subst⋆ p q r a b = J (λ n p → subst G p a ⋆ subst G q b ≡ subst G (cong₂ _+n_ p q) (a ⋆ b))
                              (J (λ l q → subst G refl a ⋆ subst G q b ≡ subst G (cong₂ _+n_ refl q) (a ⋆ b))
                                 (cong₂ _⋆_ (transportRefl _) (transportRefl _) ∙ sym (transportRefl _))
                                 q)
                               p
                             ∙ cong (λ X → subst G X (a ⋆ b)) (isSetℕ _ _ _ _)

    -- Proving the base case
    open GradedRing-⊕HIT-index (ℕ , (monoidstr 0 _+n_ isM)) G Gstr
    open GradedRing-⊕HIT-⋆ 1⋆ _⋆_ 0-⋆ ⋆-0 ⋆Assoc ⋆IdR ⋆IdL ⋆DistR+ ⋆DistL+

    sumFun≠ : (k : ℕ) → (a : G k) → (l : ℕ) →  (b : G l) →
              (i n : ℕ) → (r : i ≤ n) → (¬pp : k +n l ≡ n → ⊥) →
              sumFun i n r (fun-trad k a) (fun-trad l b) ≡ 0g (Gstr n)
    sumFun≠ k a l b zero n r ¬pp with discreteℕ k 0 | discreteℕ l n
    ... | yes p | yes q = ⊥.rec (¬pp ((k +≡ l) ∙ cong₂ _+ℕ_ p q) )
    ... | yes p | no ¬q = cong (subst G (sameFiber r)) (⋆-0 _) ∙ subst0g _
    ... | no ¬p | yes q = cong (subst G (sameFiber r)) (0-⋆ _) ∙ subst0g _
    ... | no ¬p | no ¬q = cong (subst G (sameFiber r)) (0-⋆ _) ∙ subst0g _
    sumFun≠ k a l b (suc i) n r ¬pp with discreteℕ k (suc i) | discreteℕ l (n -ℕ (suc i))
    ... | yes p | yes q = ⊥.rec (¬pp (cong₂ _+n_ p q ∙ sameFiber r))
    ... | yes p | no ¬q = cong₂ (Gstr n ._+_)
                                (cong (subst G (sameFiber r)) (⋆-0 _))
                                (sumFun≠ k a l b i n (≤-trans ≤-sucℕ r) ¬pp)
                          ∙ +IdR (Gstr n) _
                          ∙ subst0g _
    ... | no ¬p | yes q = cong₂ (Gstr n ._+_)
                                (cong (subst G (sameFiber r)) (0-⋆ _))
                                (sumFun≠ k a l b i n (≤-trans ≤-sucℕ r) ¬pp)
                          ∙ +IdR (Gstr n) _
                          ∙ subst0g _
    ... | no ¬p | no ¬q = cong₂ (Gstr n ._+_)
                                (cong (subst G (sameFiber r)) (0-⋆ _))
                                (sumFun≠ k a l b i n (≤-trans ≤-sucℕ r) ¬pp)
                          ∙ +IdR (Gstr n) _
                          ∙ subst0g _

    -- If k +n l ≡ n then, we unwrap the sum until we reach k.
    -- Before it is 0, in k the value, then it is 0
    sumFun< : (k : ℕ) → (a : G k) → (l : ℕ) →  (b : G l) →
              (i n : ℕ) → (r : i ≤ n) → (i < k) →
              sumFun i n r (fun-trad k a) (fun-trad l b) ≡ 0g (Gstr n)
    sumFun< k a l b zero n r pp with discreteℕ k 0
    ... | yes p = ⊥.rec (<→≢ pp (sym p))
    ... | no ¬p = cong (subst G (sameFiber r)) (0-⋆ _) ∙ subst0g _
    sumFun< k a l b (suc i) n r pp with discreteℕ k (suc i)
    ... | yes p = ⊥.rec (<→≢ pp (sym p))
    ... | no ¬p = cong₂ (Gstr n ._+_)
                        (cong (subst G (sameFiber r)) (0-⋆ _))
                        (sumFun< k a l b i n (≤-trans ≤-sucℕ r) (<-trans ≤-refl pp))
                  ∙ +IdR (Gstr n) _
                  ∙ subst0g _

    sumFun≤ : (k : ℕ) → (a : G k) → (l : ℕ) →  (b : G l ) →
              (i n : ℕ) → (r : i ≤ n) → (pp : k +n l ≡ n) → (k ≤ i) →
              sumFun i n r (fun-trad k a) (fun-trad l b) ≡ subst G pp (a ⋆ b)
    sumFun≤ k a l b zero n r pp rr with discreteℕ k 0 | discreteℕ l n
    ... | yes p | yes q = cong (subst G (sameFiber r)) (subst⋆ p q (pp ∙ sym (+nIdL _)) a b)
                          ∙ sym (substComposite G _ _ _)
                          ∙ cong (λ X → subst G X (a ⋆ b)) (isSetℕ _ _ _ _)
    ... | yes p | no ¬q = ⊥.rec (¬q (sym (+nIdL l) ∙ cong (λ X → X +n l) (sym p) ∙ pp))
    ... | no ¬p | yes q = ⊥.rec (¬p (≤0→≡0 rr))
    ... | no ¬p | no ¬q = ⊥.rec (¬p (≤0→≡0 rr))
    sumFun≤ k a l b (suc i) n r pp rr with discreteℕ k (suc i) | discreteℕ l (n -ℕ suc i)
    ... | yes p | yes q = cong₂ (Gstr n ._+_)
                                (cong (subst G (sameFiber r))
                                      (subst⋆ p q (pp ∙ sym (sameFiber r)) a b)
                                      ∙ sym (substComposite G _ _ _))
                                (sumFun< k a l b i n (≤-trans ≤-sucℕ r) (0 , (sym p)))
                          ∙ +IdR (Gstr n) _
                          ∙ cong (λ X → subst G X (a ⋆ b)) (isSetℕ _ _ _ _)
    ... | yes p | no ¬q = ⊥.rec (¬q (inj-m+ (sym ((suc i) +≡ l)
                                            ∙ cong (λ X → X +n l) (sym p)
                                            ∙ pp
                                            ∙ sym (sameFiber r)
                                            ∙ ((suc i) +≡ (n -ℕ suc i)))))
    ... | no ¬p | yes q = ⊥.rec (¬p (inj-+m (sym (k +≡ (n -ℕ suc i))
                                              ∙ cong (λ X → k +n X) (sym q)
                                              ∙ pp
                                              ∙ sym (sameFiber r)
                                              ∙ ((suc i) +≡ (n -ℕ suc i)))))
    ... | no ¬p | no ¬q = cong₂ (Gstr n ._+_)
                                (cong (subst G (sameFiber r)) (0-⋆ _) ∙ subst0g _)
                                (sumFun≤ k a l b i n (≤-trans ≤-sucℕ r) pp (≤-suc-≢ rr ¬p))
                          ∙ +IdL (Gstr n) _

     -- If k +n l ≢ n, then it is both zero
     -- Otherwise, it coincide in (k,l)
    sumFBase : (k : ℕ) → (a : G k) → (l : ℕ) →  (b : G l) → (n : ℕ) →
               fun-trad (k +n l) (a ⋆ b) n ≡ sumFun n n ≤-refl (fun-trad k a) (fun-trad l b)
    sumFBase k a l b n with discreteℕ (k +n l) n
    ... | yes p = sym (sumFun≤ k a l b n n ≤-refl p (l , (+-comm l k ∙ sym (k +≡ l) ∙ p)))
    ... | no ¬p = sym (sumFun≠ k a l b n n ≤-refl ¬p)

    -- Proof that ⊕HIT→⊕Fun preserve the cup product
    ⊕HIT→Fun-pres-prodFun : (x y : ⊕HIT ℕ G Gstr) → ⊕HIT→Fun (x prod y) ≡ ((⊕HIT→Fun x) prodFun (⊕HIT→Fun y))
    ⊕HIT→Fun-pres-prodFun = DS-Ind-Prop.f _ _ _ _
                         (λ x → isPropΠ (λ _ → isSetFun _ _))
                         (λ y → sym (prodFunAnnihilL (⊕HIT→Fun y)))
                         (λ k a → DS-Ind-Prop.f _ _ _ _ (λ _ → isSetFun _ _)
                                   (sym (prodFunAnnihilR (⊕HIT→Fun (base k a))))
                                   (λ l b → funExt λ n → sumFBase k a l b n)
                                   λ {U V} ind-U ind-V → cong₂ _+Fun_ ind-U ind-V
                                                          ∙ sym (prodFunDistR _ _ _))
                         λ {U} {V} ind-U ind-V y → cong₂ _+Fun_ (ind-U y) (ind-V y)
                                                    ∙ sym (prodFunDistL _ _ _)

    ⊕HIT→⊕Fun-pres-prodF : (x y : ⊕HIT ℕ G Gstr) → ⊕HIT→⊕Fun (x prod y) ≡ ((⊕HIT→⊕Fun x) prodF (⊕HIT→⊕Fun y))
    ⊕HIT→⊕Fun-pres-prodF x y = ΣPathTransport→PathΣ _ _
                                ((⊕HIT→Fun-pres-prodFun x y) , (squash₁ _ _))

-----------------------------------------------------------------------------
-- Graded Ring Structure

    open AbGroupStr (snd (⊕Fun-AbGr G Gstr)) using ()
        renaming
      ( 0g       to 0⊕Fun
      ; _+_      to _+⊕Fun_
      ; -_       to -⊕Fun_
      ; is-set   to isSet⊕Fun)

    open IsGroupHom

    ⊕FunGradedRing-Ring : Ring ℓ
    ⊕FunGradedRing-Ring = InducedRing ⊕HITgradedRing-Ring
                                      0⊕Fun 1⊕Fun _+⊕Fun_ _prodF_ -⊕Fun_
                                      (fst (Equiv-DirectSum G Gstr))
                                      (pres1 (snd (Equiv-DirectSum G Gstr)))
                                      ⊕HIT→⊕Fun-pres1
                                      (pres· (snd (Equiv-DirectSum G Gstr)))
                                      ⊕HIT→⊕Fun-pres-prodF
                                      (presinv (snd (Equiv-DirectSum G Gstr)))

    RingEquiv-DirectSumGradedRing : RingEquiv ⊕HITgradedRing-Ring ⊕FunGradedRing-Ring
    RingEquiv-DirectSumGradedRing = InducedRingEquiv ⊕HITgradedRing-Ring
                                      0⊕Fun 1⊕Fun _+⊕Fun_ _prodF_ -⊕Fun_
                                      (fst (Equiv-DirectSum G Gstr))
                                      (pres1 (snd (Equiv-DirectSum G Gstr)))
                                      ⊕HIT→⊕Fun-pres1
                                      (pres· (snd (Equiv-DirectSum G Gstr)))
                                      ⊕HIT→⊕Fun-pres-prodF
                                      (presinv (snd (Equiv-DirectSum G Gstr)))

    ⊕Fun-GradedRing : GradedRing ℓ-zero ℓ
    ⊕Fun-GradedRing = makeGradedRing
                      ⊕FunGradedRing-Ring
                      (ℕ , (monoidstr 0 _+n_ isM))
                      G Gstr
                      1⋆ _⋆_
                      0-⋆ ⋆-0
                      ⋆Assoc ⋆IdR ⋆IdL
                      ⋆DistR+ ⋆DistL+
                      (RingEquivs.invRingEquiv RingEquiv-DirectSumGradedRing)

-----------------------------------------------------------------------------
-- CommRing extension

    module _
      (⋆Comm : {k l : ℕ} → (a : G k) → (b : G l) →
               _≡_ {A = Σ[ k ∈ ℕ ] G k} ((k +n l) , (a ⋆ b)) ((l +n k) , (b ⋆ a)))
      where

      open ExtensionCommRing ⋆Comm

      ⊕FunGradedRing-CommRing : CommRing ℓ
      ⊕FunGradedRing-CommRing = InducedCommRing ⊕HITgradedRing-CommRing
                                        0⊕Fun 1⊕Fun _+⊕Fun_ _prodF_ -⊕Fun_
                                        (fst (Equiv-DirectSum G Gstr))
                                        (pres1 (snd (Equiv-DirectSum G Gstr)))
                                        ⊕HIT→⊕Fun-pres1
                                        (pres· (snd (Equiv-DirectSum G Gstr)))
                                        ⊕HIT→⊕Fun-pres-prodF
                                        (presinv (snd (Equiv-DirectSum G Gstr)))

      CommRingEquiv-DirectSumGradedRing : CommRingEquiv ⊕HITgradedRing-CommRing ⊕FunGradedRing-CommRing
      CommRingEquiv-DirectSumGradedRing = InducedCommRingEquiv ⊕HITgradedRing-CommRing
                                        0⊕Fun 1⊕Fun _+⊕Fun_ _prodF_ -⊕Fun_
                                        (fst (Equiv-DirectSum G Gstr))
                                        (pres1 (snd (Equiv-DirectSum G Gstr)))
                                        ⊕HIT→⊕Fun-pres1
                                        (pres· (snd (Equiv-DirectSum G Gstr)))
                                        ⊕HIT→⊕Fun-pres-prodF
                                        (presinv (snd (Equiv-DirectSum G Gstr)))


module Issue502 where

record R : Set where
  record S (A : Set) : Set where
    field
      f : A → A


module Structure.Type.Identity.Proofs.Eliminator where

import      Lvl
open import Functional using (_→ᶠ_ ; id ; _on₂_ ; swap ; apply)
open import Logic
open import Logic.Propositional
open import Logic.Propositional.Proofs.Structures
open import Structure.Categorical.Properties
open import Structure.Function
open import Structure.Operator
open import Structure.Groupoid
open import Structure.Setoid using (Equiv ; intro) renaming (_≡_ to _≡ₛ_)
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties
open import Structure.Relator.Properties.Proofs
open import Structure.Relator
open import Structure.Type.Identity
open import Structure.Type.Identity.Proofs
open import Syntax.Function
open import Syntax.Transitivity
open import Syntax.Type
open import Type

private variable ℓ ℓ₁ ℓ₂ ℓₑ₁ ℓₑ₂ ℓₑ ℓₘₑ ℓₚ ℓₒ : Lvl.Level
private variable T A B : Type{ℓ}
private variable x y : T
private variable Id _≡_ _▫_ : T → T → Stmt{ℓ}

module Oper (Id : T → T → Type{ℓₑ}) ⦃ refl :  Reflexivity(Id) ⦄ ⦃ identElim : IdentityEliminator{ℓₚ = ℓₑ}(Id) ⦄ where
  open Symmetry    (identity-eliminator-to-symmetry     {Id = Id}) using () renaming (proof to sym)   public
  open Transitivity(identity-eliminator-to-transitivity {Id = Id}) using () renaming (proof to trans) public
  ftrans = identity-eliminator-to-flipped-transitivityᵣ ⦃ refl ⦄ ⦃ identElim ⦄

module Oper2 (Id : A → A → Type{ℓₑ}) ⦃ refl :  Reflexivity(Id) ⦄ ⦃ identElim : IdentityEliminator{ℓₚ = ℓₚ}(Id) ⦄ where
  open Reflexivity (refl) using () renaming (proof to refl)  public
  module _ (_▫_ : A → A → Type{ℓₚ}) ⦃ [▫]-refl : Reflexivity(_▫_) ⦄ where
    open _⊆₂_ identity-eliminator-to-reflexive-subrelation using () renaming (proof to sub) public
  module _ (_▫_ : B → B → Type{ℓₚ}) ⦃ [▫]-refl : Reflexivity(_▫_) ⦄ (f : A → B) where
    open _⊆₂_ (minimal-reflection-transport ⦃ minRefl = identity-eliminator-to-reflexive-subrelation ⦄ {_▫_ = _▫_} {f = f}) using () renaming (proof to transp) public

module _
  {Id : T → T → Type{ℓₑ}} ⦃ refle-T :  Reflexivity(Id) ⦄  ⦃ identElim-T : IdentityEliminator(Id) ⦄
  {_≡_ : ∀{T : Type{ℓₑ}} → T → T → Type{ℓₘₑ}}
  ⦃ identElimOfIntro : IdentityEliminationOfIntro(Id)(_≡_) ⦄
  where

  open Oper(Id)
  open Oper2{ℓₚ = ℓₑ}(Id)

  identity-eliminator-symmetry-of-refl : ∀{x} → (sym refl ≡ refl{x})
  identity-eliminator-symmetry-of-refl = idElimOfIntro(Id)(_≡_) (\{x y} _ → (Id y x)) refl

module _
  {Id : T → T → Type{ℓₑ₁}} ⦃ refle-T :  Reflexivity(Id) ⦄  ⦃ identElim-T : IdentityEliminator(Id) ⦄
  {_≡_ : ∀{T : Type{ℓₑ₂}} → T → T → Type{ℓₘₑ}}
  ⦃ identElimOfIntro : IdentityEliminationOfIntro(Id)(_≡_) ⦄
  {_▫_ : T → T → Type{ℓₑ₂}} ⦃ refl-op : Reflexivity(_▫_) ⦄
  where

  open Oper(Id)
  open Oper2{ℓₚ = ℓₑ₂}(Id)

  identity-eliminator-reflexive-subrelation-of-refl : ∀{x} → (sub(_▫_) refl ≡ reflexivity(_▫_){x})
  identity-eliminator-reflexive-subrelation-of-refl = idElimOfIntro(Id)(_≡_) (\{x y} _ → (x ▫ y)) (reflexivity(_▫_))

module _
  {Id : A → A → Type{ℓₑ₁}} ⦃ refle-A :  Reflexivity(Id) ⦄  ⦃ identElim-A : IdentityEliminator(Id) ⦄
  {_≡_ : ∀{T : Type{ℓₑ₂}} → T → T → Type{ℓₘₑ}}
  ⦃ identElimOfIntro : IdentityEliminationOfIntro(Id)(_≡_) ⦄
  {_▫_ : B → B → Type{ℓₑ₂}} ⦃ refle-B : Reflexivity(_▫_) ⦄
  {f : A → B}
  where

  open Oper(Id)
  open Oper2{ℓₚ = ℓₑ₂}(Id)

  identity-eliminator-transport-of-refl : ∀{a} → (transp(_▫_)(f) (refl{a}) ≡ reflexivity(_▫_) {f(a)})
  identity-eliminator-transport-of-refl {a} = identity-eliminator-reflexive-subrelation-of-refl {_≡_ = _≡_} {_▫_ = (_▫_) on₂ f} ⦃ on₂-reflexivity ⦄ {x = a}

module _
  {Id : T → T → Type{ℓₑ}}
    ⦃ refle-T :  Reflexivity(Id) ⦄
    ⦃ identElim-T : IdentityEliminator(Id) ⦄
  {_≡_ : ∀{T : Type{ℓₑ}} → T → T → Type{ℓₘₑ}}
    ⦃ refle-eq : ∀{T : Type} → Reflexivity(_≡_ {T = T}) ⦄
    ⦃ identElim-eq : ∀{T : Type} → IdentityEliminator{ℓₚ = ℓₘₑ}(_≡_ {T = T}) ⦄
  ⦃ identElimOfIntro : IdentityEliminationOfIntro(Id)(_≡_) ⦄
  where

  open Oper(Id)
  open Oper2{ℓₚ = ℓₑ}(Id)
  instance _ = identity-eliminator-to-reflexive-subrelation

  identity-eliminator-flipped-transitivityᵣ-of-refl : ∀{x} → (ftrans refl refl ≡ refl{x})
  identity-eliminator-flipped-transitivityᵣ-of-refl {z} = sub₂(_≡_)((_≡_) on₂ (apply refl)) ⦃ minimal-reflection-transport ⦄ identity-eliminator-transport-of-refl

  identity-eliminator-transitivity-of-refl : ∀{x} → (trans refl refl ≡ refl{x})
  identity-eliminator-transitivity-of-refl = transitivity(_≡_) ⦃ identity-eliminator-to-transitivity ⦄ p identity-eliminator-flipped-transitivityᵣ-of-refl where
    p : trans refl refl ≡ ftrans refl refl
    p = sub₂(_≡_)((_≡_) on₂ (p ↦ identity-eliminator-to-flipped-transitivityᵣ p refl)) ⦃ minimal-reflection-transport ⦄ identity-eliminator-symmetry-of-refl

module _
  ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄
    ⦃ identElim-A : IdentityEliminator(Equiv._≡_ equiv-A) ⦄
  ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄
  {_≡_ : ∀{T : Type{ℓₑ₂}} → T → T → Type{ℓₘₑ}}
  ⦃ identElimOfIntro : IdentityEliminationOfIntro(Equiv._≡_ equiv-A)(_≡_) ⦄
  where

  open Reflexivity(Equiv.reflexivity equiv-A) using () renaming (proof to refl-A)
  open Reflexivity(Equiv.reflexivity equiv-B) using () renaming (proof to refl-B)
  instance _ = identity-eliminator-to-reflexive-subrelation
  instance _ = minimal-reflection-to-function

  identity-eliminator-function-of-refl : ∀{f : A → B}{a} → (congruence₁(f) (refl-A {a}) ≡ refl-B {f(a)})
  identity-eliminator-function-of-refl = identity-eliminator-transport-of-refl

module _
  ⦃ equiv-T : Equiv{ℓₑ₁}(T) ⦄
    ⦃ identElim-T : IdentityEliminator(Equiv._≡_ equiv-T) ⦄
  {_≡_ : ∀{T : Type{ℓₑ₂}} → T → T → Type{ℓₘₑ}}
    ⦃ refle-eq : ∀{T : Type} → Reflexivity(_≡_ {T = T}) ⦄
    ⦃ identElim-eq : ∀{T : Type} → IdentityEliminator{ℓₚ = ℓₘₑ}(_≡_ {T = T}) ⦄
  ⦃ identElimOfIntro : IdentityEliminationOfIntro(Equiv._≡_ equiv-T)(_≡_) ⦄
  where

  open Reflexivity(Equiv.reflexivity equiv-T) using () renaming (proof to refl)
  instance _ = identity-eliminator-to-reflexive-subrelation
  instance _ = minimal-reflection-to-relator

  identity-eliminator-relator-of-refl : ∀{P : T → Stmt}{x}{p : P(x)} → (substitute₁(P) refl p ≡ p)
  identity-eliminator-relator-of-refl {p = p} = sub₂(_≡_)((_≡_) on₂ (apply p)) ⦃ minimal-reflection-transport ⦄ identity-eliminator-transport-of-refl
module _
  {Id : T → T → Type{ℓₑ}}
    ⦃ refle-T :  Reflexivity(Id) ⦄
    ⦃ identElim-T : ∀{ℓₚ} → IdentityEliminator{ℓₚ = ℓₚ}(Id) ⦄
    -- ⦃ identElim₁-T : IdentityEliminator{ℓₚ = ℓₑ}(Id) ⦄
    -- ⦃ identElim₂-T : IdentityEliminator{ℓₚ = ℓₘₑ}(Id) ⦄
    -- ⦃ identElim₃-T : IdentityEliminator{ℓₚ = ℓₑ Lvl.⊔ ℓₘₑ}(Id) ⦄
  {_≡_ : ∀{T : Type{ℓₑ}} → T → T → Type{ℓₘₑ}}
    ⦃ refle-eq : ∀{T : Type} → Reflexivity(_≡_ {T = T}) ⦄
    ⦃ identElim-eq : ∀{T : Type} → IdentityEliminator{ℓₚ = ℓₘₑ}(_≡_ {T = T}) ⦄ -- TODO: Try to not have these and instead have the properties that are used
  ⦃ identElimOfIntro : IdentityEliminationOfIntro(Id)(_≡_) ⦄
  where

  open Reflexivity (refle-T)                                       using () renaming (proof to refl)
  open Symmetry    (identity-eliminator-to-symmetry     {Id = Id}) using () renaming (proof to sym)
  open Transitivity(identity-eliminator-to-transitivity {Id = Id}) using () renaming (proof to trans)
  instance _ = identity-eliminator-to-reflexive-subrelation
  instance _ = \{T} → identity-eliminator-to-symmetry     {Id = _≡_ {T = T}} ⦃ refl = refle-eq ⦄ ⦃ identElim = identElim-eq ⦄
  instance _ = \{T} → identity-eliminator-to-transitivity {Id = _≡_ {T = T}} ⦃ refl = refle-eq ⦄ ⦃ identElim = identElim-eq ⦄
  instance _ = \{T} → Structure.Setoid.intro(_) ⦃ identity-eliminator-to-equivalence {Id = _≡_ {T = T}} ⦃ refl = refle-eq ⦄ ⦃ identElim = identElim-eq ⦄ ⦄

  identity-eliminator-identityₗ : ∀{x y}{p : Id x y} → (trans refl p ≡ p)
  identity-eliminator-identityₗ {p = p} = idElim(Id) (p ↦ (trans refl p ≡ p)) identity-eliminator-transitivity-of-refl p

  identity-eliminator-identityᵣ : ∀{x y}{p : Id x y} → (trans p refl ≡ p)
  identity-eliminator-identityᵣ {p = p} = idElim(Id) (p ↦ (trans p refl ≡ p)) identity-eliminator-transitivity-of-refl p

  identity-eliminator-associativity : ∀{x y z w}{p : Id x y}{q : Id y z}{r : Id z w} → (trans (trans p q) r ≡ trans p (trans q r))
  identity-eliminator-associativity {p = p} {q = q} {r = r} =
    idElim(Id)
      (p ↦ ∀ q r → (trans (trans p q) r ≡ trans p (trans q r)))
      (q ↦ r ↦ (
        trans (trans refl q) r 🝖[ _≡_ ]-[ sub₂(_≡_)((_≡_) on₂ (expr ↦ trans expr r)) ⦃ identity-eliminator-to-reflexive-subrelation ⦃ refl = on₂-reflexivity ⦄ ⦄ identity-eliminator-identityₗ ]
        trans q r              🝖[ _≡_ ]-[ identity-eliminator-identityₗ ]-sym
        trans refl (trans q r) 🝖-end
      ))
      p q r

  identity-eliminator-inverseₗ : ∀{x y}{p : Id x y} → (trans (sym p) p ≡ refl)
  identity-eliminator-inverseₗ {p = p} =
    idElim(Id)
      (p ↦ trans (sym p) p ≡ refl)
      (
        trans (sym refl) refl 🝖[ _≡_ ]-[ identity-eliminator-identityᵣ ]
        sym refl              🝖[ _≡_ ]-[ identity-eliminator-symmetry-of-refl ]
        refl                  🝖-end
      )
      p

  identity-eliminator-inverseᵣ : ∀{x y}{p : Id x y} → (trans p (sym p) ≡ refl)
  identity-eliminator-inverseᵣ {p = p} =
    idElim(Id)
      (p ↦ trans p (sym p) ≡ refl)
      (
        trans refl (sym refl) 🝖[ _≡_ ]-[ identity-eliminator-identityₗ ]
        sym refl              🝖[ _≡_ ]-[ identity-eliminator-symmetry-of-refl ]
        refl                  🝖-end
      )
      p

  identity-eliminator-categorical-identityₗ : Morphism.Identityₗ{Obj = T} (\{x} → swap(trans{x})) (refl)
  identity-eliminator-categorical-identityₗ = Morphism.intro identity-eliminator-identityᵣ

  identity-eliminator-categorical-identityᵣ : Morphism.Identityᵣ{Obj = T} (\{x} → swap(trans{x})) (refl)
  identity-eliminator-categorical-identityᵣ = Morphism.intro identity-eliminator-identityₗ

  identity-eliminator-categorical-identity : Morphism.Identity{Obj = T} (\{x} → swap(trans{x})) (refl)
  identity-eliminator-categorical-identity = [∧]-intro identity-eliminator-categorical-identityₗ identity-eliminator-categorical-identityᵣ

  identity-eliminator-categorical-associativity : Morphism.Associativity{Obj = T} (\{x} → swap(trans{x}))
  identity-eliminator-categorical-associativity = Morphism.intro (symmetry(_≡_) identity-eliminator-associativity)

  identity-eliminator-categorical-inverterₗ : Polymorphism.Inverterₗ{Obj = T} (\{x} → swap(trans{x})) (refl) (sym)
  identity-eliminator-categorical-inverterₗ = Polymorphism.intro identity-eliminator-inverseᵣ

  identity-eliminator-categorical-inverterᵣ : Polymorphism.Inverterᵣ{Obj = T} (\{x} → swap(trans{x})) (refl) (sym)
  identity-eliminator-categorical-inverterᵣ = Polymorphism.intro identity-eliminator-inverseₗ

  identity-eliminator-categorical-inverter : Polymorphism.Inverter{Obj = T} (\{x} → swap(trans{x})) (refl) (sym)
  identity-eliminator-categorical-inverter = [∧]-intro identity-eliminator-categorical-inverterₗ identity-eliminator-categorical-inverterᵣ

  identity-eliminator-groupoid : Groupoid(Id)
  Groupoid._∘_ identity-eliminator-groupoid = swap(trans)
  Groupoid.id  identity-eliminator-groupoid = refl
  Groupoid.inv identity-eliminator-groupoid = sym
  Groupoid.associativity  identity-eliminator-groupoid = identity-eliminator-categorical-associativity
  Groupoid.identity       identity-eliminator-groupoid = identity-eliminator-categorical-identity
  Groupoid.inverter       identity-eliminator-groupoid = identity-eliminator-categorical-inverter
  Groupoid.binaryOperator identity-eliminator-groupoid = intro a where postulate a : ∀{a} → a -- TODO


module Automata.Composition.Union (Σ : Set) where

-- Standard libraries imports ----------------------------------------
open import Data.Empty using (⊥ ; ⊥-elim)
open import Data.Nat using (ℕ)
open import Data.Sum using (_⊎_ ; inj₁ ; inj₂)
open import Data.Product using (_,_)
open import Data.Vec using (Vec ; [] ; _∷_)

open import Relation.Nullary using (¬_)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl)
----------------------------------------------------------------------

-- Thesis imports ----------------------------------------------------
open import Automata.Nondeterministic
----------------------------------------------------------------------

_∪_ : (M : NDA Σ) → (N : NDA Σ) → NDA Σ
⟨ Q₁ , S₁ , F₁ , Δ₁ ⟩ ∪ ⟨ Q₂ , S₂ , F₂ , Δ₂ ⟩ = ⟨ Q , S , F , Δ ⟩
  where
    Q : Set _
    Q = Q₁ ⊎ Q₂

    S : Q → Set _
    S (inj₁ q) = S₁ q
    S (inj₂ q) = S₂ q

    F : Q → Set
    F (inj₁ q) = F₁ q
    F (inj₂ q) = F₂ q

    Δ : Q → Σ → Q → Set
    Δ (inj₁ q) c (inj₁ q′) = Δ₁ q c q′
    Δ (inj₂ q) c (inj₂ q′) = Δ₂ q c q′
    {-# CATCHALL #-}
    Δ _ _ _ = ⊥ -- No connections between the machines

M-Δ*⇒M∪N-Δ* : {M N : NDA Σ}
             → let Q₁ = NDA.Q M
                   Δ₁* = NDA.Δ* M
                   Δ* = NDA.Δ* (M ∪ N) in
               (q : Q₁) → {n : ℕ} → (xs : Vec Σ n) → (q′ : Q₁)
             → Δ₁* q xs q′
             → Δ* (inj₁ q) xs (inj₁ q′)
M-Δ*⇒M∪N-Δ* q [] .q refl = refl
M-Δ*⇒M∪N-Δ* q (x ∷ xs) q′ (q₀ , Δ₁-q-x-q₀ , Δ₁*-q₀-xs-q′) =
  inj₁ q₀ , Δ₁-q-x-q₀ , M-Δ*⇒M∪N-Δ* q₀ xs q′ Δ₁*-q₀-xs-q′

N-Δ*⇒M∪N-Δ* : {M N : NDA Σ}
             → let Q₂ = NDA.Q N
                   Δ₂* = NDA.Δ* N
                   Δ* = NDA.Δ* (M ∪ N) in
               (q : Q₂) → {n : ℕ} → (xs : Vec Σ n) → (q′ : Q₂)
             → Δ₂* q xs q′
             → Δ* (inj₂ q) xs (inj₂ q′)
N-Δ*⇒M∪N-Δ* q [] .q refl = refl
N-Δ*⇒M∪N-Δ* q (x ∷ xs) q′ (q₀ , Δ₂-q-x-q₀ , Δ₂*-q₀-xs-q′) =
  inj₂ q₀ , Δ₂-q-x-q₀ , N-Δ*⇒M∪N-Δ* q₀ xs q′ Δ₂*-q₀-xs-q′

M∪N-Δ*⇒M-Δ* : {M N : NDA Σ}
             → let Q₁ = NDA.Q M
                   Δ₁* = NDA.Δ* M
                   Δ* = NDA.Δ* (M ∪ N) in
               (q : Q₁) → {n : ℕ} → (xs : Vec Σ n) → (q′ : Q₁)
             → Δ* (inj₁ q) xs (inj₁ q′)
             → Δ₁* q xs q′
M∪N-Δ*⇒M-Δ* q [] .q refl = refl
M∪N-Δ*⇒M-Δ* q (x ∷ xs) q′ (inj₁ q₀ , Δ-q-x-q₀ , Δ*-q₀-xs-q′) =
  q₀ , Δ-q-x-q₀ , M∪N-Δ*⇒M-Δ* q₀ xs q′ Δ*-q₀-xs-q′

M∪N-Δ*⇒N-Δ* : {M N : NDA Σ}
             → let Q₂ = NDA.Q N
                   Δ₂* = NDA.Δ* N
                   Δ* = NDA.Δ* (M ∪ N) in
               (q : Q₂) → {n : ℕ} → (xs : Vec Σ n) → (q′ : Q₂)
             → Δ* (inj₂ q) xs (inj₂ q′)
             → Δ₂* q xs q′
M∪N-Δ*⇒N-Δ* q [] .q refl = refl
M∪N-Δ*⇒N-Δ* q (x ∷ xs) q′ (inj₂ q₀ , Δ-q-x-q₀ , Δ*-q₀-xs-q′) =
  q₀ , Δ-q-x-q₀ , M∪N-Δ*⇒N-Δ* q₀ xs q′ Δ*-q₀-xs-q′

M∪N-Δ*-disconnectedˡ : {M N : NDA Σ}
                     → let Q₁ = NDA.Q M
                           Q₂ = NDA.Q N
                           Δ* = NDA.Δ* (M ∪ N) in
                       (q : Q₁) → {n : ℕ} → (xs : Vec Σ n) → (q′ : Q₂)
                     → ¬ (Δ* (inj₁ q) xs (inj₂ q′))
M∪N-Δ*-disconnectedˡ q (x ∷ xs) q′ (inj₁ q₀ , _ , Δ*-q₀-xs-q′) =
  M∪N-Δ*-disconnectedˡ q₀ xs q′ Δ*-q₀-xs-q′

M∪N-Δ*-disconnectedʳ : {M N : NDA Σ}
                     → let Q₁ = NDA.Q M
                           Q₂ = NDA.Q N
                           Δ* = NDA.Δ* (M ∪ N) in
                       (q : Q₂) → {n : ℕ} → (xs : Vec Σ n) → (q′ : Q₁)
                     → ¬ (Δ* (inj₂ q) xs (inj₁ q′))
M∪N-Δ*-disconnectedʳ q (x ∷ xs) q′ (inj₂ q₀ , _ , Δ*-q₀-xs-q′) =
  M∪N-Δ*-disconnectedʳ q₀ xs q′ Δ*-q₀-xs-q′

M-Accepts⇒M∪N-Accepts : {M N : NDA Σ}
                      → {n : ℕ} → (xs : Vec Σ n)
                      → NDA.Accepts M xs
                      → NDA.Accepts (M ∪ N) xs
M-Accepts⇒M∪N-Accepts [] (q , S-q , .q , F-q , refl) =
  inj₁ q , S-q , inj₁ q , F-q , refl
M-Accepts⇒M∪N-Accepts (x ∷ xs)
  ( q  , S-q         -- The beginning state
  , q′ , F-q′       -- The ending state
  , q₀ , Δ₁-q-x-q₀   -- The first step
  , Δ₁*-q₀-xs-q′) =  -- The remaining steps
  -- Translate to the union:
    (inj₁ q , S-q        -- The beginning state
    , inj₁ q′ , F-q′     -- The ending state
    , inj₁ q₀ , Δ₁-q-x-q₀  -- The first step
    , M-Δ*⇒M∪N-Δ* q₀ xs q′ Δ₁*-q₀-xs-q′)   -- The remaining steps (applying I.H.)

N-Accepts⇒M∪N-Accepts : {M N : NDA Σ}
                      → {n : ℕ} → (xs : Vec Σ n)
                      → NDA.Accepts N xs
                      → NDA.Accepts (M ∪ N) xs
N-Accepts⇒M∪N-Accepts [] (q , S-q , .q , F-q , refl) =
  inj₂ q , S-q , inj₂ q , F-q , refl
N-Accepts⇒M∪N-Accepts (x ∷ xs)
  ( q , S-q
  , q′ , F-q′
  , q₀ , Δ-q-x-q₀
  , Δ*-q₀-xs-q′) =
    ( inj₂ q , S-q
    , inj₂ q′ , F-q′
    , inj₂ q₀ , Δ-q-x-q₀
    , N-Δ*⇒M∪N-Δ* q₀ xs q′ Δ*-q₀-xs-q′ )

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

M∪N-Accepts⇒M-Accepts∨N-Accepts : {M N : NDA Σ}
                                → {n : ℕ} → (xs : Vec Σ n)
                                → NDA.Accepts (M ∪ N) xs
                                → NDA.Accepts M xs  ⊎  NDA.Accepts N xs

-- Base cases.

M∪N-Accepts⇒M-Accepts∨N-Accepts []
  (inj₁ q , S-q , .(inj₁ q) , F-q , refl) =
    inj₁ (q , S-q , q , F-q , refl)
M∪N-Accepts⇒M-Accepts∨N-Accepts []
  (inj₂ q , S-q , .(inj₂ q) , F-q , refl) =
    inj₂ (q , S-q , q , F-q , refl)

-- Induction step 1: both the start and final state are in M.

M∪N-Accepts⇒M-Accepts∨N-Accepts (x ∷ xs)
  ( inj₁ q  , S-q
  , inj₁ q′ , F-q′
  , inj₁ q₀ , Δ-q-x-q₀
  , Δ*-q₀-xs-q′) =
    inj₁ ( q , S-q
         , q′ , F-q′
         , q₀ , Δ-q-x-q₀
         , M∪N-Δ*⇒M-Δ* q₀ xs q′ Δ*-q₀-xs-q′)

-- Induction step 2: both the start and final state are in N.

M∪N-Accepts⇒M-Accepts∨N-Accepts (x ∷ xs)
  ( inj₂ q  , S-q
  , inj₂ q′ , F-q′
  , inj₂ q₀ , Δ-q-x-q₀
  , Δ*-q₀-xs-q′) =
    inj₂ ( q  , S-q
         , q′ , F-q′
         , q₀ , Δ-q-x-q₀
         , M∪N-Δ*⇒N-Δ* q₀ xs q′ Δ*-q₀-xs-q′)

-- Unreachable cases: the proof of “Accepts (M ∪ N) xs”
-- asserts M and N are connected.

M∪N-Accepts⇒M-Accepts∨N-Accepts (x ∷ xs)
  (inj₁ q , _ , inj₂ q′ , _ , inj₁ q₀ , _ , Δ*-q₀-xs-q′) =
    ⊥-elim (M∪N-Δ*-disconnectedˡ q₀ xs q′ Δ*-q₀-xs-q′)
M∪N-Accepts⇒M-Accepts∨N-Accepts (x ∷ xs)
  (inj₂ q , _ , inj₁ q′ , _ , inj₂ q₀ , _ , Δ*-q₀-xs-q′) =
    ⊥-elim (M∪N-Δ*-disconnectedʳ q₀ xs q′ Δ*-q₀-xs-q′)

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


------------------------------------------------------------------------
-- Polymorphic and iso-recursive lambda terms
------------------------------------------------------------------------

module SystemF.Term where

open import Data.Fin using (Fin; zero; suc; inject+)
open import Data.Fin.Substitution
open import Data.Fin.Substitution.Lemmas
open import Data.Nat using (ℕ; suc; _+_; _∸_)
open import Data.Product using (Σ; _,_)
open import Data.Vec using (Vec; []; _∷_; lookup; map)
open import Function as Fun hiding (id)
open import Relation.Binary.PropositionalEquality as PropEq
  using (refl; _≡_; cong; cong₂; sym)
open PropEq.≡-Reasoning

open import SystemF.Type

------------------------------------------------------------------------
-- Untyped terms and values

infixl 9 _[_] _·_

-- Untyped terms with up to m free term variables and up to n free
-- type variables
data Term (m n : ℕ) : Set where
  var     : (x : Fin m)                   → Term m n  -- term variable
  Λ       : Term m (1 + n)                → Term m n  -- type abstraction
  λ'      : Type n       → Term (1 + m) n → Term m n  -- term abstraction
  μ       : Type n       → Term (1 + m) n → Term m n  -- recursive term
  _[_]    : Term m n     → Type n         → Term m n  -- type application
  _·_     : Term m n     → Term m n       → Term m n  -- term application
  fold    : Type (1 + n) → Term m n       → Term m n  -- fold recursive type
  unfold  : Type (1 + n) → Term m n       → Term m n  -- unfold recursive type

-- Untyped values with up to m free term variables and up to n free
-- type variables
data Val (m n : ℕ) : Set where
  Λ       : Term m (1 + n)                → Val m n   -- type abstraction
  λ'      : Type n       → Term (1 + m) n → Val m n   -- term abstraction
  fold    : Type (1 + n) → Val m n        → Val m n   -- fold recursive type

-- Conversion from values to terms
⌜_⌝  : ∀ {m n} → Val m n → Term m n
⌜ Λ x      ⌝ = Λ x
⌜ λ' a t   ⌝ = λ' a t
⌜ fold a t ⌝ = fold a ⌜ t ⌝

------------------------------------------------------------------------
-- Substitutions in terms

-- Type substitutions in terms
module TermTypeSubst where

  module TermTypeApp {T : ℕ → Set} (l : Lift T Type) where
    open Lift l hiding (var)
    open TypeSubst.TypeApp l renaming (_/_ to _/tp_)

    infixl 8 _/_

    -- Apply a type substitution to a term
    _/_ : ∀ {m n k} → Term m n → Sub T n k → Term m k
    var x      / σ = var x
    Λ t        / σ = Λ (t / σ ↑)
    λ' a t     / σ = λ' (a /tp σ) (t / σ)
    μ a t      / σ = μ (a /tp σ) (t / σ)
    t [ a ]    / σ = (t / σ) [ a /tp σ ]
    s · t      / σ = (s / σ) · (t / σ)
    fold a t   / σ = fold (a /tp σ ↑) (t / σ)
    unfold a t / σ = unfold (a /tp σ ↑) (t / σ)

  open TypeSubst using (varLift; termLift; sub)

  module Lifted {T} (lift : Lift T Type) {m} where
    application : Application (Term m) T
    application = record { _/_ = TermTypeApp._/_ lift {m = m} }

    open Application application public

  open Lifted termLift public

  -- Apply a type variable substitution (renaming) to a term
  _/Var_ : ∀ {m n k} → Term m n → Sub Fin n k → Term m k
  _/Var_ = TermTypeApp._/_ varLift

  -- Weaken a term with an additional type variable
  weaken : ∀ {m n} → Term m n → Term m (suc n)
  weaken t = t /Var VarSubst.wk

  infix 8 _[/_]

  -- Shorthand for single-variable type substitutions in terms
  _[/_] : ∀ {m n} → Term m (1 + n) → Type n → Term m n
  t [/ b ] = t / sub b

-- Lemmas about type substitutions in terms.
module TermTypeLemmas where
  open TermTypeSubst public

  private module T = TypeLemmas
  private module V = VarLemmas

  /-↑⋆ :
    ∀ {T₁ T₂} {lift₁ : Lift T₁ Type} {lift₂ : Lift T₂ Type} →
    let open T.Lifted lift₁ using () renaming (_↑⋆_ to _↑⋆₁_; _/_ to _/tp₁_)
        open   Lifted lift₁ using () renaming (_/_  to _/₁_)
        open T.Lifted lift₂ using () renaming (_↑⋆_ to _↑⋆₂_; _/_ to _/tp₂_)
        open   Lifted lift₂ using () renaming (_/_  to _/₂_)
    in
    ∀ {n k} (ρ₁ : Sub T₁ n k) (ρ₂ : Sub T₂ n k) →
    (∀ i x → Type.var x /tp₁ ρ₁ ↑⋆₁ i ≡ Type.var x /tp₂ ρ₂ ↑⋆₂ i) →
     ∀ i {m} (t : Term m (i + n))  → t /₁ ρ₁ ↑⋆₁ i ≡ t /₂ ρ₂ ↑⋆₂ i
  /-↑⋆ ρ₁ ρ₂ hyp i (var x)      = refl
  /-↑⋆ ρ₁ ρ₂ hyp i (Λ t)        = cong Λ      (/-↑⋆ ρ₁ ρ₂ hyp (1 + i) t)
  /-↑⋆ ρ₁ ρ₂ hyp i (λ' a t)     =
    cong₂ λ'     (T./-↑⋆ ρ₁ ρ₂ hyp i a)       (/-↑⋆ ρ₁ ρ₂ hyp i t)
  /-↑⋆ ρ₁ ρ₂ hyp i (μ a t)      =
    cong₂ μ      (T./-↑⋆ ρ₁ ρ₂ hyp i a)       (/-↑⋆ ρ₁ ρ₂ hyp i t)
  /-↑⋆ ρ₁ ρ₂ hyp i (t [ b ])    =
    cong₂ _[_]     (/-↑⋆ ρ₁ ρ₂ hyp i t)     (T./-↑⋆ ρ₁ ρ₂ hyp i b)
  /-↑⋆ ρ₁ ρ₂ hyp i (s · t)      =
    cong₂ _·_      (/-↑⋆ ρ₁ ρ₂ hyp i s)       (/-↑⋆ ρ₁ ρ₂ hyp i t)
  /-↑⋆ ρ₁ ρ₂ hyp i (fold a t)   =
    cong₂ fold   (T./-↑⋆ ρ₁ ρ₂ hyp (1 + i) a) (/-↑⋆ ρ₁ ρ₂ hyp i t)
  /-↑⋆ ρ₁ ρ₂ hyp i (unfold a t) =
    cong₂ unfold (T./-↑⋆ ρ₁ ρ₂ hyp (1 + i) a) (/-↑⋆ ρ₁ ρ₂ hyp i t)

  /-wk : ∀ {m n} (t : Term m n) → t / TypeSubst.wk ≡ weaken t
  /-wk t = /-↑⋆ TypeSubst.wk VarSubst.wk (λ k x → begin
    tpVar x T./ T.wk T.↑⋆ k         ≡⟨ T.var-/-wk-↑⋆ k x ⟩
    tpVar (Data.Fin.lift k suc x)   ≡⟨ cong tpVar (sym (V.var-/-wk-↑⋆ k x)) ⟩
    tpVar (lookup (V.wk V.↑⋆ k) x)  ≡⟨ refl ⟩
    tpVar x T./Var V.wk V.↑⋆ k      ∎) 0 t
      where open Type using () renaming (var to tpVar)

-- Term substitutions in terms
module TermTermSubst where

  -- Substitutions of terms in terms
  --
  -- A TermSub T m n k is a substitution which, when applied to a term
  -- with at most m free term variables and n free type variables,
  -- yields a term with at most k free term variables and n free type
  -- variables.
  TermSub : (ℕ → ℕ → Set) → ℕ → ℕ → ℕ → Set
  TermSub T m n k = Sub (flip T n) m k

  record TermLift (T : ℕ → ℕ → Set) : Set where
    infix 10 _↑tm _↑tp
    field
      lift : ∀ {m n} → T m n → Term m n
      _↑tm : ∀ {m n k} → TermSub T m n k → TermSub T (suc m) n (suc k)
      _↑tp : ∀ {m n k} → TermSub T m n k → TermSub T m (suc n) k

  module TermTermApp {T} (l : TermLift T) where
    open TermLift l

    infixl 8 _/_

    -- Apply a term substitution to a term
    _/_ : ∀ {m n k} → Term m n → TermSub T m n k → Term k n
    var x      / ρ = lift (lookup ρ x)
    Λ t        / ρ = Λ (t / ρ ↑tp)
    λ' a t     / ρ = λ' a (t / ρ ↑tm)
    μ a t      / ρ = μ a (t / ρ ↑tm)
    t [ a ]    / ρ = (t / ρ) [ a ]
    s · t      / ρ = (s / ρ) · (t / ρ)
    fold a t   / ρ = fold a (t / ρ)
    unfold a t / ρ = unfold a (t / ρ)

  Fin′ : ℕ → ℕ → Set
  Fin′ m _ = Fin m

  varLift : TermLift Fin′
  varLift = record { lift = var; _↑tm = VarSubst._↑; _↑tp = Fun.id }

  infixl 8 _/Var_

  _/Var_ : ∀ {m n k} → Term m n → Sub Fin m k → Term k n
  _/Var_ = TermTermApp._/_ varLift

  Term′ : ℕ → ℕ → Set
  Term′ = flip Term

  private
    module ExpandSimple {n : ℕ} where
      simple : Simple (Term′ n)
      simple = record { var = var; weaken = λ t → t /Var VarSubst.wk }

      open Simple simple public

  open ExpandSimple  using (_↑; simple)
  open TermTypeSubst using () renaming (weaken to weakenTp)

  termLift : TermLift Term
  termLift = record
    { lift = Fun.id; _↑tm = _↑ ; _↑tp = λ ρ → map weakenTp ρ }

  private
    module ExpandSubst {n : ℕ} where
      app : Application (Term′ n) (Term′ n)
      app = record { _/_ = TermTermApp._/_ termLift {n = n} }

      subst : Subst (flip Term n)
      subst = record
        { simple      = simple
        ; application = app
        }

      open Subst subst public

  open ExpandSubst public hiding (var; simple)

  infix 8 _[/_]

  -- Shorthand for single-variable term substitutions in terms
  _[/_] : ∀ {m n} → Term (1 + m) n → Term m n → Term m n
  s [/ t ] = s / sub t

open TermTypeSubst renaming (weaken to weakenTmTp)
open TermTermSubst renaming (weaken to weakenTmTm) hiding (id)
open TypeSubst     renaming (weaken to weakenTp; weaken↑ to weakenTp↑)
                   hiding (id)

------------------------------------------------------------------------
-- Encoding of additional term operators
--
-- NOTE: These encoded operators require more type information than
-- their "classic" untyped counterparts.  The additional types are
-- required by the underlying (untyped) abstractions and type
-- applications.  Cf. TAPL sec. 24.3, pp. 377-379.
module TermOperators where

  open TypeOperators using (⊤; ⊥; _→ⁿ_)

  -- Polymorphic identity function
  id : {m n : ℕ} → Term m n
  id = Λ (λ' (var zero) (var zero))

  -- Bottom elimination/univeral property of the initial type
  ⊥-elim : ∀ {m n} → Type n → Term m n
  ⊥-elim a = λ' ⊥ ((var zero) [ a ])

  -- Unit value
  tt = id

  -- Top introduction/universal property of the terminal type
  ⊤-intro : ∀ {m n} → Type n → Term m n
  ⊤-intro a = λ' a id

  -- Packing existential types
  as-∃_pack_,_ : ∀ {m n} → Type (1 + n) → Type n → Term m n → Term m n
  as-∃ a pack b , t =
    Λ (λ' (∀' (weakenTp↑ a →' var (suc zero)))
          ((var zero [ weakenTp b ]) · weakenTmTm (weakenTmTp t)))

  -- Unpacking existential types
  unpack_in'_ : ∀ {m n} → Term m n → Term (1 + m) (1 + n) →
                {a : Type (1 + n)} {b : Type n} → Term m n
  unpack_in'_ s t {a} {b} = (s [ b ]) · (Λ (λ' a t))

  -- n-ary term abstraction
  λⁿ : ∀ {m n k} → Vec (Type n) k → Term (k + m) n → Term m n
  λⁿ []       t = t
  λⁿ (a ∷ as) t = λⁿ as (λ' a t)

  infixl 9 _·ⁿ_

  -- n-ary term application
  _·ⁿ_ : ∀ {m n k} → Term m n → Vec (Term m n) k → Term m n
  s ·ⁿ []       = s
  s ·ⁿ (t ∷ ts) = s ·ⁿ ts · t

  -- Record/tuple constructor
  new : ∀ {m n k} → Vec (Term m n) k → {as : Vec (Type n) k} → Term m n
  new []                = tt
  new (t ∷ ts) {a ∷ as} =
    Λ (λ' (map weakenTp (a ∷ as) →ⁿ var zero)
          (var zero ·ⁿ map weakenTmTm (map weakenTmTp (t ∷ ts))))

  -- Field access/projection
  π : ∀ {m n k} → Fin k → Term m n → {as : Vec (Type n) k} → Term m n
  π     () t {[]}
  π {m} x  t {a ∷ as} =
    (t [ lookup (a ∷ as) x ]) · (λⁿ (a ∷ as) (var (inject+ m x)))


module BBHeap.Properties {A : Set}(_≤_ : A → A → Set) where

open import BBHeap _≤_
open import BBHeap.Perfect _≤_
open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import Data.Empty

sym≃ : {b b' : Bound}{h : BBHeap b}{h' : BBHeap b'} → h ≃ h' → h' ≃ h
sym≃ ≃lf = ≃lf
sym≃ (≃nd b≤x b'≤x' l⋘r l'⋘r' l≃r l'≃r' l≃l') = ≃nd b'≤x' b≤x l'⋘r' l⋘r l'≃r' l≃r (sym≃ l≃l')

trans≃ : {b b' b'' : Bound}{h : BBHeap b}{h' : BBHeap b'}{h'' : BBHeap b''} → h ≃ h' → h' ≃ h'' → h ≃ h''
trans≃ ≃lf ≃lf = ≃lf
trans≃ (≃nd b≤x b'≤x' l⋘r l'⋘r' l≃r _ l≃l') (≃nd .b'≤x' b''≤x'' .l'⋘r' l''⋘r'' _ l''≃r'' l'≃l'') = ≃nd b≤x b''≤x'' l⋘r l''⋘r'' l≃r l''≃r'' (trans≃ l≃l' l'≃l'')

lemma≃ : {b b' : Bound}{h : BBHeap b}{h' : BBHeap b'} → h ≃ h' → h ⋘ h'
lemma≃ ≃lf = lf⋘
lemma≃ (≃nd b≤x b'≤x' l⋘r l'⋘r' l≃r l'≃r' l≃l') = ll⋘ b≤x b'≤x' l⋘r l'⋘r' l'≃r' (trans≃ (sym≃ l≃r) l≃l')

lemma⋗≃ : {b b' b'' : Bound}{h : BBHeap b}{h' : BBHeap b'}{h'' : BBHeap b''} → h ⋗ h' → h' ≃ h'' → h ⋗ h''
lemma⋗≃ (⋗lf b≤x) ≃lf = ⋗lf b≤x
lemma⋗≃ (⋗nd b≤x b'≤x' l⋘r l'⋘r' l≃r _ l⋗l') (≃nd .b'≤x' b''≤x'' .l'⋘r' l''⋘r'' _ l''≃r'' l'≃l'') = ⋗nd b≤x b''≤x'' l⋘r l''⋘r'' l≃r l''≃r'' (lemma⋗≃ l⋗l' l'≃l'')

lemma⋗ : {b b' : Bound}{h : BBHeap b}{h' : BBHeap b'} → h ⋗ h'  → h ⋙ h'
lemma⋗ (⋗lf b≤x) = ⋙lf b≤x
lemma⋗ (⋗nd b≤x b'≤x' l⋘r l'⋘r' l≃r l'≃r' l⋗l') = ⋙rl b≤x b'≤x' l⋘r l≃r l'⋘r' (lemma⋗≃ l⋗l' l'≃r')

lemma⋗⋗ : {b b' b'' : Bound}{h : BBHeap b}{h' : BBHeap b'}{h'' : BBHeap b''} → h ⋗ h' → h'' ⋗ h'  → h ≃ h''
lemma⋗⋗ (⋗lf b≤x) (⋗lf b''≤x'') = ≃nd b≤x b''≤x'' lf⋘ lf⋘ ≃lf ≃lf ≃lf
lemma⋗⋗ (⋗nd b≤x b'≤x' l⋘r l'⋘r' l≃r _ l⋗l') (⋗nd b''≤x'' .b'≤x' l''⋘r'' .l'⋘r' l''≃r'' _ l''⋗l') = ≃nd b≤x b''≤x'' l⋘r l''⋘r'' l≃r l''≃r'' (lemma⋗⋗ l⋗l' l''⋗l')

lemma⋗⋗' : {b b' b'' : Bound}{h : BBHeap b}{h' : BBHeap b'}{h'' : BBHeap b''} → h ⋗ h' → h ⋗ h''  → h' ≃ h''
lemma⋗⋗' (⋗lf b≤x) (⋗nd .b≤x _ .lf⋘ _ _ _ ())
lemma⋗⋗' (⋗nd .b≤x _ .lf⋘ _ _ _ ()) (⋗lf b≤x)
lemma⋗⋗' (⋗lf b≤x) (⋗lf .b≤x) = ≃lf
lemma⋗⋗' (⋗nd b≤x b'≤x' l⋘r l'⋘r' _ l'≃r' l⋗l') (⋗nd .b≤x b''≤x'' .l⋘r l''⋘r'' _ l''≃r'' l⋗l'') = ≃nd b'≤x' b''≤x'' l'⋘r' l''⋘r'' l'≃r' l''≃r'' (lemma⋗⋗' l⋗l' l⋗l'')

lemma≃⋗ : {b b' b'' : Bound}{h : BBHeap b}{h' : BBHeap b'}{h'' : BBHeap b''} → h ≃ h' → h' ⋗ h'' → h ⋗ h''
lemma≃⋗ (≃nd b≤x b'≤x' l⋘r l'⋘r' l≃r _ l≃l') (⋗nd .b'≤x' b''≤x'' .l'⋘r' l''⋘r'' _ l''≃r'' l'⋗l'') = ⋗nd b≤x b''≤x'' l⋘r l''⋘r'' l≃r l''≃r'' (lemma≃⋗ l≃l' l'⋗l'')
lemma≃⋗ (≃nd b≤x b'≤x' lf⋘ lf⋘ ≃lf ≃lf ≃lf) (⋗lf .b'≤x') = ⋗lf b≤x

lemma-⋘-≃ : {b b' b'' : Bound}{h : BBHeap b}{h' : BBHeap b'}{h'' : BBHeap b''} → h ⋘ h' → h' ≃ h'' → h ⋘ h''
lemma-⋘-≃ lf⋘ ≃lf = lf⋘
lemma-⋘-≃ (ll⋘ b≤x b'≤x' l⋘r l'⋘r' _ r≃l') (≃nd .b'≤x' b''≤x'' .l'⋘r' l''⋘r'' _ l''≃r'' l'≃l'') = ll⋘ b≤x b''≤x'' l⋘r l''⋘r'' l''≃r'' (trans≃ r≃l' l'≃l'')
lemma-⋘-≃ (lr⋘ b≤x b'≤x' l⋙r l'⋘r' _ l⋗l') (≃nd .b'≤x' b''≤x'' .l'⋘r' l''⋘r'' _ l''≃r'' l'≃l'') = lr⋘ b≤x b''≤x'' l⋙r l''⋘r'' l''≃r'' (lemma⋗≃ l⋗l' l'≃l'')

lemma-≃-⋙ : {b b' b'' : Bound}{h : BBHeap b}{h' : BBHeap b'}{h'' : BBHeap b''} → h ≃ h' → h' ⋙ h'' → h ⋙ h''
lemma-≃-⋙ (≃nd b≤x b'≤x' lf⋘ lf⋘ ≃lf ≃lf ≃lf) (⋙lf .b'≤x') = ⋙lf b≤x
lemma-≃-⋙ (≃nd b≤x b'≤x' l⋘r l'⋘r' l≃r _ l≃l') (⋙rl .b'≤x' b''≤x'' .l'⋘r' _ l''⋘r'' l'⋗r'') = ⋙rl b≤x b''≤x'' l⋘r l≃r l''⋘r'' (lemma≃⋗ l≃l' l'⋗r'')
lemma-≃-⋙ (≃nd b≤x b'≤x' l⋘r l'⋘r' l≃r _ l≃l') (⋙rr .b'≤x' b''≤x'' .l'⋘r' _ l''⋙r'' l'≃l'') = ⋙rr b≤x b''≤x'' l⋘r l≃r l''⋙r'' (trans≃ l≃l' l'≃l'')

lemma-⋘-⋗ : {b b' b'' : Bound}{h : BBHeap b}{h' : BBHeap b'}{h'' : BBHeap b''} → h ⋘ h' → h'' ⋗ h' → h'' ⋙ h
lemma-⋘-⋗ lf⋘ (⋗lf b≤x) = ⋙lf b≤x
lemma-⋘-⋗ (ll⋘ b≤x b'≤x' l⋘r l'⋘r' _ r≃l') (⋗nd b''≤x'' .b'≤x' l''⋘r'' .l'⋘r' l''≃r'' _ l''⋗l') = ⋙rl b''≤x'' b≤x l''⋘r'' l''≃r'' l⋘r (lemma⋗≃ l''⋗l' (sym≃ r≃l'))
lemma-⋘-⋗ (lr⋘ b≤x b'≤x' l⋙r l'⋘r' _ l⋗l') (⋗nd b''≤x'' .b'≤x' l''⋘r'' .l'⋘r' l''≃r'' _ l''⋗l') = ⋙rr b''≤x'' b≤x l''⋘r'' l''≃r'' l⋙r (lemma⋗⋗ l''⋗l' l⋗l')

lemma-≃-⊥ : {b b' : Bound}{h : BBHeap b}{h' : BBHeap b'} → h ≃ h' → h ⋗ h' → ⊥
lemma-≃-⊥ () (⋗lf _)
lemma-≃-⊥ (≃nd .b≤x .b'≤x' .l⋘r .l'⋘r' _ _ l≃l') (⋗nd b≤x b'≤x' l⋘r l'⋘r' l≃r l'≃r' l⋗l')
    with lemma-≃-⊥ l≃l' l⋗l'
... | ()

lemma-⋘-⊥ : {b b' : Bound}{x x' : A}{l r : BBHeap (val x)}{l' r' : BBHeap (val x')}(b≤x : LeB b (val x))(b'≤x' : LeB b' (val x'))(l⋙r : l ⋙ r)(l'⋘r' : l' ⋘ r') → l ≃ l' → right b≤x l⋙r ⋘ left b'≤x' l'⋘r' → ⊥
lemma-⋘-⊥ b≤x b'≤x' l⋙r l'⋘r' l≃l' (lr⋘ .b≤x .b'≤x' .l⋙r .l'⋘r' _ l⋗l')
    with lemma-≃-⊥ l≃l' l⋗l'
... | ()

lemma-perfect : {b b' : Bound}{h : BBHeap b}{h' : BBHeap b'} → h ⋘ h' → Perfect h'
lemma-perfect lf⋘ = plf
lemma-perfect (ll⋘ b≤x b'≤x' l⋘l l'⋘l' l'≃r' r≃l') = pnd b'≤x' l'⋘l' l'≃r'
lemma-perfect (lr⋘ b≤x b'≤x' l⋙r l'⋘l' l'≃r' l⋗l') = pnd b'≤x' l'⋘l' l'≃r'


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

open import HoTT

module homotopy.SmashFmapConn where

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

  custom-assoc : {a₀ a₁ a₂ a₃ : A}
    {b₀ : B a₀} {b₁ b₁' b₁'' : B a₁} {b₂ : B a₂} {b₃ : B a₃}
    {p : a₀ == a₁} (p' : b₀ == b₁ [ B ↓ p ])
    (q' : b₁ == b₁')
    (r' : b₁' == b₁'')
    {s : a₁ == a₂} (s' : b₁'' == b₂ [ B ↓ s ])
    {t : a₂ == a₃} (t' : b₂ == b₃ [ B ↓ t ])
    → p' ∙ᵈ (((q' ∙ r') ◃ s') ∙ᵈ t')
      ==
      ((p' ▹ q') ▹ r') ∙ᵈ s' ∙ᵈ t'
  custom-assoc {p = idp} p'@idp q'@idp r'@idp {s = idp} s'@idp {t = idp} t' = idp

  transp-over : {a₀ a₁ : A} (p : a₀ == a₁) (b₀ : B a₀)
    → b₀ == transport B p b₀ [ B ↓ p ]
  transp-over p b₀ = from-transp B p (idp {a = transport B p b₀})

  transp-over-naturality : ∀ {a₀ a₁ : A} (p : a₀ == a₁)
    {b₀ b₀' : B a₀} (q : b₀ == b₀')
    → q ◃ transp-over p b₀'
      ==
      transp-over p b₀ ▹ ap (transport B p) q
  transp-over-naturality p@idp q@idp = idp

  to-transp-over : {a₀ a₁ : A} {p : a₀ == a₁}
    {b₀ : B a₀} {b₁ : B a₁} (q : b₀ == b₁ [ B ↓ p ])
    → q ▹ ! (to-transp q) == transp-over p b₀
  to-transp-over {p = idp} q@idp = idp

module _ {i} {j} {S* : Type i} (P* : S* → Type j) where

  -- cpa = custom path algebra
  cpa₁ : {s₁ s₂ t : S*} (p* : P* s₂) (p₁ : s₁ == t) (p₂ : s₂ == t)
    → transport P* (! (p₁ ∙ ! p₂)) p*  == transport P* p₂ p* [ P* ↓ p₁ ]
  cpa₁ p* p₁@idp p₂@idp = idp

  -- cpac = custom path algebra coherence
  cpac₁ : ∀ {k} {C : Type k} (f : C → S*)
    {c₁ c₂ : C} (q : c₁ == c₂)
    (d : Π C (P* ∘ f))
    {t : S*} (p₁ : f c₁ == t) (p₂ : f c₂ == t)
    (r : ap f q == p₁ ∙' ! p₂)
    {u  : P* (f c₂)} (v  : u  == transport P* (! (p₂ ∙ ! p₂)) (d c₂))
    {u' : P* (f c₁)} (v' : u' == transport P* (! (p₁ ∙ ! p₂)) (d c₂))
    → (v' ∙
       ap (λ pp → transport P* pp (d c₂)) (ap ! (! (r ∙ ∙'=∙ p₁ (! p₂))) ∙ !-ap f q) ∙
       to-transp {B = P*} {p = ap f (! q)}
                 (↓-ap-in P* f (apd d (! q)))) ◃
      apd d q
      ==
      ↓-ap-out= P* f q (r ∙ ∙'=∙ p₁ (! p₂))
                ((v' ◃ cpa₁ (d c₂) p₁ p₂) ∙ᵈ !ᵈ (v ◃ cpa₁ (d c₂) p₂ p₂)) ▹
      (v ∙ ap (λ pp → transport P* (! pp) (d c₂)) (!-inv-r p₂))
  cpac₁ f q@idp d p₁@.idp p₂@idp r@idp v@idp v'@idp = idp

  cpa₂ : ∀ {k} {C : Type k} (f : C → S*)
    {c₁ c₂ : C} (q : c₁ == c₂)
    (d : Π C (P* ∘ f))
    {s t : S*} (p : f c₁ == s) (r : s == t) (u : f c₂ == t)
    (h : ap f q == p ∙' (r ∙ ! u))
    → transport P* p (d c₁)
      ==
      transport P* u (d c₂)
        [ P* ↓ r ]
  cpa₂ f q@idp d p@.idp r@idp u@idp h@idp = idp

  cpac₂ : ∀ {k} {C : Type k} (f : C → S*)
    {c₁ c₂ c₃ : C} (q : c₁ == c₂) (q' : c₃ == c₂)
    (d : Π C (P* ∘ f))
    {s t : S*} (p : f c₁ == s) (p' : f c₃ == f c₂) (r : s == t) (u : f c₂ == t)
    (h : ap f q == p ∙' (r ∙ ! u))
    (h' : ap f q' == p' ∙' u ∙ ! u)
    {x : P* (f c₂)} (x' : x == transport P* p' (d c₃))
    {y : P* (f c₁)} (y' : y == d c₁)
    → ↓-ap-out=
        P*
        f
        q
        (h ∙ ∙'=∙ p (r ∙ ! u))
        ((y' ◃ transp-over P* p (d c₁)) ∙ᵈ cpa₂ f q d p r u h ∙ᵈ !ᵈ (x' ◃ cpa₂ f q' d p' u u h')) ▹
      (x' ∙
       ap (λ pp → transport P* pp (d c₃))
          (! (∙-unit-r p') ∙
           ap (p' ∙_) (! (!-inv-r u)) ∙
           ! (h' ∙ ∙'=∙ p' (u ∙ ! u))) ∙
       to-transp (↓-ap-in P* f (apd d q')))
      ==
      y' ◃ apd d q
  cpac₂ f q@idp q'@idp d p@.idp p'@.idp r@idp u@idp h@idp h'@idp x'@idp y'@idp = idp

module _ {i} {j} {k} {A : Ptd i} {A' : Ptd j} (f : A ⊙→ A') (B : Ptd k)
         {m n : ℕ₋₂}
         (f-is-m-conn : has-conn-fibers m (fst f))
         (B-is-Sn-conn : is-connected (S n) (de⊙ B)) where

  private
    a₀ = pt A
    a₀' = pt A'
    b₀ = pt B

  module ConnIn (P : A' ∧ B → (n +2+ m) -Type (lmax i (lmax j k)))
                (d : ∀ (ab : A ∧ B) → fst (P (∧-fmap f (⊙idf B) ab))) where

    h : ∀ (b : de⊙ B)
      → (∀ (a' : de⊙ A') → fst (P (smin a' b)))
      → (∀ (a : de⊙ A) → fst (P (smin (fst f a) b)))
    h b s = s ∘ fst f

    Q : de⊙ B → n -Type (lmax i (lmax j k))
    Q b = Q' , Q'-level
      where
      Q' : Type (lmax i (lmax j k))
      Q' = hfiber (h b) (λ a → d (smin a b))
      Q'-level : has-level n Q'
      Q'-level =
        conn-extend-general
          {n = m} {k = n}
          f-is-m-conn
          (λ a → P (smin a b))
          (λ a → d (smin a b))

    s₀ : ∀ (a' : de⊙ A') → fst (P (smin a' b₀))
    s₀ a' = transport (fst ∘ P) (! (∧-norm-l a')) (d smbasel)

    ∧-fmap-smgluel-β-∙' : ∀ (a : de⊙ A) →
      ap (∧-fmap f (⊙idf B)) (smgluel a)
      ==
      smgluel (fst f a) ∙' ! (smgluel a₀')
    ∧-fmap-smgluel-β-∙' a =
      ∧-fmap-smgluel-β' f (⊙idf B) a ∙
      ∙=∙' (smgluel (fst f a)) (! (smgluel a₀'))

    ∧-fmap-smgluel-β-∙ : ∀ (a : de⊙ A) →
      ap (∧-fmap f (⊙idf B)) (smgluel a)
      ==
      smgluel (fst f a) ∙ ! (smgluel a₀')
    ∧-fmap-smgluel-β-∙ a =
      ∧-fmap-smgluel-β-∙' a ∙
      ∙'=∙ (smgluel (fst f a)) (! (smgluel a₀'))

    ∧-fmap-smgluer-β-∙' : ∀ (b : de⊙ B) →
      ap (∧-fmap f (⊙idf B)) (smgluer b)
      ==
      ap (λ a' → smin a' b) (snd f) ∙' ∧-norm-r b
    ∧-fmap-smgluer-β-∙' b =
      ∧-fmap-smgluer-β' f (⊙idf B) b ∙
      ∙=∙' (ap (λ a' → smin a' b) (snd f)) (∧-norm-r b)

    ∧-fmap-smgluer-β-∙ : ∀ (b : de⊙ B) →
      ap (∧-fmap f (⊙idf B)) (smgluer b)
      ==
      ap (λ a' → smin a' b) (snd f) ∙ ∧-norm-r b
    ∧-fmap-smgluer-β-∙ b =
      ∧-fmap-smgluer-β-∙' b ∙
      ∙'=∙ (ap (λ a' → smin a' b) (snd f)) (∧-norm-r b)

    s₀-f : ∀ (a : de⊙ A) → s₀ (fst f a) == d (smin a b₀)
    s₀-f a =
      ap (λ p → transport (λ a'b → fst (P a'b)) p (d smbasel)) q ∙
      to-transp {B = fst ∘ P}
                {p = ap (∧-fmap f (⊙idf B)) (! (smgluel a))}
                (↓-ap-in (fst ∘ P)
                         (∧-fmap f (⊙idf B))
                         (apd d (! (smgluel a))))
      where
      q : ! (∧-norm-l (fst f a)) == ap (∧-fmap f (⊙idf B)) (! (smgluel a))
      q = ap ! (! (∧-fmap-smgluel-β-∙ a)) ∙ !-ap (∧-fmap f (⊙idf B)) (smgluel a)

    q₀ : fst (Q b₀)
    q₀ = s₀ , s₀-lies-over-pt
      where
      s₀-lies-over-pt : h b₀ s₀ == (λ a → d (smin a b₀))
      s₀-lies-over-pt = λ= s₀-f

    q : ∀ (b : de⊙ B) → fst (Q b)
    q = conn-extend {n = n} {h = cst b₀}
                    (pointed-conn-out (de⊙ B) b₀ {{B-is-Sn-conn}})
                    Q
                    (λ _ → q₀)

    q-f : q b₀ == q₀
    q-f = conn-extend-β {n = n} {h = cst b₀}
                        (pointed-conn-out (de⊙ B) b₀ {{B-is-Sn-conn}})
                        Q
                        (λ _ → q₀)
                        unit

    s : ∀ (a' : de⊙ A') (b : de⊙ B) → fst (P (smin a' b))
    s a' b = fst (q b) a'

    s-b₀ : ∀ (a' : de⊙ A') → s a' b₀ == s₀ a'
    s-b₀ a' = ap (λ u → fst u a') q-f

    s-f : ∀ (a : de⊙ A) (b : de⊙ B)
      → s (fst f a) b == d (smin a b)
    s-f a b = app= (snd (q b)) a

    s-f-b₀ : ∀ (a : de⊙ A)
      → s-f a b₀ == s-b₀ (fst f a) ∙ s₀-f a
    s-f-b₀ a =
      app= (snd (q b₀)) a
        =⟨ ↓-app=cst-out' (apd (λ u → app= (snd u) a) q-f) ⟩
      s-b₀ (fst f a) ∙' app= (snd q₀) a
        =⟨ ap (s-b₀ (fst f a) ∙'_) (app=-β s₀-f a) ⟩
      s-b₀ (fst f a) ∙' s₀-f a
        =⟨ ∙'=∙ (s-b₀ (fst f a)) (s₀-f a) ⟩
      s-b₀ (fst f a) ∙ s₀-f a =∎

    s-a₀' : ∀ (b : de⊙ B) →
      s a₀' b
      ==
      transport (fst ∘ P) (ap (λ a' → smin a' b) (snd f)) (d (smin a₀ b))
    s-a₀' b = ↯ $
      s a₀' b
        =⟪ ! (to-transp (↓-ap-in (fst ∘ P) (λ a' → smin a' b) (apd (λ a' → s a' b) (snd f)))) ⟫
      transport (fst ∘ P) (ap (λ a' → smin a' b) (snd f)) (s (fst f a₀) b)
        =⟪ ap (transport (fst ∘ P) (ap (λ a' → smin a' b) (snd f)))
              (s-f a₀ b) ⟫
      transport (fst ∘ P) (ap (λ a' → smin a' b) (snd f)) (d (smin a₀ b)) ∎∎

    section-smbasel : fst (P smbasel)
    section-smbasel = transport (fst ∘ P) (smgluel a₀') (d smbasel)

    section-smbaser : fst (P smbaser)
    section-smbaser = transport (fst ∘ P) (smgluer b₀) (d smbaser)

    section-smgluel' : ∀ (a' : de⊙ A') → s₀ a' == section-smbasel [ fst ∘ P ↓ smgluel a' ]
    section-smgluel' a' = cpa₁ (fst ∘ P) (d smbasel) (smgluel a') (smgluel a₀')

    section-smgluel : ∀ (a' : de⊙ A') → s a' b₀ == section-smbasel [ fst ∘ P ↓ smgluel a' ]
    section-smgluel a' = s-b₀ a' ◃ section-smgluel' a'

    section-smgluer' : ∀ (b : de⊙ B) →
      transport (fst ∘ P) (ap (λ a' → smin a' b) (snd f)) (d (smin a₀ b))
      ==
      section-smbaser
      [ fst ∘ P ↓ smgluer b ]
    section-smgluer' b =
      cpa₂
        (fst ∘ P)
        (∧-fmap f (⊙idf B))
        (smgluer b)
        d
        (ap (λ a' → smin a' b) (snd f))
        (smgluer b)
        (smgluer b₀)
        (∧-fmap-smgluer-β-∙' b)

    section-smgluer : ∀ (b : de⊙ B) → s a₀' b == section-smbaser [ fst ∘ P ↓ smgluer b ]
    section-smgluer b = s-a₀' b ◃ section-smgluer' b

    module Section =
      SmashElim
        {P = fst ∘ P}
        s
        section-smbasel
        section-smbaser
        section-smgluel
        section-smgluer

    section : Π (A' ∧ B) (fst ∘ P)
    section = Section.f

    is-section-smbasel : s a₀' b₀ == d smbasel
    is-section-smbasel = ↯ $
      s a₀' b₀
        =⟪ s-b₀ a₀' ⟫
      s₀ a₀'
        =⟪idp⟫
      transport (fst ∘ P) (! (∧-norm-l a₀')) (d smbasel)
        =⟪ ap (λ p → transport (fst ∘ P) (! p) (d smbasel))
              (!-inv-r (smgluel a₀')) ⟫
      d smbasel ∎∎

    is-section-smgluel : ∀ (a : de⊙ A) →
      s-f a b₀ ◃ apd d (smgluel a)
      ==
      apd (section ∘ ∧-fmap f (⊙idf B)) (smgluel a) ▹
      is-section-smbasel
    is-section-smgluel a =
      s-f a b₀ ◃ apd d (smgluel a)
        =⟨ ap (_◃ apd d (smgluel a)) (s-f-b₀ a) ⟩
      (s-b₀ (fst f a) ∙ s₀-f a) ◃ apd d (smgluel a)
        =⟨ cpac₁
             (fst ∘ P)
             (∧-fmap f (⊙idf B))
             (smgluel a)
             d
             (smgluel (fst f a))
             (smgluel a₀')
             (∧-fmap-smgluel-β-∙' a)
             (s-b₀ a₀')
             (s-b₀ (fst f a)) ⟩
      ↓-ap-out= (fst ∘ P)
                (∧-fmap f (⊙idf B))
                (smgluel a)
                (∧-fmap-smgluel-β-∙ a)
                (section-smgluel (fst f a) ∙ᵈ !ᵈ (section-smgluel a₀')) ▹
      is-section-smbasel
        =⟨ ! $ ap (_▹ is-section-smbasel) $
           ap (↓-ap-out= (fst ∘ P)
                         (∧-fmap f (⊙idf B))
                         (smgluel a)
                         (∧-fmap-smgluel-β-∙ a)) $
           apd-section-norm-l (fst f a) ⟩
      ↓-ap-out= (fst ∘ P)
                (∧-fmap f (⊙idf B))
                (smgluel a)
                (∧-fmap-smgluel-β-∙ a)
                (apd section (∧-norm-l (fst f a))) ▹
      is-section-smbasel
        =⟨ ! $ ap (_▹ is-section-smbasel) $
           apd-∘'' section
                   (∧-fmap f (⊙idf B))
                   (smgluel a)
                   (∧-fmap-smgluel-β-∙ a) ⟩
      apd (section ∘ ∧-fmap f (⊙idf B)) (smgluel a) ▹
      is-section-smbasel =∎
      where
      apd-section-norm-l : ∀ (a' : de⊙ A') →
        apd section (∧-norm-l a')
        ==
        section-smgluel a' ∙ᵈ !ᵈ (section-smgluel a₀')
      apd-section-norm-l a' =
        apd section (∧-norm-l a')
          =⟨ apd-∙ section (smgluel a') (! (smgluel a₀')) ⟩
        apd section (smgluel a') ∙ᵈ apd section (! (smgluel a₀'))
          =⟨ ap2 _∙ᵈ_ (Section.smgluel-β a')
                      (apd-! section (smgluel a₀') ∙
                       ap !ᵈ (Section.smgluel-β a₀')) ⟩
        section-smgluel a' ∙ᵈ !ᵈ (section-smgluel a₀') =∎

    is-section-smbaser : s a₀' b₀ == d smbaser
    is-section-smbaser = ↯ $
      s a₀' b₀
        =⟪ s-a₀' b₀ ⟫
      transport (fst ∘ P) (ap (λ a' → smin a' b₀) (snd f)) (d (smin a₀ b₀))
        =⟪ ap (λ p → transport (fst ∘ P) p (d (smin a₀ b₀))) (↯ r) ⟫
      transport (fst ∘ P) (ap (∧-fmap f (⊙idf B)) (smgluer b₀)) (d (smin a₀ b₀))
        =⟪ to-transp (↓-ap-in (fst ∘ P) (∧-fmap f (⊙idf B)) (apd d (smgluer b₀))) ⟫
      d smbaser ∎∎
      where
      r : ap (λ a' → smin a' b₀) (snd f) =-= ap (∧-fmap f (⊙idf B)) (smgluer b₀)
      r =
        ap (λ a' → smin a' b₀) (snd f)
          =⟪ ! (∙-unit-r _) ⟫
        ap (λ a' → smin a' b₀) (snd f) ∙ idp
          =⟪ ap (ap (λ a' → smin a' b₀) (snd f) ∙_)
                (! (!-inv-r (smgluer b₀))) ⟫
        ap (λ a' → smin a' b₀) (snd f) ∙ ∧-norm-r b₀
          =⟪ ! (∧-fmap-smgluer-β-∙ b₀) ⟫
        ap (∧-fmap f (⊙idf B)) (smgluer b₀) ∎∎

    is-section-smgluer : ∀ (b : de⊙ B) →
      s-f a₀ b ◃
      apd d (smgluer b)
      ==
      apd (section ∘ ∧-fmap f (⊙idf B)) (smgluer b) ▹
      is-section-smbaser
    is-section-smgluer b = ! $
      apd (section ∘ ∧-fmap f (⊙idf B)) (smgluer b) ▹
      is-section-smbaser
        =⟨ ap (_▹ is-section-smbaser) $
           apd-∘'' section
                  (∧-fmap f (⊙idf B))
                  (smgluer b)
                  (∧-fmap-smgluer-β-∙ b) ⟩
      ↓-ap-out= (fst ∘ P)
                (∧-fmap f (⊙idf B))
                (smgluer b)
                (∧-fmap-smgluer-β-∙ b)
                (apd section (ap (λ a' → smin a' b) (snd f) ∙ ∧-norm-r b)) ▹
      is-section-smbaser
        =⟨ ap (_▹ is-section-smbaser) $
           ap (↓-ap-out= (fst ∘ P)
                         (∧-fmap f (⊙idf B))
                         (smgluer b)
                         (∧-fmap-smgluer-β-∙ b)) $
           apd-section-helper ⟩
      ↓-ap-out= (fst ∘ P)
                (∧-fmap f (⊙idf B))
                (smgluer b)
                (∧-fmap-smgluer-β-∙ b)
                ((s-f a₀ b ◃ transp-over (fst ∘ P) (ap (λ a' → smin a' b) (snd f)) (d (smin a₀ b))) ∙ᵈ
                 section-smgluer' b ∙ᵈ !ᵈ (section-smgluer b₀)) ▹
      is-section-smbaser
        =⟨ cpac₂
             (fst ∘ P)
             (∧-fmap f (⊙idf B))
             (smgluer b)
             (smgluer b₀)
             d
             (ap (λ a' → smin a' b) (snd f))
             (ap (λ a' → smin a' b₀) (snd f))
             (smgluer b)
             (smgluer b₀)
             (∧-fmap-smgluer-β-∙' b)
             (∧-fmap-smgluer-β-∙' b₀)
             (s-a₀' b₀)
             (s-f a₀ b) ⟩
      s-f a₀ b ◃
      apd d (smgluer b) =∎
      where
      apd-section-helper :
        apd section (ap (λ a' → smin a' b) (snd f) ∙ ∧-norm-r b)
        ==
        (s-f a₀ b ◃ transp-over (fst ∘ P) (ap (λ a' → smin a' b) (snd f)) (d (smin a₀ b))) ∙ᵈ
        section-smgluer' b ∙ᵈ !ᵈ (section-smgluer b₀)
      apd-section-helper =
        apd section (ap (λ a' → smin a' b) (snd f) ∙ ∧-norm-r b)
          =⟨ apd-∙ section (ap (λ a' → smin a' b) (snd f)) (∧-norm-r b) ⟩
        apd section (ap (λ a' → smin a' b) (snd f)) ∙ᵈ
        apd section (∧-norm-r b)
          =⟨ ap2 _∙ᵈ_
                 (apd-∘''' section (λ a' → smin a' b) (snd f))
                 (apd-∙ section (smgluer b) (! (smgluer b₀))) ⟩
        ↓-ap-in (fst ∘ P) (λ a' → smin a' b) (apd (λ a' → s a' b) (snd f)) ∙ᵈ
        apd section (smgluer b) ∙ᵈ apd section (! (smgluer b₀))
          =⟨ ap (↓-ap-in (fst ∘ P) (λ a' → smin a' b) (apd (λ a' → s a' b) (snd f)) ∙ᵈ_) $
             ap2 _∙ᵈ_
                  (Section.smgluer-β b)
                  (apd-! section (smgluer b₀) ∙
                  ap !ᵈ (Section.smgluer-β b₀)) ⟩
        ↓-ap-in (fst ∘ P) (λ a' → smin a' b) (apd (λ a' → s a' b) (snd f)) ∙ᵈ
        section-smgluer b ∙ᵈ !ᵈ (section-smgluer b₀)
          =⟨ custom-assoc (fst ∘ P)
               (↓-ap-in (fst ∘ P) (λ a' → smin a' b) (apd (λ a' → s a' b) (snd f)))
               (! (to-transp (↓-ap-in (fst ∘ P) (λ a' → smin a' b) (apd (λ a' → s a' b) (snd f)))))
               (ap (transport (fst ∘ P) (ap (λ a' → smin a' b) (snd f))) (s-f a₀ b))
               (section-smgluer' b)
               (!ᵈ (section-smgluer b₀)) ⟩
        ((↓-ap-in (fst ∘ P) (λ a' → smin a' b) (apd (λ a' → s a' b) (snd f)) ▹
        ! (to-transp (↓-ap-in (fst ∘ P) (λ a' → smin a' b) (apd (λ a' → s a' b) (snd f))))) ▹
        ap (transport (fst ∘ P) (ap (λ a' → smin a' b) (snd f))) (s-f a₀ b)) ∙ᵈ
        section-smgluer' b ∙ᵈ !ᵈ (section-smgluer b₀)
          =⟨ ap (λ u → (u ▹ ap (transport (fst ∘ P) (ap (λ a' → smin a' b) (snd f))) (s-f a₀ b)) ∙ᵈ
                       section-smgluer' b ∙ᵈ !ᵈ (section-smgluer b₀)) $
             to-transp-over (fst ∘ P) $
             ↓-ap-in (fst ∘ P) (λ a' → smin a' b) (apd (λ a' → s a' b) (snd f)) ⟩
        (transp-over (fst ∘ P) (ap (λ a' → smin a' b) (snd f)) (s (fst f a₀) b) ▹
        ap (transport (fst ∘ P) (ap (λ a' → smin a' b) (snd f))) (s-f a₀ b)) ∙ᵈ
        section-smgluer' b ∙ᵈ !ᵈ (section-smgluer b₀)
          =⟨ ! $ ap (_∙ᵈ section-smgluer' b ∙ᵈ !ᵈ (section-smgluer b₀)) $
             transp-over-naturality (fst ∘ P)
               (ap (λ a' → smin a' b) (snd f))
               (s-f a₀ b) ⟩
        (s-f a₀ b ◃ transp-over (fst ∘ P) (ap (λ a' → smin a' b) (snd f)) (d (smin a₀ b))) ∙ᵈ
        section-smgluer' b ∙ᵈ !ᵈ (section-smgluer b₀) =∎

    is-section : section ∘ ∧-fmap f (⊙idf B) ∼ d
    is-section =
      Smash-PathOver-elim
        {P = λ ab → fst (P (∧-fmap f (⊙idf B) ab))}
        (section ∘ ∧-fmap f (⊙idf B))
        d
        s-f
        is-section-smbasel
        is-section-smbaser
        is-section-smgluel
        is-section-smgluer

  {- Proposition 4.3.2 in Guillaume Brunerie's thesis -}
  ∧-fmap-conn-l : has-conn-fibers (n +2+ m) (∧-fmap f (⊙idf B))
  ∧-fmap-conn-l = conn-in (λ P → ConnIn.section P , ConnIn.is-section P)

private
  ∧-swap-conn : ∀ {i} {j} (X : Ptd i) (Y : Ptd j) (n : ℕ₋₂)
    → has-conn-fibers n (∧-swap X Y)
  ∧-swap-conn X Y n yx =
    Trunc-preserves-level {n = -2} n $
    equiv-is-contr-map (∧-swap-is-equiv X Y) yx

∧-fmap-conn-r : ∀ {i} {j} {k}
  (A : Ptd i) {B : Ptd j} {B' : Ptd k} (g : B ⊙→ B')
  {k l : ℕ₋₂}
  → is-connected (S k) (de⊙ A)
  → has-conn-fibers l (fst g)
  → has-conn-fibers (k +2+ l) (∧-fmap (⊙idf A) g)
∧-fmap-conn-r A {B} {B'} g {k} {l} A-is-Sk-conn g-is-l-conn =
  transport
    (has-conn-fibers (k +2+ l))
    (λ= (∧-swap-fmap (⊙idf A) g)) $
  ∘-conn (∧-swap A B)
         (∧-swap B' A ∘ ∧-fmap g (⊙idf A))
         (∧-swap-conn A B _) $
  ∘-conn (∧-fmap g (⊙idf A))
         (∧-swap B' A)
         (∧-fmap-conn-l g A g-is-l-conn A-is-Sk-conn)
         (∧-swap-conn B' A _)

private
  ∘-conn' : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k}
    {n m : ℕ₋₂} (g : B → C) (f : A → B)
    → has-conn-fibers m g
    → has-conn-fibers n f
    → has-conn-fibers (minT n m) (g ∘ f)
  ∘-conn' {n = n} {m = m} g f g-conn f-conn =
    ∘-conn f g
      (λ b → connected-≤T (minT≤l n m) {{f-conn b}})
      (λ c → connected-≤T (minT≤r n m) {{g-conn c}})

{- Proposition 4.3.5 in Guillaume Brunerie's thesis -}
∧-fmap-conn : ∀ {i i' j j'}
  {A : Ptd i} {A' : Ptd i'} (f : A ⊙→ A')
  {B : Ptd j} {B' : Ptd j'} (g : B ⊙→ B')
  {m n k l : ℕ₋₂}
  → is-connected (S k) (de⊙ A')
  → is-connected (S n) (de⊙ B)
  → has-conn-fibers m (fst f)
  → has-conn-fibers l (fst g)
  → has-conn-fibers (minT (n +2+ m) (k +2+ l)) (∧-fmap f g)
∧-fmap-conn {A = A} {A'} f {B} {B'} g {m} {n} {k} {l}
            A'-is-Sk-conn B-is-Sn-conn f-is-m-conn g-is-l-conn =
  transport (has-conn-fibers (minT (n +2+ m) (k +2+ l))) p $
  ∘-conn' (∧-fmap (⊙idf A') g)
          (∧-fmap f (⊙idf B))
          (∧-fmap-conn-r A' g A'-is-Sk-conn g-is-l-conn)
          (∧-fmap-conn-l f B f-is-m-conn B-is-Sn-conn)
  where
  p : ∧-fmap (⊙idf A') g ∘ ∧-fmap f (⊙idf B) == ∧-fmap f g
  p =
    ∧-fmap (⊙idf A') g ∘ ∧-fmap f (⊙idf B)
      =⟨ ! (λ= (∧-fmap-comp f (⊙idf A') (⊙idf B) g)) ⟩
    ∧-fmap (⊙idf A' ⊙∘ f) (g ⊙∘ ⊙idf B)
      =⟨ ap (λ h → ∧-fmap h g) (⊙λ= (⊙∘-unit-l f)) ⟩
    ∧-fmap f g =∎


{-# OPTIONS --safe --warning=error --without-K #-}

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)

open import LogicalFormulae
open import Functions.Definition

module Functions.Lemmas where

invertibleImpliesBijection : {a b : _} {A : Set a} {B : Set b} {f : A → B} → Invertible f → Bijection f
Bijection.inj (invertibleImpliesBijection {a} {b} {A} {B} {f} record { inverse = inverse ; isLeft = isLeft ; isRight = isRight }) {x} {y} fx=fy = ans
  where
    bl : inverse (f x) ≡ inverse (f y)
    bl = applyEquality inverse fx=fy
    ans : x ≡ y
    ans rewrite equalityCommutative (isRight x) | equalityCommutative (isRight y) = bl
Bijection.surj (invertibleImpliesBijection {a} {b} {A} {B} {f} record { inverse = inverse ; isLeft = isLeft ; isRight = isRight }) y = (inverse y , isLeft y)

bijectionImpliesInvertible : {a b : _} {A : Set a} {B : Set b} {f : A → B} → Bijection f → Invertible f
Invertible.inverse (bijectionImpliesInvertible record { inj = inj ; surj = surj }) b = underlying (surj b)
Invertible.isLeft (bijectionImpliesInvertible {f = f} record { inj = inj ; surj = surj }) b with surj b
Invertible.isLeft (bijectionImpliesInvertible {f = f} record { inj = inj ; surj = surj }) b | a , prop = prop
Invertible.isRight (bijectionImpliesInvertible {f = f} record { inj = inj ; surj = surj }) a with surj (f a)
Invertible.isRight (bijectionImpliesInvertible {f = f} record { inj = property ; surj = surj }) a | a₁ , b = property b

injComp : {a b c : _} {A : Set a} {B : Set b} {C : Set c} {f : A → B} {g : B → C} → Injection f → Injection g → Injection (g ∘ f)
injComp {f = f} {g} propF propG pr = propF (propG pr)

surjComp : {a b c : _} {A : Set a} {B : Set b} {C : Set c} {f : A → B} {g : B → C} → Surjection f → Surjection g → Surjection (g ∘ f)
surjComp {f = f} {g} propF propG c with propG c
surjComp {f = f} {g} propF propG c | b , pr with propF b
surjComp {f = f} {g} propF propG c | b , pr | a , pr2 = a , pr'
  where
    pr' : g (f a) ≡ c
    pr' rewrite pr2 = pr

bijectionComp : {a b c : _} {A : Set a} {B : Set b} {C : Set c} {f : A → B} {g : B → C} → Bijection f → Bijection g → Bijection (g ∘ f)
Bijection.inj (bijectionComp bijF bijG) = injComp (Bijection.inj bijF) (Bijection.inj bijG)
Bijection.surj (bijectionComp bijF bijG) = surjComp (Bijection.surj bijF) (Bijection.surj bijG)

compInjRightInj : {a b c : _} {A : Set a} {B : Set b} {C : Set c} {f : A → B} {g : B → C} → Injection (g ∘ f) → Injection f
compInjRightInj {f = f} {g} property {x} {y} fx=fy = property (applyEquality g fx=fy)

compSurjLeftSurj : {a b c : _} {A : Set a} {B : Set b} {C : Set c} {f : A → B} {g : B → C} → Surjection (g ∘ f) → Surjection g
compSurjLeftSurj {f = f} {g} property b with property b
compSurjLeftSurj {f = f} {g} property b | a , b1 = f a , b1

injectionPreservedUnderExtensionalEq : {a b : _} {A : Set a} {B : Set b} {f g : A → B} → Injection f → ({x : A} → f x ≡ g x) → Injection g
injectionPreservedUnderExtensionalEq {A = A} {B} {f} {g} property prop {x} {y} gx=gy = property (transitivity (prop {x}) (transitivity gx=gy (equalityCommutative (prop {y}))))

surjectionPreservedUnderExtensionalEq : {a b : _} {A : Set a} {B : Set b} {f g : A → B} → Surjection f → ({x : A} → f x ≡ g x) → Surjection g
surjectionPreservedUnderExtensionalEq {f = f} {g} surj ext b with surj b
surjectionPreservedUnderExtensionalEq {f = f} {g} surj ext b | a , pr = a , transitivity (equalityCommutative ext) pr

bijectionPreservedUnderExtensionalEq : {a b : _} {A : Set a} {B : Set b} {f g : A → B} → Bijection f → ({x : A} → f x ≡ g x) → Bijection g
Bijection.inj (bijectionPreservedUnderExtensionalEq record { inj = inj ; surj = surj } ext) = injectionPreservedUnderExtensionalEq inj ext
Bijection.surj (bijectionPreservedUnderExtensionalEq record { inj = inj ; surj = surj } ext) = surjectionPreservedUnderExtensionalEq surj ext

inverseIsInvertible : {a b : _} {A : Set a} {B : Set b} {f : A → B} → (inv : Invertible f) → Invertible (Invertible.inverse inv)
Invertible.inverse (inverseIsInvertible {f = f} inv) = f
Invertible.isLeft (inverseIsInvertible {f = f} inv) b = Invertible.isRight inv b
Invertible.isRight (inverseIsInvertible {f = f} inv) a = Invertible.isLeft inv a

idIsBijective : {a : _} {A : Set a} → Bijection (id {a} {A})
Bijection.inj idIsBijective pr = pr
Bijection.surj idIsBijective b = b , refl

functionCompositionExtensionallyAssociative : {a b c d : _} {A : Set a} {B : Set b} {C : Set c} {D : Set d} → (f : A → B) → (g : B → C) → (h : C → D) → (x : A) → (h ∘ (g ∘ f)) x ≡ ((h ∘ g) ∘ f) x
functionCompositionExtensionallyAssociative f g h x = refl


open import Prelude
open import Nat
open import List
open import Bij

-- The contents of this file were originally written in a different codebase,
-- which was itself a descendant of a prior codebase that had been using non-standard
-- definitions of naturals and other basic definitions. As such this code has
-- inherited these non-standard idioms, as seen in Prelude, Nat, and List. Ideally,
-- this file would be refactored to use the Agda standard library instead, but beyond
-- the significant effort of refactoring, the Agda standard library appears not to be
-- packaged with Agda, and must be installed separately. The difficulties inherent in
-- attempting to use a "standard library" that is not sufficiently standard as to be
-- included with Agda itself, added to the difficulties of refactoring, have led us
-- to continue with the the non-standard forms and definitions. We hope that they are
-- fairly self-explanatory and intuitive. Below we note some of our idioms that may
-- not be obvious:
-- * We use "Some" and "None" instead of "Just" and "Nothing"
-- * abort is used to prove any goal given ⊥
-- * == is used for reflexive equality
-- * Z is zero, 1+ is suc
-- * ≤ is defined as data, < is defined as n < m = n ≤ m ∧ n ≠ m
-- * l⟦ i ⟧ is used to (maybe) get the ith element of list l
-- * ∥ l ∥ is the length of a list
--
-- Many of the definitions and theorems are documented to indicate their equivalents
-- in the Coq standard libraries Coq.FSets.FMapInterface and Coq.FSets.FMapFacts
module Delta (K : Set) {{bij : bij K Nat}} where
  abstract -- almost everything in the module is abstract

    open import delta-lemmas K {{bij}}

    ---- core definitions ----

    data dd (V : Set) : Set where
      DD : dl V → dd V

    -- nil/empty
    ∅ : {V : Set} → dd V
    ∅ = DD []

    -- singleton
    ■_ : {V : Set} → (K ∧ V) → dd V
    ■_ (k , v) = DD <| (nat k , v) :: []

    -- extension/insertion
    -- Corresponds to FMapInterface.add
    _,,_ : ∀{V} → dd V → (K ∧ V) → dd V
    (DD d) ,, (k , v) = DD <| d ,,' (nat k , v)

    infixl 10 _,,_

    -- lookup function
    -- Corresponds to FMapInterface.find
    _⟨_⟩ : {V : Set} → dd V → K → Maybe V
    (DD d) ⟨ k ⟩ = d lkup (nat k)

    -- There doesn't appear to be a corresponding function in FMapInterface
    destruct : ∀{V} → dd V → Maybe ((K ∧ V) ∧ dd V)
    destruct (DD [])
      = None
    destruct (DD ((n , v) :: []))
      = Some ((key n , v) , DD [])
    destruct (DD ((n , v) :: ((m , v') :: dd)))
      = Some ((key n , v) , DD ((m + 1+ n , v') :: dd))

    -- size
    -- Corresponds to FMapInterface.cardinal
    ||_|| : {V : Set} → dd V → Nat
    || DD d || = ∥ d ∥

    -- membership
    -- Corresponds to FMapInterface.MapsTo
    _∈_ : {V : Set} (p : K ∧ V) → (d : dd V) → Set
    _∈_ {V} (k , v) (DD d) = _∈'_ {V} (nat k , v) d

  -- domain (not abstract)
  -- Corresponds to FMapInterface.In
  dom : {V : Set} → dd V → K → Set
  dom {V} d k = Σ[ v ∈ V ] ((k , v) ∈ d)

  -- apartness, i.e. the opposite of dom (not abstract)
  _#_ : {V : Set} → K → dd V → Set
  k # d = dom d k → ⊥

  abstract

    -- maps f across the values of the delta dict
    -- Corresponds to FMapInterface.map
    dltmap : {A B : Set} → (A → B) → dd A → dd B
    dltmap f (DD d) = DD <| map (λ {(hn , hv) → (hn , f hv)}) d

    -- FMapInterface doesn't appear to have a corresponding function
    list⇒dlt : {V : Set} → List (K ∧ V) → dd V
    list⇒dlt d = d |> map (λ where (k , v) → (nat k , v)) |> list⇒dlt' |> DD

    -- converts a delta dict into a list of key-value pairs; the inverse of list⇒dlt
    -- Corresponds to FMapInterface.elements
    dlt⇒list : {V : Set} → dd V → List (K ∧ V)
    dlt⇒list (DD d) = dlt⇒list' d |> map (λ where (n , v) → (key n , v))

    -- union merge A B is the union of A and B,
    -- with (merge a b) being invoked to handle the mappings they have in common
    union : {V : Set} → (V → V → V) → dd V → dd V → dd V
    union merge (DD d1) (DD d2) = DD <| union' merge d1 d2 0

    ---- core theorems ----

    -- The next two theorems show that lookup (_⟨_⟩) is consistent with membership (_∈_)
    -- As such, future theorems which relate to membership can be taken to appropriately
    -- comment on lookup as well.
    -- Corresponds to FMapInterface.find_1
    lookup-cons-1 : {V : Set} {d : dd V} {k : K} {v : V} →
                     (k , v) ∈ d →
                     d ⟨ k ⟩ == Some v
    lookup-cons-1 {V} {DD d} {k} {v} = lookup-cons-1' {V} {d} {nat k} {v}

    -- Corresponds to FMapInterface.find_2
    lookup-cons-2 : {V : Set} {d : dd V} {k : K} {v : V} →
                     d ⟨ k ⟩ == Some v →
                     (k , v) ∈ d
    lookup-cons-2 {V} {DD d} {k} {v} h = lookup-cons-2' {d = d} {nat k} h

    -- membership (_∈_) respects insertion (_,,_)
    -- Corresponds to FMapInterface.add_1
    k,v∈d,,k,v : {V : Set} {d : dd V} {k : K} {v : V} →
                  (k , v) ∈ (d ,, (k , v))
    k,v∈d,,k,v {V} {d = DD d} {k} = n,v∈'d,,n,v {d = d} {nat k}

    -- insertion respects membership
    -- Corresponds to FMapInterface.add_2
    k∈d→k∈d+ : {V : Set} {d : dd V} {k k' : K} {v v' : V} →
                  k ≠ k' →
                  (k , v) ∈ d →
                  (k , v) ∈ (d ,, (k' , v'))
    k∈d→k∈d+ {V} {DD d} {k} {k'} {v} {v'} ne h
      = n∈d→'n∈d+ {V} {d} {nat k} {nat k'} {v} {v'} (inj-cp ne) h

    -- insertion can't generate spurious membership
    -- Corresponds to FMapInterface.add_3
    k∈d+→k∈d : {V : Set} {d : dd V} {k k' : K} {v v' : V} →
                k ≠ k' →
                (k , v) ∈ (d ,, (k' , v')) →
                (k , v) ∈ d
    k∈d+→k∈d {V} {d = DD d} {k} {k'} {v} {v'} ne h
      = n∈d+→'n∈d {V} {d} {nat k} {nat k'} {v} {v'} (inj-cp ne) h

    -- Decidability of membership
    -- This also packages up an appeal to delta dict membership into a form that
    -- lets us retain more information
    -- Corresponds to FMapFacts.In_dec
    mem-dec : {V : Set} (d : dd V) (k : K) → dom d k ∨ k # d
    mem-dec {V} (DD d) k = mem-dec' {V} d (nat k)

    -- delta dicts contain at most one binding for each variable
    -- Corresponds to FMapFacts.MapsTo_fun
    mem-unicity : {V : Set} {d : dd V} {k : K} {v v' : V} →
                   (k , v) ∈ d →
                   (k , v') ∈ d →
                   v == v'
    mem-unicity vh v'h
      with lookup-cons-1 vh | lookup-cons-1 v'h
    ... | vh' | v'h' = someinj (! vh' · v'h')

    -- meaning of nil, i.e. nothing is in nil
    -- Corresponds to FMapFacts.empty_in_iff
    k#∅ : {V : Set} {k : K} → _#_ {V} k ∅
    k#∅ (_ , ())

    -- meaning of the singleton
    ■-def : {V : Set} {k : K} {v : V} → (■ (k , v)) == ∅ ,, (k , v)
    ■-def = refl

    -- Theorem 2: Extensionality
    -- (i.e. if two dicts represent the same mapping from ids to values,
    -- then they are reflexively equal as judged by _==_)
    -- Corresponds to FMapFacts.Equal_Equiv
    extensional : {V : Set} {d1 d2 : dd V} →
                   ((k : K) → d1 ⟨ k ⟩ == d2 ⟨ k ⟩) →
                   d1 == d2
    extensional {V} {DD d1} {DD d2} all-bindings-==
      = ap1 DD <| extensional' {V} {d1} {d2} eqv-nat
        where
        eqv-nat : (n : Nat) → (d1 lkup n) == (d2 lkup n)
        eqv-nat n
          with bij.surj bij n
        ... | k , surj
          with all-bindings-== k
        ... | eq rewrite surj = eq

    -- Theorem 3: Decidable Equality
    -- This doesn't seem to directly correspond to any of the Coq theorems
    ==-dec : {V : Set}
              (d1 d2 : dd V) →
              ((v1 v2 : V) → v1 == v2 ∨ v1 ≠ v2) →
              d1 == d2 ∨ d1 ≠ d2
    ==-dec {V} (DD d1) (DD d2) h
      with ==-dec' {V} d1 d2 h
    ... | Inl refl = Inl refl
    ... | Inr ne   = Inr (λ where refl → ne refl)

    -- The next two theorems specify the behavior of destruct and prove that
    -- it behaves as intended. The third one combines them to match the paper.
    destruct-thm-1 : ∀{V} {d : dd V} →
                       destruct d == None →
                       d == ∅
    destruct-thm-1 {d = DD []} eq = refl
    destruct-thm-1 {d = DD (_ :: [])} ()
    destruct-thm-1 {d = DD (_ :: (_ :: _))} ()

    destruct-thm-2 : ∀{V} {d d' : dd V} {k : K} {v : V} →
                       destruct d == Some ((k , v) , d') →
                       k # d' ∧ d == d' ,, (k , v)
    destruct-thm-2 {d = DD ((n , v) :: [])} refl
      rewrite convert-bij2 {{bij}} {t = n}
        = n#'[] , refl
    destruct-thm-2 {d = DD ((n , v) :: ((m , v') :: t))} refl
      rewrite convert-bij2 {{bij}} {t = n}
      with too-small (n<m→n<s+m n<1+n)
    ... | not-in
      with <dec n (m + 1+ n)
    ... | Inl lt rewrite ! (undelta n m lt) = not-in , refl
    ... | Inr (Inl eq) = abort (n≠n+1+m (eq · (n+1+m==1+n+m · +comm {1+ m})))
    ... | Inr (Inr gt) = abort (<antisym gt (n<m→n<s+m n<1+n))

    -- Theorem 4: Not-So-Easy Destructibility
    destruct-thm : ∀{V} {d d' : dd V} {k : K} {v : V} →
                     (destruct d == None → d == ∅)
                       ∧
                     (destruct d == Some ((k , v) , d') →
                        k # d' ∧ d == d' ,, (k , v))
    destruct-thm = destruct-thm-1 , destruct-thm-2

    -- When using destruct or delete, this theorem is useful for establishing termination
    -- Roughly corresponds to FMapFacts.cardinal_2
    extend-size : {V : Set} {d : dd V} {k : K} {v : V} →
                   k # d →
                   || d ,, (k , v) || == 1+ || d ||
    extend-size {V} {DD d} {k} {v} n#d = extend-size' {V} {d} {nat k} {v} n#d

    -- remove a specific mapping from a delta dict
    -- Roughly corresponds to FMapInterface.remove, and associated theorems
    delete : {V : Set} {d : dd V} {k : K} {v : V} →
              (k , v) ∈ d →
              Σ[ d⁻ ∈ dd V ] (
                 d == d⁻ ,, (k , v) ∧
                 k # d⁻)
    delete {V} {DD d} {k} {v} h
      with delete' {V} {d} {nat k} {v} h
    ... | _ , refl , # = _ , refl , #

    ---- contraction and exchange ----

    -- Theorem 5
    contraction : {V : Set} {d : dd V} {k : K} {v v' : V} →
                   d ,, (k , v') ,, (k , v) == d ,, (k , v)
    contraction {V} {DD d} {k} {v} {v'}
      = ap1 DD <| contraction' {d = d} {nat k} {v} {v'}

    -- Theorem 6
    exchange : {V : Set} {d : dd V} {k1 k2 : K} {v1 v2 : V} →
                k1 ≠ k2 →
                d ,, (k1 , v1) ,, (k2 , v2) == d ,, (k2 , v2) ,, (k1 , v1)
    exchange {V} {DD d} {k1} {k2} {v1} {v2} k1≠k2
      = ap1 DD <| exchange' {d = d} <| inj-cp k1≠k2

    ---- union theorems ----

    k,v∈d1→k∉d2→k,v∈d1∪d2 : {V : Set} {m : V → V → V} {d1 d2 : dd V} {k : K} {v : V} →
                             (k , v) ∈ d1 →
                             k # d2 →
                             (k , v) ∈ union m d1 d2
    k,v∈d1→k∉d2→k,v∈d1∪d2 {d1 = DD d1} {DD d2} k∈d1 k#d2
      = lemma-union'-1 k∈d1 0≤n (tr (λ y → y #' d2) (! (n+m-n==m 0≤n)) k#d2)

    k∉d1→k,v∈d2→k,v∈d1∪d2 : {V : Set} {m : V → V → V} {d1 d2 : dd V} {k : K} {v : V} →
                             k # d1 →
                             (k , v) ∈ d2 →
                             (k , v) ∈ union m d1 d2
    k∉d1→k,v∈d2→k,v∈d1∪d2 {d1 = DD d1} {DD d2} {k} k#d1 k∈d2
      with lemma-union'-2 {n = Z} (tr (λ y → y #' d1) (! n+Z==n) k#d1) k∈d2
    ... | rslt
      rewrite n+Z==n {nat k}
        = rslt

    k∈d1→k∈d2→k∈d1∪d2 : {V : Set} {m : V → V → V} {d1 d2 : dd V} {k : K} {v1 v2 : V} →
                         (k , v1) ∈ d1 →
                         (k , v2) ∈ d2 →
                         (k , m v1 v2) ∈ union m d1 d2
    k∈d1→k∈d2→k∈d1∪d2 {d1 = DD d1} {DD d2} {k} {v1} k∈d1 k∈d2
      with lemma-union'-3 (tr (λ y → (y , v1) ∈' d1) (! n+Z==n) k∈d1) k∈d2
    ... | rslt
      rewrite n+Z==n {nat k}
        = rslt

    k∈d1∪d2→k∈d1∨k∈d2 : {V : Set} {m : V → V → V} {d1 d2 : dd V} {k : K} →
                         dom (union m d1 d2) k →
                         dom d1 k ∨ dom d2 k
    k∈d1∪d2→k∈d1∨k∈d2 {d1 = DD d1} {DD d2} k∈d1∪d2
      with lemma-union'-4 {n = Z} k∈d1∪d2
    k∈d1∪d2→k∈d1∨k∈d2 k∈d1∪d2 | Inl k'∈d1 = Inl k'∈d1
    k∈d1∪d2→k∈d1∨k∈d2 k∈d1∪d2 | Inr (_ , refl , k'∈d2) = Inr k'∈d2

    ---- dltmap theorem ----

    -- The Coq.FSets library uses different theorems to establish to specify map
    dltmap-func : {V1 V2 : Set} {d : dd V1} {f : V1 → V2} {k : K} {v : V1} →
                   dltmap f (d ,, (k , v)) == dltmap f d ,, (k , f v)
    dltmap-func {d = DD d} {f} {k} {v} = ap1 DD (dltmap-func' {d = d})

    ---- dlt <=> list theorems ----

    -- Corresponds to FMapInterface.cardinal_1
    dlt⇒list-size : {V : Set} {d : dd V} → ∥ dlt⇒list d ∥ == || d ||
    dlt⇒list-size {d = DD d} = map-len · dlt⇒list-size'

    -- Corresponds to FMapInterface.elements_1
    dlt⇒list-In-1 : {V : Set} {d : dd V} {k : K} {v : V} →
                      (k , v) ∈ d →
                      (k , v) In dlt⇒list d
    dlt⇒list-In-1 {d = DD d} {k} in'
      rewrite ! <| convert-bij1 {f = k}
      with dlt⇒list-In-1' in'
    ... | in'' rewrite convert-bij2 {{bij}} {t = bij.convert bij k}
      = map-In in''

    -- Corresponds to FMapInterface.elements_2
    dlt⇒list-In-2 : {V : Set} {d : dd V} {k : K} {v : V} →
                      (k , v) In dlt⇒list d →
                      (k , v) ∈ d
    dlt⇒list-In-2 {V} {d = DD d} {k} {v} in'
      with map-In {f = λ where (k' , v') → (nat k' , v')} in'
    ... | in'' rewrite map^2 {f = λ where (k' , v') → (nat k' , v')} {g = λ where (n' , v') → (key n' , v')} {l = dlt⇒list' d}
      = dlt⇒list-In-2' (tr
          (λ y → (nat k , v) In y)
          (map^2 · (map-ext bij-pair-1 · map-id))
          (map-In {f = λ where (k , v) → (nat k , v)} in'))

    list⇒dlt-In : {V : Set} {l : List (K ∧ V)} {k : K} {v : V} →
                    (k , v) ∈ list⇒dlt l →
                    (k , v) In l
    list⇒dlt-In {l = l} {k} {v} in'
      with list⇒dlt-In' {l = map (λ { (k , v) → nat k , v }) l} in' |> map-In {f = λ where (n , v) → key n , v}
    ... | in'' rewrite convert-bij1 {f = k}
      = tr
           (λ y → (k , v) In y)
           (map^2 · (map-ext bij-pair-2 · map-id))
           in''

    list⇒dlt-key-In : {V : Set} {l : List (K ∧ V)} {k : K} {v : V} →
                        (k , v) In l →
                        dom (list⇒dlt l) k
    list⇒dlt-key-In {_} {(k , v) :: l} {k} {v} LInH
      rewrite foldl-++ {l1 = reverse <| map (λ where (k , v) → nat k , v) l} {(nat k , v) :: []} {_,,'_} {[]}
        = _ , tr
           (λ y → (nat k , v) ∈' y)
           (! <| foldl-++ {l1 = reverse <| map (λ where (k , v) → nat k , v) l})
           (n,v∈'d,,n,v {d = list⇒dlt' <| map (λ where (k , v) → nat k , v) l})
    list⇒dlt-key-In {V} {(k' , v') :: l} {k} {v} (LInT in')
      with list⇒dlt-key-In in'
    ... | (_ , in'')
      = _ , tr
         (λ y → (nat k , vv) ∈' y)
         (! <| foldl-++ {l1 = reverse <| map (λ where (k , v) → nat k , v) l})
         lem'
      where
      nat-inj : ∀{k1 k2} → nat k1 == nat k2 → k1 == k2
      nat-inj eq = ! (convert-bij1 {{bij}}) · (ap1 key eq · convert-bij1 {{bij}})
      lem : Σ[ vv ∈ V ] ((nat k , vv) ∈' (list⇒dlt' (map (λ { (k , v) → nat k , v }) l) ,,' (nat k' , v')))
      lem
        with natEQ (nat k) (nat k')
      ... | Inl eq rewrite ! <| nat-inj eq
        = _ , n,v∈'d,,n,v {d = list⇒dlt' (map (λ { (k , v) → nat k , v }) l)}
      ... | Inr ne = _ , n∈d→'n∈d+ ne in''
      vv = π1 lem
      lem' = π2 lem

    -- contrapositives of some previous theorems
    dlt⇒list-In-1-cp : {V : Set} {d : dd V} {k : K} → (Σ[ v ∈ V ] ((k , v) In dlt⇒list d) → ⊥) → k # d
    dlt⇒list-In-1-cp {d = DD d} not-in = λ where (_ , in') → not-in (_ , (dlt⇒list-In-1 in'))
    list⇒dlt-key-In-cp : {V : Set} {l : List (K ∧ V)} {k : K} → k # list⇒dlt l → Σ[ v ∈ V ] ((k , v) In l) → ⊥
    list⇒dlt-key-In-cp k#d' (_ , k∈l) = k#d' (list⇒dlt-key-In k∈l)

    list⇒dlt-order : {V : Set} {l1 l2 : List (K ∧ V)} {k : K} {v1 v2 : V} →
                       (k , v1) ∈ (list⇒dlt ((k , v1) :: l1 ++ ((k , v2) :: l2)))
    list⇒dlt-order {_} {l1} {l2} {k} {v1} {v2}
      = tr
           (λ y → (nat k , v1) ∈' foldl _,,'_ [] (reverse y ++ ((nat k , v1) :: [])))
           (map-++-comm {a = l1})
           (list⇒dlt-order' {l1 = map (λ where (k , v) → nat k , v) l1})

    dlt⇒list-inversion : {V : Set} {d : dd V} → list⇒dlt (dlt⇒list d) == d
    dlt⇒list-inversion {d = DD d} = extensional lem
      where
      lem : (k : K) → (list⇒dlt (dlt⇒list <| DD d) ⟨ k ⟩ == DD d ⟨ k ⟩)
      lem k
        with mem-dec (list⇒dlt (dlt⇒list <| DD d)) k
      ... | Inl (_ , k∈d')
        = lookup-cons-1 k∈d' · (k∈d' |> list⇒dlt-In |> dlt⇒list-In-2 |> lookup-cons-1 {d = DD d} |> !)
      ... | Inr k#d'
        = lookup-cp-2' k#d' · (k#d' |> list⇒dlt-key-In-cp |> dlt⇒list-In-1-cp |> lookup-cp-2' {d = d} |> !)


-- | An implementation of the Marketoritative PCM
module Relation.Ternary.Separation.Construct.Market where

open import Level hiding (Lift)
open import Data.Product

open import Relation.Unary
open import Relation.Binary hiding (_⇒_)
open import Relation.Binary.PropositionalEquality as P

open import Relation.Ternary.Separation
open import Relation.Ternary.Separation.Morphisms

module _ {ℓ} (A : Set ℓ) where

  data Market : Set ℓ where
    offer  : (l : A) → Market
    demand : (r : A) → Market

module _ {ℓ} {A : Set ℓ} {{ sep : RawSep A }} {{ _ : IsSep sep }} where

  data Split : Market A → Market A → Market A → Set ℓ where

    offerₗ : {r l₁ l₂ : A} (σ : l₂ ⊎ r ≣ l₁) → Split (offer l₁) (demand r) (offer l₂)
    offerᵣ : {r l₁ l₂ : A} (σ : r ⊎ l₂ ≣ l₁) → Split (demand r) (offer l₁) (offer l₂)
    demand : {r₁ r₂ r : A} (σ : r₁ ⊎ r₂ ≣ r) → Split (demand r₁) (demand r₂) (demand r)

  comm : ∀ {Φ₁ Φ₂ Φ} → Split Φ₁ Φ₂ Φ → Split Φ₂ Φ₁ Φ
  comm (demand p) = demand (⊎-comm p)
  comm (offerₗ σ) = offerᵣ (⊎-comm σ)
  comm (offerᵣ σ) = offerₗ (⊎-comm σ)

  assoc : ∀ {a b ab c abc} → Split a b ab → Split ab c abc → ∃ λ bc → (Split a bc abc) × (Split b c bc)
  assoc (offerₗ σ₁) (offerₗ σ₂) =
    let _ , σ₃ , σ₄ = ⊎-assoc σ₂ σ₁ in -, offerₗ σ₃ , demand (⊎-comm σ₄)
  assoc (offerᵣ σ₁) (offerₗ σ₂) =
    let _ , σ₃ , σ₄ = ⊎-unassoc σ₁ σ₂ in -, offerᵣ σ₃ , offerₗ σ₄
  assoc (demand σ₁) (offerᵣ σ₂) =
    let _ , σ₃ , σ₄ = ⊎-assoc (⊎-comm σ₁) σ₂ in -, offerᵣ σ₄ , offerᵣ σ₃
  assoc (demand σ₁) (demand σ₂) =
    let _ , σ₃ , σ₄ = ⊎-assoc σ₁ σ₂ in -, demand σ₃ , demand σ₄
  instance market-raw-sep : RawSep (Market A)
  RawSep._⊎_≣_ market-raw-sep = Split

  instance market-has-sep : IsSep market-raw-sep
  market-has-sep = record
    { ⊎-comm  = comm
    ; ⊎-assoc = assoc
    }

  instance market-sep : Separation _
  market-sep = record
    { isSep = market-has-sep }

module _ {a} {A : Set a} {{r : RawSep A}} {u} {{ s : IsUnitalSep r u }} where

  module U = IsUnitalSep
  instance market-is-unital : IsUnitalSep market-raw-sep (demand ε)
  U.isSep market-is-unital  = market-has-sep
  U.⊎-idˡ market-is-unital {offer l} = offerᵣ ⊎-idˡ
  U.⊎-idˡ market-is-unital {demand r} = demand ⊎-idˡ
  U.⊎-id⁻ˡ market-is-unital (offerᵣ σ) = cong offer (sym (⊎-id⁻ˡ σ))
  U.⊎-id⁻ˡ market-is-unital (demand σ) = cong demand (⊎-id⁻ˡ σ)

module _ {a} {{ s : MonoidalSep a }} where

  open MonoidalSep s using () renaming (Carrier to A)

  matching : ∀ {a b : A} {c d} → (demand a) ⊎ (offer b) ≣ c → (demand (d ∙ a)) ⊎ (offer (d ∙ b)) ≣ c
  matching (offerᵣ σ) = offerᵣ (⊎-∙ₗ σ)

module _ {ℓ} {A : Set ℓ} {{_ : RawSep A}} where

  private
    variable
      ℓv : Level
      P Q : Pred (A × A) ℓv

  [_]Completes : A → (A × A) → Set ℓ
  [_]Completes x (y , z) = x ⊎ z ≣ y

  data ● {p} (P : Pred (A × A) p) : Pred (Market A) (ℓ ⊔ p) where
    lift : ∀ {xs l₂} → P xs → [ l₂ ]Completes xs → ● P (offer l₂)

  ●-map : ∀[ P ⇒ Q ] → ∀[ ● P ⇒ ● Q ]
  ●-map f (lift px le) = lift (f px) le

module _ {a} {A : Set a} {{r : RawSep A}} {u} {{s₁ : IsUnitalSep r u}} where

  open Morphism

  instance market : Morphism A (Market A)
  j market                 = demand
  j-⊎ market s             = demand s
  j-⊎⁻ market (demand σ)   = -, refl , σ

module _ {a} {A : Set a} {{r : RawSep A}} {u} {{s₁ : IsUnitalSep r u}} where

  open import Relation.Ternary.Separation.Construct.Product
  open Morphism (market {A = A})

  data ○ {p} (P : Pred (A × A) p) : Pred (Market A) (p) where
    lift : ∀ {xs} → P (ε , xs) → ○ P (demand xs)

  module _ {p q} {P : Pred A p} {Q : Pred (A × A) q} where
    ○≺●ₗ : ∀[ P ⇒ⱼ ● Q ─✴ ● (Π₂ P ✴ Q) ]
    app (○≺●ₗ px) (lift qx σ₂) (offerᵣ σ₁) with ⊎-assoc (⊎-comm σ₁) σ₂
    ... | _ , σ₃ , σ₄ = lift (snd px ×⟨ ⊎-idˡ , σ₄ ⟩ qx ) σ₃

    ○≺●ᵣ : ∀[ ● (Π₂ P ✴ Q) ⇒ J P ✴ ● Q ]
    ○≺●ᵣ (lift (snd px ×⟨ σₗ , σᵣ ⟩ qx) σ₂) with ⊎-id⁻ˡ σₗ
    ... | refl with ⊎-unassoc σ₂ σᵣ
    ... | _ , σ₃ , σ₄ = inj px ×⟨ offerᵣ (⊎-comm σ₃) ⟩ lift qx σ₄

{- Complete with respect to a certain element -}
module _ {a} {A : Set a} {{r : RawSep A}} {u} {{ s : IsUnitalSep r u }} where

  open import Relation.Ternary.Separation.Construct.Product
  open Morphism (market {A = A})

  record _◑_ {p q} (P : Pred A p) (Q : Pred (A × A) q) (Φ : A × A) : Set (a ⊔ p ⊔ q) where
    constructor _◑⟨_⟩_
    field
      {Φp Φq} : _
      px  : P Φp
      inc : proj₁ Φ ⊎ Φp ≣ Φq
      qx  : Q (Φq , proj₂ Φ)

  -- the following cannot be proven unfortunately
  -- _ : ∀[ (P ◑ Q₁) ✴ Q₂ ⇒ P ◑ (Q₁ ✴ Q₂) ]

  absorb : ∀ {p q} {P : Pred A p} {Q : Pred (A × A) q} →
           ∀[ P ⇒ⱼ ● Q ─✴ ● (P ◑ Q) ]
  app (absorb px) (lift qx k) (offerᵣ σ) with ⊎-assoc (⊎-comm σ) k
  ... | _ , σ₂ , σ₃ with ⊎-unassoc σ₂ (⊎-comm σ₃)
  ... | _ , σ₄ , σ₅ = lift (px ◑⟨ σ₅ ⟩ qx) σ₄

  expell : ∀ {p q} {P : Pred A p} {Q : Pred (A × A) q} →
           ∀[ ● (P ◑ Q) ⇒ J P ✴ ● Q ]
  expell (lift (px ◑⟨ τ₁ ⟩ qx) k) with ⊎-unassoc (⊎-comm τ₁) k
  ... | _ , τ₃ , τ₄ = (inj px) ×⟨ offerᵣ τ₃ ⟩ (lift qx τ₄)

{- Completion preserving updates -}
module _ {a} {A : Set a} {{r : RawSep A}} {u} {{ s : IsUnitalSep r u }} where

  open import Relation.Ternary.Separation.Construct.Product

  record ⟰_ {p} (P : Pred (A × A) p) (Φᵢ : A × A) : Set (a ⊔ p) where
    constructor complete
    field
      updater : ∀ {Φⱼ Φₖ} →
                Φᵢ ⊎ Φⱼ ≣ (Φₖ , Φₖ) →
                ∃₂ λ Φₗ Φ → Φₗ ⊎ Φⱼ ≣ (Φ , Φ) × P Φₗ
  open ⟰_ public

  ●-update : ∀ {p q} {P : Pred (A × A) p} {Q : Pred (A × A) q} →
             ∀[ ○ (P ─✴ ⟰ Q) ⇒ ● P ─✴ ● Q ]
  app (●-update (lift f)) (lift px σ₁) (offerᵣ σ₂) with ⊎-assoc (⊎-comm σ₂) σ₁
  ... | _ , σ₃ , σ₄ with updater (app f px (⊎-idˡ , σ₄)) (⊎-idʳ , ⊎-comm σ₃)
  ... | _ , _ , (σ₅ , σ₆) , qx with ⊎-id⁻ʳ σ₅
  ... | refl = lift qx (⊎-comm σ₆)