open import Relation.Binary.Core

module BBHeap.Drop {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_)
                  (trans≤ : Transitive _≤_) where

open import BBHeap _≤_
open import BBHeap.Compound _≤_
open import BBHeap.Equality _≤_
open import BBHeap.Equality.Properties _≤_
open import BBHeap.Subtyping.Properties _≤_ trans≤
open import BBHeap.Perfect _≤_
open import BBHeap.Properties _≤_
open import BBHeap.Push _≤_ tot≤ trans≤
open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import Bound.Lower.Order.Properties _≤_ trans≤
open import Data.Empty
open import Data.Product renaming (_×_ to _∧_)
open import Data.Sum renaming (_⊎_ to _∨_)
open import Order.Total _≤_ tot≤

root : {b : Bound}{h : BBHeap b}(cₕ : Compound h) → A
root (cl {x = x} _ _) = x
root (cr {x = x} _ _) = x

mutual
  drop : {b : Bound}{h : BBHeap b}(cₕ : Compound h) → BBHeap (val (root cₕ))
  drop (cl b≤x l⋘r) = drop⋘ b≤x l⋘r
  drop (cr b≤x l⋙r) = drop⋙ b≤x l⋙r

  drop⋘ : {b : Bound}{x : A}{l r : BBHeap (val x)}(b≤x : LeB b (val x)) → l ⋘ r → BBHeap (val x)
  drop⋘ b≤x lf⋘ = leaf
  drop⋘ b≤x (ll⋘ {x = y₁} {x' = y₂} x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂)
      with tot≤ y₁ y₂ | lemma-drop⋘ (cl x≤y₁ l₁⋘r₁) (cl x≤y₂ l₂⋘r₂) (ll⋘ x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂)
  ... | inj₁ y₁≤y₂ | inj₁ (_ , l⋙dr) =
                     let pl'≈l' = lemma-push⋘ (lexy y₁≤y₂) (lexy refl≤) l₁⋘r₁ ;
                          l'≈l = ≈left (lexy refl≤) x≤y₁ l₁⋘r₁ l₁⋘r₁ refl≈ refl≈ ;
                          pl'≈l = trans≈ pl'≈l' l'≈l ;
                          pl'⋙dr = lemma≈⋙ pl'≈l l⋙dr ;
                          pl'⋙dr' = subtyping⋙r (lexy y₁≤y₂) pl'⋙dr
                     in right x≤y₁ pl'⋙dr'
  ... | inj₁ y₁≤y₂ | inj₂ dl⋘r =
                     let r≈r' = ≈left x≤y₂ (lexy y₁≤y₂) l₂⋘r₂ l₂⋘r₂ refl≈ refl≈ ;
                          dl⋘r' = lemma⋘≈ dl⋘r r≈r'
                     in left x≤y₁ dl⋘r'
  ... | inj₂ y₂≤y₁ | inj₁ (_ , l⋙dr) =
                     let l'≈l = ≈left (lexy y₂≤y₁) x≤y₁ l₁⋘r₁  l₁⋘r₁ refl≈ refl≈ ;
                          l'⋙dr = lemma≈⋙ l'≈l l⋙dr
                     in right x≤y₂ l'⋙dr
  ... | inj₂ y₂≤y₁ | inj₂ dl⋘r =
                     let pr'≈r' = lemma-push⋘ (lexy y₂≤y₁) (lexy refl≤) l₂⋘r₂ ;
                          r'≈pr' = sym≈ pr'≈r' ;
                          r≈r' = ≈left x≤y₂ (lexy refl≤) l₂⋘r₂ l₂⋘r₂ refl≈ refl≈ ;
                          r≈pr' = trans≈ r≈r' r'≈pr' ;
                          dl⋘pr' = lemma⋘≈ dl⋘r r≈pr' ;
                          dl'⋘pr' = subtyping⋘l (lexy y₂≤y₁) dl⋘pr'
                     in left x≤y₂ dl'⋘pr'
  drop⋘ b≤x (lr⋘ {x = y₁} {x' = y₂} x≤y₁ x≤y₂ l₁⋙r₁ l₂⋘r₂ l₂≃r₂ l₁⋗l₂)
      with tot≤ y₁ y₂ | lemma-drop⋘ (cr x≤y₁ l₁⋙r₁) (cl x≤y₂ l₂⋘r₂) (lr⋘ x≤y₁ x≤y₂ l₁⋙r₁ l₂⋘r₂ l₂≃r₂ l₁⋗l₂)
  ... | _ | inj₁ (() , _)
  ... | inj₁ y₁≤y₂ | inj₂ dl⋘r =
                     let r≈r' = ≈left x≤y₂ (lexy y₁≤y₂) l₂⋘r₂ l₂⋘r₂ refl≈ refl≈ ;
                          dl⋘r' = lemma⋘≈ dl⋘r r≈r'
                     in left x≤y₁ dl⋘r'
  ... | inj₂ y₂≤y₁ | inj₂ dl⋘r =
                     let pr'≈r' = lemma-push⋘ (lexy y₂≤y₁) (lexy refl≤) l₂⋘r₂ ;
                          r'≈pr' = sym≈ pr'≈r' ;
                          r≈r' = ≈left x≤y₂ (lexy refl≤) l₂⋘r₂ l₂⋘r₂ refl≈ refl≈ ;
                          r≈pr' = trans≈ r≈r' r'≈pr' ;
                          dl⋘pr' = lemma⋘≈ dl⋘r r≈pr' ;
                          dl'⋘pr' = subtyping⋘l (lexy y₂≤y₁) dl⋘pr'
                     in left x≤y₂ dl'⋘pr'

  drop⋙ : {b : Bound}{x : A}{l r : BBHeap (val x)}(b≤x : LeB b (val x)) → l ⋙ r → BBHeap (val x)
  drop⋙ b≤x (⋙lf x≤y) = left x≤y lf⋘
  drop⋙ b≤x (⋙rl {x = y₁} {x' = y₂} x≤y₁ x≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋘r₂ l₁⋗r₂)
      with tot≤ y₁ y₂ | lemma-drop⋙ (cl x≤y₁ l₁⋘r₁) (cl x≤y₂ l₂⋘r₂) (⋙rl x≤y₁ x≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋘r₂ l₁⋗r₂)
  ... | inj₁ y₁≤y₂ | inj₁ (_ , dl⋘r) =
                       let r≈r' = ≈left x≤y₂ (lexy y₁≤y₂) l₂⋘r₂ l₂⋘r₂ refl≈ refl≈ ;
                            dl⋘r' = lemma⋘≈ dl⋘r r≈r'
                       in left x≤y₁ dl⋘r'
  ... | inj₁ y₁≤y₂ | inj₂ l⋙dr =
                       let l'≈l = ≈left (lexy refl≤) x≤y₁ l₁⋘r₁ l₁⋘r₁ refl≈ refl≈ ;
                            pl'≈l' = lemma-push⋘ (lexy y₁≤y₂) (lexy refl≤) l₁⋘r₁ ;
                            pl'≈l = trans≈ pl'≈l' l'≈l ;
                            pl'⋙dr = lemma≈⋙ pl'≈l l⋙dr ;
                            pl'⋙dr' = subtyping⋙r (lexy y₁≤y₂) pl'⋙dr
                       in right x≤y₁ pl'⋙dr'
  ... | inj₂ y₂≤y₁ | inj₁ (_ , dl⋘r) =
                       let pr'≈r' = lemma-push⋘ (lexy y₂≤y₁) (lexy refl≤) l₂⋘r₂ ;
                            r'≈r = ≈left (lexy refl≤) x≤y₂ l₂⋘r₂ l₂⋘r₂ refl≈ refl≈ ;
                            pr'≈r = trans≈ pr'≈r' r'≈r ;
                            r≈pr' = sym≈ pr'≈r ;
                            dl⋘pr' = lemma⋘≈ dl⋘r r≈pr' ;
                            dl'⋘pr' = subtyping⋘l (lexy y₂≤y₁) dl⋘pr'
                       in left x≤y₂ dl'⋘pr'
  ... | inj₂ y₂≤y₁ | inj₂ l⋙dr =
                       let l'≈l = ≈left (lexy y₂≤y₁) x≤y₁ l₁⋘r₁ l₁⋘r₁ refl≈ refl≈ ;
                            l'⋙dr = lemma≈⋙ l'≈l l⋙dr
                       in right x≤y₂ l'⋙dr
  drop⋙ b≤x (⋙rr {x = y₁} {x' = y₂} x≤y₁ x≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋙r₂ l₁≃l₂)
      with tot≤ y₁ y₂ | lemma-drop⋙ (cl x≤y₁ l₁⋘r₁) (cr x≤y₂ l₂⋙r₂) (⋙rr x≤y₁ x≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋙r₂ l₁≃l₂)
  ... | _ | inj₁ (() , _)
  ... | inj₁ y₁≤y₂ | inj₂ l⋙dr =
                       let l'≈l = ≈left (lexy refl≤) x≤y₁ l₁⋘r₁ l₁⋘r₁ refl≈ refl≈ ;
                            pl'≈l' = lemma-push⋘ (lexy y₁≤y₂) (lexy refl≤) l₁⋘r₁ ;
                            pl'≈l = trans≈ pl'≈l' l'≈l ;
                            pl'⋙dr = lemma≈⋙ pl'≈l l⋙dr ;
                            pl'⋙dr' = subtyping⋙r (lexy y₁≤y₂) pl'⋙dr
                       in right x≤y₁ pl'⋙dr'
  ... | inj₂ y₂≤y₁ | inj₂ l⋙dr =
                       let l'≈l = ≈left (lexy y₂≤y₁) x≤y₁ l₁⋘r₁ l₁⋘r₁ refl≈ refl≈ ;
                            l'⋙dr = lemma≈⋙ l'≈l l⋙dr
                       in right x≤y₂ l'⋙dr

  lemma-drop⋘ : {b : Bound}{l r : BBHeap b}(cₗ : Compound l)(cᵣ : Compound r) → l ⋘ r → l ≃ r ∧ l ⋙ drop cᵣ ∨ drop cₗ ⋘ r
  lemma-drop⋘ (cl y≤y₁ lf⋘) (cl y≤y₂ lf⋘) (ll⋘ .y≤y₁ .y≤y₂ .lf⋘ .lf⋘ ≃lf ≃lf) = inj₁ (≃nd y≤y₁ y≤y₂ lf⋘ lf⋘ ≃lf ≃lf ≃lf , ⋙lf y≤y₁)
  lemma-drop⋘ (cl y≤y₁ (ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄)) (cl y≤y₂ lf⋘) (ll⋘ .y≤y₁ .y≤y₂ .(ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄) .lf⋘ _ ())
  lemma-drop⋘ (cl y≤y₁ (ll⋘ {x = y₃} {x' = y₄} y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄)) (cl y≤y₂ (ll⋘ {x = y₅} {x' = y₆} y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆)) (ll⋘ {x = y₁} .y≤y₁ .y≤y₂ .(ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄) .(ll⋘ y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆) l₂≃r₂ r₁≃l₂)
      with tot≤ y₃ y₄ | tot≤ y₅ y₆ | lemma-drop⋘ (cl y₁≤y₃ l₃⋘r₃) (cl y₁≤y₄ l₄⋘r₄) (ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄) | lemma-drop⋘ (cl y₂≤y₅ l₅⋘r₅) (cl y₂≤y₆ l₆⋘r₆) (ll⋘ y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆)
  ... | _ | inj₁ y₅≤y₆ | inj₁ (l₁≃r₁ , _) | inj₁ (_ , l₂⋙dr₂) =
                       let l₁⋘r₁ = ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄ ;
                            l₂⋘r₂ = ll⋘ y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆ ;
                            l₁≃l₂ = trans≃ l₁≃r₁ r₁≃l₂ ;
                            pl₂'≈l₂' = lemma-push⋘ (lexy y₅≤y₆) (lexy refl≤) l₅⋘r₅ ;
                            l₂'≈l₂ = ≈left (lexy refl≤) y₂≤y₅ l₅⋘r₅ l₅⋘r₅ refl≈ refl≈ ;
                            pl₂'≈l₂ = trans≈ pl₂'≈l₂' l₂'≈l₂ ;
                            pl₂'⋙dr₂ = lemma≈⋙ pl₂'≈l₂ l₂⋙dr₂ ;
                            pl₂'⋙dr₂' = subtyping⋙r (lexy y₅≤y₆) pl₂'⋙dr₂ ;
                            l₂≈pl₂' = sym≈ pl₂'≈l₂ ;
                            l₁≃pl₂' = lemma≃≈ l₁≃l₂ l₂≈pl₂'
                       in inj₁ (≃nd y≤y₁ y≤y₂ l₁⋘r₁ l₂⋘r₂ l₁≃r₁ l₂≃r₂ l₁≃l₂ , ⋙rr y≤y₁ y₂≤y₅ l₁⋘r₁ l₁≃r₁ pl₂'⋙dr₂' l₁≃pl₂')
  ... | _ | inj₂ y₆≤y₅ | inj₁ (l₁≃r₁ , _) | inj₁ (_ , l₂⋙dr₂) =
                       let l₁⋘r₁ = ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄ ;
                            l₂⋘r₂ = ll⋘ y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆ ;
                            l₁≃l₂ = trans≃ l₁≃r₁ r₁≃l₂ ;
                            l₂'≈l₂ = ≈left (lexy y₆≤y₅) y₂≤y₅ l₅⋘r₅ l₅⋘r₅ refl≈ refl≈ ;
                            l₂'⋙dr₂ = lemma≈⋙ l₂'≈l₂ l₂⋙dr₂ ;
                            l₂≈l₂' = sym≈ l₂'≈l₂ ;
                            l₁≃l₂' = lemma≃≈ l₁≃l₂ l₂≈l₂'
                       in inj₁ (≃nd y≤y₁ y≤y₂ l₁⋘r₁ l₂⋘r₂ l₁≃r₁ l₂≃r₂ l₁≃l₂ , ⋙rr y≤y₁ y₂≤y₆ l₁⋘r₁ l₁≃r₁ l₂'⋙dr₂ l₁≃l₂')
  ... | inj₁ y₃≤y₄ | _ | inj₂ dl₁⋘r₁ | _ =
                       let r₁≈r₁' = ≈left y₁≤y₄ (lexy y₃≤y₄) l₄⋘r₄ l₄⋘r₄ refl≈ refl≈ ;
                            dl₁⋘r₁' = lemma⋘≈ dl₁⋘r₁ r₁≈r₁' ;
                            l₂⋘r₂ = ll⋘ y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆ ;
                            r₁'≈r₁ = sym≈ r₁≈r₁' ;
                            r₁'≃l₂ = lemma≈≃ r₁'≈r₁ r₁≃l₂
                       in inj₂ (ll⋘ y₁≤y₃ y≤y₂ dl₁⋘r₁' l₂⋘r₂ l₂≃r₂ r₁'≃l₂)
  ... | inj₂ y₄≤y₃ | _ | inj₂ dl₁⋘r₁ | _ =
                       let r₁≈r₁' = ≈left y₁≤y₄ (lexy refl≤) l₄⋘r₄ l₄⋘r₄ refl≈ refl≈ ;
                            pr₁'≈r₁' = lemma-push⋘ (lexy y₄≤y₃) (lexy refl≤) l₄⋘r₄ ;
                            dl₁⋘r₁' = lemma⋘≈ dl₁⋘r₁ r₁≈r₁' ;
                            r₁'≈pr₁' = sym≈ pr₁'≈r₁' ;
                            r₁≈pr₁' = trans≈ r₁≈r₁' r₁'≈pr₁' ;
                            dl₁⋘pr₁' = lemma⋘≈ dl₁⋘r₁ r₁≈pr₁' ;
                            l₂⋘r₂ = ll⋘ y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆ ;
                            dl₁'⋘pr₁' = subtyping⋘l (lexy y₄≤y₃) dl₁⋘pr₁' ;
                            r₁'≈r₁ = sym≈ r₁≈r₁' ;
                            r₁'≃l₂ = lemma≈≃ r₁'≈r₁ r₁≃l₂ ;
                            pr₁'≃l₂ = lemma≈≃ pr₁'≈r₁' r₁'≃l₂
                       in inj₂ (ll⋘ y₁≤y₄ y≤y₂ dl₁'⋘pr₁' l₂⋘r₂ l₂≃r₂ pr₁'≃l₂)
  ... | _ | _ | inj₁ (l₁≃r₁ , l₁⋙dr₁) | inj₂ dl₂⋘r₂
      with lemma-drop-⊥ y₂≤y₅ l₅⋘r₅ (lemma-⋘-≃ dl₂⋘r₂ (sym≃ l₂≃r₂))
  ... | ()
  lemma-drop⋘ (cl y≤y₁ (ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄)) (cl y≤y₂ (lr⋘ y₂≤y₅ y₂≤y₆ l₅⋙r₅ l₆⋘r₆ l₆≃r₆ l₅⋗l₆)) (ll⋘ .y≤y₁ .y≤y₂ .(ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄) .(lr⋘ y₂≤y₅ y₂≤y₆ l₅⋙r₅ l₆⋘r₆ l₆≃r₆ l₅⋗l₆) _ ())
  lemma-drop⋘ (cl y≤y₁ (lr⋘ y₁≤y₃ y₁≤y₄ l₃⋙r₃ l₄⋘r₄ l₄≃r₄ l₃⋗l₄)) (cl y≤y₂ lf⋘) (ll⋘ .y≤y₁ .y≤y₂ .(lr⋘ y₁≤y₃ y₁≤y₄ l₃⋙r₃ l₄⋘r₄ l₄≃r₄ l₃⋗l₄) .lf⋘ _ ())
  lemma-drop⋘ (cl y≤y₁ (lr⋘ {x = y₃} {x' = y₄} y₁≤y₃ y₁≤y₄ l₃⋙r₃ l₄⋘r₄ l₄≃r₄ l₃⋗l₄)) (cl y≤y₂ (ll⋘ {x = y₅} {x' = y₆} y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆)) (ll⋘ .y≤y₁ .y≤y₂ .(lr⋘ y₁≤y₃ y₁≤y₄ l₃⋙r₃ l₄⋘r₄ l₄≃r₄ l₃⋗l₄) .(ll⋘ y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆) l₂≃r₂ r₁≃l₂)
      with tot≤ y₃ y₄ | tot≤ y₅ y₆ | lemma-drop⋘ (cr y₁≤y₃ l₃⋙r₃) (cl y₁≤y₄ l₄⋘r₄) (lr⋘ y₁≤y₃ y₁≤y₄ l₃⋙r₃ l₄⋘r₄ l₄≃r₄ l₃⋗l₄) | lemma-drop⋘ (cl y₂≤y₅ l₅⋘r₅) (cl y₂≤y₆ l₆⋘r₆) (ll⋘ y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆)
  ... | _ | inj₁ y₅≤y₆ | inj₁ (l₁≃r₁ , _) | inj₁ (_ , l₂⋙dr₂) =
                       let l₁⋘r₁ = lr⋘ y₁≤y₃ y₁≤y₄ l₃⋙r₃ l₄⋘r₄ l₄≃r₄ l₃⋗l₄ ;
                            l₂⋘r₂ = ll⋘ y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆ ;
                            l₁≃l₂ = trans≃ l₁≃r₁ r₁≃l₂ ;
                            pl₂'≈l₂' = lemma-push⋘ (lexy y₅≤y₆) (lexy refl≤) l₅⋘r₅ ;
                            l₂'≈l₂ = ≈left (lexy refl≤) y₂≤y₅ l₅⋘r₅ l₅⋘r₅ refl≈ refl≈ ;
                            pl₂'≈l₂ = trans≈ pl₂'≈l₂' l₂'≈l₂ ;
                            pl₂'⋙dr₂ = lemma≈⋙ pl₂'≈l₂ l₂⋙dr₂ ;
                            pl₂'⋙dr₂' = subtyping⋙r (lexy y₅≤y₆) pl₂'⋙dr₂ ;
                            l₂≈pl₂' = sym≈ pl₂'≈l₂ ;
                            l₁≃pl₂' = lemma≃≈ l₁≃l₂ l₂≈pl₂'
                       in inj₁ (≃nd y≤y₁ y≤y₂ l₁⋘r₁ l₂⋘r₂ l₁≃r₁ l₂≃r₂ l₁≃l₂ , ⋙rr y≤y₁ y₂≤y₅ l₁⋘r₁ l₁≃r₁ pl₂'⋙dr₂' l₁≃pl₂')
  ... | _ | inj₂ y₆≤y₅ | inj₁ (l₁≃r₁ , _) | inj₁ (_ , l₂⋙dr₂) =
                       let l₁⋘r₁ = lr⋘ y₁≤y₃ y₁≤y₄ l₃⋙r₃ l₄⋘r₄ l₄≃r₄ l₃⋗l₄ ;
                            l₂⋘r₂ = ll⋘ y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆ ;
                            l₁≃l₂ = trans≃ l₁≃r₁ r₁≃l₂ ;
                            l₂'≈l₂ = ≈left (lexy y₆≤y₅) y₂≤y₅ l₅⋘r₅ l₅⋘r₅ refl≈ refl≈ ;
                            l₂'⋙dr₂ = lemma≈⋙ l₂'≈l₂ l₂⋙dr₂ ;
                            l₂≈l₂' = sym≈ l₂'≈l₂ ;
                            l₁≃l₂' = lemma≃≈ l₁≃l₂ l₂≈l₂'
                       in inj₁ (≃nd y≤y₁ y≤y₂ l₁⋘r₁ l₂⋘r₂ l₁≃r₁ l₂≃r₂ l₁≃l₂ , ⋙rr y≤y₁ y₂≤y₆ l₁⋘r₁ l₁≃r₁ l₂'⋙dr₂ l₁≃l₂')
  ... | inj₁ y₃≤y₄ | _ | inj₂ dl₁⋘r₁ | _ =
                       let r₁≈r₁' = ≈left y₁≤y₄ (lexy y₃≤y₄) l₄⋘r₄ l₄⋘r₄ refl≈ refl≈ ;
                            dl₁⋘r₁' = lemma⋘≈ dl₁⋘r₁ r₁≈r₁' ;
                            l₂⋘r₂ = ll⋘ y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆ ;
                            r₁'≈r₁ = sym≈ r₁≈r₁' ;
                            r₁'≃l₂ = lemma≈≃ r₁'≈r₁ r₁≃l₂
                       in inj₂ (ll⋘ y₁≤y₃ y≤y₂ dl₁⋘r₁' l₂⋘r₂ l₂≃r₂ r₁'≃l₂)
  ... | inj₂ y₄≤y₃ | _ | inj₂ dl₁⋘r₁ | _ =
                       let r₁≈r₁' = ≈left y₁≤y₄ (lexy refl≤) l₄⋘r₄ l₄⋘r₄ refl≈ refl≈ ;
                            pr₁'≈r₁' = lemma-push⋘ (lexy y₄≤y₃) (lexy refl≤) l₄⋘r₄ ;
                            dl₁⋘r₁' = lemma⋘≈ dl₁⋘r₁ r₁≈r₁' ;
                            r₁'≈pr₁' = sym≈ pr₁'≈r₁' ;
                            r₁≈pr₁' = trans≈ r₁≈r₁' r₁'≈pr₁' ;
                            dl₁⋘pr₁' = lemma⋘≈ dl₁⋘r₁ r₁≈pr₁' ;
                            l₂⋘r₂ = ll⋘ y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆ ;
                            dl₁'⋘pr₁' = subtyping⋘l (lexy y₄≤y₃) dl₁⋘pr₁' ;
                            r₁'≈r₁ = sym≈ r₁≈r₁' ;
                            r₁'≃l₂ = lemma≈≃ r₁'≈r₁ r₁≃l₂ ;
                            pr₁'≃l₂ = lemma≈≃ pr₁'≈r₁' r₁'≃l₂
                       in inj₂ (ll⋘ y₁≤y₄ y≤y₂ dl₁'⋘pr₁' l₂⋘r₂ l₂≃r₂ pr₁'≃l₂)
  ... | _ | _ | inj₁ (l₁≃r₁ , l₁⋙dr₁) | inj₂ dl₂⋘r₂
      with lemma-drop-⊥ y₂≤y₅ l₅⋘r₅ (lemma-⋘-≃ dl₂⋘r₂ (sym≃ l₂≃r₂))
  ... | ()
  lemma-drop⋘ (cl y≤y₁ (lr⋘ y₁≤y₃ y₁≤y₄ l₃⋙r₃ l₄⋘r₄ l₄≃r₄ l₃⋗l₄)) (cl y≤y₂ (lr⋘ y₂≤y₅ y₂≤y₆ l₅⋙r₅ l₆⋘r₆ l₆≃r₆ l₅⋗l₆)) (ll⋘ .y≤y₁ .y≤y₂ .(lr⋘ y₁≤y₃ y₁≤y₄ l₃⋙r₃ l₄⋘r₄ l₄≃r₄ l₃⋗l₄) .(lr⋘ y₂≤y₅ y₂≤y₆ l₅⋙r₅ l₆⋘r₆ l₆≃r₆ l₅⋗l₆) () _)
  lemma-drop⋘ (cr y≤y₁ (⋙lf y₁≤y₃)) (cl y≤y₂ lf⋘) (lr⋘ .y≤y₁ .y≤y₂ .(⋙lf y₁≤y₃) .lf⋘ ≃lf (⋗lf .y₁≤y₃)) = inj₂ (ll⋘ y₁≤y₃ y≤y₂ lf⋘ lf⋘ ≃lf ≃lf)
  lemma-drop⋘ (cr y≤y₁ (⋙lf y₁≤y₃)) (cl y≤y₂ (ll⋘ y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆)) (lr⋘ .y≤y₁ .y≤y₂ .(⋙lf y₁≤y₃) .(ll⋘ y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆) _ (⋗nd .y₁≤y₃ .y₂≤y₅ .lf⋘ .l₅⋘r₅ _ _ ()))
  lemma-drop⋘ (cr y≤y₁ (⋙lf y₁≤y₃)) (cl y≤y₂ (lr⋘ y₂≤y₅ y₂≤y₆ l₅⋙r₅ l₆⋘r₆ l₆≃r₆ l₅⋗l₆)) (lr⋘ .y≤y₁ .y≤y₂ .(⋙lf y₁≤y₃) .(lr⋘ y₂≤y₅ y₂≤y₆ l₅⋙r₅ l₆⋘r₆ l₆≃r₆ l₅⋗l₆) () _)
  lemma-drop⋘ (cr y≤y₁ (⋙rl {x = y₃} {x' = y₄} y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₃≃r₃ l₄⋘r₄ l₃⋗r₄)) (cl y≤y₂ l₂⋘r₂) (lr⋘ .y≤y₁ .y≤y₂ .(⋙rl y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₃≃r₃ l₄⋘r₄ l₃⋗r₄) .l₂⋘r₂ l₂≃r₂ l₁⋗l₂)
      with tot≤ y₃ y₄ | lemma-drop⋙ (cl y₁≤y₃ l₃⋘r₃) (cl y₁≤y₄ l₄⋘r₄) (⋙rl y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₃≃r₃ l₄⋘r₄ l₃⋗r₄)
  ... | inj₁ y₃≤y₄ | inj₁ (l₁⋗r₁ , dl₁⋘r₁) =
                       let r₁≈r₁' = ≈left y₁≤y₄ (lexy y₃≤y₄) l₄⋘r₄ l₄⋘r₄ refl≈ refl≈ ;
                            dl₁⋘r₁' = lemma⋘≈ dl₁⋘r₁ r₁≈r₁' ;
                            r₁'≈r₁ = sym≈ r₁≈r₁' ;
                            r₁≃l₂ = lemma⋗⋗' l₁⋗r₁ l₁⋗l₂ ;
                            r₁'≃l₂ = lemma≈≃ r₁'≈r₁ r₁≃l₂
                       in inj₂ (ll⋘ y₁≤y₃ y≤y₂ dl₁⋘r₁' l₂⋘r₂ l₂≃r₂ r₁'≃l₂)
  ... | inj₁ y₃≤y₄ | inj₂ l₁⋙dr₁ =
                       let l₁'≈l₁ = ≈left (lexy refl≤) y₁≤y₃ l₃⋘r₃ l₃⋘r₃ refl≈ refl≈ ;
                            pl₁'≈l₁' = lemma-push⋘ (lexy y₃≤y₄) (lexy refl≤) l₃⋘r₃ ;
                            pl₁'≈l₁ = trans≈ pl₁'≈l₁' l₁'≈l₁ ;
                            pl₁'⋙dr = lemma≈⋙ pl₁'≈l₁ l₁⋙dr₁ ;
                            pl₁'⋙dr₁' = subtyping⋙r (lexy y₃≤y₄) pl₁'⋙dr ;
                            pl₁'⋗l₂ = lemma≈⋗ pl₁'≈l₁ l₁⋗l₂
                       in inj₂ (lr⋘ y₁≤y₃ y≤y₂ pl₁'⋙dr₁' l₂⋘r₂ l₂≃r₂ pl₁'⋗l₂)
  ... | inj₂ y₄≤y₃ | inj₁ (l₁⋗r₁ , dl₁⋘r₁) =
                       let r₁'≈r₁ = ≈left (lexy refl≤) y₁≤y₄ l₄⋘r₄ l₄⋘r₄ refl≈ refl≈ ;
                            pr₁'≈r₁' = lemma-push⋘ (lexy y₄≤y₃) (lexy refl≤) l₄⋘r₄ ;
                            r₁'≈pr₁' = sym≈ pr₁'≈r₁' ;
                            pr₁'≈r₁ = trans≈ pr₁'≈r₁' r₁'≈r₁ ;
                            r₁≈pr₁' = sym≈ pr₁'≈r₁ ;
                            dl₁⋘pr₁' = lemma⋘≈ dl₁⋘r₁ r₁≈pr₁' ;
                            dl₁'⋘pr₁' = subtyping⋘l (lexy y₄≤y₃) dl₁⋘pr₁' ;
                            r₁≃l₂ = lemma⋗⋗' l₁⋗r₁ l₁⋗l₂ ;
                            pr₁'≃l₂ = lemma≈≃ pr₁'≈r₁ r₁≃l₂
                       in inj₂ (ll⋘ y₁≤y₄ y≤y₂ dl₁'⋘pr₁' l₂⋘r₂ l₂≃r₂ pr₁'≃l₂)
  ... | inj₂ y₄≤y₃ | inj₂ l₁⋙dr₁ =
                       let l₁'≈l₁ = ≈left (lexy y₄≤y₃) y₁≤y₃ l₃⋘r₃ l₃⋘r₃ refl≈ refl≈ ;
                            l₁'⋙dr₁ = lemma≈⋙ l₁'≈l₁ l₁⋙dr₁ ;
                            l₁'⋗l₂ = lemma≈⋗ l₁'≈l₁ l₁⋗l₂
                       in inj₂ (lr⋘ y₁≤y₄ y≤y₂ l₁'⋙dr₁ l₂⋘r₂ l₂≃r₂ l₁'⋗l₂)
  lemma-drop⋘ (cr y≤y₁ (⋙rr {x = y₃} {x' = y₄} y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₃≃r₃ l₄⋙r₄ l₃≃l₄)) (cl y≤y₂ l₂⋘r₂) (lr⋘ .y≤y₁ .y≤y₂ .(⋙rr y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₃≃r₃ l₄⋙r₄ l₃≃l₄) .l₂⋘r₂ l₂≃r₂ l₁⋗l₂)
      with tot≤ y₃ y₄ | lemma-drop⋙ (cl y₁≤y₃ l₃⋘r₃) (cr y₁≤y₄ l₄⋙r₄) (⋙rr y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₃≃r₃ l₄⋙r₄ l₃≃l₄)
  ... | _ | inj₁ (() , _)
  ... | inj₁ y₃≤y₄ | inj₂ l₁⋙dr₁ =
                       let l₁'≈l₁ = ≈left (lexy refl≤) y₁≤y₃ l₃⋘r₃ l₃⋘r₃ refl≈ refl≈ ;
                            pl₁'≈l₁' = lemma-push⋘ (lexy y₃≤y₄) (lexy refl≤) l₃⋘r₃ ;
                            pl₁'≈l₁ = trans≈ pl₁'≈l₁' l₁'≈l₁ ;
                            pl₁'⋙dr = lemma≈⋙ pl₁'≈l₁ l₁⋙dr₁ ;
                            pl₁'⋙dr₁' = subtyping⋙r (lexy y₃≤y₄) pl₁'⋙dr ;
                            pl₁'⋗l₂ = lemma≈⋗ pl₁'≈l₁ l₁⋗l₂
                       in inj₂ (lr⋘ y₁≤y₃ y≤y₂ pl₁'⋙dr₁' l₂⋘r₂ l₂≃r₂ pl₁'⋗l₂)
  ... | inj₂ y₄≤y₃ | inj₂ l₁⋙dr₁ =
                       let l₁'≈l₁ = ≈left (lexy y₄≤y₃) y₁≤y₃ l₃⋘r₃ l₃⋘r₃ refl≈ refl≈ ;
                            l₁'⋙dr₁ = lemma≈⋙ l₁'≈l₁ l₁⋙dr₁ ;
                            l₁'⋗l₂ = lemma≈⋗ l₁'≈l₁ l₁⋗l₂
                       in inj₂ (lr⋘ y₁≤y₄ y≤y₂ l₁'⋙dr₁ l₂⋘r₂ l₂≃r₂ l₁'⋗l₂)

  lemma-drop⋙ : {b : Bound}{l r : BBHeap b}(cₗ : Compound l)(cᵣ : Compound r) → l ⋙ r → l ⋗ r ∧ drop cₗ ⋘ r ∨ l ⋙ drop cᵣ
  lemma-drop⋙ (cl y≤y₁ lf⋘) (cl y≤y₂ l₂⋘r₂) (⋙rl .y≤y₁ .y≤y₂ .lf⋘ _ .l₂⋘r₂ ())
  lemma-drop⋙ (cl y≤y₁ (ll⋘ {x = y₃} {x' = y₄} y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄)) (cl y≤y₂ lf⋘) (⋙rl .y≤y₁ .y≤y₂ .(ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄) l₁≃r₁ .lf⋘ l₁⋗r₂)
      with tot≤ y₃ y₄ | lemma-drop⋘ (cl y₁≤y₃ l₃⋘r₃) (cl y₁≤y₄ l₄⋘r₄) (ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄)
  ... | inj₁ y₃≤y₄ | inj₁ (_ , l₁⋙dr₁) =
                       let l₁⋘r₁ = ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄ ;
                            l₁⋗l₂ = lemma⋗≃ l₁⋗r₂ ≃lf ;
                            l₁'≈l₁ = ≈left (lexy refl≤) y₁≤y₃  l₃⋘r₃ l₃⋘r₃ refl≈ refl≈ ;
                            pl₁'≈l₁' = lemma-push⋘ (lexy y₃≤y₄) (lexy refl≤) l₃⋘r₃ ;
                            pl₁'≈l₁ = trans≈ pl₁'≈l₁' l₁'≈l₁ ;
                            pl₁'⋙dr₁ = lemma≈⋙ pl₁'≈l₁ l₁⋙dr₁ ;
                            pl₁'⋙dr₁' = subtyping⋙r (lexy y₃≤y₄) pl₁'⋙dr₁ ;
                            pl₁'⋗l₂ = lemma≈⋗ pl₁'≈l₁ l₁⋗l₂
                       in inj₁ (⋗nd y≤y₁ y≤y₂ l₁⋘r₁ lf⋘ l₁≃r₁ ≃lf l₁⋗l₂ , lr⋘ y₁≤y₃ y≤y₂ pl₁'⋙dr₁' lf⋘ ≃lf pl₁'⋗l₂)
  ... | inj₂ y₄≤y₃ | inj₁ (_ , l₁⋙dr₁) =
                       let l₁⋘r₁ = ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄ ;
                            l₁⋗l₂ = lemma⋗≃ l₁⋗r₂ ≃lf ;
                            l₁'≈l₁ = ≈left (lexy y₄≤y₃) y₁≤y₃ l₃⋘r₃ l₃⋘r₃ refl≈ refl≈ ;
                            l₁'⋙dr₁ = lemma≈⋙ l₁'≈l₁ l₁⋙dr₁ ;
                            l₁'⋗l₂ = lemma≈⋗ l₁'≈l₁ l₁⋗l₂
                       in inj₁ (⋗nd y≤y₁ y≤y₂ l₁⋘r₁ lf⋘ l₁≃r₁ ≃lf l₁⋗l₂ , lr⋘ y₁≤y₄ y≤y₂ l₁'⋙dr₁ lf⋘ ≃lf l₁'⋗l₂)
  ... | _ | inj₂ dl₁⋘r₁
      with lemma-drop-⊥ y₁≤y₃ l₃⋘r₃ (lemma-⋘-≃ dl₁⋘r₁ (sym≃ l₁≃r₁))
  ... | ()
  lemma-drop⋙ (cl y≤y₁ (ll⋘ {x = y₃} {x' = y₄} y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄)) (cl y≤y₂ (ll⋘ {x = y₅} {x' = y₆} y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆)) (⋙rl .y≤y₁ .y≤y₂ .(ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄) l₁≃r₁ .(ll⋘ y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆) l₁⋗r₂)
      with tot≤ y₃ y₄ | tot≤ y₅ y₆ | lemma-drop⋘ (cl y₂≤y₅ l₅⋘r₅) (cl y₂≤y₆ l₆⋘r₆) (ll⋘ y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆) | lemma-drop⋘ (cl y₁≤y₃ l₃⋘r₃) (cl y₁≤y₄ l₄⋘r₄)  (ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄)
  ... | inj₁ y₃≤y₄ | _ | inj₁ (l₂≃r₂ , _) | inj₁ (_ , l₁⋙dr₁) =
                       let l₁⋘r₁ = ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄ ;
                            l₂⋘r₂ = ll⋘ y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆ ;
                            r₂≃l₂ = sym≃ l₂≃r₂ ;
                            l₁⋗l₂ = lemma⋗≃ l₁⋗r₂ r₂≃l₂ ;
                            l₁'≈l₁ = ≈left (lexy refl≤) y₁≤y₃  l₃⋘r₃ l₃⋘r₃ refl≈ refl≈ ;
                            pl₁'≈l₁' = lemma-push⋘ (lexy y₃≤y₄) (lexy refl≤) l₃⋘r₃ ;
                            pl₁'≈l₁ = trans≈ pl₁'≈l₁' l₁'≈l₁ ;
                            pl₁'⋙dr₁ = lemma≈⋙ pl₁'≈l₁ l₁⋙dr₁ ;
                            pl₁'⋙dr₁' = subtyping⋙r (lexy y₃≤y₄) pl₁'⋙dr₁ ;
                            pl₁'⋗l₂ = lemma≈⋗ pl₁'≈l₁ l₁⋗l₂
                       in inj₁ (⋗nd y≤y₁ y≤y₂ l₁⋘r₁ l₂⋘r₂ l₁≃r₁ l₂≃r₂ l₁⋗l₂ , lr⋘ y₁≤y₃ y≤y₂ pl₁'⋙dr₁' l₂⋘r₂ l₂≃r₂ pl₁'⋗l₂)
  ... | inj₂ y₄≤y₃ | _ | inj₁ (l₂≃r₂ , _) | inj₁ (_ , l₁⋙dr₁) =
                       let l₁⋘r₁ = ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄ ;
                            l₂⋘r₂ = ll⋘ y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₆⋘r₆ l₆≃r₆ r₅≃l₆ ;
                            r₂≃l₂ = sym≃ l₂≃r₂ ;
                            l₁⋗l₂ = lemma⋗≃ l₁⋗r₂ r₂≃l₂ ;
                            l₁'≈l₁ = ≈left (lexy y₄≤y₃) y₁≤y₃ l₃⋘r₃ l₃⋘r₃ refl≈ refl≈ ;
                            l₁'⋙dr₁ = lemma≈⋙ l₁'≈l₁ l₁⋙dr₁ ;
                            l₁'⋗l₂ = lemma≈⋗ l₁'≈l₁ l₁⋗l₂
                       in inj₁ (⋗nd y≤y₁ y≤y₂ l₁⋘r₁ l₂⋘r₂ l₁≃r₁ l₂≃r₂ l₁⋗l₂ , lr⋘ y₁≤y₄ y≤y₂ l₁'⋙dr₁ l₂⋘r₂ l₂≃r₂ l₁'⋗l₂)
  ... | _ | inj₁ y₅≤y₆ | inj₂ dl₂⋘r₂ | _ =
                         let l₁⋘r₁ = ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄ ;
                              r₂≈r₂' = ≈left y₂≤y₆ (lexy y₅≤y₆) l₆⋘r₆ l₆⋘r₆ refl≈ refl≈ ;
                              dl₂⋘r₂' = lemma⋘≈ dl₂⋘r₂ r₂≈r₂' ;
                              l₁⋗r₂' = lemma⋗≈ l₁⋗r₂ r₂≈r₂'
                         in inj₂ (⋙rl y≤y₁ y₂≤y₅ l₁⋘r₁ l₁≃r₁ dl₂⋘r₂' l₁⋗r₂')
  ... | _ | inj₂ y₆≤y₅ | inj₂ dl₂⋘r₂ | _ =
                         let l₁⋘r₁ = ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄ ;
                              r₂≈r₂' = ≈left y₂≤y₆ (lexy refl≤) l₆⋘r₆ l₆⋘r₆ refl≈ refl≈ ;
                              pr₂'≈r₂' = lemma-push⋘ (lexy y₆≤y₅) (lexy refl≤) l₆⋘r₆ ;
                              r₂'≈pr₂' = sym≈ pr₂'≈r₂' ;
                              r₂≈pr₂' = trans≈ r₂≈r₂' r₂'≈pr₂';
                              dl₂⋘pr₂' = lemma⋘≈ dl₂⋘r₂ r₂≈pr₂' ;
                              dl₂'⋘pr₂' = subtyping⋘l (lexy y₆≤y₅) dl₂⋘pr₂' ;
                              l₁⋗pr₂' = lemma⋗≈ l₁⋗r₂ r₂≈pr₂'
                         in inj₂ (⋙rl y≤y₁ y₂≤y₆ l₁⋘r₁ l₁≃r₁ dl₂'⋘pr₂' l₁⋗pr₂')
  ... | _ | _ | _ | inj₂ dl₁⋘r₁
      with lemma-drop-⊥ y₁≤y₃ l₃⋘r₃ (lemma-⋘-≃ dl₁⋘r₁ (sym≃ l₁≃r₁))
  ... | ()
  lemma-drop⋙ (cl y≤y₁ (ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄)) (cl y≤y₂ (lr⋘ {x = y₅} {x' = y₆} y₂≤y₅ y₂≤y₆ l₅⋙r₅ l₆⋘r₆ l₆≃r₆ l₅⋗l₆)) (⋙rl .y≤y₁ .y≤y₂ .(ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄) l₁≃r₁ .(lr⋘ y₂≤y₅ y₂≤y₆ l₅⋙r₅ l₆⋘r₆ l₆≃r₆ l₅⋗l₆) l₁⋗r₂)
      with tot≤ y₅ y₆ | lemma-drop⋘ (cr y₂≤y₅ l₅⋙r₅) (cl y₂≤y₆ l₆⋘r₆) (lr⋘ y₂≤y₅ y₂≤y₆ l₅⋙r₅ l₆⋘r₆ l₆≃r₆ l₅⋗l₆)
  ... | _ | inj₁ (() , _)
  ... | inj₁ y₅≤y₆ | inj₂ dl₂⋘r₂ =
                         let l₁⋘r₁ = ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄ ;
                              r₂≈r₂' = ≈left y₂≤y₆ (lexy y₅≤y₆) l₆⋘r₆ l₆⋘r₆ refl≈ refl≈ ;
                              dl₂⋘r₂' = lemma⋘≈ dl₂⋘r₂ r₂≈r₂' ;
                              l₁⋗r₂' = lemma⋗≈ l₁⋗r₂ r₂≈r₂'
                         in inj₂ (⋙rl y≤y₁ y₂≤y₅ l₁⋘r₁ l₁≃r₁ dl₂⋘r₂' l₁⋗r₂')
  ... | inj₂ y₆≤y₅ | inj₂ dl₂⋘r₂ =
                         let l₁⋘r₁ = ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄ ;
                              r₂≈r₂' = ≈left y₂≤y₆ (lexy refl≤) l₆⋘r₆ l₆⋘r₆ refl≈ refl≈ ;
                              pr₂'≈r₂' = lemma-push⋘ (lexy y₆≤y₅) (lexy refl≤) l₆⋘r₆ ;
                              r₂'≈pr₂' = sym≈ pr₂'≈r₂' ;
                              r₂≈pr₂' = trans≈ r₂≈r₂' r₂'≈pr₂';
                              dl₂⋘pr₂' = lemma⋘≈ dl₂⋘r₂ r₂≈pr₂' ;
                              dl₂'⋘pr₂' = subtyping⋘l (lexy y₆≤y₅) dl₂⋘pr₂' ;
                              l₁⋗pr₂' = lemma⋗≈ l₁⋗r₂ r₂≈pr₂'
                         in inj₂ (⋙rl y≤y₁ y₂≤y₆ l₁⋘r₁ l₁≃r₁ dl₂'⋘pr₂' l₁⋗pr₂')
  lemma-drop⋙ (cl y≤y₁ (lr⋘ y₁≤y₃ y₁≤y₄ l₃⋙r₃ l₄⋘r₄ l₄≃r₄ l₃⋗l₄)) (cl y≤y₂ l₂⋘r₂) (⋙rl .y≤y₁ .y≤y₂ .(lr⋘ y₁≤y₃ y₁≤y₄ l₃⋙r₃ l₄⋘r₄ l₄≃r₄ l₃⋗l₄) () .l₂⋘r₂ _)
  lemma-drop⋙ _ _ (⋙rr _ _ lf⋘ _ (⋙lf _) ())
  lemma-drop⋙ _ _ (⋙rr _ _ lf⋘ _ (⋙rl _ _ _ _ _ _) ())
  lemma-drop⋙ _ _ (⋙rr _ _ lf⋘ _ (⋙rr _ _ _ _ _ _) ())
  lemma-drop⋙ (cl y≤y₁ (ll⋘ y₁≤y₃ y₁≤y₄ lf⋘ l₄⋘r₄ l₄≃r₄ r₃≃l₄)) (cr y≤y₂ (⋙lf y₂≤y₅)) (⋙rr .y≤y₁ .y≤y₂ .(ll⋘ y₁≤y₃ y₁≤y₄ lf⋘ l₄⋘r₄ l₄≃r₄ r₃≃l₄) l₁≃r₁ .(⋙lf y₂≤y₅) (≃nd .y₁≤y₃ .y₂≤y₅ .lf⋘ .lf⋘ ≃lf ≃lf ≃lf)) =
                         let l₁⋘r₁ = ll⋘ y₁≤y₃ y₁≤y₄ lf⋘ l₄⋘r₄ l₄≃r₄ r₃≃l₄ ;
                              l₁⋗r₂ = ⋗lf y₁≤y₃
                         in inj₂ (⋙rl y≤y₁ y₂≤y₅ l₁⋘r₁ l₁≃r₁ lf⋘ l₁⋗r₂)
  lemma-drop⋙ _ _ (⋙rr _ _ (ll⋘ y₁≤y₃ _ (ll⋘ _ _ _ _ _ _) _ _ _) _ (⋙lf y₂≤y₅) (≃nd .y₁≤y₃ .y₂≤y₅ .(ll⋘ _ _ _ _ _ _) .lf⋘ _ ≃lf ()))
  lemma-drop⋙ _ _ (⋙rr _ _ (ll⋘ y₁≤y₃ _ (lr⋘ _ _ _ _ _ _) _ _ _) _ (⋙lf y₂≤y₅) (≃nd .y₁≤y₃ .y₂≤y₅ .(lr⋘ _ _ _ _ _ _) .lf⋘ _ ≃lf ()))
  lemma-drop⋙ (cl y≤y₁ (ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄)) (cr y≤y₂ (⋙rl {x = y₅} {x' = y₆} y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₅≃r₅ l₆⋘r₆ l₅⋗r₆)) (⋙rr .y≤y₁ .y≤y₂ .(ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄) l₁≃r₁ .(⋙rl y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₅≃r₅ l₆⋘r₆ l₅⋗r₆) l₁≃l₂)
      with tot≤ y₅ y₆ | lemma-drop⋙ (cl y₂≤y₅ l₅⋘r₅) (cl y₂≤y₆ l₆⋘r₆) (⋙rl y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₅≃r₅ l₆⋘r₆ l₅⋗r₆)
  ... | inj₁ y₅≤y₆ | inj₁ (l₂⋗r₂ , dl₂⋘r₂) =
                         let l₁⋘r₁ = ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄ ;
                              r₂≈r₂' = ≈left y₂≤y₆ (lexy y₅≤y₆) l₆⋘r₆ l₆⋘r₆ refl≈ refl≈ ;
                              dl₂⋘r₂' = lemma⋘≈ dl₂⋘r₂ r₂≈r₂' ;
                              l₁⋗r₂ = lemma≃⋗ l₁≃l₂ l₂⋗r₂ ;
                              l₁⋗r₂' = lemma⋗≈ l₁⋗r₂ r₂≈r₂'
                         in inj₂ (⋙rl y≤y₁ y₂≤y₅ l₁⋘r₁ l₁≃r₁ dl₂⋘r₂' l₁⋗r₂')
  ... | inj₁ y₅≤y₆ | inj₂ l₂⋙dr₂ =
                        let l₁⋘r₁ = ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄ ;
                             l₂'≈l₂ = ≈left (lexy refl≤) y₂≤y₅ l₅⋘r₅ l₅⋘r₅ refl≈ refl≈ ;
                             pl₂'≈l₂' = lemma-push⋘ (lexy y₅≤y₆) (lexy refl≤) l₅⋘r₅ ;
                             pl₂'≈l₂ = trans≈ pl₂'≈l₂' l₂'≈l₂ ;
                             pl₂'⋙dr₂ = lemma≈⋙ pl₂'≈l₂ l₂⋙dr₂ ;
                             l₂≈pl₂' = sym≈ pl₂'≈l₂ ;
                             pl₂'⋙dr₂' = subtyping⋙r (lexy y₅≤y₆) pl₂'⋙dr₂ ;
                             l₁≃pl₂' = lemma≃≈ l₁≃l₂ l₂≈pl₂'
                        in inj₂ (⋙rr y≤y₁ y₂≤y₅ l₁⋘r₁ l₁≃r₁ pl₂'⋙dr₂' l₁≃pl₂')
  ... | inj₂ y₆≤y₅ | inj₁ (l₂⋗r₂ , dl₂⋘r₂) =
                         let l₁⋘r₁ = ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄ ;
                              r₂'≈r₂ = ≈left (lexy refl≤) y₂≤y₆ l₆⋘r₆ l₆⋘r₆ refl≈ refl≈ ;
                              pr₂'≈r₂' = lemma-push⋘ (lexy y₆≤y₅) (lexy refl≤) l₆⋘r₆ ;
                              pr₂'≈r₂ = trans≈ pr₂'≈r₂' r₂'≈r₂ ;
                              r₂≈pr₂' = sym≈ pr₂'≈r₂ ;
                              dl₂⋘pr₂' = lemma⋘≈ dl₂⋘r₂ r₂≈pr₂' ;
                              dl₂'⋘pr₂' = subtyping⋘l (lexy y₆≤y₅) dl₂⋘pr₂' ;
                              l₁⋗r₂ = lemma≃⋗ l₁≃l₂ l₂⋗r₂ ;
                              l₁⋗pr₂' = lemma⋗≈ l₁⋗r₂ r₂≈pr₂'
                         in inj₂ (⋙rl y≤y₁ y₂≤y₆ l₁⋘r₁ l₁≃r₁ dl₂'⋘pr₂' l₁⋗pr₂')
  ... | inj₂ y₆≤y₅ | inj₂ l₂⋙dr₂ =
                         let l₁⋘r₁ = ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄ ;
                              l₂'≈l₂ = ≈left (lexy y₆≤y₅) y₂≤y₅ l₅⋘r₅ l₅⋘r₅ refl≈ refl≈ ;
                              l₂'⋙dr₂ = lemma≈⋙ l₂'≈l₂ l₂⋙dr₂ ;
                              l₂≈l₂' = sym≈ l₂'≈l₂ ;
                              l₁≃l₂' = lemma≃≈ l₁≃l₂ l₂≈l₂'
                         in inj₂ (⋙rr y≤y₁ y₂≤y₆ l₁⋘r₁ l₁≃r₁ l₂'⋙dr₂ l₁≃l₂')
  lemma-drop⋙ (cl y≤y₁ (ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄)) (cr y≤y₂ (⋙rr {x = y₅} {x' = y₆} y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₅≃r₅ l₆⋙r₆ l₅≃l₆)) (⋙rr .y≤y₁ .y≤y₂ .(ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄) l₁≃r₁ .(⋙rr y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₅≃r₅ l₆⋙r₆ l₅≃l₆) l₁≃l₂)
      with tot≤ y₅ y₆ | lemma-drop⋙ (cl y₂≤y₅ l₅⋘r₅) (cr y₂≤y₆ l₆⋙r₆) (⋙rr y₂≤y₅ y₂≤y₆ l₅⋘r₅ l₅≃r₅ l₆⋙r₆ l₅≃l₆)
  ... | _ | inj₁ (() , _)
  ... | inj₁ y₅≤y₆ | inj₂ l₂⋙dr₂ =
                        let l₁⋘r₁ = ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄ ;
                             l₂'≈l₂ = ≈left (lexy refl≤) y₂≤y₅ l₅⋘r₅ l₅⋘r₅ refl≈ refl≈ ;
                             pl₂'≈l₂' = lemma-push⋘ (lexy y₅≤y₆) (lexy refl≤) l₅⋘r₅ ;
                             pl₂'≈l₂ = trans≈ pl₂'≈l₂' l₂'≈l₂ ;
                             pl₂'⋙dr₂ = lemma≈⋙ pl₂'≈l₂ l₂⋙dr₂ ;
                             l₂≈pl₂' = sym≈ pl₂'≈l₂ ;
                             pl₂'⋙dr₂' = subtyping⋙r (lexy y₅≤y₆) pl₂'⋙dr₂ ;
                             l₁≃pl₂' = lemma≃≈ l₁≃l₂ l₂≈pl₂'
                        in inj₂ (⋙rr y≤y₁ y₂≤y₅ l₁⋘r₁ l₁≃r₁ pl₂'⋙dr₂' l₁≃pl₂')
  ... | inj₂ y₆≤y₅ | inj₂ l₂⋙dr₂ =
                         let l₁⋘r₁ = ll⋘ y₁≤y₃ y₁≤y₄ l₃⋘r₃ l₄⋘r₄ l₄≃r₄ r₃≃l₄ ;
                              l₂'≈l₂ = ≈left (lexy y₆≤y₅) y₂≤y₅ l₅⋘r₅ l₅⋘r₅ refl≈ refl≈ ;
                              l₂'⋙dr₂ = lemma≈⋙ l₂'≈l₂ l₂⋙dr₂ ;
                              l₂≈l₂' = sym≈ l₂'≈l₂ ;
                              l₁≃l₂' = lemma≃≈ l₁≃l₂ l₂≈l₂'
                         in inj₂ (⋙rr y≤y₁ y₂≤y₆ l₁⋘r₁ l₁≃r₁ l₂'⋙dr₂ l₁≃l₂')
  lemma-drop⋙ (cl y≤y₁ (lr⋘ y₁≤y₃ y₁≤y₄ l₃⋙r₃ l₄⋘r₄ l₄≃r₄ l₃⋗l₄)) (cr y≤y₂ l₂⋙r₂) (⋙rr .y≤y₁ .y≤y₂ .(lr⋘ y₁≤y₃ y₁≤y₄ l₃⋙r₃ l₄⋘r₄ l₄≃r₄ l₃⋗l₄) () .l₂⋙r₂ _)

  lemma-drop-⊥ : {b : Bound}{x : A}{l r : BBHeap (val x)}(b≤x : LeB b (val x))(l⋘r : l ⋘ r) → drop (cl b≤x l⋘r) ⋘ (left b≤x l⋘r) → ⊥
  lemma-drop-⊥ _ lf⋘ ()
  lemma-drop-⊥ b≤x (ll⋘ {x = y₁} {x' = y₂} x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂) dxlr⋘xlr
      with tot≤ y₁ y₂ | lemma-drop⋘ (cl x≤y₁ l₁⋘r₁) (cl x≤y₂ l₂⋘r₂) (ll⋘ x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂) | dxlr⋘xlr | lemma-perfect dxlr⋘xlr
  ... | inj₁ y₁≤y₂ | inj₁ (l≃r , l⋙dr) | _dxlr⋘xlr | _ =
                         let l⋘r = ll⋘ x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂ ;
                              pl'≈l' = lemma-push⋘ (lexy y₁≤y₂) (lexy refl≤) l₁⋘r₁ ;
                              l'≈l = ≈left (lexy refl≤) x≤y₁ l₁⋘r₁ l₁⋘r₁ refl≈ refl≈ ;
                              pl'≈l = trans≈ pl'≈l' l'≈l ;
                              pl'⋙dr = lemma≈⋙ pl'≈l l⋙dr ;
                              pl'⋙dr' = subtyping⋙r (lexy y₁≤y₂) pl'⋙dr ;
                              r≃l = sym≃ l≃r ;
                              l≃l = trans≃ l≃r r≃l ;
                              pl'≃l = lemma≈≃ pl'≈l l≃l
                         in lemma-⋘-⊥ x≤y₁ b≤x pl'⋙dr' l⋘r pl'≃l _dxlr⋘xlr
  ... | inj₂ y₂≤y₁ | inj₁ (l≃r , l⋙dr) | _dxlr⋘xlr | _ =
                         let l⋘r = ll⋘ x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂ ;
                              l'≈l = ≈left (lexy y₂≤y₁) x≤y₁ l₁⋘r₁  l₁⋘r₁ refl≈ refl≈ ;
                              l'⋙dr = lemma≈⋙ l'≈l l⋙dr ;
                              r≃l = sym≃ l≃r ;
                              l≃l = trans≃ l≃r r≃l ;
                              l'≃l = lemma≈≃ l'≈l l≃l
                         in lemma-⋘-⊥ x≤y₂ b≤x l'⋙dr l⋘r l'≃l _dxlr⋘xlr
  ... | _ | inj₂ dl⋘r | _ | pnd .b≤x .(ll⋘ x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂) l≃r =
                         let r≃l = sym≃ l≃r ;
                              dl⋘l = lemma-⋘-≃ dl⋘r r≃l
                         in lemma-drop-⊥ x≤y₁ l₁⋘r₁ dl⋘l
  lemma-drop-⊥ b≤x (lr⋘ x≤y₁ x≤y₂ l₁⋙r₁ l₂⋘r₂ l₂≃r₂ l₁⋗r₂) dxlr⋘xlr
      with lemma-perfect dxlr⋘xlr
  ... | pnd .b≤x .(lr⋘ x≤y₁ x≤y₂ l₁⋙r₁ l₂⋘r₂ l₂≃r₂ l₁⋗r₂) ()


module NotStrictlyPositiveInMutual where

mutual
  data Cheat : Set where
    cheat : Oops -> Cheat

  data Oops : Set where
    oops : (Cheat -> Cheat) -> Oops


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

open import HoTT
open import cohomology.Theory

open import cw.CW

module cw.cohomology.CohomologyGroupsTooHigh {i} (OT : OrdinaryTheory i)
  m {n} (n<m : n < m) (G : Group i) (⊙skel : ⊙Skeleton {i} n)
  (ac : ⊙has-cells-with-choice 0 ⊙skel i) where

open OrdinaryTheory OT
open import cw.cohomology.Descending OT

open import groups.KernelImage {G = G}
  {H = Lift-group {j = i} Unit-group}
  {K = Lift-group {j = i} Unit-group}
  cst-hom cst-hom
  (snd (Lift-abgroup Unit-abgroup))
open import groups.KernelCstImageCst G
  (Lift-group {j = i} Unit-group)
  (Lift-group {j = i} Unit-group)
  (snd (Lift-abgroup Unit-abgroup))

C-cw-iso-ker/im : C (ℕ-to-ℤ m) ⊙⟦ ⊙skel ⟧ ≃ᴳ Ker/Im
C-cw-iso-ker/im = Ker-cst-quot-Im-cst ⁻¹ᴳ ∘eᴳ lift-iso
  ∘eᴳ trivial-iso-0ᴳ (C-cw-at-higher ⊙skel n<m ac)


open import Data.Bool using ( Bool ; true ; false ; _∧_ )
open import Data.Product using ( _×_ )
open import Relation.Binary.PropositionalEquality using ( _≡_ )
open import Relation.Unary using ( _∈_ )
open import Web.Semantic.DL.Concept using
  ( Concept ; ⟨_⟩ ; ¬⟨_⟩ ; ⊤ ; ⊥ ; _⊓_ ; _⊔_ ; ∀[_]_ ; ∃⟨_⟩_ ; ≤1 ; >1 )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox using
  ( TBox ; ε ; _,_ ;_⊑₁_ ; _⊑₂_ ; Dis ; Ref ; Irr ; Tra )
open import Web.Semantic.Util using ( Subset ; □ ; □-proj₁ ; □-proj₂ )

module Web.Semantic.DL.TBox.Minimizable {Σ : Signature} where

data LHS : Subset (Concept Σ) where
  ⟨_⟩ : ∀ c → ⟨ c ⟩ ∈ LHS
  ⊤ : ⊤ ∈ LHS
  ⊥ : ⊥ ∈ LHS
  _⊓_ : ∀ {C D} → (C ∈ LHS) → (D ∈ LHS) → ((C ⊓ D) ∈ LHS)
  _⊔_ : ∀ {C D} → (C ∈ LHS) → (D ∈ LHS) → ((C ⊔ D) ∈ LHS)
  ∃⟨_⟩_ : ∀ R {C} → (C ∈ LHS) → ((∃⟨ R ⟩ C) ∈ LHS)

data RHS : Subset (Concept Σ) where
  ⟨_⟩ : ∀ c → ⟨ c ⟩ ∈ RHS
  ⊤ : ⊤ ∈ RHS
  _⊓_ : ∀ {C D} → (C ∈ RHS) → (D ∈ RHS) → ((C ⊓ D) ∈ RHS)
  ∀[_]_ : ∀ R {C} → (C ∈ RHS) → ((∀[ R ] C) ∈ RHS)
  ≤1 : ∀ R → ((≤1 R) ∈ RHS)

data μTBox : Subset (TBox Σ) where
  ε : μTBox ε
  _,_ : ∀ {T U} → (T ∈ μTBox) → (U ∈ μTBox) → ((T , U) ∈ μTBox)
  _⊑₁_ : ∀ {C D} → (C ∈ LHS) → (D ∈ RHS) → ((C ⊑₁ D) ∈ μTBox)
  _⊑₂_ : ∀ Q R → ((Q ⊑₂ R) ∈ μTBox)
  Ref : ∀ R → (Ref R ∈ μTBox)
  Tra : ∀ R → (Tra R ∈ μTBox)

lhs? : Concept Σ → Bool
lhs? ⟨ c ⟩      = true
lhs? ¬⟨ c ⟩     = false
lhs? ⊤          = true
lhs? ⊥          = true
lhs? (C ⊓ D)    = lhs? C ∧ lhs? D
lhs? (C ⊔ D)    = lhs? C ∧ lhs? D
lhs? (∀[ R ] C) = false
lhs? (∃⟨ R ⟩ C) = lhs? C
lhs? (≤1 R)     = false
lhs? (>1 R)     = false

lhs : ∀ C {C✓ : □(lhs? C)} → LHS C
lhs ⟨ c ⟩             = ⟨ c ⟩
lhs ⊤                 = ⊤
lhs ⊥                 = ⊥
lhs (C ⊓ D)    {C⊓D✓} = lhs C {□-proj₁ C⊓D✓} ⊓ lhs D {□-proj₂ {lhs? C} C⊓D✓}
lhs (C ⊔ D)    {C⊔D✓} = lhs C {□-proj₁ C⊔D✓} ⊔ lhs D {□-proj₂ {lhs? C} C⊔D✓}
lhs (∃⟨ R ⟩ C) {C✓}   = ∃⟨ R ⟩ (lhs C {C✓})
lhs ¬⟨ c ⟩     {}
lhs (∀[ R ] C) {}
lhs (≤1 R)     {}
lhs (>1 R)     {}

rhs? : Concept Σ → Bool
rhs? ⟨ c ⟩      = true
rhs? ¬⟨ c ⟩     = false
rhs? ⊤          = true
rhs? ⊥          = false
rhs? (C ⊓ D)    = rhs? C ∧ rhs? D
rhs? (C ⊔ D)    = false
rhs? (∀[ R ] C) = rhs? C
rhs? (∃⟨ R ⟩ C) = false
rhs? (≤1 R)     = true
rhs? (>1 R)     = false

rhs : ∀ C {C✓ : □(rhs? C)} → RHS C
rhs ⟨ c ⟩             = ⟨ c ⟩
rhs ⊤                 = ⊤
rhs (C ⊓ D)    {C⊓D✓} = rhs C {□-proj₁ C⊓D✓} ⊓ rhs D {□-proj₂ {rhs? C} C⊓D✓}
rhs (∀[ R ] C) {C✓}   = ∀[ R ] (rhs C {C✓})
rhs (≤1 R)            = ≤1 R
rhs ⊥          {}
rhs ¬⟨ c ⟩     {}
rhs (C ⊔ D)    {}
rhs (∃⟨ R ⟩ C) {}
rhs (>1 R)     {}

μTBox? : TBox Σ → Bool
μTBox? ε         = true
μTBox? (T , U)   = μTBox? T ∧ μTBox? U
μTBox? (C ⊑₁ D)  = lhs? C ∧ rhs? D
μTBox? (Q ⊑₂ R)  = true
μTBox? (Dis Q R) = false
μTBox? (Ref R)   = true
μTBox? (Irr R)   = false
μTBox? (Tra R)   = true

μtBox : ∀ T {T✓ : □(μTBox? T)} → μTBox T
μtBox ε               = ε
μtBox (T , U)  {TU✓}  = (μtBox T {□-proj₁ TU✓} , μtBox U {□-proj₂ {μTBox? T} TU✓})
μtBox (C ⊑₁ D) {C⊑D✓} = lhs C {□-proj₁ C⊑D✓} ⊑₁ rhs D {□-proj₂ {lhs? C} C⊑D✓}
μtBox (Q ⊑₂ R)        = Q ⊑₂ R
μtBox (Ref R)         = Ref R
μtBox (Tra R)         = Tra R
μtBox (Dis Q R) {}
μtBox (Irr R) {}


-- Exponential and compatible strengths
module SOAS.Abstract.ExpStrength {T : Set} where

open import SOAS.Families.Core {T}
open import SOAS.Context
open import SOAS.Variable
open import SOAS.ContextMaps.Combinators
open import SOAS.ContextMaps.CategoryOfRenamings

open import SOAS.Common
open import SOAS.Coalgebraic.Strength
import SOAS.Abstract.Coalgebra as →□
open →□.Sorted
open →□.Unsorted using (⊤ᵇ) renaming (Coalg to UCoalg ; Coalg⇒ to UCoalg⇒ ; □ᵇ to □ᵘᵇ)
import SOAS.Abstract.Box as □ ; open □.Sorted

open import SOAS.Families.BCCC using (⊤ₘ)

private
  variable
    X : Family
    𝒴 𝒵 : Familyₛ
    Γ Δ Θ : Ctx
    α : T

-- Mixed-sorted Cartesian and linear exponentials
_⇨_ : Family → Familyₛ → Familyₛ
(X ⇨ 𝒴) τ Γ =  X Γ → 𝒴 τ Γ

_➡_ : Family → Familyₛ → Familyₛ
X ➡ 𝒴 = □ (X ⇨ 𝒴)

_⊸_ : Family → Familyₛ → Familyₛ
(X ⊸ 𝒴) α Γ = {Δ : Ctx} → X Δ → 𝒴 α (Γ ∔ Δ)

[_⊸_] : Familyₛ → Familyₛ → Family
[ 𝒳 ⊸ 𝒴 ] Γ = {τ : T}{Δ : Ctx} → 𝒳 τ Δ → 𝒴 τ (Δ ∔ Γ)

-- Linear exponential [ 𝒳 ⊸ 𝒴 ] is an unsorted coalgebra if 𝒴 is sorted coalgebra
[_⊸_]ᵇ : (𝒳 {𝒴} : Familyₛ) → Coalg 𝒴 → UCoalg ([ 𝒳 ⊸ 𝒴 ])
[ 𝒳 ⊸ 𝒴ᵇ ]ᵇ = record
  { r = λ l ρ {_}{Δ} x → r (l x) (Δ ∔∣ ρ)
  ; counit = λ{ {Γ = Γ}{t = l} → iext (dext λ {Δ} ρ →  trans (r≈₂ (Concatʳ.identity Γ {Δ})) counit) }
  ; comult = λ{ {Γ = Γ}{Δ}{Θ}{ρ = ρ}{ϱ}{l} → iext (dext λ {Ξ} x → trans (r≈₂ (Functor.homomorphism (Ξ ∔F-))) comult) } }
  where
  open Coalg 𝒴ᵇ

-- Shorthands
⟅_⇨_⟆ : Familyₛ → Familyₛ → Familyₛ
⟅ 𝒳 ⇨ 𝒴 ⟆ = [ 𝒳 ⊸ 𝒴 ] ⇨ 𝒴
⟅_➡_⟆ : Familyₛ → Familyₛ → Familyₛ
⟅ 𝒳 ➡ 𝒴 ⟆ = [ 𝒳 ⊸ 𝒴 ] ➡ 𝒴
⟅_⊸_⟆ : Familyₛ → Familyₛ → Familyₛ
⟅ 𝒳 ⊸ 𝒴 ⟆ = [ 𝒳 ⊸ 𝒴 ] ⊸ 𝒴

-- Exponential strength of an endofunctor
record ExpStrength (Fᶠ : Functor 𝔽amiliesₛ 𝔽amiliesₛ) : Set₁ where
  open Functor Fᶠ

  field
    -- Strength transformation that lifts a 𝒫-substitution over an endofunctor F₀
    estr : {X : Family}(Xᵇ : UCoalg X)(𝒴 : Familyₛ)
         → F₀ (X ⇨ 𝒴) ⇾̣ (X ⇨ F₀ 𝒴)

    -- Naturality conditions for the two components
    estr-nat₁ : {X X′ : Family}{Xᵇ : UCoalg X}{X′ᵇ : UCoalg X′}{𝒴 : Familyₛ}
              → {f : X′ ⇾ X}(fᵇ⇒ : UCoalg⇒ X′ᵇ Xᵇ f)
              → (e : F₀ (X ⇨ 𝒴) α Γ) (x : X′ Γ)
      → estr Xᵇ 𝒴 e (f x)
      ≡ estr X′ᵇ 𝒴 (F₁ (λ e x → e (f x)) e) x

    estr-nat₂ : {X : Family}{Xᵇ : UCoalg X}{𝒴 𝒴′ : Familyₛ}
              → (g : 𝒴 ⇾̣ 𝒴′)(e : F₀ (X ⇨ 𝒴) α Γ)(x : X Γ)
      → estr Xᵇ 𝒴′ (F₁ (λ e x → g (e x)) e) x
      ≡ F₁ g (estr Xᵇ 𝒴 e x)

    estr-unit : {𝒴 : Familyₛ}{e : F₀ (⊤ₘ ⇨ 𝒴) α Γ}
              → estr ⊤ᵇ 𝒴 e tt ≡ F₁ (λ e′ → e′ tt) e

  -- Derived unit law
  estr-unit′ : {X : Family}{Xᵇ : UCoalg X}{𝒴 : Familyₛ}{e : F₀ (X ⇨ 𝒴) α Γ}
               {x : {Γ : Ctx} → X Γ}(fᵇ⇒ : UCoalg⇒ ⊤ᵇ Xᵇ (λ _ → x))
             → estr Xᵇ 𝒴 e x ≡ F₁ (λ e′ → e′ x) e
  estr-unit′ {X = X}{Xᵇ}{𝒴}{e}{x} fᵇ⇒ = begin
        estr Xᵇ 𝒴 e x                                  ≡⟨⟩
        estr Xᵇ 𝒴 e ((λ _ → x) tt)                     ≡⟨ estr-nat₁ fᵇ⇒ e tt ⟩
        estr ⊤ᵇ 𝒴 (F₁ (λ e′ _ → e′ x) e) tt            ≡⟨ estr-unit ⟩
        F₁ (λ e′ → e′ tt) (F₁ (λ e′ _ → e′ x) e)        ≡˘⟨ homomorphism ⟩
        F₁ (λ e′ → e′ x) e
    ∎ where open ≡-Reasoning

  -- Combination of coalgebraic and exponential strength over X ➡ 𝒴 = □ (X ⇨ 𝒴)
  module ➡-Strength (F:Str : Strength Fᶠ) where
    open Strength F:Str
    open ≡-Reasoning
    □estr : (Xᵇ : UCoalg X)(𝒴 : Familyₛ)
          → F₀ (X ➡ 𝒴) ⇾̣ (X ➡ F₀ 𝒴)
    □estr {X} Xᵇ 𝒴 e ρ x = estr Xᵇ 𝒴 (str ℐᴮ (X ⇨ 𝒴) e ρ) x

-- Compatible exponential and coalgebraic strengths
-- (for now no extra condition)
record CompatStrengths (Fᶠ : Functor 𝔽amiliesₛ 𝔽amiliesₛ) : Set₁ where
  open Functor Fᶠ
  field
    CoalgStr : Strength Fᶠ
    ExpStr : ExpStrength Fᶠ

  open Strength CoalgStr public
  open ExpStrength ExpStr public

  open ➡-Strength CoalgStr public


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

module Data.ByteVec where

import Data.ByteString as BS
open import Data.Word8 using (Word8)
open BS using (ByteString; length)
open import Data.Nat using (ℕ; _<_)
open import Data.Product using (Σ; _,_; proj₁; proj₂)

open import Relation.Nullary using (yes; no)
open import Relation.Nullary.Decidable using (True)
open import Relation.Binary using (Decidable)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong)
open import Relation.Binary.PropositionalEquality.TrustMe using (trustMe)

open BS public using (ByteStringKind; Lazy; Strict)

ByteVec : ∀ {k} → ℕ → Set
ByteVec {k} n = Σ (ByteString k) (λ bs → n ≡ length bs)

mkVec′ : ∀ {k} → (bs : ByteString k) → ByteVec {k} (length bs)
mkVec′ {k} bs = bs , refl

mkVec : ∀ {k} (n : ℕ) (bs : ByteString k)
  → (n≡∣bs∣ : n ≡ length bs)
  → ByteVec {k} n
mkVec {k} n = _,_

primMkVec : ∀ {k n} → ByteString k → ByteVec {k} n
primMkVec bs = bs , trustMe

index : ∀ {k n} → ByteVec {k} n → (ix : ℕ) → {ix<n : ix < n} → Word8
index (bs , _) ix {_} = BS.unsafeIndex bs ix

module test where
  open import Data.ByteString.Utf8 using (packStrict)
  -- bv5 : ByteVec {_} 5
  -- bv5 = packStrict "asdef" Σ., {!!}
  bv′ : _
  bv′ = mkVec′ (packStrict "asdef")

infix 4 _≟_

private
  t : ∀ {n k} → {v : ByteString k} → (us vs : n ≡ length v) → us ≡ vs
  t us vs = trustMe -- only one proof: refl

_≟_ : ∀ {k n} → Decidable {A = ByteVec {k} n} _≡_
_≟_ {n = n} (u , us) (v , vs) with u BS.≟ v
_≟_ {n = n} (u , us) (v , vs) | yes p rewrite p | t us vs = yes refl
_≟_ {n = n} (u , us) (v , vs) | no ¬p = no (λ x → ¬p (cong proj₁ x))


module Issue878 where

data _==_ {A : Set} (a : A) : A → Set where
  idp : a == a

data ⊤ : Set where
  tt : ⊤

record args : Set₁ where
  field
    P : ⊤ → Set
    g : (b : ⊤) → P b

module _ (r : args) where
  open args r

  postulate
    ext : ∀ b → P b

module _ {r : args} where
  open args r

  postulate
    β-r : ∀ b → ext r b == g b

a : args
a = record {P = λ x → (⊤ → ⊤); g = λ x → λ c → tt}

err : ext a tt tt == tt
err = β-r tt
-- WAS: __IMPOSSIBLE__ in Conversion.hs


{-# OPTIONS --without-K #-}
module container.m.from-nat.cone where

open import level
open import sum
open import equality
open import function
open import sets.nat.core
open import sets.nat.struct
open import sets.unit
open import container.core
open import container.m.from-nat.core
open import hott.level

module _ {li la lb} (c : Container li la lb) where
  open Container c
  open import container.m.coalgebra c hiding (_≅_; module _≅_)

  -- X and π play the role of the "chain" as in
  -- Definition 8 in Ahrens, Capriotti and Spadotti (arXiv:1504.02949v1 [cs.LO])
  module _ (Xⁱ : ℕ → I → Set (la ⊔ lb))
           (πⁱ : ∀ n → Xⁱ (suc n) →ⁱ Xⁱ n) where

    private
      X : (i : I) → ℕ → Set (la ⊔ lb)
      X i n = Xⁱ n i

      π : (i : I) (n : ℕ) → X i (suc n) → X i n
      π i n = πⁱ n i

    module cones {ℓ} (𝓩 : Coalg ℓ) where
      private
        Z = proj₁ 𝓩; θ = proj₂ 𝓩

      Cone₀ : Set _
      Cone₀ = (n : ℕ) → Z →ⁱ Xⁱ n

      Cone₁ : Cone₀ → Set _
      Cone₁ u = (n : ℕ) → πⁱ n ∘ⁱ u (suc n) ≡ u n

      Cone : Set _
      Cone = Σ Cone₀ Cone₁

      Cone₀-eq-iso : {u₁ u₂ : Cone₀}
                   → ((n : ℕ)(i : I)(z : Z i) → u₁ n i z ≡ u₂ n i z)
                   ≅ (u₁ ≡ u₂)
      Cone₀-eq-iso = Π-ap-iso refl≅ (λ _ → funext-isoⁱ) ·≅ strong-funext-iso

      Cone₁-eq-iso : {u : Cone₀}{q₁ q₂ : Cone₁ u}
                   → ( (n : ℕ)(i : I)(z : Z i)
                     → funext-invⁱ (q₁ n) i z
                     ≡ funext-invⁱ (q₂ n) i z )
                   ≅ (q₁ ≡ q₂)
      Cone₁-eq-iso {u}{q₁}{q₂} = begin
          ( (n : ℕ)(i : I)(z : Z i)
          → funext-invⁱ (q₁ n) i z
          ≡ funext-invⁱ (q₂ n) i z )
        ≅⟨ (Π-ap-iso refl≅ λ n → funext-isoⁱ) ⟩
          ( (n : ℕ) → funext-invⁱ (q₁ n) ≡ funext-invⁱ (q₂ n) )
        ≅⟨ ( Π-ap-iso refl≅ λ n → sym≅ (iso≡ (sym≅ funext-isoⁱ)) ) ⟩
          ( (n : ℕ) → q₁ n ≡ q₂ n )
        ≅⟨ strong-funext-iso ⟩
          (q₁ ≡ q₂)
        ∎
        where
          open ≅-Reasoning

      Cone-eq : {c₁ c₂ : Cone}
              → (p : (n : ℕ)(i : I)(z : Z i)
                   → proj₁ c₁ n i z ≡ proj₁ c₂ n i z)
              → ( (n : ℕ)(i : I)(z : Z i)
                → funext-invⁱ (proj₂ c₁ n) i z
                ≡ ap (π i n) (p (suc n) i z)
                · funext-invⁱ (proj₂ c₂ n) i z
                · sym (p n i z) )
              → c₁ ≡ c₂
      Cone-eq {c₁}{c₂} p α = unapΣ' (p' , α')
        where
          subst-lem : {u₁ u₂ : Cone₀}(p : u₁ ≡ u₂)(q : Cone₁ u₂)
                    → (n : ℕ)(i : I)(z : Z i)
                    → funext-invⁱ (subst Cone₁ (sym p) q n) i z
                    ≡ ap (π i n) (funext-invⁱ (funext-inv p (suc n)) i z)
                    · funext-invⁱ (q n) i z
                    · sym (funext-invⁱ (funext-inv p n) i z)
          subst-lem refl q n i z = sym (left-unit _)

          subst-lem' : {u₁ u₂ : Cone₀}(p : (n : ℕ)(i : I)(z : Z i) → u₁ n i z ≡ u₂ n i z)
                     → (q : Cone₁ u₂)(n : ℕ)(i : I)(z : Z i)
                     → funext-invⁱ (subst Cone₁ (sym (apply Cone₀-eq-iso p)) q n) i z
                     ≡ ap (π i n) (p (suc n) i z)
                     · funext-invⁱ (q n) i z
                     · sym (p n i z)
          subst-lem' {u₁}{u₂} p q n i z = subst ( λ p₁
            → funext-invⁱ (subst Cone₁ (sym (apply Cone₀-eq-iso p)) q n) i z
            ≡ ap (π i n) (p₁ (suc n) i z) · funext-invⁱ (q n) i z · sym (p₁ n i z) )
              (_≅_.iso₁ Cone₀-eq-iso p) (subst-lem (apply Cone₀-eq-iso p) q n i z)

          p' : proj₁ c₁ ≡ proj₁ c₂
          p' = apply Cone₀-eq-iso p

          α' : proj₂ c₁ ≡ subst Cone₁ (sym p') (proj₂ c₂)
          α' = apply Cone₁-eq-iso λ n i z
             → α n i z
             · sym (subst-lem' p (proj₂ c₂) n i z)

          unapΣ' : ∀ {i j}{A : Set i}{B : A → Set j}
                 → {a a' : A}{b : B a}{b' : B a'}
                 → (Σ (a ≡ a') λ q → b ≡ subst B (sym q) b')
                 → (a , b) ≡ (a' , b')
          unapΣ' (refl , refl) = refl

      private
        module limit where
          module _ (i : I) where
            open Limit (X i) (π i) public

          isom : Cone ≅ (Z →ⁱ L)
          isom = Limit-univⁱ.univ-iso I Xⁱ πⁱ

      open limit public using (isom)


-- Term matching.
module Tactic.Reflection.Match where

open import Prelude
open import Builtin.Reflection
open import Tactic.Reflection.Equality

open import Control.Monad.Zero
open import Control.Monad.State
open import Container.Traversable

private
  M : Nat → Set → Set
  M n = StateT (Vec (Maybe Term) n) Maybe

  fN : ∀ {n} (i : Nat) → IsTrue (lessNat i n) → Fin n
  fN i lt = fromNat i {{lt}}

  patVar : ∀ {n} → Nat → Nat → Maybe (Fin n)
  patVar {n} zero i with lessNat i n | fN {n} i
  ... | true  | toFin = just (toFin true)
  ... | false | _     = nothing
  patVar (suc k) zero    = nothing
  patVar (suc k) (suc i) = patVar k i

  upd : ∀ {a} {A : Set a} {n} → Fin n → A → Vec A n → Vec A n
  upd  zero   x (_ ∷ xs) = x ∷ xs
  upd (suc i) x (y ∷ xs) = y ∷ upd i x xs

  matchVar : ∀ {n} → Fin n → Term → M n ⊤
  matchVar i v =
    caseM flip indexVec i <$> get of λ
    { (just u) → guard (u == v) (pure _)
    ; nothing  → _ <$ modify (upd i (just v)) }

  MatchFun : Set → Set
  MatchFun A = ∀ {n} → Nat → A → A → M n ⊤

  matchTerm matchTerm′ : MatchFun Term
  matchArgs : MatchFun (List (Arg Term))
  matchArg : MatchFun (Arg Term)
  matchAbs : MatchFun (Abs Term)

  matchTerm k (var i []) v with patVar k i
  ... | just x  = matchVar x v
  ... | nothing = matchTerm′ k (var i []) v
  matchTerm k p v = matchTerm′ k p v

  matchTerm′ {n} k (var i args) (var j args₁) =
    guard! (j <? k && isYes (i == j) || j ≥? k && isYes (j + n == i))
           (matchArgs k args args₁)
  matchTerm′ k (con c args) (con c₁ args₁) = guard (c == c₁) (matchArgs k args args₁)
  matchTerm′ k (def f args) (def g args₁) = guard (f == g) (matchArgs k args args₁)
  matchTerm′ k (lam h p) (lam h₁ v) = guard (h == h₁) (matchAbs k p v)
  matchTerm′ k (pat-lam cs args) v = empty -- todo
  matchTerm′ k (pi a b) (pi a₁ b₁) = matchArg k a a₁ >> matchAbs k b b₁
  matchTerm′ k (lit l) (lit l₁) = guard (l == l₁) (pure _)
  matchTerm′ k (agda-sort _) _ = pure _ -- ignore sorts
  matchTerm′ k (meta _ _) _ = pure _
  matchTerm′ k unknown _ = pure _
  matchTerm′ k p v = empty

  matchArgs k (x ∷ xs) (y ∷ ys) = matchArg k x y >> matchArgs k xs ys
  matchArgs k [] [] = pure _
  matchArgs k _ _   = empty

  matchAbs k (abs _ x) (abs _ y) = matchTerm (suc k) x y
  matchArg k (arg i x) (arg j y) = guard (i == j) (matchTerm k x y)

-- match |Δ| p v = just σ
--  where Γ, Δ ⊢ p
--        Γ    ⊢ v
--        Γ    ⊢ σ : Δ
--        p σ ≡ v
match : (n : Nat) → Term → Term → Maybe (Vec Term n)
match n pat v = do
  env ← snd <$> runStateT (matchTerm 0 pat v) (pure nothing ofType Vec (Maybe Term) n)
  traverse id env


module STLC.Kovacs.NormalForm where

open import STLC.Kovacs.Embedding public
open import Category

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

mutual
  -- (Nfₑ)
  renⁿᶠ : ∀ {Γ Γ′ A} → Γ′ ⊇ Γ → Γ ⊢ⁿᶠ A → Γ′ ⊢ⁿᶠ A
  renⁿᶠ η (ƛ M)  = ƛ (renⁿᶠ (liftₑ η) M)
  renⁿᶠ η (ne M) = ne (renⁿᵉ η M)

  -- (Neₑ)
  renⁿᵉ : ∀ {Γ Γ′ A} → Γ′ ⊇ Γ → Γ ⊢ⁿᵉ A → Γ′ ⊢ⁿᵉ A
  renⁿᵉ η (𝓋 i)   = 𝓋 (getₑ η i)
  renⁿᵉ η (M ∙ N) = renⁿᵉ η M ∙ renⁿᶠ η N

mutual
  -- (Nf-idₑ)
  idrenⁿᶠ : ∀ {Γ A} → (M : Γ ⊢ⁿᶠ A)
                    → renⁿᶠ idₑ M ≡ M
  idrenⁿᶠ (ƛ M)  = ƛ & idrenⁿᶠ M
  idrenⁿᶠ (ne M) = ne & idrenⁿᵉ M

  -- (Ne-idₑ)
  idrenⁿᵉ : ∀ {Γ A} → (M : Γ ⊢ⁿᵉ A)
                    → renⁿᵉ idₑ M ≡ M
  idrenⁿᵉ (𝓋 i)   = 𝓋 & idgetₑ i
  idrenⁿᵉ (M ∙ N) = _∙_ & idrenⁿᵉ M
                        ⊗ idrenⁿᶠ N

mutual
  -- (Nf-∘ₑ)
  renⁿᶠ○ : ∀ {Γ Γ′ Γ″ A} → (η₁ : Γ″ ⊇ Γ′) (η₂ : Γ′ ⊇ Γ) (M : Γ ⊢ⁿᶠ A)
                         → renⁿᶠ (η₂ ○ η₁) M ≡ (renⁿᶠ η₁ ∘ renⁿᶠ η₂) M
  renⁿᶠ○ η₁ η₂ (ƛ M)  = ƛ & renⁿᶠ○ (liftₑ η₁) (liftₑ η₂) M
  renⁿᶠ○ η₁ η₂ (ne M) = ne & renⁿᵉ○ η₁ η₂ M

  -- (Ne-∘ₑ)
  renⁿᵉ○ : ∀ {Γ Γ′ Γ″ A} → (η₁ : Γ″ ⊇ Γ′) (η₂ : Γ′ ⊇ Γ) (M : Γ ⊢ⁿᵉ A)
                         → renⁿᵉ (η₂ ○ η₁) M ≡ (renⁿᵉ η₁ ∘ renⁿᵉ η₂) M
  renⁿᵉ○ η₁ η₂ (𝓋 i)   = 𝓋 & get○ η₁ η₂ i
  renⁿᵉ○ η₁ η₂ (M ∙ N) = _∙_ & renⁿᵉ○ η₁ η₂ M
                             ⊗ renⁿᶠ○ η₁ η₂ N

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

mutual
  -- (⌜_⌝Nf)
  embⁿᶠ : ∀ {Γ A} → Γ ⊢ⁿᶠ A → Γ ⊢ A
  embⁿᶠ (ƛ M)  = ƛ (embⁿᶠ M)
  embⁿᶠ (ne M) = embⁿᵉ M

  -- (⌜_⌝Ne)
  embⁿᵉ : ∀ {Γ A} → Γ ⊢ⁿᵉ A → Γ ⊢ A
  embⁿᵉ (𝓋 i)   = 𝓋 i
  embⁿᵉ (M ∙ N) = embⁿᵉ M ∙ embⁿᶠ N

mutual
  -- (⌜⌝Nf-nat)
  natembⁿᶠ : ∀ {A Γ Γ′} → (η : Γ′ ⊇ Γ) (M : Γ ⊢ⁿᶠ A)
                        → (embⁿᶠ ∘ renⁿᶠ η) M ≡ (ren η ∘ embⁿᶠ) M
  natembⁿᶠ η (ƛ M)  = ƛ & natembⁿᶠ (liftₑ η) M
  natembⁿᶠ η (ne M) = natembⁿᵉ η M

  -- (⌜⌝Ne-nat)
  natembⁿᵉ : ∀ {A Γ Γ′} → (η : Γ′ ⊇ Γ) (M : Γ ⊢ⁿᵉ A)
                        → (embⁿᵉ ∘ renⁿᵉ η) M ≡ (ren η ∘ embⁿᵉ) M
  natembⁿᵉ η (𝓋 i)   = refl
  natembⁿᵉ η (M ∙ N) = _∙_ & natembⁿᵉ η M
                           ⊗ natembⁿᶠ η N

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

renⁿᶠPsh : 𝒯 → Presheaf₀ 𝗢𝗣𝗘
renⁿᶠPsh A =
  record
    { Fₓ  = _⊢ⁿᶠ A
    ; F   = renⁿᶠ
    ; idF = fext! idrenⁿᶠ
    ; F⋄  = λ η₁ η₂ → fext! (renⁿᶠ○ η₂ η₁)
    }

renⁿᵉPsh : 𝒯 → Presheaf₀ 𝗢𝗣𝗘
renⁿᵉPsh A =
  record
    { Fₓ  = _⊢ⁿᵉ A
    ; F   = renⁿᵉ
    ; idF = fext! idrenⁿᵉ
    ; F⋄  = λ η₁ η₂ → fext! (renⁿᵉ○ η₂ η₁)
    }

embⁿᶠNT : ∀ {A} → NaturalTransformation (renⁿᶠPsh A) (renPsh A)
embⁿᶠNT =
  record
    { N    = embⁿᶠ
    ; natN = λ η → fext! (λ M → natembⁿᶠ η M)
    }

embⁿᵉNT : ∀ {A} → NaturalTransformation (renⁿᵉPsh A) (renPsh A)
embⁿᵉNT =
  record
    { N    = embⁿᵉ
    ; natN = λ η → fext! (λ M → natembⁿᵉ η M)
    }

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


module examplesPaperJFP.Equality where

infix 4 _≡_

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

-- obsolete, now in Agda.Builtin.Equality: {-# BUILTIN EQUALITY _≡_ #-}
--  No longer exists in Agda: {-# BUILTIN REFL refl #-}


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

{- Here, we derive our main theorem: there is a type in the n-th universe
   that is not an n-type, implying the n-th universe is not n-truncated.
   The n-th universe restricted to n-types is hence a 'strict' n-type.
   For this, we first derive local-global looping in a modular way.

   A technical point worth noting is that Agda does not implement
   cumulative universes. Since that means the crucial steps in our
   transformations (where we pass between universes uning univalence)
   can not be expressed using equality without resorting to explicit lifting,
   we decide to explicitely uses equivalences (and pointed equivalences,
   respectively) instead where possible.
   As a drawback, we have to use lemmata showing preservation of
   (pointed) equivalences of various (pointed) type constructions,
   a parametricity property derived for free
   from univalence-induced equalities. -}
module HHHUU-ComplicatedTypes where

open import lib.Basics hiding (_⊔_)
open import lib.Equivalences2
open import lib.NType2
open import lib.types.Bool
open import lib.types.Nat hiding (_+_)
open import lib.types.Paths
open import lib.types.Sigma
open import lib.types.Pi
open import lib.types.TLevel

open import Preliminaries
open import Pointed
open import UniverseOfNTypes

-- The argument that (Type lzero) is not a set is standard.
-- We omit it and the argument that (Type (S lzero)) is not a 1-Type:
-- they are both special cases of the general theorem we prove.
-- The general theorem is formalised in this file.

--Definition 7.3.1
-- We have fibered notions of the loop space contruction and n-truncatedness.
module _ {i} {X : Type• i} {j} where
  {- Note that the definition of the family of path types differs slightly from
     that in the thesis, which would correspond to transport P p x == x.
     We use dependent paths since this follows the design of the HoTT
     community's Agda library. There is no actual difference;
     both types are equivalent. -}
  Ω̃ : Fam• X j → Fam• (Ω X) j
  Ω̃ (P , x) = ((λ p → x == x [ P ↓ p ]) , idp)

  fam-has-level : ℕ₋₂ → Fam• X j → Type (i ⊔ j)
  fam-has-level n Q = (a : base X) → has-level n (fst Q a)

{- == Pointed dependent sums ==
   Pointed families as defined above enable us to introduce a Σ-connective
   for pointed types. Because of the abstract nature of some of our lemmata, we
   give Σ• in its uncurried form and first define the type of its parameter. -}
Σ•-param : ∀ i j → Type (lsucc (i ⊔ j))
Σ•-param i j = Σ (Type• i) (λ X → Fam• X j)

module _ {i j} where
  Ω-Σ•-param : Σ•-param i j → Σ•-param i j
  Ω-Σ•-param (X , W) = (Ω X , Ω̃ W)

  -- Definition 7.3.2
  Σ• : Σ•-param i j → Type• (i ⊔ j)
  Σ• (X , Q) = (Σ (base X) (fst Q) , (pt X , snd Q))

  -- Lemma 7.3.3
  {- Commutativity of pointed dependent sums and the loop space construction
     will become an important technical tool, enabling us to work at a more
     abstract level later on. -}
  Ω-Σ•-comm : (R : Σ•-param i j) → Ω (Σ• R) ≃• Σ• (Ω-Σ•-param R)
  Ω-Σ•-comm _ = (=Σ-eqv _ _ , idp) ⁻¹•

{- Pointed dependent products.
   This is not quite the equivalent of Π for pointed types: the domain parameter
   is just an ordinary non-pointed type. However, to enable our goal of
   abstractly working with pointed types, defining this notion is useful. -}
Π•-param : ∀ i j → Type (lsucc (i ⊔ j))
Π•-param i j = Σ (Type i) (λ A → A → Type• j)

module _ {i j} where
  Ω-Π•-param : Π•-param i j → Π•-param i j
  Ω-Π•-param (A , F) = (A , Ω ∘ F)

  -- Definition 7.3.4
  Π• : Π•-param i j → Type• (i ⊔ j)
  Π• (A , Y) = (Π A (base ∘ Y) , pt ∘ Y)

  -- Lemma 7.3.5
  {- Pointed dependent products and loop space construction on
     its codomain parameter commute as well. -}
  Ω-Π•-comm : (R : Π•-param i j) → Ω (Π• R) ≃• Π• (Ω-Π•-param R)
  Ω-Π•-comm _ = (app=-equiv , idp)

  Ω^-Π•-comm : (C : Type i) (F : C → Type• j) (n : ℕ)
             → (Ω ^ n) (Π• (C , F)) ≃• Π• (C , ((Ω ^ n) ∘ F))
  Ω^-Π•-comm C F 0     = ide• _
  Ω^-Π•-comm C F (S n) = Ω^-Π•-comm C _ n ∘e• equiv-Ω^ n (Ω-Π•-comm _)

equiv-Π• : ∀ {i₀ i₁ j₀ j₁} {R₀ : Π•-param i₀ j₀} {R₁ : Π•-param i₁ j₁}
           → Σ (fst R₀ ≃ fst R₁) (λ u → ∀ a → snd R₀ (<– u a) ≃• snd R₁ a)
           → Π• R₀ ≃• Π• R₁
equiv-Π• (u , v) = (equiv-Π u (fst ∘ v) , λ= (snd ∘ v))

-- Lemma 7.4.1
-- In an n-th loop space, we can forget components of truncation level n.
forget-Ω^-Σ•₂ : ∀ {i j} {X : Type• i} (Q : Fam• X j) (n : ℕ)
                → fam-has-level (n -2) Q → (Ω ^ n) (Σ• (X , Q)) ≃• (Ω ^ n) X
forget-Ω^-Σ•₂     {X = X} Q    O  h = (Σ₂-contr h , idp)
forget-Ω^-Σ•₂ {i} {X = X} Q (S n) h =
  (Ω ^ (S n)) (Σ• (X , Q))  ≃•⟨ equiv-Ω^ n (Ω-Σ•-comm _) ⟩
  (Ω ^ n) (Σ• (Ω X , Ω̃ Q))  ≃•⟨ forget-Ω^-Σ•₂ {i} _ n (λ _ → ↓-level h) ⟩
  (Ω ^ (S n)) X             ≃•∎

-- Lemma 7.4.2
{- Our Local-global looping principle.
   We would like to state this principle in the form of
     Ωⁿ⁺¹ (Type i , A) == ∀• a → Ωⁿ (A , a)
   for n ≥ 1. Unfortunately, the two sides have different universe
   levels since (Type i , A) lives in Type• (suc i) instead of Type• i.
   Morally, this is outbalanced by the extra Ω on the left-hand side,
   which might help explain on an intuitive level why
   the n-th universe ends up being not an n-type.

   The reason why the univalence principle (A ≡ B) ≃ (A ≃ B)
   cannot be written as (A ≡ B) ≡ (A ≃ B) is precisely the same. -}
module _ {i} {A : Type i} where
  -- The degenerate pre-base case carries around a propositional component.
  Ω-Type : Ω (Type i , A) ≃• Σ• (Π• (A , λ a → (A , a))
                               , (is-equiv , idf-is-equiv _))
  Ω-Type =
      Ω (Type i , A)
    ≃•⟨ ide• _ ⟩
      ((A == A) , idp)
    ≃•⟨ ua-equiv• ⁻¹• ⟩
      ((A ≃ A) , ide _)
    ≃•⟨ ide• _ ⟩
      ((Σ (A → A) is-equiv) , (idf _ , idf-is-equiv _))
    ≃•⟨ ide• _ ⟩
      Σ• (Π• (A , λ a → (A , a)) , (is-equiv , idf-is-equiv _))
    ≃•∎

  -- The base case.
  Ω²-Type : (Ω ^ 2) (Type i , A) ≃• Π• (A , λ a → Ω (A , a))
  Ω²-Type =
      (Ω ^ 2) (Type i , A)
    ≃•⟨ equiv-Ω Ω-Type ⟩
      Ω (Σ• (Π• (A , λ a → (A , a)) , (is-equiv , idf-is-equiv _)))
    ≃•⟨ forget-Ω^-Σ•₂ {i} _ 1 (is-equiv-is-prop ∘ _) ⟩
      Ω (Π• (A , λ a → (A , a)))
    ≃•⟨ Ω-Π•-comm _ ⟩
      Π• (A , λ a → Ω (A , a))
    ≃•∎

  -- The general case follows by permuting Ω and Π• repeatedly.
  Ω^-Type : (n : ℕ) → (Ω ^ (n + 2)) (Type i , A)
                   ≃• Π• (A , λ a → (Ω ^ (n + 1)) (A , a))
  Ω^-Type n = Ω^-Π•-comm _ _ n ∘e• equiv-Ω^ n Ω²-Type

-- Lemma 7.4.3 is taken from the library
-- lib.NType2._-Type-level_

{- The pointed family P (see thesis).
   It takes an n-type A and returns the space of (n+1)-loops
   with basepoint A in U_n^n (the n-th universe restricted to n-types).
   This crucial restriction to n-types implies it is just a set. -}
module _ (n : ℕ) (A : ⟨ n ⟩ -Type ｢ n ｣) where

  -- Definition of P and
  -- Corollary 7.4.4
  P : ⟨0⟩ -Type• ｢ n + 1 ｣
  P = Ω^-≤' (n + 1) q where
    q : ⟨ n + 1 ⟩ -Type• ｢ n + 1 ｣
    q = –> Σ-comm-snd (((⟨ n ⟩ -Type-≤ ｢ n ｣) , A))

  -- Forgetting about the truncation level, we may present P as follows:
  Q : Type• ｢ n + 1 ｣
  Q = (Ω ^ (n + 1)) (Type ｢ n ｣ , fst A)

  P-is-Q : fst P ≃• Q
  P-is-Q = equiv-Ω^ n (forget-Ω^-Σ•₂ _ 1 (λ _ → has-level-is-prop))

-- Definition of the type 'Loop' and
-- Lemma 7.4.5
{- The type 'Loop' of (images of) n-loops in U_(n-1)^(n-1) is
   just the dependent sum over P except for the special case n ≡ 0,
   where we take U_(-1)^(-1) (and hence Loop) to be the booleans.

   The boilerplate with raise-≤T is just to verify that Loop n is
   n-truncated.
   The bulk of the rest of this module consists of showing
   the n-th universe is not n-truncated at basepoint Loop n,
   i.e. that Q n (Loop n) is not contractible.

   Warning: The indexing of Loop starts at -1 in the thesis,
            but we use natural numbers here (starting at 0),
            thus everything is shifted by one. -}
Loop : (n : ℕ) → ⟨ n ⟩ -Type ｢ n ｣
Loop 0     = (Bool , Bool-is-set)
Loop (S n) = Σ-≤ (⟨ n ⟩ -Type-≤ ｢ n ｣) (λ A →
               raise-≤T {n = ⟨ n + 1 ⟩} (≤T-+2+-l ⟨0⟩ (-2≤T _))
                                        (fst (<– Σ-comm-snd (P n A))))

-- Lemma 7.4.6, preparations
-- The base case is given in Section 7.2 or the thesis.
-- It is done as usual (there is a non-trivial automorphism on booleans).

-- Let us go slowly.
module negation where

  -- Negation.
  ~ : Bool → Bool
  ~ = λ {true → false; false → true}

  -- Negation is an equivalence.
  e : Bool ≃ Bool
  e = equiv ~ ~ inv inv where
    inv = λ {true → idp; false → idp}

  base-case : ¬ (is-contr• (Q 0 (Loop 0)))
  base-case c = Bool-false≠true false-is-true where
    -- Negation being equal to the identity yields a contradiction.
    false-is-true =
      false             =⟨ ! (coe-β e true) ⟩
      coe (ua e) true   =⟨ ap (λ p → coe p true) (! (c (ua e))) ⟩
      coe idp true      =⟨ idp ⟩
      true              ∎

-- Let us now turn towards the successor case.
module _ (m : ℕ) where

  -- We expand the type we are later going to assume contractible.
  Q-L-is-… =
      Q (m + 1) (Loop (m + 1))
    ≃•⟨ ide• _ ⟩
      (Ω ^ (m + 2)) (_ , ⟦ Loop (m + 1) ⟧)
    ≃•⟨ (Ω^-Type m) ⟩
      Π• (_ , λ {(A , q) → Ω ^ (m + 1) $ (⟦ Loop (m + 1) ⟧ , (A , q))})
    ≃•⟨ ide• _ ⟩
      Π• (_ , λ {(A , q) → Ω ^ (m + 1) $ Σ• ((_ , A) , (base ∘ fst ∘ P m , q))})
    ≃•∎

  -- What we really want is to arrive at contractibility of E (m ≥ 1)...
  E = Π• (⟦ Loop (m + 1) ⟧ , λ {(A , q) → Ω ^ (m + 1) $ ((⟨ m ⟩ -Type ｢ m ｣) , A)})

  -- ...or at least show that the following element f of E is trivial (m ≡ 0).
  f : base E
  f (_ , q) = q

-- We want to use our assumption of contractibility of Q (n + 1) (Loop (n + 1))
-- to show that f is trivial, i.e. constant with value the basepoint.
f-is-trivial : (m : ℕ) → is-contr• (Q (m + 1) (Loop (m + 1))) → f m == pt (E m)

-- m ≡ 0
f-is-trivial 0 c = ap (λ f' → fst ∘ f')
                      (! (–> (equiv-is-contr• …-is-E') c f')) where
  -- This is almost E, except for the additional component
  -- specifying that the first component p should commute with q.
  E' = Π• (_ , λ {(A , q) → (Σ (A == A) (λ p → q == q [ (λ x → x == x) ↓ p ])
                                       , (idp , idp))})

  -- This "almost" E comes from Q 1 (Loop 1), hence can be shown contractible.
  …-is-E' : Q 1 (Loop 1) ≃• E'
  …-is-E' = equiv-Π• (ide _ , Ω-Σ•-comm ∘ _) ∘e• Q-L-is-… 0

  -- Fortunately, f can be 'extended' to an element f' of E',
  -- and triviality of f' implies triviality of f.
  f' = λ {(_ , q) → (q , ↓-idf=idf-in (∙=∙' q q))}

-- m ≥ 1: We can show Q (k + 2) (Loop (k + 2)) ≃ E (k + 1),
--        thus E is contractible, hence f trivial.
f-is-trivial (S k) c = ! (–> (equiv-is-contr• (…-is-E ∘e• Q-L-is-… (k + 1)))
                             c
                             (f (k + 1))) where
  …-is-E : _ ≃• E (k + 1)
  …-is-E = equiv-Π• (ide _ , equiv-Ω^ k ∘ (λ {(A , q) → forget-Ω^-Σ•₂
             {｢ k + 2 ｣} (base ∘ fst ∘ P (k + 1) , q) 2
             (snd ∘ P (k + 1))}))

-- Lemma 7.4.6, part 1
-- Our main lemma: like in the thesis, but in negative form.
-- This is sufficient to prove our results, and easier to formalise.
main : (n : ℕ) → ¬ (is-contr• (Q n (Loop n)))
main 0       = negation.base-case
main (S m) c = main m step where
  {- We know Q (m + 1) (Loop (m + 1)) is contractible,
     use that to show that the above f is trivial,
     deduce f (Loop m , p) ≡ p is trivial for all p in P m (Loop m),
     which implies P m (Loop m) is contractible.
     But this is just another form of Q m (Loop m),
     so the conclusion follows by induction hypothesis. -}
  step : is-contr• (Q m (Loop m))
  step = –> (equiv-is-contr• (P-is-Q m (Loop m)))
            (λ q → app= (! (f-is-trivial m c)) (Loop m , q))

-- Lemma 7.4.6, part 2
-- Alternate form of the main lemma
main' : (n : ℕ) → ¬ (is-contr• ((Ω ^ (n + 1)) ((⟨ n ⟩ -Type ｢ n ｣) , Loop n )))
main' n = main n ∘ –> (equiv-is-contr• (P-is-Q n (Loop n)))

-- Small helper thingy
helpy : ∀ {i} {n : ℕ} {X : Type• i}
        → has-level• (n -1) X → is-contr• ((Ω ^ n) X)
helpy {n = n} {X} = <– contr•-equiv-prop
                  ∘ trunc-many n
                  ∘ transport (λ k → has-level• (k -2) X)
                              (+-comm 1 n)

-- Main theorems now fall out as corollaries.
module _ (n : ℕ) where
  {- Recall that L n is n-truncated.
     We also know it is not (n-1)-truncated, it is thus a 'strict' n-type. -}
  Loop-is-not-trunc : ¬ (has-level (n -1) ⟦ Loop n ⟧)
  Loop-is-not-trunc = main n ∘ helpy ∘ (λ t → universe-=-level t t)

  -- Theorem 7.4.7
  -- The n-th universe is not n-truncated.
  Type-is-not-trunc : ¬ (has-level ⟨ n ⟩ (Type ｢ n ｣))
  Type-is-not-trunc = main n ∘ helpy

  -- Theorem 7.4.8
  -- MAIN RESULT:
  --  The n-th universe restricted to n-types is a 'strict' (n+1)-type.
  --  We do not repeat that it is (n+1)-truncated; this is formalised above
  --  (7.4.3). Instead, we only show that it is not an n-type.
  Type-≤-is-not-trunc : ¬ (has-level ⟨ n ⟩ (⟨ n ⟩ -Type ｢ n ｣))
  Type-≤-is-not-trunc = main' n ∘ helpy


module Data.List.Primitive where

-- In Agda 2.2.10 and below, there's no FFI binding for the stdlib
-- List type, so we have to roll our own. This will change.

data #List (X : Set) : Set where
  [] : #List X
  _∷_ : X → #List X → #List X
{-# COMPILED_DATA #List [] [] (:) #-}


----------------------------------------------------------------------
-- A monad with partiality and failure
----------------------------------------------------------------------

module PartialityAndFailure where

open import Category.Monad
open import Codata.Musical.Notation
open import Category.Monad.Partiality as Partiality using (_⊥)
open import Data.Maybe as Maybe using (Maybe; just; nothing; maybe)
open import Data.Maybe.Categorical as MaybeC using ()
open import Level using (_⊔_)
open import Function
open import Relation.Binary as B hiding (Rel)
open import Relation.Binary.PropositionalEquality as P using (_≡_)

------------------------------------------------------------------------
-- Danielsson's partiality-and-failure monad.

-- The definitions below are slightly modified versions of those given
-- in the code accompanying Danielsson's ICFP'12 paper "Operational
-- Semantics Using the Partiality Monad".  The original version along
-- with additional explanations can be found at
--
--   http://www.cse.chalmers.se/~nad/publications/danielsson-semantics-partiality-monad.html

_?⊥ : ∀ {a} → Set a → Set a
A ?⊥ = Maybe A ⊥

monad : ∀ {f} → RawMonad {f = f} (_⊥ ∘ Maybe)
monad = MaybeC.monadT Partiality.monad

private module M {f} = RawMonad (monad {f})

-- Re-export constructors and kinds of relations.
open Partiality public
  using (now; later; Kind; OtherKind; geq; weak; strong; other)

-- Failure.
private
  -- This module encapsulates fail so we can define/overload it as a
  -- constructor of _?⊥P and RelP in the Workaround and
  -- AlternativeEquality modules below.  Its definitions will be
  -- re-exported at the global scope later.
  module Failure {a} where

    fail : ∀ {A : Set a} → A ?⊥
    fail = now nothing

    infix 7 _or-fail

    _or-fail : ∀ {A B : Set a} → (A → B ?⊥) → Maybe A → B ?⊥
    f or-fail = maybe f fail

------------------------------------------------------------------------
-- Equality/ordering

-- The default equality for the partiality monad (bisimilarity)
-- specialized to include failure and with the underlying equality
-- fixed to "syntactic" equality (_≡_).

module Equality {a} {A : Set a} where
  open M using (_>>=_)
  private module E = Partiality.Equality (_≡_ {A = Maybe A})
  open E public using (now; later; laterʳ; laterˡ)

  infix 4 _≅_ _≳_ _≲_ _≈_

  -- The three relations specialized to include failure and with the
  -- underlying equality fixed to "syntactic" equality (_≡_).
  Rel : Kind → A ?⊥ → A ?⊥ → Set _
  Rel k x y = E.Rel k x y

  _≅_ = Rel strong
  _≳_ = Rel (other geq)
  _≲_ = flip _≳_
  _≈_ = Rel (other weak)

  fail : ∀ {k} → Rel k (Failure.fail) (Failure.fail)
  fail = now P.refl

------------------------------------------------------------------------
-- The (specialized) relations are equivalences or partial orders
-- for the chosen underlying "syntactic" equality (_≡_)

module Equivalence {a} {A : Set a} where
  open Partiality.Equivalence {A = Maybe A} {_∼_ = _≡_} public

-- Equational reasoning with the underlying equality fixed to
-- "syntactic" equality (_≡_).
module Reasoning {a} {A : Set a} where
  open Partiality.Reasoning (P.isEquivalence {A = Maybe A}) public

------------------------------------------------------------------------
-- Laws related to bind

module _ {a} {A B : Set a} where
  open Failure
  open Equality
  open M using (_>>=_)

  infixl 1 _>>=-cong_

  -- Bind preserves all the relations.
  _>>=-cong_ : ∀ {k} {x₁ x₂} {f₁ f₂ : A → B ?⊥} →
               Rel k x₁ x₂ → (∀ x → Rel k (f₁ x) (f₂ x)) →
               Rel k (x₁ >>= f₁) (x₂ >>= f₂)
  _>>=-cong_ {k} {f₁ = f₁} {f₂} x₁≈x₂ f₁≈f₂ =
    x₁≈x₂ Partiality.>>=-cong helper
    where
      helper : ∀ {x y} → x ≡ y → Rel k ((f₁ or-fail) x) ((f₂ or-fail) y)
      helper {x = nothing} P.refl = now P.refl
      helper {x = just x}  P.refl = f₁≈f₂ x

------------------------------------------------------------------------
-- Productivity checker workaround

-- Just like the partiality monad, the partiality-and-fail monad
-- suffers from the limitations of guarded coinduction.  Luckily there
-- is a (limited) workaround for this problem, namely to extend the
-- datatype _?⊥ with a _>>=_ constructor, yielding an embedded
-- language _?⊥P (of _?⊥ "programs") which internalizes the monadic
-- bind operation.  When writing corecursive functions in _?⊥P, one
-- may use _>>=_ without guarding it with other constructors.  By
-- interpreting the resulting programs in _?⊥, one recovers the
-- desired corecursive function.  For details, see e.g. Danielsson's
-- PAR'10 paper "Beating the Productivity Checker Using Embedded
-- Languages".

module Workaround {a} where
  private module W = Partiality.Workaround {a}

  infixl 1 _>>=_

  -- The language of _?⊥ "programs" internalizing _>>=_.
  data _?⊥P : Set a → Set (Level.suc a) where
    return : ∀ {A}   (x : A)                     → A ?⊥P
    later  : ∀ {A}   (x : ∞ (A ?⊥P))             → A ?⊥P
    fail   : ∀ {A}                               → A ?⊥P
    _>>=_  : ∀ {A B} (x : A ?⊥P) (f : A → B ?⊥P) → B ?⊥P

  private

    mutual

      -- Translation of _?⊥ programs to _⊥ programs.
      ⟦_⟧P′ : ∀ {A} → A ?⊥P → (Maybe A) W.⊥P
      ⟦ return x          ⟧P′ = W.now (just x)
      ⟦ later x           ⟧P′ = W.later (♯ ⟦ (♭ x) ⟧P′)
      ⟦ fail              ⟧P′ = W.now nothing
      ⟦ _>>=_ {A} {B} x f ⟧P′ = ⟦ x ⟧P′ W.>>= ⟦>>=⟧-helper f

      ⟦>>=⟧-helper : ∀ {A B : Set a} → (A → B ?⊥P) → Maybe A → (Maybe B) W.⊥P
      ⟦>>=⟧-helper f (just y) = ⟦ f y ⟧P′
      ⟦>>=⟧-helper _ nothing  = W.now nothing

  -- Interpretation of _?⊥ programs in _?⊥.
  ⟦_⟧P : ∀ {A} → A ?⊥P → A ?⊥
  ⟦_⟧P = W.⟦_⟧P ∘ ⟦_⟧P′

  -- The definitions above make sense. ⟦_⟧P is homomorphic with
  -- respect to now, later, fail and _>>=_.
  module Correct where
    open Equality {a} hiding (fail)
    open Reasoning {a}
    private
      module F      = Failure {a}
      module PM {f} = RawMonad (Partiality.monad {f})

    return-hom : ∀ {A} (x : A) → ⟦ return x ⟧P ≅ M.return x
    return-hom x = M.return x ∎

    later-hom : ∀ {A} (x : ∞ (A ?⊥P)) → ⟦ later x ⟧P ≅ later (♯ ⟦ ♭ x ⟧P)
    later-hom x = later (♯ (⟦ ♭ x ⟧P ∎) )

    fail-hom : ∀ {A} → ⟦ fail {A} ⟧P ≅ F.fail {A}
    fail-hom {A} = F.fail {A} ∎

    >>=-hom : ∀ {A B} (x : A ?⊥P) (f : A → B ?⊥P) →
              ⟦ x >>= f ⟧P ≅ (⟦ x ⟧P M.>>= λ y → ⟦ f y ⟧P)
    >>=-hom {A} {B} x f =
        W.⟦ ⟦ x ⟧P′ W.>>= (⟦>>=⟧-helper f) ⟧P
      ≅⟨ W.Correct.>>=-hom ⟦ x ⟧P′ _ ⟩
        (⟦ x ⟧P PM.>>= λ y → W.⟦ ⟦>>=⟧-helper f y ⟧P)
      ≅⟨ (⟦ x ⟧P ∎) Partiality.≡->>=-cong helper ⟩
        (⟦ x ⟧P PM.>>= maybe (⟦_⟧P ∘ f) F.fail)
      ∎
      where
        helper : ∀ y → W.⟦ ⟦>>=⟧-helper f y ⟧P ≅ maybe (⟦_⟧P ∘ f) F.fail y
        helper (just y) = ⟦ f y ⟧P ∎
        helper nothing  = F.fail ∎

------------------------------------------------------------------------
-- An alternative, but equivalent, formulation of equality/ordering

-- This version of equality works around some limitations of guarded
-- corecursion and is therefore easier to use in corecursive proofs.
-- However, it does not admit unrestricted use of transitivity.  For a
-- discussion of the technique and the related issues, see e.g.
--
--  * "Operational Semantics Using the Partiality Monad", Danielsson,
--    ICFP'12
--
--  * "Beating the Productivity Checker Using Embedded Languages",
--    Danielsson, PAR'10
--
--  * "Subtyping, Declaratively -- An Exercise in Mixed Induction and
--    Coinduction", Danielsson and Altenkirch, MPC'10
--
-- All of the above can be found at
--   http://www.cse.chalmers.se/~nad/publications/

module AlternativeEquality {a} where
  open Equality {a} hiding (fail)
  private
    open module F = Failure {a} hiding (fail)
    module AE = Partiality.AlternativeEquality {a}

  mutual
    -- Proof "programs" with the underlying equality fixed to
    -- "syntactic" equality (_≡_) and extended to include failure.

    infix  4 _≅P_ _≳P_ _≈P_
    infix  3 _∎
    infixr 2 _≡⟨_⟩_ _≅⟨_⟩_ _≳⟨_⟩_ _≳⟨_⟩≅_ _≳⟨_⟩≈_ _≈⟨_⟩≅_ _≈⟨_⟩≲_
    infixl 1 _>>=_

    _≅P_ : ∀ {A} → B.Rel (A ?⊥) _
    _≅P_ = RelP strong

    _≳P_ : ∀ {A} → B.Rel (A ?⊥) _
    _≳P_ = RelP (other geq)

    _≈P_ : ∀ {A} → B.Rel (A ?⊥) _
    _≈P_ = RelP (other weak)

    data RelP {A : Set a} : Kind → B.Rel (A ?⊥) (Level.suc a) where

      -- Congruences.

      return : ∀ {k x y} (x≡y : x ≡ y) →
               RelP k (M.return x) (M.return y)
      later  : ∀ {k x y} (x∼y : ∞ (RelP k (♭ x) (♭ y))) →
               RelP k (later x) (later y)
      fail   : ∀ {k} → RelP k (F.fail) (F.fail)
      _>>=_  : ∀ {B : Set a} {k x₁ x₂} {f₁ f₂ : B → A ?⊥} →
               let open M in
               (x₁≡x₂ : RelP k x₁ x₂)
               (f₁∼f₂ : ∀ x → RelP k (f₁ x) (f₂ x)) →
               RelP k (x₁ >>= f₁) (x₂ >>= f₂)

      -- Ordering/weak equality.

      laterʳ : ∀ {x y} (x≈y : RelP (other weak) x (♭ y)) →
               RelP (other weak) x (later y)
      laterˡ : ∀ {k x y} (x∼y : RelP (other k) (♭ x) y) →
               RelP (other k) (later x) y

      -- Equational reasoning. Note that including full transitivity
      -- for weak equality would make _≈P_ trivial; a similar problem
      -- applies to _≳P_ (never ≳P return x would be
      -- provable). Instead the definition of RelP includes limited
      -- notions of transitivity, similar to weak bisimulation up-to
      -- various things.

      _∎      : ∀ {k} x → RelP k x x
      sym     : ∀ {k x y} {eq : Partiality.Equality k} (x∼y : RelP k x y) →
                RelP k y x
      _≡⟨_⟩_  : ∀ {k} x {y z} (x≡y : x ≡ y)  (y∼z : RelP k y z) → RelP k x z
      _≅⟨_⟩_  : ∀ {k} x {y z} (x≅y : x ≅P y) (y∼z : RelP k y z) → RelP k x z
      _≳⟨_⟩_  : ∀     x {y z} (x≳y : x ≳  y) (y≳z : y ≳P z) → x ≳P z
      _≳⟨_⟩≅_ : ∀     x {y z} (x≳y : x ≳P y) (y≅z : y ≅P z) → x ≳P z
      _≳⟨_⟩≈_ : ∀     x {y z} (x≳y : x ≳P y) (y≈z : y ≈P z) → x ≈P z
      _≈⟨_⟩≅_ : ∀     x {y z} (x≈y : x ≈P y) (y≅z : y ≅P z) → x ≈P z
      _≈⟨_⟩≲_ : ∀     x {y z} (x≈y : x ≈P y) (y≲z : z ≳P y) → x ≈P z

      -- If any of the following transitivity-like rules were added to
      -- RelP, then RelP and Rel would no longer be equivalent:
      --
      --   x ≳P y → y ≳P z → x ≳P z
      --   x ≳P y → y ≳  z → x ≳P z
      --   x ≲P y → y ≈P z → x ≈P z
      --   x ≈P y → y ≳P z → x ≈P z
      --   x ≲  y → y ≈P z → x ≈P z
      --   x ≈P y → y ≳  z → x ≈P z
      --   x ≈P y → y ≈P z → x ≈P z
      --   x ≈P y → y ≈  z → x ≈P z
      --   x ≈  y → y ≈P z → x ≈P z
      --
      -- The reason is that any of these rules would make it possible
      -- to derive that never and now x are related.

  -- RelP is complete with respect to Rel.
  complete : ∀ {A k} {x y : A ?⊥} → Rel k x y → RelP k x y
  complete {x = now (just x)} {now (just .x)} (now P.refl) = return P.refl
  complete {x = now (just x)} {now nothing}   (now ())
  complete {x = now nothing}  {now (just _)}  (now ())
  complete {x = now nothing}  {now nothing}   (now P.refl) = fail
  complete (later  x∼y) = later (♯ complete (♭ x∼y))
  complete (laterʳ x≈y) = laterʳ  (complete    x≈y)
  complete (laterˡ x∼y) = laterˡ  (complete    x∼y)

  private
    AE-RelP : ∀ {A : Set a} → Kind → B.Rel (A ?⊥) _
    AE-RelP {A} = AE.RelP (P.setoid (Maybe A))

    -- RelP is sound with respect to the alternative equality of the
    -- partiality monad.
    sound′ : ∀ {A k} {x y : A ?⊥} → RelP k x y → AE-RelP k x y
    sound′ (return x≡y)      = AE.now (P.cong just x≡y)
    sound′ (later x∼y)       = AE.later (♯ sound′ (♭ x∼y))
    sound′ fail              = AE.now P.refl
    sound′ {A} {k} (_>>=_ {B} {f₁ = f₁} {f₂} x f₁∼f₂) =
      sound′ x AE.>>= helper
      where
        helper : ∀ {x y} → x ≡ y → AE-RelP k ((f₁ or-fail) x) ((f₂ or-fail) y)
        helper {x = nothing} P.refl = AE.now P.refl
        helper {x = just x}  P.refl = sound′ (f₁∼f₂ x)
    sound′ (laterʳ x)        = AE.laterʳ (sound′ x)
    sound′ (laterˡ x)        = AE.laterˡ (sound′ x)
    sound′ (x ∎)             = x AE.∎
    sound′ (sym {eq = eq} x) = AE.sym {eq = eq} (sound′ x)
    sound′ (x ≡⟨ x≡y ⟩ y≡z)  = AE._≡⟨_⟩_  x x≡y          (sound′ y≡z)
    sound′ (x ≅⟨ x≅y ⟩ y≅z)  = AE._≅⟨_⟩_  x (sound′ x≅y) (sound′ y≅z)
    sound′ (x ≳⟨ x≳y ⟩ y≳z)  = AE._≳⟨_⟩_  x x≳y          (sound′ y≳z)
    sound′ (x ≳⟨ x≳y ⟩≅ y≅z) = AE._≳⟨_⟩≅_ x (sound′ x≳y) (sound′ y≅z)
    sound′ (x ≳⟨ x≳y ⟩≈ y≈z) = AE._≳⟨_⟩≈_ x (sound′ x≳y) (sound′ y≈z)
    sound′ (x ≈⟨ x≈y ⟩≅ y≅z) = AE._≈⟨_⟩≅_ x (sound′ x≈y) (sound′ y≅z)
    sound′ (x ≈⟨ x≈y ⟩≲ y≲z) = AE._≈⟨_⟩≲_ x (sound′ x≈y) (sound′ y≲z)

  -- RelP is sound with respect to Rel.
  sound : ∀ {A k} {x y : A ?⊥} → RelP k x y → Rel k x y
  sound = AE.sound ∘ sound′

open Failure public


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

open import Categories.Category

module Categories.Object.Coproducts {o ℓ e} (C : Category o ℓ e) where

open Category C

open import Level

import Categories.Object.Initial as Initial
import Categories.Object.BinaryCoproducts as BinaryCoproducts

open Initial C
open BinaryCoproducts C

-- this should really be 'FiniteCoproducts', no?
record Coproducts : Set (o ⊔ ℓ ⊔ e) where
  field
    initial : Initial
    binary : BinaryCoproducts


-- Possible improvements:
-- * Parts of the code are not reachable from main.
-- * The following primitives are not used at all: primPOr, primComp,
--   primHComp, prim^glueU and prim^unglueU.

{-# OPTIONS --erased-cubical --save-metas #-}

-- The code from Agda.Builtin.Cubical.Glue should not be compiled.

open import Agda.Builtin.Cubical.Glue

open import Agda.Builtin.Cubical.HCompU
open import Agda.Builtin.Cubical.Id
open import Agda.Builtin.Cubical.Path
open import Agda.Builtin.Cubical.Sub
open import Agda.Builtin.IO
open import Agda.Builtin.Nat
open import Agda.Builtin.Sigma
open import Agda.Builtin.String
open import Agda.Builtin.Unit
open import Agda.Primitive.Cubical

open import Erased-cubical-Cubical

postulate
  putStr : String → IO ⊤

{-# FOREIGN GHC import qualified Data.Text.IO #-}
{-# COMPILE GHC putStr = Data.Text.IO.putStr #-}
{-# COMPILE JS putStr =
    function (x) {
      return function(cb) {
        process.stdout.write(x); cb(0); }; } #-}

i₁ : I
i₁ = primIMax (primIMax (primINeg i0) i1) (primIMin i1 i0)

i₁-1 : IsOne i₁
i₁-1 = IsOne1 (primIMax (primINeg i0) i1) (primIMin i1 i0)
         (IsOne2 (primINeg i0) i1 itIsOne)

p₁ : Partial i1 Nat
p₁ = λ _ → 12

p₂ : PartialP i1 (λ _ → Nat)
p₂ = λ _ → 12

p₃ : PartialP i0 (λ _ → Nat)
p₃ = isOneEmpty

p₄ : 12 ≡ 12
p₄ = λ _ → 12

n₁ : Nat
n₁ = p₄ i0

s : Sub Nat i1 (λ _ → 13)
s = inc 13

n₂ : Nat
n₂ = primSubOut s

i₂ : I
i₂ = primFaceForall (λ _ → i1)

i₃ : Id 12 12
i₃ = conid i0 p₄

i₄ : I
i₄ = primDepIMin i1 (λ _ → i0)

i₅ : I
i₅ = primIdFace i₃

p₅ : 12 ≡ 12
p₅ = primIdPath i₃

n₃ : Nat
n₃ = primIdJ (λ _ _ → Nat) 14 i₃

n₄ : Nat
n₄ = primIdElim (λ _ _ → Nat) (λ _ _ _ → 14) i₃

infix 2 _⊎_

data _⊎_ (A B : Set) : Set where
  inj₁ : A → A ⊎ B
  inj₂ : B → A ⊎ B

data ⊥ : Set where

⊥-elim : {A : Set} → ⊥ → A
⊥-elim ()

-- Some "standard" path functions.

refl : {A : Set} (x : A) → x ≡ x
refl x = λ _ → x

sym : {A : Set} {x y : A} → x ≡ y → y ≡ x
sym p i = p (primINeg i)

cong : {A B : Set} {x y : A} (f : A → B) → x ≡ y → f x ≡ f y
cong f p i = f (p i)

J :
  {A : Set} {x y : A}
  (P : (x y : A) → x ≡ y → Set) →
  (∀ x → P x x (refl x)) →
  (x≡y : x ≡ y) → P x y x≡y
J {x = x} P p x≡y =
  primTransp (λ i → P _ _ (λ j → x≡y (primIMin i j))) i0 (p x)

subst :
  {A : Set} {x y : A}
  (P : A → Set) → x ≡ y → P x → P y
subst P eq p = primTransp (λ i → P (eq i)) i0 p

subst-refl :
  {A : Set} {x : A}
  (P : A → Set) {p : P x} →
  subst P (refl x) p ≡ p
subst-refl {x = x} P {p = p} i =
  primTransp (λ _ → P x) i p

-- The following definitions are perhaps less standard when paths are
-- used.

trans : {A : Set} {x y z : A} → x ≡ y → y ≡ z → x ≡ z
trans x≡y y≡z = subst (_ ≡_) y≡z x≡y

trans-refl-refl :
  {A : Set}
  (x : A) → trans (refl x) (refl x) ≡ refl x
trans-refl-refl x = subst-refl (x ≡_)

trans-sym :
  {A : Set} {x y : A} (x≡y : x ≡ y) →
  trans x≡y (sym x≡y) ≡ refl x
trans-sym =
  J (λ x y x≡y → trans x≡y (sym x≡y) ≡ refl x)
    trans-refl-refl

-- Propositions and sets.

Is-proposition : Set → Set
Is-proposition A = (x y : A) → x ≡ y

Is-set : Set → Set
Is-set A = (x y : A) → Is-proposition (x ≡ y)

-- Following Hedberg's "A coherence theorem for Martin-Löf's type
-- theory".

decidable-equality→is-set :
  {A : Set} →
  ((x y : A) → x ≡ y ⊎ (x ≡ y → ⊥)) →
  Is-set A
decidable-equality→is-set dec =
  constant⇒set (λ x y → decidable⇒constant (dec x y))
  where
  Constant : {A B : Set} → (A → B) → Set
  Constant f = ∀ x y → f x ≡ f y

  _Left-inverse-of_ : {A B : Set} → (B → A) → (A → B) → Set
  g Left-inverse-of f = ∀ x → g (f x) ≡ x

  proposition : {A : Set} →
                (f : Σ (A → A) Constant) →
                Σ _ (_Left-inverse-of (fst f)) →
                Is-proposition A
  proposition (f , constant) (g , left-inverse) x y =
    trans (sym (left-inverse x))
      (trans (cong g (constant x y)) (left-inverse y))

  left-inverse :
    {A : Set}
    (f : (x y : A) → x ≡ y → x ≡ y) →
    ∀ {x y} → Σ _ (_Left-inverse-of (f x y))
  left-inverse {A = A} f {x = x} {y = y} =
      (λ x≡y → trans x≡y (sym (f y y (refl y))))
    , J (λ x y x≡y → trans (f x y x≡y) (sym (f y y (refl y))) ≡ x≡y)
        (λ _ → trans-sym _)

  constant⇒set :
    {A : Set} →
    ((x y : A) → Σ (x ≡ y → x ≡ y) Constant) →
    Is-set A
  constant⇒set constant x y =
    proposition (constant x y)
                (left-inverse λ x y → fst (constant x y))

  decidable⇒constant :
    {A : Set} →
    A ⊎ (A → ⊥) →
    Σ (A → A) Constant
  decidable⇒constant (inj₁ x) =
    (λ _ → x) , (λ _ _ → refl x)
  decidable⇒constant (inj₂ ¬A) =
    (λ x → x) , (λ x → ⊥-elim (¬A x))

if_then_else_ : {A : Set₁} → Bool → A → A → A
if true  then x else y = x
if false then x else y = y

Bool-set : Is-set Bool
Bool-set = decidable-equality→is-set λ where
  false false → inj₁ λ _ → false
  true  true  → inj₁ λ _ → true
  false true  → inj₂ λ eq →
                  primTransp (λ i → if eq i then ⊥ else ⊤) i0 _
  true  false → inj₂ λ eq →
                  primTransp (λ i → if eq i then ⊤ else ⊥) i0 _

data ∥_∥ᴱ (A : Set) : Set where
  ∣_∣        : A → ∥ A ∥ᴱ
  @0 trivial : Is-proposition ∥ A ∥ᴱ

recᴱ : {A B : Set} → @0 Is-proposition B → (A → B) → ∥ A ∥ᴱ → B
recᴱ p f ∣ x ∣           = f x
recᴱ p f (trivial x y i) = p (recᴱ p f x) (recᴱ p f y) i

-- Following Vezzosi, Mörtberg and Abel's "Cubical Agda: A Dependently
-- Typed Programming Language with Univalence and Higher Inductive
-- Types".

data _/_ (A : Set) (R : A → A → Set) : Set where
  [_]                  : A → A / R
  []-respects-relation : (x y : A) → R x y → [ x ] ≡ [ y ]
  is-set               : Is-set (A / R)

rec :
  {A B : Set} {R : A → A → Set} →
  Is-set B →
  (f : A → B) →
  ((x y : A) → R x y → f x ≡ f y) →
  A / R → B
rec s f g [ x ]                          = f x
rec s f g ([]-respects-relation x y r i) = g x y r i
rec s f g (is-set x y p q i j)           =
  s (rec s f g x) (rec s f g y)
    (λ k → rec s f g (p k)) (λ k → rec s f g (q k)) i j

const-true : I → Bool
const-true i =
  rec
    {R = _≡_}
    Bool-set
    (λ x → x)
    (λ _ _ x≡y → x≡y)
    (is-set
       _ _
       ([]-respects-relation true true (refl true))
       (refl _)
       i i)

main : IO ⊤
main =
  putStr
    (recᴱ
       easy
       (λ where
          true  → "Success\n"
          false → "Failure\n")
       ∣ const-true i0 ∣)

-- It should be possible to mention things that are not compiled in
-- type signatures.

u₁ : Not-compiled → ⊤
u₁ _ = tt

@0 A : Set₁
A = Set

u₂ : A → ⊤
u₂ _ = tt


{-# OPTIONS --allow-unsolved-metas #-}

open import Oscar.Class
open import Oscar.Class.Hmap
open import Oscar.Class.Leftunit
open import Oscar.Class.Reflexivity
open import Oscar.Class.Smap
open import Oscar.Class.Symmetry
open import Oscar.Class.Transextensionality
open import Oscar.Class.Transitivity
open import Oscar.Class.Transleftidentity
open import Oscar.Data.Substitunction
open import Oscar.Data.Term
open import Oscar.Prelude

module Test.ProblemWithDerivation-4 where

postulate
  A : Set
  B : Set
  _~A~_ : A → A → Set
  _~B~_ : B → B → Set
  s1 : A → B
  f1 : ∀ {x y} → x ~A~ y → s1 x ~B~ s1 y

instance

  𝓢urjectivity1 : Smap.class _~A~_ _~B~_ s1 s1
  𝓢urjectivity1 .⋆ _ _ = f1

-- Oscar.Class.Hmap.Transleftidentity
instance

  -HmapFromTransleftidentitySymmetry : ∀
    {𝔵} {𝔛 : Ø 𝔵}
    {𝔞} {𝔄 : 𝔛 → Ø 𝔞}
    {𝔟} {𝔅 : 𝔛 → Ø 𝔟}
    (let _∼_ = Arrow 𝔄 𝔅)
    {ℓ̇} {_∼̇_ : ∀ {x y} → x ∼ y → x ∼ y → Ø ℓ̇}
    {transitivity : Transitivity.type _∼_}
    {reflexivity : Reflexivity.type _∼_}
    {ℓ}
    ⦃ _ : Transleftidentity.class _∼_ _∼̇_ reflexivity transitivity ⦄
    ⦃ _ : ∀ {x y} → Symmetry.class (_∼̇_ {x} {y}) ⦄
    → ∀ {m n}
    → Hmap.class (λ (f : m ∼ n) (P : LeftExtensionṖroperty ℓ _∼_ _∼̇_ m) → π₀ (π₀ P) f)
                 (λ f P → π₀ (π₀ P) (transitivity f reflexivity))
  -HmapFromTransleftidentitySymmetry .⋆ _ (_ , P₁) = P₁ $ symmetry transleftidentity

test-before : ∀ {x y} → x ~A~ y → s1 x ~B~ s1 y
test-before = smap

postulate
  XX : Set
  BB : XX → Set
  CC : XX → Set
  EQ : ∀ {x y} → Arrow BB BB x y → Arrow BB BB x y → Set

instance
  postulate
    -transleftidentity : Transleftidentity.class (Arrow BB BB) EQ magic magic
    -symmetry : ∀ {x y} → Symmetry.class (EQ {x} {y})

test-after : ∀ {x y} → x ~A~ y → s1 x ~B~ s1 y
test-after = smap -- FIXME this was yellow when we used Symmetry instead of Sym. why?


module FunctionName where

open import OscarPrelude

record FunctionName : Set
 where
  constructor ⟨_⟩
  field
    name : Nat

open FunctionName public

instance EqFunctionName : Eq FunctionName
Eq._==_ EqFunctionName _ = decEq₁ (cong name) ∘ (_≟_ on name $ _)


-- Andreas, 2017-10-11, issue #2796

-- A failed check for projection-likeness
-- made the overloaded projection not resolve.

-- {-# OPTIONS -v tc.proj.like:100 #-}
-- {-# OPTIONS -v tc.proj.amb:100 #-}

postulate
  L     : Set
  lzero : L
  Type  : L → Set
  El    : ∀{l} → Type l → Set

record Pred (A : Set) l : Set where  -- Works without l
  field
    app : A → Type l

record Sub l : Set1 where
  field
    Carrier : Set
    pred    : Pred Carrier l
  open Pred pred public

open Pred   -- Works without this (of course)
open Sub

test : (S T : Sub lzero) → (f : S .Carrier → T .Carrier) → Set
test S T f = (a : S .Carrier) → El (S .app a) → El (T .app (f a))

-- Problem WAS:
-- Cannot resolve overloaded projection app because no matching candidate found
-- when checking that the expression S .app a has type
-- Type (_l_22 S T f a)

-- Should succeed.


------------------------------------------------------------------------
-- Some partiality algebra properties
------------------------------------------------------------------------

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

open import Prelude hiding (T)

open import Partiality-algebra as PA hiding (id; _∘_)

module Partiality-algebra.Properties
  {a p q} {A : Type a} (P : Partiality-algebra p q A) where

open import Equality.Propositional.Cubical

open import Function-universe equality-with-J hiding (id; _∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional equality-with-paths
open import Nat equality-with-J as Nat

open Partiality-algebra P

------------------------------------------------------------------------
-- Some predicates

-- A termination predicate: x ⇓ y means that x terminates with the
-- value y.

infix 4 _⇓_ _⇑

_⇓_ : T → A → Type p
x ⇓ y = x ≡ now y

-- A non-termination predicate.

_⇑ : T → Type p
x ⇑ = x ≡ never

------------------------------------------------------------------------
-- Preorder reasoning combinators

infix  -1 finally-⊑
infix  -1 _■
infixr -2 _⊑⟨_⟩_ _⊑⟨⟩_ _≡⟨_⟩⊑_

_⊑⟨_⟩_ : (x {y z} : T) → x ⊑ y → y ⊑ z → x ⊑ z
_ ⊑⟨ x⊑y ⟩ y⊑z = ⊑-trans x⊑y y⊑z

_⊑⟨⟩_ : (x {y} : T) → x ⊑ y → x ⊑ y
_ ⊑⟨⟩ x⊑y = x⊑y

_≡⟨_⟩⊑_ : (x {y z} : T) → x ≡ y →
          y ⊑ z → x ⊑ z
_ ≡⟨ refl ⟩⊑ y⊑z = y⊑z

_■ : (x : T) → x ⊑ x
x ■ = ⊑-refl x

finally-⊑ : (x y : T) → x ⊑ y → x ⊑ y
finally-⊑ _ _ x⊑y = x⊑y

syntax finally-⊑ x y x⊑y = x ⊑⟨ x⊑y ⟩■ y ■

------------------------------------------------------------------------
-- Some simple lemmas

-- If every element in one increasing sequence is bounded by some
-- element in another, then the least upper bound of the first
-- sequence is bounded by the least upper bound of the second one.

⊑→⨆⊑⨆ : ∀ {s₁ s₂} {f : ℕ → ℕ} →
        (∀ n → s₁ [ n ] ⊑ s₂ [ f n ]) → ⨆ s₁ ⊑ ⨆ s₂
⊑→⨆⊑⨆ {s₁} {s₂} {f} s₁⊑s₂ =
  least-upper-bound _ _ λ n →
    s₁ [ n ]    ⊑⟨ s₁⊑s₂ n ⟩
    s₂ [ f n ]  ⊑⟨ upper-bound _ _ ⟩■
    ⨆ s₂        ■

-- A variant of the previous lemma.

∃⊑→⨆⊑⨆ : ∀ {s₁ s₂} →
         (∀ m → ∃ λ n → s₁ [ m ] ⊑ s₂ [ n ]) → ⨆ s₁ ⊑ ⨆ s₂
∃⊑→⨆⊑⨆ s₁⊑s₂ = ⊑→⨆⊑⨆ (proj₂ ∘ s₁⊑s₂)

-- ⨆ is monotone.

⨆-mono : {s₁ s₂ : Increasing-sequence} →
         (∀ n → s₁ [ n ] ⊑ s₂ [ n ]) → ⨆ s₁ ⊑ ⨆ s₂
⨆-mono = ⊑→⨆⊑⨆

-- Later elements in an increasing sequence are larger.

later-larger : (s : Increasing-sequence) →
               ∀ {m n} → m ≤ n → s [ m ] ⊑ s [ n ]
later-larger s {m} (≤-refl′ refl)           = s [ m ] ■
later-larger s {m} (≤-step′ {k = n} p refl) =
  s [ m ]      ⊑⟨ later-larger s p ⟩
  s [ n ]      ⊑⟨ increasing s n ⟩■
  s [ suc n ]  ■

-- If the final elements of an increasing sequence have an upper
-- bound, then all elements have this upper bound.

upper-bound-≤→upper-bound :
  ∀ (s : Increasing-sequence) {m x} →
  (∀ n → m ≤ n → s [ n ] ⊑ x) →
  ∀ n → s [ n ] ⊑ x
upper-bound-≤→upper-bound s {m} {x} is-ub n with Nat.total m n
... | inj₁ m≤n = is-ub n m≤n
... | inj₂ n≤m =
  s [ n ]  ⊑⟨ later-larger s n≤m ⟩
  s [ m ]  ⊑⟨ is-ub m ≤-refl ⟩■
  x        ■

-- Only never is smaller than or equal to never.

only-never-⊑-never : {x : T} → x ⊑ never → x ≡ never
only-never-⊑-never x⊑never = antisymmetry x⊑never (never⊑ _)

------------------------------------------------------------------------
-- Tails

-- The tail of an increasing sequence.

tailˢ : Increasing-sequence → Increasing-sequence
tailˢ = Σ-map (_∘ suc) (_∘ suc)

-- The tail has the same least upper bound as the full sequence.

⨆tail≡⨆ : ∀ s → ⨆ (tailˢ s) ≡ ⨆ s
⨆tail≡⨆ s = antisymmetry
  (⊑→⨆⊑⨆ λ n → s [ suc n ]  ⊑⟨⟩
               s [ suc n ]  ■)
  (⨆-mono λ n → s [ n ]      ⊑⟨ increasing s n ⟩■
                s [ suc n ]  ■)

------------------------------------------------------------------------
-- Constant sequences

-- One way to form a constant sequence.

constˢ : T → Increasing-sequence
constˢ x = const x , const (⊑-refl x)

-- The least upper bound of a constant sequence is equal to the
-- value in the sequence.

⨆-const : ∀ {x : T} {inc} → ⨆ (const x , inc) ≡ x
⨆-const {x} =
  antisymmetry (least-upper-bound _ _ (λ _ → ⊑-refl x))
               (upper-bound _ 0)

------------------------------------------------------------------------
-- Box and diamond

-- Box.

□ : ∀ {ℓ} → (A → Type ℓ) → T → Type (a ⊔ p ⊔ ℓ)
□ P x = ∀ y → x ⇓ y → P y

-- Diamond.

◇ : ∀ {ℓ} → (A → Type ℓ) → T → Type (a ⊔ p ⊔ ℓ)
◇ P x = ∥ (∃ λ y → x ⇓ y × P y) ∥

-- All h-levels are closed under box.

□-closure : ∀ {ℓ} {P : A → Type ℓ} {x} n →
            (∀ x → H-level n (P x)) → H-level n (□ P x)
□-closure n h =
  Π-closure ext n λ y →
  Π-closure ext n λ _ →
  h y

-- A "constructor" for ◇. For more "constructors" for □ and ◇, see
-- Partiality-monad.Inductive.Alternative-order.

◇-now :
  ∀ {ℓ} {P : A → Type ℓ} →
  ∀ {x} → P x → ◇ P (now x)
◇-now p = ∣ _ , refl , p ∣

------------------------------------------------------------------------
-- An alternative characterisation of _⊑_

-- A relation which, /for the partiality monad/, is pointwise
-- equivalent to _⊑_. See
-- Partiality-monad.Inductive.Alternative-order.≼≃⊑ for the proof.

_≼_ : T → T → Type (a ⊔ p)
x ≼ y = ∀ z → x ⇓ z → y ⇓ z

-- _≼_ is propositional.

≼-propositional : ∀ {x y} → Is-proposition (x ≼ y)
≼-propositional =
  Π-closure ext 1 λ _ →
  Π-closure ext 1 λ _ →
  T-is-set

-- _≼_ is transitive.

≼-trans : ∀ {x y z} → x ≼ y → y ≼ z → x ≼ z
≼-trans {x} {y} {z} x≼y y≼z u =
  x ⇓ u  ↝⟨ x≼y u ⟩
  y ⇓ u  ↝⟨ y≼z u ⟩□
  z ⇓ u  □

------------------------------------------------------------------------
-- Combinators that can be used to prove that two least upper bounds
-- are equal

-- For an example of how these combinators can be used, see
-- Lambda.Partiality-monad.Inductive.Compiler-correctness.

-- A relation between sequences.

infix 4 _≳[_]_

record _≳[_]_ (s₁ : ℕ → T) (n : ℕ) (s₂ : ℕ → T) : Type p where
  constructor wrap
  field
    run : ∃ λ k → s₁ (k + n) ≡ s₂ n

open _≳[_]_ public

steps-≳ : ∀ {s₁ n s₂} → s₁ ≳[ n ] s₂ → ℕ
steps-≳ = proj₁ ∘ run

-- If two increasing sequences are related in a certain way, then
-- their least upper bounds are equal.

≳→⨆≡⨆ : ∀ {s₁ s₂} k →
        (∀ {n} → proj₁ s₁ ≳[ n ] proj₁ s₂ ∘ (k +_)) →
        ⨆ s₁ ≡ ⨆ s₂
≳→⨆≡⨆ {s₁} {s₂} k s₁≳s₂ = antisymmetry
  (⊑→⨆⊑⨆ λ n →
     let m , s₁[m+n]≡s₂[k+n] = run s₁≳s₂ in

     s₁ [ n ]      ⊑⟨ later-larger s₁ (m≤n+m _ m) ⟩
     s₁ [ m + n ]  ≡⟨ s₁[m+n]≡s₂[k+n] ⟩⊑
     s₂ [ k + n ]  ■)
  (⊑→⨆⊑⨆ λ n →
     let m , s₁[m+n]≡s₂[k+n] = run s₁≳s₂ in

     s₂ [ n ]      ⊑⟨ later-larger s₂ (m≤n+m _ k) ⟩
     s₂ [ k + n ]  ≡⟨ sym s₁[m+n]≡s₂[k+n] ⟩⊑
     s₁ [ m + n ]  ■)

-- Preorder-like reasoning combinators.

infix  -1 _∎≳
infixr -2 _≳⟨⟩_ trans-≳ trans-≡≳ trans-∀≡≳

_∎≳ : ∀ s {n} → s ≳[ n ] s
run (_ ∎≳) = 0 , refl

_≳⟨⟩_ : ∀ {n} s₁ {s₂} → s₁ ≳[ n ] s₂ → s₁ ≳[ n ] s₂
_ ≳⟨⟩ s₁≳s₂ = s₁≳s₂

trans-≳ : ∀ {n} s₁ {s₂ s₃}
          (s₂≳s₃ : s₂ ≳[ n ] s₃) →
          s₁ ≳[ steps-≳ s₂≳s₃ + n ] s₂ →
          s₁ ≳[ n ] s₃
run (trans-≳ {n} s₁ {s₂} {s₃} s₂≳s₃ s₁≳s₂) =
  let k₁ , eq₁ = run s₂≳s₃
      k₂ , eq₂ = run s₁≳s₂
  in
    k₂ + k₁
  , (s₁ ((k₂ + k₁) + n)  ≡⟨ cong s₁ (sym $ +-assoc k₂) ⟩
     s₁ (k₂ + (k₁ + n))  ≡⟨ eq₂ ⟩
     s₂       (k₁ + n)   ≡⟨ eq₁ ⟩∎
     s₃             n    ∎)

trans-≡≳ : ∀ {n} s₁ {s₂ s₃}
           (s₂≳s₃ : s₂ ≳[ n ] s₃) →
           s₁ (steps-≳ s₂≳s₃ + n) ≡ s₂ (steps-≳ s₂≳s₃ + n) →
           s₁ ≳[ n ] s₃
trans-≡≳ _ s₂≳s₃ s₁≡s₂ = _ ≳⟨ wrap (0 , s₁≡s₂) ⟩ s₂≳s₃

trans-∀≡≳ : ∀ {n} s₁ {s₂ s₃} →
            s₂ ≳[ n ] s₃ →
            (∀ n → s₁ n ≡ s₂ n) →
            s₁ ≳[ n ] s₃
trans-∀≡≳ _ s₂≳s₃ s₁≡s₂ = trans-≡≳ _ s₂≳s₃ (s₁≡s₂ _)

syntax trans-≳   s₁ s₂≳s₃ s₁≳s₂ = s₁ ≳⟨  s₁≳s₂ ⟩  s₂≳s₃
syntax trans-≡≳  s₁ s₂≳s₃ s₁≡s₂ = s₁ ≡⟨  s₁≡s₂ ⟩≳ s₂≳s₃
syntax trans-∀≡≳ s₁ s₂≳s₃ s₁≡s₂ = s₁ ∀≡⟨ s₁≡s₂ ⟩≳ s₂≳s₃

-- Some "stepping" combinators.

later : ∀ {n s₁ s₂} →
        s₁ ∘ suc ≳[ n ] s₂ ∘ suc → s₁ ≳[ suc n ] s₂
run (later {n} {s₁} {s₂} s₁≳s₂) =
  let k , eq = run s₁≳s₂
  in
    k
  , (s₁ (k + suc n)  ≡⟨ cong s₁ (sym $ suc+≡+suc k) ⟩
     s₁ (suc k + n)  ≡⟨ eq ⟩∎
     s₂ (suc n)      ∎)

earlier : ∀ {n s₁ s₂} →
          s₁ ≳[ suc n ] s₂ → s₁ ∘ suc ≳[ n ] s₂ ∘ suc
run (earlier {n} {s₁} {s₂} s₁≳s₂) =
  let k , eq = run s₁≳s₂
  in
    k
  , (s₁ (suc k + n)  ≡⟨ cong s₁ (suc+≡+suc k) ⟩
     s₁ (k + suc n)  ≡⟨ eq ⟩∎
     s₂ (suc n)      ∎)

laterˡ : ∀ {n s₁ s₂} → s₁ ∘ suc ≳[ n ] s₂ → s₁ ≳[ n ] s₂
run (laterˡ s₁≳s₂) = Σ-map suc id (run s₁≳s₂)

step⇓ : ∀ {n s} → s ≳[ n ] s ∘ suc
step⇓ = laterˡ (_ ∎≳)